nonlin_core.f90

! nonlin_core.f90
 
 
! ------------------------------------------------------------------------------
 
module nonlin_core
    use, intrinsic :: iso_fortran_env, only : real64, int32
    use nonlin_constants
    implicit none
    private
    public :: vecfcn
    public :: fcn1var
    public :: fcnnvar
    public :: jacobianfcn
    public :: gradientfcn
    public :: vecfcn_helper
    public :: fcn1var_helper
    public :: fcnnvar_helper
    public :: iteration_behavior
    public :: equation_solver
    public :: equation_solver_1var
    public :: equation_optimizer
    public :: value_pair
    public :: nonlin_solver
    public :: nonlin_solver_1var
    public :: nonlin_optimize_fcn
    public :: print_status
 
! ******************************************************************************
! INTERFACES
! ------------------------------------------------------------------------------
    interface
 
        function fcn1var(x) result(f)
            use, intrinsic :: iso_fortran_env, only : real64
            real(real64), intent(in) :: x
            real(real64) :: f
        end function
 
        subroutine vecfcn(x, f)
            use, intrinsic :: iso_fortran_env, only : real64
            real(real64), intent(in), dimension(:) :: x
            real(real64), intent(out), dimension(:) :: f
        end subroutine
 
        subroutine jacobianfcn(x, jac)
            use, intrinsic :: iso_fortran_env, only : real64
            real(real64), intent(in), dimension(:) :: x
            real(real64), intent(out), dimension(:,:) :: jac
        end subroutine
 
        function fcnnvar(x) result(f)
            use, intrinsic :: iso_fortran_env, only : real64
            real(real64), intent(in), dimension(:) :: x
            real(real64) :: f
        end function
 
        subroutine gradientfcn(x, g)
            use, intrinsic :: iso_fortran_env, only : real64
            real(real64), intent(in), dimension(:) :: x
            real(real64), intent(out), dimension(:) :: g
        end subroutine
    end interface
 
! ******************************************************************************
! TYPES
! ------------------------------------------------------------------------------
    type :: iteration_behavior
        integer(int32) :: iter_count
        integer(int32) :: fcn_count
        integer(int32) :: jacobian_count
        integer(int32) :: gradient_count
        logical :: converge_on_fcn
        logical :: converge_on_chng
        logical :: converge_on_zero_diff
    end type
 
! ------------------------------------------------------------------------------
    type, bind(C) :: value_pair
        real(real64) :: x1
        real(real64) :: x2
    end type
 
! ******************************************************************************
! NONLIN_VECFCN_HELPER.F90
! ------------------------------------------------------------------------------
    type vecfcn_helper
        private
        procedure(vecfcn), pointer, nopass :: m_fcn => null()
        procedure(jacobianfcn), pointer, nopass :: m_jac => null()
        integer(int32) :: m_nfcn = 0
        integer(int32) :: m_nvar = 0
    contains
        procedure, public :: set_fcn => vfh_set_fcn
        procedure, public :: set_jacobian => vfh_set_jac
        procedure, public :: is_fcn_defined => vfh_is_fcn_defined
        procedure, public :: is_jacobian_defined => vfh_is_jac_defined
        procedure, public :: fcn => vfh_fcn
        procedure, public :: jacobian => vfh_jac_fcn
        procedure, public :: get_equation_count => vfh_get_nfcn
        procedure, public :: get_variable_count => vfh_get_nvar
    end type
 
! ------------------------------------------------------------------------------
    interface
        module subroutine vfh_set_fcn(this, fcn, nfcn, nvar)
            class(vecfcn_helper), intent(inout) :: this
            procedure(vecfcn), intent(in), pointer :: fcn
            integer(int32), intent(in) :: nfcn, nvar
        end subroutine
 
        module subroutine vfh_set_jac(this, jac)
            class(vecfcn_helper), intent(inout) :: this
            procedure(jacobianfcn), intent(in), pointer :: jac
        end subroutine
 
        module function vfh_is_fcn_defined(this) result(x)
            class(vecfcn_helper), intent(in) :: this
            logical :: x
        end function
 
        module function vfh_is_jac_defined(this) result(x)
            class(vecfcn_helper), intent(in) :: this
            logical :: x
        end function
 
        module subroutine vfh_fcn(this, x, f)
            class(vecfcn_helper), intent(in) :: this
            real(real64), intent(in), dimension(:) :: x
            real(real64), intent(out), dimension(:) :: f
        end subroutine
 
        module subroutine vfh_jac_fcn(this, x, jac, fv, work, olwork, err)
            class(vecfcn_helper), intent(in) :: this
            real(real64), intent(inout), dimension(:) :: x
            real(real64), intent(out), dimension(:,:) :: jac
            real(real64), intent(in), dimension(:), optional, target :: fv
            real(real64), intent(out), dimension(:), optional, target :: work
            integer(int32), intent(out), optional :: olwork, err
        end subroutine
 
        module function vfh_get_nfcn(this) result(n)
            class(vecfcn_helper), intent(in) :: this
            integer(int32) :: n
        end function
 
        module function vfh_get_nvar(this) result(n)
            class(vecfcn_helper), intent(in) :: this
            integer(int32) :: n
        end function
    end interface
 
! ******************************************************************************
! NONLIN_FCN1VAR_HELPER.F90
! ------------------------------------------------------------------------------
    type fcn1var_helper
        private
        procedure(fcn1var), pointer, nopass :: m_fcn => null()
        procedure(fcn1var), pointer, nopass :: m_diff => null()
    contains
        procedure, public :: fcn => f1h_fcn
        procedure, public :: is_fcn_defined => f1h_is_fcn_defined
        procedure, public :: set_fcn => f1h_set_fcn
        procedure, public :: is_derivative_defined => f1h_is_diff_defined
        procedure, public :: diff => f1h_diff_fcn
        !!
        !! @par Syntax
        !! @code{.f90}
        !! subroutine set_diff(class(fcn1var_helper) this, procedure(fcn1var) pointer diff)
        !! @endcode
        !!
        !! @param[in,out] this The fcn1var_helper object.
        !! @param[in] diff A pointer to the function for computing the first
        !!  derivative.
        procedure, public :: set_diff => f1h_set_diff
    end type
 
! ------------------------------------------------------------------------------
    interface
        module function f1h_fcn(this, x) result(f)
            class(fcn1var_helper), intent(in) :: this
            real(real64), intent(in) :: x
            real(real64) :: f
        end function
 
        module function f1h_is_fcn_defined(this) result(x)
            class(fcn1var_helper), intent(in) :: this
            logical :: x
        end function
 
        module subroutine f1h_set_fcn(this, fcn)
            class(fcn1var_helper), intent(inout) :: this
            procedure(fcn1var), intent(in), pointer :: fcn
        end subroutine
 
        module function f1h_is_diff_defined(this) result(x)
            class(fcn1var_helper), intent(in) :: this
            logical :: x
        end function
 
        module function f1h_diff_fcn(this, x, f) result(df)
            class(fcn1var_helper), intent(in) :: this
            real(real64), intent(in) :: x
            real(real64), intent(in), optional :: f
            real(real64) :: df
        end function
 
        module subroutine f1h_set_diff(this, diff)
            class(fcn1var_helper), intent(inout) :: this
            procedure(fcn1var), pointer, intent(in) :: diff
        end subroutine
    end interface
 
! ******************************************************************************
! NONLIN_FCNNVAR_HELPER.F90
! ------------------------------------------------------------------------------
    type fcnnvar_helper
        private
        procedure(fcnnvar), pointer, nopass :: m_fcn => null()
        procedure(gradientfcn), pointer, nopass :: m_grad => null()
        integer(int32) :: m_nvar = 0
    contains
        procedure, public :: fcn => fnh_fcn
        procedure, public :: is_fcn_defined => fnh_is_fcn_defined
        procedure, public :: set_fcn => fnh_set_fcn
        procedure, public :: get_variable_count => fnh_get_nvar
        procedure, public :: set_gradient_fcn => fnh_set_grad
        procedure, public :: is_gradient_defined => fnh_is_grad_defined
        procedure, public :: gradient => fnh_grad_fcn
    end type
 
! ------------------------------------------------------------------------------
    interface
        module function fnh_fcn(this, x) result(f)
            class(fcnnvar_helper), intent(in) :: this
            real(real64), intent(in), dimension(:) :: x
            real(real64) :: f
        end function
 
        module function fnh_is_fcn_defined(this) result(x)
            class(fcnnvar_helper), intent(in) :: this
            logical :: x
        end function
 
        module subroutine fnh_set_fcn(this, fcn, nvar)
            class(fcnnvar_helper), intent(inout) :: this
            procedure(fcnnvar), intent(in), pointer :: fcn
            integer(int32), intent(in) :: nvar
        end subroutine
 
        module function fnh_get_nvar(this) result(n)
            class(fcnnvar_helper), intent(in) :: this
            integer(int32) :: n
        end function
 
        module subroutine fnh_set_grad(this, fcn)
            class(fcnnvar_helper), intent(inout) :: this
            procedure(gradientfcn), pointer, intent(in) :: fcn
        end subroutine
 
        module function fnh_is_grad_defined(this) result(x)
            class(fcnnvar_helper), intent(in) :: this
            logical :: x
        end function
 
        module subroutine fnh_grad_fcn(this, x, g, fv, err)
            class(fcnnvar_helper), intent(in) :: this
            real(real64), intent(inout), dimension(:) :: x
            real(real64), intent(out), dimension(:) :: g
            real(real64), intent(in), optional :: fv
            integer(int32), intent(out), optional :: err
        end subroutine
    end interface
 
! ******************************************************************************
! NONLIN_EQUATION_SOLVER.F90
! ------------------------------------------------------------------------------
    type, abstract :: equation_solver
        private
        integer(int32) :: m_maxeval = 100
        real(real64) :: m_fcntol = 1.0d-8
        real(real64) :: m_xtol = 1.0d-12
        real(real64) :: m_gtol = 1.0d-12
        logical :: m_printstatus = .false.
    contains
        procedure, public :: get_max_fcn_evals => es_get_max_eval
        procedure, public :: set_max_fcn_evals => es_set_max_eval
        procedure, public :: get_fcn_tolerance => es_get_fcn_tol
        procedure, public :: set_fcn_tolerance => es_set_fcn_tol
        procedure, public :: get_var_tolerance => es_get_var_tol
        procedure, public :: set_var_tolerance => es_set_var_tol
        procedure, public :: get_gradient_tolerance => es_get_grad_tol
        procedure, public :: set_gradient_tolerance => es_set_grad_tol
        procedure, public :: get_print_status => es_get_print_status
        procedure, public :: set_print_status => es_set_print_status
        procedure(nonlin_solver), deferred, public, pass :: solve
    end type
 
! ------------------------------------------------------------------------------
    interface
        pure module function es_get_max_eval(this) result(n)
            class(equation_solver), intent(in) :: this
            integer(int32) :: n
        end function
 
        module subroutine es_set_max_eval(this, n)
            class(equation_solver), intent(inout) :: this
            integer(int32), intent(in) :: n
        end subroutine
 
        pure module function es_get_fcn_tol(this) result(x)
            class(equation_solver), intent(in) :: this
            real(real64) :: x
        end function
 
        module subroutine es_set_fcn_tol(this, x)
            class(equation_solver), intent(inout) :: this
            real(real64), intent(in) :: x
        end subroutine
 
        pure module function es_get_var_tol(this) result(x)
            class(equation_solver), intent(in) :: this
            real(real64) :: x
        end function
 
        module subroutine es_set_var_tol(this, x)
            class(equation_solver), intent(inout) :: this
            real(real64), intent(in) :: x
        end subroutine
 
        pure module function es_get_grad_tol(this) result(x)
            class(equation_solver), intent(in) :: this
            real(real64) :: x
        end function
 
        module subroutine es_set_grad_tol(this, x)
            class(equation_solver), intent(inout) :: this
            real(real64), intent(in) :: x
        end subroutine
 
        pure module function es_get_print_status(this) result(x)
            class(equation_solver), intent(in) :: this
            logical :: x
        end function
 
        module subroutine es_set_print_status(this, x)
            class(equation_solver), intent(inout) :: this
            logical, intent(in) :: x
        end subroutine
    end interface
 
! ******************************************************************************
! NONLIN_EQUATION_SOLVER_1VAR.F90
! ------------------------------------------------------------------------------
    type, abstract :: equation_solver_1var
        private
        integer(int32) :: m_maxeval = 100
        real(real64) :: m_fcntol = 1.0d-8
        real(real64) :: m_xtol = 1.0d-12
        real(real64) :: m_difftol = 1.0d-12
        logical :: m_printstatus = .false.
    contains
        procedure, public :: get_max_fcn_evals => es1_get_max_eval
        procedure, public :: set_max_fcn_evals => es1_set_max_eval
        procedure, public :: get_fcn_tolerance => es1_get_fcn_tol
        procedure, public :: set_fcn_tolerance => es1_set_fcn_tol
        procedure, public :: get_var_tolerance => es1_get_var_tol
        procedure, public :: set_var_tolerance => es1_set_var_tol
        procedure, public :: get_print_status => es1_get_print_status
        procedure, public :: set_print_status => es1_set_print_status
        procedure(nonlin_solver_1var), deferred, public, pass :: solve
        procedure, public :: get_diff_tolerance => es1_get_diff_tol
        procedure, public :: set_diff_tolerance => es1_set_diff_tol
    end type
 
! ------------------------------------------------------------------------------
    interface
        pure module function es1_get_max_eval(this) result(n)
            class(equation_solver_1var), intent(in) :: this
            integer(int32) :: n
        end function
 
        module subroutine es1_set_max_eval(this, n)
            class(equation_solver_1var), intent(inout) :: this
            integer(int32), intent(in) :: n
        end subroutine
 
        pure module function es1_get_fcn_tol(this) result(x)
            class(equation_solver_1var), intent(in) :: this
            real(real64) :: x
        end function
 
        module subroutine es1_set_fcn_tol(this, x)
            class(equation_solver_1var), intent(inout) :: this
            real(real64), intent(in) :: x
        end subroutine
 
        pure module function es1_get_var_tol(this) result(x)
            class(equation_solver_1var), intent(in) :: this
            real(real64) :: x
        end function
 
        module subroutine es1_set_var_tol(this, x)
            class(equation_solver_1var), intent(inout) :: this
            real(real64), intent(in) :: x
        end subroutine
 
        pure module function es1_get_print_status(this) result(x)
            class(equation_solver_1var), intent(in) :: this
            logical :: x
        end function
 
        module subroutine es1_set_print_status(this, x)
            class(equation_solver_1var), intent(inout) :: this
            logical, intent(in) :: x
        end subroutine
 
        pure module function es1_get_diff_tol(this) result(x)
            class(equation_solver_1var), intent(in) :: this
            real(real64) :: x
        end function
 
    ! --------------------
        module subroutine es1_set_diff_tol(this, x)
            class(equation_solver_1var), intent(inout) :: this
            real(real64), intent(in) :: x
        end subroutine
    end interface
 
! ******************************************************************************
! NONLIN_EQUATION_OPTIMIZER.F90
! ------------------------------------------------------------------------------
    type, abstract :: equation_optimizer
        private
        integer(int32) :: m_maxeval = 500
        real(real64) :: m_tol = 1.0d-12
        logical :: m_printstatus = .false.
    contains
        procedure, public :: get_max_fcn_evals => oe_get_max_eval
        procedure, public :: set_max_fcn_evals => oe_set_max_eval
        procedure, public :: get_tolerance => oe_get_tol
        procedure, public :: set_tolerance => oe_set_tol
        procedure, public :: get_print_status => oe_get_print_status
        procedure, public :: set_print_status => oe_set_print_status
        procedure(nonlin_optimize_fcn), deferred, public, pass :: solve
    end type
 
! ------------------------------------------------------------------------------
    interface
        pure module function oe_get_max_eval(this) result(n)
            class(equation_optimizer), intent(in) :: this
            integer(int32) :: n
        end function
 
        module subroutine oe_set_max_eval(this, n)
            class(equation_optimizer), intent(inout) :: this
            integer(int32), intent(in) :: n
        end subroutine
 
        pure module function oe_get_tol(this) result(x)
            class(equation_optimizer), intent(in) :: this
            real(real64) :: x
        end function
 
        module subroutine oe_set_tol(this, x)
            class(equation_optimizer), intent(inout) :: this
            real(real64), intent(in) :: x
        end subroutine
 
        pure module function oe_get_print_status(this) result(x)
            class(equation_optimizer), intent(in) :: this
            logical :: x
        end function
 
        module subroutine oe_set_print_status(this, x)
            class(equation_optimizer), intent(inout) :: this
            logical, intent(in) :: x
        end subroutine
    end interface
 
! ******************************************************************************
! ABSTRACT ROUTINE INTERFACES
! ------------------------------------------------------------------------------
    interface
 
        subroutine nonlin_solver(this, fcn, x, fvec, ib, err)
            use, intrinsic :: iso_fortran_env, only : real64
            use ferror, only : errors
            import equation_solver
            import vecfcn_helper
            import iteration_behavior
            class(equation_solver), intent(inout) :: this
            class(vecfcn_helper), intent(in) :: fcn
            real(real64), intent(inout), dimension(:) :: x
            real(real64), intent(out), dimension(:) :: fvec
            type(iteration_behavior), optional :: ib
            class(errors), intent(inout), optional, target :: err
        end subroutine
 
        subroutine nonlin_solver_1var(this, fcn, x, lim, f, ib, err)
            use, intrinsic :: iso_fortran_env, only : real64
            use ferror, only : errors
            import equation_solver_1var
            import fcn1var_helper
            import value_pair
            import iteration_behavior
            class(equation_solver_1var), intent(inout) :: this
            class(fcn1var_helper), intent(in) :: fcn
            real(real64), intent(inout) :: x
            type(value_pair), intent(in) :: lim
            real(real64), intent(out), optional :: f
            type(iteration_behavior), optional :: ib
            class(errors), intent(inout), optional, target :: err
        end subroutine
 
        subroutine nonlin_optimize_fcn(this, fcn, x, fout, ib, err)
            use, intrinsic :: iso_fortran_env, only : real64
            use ferror, only : errors
            import equation_optimizer
            import fcnnvar_helper
            import iteration_behavior
            class(equation_optimizer), intent(inout) :: this
            class(fcnnvar_helper), intent(in) :: fcn
            real(real64), intent(inout), dimension(:) :: x
            real(real64), intent(out), optional :: fout
            type(iteration_behavior), optional :: ib
            class(errors), intent(inout), optional, target :: err
        end subroutine
    end interface
 
contains
! ******************************************************************************
! MISC. ROUTINES
! ------------------------------------------------------------------------------
    subroutine print_status(iter, nfeval, njaceval, xnorm, fnorm)
        ! Arguments
        integer(int32), intent(in) :: iter, nfeval, njaceval
        real(real64), intent(in) :: xnorm, fnorm
 
        ! Process
        print *, ""
        print 100, "Iteration: ", iter
        print 100, "Function Evaluations: ", nfeval
        if (njaceval > 0) print 100, "Jacobian Evaluations: ", njaceval
        print 101, "Change in Variable: ", xnorm
        print 101, "Residual: ", fnorm
 
        ! Formatting
100     format(a, i0)
101     format(a, e10.3)
    end subroutine
end module