Source

aotus / utests / quadruple / aot_quadruple_test.f90

Full commit
program quadruple_test
  use flu_binding, only: flu_State

  use aotus_module, only: open_config_file, close_config, aot_get_val
  use aot_top_module, only: aoterr_Fatal, aoterr_NonExistent, aoterr_WrongType
  use aot_table_module, only: aot_table_open, aot_table_close

  implicit none

  integer, parameter :: quad_k = selected_real_kind(33)

  type(flu_State) :: conf
  integer :: iError
  real(kind=quad_k) :: glob_quad
  real(kind=quad_k) :: tab_quad
  integer :: thandle
  character(len=80) :: ErrString
  logical :: passed

  passed = .true.

  call create_script('quad_test_config.lua')
  write(*,*)
  write(*,*) 'Running aotus_test...'
  write(*,*) ' * open_config_file (aotus_test_config.lua)'
  call open_config_file(L = conf, filename = 'quad_test_config.lua', &
    &                   ErrCode = iError, ErrString = ErrString)
  if (iError /= 0) then
    write(*,*) ' : unexpected FATAL Error occured !!!'
    write(*,*) ' : Could not open the config file quad_test_config.lua:'
    write(*,*) trim(ErrString)
    STOP
  end if
  write(*,*) '  : success.'

  ! Testing for global INTEGER
  write(*,*) ' * reading a global quadruple'
  call aot_get_val(L = conf, key = 'real_test', &
    &              val = glob_quad, ErrCode = iError)

  if (btest(iError, aoterr_Fatal)) then
    write(*,*) '  : unexpected FATAL Error occured !!!'
    if (btest(iError, aoterr_NonExistent)) &
      &   write(*,*) '  : Variable not existent!'
    if (btest(iError, aoterr_WrongType)) &
      &   write(*,*) '  : Variable has wrong type!'
    passed = .false.
  else
    if ((glob_quad > 0.5_quad_k*(1.0_quad_k-epsilon(glob_quad))) &
      & .and. (glob_quad < 0.5_quad_k*(1.0_quad_k+epsilon(glob_quad)))) then
      write(*,*) '  : success.'
    else
      write(*,*) '  : unexpected ERROR, value mismatch, got: ', glob_quad
      write(*,*) '  :                             should be: ', 0.5
      passed = .false.
    end if
  end if

  ! Testing for global Table
  write(*,*) ' * opening a global table'
  call aot_table_open(L = conf, thandle = thandle, key = 'tab')
  if (thandle == 0) then
    write(*,*) '  : unexpected FATAL Error occured !!!'
    write(*,*) '  : could not open global table primes.'
    passed = .false.
  end if

  call aot_get_val(L = conf, thandle = thandle, &
    &              key = 'real_in_tab', &
    &              val = tab_quad, ErrCode = iError)
  if (btest(iError, aoterr_Fatal)) then
    write(*,*) '  : unexpected FATAL Error occured !!!'
    passed = .false.
    if (btest(iError, aoterr_NonExistent)) &
      &   write(*,*) '  : Variable not existent!'
    if (btest(iError, aoterr_WrongType)) &
      &   write(*,*) '  : Variable has wrong type!'
  else
    if ((tab_quad < 2.0_quad_k*(1._quad_k-epsilon(tab_quad))) &
      & .or. (tab_quad > 2.0_quad_k*(1._quad_k+epsilon(tab_quad)))) then
      write(*,*) '  : unexpected ERROR, value mismatch, got: ', tab_quad
      write(*,*) '  :                             should be: ', 2.0
      passed = .false.
      iError = 42
    end if
  end if
  if (iError == 0) write(*,*) '  : success.'

  write(*,*) ' * Closing table'
  call aot_table_close(L = conf, thandle = thandle)
  write(*,*) '  : success.'

  write(*,*) ' * close_conf'
  call close_config(conf)
  write(*,*) '  : success.'
  write(*,*) '... Done with aotus_test.'
  if (passed) then
    write(*,*) 'PASSED'
  else
    write(*,*) 'FAILED'
  end if

contains

  subroutine create_script(filename)
    character(len=*) :: filename

    open(file=trim(filename), unit=22, action='write', status='replace')
    write(22,*) '-- test script for aotus_test'
    write(22,*) 'int_test = 5'
    write(22,*) 'long_test = 5000000000'
    write(22,*) 'real_test = 0.5'
    write(22,*) 'tab = {real_in_tab = 2.0}'
    write(22,*) 'log_test = true'
    write(22,*) "string_test = 'last words'"
    close(22)
  end subroutine create_script

end program quadruple_test