!> @file tests/util.f90 !------------------------------------------------------------------------------! ! This file is part of the PALM model system. ! ! PALM is free software: you can redistribute it and/or modify it under the ! terms of the GNU General Public License as published by the Free Software ! Foundation, either version 3 of the License, or (at your option) any later ! version. ! ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY ! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR ! A PARTICULAR PURPOSE. See the GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License along with ! PALM. If not, see . ! ! Copyright 2017-2018 Leibniz Universitaet Hannover ! Copyright 2017-2018 Deutscher Wetterdienst Offenbach !------------------------------------------------------------------------------! ! ! Current revisions: ! ----------------- ! ! ! Former revisions: ! ----------------- ! $Id: util.f90 3183 2018-07-27 14:25:55Z eckhard $ ! Expose error measure as parameter in assert_equal() ! ! ! 3182 2018-07-27 13:36:03Z suehring ! Initial revision ! ! ! ! Authors: ! -------- ! @author Eckhard Kadasch ! ! Description: ! ------------ !> This module provides utiliy functions used in all test programs. !------------------------------------------------------------------------------! MODULE test_utils IMPLICIT NONE CONTAINS SUBROUTINE begin_test(title, res) CHARACTER(LEN=*), INTENT(IN) :: title LOGICAL, INTENT(OUT) :: res res = .TRUE. PRINT '(/A)', "******************************************************" PRINT '(A, A, A)', " [ ] Test '", TRIM(title), "' started." PRINT '(A/)', "******************************************************" END SUBROUTINE begin_test SUBROUTINE end_test(title, res) CHARACTER(LEN=*), INTENT(IN) :: title CHARACTER(LEN=30) :: msg, label LOGICAL, INTENT(IN) :: res IF (res .EQV. .TRUE.) THEN msg = 'completed successfully.' label = ' [OK]' ELSE msg = 'failed.' label = ' [XX]' END IF PRINT '(/A, A, A, A)', TRIM(label) // " Test '", TRIM(title), "' ", TRIM(msg) PRINT '(A/)', "******************************************************" END SUBROUTINE end_test LOGICAL FUNCTION assert_equal(a, b, msg, ratio) REAL, OPTIONAL, INTENT(IN) :: ratio REAL, DIMENSION(:), INTENT(IN) :: a, b CHARACTER(LEN=*), INTENT(IN) :: msg IF ( PRESENT(ratio) ) THEN assert_equal = assert(a, b, 'eq', ratio) ELSE assert_equal = assert(a, b, 'eq') END IF IF (assert_equal .eqv. .TRUE.) THEN PRINT *, "Equality assertion for ", msg, " was successful." ELSE PRINT *, "Equality assertion for ", msg, " failed. Maximum error is ", & MAXVAL( ABS( a - b)) END IF END FUNCTION assert_equal LOGICAL FUNCTION assert(a, b, mode, ratio) REAL, DIMENSION(:), INTENT(IN) :: a, b REAL, OPTIONAL, INTENT(IN) :: ratio CHARACTER(LEN=*), INTENT(IN) :: mode REAL :: diff, mag, max_rel_diff INTEGER :: i max_rel_diff = 10 * EPSILON(1.0) IF (PRESENT(ratio)) max_rel_diff = ratio SELECT CASE( TRIM(mode) ) ! This case is inspired by ! https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ CASE('eq') IF ( ALL(a(:) == b(:)) ) THEN PRINT *, "Checking for exact equality" assert = .TRUE. ELSE assert = .TRUE. PRINT *, "Checking for near equality" DO i = 1, SIZE(a) diff = ABS(a(i) - b(i)) mag = MAX( ABS(a(i)), ABS(b(i)) ) assert = assert .AND. (diff < mag * max_rel_diff ) END DO END IF CASE DEFAULT PRINT *, " Error: Assert mode ", mode, " not implemented. Stopping." STOP END SELECT END FUNCTION assert END MODULE test_utils