Fox_sax_EQuUs.f90

Go to the documentation of this file.

!======================================================================
!     Wrapper module to read in the CMLComp XML file generated by the SIESTA package.
!     This file is part of the EQuUs package. (for details see: http://eqt.elte.hu/equus/home)
!     Copyright (C) 2016 Peter Rakyta, Ph.D.
!
!     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 3 of the License, 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, see http://www.gnu.org/licenses/.
!     
!======================================================================
#ifndef MAX_PROP_LENGTH
#define MAX_PROP_LENGTH 100
#endif



MODULE fox_sax_equus

  use equus_c
  use fox_sax
  use equus_xml

! Derived type holding the XML parser 
  type(xml_t), private :: xp
! The number of the retrived nodes
  integer :: numtargetnodes
! The array of the retrived XML target nodes
  TYPE(xmlnode), pointer :: targetnodes(:)
! The representation of the current XML target node in focus
  TYPE(xmlnode), pointer :: currenttargetnode
! The representation of the XML node in focus
  TYPE(xmlnode), pointer :: currentnode
! Logical value. True if a desired XML node is in focus
  logical, private :: targetnodeactive = .false.
! The level of the current node in the XML tree
  integer, private :: subnodelevel = 0
! The local names of the properties to be retrived from the XML
  character(len=MAX_PROP_LENGTH, kind=C_CHAR), pointer :: property_names(:)
 


!****************************************************************      
  CONTAINS
!****************************************************************




!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine convertsubnodes2eq_struct( subnodes, XMLsubnodes )

    TYPE(eqstruct), pointer :: subnodes
    TYPE(xmlnode), pointer :: XMLsubnodes(:)

    TYPE(eqstruct), pointer :: eq_struct => null()
    TYPE(eqelement), pointer :: eq_elements(:)
    integer nodenum, idx

#ifdef DEBUG
    print *, "Converting XML subnodes to eq_structs"
#endif

    nodenum = SIZE( xmlsubnodes, 1)


    allocate( eq_elements(nodenum) )
    do idx = 1, nodenum
      call convert2eq_struct( eq_struct, xmlsubnodes(idx) )        
#ifdef DEBUG
      print *, "localname of the current subnode: ", trim(xmlsubnodes(idx)%localname), " numfields: ", eq_struct%numfields
#endif

      call assocelement( eq_elements(idx), "subnode", eq_struct )

    end do

    allocate(subnodes)
    subnodes%fields = c_loc(eq_elements(1))
    subnodes%numfields = nodenum

#ifdef DEBUG
    print *, "Converting XML subnodes to eq_structs ------- finished"
#endif


  end subroutine convertsubnodes2eq_struct



!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine convert2eq_struct( eq_struct, node )

    TYPE(eqstruct), pointer :: eq_struct
    TYPE(xmlnode) :: node
    TYPE(eqelement), pointer :: eq_elements(:)
    TYPE(eqstruct), pointer :: subnodes => null()
    character(len=:), pointer :: value
    integer elementnum, idx

#ifdef DEBUG
    print *, "Converting XML node to eq_struct"
#endif   

    ! converting subnodes/value
    if ( hassubnodes(node) ) then
        call convertsubnodes2eq_struct( subnodes, node%subnodes )
    end if


    ! first eq_element stores the localname
    elementnum = 1

    if (ASSOCIATED(node%attrs)) then
      elementnum = elementnum + SIZE( node%attrs, 1 )
    end if

    if ((ASSOCIATED(node%subnodes)).or.(ASSOCIATED(node%value))) then
      elementnum = elementnum + 1
    end if


    if (elementnum.eq.0 ) then
      return
    end if

    allocate( eq_elements(elementnum) )
     

    ! converting the localname
    allocate( character(len=LEN(node%localname)) :: value )
    value = node%localname
    call assocelement( eq_elements(1), "localname", value )
    deallocate(value)


    ! converting atrributes
    if (ASSOCIATED(node%attrs)) then
      do idx = 1, SIZE( node%attrs, 1 )
        allocate( character(len=LEN(node%attrs(idx)%value)) :: value )
        value = node%attrs(idx)%value
        call assocelement( eq_elements(idx+1), node%attrs(idx)%name, value )
        deallocate(value)
      end do
    end if


    ! converting subnodes/value
    if ( hassubnodes(node) ) then
        call assocelement( eq_elements(elementnum), "subnodes", subnodes )

    else if (ASSOCIATED(node%value)) then
        allocate( character(len=LEN(node%value)) :: value )
        value = node%value
        call assocelement( eq_elements(elementnum), "value", value )
        deallocate(value)
    end if

#ifdef DEBUG
    print *, "allocate ", trim(node%localname)
#endif
    allocate( eq_struct )
    eq_struct%fields = c_loc(eq_elements(1))
    eq_struct%numfields = elementnum

#ifdef DEBUG
    print *, "Converting XML node to eq_struct ------ finished"
#endif

  end subroutine convert2eq_struct






!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine get_eq_structure( eq_struct, idx )

    TYPE(eqstruct) :: eq_struct
    TYPE(eqstruct), pointer :: peq_struct
    integer idx

    if ( idx.gt.numtargetnodes ) then
      print *, "maximal value for idx is: ", numtargetnodes
      return
    end if

    call convert2eq_struct( peq_struct, targetnodes(idx) )
    eq_struct = peq_struct

  end subroutine get_eq_structure


!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
! 
  subroutine read_xml( fname, fname_len, cproperty_names, numofProperties)


  integer*8 fname_len
  character(len=fname_len), intent(in) :: fname
  logical :: file_exist
  integer numofProperties
  TYPE(c_ptr) :: cproperty_names(numofProperties)
  character(len=MAX_PROP_LENGTH, kind=C_CHAR), pointer :: property_name

  TYPE(eqstruct) :: XML_node_tmp

  integer idx


  


! double check for the existence of the file 
  inquire(file=fname, exist=file_exist)
  if (.not.file_exist) then
    print *, 'File does not exist'
    stop
  endif

! Open the XML file
  call open_xml_file(xp, fname, iostat=iostat)
  if (iostat /= 0) then
    write(*,*) "Cannot open file."
    stop
  endif


  allocate( property_names(numofproperties))
  do idx = 1, numofproperties
    call c_f_pointer( cproperty_names(idx), property_name )
    property_names(idx) = property_name
  end do

#ifdef DEBUG
  print *, "Property names to be retrived:"
  do idx = 1, numofproperties
    print *, trim(property_names(idx))
  end do
#endif

  call parse(xp, startelement_handler=startelement_handler, &
                  endElement_handler = endElement_handler, &
                  error_handler=error_handler, &
                  fatalerror_handler = fatalerror_handler, &
                  characters_handler = characters_handler)

! Close the XML file
  call close_xml_t(xp)

! deallocating the property names
  deallocate( property_names )

#ifdef DEBUG
  print *, new_line('A'), new_line('A'), new_line('A')
  print *, "The retrived nodes:"
  do idx = 1, SIZE( targetnodes, 1)
    call printnodewithsubnodes( targetnodes(idx) )
    print *, new_line('A'), new_line('A')
  end do
#endif



  end subroutine read_xml



!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine deallocatetargetnodes()

  integer idx

  do idx = 1, SIZE( targetnodes, 1)
    call deallocatenode(targetnodes(idx))
  end do
  deallocate( targetnodes )

  end subroutine deallocatetargetnodes





!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine addtargetnode( node )
    TYPE(xmlnode), pointer :: node
    TYPE(xmlnode), pointer :: nodes_tmp(:)
    integer nodenum, idx

    if (.not.ASSOCIATED(targetnodes)) then
      allocate(targetnodes(1))
      call copynode(currenttargetnode, targetnodes(1))
      numtargetnodes = 1
      return
    end if


    nodenum = SIZE( targetnodes, 1 )
    allocate( nodes_tmp(nodenum) )

    do idx = 1, nodenum
      call copynode(targetnodes(idx), nodes_tmp(idx) )
    end do

    deallocate( targetnodes )
    allocate( targetnodes( nodenum+1 ) )
    do idx = 1, nodenum
      call copynode( nodes_tmp(idx), targetnodes(idx) )
    end do 
    deallocate( nodes_tmp )

    call copynode( node, targetnodes(nodenum+1) ) 

    numtargetnodes = numtargetnodes + 1

  end subroutine addtargetnode

!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  logical function checkname( chunk )
    character(len=*), intent(in) :: chunk
    integer idx

    do idx = 1, SIZE( property_names, 1)
      if ( chunk == property_names(idx) ) then
        checkname = .true.
        return
      end if
    end do

    checkname = .false.
    return
    
  end function checkname


!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine error_handler(msg)
    character(len=*), intent(in) :: msg
    print *,  "Error encountered and caught"
    print *,  msg
  end subroutine error_handler

!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine fatalerror_handler(msg)
    character(len=*), intent(in) :: msg
    print *,  "Fatal error encountered and caught"
    print *,  msg
  end subroutine fatalerror_handler


!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine characters_handler(chunk)
    character(len=*), intent(in) :: chunk

    character(len=len(chunk)+1), pointer :: value
    

    if (.not.targetnodeactive) then
      return
    endif

! XML node containing subnodes should not contain any value
    if (ASSOCIATED(currentnode%subnodes)) then
      currentnode%value => null()
      return
    end if

    allocate( character(len=len(chunk)+1) :: currentNode%value )
    currentnode%value = trim(chunk)
#ifdef DEBUG
    print *, "assigning value to the currentNode: ", trim(currentnode%value)
#endif   




    
  end subroutine characters_handler

!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine endelement_handler(URI, localname, name)
    character(len=*), intent(in)     :: URI
    character(len=*), intent(in)     :: localname
    character(len=*), intent(in)     :: name


    if ( targetnodeactive ) then
      ! the target node is going out of scope
      if ( subnodelevel.eq.currenttargetnode%subnodelevel ) then
#ifdef DEBUG
print *, "Deactivatig the current target node"
#endif
        targetnodeactive = .false.
        call addtargetnode( currenttargetnode )
        currenttargetnode => null()
        currentnode => null()
      end if

    else
        subnodelevel = subnodelevel -1 
        return
    end if



    if (ASSOCIATED(currentnode) ) then
      if (ASSOCIATED(currentnode%parentnode)) then
        call addsubnode( currentnode%parentnode, currentnode )
        currentnode => currentnode%parentnode
      end if
    end if

    subnodelevel = subnodelevel -1 

  end subroutine endelement_handler


!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine startelement_handler(URI, localname, name,attributes)
    character(len=*), intent(in)   :: URI  
    character(len=*), intent(in)   :: localname
    character(len=*), intent(in)   :: name 
    type(dictionary_t), intent(in) :: attributes


    type(xmlnode), pointer :: parentnode

    integer :: idx
    character(len=MAX_PROP_LENGTH), pointer :: XML_attr_value(:)

    TYPE( attrib ), pointer :: attrs(:)
    type(xmlnode), pointer :: subnode

! The number of XML attributes in a given node
    integer :: XML_attributes_num

    subnodelevel = subnodelevel + 1

    if ( .not.targetnodeactive ) then
      call createtargetnode( uri, localname, name,attributes )
      currentnode => currenttargetnode
      return
    end if


    ! create subnode in the current target node
#ifdef DEBUG
print *, "allocating subnode: ", localname
#endif

    allocate( subnode )
    xml_attributes_num = getlength(attributes)

    subnode%subnodelevel = subnodelevel
    subnode%localname = trim(localname)
    subnode%subnodes=> null() 
    subnode%value=> null() 
    allocate( subnode%attrs(xml_attributes_num) )

    do idx = 1, getlength(attributes)
      subnode%attrs(idx)%name = trim(getqname(attributes, idx))
      subnode%attrs(idx)%value = trim(getvalue(attributes, idx))
    enddo

    
    subnode%parentnode => currentnode
    currentnode => subnode

  end subroutine startelement_handler



!-------------------------------------------------------------------------------------------------
! DESCRIPTION:
  subroutine createtargetnode(URI, localname, name,attributes)
    character(len=*), intent(in)   :: URI  
    character(len=*), intent(in)   :: localname
    character(len=*), intent(in)   :: name 
    type(dictionary_t), intent(in) :: attributes

! The number of XML attributes in a given node
    integer :: XML_attributes_num

    integer :: idx
    character(len=MAX_PROP_LENGTH), pointer :: XML_attr_value(:)

    TYPE( attrib ), pointer :: attrs(:)
     
    ! retriving the attributes of a desired property
    if ( (localname.EQ."property").OR.                                     &
       (localname.EQ."propertyList") ) then
      do idx = 1, getlength(attributes)
        if ( (getqname(attributes, idx)=="dictRef").OR.                    &
           (getqname(attributes, idx)=="title")) then
          if (checkname( getvalue(attributes, idx) )) then 
            xml_attributes_num = getlength(attributes)
            targetnodeactive = .true.
          endif
        endif
      enddo

      if ( .not.targetnodeactive ) then
        return
      end if 
#ifdef DEBUG
print *, "Allocating target node"
#endif
      allocate(currenttargetnode)
      currenttargetnode%subnodelevel = subnodelevel
      currenttargetnode%localname = trim(localname)
      currenttargetnode%subnodes=> null()
      currenttargetnode%parentnode=> null()
      currenttargetnode%value=> null()
      allocate( currenttargetnode%attrs(xml_attributes_num) )

      do idx = 1, getlength(attributes)
        currenttargetnode%attrs(idx)%name = trim(getqname(attributes, idx))
        currenttargetnode%attrs(idx)%value = trim(getvalue(attributes, idx))
      enddo

      return
    end if


  end subroutine createtargetnode




end module