|
| 1 | +! Template parameter: wp (working precision) |
| 2 | +! Template free identifiers: testline, tests |
| 3 | +subroutine isabs(got, expected, eps, msg) |
| 4 | + real(kind=wp), intent(in) :: got, expected |
| 5 | + character(len=*), intent(in), optional :: msg |
| 6 | + real(kind=wp), intent(in), optional :: eps |
| 7 | + character(len=:), allocatable :: testmsg, idmsg |
| 8 | + character(len=120) gotmsg, expectedmsg |
| 9 | + real(kind=wp) tolerance |
| 10 | + logical good |
| 11 | + |
| 12 | + if (present(msg)) then |
| 13 | + allocate(character(len=len_trim(msg)+20) :: testmsg, idmsg) |
| 14 | + write (unit=idmsg, fmt='(A,A,A)') 'Failed test: "', trim(msg), '"' |
| 15 | + testmsg = trim(msg) |
| 16 | + else |
| 17 | + allocate(character(len=30) :: testmsg, idmsg) |
| 18 | + write (unit=idmsg, fmt='(A,I0)') 'Failed test no. ', tests + 1 |
| 19 | + testmsg = "" |
| 20 | + end if |
| 21 | + write (unit=gotmsg, fmt='(A,G0)') ' got: ', got |
| 22 | + write (unit=expectedmsg, fmt='(A,G0)') 'expected: ', expected |
| 23 | + |
| 24 | + if (present(eps)) then |
| 25 | + tolerance = eps |
| 26 | + else |
| 27 | + tolerance = epsilon(got) |
| 28 | + end if |
| 29 | + ! eps = 0.5e-10_wp |
| 30 | + ! Absolute accuracy within the 10 least significant digits |
| 31 | + good = abs(got - expected) < tolerance |
| 32 | + call testline(good, testmsg, idmsg, gotmsg, expectedmsg) |
| 33 | +end |
| 34 | + |
| 35 | +subroutine isrel(got, expected, eps, msg) |
| 36 | + real(kind=wp), intent(in) :: got, expected |
| 37 | + character(len=*), intent(in), optional :: msg |
| 38 | + real(kind=wp), intent(in), optional :: eps |
| 39 | + real(kind=wp) tolerance |
| 40 | + |
| 41 | + ! eps = (abs(a) + abs(b)) * 0.5e-10_wp |
| 42 | + ! Relative accuracy within the 10 most significant digits |
| 43 | + tolerance = (abs(got) + abs(expected)) |
| 44 | + if (present(eps)) then |
| 45 | + tolerance = tolerance * eps |
| 46 | + else |
| 47 | + tolerance = tolerance * epsilon(got) |
| 48 | + end if |
| 49 | + call isabs(got, expected, tolerance, msg) |
| 50 | +end |
| 51 | + |
| 52 | +subroutine isnear(got, expected, eps, msg) |
| 53 | + real(kind=wp), intent(in) :: got, expected |
| 54 | + character(len=*), intent(in), optional :: msg |
| 55 | + real(kind=wp), intent(in), optional :: eps |
| 56 | + character(len=:), allocatable :: testmsg, idmsg |
| 57 | + character(len=120) gotmsg, expectedmsg |
| 58 | + real(kind=wp) tolerance |
| 59 | + logical good |
| 60 | + |
| 61 | + if (present(msg)) then |
| 62 | + allocate(character(len=len_trim(msg)+20) :: testmsg, idmsg) |
| 63 | + write (unit=idmsg, fmt='(A,A,A)') 'Failed test: "', trim(msg), '"' |
| 64 | + testmsg = trim(msg) |
| 65 | + else |
| 66 | + allocate(character(len=30) :: testmsg, idmsg) |
| 67 | + write (unit=idmsg, fmt='(A,I0)') 'Failed test no. ', tests + 1 |
| 68 | + testmsg = "" |
| 69 | + end if |
| 70 | + write (unit=gotmsg, fmt='(A,G0)') ' got: ', got |
| 71 | + write (unit=expectedmsg, fmt='(A,G0)') 'expected: ', expected |
| 72 | + |
| 73 | + if (present(eps)) then |
| 74 | + tolerance = eps |
| 75 | + else |
| 76 | + tolerance = epsilon(got) ! minimun eps for which 1 + eps /= 1 |
| 77 | + end if |
| 78 | + ! Relative accuracy around 1.0_wp |
| 79 | + ! Semantics of isnear means using <=, and not <, c.f. epsilon(got) |
| 80 | + good = abs(got / expected - 1.0_wp) <= tolerance |
| 81 | + call testline(good, testmsg, idmsg, gotmsg, expectedmsg) |
| 82 | +end |
| 83 | + |
0 commit comments