text:
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!> @brief Module defines an object for representing an XML file.
!>
!> This module reads an XML file and stores the element information as
!> character information in a doubly-linked list/tree. Outside of the
!> initialization the only other functionality is for traversing the elements.
!> This type is basically used by the parameter list type to provide an
!> alternative way of initializing a parameter list.
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
MODULE FileType_XML
USE ISO_FORTRAN_ENV
USE IntrType
USE Strings
USE IO_Strings
USE FileType_Base

IMPLICIT NONE
PRIVATE

PUBLIC :: XMLElementType
PUBLIC :: XMLFileType

!> Character constant for a single space
CHARACTER(LEN=1),PARAMETER :: SP=' '
!> Character constant for a carraige return
CHARACTER(LEN=1),PARAMETER :: CR=CHAR(13)
!> Character constant for a line feed
CHARACTER(LEN=1),PARAMETER :: LF=CHAR(10)
!> Character constant for a tab
CHARACTER(LEN=1),PARAMETER :: TB=CHAR(9)

!> Module local constant for indicating a bad tag
INTEGER(SIK) :: BAD_TAG=-1
!> Module local constant for indicating the start of a tag
INTEGER(SIK) :: START_TAG=1
!> Module local constant for indicating the end of a tag
INTEGER(SIK) :: END_TAG=2
!> Module local constant for indicating an empty tag
INTEGER(SIK) :: EMPTY_ELEMENT_TAG=3
!> Module local constant for indicating comment tag
INTEGER(SIK) :: COMMENT_TAG=4
!> Module local constant for indicating ??? tag
INTEGER(SIK) :: PROCESSING_INST_TAG=5
!> Module local constant for indicating a declaration tag
!> the declaration tag, is usually the first tag in the file.
INTEGER(SIK) :: DECLARATION_TAG=6

!> Derived type for an XML element
TYPE :: XMLElementType
  !> The number of attributes defined on the element
  INTEGER(SIK),PRIVATE :: nAttr=0
  !> The name of the element
  TYPE(StringType) :: name
  !> The content of the element (excluding attributes)
  TYPE(StringType) :: content
  !> The names of the attributes on this element
  TYPE(StringType),ALLOCATABLE,PRIVATE :: attr_names(:)
  !> The corresponding values of the attributes on this element
  TYPE(StringType),ALLOCATABLE,PRIVATE :: attr_values(:)
  !> The parent element of this XML element
  TYPE(XMLElementType),POINTER,PRIVATE :: parent => NULL()
  !> The child elements of this element
  TYPE(XMLElementType),POINTER,PRIVATE :: children(:) => NULL()
!
!List of type bound procedures
  CONTAINS
    !> @copybrief FileType_XML::init_XMLElementType
    !> @copydoc FileType_XML::init_XMLElementType
    PROCEDURE,PASS :: init => init_XMLElementType
    !> @copybrief FileType_XML::write_XMLElementType
    !> @copydoc FileType_XML::write_XMLElementType
    PROCEDURE,PASS :: fwrite => write_XMLElementType
    !> @copybrief FileType_XML::clear_XMLElementType
    !> @copydoc FileType_XML::clear_XMLElementType
    PROCEDURE,PASS :: clear => clear_XMLElementType
    !> @copybrief FileType_XML::isEmpty_XMLElementType
    !> @copydoc FileType_XML::isEmpty_XMLElementType
    PROCEDURE,PASS :: isEmpty => isEmpty_XMLElementType
    !> @copybrief FileType_XML::hasParent_XMLElementType
    !> @copydoc FileType_XML::hasParent_XMLElementType
    PROCEDURE,PASS :: hasParent => hasParent_XMLElementType
    !> @copybrief FileType_XML::getParent_XMLElementType
    !> @copydoc FileType_XML::getParent_XMLElementType
    PROCEDURE,PASS :: getParent => getParent_XMLElementType
    !> @copybrief FileType_XML::hasChildren_XMLElementType
    !> @copydoc FileType_XML::hasChildren_XMLElementType
    PROCEDURE,PASS :: hasChildren => hasChildren_XMLElementType
    !> @copybrief FileType_XML::getChildren_XMLElementType
    !> @copydoc FileType_XML::getChildren_XMLElementType
    PROCEDURE,PASS :: getChildren => getChildren_XMLElementType
    !> @copybrief FileType_XML::getAttributes_XMLElementType
    !> @copydoc FileType_XML::getAttributes_XMLElementType
    PROCEDURE,PASS :: getAttributes => getAttributes_XMLElementType
    !> @copybrief FileType_XML::getAttributeValue_XMLElementType
    !> @copydoc FileType_XML::getAttributeValue_XMLElementType
    PROCEDURE,PASS :: getAttributeValue => getAttributeValue_XMLElementType
    !> @copybrief FileType_XML::getContent_XMLElementType
    !> @copydoc FileType_XML::getContent_XMLElementType
    PROCEDURE,PASS :: getContent => getContent_XMLElementType
    !> @copybrief FileType_XML::setName_XMLElementType
    !> @copydoc FileType_XML::setName_XMLElementType
    PROCEDURE,PASS :: setName => setName_XMLElementType
    !> @copybrief FileType_XML::setChildren_XMLElementType
    !> @copydoc FileType_XML::setChildren_XMLElementType
    PROCEDURE,PASS :: setChildren => setChildren_XMLElementType
    !> @copybrief FileType_XML::setAttribute_XMLElementType
    !> @copydoc FileType_XML::setAttribute_XMLElementType
    PROCEDURE,PASS :: setAttribute => setAttribute_XMLElementType
ENDTYPE XMLElementType

!> The XML File type
TYPE,EXTENDS(BaseFileType) :: XMLFileType
  !> Logical indicating if file was initialized
  LOGICAL(SBK) :: isInit=.FALSE.
  !> The unit number assigned to the file
  INTEGER(SIK) :: unitNo=-1
  !> The XML version
  REAL(SRK) :: version=1.0_SRK
  !> The XML file encoding
  CHARACTER(LEN=32) :: encoding='UTF-8'
  !>
  TYPE(StringType) :: style_sheet
  !>
  LOGICAL(SBK) :: standalone=.FALSE.
  !> The root XML element of the file
  TYPE(XMLElementType),POINTER :: root => NULL()
!
!List of type bound procedures
  CONTAINS
    !> @copybrief FileType_XML::init_XMLFileType
    !> @copydoc FileType_XML::init_XMLFileType
    PROCEDURE,PASS :: init => init_XMLFileType
    !> @copybrief FileType_XML::clear_XMLFileType
    !> @copydoc FileType_XML::clear_XMLFileType
    PROCEDURE,PASS :: clear => clear_XMLFileType
    !> @copybrief FileType_XML::fopen_XMLFileType
    !> @copydoc FileType_XML::fopen_XMLFileType
    PROCEDURE,PASS :: fopen => fopen_XMLFileType
    !> @copybrief FileType_XML::fclose_XMLFileType
    !> @copydoc FileType_XML::fclose_XMLFileType
    PROCEDURE,PASS :: fclose => fclose_XMLFileType
    !> @copybrief FileType_XML::fdelete_XMLFileType
    !> @copydoc FileType_XML::fdelete_XMLFileType
    PROCEDURE,PASS :: fdelete => fdelete_XMLFileType
    !> @copybrief FileType_XML::importFromDisk_XMLFileType
    !> @copydoc FileType_XML::importFromDisk_XMLFileType
    PROCEDURE,PASS :: importFromDisk => importFromDisk_XMLFileType
    !> @copybrief FileType_XML::exportToDisk_XMLFileType
    !> @copydoc FileType_XML::exportToDisk_XMLFileType
    PROCEDURE,PASS :: exportToDisk => exportToDisk_XMLFileType
ENDTYPE XMLFileType

CHARACTER(LEN=*),PARAMETER :: modName='FILETYPE_XML'
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
!> @brief Initializes an XML element object
!> @param thisXMLE the XML element object
!> @param cachedFile a cached XML file in the form of a character array
!> @param itag the positions of all the tags in the element
!> @param lines the positions of the line endings in the file
!> @param tagBegin the index of the starting tag for the element
!> @param tagEnd the index of the end tag for the element
!>
RECURSIVE SUBROUTINE init_XMLElementType(thisXMLE,cachedFile,itag,lines,tagBegin,tagEnd)
  CLASS(XMLElementType),TARGET,INTENT(INOUT) :: thisXMLE
  CHARACTER(LEN=1),INTENT(IN) :: cachedFile(:)
  INTEGER(SIK),INTENT(IN) :: itag(:,:)
  INTEGER(SIK),INTENT(IN) :: lines(:)
  INTEGER(SIK),INTENT(IN) :: tagBegin
  INTEGER(SIK),INTENT(IN) :: tagEnd

  INTEGER(SIK) :: nChildren,ichild,ierr
  INTEGER(SIK),ALLOCATABLE :: childTags(:,:)
  TYPE(StringType) :: startTagName,endTagName,tmpStr

  IF(iTag(3,tagBegin) == EMPTY_ELEMENT_TAG) THEN
!
!Empty Element
    IF(tagEnd == tagBegin) THEN
      !Get the element Name
      CALL getTagName(cachedFile(iTag(1,tagBegin):iTag(2,tagBegin)),ierr,thisXMLE%name)

      !Process the attributes
      CALL charArrytoStr(cachedFile(iTag(1,tagBegin):iTag(2,tagBegin)), tmpStr)
      CALL processTagAttributes(CHAR(tmpStr),thisXMLE%nAttr, &
          thisXMLE%attr_names,thisXMLE%attr_values,ierr)
      IF(ierr /= 0) THEN
        !Oh No!
      ENDIF
    ELSE
      !Bad input!
    ENDIF
  ELSEIF(iTag(3,tagBegin) == START_TAG) THEN
!
!Start/End Tagged Element
    IF(tagEnd > tagBegin) THEN
      IF(iTag(3,tagEnd) == END_TAG) THEN
        !Verify matching element names
        CALL getTagName(cachedFile(iTag(1,tagBegin):iTag(2,tagBegin)),ierr,startTagName)
        CALL getTagName(cachedFile(iTag(1,tagEnd):iTag(2,tagEnd)), &
            ierr,endTagName)
        IF(startTagName == endTagName .AND. ierr == 0) THEN
          !Store the name
          thisXMLE%name=startTagName

          !Process attributes
          CALL charArrytoStr(cachedFile(iTag(1,tagBegin):iTag(2,tagBegin)),tmpStr)
          CALL processTagAttributes(CHAR(tmpStr),thisXMLE%nAttr, &
              thisXMLE%attr_names,thisXMLE%attr_values,ierr)
          IF(ierr /= 0) THEN
            !Failed to process the attributes
          ENDIF

          !Determine the number of children
          CALL DetermineNChildren(tagBegin,tagEnd,iTag,nChildren, &
              childTags,ierr)
          IF(nChildren > 0) THEN
            !Process the children if any
            ALLOCATE(thisXMLE%children(nChildren))
            DO iChild=1,nChildren
              !Find the tag begin and end for the child
              CALL thisXMLE%children(ichild)%init(cachedFile,iTag,lines, &
                  childTags(1,iChild),childTags(2,iChild))
              SELECTTYPE(xmle => thisXMLE)
              TYPE IS(XMLElementType); thisXMLE%children(ichild)%parent => xmle
              ENDSELECT
            ENDDO
          ELSE
            !Store Content
            CALL charArrytoStr(cachedFile(iTag(2,tagBegin)+1:iTag(1,tagEnd)-1),thisXMLE%content)
            thisXMLE%content=TRIM(thisXMLE%content)
          ENDIF
        ELSE
          !Mismatched tags!
        ENDIF
      ELSE
        !Not matched with an end tag!
      ENDIF
    ELSE
      !Bad input!
    ENDIF
  ELSE
    !Cannot process tag!
  ENDIF
ENDSUBROUTINE init_XMLElementType
!
!-------------------------------------------------------------------------------
!> @brief Writes an XML element object to a file
!> @param thisXMLE the XML element object
!> @param unitNo the Fortran unit number of the file
!> @param nindent the amount of indentation to use when writing the element
!>
RECURSIVE SUBROUTINE write_XMLElementType(thisXMLE,unitNo,nindent)
  CLASS(XMLElementType),INTENT(IN) :: thisXMLE
  INTEGER(SIK),INTENT(IN) :: unitNo
  INTEGER(SIK),INTENT(IN),OPTIONAL :: nindent
  CHARACTER(LEN=16) :: sint
  INTEGER(SIK) :: i,ierr,nspace
  TYPE(StringType) :: fmt,tmpTag

  IF(LEN_TRIM(thisXMLE%name) > 0) THEN
    nspace=0
    IF(PRESENT(nindent)) nspace=2*nindent
    IF(ASSOCIATED(thisXMLE%children)) THEN
      !start tag
      tmpTag='<'//thisXMLE%name
      !Add attributes
      DO i=1,thisXMLE%nAttr
        tmpTag=tmpTag//' '//thisXMLE%attr_names(i)//'="'// &
            thisXMLE%attr_values(i)//'"'
      ENDDO
      tmpTag=tmpTag//'>'
      IF(nspace > 0) THEN
        WRITE(sint,'(i16)',IOSTAT=ierr) nspace
        fmt='('//TRIM(ADJUSTL(sint))//'x'
        WRITE(sint,'(i16)',IOSTAT=ierr) LEN_TRIM(tmpTag)
        fmt=fmt//',a'//TRIM(ADJUSTL(sint))//')'
      ELSE
        WRITE(sint,'(i16)',IOSTAT=ierr) LEN_TRIM(tmpTag)
        fmt='(a'//TRIM(ADJUSTL(sint))//')'
      ENDIF
      WRITE(unitNo,FMT=CHAR(fmt),IOSTAT=ierr) CHAR(tmpTag)

      !children
      DO i=1,SIZE(thisXMLE%children)
        CALL thisXMLE%children(i)%fwrite(unitNo,nspace/2+1)
      ENDDO

      !end tag
      tmpTag='</'//thisXMLE%name//'>'
      IF(nspace > 0) THEN
        WRITE(sint,'(i16)',IOSTAT=ierr) nspace
        fmt='('//TRIM(ADJUSTL(sint))//'x'
        WRITE(sint,'(i16)',IOSTAT=ierr) LEN_TRIM(tmpTag)
        fmt=fmt//',a'//TRIM(ADJUSTL(sint))//')'
      ELSE
        WRITE(sint,'(i16)',IOSTAT=ierr) LEN_TRIM(tmpTag)
        fmt='(a'//TRIM(ADJUSTL(sint))//')'
      ENDIF
      WRITE(unitNo,FMT=CHAR(fmt),IOSTAT=ierr) CHAR(tmpTag)
    ELSEIF(LEN(thisXMLE%content) > 0) THEN
      !start tag
      tmpTag='<'//thisXMLE%name
      !Add attributes
      DO i=1,thisXMLE%nAttr
        tmpTag=tmpTag//' '//thisXMLE%attr_names(i)//'="'// &
            thisXMLE%attr_values(i)//'"'
      ENDDO
      tmpTag=tmpTag//'>'
      IF(nspace > 0) THEN
        WRITE(sint,'(i16)',IOSTAT=ierr) nspace
        fmt='('//TRIM(ADJUSTL(sint))//'x'
        WRITE(sint,'(i16)',IOSTAT=ierr) LEN_TRIM(tmpTag)
        fmt=fmt//',a'//TRIM(ADJUSTL(sint))//')'
      ELSE
        WRITE(sint,'(i16)',IOSTAT=ierr) LEN_TRIM(tmpTag)
        fmt='(a'//TRIM(ADJUSTL(sint))//')'
      ENDIF
      WRITE(unitNo,FMT=CHAR(fmt),IOSTAT=ierr) CHAR(tmpTag)

      !content
      WRITE(sint,'(i16)',IOSTAT=ierr) nspace+2
      fmt='('//TRIM(ADJUSTL(sint))//'x'
      WRITE(sint,'(i16)',IOSTAT=ierr) LEN_TRIM(thisXMLE%content)
      fmt=fmt//',a'//TRIM(ADJUSTL(sint))//')'
      IF(thisXMLE%content /= LF) &
          WRITE(unitNo,FMT=CHAR(fmt),IOSTAT=ierr) CHAR(thisXMLE%content)

      !endtag
      tmpTag='</'//thisXMLE%name//'>'
      IF(nspace > 0) THEN
        WRITE(sint,'(i16)',IOSTAT=ierr) nspace
        fmt='('//TRIM(ADJUSTL(sint))//'x'
        WRITE(sint,'(i16)',IOSTAT=ierr) LEN_TRIM(tmpTag)
        fmt=fmt//',a'//TRIM(ADJUSTL(sint))//')'
      ELSE
        WRITE(sint,'(i16)',IOSTAT=ierr) LEN_TRIM(tmpTag)
        fmt='(a'//TRIM(ADJUSTL(sint))//')'
      ENDIF
      WRITE(unitNo,FMT=CHAR(fmt),IOSTAT=ierr) CHAR(tmpTag)
    ELSE
      !empty element tag
      tmpTag='<'//thisXMLE%name
      !Add attributes
      DO i=1,thisXMLE%nAttr
        tmpTag=tmpTag//' '//thisXMLE%attr_names(i)//'="'// &
            thisXMLE%attr_values(i)//'"'
      ENDDO
      tmpTag=tmpTag//'/>'
      IF(nspace > 0) THEN
        WRITE(sint,'(i16)',IOSTAT=ierr) nspace
        fmt='('//TRIM(ADJUSTL(sint))//'x'
        WRITE(sint,'(i16)',IOSTAT=ierr) LEN_TRIM(tmpTag)
        fmt=fmt//',a'//TRIM(ADJUSTL(sint))//')'
      ELSE
        WRITE(sint,'(i16)',IOSTAT=ierr) LEN_TRIM(tmpTag)
        fmt='(a'//TRIM(ADJUSTL(sint))//')'
      ENDIF
      WRITE(unitNo,FMT=CHAR(fmt),IOSTAT=ierr) CHAR(tmpTag)
    ENDIF
    fmt=''
    tmpTag=''
  ENDIF
ENDSUBROUTINE write_XMLElementType
!
!-------------------------------------------------------------------------------
!> @brief Clears an XML element object and all subobjects.
!> @param thisXMLE the XML element object
!>
RECURSIVE SUBROUTINE clear_XMLElementType(thisXMLE)
  CLASS(XMLElementType),INTENT(INOUT) :: thisXMLE
  INTEGER(SIK) :: i

  IF(ASSOCIATED(thisXMLE%children)) THEN
    DO i=SIZE(thisXMLE%children),1,-1
      CALL clear_XMLElementType(thisXMLE%children(i))
    ENDDO
    DEALLOCATE(thisXMLE%children)
  ENDIF
  NULLIFY(thisXMLE%parent)
  IF(thisXMLE%nAttr > 0) THEN
    DO i=thisXMLE%nAttr,1,-1
      thisXMLE%attr_names(i)=''
      thisXMLE%attr_values(i)=''
    ENDDO
    IF(ALLOCATED(thisXMLE%attr_names)) DEALLOCATE(thisXMLE%attr_names)
    IF(ALLOCATED(thisXMLE%attr_values)) DEALLOCATE(thisXMLE%attr_values)
  ENDIF
  thisXMLE%content=''
  thisXMLE%name=''
  thisXMLE%nAttr=0
ENDSUBROUTINE clear_XMLElementType
!
!-------------------------------------------------------------------------------
!> @brief Determines if an XML element object is empty
!> @param thisXMLE the XML element object
!> @returns bool logical indicating if the XML element object is empty
!>
PURE FUNCTION isEmpty_XMLElementType(thisXMLE) RESULT(bool)
  CLASS(XMLElementType),INTENT(IN) :: thisXMLE
  LOGICAL(SBK) :: bool
  bool=(LEN_TRIM(thisXMLE%content) == 0 .AND. &
      .NOT.ASSOCIATED(thisXMLE%children))
ENDFUNCTION isEmpty_XMLElementType
!
!-------------------------------------------------------------------------------
!> @brief Determines if an XML element has a parent.
!> @param thisXMLE the XML element object
!> @returns bool logical indicating if the XML element object has a parent
!>
PURE FUNCTION hasParent_XMLElementType(thisXMLE) RESULT(bool)
  CLASS(XMLElementType),INTENT(IN) :: thisXMLE
  LOGICAL(SBK) :: bool
  bool=ASSOCIATED(thisXMLE%parent)
ENDFUNCTION hasParent_XMLElementType
!
!-------------------------------------------------------------------------------
!> @brief Gets a pointer to the XML element objects parent
!> @param thisXMLE the XML element object
!> @param parent the parent XML element object
!>
PURE SUBROUTINE getParent_XMLElementType(thisXMLE,parent)
  CLASS(XMLElementType),INTENT(INOUT) :: thisXMLE
  TYPE(XMLElementType),POINTER,INTENT(INOUT) :: parent
  NULLIFY(parent)
  parent => thisXMLE%parent
ENDSUBROUTINE getParent_XMLElementType
!
!-------------------------------------------------------------------------------
!> @brief Returns a logical of whether or not the XML element has child
!>        elements.
!> @param thisXMLE the XML element object
!> @returns bool logical indicating if the XML element has children
!>
PURE FUNCTION hasChildren_XMLElementType(thisXMLE) RESULT(bool)
  CLASS(XMLElementType),INTENT(IN) :: thisXMLE
  LOGICAL(SBK) :: bool
  bool=ASSOCIATED(thisXMLE%children)
ENDFUNCTION hasChildren_XMLElementType
!
!-------------------------------------------------------------------------------
!> @brief Gets a pointer to the children elements of an XML element
!> @param thisXMLE the XML element object
!> @param children a pointer to the XML elements children
!>
PURE SUBROUTINE getChildren_XMLElementType(thisXMLE,children)
  CLASS(XMLElementType),INTENT(INOUT) :: thisXMLE
  TYPE(XMLElementType),POINTER,INTENT(INOUT) :: children(:)
  NULLIFY(children)
  children => thisXMLE%children
ENDSUBROUTINE getChildren_XMLElementType
!
!-------------------------------------------------------------------------------
!> @brief Get a list of the attributes of an XML element
!> @param thisXMLE the XML element object
!> @param names the names of all the attributes
!> @param values the values of all the attributes
!>
PURE SUBROUTINE getAttributes_XMLElementType(thisXMLE,names,values)
  CLASS(XMLElementType),INTENT(INOUT) :: thisXMLE
  TYPE(StringType),ALLOCATABLE,INTENT(INOUT) :: names(:)
  TYPE(StringType),ALLOCATABLE,INTENT(INOUT) :: values(:)
  INTEGER(SIK) :: i

  IF(ALLOCATED(names)) DEALLOCATE(names)
  IF(ALLOCATED(values)) DEALLOCATE(values)
  ALLOCATE(names(thisXMLE%nAttr))
  ALLOCATE(values(thisXMLE%nAttr))
  DO i=1,thisXMLE%nAttr
    names(i)=thisXMLE%attr_names(i)
    values(i)=thisXMLE%attr_values(i)
  ENDDO
ENDSUBROUTINE getAttributes_XMLElementType
!
!-------------------------------------------------------------------------------
!> @brief Gets the value of an attribute of an XML element
!> @param thisXMLE the XML element
!> @param name the name of the attribute
!> @param val the value of the attribute with name
!>
PURE SUBROUTINE getAttributeValue_XMLElementType(thisXMLE,name,val)
  CLASS(XMLElementType),INTENT(INOUT) :: thisXMLE
  TYPE(StringType),INTENT(IN) :: name
  TYPE(StringType),INTENT(OUT) :: val
  INTEGER(SIK) :: i

  val=''
  DO i=1,thisXMLE%nAttr
    IF(name == thisXMLE%attr_names(i)) THEN
      val=thisXMLE%attr_values(i)
      EXIT
    ENDIF
  ENDDO
ENDSUBROUTINE getAttributeValue_XMLElementType
!
!-------------------------------------------------------------------------------
!> @brief Returns the content of an XML element as a string
!> @param thisXMLE the XML element
!> @returns content the content of an XML element
!>
PURE FUNCTION getContent_XMLElementType(thisXMLE) RESULT(content)
  CLASS(XMLElementType),INTENT(IN) :: thisXMLE
  TYPE(StringType) :: content
  content=thisXMLE%content
ENDFUNCTION getContent_XMLElementType
!
!-------------------------------------------------------------------------------
!> @brief sets the name of an XMLElementType
!> @param thisXMLE the XML element
!> @param the new name
!>
SUBROUTINE setName_XMLElementType(thisXMLE,name)
  CLASS(XMLElementType),INTENT(INOUT) :: thisXMLE
  TYPE(StringType),INTENT(IN) :: name
  thisXMLE%name=TRIM(name)
ENDSUBROUTINE setName_XMLElementType
!
!-------------------------------------------------------------------------------
!> @brief Sets the children of an XML element as input array of XMLElementTypes
!> @param thisXMLE the parent XML element
!> @param children the array of children element types
!>
SUBROUTINE setChildren_XMLElementType(thisXMLE,children)
  CLASS(XMLElementType),TARGET,INTENT(INOUT) :: thisXMLE
  TYPE(XMLElementType),POINTER,INTENT(INOUT) :: children(:)
  INTEGER(SIK) :: i,nChildren

  !if thisXMLE already has children, clear and deallocate them first
  IF(thisXMLE%hasChildren()) THEN
    DO i=SIZE(thisXMLE%children),1,-1
      CALL clear_XMLElementType(thisXMLE%children(i))
    ENDDO
    DEALLOCATE(thisXMLE%children)
  ENDIF

  IF(SIZE(children) > 0) THEN
    nChildren=SIZE(children)
    thisXMLE%children => children
    SELECTTYPE(thisXMLE); TYPE IS(XMLElementType)
      DO i=1,nChildren
        thisXMLE%children(i)%parent => thisXMLE
      ENDDO
    ENDSELECT
  ENDIF
ENDSUBROUTINE setChildren_XMLElementType
!
!-------------------------------------------------------------------------------
!> @brief sets or adds attribute to XMLElementType
!> @param thisXMLE the XML element
!> @param the attribute name
!> @param the value of the attribute(always a string for XML)
!>
SUBROUTINE setAttribute_XMLElementType(thisXMLE,name,value)
  CLASS(XMLElementType),INTENT(INOUT) :: thisXMLE
  TYPE(StringType),INTENT(IN) :: name,value

  INTEGER(SIK) :: i
  TYPE(StringType),ALLOCATABLE :: tmpNames(:),tmpVals(:)

  DO i=1,thisXMLE%nAttr
    IF(name == thisXMLE%attr_names(i)) THEN
      thisXMLE%attr_values(i)=value
      EXIT
    ENDIF
  ENDDO
  !If not currently an attribute add it
  IF(thisXMLE%nAttr > 0) THEN
    ALLOCATE(tmpNames(thisXMLE%nAttr))
    ALLOCATE(tmpVals(thisXMLE%nAttr))

    tmpNames=thisXMLE%attr_names
    tmpVals=thisXMLE%attr_values
    IF(ALLOCATED(thisXMLE%attr_names)) DEALLOCATE(thisXMLE%attr_names)
    IF(ALLOCATED(thisXMLE%attr_values)) DEALLOCATE(thisXMLE%attr_values)
    thisXMLE%nAttr=thisXMLE%nAttr+1
    ALLOCATE(thisXMLE%attr_names(thisXMLE%nAttr))
    ALLOCATE(thisXMLE%attr_values(thisXMLE%nAttr))
    DO i=1,thisXMLE%nAttr-1
      thisXMLE%attr_names(i)=tmpNames(i)
      thisXMLE%attr_values(i)=tmpVals(i)
    ENDDO

    thisXMLE%attr_names(thisXMLE%nAttr)=name
    thisXMLE%attr_values(thisXMLE%nAttr)=value

    DEALLOCATE(tmpNames)
    DEALLOCATE(tmpVals)
  ELSE
    IF(ALLOCATED(thisXMLE%attr_names)) DEALLOCATE(thisXMLE%attr_names)
    IF(ALLOCATED(thisXMLE%attr_values)) DEALLOCATE(thisXMLE%attr_values)
    thisXMLE%nAttr=thisXMLE%nAttr+1
    ALLOCATE(thisXMLE%attr_names(thisXMLE%nAttr))
    ALLOCATE(thisXMLE%attr_values(thisXMLE%nAttr))
    thisXMLE%attr_names=name
    thisXMLE%attr_values=value
  ENDIF
ENDSUBROUTINE setAttribute_XMLElementType
!
!-------------------------------------------------------------------------------
!> @brief Initializes an XML file type
!> @param thisXMLFile the XML file type object
!> @param fname the name of the file to process
!> @param lread whether or not the file will be opened for reading or writing
!>
SUBROUTINE init_XMLFileType(thisXMLFile,fname,lread)
  CHARACTER(LEN=*),PARAMETER :: myName='init_XMLFileType'
  CLASS(XMLFileType),INTENT(INOUT) :: thisXMLFile
  CHARACTER(LEN=*) :: fname
  LOGICAL(SBK) :: lread
  CHARACTER(LEN=LEN(fname)) :: fpath,fnm,fext

  IF(.NOT.thisXMLFile%isInit) THEN
    !Initialize the file
    CALL getFileParts(fname,fpath,fnm,fext,thisXMLFile%e)
    CALL thisXMLFile%setFilePath(fpath)
    CALL thisXMLFile%setFileName(fnm)
    CALL thisXMLFile%setFileExt(fext)
    CALL thisXMLFile%setReadStat(lread)
    CALL thisXMLFile%setWriteStat(.NOT.lread)

    ALLOCATE(thisXMLFile%root)
    thisXMLFile%isInit=.TRUE.
  ELSE
    CALL thisXMLFile%e%raiseError(modName//'::'//myName// &
        ' - File is already initialized!')
  ENDIF
ENDSUBROUTINE init_XMLFileType
!
!-------------------------------------------------------------------------------
!> @brief Clears the XML File object
!> @param thisXMLFile the XML file object
!>
SUBROUTINE clear_XMLFileType(thisXMLFile)
  CLASS(XMLFileType),INTENT(INOUT) :: thisXMLFile
  IF(ASSOCIATED(thisXMLFile%root)) THEN
    CALL thisXMLFile%root%clear()
    DEALLOCATE(thisXMLFile%root)
  ENDIF
  CALL thisXMLFile%setEOFStat(.FALSE.)
  CALL thisXMLFile%fclose()
  CALL thisXMLFile%setFilePath('')
  CALL thisXMLFile%setFileName('')
  CALL thisXMLFile%setFileExt('')
  CALL thisXMLFile%setReadStat(.FALSE.)
  CALL thisXMLFile%setWriteStat(.FALSE.)
  thisXMLFile%version=1.0
  thisXMLFile%encoding='UTF-8'
ENDSUBROUTINE clear_XMLFileType
!
!-------------------------------------------------------------------------------
!> @brief Opens the XML file type for I/O
!> @param file the XML file type object
!>
!> @todo fix how the unit number is set
!>
SUBROUTINE fopen_XMLFileType(file)
  CHARACTER(LEN=*),PARAMETER :: myName='fopen_XMLFileType'
  CLASS(XMLFileType),INTENT(INOUT) :: file
  LOGICAL(SBK) :: lopen
  INTEGER(SIK) :: funit,ierr
  TYPE(StringType) :: fname

  IF(.NOT.file%isOpen()) THEN
    !Find a valid unit number
    funit=700
    INQUIRE(UNIT=funit,OPENED=lopen)
    DO WHILE(lopen)
      funit=funit+1
      INQUIRE(UNIT=funit,OPENED=lopen)
    ENDDO

    file%unitNo=funit
    fname=TRIM(file%getFilePath())//TRIM(file%getFileName())// &
        TRIM(file%getFileExt())

    IF(file%isRead()) THEN
      !Open the file for reading
      OPEN(UNIT=file%unitNo,FILE=CHAR(fname),STATUS='OLD', &
          ACCESS='SEQUENTIAL',FORM='FORMATTED',ACTION='READ',IOSTAT=ierr)
    ELSE
      !Open the file for writing
      OPEN(UNIT=file%unitNo,FILE=CHAR(fname),STATUS='REPLACE', &
          ACCESS='SEQUENTIAL',FORM='FORMATTED',ACTION='WRITE', &
          ENCODING=file%encoding,IOSTAT=ierr)
    ENDIF
    IF(ierr == 0) THEN
      CALL file%setOpenStat(.TRUE.)
    ELSE
      CALL file%e%raiseError(modName//'::'//myName// &
          ' - Trouble opening file!')
      CALL file%setOpenStat(.FALSE.)
    ENDIF
  ELSE
    CALL file%e%raiseError(modName//'::'//myName// &
        ' - File is already open!')
  ENDIF
ENDSUBROUTINE fopen_XMLFileType
!
!-------------------------------------------------------------------------------
!> @brief Closes the XML file object
!> @param file teh XML file object
!>
SUBROUTINE fclose_XMLFileType(file)
  CHARACTER(LEN=*),PARAMETER :: myName='fclose_XMLFileType'
  CLASS(XMLFileType),INTENT(INOUT) :: file
  INTEGER(SIK) :: ierr
  IF(file%isOpen()) THEN
    CLOSE(file%unitNo,IOSTAT=ierr)
    IF(ierr == 0) THEN
      CALL file%setOpenStat(.FALSE.)
    ELSE
      CALL file%e%raiseError(modName//'::'//myName// &
          ' - trouble closing file!')
    ENDIF
  ENDIF
ENDSUBROUTINE fclose_XMLFileType
!
!-------------------------------------------------------------------------------
!> @brief Deletes the XML file from disk
!> @param file the XML file object
!>
SUBROUTINE fdelete_XMLFileType(file)
  CHARACTER(LEN=*),PARAMETER :: myName='fdelete_XMLFileType'
  CLASS(XMLFileType),INTENT(INOUT) :: file
  INTEGER(SIK) :: ierr
  IF(file%isOpen()) THEN
    CLOSE(file%unitNo,STATUS='DELETE',IOSTAT=ierr)
  ELSE
    CALL file%fopen()
    CLOSE(file%unitNo,STATUS='DELETE',IOSTAT=ierr)
  ENDIF
  IF(ierr == 0) THEN
    CALL file%setOpenStat(.FALSE.)
  ELSE
    CALL file%e%raiseError(modName//'::'//myName// &
        ' - trouble closing file!')
  ENDIF
ENDSUBROUTINE fdelete_XMLFileType
!
!-------------------------------------------------------------------------------
!> @brief Loads an XML file from disk into the XML File type object in memory
!> @param thisXMLFile the XML file to populate from disk
!> @param fname the name of the file to process
!>
SUBROUTINE importFromDisk_XMLFileType(thisXMLFile,fname)
  CHARACTER(LEN=*),PARAMETER :: myName='importFromDisk_XMLFileType'
  CLASS(XMLFileType),INTENT(INOUT) :: thisXMLFile
  CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: fname

  CHARACTER(LEN=1),ALLOCATABLE :: cachedFile(:)
  INTEGER(SIK) :: nchars,nopen,nclose,nTags,ic,i,nlines
  INTEGER(SIK) :: rootTagEnd,rootTagBegin
  INTEGER(SIK),ALLOCATABLE :: itag(:,:),lines(:)
  TYPE(StringType) :: tagStr

  !Initialize and open the file if needed
  IF(.NOT.thisXMLFile%isInit) THEN
    IF(PRESENT(fname)) CALL thisXMLFile%init(fname,.TRUE.)
  ENDIF
  IF(.NOT.thisXMLFile%isOpen()) CALL thisXMLFile%fopen()

  IF(thisXMLFile%isInit) THEN
    CALL thisXMLFile%root%clear()

    IF(thisXMLFile%isOpen() .AND. thisXMLFile%isRead()) THEN
      !Get the XML Declaration info
      CALL processXMLDecl(thisXMLFile)

      !Cache the file for processing
      SELECTTYPE(thisXMLFile); TYPE IS(XMLFileType)
        CALL cacheXMLFile(thisXMLFile,nchars,cachedFile)
      ENDSELECT

      !Count the number of markup characters "<" and ">" and lines
      nopen=0
      nclose=0
      nlines=0
      DO ic=1,nchars
        IF(cachedFile(ic) == '<') nopen=nopen+1
        IF(cachedFile(ic) == '>') nclose=nclose+1
        IF(cachedFile(ic) == LF) nlines=nlines+1
      ENDDO
      IF(nopen /= nclose) THEN
        CALL thisXMLFile%e%raiseError(modName//'::'//myName// &
            ' - mismatched markup characters!')
      ELSE
        !Store the locations of all the markup characters "<" and ">" lines
        nTags=nopen
        ALLOCATE(itag(3,nTags))
        ALLOCATE(lines(nlines))
        nopen=0
        nclose=0
        nlines=0
        DO ic=1,nchars
          IF(cachedFile(ic) == '<') THEN
            nopen=nopen+1
            itag(1,nopen)=ic
          ENDIF
          IF(cachedFile(ic) == '>') THEN
            nclose=nclose+1
            itag(2,nopen)=ic
          ENDIF
          IF(cachedFile(ic) == LF) THEN
            nlines=nlines+1
            lines(nlines)=ic
          ENDIF
        ENDDO

        !Verify that they are all matching (interleaved)
        DO i=1,nTags
          IF(itag(1,i) > itag(2,i)) THEN
            CALL thisXMLFile%e%raiseError(modName//'::'//myName// &
                ' - mismatched markup characters!')
            EXIT
          ENDIF
        ENDDO

        DO i=1,nTags
          !Create temporary string
          CALL charArrytoStr(cachedFile(itag(1,i):itag(2,i)), tagStr)
          itag(3,i)=BAD_TAG
          !Determine tag types
          IF(INDEX(tagStr,'<?') == 1) THEN
            !Processing Instruction
            !Check closing marker to insure tag validity
            IF(INDEX(tagStr,'?>',.TRUE.) == LEN_TRIM(tagStr)-1) &
                itag(3,i)=PROCESSING_INST_TAG
          ELSEIF(INDEX(tagStr,'<!--') == 1) THEN
            !Comment
            !Check closing marker to insure tag validity
            IF(INDEX(tagStr,'-->',.TRUE.) /= LEN_TRIM(tagStr)-1 .AND. &
                INDEX(tagStr,'--->',.TRUE.) == 0) itag(3,i)=COMMENT_TAG
          ELSEIF(INDEX(tagStr,'<!') == 1) THEN
            !Declaration (Not currently treated)
            itag(3,i)=DECLARATION_TAG
          ELSEIF(INDEX(tagStr,'</') == 1) THEN
            !EndTag
            !Check closing marker to insure tag validity
            itag(3,i)=END_TAG
          ELSE
            !Determine if start tag or empty-element tag
            IF(INDEX(tagStr,'/>',.TRUE.) == LEN_TRIM(tagStr)-1) THEN
              itag(3,i)=EMPTY_ELEMENT_TAG
            ELSE
              itag(3,i)=START_TAG
            ENDIF
          ENDIF
          IF(itag(3,i) == BAD_TAG) THEN
            CALL thisXMLFile%e%raiseError(modName//'::'//myName// &
                ' - Unrecognizable markup in "'//tagStr//'"!')
          ENDIF
        ENDDO

        !Find first start tag
        DO i=1,nTags
          IF(itag(3,i) == START_TAG) THEN
            rootTagBegin=i
            EXIT
          ELSEIF(itag(3,i) == END_TAG .OR. &
              (itag(3,i) == EMPTY_ELEMENT_TAG .AND. i < nTags)) THEN
              CALL thisXMLFile%e%raiseError(modName//'::'//myName// &
              ' - Could not locate start of root element!')
          ENDIF
        ENDDO

        !Find last end tag
        DO i=nTags,1,-1
          IF(itag(3,i) == END_TAG) THEN
            rootTagEnd=i
            EXIT
          ELSEIF(itag(3,i) == START_TAG .OR. &
              (itag(3,i) == EMPTY_ELEMENT_TAG .AND. i < nTags) .OR. &
              itag(3,i) == DECLARATION_TAG) THEN
              CALL thisXMLFile%e%raiseError(modName//'::'//myName// &
              ' - Could not locate end of root element!')
          ENDIF
        ENDDO

        !Process the elements
        CALL thisXMLFile%root%init(cachedFile,itag,lines,rootTagBegin, &
            rootTagEnd)
      ENDIF
    ELSE
      CALL thisXMLFile%e%raiseError(modName//'::'//myName// &
          ' - XML File could not be opened for reading!')
    ENDIF
  ELSE
    CALL thisXMLFile%e%raiseError(modName//'::'//myName// &
        ' - XML File could not be initialized!')
  ENDIF
ENDSUBROUTINE importFromDisk_XMLFileType
!
!-------------------------------------------------------------------------------
!> @brief Dumps an XML file stored in memory to disk.
!> @param thisXMLFile the XML file type to write to disk
!> @param fname the file name to use on disk
!>
SUBROUTINE exportToDisk_XMLFileType(thisXMLFile,fname)
  CLASS(XMLFileType),INTENT(INOUT) :: thisXMLFile
  CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: fname
  CHARACTER(LEN=4) :: version
  INTEGER(SIK) :: ierr
  TYPE(StringType) :: header
  TYPE(XMLFileType) :: tmpFile

  IF(ASSOCIATED(thisXMLFile%root)) THEN
    CALL tmpFile%init(fname,.FALSE.)
    CALL tmpFile%fopen()

    !Write the header
    WRITE(version,FMT='(f4.1)',IOSTAT=ierr) thisXMLFile%version
    header='<?xml version="'//TRIM(ADJUSTL(version))// &
        '" encoding="'//TRIM(thisXMLFile%encoding)//'"?>'
    WRITE(tmpFile%unitNo,FMT='(a)') CHAR(header)

    !Write style-sheet info
    IF(LEN(thisXMLFile%style_sheet) > 0) THEN
      WRITE(tmpFile%unitNo,FMT='(a)') &
          '<?xml-stylesheet version="1.0" type="text/xsl" href="'// &
          thisXMLFile%style_sheet//'"?>'
    ENDIF

    !Write the XML Elements
    CALL thisXMLFile%root%fwrite(tmpFile%unitNo,0)
    CALL tmpFile%clear()
  ENDIF
ENDSUBROUTINE exportToDisk_XMLFileType
!
!-------------------------------------------------------------------------------
!> @brief Processes the XML declaration
!> @param thisXMLFile the XML file to process the declaration
!>
SUBROUTINE processXMLDecl(thisXMLFile)
  CHARACTER(LEN=*),PARAMETER :: myName='processXMLDecl'
  INTEGER(SIK),PARAMETER :: maxbuf=512
  CLASS(XMLFileType),INTENT(INOUT) :: thisXMLFile

  CHARACTER(LEN=1) :: tmpChar
  CHARACTER(LEN=7) :: fencoding,curEncoding
  CHARACTER(LEN=maxbuf) :: ioBuffer
  LOGICAL(SBK) :: lread
  INTEGER(SIK) :: i,ierr,ibuf,nattr
  REAL(SRK) :: version
  TYPE(StringType) :: tagStr,firstTag,fname
  TYPE(StringType),ALLOCATABLE :: anames(:),avalues(:)

  fencoding='DEFAULT'

  !Rewind the file
  REWIND(thisXMLFile%unitNo)

  !Get the first tag.
  ioBuffer=''
  ierr=0
  lread=.TRUE.
  tagStr=''
  DO WHILE(lread)
    READ(thisXMLFile%unitNo,'(a1)',ADVANCE='NO',IOSTAT=ierr) tmpChar
    IF(ierr == IOSTAT_EOR) tmpChar=CHAR(10)
    IF(ierr == IOSTAT_END) THEN
      CALL thisXMLFile%e%raiseError(modName//'::'//myName// &
          ' - Reached end of file before finding start of first tag "<"!')
      EXIT !No more tags
    ENDIF

    IF(tmpChar == '<') THEN
      !At the start of the tag
      ibuf=1
      ioBuffer(1:1)=tmpChar

      !Stream to closing marker
      DO WHILE(ierr /= IOSTAT_END .AND. tmpChar /= '>')
        ibuf=ibuf+1
        READ(thisXMLFile%unitNo,'(a1)',ADVANCE='NO',IOSTAT=ierr) tmpChar
        ioBuffer(ibuf:ibuf)=tmpChar
        IF(ibuf == maxbuf) THEN
          tagStr=tagStr//ioBuffer
          ibuf=1
        ENDIF
      ENDDO

      !Insure that the last character of the ioBuffer is '>'
      IF(ioBuffer(ibuf:ibuf) == '>') THEN
        tagStr=tagStr//ioBuffer(1:ibuf)
      ELSE
        !Throw an exception end of file before end marker
        CALL thisXMLFile%e%raiseError(modName//'::'//myName// &
            ' - Reached end of file before finding closing marker'// &
            ' ">" for XML tag!')
      ENDIF
      EXIT
    ELSE
      !Insure that only whitespace was read
      IF(.NOT.(SCAN(tmpChar,SP//CR//LF//TB) > 0)) THEN
        !Throw an exception, illegal characters
        CALL thisXMLFile%e%raiseError(modName//'::'//myName// &
            ' - Illegal characters between XML tags!')
        EXIT
      ENDIF
    ENDIF
  ENDDO
  firstTag=tagStr

  !Check that the first Tag starting and ending markers are
  !the XML declaration
  IF(INDEX(firstTag,'<?xml') == 1 .AND. &
      INDEX(firstTag,'?>',.TRUE.) == LEN_TRIM(firstTag)-1) THEN
    !Process the attributes if it is an xml declaration
    CALL processTagAttributes(CHAR(firstTag),nattr,anames,avalues,ierr)

    IF(ierr == 0) THEN
      !The XML declaration only has 3 possible attributes
      ! - version (required, always first)
      ! - encoding (optional)
      ! - standalone (optional)
      IF(0 < nattr .AND. nattr < 4) THEN
        !Set the version
        IF(anames(1) == 'version') THEN
          IF(INDEX(avalues(1),'1.') == 1) THEN
            version=avalues(1)%stof()
            IF(1.0_SRK < version .AND. version < 2.0_SRK) &
                thisXMLFile%version=version
          ELSE
            !Illegal value for version
            CALL thisXMLFile%e%raiseError(modName//'::'//myName// &
                ' - XML Version "'//TRIM(avalues(1))//'" is not supported!')
          ENDIF
        ELSE
          !first attribute must be 'version'!
          CALL thisXMLFile%e%raiseError(modName//'::'//myName// &
              ' - The first attribute must be the XML version!')
        ENDIF

        !Check other attributes
        IF(nattr > 1) THEN
          DO i=2,nattr
            IF(anames(i) == 'encoding') THEN
              !check if this module can process it the encoding
              IF(avalues(i) == 'UTF-8' .OR. avalues(i) == 'utf-8') THEN
                thisXMLFile%encoding='UTF-8'
                fencoding='UTF-8'
              ELSEIF(avalues(i) == 'US-ASCII' .OR. avalues(i) == 'us-ascii') THEN
                thisXMLFile%encoding='US-ASCII'
              ELSE
                CALL thisXMLFile%e%raiseError(modName//'::'//myName// &
                    ' - File encoding "'//TRIM(avalues(i))//'" is not supported!')
              ENDIF

              !Re-open file if it was not opened with the matching encoding
              INQUIRE(UNIT=thisXMLFile%unitNo,ENCODING=curEncoding)
              IF(fencoding /= curEncoding) THEN
                !Close the file
                CALL thisXMLFile%fclose()

                !Open the file for reading
                fname=TRIM(thisXMLFile%getFilePath())// &
                    TRIM(thisXMLFile%getFileName())// &
                    TRIM(thisXMLFile%getFileExt())
                OPEN(UNIT=thisXMLFile%unitNo,FILE=CHAR(fname),STATUS='OLD', &
                    ACCESS='SEQUENTIAL',FORM='FORMATTED',ACTION='READ', &
                    ENCODING=fencoding,IOSTAT=ierr)
                CALL thisXMLFile%setOpenStat(.TRUE.)
              ENDIF
            ELSEIF(anames(i) == 'standalone') THEN
              IF(avalues(i) == 'yes') THEN
                thisXMLFile%standalone=.TRUE.
              ELSEIF(avalues(i) == 'no') THEN
                thisXMLFile%standalone=.FALSE.
              ELSE
                !Illegal value for 'standalone' attribute
                CALL thisXMLFile%e%raiseError(modName//'::'//myName// &
                    ' - illegal value "'//TRIM(avalues(i))// &
                    '" for "standalone" attribute in XML declaration.')
              ENDIF
            ELSE
              !Illegal attribute
              CALL thisXMLFile%e%raiseError(modName//'::'//myName// &
                  ' - illegal attribute "'//TRIM(anames(i))// &
                  '" for XML declaration.')
            ENDIF
          ENDDO
        ENDIF
      ELSE
        !Illegal number of attributes in declaration
        CALL thisXMLFile%e%raiseError(modName//'::'//myName// &
            ' - illegal  number of attributes in XML declaration.')
      ENDIF
    ELSE
      !Failed to process attributes for XMLDecl
      CALL thisXMLFile%e%raiseError(modName//'::'//myName// &
          ' - Failed to process attributes in XML declaration.')
    ENDIF
  ENDIF
  REWIND(thisXMLFile%unitNo)
ENDSUBROUTINE processXMLDecl
!
!-------------------------------------------------------------------------------
!> @brief Loads the XML file into memory
!> @param thisXMLFile the xml file type pointing to the file to load into memory
!> @param nchars the number of characters in the file (max is 1000000)
!> @param fileCache a 1-D character array with all the characters from the file
!>
!> If the file has more than 1 million characters it will not be cached.
!>
SUBROUTINE cacheXMLFile(thisXMLFile,nchars,fileCache)
  TYPE(XMLFileType),INTENT(INOUT) :: thisXMLFile
  INTEGER(SIK),INTENT(OUT) :: nchars
  CHARACTER(LEN=1),ALLOCATABLE,INTENT(INOUT) :: fileCache(:)
  CHARACTER(LEN=1024) :: tmpChar
  INTEGER(SIK) :: i,j,ierr

  IF(ALLOCATED(fileCache)) DEALLOCATE(fileCache)
  REWIND(thisXMLFile%unitNo)

  ierr=0
  nchars=0
  DO WHILE(ierr /= IOSTAT_END)
    READ(thisXMLFile%unitNo,'(a1024)',ADVANCE='NO',IOSTAT=ierr) tmpChar
    IF(ierr == 0) THEN
      nchars=nchars+1024
    ELSEIF(ierr == IOSTAT_EOR) THEN
      nchars=nchars+LEN_TRIM(tmpChar)+1
    ENDIF
  ENDDO

  IF(nchars > 0) THEN
    ALLOCATE(fileCache(nchars))
    REWIND(thisXMLFile%unitNo)

    ierr=0
    i=0
    DO WHILE(ierr /= IOSTAT_END)
      READ(thisXMLFile%unitNo,'(a1024)',ADVANCE='NO',IOSTAT=ierr) tmpChar
      IF(ierr == 0) THEN
        DO j=1,1024
          fileCache(i+j)=tmpChar(j:j)
        ENDDO
        i=i+1024
      ELSEIF(ierr == IOSTAT_EOR) THEN
        DO j=1,LEN_TRIM(tmpChar)
          fileCache(i+j)=tmpChar(j:j)
        ENDDO
        fileCache(i+j)=LF
        i=i+j
      ENDIF
    ENDDO
    CALL thisXMLFile%fclose()
  ELSE
    nchars=-1
  ENDIF
ENDSUBROUTINE cacheXMLFile
!
!-------------------------------------------------------------------------------
!> @brief Get the name of an XML tag
!> @param fulltag the full tag string
!> @param ierr return error code
!> @returns sname a string with the tag name
!>
!> For the return error codes the values are:
!>  0: Success
!> -1: Bad value for fulltag
!> -2: illegal first character for tag name
!> -3: illegal character in tag name
!> -4: tag name starts with "xml"
!>
SUBROUTINE getTagName(fullTag,ierr,sname)
  CHARACTER(LEN=1),INTENT(IN) :: fullTag(:)
  INTEGER(SIK),INTENT(INOUT) :: ierr
  TYPE(StringType),INTENT(INOUT) :: sname
  CHARACTER(LEN=3) :: xml
  INTEGER(SIK) :: nchar,istp,inamechar,i,charval,istt
  sname=''
  nchar=SIZE(fullTag)
  IF(fullTag(1) == '<' .AND. fullTag(nchar) == '>') THEN
    istt=2
    IF(fullTag(2) == '/') istt=3 !This is an endtag
    inamechar=IACHAR(fullTag(istt))

    IF(inamechar == 58 .OR. inamechar == 95 .OR. &
        (64 < inamechar .AND. inamechar < 91) .OR. &
        (96 < inamechar .AND. inamechar < 123)) THEN

      IF(nchar-istt > 2) THEN
        xml(1:1)=fullTag(istt)
        xml(2:2)=fullTag(istt+1)
        xml(3:3)=fullTag(istt+2)
        CALL toUpper(xml)
        IF(xml == 'XML') THEN
          !Names cannot start with "xml"
          ierr=-4
          istp=-1
          nchar=1 !Skip executing the loop
        ENDIF
      ENDIF

      istp=0
      DO i=istt,nchar-1
        IF(ANY(fulltag(i) == (/LF,CR,SP,TB/))) THEN
          istp=i-1
          EXIT
        ENDIF
        charval=IACHAR(fulltag(i))

        !Check that the character is valid in a name
        IF(.NOT.(charval == 45 .OR. charval == 96 .OR. &
                charval == 95 .OR. &
                (64 < charval .AND. charval < 91) .OR. &
                (96 < charval .AND. charval < 123) .OR. &
                (47 < charval .AND. charval < 59))) THEN
          istp=-1
          EXIT
        ENDIF
      ENDDO
      IF(istp == 0) istp=nchar-1
      IF(istp > 0) THEN
        CALL charArrytoStr(fullTag(istt:istp), sname)
        ierr=0
      ELSE
        ierr=-3 !Illegal character in tag name
      ENDIF
    ELSE
      ierr=-2 !Illegal first character of tag name
    ENDIF
  ELSE
    ierr=-1 !Bad Tag
  ENDIF
ENDSUBROUTINE getTagName
!
!-------------------------------------------------------------------------------
!> @brief For a given XML element extract the tag information
!> @param elStartTag the element string with start tag
!> @param nattr the number of attributes for the element
!> @param anames the names of the attributes
!> @param avalues the values of the attributes
!> @param ierr return error code
!>
!> Return values of ierr are:
!>  0: no errors
!> -1: the element string does not have start/end tags
!> -2: "==" was encountered
!> -3: bad attribute name
!> -4: bad attribute value
!>
SUBROUTINE processTagAttributes(elStartTag,nattr,anames,avalues,ierr)
  CHARACTER(LEN=*),INTENT(IN) :: elStartTag
  INTEGER(SIK),INTENT(OUT) :: nattr
  TYPE(StringType),ALLOCATABLE,INTENT(INOUT) :: anames(:)
  TYPE(StringType),ALLOCATABLE,INTENT(INOUT) :: avalues(:)
  INTEGER(SIK),INTENT(OUT) :: ierr

  CHARACTER(LEN=1) :: quote
  CHARACTER(LEN=LEN(elStartTag)) :: startTag
  INTEGER(SIK) :: ic,i,nchars,namestt,valstt,valstp
  INTEGER(SIK),ALLOCATABLE :: anchorLoc(:)

  !Initialize return arguments
  ierr=0
  nattr=0
  IF(ALLOCATED(anames)) DEALLOCATE(anames)
  IF(ALLOCATED(avalues)) DEALLOCATE(avalues)

  !Copy input arg to temporary
  startTag=elStartTag
  startTag=ADJUSTL(startTag)
  nchars=LEN_TRIM(startTag)

  IF(startTag(1:1) == '<' .AND. startTag(nchars:nchars) == '>') THEN
    !Make sure this is not an end tag or comment
    IF(startTag(1:2) /= '<!') THEN

      !Count the number of attributes (count the number of '=' characters)
      DO ic=2,nchars
        IF(startTag(ic:ic) == '=') THEN
          nattr=nattr+1

          !Check to make sure occurrence of '=' is not in '=='
          IF(startTag(ic-1:ic-1) == '=') THEN
            ierr=-2
            nattr=0
            EXIT
          ENDIF
        ENDIF
      ENDDO

      IF(ierr /= -2) THEN
        !Allocate the return arguments
        ALLOCATE(anames(nattr))
        ALLOCATE(avalues(nattr))
        ALLOCATE(anchorLoc(nattr))

        !Get the locations of the '=' characters.
        nattr=0
        DO ic=2,nchars
          IF(startTag(ic:ic) == '=') THEN
            nattr=nattr+1
            anchorLoc(nattr)=ic
          ENDIF
        ENDDO
      ENDIF

      !Get the names (names precede the '=' character with no whitespace)
      !attribute names cannot contain whitespace, must be unique and preceded
      !by whitespace
      DO i=1,nattr
        namestt=SCAN(startTag(1:anchorLoc(i)),' '//CHAR(9)//CHAR(10)//CHAR(13),.TRUE.)
        IF(0 < namestt .AND. namestt < anchorLoc(i)) THEN
          anames(i)=startTag(namestt+1:anchorLoc(i)-1)
        ELSE
          ierr=-3
        ENDIF
      ENDDO

      !Get the values
      DO i=1,nattr
        valstt=anchorLoc(i)+1
        quote=startTag(valstt:valstt)
        valstp=INDEX(startTag(valstt+1:nchars),quote)+valstt
        IF(valstt < valstp) THEN
          avalues(i)=startTag(valstt+1:valstp-1)
        ELSE
          ierr=-4
        ENDIF
      ENDDO
    ENDIF
  ELSE
    ierr=-1
  ENDIF
ENDSUBROUTINE processTagAttributes
!
!-------------------------------------------------------------------------------
!> @brief Determines the number of child elements fora  given XML element
!> @param tagBegin the index of the first tag
!> @param tagEnd the index of the last tag
!> @param iTag the XML tags for a given element
!> @param nChildren the number of child elements
!> @param childTags the start/stop indeces of the tags of any children
!> @param ierr error code
!>
PURE SUBROUTINE DetermineNChildren(tagBegin,tagEnd,iTag,nChildren,childTags,ierr)
  INTEGER(SIK),INTENT(IN) :: tagBegin
  INTEGER(SIK),INTENT(IN) :: tagEnd
  INTEGER(SIK),INTENT(IN) :: iTag(:,:)
  INTEGER(SIK),INTENT(OUT) :: nChildren
  INTEGER(SIK),ALLOCATABLE,INTENT(INOUT) :: childTags(:,:)
  INTEGER(SIK),INTENT(OUT) :: ierr

  INTEGER(SIK) :: nTagRemain,iLevel,i,iChild

  nChildren=0
  IF(ALLOCATED(childTags)) DEALLOCATE(childTags)

  nTagRemain=tagEnd-tagBegin-1
  ierr=-1
  IF(nTagRemain > 0) THEN
    iLevel=0
    DO i=tagBegin+1,tagEnd-1
      IF(iTag(3,i) == EMPTY_ELEMENT_TAG .AND. iLevel == 0) THEN
        nChildren=nChildren+1
      ELSEIF(iTag(3,i) == START_TAG) THEN
        iLevel=iLevel+1
      ELSEIF(iTag(3,i) == END_TAG) THEN
        iLevel=iLevel-1
        IF(iLevel == 0) nChildren=nChildren+1
      ENDIF
    ENDDO
    IF(iLevel /= 0) THEN
      !This means there were not matching end tags!
      ierr=-2
      nChildren=0
    ELSE
      ierr=0
      ALLOCATE(childTags(2,nChildren))
      iLevel=0
      iChild=0
      DO i=tagBegin+1,tagEnd-1
        IF(iTag(3,i) == EMPTY_ELEMENT_TAG .AND. iLevel == 0) THEN
          iChild=iChild+1
          childTags(:,iChild)=i
        ELSEIF(iTag(3,i) == START_TAG) THEN
          iLevel=iLevel+1
          IF(iLevel == 1) THEN
            iChild=iChild+1
            childTags(1,iChild)=i
          ENDIF
        ELSEIF(iTag(3,i) == END_TAG) THEN
          iLevel=iLevel-1
          IF(iLevel == 0) childTags(2,iChild)=i
        ENDIF
      ENDDO
    ENDIF
  ENDIF
ENDSUBROUTINE DetermineNChildren
!
!-------------------------------------------------------------------------------
!> @brief Converts a character array to a string
!> @param charry an array of characters
!> @returns s a string type
!>
PURE SUBROUTINE charArryToStr(charry, s)
  CHARACTER(LEN=1),INTENT(IN) :: charry(:)
  TYPE(StringType),INTENT(INOUT) :: s
  CHARACTER(LEN=SIZE(charry)) :: tmpChar
  INTEGER(SIK) :: i
  DO i=1,SIZE(charry)
    tmpChar(i:i)=charry(i)
  ENDDO
  s=tmpChar
ENDSUBROUTINE charArryToStr
!
ENDMODULE FileType_XML

max_stars_repo_name: wgurecky/Futility

max_issues_repo_name: wgurecky/Futility

max_forks_repo_name: wgurecky/Futility


module m_Parameters
  use m_TypeDef
  use m_LogInfo
  implicit none
  private

  ! Flow type option
  integer,parameter,public:: FT_CH=1  ! Channel
  integer,parameter,public:: FT_HC=2  ! Half channel
  integer, public,save:: FlowType
  real(RK),public,save:: ubulk
  logical,public,save :: IsUxConst
  logical,public,save:: IsUseCRF
  real(RK),public::PrGradAver,uCRF

  ! mesh options
  real(RK),public,save::xlx, yly, zlz  ! domain length in three directions
  integer,public,save::nxp,nyp,nzp     ! grid point number in three directions
  integer,public,save::nxc,nyc,nzc     ! grid center number in three directions. nxc = nxp-1
  integer, public,save:: istret        ! Stretch y-mesh or not (0:no, 1:both sides, 2:bottom)
  real(RK),public,save:: cStret        ! Stretching parameter, if istret=0. this parameter doesn't work.

  integer,parameter,public:: x_pencil=1
  integer,parameter,public:: y_pencil=2
  integer,parameter,public:: z_pencil=3
  integer,parameter,public:: xm_dir=1  ! x- direction
  integer,parameter,public:: xp_dir=2  ! x+ direction
  integer,parameter,public:: ym_dir=3  ! y- direction
  integer,parameter,public:: yp_dir=4  ! y+ direction
  integer,parameter,public:: zm_dir=5  ! z- direction
  integer,parameter,public:: zp_dir=6  ! z+ direction

  ! Physical properties
  real(RK),save,public:: xnu                    ! Kinematic viscosity
  real(RK),dimension(3),save,public:: gravity   ! Gravity or  other constant body forces (if any)

  ! Time stepping scheme and Projection method options
  integer,parameter,public:: FI_AB2 =1          !  AB2 for convective term
  integer,parameter,public:: FI_RK2 =2          !  RK2 for convective term
  integer,parameter,public:: FI_RK3 =3          !  RK3 for convective term
  real(RK),save,public:: dt         ! current time step
  real(RK),save,public:: dtMax      ! Maxium time step
  real(RK),save,public:: SimTime    ! Real simulation time
  integer,save,public :: iCFL       ! Use CFL condition to change time step dynamically( 1: yes, 2:no ).
  real(RK),save,public:: CFLc       ! CFL parameter
  integer,save,public::  itime      ! current time step
  integer,save,public::  ifirst     ! First iteration
  integer,save,public::  ilast      ! Last iteration
  integer,save,public::  iadvance
  integer,save,public::  ischeme
  real(RK),dimension(3),save,public :: pmGammaConst
  real(RK),dimension(3),save,public :: pmThetaConst
  real(RK),dimension(3),save,public :: pmAlphaConst
  real(RK),save,public::pmGamma
  real(RK),save,public::pmTheta
  real(RK),save,public::pmAlpha
  real(RK),save,public::pmAlphaC
  real(RK),save,public::pmBeta
  real(RK),save,public::pmBetaT

  ! FFTW_option
  integer,save,public:: FFTW_plan_type

  ! Boundary conditions
  real(RK),public,dimension(6):: uxBcValue
  real(RK),public,dimension(6):: uyBcValue
  real(RK),public,dimension(6):: uzBcValue

  ! I/O, Statistics
  integer,public,save:: ivstats            ! time step interval for statistics calculation
  integer,public,save:: SaveVisu           ! Output visulizing file frequency
  integer,public,save:: BackupFreq         ! Output Restarting file frequency
  integer,public,save:: SaveStat           ! Output Statistics file frequency

  logical,public,save::       RestartFlag  ! restart or not
  character(64),public,save:: RunName      ! Run name
  character(64),public,save:: Res_Dir      ! Result directory
  character(64),public,save:: RestartDir   ! Restart directory
  integer,public,save:: Cmd_LFile_Freq= 1  ! report frequency in the terminal
  integer,public,save:: LF_file_lvl   = 5  ! logfile report level
  integer,public,save:: LF_cmdw_lvl   = 3  ! terminal report level

  ! Decomp2d options
  integer,public,save:: p_row,p_col

  ! limited velocity and div
  real(RK),public,save:: vel_limit
  real(RK),public,save:: div_limit

  ! SpectraOptions
  logical,public,save:: clc_Spectra
  integer,public,save:: ivSpec
  integer,public,save:: jSpecSet
  integer,public,save:: jSpecEnd
  integer,public,save:: jSpecinc

  public:: ReadAndInitParameters,DumpReadedParam,PMcoeUpdate
contains

  !******************************************************************
  ! InitParameters
  !******************************************************************
  subroutine ReadAndInitParameters(chFile)
    implicit none
    character(*),intent(in)::chFile

    ! locals
    integer:: nUnitFile,myistat
    NAMELIST/BasicParam/FlowType,ubulk,xlx,yly,zlz,nxp,nyp,nzp,istret,cStret,xnu,dtMax,iCFL,CFLc,    &
                        ifirst,ilast,ischeme,FFTW_plan_type,gravity,uxBcValue,uyBcValue,uzBcValue,   &
                        ivstats,BackupFreq,SaveStat,SaveVisu,IsUxConst,IsUseCRF,RestartFlag,RunName, &
                        Res_Dir,RestartDir,Cmd_LFile_Freq,LF_file_lvl,LF_cmdw_lvl,p_row,p_col, &
                        vel_limit,div_limit
    NAMELIST/SpectraOptions/clc_Spectra,ivSpec,jSpecSet,jSpecEnd,jSpecinc
    nUnitFile = GetFileUnit()
    open(unit=nUnitFile, file=chFile, status='old',form='formatted',IOSTAT=myistat )
    if(myistat/=0) then
      print*,"Cannot open file: "//trim(chFile); STOP
    endif
    read(nUnitFile, nml=BasicParam)
    rewind(nUnitFile)
    read(nUnitFile, nml=SpectraOptions)
    close(nUnitFile,IOSTAT=myistat)

    nxc= nxp-1
    nyc= nyp-1
    nzc= nzp-1
    if(IsUseCRF) then
      uCRF= ubulk
      uxBcValue= uxBcValue -uCRF
    else
      uCRF= zero
    endif

    if(ischeme==FI_AB2) then
      iadvance = 1
      pmGammaConst = (/ three/two, zero, zero/)
      pmThetaConst = (/     -half, zero, zero/)
    elseif(ischeme==FI_RK2) then
      iadvance = 2
      pmGammaConst = (/ half,  one, zero/)
      pmThetaConst = (/ zero,-half, zero/)
    elseif(ischeme==FI_RK3) then
      iadvance = 3
      pmGammaConst = (/ eight/fifteen,       five/twelve,    three/four/)
      pmThetaConst = (/          zero,  -seventeen/sixty,  -five/twelve/)
    else
      print*,"Time scheme WRONG!!! ischeme=",ischeme; STOP
    endif
    pmAlphaConst = pmGammaConst + pmThetaConst

  end subroutine ReadAndInitParameters

  !******************************************************************
  ! DumpReadedParam
  !******************************************************************
  subroutine DumpReadedParam()
    implicit none

    ! locals
    NAMELIST/BasicParam/FlowType,ubulk,xlx,yly,zlz,nxp,nyp,nzp,istret,cStret,xnu,dtMax,iCFL,CFLc,    &
                        ifirst,ilast,ischeme,FFTW_plan_type,gravity,uxBcValue,uyBcValue,uzBcValue,   &
                        ivstats,BackupFreq,SaveStat,SaveVisu,IsUxConst,IsUseCRF,RestartFlag,RunName, &
                        Res_Dir,RestartDir,Cmd_LFile_Freq,LF_file_lvl,LF_cmdw_lvl,p_row,p_col, &
                        vel_limit,div_limit
    NAMELIST/SpectraOptions/clc_Spectra,ivSpec,jSpecSet,jSpecEnd,jSpecinc

    write(MainLog%nUnit, nml=BasicParam)
    write(MainLog%nUnit, nml=SpectraOptions)
  end subroutine DumpReadedParam

  !******************************************************************
  ! PMcoeUpdate
  !******************************************************************
  subroutine PMcoeUpdate(ns)
    implicit none
    integer,intent(in)::ns

    pmGamma = pmGammaConst(ns) * dt
    pmTheta = pmThetaConst(ns) * dt
    pmAlpha = pmAlphaConst(ns) * dt
    pmBeta  = half * pmAlphaConst(ns) *xnu * dt
    SimTime=SimTime+dt*real(pmAlphaConst(ns),RK)

    pmAlphaC= pmAlphaConst(ns)              ! for pressure gradient purpose only
    if(ns==1) PrGradAver=zero
  end subroutine PMcoeUpdate

end module m_Parameters


text:
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
PROGRAM testExpTables
#include "UnitTest.h"
USE UnitTest
USE IntrType
USE ExceptionHandler
USE Allocs
USE ParameterLists
USE ExpTables

IMPLICIT NONE

TYPE(ExceptionHandlerType),TARGET :: e
REAL(SRK) :: x,ans,err(5),xtest,x1,x2,x3,y1,y2,y3
REAL(SRK) :: reftbl(-10000:0),reftbl2(-10000:0),reftbl3(-10000:0)
REAL(SRK) :: reftbl4(1:1000)
INTEGER(SIK) :: i
TYPE(ExpTableType),SAVE :: testET1,testET2(5)
TYPE(ParamType),SAVE :: PL
LOGICAL(SBK) :: bool

CREATE_TEST('Test ExpTables')

CALL e%setStopOnError(.FALSE.)
CALL e%setQuietMode(.TRUE.)
CALL eExpTable%addSurrogate(e)
CALL eParams%addSurrogate(e)

WRITE(*,*) '==================================================='
WRITE(*,*) 'TESTING EXPTABLES...'
WRITE(*,*) '==================================================='
WRITE(*,*) 'TESTING EXPONENTTABLETYPE'

!Error checking
CALL PL%clear()
CALL testET1%initialize(PL)
CALL PL%add('ExpTables -> tabletype',0)
CALL testET1%clear()
CALL testET1%initialize(PL)
CALL PL%set('ExpTables -> tabletype',2)
CALL PL%add('ExpTables -> minval',1)
CALL testET1%clear()
CALL testET1%initialize(PL)
CALL PL%set('ExpTables -> minval',-10)
CALL PL%add('ExpTables -> maxval',1)
CALL testET1%clear()
CALL testET1%initialize(PL)
CALL PL%set('ExpTables -> maxval',-10)
CALL testET1%clear()
CALL testET1%initialize(PL)
CALL PL%set('ExpTables -> maxval',0)
CALL PL%add('ExpTables -> nintervals',-1)
CALL testET1%clear()
CALL testET1%initialize(PL)
CALL PL%set('ExpTables -> nintervals',100)
CALL PL%add('ExpTables -> errorflag',.TRUE.)
CALL testET1%clear()
CALL testET1%initialize(PL)
CALL PL%add('ExpTables -> error',0.005_SRK)
CALL testET1%clear()
CALL testET1%initialize(PL)
CALL testET1%initialize(PL)
CALL testET1%clear()
!For the coverage
CALL PL%set('ExpTables -> tabletype',5)
CALL PL%set('ExpTables -> nintervals',1000)
CALL PL%set('ExpTables -> error',1e-7_SRK)
CALL testET1%initialize(PL)
x=testET1%maxVal-0.5_SRK*testET1%dx
ans=testET1%EXPT(x)

CALL PL%set('ExpTables -> errorflag',.FALSE.)
CALL PL%remove('ExpTables -> error')
x=-1.234567891012_SRK
DO i=1,5
  CALL PL%set('ExpTables -> tabletype',i)
  CALL testET2(i)%initialize(PL)
  ans=EXPT(testET2(i),x)
  err(i)=ans-(1._SRK-exp(x))
ENDDO

!For exact exponent function
bool = (testET2(1)%isinit .OR. testET2(1)%tableType == 1 &
      .OR.testET2(1)%nintervals == -1 .OR. (testET2(1)%dx .APPROXEQ. 0._SRK) &
      .OR.(testET2(1)%dx2rd .APPROXEQ. 0._SRK) .OR. (testET2(1)%rdx .APPROXEQ. 0._SRK) &
      .OR.(testET2(1)%rdx2rd .APPROXEQ. 0._SRK) .OR. (testET2(1)%minVal == 0) &
      .OR.(testET2(1)%maxVal == 0) .OR. (testET2(1)%tableErr .APPROXEQ. 0._SRK))
ASSERT(bool, 'testET2(1)%initialize(...)')
WRITE(*,*) '  Passed: CALL testET2(1)%initialize(...) EXACT'
!For SINGLE_LEVEL_EXP_TABLE exponent function
bool = (testET2(2)%isinit .OR. testET2(2)%tableType == 2 &
      .OR. testET2(2)%nintervals == 1000 .OR. (testET2(2)%dx .APPROXEQ. 1.e-3_SRK) &
      .OR. (testET2(2)%dx2rd .APPROXEQ. 0._SRK) .OR. (testET2(2)%rdx .APPROXEQ. 1000._SRK) &
      .OR. (testET2(2)%rdx2rd .APPROXEQ. 0._SRK) .OR. (testET2(2)%minVal == -10) &
      .OR. (testET2(2)%maxVal == 0) .OR. (testET2(2)%tableErr .APPROXEQ. 0.5e-3_SRK))
ASSERT(bool, 'testET2(2)%initialize(...)')
xtest=-10._SRK
DO i=-10000,0
  reftbl(i)=1._SRK-exp(xtest)
  xtest=xtest+1.e-3_SRK
  ASSERT(reftbl(i) .APPROXEQ. testET2(2)%table(i), 'testET2(2)%initialize(...)')
  FINFO() i
ENDDO
!Failed in intel release due to compiler optimizations
!  bool = (ALL(reftbl .APPROXEQ. testET2(2)%table))
!  ASSERT(bool, 'testET2(2)%initialize(...)')
WRITE(*,*) '  Passed: CALL testET2(2)%initialize(...) SINGLE_LEVEL'
!For TWO_LEVEL_EXP_TABLE exponent function
bool = (testET2(3)%isinit .OR. testET2(3)%tableType == 3 &
      .OR. testET2(3)%nintervals == 1000 .OR. (testET2(3)%dx .APPROXEQ. 1.e-3_SRK) &
      .OR. (testET2(3)%dx2rd .APPROXEQ. 1.e-6_SRK) .OR. (testET2(3)%rdx .APPROXEQ. 1000._SRK) &
      .OR. (testET2(3)%rdx2rd .APPROXEQ. 1.e6_SRK) .OR. (testET2(3)%minVal == -10) &
      .OR. (testET2(3)%maxVal == 0) .OR. (testET2(3)%tableErr .APPROXEQ. 0.5e-6_SRK))
ASSERT(bool, 'testET2(3)%initialize(...)')
xtest=-10._SRK
DO i=-10000,0
  reftbl(i)=exp(xtest)
  xtest=xtest+1.e-3_SRK
  ASSERT(reftbl(i) .APPROXEQ. testET2(3)%table(i), 'testET2(3)%initialize(...)')
  FINFO() i
ENDDO
!Failed in intel release due to compiler optimizations
!bool = (ALL(reftbl .APPROXEQ. testET2(3)%table))
!ASSERT(bool, 'testET2(3)%initialize(...)')
FINFO() testET2(3)%table
FINFO() reftbl
xtest=0._SRK
DO i=1,1000
  xtest=xtest+1.e-6_SRK
  reftbl4(i)=exp(xtest)
ENDDO
bool = (ALL(reftbl4 .APPROXEQ. testET2(3)%table2rd))
ASSERT(bool, 'testET2(3)%initialize(...)')
WRITE(*,*) '  Passed: CALL testET2(3)%initialize(...) TWO_LEVEL'
!For LINEAR_EXP_TABLE exponent function
bool = (testET2(4)%isinit .OR. testET2(4)%tableType == 4 &
      .OR. testET2(4)%nintervals == 1000 .OR. (testET2(4)%dx .APPROXEQ. 1.e-3_SRK) &
      .OR. (testET2(4)%dx2rd .APPROXEQ. 0._SRK) .OR. (testET2(4)%rdx .APPROXEQ. 1000._SRK) &
      .OR. (testET2(4)%rdx2rd .APPROXEQ. 0._SRK) .OR. (testET2(4)%minVal == -10) &
      .OR. (testET2(4)%maxVal == 0) .OR. (testET2(4)%tableErr .APPROXEQ. 1.25e-7_SRK))
ASSERT(bool, 'testET2(4)%initialize(...)')
x1=-10._SRK
y1=1._SRK-EXP(x1)
DO i=-10000,0
  x2=x1+1e-3_SRK
  y2=1._SRK-EXP(x2)
  reftbl(i)=(y2-y1)*1000._SRK
  reftbl2(i)=y1-reftbl(i)*x1
  x1=x2
  y1=y2
ENDDO
DO i=-10000,0
  bool = (reftbl(i) .APPROXEQ. testET2(4)%table2D(1,i))
  ASSERT(bool, 'testET2(4)%initialize(...)')
  FINFO() i,reftbl(i),testET2(4)%table2D(1,i)
ENDDO
DO i=-10000,0
  bool = (reftbl2(i) .APPROXEQ. testET2(4)%table2D(2,i))
  ASSERT(bool, 'testET2(4)%initialize(...)')
  FINFO() i,reftbl2(i),testET2(4)%table2D(2,i)
ENDDO
WRITE(*,*) '  Passed: CALL testET2(4)%initialize(...) LINEAR'

!For ORDER2_EXP_TABLE exponent function
bool = (testET2(5)%isinit .OR. testET2(5)%tableType == 5 &
      .OR. testET2(5)%nintervals == 1000 .OR. (testET2(5)%dx .APPROXEQ. 1.e-3_SRK) &
      .OR. (testET2(5)%dx2rd .APPROXEQ. 0._SRK) .OR. (testET2(5)%rdx .APPROXEQ. 1000._SRK) &
      .OR. (testET2(5)%rdx2rd .APPROXEQ. 0._SRK) .OR. (testET2(5)%minVal == -10) &
      .OR. (testET2(5)%tableErr .APPROXEQ. 9.630017699314371e-012_SRK) &
      .OR. (testET2(5)%maxVal == 0))
ASSERT(bool, 'testET2(5)%initialize(...)')
x1=-10._SRK
y1=1._SRK-EXP(x1)
x2=x1+1.0e-3_SRK
y2=1._SRK-EXP(x2)
DO i=-10000,0
  x3=x2+1.0e-3_SRK
  y3=1._SRK-EXP(x3)
  reftbl(i)=((y1+y3)*0.5_SRK-y2)*1.0e6_SRK
  reftbl2(i)=(-((x2+x3)*y1+(x1+x2)*y3)*0.5_SRK+(x1+x3)*y2)*1.0e6_SRK
  reftbl3(i)=((x3*y1+x1*y3)*x2*0.5_SRK-x1*x3*y2)*1.0e6_SRK
  x1=x2
  x2=x3
  y1=y2
  y2=y3
ENDDO
DO i=-10000,0
  bool = (reftbl(i) .APPROXEQ. testET2(5)%table(i))
  ASSERT(bool, 'testET2(5)%initialize(...)')
  FINFO() i,reftbl(i),testET2(5)%table(i)
ENDDO
DO i=-10000,0
  bool = (reftbl2(i) .APPROXEQ. testET2(5)%table2rd(i))
  ASSERT(bool, 'testET2(5)%initialize(...)')
  FINFO() i,reftbl2(i),testET2(5)%table2rd(i)
ENDDO

DO i=-10000,0
  bool = SOFTEQ(reftbl3(i),testET2(5)%table3rd(i),1.0e-7_SRK)
  ASSERT(bool, 'testET2(5)%initialize(...)')
  FINFO() i,reftbl3(i),testET2(5)%table3rd(i)
ENDDO
WRITE(*,*) '  Passed: CALL testET2(5)%initialize(...) ORDER2'

err(:)=0.0_SRK
CALL PL%set('ExpTables -> nintervals',100)
CALL PL%set('ExpTables -> errorFlag',.TRUE.)
CALL PL%add('ExpTables -> error',9.99e-7_SRK)
DO i=1,5
  CALL testET2(i)%clear()
  CALL PL%set('ExpTables -> tabletype',i)
  CALL testET2(i)%initialize(PL)
  WRITE(*,*) getMemUsageChar()
  ans=testET2(i)%EXPT(x)
  err(i)=ans-(1._SRK-EXP(x))
ENDDO
CALL testET2(5)%clear()
bool = ALL(ABS(err) <= 1e-6_SRK)
ASSERT(bool, 'tableET%EXPT(x)')
WRITE(*,*) '  Passed: tableET%EXPT(x)'

CALL testET1%clear()
bool = (.NOT.testET1%isinit .OR. testET1%tableType == -1 &
      .OR. testET1%nintervals == -1 .OR. (testET1%dx .APPROXEQ. 0._SRK) &
      .OR. (testET1%dx2rd .APPROXEQ. 0._SRK) .OR. (testET1%rdx .APPROXEQ. 0._SRK) &
      .OR. (testET1%rdx2rd .APPROXEQ. 0._SRK) .OR. (testET1%minVal == 0) &
      .OR. (testET1%maxVal == 0) .OR. (testET1%tableErr .APPROXEQ. 0._SRK))
ASSERT(bool, 'testET1%clear()')
FINALIZE_TEST()

CREATE_TEST("subtest POLAR_EXP_TABLE")

REGISTER_SUBTEST("testPOLAR_EXP_TABLE", testPOLAR_EXP_TABLE)

WRITE(*,*) '  Passed: CALL testET1%clear()'
WRITE(*,*) '==================================================='
WRITE(*,*) 'TESTING EXPTABLES COMPLETE!'
WRITE(*,*) '==================================================='
CALL PL%clear()
CALL ErrCheck()
!CALL perftest()
DO i=1,5
  CALL testET2(i)%clear()
ENDDO
CALL ExpTables_Clear_ValidParams()
!CALL bitEXP()

FINALIZE_TEST()

!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
!> This routine computes the numerical error of the tables which can be used to
!> compare to the analytic expressions for verification.
SUBROUTINE ErrCheck()
  REAL(SRK) :: x(1000),ans(1000),err_result(1000),maxerr,dx
  INTEGER(SIK) :: j,i,ntype,nintervals,itype,maxi
  TYPE(ExpTableType) :: testET

  ntype=5_SIK

  !DO i=2,6
  !  nintervals(i)=nintervals(i-1)*10_SIK
  !ENDDO
  WRITE(*,*)
  WRITE(*,*) '+------------+------------+---------------+'
  WRITE(*,*) '| Table Type | nIntervals | Max Table Err |'
  WRITE(*,*) '+------------+------------+---------------+'
  DO itype=2,5 !ntype
    nintervals=1_SIK
    DO j=2,6
      nintervals=nintervals*10
      CALL PL%set('ExpTables -> tabletype',itype)
      CALL PL%set('ExpTables -> nintervals',nintervals)
      CALL testET%initialize(PL)
      x(1)=0.0_SRK
      IF(itype/=3) THEN
        dx=testET%dx/1000._SRK
      ELSE
        dx=testET%dx2rd/1000._SRK
      ENDIF
      DO i=2,1000
        x(i)=x(i-1)-dx
      ENDDO
      DO i=2,999
        ans(i)=1._SRK-EXP(x(i))
        ans(1)=EXPT(testET,x(i))
        err_result(i)=ABS(ans(i)-ans(1))
      ENDDO
      maxerr=0._SRK
      DO i=2,999
        IF(err_result(i)>maxerr) THEN
          maxerr=err_result(i)
          maxi=i
        ENDIF
      ENDDO
      WRITE(*,'(a,i12,a,i12,a,es15.6,a)') &
      ' |',itype,'|',testET%nintervals,'|',maxerr,'|'
!          WRITE(*,*) itype,testET%nintervals,'Err:',maxi,x(maxi),maxerr
      CALL testET%clear()
    ENDDO
  ENDDO
  WRITE(*,*) '+------------+------------+---------------+'
ENDSUBROUTINE ErrCheck
!
!-------------------------------------------------------------------------------
!This routine was used to generate the performance data with TAU to show
!that the linear interpolation has favorable performance.
SUBROUTINE perftest()
#ifdef TAU
  INTEGER(SIK),SAVE :: profiler1(2)=0
  INTEGER(SIK),SAVE :: profiler2(2)=0
  INTEGER(SIK),SAVE :: profiler3(2)=0
  INTEGER(SIK),SAVE :: profiler4(2)=0
  INTEGER(SIK),SAVE :: profiler5(2)=0
  INTEGER(SIK),SAVE :: profiler6(2)=0
  INTEGER(SIK) :: nval,neval,j,ix
  REAL(SRK),ALLOCATABLE :: xval(:),ans(:)
  TYPE(ExpTableType) :: myTable

  WRITE(*,*)
  WRITE(*,*)
  WRITE(*,*) ' Getting performance measurements...'

  !Set test input for number of evaluations and number of values to evaluate
  neval=100000
  nval=300

  !Setup test input
  ALLOCATE(ans(1:nval))
  ALLOCATE(xval(1:nval))
  CALL RANDOM_NUMBER(xval)
  xval=xval*(-10._SRK)

  CALL TAU_PROFILE_INIT()
  CALL TAU_PROFILE_TIMER(profiler1, 'EXACT EXP()')
  DO i=1,neval
    ans=REAL(i,SRK)
    CALL TAU_PROFILE_START(profiler1)
    DO j=1,nval
      ans(j)=ans(j)+EXP(xval(j))
    ENDDO
    CALL TAU_PROFILE_STOP(profiler1)
  ENDDO

  CALL TAU_PROFILE_TIMER(profiler2, 'EXACT EXP() Array Form')
  DO i=1,neval
    ans=REAL(i,SRK)
    CALL TAU_PROFILE_START(profiler2)
    ans=ans+EXP(xval)
    CALL TAU_PROFILE_STOP(profiler2)
  ENDDO

  CALL TAU_PROFILE_TIMER(profiler3, 'EXACT myTable%EXPT()')
  CALL myTable%initialize(EXACT_EXP_TABLE)
  DO i=1,neval
    ans=REAL(i,SRK)
    CALL TAU_PROFILE_START(profiler3)
    DO j=1,nval
      ans(j)=ans(j)+myTable%EXPT(xval(j))
    ENDDO
    CALL TAU_PROFILE_STOP(profiler3)
  ENDDO
  CALL myTable%clear()

  CALL TAU_PROFILE_TIMER(profiler4, 'LINEAR myTable%EXPT()')
  CALL myTable%initialize(LINEAR_EXP_TABLE)
  DO i=1,neval
    ans=REAL(i,SRK)
    CALL TAU_PROFILE_START(profiler4)
    DO j=1,nval
      ans(j)=ans(j)+myTable%EXPT(xval(j))
    ENDDO
    CALL TAU_PROFILE_STOP(profiler4)
  ENDDO
  CALL myTable%clear()

  CALL TAU_PROFILE_TIMER(profiler5, 'LINEAR EXPLICIT')
  CALL myTable%initialize(LINEAR_EXP_TABLE)
  DO i=1,neval
    ans=REAL(i,SRK)
    CALL TAU_PROFILE_START(profiler5)
    DO j=1,nval
      ix=FLOOR(xval(j)*myTable%rdx)
      ans(j)=ans(j)+myTable%table2D(1,ix)*xval(j)+myTable%table2D(2,ix)
    ENDDO
    CALL TAU_PROFILE_STOP(profiler5)
  ENDDO
  CALL myTable%clear()

  WRITE(*,*) ' Performance measurements completed'
#else
  USE Times
  USE StochasticSampling

  INTEGER(SIK) :: nval,neval,j
  REAL(SRK),ALLOCATABLE :: xval(:),ans(:)
  TYPE(ExpTableType) :: myTable
  TYPE(TimerType) :: testTimer
  TYPE(StochasticSamplingType) :: myRNG

  CALL testTimer%setTimerHiResMode(.TRUE.)
  CALL myRNG%init(RNG_LEcuyer2)
  WRITE(*,*)
  WRITE(*,*)
  WRITE(*,*) ' Getting performance measurements without TAU...'

  !Set test input for number of evaluations and number of values to evaluate
  neval=1000000
  nval=3000

  !Setup test input
  ALLOCATE(ans(1:nval))
  ALLOCATE(xval(1:nval))
  DO j=1,nval
    xval(j)=myRNG%rng()
  ENDDO
  xval=xval*(-10._SRK)

  WRITE(*,*) 'EXACT myTable%EXPT()'
  CALL PL%add('ExpTables -> tabletype',EXACT_EXP_TABLE)
  CALL myTable%initialize(PL)
  CALL testTimer%tic()
  DO i=1,neval
    ans=REAL(i,SRK)
    DO j=1,nval
      ans(j)=ans(j)+myTable%EXPT(xval(j))
    ENDDO
  ENDDO
  CALL testTimer%toc()
  WRITE(*,*) "Took: ", testTimer%elapsedtime
  CALL myTable%clear()

  WRITE(*,*) 'LINEAR myTable%EXPT()'
  CALL PL%set('ExpTables -> tabletype',LINEAR_EXP_TABLE)
  CALL myTable%initialize(PL)
  CALL testTimer%ResetTimer()
  DO i=1,neval
    ans=REAL(i,SRK)
    DO j=1,nval
      ans(j)=ans(j)+myTable%EXPT(xval(j))
    ENDDO
  ENDDO
  CALL testTimer%toc()
  WRITE(*,*) "Took: ", testTimer%elapsedtime
  CALL myTable%clear()
  CALL PL%clear()
  CALL myRNG%clear()

  WRITE(*,*) ' Performance measurements completed'
#endif
ENDSUBROUTINE perftest
!
!-------------------------------------------------------------------------------
!This routine is here to test the performance and feasability of calculating
!the function EXP(x) based on bitwise comparison and operations to see if there
!is any noticable speedup.
SUBROUTINE bitEXP()
  REAL(SSK) :: x,y,xinit
  INTEGER(SNK) :: xint,yint,xinitint
  EQUIVALENCE(x,xint)
  EQUIVALENCE(y,yint)
  EQUIVALENCE(xinit,xinitint)
  INTEGER(SIK) :: i
  !REAL(SSK),ALLOCATABLE :: ans(:),xval(:)
  REAL(SSK) :: logvals(27)

  !Set test input for number of evaluations and number of values to evaluate
  !neval=1
  !nval=1

  !Setup test input
  !ALLOCATE(ans(1:nval))
  !ALLOCATE(xval(1:nval))
  !CALL RANDOM_NUMBER(xval)
  !xval=xval*(-10._SSK)

  !Trial Negative values
  !logvals(1)=LOG(1.0_SSK/256.0_SSK)
  !logvals(2)=LOG(1.0_SSK/16.0_SSK)
  !logvals(3)=LOG(1.0_SSK/4.0_SSK)
  !logvals(4)=LOG(1.0_SSK/2.0_SSK)
  !logvals(5)=LOG(1.0_SSK/1.5_SSK)
  !logvals(6)=LOG(1.0_SSK/1.25_SSK)
  !logvals(7)=LOG(1.0_SSK/1.125_SSK)
  !logvals(8)=LOG(1.0_SSK/1.0625_SSK)
  !logvals(9)=LOG(1.0_SSK/1.03125_SSK)
  !logvals(10)=LOG(1.0_SSK/1.015625_SSK)
  !logvals(11)=LOG(1.0_SSK/1.007813_SSK)
  !logvals(12)=LOG(1.0_SSK/1.003906_SSK)
  !logvals(13)=LOG(1.0_SSK/1.001953_SSK)
  !logvals(14)=LOG(1.0_SSK/1.000977_SSK)
  !logvals(15)=LOG(1.0_SSK/1.000488_SSK)
  !logvals(16)=LOG(1.0_SSK/1.000244_SSK)
  !logvals(17)=LOG(1.0_SSK/1.000122_SSK)
  !logvals(18)=LOG(1.0_SSK/1.000061_SSK)
  !logvals(19)=LOG(1.0_SSK/1.000031_SSK)
  !logvals(20)=LOG(1.0_SSK/1.000015_SSK)
  !logvals(21)=LOG(1.0_SSK/1.000008_SSK)
  !logvals(22)=LOG(1.0_SSK/1.000004_SSK)
  !logvals(23)=LOG(1.0_SSK/1.000002_SSK)
  !Positive Values
  logvals(1)=LOG(256.00000_SSK)
  logvals(2)=LOG(16.000000_SSK)
  logvals(3)=LOG(4.0000000_SSK)
  logvals(4)=LOG(2.0000000_SSK)
  logvals(5)=LOG(1.5000000_SSK)
  logvals(6)=LOG(1.2500000_SSK)
  logvals(7)=LOG(1.1250000_SSK)
  logvals(8)=LOG(1.0625000_SSK)
  logvals(9)=LOG(1.0312500_SSK)
  logvals(10)=LOG(1.0156250_SSK)
  logvals(11)=LOG(1.0078125_SSK)
  logvals(12)=LOG(1.0039063_SSK)
  logvals(13)=LOG(1.0019531_SSK)
  logvals(14)=LOG(1.0009766_SSK)
  logvals(15)=LOG(1.0004883_SSK)
  logvals(16)=LOG(1.0002441_SSK)
  logvals(17)=LOG(1.0001221_SSK)
  logvals(18)=LOG(1.0000610_SSK)
  logvals(19)=LOG(1.0000305_SSK)
  logvals(20)=LOG(1.0000153_SSK)
  logvals(21)=LOG(1.0000076_SSK)
  logvals(22)=LOG(1.0000038_SSK)
  logvals(23)=LOG(1.0000019_SSK)
  logvals(24)=LOG(1.0000010_SSK)
  logvals(25)=LOG(1.0000005_SSK)
  logvals(26)=LOG(1.0000002_SSK)
  logvals(27)=LOG(1.0000001_SSK)

  x=-10._SSK
  xinit=EXP(x)
  y=4.54E-5_SSK
  WRITE(*,*) 'x=',x,'y=',y,'EXP(x)=',xinit
  WRITE(*,*) 'Printing X...'
  CALL printBit(xint)
  WRITE(*,*) 'Printing Y...'
  CALL printBit(yint)

  !Get it to work for positive numbers first.

  x=0.5_SSK
  xinit=EXP(x)
  y=1.0_SRK
  !yint=1073741824_SIK
  !yint=65536_SIK
  WRITE(*,*) 'x=',x,'y=',y,'EXP(x)=',xinit
  WRITE(*,*) 'Printing EXP(Xinitial)...'
  CALL printBit(xinitint)
  WRITE(*,*) 'Printing Y...'
  CALL printBit(yint)
  DO i=1,5
    IF(x >= logvals(i)) THEN
      x=x-logvals(i); yint=IBSET(yint,27-i)
    ENDIF
    WRITE(*,*) 'x=',x,'y=',y,'EXP(x)=',xinit
    WRITE(*,*) 'Printing EXP(Xinitial)...'
    CALL printBit(xinitint)
    WRITE(*,*) 'Printing Y...'
    CALL printBit(yint)
  ENDDO
  DO i=6,24
    IF(x >= logvals(i)) THEN
      x=x-logvals(i); yint=IBSET(yint,27-i)
    ENDIF
    WRITE(*,*) 'x=',x,'y=',y,'EXP(x)=',xinit
    WRITE(*,*) 'Printing EXP(Xinitial)...'
    CALL printBit(xinitint)
    WRITE(*,*) 'Printing Y...'
    CALL printBit(yint)
  ENDDO
  !DO i=1,10
  !  !Add 1._SSK to x
  !  x=x-1.0_SSK
  !  WRITE(*,*) 'x=',x,'y=',y,'EXP(x)=',EXP(x)
  !  CALL printBit(xint)
  !ENDDO

  !DO i=1,neval
  !
  !ENDDO

ENDSUBROUTINE bitEXP
!
!-------------------------------------------------------------------------------
!Functionalizing the Bit Printing I'll probably need mulitple times.
!Prints the bit number from 31-0 for 32-bit values, prints the s,x,m
!notation for IEEE-754 single precision reals, and then prints the bits in the
!corresponding order.  (Haven't expanded this to take into account endian-ness)
!
!The integer specified by the input should be "equivalenced" (shares the same
!memory location with) a single precision real number.  Bit-wise operations are
!only available through integers.
!
SUBROUTINE printBit(int)
  INTEGER(SNK),INTENT(INOUT) :: int
  INTEGER(SIK) :: i,bprint(32)
  LOGICAL(SBK) :: flag(32)

  bprint=0_SIK
  DO i=1,32
    !Apparently, there is a zero bit, who knew.
    flag(i)=BTEST(int,i-1)
    IF(flag(i)) bprint(i)=1_SIK
  ENDDO
  WRITE(*,*) '      10987654321098765432109876543210'
  WRITE(*,*) '      sxxxxxxxxmmmmmmmmmmmmmmmmmmmmmmm'
  WRITE(*,'(a,32i1)') '       ',(bprint(i),i=32,1,-1)
  WRITE(*,*) '--------------------------------------'
ENDSUBROUTINE printBit
!
!-------------------------------------------------------------------------------
!This routine is here to test the performance and feasability of calculating
!the function EXP(x) based on bitwise comparison and operations to see if there
!is any noticable speedup.
SUBROUTINE testPOLAR_EXP_TABLE()
  TYPE(ExpTableType) :: testET
  TYPE(ParamType),SAVE :: PL
  REAL(SRK),ALLOCATABLE :: rsinpol(:)
  INTEGER(SIK) :: ipol,i
  REAL(SRK) :: y,result,x

  CALL PL%clear()
  !Set names for required parameters
  !Set defaults for optional parameters
  CALL PL%add('ExpTables -> tabletype',POLAR_EXP_TABLE)
  CALL PL%add('ExpTables -> minval',-10._SRK)
  CALL PL%add('ExpTables -> maxval',0._SRK)
  CALL PL%add('ExpTables -> nintervals',1000)
  CALL PL%add('ExpTables -> error',0.0005_SRK)
  CALL PL%add('ExpTables -> errorflag',.FALSE.)
  ALLOCATE(rsinpol(3))
  rsinpol=(/6.000672075_SRK,1.859748897_SRK,1.071864208_SRK/)
  CALL PL%add('ExpTables -> RSIN_polars',rsinpol)

  !Initialize the exponential table
  CALL testET%initialize(PL)
  !Error Checking
  ASSERT(testET%nintervals==1000,"nintervals")
  ASSERT(testET%tableType==POLAR_EXP_TABLE,"tableType")
  ASSERT(testET%maxVal==0._SRK,"maxVal")
  ASSERT(testET%minVal==-10._SRK,"minVal")
  ASSERT(testET%minTable==-10000,"minTable")
  FINFO() "minTable",testET%minTable
  FINFO() "minTable_ref",-1000
  ASSERT(testET%rdx==1000,"rdx")
  ASSERT(testET%dx==0.001_SRK,"dx")
  ASSERT(SOFTEQ(testET%tableErr,1.249999999E-007_SRK,1e-6_SRK),"tableErr")
  FINFO() "tableErr",testET%tableErr
  FINFO() "tableErr_ref",1.249999999E-007_SRk

  DO ipol=1,3
    x=-10.001_SRK
    DO i=-10000,0
      x=x+0.001_SRK
      y=1._SRK-EXP(x*rsinpol(ipol))
      result=testET%EXPT(x,ipol)
      !Comparing the table lookup result with the system function evaluation
      !instead of checking the coeff in the table themselves
      ASSERT(SOFTEQ(result,y,1.249999999E-007_SRK),"resultOfFunctionCall")
      FINFO() "tableLookUp",result,i,ipol
      FINFO() "reference",y
    ENDDO
  ENDDO

  DEALLOCATE(rsinpol)
  CALL testET%clear()
  CALL PL%clear()
ENDSUBROUTINE testPOLAR_EXP_TABLE
!
ENDPROGRAM testExpTables

max_stars_repo_name: picmc/Futility

max_issues_repo_name: picmc/Futility


text:
        SUBROUTINE YCLEXP(FRAME,NAME,EPS,REJECT,EPSREJ,DATA,ERR,
     *                    PEDGRE,DESCRP,ISTAT)
*
*  Module number:
*
*  Module name: yclexp
*
*  Keyphrase:
*  ----------
*       convert to count rates
*
*  Description:
*  ------------
*       This routine divides by the exposure time for each data point
*       with a correction for disabled diodes.  If DEFDDTBL is True in
*       the input .d0h file, disabled diodes are taken from the UDL
*       file, other wise they are taken from a reference file.
*
*  FORTRAN name: yclexp.for
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*  Name                         I/O     Description / Comments
*       name                    I       Name of the dead diode reference file
*       <rootname>.ulh          I       unique data log file
*
*  Subroutines Called:
*  -------------------
*  CDBS:
*       ysmput, yrdddt, ymissd
*  SDAS:
*       uigs1r
*  Others:
*
*
*  History:
*  --------
*  Version      Date        Author          Description
*    1          JUL 89  D. LINDLER      DESIGNED AND CODED
*        	Sep 90  S. Hulbert	update BUNITS
*    1.1	Apr 93	H. Bushouse	Declare passed arrays as (*), not (1)
*    2		Mar 94	H. Bushouse	Mods to handle PEDIGREE keywords
*    2.1        Mar 97  M. De La Pena   Added KYDEPLOY to CONFG1
*-------------------------------------------------------------------------------
*
* inputs:
*       frame - frame number
*       name - name of disabled diode table file
*       eps - quality array
*       reject - reject vector
*       epsrej - quality vector for reject
*
* input/output:
*       data - data array
*       err - error array
*
* outputs:
*	pedgre - DDTHFILE PEDIGREE keyword string
*	descrp - DDTHFILE DESCRIP  keyword string
*       istat - error status
*------------------------------------------------------------------------------
        INTEGER FRAME,ISTAT
        REAL EPS(*),REJECT(*),EPSREJ(*),DATA(*),ERR(*)
        CHARACTER*64 NAME
	CHARACTER*68 PEDGRE, DESCRP
C
C     UMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87
C
      INTEGER STDOUT
      PARAMETER (STDOUT = 1)
      INTEGER STDERR
      PARAMETER (STDERR = 2)
C
C Common block containing confiquration parameters
C
        CHARACTER*5 DET
        CHARACTER*3 FGWAID,APERID,YTYPE(3)
        CHARACTER*1 POLID
        INTEGER FCHNL,NCHNLS,OVERSN,NXSTEP,YBASE,YRANGE,YSTEPS,
     *          INTS,SLICES,NPAT,NREAD,NCLEAR,LVTIME
        LOGICAL HEADER,TRAILR,DEFDDT,KYDPLY
        COMMON /CONFG1/KYDPLY,DET,FGWAID,APERID,POLID,YTYPE
        COMMON /CONFG2/FCHNL,NCHNLS,OVERSN,NXSTEP,YBASE,YRANGE,YSTEPS,
     *          INTS,SLICES,NPAT,NREAD,NCLEAR,LVTIME,HEADER,TRAILR,
     *          DEFDDT
        INTEGER NX,NOBJ,NSKY,NBCK
        COMMON /CONFG3/NX,NOBJ,NSKY,NBCK
C
C Common block containing input/output file descriptions
C
C       IDS - file id numbers
C       GCOUNT - group counts
C       NAXIS - naxis
C       NAXIS1 - first dimensions
C       NAXIS2 - second dimensions
C       FILL - Fill values
C
        INTEGER IDS(30),NAXIS(30),NAXIS1(30),NAXIS2(30),GCOUNT(30)
        REAL FILL(30)
        COMMON /IOCOM/IDS,GCOUNT,NAXIS,NAXIS1,NAXIS2,FILL
C
C brigtness units for output files
C
        CHARACTER * 20 BUNITS(10)
        COMMON /BUNITS/ BUNITS
C
C local variables
C
        REAL FILLD
C                                    --->Fill flag
        LOGICAL FOUND
        INTEGER N,ND,I,NREPS,CLEARS,IREAD,NREJ,NR
        CHARACTER*80 CONTXT
        REAL DDT(512)
C                                    --->Disabled diode table
        REAL SCALE,EXPO,GOOD
C
C Epsilon values
C   EPSBAD = 400   NMISSED = NREPS
C   EPSH = 50      0.5 < MISSED/NREPS
        REAL EPSBAD,EPSH
        DATA EPSBAD/400.0/,EPSH/50.0/
C------------------------------------------------------------------------------
C
C On frame 1 read the reference data
C
        IF(FRAME.EQ.1)THEN
            FILLD = FILL(1)
C
C If DEFDDT=T, read the dead diode list from the .ulh (UDL) file
C
            IF(DEFDDT)THEN
                CALL UIGS1R(IDS(5),322+FCHNL,833,DDT,ISTAT)
                IF(ISTAT.NE.0)THEN
                        CONTXT='ERROR reading from .ulh file '
                        GO TO 999
                ENDIF
                CONTXT='Conversion to count rates using ULH disabled'//
     *                  ' diode table'
                CALL YMSPUT(CONTXT,STDOUT,0,ISTAT)
                DO 1 I=1,NCHNLS
                    IF((DDT(I).GT.32767.0).OR.(DDT(I).LT.0.0))THEN
                         DDT(I)=0.0
C				    ---> zero = disabled
                      ELSE
                         DDT(I)=1.0
C				    ---> one  = active
                    ENDIF
1                CONTINUE
C
C Otherwise, read the dead diode list from the DDTHFILE reference file
C
             ELSE
                CALL YRDDDT(NAME,DDT,PEDGRE,DESCRP,ISTAT)
                IF(ISTAT.NE.0)GO TO 1000
                CONTXT='Conversion to count rates using DDTFIL '//NAME
                CALL YMSPUT(CONTXT,STDOUT,0,ISTAT)
C
C If the reference file contains dummy data, set all diodes to active
C
		IF (PEDGRE(1:5).EQ.'DUMMY') THEN
		    CONTXT='WARNING: PEDIGREE = DUMMY for '//NAME
		    CALL YMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
		    CONTXT='         Correction for dead diodes will '
     *                     //'be skipped'
		    CALL YMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
		    DO 10 I = 1, 512
10		       DDT(I) = 1.0
		END IF
            ENDIF
C
            EXPO = LVTIME*7.8125E-6
C                                    --->exposure per repitition (seconds)
        ENDIF
C-------------------- End of frame 1 only processing ---------------------------
C
C compute number of reps
C
        CLEARS = (FRAME-1)/NREAD
C                                    --->number of clears so far
        IREAD = FRAME - CLEARS*NREAD
C                                    --->readout number
        NREPS = IREAD * OVERSN * NPAT * INTS
C
C Change rejects with fill data to 0 and print warning
C
        IF(TRAILR)THEN
            FOUND = .FALSE.
            NREJ = NXSTEP * SLICES * YSTEPS * OVERSN
            DO 20 I=1,NREJ
                IF(EPSREJ(I).GT.0.0)THEN
                        FOUND = .TRUE.
                        REJECT(I)=0
                ENDIF
20          CONTINUE
            IF(FOUND)THEN
                WRITE(CONTXT,99)FRAME
99              FORMAT('WARNING: fill data in reject array for frame',
     *                  I5,' assumed 0')
                CALL YMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
            ENDIF
        ENDIF
C
C compute number of misses; reuse EPSREJ array to store misses
C
        ND = NCHNLS + OVERSN - 1
        NR = INTS * NPAT * IREAD
        CALL YMISSD(NXSTEP,ND,NCHNLS,YSTEPS,SLICES,OVERSN,NR,REJECT,
     *                  DDT,TRAILR,EPSREJ)
C
C divide data by exposure time, correcting for dead diodes and misses
C
        N = NX * YSTEPS * SLICES
        DO 500 I=1,N
            IF(EPS(I).GE.FILLD)THEN
                    ERR(I)=0.0
                    DATA(I)=0.0
                ELSE
                    IF(EPSREJ(I).GT.NREPS)THEN
                        CONTXT='ERROR: exposure computation; MISSED'//
     *                          ' is greater then NREPS'
                    ELSE
                        IF(EPSREJ(I).LT.NREPS)THEN
                                GOOD = NREPS - EPSREJ(I)
                                SCALE = EXPO*GOOD
                                DATA(I) = DATA(I)/SCALE
                                ERR(I) = ERR(I)/SCALE
                                IF (((EPSREJ(I)/NREPS).GE.0.5).AND.
     *                                (EPS(I).LT.EPSH))EPS(I)=EPSH
                           ELSE
                                DATA(I) = 0.0
                                ERR(I) = 0.0
                                IF(EPS(I).LT.EPSBAD)EPS(I)=EPSBAD
                        ENDIF
                    ENDIF
             ENDIF
500     CONTINUE
C
C update brightness units
C
        DO 101 I = 2, 10
            IF (I .EQ. 4) GO TO 101
            BUNITS(I) = 'COUNTS/S'
101     CONTINUE
C
        GO TO 1000
999     CALL YMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
        ISTAT=1
1000    RETURN
        END

ext: f

max_stars_repo_name: iraf-community/stsdas


text:
!
!  Copyright 2017-2019 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120-------130
module broyden_sub

contains

subroutine broyden(vecr,vecr_in,vecr_out,nl,iter,iter_mod,nstock,icomm)
  use salmon_global, only: alpha_mb, nmemory_mb
  use salmon_communication, only: comm_summation
  use salmon_math
  implicit none
  integer, intent(in) :: nl
  integer, intent(in) :: iter
  integer, intent(in) :: iter_mod
  integer, intent(in) :: nstock
  integer, intent(in), optional  :: icomm
  real(8), intent(inout) :: vecr(1:nl)
  real(8), intent(inout) :: vecr_in(1:nl,1:nstock+1)
  real(8), intent(inout) :: vecr_out(1:nl,1:nstock+1)
  integer,parameter :: iter_mb=0
  real(8),parameter :: omega0=0.01d0
  integer :: iter_s,iter_e
  integer :: i,j
  real(8),allocatable :: vecf(:,:)
  real(8) :: vecr_tmp(1:nl)
  real(8),allocatable :: del_vecf(:,:),del_vecx(:,:)
  real(8),allocatable :: omega_mb(:)
  real(8),allocatable :: aa(:,:),aa_tmp1(:,:)
  real(8),allocatable :: beta(:,:)
  real(8),allocatable :: ss_tmp1(:), ss_tmp2(:)
  real(8) :: ss
  integer :: nnegative,nnegative_tmp

  vecr_out(1:nl,iter_mod)=vecr(1:nl)
  if (iter <= iter_mb+1) then
    allocate(vecf(1:nl,iter:iter))
    vecf(1:nl,iter)=vecr_out(1:nl,iter_mod)-vecr_in(1:nl,iter_mod)
    vecr_in(1:nl,iter_mod+1)=vecr_in(1:nl,iter_mod)+alpha_mb*vecf(1:nl,iter)
    deallocate(vecf)
  else
    iter_s=max(iter_mb+1+(iter_mod-iter),iter_mod-nmemory_mb)
    iter_e=iter_mod-1
    allocate(vecf(1:nl,iter_s:iter_e+1))
    allocate(del_vecf(1:nl,iter_s:iter_e))
    allocate(del_vecx(1:nl,iter_s:iter_e))
    allocate(omega_mb(iter_s:iter_e))
    allocate(beta(iter_s:iter_e,iter_s:iter_e))
    allocate(aa(1:iter_e-iter_s+1,1:iter_e-iter_s+1))
    allocate(aa_tmp1(1:iter_e-iter_s+1,1:iter_e-iter_s+1))
    if(present(icomm)) then
      allocate(ss_tmp1(iter_s:iter_e))
      allocate(ss_tmp2(iter_s:iter_e))
    end if

    vecf(1:nl,iter_s:iter_mod)=vecr_out(1:nl,iter_s:iter_mod)  &
                             -vecr_in(1:nl,iter_s:iter_mod)
    omega_mb(iter_s:iter_e)=1.d0
    do i=iter_s,iter_e
      del_vecx(1:nl,i)=vecr_in(1:nl,i+1)-vecr_in(1:nl,i)
      del_vecf(1:nl,i)=vecf(1:nl,i+1)-vecf(1:nl,i)
    end do

    if(present(icomm)) then
      do i=iter_s,iter_e
        ss_tmp1(i)=sum(del_vecf(1:nl,i)**2)
      end do
      call comm_summation(ss_tmp1,ss_tmp2,iter_e-iter_s+1,icomm)
      do i=iter_s,iter_e
        ss=sqrt(ss_tmp2(i))
        del_vecx(1:nl,i)=del_vecx(1:nl,i)/ss
        del_vecf(1:nl,i)=del_vecf(1:nl,i)/ss
      end do
    else
      do i=iter_s,iter_e
        ss=sum(del_vecf(1:nl,i)**2)
        del_vecx(1:nl,i)=del_vecx(1:nl,i)/ss
        del_vecf(1:nl,i)=del_vecf(1:nl,i)/ss
      end do
    end if

    if(present(icomm)) then
      do i=1,iter_e-iter_s+1
        do j=1,iter_e-iter_s+1
          aa_tmp1(i,j)=sum(del_vecf(1:nl,iter_s-1+i)*del_vecf(1:nl,iter_s-1+j))
        end do
      end do
      call comm_summation(aa_tmp1,aa,(iter_e-iter_s+1)**2,icomm)
      do i=1,iter_e-iter_s+1
        do j=1,iter_e-iter_s+1
          aa(i,j)=omega_mb(iter_s-1+i)*omega_mb(iter_s-1+j)*aa(i,j)
          if(i==j)then
            aa(i,j)=aa(i,j)+omega0**2
          end if
        end do
      end do
    else
      do i=1,iter_e-iter_s+1
        do j=1,iter_e-iter_s+1
          aa(i,j)=omega_mb(iter_s-1+i)*omega_mb(iter_s-1+j)*sum(del_vecf(1:nl,iter_s-1+i)*del_vecf(1:nl,iter_s-1+j))
          if(i==j)then
            aa(i,j)=aa(i,j)+omega0**2
          end if
        end do
      end do
    end if

    call matrix_inverse(aa)

    beta(iter_s:iter_e,iter_s:iter_e)=aa(1:iter_e-iter_s+1,1:iter_e-iter_s+1)
    if(present(icomm)) then
      do i=iter_s,iter_e
        ss_tmp1(i)=sum(del_vecf(:,i)*vecf(:,iter_mod))
      end do
      call comm_summation(ss_tmp1,ss_tmp2,iter_e-iter_s+1,icomm)
      vecr_tmp(1:nl)=0.d0
      do i=iter_s,iter_e
        do j=iter_s,iter_e
          vecr_tmp(1:nl)=vecr_tmp(1:nl)&
              &+omega_mb(i)*omega_mb(j)*beta(i,j)*ss_tmp2(i)*(alpha_mb*del_vecf(1:nl,j)+del_vecx(1:nl,j))
        end do
      end do
    else
      vecr_tmp(1:nl)=0.d0
      do i=iter_s,iter_e
        do j=iter_s,iter_e
          vecr_tmp(1:nl)=vecr_tmp(1:nl)&
              &+omega_mb(i)*omega_mb(j)*beta(i,j)*sum(del_vecf(:,i)*vecf(:,iter_mod))*(alpha_mb*del_vecf(1:nl,j)+del_vecx(1:nl,j))
        end do
      end do
    end if

    vecr_in(1:nl,iter_mod+1)=vecr_in(1:nl,iter_mod)+alpha_mb*vecf(1:nl,iter_mod)-vecr_tmp(1:nl)

    if(present(icomm)) then
      nnegative_tmp=0
      do i=1,nl
        if(vecr_in(i,iter_mod+1) < 0.d0) then
          nnegative_tmp=nnegative_tmp+1
        end if
      end do
      call comm_summation(nnegative_tmp,nnegative,icomm)
    else
      nnegative=0
      do i=1,nl
        if(vecr_in(i,iter_mod+1) < 0.d0) then
          nnegative=nnegative+1
        end if
      end do
    end if
    if(nnegative > 0) then
      vecr_in(1:nl,iter_mod+1)=vecr_in(1:nl,iter_mod)+alpha_mb*vecf(1:nl,iter_mod)
    end if

    deallocate(vecf,del_vecf,del_vecx,omega_mb,beta,aa,aa_tmp1)
    if(present(icomm)) then
      deallocate(ss_tmp1,ss_tmp2)
    end if
  end if
  vecr(1:nl)=vecr_in(1:nl,iter_mod+1)

  return
end subroutine broyden

end module broyden_sub

max_stars_repo_name: shunsuke-sato/SALMON

max_issues_repo_name: shunsuke-sato/SALMON

max_forks_repo_name: shunsuke-sato/SALMON