Skip to content

Commit

Permalink
Merge pull request #40 from jacobwilliams/test-refactoring
Browse files Browse the repository at this point in the history 
Modernize the tests
  • Loading branch information
@jacobwilliams
jacobwilliams authored Mar 13, 2022
2 parents 96c279d + c4ddcc9 commit e26542b
Show file tree
Hide file tree
Showing 10 changed files with 4,575 additions and 3,940 deletions.
4 changes: 2 additions & 2 deletions examples/example_lmder1.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
2 changes: 1 addition & 1 deletion examples/example_lmdif1.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
49 changes: 26 additions & 23 deletions src/minpack.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -27,7 +27,7 @@ subroutine func(n, x, fvec, iflag)
import :: wp
implicit none
integer, intent(in) :: n !! the number of variables.
real(wp), intent(in) :: x(n) !! independant variable vector
real(wp), intent(in) :: x(n) !! independent variable vector
real(wp), intent(out) :: fvec(n) !! value of function at `x`
integer, intent(inout) :: iflag !! set to <0 to terminate execution
end subroutine func
Expand All @@ -38,7 +38,7 @@ subroutine func2(m, n, x, fvec, iflag)
implicit none
integer, intent(in) :: m !! the number of functions.
integer, intent(in) :: n !! the number of variables.
real(wp), intent(in) :: x(n) !! independant variable vector
real(wp), intent(in) :: x(n) !! independent variable vector
real(wp), intent(out) :: fvec(m) !! value of function at `x`
integer, intent(inout) :: iflag !! the value of iflag should not be changed unless
!! the user wants to terminate execution of lmdif.
Expand All @@ -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 !! independent 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)
Expand All @@ -79,7 +79,7 @@ subroutine fcn_lmder(m, n, x, fvec, fjac, ldfjac, iflag)
!! the value of iflag should not be changed by fcn unless
!! the user wants to terminate execution of lmder.
!! in this case set iflag to a negative integer.
real(wp), intent(in) :: x(n) !! independant variable vector
real(wp), intent(in) :: x(n) !! independent variable vector
real(wp), intent(inout) :: fvec(m) !! value of function at `x`
real(wp), intent(inout) :: fjac(ldfjac, n) !! jacobian matrix at `x`
end subroutine fcn_lmder
Expand Down Expand Up @@ -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.

Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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

Expand Down Expand Up @@ -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)
Expand Down
8 changes: 4 additions & 4 deletions src/minpack_capi.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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)
Expand Down
Loading

0 comments on commit e26542b

Please sign in to comment.