source: palm/trunk/UTIL/inifor/tests/util.f90 @ 3182

!> @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 <http://www.gnu.org/licenses/>.
!
! Copyright 2017-2018 Leibniz Universitaet Hannover
! Copyright 2017-2018 Deutscher Wetterdienst Offenbach
!------------------------------------------------------------------------------!
!
! Current revisions:
! -----------------
! Expose error measure as parameter in assert_equal()
! 
! 
! Former revisions:
! -----------------
! $Id: util.f90 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