1module assertion
2   use, intrinsic :: iso_fortran_env, only: int16, int32, int64, real32, real64
3   use xtb_mctc_io, only : stderr
4   implicit none
5   private :: stderr
6
7   interface assert_eq
8      module procedure :: assert_eq_char
9      module procedure :: assert_eq_int16
10      module procedure :: assert_eq_int32
11      module procedure :: assert_eq_int64
12      module procedure :: assert_eq_int16_array
13      module procedure :: assert_eq_int32_array
14      module procedure :: assert_eq_int64_array
15   end interface assert_eq
16
17   interface assert_close
18      module procedure :: assert_close_int16
19      module procedure :: assert_close_int32
20      module procedure :: assert_close_int64
21      module procedure :: assert_close_real32
22      module procedure :: assert_close_real64
23   end interface assert_close
24
25   integer, public :: afail = 0
26
27contains
28
29subroutine assert(bool)
30   logical,intent(in) :: bool
31
32   if (.not.bool) then
33      write(stderr,'("assertion FAILED")')
34      afail = afail+1
35   endif
36end subroutine assert
37
38subroutine assert_eq_char(val1,val2)
39   character(len=*),intent(in) :: val1,val2
40
41   if (val1 /= val2) then
42      write(stderr,'("assertion:",1x,a," == ",a,1x,"FAILED")') &
43         val1,val2
44      afail = afail+1
45   endif
46end subroutine assert_eq_char
47
48subroutine assert_eq_int16(val1,val2)
49   integer(int16),intent(in) :: val1,val2
50
51   if (val1 /= val2) then
52      write(stderr,'("assertion:",1x,g21.14," == ",g21.14,1x,"FAILED")') &
53         val1,val2
54      afail = afail+1
55   endif
56end subroutine assert_eq_int16
57
58subroutine assert_eq_int32(val1,val2)
59   integer(int32),intent(in) :: val1,val2
60
61   if (val1 /= val2) then
62      write(stderr,'("assertion:",1x,g21.14," == ",g21.14,1x,"FAILED")') &
63         val1,val2
64      afail = afail+1
65   endif
66end subroutine assert_eq_int32
67
68subroutine assert_eq_int64(val1,val2)
69   integer(int64),intent(in) :: val1,val2
70
71   if (val1 /= val2) then
72      write(stderr,'("assertion:",1x,g21.14," == ",g21.14,1x,"FAILED")') &
73         val1,val2
74      afail = afail+1
75   endif
76end subroutine assert_eq_int64
77
78subroutine assert_eq_int16_array(val1,val2)
79   integer(int16),intent(in) :: val1(:),val2(:)
80   integer :: i
81
82   if (size(val1) .ne. size(val2)) then
83      write(stderr,'("shape missmatch:",1x,i0," == ",i0,1x,"FAILED")') &
84         val1,val2
85      afail = afail+1
86   endif
87   if (any(val1 /= val2)) then
88      do i = 1, size(val1)
89         if (val1(i) /= val2(i)) &
90         write(stderr,'("assertion:",1x,g21.14," == ",g21.14,1x,"FAILED at ",i0)')&
91            val1(i),val2(i),i
92      enddo
93      afail = afail+1
94   endif
95end subroutine assert_eq_int16_array
96
97subroutine assert_eq_int32_array(val1,val2)
98   integer(int32),intent(in) :: val1(:),val2(:)
99   integer :: i
100
101   if (size(val1) .ne. size(val2)) then
102      write(stderr,'("shape missmatch:",1x,i0," == ",i0,1x,"FAILED")') &
103         val1,val2
104      afail = afail+1
105   endif
106   if (any(val1 /= val2)) then
107      do i = 1, size(val1)
108         if (val1(i) /= val2(i)) &
109         write(stderr,'("assertion:",1x,g21.14," == ",g21.14,1x,"FAILED at ",i0)')&
110            val1(i),val2(i),i
111      enddo
112      afail = afail+1
113   endif
114end subroutine assert_eq_int32_array
115
116subroutine assert_eq_int64_array(val1,val2)
117   integer(int64),intent(in) :: val1(:),val2(:)
118   integer :: i
119
120   if (size(val1) .ne. size(val2)) then
121      write(stderr,'("shape missmatch:",1x,i0," == ",i0,1x,"FAILED")') &
122         val1,val2
123      afail = afail+1
124   endif
125   if (any(val1 /= val2)) then
126      do i = 1, size(val1)
127         if (val1(i) /= val2(i)) &
128         write(stderr,'("assertion:",1x,g21.14," == ",g21.14,1x,"FAILED at ",i0)')&
129            val1(i),val2(i),i
130      enddo
131      afail = afail+1
132   endif
133end subroutine assert_eq_int64_array
134
135subroutine assert_close_real64(val1,val2,thr)
136   real(real64),intent(in) :: val1,val2,thr
137   real(real64) :: diff
138
139   diff = val1 - val2
140   if (abs(diff) > thr) then
141      write(stderr,'("assertion:",1x,g21.14," == ",g21.14,1x,"FAILED")') &
142         val1,val2
143      afail = afail+1
144   endif
145end subroutine assert_close_real64
146
147subroutine assert_close_real32(val1,val2,thr)
148   real(real32),intent(in) :: val1,val2,thr
149   real(real32) :: diff
150
151   diff = val1 - val2
152   if (abs(diff) > thr) then
153      write(stderr,'("assertion:",1x,g21.14," == ",g21.14,1x,"FAILED")') &
154         val1,val2
155      afail = afail+1
156   endif
157end subroutine assert_close_real32
158
159subroutine assert_close_int16(val1,val2,thr)
160   integer(int16),intent(in) :: val1,val2,thr
161   integer(int16) :: diff
162
163   diff = val1 - val2
164   if (abs(diff) > thr) then
165      write(stderr,'("assertion:",1x,g21.14," == ",g21.14,1x,"FAILED")') &
166         val1,val2
167      afail = afail+1
168   endif
169end subroutine assert_close_int16
170
171subroutine assert_close_int32(val1,val2,thr)
172   integer(int32),intent(in) :: val1,val2,thr
173   integer(int32) :: diff
174
175   diff = val1 - val2
176   if (abs(diff) > thr) then
177      write(stderr,'("assertion:",1x,g21.14," == ",g21.14,1x,"FAILED")') &
178         val1,val2
179      afail = afail+1
180   endif
181end subroutine assert_close_int32
182
183subroutine assert_close_int64(val1,val2,thr)
184   integer(int64),intent(in) :: val1,val2,thr
185   integer(int64) :: diff
186
187   diff = val1 - val2
188   if (abs(diff) > thr) then
189      write(stderr,'("assertion:",1x,g21.14," == ",g21.14,1x,"FAILED")') &
190         val1,val2
191      afail = afail+1
192   endif
193end subroutine assert_close_int64
194
195end module assertion
196