├── .github └── workflows │ └── CI.yml ├── .gitignore ├── LICENSE ├── README.md ├── codecov.yml ├── ford.md ├── fpm.toml ├── media ├── logo.png └── logo.svg ├── nlesolver-fortran.code-workspace ├── src └── nlesolver_module.F90 └── test ├── nlesolver_test_1.f90 └── sparse_test.f90 /.github/workflows/CI.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: [push] 3 | jobs: 4 | 5 | Build: 6 | runs-on: ${{ matrix.os }} 7 | permissions: 8 | contents: write 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | os: [ubuntu-latest] 13 | gcc_v: [14] # Version of GFortran we want to use. 14 | python-version: [3.12] 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 | sudo apt-get install libblas-dev liblapack-dev 57 | 58 | # - name: Compile 59 | # run: fpm build --profile release 60 | 61 | - name: Run tests 62 | run: fpm test --profile debug --flag -coverage 63 | 64 | - name: Create coverage report 65 | run: | 66 | mkdir -p ${{ env.COV_DIR }} 67 | mv ./build/gfortran_*/*/* ${{ env.COV_DIR }} 68 | lcov --capture --initial --base-directory . --directory ${{ env.COV_DIR }} --output-file ${{ env.COV_DIR }}/coverage.base 69 | lcov --capture --base-directory . --directory ${{ env.COV_DIR }} --output-file ${{ env.COV_DIR }}/coverage.capture 70 | lcov --add-tracefile ${{ env.COV_DIR }}/coverage.base --add-tracefile ${{ env.COV_DIR }}/coverage.capture --output-file ${{ env.COV_DIR }}/coverage.info 71 | env: 72 | COV_DIR: build/coverage 73 | 74 | - name: Upload coverage report 75 | uses: codecov/codecov-action@v3 76 | with: 77 | files: build/coverage/coverage.info 78 | 79 | - name: Build documentation 80 | run: ford ./ford.md 81 | 82 | - name: Deploy Documentation 83 | if: github.ref == 'refs/heads/master' 84 | uses: JamesIves/github-pages-deploy-action@v4.7.3 85 | with: 86 | branch: gh-pages # The branch the action should deploy to. 87 | folder: doc # The folder the action should deploy. 88 | single-commit: true 89 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Prerequisites 2 | *.d 3 | 4 | # Compiled Object files 5 | *.slo 6 | *.lo 7 | *.o 8 | *.obj 9 | 10 | # Precompiled Headers 11 | *.gch 12 | *.pch 13 | 14 | # Compiled Dynamic libraries 15 | *.so 16 | *.dylib 17 | *.dll 18 | 19 | # Fortran module files 20 | *.mod 21 | *.smod 22 | 23 | # Compiled Static libraries 24 | *.lai 25 | *.la 26 | *.a 27 | *.lib 28 | 29 | # Executables 30 | *.exe 31 | *.out 32 | *.app 33 | 34 | # misc 35 | .DS_Store 36 | 37 | # directories 38 | /build 39 | /doc 40 | /lib 41 | /bin -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2021-2025, Jacob Williams 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![nlesolver-fortran](media/logo.png) 2 | 3 | Nonlinear Equation Solver with Modern Fortran. 4 | ============ 5 | 6 | A basic Newton-Raphson type nonlinear equation solver for sparse or dense systems with `m` functions of `n` input variables. 7 | 8 | ### Status 9 | 10 | [![GitHub Badge](https://img.shields.io/badge/GitHub-181717?logo=github&logoColor=fff&style=plastic)](https://github.com/jacobwilliams/nlesolver-fortran) 11 | [![Language](https://img.shields.io/badge/-Fortran-734f96?logo=fortran&logoColor=white)](https://github.com/topics/fortran) 12 | [![CI Status](https://github.com/jacobwilliams/nlesolver-fortran/actions/workflows/CI.yml/badge.svg)](https://github.com/jacobwilliams/nlesolver-fortran/actions) 13 | [![GitHub release](https://img.shields.io/github/release/jacobwilliams/nlesolver-fortran.svg)](https://github.com/jacobwilliams/nlesolver-fortran/releases/latest) 14 | [![codecov](https://codecov.io/gh/jacobwilliams/nlesolver-fortran/branch/master/graph/badge.svg)](https://codecov.io/gh/jacobwilliams/nlesolver-fortran) 15 | [![last-commit](https://img.shields.io/github/last-commit/jacobwilliams/nlesolver-fortran)](https://github.com/jacobwilliams/nlesolver-fortran/commits/master) 16 | 17 | ### Features 18 | 19 | * Is object-oriented. 20 | * Works with square, under-determined, or over-determined systems. 21 | * Can use different methods to solve the linear system: 22 | 1. [LAPACK](https://www.netlib.org/lapack/) routines (`dgesv` or `dgels`) for dense systems: If `n=m`, uses `dgesv` (LU decomposition). If `n/=m`, uses `dgels` (if `m>n` uses QR factorization, if `m 10 | predocmark: < 11 | docmark_alt: 12 | docmark: ! 13 | display: public 14 | protected 15 | private 16 | source: true 17 | graph: true 18 | externalize: true 19 | external: fmin = https://jacobwilliams.github.io/fmin 20 | extra_mods: iso_fortran_env: https://gcc.gnu.org/onlinedocs/gfortran/ISO_005fFORTRAN_005fENV.html 21 | fmin_module: https://jacobwilliams.github.io/fmin 22 | lusol_ez_module: https://jacobwilliams.github.io/lusol 23 | lsqr_module: https://jacobwilliams.github.io/LSQR 24 | lsmrModule: https://jacobwilliams.github.io/LSMR 25 | 26 | {!README.md!} 27 | -------------------------------------------------------------------------------- /fpm.toml: -------------------------------------------------------------------------------- 1 | name = "nlesolver-fortran" 2 | author = "Jacob Williams" 3 | copyright = "Copyright (c) 2021-2025, Jacob Williams" 4 | license = "BSD-3" 5 | description = "Nonlinear Equation Solver with Modern Fortran" 6 | homepage = "https://github.com/jacobwilliams/nlesolver-fortran" 7 | keywords = ["nle solver"] 8 | 9 | [build] 10 | auto-executables = false 11 | auto-examples = false 12 | auto-tests = true 13 | link = ["lapack", "blas"] 14 | 15 | [library] 16 | source-dir = "src" 17 | 18 | [dependencies] 19 | fmin = { git="https://github.com/jacobwilliams/fmin.git", tag="1.1.1" } 20 | LSQR = { git="https://github.com/jacobwilliams/LSQR", tag="1.1.0" } 21 | lusol = { git="https://github.com/jacobwilliams/lusol", tag="1.0.0" } 22 | LSMR = { git="https://github.com/jacobwilliams/LSMR", tag="1.0.0" } 23 | 24 | [install] 25 | library = true 26 | -------------------------------------------------------------------------------- /media/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jacobwilliams/nlesolver-fortran/60f38870a25e6b448dd552f184aa2f8616fc8cb0/media/logo.png -------------------------------------------------------------------------------- /media/logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 20 | 22 | 30 | 35 | 36 | 44 | 49 | 50 | 53 | 60 | 61 | 64 | 71 | 72 | 74 | 78 | 82 | 83 | 84 | 107 | 109 | 110 | 112 | image/svg+xml 113 | 115 | 116 | 117 | 118 | 119 | 124 | 132 | NLESolver-Fortran 143 | 144 | 145 | -------------------------------------------------------------------------------- /nlesolver-fortran.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/nlesolver_module.F90: -------------------------------------------------------------------------------- 1 | !****************************************************************************************************** 2 | !> 3 | ! A basic multidimensional nonlinear equation solver, using a Newton-Raphson type direct method. 4 | ! 5 | !### Features 6 | ! * Works with square, under-determined, or over-determined systems. 7 | ! * Uses LAPACK routines (`dgesv` or `dgels`) to solve the linear system. 8 | ! * Has a Broyden update option. 9 | ! * Has various line search options. 10 | ! 11 | !### References 12 | ! * https://en.wikipedia.org/wiki/Backtracking_line_search 13 | ! * http://projecteuclid.org/download/pdf_1/euclid.pjm/1102995080 14 | ! * http://help.agi.com/stk/index.htm#gator/eq-diffcorr.htm 15 | ! * http://gmat.sourceforge.net/doc/R2015a/html/DifferentialCorrector.html 16 | ! * https://openmdao.org/newdocs/versions/latest/features/building_blocks/solvers/bounds_enforce.html 17 | ! 18 | !### Author 19 | ! * Jacob Williams 20 | ! 21 | !### License 22 | ! * BSD-3 23 | ! 24 | !@todo add an `istat` output to func and grad, for user stopping 25 | ! or to take a smaller stop (if istat>0 take a smaller step, if istat<0 abort) 26 | ! 27 | !@note The default real kind (`wp`) can be 28 | ! changed using optional preprocessor flags. 29 | ! This library was built with real kind: 30 | #ifdef REAL32 31 | ! `real(kind=real32)` [4 bytes] 32 | #elif REAL64 33 | ! `real(kind=real64)` [8 bytes] 34 | #elif REAL128 35 | ! `real(kind=real128)` [16 bytes] 36 | #else 37 | ! `real(kind=real64)` [8 bytes] 38 | #endif 39 | 40 | module nlesolver_module 41 | 42 | use iso_fortran_env 43 | use fmin_module, only: fmin 44 | use lsqr_module, only: lsqr_solver_ez 45 | use lusol_ez_module, only: solve, lusol_settings 46 | use lsmrModule, only: lsmr_ez 47 | 48 | implicit none 49 | 50 | private 51 | 52 | #ifdef REAL32 53 | integer,parameter,public :: nlesolver_rk = real32 !! real kind used by this module [4 bytes] 54 | #elif REAL64 55 | integer,parameter,public :: nlesolver_rk = real64 !! real kind used by this module [8 bytes] 56 | #elif REAL128 57 | integer,parameter,public :: nlesolver_rk = real128 !! real kind used by this module [16 bytes] 58 | #else 59 | integer,parameter,public :: nlesolver_rk = real64 !! real kind used by this module [8 bytes] 60 | #endif 61 | 62 | integer,parameter :: wp = nlesolver_rk !! local copy of `nlesolver_rk` with a shorter name 63 | 64 | real(wp),parameter :: zero = 0.0_wp 65 | real(wp),parameter :: one = 1.0_wp 66 | real(wp),parameter :: two = 2.0_wp 67 | real(wp),parameter :: eps = epsilon(one) !! machine \( \epsilon \) 68 | real(wp),parameter :: big = huge(one) 69 | 70 | ! options for sparsity_mode 71 | integer,parameter,public :: NLESOLVER_SPARSITY_DENSE = 1 !! [[nlesolver_type:sparsity_mode]] : assume dense (use dense solver). 72 | integer,parameter,public :: NLESOLVER_SPARSITY_LSQR = 2 !! [[nlesolver_type:sparsity_mode]] : assume sparse (use LSQR sparse solver). 73 | integer,parameter,public :: NLESOLVER_SPARSITY_LUSOL = 3 !! [[nlesolver_type:sparsity_mode]] : assume sparse (use LUSOL sparse solver). 74 | integer,parameter,public :: NLESOLVER_SPARSITY_LSMR = 4 !! [[nlesolver_type:sparsity_mode]] : assume sparse (use LSMR sparse solver). 75 | integer,parameter,public :: NLESOLVER_SPARSITY_CUSTOM_SPARSE = 5 !! [[nlesolver_type:sparsity_mode]] : assume sparse (use a user provided sparse solver). 76 | !integer,parameter,public :: NLESOLVER_SPARSITY_CUSTOM_DENSE = 6 !! [[nlesolver_type:sparsity_mode]] : assume dense (use a user provided dense solver). [not available] 77 | ! if add will have to update code below where sparsity_modes /= 1 is assumed sparse 78 | 79 | ! bounds mode options: 80 | integer,parameter,public :: NLESOLVER_IGNORE_BOUNDS = 0 !! [[nlesolver_type:bounds_mode]] : ignore bounds 81 | integer,parameter,public :: NLESOLVER_SCALAR_BOUNDS = 1 !! [[nlesolver_type:bounds_mode]] : scalar mode 82 | integer,parameter,public :: NLESOLVER_VECTOR_BOUNDS = 2 !! [[nlesolver_type:bounds_mode]] : vector mode 83 | integer,parameter,public :: NLESOLVER_WALL_BOUNDS = 3 !! [[nlesolver_type:bounds_mode]] : wall mode 84 | 85 | ! options to compute vector norm for function value: 86 | integer,parameter,public :: NLESOLVER_2_NORM = 1 !! [[nlesolver_type:norm_mode]] : 2-norm 87 | integer,parameter,public :: NLESOLVER_INF_NORM = 2 !! [[nlesolver_type:norm_mode]] : infinity-norm 88 | integer,parameter,public :: NLESOLVER_1_NORM = 3 !! [[nlesolver_type:norm_mode]] : 1-norm 89 | 90 | ! options for linesearch step mode: 91 | integer,parameter,public :: NLESOLVER_LINESEARCH_SIMPLE = 1 !! [[nlesolver_type:linesearch]] : use the specified `alpha` (0,1] 92 | integer,parameter,public :: NLESOLVER_LINESEARCH_BACKTRACKING = 2 !! [[nlesolver_type:linesearch]] : backtracking linesearch (between `alpha_min` and `alpha_max`) 93 | integer,parameter,public :: NLESOLVER_LINESEARCH_EXACT = 3 !! [[nlesolver_type:linesearch]] : exact linesearch (between `alpha_min` and `alpha_max`) 94 | integer,parameter,public :: NLESOLVER_LINESEARCH_FIXEDPOINT = 4 !! [[nlesolver_type:linesearch]] : evaluate function at specified fixed points (between `alpha_min` and `alpha_max`) 95 | 96 | !********************************************************* 97 | type,public :: nlesolver_type 98 | 99 | !! Nonlinear equations solver class. 100 | 101 | private 102 | 103 | integer :: n = 0 !! number of opt vars 104 | integer :: m = 0 !! number of constraints 105 | integer :: max_iter = 100 !! maximum number of iterations 106 | real(wp) :: tol = 1.0e-6_wp !! convergence tolerance for function values 107 | real(wp) :: alpha = 1.0_wp !! step length (when specified constant) 108 | real(wp) :: alpha_min = 0.1_wp !! minimum step length (when allowed to vary) 109 | real(wp) :: alpha_max = 1.0_wp !! maximum step length (when allowed to vary) 110 | real(wp) :: tolx = 1.0e-8_wp !! convergence tolerance for `x` 111 | real(wp) :: c = 0.5_wp !! backtracking linesearch parameter (0,1) 112 | real(wp) :: tau = 0.5_wp !! backtracking linesearch parameter (0,1) 113 | real(wp) :: fmin_tol = 1.0e-5_wp !! tolerance for "exact" linesearch 114 | integer :: n_intervals = 2 !! number of intervals for fixed point linesearch 115 | logical :: use_broyden = .false. !! if true, a Broyden update is used 116 | !! rather than computing the Jacobian 117 | !! at every step. The `grad` function is 118 | !! only called for the initial evaluation. 119 | integer :: broyden_update_n = 4 !! if this value is `>0`, the Broyden update 120 | !! is computed at most this many times before 121 | !! the full Jacobian is recomputed. 122 | integer :: n_uphill_max = 5 !! maximum number of consecutive steps 123 | !! to allow where the value of `f` increases 124 | logical :: verbose = .false. !! verbose output printing 125 | integer :: iunit = output_unit !! output unit for printing (assumed to be open). 126 | character(len=:),allocatable :: message !! latest status message 127 | integer :: istat = -999 !! latest status message 128 | 129 | integer :: norm_mode = NLESOLVER_2_NORM !! how to compute the norm of the function vector: 130 | !! 131 | !! * 1 = 2-norm (default) 132 | !! * 2 = infinity-norm 133 | !! * 3 = 1-norm 134 | 135 | integer :: bounds_mode = NLESOLVER_IGNORE_BOUNDS !! how to handle the `x` variable bounds: 136 | !! 137 | !! * 0 = ignore bounds (default). 138 | !! * 1 = scalar mode : adjust the step vector (`xnew-x`) by moving each individual scalar component 139 | !! of `xnew` to be within the bounds. Note that this can change the direction and magnitude of 140 | !! the search vector. 141 | !! * 2 = vector mode: backtrack the search vector so that no bounds are violated. note that 142 | !! this does not change the direction of the vector, only the magnitude. 143 | !! * 3 = wall mode: adjust the step vector (`xnew-x`) by moving each individual scalar component 144 | !! of `xnew` to be within the bounds. And then holding the ones changed fixed during the line search. 145 | !! 146 | !! Note: if `bounds_mode>0`, then the initial `x` vector is also adjusted 147 | !! to be within the bounds before the first step, if necessary. This is just done 148 | !! by adjusting each scalar component of `x` to be within bounds. 149 | real(wp),dimension(:),allocatable :: xlow !! lower bounds for `x` (size is `n`). only used if `bounds_mode>0`. 150 | real(wp),dimension(:),allocatable :: xupp !! upper bounds for `x` (size is `n`). only used if `bounds_mode>0`. 151 | 152 | procedure(func_func),pointer :: func => null() !! user-supplied routine to compute the function 153 | procedure(export_func),pointer :: export_iteration => null() !! user-supplied routine to export iterations 154 | procedure(wait_func),pointer :: user_input_check => null() !! user-supplied routine to enable user to stop iterations 155 | procedure(linesearch_func),pointer :: linesearch => null() !! line search method (determined by `step_mode` user input in [[nlesolver_type:initialize]]) 156 | 157 | ! sparsity options: 158 | integer :: sparsity_mode = NLESOLVER_SPARSITY_DENSE !! sparsity mode: 159 | !! 160 | !! * 1 - assume dense (use dense solver). 161 | !! * 2 - assume sparse (use LSQR sparse solver). 162 | !! * 3 - assume sparse (use LUSOL sparse solver). 163 | !! * 4 - assume sparse (use LSMR sparse solver). 164 | !! * 5 - assume sparse (use a user provided sparse solver). 165 | integer :: n_nonzeros = -1 !! number of nonzero Jacobian elements (used for `sparsity_mode > 1`) 166 | integer,dimension(:),allocatable :: irow !! sparsity pattern nonzero elements row indices. 167 | integer,dimension(:),allocatable :: icol !! sparsity pattern nonzero elements column indices 168 | 169 | ! LSQR parameters: 170 | real(wp) :: atol = zero !! relative error in definition of `A` 171 | real(wp) :: btol = zero !! relative error in definition of `b` 172 | real(wp) :: conlim = zero !! An upper limit on `cond(Abar)`, the apparent 173 | !! condition number of the matrix `Abar`. 174 | integer :: itnlim = 100 !! max iterations 175 | integer :: nout = 0 !! output unit for printing 176 | real(wp) :: damp = zero !! damp parameter for LSQR 177 | 178 | integer :: localSize = 0 !! LSMR: Number of vectors for local reorthogonalization: 179 | !! 180 | !! * 0 No reorthogonalization is performed. 181 | !! * >0 This many n-vectors "v" (the most recent ones) 182 | !! are saved for reorthogonalizing the next v. 183 | !! 184 | !! localSize need not be more than `min(m,n)`. 185 | !! At most `min(m,n)` vectors will be allocated. 186 | 187 | ! LUSOL parameters: 188 | integer :: lusol_method = 0 !! * 0 => TPP: Threshold Partial Pivoting. 189 | !! * 1 => TRP: Threshold Rook Pivoting. 190 | !! * 2 => TCP: Threshold Complete Pivoting. 191 | 192 | ! dense version: 193 | procedure(grad_func),pointer :: grad => null() !! user-supplied routine to compute the gradient of the function (dense version) 194 | 195 | ! sparse version: 196 | procedure(grad_func_sparse),pointer :: grad_sparse => null() !! user-supplied routine to compute the gradient of the function (sparse version) 197 | 198 | ! custom sparse solver: 199 | procedure(sparse_solver_func),pointer :: custom_solver_sparse => null() !! user-supplied sparse linear solver routine (used for `sparsity_mode=5`) 200 | 201 | procedure(norm_func),pointer :: norm => null() !! function for computing the norm of the `f` vector 202 | 203 | contains 204 | 205 | private 206 | 207 | procedure,public :: initialize => initialize_nlesolver_variables 208 | procedure,public :: solve => nlesolver_solver 209 | procedure,public :: destroy => destroy_nlesolver_variables 210 | procedure,public :: status => get_status 211 | 212 | procedure :: set_status 213 | procedure :: adjust_x_for_bounds 214 | procedure :: adjust_search_direction 215 | procedure :: compute_next_step 216 | 217 | end type nlesolver_type 218 | !********************************************************* 219 | 220 | abstract interface 221 | 222 | subroutine sparse_solver_func(me,n_cols,n_rows,n_nonzero,irow,icol,a,b,x,istat) 223 | !! for a custom user-provided linear solver (sparse version) 224 | !! solve `Ax = b` for `x`, given `A` and `b`. 225 | import :: wp,nlesolver_type 226 | implicit none 227 | class(nlesolver_type),intent(inout) :: me 228 | integer,intent(in) :: n_cols !! `n`: number of columns in A. 229 | integer,intent(in) :: n_rows !! `m`: number of rows in A. 230 | integer,intent(in) :: n_nonzero !! number of nonzero elements of A. 231 | integer,dimension(n_nonzero),intent(in) :: irow, icol !! sparsity pattern (size is `n_nonzero`) 232 | real(wp),dimension(n_nonzero),intent(in) :: a !! matrix elements (size is `n_nonzero`) 233 | real(wp),dimension(n_rows),intent(in) :: b !! right hand side (size is `m`) 234 | real(wp),dimension(n_cols),intent(out) :: x !! solution (size is `n`) 235 | integer,intent(out) :: istat !! status code (=0 for success) 236 | end subroutine sparse_solver_func 237 | 238 | subroutine func_func(me,x,f) 239 | !! compute the function 240 | import :: wp,nlesolver_type 241 | implicit none 242 | class(nlesolver_type),intent(inout) :: me 243 | real(wp),dimension(:),intent(in) :: x 244 | real(wp),dimension(:),intent(out) :: f 245 | end subroutine func_func 246 | 247 | subroutine grad_func(me,x,g) 248 | !! compute the gradient of the function (Jacobian). Dense version. 249 | import :: wp,nlesolver_type 250 | implicit none 251 | class(nlesolver_type),intent(inout) :: me 252 | real(wp),dimension(:),intent(in) :: x 253 | real(wp),dimension(:,:),intent(out) :: g 254 | end subroutine grad_func 255 | 256 | subroutine grad_func_sparse(me,x,g) 257 | !! compute the gradient of the function (Jacobian). Sparse version. 258 | import :: wp,nlesolver_type 259 | implicit none 260 | class(nlesolver_type),intent(inout) :: me 261 | real(wp),dimension(:),intent(in) :: x 262 | real(wp),dimension(:),intent(out) :: g !! sparse jacobian. length is `n_nonzeros` 263 | end subroutine grad_func_sparse 264 | 265 | subroutine export_func(me,x,f,iter) 266 | !! export an iteration: 267 | import :: wp,nlesolver_type 268 | implicit none 269 | class(nlesolver_type),intent(inout) :: me 270 | real(wp),dimension(:),intent(in) :: x 271 | real(wp),dimension(:),intent(in) :: f 272 | integer,intent(in) :: iter !! iteration number 273 | end subroutine export_func 274 | 275 | subroutine wait_func(me,user_stop) 276 | !! enable a user-triggered stop of the iterations: 277 | import :: wp,nlesolver_type 278 | implicit none 279 | class(nlesolver_type),intent(inout) :: me 280 | logical,intent(out) :: user_stop 281 | end subroutine wait_func 282 | 283 | subroutine linesearch_func(me,xold,p,x,f,fvec,fjac,fjac_sparse) 284 | !! line search method. Note that not all inputs/outputs are 285 | !! used by all methods. 286 | import :: wp,nlesolver_type 287 | implicit none 288 | class(nlesolver_type),intent(inout) :: me 289 | real(wp),dimension(me%n),intent(in) :: xold !! previous value of `x` 290 | real(wp),dimension(me%n),intent(in) :: p !! search direction 291 | real(wp),dimension(me%n),intent(out) :: x !! new `x` 292 | real(wp),intent(inout) :: f !! * input: current magnitude of `fvec`, 293 | !! * output: new value of `f` 294 | real(wp),dimension(me%m),intent(inout) :: fvec !! * input: current function vector, 295 | !! * output: new function vector 296 | real(wp),dimension(:,:),intent(in),optional :: fjac !! jacobian matrix [dense] 297 | real(wp),dimension(:),intent(in),optional :: fjac_sparse !! jacobian matrix [sparse] 298 | end subroutine linesearch_func 299 | 300 | pure function norm_func(me, fvec) result(f) 301 | !! function vector norm. 302 | import :: wp,nlesolver_type 303 | implicit none 304 | class(nlesolver_type),intent(in) :: me 305 | real(wp),dimension(me%m),intent(in) :: fvec !! the function vector 306 | real(wp) :: f !! norm of the vector 307 | end function norm_func 308 | 309 | end interface 310 | 311 | contains 312 | !******************************************************************************************************* 313 | 314 | !***************************************************************************************** 315 | !> 316 | ! Set status flag and message. 317 | 318 | subroutine set_status(me,istat,string,i,r) 319 | 320 | implicit none 321 | 322 | class(nlesolver_type),intent(inout) :: me 323 | integer,intent(in) :: istat !! status code 324 | character(len=*),intent(in) :: string !! status message 325 | integer,intent(in),optional :: i !! an integer value to append 326 | real(wp),intent(in),optional :: r !! a real value to append 327 | 328 | character(len=:),allocatable :: message !! the full message to log 329 | integer :: iostat !! write `iostat` code 330 | 331 | message = trim(string) 332 | if (present(i)) message = message//' '//int2str(i) 333 | if (present(r)) message = message//' '//real2str(r) 334 | 335 | if (me%verbose) write(me%iunit,'(A)',iostat=iostat) message 336 | 337 | ! store in the class: 338 | me%istat = istat 339 | me%message = message 340 | 341 | end subroutine set_status 342 | !***************************************************************************************** 343 | 344 | !***************************************************************************************** 345 | !> 346 | ! Convert an integer to a string. Works for up to 256 digits. 347 | 348 | function int2str(i) result(s) 349 | integer, intent(in) :: i !! integer to convert 350 | character(len=:),allocatable :: s !! string result 351 | character(len=256) :: tmp !! temp string 352 | integer :: iostat !! write `iostat` code 353 | write(tmp,fmt=*,iostat=iostat) i 354 | if (iostat/=0) then 355 | s = '****' 356 | else 357 | s = trim(adjustl(tmp)) 358 | end if 359 | end function int2str 360 | !***************************************************************************************** 361 | 362 | !***************************************************************************************** 363 | !> 364 | ! Convert a real to a string. Works for up to 256 digits. 365 | 366 | function real2str(r) result(s) 367 | real(wp), intent(in) :: r !! real to convert 368 | character(len=:),allocatable :: s !! string result 369 | character(len=256) :: tmp !! temp string 370 | integer :: iostat !! write `iostat` code 371 | write(tmp,fmt=*,iostat=iostat) r 372 | if (iostat/=0) then 373 | s = '****' 374 | else 375 | s = trim(adjustl(tmp)) 376 | end if 377 | end function real2str 378 | !***************************************************************************************** 379 | 380 | !***************************************************************************************** 381 | !> 382 | ! Return the status code and message from the [[nlesolver_type]] class. 383 | ! 384 | !### Status codes 385 | ! 386 | ! * -1 -- Error: Invalid alpha 387 | ! * -2 -- Error: Invalid alpha_min 388 | ! * -3 -- Error: Invalid alpha_max 389 | ! * -4 -- Error: Alpha_min must be < alpha_max 390 | ! * -5 -- Error: Invalid step_mode 391 | ! * -6 -- Error solving linear system 392 | ! * -7 -- Error: More than 5 steps in the uphill direction 393 | ! * -8 -- Error: Divide by zero when computing Broyden update 394 | ! * -9 -- Error: Out of memory 395 | ! * -10 -- Error: function routine is not associated 396 | ! * -11 -- Error: gradient routine is not associated 397 | ! * -12 -- Error: backtracking linesearch c must be in range (0, 1) 398 | ! * -13 -- Error: backtracking linesearch tau must be in range (0, 1) 399 | ! * -14 -- Error: must specify grad_sparse, irow, and icol for sparsity_mode > 1 400 | ! * -15 -- Error: irow and icol must be the same length 401 | ! * -16 -- Error: xlow > xupp 402 | ! * -17 -- Error adjusting line search direction for bounds 403 | ! * -18 -- Error: invalid norm_mode 404 | ! * -999 -- Error: class has not been initialized 405 | ! * 0 -- Class successfully initialized in [[nlesolver_type:initialize]] 406 | ! * 1 -- Required accuracy achieved 407 | ! * 2 -- Solution cannot be improved 408 | ! * 3 -- Maximum number of iterations reached 409 | ! * 4 -- Stopped by the user 410 | 411 | subroutine get_status(me, istat, message) 412 | 413 | implicit none 414 | 415 | class(nlesolver_type),intent(inout) :: me 416 | integer,intent(out),optional :: istat !! Integer status code. 417 | character(len=:),allocatable,intent(out),optional :: message !! Text status message 418 | 419 | if (present(istat)) istat = me%istat 420 | 421 | if (present(message)) then 422 | if (allocated(me%message)) then 423 | message = trim(me%message) 424 | else 425 | message = 'Error: class has not been initialized' 426 | end if 427 | end if 428 | 429 | end subroutine get_status 430 | !***************************************************************************************** 431 | 432 | !***************************************************************************************** 433 | !> 434 | ! Constructor for the class. 435 | 436 | subroutine initialize_nlesolver_variables(me,& 437 | n,m,max_iter,tol,alpha,alpha_min,alpha_max,tolx,fmin_tol,& 438 | backtrack_c,backtrack_tau,& 439 | use_broyden,broyden_update_n,step_mode,& 440 | func,grad,grad_sparse,& 441 | export_iteration,user_input_check,& 442 | verbose,iunit,n_uphill_max,n_intervals,& 443 | sparsity_mode,irow,icol,& 444 | atol,btol,conlim,damp,itnlim,nout,& 445 | lusol_method,localSize,custom_solver_sparse,& 446 | bounds_mode,xlow,xupp,norm_mode) 447 | 448 | implicit none 449 | 450 | class(nlesolver_type),intent(inout) :: me 451 | integer,intent(in) :: n !! number of optimization variables 452 | integer,intent(in) :: m !! number of constraints 453 | integer,intent(in) :: max_iter !! maximum number of iterations 454 | real(wp),intent(in) :: tol !! function convergence tolerance 455 | procedure(func_func) :: func !! computes the function vector 456 | procedure(grad_func),optional :: grad !! computes the jacobian [required for dense mode: `sparsity_mode=1`] 457 | procedure(grad_func_sparse),optional :: grad_sparse !! computes the jacobian [required for sparse mode: `sparsity_mode>1`] 458 | integer,intent(in),optional :: step_mode !! step mode: 459 | !! 460 | !! * 1 = use the specified `alpha` (0,1] 461 | !! * 2 = backtracking linesearch (between `alpha_min` and `alpha_max`) 462 | !! * 3 = exact linesearch (between `alpha_min` and `alpha_max`) 463 | !! * 4 = evaluate function at specified fixed points (between `alpha_min` and `alpha_max`) 464 | real(wp),intent(in),optional :: alpha !! constant step length for `step_mode=1` (0,1] 465 | real(wp),intent(in),optional :: alpha_min !! minimum step length (0,1] 466 | real(wp),intent(in),optional :: alpha_max !! maximum step length (0,1] 467 | real(wp),intent(in),optional :: tolx !! convergence tolerance for changes in `x` 468 | real(wp),intent(in),optional :: fmin_tol !! convergence tolerance for [[fmin]] (used when `step_mode=3`) 469 | real(wp),intent(in),optional :: backtrack_c !! backtracking linesearch parameter (0,1) 470 | real(wp),intent(in),optional :: backtrack_tau !! backtracking linesearch parameter (0,1) 471 | logical,intent(in),optional :: use_broyden !! use a Broyden update (default is False) 472 | integer,intent(in),optional :: broyden_update_n !! For Broyden mode, update the full Jacobian 473 | !! at most every this many iterations (must be >1) 474 | !! If <=1 then Jacobian is only computed on the 475 | !! first iteration. 476 | procedure(export_func),optional :: export_iteration !! function to export each iteration 477 | procedure(wait_func),optional :: user_input_check !! check for user input (to stop solver if necessary) 478 | logical,intent(in),optional :: verbose !! for verbose status printing 479 | integer,intent(in),optional :: iunit !! unit for verbose printing (assumed to be open). 480 | !! by default this is `output_unit`. 481 | integer,intent(in),optional :: n_uphill_max !! maximum number of consecutive steps 482 | !! to allow where the value of `f` increases 483 | integer,intent(in),optional :: n_intervals !! number of intervals for fixed point linesearch 484 | 485 | integer,intent(in),optional :: sparsity_mode !! sparsity mode: 486 | !! 487 | !! * 1 - assume dense (use dense solver) 488 | !! Must specify `grad` for this mode. 489 | !! * 2 - assume sparse (use LSQR sparse solver). 490 | !! * 3 - assume sparse (use LUSOL sparse solver). 491 | !! * 4 - assume sparse (use LSMR sparse solver). 492 | !! * 5 - assume sparse (use the user provided sparse 493 | !! solver `custom_solver_sparse`). 494 | !! Must also specify `grad_sparse` and the `irow` and `icol` 495 | !! sparsity pattern for `mode>1`. 496 | integer,dimension(:),intent(in),optional :: irow !! sparsity pattern nonzero elements row indices. 497 | !! must be specified with `icol` and be the same length (`n_nonzeros`). 498 | integer,dimension(:),intent(in),optional :: icol !! sparsity pattern nonzero elements column indices 499 | !! must be specified with `icol` and be the same length (`n_nonzeros`). 500 | real(wp),intent(in),optional :: atol !! `LSQR`: relative error in definition of `A` 501 | real(wp),intent(in),optional :: btol !! `LSQR`: relative error in definition of `b` 502 | real(wp),intent(in),optional :: conlim !! `LSQR`: An upper limit on `cond(Abar)`, the apparent 503 | !! condition number of the matrix `Abar`. 504 | real(wp),intent(in),optional :: damp !! `LSQR`: damp factor 505 | integer,intent(in),optional :: itnlim !! `LSQR`: max iterations 506 | integer,intent(in),optional :: nout !! `LSQR`: output unit for printing 507 | integer,intent(in),optional :: lusol_method !! `LUSOL` method: 508 | !! 509 | !! * 0 => TPP: Threshold Partial Pivoting. 510 | !! * 1 => TRP: Threshold Rook Pivoting. 511 | !! * 2 => TCP: Threshold Complete Pivoting. 512 | integer,intent(in),optional :: localSize !! `LSMR`: Number of vectors for local reorthogonalization: 513 | !! 514 | !! * 0 No reorthogonalization is performed. 515 | !! * >0 This many n-vectors "v" (the most recent ones) 516 | !! are saved for reorthogonalizing the next v. 517 | !! 518 | !! localSize need not be more than `min(m,n)`. 519 | !! At most `min(m,n)` vectors will be allocated. 520 | procedure(sparse_solver_func),optional :: custom_solver_sparse !! for `sparsity_mode=5`, this is the 521 | !! user-provided linear solver. 522 | integer,intent(in),optional :: bounds_mode !! how to handle the `x` variable bounds: 523 | !! 524 | !! * 0 = ignore bounds 525 | !! * 1 = scalar mode 526 | !! * 2 = vector mode 527 | !! * 3 = wall mode 528 | !! 529 | !! See [[nlesolver_type:bounds_mode]] for full descriptions. 530 | real(wp),dimension(n),intent(in),optional :: xlow !! lower bounds for `x` (size is `n`). only used if `bounds_mode>0` and 531 | !! both `xlow` and `xupp` are specified. 532 | real(wp),dimension(n),intent(in),optional :: xupp !! upper bounds for `x` (size is `n`). only used if `bounds_mode>0` and 533 | !! both `xlow` and `xupp` are specified. 534 | integer,intent(in),optional :: norm_mode !! how to compute the norm of the function vector: 535 | !! 536 | !! * 1 = 2-norm (optional) 537 | !! * 2 = infinity-norm 538 | !! * 3 = 1-norm 539 | !! 540 | !! See [[nlesolver_type:norm_mode]] for full descriptions. 541 | 542 | logical :: status_ok !! true if there were no errors 543 | 544 | status_ok = .true. 545 | 546 | !required: 547 | me%n = abs(n) 548 | me%m = abs(m) 549 | me%max_iter = abs(max_iter) 550 | me%tol = abs(tol) 551 | me%func => func 552 | if (present(grad)) me%grad => grad 553 | if (present(grad_sparse)) me%grad_sparse => grad_sparse 554 | 555 | !optional: 556 | 557 | if (present(bounds_mode) .and. present(xlow) .and. present(xupp)) then 558 | if (any(xlow>xupp)) then ! check for consistency 559 | status_ok = .false. 560 | call me%set_status(istat = -16, string = 'Error: xlow > xupp') 561 | return 562 | end if 563 | me%bounds_mode = bounds_mode 564 | me%xupp = xupp 565 | me%xlow = xlow 566 | else 567 | me%bounds_mode = NLESOLVER_IGNORE_BOUNDS ! default 568 | end if 569 | 570 | if (present(norm_mode)) then 571 | select case (norm_mode) 572 | case(NLESOLVER_2_NORM ); me%norm => norm_2 573 | case(NLESOLVER_INF_NORM ); me%norm => norm_inf 574 | case(NLESOLVER_1_NORM ); me%norm => norm_1 575 | case default 576 | status_ok = .false. 577 | call me%set_status(istat = -18, string = 'Error: invalid norm_mode:',i=norm_mode) 578 | return 579 | end select 580 | else 581 | me%norm => norm_2 ! default 582 | end if 583 | 584 | if (present(step_mode)) then 585 | select case (step_mode) 586 | case(NLESOLVER_LINESEARCH_SIMPLE); me%linesearch => simple_step 587 | case(NLESOLVER_LINESEARCH_BACKTRACKING); me%linesearch => backtracking_linesearch 588 | case(NLESOLVER_LINESEARCH_EXACT); me%linesearch => exact_linesearch 589 | case(NLESOLVER_LINESEARCH_FIXEDPOINT); me%linesearch => fixed_point_linesearch 590 | case default 591 | status_ok = .false. 592 | call me%set_status(istat = -5, string = 'Error: invalid step_mode:',i=step_mode) 593 | return 594 | end select 595 | else 596 | me%linesearch => simple_step 597 | end if 598 | 599 | if (present(alpha)) me%alpha = abs(alpha) 600 | if (present(alpha_min)) me%alpha_min = abs(alpha_min) 601 | if (present(alpha_max)) me%alpha_max = abs(alpha_max) 602 | if (present(tolx)) me%tolx = abs(tolx) 603 | if (present(backtrack_c)) me%c = abs(backtrack_c) 604 | if (present(backtrack_tau)) me%tau = abs(backtrack_tau) 605 | if (present(use_broyden)) me%use_broyden = use_broyden 606 | if (present(broyden_update_n)) me%broyden_update_n = abs(broyden_update_n) 607 | if (present(verbose)) me%verbose = verbose 608 | if (present(iunit)) me%iunit = iunit 609 | if (present(n_uphill_max)) me%n_uphill_max = abs(n_uphill_max) 610 | if (present(n_intervals)) me%n_intervals = max(abs(n_intervals),1) 611 | if (present(fmin_tol)) me%fmin_tol = abs(fmin_tol) 612 | 613 | if (present(export_iteration)) me%export_iteration => export_iteration 614 | if (present(user_input_check)) me%user_input_check => user_input_check 615 | 616 | ! error checks: 617 | if (me%alphaone) then 618 | status_ok = .false. 619 | call me%set_status(istat = -1, string = 'Error: invalid alpha:',r=me%alpha) 620 | return 621 | end if 622 | if (me%alpha_minone) then 623 | status_ok = .false. 624 | call me%set_status(istat = -2, string = 'Error: invalid alpha_min:',r=me%alpha_min) 625 | return 626 | end if 627 | if (me%alpha_maxone) then 628 | status_ok = .false. 629 | call me%set_status(istat = -3, string = 'Error: invalid alpha_max:',r=me%alpha_max) 630 | return 631 | end if 632 | if (me%alpha_max<=me%alpha_min) then 633 | status_ok = .false. 634 | call me%set_status(istat = -4, string = 'Error: alpha_min must be < alpha_max') 635 | return 636 | end if 637 | if (me%cone) then 638 | status_ok = .false. 639 | call me%set_status(istat = -12, string = 'Error: backtracking linesearch c must be in range (0, 1):',r=me%c) 640 | return 641 | end if 642 | if (me%tauone) then 643 | status_ok = .false. 644 | call me%set_status(istat = -13, string = 'Error: backtracking linesearch tau must be in range (0, 1):',r=me%tau) 645 | return 646 | end if 647 | 648 | ! initialize: 649 | me%n_nonzeros = -1 ! not used 650 | if (allocated(me%irow)) deallocate(me%irow) 651 | if (allocated(me%icol)) deallocate(me%icol) 652 | 653 | if (present(custom_solver_sparse)) me%custom_solver_sparse => custom_solver_sparse 654 | 655 | if (present(sparsity_mode)) then 656 | me%sparsity_mode = sparsity_mode 657 | if (sparsity_mode>NLESOLVER_SPARSITY_DENSE) then ! sparse solver method 658 | if (present(irow) .and. present(icol) .and. present(grad_sparse)) then 659 | if (size(irow) == size(icol)) then 660 | me%n_nonzeros = size(irow) 661 | me%irow = irow 662 | me%icol = icol 663 | else 664 | call me%set_status(istat = -15, string = 'Error: irow and icol must be the same length') 665 | return 666 | end if 667 | else 668 | call me%set_status(istat = -14, string = 'Error: must specify grad_sparse, irow, and icol for sparsity_mode > 1') 669 | return 670 | end if 671 | ! LSQR optional inputs: 672 | if (present(atol)) me%atol = atol 673 | if (present(btol)) me%btol = btol 674 | if (present(conlim)) me%conlim = conlim 675 | if (present(damp)) me%damp = damp 676 | if (present(itnlim)) me%itnlim = itnlim 677 | if (present(nout)) me%nout = nout 678 | 679 | ! LUSOL method 680 | if (present(nout)) me%lusol_method = lusol_method 681 | 682 | ! LSMR optional inputs: 683 | if (present(localSize)) me%localSize = localSize 684 | 685 | end if 686 | if (sparsity_mode==NLESOLVER_SPARSITY_CUSTOM_SPARSE) then 687 | if (.not. associated(me%custom_solver_sparse)) then 688 | call me%set_status(istat = -16, string = 'Error: must specify custom_solver_sparse for sparsity_mode = 5') 689 | return 690 | end if 691 | end if 692 | end if 693 | 694 | if (status_ok) then 695 | call me%set_status(istat = 0, string = 'Class successfully initialized') 696 | end if 697 | 698 | end subroutine initialize_nlesolver_variables 699 | !***************************************************************************************** 700 | 701 | !***************************************************************************************** 702 | !> 703 | ! Main solver. 704 | 705 | subroutine nlesolver_solver(me,x) 706 | 707 | implicit none 708 | 709 | class(nlesolver_type),intent(inout) :: me 710 | real(wp),dimension(:),intent(inout) :: x 711 | 712 | real(wp),dimension(:) ,allocatable :: fvec !! function vector 713 | real(wp),dimension(:,:),allocatable :: fjac !! jacobian matrix [dense] 714 | real(wp),dimension(:), allocatable :: fjac_sparse !! jacobian matrix [sparse] 715 | real(wp),dimension(:), allocatable :: prev_fjac_sparse !! previous jacobian matrix [sparse] 716 | real(wp),dimension(:) ,allocatable :: rhs !! linear system right-hand side 717 | real(wp),dimension(:) ,allocatable :: p !! search direction 718 | real(wp),dimension(:) ,allocatable :: xold !! previous value of `x` 719 | real(wp),dimension(:) ,allocatable :: prev_fvec !! previous function vector 720 | real(wp),dimension(:,:),allocatable :: prev_fjac !! previous jacobian matrix 721 | real(wp),dimension(:,:),allocatable :: delf !! used for Broyden (rank 2 for `matmul`) 722 | real(wp),dimension(:,:),allocatable :: delx !! used for Broyden (rank 2 for `matmul`) 723 | logical :: user_stop !! user stop button flag 724 | integer :: info !! status flag from the [[linear_solver]] 725 | integer :: iter !! iteration counter 726 | real(wp) :: f !! magnitude of `fvec` 727 | real(wp) :: fold !! previous value of `f` 728 | integer :: n_uphill !! number of steps taken in the "uphill" direction 729 | !! (where `f` is increasing) 730 | real(wp) :: delxmag2 !! used for Broyden 731 | logical :: recompute_jac !! if using Broyden, and we want to call the user 732 | !! jacobian routine instead 733 | integer :: broyden_counter !! number of times the broyden update has been used 734 | integer :: alloc_stat !! allocation status flag 735 | type(lsqr_solver_ez) :: sparse_solver !! sparse LSQR solver class 736 | type(lusol_settings) :: lusol_options 737 | integer :: i !! counter 738 | integer,dimension(:),allocatable :: idx, index_array !! for sparse indexing 739 | character(len=10) :: i_str !! string version of `i` for row string 740 | real(wp) :: normA, condA, normr, normAr, normx !! for LSMR 741 | integer :: itn !! for LSMR 742 | 743 | if (me%istat<0) return ! class was not initialized properly 744 | 745 | if (.not. associated(me%func)) then 746 | call me%set_status(istat = -10, string = 'Error: function routine is not associated') 747 | return 748 | end if 749 | if (me%sparsity_mode==NLESOLVER_SPARSITY_DENSE .and. .not. associated(me%grad)) then 750 | call me%set_status(istat = -11, string = 'Error: gradient routine is not associated') 751 | return 752 | end if 753 | if (me%sparsity_mode>NLESOLVER_SPARSITY_DENSE .and. .not. associated(me%grad_sparse)) then 754 | call me%set_status(istat = -11, string = 'Error: gradient routine is not associated') 755 | return 756 | end if 757 | 758 | ! initialize: 759 | iter = 0 760 | n_uphill = 0 761 | recompute_jac = .false. 762 | broyden_counter = 0 763 | 764 | ! allocate the arrays: 765 | alloc_stat = 0 766 | if (alloc_stat==0) allocate(fvec (me%m) , stat=alloc_stat) 767 | 768 | if (me%sparsity_mode==NLESOLVER_SPARSITY_DENSE) then 769 | ! dense 770 | if (alloc_stat==0) allocate(fjac (me%m,me%n) , stat=alloc_stat) 771 | else 772 | ! sparse 773 | if (alloc_stat==0) allocate(fjac_sparse (me%n_nonzeros) , stat=alloc_stat) 774 | if (me%use_broyden .and. alloc_stat==0) allocate(prev_fjac_sparse(me%n_nonzeros) , stat=alloc_stat) 775 | end if 776 | 777 | if (alloc_stat==0) allocate(rhs (me%m) , stat=alloc_stat) 778 | if (alloc_stat==0) allocate(p (me%n) , stat=alloc_stat) 779 | if (alloc_stat==0) allocate(xold (me%n) , stat=alloc_stat) 780 | if (me%use_broyden) then 781 | ! only need these for broyden: 782 | if (alloc_stat==0) allocate(prev_fvec(me%m) , stat=alloc_stat) 783 | if (me%sparsity_mode/=NLESOLVER_SPARSITY_DENSE .and. alloc_stat==0) then 784 | allocate(prev_fjac(me%m,me%n) , stat=alloc_stat) 785 | index_array = [(i, i=1,me%n_nonzeros)] ! an array to index the sparse jacobian elements 786 | end if 787 | if (alloc_stat==0) allocate(delf (me%m,1) , stat=alloc_stat) 788 | if (alloc_stat==0) allocate(delx (me%n,1) , stat=alloc_stat) 789 | end if 790 | if (alloc_stat/=0) then 791 | call me%set_status(istat = -9, string = 'Error: Out of memory') 792 | return 793 | else 794 | me%istat = -998 795 | me%message = 'Unknown error' 796 | end if 797 | 798 | ! evaluate the function: 799 | call me%adjust_x_for_bounds(x) ! if the guess is out of bounds it may also be adjusted first. 800 | call me%func(x,fvec) 801 | f = me%norm(fvec) 802 | 803 | ! check to see if initial guess is a root: 804 | if (f <= me%tol) then 805 | 806 | call me%set_status(istat = 1, string = 'Required accuracy achieved') 807 | 808 | else 809 | 810 | ! main iteration loop: 811 | do iter = 1,me%max_iter 812 | 813 | ! Export the current iteration: 814 | if (associated(me%export_iteration)) call me%export_iteration(x,fvec,iter) 815 | 816 | ! Check for user stop: 817 | if (associated(me%user_input_check)) then 818 | call me%user_input_check(user_stop) 819 | if (user_stop) then 820 | call me%set_status(istat = 4, string = 'Stopped by the user') 821 | exit 822 | end if 823 | end if 824 | 825 | if (me%use_broyden .and. .not. recompute_jac) then 826 | if (iter==1) then 827 | ! always compute Jacobian on the first iteration 828 | !call me%grad(x,fjac) 829 | select case (me%sparsity_mode) 830 | case (NLESOLVER_SPARSITY_DENSE) 831 | call me%grad(x,fjac) 832 | case default ! sparse modes 833 | call me%grad_sparse(x,fjac_sparse) 834 | end select 835 | broyden_counter = 0 836 | else 837 | ! and use Broyden update to estimate Jacobian 838 | ! for subsequent iterations. 839 | 840 | ! note: fvec was computed the last iteration 841 | delx(:,1) = x - xold 842 | delf(:,1) = fvec - prev_fvec 843 | 844 | if (me%sparsity_mode==NLESOLVER_SPARSITY_DENSE) then ! dense 845 | 846 | delxmag2 = dot_product(delx(:,1),delx(:,1)) 847 | if (delxmag2 < eps) then 848 | call me%set_status(istat = -8, & 849 | string = 'Error: Divide by zero when computing Broyden update') 850 | exit 851 | end if 852 | 853 | ! Jacobian estimate: 854 | ! This is the equation from wikipedia : https://en.wikipedia.org/wiki/Broyden%27s_method 855 | fjac = prev_fjac + matmul((delf-matmul(prev_fjac,delx)), transpose(delx)) / delxmag2 856 | 857 | ! see also: eqn 4 in Schubert, which is different ... 858 | 859 | else ! using a sparse option 860 | 861 | ! Just a row-by-row version of the fjac equation above. 862 | ! see L.K. Schubert, 1970 863 | do i = 1, me%m 864 | 865 | idx = pack(index_array, mask = me%irow==i) ! the nonzero elements in this row 866 | if (size(idx)==0) cycle ! no non-zeros in this row 867 | 868 | associate (dx => delx(me%icol(idx),:)) ! nonzero x vec for this row 869 | delxmag2 = dot_product(dx(:,1),dx(:,1)) ! only those x's for this row 870 | if (delxmag2 < eps) then 871 | write(i_str,'(I10)') i 872 | call me%set_status(istat = -8, & 873 | string = 'Error: Divide by zero when computing sparse Broyden update for row '//& 874 | trim(adjustl(i_str))) 875 | exit 876 | end if 877 | fjac_sparse(idx) = prev_fjac_sparse(idx) + & 878 | matmul((delf(i,1)-matmul(prev_fjac_sparse(idx),dx)), transpose(dx)) / delxmag2 879 | end associate 880 | 881 | end do 882 | 883 | end if 884 | broyden_counter = broyden_counter + 1 885 | end if 886 | prev_fvec = fvec 887 | if (me%sparsity_mode==NLESOLVER_SPARSITY_DENSE) then 888 | prev_fjac = fjac 889 | else 890 | prev_fjac_sparse = fjac_sparse 891 | end if 892 | else 893 | ! compute the jacobian: 894 | select case (me%sparsity_mode) 895 | case (NLESOLVER_SPARSITY_DENSE) 896 | call me%grad(x,fjac) 897 | case default ! sparse 898 | call me%grad_sparse(x,fjac_sparse) 899 | end select 900 | recompute_jac = .false. ! for broyden 901 | broyden_counter = 0 902 | end if 903 | 904 | xold = x 905 | fold = f 906 | 907 | ! compute the search direction p by solving linear system: 908 | rhs = -fvec ! RHS of the linear system 909 | select case (me%sparsity_mode) 910 | 911 | case (NLESOLVER_SPARSITY_DENSE) 912 | ! use dense solver 913 | call linear_solver(me%m,me%n,fjac,rhs,p,info) 914 | 915 | case (NLESOLVER_SPARSITY_LSQR) 916 | ! initialize the LSQR sparse solver 917 | call sparse_solver%initialize(me%m,me%n,fjac_sparse,me%irow,me%icol,& 918 | atol = me%atol, & 919 | btol = me%btol, & 920 | conlim = me%conlim, & 921 | itnlim = me%itnlim, & 922 | nout = me%nout) 923 | call sparse_solver%solve(rhs,me%damp,p,info) ! solve the linear system 924 | ! check convergence: 925 | select case (info) 926 | case(4) 927 | call me%set_status(istat = -1004, & 928 | string = 'LSQR Error: The system appears to be ill-conditioned. istop =', i=info) 929 | exit 930 | case(5) 931 | call me%set_status(istat = -1005, & 932 | string = 'LSQR Error: The iteration limit was reached. istop =', i=info) 933 | exit 934 | case default 935 | info = 0 936 | end select 937 | 938 | case (NLESOLVER_SPARSITY_LUSOL) 939 | ! use lusol solver 940 | lusol_options%method = me%lusol_method 941 | call solve(me%n,me%m,me%n_nonzeros,me%irow,me%icol,fjac_sparse,rhs,p,info,& 942 | settings=lusol_options) 943 | 944 | case (NLESOLVER_SPARSITY_LSMR) 945 | 946 | ! use LSMR solver: 947 | !me%conlim = 1.0_wp/(100*epsilon(1.0_wp)) 948 | call lsmr_ez ( me%m, me%n, me%irow, me%icol, fjac_sparse, rhs, me%damp, & 949 | me%atol, me%btol, me%conlim, me%itnlim, me%localSize, me%nout, & 950 | p, info, itn, normA, condA, normr, normAr, normx ) 951 | 952 | ! check convergence: 953 | select case (info) 954 | case(4) 955 | call me%set_status(istat = -1004, & 956 | string = 'LSMR Error: The system appears to be ill-conditioned. istop =', i=info) 957 | exit 958 | case(5) 959 | call me%set_status(istat = -1005, & 960 | string = 'LSMR Error: The iteration limit was reached. istop =', i=info) 961 | exit 962 | case default 963 | info = 0 964 | end select 965 | 966 | case (NLESOLVER_SPARSITY_CUSTOM_SPARSE) 967 | if (associated(me%custom_solver_sparse)) then 968 | ! a user-provided sparse solver: 969 | call me%custom_solver_sparse(me%n,me%m,me%n_nonzeros,me%irow,me%icol,fjac_sparse,rhs,p,info) 970 | else 971 | call me%set_status(istat = -1006, & 972 | string = 'Error: The custom_solver_sparse procedure has not been set.') 973 | exit 974 | end if 975 | case default 976 | error stop 'invalid sparsity_mode' 977 | end select 978 | 979 | ! check for errors: 980 | if (info /= 0) then 981 | 982 | call me%set_status(istat = -6, string = 'Error solving linear system. info =', i=info) 983 | exit 984 | 985 | else 986 | 987 | ! next step, using the specified method: 988 | call me%linesearch(xold,p,x,f,fvec,fjac,fjac_sparse) 989 | 990 | ! keep track of the number of steps in the "uphill" direction: 991 | if (f>fold) then 992 | n_uphill = n_uphill + 1 993 | else 994 | n_uphill = 0 995 | end if 996 | 997 | ! check for stopping conditions 998 | if (f <= me%tol) then 999 | 1000 | call me%set_status(istat = 1, string = 'Required accuracy achieved') 1001 | exit 1002 | 1003 | elseif ( maxval(abs(x-xold)) <= me%tolx ) then 1004 | 1005 | call me%set_status(istat = 2, string = 'Solution cannot be improved') 1006 | exit 1007 | 1008 | elseif (iter == me%max_iter) then 1009 | 1010 | call me%set_status(istat = 3, string = 'Maximum number of iterations reached') 1011 | exit 1012 | 1013 | elseif (n_uphill > me%n_uphill_max) then 1014 | 1015 | call me%set_status(istat = 5, string = 'Too many steps in the uphill direction') 1016 | exit 1017 | 1018 | elseif (me%use_broyden) then 1019 | 1020 | ! If delxmag2 is too small when using broyden, just 1021 | ! call the user-supplied jacobian function to avoid 1022 | ! a divide by zero on the next step. This should 1023 | ! normally only happen when the solution is almost converged. 1024 | if (norm2(x-xold)**2 <= eps) then 1025 | recompute_jac = .true. 1026 | else 1027 | if (me%broyden_update_n>0) then 1028 | ! Note that we also recompute if we have taken an uphill step 1029 | if (broyden_counter==me%broyden_update_n .or. n_uphill>0) then 1030 | ! time to recompute the full jacobian 1031 | recompute_jac = .true. 1032 | end if 1033 | end if 1034 | end if 1035 | 1036 | endif 1037 | 1038 | end if 1039 | 1040 | end do !end of iterations loop 1041 | 1042 | end if 1043 | 1044 | !Export the last iteration: 1045 | iter = iter + 1 1046 | if (associated(me%export_iteration)) call me%export_iteration(x,fvec,iter) 1047 | 1048 | end subroutine nlesolver_solver 1049 | !***************************************************************************************** 1050 | 1051 | !***************************************************************************************** 1052 | !> 1053 | ! if necessary, adjust the `x` vector to be within the bounds. 1054 | ! used for the initial guess. 1055 | 1056 | subroutine adjust_x_for_bounds(me,x) 1057 | 1058 | implicit none 1059 | 1060 | class(nlesolver_type),intent(inout) :: me 1061 | real(wp),dimension(me%n),intent(inout) :: x !! the `x` vector to adjust 1062 | 1063 | integer :: i !! counter 1064 | 1065 | if (me%bounds_mode/=NLESOLVER_IGNORE_BOUNDS) then 1066 | ! for all bounds modes, adjust the initial guess to be within the bounds 1067 | ! x = min(max(x,me%xlow),me%xupp) 1068 | do i = 1, me%n 1069 | if (x(i)me%xupp(i)) then 1073 | x(i) = me%xupp(i) 1074 | if (me%verbose) write(me%iunit, '(A)') 'Initial x('//int2str(i)//') > xupp(i) : adjusting to upper bound' 1075 | end if 1076 | end do 1077 | end if 1078 | 1079 | end subroutine adjust_x_for_bounds 1080 | !***************************************************************************************** 1081 | 1082 | !***************************************************************************************** 1083 | !> 1084 | ! if necessary, adjust the search direction vector `p` so that bounds are not violated. 1085 | ! 1086 | !### Reference 1087 | ! * https://openmdao.org/newdocs/versions/latest/features/building_blocks/solvers/bounds_enforce.html 1088 | 1089 | subroutine adjust_search_direction(me,x,p,pnew,modified) 1090 | 1091 | implicit none 1092 | 1093 | class(nlesolver_type),intent(inout) :: me 1094 | real(wp),dimension(me%n),intent(in) :: x !! initial `x`. it is assumed that this does not violate any bounds. 1095 | real(wp),dimension(me%n),intent(in) :: p !! search direction `p = xnew - x` 1096 | real(wp),dimension(me%n),intent(out) :: pnew !! new search direction 1097 | logical,dimension(me%n),intent(out) :: modified !! indicates the elements of `p` that were modified 1098 | 1099 | integer :: i !! counter 1100 | real(wp),dimension(:),allocatable :: xnew !! `x + pnew` 1101 | logical :: search_direction_modifed !! if `p` has been modified 1102 | real(wp) :: t !! indep var in the step equation: `xnew = x + t*p` 1103 | 1104 | if (me%bounds_mode==NLESOLVER_IGNORE_BOUNDS) then ! no change 1105 | modified = .false. 1106 | pnew = p 1107 | return 1108 | end if 1109 | 1110 | allocate(xnew(me%n)) 1111 | xnew = x + p ! this is the full Newton step 1112 | search_direction_modifed = .false. ! will be set to true if any bounds are violated 1113 | if (me%bounds_mode==NLESOLVER_VECTOR_BOUNDS) t = 1.0_wp ! for mode 2, start with full newton step 1114 | ! note: have to check each variable and 1115 | ! choose the smallest t. don't need to 1116 | ! keep track of xnew. 1117 | modified = .false. 1118 | 1119 | do i = 1, me%n 1120 | if (xnew(i)me%xupp(i)) then 1129 | search_direction_modifed = .true. 1130 | modified(i) = .true. 1131 | if (me%verbose) write(me%iunit, '(A)') 'x('//int2str(i)//') > xupp(i) : adjusting to upper bound' 1132 | select case (me%bounds_mode) 1133 | case(NLESOLVER_SCALAR_BOUNDS,NLESOLVER_WALL_BOUNDS); xnew(i) = me%xupp(i) 1134 | case(NLESOLVER_VECTOR_BOUNDS); t = min(t,(me%xupp(i)-x(i))/p(i)) 1135 | end select 1136 | end if 1137 | end do 1138 | 1139 | if (search_direction_modifed) then 1140 | ! adjust the search direction: 1141 | select case (me%bounds_mode) 1142 | case (NLESOLVER_SCALAR_BOUNDS,NLESOLVER_WALL_BOUNDS) 1143 | pnew = xnew - x ! here we have changed the search direction vector 1144 | if (all(pnew==0.0_wp)) call me%set_status(istat = -17, string = 'Error adjusting line search direction for bounds') 1145 | case (NLESOLVER_VECTOR_BOUNDS) 1146 | ! here was are staying on the original search direction vector, just walking back 1147 | if (t <= 0.0_wp) then ! something wrong 1148 | call me%set_status(istat = -17, string = 'Error adjusting line search direction for bounds') 1149 | pnew = p 1150 | else 1151 | pnew = p / t 1152 | end if 1153 | end select 1154 | if (me%verbose) write(me%iunit, '(A)') 'Search direction modified to be within bounds' 1155 | else 1156 | pnew = p 1157 | end if 1158 | 1159 | end subroutine adjust_search_direction 1160 | !***************************************************************************************** 1161 | 1162 | !***************************************************************************************** 1163 | !> 1164 | ! Compute the next step. 1165 | 1166 | subroutine compute_next_step(me, xold, search_direction, alpha, modified, xnew) 1167 | 1168 | class(nlesolver_type),intent(inout) :: me 1169 | real(wp),dimension(me%n),intent(in) :: xold !! initial `x` 1170 | real(wp),dimension(me%n),intent(in) :: search_direction !! search direction vector 1171 | real(wp),intent(in) :: alpha !! step length to take in the search direction 1172 | logical,dimension(me%n),intent(in) :: modified !! indicates the elements of `p` that were 1173 | !! modified because they violated the bounds. 1174 | !! Output of [[adjust_search_direction]]. 1175 | real(wp),dimension(me%n),intent(out) :: xnew !! final `x` 1176 | 1177 | if (me%bounds_mode == NLESOLVER_WALL_BOUNDS) then 1178 | ! for the 'wall' mode, the modified variables are held fixed during the step 1179 | where (modified) 1180 | xnew = xold 1181 | else where 1182 | xnew = xold + search_direction * alpha 1183 | end where 1184 | else 1185 | ! all other modes just use the computed search direction 1186 | xnew = xold + search_direction * alpha 1187 | end if 1188 | 1189 | end subroutine compute_next_step 1190 | !***************************************************************************************** 1191 | 1192 | !***************************************************************************************** 1193 | !> 1194 | ! 2-norm function 1195 | 1196 | pure function norm_2(me, fvec) result(f) 1197 | 1198 | class(nlesolver_type),intent(in) :: me 1199 | real(wp),dimension(me%m),intent(in) :: fvec !! the function vector 1200 | real(wp) :: f !! norm of the vector 1201 | 1202 | f = norm2(fvec) 1203 | 1204 | end function norm_2 1205 | !***************************************************************************************** 1206 | 1207 | !***************************************************************************************** 1208 | !> 1209 | ! 1-norm function 1210 | 1211 | pure function norm_1(me, fvec) result(f) 1212 | 1213 | class(nlesolver_type),intent(in) :: me 1214 | real(wp),dimension(me%m),intent(in) :: fvec !! the function vector 1215 | real(wp) :: f !! norm of the vector 1216 | 1217 | f = sum(abs(fvec)) 1218 | 1219 | end function norm_1 1220 | !***************************************************************************************** 1221 | 1222 | !***************************************************************************************** 1223 | !> 1224 | ! Infinity-norm function 1225 | 1226 | pure function norm_inf(me, fvec) result(f) 1227 | 1228 | class(nlesolver_type),intent(in) :: me 1229 | real(wp),dimension(me%m),intent(in) :: fvec !! the function vector 1230 | real(wp) :: f !! norm of the vector 1231 | 1232 | f = maxval(abs(fvec)) 1233 | 1234 | end function norm_inf 1235 | !***************************************************************************************** 1236 | 1237 | !***************************************************************************************** 1238 | !> 1239 | ! Destructor 1240 | 1241 | subroutine destroy_nlesolver_variables(me) 1242 | 1243 | implicit none 1244 | 1245 | class(nlesolver_type),intent(out) :: me 1246 | 1247 | me%message = 'Error: class has not been initialized' 1248 | me%istat = -999 1249 | 1250 | end subroutine destroy_nlesolver_variables 1251 | !***************************************************************************************** 1252 | 1253 | !***************************************************************************************** 1254 | !> 1255 | ! Solve the linear system: \( Ax = b \), using a dense, direct method. 1256 | ! 1257 | ! * if `n=m` : use LAPACK `dgesv` (LU decomposition) 1258 | ! * if `n/=m` : use LAPACK `dgels` (if m>n uses QR factorization, 1259 | ! if m 1340 | ! Take a simple step in the search direction of `p * alpha`. 1341 | 1342 | subroutine simple_step(me,xold,p,x,f,fvec,fjac,fjac_sparse) 1343 | 1344 | implicit none 1345 | 1346 | class(nlesolver_type),intent(inout) :: me 1347 | real(wp),dimension(me%n),intent(in) :: xold !! previous value of `x` 1348 | real(wp),dimension(me%n),intent(in) :: p !! search direction 1349 | real(wp),dimension(me%n),intent(out) :: x !! new `x` 1350 | real(wp),intent(inout) :: f !! magnitude of `fvec` 1351 | real(wp),dimension(me%m),intent(inout) :: fvec !! function vector 1352 | real(wp),dimension(:,:),intent(in),optional :: fjac !! jacobian matrix [dense] 1353 | real(wp),dimension(:),intent(in),optional :: fjac_sparse !! jacobian matrix [sparse] 1354 | 1355 | real(wp),dimension(:),allocatable :: search_direction 1356 | logical,dimension(:),allocatable :: modified !! indicates the elements of p that were modified 1357 | 1358 | allocate(search_direction(me%n)) 1359 | allocate(modified(me%n)) 1360 | 1361 | call me%adjust_search_direction(xold,p,search_direction,modified) 1362 | call me%compute_next_step(xold, search_direction, me%alpha, modified, x) 1363 | 1364 | !evaluate the function at the new point: 1365 | call me%func(x,fvec) 1366 | f = me%norm(fvec) 1367 | 1368 | end subroutine simple_step 1369 | !***************************************************************************************** 1370 | 1371 | !***************************************************************************************** 1372 | !> 1373 | ! Backtracking line search. 1374 | ! 1375 | !### See also 1376 | ! * [Backtracking line search](https://en.wikipedia.org/wiki/Backtracking_line_search) 1377 | ! 1378 | !@note Either `fjac` or `fjac_sparse` should be present. 1379 | 1380 | subroutine backtracking_linesearch(me,xold,p,x,f,fvec,fjac,fjac_sparse) 1381 | 1382 | implicit none 1383 | 1384 | class(nlesolver_type),intent(inout) :: me 1385 | real(wp),dimension(me%n),intent(in) :: xold !! previous value of `x` 1386 | real(wp),dimension(me%n),intent(in) :: p !! search direction 1387 | real(wp),dimension(me%n),intent(out) :: x !! new `x` 1388 | real(wp),intent(inout) :: f !! magnitude of `fvec` 1389 | real(wp),dimension(me%m),intent(inout) :: fvec !! function vector 1390 | real(wp),dimension(:,:),intent(in),optional :: fjac !! jacobian matrix [dense] 1391 | real(wp),dimension(:),intent(in),optional :: fjac_sparse !! jacobian matrix [sparse] 1392 | 1393 | integer :: i !! counter 1394 | real(wp) :: slope !! local slope of the function of `alpha` along the search direction used for line search 1395 | logical :: min_alpha_reached !! if the minimum step size is reached during the line search 1396 | real(wp) :: alpha !! `alpha` for the line search 1397 | real(wp) :: ftmp !! `f` value for linesearch 1398 | real(wp) :: t !! used for line search 1399 | real(wp),dimension(:),allocatable :: gradf !! line search objective function gradient vector 1400 | real(wp),dimension(:),allocatable :: xtmp !! `x` value for linesearch 1401 | real(wp),dimension(:),allocatable :: fvectmp !! `fvec` value for linesearch 1402 | real(wp),dimension(:),allocatable :: search_direction !! search direction to use (can be modified from `p` if bounds are violated) 1403 | logical,dimension(:),allocatable :: modified !! indicates the elements of p that were modified 1404 | 1405 | ! allocate arrays: 1406 | allocate(gradf(me%n)) 1407 | allocate(xtmp(me%n)) 1408 | allocate(fvectmp(me%m)) 1409 | allocate(search_direction(me%n)) 1410 | allocate(modified(me%n)) 1411 | 1412 | ! set the search direction: 1413 | call me%adjust_search_direction(xold,p,search_direction,modified) 1414 | 1415 | ! compute the gradient of the function to be minimized 1416 | ! (which in this case is 1/2 the norm of fvec). Use the chain 1417 | ! rule and the Jacobian matrix already computed. 1418 | if (present(fjac)) then 1419 | ! dense 1420 | do i=1,me%n 1421 | gradf(i) = dot_product(fvec,fjac(:,i)) 1422 | end do 1423 | else 1424 | ! sparse 1425 | do i=1,me%n 1426 | gradf(i) = dot_product(fvec,pack(fjac_sparse,mask=me%icol==i)) 1427 | end do 1428 | end if 1429 | slope = dot_product(search_direction, gradf) 1430 | t = -me%c * slope 1431 | 1432 | if (me%verbose) then 1433 | write(me%iunit,'(1P,*(A,1X,E16.6))') ' slope = ', slope 1434 | write(me%iunit,'(1P,*(A,1X,E16.6))') ' t = ', t 1435 | end if 1436 | 1437 | ! perform the line search: 1438 | 1439 | min_alpha_reached = .false. ! initialize 1440 | alpha = me%alpha_max ! start with the largest step 1441 | do 1442 | 1443 | call me%compute_next_step(xold, search_direction, alpha, modified, xtmp) 1444 | call me%func(xtmp,fvectmp) 1445 | ftmp = me%norm(fvectmp) 1446 | 1447 | if (me%verbose) then 1448 | write(me%iunit,'(1P,*(A,1X,E16.6))') ' alpha = ', alpha, ' f = ', ftmp 1449 | if (f - ftmp >= alpha*t) then 1450 | write(me%iunit,'(1P,2(A,1X,E16.6),1X,A)') ' f - ftmp = ', f - ftmp, ' alpha*t = ', alpha*t, ' [ACCEPTED]' 1451 | else 1452 | write(me%iunit,'(1P,*(A,1X,E16.6))') ' f - ftmp = ', f - ftmp, ' alpha*t = ', alpha*t 1453 | end if 1454 | end if 1455 | 1456 | if (((f - ftmp) / 2.0_wp >= alpha*t) .or. min_alpha_reached) then 1457 | if (me%verbose .and. min_alpha_reached) then 1458 | write(me%iunit,'(A)') ' Minimum alpha reached' 1459 | end if 1460 | ! Armijo-Goldstein condition is satisfied 1461 | ! (or the min step has been reached) 1462 | x = xtmp 1463 | fvec = fvectmp 1464 | f = ftmp 1465 | exit 1466 | end if 1467 | alpha = alpha * me%tau ! reduce step size 1468 | 1469 | if (alpha<=me%alpha_min) then 1470 | alpha = me%alpha_min 1471 | min_alpha_reached = .true. ! will stop on the next step 1472 | end if 1473 | 1474 | end do 1475 | 1476 | end subroutine backtracking_linesearch 1477 | !***************************************************************************************** 1478 | 1479 | !***************************************************************************************** 1480 | !> 1481 | ! An exact linesearch that uses a derivative-free minimizer to 1482 | ! find the minimum value of `f(x)` between 1483 | ! `x = xold + p * alpha_min` and 1484 | ! `x = xold + p * alpha_max`. 1485 | ! 1486 | ! Usually this is overkill and not necessary, but is here as an option for testing. 1487 | 1488 | subroutine exact_linesearch(me,xold,p,x,f,fvec,fjac,fjac_sparse) 1489 | 1490 | implicit none 1491 | 1492 | class(nlesolver_type),intent(inout) :: me 1493 | real(wp),dimension(me%n),intent(in) :: xold !! previous value of `x` 1494 | real(wp),dimension(me%n),intent(in) :: p !! search direction 1495 | real(wp),dimension(me%n),intent(out) :: x !! new `x` 1496 | real(wp),intent(inout) :: f !! magnitude of `fvec` 1497 | real(wp),dimension(me%m),intent(inout) :: fvec !! function vector 1498 | real(wp),dimension(:,:),intent(in),optional :: fjac !! jacobian matrix [dense] 1499 | real(wp),dimension(:),intent(in),optional :: fjac_sparse !! jacobian matrix [sparse] 1500 | 1501 | real(wp),dimension(:),allocatable :: xnew !! used in [[func_for_fmin]] 1502 | real(wp) :: alpha_min 1503 | real(wp),dimension(:),allocatable :: search_direction !! search direction to use (may be modified from `p` if bounds are violated) 1504 | logical,dimension(:),allocatable :: modified !! indicates the elements of p that were modified 1505 | 1506 | allocate(xnew(me%n)) 1507 | allocate(search_direction(me%n)) 1508 | allocate(modified(me%n)) 1509 | 1510 | ! find the minimum value of f in the range of alphas: 1511 | alpha_min = fmin(func_for_fmin,me%alpha_min,me%alpha_max,me%fmin_tol) 1512 | 1513 | if (me%verbose) write(me%iunit,'(1P,*(A,1X,E16.6))') ' alpha_min = ', alpha_min 1514 | 1515 | call me%adjust_search_direction(xold,p,search_direction,modified) 1516 | call me%compute_next_step(xold, search_direction, alpha_min, modified, x) 1517 | if (all(x==xnew)) then 1518 | ! already computed in the func 1519 | else 1520 | call me%func(x,fvec) 1521 | f = me%norm(fvec) 1522 | end if 1523 | 1524 | contains 1525 | 1526 | real(wp) function func_for_fmin(alpha) 1527 | !! function for [[fmin]] 1528 | implicit none 1529 | real(wp),intent(in) :: alpha !! indep variable 1530 | 1531 | call me%compute_next_step(xold, search_direction, alpha, modified, xnew) 1532 | call me%func(xnew,fvec) 1533 | func_for_fmin = me%norm(fvec) ! return result 1534 | 1535 | f = func_for_fmin ! just in case this is the solution 1536 | 1537 | end function func_for_fmin 1538 | 1539 | end subroutine exact_linesearch 1540 | !***************************************************************************************** 1541 | 1542 | !***************************************************************************************** 1543 | !> 1544 | ! A simple search that just evaluates the function at a specified 1545 | ! number of points and picks the one with the minimum function value. 1546 | 1547 | subroutine fixed_point_linesearch(me,xold,p,x,f,fvec,fjac,fjac_sparse) 1548 | 1549 | implicit none 1550 | 1551 | class(nlesolver_type),intent(inout) :: me 1552 | real(wp),dimension(me%n),intent(in) :: xold !! previous value of `x` 1553 | real(wp),dimension(me%n),intent(in) :: p !! search direction 1554 | real(wp),dimension(me%n),intent(out) :: x !! new `x` 1555 | real(wp),intent(inout) :: f !! magnitude of `fvec` 1556 | real(wp),dimension(me%m),intent(inout) :: fvec !! function vector 1557 | real(wp),dimension(:,:),intent(in),optional :: fjac !! jacobian matrix [dense] 1558 | real(wp),dimension(:),intent(in),optional :: fjac_sparse !! jacobian matrix [sparse] 1559 | 1560 | integer :: i !! counter 1561 | integer :: n_points !! number of points to compute 1562 | real(wp),dimension(:),allocatable :: alphas_to_try !! set of `alpha` values to try 1563 | real(wp),dimension(:),allocatable :: x_tmp !! temp `x` 1564 | real(wp),dimension(:),allocatable :: fvec_tmp !! temp `fvec` 1565 | real(wp) :: f_tmp !! temp `f` 1566 | real(wp) :: step_size !! step size for `alpha` 1567 | integer :: n !! number of steps to divide the interval 1568 | real(wp),dimension(:),allocatable :: search_direction !! search direction to use (may be modified from `p` if bounds are violated) 1569 | logical,dimension(:),allocatable :: modified !! indicates the elements of p that were modified 1570 | 1571 | ! 1 o-----------o 1572 | ! 2 o-----o-----o 1573 | ! 3 o---o---o---o 1574 | 1575 | n = me%n_intervals 1576 | n_points = n + 1 1577 | 1578 | allocate(alphas_to_try(n_points)) 1579 | allocate(x_tmp(me%n)) 1580 | allocate(fvec_tmp(me%m)) 1581 | allocate(search_direction(me%n)) 1582 | allocate(modified(me%n)) 1583 | 1584 | step_size = (me%alpha_max - me%alpha_min) / real(n,wp) 1585 | 1586 | ! compute the alphas: 1587 | alphas_to_try(1) = me%alpha_min 1588 | do i = 2, n 1589 | alphas_to_try(i) = alphas_to_try(i-1) + step_size 1590 | end do 1591 | alphas_to_try(n_points) = me%alpha_max 1592 | 1593 | ! now compute the functions at these alphas: 1594 | f = big 1595 | call me%adjust_search_direction(xold,p,search_direction,modified) 1596 | do i = 1, n_points 1597 | 1598 | call me%compute_next_step(xold, search_direction, alphas_to_try(i), modified, x_tmp) 1599 | 1600 | ! evaluate the function at this point: 1601 | call me%func(x_tmp,fvec_tmp) 1602 | f_tmp = me%norm(fvec_tmp) 1603 | 1604 | if (f_tmp<=f) then ! new best point 1605 | x = x_tmp 1606 | f = f_tmp 1607 | fvec = fvec_tmp 1608 | end if 1609 | 1610 | end do 1611 | 1612 | end subroutine fixed_point_linesearch 1613 | !***************************************************************************************** 1614 | 1615 | !****************************************************************************************************** 1616 | end module nlesolver_module 1617 | !****************************************************************************************************** -------------------------------------------------------------------------------- /test/nlesolver_test_1.f90: -------------------------------------------------------------------------------- 1 | !****************************************************************************************************** 2 | !> 3 | ! Test of a small, square (`n=m`) problem. 4 | 5 | program nlesolver_test_1 6 | 7 | use nlesolver_module, wp => nlesolver_rk 8 | 9 | implicit none 10 | 11 | integer,parameter :: n = 2 12 | integer,parameter :: m = 2 13 | integer,parameter :: max_iter = 100 14 | real(wp),parameter :: tol = 1.0e-8_wp 15 | logical,parameter :: verbose = .false. 16 | 17 | type(nlesolver_type) :: solver 18 | real(wp) :: alpha 19 | logical :: use_broyden 20 | integer :: step_mode 21 | integer :: n_intervals 22 | integer :: istat !! Integer status code. 23 | character(len=:),allocatable :: message !! Text status message 24 | real(wp),dimension(n) :: x 25 | integer :: f_evals 26 | integer :: i 27 | character(len=:),allocatable :: description 28 | real(wp) :: fmin_tol 29 | integer :: bounds_mode 30 | 31 | fmin_tol = 1.0e-2_wp ! don't need a tight tol for this 32 | n_intervals = 2 33 | alpha = 1.0_wp 34 | 35 | write(*,*) '' 36 | write(*,*) '***********************' 37 | write(*,*) '* nlesolver_test_1 *' 38 | write(*,*) '***********************' 39 | write(*,*) '' 40 | do i = 1, 11 41 | 42 | bounds_mode = NLESOLVER_IGNORE_BOUNDS ! default 43 | 44 | select case (i) 45 | case(1) 46 | step_mode = 1 47 | use_broyden = .false. 48 | f_evals = 0 49 | description = 'Constant alpha' 50 | case(2) 51 | step_mode = 1 52 | use_broyden = .true. 53 | f_evals = 0 54 | description = 'Constant alpha + broyden' 55 | case(3) 56 | step_mode = 2 57 | use_broyden = .false. 58 | f_evals = 0 59 | description = 'Backtracking line search' 60 | case(4) 61 | step_mode = 2 62 | use_broyden = .true. 63 | f_evals = 0 64 | description = 'Backtracking line search + broyden' 65 | case(5) 66 | step_mode = 3 67 | use_broyden = .false. 68 | f_evals = 0 69 | description = 'Exact line search' 70 | case(6) 71 | step_mode = 3 72 | use_broyden = .true. 73 | f_evals = 0 74 | description = 'Exact line search + broyden' 75 | case(7) 76 | step_mode = 4 77 | use_broyden = .false. 78 | f_evals = 0 79 | description = 'Fixed point search' 80 | case(8) 81 | step_mode = 4 82 | use_broyden = .true. 83 | f_evals = 0 84 | description = 'Fixed point search + broyden' 85 | 86 | case(9) 87 | step_mode = 4 88 | use_broyden = .true. 89 | f_evals = 0 90 | description = 'Fixed point search + broyden + scalar bounds' 91 | bounds_mode = NLESOLVER_SCALAR_BOUNDS 92 | case(10) 93 | step_mode = 4 94 | use_broyden = .true. 95 | f_evals = 0 96 | description = 'Fixed point search + broyden + vector bounds' 97 | bounds_mode = NLESOLVER_VECTOR_BOUNDS 98 | case(11) 99 | step_mode = 4 100 | use_broyden = .true. 101 | f_evals = 0 102 | description = 'Fixed point search + broyden + wall bounds' 103 | bounds_mode = NLESOLVER_WALL_BOUNDS 104 | 105 | case default 106 | error stop 'invalid case' 107 | end select 108 | 109 | write(*,*) '-------------------------------------------------------' 110 | write(*,'(A,I3,A,A)') 'Case ', i, ' : ', description 111 | write(*,*) '' 112 | 113 | call solver%initialize( n = n, & 114 | m = m, & 115 | max_iter = max_iter, & 116 | tol = tol, & 117 | func = func, & 118 | grad = grad, & 119 | step_mode = step_mode,& 120 | use_broyden = use_broyden,& 121 | export_iteration = export,& 122 | n_intervals = n_intervals, & 123 | fmin_tol = fmin_tol, & 124 | verbose = verbose, & 125 | bounds_mode = NLESOLVER_SCALAR_BOUNDS, & 126 | xlow = [0.0_wp, -5.0_wp], & 127 | xupp = [1.0_wp, 0.0_wp]) 128 | call solver%status(istat, message) 129 | write(*,'(I3,1X,A)') istat, message 130 | if (istat /= 0) error stop 131 | 132 | x = [1.0_wp, 2.0_wp] 133 | call solver%solve(x) 134 | 135 | call solver%status(istat, message) 136 | write(*,'(I3,1X,A)') istat, message 137 | write(*,*) '' 138 | 139 | end do 140 | 141 | contains 142 | 143 | subroutine func(me,x,f) 144 | !! compute the function 145 | implicit none 146 | class(nlesolver_type),intent(inout) :: me 147 | real(wp),dimension(:),intent(in) :: x 148 | real(wp),dimension(:),intent(out) :: f 149 | 150 | f_evals = f_evals + 1 151 | 152 | f(1) = x(1)**2 + x(2) - 0.1_wp 153 | f(2) = x(2) + 0.2_wp 154 | 155 | ! root is 5.477226E-01 -2.000000E-01 156 | 157 | end subroutine func 158 | 159 | subroutine grad(me,x,g) 160 | !! compute the gradient of the function (Jacobian): 161 | implicit none 162 | class(nlesolver_type),intent(inout) :: me 163 | real(wp),dimension(:),intent(in) :: x 164 | real(wp),dimension(:,:),intent(out) :: g 165 | 166 | f_evals = f_evals + 2 ! to approximate forward diff derivatives 167 | 168 | g(1,1) = 2.0_wp * x(1) !df(1)/dx 169 | g(2,1) = 0.0_wp !df(2)/dx 170 | 171 | g(1,2) = 1.0_wp !df(1)/dy 172 | g(2,2) = 1.0_wp !df(2)/dy 173 | 174 | end subroutine grad 175 | 176 | subroutine export(me,x,f,iter) 177 | !! export an iteration: 178 | implicit none 179 | class(nlesolver_type),intent(inout) :: me 180 | real(wp),dimension(:),intent(in) :: x 181 | real(wp),dimension(:),intent(in) :: f 182 | integer,intent(in) :: iter !! iteration number 183 | 184 | write(*,'(1P,I3,1X,A,I3,A,*(E15.6))') iter, '(',f_evals,')', x, norm2(f) 185 | 186 | end subroutine export 187 | 188 | !****************************************************************************************************** 189 | end program nlesolver_test_1 190 | !****************************************************************************************************** -------------------------------------------------------------------------------- /test/sparse_test.f90: -------------------------------------------------------------------------------- 1 | !****************************************************************************************************** 2 | !> 3 | ! Test of a sparse problem. 4 | 5 | program sparse_test 6 | 7 | use nlesolver_module, wp => nlesolver_rk 8 | 9 | implicit none 10 | 11 | integer,parameter :: n = 2 12 | integer,parameter :: m = 2 13 | integer,parameter :: max_iter = 100 14 | real(wp),parameter :: tol = 1.0e-8_wp 15 | logical,parameter :: verbose = .false. 16 | integer,dimension(3),parameter :: icol = [1,2,2] 17 | integer,dimension(3),parameter :: irow = [1,1,2] 18 | 19 | integer :: f_evals 20 | 21 | call go(2, 'LSQR') 22 | call go(3, 'LUSOL') 23 | call go(4, 'LSMR') 24 | 25 | contains 26 | 27 | subroutine go(sparsity_mode, mode_name) 28 | !! run the tests for the specified sparsity mode 29 | 30 | integer,intent(in) :: sparsity_mode 31 | character(len=*),intent(in) :: mode_name !! name of the sparsity mode used 32 | 33 | type(nlesolver_type) :: solver 34 | real(wp) :: alpha 35 | logical :: use_broyden 36 | integer :: step_mode 37 | integer :: n_intervals 38 | integer :: istat !! Integer status code. 39 | character(len=:),allocatable :: message !! Text status message 40 | real(wp),dimension(n) :: x 41 | integer :: i 42 | character(len=:),allocatable :: description 43 | real(wp) :: fmin_tol 44 | 45 | fmin_tol = 1.0e-2_wp ! don't need a tight tol for this 46 | n_intervals = 2 47 | alpha = 1.0_wp 48 | 49 | write(*,*) '' 50 | write(*,*) '***********************' 51 | write(*,*) '* sparse_test : '//trim(mode_name) 52 | write(*,*) '***********************' 53 | write(*,*) '' 54 | do i = 1, 8 55 | 56 | select case (i) 57 | case(1) 58 | step_mode = 1 59 | use_broyden = .false. 60 | f_evals = 0 61 | description = 'Constant alpha' 62 | case(2) 63 | step_mode = 1 64 | use_broyden = .true. 65 | f_evals = 0 66 | description = 'Constant alpha + broyden' 67 | case(3) 68 | step_mode = 2 69 | use_broyden = .false. 70 | f_evals = 0 71 | description = 'Backtracking line search' 72 | case(4) 73 | step_mode = 2 74 | use_broyden = .true. 75 | f_evals = 0 76 | description = 'Backtracking line search + broyden' 77 | case(5) 78 | step_mode = 3 79 | use_broyden = .false. 80 | f_evals = 0 81 | description = 'Exact line search' 82 | case(6) 83 | step_mode = 3 84 | use_broyden = .true. 85 | f_evals = 0 86 | description = 'Exact line search + broyden' 87 | case(7) 88 | step_mode = 4 89 | use_broyden = .false. 90 | f_evals = 0 91 | description = 'Fixed point search' 92 | case(8) 93 | step_mode = 4 94 | use_broyden = .true. 95 | f_evals = 0 96 | description = 'Fixed point search + broyden' 97 | case default 98 | error stop 'invalid case' 99 | end select 100 | 101 | write(*,*) '-------------------------------------------------------' 102 | write(*,'(A,I3,A,A)') 'Case ', i, ' : ', description 103 | write(*,*) '' 104 | 105 | call solver%initialize( n = n, & 106 | m = m, & 107 | max_iter = max_iter, & 108 | tol = tol, & 109 | atol = tol, & 110 | btol = tol, & 111 | func = func, & 112 | grad_sparse = grad_sparse, & 113 | step_mode = step_mode,& 114 | use_broyden = use_broyden,& 115 | export_iteration = export,& 116 | n_intervals = n_intervals, & 117 | fmin_tol = fmin_tol, & 118 | verbose = verbose,& 119 | sparsity_mode = sparsity_mode,& ! lsmr 120 | irow = irow,& 121 | icol = icol,& 122 | damp = 0.0_wp) 123 | call solver%status(istat, message) 124 | write(*,'(I3,1X,A)') istat, message 125 | if (istat /= 0) error stop 126 | 127 | x = [1.0_wp, 2.0_wp] 128 | call solver%solve(x) 129 | 130 | call solver%status(istat, message) 131 | write(*,'(I3,1X,A)') istat, message 132 | write(*,*) '' 133 | 134 | end do 135 | 136 | end subroutine go 137 | 138 | subroutine func(me,x,f) 139 | !! compute the function 140 | implicit none 141 | class(nlesolver_type),intent(inout) :: me 142 | real(wp),dimension(:),intent(in) :: x 143 | real(wp),dimension(:),intent(out) :: f 144 | 145 | f_evals = f_evals + 1 146 | 147 | f(1) = x(1)**2 + x(2) - 0.1_wp 148 | f(2) = x(2) + 0.2_wp 149 | 150 | ! root is 5.477226E-01 -2.000000E-01 151 | 152 | end subroutine func 153 | 154 | subroutine grad(me,x,g) 155 | !! compute the gradient of the function (Jacobian): 156 | implicit none 157 | class(nlesolver_type),intent(inout) :: me 158 | real(wp),dimension(:),intent(in) :: x 159 | real(wp),dimension(:,:),intent(out) :: g 160 | 161 | f_evals = f_evals + 2 ! to approximate forward diff derivatives 162 | 163 | g(1,1) = 2.0_wp * x(1) !df(1)/dx 164 | g(2,1) = 0.0_wp !df(2)/dx 165 | 166 | g(1,2) = 1.0_wp !df(1)/dy 167 | g(2,2) = 1.0_wp !df(2)/dy 168 | 169 | end subroutine grad 170 | 171 | subroutine grad_sparse(me,x,g) 172 | !! compute the gradient of the function (Jacobian): 173 | implicit none 174 | class(nlesolver_type),intent(inout) :: me 175 | real(wp),dimension(:),intent(in) :: x 176 | real(wp),dimension(:),intent(out) :: g 177 | 178 | real(wp),dimension(m,n) :: g_dense 179 | 180 | ! for this example, just convert the dense 181 | ! jacobian to the sparse representation 182 | call grad(me,x,g_dense) 183 | 184 | g(1) = g_dense(1,1) 185 | g(2) = g_dense(1,2) 186 | g(3) = g_dense(2,2) 187 | 188 | f_evals = f_evals + 2 ! to approximate forward diff derivatives 189 | 190 | end subroutine grad_sparse 191 | 192 | subroutine export(me,x,f,iter) 193 | !! export an iteration: 194 | implicit none 195 | class(nlesolver_type),intent(inout) :: me 196 | real(wp),dimension(:),intent(in) :: x 197 | real(wp),dimension(:),intent(in) :: f 198 | integer,intent(in) :: iter !! iteration number 199 | 200 | write(*,'(1P,I3,1X,A,I3,A,*(E15.6))') iter, '(',f_evals,')', x, norm2(f) 201 | 202 | end subroutine export 203 | 204 | !****************************************************************************************************** 205 | end program sparse_test 206 | !****************************************************************************************************** --------------------------------------------------------------------------------