types_xml.f90 8.34 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313
!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! Wrapper routines for XML IO - Fortran side
!
!                                   GM'16
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MODULE m_types_xml

  USE m_juDFT

  PRIVATE

  TYPE t_xml
     INTEGER:: id
   CONTAINS
     PROCEDURE,NOPASS :: InitInterface
     PROCEDURE,NOPASS :: ParseSchema
     PROCEDURE,NOPASS :: ParseDoc 
     PROCEDURE,NOPASS :: ValidateDoc 
     PROCEDURE,NOPASS :: InitXPath
     PROCEDURE,NOPASS :: GetNumberOfNodes  
     PROCEDURE,NOPASS :: SetAttributeValue  
     PROCEDURE,NOPASS :: GetAttributeValue  
     PROCEDURE,NOPASS :: FreeResources
  END TYPE t_xml
  PUBLIC t_xml

CONTAINS

  SUBROUTINE init_from_command_line()
    IMPLICIT NONE
    CHARACTER(len=1000)::xpath
    INTEGER:: i,ii

    IF (judft_was_argument("-xmlXPath")) THEN
       xpath=judft_string_for_argument("-xmlXPath")
       DO WHILE(INDEX(xpath,"=")>0)
          i=INDEX(xpath,"=")
          ii=INDEX(xpath,":")
          IF (ii==0) ii=LEN(TRIM(xpath))+1
          IF (i>100.OR.ii-i>100) CALL judft_error("Too long xmlXPath argument",calledby="xmlIntWarpFort.f90")
          CALL SetAttributeValue(xpath(:i-1),xpath(i+1:ii-1))
          WRITE(*,*) "Set from command line:",TRIM(xpath(:i-1)),"=",TRIM(xpath(i+1:ii-1))
          IF (ii+1<LEN(xpath))THEN
             xpath=xpath(ii+1:)
          ELSE
             xpath=""
          ENDIF
       END DO
    END IF
  END SUBROUTINE init_from_command_line


  SUBROUTINE InitInterface()

    USE iso_c_binding
    USE m_types

    IMPLICIT NONE

    INTEGER :: errorStatus

    INTERFACE
       FUNCTION initializeXMLInterface() BIND(C, name="initializeXMLInterface")
         USE iso_c_binding
         INTEGER(c_int) initializeXMLInterface
       END FUNCTION initializeXMLInterface
    END INTERFACE

    errorStatus = 0
    errorStatus = initializeXMLInterface()
    IF(errorStatus.NE.0) THEN
       CALL juDFT_error("Could not initialize XML interface.",calledby="xmlInitInterface")
    END IF

  END SUBROUTINE InitInterface

  SUBROUTINE ParseSchema(schemaFilename)

    USE iso_c_binding
    USE m_types

    IMPLICIT NONE

    CHARACTER(LEN=200,KIND=c_char), INTENT(IN) :: schemaFilename

    INTEGER :: errorStatus

    INTERFACE
       FUNCTION parseXMLSchema(schemaFilename) BIND(C, name="parseXMLSchema")
         USE iso_c_binding
         INTEGER(c_int) parseXMLSchema
         CHARACTER(kind=c_char) :: schemaFilename(*)
       END FUNCTION parseXMLSchema
    END INTERFACE

    errorStatus = 0
    errorStatus = parseXMLSchema(schemaFilename)
    IF(errorStatus.NE.0) THEN
       CALL juDFT_error("XML Schema file not parsable: "//TRIM(ADJUSTL(schemaFilename)),calledby="xmlParseSchema")
    END IF

  END SUBROUTINE ParseSchema

  SUBROUTINE ParseDoc(docFilename)

    USE iso_c_binding
    USE m_types

    IMPLICIT NONE

    CHARACTER(LEN=200,KIND=c_char), INTENT(IN) :: docFilename

    INTEGER :: errorStatus

    INTERFACE
       FUNCTION parseXMLDocument(docFilename) BIND(C, name="parseXMLDocument")
         USE iso_c_binding
         INTEGER(c_int) parseXMLDocument
         CHARACTER(kind=c_char) :: docFilename(*)
       END FUNCTION parseXMLDocument
    END INTERFACE

    errorStatus = 0
    errorStatus = parseXMLDocument(docFilename)
    IF(errorStatus.NE.0) THEN
       CALL juDFT_error("XML document file not parsable: "//TRIM(ADJUSTL(docFilename)),calledby="xmlParseDoc")
    END IF

  END SUBROUTINE ParseDoc

  SUBROUTINE ValidateDoc()

    USE iso_c_binding
    USE m_types

    IMPLICIT NONE

    INTEGER :: errorStatus

    INTERFACE
       FUNCTION validateXMLDocument() BIND(C, name="validateXMLDocument")
         USE iso_c_binding
         INTEGER(c_int) validateXMLDocument
       END FUNCTION validateXMLDocument
    END INTERFACE

    errorStatus = 0
    errorStatus = validateXMLDocument()
    IF(errorStatus.NE.0) THEN
       CALL juDFT_error("XML document cannot be validated against Schema.",calledby="xmlValidateDoc")
    END IF

  END SUBROUTINE ValidateDoc

  SUBROUTINE InitXPath()

    USE iso_c_binding
    USE m_types

    IMPLICIT NONE

    INTEGER :: errorStatus

    INTERFACE
       FUNCTION initializeXPath() BIND(C, name="initializeXPath")
         USE iso_c_binding
         INTEGER(c_int) initializeXPath
       END FUNCTION initializeXPath
    END INTERFACE

    errorStatus = 0
    errorStatus = initializeXPath()
    IF(errorStatus.NE.0) THEN
       CALL juDFT_error("Could not initialize XPath.",calledby="InitXPath")
    END IF
    CALL init_from_command_line()
  END SUBROUTINE InitXPath

  FUNCTION GetNumberOfNodes(xPath)

    USE iso_c_binding
    USE m_types

    IMPLICIT NONE

    INTEGER :: GetNumberOfNodes
    CHARACTER(LEN=*,KIND=c_char), INTENT(IN) :: xPath

    INTERFACE
       FUNCTION getNumberOfXMLNodes(xPathExpression) BIND(C, name="getNumberOfXMLNodes")
         USE iso_c_binding
         INTEGER(c_int) getNumberOfXMLNodes
         CHARACTER(kind=c_char) :: xPathExpression(*)
       END FUNCTION getNumberOfXMLNodes
    END INTERFACE

    GetNumberOfNodes = getNumberOfXMLNodes(TRIM(ADJUSTL(xPath))//C_NULL_CHAR)

  END FUNCTION GetNumberOfNodes

  FUNCTION GetAttributeValue(xPath)

    USE iso_c_binding
    USE m_types

    IMPLICIT NONE

    CHARACTER(LEN=:),ALLOCATABLE :: GetAttributeValue

    CHARACTER(LEN=*, KIND=c_char), INTENT(IN) :: xPath

    CHARACTER (LEN=1, KIND=c_char), POINTER, DIMENSION (:) :: valueFromC => NULL()
    CHARACTER*255 :: VALUE
    INTEGER :: length, errorStatus, i
    TYPE(c_ptr) :: c_string

    INTERFACE
       FUNCTION getXMLAttributeValue(xPathExpression) BIND(C, name="getXMLAttributeValue")
         USE iso_c_binding
         CHARACTER(KIND=c_char) :: xPathExpression(*)
         TYPE(c_ptr) :: getXMLAttributeValue
       END FUNCTION getXMLAttributeValue
    END INTERFACE



    c_string = getXMLAttributeValue(TRIM(ADJUSTL(xPath))//C_NULL_CHAR)

    CALL C_F_POINTER(c_string, valueFromC, [ 255 ])
    IF (.NOT.C_ASSOCIATED(c_string)) THEN
       WRITE(*,*) 'Error in trying to obtain attribute value from XPath:'
       WRITE(*,*) TRIM(ADJUSTL(xPath))
       CALL juDFT_error("Attribute value could not be obtained.",calledby="xmlGetAttributeValue")
    END IF

    VALUE = ''
    i = 1
    DO WHILE ((valueFromC(i).NE.C_NULL_CHAR).AND.(i.LE.255))
       VALUE(i:i) = valueFromC(i)
       i = i + 1
    END DO
    length = i-1

    GetAttributeValue = TRIM(ADJUSTL(VALUE(1:length)))

  END FUNCTION GetAttributeValue


  SUBROUTINE SetAttributeValue(xPath,VALUE)

    USE iso_c_binding
    USE m_types

    IMPLICIT NONE

    CHARACTER(LEN=*, KIND=c_char), INTENT(IN) :: xPath
    CHARACTER(len=*, KIND=c_char), INTENT(IN) :: VALUE

    INTEGER :: errorStatus

    INTERFACE
       FUNCTION setXMLAttributeValue(xPathExpression,valueExpression) BIND(C, name="setXMLAttributeValue")
         USE iso_c_binding
         CHARACTER(KIND=c_char) :: xPathExpression(*)
         CHARACTER(KIND=c_char) :: valueExpression(*)
         INTEGER(c_int) :: setXMLAttributeValue
       END FUNCTION setXMLAttributeValue
    END INTERFACE

    errorStatus = setXMLAttributeValue(TRIM(ADJUSTL(xPath))//C_NULL_CHAR,TRIM(ADJUSTL(VALUE))//C_NULL_CHAR)
    IF (errorStatus.NE.0) THEN
       WRITE(*,*) 'Error in trying to setting attribute value from XPath:'
       WRITE(*,*) TRIM(ADJUSTL(xPath))
       WRITE(*,*) TRIM(ADJUSTL(VALUE))
       CALL juDFT_error("Attribute value could not be set.",calledby="xmlSetAttributeValue")
    END IF

  END SUBROUTINE SetAttributeValue

  SUBROUTINE FreeResources()

    USE iso_c_binding
    USE m_types

    IMPLICIT NONE

    INTEGER :: errorStatus

    INTERFACE
       FUNCTION freeXMLResources() BIND(C, name="freeXMLResources")
         USE iso_c_binding
         INTEGER freeXMLResources
       END FUNCTION freeXMLResources
    END INTERFACE

    errorStatus = 0
    errorStatus = freeXMLResources()
    IF(errorStatus.NE.0) THEN
       CALL juDFT_error("Could not free XML resources.",calledby="xmlFreeResources")
       STOP 'Error!'
    END IF

  END SUBROUTINE FreeResources

END MODULE m_types_xml