aot_out_general_module.f90 Source File


Files dependent on this one

sourcefile~~aot_out_general_module.f90~~AfferentGraph sourcefile~aot_out_general_module.f90 aot_out_general_module.f90 sourcefile~aot_out_module.f90 aot_out_module.f90 sourcefile~aot_out_module.f90->sourcefile~aot_out_general_module.f90 sourcefile~aot_quadruple_out_module.f90 aot_quadruple_out_module.f90 sourcefile~aot_out_module.f90->sourcefile~aot_quadruple_out_module.f90 sourcefile~aot_extdouble_out_module.f90 aot_extdouble_out_module.f90 sourcefile~aot_out_module.f90->sourcefile~aot_extdouble_out_module.f90 sourcefile~aot_quadruple_out_module.f90->sourcefile~aot_out_general_module.f90 sourcefile~aot_extdouble_out_module.f90->sourcefile~aot_out_general_module.f90

Contents


Source Code

! Copyright (c) 2012-2016, 2019 Harald Klimach <harald@klimachs.de>
! Copyright (c) 2016 Kannan Masilamani <kannan.masilamani@uni-siegen.de>
!
! Parts of this file were written by Harald Klimach for
! German Research School of Simulation Sciences and University of Siegen.
! Parts of this file were written by Kannan Masilamani for University of Siegen.
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
! IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
! DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
! OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE
! OR OTHER DEALINGS IN THE SOFTWARE.
! **************************************************************************** !

!> Collection of general operations required for the output of Lua scripts.
module aot_out_general_module

  implicit none

  private

  public :: aot_out_type
  public :: aot_out_open
  public :: aot_out_close
  public :: aot_out_open_table
  public :: aot_out_close_table
  public :: aot_out_breakline
  public :: aot_out_toChunk

  !> This type provides the internal representation of the opened Lua script.
  !!
  !! It is used to keep track of the state in the script internally.
  type aot_out_type
    integer :: outunit !! Unit to write to
    integer :: indent !! Indentation level (number of spaces)
    integer :: stack(100) !! Number of entries on each level
    integer :: level !! Current nesting level in tables
    logical :: externalOpen !! Flag if file opened outside the aot_out scope
    integer :: in_step !! Number of spaces for each indentation level
  end type


contains


! **************************************************************************** !
  !> Open the file to write to and return a handle (put_conf) to it.
  !!
  !! This will overwrite the given file, if it already exists.
  !! Either filename of outUnit has to be specified, use outUnit to write to a
  !! pre-connected file.
  !! If both are given, the file will be opened and connected to a new unit,
  !! outUnit is ignored in this case.
  subroutine aot_out_open(put_conf, filename, outUnit, indentation, outstat)
    !------------------------------------------------------------------------
    type(aot_out_type), intent(out) :: put_conf !! Handle for the file
    character(len=*), optional, intent(in) :: filename !! File to open
    integer, optional, intent(in) :: outUnit !! Pre-connected unit to write to
    integer, optional, intent(in) :: indentation !! Spacer per indentation level

    !> IO status of the open operation for the given filename or an indication
    !! whether the given outUnit is actually connected to an open file.
    !!
    !! This returns 0 if the the returned unit has properly been properly
    !! connected to the file.
    integer, optional, intent(out) :: outstat
    !------------------------------------------------------------------------
    integer :: iError
    logical :: isOpen
    !------------------------------------------------------------------------

    if (present(indentation)) then
      put_conf%in_step = indentation
    else
      put_conf%in_step = 4
    end if

    if (present(filename)) then
      put_conf%outunit = newunit()
      open(unit = put_conf%outunit, file = trim(filename), action = 'write', &
        &  status='replace', recl = 360, iostat=iError)
      put_conf%externalOpen = .false.
    else if (present(outUnit)) then
      inquire(unit=outUnit, opened=isOpen)
      if (isOpen) then
        iError = 0
      else
        iError = -10
      end if
      put_conf%externalOpen = .true.
      put_conf%outunit = outUnit
    end if

    if (present(outstat)) outstat = iError

    put_conf%indent = 0
    put_conf%stack(:) = 0
    put_conf%level = 0

  end subroutine aot_out_open
! **************************************************************************** !


! **************************************************************************** !
  !>  Close the opened script again.
  !!
  !! This will close the file, if the data was not written to a pre-connected
  !! unit (that is the file for the script was opened in the aot_out_open).
  subroutine aot_out_close(put_conf)
    !------------------------------------------------------------------------
    type(aot_out_type), intent(inout)  :: put_conf
    !------------------------------------------------------------------------
    if ( .not. put_conf%externalOpen ) close( put_conf%outunit )
  end subroutine aot_out_close
! **************************************************************************** !


! **************************************************************************** !
  !> Start a new table to write to.
  !!
  !! You can give the table a name with the tname argument.
  !! If the table definition should NOT start on a new line, you have to pass
  !! in an advance_previous = .false.
  subroutine aot_out_open_table(put_conf, tname, advance_previous)
    !------------------------------------------------------------------------
    type(aot_out_type), intent(inout)  :: put_conf
    character(len=*), optional, intent(in) :: tname
    logical, optional, intent(in) :: advance_previous
    !------------------------------------------------------------------------

    call aot_out_breakline(put_conf, advance_previous)

    if (present(tname)) then
      write(put_conf%outunit, fmt='(a)', advance='no') trim(tname)//' = {'
    else
      write(put_conf%outunit, fmt='(a)', advance='no') '{'
    end if

    put_conf%level = put_conf%level + 1
    put_conf%indent = put_conf%indent + put_conf%in_step

  end subroutine aot_out_open_table
! **************************************************************************** !


! **************************************************************************** !
  !>  Close the current table.
  !!
  !! The table on the current table is closed with a curly bracket.
  !! If this bracket should be put to the same line as the last entry of the
  !! table, you have to set advance_previous = .false.
  subroutine aot_out_close_table(put_conf, advance_previous)
    !------------------------------------------------------------------------
    type(aot_out_type), intent(inout)  :: put_conf
    logical, optional, intent(in) :: advance_previous
    !------------------------------------------------------------------------
    logical :: loc_adv_prev
    character(len=max(put_conf%indent-put_conf%in_step,0)) :: indent
    character(len=3) :: adv_string
    !------------------------------------------------------------------------

    indent = ''
    adv_string = 'yes'

    if (present(advance_previous)) then
      loc_adv_prev = advance_previous
    else
      loc_adv_prev = .true.
    end if

    put_conf%indent = max(put_conf%indent - put_conf%in_step, 0)
    put_conf%stack(put_conf%level) = 0
    put_conf%level = max(put_conf%level - 1, 0)

    if (put_conf%level > 0) then
      ! Do not advance, to let the next entry append the separator to the line.
      adv_string = 'no'
    end if

    ! Close last entry without separator.
    if (loc_adv_prev) then
      ! Closing brace should be on new line.
      write(put_conf%outunit,*) ''
      write(put_conf%outunit, fmt="(a)", advance=adv_string) indent//'}'
    else
      ! Closing brace on same line as last entry.
      write(put_conf%outunit, fmt="(a)", advance=adv_string) ' }'
    end if

  end subroutine aot_out_close_table
! **************************************************************************** !




! **************************************************************************** !
  !> This subroutine takes care of the proper linebreaking in Lua-Tables.
  !!
  !! It takes care of a proper line-continuation, depending on the optional
  !! advance_previous flag and increases the count of elements in the current
  !! table.
  !! The default is to put each entry on a new line, if it should be on the
  !! same line advance_previous = .false. has to be set.
  subroutine aot_out_breakline(put_conf, advance_previous)
    type(aot_out_type), intent(inout)  :: put_conf
    logical, optional, intent(in) :: advance_previous

    character(len=put_conf%indent) :: indent
    character :: sep
    logical :: loc_adv_prev

    indent = ''
    if (present(advance_previous)) then
      loc_adv_prev = advance_previous
    else
      loc_adv_prev = .true.
    end if

    lev_if: if (put_conf%level > 0) then

      if (put_conf%stack(put_conf%level) > 0) then
        ! Use the separator to close the previous entry.
        sep = ','
      else
        ! First entry, nothing to separate yet.
        sep = ''
      end if

      if (loc_adv_prev) then
        write(put_conf%outunit, fmt='(a)') trim(sep)
        write(put_conf%outunit, fmt='(a)', advance='no') indent
      else
        write(put_conf%outunit, fmt='(a)', advance='no') trim(sep)//" "
      end if

      put_conf%stack(put_conf%level) = put_conf%stack(put_conf%level) + 1

    else if (put_conf%level .eq. 0)then
      write(put_conf%outunit, fmt='(a)', advance='no') " "
    end if lev_if

  end subroutine aot_out_breakline
! **************************************************************************** !


! **************************************************************************** !
  !> This subroutine converts information written in outunit to string
  subroutine aot_out_toChunk(out_conf, chunk, ErrCode, ErrString)
    type(aot_out_type), intent(in)  :: out_conf

    !> String with Lua code to load.
    character(len=*), intent(out) :: chunk

    !> Error code returned by Lua during loading or executing the file.
    !!
    !! This optional parameter might be used to react on errors in the calling
    !! side. If neither ErrCode nor ErrString are given, this subroutine will
    !! stop the program execution and print the error message
    integer, intent(out), optional :: ErrCode

    !> Error description
    !!
    !! This optional argument holds the error message in case something
    !! went wrong. It can be used to provide some feedback to the user in the
    !! calling routine. If neither ErrCode nor ErrString are provided,
    !! this subroutine will print the error message and stop program execution.
    character(len=*), intent(out), optional :: ErrString

    logical :: stop_on_error
    integer :: error
    integer :: chunk_len, chunk_left, read_len
    character(len=320) :: err_string
    logical :: unitOpened
    integer :: read_stat
    character(len=320) :: chunk_line

    stop_on_error = .not.(present(ErrString) .or. present(ErrCode))
    error = 0
    err_string = ''

    ! length of chunk
    chunk_len = len(chunk)

    inquire(unit=out_conf%outunit, opened=unitOpened)
    if (unitOpened) then
      chunk = ''
      chunk_left = chunk_len
      rewind(out_conf%outunit)
      do
        read(out_conf%outunit,'(a)', iostat=read_stat) chunk_line
        read_len = len(trim(chunk_line))
        if (read_stat /= 0) then
          if (read_stat > 0) then
            error = read_stat
            err_string = 'Error reading out conf unit'
          end if
          exit ! exit reading
        end if
        if (chunk_left >= read_len) then
          chunk_left = chunk_left - len(trim(chunk))
          chunk =  trim(chunk)//new_line('x')//trim(chunk_line)
        else
          error = 2
          err_string = 'Reached limit of output string length'
          exit
        end if
      end do
    else
      error = 1
      err_string = 'Output conf unit is not opened'
    end if

    if (present(ErrCode)) then
      ErrCode = error
    end if

    if (present(ErrString)) then
      ErrString = err_string
    end if

    if (error /= 0) then
      if (stop_on_error) then
        write(*,*) 'From aot_out_toChunk: '//trim(err_string)
        STOP
      end if
    end if
  end subroutine aot_out_toChunk
! **************************************************************************** !


! **************************************************************************** !
  !> Helper function to provide new unit, as long as F2008 newunit argument
  !! in open statement is not commonly available.
  !!
  !! To be used right in front of the open statement like this:
  !!  myUnit = newunit()
  !!  open(myUnit, ...)
  function newunit() result(nu)
    integer :: nu

    logical :: connected

    nu = 21
    inquire(unit=nu, opened=connected)
    do while(connected)
      nu = nu + 1
      inquire(unit=nu, opened=connected)
    end do
  end function newunit
! **************************************************************************** !


end module aot_out_general_module