Fortran 用Minpack求解S曲线

我想使用Minpack（fortran）来估计S曲线的以下广义形式中的d参数：y=（A-d）/（1+（x**B/C））+d

---

其思想是，在该应用程序中，用户提供A[始终为0以强制通过（0,0）]、B和C，然后Minpack将从中找到强制通过（1，y）的D值，其中y也由用户提供，但必须是，该问题不是属于另一个社区，例如计算科学网站，“两次连续迭代之间的相对误差最多为xtol”，这意味着已经达到收敛。迭代后，算法发现变化小于xtol。上面的代码是从“example_primes.f90”修改而来的。我猜“stop”后面跟“failed to converge”有点错误。我将从代码中删除这一行。谢谢

if (info /= 1) stop "failed to converge"

    module types
    implicit none
    private
    public dp

    integer, parameter :: dp=kind(0d0)

end module

module f_vals 
    DOUBLE PRECISION, SAVE, DIMENSION(:), POINTER:: fixed_vals
end module

module find_fit_module

! This module contains a general function find_fit() for a nonlinear least
! squares fitting. The function can fit any nonlinear expression to any data.

    use minpack, only: lmdif1
    use types, only: dp
    implicit none
    private
    public find_fit

    contains

    subroutine find_fit(data_x, data_y, expr, pars)

    ! Fits the (data_x, data_y) arrays with the function expr(x, pars).
    ! The user can provide any nonlinear function 'expr' depending on any number of
    ! parameters 'pars' and it must return the evaluated expression on the
    ! array 'x'. The arrays 'data_x' and 'data_y' must have the same
    ! length.

        real(dp), intent(in) :: data_x(:), data_y(:)
        interface
            function expr(x, pars) result(y)
            use types, only: dp
            implicit none
            real(dp), intent(in) :: x(:), pars(:)
            real(dp) :: y(size(x))
            end function
        end interface

        real(dp), intent(inout) :: pars(:)

        real(dp) :: tol, fvec(size(data_x))
        integer :: iwa(size(pars)), info, m, n
        real(dp), allocatable :: wa(:)

        tol = sqrt(epsilon(1._dp))
        !tol = 0.001
        m = size(fvec)
        n = size(pars)
        allocate(wa(m*n + 5*n + m))
        call lmdif1(fcn, m, n, pars, fvec, tol, info, iwa, wa, size(wa))

        open(222, FILE='D_Value.txt')
        write(222,4) pars(1)
4       format(E20.12)
        close(222)

        if (info /= 1) stop "failed to converge"

        contains

        subroutine fcn(m, n, x, fvec, iflag)
            integer, intent(in) :: m, n, iflag
            real(dp), intent(in) :: x(n)
            real(dp), intent(out) :: fvec(m)
            ! Suppress compiler warning:
            fvec(1) = iflag
            fvec = data_y - expr(data_x, x)
        end subroutine

    end subroutine

end module


program snwdeplcrv

! Find a nonlinear fit of the form y = (A - D) / (1 + (x**B/C)) + D.

    use find_fit_module, only: find_fit
    use types, only: dp
    use f_vals
    implicit none

    real(dp) :: pars(1), y_int_at_1
    real(dp) :: y(1) = 1.0   ! Initialization of value to be reset by user (y: value of S-curve @ x=1)
    real(dp) :: A, B, C
    integer :: i

    allocate(fixed_vals(3)) ! A, B, C parameters

    pars = [1._dp]  ! D parameter in S-curve function

    ! Read PEST-specified parameters
    write(*,*) '  Enter value that S-curve should equal when SWE=1 (must be <= 1)'
    read(*,*) y_int_at_1
    if(y_int_at_1 > 1.0)  y_int_at_1 = 1
    y = y_int_at_1

    ! Read PEST-specified parameters
    write(*,*) '  Enter S-curve parameters: A, B, & C.  D parameter to be estimated ' 
    read(*,*) A, B, C

    fixed_vals(1) = A
    fixed_vals(2) = B
    fixed_vals(3) = C

    call find_fit([(real(i, dp), i=1,size(y))], y, expression, pars)
    print *, pars

    contains

    function expression(x, pars) result(y)
        use f_vals
        real(dp), intent(in) :: x(:), pars(:)
        real(dp) :: y(size(x))
        real(dp) :: A, B, C, D

        A = fixed_vals(1)
        B = fixed_vals(2)
        C = fixed_vals(3)

        D = pars(1)
        y = (A - D) / (1 + (x**B / C)) + D
    end function

end program