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