├── .github └── workflows │ └── CI.yml ├── .gitignore ├── LICENSE ├── README.md ├── codecov.yml ├── ford.md ├── fpm.toml ├── media └── logo.png ├── numdiff.code-workspace ├── src ├── cache_module.f90 ├── diff_module.f90 ├── dsm_module.f90 ├── kinds_module.F90 ├── numerical_differentiation_module.f90 └── utilities_module.f90 └── tests ├── dsm_test.f90 ├── test1.f90 └── test2.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.11] 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@v7 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 add-apt-repository ppa:ubuntu-toolchain-r/test 50 | sudo apt-get update 51 | sudo apt-get install -y gcc-${{ matrix.gcc_v }} gfortran-${{ matrix.gcc_v }} 52 | sudo update-alternatives \ 53 | --install /usr/bin/gcc gcc /usr/bin/gcc-${{ matrix.gcc_v }} 100 \ 54 | --slave /usr/bin/gfortran gfortran /usr/bin/gfortran-${{ matrix.gcc_v }} \ 55 | --slave /usr/bin/gcov gcov /usr/bin/gcov-${{ matrix.gcc_v }} 56 | 57 | # - name: Compile 58 | # run: fpm build --profile release 59 | 60 | - name: Run tests 61 | run: fpm test --profile debug --flag -coverage 62 | 63 | - name: Create coverage report 64 | run: | 65 | mkdir -p ${{ env.COV_DIR }} 66 | mv ./build/gfortran_*/*/* ${{ env.COV_DIR }} 67 | lcov --capture --initial --base-directory . --directory ${{ env.COV_DIR }} --output-file ${{ env.COV_DIR }}/coverage.base 68 | lcov --capture --base-directory . --directory ${{ env.COV_DIR }} --output-file ${{ env.COV_DIR }}/coverage.capture 69 | lcov --add-tracefile ${{ env.COV_DIR }}/coverage.base --add-tracefile ${{ env.COV_DIR }}/coverage.capture --output-file ${{ env.COV_DIR }}/coverage.info 70 | env: 71 | COV_DIR: build/coverage 72 | 73 | - name: Upload coverage report 74 | uses: codecov/codecov-action@v3 75 | with: 76 | files: build/coverage/coverage.info 77 | 78 | - name: Build documentation 79 | run: ford ./ford.md 80 | 81 | - name: Deploy Documentation 82 | if: github.ref == 'refs/heads/master' 83 | uses: JamesIves/github-pages-deploy-action@v4.7.3 84 | with: 85 | branch: gh-pages # The branch the action should deploy to. 86 | folder: doc # The folder the action should deploy. 87 | single-commit: true 88 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Other 2 | doc 3 | bin 4 | 5 | # Compiled Object files 6 | *.slo 7 | *.lo 8 | *.o 9 | *.obj 10 | 11 | # Precompiled Headers 12 | *.gch 13 | *.pch 14 | 15 | # Compiled Dynamic libraries 16 | *.so 17 | *.dylib 18 | *.dll 19 | 20 | # Fortran module files 21 | *.mod 22 | *.smod 23 | 24 | # Compiled Static libraries 25 | *.lai 26 | *.la 27 | *.a 28 | *.lib 29 | 30 | # Executables 31 | *.exe 32 | *.out 33 | *.app 34 | 35 | *.sln 36 | *.suo 37 | *.vfproj 38 | *u2d 39 | Release 40 | Debug 41 | x64 42 | 43 | # mac 44 | .DS_Store 45 | 46 | # test artifacts: 47 | /*.pdf 48 | /*.py -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | NumDiff -- Numerical Differentiation Library 2 | https://github.com/jacobwilliams/NumDiff 3 | 4 | Copyright (c) 2016-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 | 33 | Minpack Copyright Notice (1999) University of Chicago. All rights reserved 34 | 35 | Redistribution and use in source and binary forms, with or 36 | without modification, are permitted provided that the 37 | following conditions are met: 38 | 39 | 1. Redistributions of source code must retain the above 40 | copyright notice, this list of conditions and the following 41 | disclaimer. 42 | 43 | 2. Redistributions in binary form must reproduce the above 44 | copyright notice, this list of conditions and the following 45 | disclaimer in the documentation and/or other materials 46 | provided with the distribution. 47 | 48 | 3. The end-user documentation included with the 49 | redistribution, if any, must include the following 50 | acknowledgment: 51 | 52 | "This product includes software developed by the 53 | University of Chicago, as Operator of Argonne National 54 | Laboratory. 55 | 56 | Alternately, this acknowledgment may appear in the software 57 | itself, if and wherever such third-party acknowledgments 58 | normally appear. 59 | 60 | 4. WARRANTY DISCLAIMER. THE SOFTWARE IS SUPPLIED "AS IS" 61 | WITHOUT WARRANTY OF ANY KIND. THE COPYRIGHT HOLDER, THE 62 | UNITED STATES, THE UNITED STATES DEPARTMENT OF ENERGY, AND 63 | THEIR EMPLOYEES: (1) DISCLAIM ANY WARRANTIES, EXPRESS OR 64 | IMPLIED, INCLUDING BUT NOT LIMITED TO ANY IMPLIED WARRANTIES 65 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, TITLE 66 | OR NON-INFRINGEMENT, (2) DO NOT ASSUME ANY LEGAL LIABILITY 67 | OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS, OR 68 | USEFULNESS OF THE SOFTWARE, (3) DO NOT REPRESENT THAT USE OF 69 | THE SOFTWARE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS, (4) 70 | DO NOT WARRANT THAT THE SOFTWARE WILL FUNCTION 71 | UNINTERRUPTED, THAT IT IS ERROR-FREE OR THAT ANY ERRORS WILL 72 | BE CORRECTED. 73 | 74 | 5. LIMITATION OF LIABILITY. IN NO EVENT WILL THE COPYRIGHT 75 | HOLDER, THE UNITED STATES, THE UNITED STATES DEPARTMENT OF 76 | ENERGY, OR THEIR EMPLOYEES: BE LIABLE FOR ANY INDIRECT, 77 | INCIDENTAL, CONSEQUENTIAL, SPECIAL OR PUNITIVE DAMAGES OF 78 | ANY KIND OR NATURE, INCLUDING BUT NOT LIMITED TO LOSS OF 79 | PROFITS OR LOSS OF DATA, FOR ANY REASON WHATSOEVER, WHETHER 80 | SUCH LIABILITY IS ASSERTED ON THE BASIS OF CONTRACT, TORT 81 | (INCLUDING NEGLIGENCE OR STRICT LIABILITY), OR OTHERWISE, 82 | EVEN IF ANY OF SAID PARTIES HAS BEEN WARNED OF THE 83 | POSSIBILITY OF SUCH LOSS OR DAMAGES. 84 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![NumDiff](media/logo.png) 2 | ============ 3 | 4 | ## Brief description 5 | 6 | **NumDiff** provides a modern Fortran interface for computing the Jacobian (derivative) matrix of `m` nonlinear functions which depend on `n` variables. The Jacobian matrix is required for various applications, including numerical optimization. It can also be used to test the accuracy of gradients computed by other means. The library also provides for computing the sparsity of this matrix, and returning the Jacobian in sparse or dense form. 7 | 8 | ## Status 9 | 10 | [![GitHub release](https://img.shields.io/github/release/jacobwilliams/NumDiff.svg)](https://github.com/jacobwilliams/NumDiff/releases/latest) 11 | [![Build Status](https://github.com/jacobwilliams/NumDiff/actions/workflows/CI.yml/badge.svg)](https://github.com/jacobwilliams/NumDiff/actions) 12 | [![codecov](https://codecov.io/gh/jacobwilliams/NumDiff/branch/master/graph/badge.svg)](https://codecov.io/gh/jacobwilliams/NumDiff) 13 | [![last-commit](https://img.shields.io/github/last-commit/jacobwilliams/NumDiff)](https://github.com/jacobwilliams/NumDiff/commits/master) 14 | 15 | This is currently a work in progress. The goal is a comprehensive library that contains a full suite of computationally efficient implementations of algorithms for sparsity determination and numerical differentiation. This code is hosted on GitHub at: https://github.com/jacobwilliams/NumDiff 16 | 17 | ### To Do 18 | 19 | - [x] Computing the nonlinear sparsity pattern 20 | - [x] Specified by the user 21 | - [x] Assume all elements `true` 22 | - [x] Three random points within variable bounds (have the option to specify separate bounds for this purpose) 23 | - [x] Various order finite different gradient methods 24 | - [x] 2-point (backward 1, forward 1) 25 | - [x] 3-point (backward 2, central, forward 2) 26 | - [x] 4-point (backward 3, backward 2, forward 2, forward 3) 27 | - [x] 5-point (backward 4, backward 3, central, forward 3, forward 4) 28 | - [x] 6-point (backward 5, backward 4, backward 3, forward 3, forward 4, forward 5) 29 | - [x] 7-point (backward 6, backward 5, backward 4, central, forward 4, forward 5, forward 6) 30 | - [x] 8-point (backward 7, backward 6, backward 5, backward 4, forward 4, forward 5, forward 6, forward 7) 31 | - [x] 9-point (backward 8, backward 7, backward 6, backward 5, central, forward 5, forward 6, forward 7, forward 8) 32 | - [x] 11-point (central) 33 | - [x] 13-point (central) 34 | - [x] 15-point (central) 35 | - [x] 17-point (central) 36 | - [x] Perturbations should respect variable bounds 37 | - [x] Neville's process 38 | - [x] Ability to use different methods for different columns 39 | - [x] Jacobian partitioning to compute multiple columns at the same time 40 | - [ ] Estimate the optimal perturbation step size 41 | - [ ] Computing the linear sparsity pattern (constant elements of Jacobian) 42 | - [ ] Add other gradient methods? 43 | - [ ] Also compute Hessian matrix? 44 | - [ ] OpenMP or Coarrays for parallelization 45 | - [ ] Testing for computational efficiency 46 | - [ ] General code cleanup 47 | 48 | ## Building NumDiff 49 | 50 | ### FPM 51 | 52 | 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: 53 | 54 | ``` 55 | fpm build --profile release 56 | fpm test --profile release 57 | ``` 58 | 59 | To use `NumDiff` within your FPM project, add the following to your `fpm.toml` file: 60 | ```toml 61 | [dependencies] 62 | NumDiff = { git="https://github.com/jacobwilliams/NumDiff.git" } 63 | ``` 64 | 65 | or, to use a specific version: 66 | 67 | ```toml 68 | [dependencies] 69 | NumDiff = { git="https://github.com/jacobwilliams/NumDiff.git", tag = "1.7.0" } 70 | ``` 71 | 72 | To generate the documentation using [FORD](https://github.com/Fortran-FOSS-Programmers/ford), run: 73 | 74 | ``` 75 | ford ford.md 76 | ``` 77 | 78 | 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: 79 | 80 | Preprocessor flag | Kind | Number of bytes 81 | ----------------- | ----- | --------------- 82 | `REAL32` | `real(kind=real32)` | 4 83 | `REAL64` | `real(kind=real64)` | 8 84 | `REAL128` | `real(kind=real128)` | 16 85 | 86 | For example, to build a single precision version of the library, use: 87 | 88 | ``` 89 | fpm build --profile release --flag "-DREAL32" 90 | ``` 91 | 92 | Note that the [pyplot-fortran](https://github.com/jacobwilliams/pyplot-fortran) library is a dependency for one of the test cases. FPM will automatically download the right version. 93 | 94 | ## Documentation 95 | 96 | The latest API documentation can be found [here](https://jacobwilliams.github.io/NumDiff/). This was generated from the source code using [FORD](https://github.com/Fortran-FOSS-Programmers/ford) (note that the included `build.sh` script will also generate these files). 97 | 98 | ## License 99 | 100 | The NumDiff source code and related files and documentation are distributed under a permissive free software [license](https://github.com/jacobwilliams/NumDiff/blob/master/LICENSE) (BSD-style). 101 | 102 | ## References 103 | 104 | * J. Oliver, "An algorithm for numerical differentiation of a function of one real variable", Journal of Computational and Applied Mathematics 6 (2) (1980) 145-160. Fortran 77 code from [NIST](ftp://math.nist.gov/pub/repository/diff/src/DIFF) 105 | * Thomas F. Coleman, Burton S. Garbow, Jorge J. More, "Algorithm 618: FORTRAN subroutines for estimating sparse Jacobian Matrices", ACM Transactions on Mathematical Software (TOMS), Volume 10 Issue 3, Sept. 1984, Pages 346-347 106 | * G. E. Mullges, F. Uhlig, "Numerical Algorithms with Fortran", Springer, 1996. -------------------------------------------------------------------------------- /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: 60% 14 | -------------------------------------------------------------------------------- /ford.md: -------------------------------------------------------------------------------- 1 | project: NumDiff 2 | project_dir: ./src 3 | output_dir: ./doc 4 | media_dir: ./media 5 | project_github: https://github.com/jacobwilliams/NumDiff 6 | summary: NumDiff -- Numerical Differentiation Library 7 | author: Jacob Williams 8 | github: https://github.com/jacobwilliams 9 | predocmark_alt: > 10 | predocmark: < 11 | docmark_alt: 12 | docmark: ! 13 | display: public 14 | protected 15 | private 16 | source: true 17 | graph: true 18 | exclude_dir: ./src/tests 19 | 20 | {!README.md!} 21 | -------------------------------------------------------------------------------- /fpm.toml: -------------------------------------------------------------------------------- 1 | name = "NumDiff" 2 | version = "1.5.1" 3 | author = "Jacob Williams" 4 | maintainer = "Jacob Williams" 5 | copyright = "Copyright (c) 2016-2022, Jacob Williams" 6 | license = "BSD-3" 7 | description = "Modern Fortran Numerical Differentiation Library" 8 | homepage = "https://github.com/jacobwilliams/NumDiff" 9 | 10 | [library] 11 | source-dir = "src" 12 | 13 | [install] 14 | library = true 15 | 16 | [build] 17 | auto-executables = false 18 | auto-examples = false 19 | auto-tests = false 20 | 21 | [dev-dependencies] 22 | pyplot-fortran = { git="https://github.com/jacobwilliams/pyplot-fortran.git", tag = "3.2.1" } 23 | 24 | [[test]] 25 | name = "dsm_test" 26 | source-dir = "tests" 27 | main = "dsm_test.f90" 28 | 29 | [[test]] 30 | name = "test1" 31 | source-dir = "tests" 32 | main = "test1.f90" 33 | 34 | [[test]] 35 | name = "test2" 36 | source-dir = "tests" 37 | main = "test2.f90" 38 | -------------------------------------------------------------------------------- /media/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jacobwilliams/NumDiff/9c661fdb49e30e28a94834ccc01421b2681f8f49/media/logo.png -------------------------------------------------------------------------------- /numdiff.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 | } -------------------------------------------------------------------------------- /src/cache_module.f90: -------------------------------------------------------------------------------- 1 | !******************************************************************************* 2 | !> author: Jacob Williams 3 | ! 4 | ! For caching function evaluations. 5 | 6 | module numdiff_cache_module 7 | 8 | use iso_fortran_env, only: ip => int64 ! same number of bits as real(wp) 9 | use numdiff_kinds_module 10 | use numdiff_utilities_module, only: unique 11 | 12 | implicit none 13 | 14 | private 15 | 16 | type :: fx 17 | !! an [x,f(x)] cached pair. 18 | private 19 | real(wp),dimension(:),allocatable :: x !! vector of input values 20 | real(wp),dimension(:),allocatable :: f !! vector of output functions `f(x)` 21 | !! note: only the elements indicated by `ifs` 22 | !! will have valid values. The others will 23 | !! be dummy values. 24 | integer,dimension(:),allocatable :: ifs !! elements of `f` present in the cache 25 | !! (this is just an array of the indices 26 | !! present in `f`) 27 | end type fx 28 | 29 | type,public :: function_cache 30 | !! a vector function cache. 31 | private 32 | integer :: n = 0 !! size of `x` 33 | integer :: m = 0 !! size of `f` 34 | type(fx),dimension(:),allocatable :: c !! the cache of `f(x)` 35 | integer :: chunk_size = 100 !! for resizing vectors 36 | !! in the [[unique]] function 37 | contains 38 | private 39 | procedure,public :: initialize => initialize_cache 40 | procedure,public :: get => get_from_cache 41 | procedure,public :: put => put_in_cache 42 | procedure,public :: destroy => destroy_cache 43 | procedure,public :: print => print_cache 44 | end type function_cache 45 | 46 | contains 47 | !******************************************************************************* 48 | 49 | !******************************************************************************* 50 | !> 51 | ! Initialize the cache. Must be called first before use. 52 | 53 | subroutine initialize_cache(me,isize,n,m,chunk_size) 54 | 55 | implicit none 56 | 57 | class(function_cache),intent(inout) :: me 58 | integer,intent(in) :: isize !! the size of the hash table 59 | integer,intent(in) :: n !! number of independant variables (x) 60 | integer,intent(in) :: m !! number of functions (f) 61 | integer,intent(in),optional :: chunk_size !! chunk size to speed up reallocation 62 | !! of arrays. A good value is a guess for 63 | !! the actual number of elements of `f` that 64 | !! will be saved per value of `x` [default is 100] 65 | 66 | call me%destroy() 67 | 68 | allocate(me%c(0:isize-1)) 69 | me%n = n 70 | me%m = m 71 | 72 | if (present(chunk_size)) then 73 | me%chunk_size = chunk_size 74 | else 75 | me%chunk_size = 100 76 | end if 77 | 78 | end subroutine initialize_cache 79 | !******************************************************************************* 80 | 81 | !******************************************************************************* 82 | !> 83 | ! Print the contents of the cache. Used for debugging. 84 | 85 | subroutine print_cache(me,iunit) 86 | 87 | implicit none 88 | 89 | class(function_cache),intent(inout) :: me 90 | integer,intent(in) :: iunit !! file unit for writing 91 | !! (assumed to be opened) 92 | 93 | integer :: i !! counter 94 | 95 | write(iunit,'(A)') '' 96 | write(iunit,'(A)') '------------------------' 97 | if (allocated(me%c)) then 98 | do i = 1, size(me%c) 99 | if (allocated(me%c(i)%x)) then 100 | write(iunit,'(A)') '' 101 | write(iunit,'(A,1X,I10)') 'Entry ',i 102 | write(iunit,'(A,1X,*(F27.16,1X))') 'x :', me%c(i)%x 103 | if (allocated(me%c(i)%f)) then 104 | write(iunit,'(A,1X,*(I27,1X))') 'ifs:', me%c(i)%ifs 105 | write(iunit,'(A,1X,*(F27.16,1X))') 'f :', me%c(i)%f(me%c(i)%ifs) 106 | end if 107 | write(iunit,'(A)') '------------------------' 108 | end if 109 | end do 110 | else 111 | write(iunit,'(A)') 'Cache is not initialized' 112 | write(iunit,'(A)') '------------------------' 113 | end if 114 | write(iunit,'(A)') '' 115 | 116 | end subroutine print_cache 117 | !******************************************************************************* 118 | 119 | !******************************************************************************* 120 | !> 121 | ! Check if the `x` vector is in the cache, if so return `f`. 122 | ! Note that only some of the elements may be present, so it will return 123 | ! the ones there are there, and indicate which ones were found. 124 | 125 | subroutine get_from_cache(me,x,ifs,i,f,xfound,ffound) 126 | 127 | implicit none 128 | 129 | class(function_cache),intent(inout) :: me 130 | real(wp),dimension(:),intent(in) :: x !! independant variable vector 131 | integer,dimension(:),intent(in) :: ifs !! elements of `f` needed 132 | integer,intent(out) :: i !! index in the hash table 133 | real(wp),dimension(:),intent(out) :: f !! `f(x)` from the cache (if it was found) 134 | logical,intent(out) :: xfound !! if `x` was found in the cache 135 | logical,dimension(size(ifs)),intent(out) :: ffound !! which `ifs` were found in the cache 136 | 137 | integer :: j !! counter 138 | 139 | ! initialize: 140 | xfound = .false. 141 | ffound = .false. 142 | 143 | if (allocated(me%c)) then 144 | 145 | ! get index in the hash table: 146 | i = mod( abs(vector_djb_hash(x)), int(size(me%c),ip) ) 147 | 148 | ! check the table: 149 | if (allocated(me%c(i)%x) .and. allocated(me%c(i)%f)) then 150 | if (size(me%c(i)%x)==size(x) .and. & 151 | size(me%c(i)%f)==size(f)) then 152 | if (all(me%c(i)%x==x)) then 153 | xfound = .true. 154 | ! return the elements that were found in the cache: 155 | f(me%c(i)%ifs) = me%c(i)%f(me%c(i)%ifs) 156 | ! what indices are in the cache? 157 | do j = 1, size(ifs) 158 | ffound(j) = any(ifs(j)==me%c(i)%ifs) 159 | end do 160 | end if 161 | end if 162 | end if 163 | 164 | else 165 | error stop 'Error: the cache has not been initialized.' 166 | end if 167 | 168 | end subroutine get_from_cache 169 | !******************************************************************************* 170 | 171 | !******************************************************************************* 172 | !> 173 | ! Put a value into the cache. 174 | 175 | subroutine put_in_cache(me,i,x,f,ifs) 176 | 177 | implicit none 178 | 179 | class(function_cache),intent(inout) :: me 180 | integer,intent(in) :: i !! index in the hash table 181 | real(wp),dimension(:),intent(in) :: x !! independant variable vector (dimension `n`) 182 | real(wp),dimension(:),intent(in) :: f !! function vector `f(x)` (dimension `m`) 183 | integer,dimension(:),intent(in) :: ifs !! elements of `f` to add (should all be `>0, <=m`) 184 | 185 | real(wp),parameter :: null = huge(1.0_wp) !! an unusual value to initialize arrays 186 | 187 | if (allocated(me%c)) then 188 | if (i<=size(me%c)) then 189 | 190 | if (allocated(me%c(i)%x)) then 191 | ! we need to check if there is an x already there, 192 | ! which may already have some function indices present. 193 | ! if same x, then add the new indices to them. 194 | ! if a different x, then replace indices. 195 | if (all(me%c(i)%x==x)) then 196 | ! this x is already present in this location. 197 | ! so merge the new f,ifs into what is already there. 198 | if (allocated(me%c(i)%f)) then 199 | me%c(i)%ifs = unique([me%c(i)%ifs,ifs],& 200 | chunk_size=me%chunk_size) 201 | else 202 | allocate(me%c(i)%f(me%m)) 203 | me%c(i)%f = null ! initialize to an unusual value 204 | me%c(i)%ifs = ifs 205 | end if 206 | me%c(i)%f(ifs) = f(ifs) 207 | else 208 | ! replace existing x and f. 209 | me%c(i)%x = x 210 | me%c(i)%ifs = ifs 211 | if (allocated(me%c(i)%f)) deallocate(me%c(i)%f) 212 | allocate(me%c(i)%f(me%m)) 213 | me%c(i)%f = null ! initialize to an unusual value 214 | me%c(i)%f(ifs) = f(ifs) 215 | end if 216 | else 217 | ! new entry in the cache: 218 | me%c(i)%x = x 219 | allocate(me%c(i)%f(me%m)) 220 | me%c(i)%f = null ! initialize to an unusual value 221 | me%c(i)%ifs = ifs 222 | me%c(i)%f(ifs) = f(ifs) 223 | end if 224 | 225 | else 226 | error stop 'Error: invalid index in hash table.' 227 | end if 228 | else 229 | error stop 'Error: the cache has not been initialized.' 230 | end if 231 | 232 | end subroutine put_in_cache 233 | !******************************************************************************* 234 | 235 | !******************************************************************************* 236 | !> 237 | ! Destroy a cache. 238 | 239 | subroutine destroy_cache(me) 240 | 241 | implicit none 242 | 243 | class(function_cache),intent(out) :: me 244 | 245 | end subroutine destroy_cache 246 | !******************************************************************************* 247 | 248 | !******************************************************************************* 249 | !> 250 | ! DJB hash algorithm for a `real(wp)` vector. 251 | ! 252 | !### See also 253 | ! * J. Shahbazian, Fortran hashing algorithm, July 6, 2013 254 | ! [Fortran Dev](https://fortrandev.wordpress.com/2013/07/06/fortran-hashing-algorithm/) 255 | 256 | pure function vector_djb_hash(r) result(hash) 257 | 258 | real(wp),dimension(:),intent(in) :: r !! the vector 259 | integer(ip) :: hash !! the hash value 260 | 261 | integer :: i !! counter 262 | 263 | hash = 5381_ip 264 | 265 | do i=1,size(r) 266 | hash = ishft(hash,5_ip) + hash + transfer(r(i),1_ip) 267 | end do 268 | 269 | end function vector_djb_hash 270 | !******************************************************************************* 271 | 272 | !******************************************************************************* 273 | end module numdiff_cache_module 274 | !******************************************************************************* 275 | -------------------------------------------------------------------------------- /src/diff_module.f90: -------------------------------------------------------------------------------- 1 | !***************************************************************************************** 2 | !> author: Jacob Williams 3 | ! license: BSD 4 | ! 5 | ! Numerical differentiation of a 1D function `f(x)` using Neville's process. 6 | ! 7 | !## Authors 8 | ! * J. Oliver, "An algorithm for numerical differentiation of a function 9 | ! of one real variable", Journal of Computational and Applied Mathematics 10 | ! 6 (2) (1980) 145–160. [Algol 60 source in original paper] 11 | ! * David Kahaner, Fortran 77 code from 12 | ! [NIST](ftp://math.nist.gov/pub/repository/diff/src/DIFF) 13 | ! * Jacob Williams : 2/17/2013 : Converted to modern Fortran. 14 | ! Some refactoring, addition of test cases. 15 | 16 | module diff_module 17 | 18 | use numdiff_kinds_module 19 | 20 | implicit none 21 | 22 | private 23 | 24 | type,public :: diff_func 25 | !! class to define the function for [[diff]] 26 | private 27 | logical :: stop = .false. 28 | procedure(func),pointer :: f => null() 29 | contains 30 | private 31 | procedure :: faccur 32 | procedure,public :: set_function 33 | procedure,public :: compute_derivative => diff 34 | procedure,public :: terminate 35 | end type diff_func 36 | 37 | abstract interface 38 | function func(me,x) result(fx) 39 | !! interface to function for [[diff]] 40 | import :: diff_func,wp 41 | implicit none 42 | class(diff_func),intent(inout) :: me 43 | real(wp),intent(in) :: x 44 | real(wp) :: fx 45 | end function func 46 | end interface 47 | 48 | contains 49 | !***************************************************************************************** 50 | 51 | !***************************************************************************************** 52 | !> author: Jacob Williams 53 | ! date: 12/27/2015 54 | ! 55 | ! Set the function in a [[diff_func]]. 56 | ! Must be called before [[diff]]. 57 | 58 | subroutine set_function(me,f) 59 | 60 | implicit none 61 | 62 | class(diff_func),intent(inout) :: me 63 | procedure(func) :: f 64 | 65 | me%f => f 66 | 67 | end subroutine set_function 68 | !***************************************************************************************** 69 | 70 | !***************************************************************************************** 71 | !> 72 | ! Can be called by the user in the function to terminate the computation. 73 | ! This will set `ifail=-1`. 74 | 75 | subroutine terminate(me) 76 | 77 | implicit none 78 | 79 | class(diff_func),intent(inout) :: me 80 | 81 | me%stop = .true. 82 | 83 | end subroutine terminate 84 | !***************************************************************************************** 85 | 86 | !***************************************************************************************** 87 | !> 88 | ! the procedure `diff` calculates the first, second or 89 | ! third order derivative of a function by using neville's process to 90 | ! extrapolate from a sequence of simple polynomial approximations based on 91 | ! interpolating points distributed symmetrically about `x0` (or lying only on 92 | ! one side of `x0` should this be necessary). if the specified tolerance is 93 | ! non-zero then the procedure attempts to satisfy this absolute or relative 94 | ! accuracy requirement, while if it is unsuccessful or if the tolerance is 95 | ! set to zero then the result having the minimum achievable estimated error 96 | ! is returned instead. 97 | 98 | subroutine diff(me,iord,x0,xmin,xmax,eps,accr,deriv,error,ifail) 99 | 100 | implicit none 101 | 102 | class(diff_func),intent(inout) :: me 103 | integer,intent(in) :: iord !! 1, 2 or 3 specifies that the first, second or third order 104 | !! derivative,respectively, is required. 105 | real(wp), intent(in) :: x0 !! the point at which the derivative of the function is to be calculated. 106 | real(wp), intent(in) :: xmin !! `xmin`, `xmax` restrict the interpolating points to lie in [`xmin`, `xmax`], which 107 | !! should be the largest interval including `x0` in which the function is 108 | !! calculable and continuous. 109 | real(wp), intent(in) :: xmax !! `xmin`, `xmax` restrict the interpolating points to lie in [`xmin`, `xmax`], which 110 | !! should be the largest interval including `x0` in which the function is 111 | !! calculable and continuous. 112 | real(wp), intent(in) :: eps !! denotes the tolerance, either absolute or relative. `eps=0` specifies that 113 | !! the error is to be minimised, while `eps>0` or `eps<0` specifies that the 114 | !! absolute or relative error, respectively, must not exceed `abs(eps)` if 115 | !! possible. the accuracy requirement should not be made stricter than 116 | !! necessary, since the amount of computation tends to increase as 117 | !! the magnitude of `eps` decreases, and is particularly high when `eps=0`. 118 | real(wp), intent(in) :: accr !! denotes that the absolute (`accr>0`) or relative (`accr<0`) errors in the 119 | !! computed values of the function are most unlikely to exceed `abs(accr)`, which 120 | !! should be as small as possible. if the user cannot estimate `accr` with 121 | !! complete confidence, then it should be set to zero. 122 | real(wp), intent(out) :: deriv !! the calculated value of the derivative 123 | real(wp), intent(out) :: error !! an estimated upper bound on the magnitude of the absolute error in 124 | !! the calculated result. it should always be examined, since in extreme case 125 | !! may indicate that there are no correct significant digits in the value 126 | !! returned for derivative. 127 | integer, intent(out) :: ifail !! will have one of the following values on exit: 128 | !! *0* the procedure was successful. 129 | !! *1* the estimated error in the result exceeds the (non-zero) requested 130 | !! error, but the most accurate result possible has been returned. 131 | !! *2* input data incorrect (derivative and error will be undefined). 132 | !! *3* the interval [`xmin`, `xmax`] is too small (derivative and error will be 133 | !! undefined). 134 | !! *-1* stopped by the user. 135 | 136 | real(wp) :: acc,beta,beta4,h,h0,h1,h2, & 137 | newh1,newh2,heval,hprev,baseh,hacc1,hacc2,nhacc1, & 138 | nhacc2,minh,maxh,maxh1,maxh2,tderiv,f0,twof0,f1,f2,f3,f4,fmax, & 139 | maxfun,pmaxf,df1,deltaf,pdelta,z,zpower,c0f0,c1,c2,c3,dnew,dprev, & 140 | re,te,newerr,temerr,newacc,pacc1,pacc2,facc1,facc2,acc0, & 141 | acc1,acc2,relacc,twoinf,twosup,s, & 142 | d(10),denom(10),e(10),minerr(10),maxf(0:10),save(0:13),storef(-45:45),factor 143 | integer :: i,j,k,n,nmax,method,signh,fcount,init 144 | logical :: ignore(10),contin,saved 145 | real(wp) :: dummy1,dummy2 146 | 147 | integer,parameter :: eta = digits(1.0_wp) - 1 !! minimum number of significant binary digits (apart from the 148 | !! sign digit) used to represent the mantissa of real(wp) numbers. it should 149 | !! be decreased by one if the computer truncates rather than rounds. 150 | integer,parameter :: inf = -minexponent(1.0_wp) - 2 !! the largest possible positive integers subject to 151 | !! 2**(-inf) and -2**(-inf) being representable real(wp) numbers. 152 | integer,parameter :: sup = maxexponent(1.0_wp) - 1 !! the largest possible positive integers subject to 153 | !! 2**sup and -2**sup being representable real(wp) numbers. 154 | 155 | real(wp),parameter :: sqrt2 = sqrt(2.0_wp) !! \( \sqrt(2) \) 156 | real(wp),parameter :: sqrt3 = sqrt(3.0_wp) !! \( \sqrt(3) \) 157 | 158 | me%stop = .false. 159 | 160 | ! execution commences with examination of input parameters 161 | if (iord<1 .or. iord>3 .or. xmax<=xmin .or. & 162 | x0>xmax .or. x0 128.0_wp*twoinf*2.0_wp**eta) s = abs(x0)*2.0_wp**(-eta) 187 | if (maxh1 < s) then 188 | ! interval too small 189 | ifail =3 190 | return 191 | end if 192 | if (acc < 0.0_wp) then 193 | if (-acc > relacc) relacc = -acc 194 | acc = 0.0_wp 195 | end if 196 | 197 | ! determine the smallest spacing at which the calculated 198 | ! function values are unequal near x0. 199 | 200 | f0 = me%f(x0) 201 | if (me%stop) then 202 | ifail = -1 203 | return 204 | end if 205 | twof0 = f0 + f0 206 | if (abs(x0) > twoinf*2.0_wp**eta) then 207 | h = abs(x0)*2.0_wp**(-eta) 208 | z = 2.0_wp 209 | else 210 | h = twoinf 211 | z = 64.0_wp 212 | end if 213 | df1 = me%f(x0+signh*h) - f0 214 | if (me%stop) then 215 | ifail = -1 216 | return 217 | end if 218 | do 219 | if (df1 /= 0.0_wp .or. z*h > maxh1) exit 220 | h = z*h 221 | df1 = me%f(x0+signh*h) - f0 222 | if (me%stop) then 223 | ifail = -1 224 | return 225 | end if 226 | if (z /= 2.0_wp) then 227 | if (df1 /= 0.0_wp) then 228 | h = h/z 229 | z = 2.0_wp 230 | df1 = 0.0_wp 231 | else 232 | if (z*h > maxh1) z = 2.0_wp 233 | end if 234 | end if 235 | end do 236 | 237 | if (df1 == 0.0_wp) then 238 | ! constant function 239 | deriv = 0.0_wp 240 | error = 0.0_wp 241 | ifail = 0 242 | return 243 | end if 244 | if (h > maxh1/128.0_wp) then 245 | ! minimum h too large 246 | ifail = 3 247 | return 248 | end if 249 | 250 | h = 8.0_wp*h 251 | h1 = signh*h 252 | h0 = h1 253 | h2 = -h1 254 | minh = 2.0_wp**(-min(inf,sup)/iord) 255 | if (minh < h) minh = h 256 | select case (iord) 257 | case(1) 258 | s = 8.0_wp 259 | case(2) 260 | s = 9.0_wp*sqrt3 261 | case(3) 262 | s = 27.0_wp 263 | end select 264 | if (minh > maxh1/s) then 265 | ifail = 3 266 | return 267 | end if 268 | if (minh > maxh2/s .or. maxh2 < 128.0_wp*twoinf) then 269 | method = 1 270 | else 271 | method = 2 272 | end if 273 | 274 | ! method 1 uses 1-sided formulae, and method 2 symmetric. 275 | ! now estimate accuracy of calculated function values. 276 | 277 | if (method /= 2 .or. iord == 2) then 278 | if (x0 /= 0.0_wp) then 279 | dummy1 = 0.0_wp 280 | dummy2 = -h1 281 | call me%faccur(dummy1,dummy2,acc0,x0,twoinf,f0,f1,ifail) 282 | if (ifail==-1) return 283 | else 284 | acc0 = 0.0_wp 285 | end if 286 | end if 287 | 288 | if (abs(h1) > twosup/128.0_wp) then 289 | hacc1 = twosup 290 | else 291 | hacc1 = 128.0_wp*h1 292 | end if 293 | 294 | if (abs(hacc1)/4.0_wp < minh) then 295 | hacc1 = 4.0_wp*signh*minh 296 | else if (abs(hacc1) > maxh1) then 297 | hacc1 = signh*maxh1 298 | end if 299 | f1 = me%f(x0+hacc1) 300 | if (me%stop) then 301 | ifail = -1 302 | return 303 | end if 304 | call me%faccur(hacc1,h1,acc1,x0,twoinf,f0,f1,ifail) 305 | if (ifail==-1) return 306 | if (method == 2) then 307 | hacc2 = -hacc1 308 | if (abs(hacc2) > maxh2) hacc2 = -signh * maxh2 309 | f1 = me%f(x0 + hacc2) 310 | if (me%stop) then 311 | ifail = -1 312 | return 313 | end if 314 | call me%faccur(hacc2,h2,acc2,x0,twoinf,f0,f1,ifail) 315 | if (ifail==-1) return 316 | end if 317 | nmax = 8 318 | if (eta > 36) nmax = 10 319 | n = -1 320 | fcount = 0 321 | deriv = 0.0_wp 322 | error = twosup 323 | init = 3 324 | contin = .true. 325 | 326 | do 327 | 328 | n = n+1 329 | if (.not. contin) exit 330 | 331 | if (init == 3) then 332 | ! calculate coefficients for differentiation 333 | ! formulae and neville extrapolation algorithm 334 | if (iord == 1) then 335 | beta=2.0_wp 336 | else if (method == 2) then 337 | beta = sqrt2 338 | else 339 | beta = sqrt3 340 | end if 341 | beta4 = beta**4 342 | z = beta 343 | if (method == 2) z = z**2 344 | zpower = 1.0_wp 345 | do k = 1,nmax 346 | zpower = z*zpower 347 | denom(k) = zpower-1 348 | end do 349 | if (method == 2 .and. iord == 1) then 350 | e(1) = 5.0_wp 351 | e(2) = 6.3_wp 352 | do i = 3,nmax 353 | e(i) = 6.81_wp 354 | end do 355 | else if ((method /= 2 .and. iord == 1) .or. & 356 | (method == 2 .and. iord == 2)) then 357 | e(1) = 10.0_wp 358 | e(2) = 16.0_wp 359 | e(3) = 20.36_wp 360 | e(4) = 23.0_wp 361 | e(5) = 24.46_wp 362 | do i = 6,nmax 363 | e(i) = 26.0_wp 364 | end do 365 | if (method == 2 .and. iord == 2) then 366 | do i = 1,nmax 367 | e(i)=2.0_wp*e(i) 368 | end do 369 | end if 370 | else if (method /= 2 .and. iord == 2) then 371 | e(1) = 17.78_wp 372 | e(2) = 30.06_wp 373 | e(3) = 39.66_wp 374 | e(4) = 46.16_wp 375 | e(5) = 50.26_wp 376 | do i = 6,nmax 377 | e(i) = 55.0_wp 378 | end do 379 | else if (method == 2 .and. iord == 3) then 380 | e(1) = 25.97_wp 381 | e(2) = 41.22_wp 382 | e(3) = 50.95_wp 383 | e(4) = 56.4_wp 384 | e(5) = 59.3_wp 385 | do i = 6,nmax 386 | e(i) = 62.0_wp 387 | end do 388 | else 389 | e(1) = 24.5_wp 390 | e(2) = 40.4_wp 391 | e(3) = 52.78_wp 392 | e(4) = 61.2_wp 393 | e(5) = 66.55_wp 394 | do i = 6,nmax 395 | e(i) = 73.0_wp 396 | end do 397 | c0f0 = -twof0/(3.0_wp*beta) 398 | c1 = 3.0_wp/(3.0_wp*beta-1.0_wp) 399 | c2 = -1.0_wp/(3.0_wp*(beta-1.0_wp)) 400 | c3 = 1.0_wp/(3.0_wp*beta*(5.0_wp-2.0_wp*beta)) 401 | end if 402 | end if 403 | 404 | if (init >= 2) then 405 | ! initialization of steplengths, accuracy and other parameters 406 | 407 | heval = signh*minh 408 | h = heval 409 | baseh = heval 410 | maxh = maxh2 411 | if (method == 1)maxh = maxh1 412 | do k = 1,nmax 413 | minerr(k) = twosup 414 | ignore(k) = .false. 415 | end do 416 | if (method == 1) newacc = acc1 417 | if (method == -1) newacc = acc2 418 | if (method == 2) newacc = (acc1+acc2)/2.0_wp 419 | if (newacc < acc) newacc = acc 420 | if ((method /= 2 .or. iord == 2) .and. newacc < acc0) newacc = acc0 421 | if (method /= -1) then 422 | facc1 = acc1 423 | nhacc1 = hacc1 424 | newh1 = h1 425 | end if 426 | if (method /= 1) then 427 | facc2 = acc2 428 | nhacc2 = hacc2 429 | newh2 = h2 430 | else 431 | facc2 = 0.0_wp 432 | nhacc2 = 0.0_wp 433 | end if 434 | init = 1 435 | j = 0 436 | saved = .false. 437 | end if 438 | 439 | ! calculate new or initial function values 440 | 441 | if (init == 1 .and. (n == 0 .or. iord == 1) .and. & 442 | .not.(method == 2 .and. fcount >= 45)) then 443 | if (method == 2) then 444 | fcount = fcount + 1 445 | f1 = me%f(x0+heval) 446 | if (me%stop) then 447 | ifail = -1 448 | return 449 | end if 450 | storef(fcount) = f1 451 | f2 = me%f(x0-heval) 452 | if (me%stop) then 453 | ifail = -1 454 | return 455 | end if 456 | storef(-fcount) = f2 457 | else 458 | j = j+1 459 | if (j <= fcount) then 460 | f1 = storef(j*method) 461 | else 462 | f1 = me%f(x0+heval) 463 | if (me%stop) then 464 | ifail = -1 465 | return 466 | end if 467 | end if 468 | end if 469 | else 470 | f1 = me%f(x0+heval) 471 | if (me%stop) then 472 | ifail = -1 473 | return 474 | end if 475 | if (method == 2) then 476 | f2 = me%f(x0-heval) 477 | if (me%stop) then 478 | ifail = -1 479 | return 480 | end if 481 | end if 482 | end if 483 | if (n == 0) then 484 | if (method == 2 .and. iord == 3) then 485 | pdelta = f1-f2 486 | pmaxf = (abs(f1)+abs(f2))/2.0_wp 487 | heval = beta*heval 488 | f1 = me%f(x0+heval) 489 | if (me%stop) then 490 | ifail = -1 491 | return 492 | end if 493 | f2 = me%f(x0-heval) 494 | if (me%stop) then 495 | ifail = -1 496 | return 497 | end if 498 | deltaf = f1-f2 499 | maxfun = (abs(f1)+abs(f2))/2.0_wp 500 | heval = beta*heval 501 | f1 = me%f(x0+heval) 502 | if (me%stop) then 503 | ifail = -1 504 | return 505 | end if 506 | f2 = me%f(x0-heval) 507 | if (me%stop) then 508 | ifail = -1 509 | return 510 | end if 511 | else if (method /= 2 .and. iord >= 2) then 512 | if (iord == 2) then 513 | f3 = f1 514 | else 515 | f4 = f1 516 | heval = beta*heval 517 | f3 = me%f(x0+heval) 518 | if (me%stop) then 519 | ifail = -1 520 | return 521 | end if 522 | end if 523 | heval = beta*heval 524 | f2 = me%f(x0+heval) 525 | if (me%stop) then 526 | ifail = -1 527 | return 528 | end if 529 | heval = beta*heval 530 | f1 = me%f(x0+heval) 531 | if (me%stop) then 532 | ifail = -1 533 | return 534 | end if 535 | end if 536 | end if 537 | 538 | ! evaluate a new approximation dnew to the derivative 539 | 540 | if (n > nmax) then 541 | n = nmax 542 | do i = 1,n 543 | maxf(i-1) = maxf(i) 544 | end do 545 | end if 546 | if (method == 2) then 547 | maxf(n) = (abs(f1)+abs(f2))/2.0_wp 548 | if (iord == 1) then 549 | dnew = (f1-f2)/2.0_wp 550 | else if (iord == 2) then 551 | dnew = f1+f2-twof0 552 | else 553 | dnew = -pdelta 554 | pdelta = deltaf 555 | deltaf = f1-f2 556 | dnew = dnew + 0.5_wp*deltaf 557 | if (maxf(n) < pmaxf) maxf(n) = pmaxf 558 | pmaxf = maxfun 559 | maxfun = (abs(f1)+abs(f2))/2.0_wp 560 | end if 561 | else 562 | maxf(n) = abs(f1) 563 | if (iord == 1) then 564 | dnew = f1-f0 565 | else if (iord == 2) then 566 | dnew = (twof0-3.0_wp*f3+f1)/3.0_wp 567 | if (maxf(n) < abs(f3)) maxf(n) = abs(f3) 568 | f3 = f2 569 | f2 = f1 570 | else 571 | dnew = c3*f1+c2*f2+c1*f4+c0f0 572 | if (maxf(n) < abs(f2)) maxf(n) = abs(f2) 573 | if (maxf(n) < abs(f4)) maxf(n) = abs(f4) 574 | f4 = f3 575 | f3 = f2 576 | f2 = f1 577 | end if 578 | end if 579 | if (abs(h) > 1) then 580 | dnew = dnew/h**iord 581 | else 582 | if (128.0_wp*abs(dnew) > twosup*abs(h)**iord) then 583 | dnew = twosup/128.0_wp 584 | else 585 | dnew = dnew/h**iord 586 | end if 587 | end if 588 | 589 | if (init == 0) then 590 | ! update estimated accuracy of function values 591 | newacc = acc 592 | if ((method /= 2 .or. iord == 2) .and. newacc < acc0) newacc = acc0 593 | if (method /= -1 .and. abs(nhacc1) <= 1.125_wp*abs(heval)/beta4) then 594 | nhacc1 = heval 595 | pacc1 = facc1 596 | call me%faccur(nhacc1,newh1,facc1,x0,twoinf,f0,f1,ifail) 597 | if (ifail==-1) return 598 | if (facc1 < pacc1) facc1=(3.0_wp*facc1+pacc1)/4.0_wp 599 | end if 600 | if (method /= 1 .and. abs(nhacc2) <= 1.125_wp*abs(heval)/beta4) then 601 | if (method == 2) then 602 | f1 = f2 603 | nhacc2 = -heval 604 | else 605 | nhacc2 = heval 606 | end if 607 | pacc2 = facc2 608 | call me%faccur(nhacc2,newh2,facc2,x0,twoinf,f0,f1,ifail) 609 | if (ifail==-1) return 610 | if (facc2 < pacc2) facc2 = (3.0_wp*facc2+pacc2)/4.0_wp 611 | end if 612 | if (method == 1 .and. newacc < facc1) newacc = facc1 613 | if (method == -1 .and. newacc < facc2) newacc = facc2 614 | if (method == 2 .and. newacc < (facc1+facc2)/2.0_wp) & 615 | newacc = (facc1+facc2)/2.0_wp 616 | end if 617 | 618 | ! evaluate successive elements of the current row in the neville 619 | ! array, estimating and examining the truncation and rounding 620 | ! errors in each 621 | 622 | contin = n < nmax 623 | hprev = abs(h) 624 | fmax = maxf(n) 625 | if ((method /= 2 .or. iord == 2) .and. fmax < abs(f0)) fmax = abs(f0) 626 | 627 | do k = 1,n 628 | dprev = d(k) 629 | d(k) = dnew 630 | dnew = dprev+(dprev-dnew)/denom(k) 631 | te = abs(dnew-d(k)) 632 | if (fmax < maxf(n-k)) fmax = maxf(n-k) 633 | hprev = hprev/beta 634 | if (newacc >= relacc*fmax) then 635 | re = newacc*e(k) 636 | else 637 | re = relacc*fmax*e(k) 638 | end if 639 | if (re /= 0.0_wp) then 640 | if (hprev > 1) then 641 | re = re/hprev**iord 642 | else if (2.0_wp*re > twosup*hprev**iord) then 643 | re = twosup/2.0_wp 644 | else 645 | re = re/hprev**iord 646 | end if 647 | end if 648 | newerr = te+re 649 | if (te > re) newerr = 1.25_wp*newerr 650 | if (.not. ignore(k)) then 651 | if ((init == 0 .or. (k == 2 .and. .not.ignore(1))) & 652 | .and. newerr < error) then 653 | deriv = d(k) 654 | error = newerr 655 | end if 656 | if (init == 1 .and. n == 1) then 657 | tderiv = d(1) 658 | temerr = newerr 659 | end if 660 | if (minerr(k) < twosup/4.0_wp) then 661 | s = 4.0_wp*minerr(k) 662 | else 663 | s = twosup 664 | end if 665 | if (te > re .or. newerr > s) then 666 | ignore(k) = .true. 667 | else 668 | contin = .true. 669 | end if 670 | if (newerr < minerr(k)) minerr(k) = newerr 671 | if (init == 1 .and. n == 2 .and. k == 1 .and. .not.ignore(1)) then 672 | if (newerr < temerr) then 673 | tderiv = d(1) 674 | temerr = newerr 675 | end if 676 | if (temerr < error) then 677 | deriv = tderiv 678 | error = temerr 679 | end if 680 | end if 681 | end if 682 | end do 683 | 684 | if (n < nmax) d(n+1) = dnew 685 | if (eps < 0.0_wp) then 686 | s = abs(eps*deriv) 687 | else 688 | s = eps 689 | end if 690 | if (error <= s) then 691 | contin = .false. 692 | else if (init == 1 .and. (n == 2 .or. ignore(1))) then 693 | if ((ignore(1) .or. ignore(2)) .and. saved) then 694 | saved = .false. 695 | n = 2 696 | h = beta * save(0) 697 | heval = beta*save(1) 698 | maxf(0) = save(2) 699 | maxf(1) = save(3) 700 | maxf(2) = save(4) 701 | d(1) = save(5) 702 | d(2) = save(6) 703 | d(3) = save(7) 704 | minerr(1) = save(8) 705 | minerr(2) = save(9) 706 | if (method == 2 .and. iord == 3) then 707 | pdelta = save(10) 708 | deltaf = save(11) 709 | pmaxf = save(12) 710 | maxfun = save(13) 711 | else if (method /= 2 .and. iord >= 2) then 712 | f2 = save(10) 713 | f3 = save(11) 714 | if (iord == 3) f4 = save(12) 715 | end if 716 | init = 0 717 | ignore(1) = .false. 718 | ignore(2) = .false. 719 | else if (.not. (ignore(1) .or. ignore(2)) .and. n == 2 & 720 | .and. beta4*factor*abs(heval) <= maxh) then 721 | ! save all current values in case of return to current point 722 | saved = .true. 723 | save(0) = h 724 | save(1) = heval 725 | save(2) = maxf(0) 726 | save(3) = maxf(1) 727 | save(4) = maxf(2) 728 | save(5) = d(1) 729 | save(6) = d(2) 730 | save(7) = d(3) 731 | save(8) = minerr(1) 732 | save(9) = minerr (2) 733 | if (method == 2 .and. iord == 3) then 734 | save(10) = pdelta 735 | save(11) = deltaf 736 | save(12) = pmaxf 737 | save(13) = maxfun 738 | else if (method /= 2 .and. iord >= 2) then 739 | save(10) = f2 740 | save(11) = f3 741 | if (iord == 3) save(12) = f4 742 | end if 743 | h = factor*baseh 744 | heval = h 745 | baseh = h 746 | n = -1 747 | else 748 | init = 0 749 | h = beta*h 750 | heval = beta*heval 751 | end if 752 | else if (contin .and. beta*abs(heval) <= maxh) then 753 | h = beta*h 754 | heval = beta*heval 755 | else if (method /= 1) then 756 | contin = .true. 757 | if (method == 2) then 758 | init = 3 759 | method = -1 760 | if (iord /= 2) then 761 | if (x0 /= 0.0_wp) then 762 | dummy1 = 0.0_wp 763 | dummy2 = -h0 764 | call me%faccur(dummy1,dummy2,acc0,x0,twoinf,f0,f1,ifail) 765 | if (ifail==-1) return 766 | else 767 | acc0 = 0.0_wp 768 | end if 769 | end if 770 | else 771 | init = 2 772 | method = 1 773 | end if 774 | n = -1 775 | signh = -signh 776 | else 777 | contin = .false. 778 | end if 779 | 780 | end do 781 | 782 | if (eps < 0.0_wp) then 783 | s = abs(eps*deriv) 784 | else 785 | s = eps 786 | end if 787 | ifail = 0 788 | if (eps /= 0.0_wp .and. error > s) ifail = 1 789 | 790 | end if 791 | 792 | end subroutine diff 793 | !***************************************************************************************** 794 | 795 | !***************************************************************************************** 796 | !> 797 | ! This procedure attempts to estimate the level of rounding errors in 798 | ! the calculated function values near the point `x0+h0` by fitting a 799 | ! least-squares straight-line approximation to the function at the 800 | ! six points `x0+h0-j*h1`, (`j = 0,1,3,5,7,9`), and then setting `facc` to 801 | ! twice the largest deviation of the function values from this line. 802 | ! `hi` is adjusted if necessary so that it is approximately 8 times the 803 | ! smallest spacing at which the function values are unequal near `x0+h0`. 804 | 805 | subroutine faccur(me,h0,h1,facc,x0,twoinf,f0,f1,ifail) 806 | 807 | implicit none 808 | 809 | class(diff_func),intent(inout) :: me 810 | real(wp), intent(inout) :: h0 811 | real(wp), intent(inout) :: h1 812 | real(wp), intent(out) :: facc 813 | real(wp), intent(in) :: x0 814 | real(wp), intent(in) :: twoinf 815 | real(wp), intent(in) :: f0 816 | real(wp), intent(in) :: f1 817 | integer, intent(out) :: ifail !! 0 if no error, -1 if user termination. 818 | 819 | real(wp) :: a0,a1,f00,f001,f2,deltaf,t0,t1,df(5) 820 | integer :: j 821 | 822 | ifail = 0 823 | t0 = 0.0_wp 824 | t1 = 0.0_wp 825 | if (h0 /= 0.0_wp) then 826 | if (x0+h0 /= 0.0_wp) then 827 | f00 = f1 828 | else 829 | h0 = 0.875_wp*h0 830 | f00 = me%f(x0+h0) 831 | if (me%stop) then 832 | ifail = -1 833 | return 834 | end if 835 | end if 836 | if (abs(h1) >= 32.0_wp*twoinf) h1 = h1/8.0_wp 837 | if (16.0_wp*abs(h1) > abs(h0)) h1 = sign(h1,1.0_wp)*abs(h0)/16.0_wp 838 | f001 = me%f(x0+h0-h1) 839 | if (me%stop) then 840 | ifail = -1 841 | return 842 | end if 843 | if (f001 == f00) then 844 | if (256.0_wp*abs(h1) <= abs(h0)) then 845 | h1 = 2.0_wp*h1 846 | do 847 | f001 = me%f(x0+h0-h1) 848 | if (me%stop) then 849 | ifail = -1 850 | return 851 | end if 852 | if (f001 /= f00 .or. 256.0_wp*abs(h1) > abs(h0)) exit 853 | h1 = 2.0_wp*h1 854 | end do 855 | h1 = 8.0_wp*h1 856 | else 857 | h1 = sign(h1,1.0_wp)*abs(h0)/16.0_wp 858 | end if 859 | else 860 | if (256.0_wp*twoinf <= abs(h0)) then 861 | do 862 | f001 = me%f(x0+h0-h1/2.0_wp) 863 | if (me%stop) then 864 | ifail = -1 865 | return 866 | end if 867 | if (f001 == f00 .or. abs(h1) < 4.0_wp*twoinf) exit 868 | h1 = h1/2.0_wp 869 | end do 870 | h1 = 8.0_wp*h1 871 | if (16.0_wp*abs(h1) > abs(h0)) h1 = sign(h1,1.0_wp)*abs(h0)/16.0_wp 872 | else 873 | h1 = sign(h1,1.0_wp)*abs(h0)/16.0_wp 874 | end if 875 | end if 876 | else 877 | f00 = f0 878 | end if 879 | 880 | do j = 1,5 881 | f2 = me%f(x0+h0-real(2*j-1,wp)*h1) 882 | if (me%stop) then 883 | ifail = -1 884 | return 885 | end if 886 | df(j) = f2 - f00 887 | t0 = t0+df(j) 888 | t1 = t1+real(2*j-1,wp)*df(j) 889 | end do 890 | a0 = (33.0_wp*t0-5.0_wp*t1)/73.0_wp 891 | a1 = (-5.0_wp*t0+1.2_wp*t1)/73.0_wp 892 | facc = abs(a0) 893 | do j = 1,5 894 | deltaf = abs(df(j)-(a0+real(2*j-1,wp)*a1)) 895 | if (facc < deltaf) facc = deltaf 896 | end do 897 | facc = 2.0_wp*facc 898 | 899 | end subroutine faccur 900 | !***************************************************************************************** 901 | 902 | !***************************************************************************************** 903 | end module diff_module 904 | !***************************************************************************************** 905 | -------------------------------------------------------------------------------- /src/dsm_module.f90: -------------------------------------------------------------------------------- 1 | !******************************************************************************* 2 | !> 3 | ! Jacobian partitioning using the DSM algorithm. 4 | ! 5 | !### Reference 6 | ! * Argonne National Laboratory. MINPACK Project. July 1983. 7 | ! Thomas F. Coleman, Burton S. Garbow, Jorge J. More 8 | ! * Thomas F. Coleman, Burton S. Garbow, Jorge J. More, "Algorithm 618: 9 | ! FORTRAN subroutines for estimating sparse Jacobian Matrices", 10 | ! ACM Transactions on Mathematical Software (TOMS), 11 | ! Volume 10 Issue 3, Sept. 1984, Pages 346-347 12 | ! 13 | !### History 14 | ! * Jacob Williams, Nov. 2016, extensive refactoring into modern Fortran. 15 | 16 | module dsm_module 17 | 18 | use numdiff_kinds_module 19 | 20 | implicit none 21 | 22 | private 23 | 24 | public :: dsm 25 | public :: fdjs 26 | 27 | contains 28 | !******************************************************************************* 29 | 30 | !******************************************************************************* 31 | !> 32 | ! The purpose of `dsm` is to determine an optimal or near- 33 | ! optimal consistent partition of the columns of a sparse 34 | ! `m` by `n` matrix `a`. 35 | ! 36 | ! the sparsity pattern of the matrix `a` is specified by 37 | ! the arrays `indrow` and `indcol`. on input the indices 38 | ! for the non-zero elements of `a` are 39 | ! 40 | ! `indrow(k),indcol(k), k = 1,2,...,npairs`. 41 | ! 42 | ! the (`indrow`,`indcol`) pairs may be specified in any order. 43 | ! duplicate input pairs are permitted, but the subroutine 44 | ! eliminates them. 45 | ! 46 | ! the subroutine partitions the columns of `a` into groups 47 | ! such that columns in the same group do not have a 48 | ! non-zero in the same row position. a partition of the 49 | ! columns of `a` with this property is consistent with the 50 | ! direct determination of `a`. 51 | 52 | subroutine dsm(m,n,Npairs,Indrow,Indcol,Ngrp,Maxgrp,Mingrp,Info,Ipntr,Jpntr) 53 | 54 | implicit none 55 | 56 | integer,intent(in) :: m !! number of rows of `a` (>0) 57 | integer,intent(in) :: n !! number of columns of `a` (>0) 58 | integer,intent(in) :: npairs !! number of (`indrow`,`indcol`) pairs used 59 | !! to describe the sparsity pattern of `a` (>0) 60 | integer,intent(out) :: maxgrp !! the number of groups in the partition 61 | !! of the columns of `a`. 62 | integer,intent(out) :: mingrp !! a lower bound for the number of groups 63 | !! in any consistent partition of the 64 | !! columns of `a`. 65 | integer,intent(out) :: info !! for normal termination `info = 1`. 66 | !! if `m`, `n`, or `npairs` is not positive, 67 | !! then `info = 0`. if the k-th element of 68 | !! `indrow` is not an integer between 69 | !! 1 and m or the k-th element of `indcol` 70 | !! is not an integer between 1 and n, 71 | !! then `info = -k`. 72 | integer,dimension(npairs),intent(inout) :: indrow !! an integer array of length `npairs`. on input `indrow` 73 | !! must contain the row indices of the non-zero elements of `a`. 74 | !! on output `indrow` is permuted so that the corresponding 75 | !! column indices are in non-decreasing order. the column 76 | !! indices can be recovered from the array `jpntr`. 77 | integer,dimension(npairs),intent(inout) :: indcol !! an integer array of length `npairs`. on input `indcol` 78 | !! must contain the column indices of the non-zero elements of 79 | !! `a`. on output `indcol` is permuted so that the corresponding 80 | !! row indices are in non-decreasing order. the row indices 81 | !! can be recovered from the array `ipntr`. 82 | integer,dimension(n),intent(out) :: ngrp !! specifies the partition of the columns of `a`. 83 | !! column `jcol` belongs to group `ngrp(jcol)`. 84 | integer,dimension(m+1),intent(out) :: ipntr !! an integer output array of length `m + 1` which 85 | !! specifies the locations of the column indices in `indcol`. 86 | !! the column indices for row `i` are 87 | !! `indcol(k), k = ipntr(i),...,ipntr(i+1)-1`. 88 | !! note that `ipntr(m+1)-1` is then the number of non-zero 89 | !! elements of the matrix `a`. 90 | integer,dimension(n+1),intent(out) :: jpntr !! jpntr is an integer output array of length n + 1 which 91 | !! specifies the locations of the row indices in indrow. 92 | !! the row indices for column j are 93 | !! `indrow(k), k = jpntr(j),...,jpntr(j+1)-1`. 94 | !! note that `jpntr(n+1)-1` is then the number of non-zero 95 | !! elements of the matrix `a`. 96 | 97 | integer,dimension(max(m,6*n)) :: iwa !! an integer work array 98 | integer :: i , ir , j , jp , k , maxclq , nnz , numgrp 99 | 100 | ! check the input data. 101 | 102 | Info = 0 103 | if ( m<1 .or. n<1 .or. Npairs<1 ) return 104 | do k = 1 , Npairs 105 | Info = -k 106 | if ( Indrow(k)<1 .or. Indrow(k)>m .or. Indcol(k)<1 .or. Indcol(k)>n ) return 107 | enddo 108 | Info = 1 109 | 110 | ! sort the data structure by columns. 111 | 112 | call srtdat(n,Npairs,Indrow,Indcol,Jpntr,Iwa) 113 | 114 | ! compress the data and determine the number of 115 | ! non-zero elements of a. 116 | 117 | do i = 1 , m 118 | Iwa(i) = 0 119 | enddo 120 | nnz = 1 121 | do j = 1 , n 122 | k = nnz 123 | do jp = Jpntr(j) , Jpntr(j+1) - 1 124 | ir = Indrow(jp) 125 | if ( Iwa(ir)/=j ) then 126 | Indrow(nnz) = ir 127 | nnz = nnz + 1 128 | Iwa(ir) = j 129 | endif 130 | enddo 131 | Jpntr(j) = k 132 | enddo 133 | Jpntr(n+1) = nnz 134 | 135 | ! extend the data structure to rows. 136 | 137 | call setr(m,n,Indrow,Jpntr,Indcol,Ipntr,Iwa) 138 | 139 | ! determine a lower bound for the number of groups. 140 | 141 | Mingrp = 0 142 | do i = 1 , m 143 | Mingrp = max(Mingrp,Ipntr(i+1)-Ipntr(i)) 144 | enddo 145 | 146 | ! determine the degree sequence for the intersection 147 | ! graph of the columns of a. 148 | 149 | call degr(n,Indrow,Jpntr,Indcol,Ipntr,Iwa(5*n+1),Iwa(n+1)) 150 | 151 | ! color the intersection graph of the columns of a 152 | ! with the smallest-last (sl) ordering. 153 | 154 | call slo(n,Indrow,Jpntr,Indcol,Ipntr,Iwa(5*n+1),Iwa(4*n+1),maxclq,& 155 | Iwa(1),Iwa(n+1),Iwa(2*n+1),Iwa(3*n+1)) 156 | call seq(n,Indrow,Jpntr,Indcol,Ipntr,Iwa(4*n+1),Ngrp,Maxgrp, & 157 | Iwa(n+1)) 158 | Mingrp = max(Mingrp,maxclq) 159 | 160 | ! exit if the smallest-last ordering is optimal. 161 | 162 | if ( Maxgrp==Mingrp ) return 163 | 164 | ! color the intersection graph of the columns of a 165 | ! with the incidence-degree (id) ordering. 166 | 167 | call ido(m,n,Indrow,Jpntr,Indcol,Ipntr,Iwa(5*n+1),Iwa(4*n+1), & 168 | maxclq,Iwa(1),Iwa(n+1),Iwa(2*n+1),Iwa(3*n+1)) 169 | call seq(n,Indrow,Jpntr,Indcol,Ipntr,Iwa(4*n+1),Iwa(1),numgrp, & 170 | Iwa(n+1)) 171 | Mingrp = max(Mingrp,maxclq) 172 | 173 | ! retain the better of the two orderings so far. 174 | 175 | if ( numgrp 207 | ! Given the sparsity pattern of an `m` by `n` matrix `a`, 208 | ! this subroutine determines the degree sequence for 209 | ! the intersection graph of the columns of `a`. 210 | ! 211 | ! In graph-theory terminology, the intersection graph of 212 | ! the columns of `a` is the loopless graph `g` with vertices 213 | ! `a(j), j = 1,2,...,n` where `a(j)` is the `j`-th column of `a` 214 | ! and with edge `(a(i),a(j))` if and only if columns `i` and `j` 215 | ! have a non-zero in the same row position. 216 | ! 217 | !@note The value of `m` is not needed by `degr` and is 218 | ! therefore not present in the subroutine statement. 219 | 220 | subroutine degr(n,Indrow,Jpntr,Indcol,Ipntr,Ndeg,Iwa) 221 | 222 | implicit none 223 | 224 | integer,intent(in) :: n !! a positive integer input variable set to the number 225 | !! of columns of `a`. 226 | integer,dimension(*),intent(in) :: indrow !! an integer input array which contains the row 227 | !! indices for the non-zeroes in the matrix `a`. 228 | integer,dimension(n+1),intent(in) :: jpntr !! an integer input array of length `n + 1` which 229 | !! specifies the locations of the row indices in `indrow`. 230 | !! the row indices for column `j` are 231 | !! `indrow(k), k = jpntr(j),...,jpntr(j+1)-1`. 232 | !! **note** that `jpntr(n+1)-1` is then the number of non-zero 233 | !! elements of the matrix `a`. 234 | integer,dimension(*),intent(in) :: indcol !! an integer input array which contains the 235 | !! column indices for the non-zeroes in the matrix `a`. 236 | integer,dimension(*),intent(in) :: ipntr !! an integer input array of length `m + 1` which 237 | !! specifies the locations of the column indices in `indcol`. 238 | !! the column indices for row `i` are 239 | !! `indcol(k), k = ipntr(i),...,ipntr(i+1)-1`. 240 | !! **note** that `ipntr(m+1)-1` is then the number of non-zero 241 | !! elements of the matrix `a`. 242 | integer,dimension(n),intent(out) :: ndeg !! an integer output array of length `n` which 243 | !! specifies the degree sequence. the degree of the 244 | !! `j`-th column of `a` is `ndeg(j)`. 245 | integer,dimension(n) :: iwa !! an integer work array of length `n` 246 | 247 | integer :: ic , ip , ir , jcol , jp 248 | 249 | ! initialization block. 250 | 251 | do jp = 1 , n 252 | Ndeg(jp) = 0 253 | Iwa(jp) = 0 254 | enddo 255 | 256 | ! compute the degree sequence by determining the contributions 257 | ! to the degrees from the current(jcol) column and further 258 | ! columns which have not yet been considered. 259 | 260 | do jcol = 2 , n 261 | Iwa(jcol) = n 262 | 263 | ! determine all positions (ir,jcol) which correspond 264 | ! to non-zeroes in the matrix. 265 | 266 | do jp = Jpntr(jcol) , Jpntr(jcol+1) - 1 267 | ir = Indrow(jp) 268 | 269 | ! for each row ir, determine all positions (ir,ic) 270 | ! which correspond to non-zeroes in the matrix. 271 | 272 | do ip = Ipntr(ir) , Ipntr(ir+1) - 1 273 | ic = Indcol(ip) 274 | 275 | ! array iwa marks columns which have contributed to 276 | ! the degree count of column jcol. update the degree 277 | ! counts of these columns as well as column jcol. 278 | 279 | if ( Iwa(ic) 294 | ! given the sparsity pattern of an `m` by `n` matrix `a`, this 295 | ! subroutine determines an incidence-degree ordering of the 296 | ! columns of `a`. 297 | ! 298 | ! the incidence-degree ordering is defined for the loopless 299 | ! graph `g` with vertices `a(j), j = 1,2,...,n` where `a(j)` is the 300 | ! `j`-th column of `a` and with edge `(a(i),a(j))` if and only if 301 | ! columns `i` and `j` have a non-zero in the same row position. 302 | ! 303 | ! the incidence-degree ordering is determined recursively by 304 | ! letting `list(k), k = 1,...,n` be a column with maximal 305 | ! incidence to the subgraph spanned by the ordered columns. 306 | ! among all the columns of maximal incidence, `ido` chooses a 307 | ! column of maximal degree. 308 | 309 | subroutine ido(m,n,Indrow,Jpntr,Indcol,Ipntr,Ndeg,List,Maxclq, & 310 | Iwa1,Iwa2,Iwa3,Iwa4) 311 | 312 | implicit none 313 | 314 | integer,intent(in) :: m !! a positive integer input variable set to the number 315 | !! of rows of `a`. 316 | integer,intent(in) :: n !! a positive integer input variable set to the number 317 | !! of columns of `a`. 318 | integer,intent(out) :: Maxclq !! an integer output variable set to the size 319 | !! of the largest clique found during the ordering. 320 | integer,dimension(*),intent(in) :: Indrow !! an integer input array which contains the row 321 | !! indices for the non-zeroes in the matrix `a`. 322 | integer,dimension(n+1),intent(in) :: Jpntr !! an integer input array of length `n + 1` which 323 | !! specifies the locations of the row indices in `indrow`. 324 | !! the row indices for column `j` are 325 | !! `indrow(k), k = jpntr(j),...,jpntr(j+1)-1`. 326 | !! **note** that `jpntr(n+1)-1` is then the number of non-zero 327 | !! elements of the matrix `a`. 328 | integer,dimension(*),intent(in) :: Indcol !! an integer input array which contains the 329 | !! column indices for the non-zeroes in the matrix `a`. 330 | integer,dimension(m+1),intent(in) :: Ipntr !! an integer input array of length `m + 1` which 331 | !! specifies the locations of the column indices in `indcol`. 332 | !! the column indices for row `i` are 333 | !! `indcol(k), k = ipntr(i),...,ipntr(i+1)-1`. 334 | !! **note** that `ipntr(m+1)-1` is then the number of non-zero 335 | !! elements of the matrix `a`. 336 | integer,dimension(n),intent(in) :: Ndeg !! an integer input array of length `n` which specifies 337 | !! the degree sequence. the degree of the `j`-th column 338 | !! of `a` is `ndeg(j)`. 339 | integer,dimension(n),intent(out) :: List !! an integer output array of length `n` which specifies 340 | !! the incidence-degree ordering of the columns of `a`. the `j`-th 341 | !! column in this order is `list(j)`. 342 | integer,dimension(0:n-1) :: Iwa1 !! integer work array of length `n`. 343 | integer,dimension(n) :: Iwa2 !! integer work array of length `n`. 344 | integer,dimension(n) :: Iwa3 !! integer work array of length `n`. 345 | integer,dimension(n) :: Iwa4 !! integer work array of length `n`. 346 | 347 | integer :: ic , ip , ir , jcol , jp , maxinc , maxlst , ncomp , & 348 | numinc , numlst , numord , numwgt 349 | 350 | ! sort the degree sequence. 351 | 352 | call numsrt(n,n-1,Ndeg,-1,Iwa4,Iwa2,Iwa3) 353 | 354 | ! initialization block. 355 | ! 356 | ! create a doubly-linked list to access the incidences of the 357 | ! columns. the pointers for the linked list are as follows. 358 | ! 359 | ! each un-ordered column ic is in a list (the incidence list) 360 | ! of columns with the same incidence. 361 | ! 362 | ! iwa1(numinc) is the first column in the numinc list 363 | ! unless iwa1(numinc) = 0. in this case there are 364 | ! no columns in the numinc list. 365 | ! 366 | ! iwa2(ic) is the column before ic in the incidence list 367 | ! unless iwa2(ic) = 0. in this case ic is the first 368 | ! column in this incidence list. 369 | ! 370 | ! iwa3(ic) is the column after ic in the incidence list 371 | ! unless iwa3(ic) = 0. in this case ic is the last 372 | ! column in this incidence list. 373 | ! 374 | ! if ic is an un-ordered column, then list(ic) is the 375 | ! incidence of ic to the graph induced by the ordered 376 | ! columns. if jcol is an ordered column, then list(jcol) 377 | ! is the incidence-degree order of column jcol. 378 | 379 | maxinc = 0 380 | do jp = n , 1 , -1 381 | ic = Iwa4(jp) 382 | Iwa1(n-jp) = 0 383 | Iwa2(ic) = 0 384 | Iwa3(ic) = Iwa1(0) 385 | if ( Iwa1(0)>0 ) Iwa2(Iwa1(0)) = ic 386 | Iwa1(0) = ic 387 | Iwa4(jp) = 0 388 | List(jp) = 0 389 | enddo 390 | 391 | ! DETERMINE THE MAXIMAL SEARCH LENGTH FOR THE LIST 392 | ! OF COLUMNS OF MAXIMAL INCIDENCE. 393 | 394 | maxlst = 0 395 | do ir = 1 , m 396 | maxlst = maxlst + (Ipntr(ir+1)-Ipntr(ir))**2 397 | enddo 398 | maxlst = maxlst/n 399 | Maxclq = 0 400 | numord = 1 401 | 402 | ! BEGINNING OF ITERATION LOOP. 403 | 404 | ! UPDATE THE SIZE OF THE LARGEST CLIQUE 405 | ! FOUND DURING THE ORDERING. 406 | 407 | 100 if ( maxinc==0 ) ncomp = 0 408 | ncomp = ncomp + 1 409 | if ( maxinc+1==ncomp ) Maxclq = max(Maxclq,ncomp) 410 | 411 | ! CHOOSE A COLUMN JCOL OF MAXIMAL DEGREE AMONG THE 412 | ! COLUMNS OF MAXIMAL INCIDENCE MAXINC. 413 | 414 | 200 jp = Iwa1(maxinc) 415 | if ( jp>0 ) then 416 | numwgt = -1 417 | do numlst = 1 , maxlst 418 | if ( Ndeg(jp)>numwgt ) then 419 | numwgt = Ndeg(jp) 420 | jcol = jp 421 | endif 422 | jp = Iwa3(jp) 423 | if ( jp<=0 ) exit 424 | enddo 425 | List(jcol) = numord 426 | numord = numord + 1 427 | 428 | ! TERMINATION TEST. 429 | 430 | if ( numord>n ) then 431 | 432 | ! INVERT THE ARRAY LIST. 433 | 434 | do jcol = 1 , n 435 | Iwa2(List(jcol)) = jcol 436 | enddo 437 | do jp = 1 , n 438 | List(jp) = Iwa2(jp) 439 | enddo 440 | 441 | else 442 | 443 | ! DELETE COLUMN JCOL FROM THE MAXINC LIST. 444 | 445 | if ( Iwa2(jcol)==0 ) then 446 | Iwa1(maxinc) = Iwa3(jcol) 447 | else 448 | Iwa3(Iwa2(jcol)) = Iwa3(jcol) 449 | endif 450 | if ( Iwa3(jcol)>0 ) Iwa2(Iwa3(jcol)) = Iwa2(jcol) 451 | 452 | ! FIND ALL COLUMNS ADJACENT TO COLUMN JCOL. 453 | 454 | Iwa4(jcol) = n 455 | 456 | ! DETERMINE ALL POSITIONS (IR,JCOL) WHICH CORRESPOND 457 | ! TO NON-ZEROES IN THE MATRIX. 458 | 459 | do jp = Jpntr(jcol) , Jpntr(jcol+1) - 1 460 | ir = Indrow(jp) 461 | 462 | ! FOR EACH ROW IR, DETERMINE ALL POSITIONS (IR,IC) 463 | ! WHICH CORRESPOND TO NON-ZEROES IN THE MATRIX. 464 | 465 | do ip = Ipntr(ir) , Ipntr(ir+1) - 1 466 | ic = Indcol(ip) 467 | 468 | ! ARRAY IWA4 MARKS COLUMNS WHICH ARE ADJACENT TO 469 | ! COLUMN JCOL. 470 | 471 | if ( Iwa4(ic)0 ) Iwa2(Iwa3(ic)) = Iwa2(ic) 488 | 489 | ! ADD COLUMN IC TO THE NUMINC+1 LIST. 490 | 491 | Iwa2(ic) = 0 492 | Iwa3(ic) = Iwa1(numinc+1) 493 | if ( Iwa1(numinc+1)>0 ) Iwa2(Iwa1(numinc+1)) = ic 494 | Iwa1(numinc+1) = ic 495 | endif 496 | enddo 497 | enddo 498 | 499 | ! END OF ITERATION LOOP. 500 | 501 | goto 100 502 | endif 503 | else 504 | maxinc = maxinc - 1 505 | goto 200 506 | endif 507 | 508 | end subroutine ido 509 | !******************************************************************************* 510 | 511 | !******************************************************************************* 512 | !> 513 | ! Given a sequence of integers, this subroutine groups 514 | ! together those indices with the same sequence value 515 | ! and, optionally, sorts the sequence into either 516 | ! ascending or descending order. 517 | ! 518 | ! The sequence of integers is defined by the array `num`, 519 | ! and it is assumed that the integers are each from the set 520 | ! `0,1,...,nmax`. on output the indices `k` such that `num(k) = l` 521 | ! for any `l = 0,1,...,nmax` can be obtained from the arrays 522 | ! last and next as follows. 523 | !```fortran 524 | ! k = last(l) 525 | ! while (k /= 0) k = next(k) 526 | !``` 527 | ! Optionally, the subroutine produces an array index so that 528 | ! the sequence `num(index(i)), i = 1,2,...,n` is sorted. 529 | 530 | subroutine numsrt(n,Nmax,Num,Mode,Index,Last,Next) 531 | 532 | implicit none 533 | 534 | integer,intent(in) :: n !! a positive integer input variable. 535 | integer :: Nmax !! a positive integer input variable. 536 | integer :: Mode !! an integer input variable. the sequence `num` is 537 | !! sorted in ascending order if `mode` is positive and in 538 | !! descending order if `mode` is negative. if `mode` is 0, 539 | !! no sorting is done. 540 | integer,dimension(n) :: Num !! an input array of length `n` which contains the 541 | !! sequence of integers to be grouped and sorted. it 542 | !! is assumed that the integers are each from the set 543 | !! `0,1,...,nmax`. 544 | integer,dimension(n) :: Index !! an integer output array of length `n` set so 545 | !! that the sequence 546 | !! `num(index(i)), i = 1,2,...,n` 547 | !! is sorted according to the setting of mode. 548 | !! if `mode` is 0, `index` is not referenced. 549 | integer,dimension(0:Nmax) :: Last !! an integer output array of length `nmax + 1`. the 550 | !! index of `num` for the last occurrence of `l` is `last(l)` 551 | !! for any `l = 0,1,...,nmax` unless `last(l) = 0`. in 552 | !! this case `l` does not appear in `num`. 553 | integer,dimension(n) :: Next !! an integer output array of length `n`. if 554 | !! `num(k) = l`, then the index of `num` for the previous 555 | !! occurrence of `l` is `next(k)` for any `l = 0,1,...,nmax` 556 | !! unless `next(k) = 0`. in this case there is no previous 557 | !! occurrence of `l` in `num`. 558 | 559 | integer :: i , j , jinc , jl , ju , k , l 560 | 561 | ! determine the arrays next and last. 562 | 563 | do i = 0 , Nmax 564 | Last(i) = 0 565 | enddo 566 | 567 | do k = 1 , n 568 | l = Num(k) 569 | Next(k) = Last(l) 570 | Last(l) = k 571 | enddo 572 | 573 | if ( Mode/=0 ) then 574 | 575 | ! store the pointers to the sorted array in index. 576 | i = 1 577 | if ( Mode>0 ) then 578 | jl = 0 579 | ju = Nmax 580 | jinc = 1 581 | else 582 | jl = Nmax 583 | ju = 0 584 | jinc = -1 585 | endif 586 | do j = jl , ju , jinc 587 | k = Last(j) 588 | do 589 | if (k==0) exit 590 | Index(i) = k 591 | i = i + 1 592 | k = Next(k) 593 | enddo 594 | enddo 595 | 596 | end if 597 | 598 | end subroutine numsrt 599 | !******************************************************************************* 600 | 601 | !******************************************************************************* 602 | !> 603 | ! given the sparsity pattern of an `m` by `n` matrix `a`, this 604 | ! subroutine determines a consistent partition of the 605 | ! columns of `a` by a sequential algorithm. 606 | ! 607 | ! a consistent partition is defined in terms of the loopless 608 | ! graph `g` with vertices `a(j), j = 1,2,...,n` where `a(j)` is the 609 | ! `j`-th column of `a` and with edge `(a(i),a(j))` if and only if 610 | ! columns `i` and `j` have a non-zero in the same row position. 611 | ! 612 | ! a partition of the columns of a into groups is consistent 613 | ! if the columns in any group are not adjacent in the graph `g`. 614 | ! in graph-theory terminology, a consistent partition of the 615 | ! columns of a corresponds to a coloring of the graph `g`. 616 | ! 617 | ! the subroutine examines the columns in the order specified 618 | ! by the array list, and assigns the current column to the 619 | ! group with the smallest possible number. 620 | ! 621 | ! note that the value of `m` is not needed by `seq` and is 622 | ! therefore not present in the subroutine statement. 623 | 624 | subroutine seq(n,Indrow,Jpntr,Indcol,Ipntr,List,Ngrp,Maxgrp,Iwa) 625 | 626 | implicit none 627 | 628 | integer :: n !! a positive integer input variable set to the number 629 | !! of columns of `a`. 630 | integer :: Maxgrp !! an integer output variable which specifies the 631 | !! number of groups in the partition of the columns of `a`. 632 | integer,dimension(*) :: Indrow !! an integer input array which contains the row 633 | !! indices for the non-zeroes in the matrix `a`. 634 | integer,dimension(n+1) :: Jpntr !! an integer input array of length `n + 1` which 635 | !! specifies the locations of the row indices in `indrow`. 636 | !! the row indices for column `j` are 637 | !! `indrow(k), k = jpntr(j),...,jpntr(j+1)-1`. 638 | !! **note** that `jpntr(n+1)-1` is then the number of non-zero 639 | !! elements of the matrix `a`. 640 | integer,dimension(*) :: Indcol !! an integer input array which contains the 641 | !! column indices for the non-zeroes in the matrix `a`. 642 | integer,dimension(*) :: Ipntr !! an integer input array of length `m + 1` which 643 | !! specifies the locations of the column indices in `indcol`. 644 | !! the column indices for row `i` are 645 | !! `indcol(k), k = ipntr(i),...,ipntr(i+1)-1`. 646 | !! **note** that `ipntr(m+1)-1` is then the number of non-zero 647 | !! elements of the matrix `a`. 648 | integer,dimension(n) :: List !! an integer input array of length `n` which specifies 649 | !! the order to be used by the sequential algorithm. 650 | !! the `j`-th column in this order is `list(j)`. 651 | integer,dimension(n) :: Ngrp !! an integer output array of length `n` which specifies 652 | !! the partition of the columns of `a`. column `jcol` belongs 653 | !! to group `ngrp(jcol)`. 654 | integer,dimension(n) :: Iwa !! an integer work array of length `n` 655 | 656 | integer :: ic , ip , ir , j , jcol , jp 657 | 658 | ! initialization block. 659 | 660 | Maxgrp = 0 661 | do jp = 1 , n 662 | Ngrp(jp) = n 663 | Iwa(jp) = 0 664 | enddo 665 | 666 | ! beginning of iteration loop. 667 | do j = 1 , n 668 | 669 | jcol = List(j) 670 | 671 | ! find all columns adjacent to column jcol. 672 | ! 673 | ! determine all positions (ir,jcol) which correspond 674 | ! to non-zeroes in the matrix. 675 | do jp = Jpntr(jcol) , Jpntr(jcol+1) - 1 676 | ir = Indrow(jp) 677 | ! for each row ir, determine all positions (ir,ic) 678 | ! which correspond to non-zeroes in the matrix. 679 | do ip = Ipntr(ir) , Ipntr(ir+1) - 1 680 | ic = Indcol(ip) 681 | ! array iwa marks the group numbers of the 682 | ! columns which are adjacent to column jcol. 683 | Iwa(Ngrp(ic)) = j 684 | enddo 685 | enddo 686 | 687 | ! assign the smallest un-marked group number to jcol. 688 | do jp = 1 , Maxgrp 689 | if ( Iwa(jp)/=j ) then 690 | Maxgrp = Maxgrp - 1 691 | exit 692 | end if 693 | enddo 694 | Maxgrp = Maxgrp + 1 695 | Ngrp(jcol) = jp 696 | 697 | enddo 698 | ! end of iteration loop. 699 | 700 | end subroutine seq 701 | !******************************************************************************* 702 | 703 | !******************************************************************************* 704 | !> 705 | ! given a column-oriented definition of the sparsity pattern 706 | ! of an `m` by `n` matrix `a`, this subroutine determines a 707 | ! row-oriented definition of the sparsity pattern of `a`. 708 | ! 709 | ! on input the column-oriented definition is specified by 710 | ! the arrays `indrow` and `jpntr`. on output the row-oriented 711 | ! definition is specified by the arrays `indcol` and `ipntr`. 712 | 713 | subroutine setr(m,n,Indrow,Jpntr,Indcol,Ipntr,Iwa) 714 | 715 | implicit none 716 | 717 | integer,intent(in) :: m !! a positive integer input variable set to the number 718 | !! of rows of `a`. 719 | integer,intent(in) :: n !! a positive integer input variable set to the number 720 | !! of columns of `a`. 721 | integer,dimension(*) :: Indrow !! an integer input array which contains the row 722 | !! indices for the non-zeroes in the matrix `a`. 723 | integer,dimension(n+1) :: Jpntr !! an integer input array of length `n + 1` which 724 | !! specifies the locations of the row indices in `indrow`. 725 | !! the row indices for column `j` are 726 | !! `indrow(k), k = jpntr(j),...,jpntr(j+1)-1`. 727 | !! **note** that `jpntr(n+1)-1` is then the number of non-zero 728 | !! elements of the matrix `a`. 729 | integer,dimension(*) :: Indcol !! an integer output array which contains the 730 | !! column indices for the non-zeroes in the matrix `a`. 731 | integer,dimension(m+1) :: Ipntr !! an integer output array of length `m + 1` which 732 | !! specifies the locations of the column indices in `indcol`. 733 | !! the column indices for row `i` are 734 | !! `indcol(k), k = ipntr(i),...,ipntr(i+1)-1`. 735 | !! **note** that `ipntr(1)` is set to 1 and that `ipntr(m+1)-1` is 736 | !! then the number of non-zero elements of the matrix `a`. 737 | integer,dimension(m) :: Iwa !! an integer work array of length `m`. 738 | 739 | integer :: ir , jcol , jp 740 | 741 | ! store in array iwa the counts of non-zeroes in the rows. 742 | 743 | do ir = 1 , m 744 | Iwa(ir) = 0 745 | enddo 746 | do jp = 1 , Jpntr(n+1) - 1 747 | Iwa(Indrow(jp)) = Iwa(Indrow(jp)) + 1 748 | enddo 749 | 750 | ! set pointers to the start of the rows in indcol. 751 | 752 | Ipntr(1) = 1 753 | do ir = 1 , m 754 | Ipntr(ir+1) = Ipntr(ir) + Iwa(ir) 755 | Iwa(ir) = Ipntr(ir) 756 | enddo 757 | 758 | ! fill indcol. 759 | 760 | do jcol = 1 , n 761 | do jp = Jpntr(jcol) , Jpntr(jcol+1) - 1 762 | ir = Indrow(jp) 763 | Indcol(Iwa(ir)) = jcol 764 | Iwa(ir) = Iwa(ir) + 1 765 | enddo 766 | enddo 767 | 768 | end subroutine setr 769 | !******************************************************************************* 770 | 771 | !******************************************************************************* 772 | !> 773 | ! given the sparsity pattern of an `m` by `n` matrix `a`, this 774 | ! subroutine determines the smallest-last ordering of the 775 | ! columns of `a`. 776 | ! 777 | ! the smallest-last ordering is defined for the loopless 778 | ! graph `g` with vertices `a(j), j = 1,2,...,n` where `a(j)` is the 779 | ! `j`-th column of `a` and with edge `(a(i),a(j))` if and only if 780 | ! columns `i` and `j` have a non-zero in the same row position. 781 | ! 782 | ! the smallest-last ordering is determined recursively by 783 | ! letting `list(k), k = n,...,1` be a column with least degree 784 | ! in the subgraph spanned by the un-ordered columns. 785 | ! 786 | ! note that the value of `m` is not needed by `slo` and is 787 | ! therefore not present in the subroutine statement. 788 | 789 | subroutine slo(n,Indrow,Jpntr,Indcol,Ipntr,Ndeg,List,Maxclq,Iwa1, & 790 | Iwa2,Iwa3,Iwa4) 791 | 792 | implicit none 793 | 794 | integer :: n !! a positive integer input variable set to the number 795 | !! of columns of `a`. 796 | integer :: Maxclq !! an integer output variable set to the size 797 | !! of the largest clique found during the ordering. 798 | integer,dimension(*) :: Indrow !! an integer input array which contains the row 799 | !! indices for the non-zeroes in the matrix `a`. 800 | integer,dimension(n+1) :: Jpntr !! an integer input array of length `n + 1` which 801 | !! specifies the locations of the row indices in `indrow`. 802 | !! the row indices for column `j` are 803 | !! `indrow(k), k = jpntr(j),...,jpntr(j+1)-1`. 804 | !! **note** that `jpntr(n+1)-1` is then the number of non-zero 805 | !! elements of the matrix `a`. 806 | integer,dimension(*) :: Indcol !! an integer input array which contains the 807 | !! column indices for the non-zeroes in the matrix `a`. 808 | integer,dimension(*) :: Ipntr !! an integer input array of length `m + 1` which 809 | !! specifies the locations of the column indices in `indcol`. 810 | !! the column indices for row `i` are 811 | !! `indcol(k), k = ipntr(i),...,ipntr(i+1)-1`. 812 | !! **note** that `ipntr(m+1)-1` is then the number of non-zero 813 | !! elements of the matrix `a`. 814 | integer,dimension(n) :: Ndeg !! an integer input array of length `n` which specifies 815 | !! the degree sequence. the degree of the `j`-th column 816 | !! of `a` is `ndeg(j)`. 817 | integer,dimension(n) :: List !! an integer output array of length `n` which specifies 818 | !! the smallest-last ordering of the columns of `a`. the `j`-th 819 | !! column in this order is `list(j)`. 820 | integer,dimension(0:n-1) :: Iwa1 !! integer work array of length `n` 821 | integer,dimension(n) :: Iwa2 !! integer work array of length `n` 822 | integer,dimension(n) :: Iwa3 !! integer work array of length `n` 823 | integer,dimension(n) :: Iwa4 !! integer work array of length `n` 824 | 825 | integer :: ic , ip , ir , jcol , jp , mindeg , numdeg , numord 826 | 827 | ! INITIALIZATION BLOCK. 828 | 829 | mindeg = n 830 | do jp = 1 , n 831 | Iwa1(jp-1) = 0 832 | Iwa4(jp) = n 833 | List(jp) = Ndeg(jp) 834 | mindeg = min(mindeg,Ndeg(jp)) 835 | enddo 836 | 837 | ! CREATE A DOUBLY-LINKED LIST TO ACCESS THE DEGREES OF THE 838 | ! COLUMNS. THE POINTERS FOR THE LINKED LIST ARE AS FOLLOWS. 839 | ! 840 | ! EACH UN-ORDERED COLUMN IC IS IN A LIST (THE DEGREE LIST) 841 | ! OF COLUMNS WITH THE SAME DEGREE. 842 | ! 843 | ! IWA1(NUMDEG) IS THE FIRST COLUMN IN THE NUMDEG LIST 844 | ! UNLESS IWA1(NUMDEG) = 0. IN THIS CASE THERE ARE 845 | ! NO COLUMNS IN THE NUMDEG LIST. 846 | ! 847 | ! IWA2(IC) IS THE COLUMN BEFORE IC IN THE DEGREE LIST 848 | ! UNLESS IWA2(IC) = 0. IN THIS CASE IC IS THE FIRST 849 | ! COLUMN IN THIS DEGREE LIST. 850 | ! 851 | ! IWA3(IC) IS THE COLUMN AFTER IC IN THE DEGREE LIST 852 | ! UNLESS IWA3(IC) = 0. IN THIS CASE IC IS THE LAST 853 | ! COLUMN IN THIS DEGREE LIST. 854 | ! 855 | ! IF IC IS AN UN-ORDERED COLUMN, THEN LIST(IC) IS THE 856 | ! DEGREE OF IC IN THE GRAPH INDUCED BY THE UN-ORDERED 857 | ! COLUMNS. IF JCOL IS AN ORDERED COLUMN, THEN LIST(JCOL) 858 | ! IS THE SMALLEST-LAST ORDER OF COLUMN JCOL. 859 | 860 | do jp = 1 , n 861 | numdeg = Ndeg(jp) 862 | Iwa2(jp) = 0 863 | Iwa3(jp) = Iwa1(numdeg) 864 | if ( Iwa1(numdeg)>0 ) Iwa2(Iwa1(numdeg)) = jp 865 | Iwa1(numdeg) = jp 866 | enddo 867 | Maxclq = 0 868 | numord = n 869 | 870 | ! BEGINNING OF ITERATION LOOP. 871 | ! 872 | ! 873 | ! MARK THE SIZE OF THE LARGEST CLIQUE 874 | ! FOUND DURING THE ORDERING. 875 | 876 | 100 if ( mindeg+1==numord .and. Maxclq==0 ) Maxclq = numord 877 | 878 | ! CHOOSE A COLUMN JCOL OF MINIMAL DEGREE MINDEG. 879 | 880 | 200 jcol = Iwa1(mindeg) 881 | if ( jcol>0 ) then 882 | List(jcol) = numord 883 | numord = numord - 1 884 | 885 | ! TERMINATION TEST. 886 | 887 | if ( numord==0 ) then 888 | 889 | ! INVERT THE ARRAY LIST. 890 | 891 | do jcol = 1 , n 892 | Iwa2(List(jcol)) = jcol 893 | enddo 894 | do jp = 1 , n 895 | List(jp) = Iwa2(jp) 896 | enddo 897 | 898 | else 899 | 900 | ! DELETE COLUMN JCOL FROM THE MINDEG LIST. 901 | 902 | Iwa1(mindeg) = Iwa3(jcol) 903 | if ( Iwa3(jcol)>0 ) Iwa2(Iwa3(jcol)) = 0 904 | 905 | ! FIND ALL COLUMNS ADJACENT TO COLUMN JCOL. 906 | 907 | Iwa4(jcol) = 0 908 | 909 | ! DETERMINE ALL POSITIONS (IR,JCOL) WHICH CORRESPOND 910 | ! TO NON-ZEROES IN THE MATRIX. 911 | 912 | do jp = Jpntr(jcol) , Jpntr(jcol+1) - 1 913 | ir = Indrow(jp) 914 | 915 | ! FOR EACH ROW IR, DETERMINE ALL POSITIONS (IR,IC) 916 | ! WHICH CORRESPOND TO NON-ZEROES IN THE MATRIX. 917 | 918 | do ip = Ipntr(ir) , Ipntr(ir+1) - 1 919 | ic = Indcol(ip) 920 | 921 | ! ARRAY IWA4 MARKS COLUMNS WHICH ARE ADJACENT TO 922 | ! COLUMN JCOL. 923 | 924 | if ( Iwa4(ic)>numord ) then 925 | Iwa4(ic) = numord 926 | 927 | ! UPDATE THE POINTERS TO THE CURRENT DEGREE LISTS. 928 | 929 | numdeg = List(ic) 930 | List(ic) = List(ic) - 1 931 | mindeg = min(mindeg,List(ic)) 932 | 933 | ! DELETE COLUMN IC FROM THE NUMDEG LIST. 934 | 935 | if ( Iwa2(ic)==0 ) then 936 | Iwa1(numdeg) = Iwa3(ic) 937 | else 938 | Iwa3(Iwa2(ic)) = Iwa3(ic) 939 | endif 940 | if ( Iwa3(ic)>0 ) Iwa2(Iwa3(ic)) = Iwa2(ic) 941 | 942 | ! ADD COLUMN IC TO THE NUMDEG-1 LIST. 943 | 944 | Iwa2(ic) = 0 945 | Iwa3(ic) = Iwa1(numdeg-1) 946 | if ( Iwa1(numdeg-1)>0 ) Iwa2(Iwa1(numdeg-1)) = ic 947 | Iwa1(numdeg-1) = ic 948 | endif 949 | enddo 950 | enddo 951 | 952 | ! END OF ITERATION LOOP. 953 | 954 | goto 100 955 | endif 956 | else 957 | mindeg = mindeg + 1 958 | goto 200 959 | endif 960 | 961 | end subroutine slo 962 | !******************************************************************************* 963 | 964 | !******************************************************************************* 965 | !> 966 | ! given the non-zero elements of an `m` by `n` matrix `a` in 967 | ! arbitrary order as specified by their row and column 968 | ! indices, this subroutine permutes these elements so 969 | ! that their column indices are in non-decreasing order. 970 | ! 971 | ! on input it is assumed that the elements are specified in 972 | ! 973 | ! `indrow(k),indcol(k), k = 1,...,nnz`. 974 | ! 975 | ! on output the elements are permuted so that `indcol` is 976 | ! in non-decreasing order. in addition, the array `jpntr` 977 | ! is set so that the row indices for column `j` are 978 | ! 979 | ! `indrow(k), k = jpntr(j),...,jpntr(j+1)-1`. 980 | ! 981 | ! note that the value of `m` is not needed by srtdat and is 982 | ! therefore not present in the subroutine statement. 983 | 984 | subroutine srtdat(n,Nnz,Indrow,Indcol,Jpntr,Iwa) 985 | 986 | implicit none 987 | 988 | integer :: n !! a positive integer input variable set to the number 989 | !! of columns of `a`. 990 | integer :: Nnz !! a positive integer input variable set to the number 991 | !! of non-zero elements of `a`. 992 | integer,dimension(Nnz) :: Indrow !! an integer array of length `nnz`. on input `indrow` 993 | !! must contain the row indices of the non-zero elements of `a`. 994 | !! on output `indrow` is permuted so that the corresponding 995 | !! column indices of `indcol` are in non-decreasing order. 996 | integer,dimension(Nnz) :: Indcol !! an integer array of length `nnz`. on input `indcol` 997 | !! must contain the column indices of the non-zero elements 998 | !! of `a`. on output `indcol` is permuted so that these indices 999 | !! are in non-decreasing order. 1000 | integer,dimension(n+1) :: Jpntr !! an integer output array of length `n + 1` which 1001 | !! specifies the locations of the row indices in the output 1002 | !! `indrow`. the row indices for column `j` are 1003 | !! `indrow(k), k = jpntr(j),...,jpntr(j+1)-1`. 1004 | !! **note** that `jpntr(1)` is set to 1 and that `jpntr(n+1)-1` 1005 | !! is then `nnz`. 1006 | integer,dimension(n) :: Iwa !! an integer work array of length `n`. 1007 | 1008 | integer :: i , j , k , l 1009 | 1010 | ! store in array iwa the counts of non-zeroes in the columns. 1011 | 1012 | do j = 1 , n 1013 | Iwa(j) = 0 1014 | enddo 1015 | do k = 1 , Nnz 1016 | Iwa(Indcol(k)) = Iwa(Indcol(k)) + 1 1017 | enddo 1018 | 1019 | ! set pointers to the start of the columns in indrow. 1020 | 1021 | Jpntr(1) = 1 1022 | do j = 1 , n 1023 | Jpntr(j+1) = Jpntr(j) + Iwa(j) 1024 | Iwa(j) = Jpntr(j) 1025 | enddo 1026 | k = 1 1027 | 1028 | ! begin in-place sort. 1029 | 1030 | do 1031 | j = Indcol(k) 1032 | if ( k>=Jpntr(j) ) then 1033 | ! current element is in position. now examine the 1034 | ! next element or the first un-sorted element in 1035 | ! the j-th group. 1036 | k = max(k+1,Iwa(j)) 1037 | else 1038 | ! current element is not in position. place element 1039 | ! in position and make the displaced element the 1040 | ! current element. 1041 | l = Iwa(j) 1042 | Iwa(j) = Iwa(j) + 1 1043 | i = Indrow(k) 1044 | Indrow(k) = Indrow(l) 1045 | Indcol(k) = Indcol(l) 1046 | Indrow(l) = i 1047 | Indcol(l) = j 1048 | endif 1049 | if ( k>Nnz ) exit 1050 | end do 1051 | 1052 | end subroutine srtdat 1053 | !******************************************************************************* 1054 | 1055 | !******************************************************************************* 1056 | !> 1057 | ! Given a consistent partition of the columns of an `m` by `n` 1058 | ! jacobian matrix into groups, this subroutine computes 1059 | ! approximations to those columns in a given group. the 1060 | ! approximations are stored into either a column-oriented 1061 | ! or a row-oriented pattern. 1062 | ! 1063 | ! a partition is consistent if the columns in any group 1064 | ! do not have a non-zero in the same row position. 1065 | ! 1066 | ! approximations to the columns of the jacobian matrix in a 1067 | ! given group can be obtained by specifying a difference 1068 | ! parameter array `d` with `d(jcol)` non-zero if and only if 1069 | ! `jcol` is a column in the group, and an approximation to 1070 | ! `jac*d` where `jac` denotes the jacobian matrix of a mapping f. 1071 | ! 1072 | ! `d` can be defined with the following segment of code. 1073 | !```fortran 1074 | ! do jcol = 1, n 1075 | ! d(jcol) = 0.0 1076 | ! if (ngrp(jcol) == numgrp) d(jcol) = eta(jcol) 1077 | ! end do 1078 | !``` 1079 | ! in the above code `numgrp` is the given group number, 1080 | ! `ngrp(jcol)` is the group number of column `jcol`, and 1081 | ! `eta(jcol)` is the difference parameter used to 1082 | ! approximate column `jcol` of the jacobian matrix. 1083 | ! suitable values for the array `eta` must be provided. 1084 | ! 1085 | ! as mentioned above, an approximation to `jac*d` must 1086 | ! also be provided. for example, the approximation 1087 | !```fortran 1088 | ! f(x+d) - f(x) 1089 | !``` 1090 | ! corresponds to the forward difference formula at `x`. 1091 | 1092 | subroutine fdjs(m,n,Col,Ind,Npntr,Ngrp,Numgrp,d,Fjacd,Fjac) 1093 | 1094 | implicit none 1095 | 1096 | integer,intent(in) :: m !! a positive integer input variable set to the number 1097 | !! of rows of the jacobian matrix. 1098 | integer,intent(in) :: n !! a positive integer input variable set to the number 1099 | !! of columns of the jacobian matrix. 1100 | integer :: Numgrp !! a positive integer input variable set to a group 1101 | !! number in the partition. the columns of the jacobian 1102 | !! matrix in this group are to be estimated on this call. 1103 | integer,dimension(*) :: Ind !! an integer input array which contains the row 1104 | !! indices for the non-zeroes in the jacobian matrix 1105 | !! if `col` is true, and contains the column indices for 1106 | !! the non-zeroes in the jacobian matrix if `col` is false. 1107 | integer,dimension(*) :: Npntr !! an integer input array which specifies the 1108 | !! locations of the row indices in `ind` if `col` is true, and 1109 | !! specifies the locations of the column indices in `ind` if 1110 | !! `col` is false. if `col` is true, the indices for column `j` are 1111 | !! `ind(k), k = npntr(j),...,npntr(j+1)-1`. 1112 | !! if `col` is false, the indices for row `i` are 1113 | !! `ind(k), k = npntr(i),...,npntr(i+1)-1`. 1114 | !! ***Note*** that `npntr(n+1)-1` if `col` is true, or `npntr(m+1)-1` 1115 | !! if `col` is false, is then the number of non-zero elements 1116 | !! of the jacobian matrix. 1117 | integer,dimension(n) :: Ngrp !! an integer input array of length `n` which specifies 1118 | !! the partition of the columns of the jacobian matrix. 1119 | !! column `jcol` belongs to group `ngrp(jcol)`. 1120 | real(wp),dimension(n) :: d !! an input array of length `n` which contains the 1121 | !! difference parameter vector for the estimate of 1122 | !! the jacobian matrix columns in group `numgrp`. 1123 | real(wp),dimension(m) :: Fjacd !! an input array of length `m` which contains 1124 | !! an approximation to the difference vector `jac*d`, 1125 | !! where `jac` denotes the jacobian matrix. 1126 | real(wp),dimension(*) :: Fjac !! an output array of length `nnz`, where `nnz` is the 1127 | !! number of its non-zero elements. at each call of `fdjs`, 1128 | !! `fjac` is updated to include the non-zero elements of the 1129 | !! jacobian matrix for those columns in group `numgrp`. `fjac` 1130 | !! should not be altered between successive calls to `fdjs`. 1131 | logical,intent(in) :: Col !! a logical input variable. if `col` is set true, then the 1132 | !! jacobian approximations are stored into a column-oriented 1133 | !! pattern. if `col` is set false, then the jacobian 1134 | !! approximations are stored into a row-oriented pattern. 1135 | 1136 | integer :: ip , irow , jcol , jp 1137 | 1138 | ! compute estimates of jacobian matrix columns in group 1139 | ! numgrp. the array fjacd must contain an approximation 1140 | ! to jac*d, where jac denotes the jacobian matrix and d 1141 | ! is a difference parameter vector with d(jcol) non-zero 1142 | ! if and only if jcol is a column in group numgrp. 1143 | 1144 | if ( Col ) then ! column orientation. 1145 | 1146 | do jcol = 1 , n 1147 | if ( Ngrp(jcol)==Numgrp ) then 1148 | do jp = Npntr(jcol) , Npntr(jcol+1) - 1 1149 | irow = Ind(jp) 1150 | Fjac(jp) = Fjacd(irow)/d(jcol) 1151 | enddo 1152 | endif 1153 | enddo 1154 | 1155 | else ! row orientation. 1156 | 1157 | do irow = 1 , m 1158 | do ip = Npntr(irow) , Npntr(irow+1) - 1 1159 | jcol = Ind(ip) 1160 | if ( Ngrp(jcol)==Numgrp ) then 1161 | Fjac(ip) = Fjacd(irow)/d(jcol) 1162 | exit 1163 | endif 1164 | enddo 1165 | enddo 1166 | 1167 | endif 1168 | 1169 | end subroutine fdjs 1170 | !******************************************************************************* 1171 | 1172 | !******************************************************************************* 1173 | end module dsm_module 1174 | !******************************************************************************* 1175 | -------------------------------------------------------------------------------- /src/kinds_module.F90: -------------------------------------------------------------------------------- 1 | !******************************************************************************* 2 | !> 3 | ! Numeric kinds for NumDiff. 4 | ! 5 | !@note The default real kind (`wp`) can be 6 | ! changed using optional preprocessor flags. 7 | ! This library was built with real kind: 8 | #ifdef REAL32 9 | ! `real(kind=real32)` [4 bytes] 10 | #elif REAL64 11 | ! `real(kind=real64)` [8 bytes] 12 | #elif REAL128 13 | ! `real(kind=real128)` [16 bytes] 14 | #else 15 | ! `real(kind=real64)` [8 bytes] 16 | #endif 17 | 18 | module numdiff_kinds_module 19 | 20 | use iso_fortran_env 21 | 22 | private 23 | 24 | #ifdef REAL32 25 | integer,parameter,public :: wp = real32 !! default real kind [4 bytes] 26 | #elif REAL64 27 | integer,parameter,public :: wp = real64 !! default real kind [8 bytes] 28 | #elif REAL128 29 | integer,parameter,public :: wp = real128 !! default real kind [16 bytes] 30 | #else 31 | integer,parameter,public :: wp = real64 !! default real kind [8 bytes] 32 | #endif 33 | 34 | end module numdiff_kinds_module 35 | !******************************************************************************* -------------------------------------------------------------------------------- /src/utilities_module.f90: -------------------------------------------------------------------------------- 1 | !******************************************************************************* 2 | !> author: Jacob Williams 3 | ! 4 | ! Utility routines. 5 | 6 | module numdiff_utilities_module 7 | 8 | use numdiff_kinds_module 9 | 10 | integer,parameter :: max_size_for_insertion_sort = 20 !! max size for using insertion sort. 11 | 12 | private 13 | 14 | interface expand_vector 15 | module procedure :: expand_vector_int, expand_vector_real 16 | end interface expand_vector 17 | public :: expand_vector 18 | 19 | interface unique 20 | module procedure :: unique_int, unique_real 21 | end interface unique 22 | public :: unique 23 | 24 | interface sort_ascending 25 | module procedure :: sort_ascending_int, sort_ascending_real 26 | end interface sort_ascending 27 | public :: sort_ascending 28 | 29 | interface swap 30 | module procedure :: swap_int, swap_real 31 | end interface swap 32 | 33 | public :: equal_within_tol 34 | public :: divide_interval 35 | 36 | contains 37 | !******************************************************************************* 38 | 39 | !******************************************************************************* 40 | !> 41 | ! Add elements to the integer vector in chunks. 42 | 43 | pure subroutine expand_vector_int(vec,n,chunk_size,val,finished) 44 | 45 | implicit none 46 | 47 | integer,dimension(:),allocatable,intent(inout) :: vec 48 | integer,intent(inout) :: n !! counter for last element added to `vec`. 49 | !! must be initialized to `size(vec)` 50 | !! (or 0 if not allocated) before first call 51 | integer,intent(in) :: chunk_size !! allocate `vec` in blocks of this size (>0) 52 | integer,intent(in),optional :: val !! the value to add to `vec` 53 | logical,intent(in),optional :: finished !! set to true to return `vec` 54 | !! as its correct size (`n`) 55 | 56 | integer,dimension(:),allocatable :: tmp !! temporary array 57 | 58 | if (present(val)) then 59 | if (allocated(vec)) then 60 | if (n==size(vec)) then 61 | ! have to add another chunk: 62 | allocate(tmp(size(vec)+chunk_size)) 63 | tmp(1:size(vec)) = vec 64 | call move_alloc(tmp,vec) 65 | end if 66 | n = n + 1 67 | else 68 | ! the first element: 69 | allocate(vec(chunk_size)) 70 | n = 1 71 | end if 72 | vec(n) = val 73 | end if 74 | 75 | if (present(finished)) then 76 | if (finished) then 77 | ! set vec to actual size (n): 78 | if (allocated(tmp)) deallocate(tmp) 79 | allocate(tmp(n)) 80 | tmp = vec(1:n) 81 | call move_alloc(tmp,vec) 82 | end if 83 | end if 84 | 85 | end subroutine expand_vector_int 86 | !******************************************************************************* 87 | 88 | !******************************************************************************* 89 | !> 90 | ! Add elements to the real vector in chunks. 91 | 92 | pure subroutine expand_vector_real(vec,n,chunk_size,val,finished) 93 | 94 | implicit none 95 | 96 | real(wp),dimension(:),allocatable,intent(inout) :: vec 97 | integer,intent(inout) :: n !! counter for last element added to `vec`. 98 | !! must be initialized to `size(vec)` 99 | !! (or 0 if not allocated) before first call 100 | integer,intent(in) :: chunk_size !! allocate `vec` in blocks of this size (>0) 101 | real(wp),intent(in),optional :: val !! the value to add to `vec` 102 | logical,intent(in),optional :: finished !! set to true to return `vec` 103 | !! as its correct size (`n`) 104 | 105 | real(wp),dimension(:),allocatable :: tmp !! temporary array 106 | 107 | if (present(val)) then 108 | if (allocated(vec)) then 109 | if (n==size(vec)) then 110 | ! have to add another chunk: 111 | allocate(tmp(size(vec)+chunk_size)) 112 | tmp(1:size(vec)) = vec 113 | call move_alloc(tmp,vec) 114 | end if 115 | n = n + 1 116 | else 117 | ! the first element: 118 | allocate(vec(chunk_size)) 119 | n = 1 120 | end if 121 | vec(n) = val 122 | end if 123 | 124 | if (present(finished)) then 125 | if (finished) then 126 | ! set vec to actual size (n): 127 | if (allocated(tmp)) deallocate(tmp) 128 | allocate(tmp(n)) 129 | tmp = vec(1:n) 130 | call move_alloc(tmp,vec) 131 | end if 132 | end if 133 | 134 | end subroutine expand_vector_real 135 | !******************************************************************************* 136 | 137 | !******************************************************************************* 138 | !> 139 | ! Returns only the unique elements of the vector (sorted in ascending order). 140 | 141 | function unique_int(vec,chunk_size) result(ivec_unique) 142 | 143 | implicit none 144 | 145 | integer,dimension(:),intent(in) :: vec !! a vector of integers 146 | integer,intent(in) :: chunk_size !! chunk size for adding to arrays 147 | integer,dimension(:),allocatable :: ivec_unique !! unique elements of `ivec` 148 | 149 | integer,dimension(size(vec)) :: ivec !! temp copy of vec 150 | integer :: i !! counter 151 | integer :: n !! number of unique elements 152 | 153 | ! first we sort it: 154 | ivec = vec ! make a copy 155 | call sort_ascending(ivec) 156 | 157 | ! add the first element: 158 | n = 1 159 | ivec_unique = [ivec(1)] 160 | 161 | ! walk through array and get the unique ones: 162 | if (size(ivec)>1) then 163 | do i = 2, size(ivec) 164 | if (ivec(i)/=ivec(i-1)) then 165 | call expand_vector(ivec_unique,n,chunk_size,val=ivec(i)) 166 | end if 167 | end do 168 | call expand_vector(ivec_unique,n,chunk_size,finished=.true.) 169 | end if 170 | 171 | end function unique_int 172 | !******************************************************************************* 173 | 174 | !******************************************************************************* 175 | !> 176 | ! Returns only the unique elements of the vector (sorted in ascending order). 177 | 178 | function unique_real(vec,chunk_size) result(ivec_unique) 179 | 180 | implicit none 181 | 182 | real(wp),dimension(:),intent(in) :: vec !! a vector of integers 183 | integer,intent(in) :: chunk_size !! chunk size for adding to arrays 184 | real(wp),dimension(:),allocatable :: ivec_unique !! unique elements of `ivec` 185 | 186 | real(wp),dimension(size(vec)) :: ivec !! temp copy of vec 187 | integer :: i !! counter 188 | integer :: n !! number of unique elements 189 | 190 | ! first we sort it: 191 | ivec = vec ! make a copy 192 | call sort_ascending(ivec) 193 | 194 | ! add the first element: 195 | n = 1 196 | ivec_unique = [ivec(1)] 197 | 198 | ! walk through array and get the unique ones: 199 | if (size(ivec)>1) then 200 | do i = 2, size(ivec) 201 | if (ivec(i)/=ivec(i-1)) then 202 | call expand_vector(ivec_unique,n,chunk_size,val=ivec(i)) 203 | end if 204 | end do 205 | call expand_vector(ivec_unique,n,chunk_size,finished=.true.) 206 | end if 207 | 208 | end function unique_real 209 | !******************************************************************************* 210 | 211 | !******************************************************************************* 212 | !> 213 | ! Sorts an integer array `ivec` in increasing order. 214 | ! Uses a basic recursive quicksort 215 | ! (with insertion sort for partitions with \(\le\) 20 elements). 216 | 217 | subroutine sort_ascending_int(ivec) 218 | 219 | implicit none 220 | 221 | integer,dimension(:),intent(inout) :: ivec 222 | 223 | call quicksort(1,size(ivec)) 224 | 225 | contains 226 | 227 | recursive subroutine quicksort(ilow,ihigh) 228 | 229 | !! Sort the array 230 | 231 | implicit none 232 | 233 | integer,intent(in) :: ilow 234 | integer,intent(in) :: ihigh 235 | 236 | integer :: ipivot !! pivot element 237 | integer :: i !! counter 238 | integer :: j !! counter 239 | 240 | if ( ihigh-ilow<=max_size_for_insertion_sort .and. ihigh>ilow ) then 241 | 242 | ! do insertion sort: 243 | do i = ilow + 1,ihigh 244 | do j = i,ilow + 1,-1 245 | if ( ivec(j) < ivec(j-1) ) then 246 | call swap(ivec(j),ivec(j-1)) 247 | else 248 | exit 249 | end if 250 | end do 251 | end do 252 | 253 | elseif ( ihigh-ilow>max_size_for_insertion_sort ) then 254 | 255 | ! do the normal quicksort: 256 | call partition(ilow,ihigh,ipivot) 257 | call quicksort(ilow,ipivot - 1) 258 | call quicksort(ipivot + 1,ihigh) 259 | 260 | end if 261 | 262 | end subroutine quicksort 263 | 264 | subroutine partition(ilow,ihigh,ipivot) 265 | 266 | !! Partition the array, based on the 267 | !! lexical ivecing comparison. 268 | 269 | implicit none 270 | 271 | integer,intent(in) :: ilow 272 | integer,intent(in) :: ihigh 273 | integer,intent(out) :: ipivot 274 | 275 | integer :: i,ip 276 | 277 | call swap(ivec(ilow),ivec((ilow+ihigh)/2)) 278 | ip = ilow 279 | do i = ilow + 1, ihigh 280 | if ( ivec(i) < ivec(ilow) ) then 281 | ip = ip + 1 282 | call swap(ivec(ip),ivec(i)) 283 | end if 284 | end do 285 | call swap(ivec(ilow),ivec(ip)) 286 | ipivot = ip 287 | 288 | end subroutine partition 289 | 290 | end subroutine sort_ascending_int 291 | !******************************************************************************* 292 | 293 | !******************************************************************************* 294 | !> 295 | ! Sorts a real array `ivec` in increasing order. 296 | ! Uses a basic recursive quicksort 297 | ! (with insertion sort for partitions with \(\le\) 20 elements). 298 | 299 | subroutine sort_ascending_real(ivec) 300 | 301 | implicit none 302 | 303 | real(wp),dimension(:),intent(inout) :: ivec 304 | 305 | call quicksort(1,size(ivec)) 306 | 307 | contains 308 | 309 | recursive subroutine quicksort(ilow,ihigh) 310 | 311 | !! Sort the array 312 | 313 | implicit none 314 | 315 | integer,intent(in) :: ilow 316 | integer,intent(in) :: ihigh 317 | 318 | integer :: ipivot !! pivot element 319 | integer :: i !! counter 320 | integer :: j !! counter 321 | 322 | if ( ihigh-ilow<=max_size_for_insertion_sort .and. ihigh>ilow ) then 323 | 324 | ! do insertion sort: 325 | do i = ilow + 1,ihigh 326 | do j = i,ilow + 1,-1 327 | if ( ivec(j) < ivec(j-1) ) then 328 | call swap(ivec(j),ivec(j-1)) 329 | else 330 | exit 331 | end if 332 | end do 333 | end do 334 | 335 | elseif ( ihigh-ilow>max_size_for_insertion_sort ) then 336 | 337 | ! do the normal quicksort: 338 | call partition(ilow,ihigh,ipivot) 339 | call quicksort(ilow,ipivot - 1) 340 | call quicksort(ipivot + 1,ihigh) 341 | 342 | end if 343 | 344 | end subroutine quicksort 345 | 346 | subroutine partition(ilow,ihigh,ipivot) 347 | 348 | !! Partition the array, based on the 349 | !! lexical ivecing comparison. 350 | 351 | implicit none 352 | 353 | integer,intent(in) :: ilow 354 | integer,intent(in) :: ihigh 355 | integer,intent(out) :: ipivot 356 | 357 | integer :: i,ip 358 | 359 | call swap(ivec(ilow),ivec((ilow+ihigh)/2)) 360 | ip = ilow 361 | do i = ilow + 1, ihigh 362 | if ( ivec(i) < ivec(ilow) ) then 363 | ip = ip + 1 364 | call swap(ivec(ip),ivec(i)) 365 | end if 366 | end do 367 | call swap(ivec(ilow),ivec(ip)) 368 | ipivot = ip 369 | 370 | end subroutine partition 371 | 372 | end subroutine sort_ascending_real 373 | !******************************************************************************* 374 | 375 | !******************************************************************************* 376 | !> 377 | ! Swap two integer values. 378 | 379 | pure elemental subroutine swap_int(i1,i2) 380 | 381 | implicit none 382 | 383 | integer,intent(inout) :: i1 384 | integer,intent(inout) :: i2 385 | 386 | integer :: tmp 387 | 388 | tmp = i1 389 | i1 = i2 390 | i2 = tmp 391 | 392 | end subroutine swap_int 393 | !******************************************************************************* 394 | 395 | !******************************************************************************* 396 | !> 397 | ! Swap two integer values. 398 | 399 | pure elemental subroutine swap_real(i1,i2) 400 | 401 | implicit none 402 | 403 | real(wp),intent(inout) :: i1 404 | real(wp),intent(inout) :: i2 405 | 406 | real(wp) :: tmp 407 | 408 | tmp = i1 409 | i1 = i2 410 | i2 = tmp 411 | 412 | end subroutine swap_real 413 | !******************************************************************************* 414 | 415 | !******************************************************************************* 416 | !> 417 | ! Returns true if the values in the array are the same 418 | ! (to within the specified absolute tolerance). 419 | 420 | pure function equal_within_tol(vals,tol) result (equal) 421 | 422 | implicit none 423 | 424 | real(wp),dimension(:),intent(in) :: vals !! a set of values 425 | real(wp),intent(in) :: tol !! a positive tolerance value 426 | logical :: equal !! true if they are equal 427 | !! within the tolerance 428 | 429 | equal = all ( abs(vals - vals(1)) <= abs(tol) ) 430 | 431 | end function equal_within_tol 432 | !******************************************************************************* 433 | 434 | !******************************************************************************* 435 | !> 436 | ! Returns a set of slightly randomized equally-spaced 437 | ! points that divide an interval. 438 | ! 439 | !### Example: 440 | ! 441 | ! for `num_points` = 3: 442 | !``` 443 | ! o---|---|---|---o 444 | ! 1 2 3 445 | !``` 446 | ! returns: `[0.25308641972530865, 0.5061728394506173, 0.759259259175926]`. 447 | 448 | function divide_interval(num_points) result(points) 449 | 450 | implicit none 451 | 452 | integer,intent(in) :: num_points !! the number of points in the interval 453 | real(wp),dimension(:),allocatable :: points !! the resultant vector 454 | 455 | real(wp),parameter :: noise = 1.012345678901234567_wp !! a noise value. Not a round number 456 | !! so as to avoid freak zeros in the 457 | !! jacobian 458 | real(wp),parameter :: min_val = 10.0_wp * epsilon(1.0_wp) !! the minimize distance from the lower bound 459 | real(wp),parameter :: max_val = 1.0_wp - min_val !! the minimize distance from the upper bound 460 | 461 | integer :: i !! counter 462 | real(wp) :: delta !! step size 463 | real(wp),dimension(:),allocatable :: tmp !! a temp array to hold the values 464 | 465 | delta = 1.0_wp / (num_points + 1) 466 | 467 | allocate(tmp(num_points)) 468 | do i = 1, num_points 469 | tmp(i) = min(max(min_val,delta*i*noise),max_val) 470 | end do 471 | ! this is to protect for the min/max case if there 472 | ! are enough points so that some are duplicated near 473 | ! the bounds: 474 | points = unique(tmp,chunk_size=10) 475 | 476 | end function divide_interval 477 | !******************************************************************************* 478 | 479 | !******************************************************************************* 480 | end module numdiff_utilities_module 481 | !******************************************************************************* 482 | -------------------------------------------------------------------------------- /tests/dsm_test.f90: -------------------------------------------------------------------------------- 1 | program dsm_test 2 | 3 | !! This is a test program for subroutines [[dsm]] and [[fdjs]]. 4 | !! the test data represents a neutron kinetics problem. 5 | !! 6 | !!### Reference 7 | !! * Argonne National Laboratory. MINPACK Project. July 1983. 8 | !! Thomas F. Coleman, Burton S. Garbow, Jorge J. More 9 | !! * Thomas F. Coleman, Burton S. Garbow, Jorge J. More, "Algorithm 618: 10 | !! FORTRAN subroutines for estimating sparse Jacobian Matrices", 11 | !! ACM Transactions on Mathematical Software (TOMS), 12 | !! Volume 10 Issue 3, Sept. 1984, Pages 346-347 13 | 14 | use dsm_module 15 | use iso_fortran_env, only: output_unit 16 | use numdiff_kinds_module, only: wp 17 | 18 | implicit none 19 | 20 | integer,parameter :: nwrite = output_unit !! unit for printing 21 | 22 | integer i , info , ip , j , jp , l , m , maxgrp , maxrow , & 23 | mingrp , minrow , n , nnz , numgrp 24 | integer indcol(6000) , indrow(6000) , ipntr(1201) , jpntr(1201) , & 25 | ngrp(1200) 26 | logical col 27 | real(wp) :: dnsm , errij , errmax , fjact , fjactr , sum 28 | real(wp) :: d(1200) , fjac(6000) , fjacd(1200) , fvec(1200) , x(1200) , & 29 | xd(1200) 30 | 31 | col = .true. 32 | ! 33 | ! TEST FOR DSM AND FDJS. 34 | ! 35 | write (nwrite,99001) 36 | ! 37 | ! FORMAT STATEMENTS. 38 | ! 39 | 99001 format (//' TESTS FOR DSM AND FDJS - NEUTRON KINETICS PROBLEM'// & 40 | &' STATISTICS GENERATED '//' N - NUMBER OF COLUMNS '/& 41 | &' NNZ - NUMBER OF NON-ZERO ELEMENTS'/ & 42 | &' DNSM - MATRIX DENSITY (PERCENTAGE)'/ & 43 | &' MINROW - MINIMUM NUMBER OF NON-ZEROS IN ANY ROW'/ & 44 | &' MAXROW - MAXIMUM NUMBER OF NON-ZEROS IN ANY ROW'/ & 45 | &' MINGRP - LOWER BOUND ON NUMBER OF GROUPS'/ & 46 | &' MAXGRP - NUMBER OF GROUPS DETERMINED BY DSM'//) 47 | do n = 300 , 1200 , 300 48 | write (nwrite,99002) 49 | 99002 format (//3x,'N',6x,'NNZ',5x,'DNSM',5x,'MINROW',4x,'MAXROW',4x,& 50 | &'MINGRP',4x,'MAXGRP'//) 51 | ! 52 | ! DEFINITION OF SPARSITY PATTERN. 53 | ! 54 | m = n 55 | l = n/3 56 | nnz = 0 57 | do j = 1 , n 58 | nnz = nnz + 1 59 | indrow(nnz) = j 60 | indcol(nnz) = j 61 | if ( mod(j,l)/=0 ) then 62 | nnz = nnz + 1 63 | indrow(nnz) = j + 1 64 | indcol(nnz) = j 65 | endif 66 | if ( j<=2*l ) then 67 | nnz = nnz + 1 68 | indrow(nnz) = j + l 69 | indcol(nnz) = j 70 | if ( mod(j,l)/=1 ) then 71 | nnz = nnz + 1 72 | indrow(nnz) = j - 1 73 | indcol(nnz) = j 74 | endif 75 | endif 76 | nnz = nnz + 1 77 | if ( j>l ) then 78 | indrow(nnz) = j - l 79 | else 80 | indrow(nnz) = j + 2*l 81 | endif 82 | indcol(nnz) = j 83 | enddo 84 | ! 85 | ! CALL DSM. 86 | ! 87 | call dsm(m,n,nnz,indrow,indcol,ngrp,maxgrp,mingrp,info,ipntr,jpntr) 88 | if ( info<=0 ) write (nwrite,99003) info 89 | 99003 format (//' *** MISTAKE IN INPUT DATA, INFO IS ***',i6) 90 | ! 91 | ! STATISTICS FOR THE MATRIX. 92 | ! 93 | maxrow = 0 94 | minrow = n 95 | do i = 1 , m 96 | maxrow = max(maxrow,ipntr(i+1)-ipntr(i)) 97 | minrow = min(minrow,ipntr(i+1)-ipntr(i)) 98 | enddo 99 | dnsm = real(100*nnz,wp)/real(m*n,wp) 100 | write (nwrite,99004) n , nnz , dnsm , minrow , maxrow , & 101 | & mingrp , maxgrp 102 | 99004 format (2(i5,3x),f6.2,4x,4(i5,5x)) 103 | ! 104 | ! TEST FOR FDJS. 105 | ! 106 | do j = 1 , n 107 | x(j) = real(j,wp)/real(n,wp) 108 | enddo 109 | call fcn(n,x,indcol,ipntr,fvec) 110 | ! 111 | ! APPROXIMATE THE JACOBIAN MATRIX. 112 | ! 113 | do numgrp = 1 , maxgrp 114 | do j = 1 , n 115 | d(j) = 0.0_wp 116 | if ( ngrp(j)==numgrp ) d(j) = 1.0e-6_wp !d(j) = 0.001_wp 117 | xd(j) = x(j) + d(j) 118 | enddo 119 | call fcn(n,xd,indcol,ipntr,fjacd) 120 | do i = 1 , m 121 | fjacd(i) = fjacd(i) - fvec(i) 122 | enddo 123 | if ( col ) then 124 | call fdjs(m,n,col,indrow,jpntr,ngrp,numgrp,d,fjacd,fjac) 125 | else 126 | call fdjs(m,n,col,indcol,ipntr,ngrp,numgrp,d,fjacd,fjac) 127 | endif 128 | enddo 129 | ! 130 | ! TEST THE APPROXIMATION TO THE JACOBIAN. 131 | ! 132 | errmax = 0.0_wp 133 | if ( col ) then 134 | ! 135 | ! TEST FOR THE COLUMN-ORIENTED DEFINITION OF 136 | ! THE SPARSITY PATTERN. 137 | ! 138 | do j = 1 , n 139 | do jp = jpntr(j) , jpntr(j+1) - 1 140 | i = indrow(jp) 141 | sum = 0.0_wp 142 | do ip = ipntr(i) , ipntr(i+1) - 1 143 | sum = sum + x(indcol(ip)) 144 | enddo 145 | sum = sum + x(i) 146 | fjact = 1.0_wp + 2.0_wp*sum 147 | if ( i==j ) fjact = 2.0_wp*fjact 148 | errij = fjac(jp) - fjact 149 | if ( fjact/=0.0_wp ) errij = errij/fjact 150 | errmax = max(errmax,abs(errij)) 151 | enddo 152 | enddo 153 | else 154 | ! 155 | ! TEST FOR THE ROW-ORIENTED DEFINITION OF 156 | ! THE SPARSITY PATTERN. 157 | ! 158 | do i = 1 , m 159 | sum = 0.0_wp 160 | do ip = ipntr(i) , ipntr(i+1) - 1 161 | sum = sum + x(indcol(ip)) 162 | enddo 163 | sum = sum + x(i) 164 | fjactr = 1.0_wp + 2.0_wp*sum 165 | do ip = ipntr(i) , ipntr(i+1) - 1 166 | j = indcol(ip) 167 | fjact = fjactr 168 | if ( i==j ) fjact = 2.0_wp*fjact 169 | errij = fjac(ip) - fjact 170 | if ( fjact/=0.0_wp ) errij = errij/fjact 171 | errmax = max(errmax,abs(errij)) 172 | enddo 173 | enddo 174 | endif 175 | write (nwrite,99005) errmax 176 | 99005 format (//' LARGEST RELATIVE ERROR OF APPROXIMATION IS',e10.2) 177 | col = .not.col 178 | enddo 179 | stop 180 | 181 | 182 | contains 183 | 184 | subroutine fcn(n,x,Indcol,Ipntr,Fvec) 185 | 186 | !! Function subroutine for testing [[fdjs]]. 187 | 188 | implicit none 189 | 190 | integer n 191 | integer Indcol(*) , Ipntr(n+1) 192 | real(wp) ::x(n) , Fvec(n) 193 | 194 | integer i , ip 195 | real(wp) :: sum 196 | 197 | do i = 1 , n 198 | sum = 0.0_wp 199 | do ip = Ipntr(i) , Ipntr(i+1) - 1 200 | sum = sum + x(Indcol(ip)) 201 | enddo 202 | sum = sum + x(i) 203 | Fvec(i) = sum*(1.0_wp+sum) + 1.0_wp 204 | enddo 205 | 206 | end subroutine fcn 207 | 208 | end program dsm_test 209 | -------------------------------------------------------------------------------- /tests/test1.f90: -------------------------------------------------------------------------------- 1 | !******************************************************************************* 2 | !> author: Jacob Williams 3 | ! date: October 31, 2016 4 | ! 5 | ! Test1 for the numerical differentiation module. 6 | 7 | program test1 8 | 9 | use iso_fortran_env, only: output_unit, error_unit 10 | use numerical_differentiation_module 11 | use numdiff_kinds_module, only: wp 12 | 13 | implicit none 14 | 15 | integer,parameter :: n = 10 16 | integer,parameter :: m = 6 17 | real(wp),dimension(n),parameter :: x = 1.0_wp 18 | real(wp),dimension(n),parameter :: xlow = -10.0_wp 19 | real(wp),dimension(n),parameter :: xhigh = 10.0_wp 20 | real(wp),dimension(n),parameter :: dpert = 1.0e-5_wp 21 | integer,parameter :: perturb_mode = 1 22 | integer,parameter :: cache_size = 0 !! `0` indicates not to use cache 23 | integer,parameter :: sparsity_mode = 4 24 | 25 | type(numdiff_type) :: my_prob 26 | integer :: i !! counter 27 | integer :: j !! counter 28 | real(wp),dimension(:),allocatable :: jac 29 | character(len=:),allocatable :: formula 30 | type(finite_diff_method) :: fd 31 | logical :: status_ok 32 | type(meth_array) :: meths 33 | integer :: func_evals !! function evaluation counter 34 | integer,dimension(:),allocatable :: methods !! array of method IDs 35 | character(len=:),allocatable :: error_msg !! error message string 36 | 37 | methods = [(i, i = 1, 44)] 38 | methods = [methods, 500,600,700,800] ! these only have central diffs 39 | 40 | do j=1,size(methods) ! try different finite diff methods 41 | 42 | i = methods(j) 43 | 44 | call get_finite_diff_formula(i,formula) 45 | if (formula=='') then 46 | write(output_unit,*) 'id ', i , 'not available' 47 | cycle 48 | end if 49 | func_evals = 0 50 | call my_prob%destroy() 51 | call my_prob%initialize(n,m,xlow,xhigh,perturb_mode,dpert,& 52 | problem_func=my_func,& 53 | sparsity_mode=sparsity_mode,& 54 | jacobian_method=i,& 55 | partition_sparsity_pattern=.false.,& 56 | cache_size=cache_size) 57 | if (my_prob%failed()) then 58 | call my_prob%get_error_status(error_msg=error_msg) 59 | write(error_unit,'(A)') error_msg 60 | stop 61 | end if 62 | 63 | call my_prob%compute_jacobian(x,jac) 64 | if (my_prob%failed()) then 65 | call my_prob%get_error_status(error_msg=error_msg) 66 | write(error_unit,'(A)') error_msg 67 | stop 68 | end if 69 | 70 | if (i==1) then 71 | write(output_unit,'(A)') '' 72 | call my_prob%print_sparsity_pattern(output_unit) 73 | write(output_unit,'(A)') '' 74 | call my_prob%print_sparsity_matrix(output_unit) 75 | write(output_unit,'(A)') '' 76 | 77 | write(output_unit,'(A)') '' 78 | write(output_unit,'(A)') '--------------------------------------' 79 | write(output_unit,'(A,I4)') ' specify method [no partitioning] : ',i 80 | write(output_unit,'(A)') '--------------------------------------' 81 | write(output_unit,'(A)') '' 82 | end if 83 | 84 | write(output_unit,'(A)') formula 85 | write(output_unit,'(A)') '' 86 | write(output_unit,'(A,1X,*(F27.16,","))') 'jac =',jac 87 | write(output_unit,'(A,1X,I5)') 'function evaluations:',func_evals 88 | write(output_unit,'(A)') '' 89 | 90 | end do 91 | 92 | do j=1,size(methods) ! try different finite diff methods 93 | 94 | i = methods(j) 95 | 96 | call get_finite_diff_formula(i,formula) 97 | if (formula=='') then 98 | write(output_unit,*) 'id ', i , 'not available' 99 | cycle 100 | end if 101 | 102 | func_evals = 0 103 | call my_prob%destroy() 104 | call my_prob%initialize(n,m,xlow,xhigh,perturb_mode,dpert,& 105 | problem_func=my_func,& 106 | sparsity_mode=sparsity_mode,& 107 | jacobian_method=i,& 108 | partition_sparsity_pattern=.true.,& 109 | cache_size=1000) ! use the cache for these cases 110 | if (my_prob%failed()) then 111 | call my_prob%get_error_status(error_msg=error_msg) 112 | write(error_unit,'(A)') error_msg 113 | stop 114 | end if 115 | 116 | call my_prob%compute_jacobian(x,jac) 117 | if (my_prob%failed()) then 118 | call my_prob%get_error_status(error_msg=error_msg) 119 | write(error_unit,'(A)') error_msg 120 | stop 121 | end if 122 | 123 | if (i==1) then 124 | write(output_unit,'(A)') '' 125 | call my_prob%print_sparsity_pattern(output_unit) 126 | write(output_unit,'(A)') '' 127 | call my_prob%print_sparsity_matrix(output_unit) 128 | write(output_unit,'(A)') '' 129 | 130 | write(output_unit,'(A)') '' 131 | write(output_unit,'(A)') '--------------------------------------' 132 | write(output_unit,'(A,I4)') ' specify method [with partitioning] : ',i 133 | write(output_unit,'(A)') '--------------------------------------' 134 | write(output_unit,'(A)') '' 135 | end if 136 | 137 | write(output_unit,'(A)') formula 138 | write(output_unit,'(A)') '' 139 | write(output_unit,'(A,1X,*(F27.16,","))') 'jac =',jac 140 | write(output_unit,'(A,1X,I5)') 'function evaluations:',func_evals 141 | write(output_unit,'(A)') '' 142 | 143 | end do 144 | 145 | meths = get_all_methods_in_class(3) 146 | 147 | write(output_unit,'(A)') '' 148 | write(output_unit,'(A)') '-------------------' 149 | write(output_unit,'(A)') 'select_finite_diff_method' 150 | write(output_unit,'(A)') '-------------------' 151 | write(output_unit,'(A)') '' 152 | call my_prob%select_finite_diff_method(0.0_wp,0.0_wp,1.0_wp,0.001_wp,meths,fd,status_ok) 153 | call fd%get_formula(formula) 154 | write(output_unit,'(A)') formula 155 | write(output_unit,'(A)') '' 156 | 157 | call my_prob%select_finite_diff_method(0.9999_wp,0.0_wp,1.0_wp,0.001_wp,meths,fd,status_ok) 158 | call fd%get_formula(formula) 159 | write(output_unit,'(A)') formula 160 | write(output_unit,'(A)') '' 161 | 162 | do i=2,9 163 | 164 | write(output_unit,'(A)') '' 165 | write(output_unit,'(A)') '-------------------' 166 | write(output_unit,'(A,I2)') ' specify class [no partitioning] : ', i 167 | write(output_unit,'(A)') '-------------------' 168 | write(output_unit,'(A)') '' 169 | 170 | func_evals = 0 171 | call my_prob%destroy() 172 | call my_prob%initialize(n,m,xlow,xhigh,perturb_mode,dpert,& 173 | problem_func=my_func,& 174 | sparsity_mode=sparsity_mode,& 175 | class=i,& 176 | cache_size=cache_size) 177 | if (my_prob%failed()) then 178 | call my_prob%get_error_status(error_msg=error_msg) 179 | write(error_unit,'(A)') error_msg 180 | stop 181 | end if 182 | 183 | call my_prob%compute_jacobian(x,jac) 184 | if (my_prob%failed()) then 185 | call my_prob%get_error_status(error_msg=error_msg) 186 | write(error_unit,'(A)') error_msg 187 | stop 188 | end if 189 | write(output_unit,'(A,1X,*(F27.16,","))') 'jac =',jac 190 | write(output_unit,'(A,1X,I5)') 'function evaluations:',func_evals 191 | write(output_unit,'(A)') '' 192 | 193 | end do 194 | 195 | do i=2,9 196 | 197 | write(output_unit,'(A)') '' 198 | write(output_unit,'(A)') '-------------------' 199 | write(output_unit,'(A,I2)') ' specify class [with partitioning] : ',i 200 | write(output_unit,'(A)') '-------------------' 201 | write(output_unit,'(A)') '' 202 | 203 | func_evals = 0 204 | call my_prob%destroy() 205 | call my_prob%initialize(n,m,xlow,xhigh,perturb_mode,dpert,& 206 | problem_func=my_func,& 207 | sparsity_mode=sparsity_mode,& 208 | class=i,partition_sparsity_pattern=.true.,& 209 | cache_size=cache_size) 210 | if (my_prob%failed()) then 211 | call my_prob%get_error_status(error_msg=error_msg) 212 | write(error_unit,'(A)') error_msg 213 | stop 214 | end if 215 | 216 | call my_prob%compute_jacobian(x,jac) 217 | if (my_prob%failed()) then 218 | call my_prob%get_error_status(error_msg=error_msg) 219 | write(error_unit,'(A)') error_msg 220 | stop 221 | end if 222 | write(output_unit,'(A,1X,*(F27.16,","))') 'jac =',jac 223 | write(output_unit,'(A,1X,I5)') 'function evaluations:',func_evals 224 | write(output_unit,'(A)') '' 225 | 226 | end do 227 | 228 | write(output_unit,'(A)') '' 229 | write(output_unit,'(A)') '-------------------' 230 | write(output_unit,'(A)') ' diff algorithm' 231 | write(output_unit,'(A)') '-------------------' 232 | write(output_unit,'(A)') '' 233 | 234 | func_evals = 0 235 | call my_prob%diff_initialize(n,m,xlow,xhigh,my_func,sparsity_mode=1,& ! use a dense method for this one 236 | cache_size=cache_size) 237 | if (my_prob%failed()) then 238 | call my_prob%get_error_status(error_msg=error_msg) 239 | write(error_unit,'(A)') error_msg 240 | stop 241 | end if 242 | 243 | call my_prob%compute_jacobian(x,jac) 244 | if (my_prob%failed()) then 245 | call my_prob%get_error_status(error_msg=error_msg) 246 | write(error_unit,'(A)') error_msg 247 | stop 248 | end if 249 | write(output_unit,'(A,1X,*(F27.16,","))') 'jac =',jac 250 | write(output_unit,'(A,1X,I5)') 'function evaluations:',func_evals 251 | write(output_unit,'(A)') '' 252 | 253 | contains 254 | 255 | subroutine my_func(me,x,f,funcs_to_compute) 256 | 257 | !! Problem function 258 | 259 | implicit none 260 | 261 | class(numdiff_type),intent(inout) :: me 262 | real(wp),dimension(:),intent(in) :: x 263 | real(wp),dimension(:),intent(out) :: f 264 | integer,dimension(:),intent(in) :: funcs_to_compute 265 | 266 | if (any(funcs_to_compute==1)) f(1) = x(1)*x(2) - x(3)**3 267 | if (any(funcs_to_compute==2)) f(2) = x(3) - 1.0_wp 268 | if (any(funcs_to_compute==3)) f(3) = x(4)*x(5) 269 | if (any(funcs_to_compute==4)) f(4) = 2.0_wp*x(6) + sin(x(7)) 270 | if (any(funcs_to_compute==5)) f(5) = cos(x(8)) + sqrt(abs(x(9))) 271 | if (any(funcs_to_compute==6)) f(6) = 1.0_wp / (1.0_wp + exp(x(10))) 272 | 273 | func_evals = func_evals + 1 274 | 275 | end subroutine my_func 276 | 277 | !******************************************************************************* 278 | end program test1 279 | !******************************************************************************* 280 | -------------------------------------------------------------------------------- /tests/test2.f90: -------------------------------------------------------------------------------- 1 | !******************************************************************************* 2 | !> author: Jacob Williams 3 | ! date: October 1, 2022 4 | ! 5 | ! Test2 for the numerical differentiation module. 6 | ! Makes a plot of the errors using different methods and step sizes. 7 | 8 | program test2 9 | 10 | use iso_fortran_env 11 | use numerical_differentiation_module 12 | use numdiff_kinds_module, only: wp 13 | use pyplot_module 14 | 15 | implicit none 16 | 17 | integer,parameter :: n = 1 !! number of variables 18 | integer,parameter :: m = 1 !! number of functions 19 | real(wp),dimension(n),parameter :: x = 1.0_wp !! point at which to compute the derivative 20 | real(wp),dimension(n),parameter :: xlow = -100000.0_wp !! bounds not really needed 21 | real(wp),dimension(n),parameter :: xhigh = 100000.0_wp !! 22 | integer,parameter :: perturb_mode = 1 !! absolute step 23 | integer,parameter :: cache_size = 0 !! `0` indicates not to use cache 24 | integer,parameter :: sparsity_mode = 1 !! assume dense 25 | integer,dimension(*),parameter :: methods = [1,3,10,21,36,500,600,700,800] 26 | !! array of method IDs: 27 | !! [1,3,10,21,36,500,600,700,800] 28 | !! forward + all the central diff ones 29 | integer,parameter :: exp_star = -ceiling(log10(epsilon(1.0_wp))) !! exponent to start with 30 | integer,parameter :: exp_stop = -2 !! exponent to end with 31 | integer,parameter :: exp_step = -1 !! ecponent step 32 | integer,parameter :: exp_scale = 5 !! number of substeps from one to the next 33 | 34 | type(numdiff_type) :: my_prob !! main class to compute the derivatives 35 | integer :: i !! method counter 36 | integer :: j !! counter 37 | real(wp),dimension(:),allocatable :: jac !! jacobian 38 | integer :: func_evals !! function evaluation counter 39 | character(len=:),allocatable :: error_msg !! error message string 40 | real(wp),dimension(n) :: dpert !! perturbation step size 41 | integer :: ipert !! perturbation step size counter 42 | real(wp) :: error !! diff from true derivative 43 | integer :: num_dperts !! number of dperts to test 44 | integer :: num_methods !! number of methods to test 45 | real(wp),dimension(:),allocatable :: results_dpert !! results array - dpert 46 | real(wp),dimension(:),allocatable :: results_errors !! results array - errors 47 | type(pyplot) :: plt !! for plotting the results 48 | character(len=:),allocatable :: formula !! finite diff formula for the plot legend 49 | character(len=:),allocatable :: name !! finite diff name for the plot legend 50 | integer :: idx !! index in results arrays 51 | character(len=:),allocatable :: real_kind_str !! real kind for the plot title 52 | real(wp),dimension(3) :: color !! line color array 53 | real(wp),dimension(2) :: ylim !! plot y limit array 54 | 55 | ! size the arrays: 56 | num_methods = size(methods) 57 | num_dperts = size([(i, i = exp_star*exp_scale, exp_stop*exp_scale, exp_step)]) 58 | allocate(results_errors(num_dperts)); results_errors = -huge(1.0_wp) 59 | 60 | ! for plot title: 61 | select case(wp) 62 | case(REAL32); real_kind_str = '[Single Precision]' 63 | case(REAL64); real_kind_str = '[Double Precision]' 64 | case(REAL128); real_kind_str = '[Quad Precision]' 65 | case default; error stop 'Invalid real kind' 66 | end select 67 | 68 | ! initialize the plot: 69 | call plt%initialize(grid = .true.,& 70 | figsize = [20,10],& 71 | axes_labelsize = 30, & 72 | xtick_labelsize = 30, & 73 | ytick_labelsize = 30, & 74 | font_size = 30, & 75 | xlabel = 'Finite Difference Perturbation Step Size $h$',& 76 | ylabel = 'Finite Difference Derivative Error',& 77 | title = 'Derivative of $x + \sin(x)$ at $x=1$ '//real_kind_str,& 78 | legend = .true., & 79 | legend_fontsize = 10,& 80 | usetex = .true.) 81 | 82 | ! try different finite diff methods 83 | do j=1,size(methods) 84 | 85 | idx = 0 86 | i = methods(j) ! method id 87 | call get_finite_diff_formula(i,formula,name) 88 | 89 | ! cycle through perturbation step sizes: 90 | do ipert = exp_star*exp_scale, exp_stop*exp_scale, exp_step 91 | 92 | idx = idx + 1 ! index for arrays 93 | dpert = 10.0_wp ** (-ipert/real(exp_scale,wp)) ! compute perturbation step size 94 | if (j==1) then 95 | if (.not. allocated(results_dpert)) allocate(results_dpert(0)) 96 | results_dpert = [results_dpert, dpert(1)] ! save dpert 97 | end if 98 | 99 | func_evals = 0 100 | call my_prob%destroy() 101 | call my_prob%initialize(n,m,xlow,xhigh,perturb_mode,dpert,& 102 | problem_func=my_func,& 103 | sparsity_mode=sparsity_mode,& 104 | jacobian_method=i,& 105 | partition_sparsity_pattern=.false.,& 106 | cache_size=cache_size) 107 | if (my_prob%failed()) then 108 | call my_prob%get_error_status(error_msg=error_msg) 109 | error stop error_msg 110 | end if 111 | 112 | call my_prob%compute_jacobian(x,jac) 113 | if (my_prob%failed()) then 114 | call my_prob%get_error_status(error_msg=error_msg) 115 | error stop error_msg 116 | end if 117 | error = abs(deriv(x(1)) - jac(1)) 118 | !write(output_unit,'(I5,1X,*(F27.16))') i , dpert, error 119 | if (error<=epsilon(1.0_wp)) error = 0.0_wp 120 | results_errors(idx) = error ! save result 121 | 122 | end do 123 | 124 | ! line color for the plot: 125 | select case (j) 126 | case(1); color = [1.0_wp, 0.0_wp, 0.0_wp] ! red 127 | case(2); color = [0.0_wp, 1.0_wp, 0.0_wp] ! green 128 | case default 129 | ! blue gradient for the others 130 | color = [real(j-2,wp)/num_methods, & 131 | real(j-2,wp)/num_methods, & 132 | 0.9_wp] 133 | end select 134 | ylim = [10.0_wp**(ceiling(log10(epsilon(1.0_wp)))), 1.0_wp] 135 | 136 | ! plot for this method: 137 | call plt%add_plot(results_dpert,results_errors,& 138 | xscale='log', yscale='log',& 139 | label = formula,linestyle='.-',markersize=5,linewidth=2, & 140 | color = color,& 141 | xlim = ylim,& 142 | ylim = ylim) 143 | 144 | end do 145 | 146 | ! save plot: 147 | call plt%savefig('results '//real_kind_str//'.pdf', pyfile='results.py') 148 | 149 | contains 150 | 151 | function func(x) 152 | !! Problem function 153 | real(wp), intent(in) :: x 154 | real(wp) :: func 155 | func = x + sin(x) 156 | end function func 157 | function deriv(x) 158 | !! Problem function true derivative 159 | real(wp), intent(in) :: x 160 | real(wp) :: deriv 161 | deriv = 1.0_wp + cos(x) 162 | end function deriv 163 | 164 | subroutine my_func(me,x,f,funcs_to_compute) 165 | !! Problem function interface for numdiff 166 | class(numdiff_type),intent(inout) :: me 167 | real(wp),dimension(:),intent(in) :: x 168 | real(wp),dimension(:),intent(out) :: f 169 | integer,dimension(:),intent(in) :: funcs_to_compute 170 | if (any(funcs_to_compute==1)) f(1) = func(x(1)) 171 | func_evals = func_evals + 1 172 | end subroutine my_func 173 | 174 | !******************************************************************************* 175 | end program test2 176 | !******************************************************************************* 177 | --------------------------------------------------------------------------------