Commits

Manuel Hasert committed d5a4b71 Merge

quadruple merge

Comments (0)

Files changed (19)

source/aot_fun_module.f90

   ! Include quadruple precision interfaces if available
   use aot_quadruple_fun_module
 
+  ! Support for extended double precision
+  use aot_extdouble_fun_module
+
   implicit none
 
   private

source/aot_out_module.f90

   ! Include interfaces for quadruple precision if available.
   use aot_quadruple_out_module
 
+  ! Support for extended double precision.
+  use aot_extdouble_out_module
+
   implicit none
 
   public :: aot_out_type

source/aot_table_module.f90

   ! double precision.
   use aot_quadruple_table_module
 
+  ! Support for extended double precision.
+  use aot_extdouble_table_module
+
   implicit none
 
   private

source/aot_top_module.f90

   ! double precision.
   use aot_quadruple_top_module
 
+  ! Support for extended double precision.
+  use aot_extdouble_top_module
+
   implicit none
 
   private

source/aot_vector_module.f90

   ! double precision.
   use aot_quadruple_vector_module
 
+  ! Support for extended double precision.
+  use aot_extdouble_vector_module
+
   implicit none
 
   public :: aot_table_get_val, aot_get_val, aot_top_get_val

source/aotus_module.f90

   ! double precision.
   use aot_quadruple_module
 
+  ! Support for extdouble precision.
+  use aot_extdouble_module
+
   implicit none
 
   private

source/extdouble/aot_extdouble_fun_module.f90

+!> A module providing extdouble number input to Lua functions
+!!
+!! Note that Lua actually only handles double precision, and the numbers are
+!! converted accordingly. Thus this is merely a convenience interface, to allow
+!! the usage of the functions from this module with extdouble precision numbers.
+module aot_extdouble_fun_module
+  use flu_binding
+  use aot_kinds_module, only: double_k
+  use aot_extdouble_top_module, only: xdble_k
+  use aot_fun_declaration_module, only: aot_fun_type
+
+  implicit none
+
+  private
+
+  public :: aot_fun_put
+
+  !> Put an argument into the lua function.
+  !!
+  !! Arguments have to be in order, first put the first argument then the second
+  !! and so on.
+  !! Here we add support for extdouble precision numbers
+  interface aot_fun_put
+    module procedure aot_fun_put_extdouble
+  end interface aot_fun_put
+
+contains
+
+  !> Put an argument of type double into the list of arguments for the function.
+  subroutine aot_fun_put_extdouble(L, fun, arg)
+    type(flu_state) :: L !< Handle for the Lua script.
+
+    !> Handle of the function, this argument should be put into.
+    type(aot_fun_type) :: fun
+
+    !> Actual argument to hand over to the Lua function.
+    real(kind=xdble_k), intent(in) :: arg
+
+    real(kind=double_k) :: locarg
+
+    ! Only do something, if the function is actually properly defined.
+    if (fun%handle /= 0) then
+
+      locarg = real(arg, kind=double_k)
+
+      ! If the function was executed before this call, it has to be
+      ! reset.
+      if (fun%arg_count == -1) then
+        ! Set the top of the stack to the reference of the function.
+        ! Discarding anything above it.
+        call flu_settop(L, fun%handle)
+        ! Push a copy of the function itself on the stack again, before
+        ! adding arguments, to savely survive popping of the function
+        ! upon execution.
+        call flu_pushvalue(L, fun%handle)
+        ! Increase the argument count to 0 again (really start counting
+        ! arguments afterwards.
+        fun%arg_count = fun%arg_count+1
+      end if
+
+      call flu_pushNumber(L, locarg)
+      fun%arg_count = fun%arg_count+1
+    end if
+
+  end subroutine aot_fun_put_extdouble
+
+end module aot_extdouble_fun_module

source/extdouble/aot_extdouble_module.f90

+module aot_extdouble_module
+  use flu_binding
+  use aot_extdouble_top_module, only: xdble_k
+  use aot_top_module, only: aot_top_get_val, aot_err_handler, &
+    &                       aoterr_Fatal, aoterr_NonExistent, aoterr_WrongType
+
+  implicit none
+
+  private
+
+  public :: aot_get_val
+
+  interface aot_get_val
+    module procedure get_config_extdouble
+  end interface
+
+contains
+
+  subroutine get_config_extdouble(val, ErrCode, L, key, default)
+    type(flu_State) :: L !< Handle for the Lua script to get the value from.
+    character(len=*), intent(in) :: key !< Variable name to look for.
+
+    !> Value of the Variable in the script
+    real(kind=xdble_k), intent(out) :: val
+
+    !> ErrorCode to indicate what kind of problem might have occured.
+    integer, intent(out) :: ErrCode
+
+    !> Some default value that should be used, if the variable is not set in the
+    !! Lua script.
+    real(kind=xdble_k), optional, intent(in) :: default
+
+    call flu_getglobal(L, key)
+    call aot_top_get_val(val, ErrCode, L, default)
+
+  end subroutine get_config_extdouble
+
+end module aot_extdouble_module

source/extdouble/aot_extdouble_out_module.f90

+!> A module to produce Lua scripts with nested tables.
+!!
+!! This module eases the output of readable Lua scripts.
+!! It takes care of indentation with nested tables, and provides a concise
+!! interface to output Fortran data into Lua tables.
+!! Therefore this module is somehow the counter-part to the reading functions,
+!! however it is almost completely independent and relies purely on Fortran
+!! output methods. Thus this module could stand alone, along with the
+!! aot_kinds_module without the Lua library.
+module aot_extdouble_out_module
+  use aot_out_general_module, only: aot_out_type, aot_out_open, aot_out_close, &
+    &                               aot_out_open_table, aot_out_close_table, &
+    &                               aot_out_breakline
+  use aot_extdouble_top_module, only: xdble_k
+
+  implicit none
+
+  public :: aot_out_val
+
+  !> Put Fortran intrinsic types into the script.
+  !!
+  !! Scalar values and one-dimensional arrays are supported.
+  !! Here we add support for extdouble precision.
+  !! NOTE however, that the used format will only be in double precision, as
+  !! Lua does not provide higher accuracy right now anyway.
+  interface aot_out_val
+    ! scalars
+    module procedure aot_out_val_extdouble
+
+    ! arrays
+    module procedure aot_out_val_arr_extdouble
+  end interface
+
+  private
+
+contains
+
+  !>  Put extdouble variables into the Lua script.
+  !!
+  !! The value is passed in with path, optionally you can assign a name to it
+  !! with the vname argument. If it should be put on the same line as the
+  !! previous entry, you have to set advance_previous=.false.
+  subroutine aot_out_val_extdouble(put_conf, val, vname, advance_previous)
+    !------------------------------------------------------------------------
+    type(aot_out_type), intent(inout)  :: put_conf
+    character(len=*), optional, intent(in) :: vname
+    logical, optional, intent(in) :: advance_previous
+    real(kind=xdble_k), intent(in) :: val
+    !------------------------------------------------------------------------
+    character(len=3) :: adv_string
+    !------------------------------------------------------------------------
+
+    if (put_conf%level > 0) then
+      ! Leave the advancing to the next entry in the table.
+      adv_string = 'no'
+    else
+      ! Not within a table, finalize the global definition with a newline.
+      adv_string = 'yes'
+    end if
+
+    call aot_out_breakline(put_conf, advance_previous)
+
+    if (present(vname)) then
+      write(put_conf%outunit, fmt="(a,EN24.15)", advance=adv_string) &
+        & trim(vname)//" = ", val
+    else
+      write(put_conf%outunit, fmt="(EN24.15)", advance=adv_string) val
+    end if
+
+  end subroutine aot_out_val_extdouble
+!******************************************************************************!
+
+
+!******************************************************************************!
+  !> This is a vectorized version of the value output.
+  !!
+  !! It takes a one-dimensional array and puts it into a table. The parameters
+  !! have the usual meanings, as in the scalar routines, however and additional
+  !! argument (max_per_line) allows the specification of the number of elements
+  !! that might be put onto a single line.
+  !! The first entry will be placed into the same line as the opening brace, and
+  !! the closing brace will be put on the same line, as the last entry.
+  subroutine aot_out_val_arr_extdouble(put_conf, val, vname, advance_previous, &
+    &                                   max_per_line)
+    !------------------------------------------------------------------------
+    !> Lua script to write the array into.
+    type(aot_out_type), intent(inout)  :: put_conf
+
+    !> Name for this array
+    character(len=*), optional, intent(in) :: vname
+
+    !> Actual data to write into the script
+    real(kind=xdble_k), intent(in) :: val(:)
+
+    !> Flag if this array should be put on the same line as the last entry of
+    !! the parent table.
+    logical, optional, intent(in) :: advance_previous
+
+    !> Maximal number of entries to put into a single line.
+    !! Defaults to 3.
+    integer, optional, intent(in) :: max_per_line
+    !------------------------------------------------------------------------
+    integer :: i
+    integer :: nVals
+    integer :: mpl
+    logical :: bline
+    !------------------------------------------------------------------------
+
+    if (present(max_per_line)) then
+      mpl = max_per_line
+    else
+      mpl = 3
+    end if
+
+    ! Opening the table(subtable for array actually)
+    call aot_out_open_table(put_conf, vname, &
+      &                     advance_previous = advance_previous)
+
+    nVals = size(val)
+    if (nVals > 0) then
+      ! Always put the first entry on the same line as the opening brace.
+      call aot_out_val(put_conf, val(1), advance_previous = .false.)
+
+      do i=2,nVals
+        ! Output each entry and break the line after mpl entries on a line.
+        bline = (mod(i-1, mpl) == 0)
+        call aot_out_val(put_conf, val(i), advance_previous = bline)
+      end do
+    end if
+
+    ! Always put the closing brace on the same line as the last entry.
+    call aot_out_close_table(put_conf, advance_previous = .false.)
+
+  end subroutine aot_out_val_arr_extdouble
+!******************************************************************************!
+
+end module aot_extdouble_out_module

source/extdouble/aot_extdouble_table_module.f90

+module aot_extdouble_table_module
+  use flu_binding
+  use aot_kinds_module, only: double_k
+  use aot_extdouble_top_module, only: xdble_k
+  use aot_top_module, only: aot_top_get_val
+  use aot_table_ops_module, only: aot_table_open, aot_table_close, &
+    &                             aot_table_length, aot_table_first, &
+    &                             aot_table_top, aot_table_push
+  implicit none
+
+  private
+
+  public :: aot_table_get_val, aot_table_set_val, aot_table_from_1Darray, &
+    &       aot_get_val
+
+  !> Get a value from a table.
+  !!
+  !! First the given key is looked up, if this fails, the value
+  !! at the given position is looked up, and if this also fails,
+  !! the default value is returned.
+  !! Positional addressing is only valid, as long,
+  !! as no value was provided by an explicit key
+  !! in the list before the entry in question.
+  interface aot_table_get_val
+    module procedure get_table_extdouble
+  end interface
+
+  !> Set a value in a table.
+  !!
+  !! The given value will be put at the entry named by key into the table
+  !! provided in thandle.
+  !! Alternatively you can also put the value by position into the table by
+  !! providing the pos argument.
+  !! If both, pos and key are provided, the key will be used.
+  !! Though, both of them are optional, at least one of them has to be provided.
+  interface aot_table_set_val
+    module procedure set_table_extdouble
+  end interface
+
+  !> Get a value from a table.
+  !!
+  !! First the given key is looked up, if this fails, the value
+  !! at the given position is looked up, and if this also fails,
+  !! the default value is returned.
+  !! Positional addressing is only valid, as long,
+  !! as no value was provided by an explicit key
+  !! in the list before the entry in question.
+  !!
+  !! The interface to access table values looks like:
+  !! `call aot_get_val(val, errCode, L, thandle, key, pos, default)`.
+  !! Position pos and key are both optional, but one of them has to be provided.
+  !! If both are provided the key takes precedence over the pos, and the pos
+  !! will only be tried if the access to the key fails.
+  !! See for example get_table_real() for a more detailed
+  !! description of the parameters.
+  !!
+  !! Note that positional addressing only works intuitively as long as there
+  !! have been no entries specified by keys in the table.
+  !! This kind of resembles the behavior of Fortran interfaces with named or
+  !! unnamed arguments, as soon as you provide a name, all following arguments
+  !! have to be given by key also.
+  !! Just stick to this rule for the Lua tables as well to avoid too much
+  !! headache.
+  !!
+  !! The reason for this is, that positional addressing in Lua refers only to
+  !! the unnamed entries of the tables.
+  interface aot_get_val
+    module procedure get_table_extdouble
+  end interface
+
+  !> This interface enables the simple creation of uniform one dimensional
+  !! arrays as tables in the Lua context.
+  !!
+  !! It takes an one dimensional array of values and returns a thandle to
+  !! identify the newly generated table.
+  interface aot_table_from_1Darray
+    module procedure create_1Darray_extdouble
+  end interface
+
+contains
+
+  !> Retrieve a extdouble precision real value from a table.
+  !!
+  !! NOTE that Lua actually only provides double precision numbers, and this
+  !! interface is merely a convenience for Fortran implementations with
+  !! extdouble precision real numbers.
+  subroutine get_table_extdouble(val, ErrCode, L, thandle, key, pos, &
+    &                            default)
+    type(flu_State) :: L !< Handle to the Lua script.
+
+    !> Handle to the table to look the value up in.
+    integer, intent(in) :: thandle
+
+    !> Value of the table entry if it exists.
+    real(kind=xdble_k), intent(out) :: val
+
+    !> Error code to indicate what kind of problem might have occured.
+    integer, intent(out) :: ErrCode
+
+    !> Name of the entry to look for.
+    !!
+    !! Key and pos are both optional, however at least one of them has to be
+    !! supplied.
+    !! The key takes precedence over the pos if both are given.
+    character(len=*), intent(in), optional :: key
+
+    !> Position of the entry to look for in the table.
+    !!
+    !! It allows the access to unnamed arrays in the Lua tables.
+    integer, intent(in), optional :: pos
+
+    !> Some default value, that should be used, if the variable is not set in
+    !! the Lua script.
+    real(kind=xdble_k), intent(in), optional :: default
+
+    call aot_table_push(L=L, thandle=thandle, &
+      &                   key=key, pos=pos)
+    call aot_top_get_val(val, ErrCode, L, default)
+
+  end subroutine get_table_extdouble
+
+
+  !> Put a extdouble precision real value into a table.
+  subroutine set_table_extdouble(val, L, thandle, key, pos)
+    type(flu_State) :: L !< Handle to the Lua script.
+
+    !> Handle to the table to look the value up in.
+    integer, intent(in) :: thandle
+
+    !> Value of the table entry if it exists.
+    real(kind=xdble_k), intent(in) :: val
+
+    !> Name of the entry to look for.
+    !!
+    !! Key and pos are both optional, however at least one of them has to be
+    !! supplied.
+    !! The key takes precedence over the pos if both are given.
+    character(len=*), intent(in), optional :: key
+
+    !> Position of the entry to look for in the table.
+    !!
+    !! It allows the access to unnamed arrays in the Lua tables.
+    integer, intent(in), optional :: pos
+
+    real(kind=double_k) :: locval
+
+    locval = real(val, kind=double_k)
+
+    if (thandle > 0) then
+      if (present(key)) then
+        ! If there is a key, use that.
+        ! First put the value on the top of the stack
+        call flu_pushNumber(L, locval)
+        ! Now put it into the table
+        call flu_setField(L, thandle, trim(key))
+      else
+        ! No key given, try to put the value by position
+        if (present(pos)) then
+          ! First put the index, where to write the value into the table, on the
+          ! stack.
+          call flu_pushInteger(L, pos)
+          ! Now put the actual value on the top of the stack.
+          call flu_pushNumber(L, locval)
+          ! Get the two entries from the stack into the table.
+          call flu_setTable(L, thandle)
+        end if
+      end if
+    end if
+
+  end subroutine set_table_extdouble
+
+
+  !> This subroutine takes a one dimensional array, and puts it as a table
+  !! into the Lua context.
+  !!
+  !! The returned thandle provides the index to access this newly created
+  !! table.
+  subroutine create_1Darray_extdouble(L, thandle, val)
+    type(flu_State) :: L !< Handle to the Lua script.
+
+    !> Handle to access the newly created table.
+    integer, intent(out) :: thandle
+
+    !> Values to put into the new table.
+    real(kind=xdble_k), intent(in) :: val(:)
+
+    integer :: tab
+    integer :: nvals
+    integer :: i
+    real(kind=double_k), allocatable :: locval(:)
+
+    nVals = size(val)
+    allocate(locVal(nVals))
+    locVal = real(val, kind=double_k)
+    call flu_createtable(L, nVals, 0)
+    thandle = flu_gettop(L)
+    tab = thandle
+
+    do i=1,nVals
+      call flu_pushInteger(L, i)
+      call flu_pushNumber(L, locval(i))
+      call flu_settable(L, tab)
+    end do
+
+    deallocate(locval)
+
+  end subroutine create_1Darray_extdouble
+
+
+end module aot_extdouble_table_module

source/extdouble/aot_extdouble_top_module.f90

+module aot_extdouble_top_module
+  use flu_binding
+  use aot_err_module, only: aoterr_Fatal, aoterr_NonExistent, &
+    &                       aoterr_WrongType, aot_err_handler
+
+  implicit none
+
+  private
+
+  public :: aot_top_get_val
+
+  interface aot_top_get_val
+    module procedure aot_top_get_extdouble
+  end interface
+
+  integer, parameter, public :: xdble_k = selected_real_kind(18)
+
+contains
+
+  !> Interpret topmost entry on Lua stack as a extdouble precision real.
+  !!
+  !! NOTE that numbers provided by Lua are only double precision.
+  subroutine aot_top_get_extdouble(val, ErrCode, L, default)
+    type(flu_State) :: L !< Handle to the Lua script
+
+    !> Value of the Variable in the script
+    real(kind=xdble_k), intent(out) :: val
+
+    !> Error code to indicate what kind of problem might have occured.
+    integer, intent(out) :: ErrCode
+
+    !> Some default value, that should be used, if the variable is not set in
+    !! the Lua script.
+    real(kind=xdble_k), optional, intent(in) :: default
+
+    logical :: not_retrievable
+
+    ErrCode = 0
+    not_retrievable = .false.
+
+    if (flu_isNoneOrNil(L, -1)) then
+      ErrCode = ibSet(ErrCode, aoterr_NonExistent)
+      not_retrievable = .true.
+    else
+      if (flu_isNumber(L, -1)) then
+        val = real(flu_toDouble(L, -1), kind=xdble_k)
+      else
+        ErrCode = ibSet(ErrCode, aoterr_WrongType)
+        ErrCode = ibSet(ErrCode, aoterr_Fatal)
+        not_retrievable = .true.
+      end if
+    end if
+
+    if (not_retrievable) then
+      if (present(default)) then
+        val = default
+      else
+        ErrCode = ibSet(ErrCode, aoterr_Fatal)
+      end if
+    end if
+    call flu_pop(L)
+
+  end subroutine aot_top_get_extdouble
+
+
+end module aot_extdouble_top_module

source/extdouble/aot_extdouble_vector_module.f90

+!> This module provides some convenience functions to access complete vectors
+!! from a lua table at once.
+!!
+!! It provides two generic interfaces, one for vectors inside tables, and one
+!! for vectors defined as global variables (get_config_val).
+!! Vectors might be accessed with a variable length, to be defined by the
+!! Lua table and allocated in the get_ routines or with a fixed length.
+!! For the variable length vectors, a maximal length has to be provided
+!! up to which the vector might be allocated.
+!! Otherwise the interfaces correspond to the scalar retrieval operations.
+module aot_extdouble_vector_module
+  use flu_binding
+  use aot_extdouble_top_module, only: xdble_k
+  use aot_table_ops_module, only: aot_table_close, aot_table_top, &
+    &                             aot_table_length, aot_table_push, &
+    &                             aot_table_first
+  use aot_top_module, only: aot_top_get_val, aoterr_NonExistent, aoterr_Fatal
+
+  implicit none
+
+  public :: aot_table_get_val, aot_get_val, aot_top_get_val
+
+  !> Use these routines to obtain a vector whose length is unknown.
+  !!
+  !! Arrays will be allocated as needed to read the data from the
+  !! Lua script with these routines. A maximal length has to be
+  !! specified to limit the allocated memory by these routines (and make the
+  !! interfaces distinguishable).
+  interface aot_get_val
+    module procedure get_config_extdouble_vvect
+
+    module procedure get_table_extdouble_vvect
+  end interface
+
+  interface aot_table_get_val
+    module procedure get_table_extdouble_vvect
+  end interface
+
+  interface aot_top_get_val
+    module procedure get_top_extdouble_vvect
+  end interface
+
+
+  !> Use these routines to obtain a vector of known length.
+  !!
+  !! The given vector has to exist already and will be filled by
+  !! values from the Lua table, as far as they exist.
+  !! If the Lua table is longer than the available elements in the array
+  !! only the first elements from the table will be stored in the array.
+  interface aot_get_val
+    module procedure get_config_extdouble_v
+
+    module procedure get_table_extdouble_v
+  end interface
+
+  interface aot_table_get_val
+    module procedure get_table_extdouble_v
+  end interface
+
+  interface aot_top_get_val
+    module procedure get_top_extdouble_v
+  end interface
+
+
+  private
+
+
+contains
+
+  !> This routine obtains a vectorial quantity with variable length from a Lua
+  !! table as a whole.
+  !!
+  !! It is intented to ease the reading of vectors on the Fortran side by
+  !! capsulating the parsing of the Lua table internally.
+  !! For the dynamically sized array, which will be allocated, a upper limit
+  !! to allocate has to be specified.
+  subroutine get_table_extdouble_vvect(val, ErrCode, maxlength, L, thandle, &
+    &                                  key, pos, default)
+    type(flu_State) :: L !< Handle to the lua script
+    integer, intent(in) :: thandle !< Handle of the parent table
+
+    !> Vector read from the Lua table, will have the same length as the table
+    !! but not exceed maxlength, if provided.
+    real(kind=xdble_k), intent(out), allocatable :: val(:)
+
+    !> Error code describing problems encountered in each of the components.
+    !! Will be allocated with the same length as the returned vector.
+    !! If the complete vector is not given in the Lua script, and no default
+    !! is provided, an zerosized array will be returned.
+    integer, intent(out), allocatable :: ErrCode(:)
+
+    !> Maximal length to allocate for the vector.
+    integer, intent(in) :: maxlength
+
+    !> Name of the variable (vector) to read.
+    character(len=*), intent(in), optional :: key
+
+    !> Position of the (vector) to read.
+    integer, intent(in), optional :: pos
+
+    !> A default vector to use, if no proper definition is found.
+    !! Components will be filled with the help of this default definition.
+    real(kind=xdble_k), intent(in), optional :: default(:)
+
+    ! Get the requeseted value from the provided table
+    call aot_table_push(L=L, thandle=thandle, &
+      &                   key=key, pos=pos)
+
+    call aot_top_get_val(val, ErrCode, maxlength, L, default)
+
+  end subroutine get_table_extdouble_vvect
+
+
+  !> This routine obtains a vectorial quantity with variable length from a Lua
+  !! global variable as a whole.
+  !!
+  !! It is intented to ease the reading of vectors on the Fortran side by
+  !! capsulating the parsing of the Lua table internally.
+  !! For the dynamically sized array, which will be allocated, a upper limit
+  !! to allocate has to be specified.
+  subroutine get_config_extdouble_vvect(val, ErrCode, maxlength, L, &
+    &                                   key, default)
+    type(flu_State) :: L !< Handle to the lua script
+
+    !> Vector read from the Lua table, will have the same length as the table
+    !! but not exceed maxlength, if provided.
+    real(kind=xdble_k), intent(out), allocatable :: val(:)
+
+    !> Error code describing problems encountered in each of the components.
+    !! Will be allocated with the same length as the returned vector.
+    !! If the complete vector is not given in the Lua script, and no default
+    !! is provided, an zerosized array will be returned.
+    integer, intent(out), allocatable :: ErrCode(:)
+
+    !> Maximal length to allocate for the vector.
+    integer, intent(in) :: maxlength
+
+    !> Name of the variable (vector) to read.
+    character(len=*), intent(in) :: key
+
+    !> A default vector to use, if no proper definition is found.
+    !! Components will be filled with the help of this default definition.
+    real(kind=xdble_k), intent(in), optional :: default(:)
+
+    ! Get the requeseted global variable
+    call flu_getglobal(L, key)
+
+    call aot_top_get_val(val, ErrCode, maxlength, L, default)
+
+  end subroutine get_config_extdouble_vvect
+
+
+  !> This routine obtains a vectorial quantity with fixed length from a Lua
+  !! table as a whole.
+  !!
+  !! It is intented to ease the reading of vectors on the Fortran side by
+  !! capsulating the parsing of the Lua table internally.
+  !! Components which are not found are filled with the data given in
+  !! the default vector. For each component an error code will be returned
+  !! to indicate the success when reading it.
+  !! If the vector is not defined at all, all components will be indicated
+  !! as non-existent.
+  !! Components, which are neither defined in the Lua script, nor in the
+  !! default will be marked with the aoterr_Fatal flag.
+  subroutine get_table_extdouble_v(val, ErrCode, L, thandle, key, &
+    &                         pos, default)
+    type(flu_State) :: L !< Handle to the lua script
+    integer, intent(in) :: thandle !< Handle of the parent table
+
+    !> Vector read from the Lua table.
+    real(kind=xdble_k), intent(out) :: val(:)
+
+    !> Error code describing problems encountered in each of the components.
+    !! This array has to have the same length as val.
+    integer, intent(out) :: ErrCode(:)
+
+    !> Name of the variable (vector) to read.
+    character(len=*), intent(in), optional :: key
+
+    !> Position of the (vector) to read.
+    integer, intent(in), optional :: pos
+
+    !> A default vector to use, if no proper definition is found.
+    !! Components will be filled with the help of this default definition.
+    real(kind=xdble_k), intent(in), optional :: default(:)
+
+    ! Get the requeseted value from the provided table
+    call aot_table_push(L=L, thandle=thandle, &
+      &                 key=key, pos=pos)
+
+    call aot_top_get_val(val, ErrCode, L, default)
+  end subroutine get_table_extdouble_v
+
+
+  !> This routine obtains a vectorial quantity with fixed length from a Lua
+  !! global variable as a whole.
+  !!
+  !! It is intented to ease the reading of vectors on the Fortran side by
+  !! capsulating the parsing of the Lua table internally.
+  !! Components which are not found are filled with the data given in
+  !! the default vector. For each component an error code will be returned
+  !! to indicate the success when reading it.
+  !! If the vector is not defined at all, all components will be indicated
+  !! as non-existent.
+  !! Components, which are neither defined in the Lua script, nor in the
+  !! default will be marked with the aoterr_Fatal flag.
+  subroutine get_config_extdouble_v(val, ErrCode, L, key, default)
+    type(flu_State) :: L !< Handle to the lua script
+
+    !> Vector read from the Lua table.
+    real(kind=xdble_k), intent(out) :: val(:)
+
+    !> Error code describing problems encountered in each of the components.
+    !! This array has to have the same length as val.
+    integer, intent(out) :: ErrCode(:)
+
+    !> Name of the variable (vector) to read.
+    character(len=*), intent(in) :: key
+
+    !> A default vector to use, if no proper definition is found.
+    !! Components will be filled with the help of this default definition.
+    real(kind=xdble_k), intent(in), optional :: default(:)
+
+    ! Get the requeseted value from the provided table
+    call flu_getglobal(L, key)
+
+    call aot_top_get_val(val, ErrCode, L, default)
+  end subroutine get_config_extdouble_v
+
+
+  subroutine get_top_extdouble_vvect(val, ErrCode, maxlength, L, default)
+    type(flu_State) :: L !< Handle to the lua script
+
+    !> Vector read from the Lua table, will have the same length as the table
+    !! but not exceed maxlength, if provided.
+    real(kind=xdble_k), intent(out), allocatable :: val(:)
+
+    !> Error code describing problems encountered in each of the components.
+    !! Will be allocated with the same length as the returned vector.
+    !! If the complete vector is not given in the Lua script, and no default
+    !! is provided, an zerosized array will be returned.
+    integer, intent(out), allocatable :: ErrCode(:)
+
+    !> Maximal length to allocate for the vector.
+    integer, intent(in) :: maxlength
+
+    !> A default vector to use, if no proper definition is found.
+    !! Components will be filled with the help of this default definition.
+    real(kind=xdble_k), intent(in), optional :: default(:)
+
+    integer :: vect_handle
+    integer :: table_len, vect_len, def_len
+    integer :: vect_lb
+    integer :: iComp
+
+    ! Try to interpret the top entry on the stack as a table
+    vect_handle = aot_table_top(L=L)
+    table_len = aot_table_length(L=L, thandle=vect_handle)
+
+    ! The size of the vector is limited by maxlength.
+    vect_len = min(maxlength, table_len)
+
+    ! Find the length of the default value, if it is not provided, its 0.
+    def_len = 0
+    if (present(default)) def_len = size(default)
+
+    ! Now parse the table with the vector entries.
+    if (aot_table_first(L, vect_handle)) then
+      allocate(val(vect_len))
+      allocate(errCode(vect_len))
+
+      ! Only if the vector table actually exists, and has at least one entry,
+      ! this parsing has to be done.
+      if (present(default).and.(def_len > 0)) then
+        call aot_top_get_val(val(1), ErrCode(1), L, default(1))
+      else
+        call aot_top_get_val(val(1), ErrCode(1), L)
+      end if
+
+      ! Up to the length of the default value, provide the default settings.
+      do iComp=2,def_len
+        if (.not. flu_next(L, vect_handle)) exit
+        call aot_top_get_val(val(iComp), ErrCode(iComp), L, &
+          &                  default(iComp))
+      end do
+
+      vect_lb = max(2, def_len+1)
+      ! After def_len entries no default values for the components are
+      ! available anymore, proceed without a default setting for the rest.
+      do iComp=vect_lb,vect_len
+        if (.not. flu_next(L, vect_handle)) exit
+        call aot_top_get_val(val(iComp), ErrCode(iComp), L)
+      end do
+    else
+      ! No vector definition found in the Lua script, use the default.
+      if (present(default)) then
+        allocate(val(def_len))
+        allocate(errCode(vect_len))
+        val = default
+        ErrCode = ibSet(ErrCode, aoterr_NonExistent)
+      else
+        ! No vector definition in the Lua script and no default provided,
+        ! return an empty array.
+        allocate(val(0))
+        allocate(errCode(0))
+      end if
+    end if
+    call aot_table_close(L, vect_handle)
+
+  end subroutine get_top_extdouble_vvect
+
+
+  subroutine get_top_extdouble_v(val, ErrCode, L,  default)
+    type(flu_State) :: L !< Handle to the lua script
+
+    !> Vector read from the Lua table.
+    real(kind=xdble_k), intent(out) :: val(:)
+
+    !> Error code describing problems encountered in each of the components.
+    !! This array has to have the same length as val.
+    integer, intent(out) :: ErrCode(:)
+
+    !> A default vector to use, if no proper definition is found.
+    !! Components will be filled with the help of this default definition.
+    real(kind=xdble_k), intent(in), optional :: default(:)
+
+    integer :: vect_handle
+    integer :: table_len, vect_len, def_len
+    integer :: vect_lb
+    integer :: iComp
+
+    ! Try to interpret it as table.
+    vect_handle = aot_table_top(L=L)
+    table_len = aot_table_length(L=L, thandle=vect_handle)
+
+    vect_len = min(table_len, size(val))
+
+    ! Find the length of the default value, if it is not provided, its 0.
+    def_len = 0
+    if (present(default)) def_len = size(default)
+
+    ! Now parse the table with the vector entries.
+    if (aot_table_first(L, vect_handle).and.(vect_len > 0)) then
+
+      ! Only if the vector table actually exists, and has at least one entry,
+      ! this parsing has to be done.
+      if (present(default).and.(def_len > 0)) then
+        call aot_top_get_val(val(1), ErrCode(1), L, default(1))
+      else
+        call aot_top_get_val(val(1), ErrCode(1), L)
+      end if
+
+      ! Up to the length of the default value, provide the default settings.
+      do iComp=2,def_len
+        if (.not. flu_next(L, vect_handle)) exit
+        call aot_top_get_val(val(iComp), ErrCode(iComp), L, &
+          &                  default(iComp))
+      end do
+
+      vect_lb = max(2, def_len+1)
+      ! After def_len entries no default values for the components are
+      ! available anymore, proceed without a default setting for the rest.
+      do iComp=vect_lb,vect_len
+        if (.not. flu_next(L, vect_handle)) exit
+        call aot_top_get_val(val(iComp), ErrCode(iComp), L)
+      end do
+
+      ! If the table in the Lua script is not long enough, fill the remaining
+      ! components with the default components, as far as they are defined.
+      do iComp=vect_len+1,def_len
+        ErrCode(iComp) = ibSet(ErrCode(iComp), aoterr_NonExistent)
+        val(iComp) = default(iComp)
+      end do
+      vect_lb = max(vect_len+1, def_len)
+      do iComp=vect_lb,vect_len
+        ErrCode(iComp) = ibSet(ErrCode(iComp), aoterr_Fatal)
+      end do
+    else
+      ! No vector definition found in the Lua script, use the default.
+      ErrCode = ibSet(ErrCode, aoterr_NonExistent)
+      if (present(default)) then
+        val(:def_len) = default(:def_len)
+        if (def_len < vect_len) then
+          ErrCode(def_len+1:) = ibSet(ErrCode(def_len+1:), aoterr_Fatal)
+        end if
+      else
+        ! No vector definition in the Lua script and no default provided.
+        ErrCode = ibSet(ErrCode, aoterr_Fatal)
+      end if
+    end if
+    call aot_table_close(L, vect_handle)
+
+  end subroutine get_top_extdouble_v
+
+
+end module aot_extdouble_vector_module

source/extdouble/dummy_extdouble_fun_module.f90

+module aot_extdouble_fun_module
+
+  implicit none
+
+  private
+
+  integer, parameter :: xdble_k = selected_real_kind(18)
+
+end module aot_extdouble_fun_module

source/extdouble/dummy_extdouble_module.f90

+module aot_extdouble_module
+  implicit none
+
+  private
+
+  integer, parameter :: xdble_k = selected_real_kind(18)
+
+end module aot_extdouble_module

source/extdouble/dummy_extdouble_out_module.f90

+module aot_extdouble_out_module
+
+  implicit none
+
+  private
+
+  integer, parameter :: xdble_k = selected_real_kind(18)
+
+end module aot_extdouble_out_module

source/extdouble/dummy_extdouble_table_module.f90

+module aot_extdouble_table_module
+  implicit none
+
+  private
+
+end module aot_extdouble_table_module

source/extdouble/dummy_extdouble_top_module.f90

+module aot_extdouble_top_module
+
+  implicit none
+
+  private
+
+  integer, parameter :: xdble_k = selected_real_kind(18)
+
+end module aot_extdouble_top_module

source/extdouble/dummy_extdouble_vector_module.f90

+module aot_extdouble_vector_module
+
+  implicit none
+
+  private
+
+  integer, parameter :: xdble_k = selected_real_kind(18)
+
+end module aot_extdouble_vector_module
                   msg = 'Checking for Quadruple Precision',
                   mandatory=False, define_name='quadruple')
     conf.env['quad_support'] = conf.is_defined('quadruple')
+
+    conf.check_fc(fragment = '''
+       program checkxdble
+         implicit none
+         integer, parameter :: xdble_k = selected_real_kind(18)
+         real(kind=xdble_k) :: a_xdble_real
+       end program checkxdble''',
+                  msg = 'Checking for Extended Double Precision',
+                  mandatory=False, define_name='extdouble')
+    conf.env['xdble_support'] = conf.is_defined('extdouble')
     # Cleanup the DEFINES again
     conf.env.DEFINES = tmpDEF
 
         aotus_sources += ['source/quadruple/dummy_quadruple_out_module.f90']
         aotus_sources += ['source/quadruple/dummy_quadruple_vector_module.f90']
 
+    if bld.env['xdble_support']:
+        aotus_sources += ['source/extdouble/aot_extdouble_module.f90']
+        aotus_sources += ['source/extdouble/aot_extdouble_fun_module.f90']
+        aotus_sources += ['source/extdouble/aot_extdouble_table_module.f90']
+        aotus_sources += ['source/extdouble/aot_extdouble_top_module.f90']
+        aotus_sources += ['source/extdouble/aot_extdouble_out_module.f90']
+        aotus_sources += ['source/extdouble/aot_extdouble_vector_module.f90']
+    else:
+        aotus_sources += ['source/extdouble/dummy_extdouble_module.f90']
+        aotus_sources += ['source/extdouble/dummy_extdouble_fun_module.f90']
+        aotus_sources += ['source/extdouble/dummy_extdouble_table_module.f90']
+        aotus_sources += ['source/extdouble/dummy_extdouble_top_module.f90']
+        aotus_sources += ['source/extdouble/dummy_extdouble_out_module.f90']
+        aotus_sources += ['source/extdouble/dummy_extdouble_vector_module.f90']
+
     bld(
         features = 'c',
         source = core_sources + lib_sources,
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.