crp/OpenMC
1
0
Fork 0
mirror of https://github.com/openmc-dev/openmc.git synced 2026-07-21 14:35:27 -04:00
Code Issues Projects Releases Packages Wiki Activity Actions 5

Replace FoX with pugixml

Browse source
This commit is contained in:
Paul Romano 2017-02-24 15:19:31 -06:00
parent 7927a2d814
commit 25d646d184
20 changed files with 15318 additions and 1098 deletions
Download patch file Download diff file Expand all files Collapse all files

3
.gitmodules vendored
View file

@ -1,3 +0,0 @@
[submodule "src/xml/fox"]
path = src/xml/fox
url = https://github.com/mit-crpg/fox.git

34
CMakeLists.txt
View file

@ -1,5 +1,5 @@
cmake_minimum_required(VERSION 2.8 FATAL_ERROR)
project(openmc Fortran C)
project(openmc Fortran C CXX)
# Setup output directories
set(CMAKE_ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/lib)
@ -225,27 +225,14 @@ if(GIT_SHA1_SUCCESS EQUAL 0)
endif()
#===============================================================================
# FoX Fortran XML Library
# pugixml library
#===============================================================================
# Only initialize git submodules if it is not there. User is responsible
# for future updates of fox xml submodule.
if(NOT EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/src/xml/fox/.git)
if(NOT EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/.git)
message("-- Cloning FoX XML git repository...")
execute_process(COMMAND git clone https://github.com/mit-crpg/fox.git src/xml/fox
WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
execute_process(COMMAND git checkout bdc852f4f43d969fb1b179cba79295c1e095a455
WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/src/xml/fox)
else()
message("-- Initializing/Updating FoX XML submodule...")
execute_process(COMMAND git submodule init
WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
execute_process(COMMAND git submodule update
WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
endif()
endif()
add_subdirectory(src/xml/fox)
add_library(pugixml src/pugixml/pugixml_c.cpp src/pugixml/pugixml.cpp)
set_property(TARGET pugixml PROPERTY CXX_STANDARD 11)
add_library(pugixml_fortran src/pugixml/pugixml_f.F90)
target_link_libraries(pugixml_fortran pugixml)
#===============================================================================
# RPATH information
@ -352,11 +339,12 @@ set(LIBOPENMC_FORTRAN_SRC
src/vector_header.F90
src/volume_calc.F90
src/volume_header.F90
src/xml_interface.F90
src/xml/openmc_fox.F90)
src/xml_interface.F90)
add_library(libopenmc STATIC ${LIBOPENMC_FORTRAN_SRC})
set_target_properties(libopenmc PROPERTIES OUTPUT_NAME openmc)
add_executable(${program} src/main.F90)
set_property(TARGET ${program} libopenmc pugixml_fortran
PROPERTY LINKER_LANGUAGE Fortran)
# target_include_directories was added in CMake 2.8.11 and is the recommended
# way to set include directories. For lesser versions, we revert to set_property
@ -388,7 +376,7 @@ endforeach()
# target_link_libraries treats any arguments starting with - but not -l as
# linker flags. Thus, we can pass both linker flags and libraries together.
target_link_libraries(libopenmc ${ldflags} ${HDF5_LIBRARIES} fox_dom faddeeva)
target_link_libraries(libopenmc ${ldflags} ${HDF5_LIBRARIES} pugixml_fortran faddeeva)
target_link_libraries(${program} ${ldflags} libopenmc)
#===============================================================================

139
src/cmfd_input.F90
View file

@ -61,10 +61,10 @@ contains
logical :: file_exists ! does cmfd.xml exist?
logical :: found
character(MAX_LINE_LEN) :: filename
character(MAX_LINE_LEN) :: temp_str
real(8) :: gs_tol(2)
type(Node), pointer :: doc => null()
type(Node), pointer :: node_mesh => null()
type(XMLDocument) :: doc
type(XMLNode) :: root
type(XMLNode) :: node_mesh
! Read cmfd input file
filename = trim(path_input) // "cmfd.xml"
@ -84,13 +84,14 @@ contains
end if
! Parse cmfd.xml file
call open_xmldoc(doc, filename)
call doc % load_file(filename)
root = doc % document_element()
! Get pointer to mesh XML node
call get_node_ptr(doc, "mesh", node_mesh, found = found)
node_mesh = root % child("mesh")
! Check if mesh is there
if (.not.found) then
if (.not. node_mesh % associated()) then
call fatal_error("No CMFD mesh specified in CMFD XML file.")
end if
@ -99,8 +100,8 @@ contains
! Get number of energy groups
if (check_for_node(node_mesh, "energy")) then
ng = get_arraysize_double(node_mesh, "energy")
if(.not.allocated(cmfd%egrid)) allocate(cmfd%egrid(ng))
ng = node_word_count(node_mesh, "energy")
if(.not. allocated(cmfd%egrid)) allocate(cmfd%egrid(ng))
call get_node_array(node_mesh, "energy", cmfd%egrid)
cmfd % indices(4) = ng - 1 ! sets energy group dimension
! If using MG mode, check to see if these egrid points at least match
@ -137,11 +138,11 @@ contains
if (check_for_node(node_mesh, "map")) then
allocate(cmfd % coremap(cmfd % indices(1), cmfd % indices(2), &
cmfd % indices(3)))
if (get_arraysize_integer(node_mesh, "map") /= &
if (node_word_count(node_mesh, "map") /= &
product(cmfd % indices(1:3))) then
call fatal_error('CMFD coremap not to correct dimensions')
end if
allocate(iarray(get_arraysize_integer(node_mesh, "map")))
allocate(iarray(node_word_count(node_mesh, "map")))
call get_node_array(node_mesh, "map", iarray)
cmfd % coremap = reshape(iarray,(cmfd % indices(1:3)))
cmfd_coremap = .true.
@ -149,71 +150,53 @@ contains
end if
! Check for normalization constant
if (check_for_node(doc, "norm")) then
call get_node_value(doc, "norm", cmfd % norm)
if (check_for_node(root, "norm")) then
call get_node_value(root, "norm", cmfd % norm)
end if
! Set feedback logical
if (check_for_node(doc, "feedback")) then
call get_node_value(doc, "feedback", temp_str)
temp_str = to_lower(temp_str)
if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
cmfd_feedback = .true.
if (check_for_node(root, "feedback")) then
call get_node_value(root, "feedback", cmfd_feedback)
end if
! Set downscatter logical
if (check_for_node(doc, "downscatter")) then
call get_node_value(doc, "downscatter", temp_str)
temp_str = to_lower(temp_str)
if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
cmfd_downscatter = .true.
if (check_for_node(root, "downscatter")) then
call get_node_value(root, "downscatter", cmfd_downscatter)
end if
! Reset dhat parameters
if (check_for_node(doc, "dhat_reset")) then
call get_node_value(doc, "dhat_reset", temp_str)
temp_str = to_lower(temp_str)
if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
dhat_reset = .true.
if (check_for_node(root, "dhat_reset")) then
call get_node_value(root, "dhat_reset", dhat_reset)
end if
! Set monitoring
if (check_for_node(doc, "power_monitor")) then
call get_node_value(doc, "power_monitor", temp_str)
temp_str = to_lower(temp_str)
if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
cmfd_power_monitor = .true.
if (check_for_node(root, "power_monitor")) then
call get_node_value(root, "power_monitor", cmfd_power_monitor)
end if
! Output logicals
if (check_for_node(doc, "write_matrices")) then
call get_node_value(doc, "write_matrices", temp_str)
temp_str = to_lower(temp_str)
if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
cmfd_write_matrices = .true.
if (check_for_node(root, "write_matrices")) then
call get_node_value(root, "write_matrices", cmfd_write_matrices)
end if
! Run an adjoint calc
if (check_for_node(doc, "run_adjoint")) then
call get_node_value(doc, "run_adjoint", temp_str)
temp_str = to_lower(temp_str)
if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
cmfd_run_adjoint = .true.
if (check_for_node(root, "run_adjoint")) then
call get_node_value(root, "run_adjoint", cmfd_run_adjoint)
end if
! Batch to begin cmfd
if (check_for_node(doc, "begin")) &
call get_node_value(doc, "begin", cmfd_begin)
if (check_for_node(root, "begin")) &
call get_node_value(root, "begin", cmfd_begin)
! Check for cmfd tally resets
if (check_for_node(doc, "tally_reset")) then
n_cmfd_resets = get_arraysize_integer(doc, "tally_reset")
if (check_for_node(root, "tally_reset")) then
n_cmfd_resets = node_word_count(root, "tally_reset")
else
n_cmfd_resets = 0
end if
if (n_cmfd_resets > 0) then
allocate(int_array(n_cmfd_resets))
call get_node_array(doc, "tally_reset", int_array)
call get_node_array(root, "tally_reset", int_array)
do i = 1, n_cmfd_resets
call cmfd_reset % add(int_array(i))
end do
@ -221,34 +204,34 @@ contains
end if
! Get display
if (check_for_node(doc, "display")) &
call get_node_value(doc, "display", cmfd_display)
if (check_for_node(root, "display")) &
call get_node_value(root, "display", cmfd_display)
! Read in spectral radius estimate and tolerances
if (check_for_node(doc, "spectral")) &
call get_node_value(doc, "spectral", cmfd_spectral)
if (check_for_node(doc, "shift")) &
call get_node_value(doc, "shift", cmfd_shift)
if (check_for_node(doc, "ktol")) &
call get_node_value(doc, "ktol", cmfd_ktol)
if (check_for_node(doc, "stol")) &
call get_node_value(doc, "stol", cmfd_stol)
if (check_for_node(doc, "gauss_seidel_tolerance")) then
n_params = get_arraysize_double(doc, "gauss_seidel_tolerance")
if (check_for_node(root, "spectral")) &
call get_node_value(root, "spectral", cmfd_spectral)
if (check_for_node(root, "shift")) &
call get_node_value(root, "shift", cmfd_shift)
if (check_for_node(root, "ktol")) &
call get_node_value(root, "ktol", cmfd_ktol)
if (check_for_node(root, "stol")) &
call get_node_value(root, "stol", cmfd_stol)
if (check_for_node(root, "gauss_seidel_tolerance")) then
n_params = node_word_count(root, "gauss_seidel_tolerance")
if (n_params /= 2) then
call fatal_error('Gauss Seidel tolerance is not 2 parameters &
&(absolute, relative).')
end if
call get_node_array(doc, "gauss_seidel_tolerance", gs_tol)
call get_node_array(root, "gauss_seidel_tolerance", gs_tol)
cmfd_atoli = gs_tol(1)
cmfd_rtoli = gs_tol(2)
end if
! Create tally objects
call create_cmfd_tally(doc)
call create_cmfd_tally(root)
! Close CMFD XML file
call close_xmldoc(doc)
call doc % clear()
end subroutine read_cmfd_xml
@ -261,7 +244,7 @@ contains
! 3: Surface current
!===============================================================================
subroutine create_cmfd_tally(doc)
subroutine create_cmfd_tally(root)
use constants, only: MAX_LINE_LEN
use error, only: fatal_error, warning
@ -274,9 +257,8 @@ contains
use tally_initialize, only: add_tallies
use xml_interface
type(Node), pointer :: doc ! pointer to XML doc info
type(XMLNode), intent(in) :: root ! XML root element
character(MAX_LINE_LEN) :: temp_str ! temp string
integer :: i, j ! loop counter
integer :: n ! size of arrays in mesh specification
integer :: ng ! number of energy groups (default 1)
@ -287,7 +269,7 @@ contains
type(TallyObject), pointer :: t
type(RegularMesh), pointer :: m
type(TallyFilterContainer) :: filters(N_FILTER_TYPES) ! temporary filters
type(Node), pointer :: node_mesh
type(XMLNode) :: node_mesh
! Set global variables if they are 0 (this can happen if there is no tally
! file)
@ -304,10 +286,10 @@ contains
m % type = LATTICE_RECT
! Get pointer to mesh XML node
call get_node_ptr(doc, "mesh", node_mesh)
node_mesh = root % child("mesh")
! Determine number of dimensions for mesh
n = get_arraysize_integer(node_mesh, "dimension")
n = node_word_count(node_mesh, "dimension")
if (n /= 2 .and. n /= 3) then
call fatal_error("Mesh must be two or three dimensions.")
end if
@ -330,7 +312,7 @@ contains
m % dimension = iarray3(1:n)
! Read mesh lower-left corner location
if (m % n_dimension /= get_arraysize_double(node_mesh, "lower_left")) then
if (m % n_dimension /= node_word_count(node_mesh, "lower_left")) then
call fatal_error("Number of entries on <lower_left> must be the same as &
&the number of entries on <dimension>.")
end if
@ -352,8 +334,8 @@ contains
if (check_for_node(node_mesh, "width")) then
! Check to ensure width has same dimensions
if (get_arraysize_double(node_mesh, "width") /= &
get_arraysize_double(node_mesh, "lower_left")) then
if (node_word_count(node_mesh, "width") /= &
node_word_count(node_mesh, "lower_left")) then
call fatal_error("Number of entries on <width> must be the same as the &
&number of entries on <lower_left>.")
end if
@ -370,8 +352,8 @@ contains
elseif (check_for_node(node_mesh, "upper_right")) then
! Check to ensure width has same dimensions
if (get_arraysize_double(node_mesh, "upper_right") /= &
get_arraysize_double(node_mesh, "lower_left")) then
if (node_word_count(node_mesh, "upper_right") /= &
node_word_count(node_mesh, "lower_left")) then
call fatal_error("Number of entries on <upper_right> must be the same &
&as the number of entries on <lower_left>.")
end if
@ -404,11 +386,8 @@ contains
t => cmfd_tallies(i)
! Set reset property
if (check_for_node(doc, "reset")) then
call get_node_value(doc, "reset", temp_str)
temp_str = to_lower(temp_str)
if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
t % reset = .true.
if (check_for_node(root, "reset")) then
call get_node_value(root, "reset", t % reset)
end if
! Set up mesh filter
@ -427,7 +406,7 @@ contains
allocate(EnergyFilter :: filters(n_filters) % obj)
select type (filt => filters(n_filters) % obj)
type is (EnergyFilter)
ng = get_arraysize_double(node_mesh, "energy")
ng = node_word_count(node_mesh, "energy")
filt % n_bins = ng - 1
allocate(filt % bins(ng))
call get_node_array(node_mesh, "energy", filt % bins)
@ -492,7 +471,7 @@ contains
allocate(EnergyoutFilter :: filters(n_filters) % obj)
select type (filt => filters(n_filters) % obj)
type is (EnergyoutFilter)
ng = get_arraysize_double(node_mesh, "energy")
ng = node_word_count(node_mesh, "energy")
filt % n_bins = ng - 1
allocate(filt % bins(ng))
call get_node_array(node_mesh, "energy", filt % bins)

5
src/distribution_univariate.F90
View file

@ -5,6 +5,7 @@ module distribution_univariate
use error, only: fatal_error
use random_lcg, only: prn
use math, only: maxwell_spectrum, watt_spectrum
use pugixml
use string, only: to_lower
use xml_interface
@ -265,7 +266,7 @@ contains
subroutine distribution_from_xml(dist, node_dist)
class(Distribution), allocatable, intent(inout) :: dist
type(Node), pointer :: node_dist
type(XMLNode), intent(in) :: node_dist
character(MAX_WORD_LEN) :: type
character(MAX_LINE_LEN) :: temp_str
@ -279,7 +280,7 @@ contains
! Determine number of parameters specified
if (check_for_node(node_dist, "parameters")) then
n = get_arraysize_double(node_dist, "parameters")
n = node_word_count(node_dist, "parameters")
else
n = 0
end if

674
src/input_xml.F90
View file

File diff suppressed because it is too large Load diff

1
src/nuclide_header.F90
View file

@ -23,7 +23,6 @@ module nuclide_header
use stl_vector, only: VectorInt, VectorReal
use string
use urr_header, only: UrrData
use xml_interface
implicit none

74
src/pugixml/pugiconfig.hpp Normal file
View file

@ -0,0 +1,74 @@
/**
* pugixml parser - version 1.8
* --------------------------------------------------------
* Copyright (C) 2006-2016, by Arseny Kapoulkine (arseny.kapoulkine@gmail.com)
* Report bugs and download new versions at http://pugixml.org/
*
* This library is distributed under the MIT License. See notice at the end
* of this file.
*
* This work is based on the pugxml parser, which is:
* Copyright (C) 2003, by Kristen Wegner (kristen@tima.net)
*/
#ifndef HEADER_PUGICONFIG_HPP
#define HEADER_PUGICONFIG_HPP
// Uncomment this to enable wchar_t mode
// #define PUGIXML_WCHAR_MODE
// Uncomment this to enable compact mode
// #define PUGIXML_COMPACT
// Uncomment this to disable XPath
// #define PUGIXML_NO_XPATH
// Uncomment this to disable STL
// #define PUGIXML_NO_STL
// Uncomment this to disable exceptions
// #define PUGIXML_NO_EXCEPTIONS
// Set this to control attributes for public classes/functions, i.e.:
// #define PUGIXML_API __declspec(dllexport) // to export all public symbols from DLL
// #define PUGIXML_CLASS __declspec(dllimport) // to import all classes from DLL
// #define PUGIXML_FUNCTION __fastcall // to set calling conventions to all public functions to fastcall
// In absence of PUGIXML_CLASS/PUGIXML_FUNCTION definitions PUGIXML_API is used instead
// Tune these constants to adjust memory-related behavior
// #define PUGIXML_MEMORY_PAGE_SIZE 32768
// #define PUGIXML_MEMORY_OUTPUT_STACK 10240
// #define PUGIXML_MEMORY_XPATH_PAGE_SIZE 4096
// Uncomment this to switch to header-only version
// #define PUGIXML_HEADER_ONLY
// Uncomment this to enable long long support
// #define PUGIXML_HAS_LONG_LONG
#endif
/**
* Copyright (c) 2006-2016 Arseny Kapoulkine
*
* Permission is hereby granted, free of charge, to any person
* obtaining a copy of this software and associated documentation
* files (the "Software"), to deal in the Software without
* restriction, including without limitation the rights to use,
* copy, modify, merge, publish, distribute, sublicense, and/or sell
* copies of the Software, and to permit persons to whom the
* Software is furnished to do so, subject to the following
* conditions:
*
* The above copyright notice and this permission notice shall be
* included in all copies or substantial portions of the Software.
*
* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
* EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
* OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
* NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
* HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
* WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
* OTHER DEALINGS IN THE SOFTWARE.
*/

12622
src/pugixml/pugixml.cpp Normal file
View file

File diff suppressed because it is too large Load diff

1434
src/pugixml/pugixml.hpp Normal file
View file

File diff suppressed because it is too large Load diff

1
src/pugixml/pugixml_c.cpp Normal file
View file

@ -0,0 +1 @@
#include "pugixml_c.hpp"

97
src/pugixml/pugixml_c.hpp Normal file
View file

@ -0,0 +1,97 @@
#include <cstring>
#include "pugixml.hpp"
using namespace pugi;
extern "C" {
// xml_node functions
const char* xml_node_name(xml_node_struct* node){
return xml_node(node).name();
}
xml_node_struct* xml_node_child(xml_node_struct* node, char* name){
return xml_node(node).child(name).internal_object();
}
xml_node_struct* xml_node_next_sibling(xml_node_struct* node, char* name){
return xml_node(node).next_sibling(name).internal_object();
}
xml_attribute_struct* xml_node_attribute(xml_node_struct* node, char* name){
return xml_node(node).attribute(name).internal_object();
}
const char* xml_node_child_value(xml_node_struct* node){
return xml_node(node).child_value();
}
xml_node_struct* xml_node_text(xml_node_struct* node){
return xml_node(node).internal_object();
}
// xml_attribute functions
const char* xml_attribute_name(xml_attribute_struct* attribute){
return xml_attribute(attribute).name();
}
const char* xml_attribute_value(xml_attribute_struct* attribute){
return xml_attribute(attribute).value();
}
xml_attribute_struct* xml_attribute_next_attribute(xml_attribute_struct* attribute){
return xml_attribute(attribute).next_attribute().internal_object();
}
bool xml_attribute_as_bool(xml_attribute_struct* attribute){
return xml_attribute(attribute).as_bool();
}
int xml_attribute_as_int(xml_attribute_struct* attribute){
return xml_attribute(attribute).as_int();
}
long long xml_attribute_as_llong(xml_attribute_struct* attribute){
return xml_attribute(attribute).as_llong();
}
double xml_attribute_as_double(xml_attribute_struct* attribute){
return xml_attribute(attribute).as_double();
}
// xml_text functions
bool xml_text_as_bool(xml_node_struct* node){
return xml_node(node).text().as_bool();
}
int xml_text_as_int(xml_node_struct* node){
return xml_node(node).text().as_int();
}
long long xml_text_as_llong(xml_node_struct* node){
return xml_node(node).text().as_llong();
}
double xml_text_as_double(xml_node_struct* node){
return xml_node(node).text().as_double();
}
// xml_document functions
xml_document* xml_document_load_file(char* filename){
xml_document * doc = new xml_document();
xml_parse_result result = doc->load_file(filename);
return doc;
}
xml_node_struct* xml_document_document_element(xml_document* doc){
return doc->document_element().internal_object();
}
void xml_document_clear(xml_document* doc){
delete doc;
}
}

451
src/pugixml/pugixml_f.F90 Normal file
View file

@ -0,0 +1,451 @@
module pugixml
use, intrinsic :: ISO_C_BINDING
implicit none
private
interface
function strlen(str) result(sz) bind(C)
import C_PTR, C_SIZE_T
type(C_PTR), value :: str
integer(C_SIZE_T) :: sz
end function strlen
end interface
!=============================================================================
! XMLNode C interface and derived type
interface
function xml_node_name(node) result(name) bind(C)
import C_PTR
type(C_PTR), value :: node
type(C_PTR) :: name
end function xml_node_name
function xml_node_name_size(base) result(sz) bind(C)
import C_PTR, C_SIZE_T
type(C_PTR), value :: base
integer(C_SIZE_T) :: sz
end function xml_node_name_size
function xml_node_child(node, name) result(child) bind(C)
import C_PTR
type(C_PTR), value :: node
type(C_PTR), value :: name
type(C_PTR) :: child
end function xml_node_child
function xml_node_next_sibling(node, name) result(next) bind(C)
import C_PTR
type(C_PTR), value :: node
type(C_PTR), value :: name
type(C_PTR) :: next
end function xml_node_next_sibling
function xml_node_attribute(node, name) result(attribute) bind(C)
import C_PTR
type(C_PTR), value :: node
type(C_PTR), value :: name
type(C_PTR) :: attribute
end function xml_node_attribute
function xml_node_child_value(node) result(val) bind(C)
import C_PTR
type(C_PTR), value :: node
type(C_PTR) :: val
end function xml_node_child_value
function xml_node_text(node) result(text) bind(C)
import C_PTR
type(C_PTR), value :: node
type(C_PTR) :: text
end function xml_node_text
end interface
type :: XMLNode
type(C_PTR) :: ptr
contains
procedure :: name => xmlnode_name
procedure :: child => xmlnode_child
procedure :: next_sibling => xmlnode_next_sibling
procedure :: attribute => xmlnode_attribute
procedure :: child_value => xmlnode_child_value
procedure :: text => xmlnode_text
procedure :: associated => xmlnode_associated
end type XMLNode
!=============================================================================
! XMLAttribute C interface and derived type
interface
function xml_attribute_name(attribute) result(name) bind(C)
import C_PTR
type(C_PTR), value :: attribute
type(C_PTR) :: name
end function xml_attribute_name
function xml_attribute_name_size(base) result(sz) bind(C)
import C_PTR, C_SIZE_T
type(C_PTR), value :: base
integer(C_SIZE_T) :: sz
end function xml_attribute_name_size
function xml_attribute_value(attribute) result(val) bind(C)
import C_PTR
type(C_PTR), value :: attribute
type(C_PTR) :: val
end function xml_attribute_value
function xml_attribute_next_attribute(attribute) result(next) bind(C)
import C_PTR
type(C_PTR), value :: attribute
type(C_PTR) :: next
end function xml_attribute_next_attribute
function xml_attribute_as_bool(attribute) result(x) bind(C)
import C_PTR, C_BOOL
type(C_PTR), value :: attribute
logical(C_BOOL) :: x
end function xml_attribute_as_bool
function xml_attribute_as_int(attribute) result(x) bind(C)
import C_PTR, C_INT
type(C_PTR), value :: attribute
integer(C_INT) :: x
end function xml_attribute_as_int
function xml_attribute_as_llong(attribute) result(x) bind(C)
import C_PTR, C_LONG_LONG
type(C_PTR), value :: attribute
integer(C_LONG_LONG) :: x
end function xml_attribute_as_llong
function xml_attribute_as_double(attribute) result(x) bind(C)
import C_PTR, C_DOUBLE
type(C_PTR), value :: attribute
real(C_DOUBLE) :: x
end function xml_attribute_as_double
end interface
type :: XMLAttribute
type(C_PTR) :: ptr
contains
procedure :: name => xmlattribute_name
procedure :: value => xmlattribute_value
procedure :: next_attribute => xmlattribute_next_attribute
procedure :: as_bool => xmlattribute_as_bool
procedure :: as_int => xmlattribute_as_int
procedure :: as_llong => xmlattribute_as_llong
procedure :: as_double => xmlattribute_as_double
procedure :: associated => xmlattribute_associated
end type XMLAttribute
!=============================================================================
! XMLText C interface and derived type
interface
function xml_text_as_bool(text) result(x) bind(C)
import C_PTR, C_BOOL
type(C_PTR), value :: text
logical(C_BOOL) :: x
end function xml_text_as_bool
function xml_text_as_int(text) result(x) bind(C)
import C_PTR, C_INT
type(C_PTR), value :: text
integer(C_INT) :: x
end function xml_text_as_int
function xml_text_as_llong(text) result(x) bind(C)
import C_PTR, C_LONG_LONG
type(C_PTR), value :: text
integer(C_LONG_LONG) :: x
end function xml_text_as_llong
function xml_text_as_double(text) result(x) bind(C)
import C_PTR, C_DOUBLE
type(C_PTR), value :: text
real(C_DOUBLE) :: x
end function xml_text_as_double
end interface
type :: XMLText
type(C_PTR) :: ptr
contains
procedure :: as_bool => xmltext_as_bool
procedure :: as_int => xmltext_as_int
procedure :: as_llong => xmltext_as_llong
procedure :: as_double => xmltext_as_double
end type XMLText
!=============================================================================
! XMLDocument C interface and derived type
interface
function xml_document_load_file(filename) result(doc) bind(C)
import C_PTR
type(C_PTR), value :: filename
type(C_PTR) :: doc
end function xml_document_load_file
function xml_document_document_element(doc) result(node) bind(C)
import C_PTR
type(C_PTR), value :: doc
type(C_PTR) :: node
end function xml_document_document_element
subroutine xml_document_clear(doc) bind(C)
import C_PTR
type(C_PTR), value :: doc
end subroutine xml_document_clear
end interface
type, extends(XMLNode) :: XMLDocument
contains
procedure :: load_file => xmldocument_load_file
procedure :: document_element => xmldocument_document_element
procedure :: clear => xmldocument_clear
end type XMLDocument
public :: XMLNode, XMLAttribute, XMLText, XMLDocument
contains
!=============================================================================
! XMLNode Implementation
function xmlnode_name(this) result(name)
class(XMLNode), intent(in) :: this
character(len=:, kind=C_CHAR), allocatable :: name
character(kind=C_CHAR), pointer :: string(:)
integer(C_SIZE_T) :: size_string
integer(C_SIZE_T) :: i
type(C_PTR) :: name_ptr
name_ptr = xml_node_name(this%ptr)
size_string = strlen(name_ptr)
call c_f_pointer(name_ptr, string, [size_string])
allocate(character(len=size_string, kind=C_CHAR) :: name)
do i = 1, size_string
name(i:i) = string(i)
end do
end function xmlnode_name
function xmlnode_child(this, name) result(child)
class(XMLNode), intent(in) :: this
character(len=*), optional :: name
type(XMLNode) :: child
integer :: i, n
character(len=:, kind=C_CHAR), target, allocatable :: string
if (present(name)) then
allocate(character(len=len_trim(name) + 1, kind=C_CHAR) :: string)
n = len_trim(name)
do i = 1, n
string(i:i) = name(i:i)
end do
string(n+1:n+1) = C_NULL_CHAR
child%ptr = xml_node_child(this%ptr, c_loc(string))
else
child%ptr = xml_node_child(this%ptr, C_NULL_PTR)
end if
end function xmlnode_child
function xmlnode_next_sibling(this, name) result(next)
class(XMLNode), intent(in) :: this
character(len=*), optional :: name
type(XMLNode) :: next
integer :: i, n
character(len=:, kind=C_CHAR), target, allocatable :: string
if (present(name)) then
allocate(character(len=len_trim(name) + 1, kind=C_CHAR) :: string)
n = len_trim(name)
do i = 1, n
string(i:i) = name(i:i)
end do
string(n+1:n+1) = C_NULL_CHAR
next%ptr = xml_node_next_sibling(this%ptr, c_loc(string))
else
next%ptr = xml_node_next_sibling(this%ptr, C_NULL_PTR)
end if
end function xmlnode_next_sibling
function xmlnode_attribute(this, name) result(attribute)
class(XMLNode), intent(in) :: this
character(len=*), intent(in) :: name
type(XMLAttribute) :: attribute
integer :: i, n
character(kind=C_CHAR), target :: string(len_trim(name) + 1)
n = len_trim(name)
do i = 1, n
string(i) = name(i:i)
end do
string(n+1) = C_NULL_CHAR
attribute%ptr = xml_node_attribute(this%ptr, c_loc(string))
end function xmlnode_attribute
function xmlnode_child_value(this) result(val)
class(XMLNode), intent(in) :: this
character(len=:, kind=C_CHAR), allocatable :: val
character(kind=C_CHAR), pointer :: string(:)
integer(C_SIZE_T) :: size_string
integer(C_SIZE_T) :: i
type(C_PTR) :: text
text = xml_node_child_value(this%ptr)
size_string = strlen(text)
call c_f_pointer(text, string, [size_string])
allocate(character(len=size_string, kind=C_CHAR) :: val)
do i = 1, size_string
val(i:i) = string(i)
end do
end function xmlnode_child_value
function xmlnode_text(this) result(text)
class(XMLNode), intent(in) :: this
type(XMLText) :: text
text%ptr = xml_node_text(this%ptr)
end function xmlnode_text
logical function xmlnode_associated(this)
class(XMLNode), intent(in) :: this
xmlnode_associated = c_associated(this%ptr)
end function xmlnode_associated
!=============================================================================
! XMLAttribute Implementation
function xmlattribute_name(this) result(name)
class(XMLAttribute), intent(in) :: this
character(len=:, kind=C_CHAR), allocatable :: name
character(kind=C_CHAR), pointer :: string(:)
integer(C_SIZE_T) :: size_string
integer(C_SIZE_T) :: i
type(C_PTR) :: name_ptr
name_ptr = xml_attribute_name(this%ptr)
size_string = strlen(name_ptr)
call c_f_pointer(name_ptr, string, [size_string])
allocate(character(len=size_string, kind=C_CHAR) :: name)
do i = 1, size_string
name(i:i) = string(i)
end do
end function xmlattribute_name
function xmlattribute_value(this) result(val)
class(XMLAttribute), intent(in) :: this
character(len=:, kind=C_CHAR), allocatable :: val
character(kind=C_CHAR), pointer :: string(:)
integer(C_SIZE_T) :: size_string
integer(C_SIZE_T) :: i
type(C_PTR) :: val_ptr
val_ptr = xml_attribute_value(this%ptr)
size_string = strlen(val_ptr)
call c_f_pointer(val_ptr, string, [size_string])
allocate(character(len=size_string, kind=C_CHAR) :: val)
do i = 1, size_string
val(i:i) = string(i)
end do
end function xmlattribute_value
function xmlattribute_next_attribute(this) result(next)
class(XMLAttribute), intent(in) :: this
type(XMLAttribute) :: next
next%ptr = xml_attribute_next_attribute(this%ptr)
end function xmlattribute_next_attribute
logical(C_BOOL) function xmlattribute_as_bool(this)
class(XMLAttribute), intent(in) :: this
xmlattribute_as_bool = xml_attribute_as_bool(this%ptr)
end function xmlattribute_as_bool
integer(C_INT) function xmlattribute_as_int(this)
class(XMLAttribute), intent(in) :: this
xmlattribute_as_int = xml_attribute_as_int(this%ptr)
end function xmlattribute_as_int
integer(C_LONG_LONG) function xmlattribute_as_llong(this)
class(XMLAttribute), intent(in) :: this
xmlattribute_as_llong = xml_attribute_as_llong(this%ptr)
end function xmlattribute_as_llong
real(C_DOUBLE) function xmlattribute_as_double(this)
class(XMLAttribute), intent(in) :: this
xmlattribute_as_double = xml_attribute_as_double(this%ptr)
end function xmlattribute_as_double
logical function xmlattribute_associated(this)
class(XMLAttribute), intent(in) :: this
xmlattribute_associated = c_associated(this%ptr)
end function xmlattribute_associated
!=============================================================================
! XMLText Implementation
logical(C_BOOL) function xmltext_as_bool(this)
class(XMLText), intent(in) :: this
xmltext_as_bool = xml_text_as_bool(this%ptr)
end function xmltext_as_bool
integer(C_INT) function xmltext_as_int(this)
class(XMLText), intent(in) :: this
xmltext_as_int = xml_text_as_int(this%ptr)
end function xmltext_as_int
integer(C_LONG_LONG) function xmltext_as_llong(this)
class(XMLText), intent(in) :: this
xmltext_as_llong = xml_text_as_llong(this%ptr)
end function xmltext_as_llong
real(C_DOUBLE) function xmltext_as_double(this)
class(XMLText), intent(in) :: this
xmltext_as_double = xml_text_as_double(this%ptr)
end function xmltext_as_double
!=============================================================================
! XMLDocument Implementation
subroutine xmldocument_load_file(this, filename)
class(XMLDocument), intent(inout) :: this
character(*), intent(in) :: filename
integer :: i, n
character(kind=C_CHAR), target :: string(len_trim(filename) + 1)
n = len_trim(filename)
do i = 1, n
string(i) = filename(i:i)
end do
string(n+1) = C_NULL_CHAR
this%ptr = xml_document_load_file(c_loc(string))
end subroutine xmldocument_load_file
function xmldocument_document_element(this) result(node)
class(XMLDocument), intent(in) :: this
type(XMLNode) :: node
node%ptr = xml_document_document_element(this%ptr)
end function xmldocument_document_element
subroutine xmldocument_clear(this)
class(XMLDocument), intent(inout) :: this
call xml_document_clear(this%ptr)
end subroutine xmldocument_clear
end module pugixml

32
src/string.F90
View file

@ -1,5 +1,7 @@
module string
use, intrinsic :: ISO_C_BINDING
use constants, only: MAX_WORDS, MAX_LINE_LEN, ERROR_INT, ERROR_REAL, &
OP_LEFT_PAREN, OP_RIGHT_PAREN, OP_COMPLEMENT, OP_INTERSECTION, OP_UNION
use error, only: fatal_error, warning
@ -482,4 +484,34 @@ contains
end function real_to_str
!===============================================================================
! WORD_COUNT determines the number of words in a string
!===============================================================================
function word_count(str) result(n)
character(*), intent(in) :: str
integer :: n
integer :: i
character(kind=C_CHAR) :: chr
logical :: inword
! Count number of words
inword = .false.
n = 0
do i = 1, len_trim(str)
chr = str(i:i)
select case (chr)
case (' ', C_HORIZONTAL_TAB, C_NEW_LINE, C_CARRIAGE_RETURN)
if (inword) then
inword = .false.
n = n + 1
end if
case default
inword = .true.
end select
end do
if (inword) n = n + 1
end function word_count
end module string

4
src/volume_header.F90
View file

@ -20,7 +20,7 @@ contains
subroutine volume_from_xml(this, node_vol)
class(VolumeCalculation), intent(out) :: this
type(Node), pointer :: node_vol
type(XMLNode), intent(in) :: node_vol
integer :: num_domains
character(10) :: temp_str
@ -41,7 +41,7 @@ contains
! Read cell IDs
if (check_for_node(node_vol, "domain_ids")) then
num_domains = get_arraysize_integer(node_vol, "domain_ids")
num_domains = node_word_count(node_vol, "domain_ids")
else
call fatal_error("Must specify at least one cell for a volume calculation")
end if

1
src/xml/fox

@ -1 +0,0 @@
Subproject commit bdc852f4f43d969fb1b179cba79295c1e095a455

194
src/xml/openmc_fox.F90
View file

@ -1,194 +0,0 @@
module openmc_fox
use fox_m_fsys_array_str, only: str_vs, vs_str, vs_str_alloc
use fox_m_fsys_format, only: operator(//)
use fox_m_fsys_string, only: toLower
use fox_m_utils_uri, only: URI, parseURI, destroyURI, isAbsoluteURI, &
rebaseURI, expressURI
use m_common_charset, only: checkChars, XML1_0, XML1_1
use m_common_element, only: element_t, get_element, attribute_t, &
attribute_has_default, get_attribute_declaration, get_attlist_size
use m_common_namecheck, only: checkQName, prefixOfQName, localPartOfQName, &
checkName, checkPublicId, checkNCName
use m_common_struct, only: xml_doc_state, init_xml_doc_state, destroy_xml_doc_state
use m_dom_error, only: DOMException, throw_exception, inException, getExceptionCode, &
NO_MODIFICATION_ALLOWED_ERR, NOT_FOUND_ERR, HIERARCHY_REQUEST_ERR, &
WRONG_DOCUMENT_ERR, FoX_INTERNAL_ERROR, FoX_NODE_IS_NULL, FoX_LIST_IS_NULL, &
INUSE_ATTRIBUTE_ERR, FoX_MAP_IS_NULL, INVALID_CHARACTER_ERR, NAMESPACE_ERR, &
FoX_INVALID_PUBLIC_ID, FoX_INVALID_SYSTEM_ID, FoX_IMPL_IS_NULL, FoX_INVALID_NODE, &
FoX_INVALID_CHARACTER, FoX_INVALID_COMMENT, FoX_INVALID_CDATA_SECTION, &
FoX_INVALID_PI_DATA, NOT_SUPPORTED_ERR, FoX_INVALID_ENTITY, &
INDEX_SIZE_ERR, FoX_NO_SUCH_ENTITY, FoX_HIERARCHY_REQUEST_ERR, &
FoX_INVALID_URI
use m_dom_dom
use fox_dom
use fox_m_fsys_count_parse_input, only: countrts
implicit none
contains
function getChildrenByTagName(doc, tagName, name, ex)result(list)
type(DOMException), intent(out), optional :: ex
type(Node), pointer :: doc
character(len=*), intent(in), optional :: tagName, name
type(NodeList), pointer :: list
type(NodeListPtr), pointer :: nll(:), temp_nll(:)
type(Node), pointer :: arg, this, treeroot
logical :: doneChildren, doneAttributes, allElements
integer :: i, i_tree
list => null()
if (.not.associated(doc)) then
if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then
call throw_exception(FoX_NODE_IS_NULL, "getElementsByTagName", ex)
if (present(ex)) then
if (inException(ex)) then
return
endif
endif
endif
endif
if (doc%nodeType==DOCUMENT_NODE) then
if (present(name).or..not.present(tagName)) then
if (getFoX_checks().or.FoX_INVALID_NODE<200) then
call throw_exception(FoX_INVALID_NODE, "getElementsByTagName", ex)
if (present(ex)) then
if (inException(ex)) then
return
endif
endif
endif
endif
elseif (doc%nodeType==ELEMENT_NODE) then
if (present(name).or..not.present(tagName)) then
if (getFoX_checks().or.FoX_INVALID_NODE<200) then
call throw_exception(FoX_INVALID_NODE, "getElementsByTagName", ex)
if (present(ex)) then
if (inException(ex)) then
return
endif
endif
endif
endif
else
if (getFoX_checks().or.FoX_INVALID_NODE<200) then
call throw_exception(FoX_INVALID_NODE, "getElementsByTagName", ex)
if (present(ex)) then
if (inException(ex)) then
return
endif
endif
endif
endif
if (doc%nodeType==DOCUMENT_NODE) then
arg => getDocumentElement(doc)
else
arg => doc
endif
allocate(list)
allocate(list%nodes(0))
list%element => doc
if (present(name)) list%nodeName => vs_str_alloc(name)
if (present(tagName)) list%nodeName => vs_str_alloc(tagName)
allElements = (str_vs(list%nodeName)=="*")
if (doc%nodeType==DOCUMENT_NODE) then
nll => doc%docExtras%nodelists
elseif (doc%nodeType==ELEMENT_NODE) then
nll => doc%ownerDocument%docExtras%nodelists
endif
allocate(temp_nll(size(nll)+1))
do i = 1, size(nll)
temp_nll(i)%this => nll(i)%this
enddo
temp_nll(i)%this => list
deallocate(nll)
if (doc%nodeType==DOCUMENT_NODE) then
doc%docExtras%nodelists => temp_nll
elseif (doc%nodeType==ELEMENT_NODE) then
doc%ownerDocument%docExtras%nodelists => temp_nll
endif
treeroot => arg
i_tree = 0
doneChildren = .false.
doneAttributes = .false.
this => treeroot
do
if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then
if (this%nodeType==ELEMENT_NODE) then
if ((allElements .or. str_vs(this%nodeName)==tagName) &
.and..not.(getNodeType(doc)==ELEMENT_NODE.and.associated(this, arg))) &
call append(list, this)
doneAttributes = .true.
endif
else
if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then
doneAttributes = .true.
else
endif
endif
if (.not.doneChildren) then
if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then
if (getLength(getAttributes(this))>0) then
this => item(getAttributes(this), 0)
else
doneAttributes = .true.
endif
elseif (hasChildNodes(this) .and. .not. associated(getParentNode(this), treeroot)) then
this => getFirstChild(this)
doneChildren = .false.
doneAttributes = .false.
else
doneChildren = .true.
doneAttributes = .false.
endif
else ! if doneChildren
if (associated(this, treeroot)) exit
if (getNodeType(this)==ATTRIBUTE_NODE) then
if (i_tree<getLength(getAttributes(getOwnerElement(this)))-1) then
i_tree= i_tree+ 1
this => item(getAttributes(getOwnerElement(this)), i_tree)
doneChildren = .false.
else
i_tree= 0
this => getOwnerElement(this)
doneAttributes = .true.
doneChildren = .false.
endif
elseif (associated(getNextSibling(this))) then
this => getNextSibling(this)
doneChildren = .false.
doneAttributes = .false.
else
this => getParentNode(this)
endif
endif
enddo
end function getChildrenByTagName
end module openmc_fox

638
src/xml_interface.F90
View file

@ -1,30 +1,22 @@
module xml_interface
use constants, only: MAX_LINE_LEN
use error, only: fatal_error
use openmc_fox
use, intrinsic :: ISO_C_BINDING
use error, only: fatal_error
use pugixml
use string, only: word_count
implicit none
private
public :: Node
public :: NodeList
public :: open_xmldoc
public :: close_xmldoc
public :: XMLDocument, XMLNode, XMLText, XMLAttribute
public :: check_for_node
public :: get_node_ptr
public :: get_node_list
public :: get_list_size
public :: get_list_item
public :: get_node_value
public :: get_node_array
public :: get_arraysize_integer
public :: get_arraysize_double
public :: get_arraysize_string
integer, parameter :: ATTR_NODE = 0
integer, parameter :: ELEM_NODE = 1
public :: node_word_count
interface get_node_value
module procedure get_node_value_bool
module procedure get_node_value_integer
module procedure get_node_value_long
module procedure get_node_value_double
@ -39,493 +31,301 @@ module xml_interface
contains
!===============================================================================
! OPEN_XMLDOC opens and parses an XML and returns a pointer to the document
!===============================================================================
subroutine open_xmldoc(ptr, filename)
character(len=*) :: filename
type(Node), pointer :: ptr
ptr => parseFile(trim(filename)) ! Pointer to the whole XML document
ptr => getDocumentElement(ptr) ! Grabs root element of XML document
end subroutine open_xmldoc
!===============================================================================
! CLOSE_XMLDOC closes and destroys all memory associated with document
!===============================================================================
subroutine close_xmldoc(ptr)
type(Node), pointer :: ptr
ptr => getParentNode(ptr) ! Go from root element ptr to document ptr
call destroy(ptr) ! Deallocates all nodes recursively
end subroutine close_xmldoc
!===============================================================================
! CHECK_FOR_NODE checks for an attribute or sub-element node with the given
! node name. This should only be used for checking a single occurance of a
! sub-element node. To check for sub-element nodes that repeat, use
! get_node_list and get_list_size. This is to minimize number of calls
! to getChildrenByTagName.
! sub-element node.
!===============================================================================
function check_for_node(ptr, node_name) result(found)
character(len=*), intent(in) :: node_name
function check_for_node(node, name) result(found)
type(XMLNode), intent(in) :: node
character(len=*), intent(in) :: name
logical :: found
type(Node), pointer, intent(in) :: ptr
type(Node), pointer :: temp_ptr
type(NodeList), pointer :: elem_list
type(XMLAttribute) :: attr
type(XMLNode) :: child
! Default that we found it and attribute
found = .true.
! Get the attribute node
temp_ptr => getAttributeNode(ptr, trim(node_name))
! Check if node exists
if (associated(temp_ptr)) return
! Check for a sub-element
elem_list => getChildrenByTagName(ptr, trim(node_name))
! Get the length of the list
if (getLength(elem_list) == 0) then
found = .false.
return
! Check if an attribute or exists
attr = node%attribute(name)
if (attr%associated()) then
found = .true.
else
child = node%child(name)
if (child%associated()) then
found = .true.
else
found = .false.
end if
end if
end function check_for_node
!===============================================================================
! GET_NODE_PTR returns a Node pointer to an attribute or sub-element node.
! Note, this should only be used for sub-element nodes that occur only once.
! For repeated nodes, use get_node_list and then get_item_item.
!===============================================================================
subroutine get_node_ptr(in_ptr, node_name, out_ptr, found)
character(len=*), intent(in) :: node_name
logical, intent(out), optional :: found
type(Node), pointer, intent(in) :: in_ptr
type(Node), pointer, intent(out) :: out_ptr
logical :: found_
type(NodeList), pointer :: elem_list
! Set found to false
found_ = .false.
! Check for a sub-element
elem_list => getChildrenByTagName(in_ptr, trim(node_name))
! Get the length of the list
if (getLength(elem_list) == 0) return
! Point to the new element
out_ptr => item(elem_list, 0)
found_ = .true.
! Check to output found
if (present(found)) found = found_
end subroutine get_node_ptr
!===============================================================================
! GET_NODE_LIST is used to get a pointer to a list of sub-element nodes
!===============================================================================
subroutine get_node_list(in_ptr, node_name, out_ptr)
subroutine get_node_list(node, name, node_list)
type(XMLNode), intent(in) :: node
character(*), intent(in) :: name
type(XMLNode), allocatable, intent(out) :: node_list(:)
character(len=*), intent(in) :: node_name
type(Node), pointer, intent(in) :: in_ptr
type(NodeList), pointer, intent(out) :: out_ptr
integer :: i, n
type(XMLNode) :: first, current
! Check for a sub-element
out_ptr => getChildrenByTagName(in_ptr, trim(node_name))
first = node % child(name)
! Determine number of nodes
n = 0
current = first
do while (current % associated())
n = n + 1
current = current % next_sibling(name)
end do
! Allocate nodes
allocate(node_list(n))
current = first
do i = 1, n
node_list(i) = current
current = current % next_sibling(name)
end do
end subroutine get_node_list
!===============================================================================
! GET_LIST_SIZE is used to get the number of elements from a node list
! GET_NODE_VALUE_BOOL returns a logical value from an attribute or node
!===============================================================================
function get_list_size(in_ptr) result(n_size)
subroutine get_node_value_bool(node, name, val)
type(XMLNode), intent(in) :: node
character(*), intent(in) :: name
logical, intent(out) :: val
integer :: n_size
type(NodeList), pointer, intent(in) :: in_ptr
type(XMLAttribute) :: attr
type(XMLNode) :: child
type(XMLText) :: text
! Get the size of the list
n_size = getLength(in_ptr)
end function get_list_size
!===============================================================================
! GET_LIST_ITEM is used to select a specific item from a node list
!===============================================================================
subroutine get_list_item(in_ptr, idx, out_ptr)
integer, intent(in) :: idx
type(NodeList), pointer, intent(in) :: in_ptr
type(Node), pointer, intent(out) :: out_ptr
! Check for a sub-element
out_ptr => item(in_ptr, idx - 1)
end subroutine get_list_item
attr = node % attribute(name)
if (attr % associated()) then
val = attr % as_bool()
else
child = node % child(name)
if (child % associated()) then
text = child % text()
val = text % as_bool()
else
call fatal_error("No child XML node named '" // trim(name) // "'.")
end if
end if
end subroutine get_node_value_bool
!===============================================================================
! GET_NODE_VALUE_INTEGER returns a integer value from an attribute or node
!===============================================================================
subroutine get_node_value_integer(ptr, node_name, result_int)
subroutine get_node_value_integer(node, name, val)
type(XMLNode), intent(in) :: node
character(*), intent(in) :: name
integer, intent(out) :: val
character(len=*), intent(in) :: node_name
integer :: result_int
type(Node), pointer, intent(in) :: ptr
type(XMLAttribute) :: attr
type(XMLNode) :: child
type(XMLText) :: text
integer :: node_type
logical :: found
type(Node), pointer :: temp_ptr
! Get pointer to the node
call get_node(ptr, node_name, temp_ptr, node_type, found)
! Leave if it was not found
if (.not. found) then
call fatal_error("Node " // node_name // " not part of Node " &
&// getNodeName(ptr) // ".")
end if
! Extract value
if (node_type == ATTR_NODE) then
call extractDataAttribute(ptr, node_name, result_int)
attr = node % attribute(name)
if (attr % associated()) then
val = attr % as_int()
else
call extractDataContent(temp_ptr, result_int)
child = node % child(name)
if (child % associated()) then
text = child % text()
val = text % as_int()
else
call fatal_error("No XML node named '" // trim(name) // "'.")
end if
end if
end subroutine get_node_value_integer
!===============================================================================
! GET_NODE_VALUE_LONG returns an 8-byte integer from attribute or node
!===============================================================================
subroutine get_node_value_long(ptr, node_name, result_long)
subroutine get_node_value_long(node, name, val)
type(XMLNode), intent(in) :: node
character(*), intent(in) :: name
integer(C_LONG_LONG), intent(out) :: val
character(len=*), intent(in) :: node_name
integer(8) :: result_long
type(Node), pointer, intent(in) :: ptr
type(XMLAttribute) :: attr
type(XMLNode) :: child
type(XMLText) :: text
integer :: node_type
logical :: found
type(Node), pointer :: temp_ptr
! Get pointer to the node
call get_node(ptr, node_name, temp_ptr, node_type, found)
! Leave if it was not found
if (.not. found) then
call fatal_error("Node " // node_name // " not part of Node " &
&// getNodeName(ptr) // ".")
end if
! Extract value
if (node_type == ATTR_NODE) then
call extractDataAttribute(ptr, node_name, result_long)
attr = node % attribute(name)
if (attr % associated()) then
val = attr % as_llong()
else
call extractDataContent(temp_ptr, result_long)
child = node % child(name)
if (child % associated()) then
text = child % text()
val = text % as_llong()
else
call fatal_error("No XML node named '" // trim(name) // "'.")
end if
end if
end subroutine get_node_value_long
!===============================================================================
! GET_NODE_VALUE_DOUBLE returns a double precision real from attr. or node
!===============================================================================
subroutine get_node_value_double(ptr, node_name, result_double)
subroutine get_node_value_double(node, name, val)
type(XMLNode), intent(in) :: node
character(*), intent(in) :: name
real(C_DOUBLE), intent(out) :: val
character(len=*), intent(in) :: node_name
real(8) :: result_double
type(Node), pointer, intent(in) :: ptr
type(XMLAttribute) :: attr
type(XMLNode) :: child
type(XMLText) :: text
integer :: node_type
logical :: found
type(Node), pointer :: temp_ptr
! Get pointer to the node
call get_node(ptr, node_name, temp_ptr, node_type, found)
! Leave if it was not found
if (.not. found) then
call fatal_error("Node " // node_name // " not part of Node " &
&// getNodeName(ptr) // ".")
end if
! Extract value
if (node_type == ATTR_NODE) then
call extractDataAttribute(ptr, node_name, result_double)
attr = node % attribute(name)
if (attr % associated()) then
val = attr % as_double()
else
call extractDataContent(temp_ptr, result_double)
child = node % child(name)
if (child % associated()) then
text = child % text()
val = text % as_double()
else
call fatal_error("No XML node named '" // trim(name) // "'.")
end if
end if
end subroutine get_node_value_double
!===============================================================================
! GET_NODE_VALUE_STRING returns a single string from attr. or node
!===============================================================================
function node_value_string(node, name) result(val)
type(XMLNode), intent(in) :: node
character(*), intent(in) :: name
character(len=:, kind=C_CHAR), allocatable :: val
type(XMLAttribute) :: attr
type(XMLNode) :: child
attr = node % attribute(name)
if (attr % associated()) then
val = adjustl(attr % value())
else
child = node % child(name)
if (child % associated()) then
val = adjustl(child % child_value())
else
call fatal_error("No child XML node named '" // trim(name) // "'.")
end if
end if
end function node_value_string
subroutine get_node_value_string(node, name, val)
type(XMLNode), intent(in) :: node
character(*), intent(in) :: name
character(*), intent(out) :: val
val = node_value_string(node, name)
end subroutine get_node_value_string
!===============================================================================
! NODE_WORD_COUNT returns the number of words in a text node or attribute value
!===============================================================================
integer function node_word_count(node, name)
type(XMLNode), intent(in) :: node
character(*), intent(in) :: name
node_word_count = word_count(node_value_string(node, name))
end function node_word_count
!===============================================================================
! GET_NODE_ARRAY_INTEGER returns a 1-D array of integers
!===============================================================================
subroutine get_node_array_integer(ptr, node_name, result_int)
subroutine get_node_array_integer(node, name, array)
type(XMLNode), intent(in) :: node
character(*), intent(in) :: name
integer, intent(out) :: array(:)
character(len=*), intent(in) :: node_name
integer :: result_int(:)
type(Node), pointer, intent(in) :: ptr
integer :: stat
character(len=:, kind=C_CHAR), allocatable :: str
integer :: node_type
logical :: found
type(Node), pointer :: temp_ptr
! Get value of text node/attribute
str = node_value_string(node, name)
! Get pointer to the node
call get_node(ptr, node_name, temp_ptr, node_type, found)
! Leave if it was not found
if (.not. found) then
call fatal_error("Node " // node_name // " not part of Node " &
&// getNodeName(ptr) // ".")
! Read numbers into array
read(UNIT=str, FMT=*, IOSTAT=stat) array
if (stat > 0) then
call fatal_error("Error converting XML text: " // trim(str))
end if
! Extract value
if (node_type == ATTR_NODE) then
call extractDataAttribute(ptr, node_name, result_int)
else
call extractDataContent(temp_ptr, result_int)
end if
end subroutine get_node_array_integer
!===============================================================================
! GET_NODE_ARRAY_DOUBLE returns a 1-D array of double precision reals
!===============================================================================
subroutine get_node_array_double(ptr, node_name, result_double)
subroutine get_node_array_double(node, name, array)
type(XMLNode), intent(in) :: node
character(*), intent(in) :: name
real(C_DOUBLE), intent(out) :: array(:)
character(len=*), intent(in) :: node_name
real(8) :: result_double(:)
type(Node), pointer, intent(in) :: ptr
integer :: stat
character(len=:, kind=C_CHAR), allocatable :: str
integer :: node_type
logical :: found
type(Node), pointer :: temp_ptr
! Get value of text node/attribute
str = node_value_string(node, name)
! Get pointer to the node
call get_node(ptr, node_name, temp_ptr, node_type, found)
! Leave if it was not found
if (.not. found) then
call fatal_error("Node " // node_name // " not part of Node " &
&// getNodeName(ptr) // ".")
! Read numbers into array
read(UNIT=str, FMT=*, IOSTAT=stat) array
if (stat > 0) then
call fatal_error("Error converting XML text: " // trim(str))
end if
! Extract value
if (node_type == ATTR_NODE) then
call extractDataAttribute(ptr, node_name, result_double)
else
call extractDataContent(temp_ptr, result_double)
end if
end subroutine get_node_array_double
!===============================================================================
! GET_NODE_ARRAY_STRING returns a 1-D array of strings
!===============================================================================
subroutine get_node_array_string(ptr, node_name, result_string)
subroutine get_node_array_string(node, name, array)
type(XMLNode), intent(in) :: node
character(*), intent(in) :: name
character(len=*), intent(out) :: array(:)
character(len=*), intent(in) :: node_name
character(len=*) :: result_string(:)
type(Node), pointer, intent(in) :: ptr
integer :: i, n
integer :: start
logical :: inword
character(kind=C_CHAR) :: chr
character(len=:, kind=C_CHAR), allocatable :: str
integer :: node_type
logical :: found
type(Node), pointer :: temp_ptr
! Get value of text node/attribute
str = node_value_string(node, name)
! Get pointer to the node
call get_node(ptr, node_name, temp_ptr, node_type, found)
! Leave if it was not found
if (.not. found) then
call fatal_error("Node " // node_name // " not part of Node " &
&// getNodeName(ptr) // ".")
inword = .false.
n = 0
do i = 1, len(str)
chr = str(i:i)
select case (chr)
case (' ', C_HORIZONTAL_TAB, C_NEW_LINE, C_CARRIAGE_RETURN)
if (inword) then
inword = .false.
n = n + 1
array(n) = str(start:i-1)
end if
case default
if (.not. inword) then
start = i
inword = .true.
end if
end select
end do
if (inword) then
n = n + 1
array(n) = str(start:len(str))
end if
! Extract value
if (node_type == ATTR_NODE) then
call extractDataAttribute(ptr, node_name, result_string)
else
call extractDataContent(temp_ptr, result_string)
end if
end subroutine get_node_array_string
!===============================================================================
! GET_NODE_VALUE_STRING returns a single string from attr. or node
!===============================================================================
subroutine get_node_value_string(ptr, node_name, result_str)
character(len=*), intent(in) :: node_name
character(len=*) :: result_str
type(Node), pointer, intent(in) :: ptr
integer :: node_type
logical :: found
type(Node), pointer :: temp_ptr
! Get pointer to the node
call get_node(ptr, node_name, temp_ptr, node_type, found)
! Leave if it was not found
if (.not. found) then
call fatal_error("Node " // node_name // " not part of Node " // &
getNodeName(ptr) // ".")
end if
! Extract value
if (node_type == ATTR_NODE) then
call extractDataAttribute(ptr, node_name, result_str)
else
call extractDataContent(temp_ptr, result_str)
end if
end subroutine get_node_value_string
!===============================================================================
! GET_NODE_ARRAYSIZE_INTEGER returns the size of the integer array
!===============================================================================
function get_arraysize_integer(ptr, node_name) result(n)
character(len=*), intent(in) :: node_name
integer :: n
type(Node), pointer, intent(in) :: ptr
integer :: node_type
logical :: found
type(Node), pointer :: temp_ptr
! Get pointer to the node
call get_node(ptr, node_name, temp_ptr, node_type, found)
! Leave if it was not found
if (.not. found) then
call fatal_error("Node " // node_name // " not part of Node " &
&// getNodeName(ptr) // ".")
end if
! Get the size
n = countrts(getTextContent(temp_ptr), 0)
end function get_arraysize_integer
!===============================================================================
! GET_NODE_ARRAYSIZE_DOUBLE returns the size of double prec. real array
!===============================================================================
function get_arraysize_double(ptr, node_name) result(n)
character(len=*), intent(in) :: node_name
integer :: n
type(Node), pointer, intent(in) :: ptr
integer :: node_type
logical :: found
type(Node), pointer :: temp_ptr
! Get pointer to the node
call get_node(ptr, node_name, temp_ptr, node_type, found)
! Leave if it was not found
if (.not. found) then
call fatal_error("Node " // node_name // " not part of Node " &
&// getNodeName(ptr) // ".")
end if
! Get the size
n = countrts(getTextContent(temp_ptr), 0.0_8)
end function get_arraysize_double
!===============================================================================
! GET_NODE_ARRAYSIZE_STRING returns the size of string array
!===============================================================================
function get_arraysize_string(ptr, node_name) result(n)
character(len=*), intent(in) :: node_name
integer :: n
type(Node), pointer, intent(in) :: ptr
integer :: node_type
logical :: found
type(Node), pointer :: temp_ptr
! Get pointer to the node
call get_node(ptr, node_name, temp_ptr, node_type, found)
! Leave if it was not found
if (.not. found) then
call fatal_error("Node " // node_name // " not part of Node " // &
getNodeName(ptr) // ".")
end if
! Get the size
n = countrts(getTextContent(temp_ptr), 'a')
end function get_arraysize_string
!===============================================================================
! GET_NODE private routine that gets a pointer to a specific node
!===============================================================================
subroutine get_node(in_ptr, node_name, out_ptr, node_type, found)
character(len=*), intent(in) :: node_name
integer, intent(out) :: node_type
logical, intent(out) :: found
type(Node), pointer, intent(in) :: in_ptr
type(Node), pointer, intent(out) :: out_ptr
type(NodeList), pointer :: elem_list
! Default that we found it and attribute
found = .true.
node_type = ATTR_NODE
! Get the attribute node
out_ptr => getAttributeNode(in_ptr, trim(node_name))
! Check if node exists
if (associated(out_ptr)) return
! Check for a sub-element
elem_list => getChildrenByTagName(in_ptr, trim(node_name))
! Get the length of the list
if (getLength(elem_list) == 0) then
found = .false.
return
end if
! Point to the new element
node_type = ELEM_NODE
out_ptr => item(elem_list, 0)
end subroutine get_node
end module xml_interface

8
tests/test_cmfd_feed/cmfd.xml
View file

@ -8,8 +8,8 @@
<albedo> 0.0 0.0 1.0 1.0 1.0 1.0 </albedo>
</mesh>
<begin> 5 </begin>
<display> dominance </display>
<feedback> true </feedback>
<gauss_seidel_tolerance> 1.e-15 1.e-20 </gauss_seidel_tolerance>
<begin>5</begin>
<display>dominance</display>
<feedback>true</feedback>
<gauss_seidel_tolerance>1.e-15 1.e-20</gauss_seidel_tolerance>
</cmfd>

2
tests/test_cmfd_feed/settings.xml
View file

@ -23,6 +23,6 @@
</entropy>
<!-- Run CMFD -->
<run_cmfd> true </run_cmfd>
<run_cmfd>true</run_cmfd>
</settings>

2
tests/test_cmfd_nofeed/settings.xml
View file

@ -23,6 +23,6 @@
</entropy>
<!-- Run CMFD -->
<run_cmfd> true </run_cmfd>
<run_cmfd>true</run_cmfd>
</settings>