parser.F90

Go to the documentation of this file.

!! Copyright (C) 2003-2006 M. Marques, A. Castro, A. Rubio, G. Bertsch
!!
!! This program 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 2, or (at your option)
!! any later version.
!!
!! This program 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 this program; if not, write to the Free Software
!! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
!! 02110-1301, USA.
!!
 
#include "global.h"
 
module parser_oct_m
  use global_oct_m
  use loct_oct_m
  use mpi_oct_m
  use namespace_oct_m
  use unit_oct_m
  use varinfo_oct_m
 
  implicit none
 
  private
  public ::              &
    block_t,             &
    parser_init,         &
    parser_end,          &
    parse_init,          &
    parse_putsym,        &
    parse_end,           &
    parse_is_defined,    &
    parse_variable,      &
    parse_block,         &
    parse_block_end,     &
    parse_block_n,       &
    parse_block_cols,    &
    parse_block_integer, &
    parse_block_float,   &
    parse_block_cmplx,   &
    parse_block_string,  &
    parse_block_logical, &
    parse_expression,    &
    parse_array,         &
    parse_input_string,  &
    parser_initialize_symbol_table, &
    parse_get_full_name
 
  type :: block_t
    private
    integer, pointer :: p
  end type block_t
 
  character(len=27), parameter, public :: parser_varname_excluded_characters = '|!''"#$%&/\‍()=?{}+-*^.,;:<> '
 
  interface parse_init
    integer function oct_parse_init(file_out, mpiv_node)
      implicit none
      character(len=*), intent(in) :: file_out
      integer,          intent(in) :: mpiv_node
    end function oct_parse_init
  end interface parse_init
 
  interface parse_putsym
    subroutine oct_parse_putsym_int(sym, i)
      implicit none
      character(len=*), intent(in) :: sym
      integer,          intent(in) :: i
    end subroutine oct_parse_putsym_int
 
    subroutine oct_parse_putsym_double(sym, d)
      use, intrinsic :: iso_fortran_env
      implicit none
      character(len=*), intent(in) :: sym
      real(real64),         intent(in) :: d
    end subroutine oct_parse_putsym_double
  end interface parse_putsym
 
  interface parse_input_file
    integer function oct_parse_input(file_in, set_used)
      implicit none
      character(len=*), intent(in) :: file_in
      integer,          intent(in) :: set_used
    end function oct_parse_input
  end interface parse_input_file
 
  interface parse_input_string
    integer function oct_parse_input_string(file_contents, set_used)
      implicit none
      character(len=*), intent(in) :: file_contents
      integer,          intent(in) :: set_used
    end function oct_parse_input_string
  end interface parse_input_string
 
  interface parse_environment
    subroutine oct_parse_environment(prefix)
      implicit none
      character(len=*), intent(in) :: prefix
    end subroutine oct_parse_environment
  end interface parse_environment
 
  interface parse_end
    subroutine oct_parse_end()
      implicit none
    end subroutine oct_parse_end
  end interface parse_end
 
  interface sym_output_table
    subroutine oct_sym_output_table(only_unused, mpiv_node)
      implicit none
      integer, intent(in) :: only_unused
      integer, intent(in) :: mpiv_node
    end subroutine oct_sym_output_table
  end interface sym_output_table
 
  interface parse_isdef
    integer pure function oct_parse_isdef(name)
      implicit none
      character(len=*), intent(in) :: name
    end function oct_parse_isdef
  end interface parse_isdef
 
  interface
    subroutine oct_parse_int(name, def, res)
      use, intrinsic :: iso_fortran_env
      implicit none
      character(len=*), intent(in)  :: name
      integer(int64),      intent(in)  :: def
      integer(int64),      intent(out) :: res
    end subroutine oct_parse_int
 
    subroutine oct_parse_double(name, def, res)
      use, intrinsic :: iso_fortran_env
      implicit none
      character(len=*), intent(in)  :: name
      real(real64),         intent(in)  :: def
      real(real64),         intent(out) :: res
    end subroutine oct_parse_double
 
    subroutine oct_parse_complex(name, def, res)
      use, intrinsic :: iso_fortran_env
      implicit none
      character(len=*), intent(in)  :: name
      complex(real64),      intent(in)  :: def
      complex(real64),      intent(out) :: res
    end subroutine oct_parse_complex
 
    subroutine oct_parse_string(name, def, res)
      implicit none
      character(len=*), intent(in)  :: name, def
      character(len=*), intent(out) :: res
    end subroutine oct_parse_string
 
    integer function oct_parse_block(name, blk)
      import block_t
      implicit none
      character(len=*), intent(in)  :: name
      type(block_t),    intent(out) :: blk
    end function oct_parse_block
  end interface
 
  interface parse_variable
    module procedure parse_integer
    module procedure parse_integer8
    module procedure parse_integer48
    module procedure parse_integer84
    module procedure parse_logical
    module procedure parse_string
    module procedure parse_cmplx
    module procedure oct_parse_double_unit
  end interface parse_variable
 
  interface parse_block_end
    subroutine oct_parse_block_end(blk)
      import block_t
      implicit none
      type(block_t), intent(inout) :: blk
    end subroutine oct_parse_block_end
  end interface parse_block_end
 
  interface parse_block_n
    integer function oct_parse_block_n(blk)
      import block_t
      implicit none
      type(block_t), intent(in) :: blk
    end function oct_parse_block_n
  end interface parse_block_n
 
  interface parse_block_cols
    integer function oct_parse_block_cols(blk, line)
      import block_t
      implicit none
      type(block_t), intent(in) :: blk
      integer,       intent(in) :: line
    end function oct_parse_block_cols
  end interface parse_block_cols
 
  interface parse_block_integer
    subroutine oct_parse_block_int(blk, l, c, res)
      import block_t
      implicit none
      type(block_t), intent(in)  :: blk
      integer,       intent(in)  :: l, c
      integer,       intent(out) :: res
    end subroutine oct_parse_block_int
 
    subroutine oct_parse_block_int8(blk, l, c, res)
      use, intrinsic :: iso_fortran_env
      import block_t
      implicit none
      type(block_t), intent(in)    :: blk
      integer, intent(in)          :: l, c
      integer(int64), intent(out)      :: res
    end subroutine oct_parse_block_int8
  end interface parse_block_integer
 
  interface parse_block_float
    subroutine oct_parse_block_double(blk, l, c, res)
      use, intrinsic :: iso_fortran_env
      import block_t
      implicit none
      type(block_t), intent(in)  :: blk
      integer,       intent(in)  :: l, c
      real(real64),      intent(out) :: res
    end subroutine oct_parse_block_double
 
    module procedure oct_parse_block_double_unit
  end interface parse_block_float
 
  interface parse_block_cmplx
    subroutine oct_parse_block_complex(blk, l, c, res)
      use, intrinsic :: iso_fortran_env
      import block_t
      implicit none
      type(block_t), intent(in)  :: blk
      integer,       intent(in)  :: l, c
      complex(real64),   intent(out) :: res
    end subroutine oct_parse_block_complex
  end interface parse_block_cmplx
 
  interface parse_block_string
    subroutine oct_parse_block_string(blk, l, c, res)
      import block_t
      implicit none
      type(block_t),    intent(in)  :: blk
      integer,          intent(in)  :: l, c
      character(len=*), intent(out) :: res
    end subroutine oct_parse_block_string
  end interface parse_block_string
 
  ! ---------------------------------------------------------
  ! ---------------------------------------------------------
 
  interface
    subroutine oct_parse_expression(re, im, ndim, x, r, t, pot)
      use, intrinsic :: iso_fortran_env
      implicit none
      real(real64),         intent(in)  :: x, r, t
      integer,          intent(in)  :: ndim
      real(real64),         intent(out) :: re, im
      character(len=*), intent(in)  :: pot
    end subroutine oct_parse_expression
  end interface
 
  interface parse_expression
    subroutine oct_parse_expression1(re, im, c, x, string)
      use, intrinsic :: iso_fortran_env
      implicit none
      real(real64),         intent(out) :: re, im
      character(len=*), intent(in)  :: c
      real(real64),         intent(in)  :: x
      character(len=*), intent(in)  :: string
    end subroutine oct_parse_expression1
 
    module procedure oct_parse_expression_vec
  end interface
 
contains
 
  subroutine parser_initialize_symbol_table(log_file)
    character(len=*), optional, intent(in) :: log_file
 
    integer :: ierr
    logical :: file_exists
    character(len=:), allocatable :: log_file_
 
    if (present(log_file)) then
      log_file_ = trim(log_file)
    else
      log_file_ = 'exec/parser.log'
    end if
 
    inquire(file=trim(conf%share)//'/variables', exist=file_exists)
    if (.not. file_exists) then
      write(stderr,'(a)') '*** Fatal Error (description follows)'
      write(stderr,'(a)') 'Error initializing parser'
      write(stderr,'(a)') 'Cannot open variables file: '//trim(conf%share)//'/variables'
      call parse_fatal()
    end if
 
    ! If using default log file, make the directory
    if (.not. present(log_file)) then
      if (mpi_world%is_root()) call loct_mkdir('exec')
    endif
 
    ! Initialize the symbol table, and the log file
    ! Note, it would make sense to expose `sym_init_table` as its own call
    ierr = parse_init(log_file_, mpi_world%rank)
    if (ierr /= 0) then
      write(stderr,'(a)') '*** Fatal Error (description follows)'
      write(stderr,'(a)') 'Error initializing parser: cannot write to ' // log_file_
      write(stderr,'(a)') 'Do you have write permissions in this directory?'
      call parse_fatal()
    end if
 
    ! Parse option definitions, and use them to populate the symbol table keys
    ierr = parse_input_file(trim(conf%share)//'/variables', set_used = 1)
    if (ierr /= 0) then
      write(stderr,'(a)') '*** Fatal Error (description follows)'
      write(stderr,'(a)') 'Error initializing parser'
      write(stderr,'(a)') 'Cannot open variables file: '//trim(conf%share)//'/variables'
      call parse_fatal()
    end if
 
  end subroutine parser_initialize_symbol_table
 
 
  subroutine parser_init()
 
    integer :: ierr
    logical :: file_exists
 
    call parser_initialize_symbol_table()
 
    inquire(file='inp', exist=file_exists)
    if (.not. file_exists) then
      write(stderr,'(a)') '*** Fatal Error (description follows)'
      write(stderr,'(a)') 'Error initializing parser'
      write(stderr,'(a)') 'Cannot open input file!'
      write(stderr,'(a)') 'Please provide an input file with name inp in the current workdir'
      call parse_fatal()
    end if
 
    ierr = parse_input_file('inp', set_used = 0)
    if (ierr /= 0) then
      write(stderr,'(a)') '*** Fatal Error (description follows)'
      write(stderr,'(a)') 'Error initializing parser'
      write(stderr,'(a)') 'Cannot open input file!'
      write(stderr,'(a)') 'Please provide an input file with name inp in the current workdir'
      call parse_fatal()
    end if
 
    ! parse OCT_ prefixed variables from environment
    call parse_environment("OCT_")
 
  end subroutine parser_init
 
  subroutine parser_end()
    integer :: parser_log
 
    ! Output the symbol table
    call sym_output_table(only_unused = 1, mpiv_node = mpi_world%rank)
    ! Free the symbol table and close global C file handle.
    call parse_end()
 
    ! Write the octopus version and git_commit hash to the parser.log.
    ! This is done after parse_end(), to avoid conflicting with the existing open file handle
    if(mpi_world%is_root()) then
      open(newunit=parser_log, file='exec/parser.log', status='old', action='write', position='append')
      write(parser_log, '(a)') '# Octopus version: '//trim(conf%version)
      write(parser_log, '(a)') '# Octopus git_commit: '//trim(conf%git_commit)
      close(parser_log)
    end if
 
  end subroutine parser_end
 
  ! ---------------------------------------------------------
 
  logical function parse_is_defined(namespace, name) result(isdef)
    type(namespace_t), intent(in) :: namespace
    character(len=*),  intent(in) :: name
 
    isdef = parse_isdef(parse_get_full_name(namespace, name)) /= 0
 
  end function parse_is_defined
 
  ! ---------------------------------------------------------
 
  subroutine parse_integer(namespace, name, def, res)
    type(namespace_t), intent(in)    :: namespace
    character(len=*),  intent(in)    :: name
    integer,           intent(in)    :: def
    integer,           intent(out)   :: res
 
    integer(int64) :: res8
 
    call parse_check_varinfo(name)
    call oct_parse_int(parse_get_full_name(namespace, name), int(def, int64), res8)
 
    res = int(res8)
 
  end subroutine parse_integer
 
  ! ---------------------------------------------------------
 
  subroutine parse_integer8(namespace, name, def, res)
    type(namespace_t), intent(in)    :: namespace
    character(len=*),  intent(in)    :: name
    integer(int64),       intent(in)    :: def
    integer(int64),       intent(out)   :: res
 
    call parse_check_varinfo(name)
    call oct_parse_int(parse_get_full_name(namespace, name), def, res)
 
  end subroutine parse_integer8
 
  ! ---------------------------------------------------------
 
  subroutine parse_integer48(namespace, name, def, res)
    type(namespace_t), intent(in)    :: namespace
    character(len=*),  intent(in)    :: name
    integer,           intent(in)    :: def
    integer(int64),       intent(out)   :: res
 
    call parse_check_varinfo(name)
    call oct_parse_int(parse_get_full_name(namespace, name), int(def, int64), res)
 
  end subroutine parse_integer48
 
  ! ---------------------------------------------------------
 
  subroutine parse_integer84(namespace, name, def, res)
    type(namespace_t), intent(in)    :: namespace
    character(len=*),  intent(in)    :: name
    integer(int64),       intent(in)    :: def
    integer,           intent(out)   :: res
 
    integer(int64) :: res8
 
    call parse_check_varinfo(name)
    call oct_parse_int(parse_get_full_name(namespace, name), def, res8)
 
    res = int(res8)
 
  end subroutine parse_integer84
 
  ! ---------------------------------------------------------
 
  subroutine parse_string(namespace, name, def, res)
    type(namespace_t), intent(in)    :: namespace
    character(len=*),  intent(in)    :: name
    character(len=*),  intent(in)    :: def
    character(len=*),  intent(out)   :: res
 
    call parse_check_varinfo(name)
    call oct_parse_string(parse_get_full_name(namespace, name), def, res)
 
  end subroutine parse_string
 
 
  subroutine parse_logical(namespace, name, def, res)
    type(namespace_t), intent(in)    :: namespace
    character(len=*),  intent(in)    :: name
    logical,           intent(in)    :: def
    logical,           intent(out)   :: res
 
    integer(int64) :: idef, ires
 
    call parse_check_varinfo(name)
 
    ! logical is a FORTRAN type, so we emulate the routine with integers
    idef = 0
    if (def) idef = 1
 
    call oct_parse_int(parse_get_full_name(namespace, name), idef, ires)
    res = (ires /= 0)
 
  end subroutine parse_logical
 
  ! ---------------------------------------------------------
 
  subroutine parse_cmplx(namespace, name, def, res)
    type(namespace_t), intent(in)    :: namespace
    character(len=*),  intent(in)    :: name
    complex(real64),        intent(in)    :: def
    complex(real64),        intent(out)   :: res
 
    call parse_check_varinfo(name)
    call oct_parse_complex(parse_get_full_name(namespace, name), def, res)
 
  end subroutine parse_cmplx
 
  ! ---------------------------------------------------------
 
  integer function parse_block(namespace, name, blk, check_varinfo_)
    type(namespace_t), intent(in)    :: namespace
    character(len=*),  intent(in)    :: name
    type(block_t),     intent(out)   :: blk
    logical, optional, intent(in)    :: check_varinfo_
 
    logical check_varinfo
 
    check_varinfo = .true.
    if (present(check_varinfo_)) check_varinfo = check_varinfo_
 
    if (check_varinfo) then
      call parse_check_varinfo(name)
    end if
    parse_block = oct_parse_block(parse_get_full_name(namespace, name), blk)
 
  end function parse_block
 
  ! ---------------------------------------------------------
 
  subroutine parse_block_logical(blk, l, c, res)
    type(block_t), intent(in)  :: blk
    integer,       intent(in)  :: l, c
    logical,       intent(out) :: res
 
    integer :: ires
 
    call oct_parse_block_int(blk, l, c, ires)
    res = (ires /= 0)
 
  end subroutine parse_block_logical
 
  ! ---------------------------------------------------------
 
  subroutine oct_parse_double_unit(namespace, name, def, res, unit)
    type(namespace_t),      intent(in)  :: namespace
    character(len=*),       intent(in)  :: name
    real(real64),                intent(in)  :: def
    real(real64),                intent(out) :: res
    type(unit_t), optional, intent(in)  :: unit
 
    call parse_check_varinfo(name)
 
    if (present(unit)) then
      call oct_parse_double(parse_get_full_name(namespace, name), units_from_atomic(unit, def), res)
      res = units_to_atomic(unit, res)
    else
      call oct_parse_double(parse_get_full_name(namespace, name), def, res)
    end if
 
  end subroutine oct_parse_double_unit
 
  ! ---------------------------------------------------------
 
  subroutine oct_parse_block_double_unit(blk, l, c, res, unit)
    type(block_t), intent(in)  :: blk
    integer,       intent(in)  :: l, c
    real(real64),       intent(out) :: res
    type(unit_t),  intent(in)  :: unit
 
    call oct_parse_block_double(blk, l, c, res)
    res = units_to_atomic(unit, res)
 
  end subroutine oct_parse_block_double_unit
 
  ! ---------------------------------------------------------
  subroutine oct_parse_expression_vec(re, im, ndim, x, r, t, pot)
    real(real64),          intent(out) :: re, im
    integer,          intent(in)  :: ndim
    real(real64),          intent(in)  :: x(:), r, t
    character(len=*), intent(in)  :: pot
 
    call oct_parse_expression(re, im, ndim, x(1), r, t, pot)
 
  end subroutine oct_parse_expression_vec
 
 
  ! ----------------------------------------------------------------------
  subroutine parse_array(inp_string, x, arraychar)
    character(len=*), intent(inout) :: inp_string
    real(real64),     intent(in)    :: x(:, :)
    character(len=1), intent(in)    :: arraychar
 
    integer              :: i, m, n_atom, coord, string_length
    character (LEN=100)  :: v_string
 
    string_length = len(inp_string)
    do i = 1, string_length - 1
      if (inp_string(i:i+1) == arraychar//"[") then
        m = 0
        if (inp_string(i+3:i+3) == ",") m = 1
        if (inp_string(i+4:i+4) == ",") m = 2
        if (m == 0) then
          write(stderr, '(a)') "*** Fatal Error (description follows)"
          write(stderr, '(a)') "Attempting to parse a string with array elements larger than 99"
          call parse_fatal()
        end if
        read(inp_string(i+2:i+1+m),*) n_atom
        read(inp_string(i+3+m:i+3+m),*) coord
        write(v_string,*) x(n_atom, coord)
        inp_string = inp_string(:i-1) // "(" // trim(v_string) // ")" // inp_string(i+5+m:)
      end if
    end do
 
  end subroutine parse_array
 
  ! ----------------------------------------------------------------------
 
  subroutine parse_check_varinfo(varname)
    character(len=*), intent(in) :: varname
 
    if (.not. varinfo_exists(varname)) then
      write(stderr,'(a)') "*** Fatal Internal Error (description follows)"
      write(stderr,'(a)') 'Attempting to parse undocumented variable '//trim(varname)//'.'
      call parse_fatal()
    end if
 
  end subroutine parse_check_varinfo
 
  ! ----------------------------------------------------------------------
  function parse_get_full_name(namespace, varname) result(name)
    type(namespace_t), target, intent(in)  :: namespace
    character(len=*),          intent(in)  :: varname
    character(len=:),          allocatable :: name
 
    logical :: found
    integer :: is
    type(namespace_t), pointer :: ancestor
    character(len=MAX_NAMESPACE_LEN) :: ancestor_name, tmp
 
    found = .false.
 
    ! Loop over all ancestors, starting from the right-most
    ancestor => namespace
    do while (associated(ancestor) .and. .not. found)
 
      ! Loop over all paths to this ancestor, starting from the most complete path
      ancestor_name = ancestor%get()
      is = -1
      do while (len_trim(ancestor_name) > 0 .and. is /= 0 .and. .not. found)
        ! Check if the current path is found in the input file
        name = trim(ancestor_name) // "." // trim(varname)
        found = parse_isdef(trim(name)) /= 0
 
        ! Remove the left-most namespace ("is" will be zero if there is only one namespace left)
        is = index(ancestor_name, ".")
        tmp = ancestor_name(is+1:)
        ancestor_name = tmp
      end do
      ancestor => ancestor%parent
    end do
 
    ! If no suitable namespace found, just return the variable name
    if (.not. found) name = varname
 
  end function parse_get_full_name
 
  ! ----------------------------------------------------------------------
  subroutine parse_fatal()
 
    call mpi_world%abort()
 
  end subroutine parse_fatal
 
end module parser_oct_m
 
!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End: