test_framework_routines.f90

Go to the documentation of this file.

MODULE test_framework_routines

  USE constants
  USE iso_varying_string
  USE kinds
  USE matrix_vector
  USE strings

#include "macros.h"
#include "dllexport.h"

  IMPLICIT NONE

  PRIVATE

  !Module parameters

  !Module types

  !Module variables

  !Interfaces
  
  INTERFACE test_framework_assert_equals
    MODULE PROCEDURE test_framework_assert_equals_intg
    MODULE PROCEDURE test_framework_assert_equals_dp
    MODULE PROCEDURE test_framework_assert_equals_dp1
    MODULE PROCEDURE test_framework_assert_equals_dp2
  END INTERFACE !TEST_FRAMEWORK_ASSERT_EQUALS
  
  PUBLIC test_framework_assert_equals, test_framework_gradient_value_get

CONTAINS  

  !
  !================================================================================================================================
  !   
  
  SUBROUTINE test_framework_assert_equals_intg(EXPECTED_VALUE,ACTUAL_VALUE,ERR)
    !DLLEXPORT(TEST_FRAMEWORK_ASSERT_EQUALS_INTG)
  
    !Argument variables 
    INTEGER(INTG), INTENT(IN) :: EXPECTED_VALUE
    INTEGER(INTG), INTENT(IN) :: ACTUAL_VALUE
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string) :: ERROR
    !Local Variables
    
    enters("TEST_FRAMEWORK_ASSERT_EQUALS_INTG",err,error,*999)
    
    IF(expected_value/=actual_value) THEN
       CALL flagerror("Not equal",err,error,*999)
    ENDIF
          
    exits("TEST_FRAMEWORK_ASSERT_EQUALS_INTG")
    RETURN
999 errorsexits("TEST_FRAMEWORK_ASSERT_EQUALS_INTG",err,error)
    RETURN 
  END SUBROUTINE test_framework_assert_equals_intg
  
  !
  !================================================================================================================================
  !   
  
  SUBROUTINE test_framework_assert_equals_dp1(EXPECTED_VALUE,ACTUAL_VALUE,ERR)
    !DLLEXPORT(TEST_FRAMEWORK_ASSERT_EQUALS_DP1)
    !Argument variables 
    REAL(DP), INTENT(IN) :: EXPECTED_VALUE
    REAL(DP), INTENT(IN) :: ACTUAL_VALUE
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string) :: ERROR
    !Local Variables
    
    enters("TEST_FRAMEWORK_ASSERT_EQUALS_DP1",err,error,*999)
    
    CALL test_framework_assert_equals_dp2(expected_value,actual_value,zero_tolerance,err)
          
    exits("TEST_FRAMEWORK_ASSERT_EQUALS_DP1")
    RETURN
999 errorsexits("TEST_FRAMEWORK_ASSERT_EQUALS_DP1",err,error)
    RETURN 
  END SUBROUTINE test_framework_assert_equals_dp1
  
  !
  !================================================================================================================================
  !   
  
  SUBROUTINE test_framework_assert_equals_dp2(EXPECTED_VALUE,ACTUAL_VALUE,TOLERANCE,ERR)
    !DLLEXPORT(TEST_FRAMEWORK_ASSERT_EQUALS_DP2)
  
    !Argument variables 
    REAL(DP), INTENT(IN) :: EXPECTED_VALUE
    REAL(DP), INTENT(IN) :: ACTUAL_VALUE
    REAL(DP), INTENT(IN) :: TOLERANCE
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string) :: ERROR
    !Local Variables
    
    enters("TEST_FRAMEWORK_ASSERT_EQUALS_DP2",err,error,*999)
    
    IF(abs(expected_value-actual_value)>tolerance) THEN
       CALL flagerror("Not Equal",err,error,*999)
    ENDIF
          
    exits("TEST_FRAMEWORK_ASSERT_EQUALS_DP2")
    RETURN
999 errorsexits("TEST_FRAMEWORK_ASSERT_EQUALS_DP1",err,error)
    RETURN 
  END SUBROUTINE test_framework_assert_equals_dp2
  
  !
  !================================================================================================================================
  !   
  
  SUBROUTINE test_framework_assert_equals_dp(EXPECTED_VALUE,ACTUAL_VALUE,ERR)
    !DLLEXPORT(TEST_FRAMEWORK_ASSERT_EQUALS_DP)
    !Argument variables 
    REAL(DP), INTENT(IN) :: EXPECTED_VALUE(:)
    REAL(DP), INTENT(IN) :: ACTUAL_VALUE(:)
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string) :: ERROR
    !Local Variables
    INTEGER(INTG) :: i
    
    enters("TEST_FRAMEWORK_ASSERT_EQUALS_DP",err,error,*999)
    
    IF(SIZE(expected_value)==SIZE(actual_value)) THEN
      DO i=1,SIZE(expected_value)
        CALL test_framework_assert_equals(expected_value(i),actual_value(i),err)
      ENDDO !i
    ELSE
       CALL flagerror("Not Equal",err,error,*999)
    ENDIF
          
    exits("TEST_FRAMEWORK_ASSERT_EQUALS_DP")
    RETURN
999 errorsexits("TEST_FRAMEWORK_ASSERT_EQUALS_DP",err,error)
    RETURN 
  END SUBROUTINE test_framework_assert_equals_dp 
  
  !
  !================================================================================================================================
  !   
  
  SUBROUTINE test_framework_gradient_value_get(X_VALUES,Y_VALUES,GRADIENT_VALUE)
    !DLLEXPORT(TEST_FRAMEWORK_GRADIENT_VALUE_GET)
  
    !Argument variables 
    REAL(DP), INTENT(IN) :: X_VALUES(:)
    REAL(DP), INTENT(IN) :: Y_VALUES(:)
    REAL(DP), INTENT(OUT) :: GRADIENT_VALUE
    INTEGER(INTG) :: ERR
    TYPE(varying_string) :: ERROR
    !Local Variables
    INTEGER(INTG) :: i, interval_size
    
    enters("TEST_FRAMEWORK_GRADIENT_VALUE_GET",err,error,*999)

    IF(SIZE(x_values)==SIZE(y_values)) THEN
      gradient_value=0.0_dp
      interval_size=SIZE(x_values)-1
      DO i=1,SIZE(x_values)
        IF(i/=1) THEN
          gradient_value=gradient_value+(y_values(i)-y_values(i-1))/(x_values(i)-x_values(i-1))/interval_size
        ENDIF
      ENDDO !i
    ELSE
       CALL flagerror('Size of x and Size of y do not match',err,error,*999)     
    ENDIF

    exits("TEST_FRAMEWORK_GRADIENT_VALUE_GET")
    RETURN
999 errorsexits("TEST_FRAMEWORK_GRADIENT_VALUE_GET",err,error)
    RETURN 
  END SUBROUTINE test_framework_gradient_value_get 
 
END MODULE test_framework_routines