Modernize the tests

.github/workflows/CI.yml

@@ -66,14 +66,34 @@ jobs:
       if: ${{ matrix.build == 'fpm' }}
       run: fpm build --profile release
 
-    - name: Run test (fpm)
+    - name: Run chkder test (fpm)
       if: ${{ matrix.build == 'fpm' }}
-      run: fpm test
+      run: fpm test test_chkder
+
+    - name: Run hybrd test (fpm)
+      if: ${{ matrix.build == 'fpm' }}
+      run: fpm test test_hybrd
+
+    - name: Run hybrj test (fpm)
+      if: ${{ matrix.build == 'fpm' }}
+      run: fpm test test_hybrj
+
+    - name: Run lmdif test (fpm)
+      if: ${{ matrix.build == 'fpm' }}
+      run: fpm test test_lmdif
+
+    - name: Run lmstr test (fpm)
+      if: ${{ matrix.build == 'fpm' }}
+      run: fpm test test_lmstr
 
     - name: Run examples (fpm)
       if: ${{ matrix.build == 'fpm' }}
       run: fpm run --example --all
 
+    - name: Run lmder test (fpm)
+      if: ${{ matrix.build == 'fpm' }}
+      run: fpm test test_lmder
+
     - name: Setup build (meson)
       if: ${{ matrix.build == 'meson' }}
       run: >-

examples/example_lmder1.f90

@@ -23,15 +23,15 @@ subroutine fcn(m, n, x, fvec, fjac, ldfjac, iflag)
         tmp1 = i
         tmp2 = 16 - i
         tmp3 = tmp1
-        if (i .gt. 8) tmp3 = tmp2
+        if (i > 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
+        if (i > 8) tmp3 = tmp2
         tmp4 = (x(2)*tmp2 + x(3)*tmp3)**2
         fjac(i,1) = -1.D0
         fjac(i,2) = tmp1*tmp2/tmp4

examples/example_lmdif1.f90

@@ -24,7 +24,7 @@ subroutine fcn(m, n, x, fvec, iflag)
     tmp1 = i
     tmp2 = 16 - i
     tmp3 = tmp1
-    if (i .gt. 8) tmp3 = tmp2
+    if (i > 8) tmp3 = tmp2
     fvec(i) = y(i) - (x(1) + tmp1/(x(2)*tmp2 + x(3)*tmp3))
 end do
 end subroutine

scripts/validate.sh

@@ -0,0 +1,111 @@
+#!/bin/bash
+
+#
+# Download the old minpack and test files from Netlib
+# and compile and run all the tests.
+#
+# This was used to generate the comparisons for the unit tests.
+#
+
+COMPILER=gfortran
+
+rm -rf lib
+rm -rf test
+
+mkdir lib
+mkdir test
+
+# minpack library files:
+wget https://netlib.org/minpack/chkder.f
+wget https://netlib.org/minpack/dogleg.f
+wget https://netlib.org/minpack/dpmpar.f
+wget https://netlib.org/minpack/enorm.f
+wget https://netlib.org/minpack/fdjac1.f
+wget https://netlib.org/minpack/fdjac2.f
+wget https://netlib.org/minpack/hybrd.f
+wget https://netlib.org/minpack/hybrd1.f
+wget https://netlib.org/minpack/hybrj.f
+wget https://netlib.org/minpack/hybrj1.f
+wget https://netlib.org/minpack/lmder.f
+wget https://netlib.org/minpack/lmder1.f
+wget https://netlib.org/minpack/lmdif.f
+wget https://netlib.org/minpack/lmdif1.f
+wget https://netlib.org/minpack/lmpar.f
+wget https://netlib.org/minpack/lmstr.f
+wget https://netlib.org/minpack/lmstr1.f
+wget https://netlib.org/minpack/qform.f
+wget https://netlib.org/minpack/qrfac.f
+wget https://netlib.org/minpack/qrsolv.f
+wget https://netlib.org/minpack/r1mpyq.f
+wget https://netlib.org/minpack/r1updt.f
+wget https://netlib.org/minpack/rwupdt.f
+
+mv *.f lib
+
+# test programs:
+wget https://netlib.org/minpack/ex/file15
+wget https://netlib.org/minpack/ex/file16
+wget https://netlib.org/minpack/ex/file17
+wget https://netlib.org/minpack/ex/file18
+wget https://netlib.org/minpack/ex/file19
+wget https://netlib.org/minpack/ex/file20
+
+mv file15 ./test/file15.f
+mv file16 ./test/file16.f
+mv file17 ./test/file17.f
+mv file18 ./test/file18.f
+mv file19 ./test/file19.f
+mv file20 ./test/file20.f
+
+# modify the tests to read the data from the files
+# note: this is mac sed:
+sed -i -e 's|         READ (NREAD,50) NPROB,N,NTRIES|         if (ic==0) open(unit=NREAD,file="file21",status="OLD");READ (NREAD,50) NPROB,N,NTRIES|g' ./test/file15.f
+sed -i -e 's|         READ (NREAD,50) NPROB,N,NTRIES|         if (ic==0) open(unit=NREAD,file="file21",status="OLD");READ (NREAD,50) NPROB,N,NTRIES|g' ./test/file16.f
+sed -i -e 's|         READ (NREAD,50) NPROB,N,M,NTRIES|         if (ic==0) open(unit=NREAD,file="file22",status="OLD");READ (NREAD,50) NPROB,N,M,NTRIES|g' ./test/file17.f
+sed -i -e 's|         READ (NREAD,50) NPROB,N,M,NTRIES|         if (ic==0) open(unit=NREAD,file="file22",status="OLD");READ (NREAD,50) NPROB,N,M,NTRIES|g' ./test/file18.f
+sed -i -e 's|         READ (NREAD,50) NPROB,N,M,NTRIES|         if (ic==0) open(unit=NREAD,file="file22",status="OLD");READ (NREAD,50) NPROB,N,M,NTRIES|g' ./test/file19.f
+sed -i -e 's|      LDFJAC = 10|      LDFJAC = 10; open(unit=NREAD,file="file23",status="OLD")|g' ./test/file20.f
+
+sed -i -e 's|      DATA NREAD,NWRITE /5,6/|      DATA NREAD,NWRITE /500,6/|g' ./test/file15.f
+sed -i -e 's|      DATA NREAD,NWRITE /5,6/|      DATA NREAD,NWRITE /500,6/|g' ./test/file16.f
+sed -i -e 's|      DATA NREAD,NWRITE /5,6/|      DATA NREAD,NWRITE /500,6/|g' ./test/file17.f
+sed -i -e 's|      DATA NREAD,NWRITE /5,6/|      DATA NREAD,NWRITE /500,6/|g' ./test/file18.f
+sed -i -e 's|      DATA NREAD,NWRITE /5,6/|      DATA NREAD,NWRITE /500,6/|g' ./test/file19.f
+sed -i -e 's|      DATA NREAD,NWRITE /5,6/|      DATA NREAD,NWRITE /500,6/|g' ./test/file20.f
+
+# input files:
+wget https://netlib.org/minpack/ex/file21
+wget https://netlib.org/minpack/ex/file22
+wget https://netlib.org/minpack/ex/file23
+
+# compile tests:
+$COMPILER -O0 -ffixed-line-length-none ./lib/*.f ./test/file15.f -o test_hybrd_O0_$COMPILER
+$COMPILER -O0 -ffixed-line-length-none ./lib/*.f ./test/file16.f -o test_hybrj_O0_$COMPILER
+$COMPILER -O0 -ffixed-line-length-none ./lib/*.f ./test/file17.f -o test_lmder_O0_$COMPILER
+$COMPILER -O0 -ffixed-line-length-none ./lib/*.f ./test/file18.f -o test_lmstr_O0_$COMPILER
+$COMPILER -O0 -ffixed-line-length-none ./lib/*.f ./test/file19.f -o test_lmdif_O0_$COMPILER
+$COMPILER -O0 -ffixed-line-length-none ./lib/*.f ./test/file20.f -o test_chkder_O0_$COMPILER
+
+# run tests:
+./test_hybrd_O0_$COMPILER > output_test_hybrd_O0_$COMPILER.txt
+./test_hybrj_O0_$COMPILER > output_test_hybrj_O0_$COMPILER.txt
+./test_lmder_O0_$COMPILER > output_test_lmder_O0_$COMPILER.txt
+./test_lmstr_O0_$COMPILER > output_test_lmstr_O0_$COMPILER.txt
+./test_lmdif_O0_$COMPILER > output_test_lmdif_O0_$COMPILER.txt
+./test_chkder_O0_$COMPILER > output_test_chkder_O0_$COMPILER.txt
+
+# compile tests:
+$COMPILER -O2 -ffixed-line-length-none ./lib/*.f ./test/file15.f -o test_hybrd_O2_$COMPILER
+$COMPILER -O2 -ffixed-line-length-none ./lib/*.f ./test/file16.f -o test_hybrj_O2_$COMPILER
+$COMPILER -O2 -ffixed-line-length-none ./lib/*.f ./test/file17.f -o test_lmder_O2_$COMPILER
+$COMPILER -O2 -ffixed-line-length-none ./lib/*.f ./test/file18.f -o test_lmstr_O2_$COMPILER
+$COMPILER -O2 -ffixed-line-length-none ./lib/*.f ./test/file19.f -o test_lmdif_O2_$COMPILER
+$COMPILER -O2 -ffixed-line-length-none ./lib/*.f ./test/file20.f -o test_chkder_O2_$COMPILER
+
+# run tests:
+./test_hybrd_O2_$COMPILER > output_test_hybrd_O2_$COMPILER.txt
+./test_hybrj_O2_$COMPILER > output_test_hybrj_O2_$COMPILER.txt
+./test_lmder_O2_$COMPILER > output_test_lmder_O2_$COMPILER.txt
+./test_lmstr_O2_$COMPILER > output_test_lmstr_O2_$COMPILER.txt
+./test_lmdif_O2_$COMPILER > output_test_lmdif_O2_$COMPILER.txt
+./test_chkder_O2_$COMPILER > output_test_chkder_O2_$COMPILER.txt

src/minpack.f90

@@ -49,19 +49,19 @@ subroutine fcn_hybrj(n, x, fvec, fjac, ldfjac, iflag)
             !! user-supplied subroutine for [[hybrj]] and [[hybrj1]]
             import :: wp
             implicit none
-            integer, intent(in)                       :: n !! the number of variables.
-            real(wp), dimension(n), intent(in)         :: x !! independant variable vector
-            integer, intent(in)                       :: ldfjac !! leading dimension of the array fjac.
-            real(wp), dimension(n), intent(out)        :: fvec !! value of function at `x`
-            real(wp), dimension(ldfjac, n), intent(out) :: fjac !! jacobian matrix at `x`
-            integer, intent(inout)                    :: iflag !! if iflag = 1 calculate the functions at x and
-                                                              !! return this vector in fvec. do not alter fjac.
-                                                              !! if iflag = 2 calculate the jacobian at x and
-                                                              !! return this matrix in fjac. do not alter fvec.
-                                                              !!
-                                                              !! the value of iflag should not be changed by fcn unless
-                                                              !! the user wants to terminate execution of hybrj.
-                                                              !! in this case set iflag to a negative integer.
+            integer, intent(in) :: n !! the number of variables.
+            real(wp), dimension(n), intent(in) :: x !! independant variable vector
+            integer, intent(in) :: ldfjac !! leading dimension of the array fjac.
+            real(wp), dimension(n), intent(inout) :: fvec !! value of function at `x`
+            real(wp), dimension(ldfjac, n), intent(inout) :: fjac !! jacobian matrix at `x`
+            integer, intent(inout) :: iflag !! if iflag = 1 calculate the functions at x and
+                                            !! return this vector in fvec. do not alter fjac.
+                                            !! if iflag = 2 calculate the jacobian at x and
+                                            !! return this matrix in fjac. do not alter fvec.
+                                            !!
+                                            !! the value of iflag should not be changed by fcn unless
+                                            !! the user wants to terminate execution of hybrj.
+                                            !! in this case set iflag to a negative integer.
         end subroutine fcn_hybrj
 
         subroutine fcn_lmder(m, n, x, fvec, fjac, ldfjac, iflag)
@@ -97,7 +97,7 @@ subroutine fcn_lmstr(m, n, x, fvec, fjrow, iflag)
                                        !! the value of iflag should not be changed by fcn unless
                                        !! the user wants to terminate execution of lmstr.
                                        !! in this case set iflag to a negative integer.
-            real(wp), intent(in) :: x(n) !! independent variable vector
+            real(wp), intent(in) :: x(n) !! independant variable vector
             real(wp), intent(inout) :: fvec(m) !! value of function at `x`
             real(wp), intent(inout) :: fjrow(n) !! jacobian row
         end subroutine fcn_lmstr
@@ -703,7 +703,7 @@ subroutine hybrd(fcn, n, x, Fvec, Xtol, Maxfev, Ml, Mu, Epsfcn, Diag, Mode, &
         ! determine the number of calls to fcn needed to compute
         ! the jacobian matrix.
 
-        msum = min0(Ml + Mu + 1, n)
+        msum = min(Ml + Mu + 1, n)
 
         ! initialize iteration counter and monitors.
 
@@ -3125,7 +3125,7 @@ subroutine qform(m, n, q, Ldq, Wa)
 
         ! zero out upper triangle of q in the first min(m,n) columns.
 
-        minmn = min0(m, n)
+        minmn = min(m, n)
         if (minmn >= 2) then
             do j = 2, minmn
                 jm1 = j - 1
@@ -3240,7 +3240,7 @@ subroutine qrfac(m, n, a, Lda, Pivot, Ipvt, Lipvt, Rdiag, Acnorm, Wa)
 
         ! reduce a to r with householder transformations.
 
-        minmn = min0(m, n)
+        minmn = min(m, n)
         do j = 1, minmn
             if (Pivot) then
 
@@ -3515,10 +3515,13 @@ subroutine r1mpyq(m, n, a, Lda, v, w)
         if (nm1 >= 1) then
             do nmj = 1, nm1
                 j = n - nmj
-                if (abs(v(j)) > one) cos = one/v(j)
-                if (abs(v(j)) > one) sin = sqrt(one - cos**2)
-                if (abs(v(j)) <= one) sin = v(j)
-                if (abs(v(j)) <= one) cos = sqrt(one - sin**2)
+                if (abs(v(j)) > one) then
+                    cos = one/v(j)
+                    sin = sqrt(one - cos**2)
+                else
+                    sin = v(j)
+                    cos = sqrt(one - sin**2)
+                end if
                 do i = 1, m
                     temp = cos*a(i, j) - sin*a(i, n)
                     a(i, n) = sin*a(i, j) + cos*a(i, n)

src/minpack_capi.f90

@@ -187,8 +187,8 @@ subroutine wrap_fcn(n, x, fvec, fjac, ldfjac, iflag)
             integer, intent(in) :: n
             real(wp), intent(in) :: x(n)
             integer, intent(in) :: ldfjac
-            real(wp), intent(out) :: fvec(n)
-            real(wp), intent(out) :: fjac(ldfjac, n)
+            real(wp), intent(inout) :: fvec(n)
+            real(wp), intent(inout) :: fjac(ldfjac, n)
             integer, intent(inout) :: iflag
 
             call fcn(n, x, fvec, fjac, ldfjac, iflag, udata)
@@ -216,8 +216,8 @@ subroutine wrap_fcn(n, x, fvec, fjac, ldfjac, iflag)
             integer, intent(in) :: n
             real(wp), intent(in) :: x(n)
             integer, intent(in) :: ldfjac
-            real(wp), intent(out) :: fvec(n)
-            real(wp), intent(out) :: fjac(ldfjac, n)
+            real(wp), intent(inout) :: fvec(n)
+            real(wp), intent(inout) :: fjac(ldfjac, n)
             integer, intent(inout) :: iflag
 
             call fcn(n, x, fvec, fjac, ldfjac, iflag, udata)