forked from scivision/fortran2018-examples
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathassert.f90
155 lines (126 loc) · 4.3 KB
/
assert.f90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
module assert
use, intrinsic:: iso_fortran_env, stderr=>error_unit, sp=>real32, dp=>real64
use, intrinsic:: ieee_arithmetic
implicit none (type, external)
private
public :: isclose, assert_isclose
interface isclose
module procedure isclose_32, isclose_64
end interface isclose
interface assert_isclose
module procedure assert_isclose_32, assert_isclose_64
end interface assert_isclose
contains
elemental logical function isclose_32(actual, desired, rtol, atol, equal_nan) result (isclose)
! inputs
! ------
! actual: value "measured"
! desired: value "wanted"
! rtol: relative tolerance
! atol: absolute tolerance
! equal_nan: consider NaN to be equal?
!
! rtol overrides atol when both are specified
!
! https://www.python.org/dev/peps/pep-0485/#proposed-implementation
! https://github.com/PythonCHB/close_pep/blob/master/is_close.py
real(sp), intent(in) :: actual, desired
real(sp), intent(in), optional :: rtol, atol
logical, intent(in), optional :: equal_nan
real(sp) :: r,a
logical :: n
! this is appropriate INSTEAD OF merge(), since non present values aren't defined.
r = 1e-5_sp
a = 0
n = .false.
if (present(rtol)) r = rtol
if (present(atol)) a = atol
if (present(equal_nan)) n = equal_nan
!print*,r,a,n,actual,desired
!--- sanity check
if ((r < 0).or.(a < 0)) error stop 'invalid tolerance parameter(s)'
!--- equal nan
isclose = n.and.(ieee_is_nan(actual).and.ieee_is_nan(desired))
if (isclose) return
!--- Inf /= Inf, unequal NaN
if (.not.ieee_is_finite(actual) .or. .not.ieee_is_finite(desired)) return
!--- floating point closeness check
isclose = abs(actual-desired) <= max(r * max(abs(actual), abs(desired)), a)
end function isclose_32
elemental logical function isclose_64(actual, desired, rtol, atol, equal_nan) result (isclose)
! inputs
! ------
! actual: value "measured"
! desired: value "wanted"
! rtol: relative tolerance
! atol: absolute tolerance
! equal_nan: consider NaN to be equal?
!
! rtol overrides atol when both are specified
!
! https://www.python.org/dev/peps/pep-0485/#proposed-implementation
! https://github.com/PythonCHB/close_pep/blob/master/is_close.py
real(dp), intent(in) :: actual, desired
real(dp), intent(in), optional :: rtol, atol
logical, intent(in), optional :: equal_nan
real(dp) :: r,a
logical :: n
! this is appropriate INSTEAD OF merge(), since non present values aren't defined.
r = 1e-5_dp
a = 0
n = .false.
if (present(rtol)) r = rtol
if (present(atol)) a = atol
if (present(equal_nan)) n = equal_nan
!print*,r,a,n,actual,desired
!--- sanity check
if ((r < 0).or.(a < 0)) error stop 'invalid tolerance parameter(s)'
!--- equal nan
isclose = n.and.(ieee_is_nan(actual).and.ieee_is_nan(desired))
if (isclose) return
!--- Inf /= Inf, unequal NaN
if (.not.ieee_is_finite(actual) .or. .not.ieee_is_finite(desired)) return
!--- floating point closeness check
isclose = abs(actual-desired) <= max(r * max(abs(actual), abs(desired)), a)
end function isclose_64
impure elemental subroutine assert_isclose_64(actual, desired, rtol, atol, equal_nan, err_msg)
! inputs
! ------
! actual: value "measured"
! desired: value "wanted"
! rtol: relative tolerance
! atol: absolute tolerance
! equal_nan: consider NaN to be equal?
! err_msg: message to print on mismatch
!
! rtol overrides atol when both are specified
real(dp), intent(in) :: actual, desired
real(dp), intent(in), optional :: rtol, atol
logical, intent(in), optional :: equal_nan
character(*), intent(in), optional :: err_msg
if (.not.isclose(actual,desired,rtol,atol,equal_nan)) then
write(stderr,*) merge(err_msg,'',present(err_msg)),': actual',actual,'desired',desired
error stop
endif
end subroutine assert_isclose_64
impure elemental subroutine assert_isclose_32(actual, desired, rtol, atol, equal_nan, err_msg)
! inputs
! ------
! actual: value "measured"
! desired: value "wanted"
! rtol: relative tolerance
! atol: absolute tolerance
! equal_nan: consider NaN to be equal?
! err_msg: message to print on mismatch
!
! rtol overrides atol when both are specified
real(sp), intent(in) :: actual, desired
real(sp), intent(in), optional :: rtol, atol
logical, intent(in), optional :: equal_nan
character(*), intent(in), optional :: err_msg
if (.not.isclose(actual,desired,rtol,atol,equal_nan)) then
write(stderr,*) merge(err_msg,'',present(err_msg)),': actual',actual,'desired',desired
error stop
endif
end subroutine assert_isclose_32
end module assert