Include additional examples from certik/minpack

.github/workflows/CI.yml

@@ -50,6 +50,9 @@ jobs:
     - name: Run test
       run: fpm test
 
+    - name: Run examples
+      run: fpm run --example --all
+
   Docs:
     runs-on: ${{ matrix.os }}
     strategy:

examples/example_hybrd.f90

@@ -0,0 +1,103 @@
+!> The problem is to determine the values of x(1), x(2), ..., x(9)
+!>  which solve the system of tridiagonal equations
+!>     (3-2*x(1))*x(1)           -2*x(2)                   = -1
+!>             -x(i-1) + (3-2*x(i))*x(i)         -2*x(i+1) = -1, i=2-8
+!>                                 -x(8) + (3-2*x(9))*x(9) = -1
+program example_hybrd
+
+    use minpack_module, only: hybrd, enorm, dpmpar
+    implicit none
+    integer j, n, maxfev, ml, mu, mode, nprint, info, nfev, ldfjac, lr, nwrite
+    double precision xtol, epsfcn, factor, fnorm
+    double precision x(9), fvec(9), diag(9), fjac(9, 9), r(45), qtf(9), &
+        wa1(9), wa2(9), wa3(9), wa4(9)
+
+    !> Logical output unit is assumed to be number 6.
+    data nwrite/6/
+
+    n = 9
+
+    !> The following starting values provide a rough solution.
+    do j = 1, 9
+        x(j) = -1.0d0
+    end do
+
+    ldfjac = 9
+    lr = 45
+
+    !> Set xtol to the square root of the machine precision.
+    !>  unless high precision solutions are required,
+    !>  this is the recommended setting.
+    xtol = dsqrt(dpmpar(1))
+
+    maxfev = 2000
+    ml = 1
+    mu = 1
+    epsfcn = 0.0d0
+    mode = 2
+    do j = 1, 9
+        diag(j) = 1.0d0
+    end do
+    factor = 1.0d2
+    nprint = 0
+
+    call hybrd(fcn, n, x, fvec, xtol, maxfev, ml, mu, epsfcn, diag, &
+               mode, factor, nprint, info, nfev, fjac, ldfjac, &
+               r, lr, qtf, wa1, wa2, wa3, wa4)
+    fnorm = enorm(n, fvec)
+    write (nwrite, 1000) fnorm, nfev, info, (x(j), j=1, n)
+
+1000 format(5x, "FINAL L2 NORM OF THE RESIDUALS", d15.7// &
+           5x, "NUMBER OF FUNCTION EVALUATIONS", i10// &
+           5x, "EXIT PARAMETER", 16x, i10// &
+           5x, "FINAL APPROXIMATE SOLUTION"//(5x, 3d15.7))
+
+    !> Results obtained with different compilers or machines
+    !>  may be slightly different.
+    !>
+    !>> FINAL L2 NORM OF THE RESIDUALS  0.1192636D-07
+    !>>
+    !>> NUMBER OF FUNCTION EVALUATIONS        14
+    !>>
+    !>> EXIT PARAMETER                         1
+    !>>
+    !>> FINAL APPROXIMATE SOLUTION
+    !>>
+    !>>  -0.5706545D+00 -0.6816283D+00 -0.7017325D+00
+    !>>  -0.7042129D+00 -0.7013690D+00 -0.6918656D+00
+    !>>  -0.6657920D+00 -0.5960342D+00 -0.4164121D+00
+
+contains
+
+    !> Subroutine fcn for hybrd example.
+    subroutine fcn(n, x, fvec, iflag)
+
+        implicit none
+        integer, intent(in) :: n
+        integer, intent(inout) :: iflag
+        double precision, intent(in) :: x(n)
+        double precision, intent(out) :: fvec(n)
+
+        integer k
+        double precision one, temp, temp1, temp2, three, two, zero
+        data zero, one, two, three/0.0d0, 1.0d0, 2.0d0, 3.0d0/
+
+        if (iflag /= 0) go to 5
+
+        !! Insert print statements here when nprint is positive.
+
+        return
+5       continue
+        do k = 1, n
+            temp = (three - two*x(k))*x(k)
+            temp1 = zero
+            if (k /= 1) temp1 = x(k - 1)
+            temp2 = zero
+            if (k /= n) temp2 = x(k + 1)
+            fvec(k) = temp - temp1 - two*temp2 + one
+        end do
+        return
+
+    end subroutine fcn
+
+end program example_hybrd

examples/example_hybrd1.f90

@@ -0,0 +1,80 @@
+!> the problem is to determine the values of x(1), x(2), ..., x(9),
+!>  which solve the system of tridiagonal equations.
+!>
+!>  (3-2*x(1))*x(1)           -2*x(2)                   = -1
+!>          -x(i-1) + (3-2*x(i))*x(i)         -2*x(i+1) = -1, i=2-8
+!>                              -x(8) + (3-2*x(9))*x(9) = -1
+program example_hybrd1
+
+    use minpack_module, only: hybrd1, dpmpar, enorm
+    implicit none
+    integer j, n, info, lwa, nwrite
+    double precision tol, fnorm
+    double precision x(9), fvec(9), wa(180)
+
+    !> Logical output unit is assumed to be number 6.
+    data nwrite/6/
+
+    n = 9
+
+    !> The following starting values provide a rough solution.
+    do j = 1, 9
+        x(j) = -1.d0
+    end do
+
+    lwa = 180
+
+    !> Set tol to the square root of the machine precision.
+    !>  unless high precision solutions are required,
+    !>  this is the recommended setting.
+    tol = dsqrt(dpmpar(1))
+
+    call hybrd1(fcn, n, x, fvec, tol, info, wa, lwa)
+    fnorm = enorm(n, fvec)
+    write (nwrite, 1000) fnorm, info, (x(j), j=1, n)
+
+1000 format(5x, "FINAL L2 NORM OF THE RESIDUALS", d15.7// &
+           5x, "EXIT PARAMETER", 16x, i10// &
+           5x, "FINAL APPROXIMATE SOLUTION"// &
+           (5x, 3d15.7))
+
+    !> Results obtained with different compilers or machines
+    !>  may be slightly different.
+    !>
+    !>> FINAL L2 NORM OF THE RESIDUALS  0.1192636D-07
+    !>>
+    !>> EXIT PARAMETER                         1
+    !>>
+    !>> FINAL APPROXIMATE SOLUTION
+    !>>
+    !>>  -0.5706545D+00 -0.6816283D+00 -0.7017325D+00
+    !>>  -0.7042129D+00 -0.7013690D+00 -0.6918656D+00
+    !>>  -0.6657920D+00 -0.5960342D+00 -0.4164121D+00
+
+contains
+
+    !> Subroutine fcn for hybrd1 example.
+    subroutine fcn(n, x, fvec, iflag)
+
+        implicit none
+        integer, intent(in) :: n
+        integer, intent(inout) :: iflag
+        double precision, intent(in) :: x(n)
+        double precision, intent(out) :: fvec(n)
+
+        integer k
+        double precision one, temp, temp1, temp2, three, two, zero
+        data zero, one, two, three/0.0d0, 1.0d0, 2.0d0, 3.0d0/
+
+        do k = 1, n
+            temp = (three - two*x(k))*x(k)
+            temp1 = zero
+            if (k /= 1) temp1 = x(k - 1)
+            temp2 = zero
+            if (k /= n) temp2 = x(k + 1)
+            fvec(k) = temp - temp1 - two*temp2 + one
+        end do
+
+    end subroutine fcn
+
+end program example_hybrd1

examples/example_lmder1.f90

@@ -0,0 +1,93 @@
+module testmod_der1
+implicit none
+private
+public fcn, dp
+
+integer, parameter :: dp=kind(0d0)
+
+contains
+
+subroutine fcn(m, n, x, fvec, fjac, ldfjac, iflag)
+integer, intent(in) :: m, n, ldfjac
+integer, intent(inout) :: iflag
+real(dp), intent(in) :: x(n)
+real(dp), intent(inout) :: fvec(m), fjac(ldfjac, n)
+
+integer :: i
+real(dp) :: tmp1, tmp2, tmp3, tmp4, y(15)
+y = [1.4D-1, 1.8D-1, 2.2D-1, 2.5D-1, 2.9D-1, 3.2D-1, 3.5D-1, 3.9D-1, &
+        3.7D-1, 5.8D-1, 7.3D-1, 9.6D-1, 1.34D0, 2.1D0, 4.39D0]
+
+if (iflag == 1) then
+    do i = 1, 15
+        tmp1 = i
+        tmp2 = 16 - i
+        tmp3 = tmp1
+        if (i .gt. 8) tmp3 = tmp2
+        fvec(i) = y(i) - (x(1) + tmp1/(x(2)*tmp2 + x(3)*tmp3))
+    end do
+else
+    do i = 1, 15
+        tmp1 = i
+        tmp2 = 16 - i
+        tmp3 = tmp1
+        if (i .gt. 8) tmp3 = tmp2
+        tmp4 = (x(2)*tmp2 + x(3)*tmp3)**2
+        fjac(i,1) = -1.D0
+        fjac(i,2) = tmp1*tmp2/tmp4
+        fjac(i,3) = tmp1*tmp3/tmp4
+    end do
+end if
+end subroutine
+
+end module
+
+
+program example_lmder1
+use minpack_module, only: enorm, lmder1, chkder
+use testmod_der1, only: dp, fcn
+implicit none
+
+integer :: info
+real(dp) :: tol, x(3), fvec(15), fjac(size(fvec), size(x))
+integer :: ipvt(size(x))
+real(dp), allocatable :: wa(:)
+
+! The following starting values provide a rough fit.
+x = [1._dp, 1._dp, 1._dp]
+
+call check_deriv()
+
+! Set tol to the square root of the machine precision. Unless high precision
+! solutions are required, this is the recommended setting.
+tol = sqrt(epsilon(1._dp))
+
+allocate(wa(5*size(x) + size(fvec)))
+call lmder1(fcn, size(fvec), size(x), x, fvec, fjac, size(fjac, 1), tol, &
+    info, ipvt, wa, size(wa))
+print 1000, enorm(size(fvec), fvec), info, x
+1000 format(5x, 'FINAL L2 NORM OF THE RESIDUALS', d15.7 // &
+            5x, 'EXIT PARAMETER', 16x, i10              // &
+            5x, 'FINAL APPROXIMATE SOLUTION'            // &
+            5x, 3d15.7)
+
+contains
+
+subroutine check_deriv()
+integer :: iflag
+real(dp) :: xp(size(x)), fvecp(size(fvec)), err(size(fvec))
+call chkder(size(fvec), size(x), x, fvec, fjac, size(fjac, 1), xp, fvecp, &
+    1, err)
+iflag = 1
+call fcn(size(fvec), size(x), x, fvec, fjac, size(fjac, 1), iflag)
+iflag = 2
+call fcn(size(fvec), size(x), x, fvec, fjac, size(fjac, 1), iflag)
+iflag = 1
+call fcn(size(fvec), size(x), xp, fvecp, fjac, size(fjac, 1), iflag)
+call chkder(size(fvec), size(x), x, fvec, fjac, size(fjac, 1), xp, fvecp, &
+    2, err)
+print *, "Derivatives check (1.0 is correct, 0.0 is incorrect):"
+print *, err
+end subroutine
+
+end program

examples/example_lmdif1.f90

@@ -0,0 +1,61 @@
+module testmod_dif1
+implicit none
+private
+public fcn, dp
+
+integer, parameter :: dp=kind(0d0)
+
+contains
+
+subroutine fcn(m, n, x, fvec, iflag)
+integer, intent(in) :: m, n
+integer, intent(inout) :: iflag
+real(dp), intent(in) :: x(n)
+real(dp), intent(out) :: fvec(m)
+
+integer :: i
+real(dp) :: tmp1, tmp2, tmp3, y(15)
+! Suppress compiler warning:
+y(1) = iflag
+y = [1.4D-1, 1.8D-1, 2.2D-1, 2.5D-1, 2.9D-1, 3.2D-1, 3.5D-1, 3.9D-1, &
+        3.7D-1, 5.8D-1, 7.3D-1, 9.6D-1, 1.34D0, 2.1D0, 4.39D0]
+
+do i = 1, 15
+    tmp1 = i
+    tmp2 = 16 - i
+    tmp3 = tmp1
+    if (i .gt. 8) tmp3 = tmp2
+    fvec(i) = y(i) - (x(1) + tmp1/(x(2)*tmp2 + x(3)*tmp3))
+end do
+end subroutine
+
+end module
+
+
+program example_lmdif1
+use minpack_module, only: enorm, lmdif1
+use testmod_dif1, only: dp, fcn
+implicit none
+
+integer :: info, m, n
+real(dp) :: tol, x(3), fvec(15)
+integer :: iwa(size(x))
+real(dp), allocatable :: wa(:)
+
+! The following starting values provide a rough fit.
+x = [1._dp, 1._dp, 1._dp]
+
+! Set tol to the square root of the machine precision. Unless high precision
+! solutions are required, this is the recommended setting.
+tol = sqrt(epsilon(1._dp))
+
+m = size(fvec)
+n = size(x)
+allocate(wa(m*n + 5*n + m))
+call lmdif1(fcn, size(fvec), size(x), x, fvec, tol, info, iwa, wa, size(wa))
+print 1000, enorm(size(fvec), fvec), info, x
+1000 format(5x, 'FINAL L2 NORM OF THE RESIDUALS', d15.7 // &
+            5x, 'EXIT PARAMETER', 16x, i10              // &
+            5x, 'FINAL APPROXIMATE SOLUTION'            // &
+            5x, 3d15.7)
+end program