LCOV - code coverage report
Current view: top level - io - xmlIntWrapFort.f90 (source / functions) Hit Total Coverage
Test: combined.info Lines: 44 78 56.4 %
Date: 2019-09-08 04:53:50 Functions: 8 10 80.0 %

          Line data    Source code
       1             : !--------------------------------------------------------------------------------
       2             : ! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
       3             : ! This file is part of FLEUR and available as free software under the conditions
       4             : ! of the MIT license as expressed in the LICENSE file in more detail.
       5             : !--------------------------------------------------------------------------------
       6             : 
       7             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
       8             : !
       9             : ! Wrapper routines for XML IO - Fortran side
      10             : !
      11             : !                                   GM'16
      12             : !
      13             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      14             : MODULE m_xmlIntWrapFort
      15             : 
      16             : USE m_juDFT
      17             : 
      18             : 
      19             : PRIVATE :: init_from_command_line
      20             : CONTAINS
      21             : 
      22          24 : SUBROUTINE init_from_command_line()
      23             :   IMPLICIT NONE
      24             :   CHARACTER(len=1000)::xpath
      25             :   INTEGER:: i,ii
      26             :   
      27          24 :   IF (judft_was_argument("-xmlXPath")) THEN
      28           0 :      xpath=judft_string_for_argument("-xmlXPath")
      29           0 :      DO WHILE(INDEX(xpath,"=")>0)
      30           0 :         i=INDEX(xpath,"=")
      31           0 :         ii=INDEX(xpath,":")
      32           0 :         IF (ii==0) ii=LEN(TRIM(xpath))+1
      33           0 :         IF (i>100.OR.ii-i>100) CALL judft_error("Too long xmlXPath argument",calledby="xmlIntWarpFort.f90")
      34           0 :         CALL xmlSetAttributeValue(xpath(:i-1),xpath(i+1:ii-1))
      35           0 :         WRITE(*,*) "Set from command line:",TRIM(xpath(:i-1)),"=",TRIM(xpath(i+1:ii-1))
      36           0 :         IF (ii+1<len(xpath))THEN
      37           0 :            xpath=xpath(ii+1:)
      38             :         ELSE
      39           0 :            xpath=""
      40             :         ENDIF
      41             :      END DO
      42             :   END IF
      43          24 : END SUBROUTINE init_from_command_line
      44             :      
      45             : 
      46          24 : SUBROUTINE xmlInitInterface()
      47             : 
      48             :    USE iso_c_binding
      49             :    USE m_types
      50             : 
      51             :    IMPLICIT NONE
      52             : 
      53             :    INTEGER :: errorStatus
      54             : 
      55             :    interface
      56             :       function initializeXMLInterface() bind(C, name="initializeXMLInterface")
      57             :          use iso_c_binding
      58             :          INTEGER(c_int) initializeXMLInterface
      59             :       end function initializeXMLInterface
      60             :    end interface
      61             : 
      62          24 :    errorStatus = 0
      63          24 :    errorStatus = initializeXMLInterface()
      64          24 :    IF(errorStatus.NE.0) THEN
      65           0 :       CALL juDFT_error("Could not initialize XML interface.",calledby="xmlInitInterface")
      66             :    END IF
      67             : 
      68          24 : END SUBROUTINE xmlInitInterface
      69             : 
      70          24 : SUBROUTINE xmlParseSchema(schemaFilename)
      71             : 
      72             :    USE iso_c_binding
      73             :    USE m_types
      74             : 
      75             :    IMPLICIT NONE
      76             : 
      77             :    CHARACTER(LEN=200,KIND=c_char), INTENT(IN) :: schemaFilename
      78             : 
      79             :    INTEGER :: errorStatus
      80             : 
      81             :    interface
      82             :       function parseXMLSchema(schemaFilename) bind(C, name="parseXMLSchema")
      83             :          use iso_c_binding
      84             :          INTEGER(c_int) parseXMLSchema
      85             :          character(kind=c_char) :: schemaFilename(*)
      86             :       end function parseXMLSchema
      87             :    end interface
      88             : 
      89          24 :    errorStatus = 0
      90          24 :    errorStatus = parseXMLSchema(schemaFilename)
      91          24 :    IF(errorStatus.NE.0) THEN
      92           0 :       CALL juDFT_error("XML Schema file not parsable: "//TRIM(ADJUSTL(schemaFilename)),calledby="xmlParseSchema")
      93             :    END IF
      94             : 
      95          24 : END SUBROUTINE xmlParseSchema
      96             : 
      97          24 : SUBROUTINE xmlParseDoc(docFilename)
      98             : 
      99             :    USE iso_c_binding
     100             :    USE m_types
     101             : 
     102             :    IMPLICIT NONE
     103             : 
     104             :    CHARACTER(LEN=200,KIND=c_char), INTENT(IN) :: docFilename
     105             : 
     106             :    INTEGER :: errorStatus
     107             : 
     108             :    interface
     109             :       function parseXMLDocument(docFilename) bind(C, name="parseXMLDocument")
     110             :          use iso_c_binding
     111             :          INTEGER(c_int) parseXMLDocument
     112             :          character(kind=c_char) :: docFilename(*)
     113             :       end function parseXMLDocument
     114             :    end interface
     115             : 
     116          24 :    errorStatus = 0
     117          24 :    errorStatus = parseXMLDocument(docFilename)
     118          24 :    IF(errorStatus.NE.0) THEN
     119           0 :       CALL juDFT_error("XML document file not parsable: "//TRIM(ADJUSTL(docFilename)),calledby="xmlParseDoc")
     120             :    END IF
     121             : 
     122          24 : END SUBROUTINE xmlParseDoc
     123             : 
     124          24 : SUBROUTINE xmlValidateDoc()
     125             : 
     126             :    USE iso_c_binding
     127             :    USE m_types
     128             : 
     129             :    IMPLICIT NONE
     130             : 
     131             :    INTEGER :: errorStatus
     132             : 
     133             :    interface
     134             :       function validateXMLDocument() bind(C, name="validateXMLDocument")
     135             :          use iso_c_binding
     136             :          INTEGER(c_int) validateXMLDocument
     137             :       end function validateXMLDocument
     138             :    end interface
     139             : 
     140          24 :    errorStatus = 0
     141          24 :    errorStatus = validateXMLDocument()
     142          24 :    IF(errorStatus.NE.0) THEN
     143             :       CALL juDFT_error("XML document cannot be validated against Schema.",&
     144           0 :                        calledby="xmlValidateDoc",hint="See hints in lines directly above this error message.")
     145             :    END IF
     146             : 
     147          24 : END SUBROUTINE xmlValidateDoc
     148             : 
     149          24 : SUBROUTINE xmlInitXPath()
     150             : 
     151             :    USE iso_c_binding
     152             :    USE m_types
     153             : 
     154             :    IMPLICIT NONE
     155             : 
     156             :    INTEGER :: errorStatus
     157             : 
     158             :    interface
     159             :       function initializeXPath() bind(C, name="initializeXPath")
     160             :          use iso_c_binding
     161             :          INTEGER(c_int) initializeXPath
     162             :       end function initializeXPath
     163             :    end interface
     164             : 
     165          24 :    errorStatus = 0
     166          24 :    errorStatus = initializeXPath()
     167          24 :    IF(errorStatus.NE.0) THEN
     168           0 :       CALL juDFT_error("Could not initialize XPath.",calledby="xmlInitXPath")
     169             :    END IF
     170          24 :    CALL init_from_command_line()
     171          24 : END SUBROUTINE xmlInitXPath
     172             : 
     173        2160 : FUNCTION xmlGetNumberOfNodes(xPath)
     174             : 
     175             :    USE iso_c_binding
     176             :    USE m_types
     177             : 
     178             :    IMPLICIT NONE
     179             : 
     180             :    INTEGER :: xmlGetNumberOfNodes
     181             :    CHARACTER(LEN=*,KIND=c_char), INTENT(IN) :: xPath
     182             : 
     183             :    interface
     184             :       function getNumberOfXMLNodes(xPathExpression) bind(C, name="getNumberOfXMLNodes")
     185             :          use iso_c_binding
     186             :          INTEGER(c_int) getNumberOfXMLNodes
     187             :          character(kind=c_char) :: xPathExpression(*)
     188             :       end function getNumberOfXMLNodes
     189             :    end interface
     190             : 
     191        2160 :    xmlGetNumberOfNodes = getNumberOfXMLNodes(TRIM(ADJUSTL(xPath))//C_NULL_CHAR)
     192             : 
     193        4320 : END FUNCTION xmlGetNumberOfNodes
     194             : 
     195        2915 : FUNCTION xmlGetAttributeValue(xPath)
     196             : 
     197             :    USE iso_c_binding
     198             :    USE m_types
     199             : 
     200             :    IMPLICIT NONE
     201             : 
     202             :    CHARACTER(LEN=255) :: xmlGetAttributeValue
     203             : 
     204             :    CHARACTER(LEN=*, KIND=c_char), INTENT(IN) :: xPath
     205             : 
     206             :    CHARACTER (LEN=1, KIND=c_char), POINTER, DIMENSION (:) :: valueFromC => null()
     207             :    CHARACTER*255 :: value
     208             :    INTEGER :: length, errorStatus, i
     209             :    TYPE(c_ptr) :: c_string
     210             : 
     211             :    interface
     212             :       function getXMLAttributeValue(xPathExpression) bind(C, name="getXMLAttributeValue")
     213             :          use iso_c_binding
     214             :          CHARACTER(KIND=c_char) :: xPathExpression(*)
     215             :          TYPE(c_ptr) :: getXMLAttributeValue
     216             :       end function getXMLAttributeValue
     217             :    end interface
     218             : 
     219             :   
     220             : 
     221        2915 :    c_string = getXMLAttributeValue(TRIM(ADJUSTL(xPath))//C_NULL_CHAR)
     222             : 
     223        2915 :    CALL C_F_POINTER(c_string, valueFromC, [ 255 ])
     224        2915 :    IF (.NOT.c_associated(c_string)) THEN
     225           0 :       WRITE(*,*) 'Error in trying to obtain attribute value from XPath:'
     226           0 :       WRITE(*,*) TRIM(ADJUSTL(xPath))
     227           0 :       CALL juDFT_error("Attribute value could not be obtained.",calledby="xmlGetAttributeValue")
     228             :    END IF
     229             : 
     230        2915 :    value = ''
     231        2915 :    i = 1
     232       34325 :    DO WHILE ((valueFromC(i).NE.C_NULL_CHAR).AND.(i.LE.255))
     233       15705 :       value(i:i) = valueFromC(i)
     234       15705 :       i = i + 1
     235             :    END DO
     236        2915 :    length = i-1
     237             : 
     238        2915 :    xmlGetAttributeValue = value(1:length)
     239             : 
     240        5830 : END FUNCTION xmlGetAttributeValue
     241             : 
     242             : 
     243           0 : SUBROUTINE xmlSetAttributeValue(xPath,VALUE)
     244             : 
     245             :    USE iso_c_binding
     246             :    USE m_types
     247             : 
     248             :    IMPLICIT NONE
     249             :   
     250             :    CHARACTER(LEN=*, KIND=c_char), INTENT(IN) :: xPath
     251             :    CHARACTER(len=*, KIND=c_char), INTENT(IN) :: value
     252             : 
     253             :    INTEGER :: errorStatus
     254             : 
     255             :    INTERFACE
     256             :       FUNCTION setXMLAttributeValue(xPathExpression,valueExpression) BIND(C, name="setXMLAttributeValue")
     257             :          use iso_c_binding
     258             :          CHARACTER(KIND=c_char) :: xPathExpression(*)
     259             :          CHARACTER(KIND=c_char) :: valueExpression(*)
     260             :          INTEGER(c_int) :: setXMLAttributeValue
     261             :        END FUNCTION setXMLAttributeValue
     262             :     END INTERFACE
     263             : 
     264           0 :     errorStatus = setXMLAttributeValue(TRIM(ADJUSTL(xPath))//C_NULL_CHAR,TRIM(ADJUSTL(VALUE))//C_NULL_CHAR)
     265           0 :     IF (errorStatus.ne.0) THEN
     266           0 :       WRITE(*,*) 'Error in trying to setting attribute value from XPath:'
     267           0 :       WRITE(*,*) TRIM(ADJUSTL(xPath))
     268           0 :       WRITE(*,*) TRIM(ADJUSTL(VALUE))
     269           0 :       CALL juDFT_error("Attribute value could not be set.",calledby="xmlSetAttributeValue")
     270             :    END IF
     271             : 
     272           0 :  END SUBROUTINE xmlSetAttributeValue
     273             : 
     274           0 : SUBROUTINE xmlFreeResources()
     275             : 
     276             :    USE iso_c_binding
     277             :    USE m_types
     278             : 
     279             :    IMPLICIT NONE
     280             : 
     281             :    INTEGER :: errorStatus
     282             : 
     283             :    interface
     284             :       function freeXMLResources() bind(C, name="freeXMLResources")
     285             :          use iso_c_binding
     286             :          INTEGER freeXMLResources
     287             :       end function freeXMLResources
     288             :    end interface
     289             : 
     290           0 :    errorStatus = 0
     291           0 :    errorStatus = freeXMLResources()
     292           0 :    IF(errorStatus.NE.0) THEN
     293           0 :       CALL juDFT_error("Could not free XML resources.",calledby="xmlFreeResources")
     294           0 :       STOP 'Error!'
     295             :    END IF
     296             : 
     297           0 : END SUBROUTINE xmlFreeResources
     298             : 
     299             : END MODULE m_xmlIntWrapFort

Generated by: LCOV version 1.13