Skip to content

Commit fca10b5

Browse files
jacobwilliamsjacobwilliams
committed
see if this fixes the floating point warnings
changed the tests to nested ifs, so the inner ones aren't computed if the outer ones fail.
1 parent 92a4c6a commit fca10b5

File tree

6 files changed

+236
-69
lines changed

6 files changed

+236
-69
lines changed

‎test/test_chkder.f90

Lines changed: 39 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -35,6 +35,8 @@ program test_chkder
3535
real(wp), parameter :: tol = sqrt(dpmpar(1)) !! abstol for matching previously generated solutions
3636
real(wp), parameter :: solution_reltol = 1.0e-4_wp !! reltol for matching previously generated solutions
3737

38+
integer,dimension(ncases),parameter :: info_original = 1 ! not used here
39+
3840
cp = 1.23e-1_wp
3941

4042
do icase = 1, ncases+1
@@ -92,15 +94,7 @@ program test_chkder
9294
write (nwrite, '(//5x, a//(5x, 5d15.7))') ' FIRST FUNCTION VECTOR ', (fvec1(i), i=1, n)
9395
write (nwrite, '(//5x, a//(5x, 5d15.7))') ' FUNCTION DIFFERENCE VECTOR', (diff(i), i=1, n)
9496
write (nwrite, '(//5x, a//(5x, 5d15.7))') ' ERROR VECTOR', (err(i), i=1, n)
95-
96-
! compare with previously generated solutions:
97-
if (any(abs(solution(nprob) - diff)>tol .and. &
98-
abs((solution(nprob) - diff)/(solution(nprob))) > solution_reltol)) then
99-
write(nwrite,'(A)') 'Failed case'
100-
write(nwrite, '(//5x, a//(5x, 5d15.7))') 'Expected diff: ', solution(nprob)
101-
write(nwrite, '(/5x, a//(5x, 5d15.7))') 'Computed diff: ', diff
102-
error stop
103-
end if
97+
call compare_solutions(nprob, diff, solution_reltol, tol)
10498

10599
end if
106100

@@ -109,6 +103,42 @@ program test_chkder
109103
contains
110104
!*****************************************************************************************
111105

106+
!*****************************************************************************************
107+
!>
108+
! Compare with previously generated solutions.
109+
110+
subroutine compare_solutions(ic, x, reltol, abstol)
111+
112+
implicit none
113+
114+
integer,intent(in) :: ic !! problem number (index is `solution` vector)
115+
real(wp),dimension(:),intent(in) :: x !! computed `x` vector from the method
116+
real(wp),intent(in) :: reltol !! relative tolerance for `x` to pass
117+
real(wp),intent(in) :: abstol !! absolute tolerance for `x` to pass
118+
119+
real(wp),dimension(size(x)) :: diff, absdiff, reldiff
120+
121+
if (info_original(ic)<5) then ! ignore any where the original minpack failed
122+
diff = solution(ic) - x
123+
absdiff = abs(diff)
124+
if (any(absdiff>abstol)) then ! first do an absolute diff
125+
! also do a rel diff if the abs diff fails (also protect for divide by zero)
126+
reldiff = absdiff
127+
where (solution(ic) /= 0.0_wp) reldiff = absdiff / abs(solution(ic))
128+
if (any(reldiff > reltol)) then
129+
write(nwrite,'(A)') 'Failed case'
130+
write(nwrite, '(//5x, a//(5x, 5d15.7))') 'Expected x: ', solution(ic)
131+
write(nwrite, '(/5x, a//(5x, 5d15.7))') 'Computed x: ', x
132+
write(nwrite, '(/5x, a//(5x, 5d15.7))') 'absdiff: ', absdiff
133+
write(nwrite, '(/5x, a//(5x, 5d15.7))') 'reldiff: ', reldiff
134+
error stop ! test failed
135+
end if
136+
end if
137+
end if
138+
139+
end subroutine compare_solutions
140+
!*****************************************************************************************
141+
112142
!*****************************************************************************************
113143
!>
114144
! Replaced statement function in original code.

‎test/test_hybrd.f90

Lines changed: 49 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -28,10 +28,10 @@ program test_hybrd
2828
1,1,1,1,1,1,1,1,1]
2929

3030
integer :: i, ic, info, k, lwa, n, NFEv, NPRob, ntries, icase
31-
integer :: na(55), nf(55), np(55), nx(55)
32-
real(wp) :: fnm(55)
31+
integer,dimension(55) :: na, nf, np, nx
32+
real(wp),dimension(55) :: fnm
3333
real(wp) :: factor, fnorm1, fnorm2
34-
real(wp),allocatable :: fvec(:), wa(:), x(:)
34+
real(wp),dimension(:),allocatable :: fvec, wa, x
3535

3636
integer, parameter :: nwrite = output_unit !! logical output unit
3737
real(wp), parameter :: one = 1.0_wp
@@ -84,24 +84,50 @@ program test_hybrd
8484
' EXIT PARAMETER', info, &
8585
' FINAL APPROXIMATE SOLUTION', x(1:n)
8686
factor = ten*factor
87-
88-
! compare with previously generated solutions:
89-
if (info_original(ic)<5 .and. & ! ignore any where the original minpack failed
90-
any(abs( solution(ic) - x)>tol .and. &
91-
abs((solution(ic) - x)/(solution(ic))) > solution_reltol)) then
92-
write(nwrite,'(A)') 'Failed case'
93-
write(nwrite, '(//5x, a//(5x, 5d15.7))') 'Expected x: ', solution(ic)
94-
write(nwrite, '(/5x, a//(5x, 5d15.7))') 'Computed x: ', x
95-
error stop
96-
end if
97-
87+
call compare_solutions(ic, x, solution_reltol, tol)
9888
end do
9989
end if
10090
end do
10191

10292
contains
10393
!*****************************************************************************************
10494

95+
!*****************************************************************************************
96+
!>
97+
! Compare with previously generated solutions.
98+
99+
subroutine compare_solutions(ic, x, reltol, abstol)
100+
101+
implicit none
102+
103+
integer,intent(in) :: ic !! problem number (index is `solution` vector)
104+
real(wp),dimension(:),intent(in) :: x !! computed `x` vector from the method
105+
real(wp),intent(in) :: reltol !! relative tolerance for `x` to pass
106+
real(wp),intent(in) :: abstol !! absolute tolerance for `x` to pass
107+
108+
real(wp),dimension(size(x)) :: diff, absdiff, reldiff
109+
110+
if (info_original(ic)<5) then ! ignore any where the original minpack failed
111+
diff = solution(ic) - x
112+
absdiff = abs(diff)
113+
if (any(absdiff>abstol)) then ! first do an absolute diff
114+
! also do a rel diff if the abs diff fails (also protect for divide by zero)
115+
reldiff = absdiff
116+
where (solution(ic) /= 0.0_wp) reldiff = absdiff / abs(solution(ic))
117+
if (any(reldiff > reltol)) then
118+
write(nwrite,'(A)') 'Failed case'
119+
write(nwrite, '(//5x, a//(5x, 5d15.7))') 'Expected x: ', solution(ic)
120+
write(nwrite, '(/5x, a//(5x, 5d15.7))') 'Computed x: ', x
121+
write(nwrite, '(/5x, a//(5x, 5d15.7))') 'absdiff: ', absdiff
122+
write(nwrite, '(/5x, a//(5x, 5d15.7))') 'reldiff: ', reldiff
123+
error stop ! test failed
124+
end if
125+
end if
126+
end if
127+
128+
end subroutine compare_solutions
129+
!*****************************************************************************************
130+
105131
!*****************************************************************************************
106132
!>
107133
! The calling sequence of fcn should be identical to the
@@ -388,14 +414,20 @@ subroutine vecfcn(n, x, Fvec, Nprob)
388414
Fvec(4) = c6*temp2 + c4*(x(4) - one) + c5*(x(2) - one)
389415
case (5)
390416
! HELICAL VALLEY FUNCTION.
417+
write(*,*) '1'
391418
tpi = eight*atan(one)
392-
temp1 = sign(c7, x(2))
393-
if (x(1) > zero) temp1 = atan(x(2)/x(1))/tpi
394-
if (x(1) < zero) temp1 = atan(x(2)/x(1))/tpi + c8
419+
if (x(1) > zero) then
420+
temp1 = atan(x(2)/x(1))/tpi
421+
else if (x(1) < zero) then
422+
temp1 = atan(x(2)/x(1))/tpi + c8
423+
else
424+
temp1 = sign(c7, x(2)) ! does this ever happen?
425+
end if
395426
temp2 = sqrt(x(1)**2 + x(2)**2)
396427
Fvec(1) = ten*(x(3) - ten*temp1)
397428
Fvec(2) = ten*(temp2 - one)
398429
Fvec(3) = x(3)
430+
write(*,*) '2'
399431
case (6)
400432
! WATSON FUNCTION.
401433
do k = 1, n

‎test/test_hybrj.f90

Lines changed: 37 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -89,16 +89,7 @@ program test_hybrj
8989
' EXIT PARAMETER', info, &
9090
' FINAL APPROXIMATE SOLUTION', x(1:n)
9191
factor = ten*factor
92-
93-
! compare with previously generated solutions:
94-
if (info_original(ic)<5 .and. & ! ignore any where the original minpack failed
95-
any(abs( solution(ic) - x)>tol .and. &
96-
abs((solution(ic) - x)/(solution(ic))) > solution_reltol)) then
97-
write(nwrite,'(A)') 'Failed case'
98-
write(nwrite, '(//5x, a//(5x, 5d15.7))') 'Expected x: ', solution(ic)
99-
write(nwrite, '(/5x, a//(5x, 5d15.7))') 'Computed x: ', x
100-
error stop
101-
end if
92+
call compare_solutions(ic, x, solution_reltol, tol)
10293

10394
end do
10495
end if
@@ -107,6 +98,42 @@ program test_hybrj
10798
contains
10899
!*****************************************************************************************
109100

101+
!*****************************************************************************************
102+
!>
103+
! Compare with previously generated solutions.
104+
105+
subroutine compare_solutions(ic, x, reltol, abstol)
106+
107+
implicit none
108+
109+
integer,intent(in) :: ic !! problem number (index is `solution` vector)
110+
real(wp),dimension(:),intent(in) :: x !! computed `x` vector from the method
111+
real(wp),intent(in) :: reltol !! relative tolerance for `x` to pass
112+
real(wp),intent(in) :: abstol !! absolute tolerance for `x` to pass
113+
114+
real(wp),dimension(size(x)) :: diff, absdiff, reldiff
115+
116+
if (info_original(ic)<5) then ! ignore any where the original minpack failed
117+
diff = solution(ic) - x
118+
absdiff = abs(diff)
119+
if (any(absdiff>abstol)) then ! first do an absolute diff
120+
! also do a rel diff if the abs diff fails (also protect for divide by zero)
121+
reldiff = absdiff
122+
where (solution(ic) /= 0.0_wp) reldiff = absdiff / abs(solution(ic))
123+
if (any(reldiff > reltol)) then
124+
write(nwrite,'(A)') 'Failed case'
125+
write(nwrite, '(//5x, a//(5x, 5d15.7))') 'Expected x: ', solution(ic)
126+
write(nwrite, '(/5x, a//(5x, 5d15.7))') 'Computed x: ', x
127+
write(nwrite, '(/5x, a//(5x, 5d15.7))') 'absdiff: ', absdiff
128+
write(nwrite, '(/5x, a//(5x, 5d15.7))') 'reldiff: ', reldiff
129+
error stop ! test failed
130+
end if
131+
end if
132+
end if
133+
134+
end subroutine compare_solutions
135+
!*****************************************************************************************
136+
110137
!*****************************************************************************************
111138
!>
112139
! The calling sequence of fcn should be identical to the

‎test/test_lmder.f90

Lines changed: 37 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -95,24 +95,50 @@ program test_lmder
9595
' EXIT PARAMETER', info, &
9696
' FINAL APPROXIMATE SOLUTION',x(1:n)
9797
factor = ten*factor
98-
99-
! compare with previously generated solutions:
100-
if (info_original(ic)<5 .and. & ! ignore any where the original minpack failed
101-
any(abs( solution(ic) - x)>tol .and. &
102-
abs((solution(ic) - x)/(solution(ic))) > solution_reltol)) then
103-
write(nwrite,'(A)') 'Failed case'
104-
write(nwrite, '(//5x, a//(5x, 5d15.7))') 'Expected x: ', solution(ic)
105-
write(nwrite, '(/5x, a//(5x, 5d15.7))') 'Computed x: ', x
106-
error stop
107-
end if
108-
98+
call compare_solutions(ic, x, solution_reltol, tol)
10999
end do
110100
end if
111101
end do
112102

113103
contains
114104
!*****************************************************************************************
115105

106+
!*****************************************************************************************
107+
!>
108+
! Compare with previously generated solutions.
109+
110+
subroutine compare_solutions(ic, x, reltol, abstol)
111+
112+
implicit none
113+
114+
integer,intent(in) :: ic !! problem number (index is `solution` vector)
115+
real(wp),dimension(:),intent(in) :: x !! computed `x` vector from the method
116+
real(wp),intent(in) :: reltol !! relative tolerance for `x` to pass
117+
real(wp),intent(in) :: abstol !! absolute tolerance for `x` to pass
118+
119+
real(wp),dimension(size(x)) :: diff, absdiff, reldiff
120+
121+
if (info_original(ic)<5) then ! ignore any where the original minpack failed
122+
diff = solution(ic) - x
123+
absdiff = abs(diff)
124+
if (any(absdiff>abstol)) then ! first do an absolute diff
125+
! also do a rel diff if the abs diff fails (also protect for divide by zero)
126+
reldiff = absdiff
127+
where (solution(ic) /= 0.0_wp) reldiff = absdiff / abs(solution(ic))
128+
if (any(reldiff > reltol)) then
129+
write(nwrite,'(A)') 'Failed case'
130+
write(nwrite, '(//5x, a//(5x, 5d15.7))') 'Expected x: ', solution(ic)
131+
write(nwrite, '(/5x, a//(5x, 5d15.7))') 'Computed x: ', x
132+
write(nwrite, '(/5x, a//(5x, 5d15.7))') 'absdiff: ', absdiff
133+
write(nwrite, '(/5x, a//(5x, 5d15.7))') 'reldiff: ', reldiff
134+
error stop ! test failed
135+
end if
136+
end if
137+
end if
138+
139+
end subroutine compare_solutions
140+
!*****************************************************************************************
141+
116142
!*****************************************************************************************
117143
!>
118144
! The calling sequence of fcn should be identical to the

‎test/test_lmdif.f90

Lines changed: 37 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -88,24 +88,50 @@ program test_lmdif
8888
' EXIT PARAMETER', info, &
8989
' FINAL APPROXIMATE SOLUTION', x(1:n)
9090
factor = ten*factor
91-
92-
! compare with previously generated solutions:
93-
if (info_original(ic)<5 .and. & ! ignore any where the original minpack failed
94-
any(abs( solution(ic) - x)>tol .and. &
95-
abs((solution(ic) - x)/(solution(ic))) > solution_reltol)) then
96-
write(nwrite,'(A)') 'Failed case'
97-
write(nwrite, '(//5x, a//(5x, 5d15.7))') 'Expected x: ', solution(ic)
98-
write(nwrite, '(/5x, a//(5x, 5d15.7))') 'Computed x: ', x
99-
error stop
100-
end if
101-
91+
call compare_solutions(ic, x, solution_reltol, tol)
10292
end do
10393
end if
10494
end do
10595

10696
contains
10797
!*****************************************************************************************
10898

99+
!*****************************************************************************************
100+
!>
101+
! Compare with previously generated solutions.
102+
103+
subroutine compare_solutions(ic, x, reltol, abstol)
104+
105+
implicit none
106+
107+
integer,intent(in) :: ic !! problem number (index is `solution` vector)
108+
real(wp),dimension(:),intent(in) :: x !! computed `x` vector from the method
109+
real(wp),intent(in) :: reltol !! relative tolerance for `x` to pass
110+
real(wp),intent(in) :: abstol !! absolute tolerance for `x` to pass
111+
112+
real(wp),dimension(size(x)) :: diff, absdiff, reldiff
113+
114+
if (info_original(ic)<5) then ! ignore any where the original minpack failed
115+
diff = solution(ic) - x
116+
absdiff = abs(diff)
117+
if (any(absdiff>abstol)) then ! first do an absolute diff
118+
! also do a rel diff if the abs diff fails (also protect for divide by zero)
119+
reldiff = absdiff
120+
where (solution(ic) /= 0.0_wp) reldiff = absdiff / abs(solution(ic))
121+
if (any(reldiff > reltol)) then
122+
write(nwrite,'(A)') 'Failed case'
123+
write(nwrite, '(//5x, a//(5x, 5d15.7))') 'Expected x: ', solution(ic)
124+
write(nwrite, '(/5x, a//(5x, 5d15.7))') 'Computed x: ', x
125+
write(nwrite, '(/5x, a//(5x, 5d15.7))') 'absdiff: ', absdiff
126+
write(nwrite, '(/5x, a//(5x, 5d15.7))') 'reldiff: ', reldiff
127+
error stop ! test failed
128+
end if
129+
end if
130+
end if
131+
132+
end subroutine compare_solutions
133+
!*****************************************************************************************
134+
109135
!*****************************************************************************************
110136
!>
111137
! The calling sequence of fcn should be identical to the

0 commit comments

Comments
 (0)