mirror of
https://github.com/openmc-dev/openmc.git
synced 2026-07-27 21:55:41 -04:00
Merge branch 'develop' into cdash
This commit is contained in:
Bryan Herman
commit
d5768e30e0
294 changed files with 187079 additions and 226189 deletions
3
.gitignore
vendored
3
.gitignore
vendored
|
|
@ -38,3 +38,6 @@ results_error.dat
|
|||
|
||||
# HDF5 files
|
||||
*.h5
|
||||
|
||||
# Data downloaded from NNDC
|
||||
data/nndc
|
||||
|
|
|
|||
3
.gitmodules
vendored
Normal file
3
.gitmodules
vendored
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
[submodule "src/xml/fox"]
|
||||
path = src/xml/fox
|
||||
url = git@github.com:mit-crpg/fox
|
||||
|
|
@ -6,12 +6,17 @@ import shutil
|
|||
import subprocess
|
||||
import sys
|
||||
import tarfile
|
||||
import glob
|
||||
|
||||
try:
|
||||
from urllib.request import urlopen
|
||||
except ImportError:
|
||||
from urllib2 import urlopen
|
||||
|
||||
cwd = os.getcwd()
|
||||
sys.path.append(os.path.join(cwd, '..', 'src', 'utils'))
|
||||
from convert_binary import ascii_to_binary
|
||||
|
||||
baseUrl = 'http://www.nndc.bnl.gov/endf/b7.1/aceFiles/'
|
||||
files = ['ENDF-B-VII.1-neutron-293.6K.tar.gz',
|
||||
'ENDF-B-VII.1-neutron-300K.tar.gz',
|
||||
|
|
@ -73,6 +78,17 @@ for f in files:
|
|||
print('Extracting {0}...'.format(f))
|
||||
tgz.extractall(path='nndc/' + suffix)
|
||||
|
||||
#===============================================================================
|
||||
# EDIT GRAPHITE ZAID (6012 to 6000)
|
||||
|
||||
print('Changing graphite ZAID from 6012 to 6000')
|
||||
graphite = os.path.join('nndc', 'tsl', 'graphite.acer')
|
||||
with open(graphite) as fh:
|
||||
text = fh.read()
|
||||
text = text.replace('6012', '6000', 1)
|
||||
with open(graphite, 'w') as fh:
|
||||
fh.write(text)
|
||||
|
||||
# ==============================================================================
|
||||
# COPY CROSS_SECTIONS.XML
|
||||
|
||||
|
|
@ -94,3 +110,43 @@ if not response or response.lower().startswith('y'):
|
|||
if os.path.exists(f):
|
||||
print('Removing {0}...'.format(f))
|
||||
os.remove(f)
|
||||
|
||||
# ==============================================================================
|
||||
# PROMPT USER TO CONVERT ASCII TO BINARY
|
||||
|
||||
# Ask user to convert
|
||||
if sys.version_info[0] < 3:
|
||||
response = raw_input('Convert ACE files to binary? ([y]/n) ')
|
||||
else:
|
||||
response = input('Convert ACE files to binary? ([y]/n) ')
|
||||
|
||||
# Convert files if requested
|
||||
if not response or response.lower().startswith('y'):
|
||||
|
||||
# get a list of directories
|
||||
ace_dirs = glob.glob(os.path.join('nndc', '*K'))
|
||||
ace_dirs += glob.glob(os.path.join('nndc', 'tsl'))
|
||||
|
||||
# loop around ace directories
|
||||
for d in ace_dirs:
|
||||
print('Coverting {0}...'.format(d))
|
||||
|
||||
# get a list of files to convert
|
||||
ace_files = glob.glob(os.path.join(d, '*.ace*'))
|
||||
|
||||
# convert files
|
||||
for f in ace_files:
|
||||
print(' Coverting {0}...'.format(os.path.split(f)[1]))
|
||||
ascii_to_binary(f, f)
|
||||
|
||||
# Change cross_sections.xml file
|
||||
xs_file = os.path.join('nndc', 'cross_sections.xml')
|
||||
asc_str = "<filetype>ascii</filetype>"
|
||||
bin_str = "<filetype> binary </filetype>\n "
|
||||
bin_str += "<record_length> 4096 </record_length>\n "
|
||||
bin_str += "<entries> 512 </entries>"
|
||||
with open(xs_file) as fh:
|
||||
text = fh.read()
|
||||
text = text.replace(asc_str, bin_str)
|
||||
with open(xs_file, 'w') as fh:
|
||||
fh.write(text)
|
||||
|
|
|
|||
|
|
@ -108,6 +108,15 @@ before submitting a formal pull request using gfortran and intel compilers
|
|||
if available.
|
||||
|
||||
The test suite is designed to integrate with cmake using ctest_.
|
||||
It is configured to run with cross sections from NNDC_. To
|
||||
download these cross sections please do the following:
|
||||
|
||||
.. code-block:: sh
|
||||
|
||||
cd ../data
|
||||
python get_nndc.py
|
||||
export CROSS_SECTIONS=<path_to_data_folder>/nndc/cross_sections.xml
|
||||
|
||||
The test suite can be run on an already existing build using:
|
||||
|
||||
.. code-block:: sh
|
||||
|
|
@ -233,3 +242,4 @@ from your private repository into a public fork.
|
|||
.. _paid plan: https://github.com/plans
|
||||
.. _Bitbucket: https://bitbucket.org
|
||||
.. _ctest: http://www.cmake.org/cmake/help/v2.8.12/ctest.html
|
||||
.. _NNDC: http://http://www.nndc.bnl.gov/endf/b7.1/acefiles.html
|
||||
|
|
|
|||
|
|
@ -13,13 +13,13 @@ With the FoX library, extending the user input files to include new tags is
|
|||
fairly straightforward. The steps for modifying/adding input are as follows:
|
||||
|
||||
1. Add appropriate calls to procedures from the `xml_interface module`_, such as
|
||||
``check_for_node``, ``get_node_value``, and ``get_node_array``. All input
|
||||
reading is performed in the `input_xml module`_.
|
||||
``check_for_node``, ``get_node_value``, and ``get_node_array``. All input
|
||||
reading is performed in the `input_xml module`_.
|
||||
|
||||
2. Make sure that your input can be categorized as one of the datatypes from
|
||||
`XML Schema Part 2`_ and that parsing of the data appropriately reflects
|
||||
this. For example, for a boolean_ value, true can be represented either by "true"
|
||||
or by "1".
|
||||
`XML Schema Part 2`_ and that parsing of the data appropriately reflects
|
||||
this. For example, for a boolean_ value, true can be represented either by
|
||||
"true" or by "1".
|
||||
|
||||
3. Add code to check the variable for any possible errors.
|
||||
|
||||
|
|
@ -29,10 +29,90 @@ schema for the file you changed (e.g. src/relaxng/geometry.rnc) so that
|
|||
those who use Emacs can confirm whether their input is valid before they
|
||||
run. You will need to be familiar with RELAX NG `compact syntax`_.
|
||||
|
||||
.. _FoX: https://github.com/andreww/fox
|
||||
Working with the FoX Submodule
|
||||
==============================
|
||||
|
||||
The FoX_ library is included as a submodule_ in OpenMC. This means that for a
|
||||
given commit in OpenMC, there is an associated commit id that links to FoX.
|
||||
The actual FoX source code is maintained at mit-crpg/fox, branch openmc. When
|
||||
cloning the OpenMC repo for the first time, you will notice that the directory
|
||||
*src/xml/fox* is empty. To fetch the submodule source code, you can manually
|
||||
enter the following from the root directory of OpenMC:
|
||||
|
||||
.. code-block:: sh
|
||||
|
||||
git submodule init
|
||||
git submodule update
|
||||
|
||||
It should be noted that if the submodule is not initialized and updated, *cmake*
|
||||
will automatically perform these commands if it cannot file the FoX source code.
|
||||
|
||||
If you navigate into the FoX source code in OpenMC, src/xml/fox, and check git
|
||||
information, you will notice that you are in a completely different repo. Actually,
|
||||
you are in a clone of mit-crpg/fox. If you have write access to this repo, you can
|
||||
make changes to the FoX source code, commit and push just like any other repo.
|
||||
Just because you make changes to the FoX source code in OpenMC or in a standalone
|
||||
repo, this does not mean that OpenMC will automatically fetch these changes. The
|
||||
way submodules work is that they are just stored as a commit id. To save FoX xml
|
||||
source changes to your OpenMC branch, do the following:
|
||||
|
||||
1. Go into src/xml/fox and check out the appropriate source code state
|
||||
|
||||
2. Navigate back out of fox subdirectory and type:
|
||||
|
||||
.. code-block:: sh
|
||||
|
||||
git status
|
||||
|
||||
3. Make sure you see that git recognized that the state of FoX changed:
|
||||
|
||||
::
|
||||
|
||||
# On branch fox_submodule
|
||||
# Changes not staged for commit:
|
||||
# (use "git add <file>..." to update what will be committed)
|
||||
# (use "git checkout -- <file>..." to discard changes in working directory)
|
||||
#
|
||||
# modified: fox (new commits)
|
||||
|
||||
4. Commit and push this change
|
||||
|
||||
Editing FoX on Personal Fork
|
||||
============================
|
||||
|
||||
If you don't have write access to mit-crpg/fox and thus can't make a branch off of the openmc
|
||||
branch there, you will need to fork mit-crpg/fox to your personal account. You need to then
|
||||
link your branch in your OpenMC repo, to the *openmc* branch on your own personal FoX fork.
|
||||
To do this, edit the *.gitmodules* file in the root folder of the repo. It contains the
|
||||
following information:
|
||||
|
||||
::
|
||||
|
||||
[submodule "src/xml/fox"]
|
||||
path = src/xml/fox
|
||||
url = git@github.com:mit-crpg/fox
|
||||
|
||||
Change the url remote to your own fork. The commit id should stay constant until you start
|
||||
making modification to FoX yourself. Once you have made changes to your FoX fork and linked
|
||||
the new commit id to your OpenMC branch, you can pull request your changes in by peforming
|
||||
the following steps:
|
||||
|
||||
1. Create a pull request from your fork of FoX to mit-crpg/fox and wait until it
|
||||
is merged into the openmc branch.
|
||||
|
||||
2. In your OpenMC repo, change your *.gitmodules* file back to point at mit-crpg/fox.
|
||||
|
||||
3. Submit a pull request to mit-crpg/openmc
|
||||
|
||||
.. warning:: If you make changes to your FoX submodule inside of an OpenMC repo and do not
|
||||
commit, do **not** run *git submodule update*. This may throw away any changes that
|
||||
were not committed.
|
||||
|
||||
.. _FoX: https://github.com/mit-crpg/fox
|
||||
.. _xml_interface module: https://github.com/mit-crpg/openmc/blob/develop/src/xml_interface.F90
|
||||
.. _input_xml module: https://github.com/mit-crpg/openmc/blob/develop/src/input_xml.F90
|
||||
.. _XML Schema Part 2: http://www.w3.org/TR/xmlschema-2/
|
||||
.. _boolean: http://www.w3.org/TR/xmlschema-2/#boolean
|
||||
.. _RELAX NG: http://relaxng.org/
|
||||
.. _compact syntax: http://relaxng.org/compact-tutorial-20030326.html
|
||||
.. _submodule: http://git-scm.com/book/en/Git-Tools-Submodules
|
||||
|
|
|
|||
|
|
@ -10,8 +10,8 @@ Publications
|
|||
|
||||
- Andrew Siegel, Kord Smith, Kyle Felker, Paul Romano, Benoit Forget, and Peter
|
||||
Beckman, "Improved cache performance in Monte Carlo transport calculations
|
||||
using energy banding," *Comput. Phys. Commun.*
|
||||
(2013). `<http://dx.doi.org/10.1016/j.cpc.2013.10.008>`_
|
||||
using energy banding," *Comput. Phys. Commun.*, **185** (4), 1195--1199
|
||||
(2014). `<http://dx.doi.org/10.1016/j.cpc.2013.10.008>`_
|
||||
|
||||
- Jonathan A. Walsh, Benoit Forget, and Kord S. Smith, "Validation of OpenMC
|
||||
Reactor Physics Simulations with the B&W 1810 Series Benchmarks,"
|
||||
|
|
|
|||
|
|
@ -325,7 +325,9 @@ This will build an executable named ``openmc``.
|
|||
Testing Build
|
||||
-------------
|
||||
|
||||
If you have ENDF/B-VII.0 cross sections from MCNP5/X you can test your build.
|
||||
If you have ENDF/B-VII.1 cross sections from NNDC_ you can test your build.
|
||||
Make sure the **CROSS_SECTIONS** environmental variable is set to the
|
||||
*cross_sections.xml* file in the *data/nndc* directory.
|
||||
There are two ways to run tests. The first is to use the Makefile present in
|
||||
the source directory and run the following:
|
||||
|
||||
|
|
@ -370,7 +372,8 @@ extract, and set up a confiuration file:
|
|||
python get_nndc_data.py
|
||||
|
||||
At this point, you should set the :envvar:`CROSS_SECTIONS` environment variable
|
||||
to the absolute path of the file ``openmc/data/nndc/cross_sections.xml``.
|
||||
to the absolute path of the file ``openmc/data/nndc/cross_sections.xml``. This
|
||||
cross section set is used by the test suite.
|
||||
|
||||
Using JEFF Cross Sections from OECD/NEA
|
||||
---------------------------------------
|
||||
|
|
@ -491,3 +494,4 @@ schemas.xml file in your own OpenMC source directory.
|
|||
.. _validation: http://en.wikipedia.org/wiki/XML_validation
|
||||
.. _RELAX NG: http://relaxng.org/
|
||||
.. _ctest: http://www.cmake.org/cmake/help/v2.8.12/ctest.html
|
||||
.. _NNDC: http://http://www.nndc.bnl.gov/endf/b7.1/acefiles.html
|
||||
|
|
|
|||
|
|
@ -182,17 +182,25 @@ endif()
|
|||
# FoX Fortran XML Library
|
||||
#===============================================================================
|
||||
|
||||
file(GLOB_RECURSE source_fox xml/*.F90)
|
||||
add_library(fox STATIC ${source_fox})
|
||||
# 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}/xml/fox/.git)
|
||||
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()
|
||||
add_subdirectory(xml/fox)
|
||||
|
||||
#===============================================================================
|
||||
# Build OpenMC executable
|
||||
#===============================================================================
|
||||
|
||||
set(program "openmc")
|
||||
file(GLOB source *.F90)
|
||||
file(GLOB source *.F90 xml/openmc_fox.F90)
|
||||
add_executable(${program} ${source})
|
||||
target_link_libraries(${program} ${libraries} fox)
|
||||
target_link_libraries(${program} ${libraries} fox_dom)
|
||||
set_target_properties(${program} PROPERTIES
|
||||
COMPILE_FLAGS "${f90flags}"
|
||||
LINK_FLAGS "${ldflags}")
|
||||
|
|
|
|||
|
|
@ -1520,7 +1520,9 @@ contains
|
|||
call get_node_value(node_ele, "name", name)
|
||||
|
||||
! Check for cross section
|
||||
if (.not.check_for_node(node_ele, "xs")) then
|
||||
if (check_for_node(node_ele, "xs")) then
|
||||
call get_node_value(node_ele, "xs", temp_str)
|
||||
else
|
||||
if (default_xs == '') then
|
||||
message = "No cross section specified for nuclide in material " &
|
||||
// trim(to_str(mat % id))
|
||||
|
|
|
|||
77
src/utils/convert_binary.py
Executable file
77
src/utils/convert_binary.py
Executable file
|
|
@ -0,0 +1,77 @@
|
|||
#!/usr/bin/env python
|
||||
|
||||
from __future__ import division
|
||||
|
||||
from struct import pack
|
||||
import sys
|
||||
|
||||
|
||||
def ascii_to_binary(ascii_file, binary_file):
|
||||
"""Convert an ACE file in ASCII format (type 1) to binary format (type 2).
|
||||
|
||||
Parameters
|
||||
----------
|
||||
ascii_file : str
|
||||
Filename of ASCII ACE file
|
||||
binary_file : str
|
||||
Filename of binary ACE file to be written
|
||||
|
||||
"""
|
||||
|
||||
# Open ASCII file
|
||||
ascii = open(ascii_file, 'r')
|
||||
|
||||
# Set default record length
|
||||
record_length = 4096
|
||||
|
||||
# Read data from ASCII file
|
||||
lines = ascii.readlines()
|
||||
ascii.close()
|
||||
|
||||
# Open binary file
|
||||
binary = open(binary_file, 'wb')
|
||||
|
||||
idx = 0
|
||||
while idx < len(lines):
|
||||
# Read/write header block
|
||||
hz = lines[idx][:10].encode('UTF-8')
|
||||
aw0 = float(lines[idx][10:22])
|
||||
tz = float(lines[idx][22:34])
|
||||
hd = lines[idx][35:45].encode('UTF-8')
|
||||
hk = lines[idx + 1][:70].encode('UTF-8')
|
||||
hm = lines[idx + 1][70:80].encode('UTF-8')
|
||||
binary.write(pack('=10sdd10s70s10s', hz, aw0, tz, hd, hk, hm))
|
||||
|
||||
# Read/write IZ/AW pairs
|
||||
data = ' '.join(lines[idx + 2:idx + 6]).split()
|
||||
iz = list(map(int, data[::2]))
|
||||
aw = list(map(float, data[1::2]))
|
||||
izaw = [item for sublist in zip(iz, aw) for item in sublist]
|
||||
binary.write(pack('=' + 16*'id', *izaw))
|
||||
|
||||
# Read/write NXS and JXS arrays. Null bytes are added at the end so
|
||||
# that XSS will start at the second record
|
||||
nxs = list(map(int, ' '.join(lines[idx + 6:idx + 8]).split()))
|
||||
jxs = list(map(int, ' '.join(lines[idx + 8:idx + 12]).split()))
|
||||
binary.write(pack('=16i32i{0}x'.format(record_length - 500), *(nxs + jxs)))
|
||||
|
||||
# Read/write XSS array. Null bytes are added to form a complete record
|
||||
# at the end of the file
|
||||
n_lines = (nxs[0] + 3)//4
|
||||
xss = list(map(float, ' '.join(lines[idx + 12:idx + 12 + n_lines]).split()))
|
||||
extra_bytes = record_length - ((len(xss)*8 - 1) % record_length + 1)
|
||||
binary.write(pack('={0}d{1}x'.format(nxs[0], extra_bytes), *xss))
|
||||
|
||||
# Advance to next table in file
|
||||
idx += 12 + n_lines
|
||||
|
||||
# Close binary file
|
||||
binary.close()
|
||||
|
||||
if __name__ == '__main__':
|
||||
# Check for proper number of arguments
|
||||
if len(sys.argv) < 3:
|
||||
sys.exit('Usage: {0} ascii_file binary_file'.format(sys.argv[0]))
|
||||
|
||||
# Convert ASCII file
|
||||
ascii_to_binary(sys.argv[1], sys.argv[2])
|
||||
|
|
@ -1,71 +0,0 @@
|
|||
FoX - Fortran XML library
|
||||
|
||||
FoX was originally derived from the xmlf90 codebase,
|
||||
(c) Alberto Garcia & Jon Wakelin, 2003-2004.
|
||||
|
||||
FoX also includes externally-written code from
|
||||
Scott Ladd <scott.ladd@coyotegulch.com>, which is licensed
|
||||
as shown in the file utils/fox_m_utils_mtprng.f90
|
||||
|
||||
This version of FoX is:
|
||||
(c) 2005-2009 Toby White <tow@uszla.me.uk>
|
||||
(c) 2007-2009 Gen-Tao Chiang <gtc25@cam.ac.uk>
|
||||
(c) 2008-2012 Andrew Walker <a.walker@ucl.ac.uk>
|
||||
|
||||
All rights reserved.
|
||||
|
||||
* Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are
|
||||
met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright notice,
|
||||
this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above copyright
|
||||
notice, this list of conditions and the following disclaimer in the
|
||||
documentation and/or other materials provided with the distribution.
|
||||
|
||||
* Neither the name of the copyright holder nor the names of its
|
||||
contributors may be used to endorse or promote products derived from
|
||||
this software without specific prior written permission.
|
||||
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
This distribution also includes code wrtten by Scott Ladd
|
||||
utils/,
|
||||
|
||||
! This computer program source file is supplied "AS IS". Scott Robert <br />
|
||||
! Ladd (hereinafter referred to as "Author") disclaims all warranties, <br />
|
||||
! expressed or implied, including, without limitation, the warranties <br />
|
||||
! of merchantability and of fitness for any purpose. The Author <br />
|
||||
! assumes no liability for direct, indirect, incidental, special, <br />
|
||||
! exemplary, or consequential damages, which may result from the use <br />
|
||||
! of this software, even if advised of the possibility of such damage. <br />
|
||||
! <br />
|
||||
! The Author hereby grants anyone permission to use, copy, modify, and <br />
|
||||
! distribute this source code, or portions hereof, for any purpose, <br />
|
||||
! without fee, subject to the following restrictions: <br />
|
||||
! <br />
|
||||
! 1. The origin of this source code must not be misrepresented. <br />
|
||||
! <br />
|
||||
! 2. Altered versions must be plainly marked as such and must not <br />
|
||||
! be misrepresented as being the original source. <br />
|
||||
! <br />
|
||||
! 3. This Copyright notice may not be removed or altered from any <br />
|
||||
! source or altered source distribution. <br />
|
||||
! <br />
|
||||
! The Author specifically permits (without fee) and encourages the use <br />
|
||||
! of this source code for entertainment, education, or decoration. If <br />
|
||||
! you use this source code in a product, acknowledgment is not required <br />
|
||||
! but would be appreciated.
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
xml_lib = lib/libxml.a
|
||||
|
||||
#===============================================================================
|
||||
# Targets
|
||||
#===============================================================================
|
||||
|
||||
$(xml_lib):
|
||||
mkdir -p include
|
||||
mkdir -p lib
|
||||
cd fsys; make MACHINE=$(MACHINE) F90=$(F90) F90FLAGS="$(F90FLAGS)"
|
||||
cd utils; make MACHINE=$(MACHINE) F90=$(F90) F90FLAGS="$(F90FLAGS)"
|
||||
cd common; make MACHINE=$(MACHINE) F90=$(F90) F90FLAGS="$(F90FLAGS)"
|
||||
cd wxml; make MACHINE=$(MACHINE) F90=$(F90) F90FLAGS="$(F90FLAGS)"
|
||||
cd sax; make MACHINE=$(MACHINE) F90=$(F90) F90FLAGS="$(F90FLAGS)"
|
||||
cd dom; make MACHINE=$(MACHINE) F90=$(F90) F90FLAGS="$(F90FLAGS)"
|
||||
cd lib; ar rcs libxml.a *.o; rm -f *.o
|
||||
|
||||
clean:
|
||||
cd fsys; make clean
|
||||
cd utils; make clean
|
||||
cd common; make clean
|
||||
cd wxml; make clean
|
||||
cd sax; make clean
|
||||
cd dom; make clean
|
||||
@rm -r -f include
|
||||
@rm -r -f lib
|
||||
|
||||
#===============================================================================
|
||||
# Rules
|
||||
#===============================================================================
|
||||
|
||||
.PHONY: clean
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
This directory contains source code from FoX - A Fortran Library for XML
|
||||
Current version is 4.1.2
|
||||
www1.gly.bris.ac.uk/~walker/FoX/
|
||||
|
|
@ -1,55 +0,0 @@
|
|||
module FoX_common
|
||||
|
||||
use fox_m_fsys_array_str
|
||||
use fox_m_fsys_format
|
||||
use fox_m_fsys_parse_input
|
||||
use fox_m_fsys_count_parse_input
|
||||
use m_common_attrs
|
||||
use m_common_error
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
#ifdef DUMMYLIB
|
||||
character(len=*), parameter :: FoX_version = '4.1.2-dummy'
|
||||
#else
|
||||
character(len=*), parameter :: FoX_version = '4.1.2'
|
||||
#endif
|
||||
|
||||
public :: FoX_version
|
||||
|
||||
public :: rts
|
||||
public :: countrts
|
||||
public :: str
|
||||
public :: operator(//)
|
||||
|
||||
public :: FoX_set_fatal_errors
|
||||
public :: FoX_get_fatal_errors
|
||||
public :: FoX_set_fatal_warnings
|
||||
public :: FoX_get_fatal_warnings
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
public :: str_vs
|
||||
public :: vs_str
|
||||
public :: alloc
|
||||
public :: concat
|
||||
#endif
|
||||
|
||||
!These are all exported through SAX now
|
||||
public :: dictionary_t
|
||||
!SAX functions
|
||||
public :: getIndex
|
||||
public :: getLength
|
||||
public :: getLocalName
|
||||
public :: getQName
|
||||
public :: getURI
|
||||
public :: getValue
|
||||
public :: getType
|
||||
public :: isSpecified
|
||||
public :: isDeclared
|
||||
public :: setSpecified
|
||||
public :: setDeclared
|
||||
!For convenience
|
||||
public :: hasKey
|
||||
|
||||
end module FoX_common
|
||||
|
|
@ -1,59 +0,0 @@
|
|||
source = $(wildcard *.F90)
|
||||
objects = $(source:.F90=.o)
|
||||
|
||||
#===============================================================================
|
||||
# Compiler Options
|
||||
#===============================================================================
|
||||
|
||||
# Ignore unusd variables
|
||||
|
||||
ifeq ($(MACHINE),bluegene)
|
||||
override F90 = xlf2003
|
||||
endif
|
||||
|
||||
ifeq ($(F90),ifort)
|
||||
override F90FLAGS += -warn nounused
|
||||
endif
|
||||
|
||||
#===============================================================================
|
||||
# Targets
|
||||
#===============================================================================
|
||||
|
||||
all: $(objects)
|
||||
mv *.mod ../include
|
||||
mv *.o ../lib
|
||||
clean:
|
||||
@rm -f *.o *.mod
|
||||
neat:
|
||||
@rm -f *.o *.mod
|
||||
|
||||
#===============================================================================
|
||||
# Rules
|
||||
#===============================================================================
|
||||
|
||||
.SUFFIXES: .F90 .o
|
||||
|
||||
.PHONY: clean neat
|
||||
|
||||
%.o: %.F90
|
||||
$(F90) $(F90FLAGS) -c -I../include $<
|
||||
|
||||
#===============================================================================
|
||||
# Dependencies
|
||||
#===============================================================================
|
||||
|
||||
FoX_common.o: m_common_attrs.o
|
||||
m_common_attrs.o: m_common_element.o m_common_error.o
|
||||
m_common_buffer.o: m_common_charset.o m_common_error.o
|
||||
m_common_element.o: m_common_charset.o m_common_content_model.o m_common_error.o m_common_namecheck.o
|
||||
m_common_elstack.o: m_common_content_model.o m_common_error.o
|
||||
m_common_entities.o: m_common_charset.o m_common_error.o
|
||||
m_common_entity_expand.o: m_common_entities.o m_common_error.o
|
||||
m_common_entity_expand.o: m_common_namecheck.o m_common_struct.o
|
||||
m_common_io.o: m_common_error.o
|
||||
m_common_namecheck.o: m_common_charset.o
|
||||
m_common_namespaces.o: m_common_attrs.o m_common_charset.o m_common_error.o
|
||||
m_common_namespaces.o: m_common_namecheck.o m_common_struct.o
|
||||
m_common_notations.o: m_common_error.o
|
||||
m_common_struct.o: m_common_charset.o m_common_element.o m_common_entities.o
|
||||
m_common_struct.o: m_common_notations.o
|
||||
File diff suppressed because it is too large
Load diff
|
|
@ -1,261 +0,0 @@
|
|||
module m_common_buffer
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
use fox_m_fsys_format, only: str
|
||||
use m_common_charset, only: XML1_0
|
||||
use m_common_error, only: FoX_error, FoX_warning
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
! At this point we use a fixed-size buffer.
|
||||
! Note however that buffer overflows will only be
|
||||
! triggered by overly long *unbroken* pcdata values, or
|
||||
! by overly long attribute values. Hopefully
|
||||
! element or attribute names are "short enough".
|
||||
!
|
||||
! In a forthcoming implementation it could be made dynamical...
|
||||
|
||||
! MAX_BUFF_SIZE cannot be bigger than the maximum available
|
||||
! record length for a compiler. In practice, this means
|
||||
! 1024 seems to be the biggest available size.
|
||||
|
||||
integer, parameter :: MAX_BUFF_SIZE = 1024
|
||||
|
||||
type buffer_t
|
||||
private
|
||||
integer :: size
|
||||
character(len=MAX_BUFF_SIZE) :: str
|
||||
integer :: unit
|
||||
integer :: xml_version
|
||||
end type buffer_t
|
||||
|
||||
public :: buffer_t
|
||||
|
||||
public :: add_to_buffer
|
||||
public :: print_buffer, str, char, len
|
||||
public :: buffer_to_chararray
|
||||
public :: reset_buffer
|
||||
public :: dump_buffer
|
||||
|
||||
interface str
|
||||
module procedure buffer_to_str
|
||||
end interface
|
||||
|
||||
interface char
|
||||
module procedure buffer_to_str
|
||||
end interface
|
||||
|
||||
interface len
|
||||
module procedure buffer_length
|
||||
end interface
|
||||
|
||||
contains
|
||||
|
||||
subroutine reset_buffer(buffer, unit, xml_version)
|
||||
type(buffer_t), intent(inout) :: buffer
|
||||
integer, intent(in), optional :: unit
|
||||
integer, intent(in) :: xml_version
|
||||
|
||||
buffer%size = 0
|
||||
if (present(unit)) then
|
||||
buffer%unit = unit
|
||||
else
|
||||
buffer%unit = 6
|
||||
endif
|
||||
buffer%xml_version = xml_version
|
||||
|
||||
end subroutine reset_buffer
|
||||
|
||||
|
||||
subroutine print_buffer(buffer)
|
||||
type(buffer_t), intent(in) :: buffer
|
||||
|
||||
write(unit=6,fmt="(a)") buffer%str(:buffer%size)
|
||||
|
||||
end subroutine print_buffer
|
||||
|
||||
|
||||
function buffer_to_str(buffer) result(str)
|
||||
type(buffer_t), intent(in) :: buffer
|
||||
character(len=buffer%size) :: str
|
||||
|
||||
str = buffer%str(:buffer%size)
|
||||
end function buffer_to_str
|
||||
|
||||
|
||||
function buffer_to_chararray(buffer) result(str)
|
||||
type(buffer_t), intent(in) :: buffer
|
||||
character(len=1), dimension(buffer%size) :: str
|
||||
integer :: i
|
||||
|
||||
do i = 1, buffer%size
|
||||
str(i) = buffer%str(i:i)
|
||||
enddo
|
||||
end function buffer_to_chararray
|
||||
|
||||
|
||||
function buffer_length(buffer) result(length)
|
||||
type(buffer_t), intent(in) :: buffer
|
||||
integer :: length
|
||||
|
||||
length = buffer%size
|
||||
|
||||
end function buffer_length
|
||||
|
||||
|
||||
subroutine dump_buffer(buffer, lf)
|
||||
type(buffer_t), intent(inout) :: buffer
|
||||
logical, intent(in), optional :: lf
|
||||
|
||||
integer :: i, n
|
||||
logical :: lf_
|
||||
|
||||
if (present(lf)) then
|
||||
lf_ = lf
|
||||
else
|
||||
lf_ = .true.
|
||||
endif
|
||||
|
||||
i = scan(buffer%str(:buffer%size), achar(10)//achar(13))
|
||||
n = 1
|
||||
do while (i>0)
|
||||
write(buffer%unit, '(a)', advance="yes") buffer%str(n:n+i-2)
|
||||
n = n + i
|
||||
if (n>buffer%size) exit
|
||||
i = scan(buffer%str(n:), achar(10)//achar(13))
|
||||
enddo
|
||||
|
||||
if (n<=buffer%size) then
|
||||
if (lf_) then
|
||||
write(buffer%unit, '(a)', advance="yes") buffer%str(n:buffer%size)
|
||||
else
|
||||
write(buffer%unit, '(a)', advance="no") buffer%str(n:buffer%size)
|
||||
endif
|
||||
endif
|
||||
|
||||
buffer%size = 0
|
||||
end subroutine dump_buffer
|
||||
|
||||
|
||||
subroutine check_buffer(s, version)
|
||||
character(len=*), intent(in) :: s
|
||||
integer, intent(in) :: version
|
||||
|
||||
integer :: i
|
||||
|
||||
!FIXME this is almost a duplicate of logic in wxml/m_wxml_escape.f90
|
||||
|
||||
! We have to do it this way (with achar etc) in case the native
|
||||
! platform encoding is not ASCII
|
||||
|
||||
do i = 1, len(s)
|
||||
select case (iachar(s(i:i)))
|
||||
case (0)
|
||||
call FoX_error("Tried to output a NUL character")
|
||||
case (1:8,11:12,14:31)
|
||||
if (version==XML1_0) then
|
||||
call FoX_error("Tried to output a character invalid under XML 1.0: &#"//str(iachar(s(i:i)))//";")
|
||||
endif
|
||||
case (128:)
|
||||
!TOHW we should maybe just disallow this ...
|
||||
call FoX_warning("emitting non-ASCII character. Platform-dependent result!")
|
||||
end select
|
||||
enddo
|
||||
|
||||
end subroutine check_buffer
|
||||
|
||||
|
||||
subroutine add_to_buffer(s, buffer, ws_significant)
|
||||
character(len=*), intent(in) :: s
|
||||
type(buffer_t), intent(inout) :: buffer
|
||||
logical, intent(in), optional :: ws_significant
|
||||
|
||||
character(len=(buffer%size+len(s))) :: s2
|
||||
integer :: i, n, len_b
|
||||
logical :: warning, ws_
|
||||
|
||||
! Is whitespace significant in this context?
|
||||
! We have to assume so unless told otherwise.
|
||||
if (present(ws_significant)) then
|
||||
ws_ = ws_significant
|
||||
else
|
||||
ws_ = .true.
|
||||
endif
|
||||
|
||||
! FIXME The algorithm below unilaterally forces all
|
||||
! line feeds and carriage returns to native EOL, regardless
|
||||
! of input document. Thus it is impossible to output a
|
||||
! document containing a literal non-native newline character
|
||||
! Ideally we would put this under the control of the user.
|
||||
|
||||
! We check if whitespace is significant. If not, we can
|
||||
! adjust the buffer without worrying about it.
|
||||
! But if we are not told, we warn about it.
|
||||
! And if we are told it definitely is - then we error out.
|
||||
|
||||
! If we overreach our buffer size, we will be unable to
|
||||
! output any more characters without a newline.
|
||||
! Go through new string, insert newlines
|
||||
! at spaces just before MAX_BUFF_SIZE chars
|
||||
! until we have less than MAX_BUFF_SIZE left to go,
|
||||
! then put that in the buffer.
|
||||
|
||||
! If no whitespace is found in the newly-added string, then
|
||||
! insert a new line immediately before it (at the end of the
|
||||
! current buffer)
|
||||
|
||||
call check_buffer(s, buffer%xml_version)
|
||||
|
||||
s2 = buffer%str(:buffer%size)//s
|
||||
|
||||
|
||||
! output as much of this using existing newlines as possible.
|
||||
warning = .false.
|
||||
n = 1
|
||||
do while (n<=len(s2))
|
||||
! Note this is an XML-1.0 only definition of newline
|
||||
i = scan(s2(n:), achar(10)//achar(13))
|
||||
if (i>0) then
|
||||
! turn that newline into an output newline ...
|
||||
write(buffer%unit, '(a)') s2(n:n+i-2)
|
||||
n = n + i
|
||||
elseif (n<=len(s2)-MAX_BUFF_SIZE) then
|
||||
! We need to insert a newline, or we'll overrun the buffer
|
||||
! No suitable newline, so convert a space or tab into a newline.
|
||||
i = scan(s2(n:n+MAX_BUFF_SIZE-1), achar(9)//achar(32), back=.true.)
|
||||
! If no space or tab is present, we fail.
|
||||
if (i>0.and..not.present(ws_significant)) then
|
||||
! We can insert a newline, but we don't know whether it is significant. Warn:
|
||||
if (.not.warning) then
|
||||
! We only output this warning once.
|
||||
call FoX_warning( &
|
||||
"Fortran made FoX insert a newline. "// &
|
||||
"If whitespace might be significant, check your output.")
|
||||
warning = .true.
|
||||
endif
|
||||
elseif (i==0) then
|
||||
call FoX_error( &
|
||||
"Fortran made FoX insert a newline but it can't. Stopping now.")
|
||||
elseif (ws_) then
|
||||
call FoX_error( &
|
||||
"Fortran made FoX insert a newline but whitespace is significant. Stopping now.")
|
||||
else
|
||||
continue ! without error or warning, because whitespace is not significant
|
||||
endif
|
||||
write(buffer%unit, '(a)') s2(n:n+i-1)
|
||||
n = n + i
|
||||
else
|
||||
! We don't need to do anything, just add the remainder to the buffer.
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
|
||||
len_b = len(s2) - n + 1
|
||||
buffer%str(:len_b) = s2(n:)
|
||||
buffer%size = len_b
|
||||
|
||||
end subroutine add_to_buffer
|
||||
|
||||
#endif
|
||||
end module m_common_buffer
|
||||
|
|
@ -1,447 +0,0 @@
|
|||
module m_common_charset
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
! Written to use ASCII charset only. Full UNICODE would
|
||||
! take much more work and need a proper unicode library.
|
||||
|
||||
use fox_m_fsys_string, only: toLower
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
!!$ character(len=1), parameter :: ASCII = &
|
||||
!!$achar(0)//achar(1)//achar(2)//achar(3)//achar(4)//achar(5)//achar(6)//achar(7)//achar(8)//achar(9)//&
|
||||
!!$achar(10)//achar(11)//achar(12)//achar(13)//achar(14)//achar(15)//achar(16)//achar(17)//achar(18)//achar(19)//&
|
||||
!!$achar(20)//achar(21)//achar(22)//achar(23)//achar(24)//achar(25)//achar(26)//achar(27)//achar(28)//achar(29)//&
|
||||
!!$achar(30)//achar(31)//achar(32)//achar(33)//achar(34)//achar(35)//achar(36)//achar(37)//achar(38)//achar(39)//&
|
||||
!!$achar(40)//achar(41)//achar(42)//achar(43)//achar(44)//achar(45)//achar(46)//achar(47)//achar(48)//achar(49)//&
|
||||
!!$achar(50)//achar(51)//achar(52)//achar(53)//achar(54)//achar(55)//achar(56)//achar(57)//achar(58)//achar(59)//&
|
||||
!!$achar(60)//achar(61)//achar(62)//achar(63)//achar(64)//achar(65)//achar(66)//achar(67)//achar(68)//achar(69)//&
|
||||
!!$achar(70)//achar(71)//achar(72)//achar(73)//achar(74)//achar(75)//achar(76)//achar(77)//achar(78)//achar(79)//&
|
||||
!!$achar(80)//achar(81)//achar(82)//achar(83)//achar(84)//achar(85)//achar(86)//achar(87)//achar(88)//achar(89)//&
|
||||
!!$achar(90)//achar(91)//achar(92)//achar(93)//achar(94)//achar(95)//achar(96)//achar(97)//achar(98)//achar(99)//&
|
||||
!!$achar(100)//achar(101)//achar(102)//achar(103)//achar(104)//achar(105)//achar(106)//achar(107)//achar(108)//achar(109)//&
|
||||
!!$achar(110)//achar(111)//achar(112)//achar(113)//achar(114)//achar(115)//achar(116)//achar(117)//achar(118)//achar(119)//&
|
||||
!!$achar(120)//achar(121)//achar(122)//achar(123)//achar(124)//achar(125)//achar(126)//achar(127)
|
||||
|
||||
character(len=1), parameter :: SPACE = achar(32)
|
||||
character(len=1), parameter :: NEWLINE = achar(10)
|
||||
character(len=1), parameter :: CARRIAGE_RETURN = achar(13)
|
||||
character(len=1), parameter :: TAB = achar(9)
|
||||
|
||||
character(len=*), parameter :: whitespace = SPACE//NEWLINE//CARRIAGE_RETURN//TAB
|
||||
|
||||
character(len=*), parameter :: lowerCase = "abcdefghijklmnopqrstuvwxyz"
|
||||
character(len=*), parameter :: upperCase = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
|
||||
character(len=*), parameter :: digits = "0123456789"
|
||||
character(len=*), parameter :: hexdigits = "0123456789abcdefABCDEF"
|
||||
character(len=*), parameter :: InitialNCNameChars = lowerCase//upperCase//"_"
|
||||
character(len=*), parameter :: NCNameChars = InitialNCNameChars//digits//".-"
|
||||
character(len=*), parameter :: InitialNameChars = InitialNCNameChars//":"
|
||||
character(len=*), parameter :: NameChars = NCNameChars//":"
|
||||
|
||||
character(len=*), parameter :: PubIdChars = NameChars//whitespace//"'()+,/=?;!*#@$%"
|
||||
character(len=*), parameter :: validchars = &
|
||||
whitespace//"!""#$%&'()*+,-./"//digits// &
|
||||
":;<=>?@"//upperCase//"[\]^_`"//lowerCase//"{|}~"
|
||||
! these are all the standard ASCII printable characters: whitespace + (33-126)
|
||||
! which are the only characters we can guarantee to know how to handle properly.
|
||||
|
||||
integer, parameter :: XML1_0 = 10 ! NB 0x7F was legal in XML-1.0, but illegal in XML-1.1
|
||||
|
||||
integer, parameter :: XML1_1 = 11
|
||||
|
||||
character(len=*), parameter :: XML1_0_ILLEGALCHARS = achar(0)
|
||||
character(len=*), parameter :: XML1_1_ILLEGALCHARS = NameChars
|
||||
|
||||
character(len=*), parameter :: XML1_0_INITIALNAMECHARS = InitialNameChars
|
||||
character(len=*), parameter :: XML1_1_INITIALNAMECHARS = InitialNameChars
|
||||
character(len=*), parameter :: XML1_0_NAMECHARS = NameChars
|
||||
character(len=*), parameter :: XML1_1_NAMECHARS = NameChars
|
||||
|
||||
character(len=*), parameter :: XML1_0_INITIALNCNAMECHARS = InitialNCNameChars
|
||||
character(len=*), parameter :: XML1_1_INITIALNCNAMECHARS = InitialNCNameChars
|
||||
character(len=*), parameter :: XML1_0_NCNAMECHARS = NCNameChars
|
||||
character(len=*), parameter :: XML1_1_NCNAMECHARS = NCNameChars
|
||||
|
||||
|
||||
character(len=*), parameter :: XML_WHITESPACE = whitespace
|
||||
character(len=*), parameter :: XML_INITIALENCODINGCHARS = lowerCase//upperCase
|
||||
character(len=*), parameter :: XML_ENCODINGCHARS = lowerCase//upperCase//digits//'._-'
|
||||
|
||||
public :: validchars
|
||||
public :: whitespace
|
||||
public :: uppercase
|
||||
|
||||
public :: digits
|
||||
public :: hexdigits
|
||||
|
||||
public :: XML1_0
|
||||
public :: XML1_1
|
||||
public :: XML1_0_NAMECHARS
|
||||
public :: XML1_1_NAMECHARS
|
||||
public :: XML1_0_INITIALNAMECHARS
|
||||
public :: XML1_1_INITIALNAMECHARS
|
||||
public :: XML_WHITESPACE
|
||||
public :: XML_INITIALENCODINGCHARS
|
||||
public :: XML_ENCODINGCHARS
|
||||
|
||||
public :: isLegalChar
|
||||
public :: isLegalCharRef
|
||||
public :: isRepCharRef
|
||||
public :: isInitialNameChar
|
||||
public :: isNameChar
|
||||
public :: isInitialNCNameChar
|
||||
public :: isNCNameChar
|
||||
public :: isXML1_0_NameChar
|
||||
public :: isXML1_1_NameChar
|
||||
public :: checkChars
|
||||
public :: isUSASCII
|
||||
public :: allowed_encoding
|
||||
|
||||
contains
|
||||
|
||||
pure function isLegalChar(c, ascii_p, xml_version) result(p)
|
||||
character, intent(in) :: c
|
||||
! really we should check the encoding here & be more intelligent
|
||||
! for now we worry only about is it ascii or not.
|
||||
logical, intent(in) :: ascii_p
|
||||
integer, intent(in) :: xml_version
|
||||
logical :: p
|
||||
! Is this character legal as a source character in the document?
|
||||
integer :: i
|
||||
i = iachar(c)
|
||||
if (i<0) then
|
||||
p = .false.
|
||||
return
|
||||
elseif (i>127) then
|
||||
p = .not.ascii_p
|
||||
return
|
||||
! ie if we are ASCII, then >127 is definitely illegal.
|
||||
! otherwise maybe it's ok
|
||||
endif
|
||||
select case(xml_version)
|
||||
case (XML1_0)
|
||||
p = (i==9.or.i==10.or.i==13.or.(i>31.and.i<128))
|
||||
case (XML1_1)
|
||||
p = (i==9.or.i==10.or.i==13.or.(i>31.and.i<127))
|
||||
! NB 0x7F was legal in XML-1.0, but illegal in XML-1.1
|
||||
end select
|
||||
end function isLegalChar
|
||||
|
||||
pure function isLegalCharRef(i, xml_version) result(p)
|
||||
integer, intent(in) :: i
|
||||
integer, intent(in) :: xml_version
|
||||
logical :: p
|
||||
|
||||
! Is Unicode character #i legal as a character reference?
|
||||
|
||||
if (xml_version==XML1_0) then
|
||||
p = (i==9).or.(i==10).or.(i==13).or.(i>31.and.i<55296).or.(i>57343.and.i<65534).or.(i>65535.and.i<1114112)
|
||||
elseif (xml_version==XML1_1) then
|
||||
p = (i>0.and.i<55296).or.(i>57343.and.i<65534).or.(i>65535.and.i<1114112)
|
||||
! XML 1.1 made all control characters legal as character references.
|
||||
end if
|
||||
end function isLegalCharRef
|
||||
|
||||
pure function isRepCharRef(i, xml_version) result(p)
|
||||
integer, intent(in) :: i
|
||||
integer, intent(in) :: xml_version
|
||||
logical :: p
|
||||
|
||||
! Is Unicode character #i legal and representable here?
|
||||
|
||||
if (xml_version==XML1_0) then
|
||||
p = (i==9).or.(i==10).or.(i==13).or.(i>31.and.i<128)
|
||||
elseif (xml_version==XML1_1) then
|
||||
p = (i>0.and.i<128)
|
||||
! XML 1.1 made all control characters legal as character references.
|
||||
end if
|
||||
end function isRepCharRef
|
||||
|
||||
pure function isInitialNameChar(c, xml_version) result(p)
|
||||
character, intent(in) :: c
|
||||
integer, intent(in) :: xml_version
|
||||
logical :: p
|
||||
|
||||
select case(xml_version)
|
||||
case (XML1_0)
|
||||
p = (verify(c, XML1_0_INITIALNAMECHARS)==0)
|
||||
case (XML1_1)
|
||||
p = (verify(c, XML1_1_INITIALNAMECHARS)==0)
|
||||
end select
|
||||
|
||||
end function isInitialNameChar
|
||||
|
||||
pure function isNameChar(c, xml_version) result(p)
|
||||
character(len=*), intent(in) :: c
|
||||
integer, intent(in) :: xml_version
|
||||
logical :: p
|
||||
|
||||
select case(xml_version)
|
||||
case (XML1_0)
|
||||
p = (verify(c, XML1_0_NAMECHARS)==0)
|
||||
case (XML1_1)
|
||||
p = (verify(c, XML1_1_NAMECHARS)==0)
|
||||
end select
|
||||
|
||||
end function isNameChar
|
||||
|
||||
pure function isInitialNCNameChar(c, xml_version) result(p)
|
||||
character, intent(in) :: c
|
||||
integer, intent(in) :: xml_version
|
||||
logical :: p
|
||||
|
||||
select case(xml_version)
|
||||
case (XML1_0)
|
||||
p = (verify(c, XML1_0_INITIALNCNAMECHARS)==0)
|
||||
case (XML1_1)
|
||||
p = (verify(c, XML1_1_INITIALNCNAMECHARS)==0)
|
||||
end select
|
||||
end function isInitialNCNameChar
|
||||
|
||||
pure function isNCNameChar(c, xml_version) result(p)
|
||||
character(len=*), intent(in) :: c
|
||||
integer, intent(in) :: xml_version
|
||||
logical :: p
|
||||
|
||||
select case(xml_version)
|
||||
case (XML1_0)
|
||||
p = (verify(c, XML1_0_NCNAMECHARS)==0)
|
||||
case (XML1_1)
|
||||
p = (verify(c, XML1_1_NCNAMECHARS)==0)
|
||||
end select
|
||||
end function isNCNameChar
|
||||
|
||||
function isXML1_0_NameChar(c) result(p)
|
||||
character, intent(in) :: c
|
||||
logical :: p
|
||||
|
||||
p = (verify(c, XML1_0_NAMECHARS)==0)
|
||||
|
||||
end function isXML1_0_NameChar
|
||||
|
||||
function isXML1_1_NameChar(c) result(p)
|
||||
character, intent(in) :: c
|
||||
logical :: p
|
||||
|
||||
p = (verify(c, XML1_1_NAMECHARS)==0)
|
||||
|
||||
end function isXML1_1_NameChar
|
||||
|
||||
pure function checkChars(value, xv) result(p)
|
||||
character(len=*), intent(in) :: value
|
||||
integer, intent(in) :: xv
|
||||
logical :: p
|
||||
|
||||
! This checks if value only contains values
|
||||
! legal to appear (escaped or unescaped)
|
||||
! according to whichever XML version is in force.
|
||||
integer :: i
|
||||
|
||||
p = .true.
|
||||
do i = 1, len(value)
|
||||
if (xv == XML1_0) then
|
||||
select case(iachar(value(i:i)))
|
||||
case (0,8)
|
||||
p = .false.
|
||||
case (11,12)
|
||||
p = .false.
|
||||
end select
|
||||
else
|
||||
if (iachar(value(i:i))==0) p =.false.
|
||||
endif
|
||||
enddo
|
||||
end function checkChars
|
||||
|
||||
function isUSASCII(encoding) result(p)
|
||||
character(len=*), intent(in) :: encoding
|
||||
logical :: p
|
||||
|
||||
character(len=len(encoding)) :: enc
|
||||
enc = toLower(encoding)
|
||||
p = (enc=="ansi_x3.4-1968" &
|
||||
.or. enc=="ansi_x3.4-1986" &
|
||||
.or. enc=="iso_646.irv:1991" &
|
||||
.or. enc=="ascii" &
|
||||
.or. enc=="iso646-us" &
|
||||
.or. enc=="us-ascii" &
|
||||
.or. enc=="us" &
|
||||
.or. enc=="ibm367" &
|
||||
.or. enc=="cp367" &
|
||||
.or. enc=="csascii")
|
||||
|
||||
end function isUSASCII
|
||||
|
||||
function allowed_encoding(encoding) result(p)
|
||||
character(len=*), intent(in) :: encoding
|
||||
logical :: p
|
||||
|
||||
character(len=len(encoding)) :: enc
|
||||
logical :: utf8, usascii, iso88591, iso88592, iso88593, iso88594, &
|
||||
iso88595, iso88596, iso88597, iso88598, iso88599, iso885910, &
|
||||
iso885913, iso885914, iso885915, iso885916
|
||||
|
||||
enc = toLower(encoding)
|
||||
|
||||
! From http://www.iana.org/assignments/character-sets
|
||||
! We can only reliably do US-ASCII (the below is mostly
|
||||
! a list of synonyms for US-ASCII) but we also accept
|
||||
! UTF-8 as a practicality. We bail out if any non-ASCII
|
||||
! characters are used later on.
|
||||
utf8 = (enc=="utf-8")
|
||||
|
||||
usascii = (enc=="ansi_x3.4-1968" &
|
||||
.or. enc=="ansi_x3.4-1986" &
|
||||
.or. enc=="iso_646.irv:1991" &
|
||||
.or. enc=="ascii" &
|
||||
.or. enc=="iso646-us" &
|
||||
.or. enc=="us-ascii" &
|
||||
.or. enc=="us" &
|
||||
.or. enc=="ibm367" &
|
||||
.or. enc=="cp367" &
|
||||
.or. enc=="csascii")
|
||||
! As of FoX 4.0, we accept ISO-8859-??, also as practicality
|
||||
! since we know it is identical to ASCII as far as 0x7F
|
||||
|
||||
iso88591 = (enc =="iso_8859-1:1987" &
|
||||
.or. enc=="iso-ir-100" &
|
||||
.or. enc=="iso_8859-1" &
|
||||
.or. enc=="iso-8859-1" &
|
||||
.or. enc=="latin1" &
|
||||
.or. enc=="l1" &
|
||||
.or. enc=="ibm819" &
|
||||
.or. enc=="cp819" &
|
||||
.or. enc=="csisolatin1")
|
||||
|
||||
iso88592 = (enc=="iso_8859-2:1987" &
|
||||
.or. enc=="iso-ir-101" &
|
||||
.or. enc=="iso_8859-2" &
|
||||
.or. enc=="iso-8859-2" &
|
||||
.or. enc=="latin2" &
|
||||
.or. enc=="l2" &
|
||||
.or. enc=="csisolatin2")
|
||||
|
||||
iso88593 = (enc=="iso_8859-3:1988" &
|
||||
.or. enc=="iso-ir-109" &
|
||||
.or. enc=="iso_8859-3" &
|
||||
.or. enc=="iso-8859-3" &
|
||||
.or. enc=="latin3" &
|
||||
.or. enc=="l3" &
|
||||
.or. enc=="csisolatin3")
|
||||
|
||||
iso88594 = (enc=="iso_8859-4:1988" &
|
||||
.or. enc=="iso-ir-110" &
|
||||
.or. enc=="iso_8859-4" &
|
||||
.or. enc=="iso-8859-4" &
|
||||
.or. enc=="latin4" &
|
||||
.or. enc=="l4" &
|
||||
.or. enc=="csisolatin4")
|
||||
|
||||
iso88595 = (enc=="iso_8859-5:1988" &
|
||||
.or. enc=="iso-ir-144" &
|
||||
.or. enc=="iso_8859-5" &
|
||||
.or. enc=="iso-8859-5" &
|
||||
.or. enc=="cyrillic" &
|
||||
.or. enc=="csisolatincyrillic")
|
||||
|
||||
iso88596 = (enc=="iso_8859-6:1987" &
|
||||
.or. enc=="iso-ir-127" &
|
||||
.or. enc=="iso_8859-6" &
|
||||
.or. enc=="iso-8859-6" &
|
||||
.or. enc=="ecma-114" &
|
||||
.or. enc=="asmo-708" &
|
||||
.or. enc=="arabic" &
|
||||
.or. enc=="csisolatinarabic")
|
||||
|
||||
iso88597 = (enc=="iso_8859-7:1987" &
|
||||
.or. enc=="iso-ir-126" &
|
||||
.or. enc=="iso_8859-7" &
|
||||
.or. enc=="iso-8859-7" &
|
||||
.or. enc=="elot_928" &
|
||||
.or. enc=="ecma-118" &
|
||||
.or. enc=="greek" &
|
||||
.or. enc=="greek8" &
|
||||
.or. enc=="csisolatingreek")
|
||||
|
||||
iso88598 = (enc=="iso_8859-8:1988" &
|
||||
.or. enc=="iso-ir-138" &
|
||||
.or. enc=="iso_8859-8" &
|
||||
.or. enc=="iso-8859-8" &
|
||||
.or. enc=="hebrew" &
|
||||
.or. enc=="csisolatinhebrew")
|
||||
|
||||
iso88599 = (enc=="iso_8859-9:1989" &
|
||||
.or. enc=="iso-ir-148" &
|
||||
.or. enc=="iso_8859-9" &
|
||||
.or. enc=="iso-8859-9" &
|
||||
.or. enc=="latin5" &
|
||||
.or. enc=="l5" &
|
||||
.or. enc=="csisolatin5")
|
||||
|
||||
iso885910 = (enc=="iso-8859-10" &
|
||||
.or. enc=="iso-ir-157" &
|
||||
.or. enc=="l6" &
|
||||
.or. enc=="iso_8859-10:1992" &
|
||||
.or. enc=="csisolatin6" &
|
||||
.or. enc=="latin6")
|
||||
|
||||
! ISO 6937 replaces $ sign with currency sign.
|
||||
! JIS-X0201 has Yen instead of backslash, macron instead of tilde
|
||||
! 16, 17, 18, 19 - Japanese encoding we can't use.
|
||||
! BS 4730 replaces hash with UK pound sign, and tilde to macron
|
||||
! 21, 22, 23, 24, 25, 26 - other variants of iso646, similar but not identical
|
||||
|
||||
! iso10646utf1 = (enc=="iso-10646-utf-1") ! FIXME check
|
||||
! iso656basic1983 = (enc=="iso_646.basic:1983" &
|
||||
! .or. enc=="csiso646basic1983") ! FIXME check
|
||||
! INVARIANT - almost but not quite a subset of ASCII
|
||||
! iso646irv = (enc=="iso_646.irv:1983" &
|
||||
! .or. enc=="iso-ir-2" &
|
||||
! .or. enc=="irv")
|
||||
! 31, 32, 33, 34 - NATS scandinavian, different from ASCII
|
||||
! 35 - another iso646 variant
|
||||
! 36, 37, 38 Korean shifted/multibyte
|
||||
! 39, 40 Japanese shifted/multibyte
|
||||
! 41, 42, JIS (iso646inv 7 bits)
|
||||
! 43 another iso646 variantt
|
||||
! 44, 45 greek variants
|
||||
! 46 another iso646 variant
|
||||
! 47 greek
|
||||
! 48 cyrillic ascii relationship unknown
|
||||
! 49 JIS again
|
||||
! 50 similar not identical
|
||||
! 51, 52, 53 not identical
|
||||
! 54 see 48
|
||||
! 55 see 47
|
||||
! 56 another iso646 variant
|
||||
! 57 chinese
|
||||
! ... to be continued
|
||||
|
||||
iso885913 = (enc=="iso-8859-13")
|
||||
iso885914 = (enc=="iso-8859-14" &
|
||||
.or. enc=="iso-ir-199" &
|
||||
.or. enc=="iso_8859-14:1998" &
|
||||
.or. enc=="iso_8849-14" &
|
||||
.or. enc=="iso_latin8" &
|
||||
.or. enc=="iso-celtic" &
|
||||
.or. enc=="l8")
|
||||
iso885915 = (enc=="iso-8859-15" &
|
||||
.or. enc=="iso-8859-15" &
|
||||
.or. enc=="latin-9")
|
||||
iso885916 = (enc=="iso-8859-16" &
|
||||
.or. enc=="iso-ir226" &
|
||||
.or. enc=="iso_8859-16:2001" &
|
||||
.or. enc=="iso_8859-16" &
|
||||
.or. enc=="latin10" &
|
||||
.or. enc=="l10")
|
||||
|
||||
p = utf8.or.usascii.or.iso88591.or.iso88592.or.iso88593 &
|
||||
.or.iso88594.or.iso88595.or.iso88596.or.iso88597 &
|
||||
.or.iso88598.or.iso88599.or.iso885910.or.iso885913 &
|
||||
.or.iso885914.or.iso885915.or.iso885916
|
||||
|
||||
end function allowed_encoding
|
||||
|
||||
#endif
|
||||
end module m_common_charset
|
||||
|
|
@ -1,490 +0,0 @@
|
|||
module m_common_content_model
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
! Allow validating the content model of an XML document
|
||||
|
||||
use fox_m_fsys_array_str, only: str_vs, vs_str_alloc, vs_vs_alloc
|
||||
implicit none
|
||||
private
|
||||
|
||||
integer, parameter :: OP_NULL = 0
|
||||
integer, parameter :: OP_EMPTY = 1
|
||||
integer, parameter :: OP_ANY = 2
|
||||
integer, parameter :: OP_MIXED = 3
|
||||
integer, parameter :: OP_NAME = 4
|
||||
integer, parameter :: OP_CHOICE = 5
|
||||
integer, parameter :: OP_SEQ = 6
|
||||
|
||||
integer, parameter :: REP_NULL = 0
|
||||
integer, parameter :: REP_ONCE = 1
|
||||
integer, parameter :: REP_QUESTION_MARK = 2
|
||||
integer, parameter :: REP_ASTERISK = 3
|
||||
|
||||
type content_particle_t
|
||||
character, pointer :: name(:) => null()
|
||||
integer :: operator = OP_NULL
|
||||
integer :: repeater = REP_NULL
|
||||
type(content_particle_t), pointer :: nextSibling => null()
|
||||
type(content_particle_t), pointer :: parent => null()
|
||||
type(content_particle_t), pointer :: firstChild => null()
|
||||
end type content_particle_t
|
||||
|
||||
public :: content_particle_t
|
||||
|
||||
public :: newCP
|
||||
public :: transformCPPlus
|
||||
public :: checkCP
|
||||
public :: checkCPToEnd
|
||||
public :: elementContentCP
|
||||
public :: emptyContentCP
|
||||
public :: destroyCPtree
|
||||
public :: dumpCPtree
|
||||
|
||||
public :: OP_NULL, OP_NAME, OP_MIXED, OP_CHOICE, OP_SEQ
|
||||
public :: REP_QUESTION_MARK, REP_ASTERISK
|
||||
|
||||
contains
|
||||
|
||||
function newCP(empty, any, name, repeat) result(cp)
|
||||
logical, intent(in), optional :: empty
|
||||
logical, intent(in), optional :: any
|
||||
character(len=*), intent(in), optional :: name
|
||||
character, intent(in), optional :: repeat
|
||||
type(content_particle_t), pointer :: cp
|
||||
|
||||
allocate(cp)
|
||||
if (present(empty)) then
|
||||
cp%operator = OP_EMPTY
|
||||
elseif (present(any)) then
|
||||
cp%operator = OP_ANY
|
||||
elseif (present(name)) then
|
||||
cp%operator = OP_NAME
|
||||
cp%name => vs_str_alloc(name)
|
||||
else
|
||||
cp%operator = OP_SEQ
|
||||
endif
|
||||
if (present(repeat)) then
|
||||
select case (repeat)
|
||||
case("?")
|
||||
cp%repeater = REP_QUESTION_MARK
|
||||
case("*")
|
||||
cp%repeater = REP_ASTERISK
|
||||
end select
|
||||
endif
|
||||
|
||||
end function newCP
|
||||
|
||||
function copyCP(cp) result(cp_out)
|
||||
type(content_particle_t), pointer :: cp
|
||||
type(content_particle_t), pointer :: cp_out
|
||||
|
||||
allocate(cp_out)
|
||||
if (associated(cp%name)) cp_out%name => vs_vs_alloc(cp%name)
|
||||
cp_out%operator = cp%operator
|
||||
cp_out%repeater = cp%repeater
|
||||
end function copyCP
|
||||
|
||||
function copyCPtree(cp) result(cp_out)
|
||||
type(content_particle_t), pointer :: cp
|
||||
type(content_particle_t), pointer :: cp_out
|
||||
|
||||
type(content_particle_t), pointer :: tcp, tcp_out, tcpn_out, tcpp_out
|
||||
logical :: done
|
||||
|
||||
tcp => cp
|
||||
cp_out => copyCP(cp)
|
||||
tcp_out => cp_out
|
||||
done = .false.
|
||||
do while (associated(tcp_out))
|
||||
if (.not.done) then
|
||||
do while (associated(tcp%firstChild))
|
||||
tcp => tcp%firstChild
|
||||
tcpn_out => copyCP(tcp)
|
||||
tcp_out%firstChild => tcpn_out
|
||||
tcpn_out%parent => tcp_out
|
||||
tcp_out => tcpn_out
|
||||
enddo
|
||||
endif
|
||||
tcpp_out => tcp_out%parent
|
||||
if (associated(tcp%nextSibling)) then
|
||||
done = .false.
|
||||
tcp => tcp%nextSibling
|
||||
tcpn_out => copyCP(tcp)
|
||||
tcp_out%nextSibling => tcpn_out
|
||||
tcpn_out%parent => tcpp_out
|
||||
tcp_out => tcpn_out
|
||||
else
|
||||
done = .true.
|
||||
tcp => tcp%parent
|
||||
tcp_out => tcp_out%parent
|
||||
endif
|
||||
enddo
|
||||
end function copyCPtree
|
||||
|
||||
subroutine transformCPPlus(cp)
|
||||
type(content_particle_t), pointer :: cp
|
||||
|
||||
type(content_particle_t), pointer :: tcp, cp_new
|
||||
|
||||
! Make copy of cp, and graft children on
|
||||
cp_new => copyCP(cp)
|
||||
cp_new%firstChild => cp%firstChild
|
||||
|
||||
! Reset children's parents ...
|
||||
tcp => cp%firstChild
|
||||
do while (associated(tcp))
|
||||
tcp%parent => cp_new
|
||||
tcp => tcp%nextSibling
|
||||
enddo
|
||||
|
||||
! Clear cp & make it an SEQ
|
||||
if (associated(cp%name)) deallocate(cp%name)
|
||||
cp%operator = OP_SEQ
|
||||
|
||||
! Append our copied cp to the now-an-SEQ
|
||||
cp%firstChild => cp_new
|
||||
cp_new%parent => cp
|
||||
|
||||
! Copy it for a sibling, and make the sibling a *
|
||||
cp_new%nextSibling => copyCPtree(cp_new)
|
||||
cp_new%nextSibling%parent => cp
|
||||
cp_new%nextSibling%repeater = REP_ASTERISK
|
||||
|
||||
end subroutine transformCPPlus
|
||||
|
||||
function checkCP(cp, name) result(p)
|
||||
type(content_particle_t), pointer :: cp
|
||||
character(len=*), intent(in) :: name
|
||||
logical :: p
|
||||
|
||||
type(content_particle_t), pointer :: tcp
|
||||
|
||||
! for EMPTY, ANY or MIXED, cp never moves.
|
||||
! for element content, we move the pointer as we
|
||||
! move through the regex.
|
||||
|
||||
! If the regex includes ambiguous content, we are
|
||||
! a bit screwed. But the document is in error if so.
|
||||
! (and we are not required to diagnose errors.)
|
||||
|
||||
p = .false.
|
||||
if (.not.associated(cp)) return
|
||||
|
||||
select case(cp%operator)
|
||||
case (OP_EMPTY)
|
||||
continue ! anything fails
|
||||
case (OP_ANY)
|
||||
p = .true.
|
||||
case (OP_MIXED)
|
||||
tcp => cp%firstChild
|
||||
do while (associated(tcp))
|
||||
if (name==str_vs(tcp%name)) then
|
||||
p = .true.
|
||||
exit
|
||||
endif
|
||||
tcp => tcp%nextSibling
|
||||
enddo
|
||||
case default
|
||||
do
|
||||
if (.not.associated(cp)) exit
|
||||
select case (cp%operator)
|
||||
case (OP_NAME)
|
||||
p = (name==str_vs(cp%name))
|
||||
if (p) then
|
||||
tcp => nextCPAfterMatch(cp)
|
||||
cp => tcp
|
||||
exit
|
||||
else
|
||||
tcp => nextCPAfterFail(cp)
|
||||
cp => tcp
|
||||
endif
|
||||
case (OP_CHOICE, OP_SEQ)
|
||||
cp => cp%firstChild
|
||||
end select
|
||||
end do
|
||||
end select
|
||||
|
||||
end function checkCP
|
||||
|
||||
function nextCPaftermatch(cp) result(cp_next)
|
||||
type (content_particle_t), pointer :: cp
|
||||
type (content_particle_t), pointer :: cp_next
|
||||
|
||||
type (content_particle_t), pointer :: tcp
|
||||
|
||||
cp_next => cp
|
||||
|
||||
do
|
||||
if (cp_next%repeater==REP_ASTERISK) exit
|
||||
tcp => cp_next%parent
|
||||
if (associated(tcp)) then
|
||||
if (tcp%operator==OP_CHOICE) then
|
||||
! siblings are uninteresting, we've matched this CHOICE
|
||||
cp_next => tcp
|
||||
! Move up & try the whole thing again on the parent CHOICE
|
||||
elseif (tcp%operator==OP_SEQ) then
|
||||
! we do care about siblings, move onto next one
|
||||
if (associated(cp_next%nextSibling)) then
|
||||
cp_next => cp_next%nextSibling
|
||||
! thatll do, itll be the next thing to try
|
||||
exit
|
||||
else
|
||||
! No sibling, move up a level
|
||||
cp_next => tcp
|
||||
! and try again
|
||||
endif
|
||||
endif
|
||||
else
|
||||
! We've got to the top already.
|
||||
cp_next => tcp
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
|
||||
end function nextCPaftermatch
|
||||
|
||||
function nextCPafterfail(cp) result(cp_next)
|
||||
type(content_particle_t), pointer :: cp
|
||||
type(content_particle_t), pointer :: cp_next
|
||||
|
||||
type(content_particle_t), pointer :: tcp
|
||||
logical :: match
|
||||
|
||||
match = .false.
|
||||
cp_next => cp
|
||||
do
|
||||
tcp => cp_next%parent
|
||||
if (associated(tcp)) then
|
||||
if (tcp%operator==OP_CHOICE) then
|
||||
! we care about siblings, lets try the next one
|
||||
if (associated(cp_next%nextSibling)) then
|
||||
cp_next => cp_next%nextSibling
|
||||
! super, lets go back and try that
|
||||
exit
|
||||
else ! weve failed to match any cp in this CHOICE ...
|
||||
cp_next => tcp
|
||||
! go up a level and see if theres another legitimate choice
|
||||
endif
|
||||
elseif (tcp%operator==OP_SEQ) then
|
||||
if ((match.or.cp_next%repeater/=REP_NULL) &
|
||||
.and.associated(cp_next%nextSibling)) then
|
||||
! we were allowed to fail to match, try sibling
|
||||
cp_next => cp_next%nextSibling
|
||||
exit
|
||||
elseif (cp_next%repeater/=REP_NULL) then
|
||||
match = .true.
|
||||
! The last item was optional, so weve matched at this level
|
||||
cp_next => tcp
|
||||
elseif (associated(tcp%firstChild, cp_next)) then
|
||||
! we havent matched - but we hadnt started, Maybe it was ok
|
||||
! not to match because we are nested inside an optional thingy
|
||||
cp_next => tcp
|
||||
else
|
||||
! We were not allowed to fail there,
|
||||
! there is no legitimate next choice.
|
||||
cp_next => null()
|
||||
exit
|
||||
endif
|
||||
endif
|
||||
else
|
||||
! weve got all the way to the top without
|
||||
! finding a new cp to try. But if this top-level
|
||||
! cp is ASTERISK'ed we can try it agin
|
||||
cp_next => null()
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
|
||||
end function nextCPafterfail
|
||||
|
||||
function checkCPToEnd(cp) result(p)
|
||||
type(content_particle_t), pointer :: cp
|
||||
logical :: p
|
||||
|
||||
type(content_particle_t), pointer :: tcp
|
||||
|
||||
if (associated(cp)) then
|
||||
select case(cp%operator)
|
||||
case (OP_EMPTY, OP_ANY, OP_MIXED)
|
||||
p = .true.
|
||||
case default
|
||||
tcp => nextCPMustMatch(cp)
|
||||
p = .not.associated(tcp)
|
||||
end select
|
||||
else
|
||||
p = .true.
|
||||
endif
|
||||
end function checkCPToEnd
|
||||
|
||||
function nextCPMustMatch(cp) result(cp_next)
|
||||
type(content_particle_t), pointer :: cp
|
||||
type(content_particle_t), pointer :: cp_next
|
||||
|
||||
type(content_particle_t), pointer :: tcp
|
||||
|
||||
if (.not.associated(cp)) return
|
||||
if (.not.associated(cp%parent)) then
|
||||
! we havent started exploring this one.
|
||||
! get the first starting position
|
||||
cp_next => cp
|
||||
do while (cp_next%repeater==REP_NULL)
|
||||
if (associated(cp_next%firstChild)) then
|
||||
cp_next => cp_next%firstChild
|
||||
else
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
cp_next => cp
|
||||
endif
|
||||
if (cp_next%repeater==REP_NULL) return
|
||||
do
|
||||
tcp => cp_next%parent
|
||||
if (associated(tcp)) then
|
||||
if (tcp%operator==OP_CHOICE) then
|
||||
! its matched by the optional one we are on, go up a level
|
||||
cp_next => tcp
|
||||
elseif (tcp%operator==OP_SEQ) then
|
||||
! check all siblings for any compulsory ones
|
||||
do while (associated(cp_next%nextSibling))
|
||||
cp_next => cp_next%nextSibling
|
||||
if (cp_next%repeater==REP_NULL) return
|
||||
enddo
|
||||
! all were optional, go up a level
|
||||
cp_next => tcp
|
||||
endif
|
||||
else
|
||||
! weve got all the way to the top without
|
||||
! finding a new cp to try
|
||||
cp_next => tcp
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
|
||||
end function nextCPMustMatch
|
||||
|
||||
function elementContentCP(cp) result(p)
|
||||
type(content_particle_t), pointer :: cp
|
||||
logical :: p
|
||||
|
||||
if (associated(cp)) then
|
||||
select case (cp%operator)
|
||||
case (OP_EMPTY, OP_ANY, OP_MIXED)
|
||||
p = .false.
|
||||
case default
|
||||
p = .true.
|
||||
end select
|
||||
else
|
||||
p = .true.
|
||||
endif
|
||||
|
||||
end function elementContentCP
|
||||
|
||||
function emptyContentCP(cp) result(p)
|
||||
type(content_particle_t), pointer :: cp
|
||||
logical :: p
|
||||
|
||||
if (associated(cp)) then
|
||||
p = cp%operator==OP_EMPTY
|
||||
else
|
||||
p = .false.
|
||||
endif
|
||||
|
||||
end function emptyContentCP
|
||||
|
||||
subroutine destroyCP(cp)
|
||||
type(content_particle_t), pointer :: cp
|
||||
|
||||
if (associated(cp%name)) deallocate(cp%name)
|
||||
deallocate(cp)
|
||||
end subroutine destroyCP
|
||||
|
||||
subroutine destroyCPtree(cp)
|
||||
type(content_particle_t), pointer :: cp
|
||||
|
||||
type(content_particle_t), pointer :: current, tcp
|
||||
|
||||
current => cp
|
||||
do
|
||||
do while (associated(current%firstChild))
|
||||
current => current%firstChild
|
||||
enddo
|
||||
if (associated(current, cp)) exit
|
||||
tcp => current
|
||||
if (associated(current%nextSibling)) then
|
||||
current => current%nextSibling
|
||||
call destroyCP(tcp)
|
||||
else
|
||||
current => current%parent
|
||||
call destroyCP(tcp)
|
||||
current%firstChild => null()
|
||||
endif
|
||||
enddo
|
||||
call destroyCP(cp)
|
||||
|
||||
end subroutine destroyCPtree
|
||||
|
||||
subroutine dumpCP(cp)
|
||||
type(content_particle_t), pointer :: cp
|
||||
|
||||
select case(cp%operator)
|
||||
case (OP_EMPTY)
|
||||
write(*,'(a)', advance="no") "EMPTY"
|
||||
case (OP_ANY)
|
||||
write(*,'(a)', advance="no") "ANY"
|
||||
case (OP_MIXED)
|
||||
write(*,'(a)', advance="no") "MIXED"
|
||||
case (OP_NAME)
|
||||
write(*,'(a)', advance="no") str_vs(cp%name)
|
||||
case (OP_CHOICE)
|
||||
write(*,'(a)', advance="no") "CHOICE"
|
||||
case (OP_SEQ)
|
||||
write(*,'(a)', advance="no") "SEQ"
|
||||
end select
|
||||
select case(cp%repeater)
|
||||
case (REP_QUESTION_MARK)
|
||||
write(*,'(a)', advance="no") "?"
|
||||
case (REP_ASTERISK)
|
||||
write(*,'(a)', advance="no") "*"
|
||||
end select
|
||||
write(*,*)
|
||||
end subroutine dumpCP
|
||||
|
||||
subroutine dumpCPtree(cp)
|
||||
type(content_particle_t), pointer :: cp
|
||||
|
||||
type(content_particle_t), pointer :: current
|
||||
|
||||
integer :: i
|
||||
logical :: done
|
||||
i = 0
|
||||
current => cp
|
||||
done = .false.
|
||||
call dumpCP(current)
|
||||
do
|
||||
if (.not.done) then
|
||||
do while (associated(current%firstChild))
|
||||
i = i + 2
|
||||
current => current%firstChild
|
||||
write(*,'(a)', advance="no") repeat(" ",i)
|
||||
call dumpCP(current)
|
||||
enddo
|
||||
endif
|
||||
if (associated(current, cp)) exit
|
||||
if (associated(current%nextSibling)) then
|
||||
done = .false.
|
||||
current => current%nextSibling
|
||||
write(*,'(a)', advance="no") repeat(" ",i)
|
||||
call dumpCP(current)
|
||||
else
|
||||
done = .true.
|
||||
i = i - 2
|
||||
current => current%parent
|
||||
endif
|
||||
enddo
|
||||
|
||||
end subroutine dumpCPtree
|
||||
|
||||
#endif
|
||||
|
||||
end module m_common_content_model
|
||||
File diff suppressed because it is too large
Load diff
|
|
@ -1,236 +0,0 @@
|
|||
module m_common_elstack
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
use fox_m_fsys_array_str, only: str_vs, vs_str
|
||||
use m_common_error, only: FoX_fatal
|
||||
use m_common_content_model, only: content_particle_t, checkCP, &
|
||||
elementContentCP, emptyContentCP, checkCPToEnd
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
! Element stack during parsing. Keeps track of element names
|
||||
! and optionally tracks validity of content model
|
||||
|
||||
! Initial stack size:
|
||||
integer, parameter :: STACK_SIZE_INIT = 10
|
||||
! Multiplier when stack is exceeded:
|
||||
real, parameter :: STACK_SIZE_MULT = 1.5
|
||||
|
||||
type :: elstack_item
|
||||
character, dimension(:), pointer :: name => null()
|
||||
type(content_particle_t), pointer :: cp => null()
|
||||
end type elstack_item
|
||||
|
||||
type :: elstack_t
|
||||
private
|
||||
integer :: n_items
|
||||
type(elstack_item), pointer, dimension(:) :: stack => null()
|
||||
end type elstack_t
|
||||
|
||||
public :: elstack_t
|
||||
|
||||
public :: push_elstack, pop_elstack, init_elstack, destroy_elstack, reset_elstack, print_elstack
|
||||
public :: get_top_elstack, is_empty
|
||||
public :: checkContentModel
|
||||
public :: checkContentModelToEnd
|
||||
public :: elementContent
|
||||
public :: emptyContent
|
||||
public :: len
|
||||
|
||||
interface len
|
||||
module procedure number_of_items
|
||||
end interface
|
||||
|
||||
interface is_empty
|
||||
module procedure is_empty_elstack
|
||||
end interface
|
||||
|
||||
contains
|
||||
|
||||
subroutine init_elstack(elstack)
|
||||
type(elstack_t), intent(inout) :: elstack
|
||||
|
||||
! We go from 0 (and initialize the 0th string to "")
|
||||
! in order that we can safely check the top of an
|
||||
! empty stack
|
||||
allocate(elstack%stack(0:STACK_SIZE_INIT))
|
||||
elstack%n_items = 0
|
||||
allocate(elstack%stack(0)%name(0))
|
||||
|
||||
end subroutine init_elstack
|
||||
|
||||
subroutine destroy_elstack(elstack)
|
||||
type(elstack_t), intent(inout) :: elstack
|
||||
integer :: i
|
||||
do i = 0, elstack % n_items
|
||||
deallocate(elstack%stack(i)%name)
|
||||
enddo
|
||||
deallocate(elstack%stack)
|
||||
end subroutine destroy_elstack
|
||||
|
||||
subroutine reset_elstack(elstack)
|
||||
type(elstack_t), intent(inout) :: elstack
|
||||
|
||||
call destroy_elstack(elstack)
|
||||
call init_elstack(elstack)
|
||||
|
||||
end subroutine reset_elstack
|
||||
|
||||
subroutine resize_elstack(elstack)
|
||||
type(elstack_t), intent(inout) :: elstack
|
||||
type(elstack_item), dimension(0:ubound(elstack%stack,1)) :: temp
|
||||
integer :: i, s
|
||||
|
||||
s = ubound(elstack%stack, 1)
|
||||
|
||||
do i = 0, s
|
||||
temp(i)%name => elstack%stack(i)%name
|
||||
temp(i)%cp => elstack%stack(i)%cp
|
||||
enddo
|
||||
deallocate(elstack%stack)
|
||||
allocate(elstack%stack(0:nint(s*STACK_SIZE_MULT)))
|
||||
do i = 0, s
|
||||
elstack%stack(i)%name => temp(i)%name
|
||||
elstack%stack(i)%cp => temp(i)%cp
|
||||
enddo
|
||||
|
||||
end subroutine resize_elstack
|
||||
|
||||
pure function is_empty_elstack(elstack) result(answer)
|
||||
type(elstack_t), intent(in) :: elstack
|
||||
logical :: answer
|
||||
|
||||
answer = (elstack%n_items == 0)
|
||||
end function is_empty_elstack
|
||||
|
||||
function number_of_items(elstack) result(n)
|
||||
type(elstack_t), intent(in) :: elstack
|
||||
integer :: n
|
||||
|
||||
n = elstack%n_items
|
||||
end function number_of_items
|
||||
|
||||
subroutine push_elstack(elstack, name, cp)
|
||||
type(elstack_t), intent(inout) :: elstack
|
||||
character(len=*), intent(in) :: name
|
||||
type(content_particle_t), pointer, optional :: cp
|
||||
|
||||
integer :: n
|
||||
|
||||
n = elstack%n_items
|
||||
n = n + 1
|
||||
if (n == size(elstack%stack)) then
|
||||
call resize_elstack(elstack)
|
||||
endif
|
||||
allocate(elstack%stack(n)%name(len(name)))
|
||||
elstack%stack(n)%name = vs_str(name)
|
||||
if (present(cp)) elstack%stack(n)%cp => cp
|
||||
elstack%n_items = n
|
||||
|
||||
end subroutine push_elstack
|
||||
|
||||
function pop_elstack(elstack) result(item)
|
||||
type(elstack_t), intent(inout) :: elstack
|
||||
character(len=merge(size(elstack%stack(elstack%n_items)%name), 0, elstack%n_items > 0)) :: item
|
||||
|
||||
integer :: n
|
||||
|
||||
n = elstack%n_items
|
||||
if (n == 0) then
|
||||
call FoX_fatal("Element stack empty")
|
||||
endif
|
||||
item = str_vs(elstack%stack(n)%name)
|
||||
deallocate(elstack%stack(n)%name)
|
||||
elstack%n_items = n - 1
|
||||
|
||||
end function pop_elstack
|
||||
|
||||
pure function get_top_elstack(elstack) result(item)
|
||||
! Get the top element of the stack, *without popping it*.
|
||||
type(elstack_t), intent(in) :: elstack
|
||||
character(len=merge(size(elstack%stack(elstack%n_items)%name), 0, elstack%n_items > 0)) :: item
|
||||
|
||||
integer :: n
|
||||
|
||||
n = elstack%n_items
|
||||
|
||||
if (n==0) then
|
||||
item = ""
|
||||
else
|
||||
item = str_vs(elstack%stack(n)%name)
|
||||
endif
|
||||
|
||||
end function get_top_elstack
|
||||
|
||||
function checkContentModel(elstack, name) result(p)
|
||||
type(elstack_t), intent(inout) :: elstack
|
||||
character(len=*), intent(in) :: name
|
||||
logical :: p
|
||||
|
||||
type(content_particle_t), pointer :: cp
|
||||
|
||||
integer :: n
|
||||
n = elstack%n_items
|
||||
if (n==0) then
|
||||
p = .true.
|
||||
else
|
||||
cp => elstack%stack(n)%cp
|
||||
p = checkCP(cp, name)
|
||||
elstack%stack(n)%cp => cp
|
||||
endif
|
||||
end function checkContentModel
|
||||
|
||||
function checkContentModelToEnd(elstack) result(p)
|
||||
type(elstack_t), intent(inout) :: elstack
|
||||
logical :: p
|
||||
|
||||
type(content_particle_t), pointer :: cp
|
||||
|
||||
integer :: n
|
||||
n = elstack%n_items
|
||||
|
||||
cp => elstack%stack(n)%cp
|
||||
p = checkCPToEnd(cp)
|
||||
|
||||
end function checkContentModelToEnd
|
||||
|
||||
function elementContent(elstack) result(p)
|
||||
type(elstack_t), intent(in) :: elstack
|
||||
logical :: p
|
||||
|
||||
integer :: n
|
||||
n = elstack%n_items
|
||||
if (n==0) then
|
||||
p = .false.
|
||||
else
|
||||
p = elementContentCP(elstack%stack(n)%cp)
|
||||
endif
|
||||
end function elementContent
|
||||
|
||||
function emptyContent(elstack) result(p)
|
||||
type(elstack_t), intent(in) :: elstack
|
||||
logical :: p
|
||||
|
||||
integer :: n
|
||||
n = elstack%n_items
|
||||
if (n==0) then
|
||||
p = .false.
|
||||
else
|
||||
p = emptyContentCP(elstack%stack(n)%cp)
|
||||
endif
|
||||
end function emptyContent
|
||||
|
||||
subroutine print_elstack(elstack,unit)
|
||||
type(elstack_t), intent(in) :: elstack
|
||||
integer, intent(in) :: unit
|
||||
integer :: i
|
||||
|
||||
do i = elstack%n_items, 1, -1
|
||||
write(unit=unit,fmt=*) elstack%stack(i)%name
|
||||
enddo
|
||||
|
||||
end subroutine print_elstack
|
||||
|
||||
#endif
|
||||
end module m_common_elstack
|
||||
|
|
@ -1,475 +0,0 @@
|
|||
module m_common_entities
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
|
||||
use fox_m_fsys_array_str, only: str_vs, vs_str_alloc
|
||||
use fox_m_fsys_format, only: str_to_int_10, str_to_int_16
|
||||
use fox_m_utils_uri, only: URI, destroyURI
|
||||
use m_common_charset, only: digits, hexdigits
|
||||
use m_common_error, only: FoX_error
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
type entity_t
|
||||
logical :: external
|
||||
logical :: wfc ! Was this entity declared externally or in a PE, where
|
||||
! a non-validating processor might not see it?
|
||||
character(len=1), dimension(:), pointer :: name => null()
|
||||
character(len=1), dimension(:), pointer :: text => null()
|
||||
character(len=1), dimension(:), pointer :: publicId => null()
|
||||
character(len=1), dimension(:), pointer :: systemId => null()
|
||||
character(len=1), dimension(:), pointer :: notation => null()
|
||||
type(URI), pointer :: baseURI => null()
|
||||
end type entity_t
|
||||
|
||||
type entity_list
|
||||
private
|
||||
type(entity_t), dimension(:), pointer :: list => null()
|
||||
end type entity_list
|
||||
|
||||
public :: is_unparsed_entity
|
||||
public :: is_external_entity
|
||||
|
||||
public :: expand_entity_text
|
||||
public :: expand_entity_text_len
|
||||
public :: existing_entity
|
||||
|
||||
public :: expand_char_entity
|
||||
|
||||
public :: expand_entity
|
||||
public :: expand_entity_len
|
||||
|
||||
public :: entity_t
|
||||
public :: entity_list
|
||||
public :: init_entity_list
|
||||
public :: reset_entity_list
|
||||
public :: destroy_entity_list
|
||||
public :: print_entity_list
|
||||
public :: add_internal_entity
|
||||
public :: add_external_entity
|
||||
public :: pop_entity_list
|
||||
|
||||
interface size
|
||||
module procedure size_el
|
||||
end interface
|
||||
|
||||
interface is_unparsed_entity
|
||||
module procedure is_unparsed_entity_
|
||||
module procedure is_unparsed_entity_from_list
|
||||
end interface
|
||||
|
||||
public :: getEntityByIndex
|
||||
public :: getEntityByName
|
||||
|
||||
public :: size
|
||||
|
||||
contains
|
||||
|
||||
function size_el(el) result(n)
|
||||
type(entity_list), intent(in) :: el
|
||||
integer :: n
|
||||
|
||||
n = ubound(el%list, 1)
|
||||
end function size_el
|
||||
|
||||
function shallow_copy_entity(ent1) result(ent2)
|
||||
type(entity_t), intent(in) :: ent1
|
||||
type(entity_t) :: ent2
|
||||
|
||||
ent2%external = ent1%external
|
||||
ent2%wfc = ent1%wfc
|
||||
ent2%name => ent1%name
|
||||
ent2%text => ent1%text
|
||||
ent2%publicId => ent1%publicId
|
||||
ent2%systemId => ent1%systemId
|
||||
ent2%notation => ent1%notation
|
||||
ent2%baseURI => ent1%baseURI
|
||||
|
||||
end function shallow_copy_entity
|
||||
|
||||
function getEntityByIndex(el, i) result(e)
|
||||
type(entity_list), intent(in) :: el
|
||||
integer, intent(in) :: i
|
||||
type(entity_t), pointer :: e
|
||||
|
||||
e => el%list(i)
|
||||
end function getEntityByIndex
|
||||
|
||||
function getEntityNameByIndex(el, i) result(c)
|
||||
type(entity_list), intent(in) :: el
|
||||
integer, intent(in) :: i
|
||||
character(len=size(el%list(i)%name)) :: c
|
||||
|
||||
c = str_vs(el%list(i)%name)
|
||||
end function getEntityNameByIndex
|
||||
|
||||
function getEntityByName(el, name) result(e)
|
||||
type(entity_list), intent(in) :: el
|
||||
character(len=*), intent(in) :: name
|
||||
type(entity_t), pointer :: e
|
||||
|
||||
integer :: i
|
||||
|
||||
e => null()
|
||||
do i = 1, size(el%list)
|
||||
if (str_vs(el%list(i)%name)==name) then
|
||||
e => el%list(i)
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
end function getEntityByName
|
||||
|
||||
|
||||
subroutine destroy_entity(ent)
|
||||
type(entity_t), intent(inout) :: ent
|
||||
|
||||
deallocate(ent%name)
|
||||
deallocate(ent%text)
|
||||
deallocate(ent%publicId)
|
||||
deallocate(ent%systemId)
|
||||
deallocate(ent%notation)
|
||||
|
||||
if (associated(ent%baseURI)) call destroyURI(ent%baseURI)
|
||||
|
||||
end subroutine destroy_entity
|
||||
|
||||
|
||||
subroutine init_entity_list(ents)
|
||||
type(entity_list), intent(inout) :: ents
|
||||
|
||||
if (associated(ents%list)) deallocate(ents%list)
|
||||
allocate(ents%list(0))
|
||||
|
||||
end subroutine init_entity_list
|
||||
|
||||
|
||||
subroutine reset_entity_list(ents)
|
||||
type(entity_list), intent(inout) :: ents
|
||||
|
||||
call destroy_entity_list(ents)
|
||||
call init_entity_list(ents)
|
||||
|
||||
end subroutine reset_entity_list
|
||||
|
||||
|
||||
subroutine destroy_entity_list(ents)
|
||||
type(entity_list), intent(inout) :: ents
|
||||
|
||||
integer :: i, n
|
||||
|
||||
n = size(ents%list)
|
||||
do i = 1, n
|
||||
call destroy_entity(ents%list(i))
|
||||
enddo
|
||||
deallocate(ents%list)
|
||||
end subroutine destroy_entity_list
|
||||
|
||||
function pop_entity_list(ents) result(name)
|
||||
type(entity_list), intent(inout) :: ents
|
||||
character(len=size(ents%list(size(ents%list))%name)) :: name
|
||||
|
||||
type(entity_t), pointer :: ents_tmp(:)
|
||||
integer :: i, n
|
||||
n = size(ents%list)
|
||||
|
||||
ents_tmp => ents%list
|
||||
allocate(ents%list(n-1))
|
||||
do i = 1, n - 1
|
||||
ents%list(i) = shallow_copy_entity(ents_tmp(i))
|
||||
enddo
|
||||
name = str_vs(ents_tmp(i)%name)
|
||||
|
||||
call destroy_entity(ents_tmp(i))
|
||||
deallocate(ents_tmp)
|
||||
end function pop_entity_list
|
||||
|
||||
subroutine print_entity_list(ents)
|
||||
type(entity_list), intent(in) :: ents
|
||||
|
||||
integer :: i, n
|
||||
|
||||
n = size(ents%list)
|
||||
write(*,'(a)') '>ENTITYLIST'
|
||||
do i = 1, n
|
||||
write(*,'(a)') str_vs(ents%list(i)%name)
|
||||
write(*,'(a)') str_vs(ents%list(i)%text)
|
||||
write(*,'(a)') str_vs(ents%list(i)%publicId)
|
||||
write(*,'(a)') str_vs(ents%list(i)%systemId)
|
||||
write(*,'(a)') str_vs(ents%list(i)%notation)
|
||||
enddo
|
||||
write(*,'(a)') '<ENTITYLIST'
|
||||
end subroutine print_entity_list
|
||||
|
||||
|
||||
subroutine add_entity(ents, name, text, publicId, systemId, notation, baseURI, wfc)
|
||||
type(entity_list), intent(inout) :: ents
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=*), intent(in) :: text
|
||||
character(len=*), intent(in) :: publicId
|
||||
character(len=*), intent(in) :: systemId
|
||||
character(len=*), intent(in) :: notation
|
||||
type(URI), pointer :: baseURI
|
||||
logical, intent(in) :: wfc
|
||||
|
||||
type(entity_t), pointer :: ents_tmp(:)
|
||||
integer :: i, n
|
||||
|
||||
! This should only ever be called by add_internal_entity or add_external_entity
|
||||
! below, so we don't bother sanity-checking input. Note especially we don't
|
||||
! check for duplication of entities, so this will happily add another entity
|
||||
! of the same name if you ask it to. This should't matter though, since the
|
||||
! first defined will always be picked up first, which is what the XML spec
|
||||
! requires.
|
||||
|
||||
n = size(ents%list)
|
||||
ents_tmp => ents%list
|
||||
allocate(ents%list(n+1))
|
||||
do i = 1, n
|
||||
ents%list(i) = shallow_copy_entity(ents_tmp(i))
|
||||
enddo
|
||||
deallocate(ents_tmp)
|
||||
ents%list(i)%external = len(systemId)>0
|
||||
ents%list(i)%wfc = wfc
|
||||
ents%list(i)%name => vs_str_alloc(name)
|
||||
ents%list(i)%text => vs_str_alloc(text)
|
||||
ents%list(i)%publicId => vs_str_alloc(publicId)
|
||||
ents%list(i)%systemId => vs_str_alloc(systemId)
|
||||
ents%list(i)%notation => vs_str_alloc(notation)
|
||||
ents%list(i)%baseURI => baseURI
|
||||
end subroutine add_entity
|
||||
|
||||
|
||||
subroutine add_internal_entity(ents, name, text, baseURI, wfc)
|
||||
type(entity_list), intent(inout) :: ents
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=*), intent(in) :: text
|
||||
type(URI), pointer :: baseURI
|
||||
logical, intent(in) :: wfc
|
||||
|
||||
call add_entity(ents, name=name, text=text, &
|
||||
publicId="", systemId="", notation="", baseURI=baseURI, wfc=wfc)
|
||||
end subroutine add_internal_entity
|
||||
|
||||
|
||||
subroutine add_external_entity(ents, name, systemId, baseURI, wfc, publicId, notation)
|
||||
type(entity_list), intent(inout) :: ents
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=*), intent(in) :: systemId
|
||||
character(len=*), intent(in), optional :: publicId
|
||||
character(len=*), intent(in), optional :: notation
|
||||
type(URI), pointer :: baseURI
|
||||
logical, intent(in) :: wfc
|
||||
|
||||
if (present(publicId) .and. present(notation)) then
|
||||
call add_entity(ents, name=name, text="", &
|
||||
publicId=publicId, systemId=systemId, notation=notation, &
|
||||
wfc=wfc, baseURI=baseURI)
|
||||
elseif (present(publicId)) then
|
||||
call add_entity(ents, name=name, text="", &
|
||||
publicId=publicId, systemId=systemId, notation="", &
|
||||
wfc=wfc, baseURI=baseURI)
|
||||
elseif (present(notation)) then
|
||||
call add_entity(ents, name=name, text="", &
|
||||
publicId="", systemId=systemId, notation=notation, &
|
||||
wfc=wfc, baseURI=baseURI)
|
||||
else
|
||||
call add_entity(ents, name=name, text="", &
|
||||
publicId="", systemId=systemId, notation="", &
|
||||
wfc=wfc, baseURI=baseURI)
|
||||
endif
|
||||
end subroutine add_external_entity
|
||||
|
||||
|
||||
function is_unparsed_entity_from_list(ents, name) result(p)
|
||||
type(entity_list), intent(in) :: ents
|
||||
character(len=*), intent(in) :: name
|
||||
logical :: p
|
||||
|
||||
integer :: i
|
||||
|
||||
p = .false.
|
||||
|
||||
do i = 1, size(ents%list)
|
||||
if (name == str_vs(ents%list(i)%name)) then
|
||||
p = (size(ents%list(i)%notation)>0)
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
end function is_unparsed_entity_from_list
|
||||
|
||||
function is_unparsed_entity_(ent) result(p)
|
||||
type(entity_t), intent(in) :: ent
|
||||
logical :: p
|
||||
|
||||
p = (size(ent%notation)>0)
|
||||
|
||||
end function is_unparsed_entity_
|
||||
|
||||
|
||||
function is_external_entity(ents, name) result(p)
|
||||
type(entity_list), intent(in) :: ents
|
||||
character(len=*), intent(in) :: name
|
||||
logical :: p
|
||||
|
||||
integer :: i
|
||||
|
||||
p = .false.
|
||||
|
||||
do i = 1, size(ents%list)
|
||||
if (name == str_vs(ents%list(i)%name)) then
|
||||
p = ents%list(i)%external
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
end function is_external_entity
|
||||
|
||||
pure function expand_char_entity_len(name) result(n)
|
||||
character(len=*), intent(in) :: name
|
||||
integer :: n
|
||||
|
||||
integer :: number
|
||||
|
||||
if (name(1:1) == "#") then
|
||||
if (name(2:2) == "x") then ! hex character reference
|
||||
if (verify(name(3:), hexdigits) == 0) then
|
||||
number = str_to_int_16(name(3:))
|
||||
if (0 <= number .and. number <= 128) then
|
||||
n = 1
|
||||
else
|
||||
n = len(name) + 2
|
||||
endif
|
||||
else
|
||||
n = 0
|
||||
endif
|
||||
else ! decimal character reference
|
||||
if (verify(name(3:), digits) == 0) then
|
||||
number = str_to_int_10(name(2:))
|
||||
if (0 <= number .and. number <= 128) then
|
||||
n = 1
|
||||
else
|
||||
n = len(name) + 2
|
||||
endif
|
||||
else
|
||||
n = 0
|
||||
endif
|
||||
endif
|
||||
else
|
||||
n = 0
|
||||
endif
|
||||
end function expand_char_entity_len
|
||||
|
||||
|
||||
function expand_char_entity(name) result(text)
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=expand_char_entity_len(name)) :: text
|
||||
|
||||
integer :: number
|
||||
|
||||
select case (len(text))
|
||||
case (0)
|
||||
call FoX_error("Invalid character entity reference")
|
||||
case (1)
|
||||
if (name(2:2) == "x") then ! hex character reference
|
||||
number = str_to_int_16(name(3:))
|
||||
else ! decimal character reference
|
||||
number = str_to_int_10(name(2:))
|
||||
endif
|
||||
text = achar(number)
|
||||
! FIXME what about > 127 ...
|
||||
case default
|
||||
text = "&"//name//";"
|
||||
end select
|
||||
|
||||
end function expand_char_entity
|
||||
|
||||
|
||||
pure function existing_entity(ents, name) result(p)
|
||||
type(entity_list), intent(in) :: ents
|
||||
character(len=*), intent(in) :: name
|
||||
logical :: p
|
||||
|
||||
integer :: i
|
||||
|
||||
p = .false.
|
||||
|
||||
!FIXME the following test is not entirely in accordance with the valid chars check we do elsewhere...
|
||||
|
||||
do i = 1, size(ents%list)
|
||||
if (name == str_vs(ents%list(i)%name)) then
|
||||
p = .true.
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
|
||||
end function existing_entity
|
||||
|
||||
|
||||
pure function expand_entity_text_len(ents, name) result(n)
|
||||
type(entity_list), intent(in) :: ents
|
||||
character(len=*), intent(in) :: name
|
||||
integer :: n
|
||||
|
||||
integer :: i
|
||||
|
||||
do i = 1, size(ents%list)
|
||||
if (name == str_vs(ents%list(i)%name)) then
|
||||
n = size(ents%list(i)%text)
|
||||
endif
|
||||
enddo
|
||||
|
||||
end function expand_entity_text_len
|
||||
|
||||
|
||||
function expand_entity_text(ents, name) result(text)
|
||||
type(entity_list), intent(in) :: ents
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=expand_entity_text_len(ents, name)) :: text
|
||||
|
||||
integer :: i
|
||||
|
||||
! No error checking - make sure entity exists before calling it.
|
||||
|
||||
do i = 1, size(ents%list)
|
||||
if (name == str_vs(ents%list(i)%name)) then
|
||||
text = str_vs(ents%list(i)%text)
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
|
||||
end function expand_entity_text
|
||||
|
||||
|
||||
pure function expand_entity_len(ents, name) result(n)
|
||||
type(entity_list), intent(in) :: ents
|
||||
character(len=*), intent(in) :: name
|
||||
integer :: n
|
||||
|
||||
integer :: i
|
||||
|
||||
do i = 1, size(ents%list)
|
||||
if (name == str_vs(ents%list(i)%name)) then
|
||||
n = size(ents%list(i)%text)
|
||||
endif
|
||||
enddo
|
||||
|
||||
end function expand_entity_len
|
||||
|
||||
|
||||
function expand_entity(ents, name) result(text)
|
||||
type(entity_list), intent(in) :: ents
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=expand_entity_len(ents, name)) :: text
|
||||
|
||||
integer :: i
|
||||
|
||||
do i = 1, size(ents%list)
|
||||
if (name == str_vs(ents%list(i)%name)) then
|
||||
text = str_vs(ents%list(i)%text)
|
||||
endif
|
||||
enddo
|
||||
|
||||
end function expand_entity
|
||||
|
||||
#endif
|
||||
end module m_common_entities
|
||||
|
|
@ -1,86 +0,0 @@
|
|||
module m_common_entity_expand
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
use fox_m_fsys_array_str, only: str_vs, vs_str
|
||||
use m_common_entities, only: expand_char_entity
|
||||
use m_common_error, only: error_stack, add_error
|
||||
use m_common_namecheck, only: checkName, checkCharacterEntityReference, &
|
||||
checkRepCharEntityReference
|
||||
use m_common_struct, only: xml_doc_state
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
public :: expand_entity_value_alloc
|
||||
|
||||
! This does the first level of expansion of the contents of an entity
|
||||
! reference, for storage during processing. Only character references
|
||||
! are expanded.
|
||||
|
||||
contains
|
||||
|
||||
function expand_entity_value_alloc(repl, xds, stack) result(repl_new)
|
||||
!perform expansion of character entity references
|
||||
! check that no parameter entities are present
|
||||
! and check that all general entity references are well-formed.
|
||||
!before storing it.
|
||||
!
|
||||
! This is only ever called from the SAX parser
|
||||
! (might it be called from WXML?)
|
||||
! so input & output is with character arrays, not strings.
|
||||
character, dimension(:), intent(in) :: repl
|
||||
type(xml_doc_state), intent(in) :: xds
|
||||
type(error_stack), intent(inout) :: stack
|
||||
character, dimension(:), pointer :: repl_new
|
||||
|
||||
character, dimension(size(repl)) :: repl_temp
|
||||
integer :: i, i2, j
|
||||
|
||||
allocate(repl_new(0))
|
||||
if (index(str_vs(repl),'%')/=0) then
|
||||
call add_error(stack, "Not allowed % in internal subset general entity value")
|
||||
return
|
||||
endif
|
||||
|
||||
i = 1
|
||||
i2 = 1
|
||||
do
|
||||
if (i>size(repl)) exit
|
||||
if (repl(i)=='&') then
|
||||
j = index(str_vs(repl(i+1:)),';')
|
||||
if (j==0) then
|
||||
call add_error(stack, "Not allowed bare & in entity value")
|
||||
return
|
||||
elseif (checkName(str_vs(repl(i+1:i+j-1)), xds%xml_version)) then
|
||||
repl_temp(i2:i2+j) = repl(i:i+j)
|
||||
i = i + j + 1
|
||||
i2 = i2 + j + 1
|
||||
! For SAX, we need to be able to represent the character:
|
||||
elseif (checkRepCharEntityReference(str_vs(repl(i+1:i+j-1)), xds%xml_version)) then
|
||||
!if it is ascii then
|
||||
repl_temp(i2:i2) = vs_str(expand_char_entity(str_vs(repl(i+1:i+j-1))))
|
||||
i = i + j + 1
|
||||
i2 = i2 + 1
|
||||
elseif (checkCharacterEntityReference(str_vs(repl(i+1:i+j-1)), xds%xml_version)) then
|
||||
! We can't represent it. Issue an error and stop.
|
||||
call add_error(stack, "Unable to digest character entity reference in entity value, sorry.")
|
||||
return
|
||||
else
|
||||
call add_error(stack, "Invalid entity reference in entity value")
|
||||
return
|
||||
endif
|
||||
else
|
||||
repl_temp(i2) = repl(i)
|
||||
i = i + 1
|
||||
i2 = i2 + 1
|
||||
endif
|
||||
enddo
|
||||
|
||||
deallocate(repl_new)
|
||||
allocate(repl_new(i2-1))
|
||||
repl_new = repl_temp(:i2-1)
|
||||
|
||||
end function expand_entity_value_alloc
|
||||
|
||||
#endif
|
||||
end module m_common_entity_expand
|
||||
|
|
@ -1,211 +0,0 @@
|
|||
module m_common_error
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
use fox_m_fsys_abort_flush, only: pxfabort, pxfflush
|
||||
use fox_m_fsys_array_str, only: vs_str_alloc
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
integer, parameter :: ERR_NULL = 0
|
||||
integer, parameter :: ERR_WARNING = 1
|
||||
integer, parameter :: ERR_ERROR = 2
|
||||
integer, parameter :: ERR_FATAL = 3
|
||||
#endif
|
||||
logical, save :: errors_are_fatal = .false.
|
||||
logical, save :: warnings_are_fatal = .false.
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
type error_t
|
||||
integer :: severity = ERR_NULL
|
||||
integer :: error_code = 0
|
||||
character, dimension(:), pointer :: msg => null()
|
||||
end type error_t
|
||||
|
||||
type error_stack
|
||||
type(error_t), dimension(:), pointer :: stack => null()
|
||||
end type error_stack
|
||||
|
||||
interface FoX_warning
|
||||
module procedure FoX_warning_base
|
||||
end interface
|
||||
|
||||
interface FoX_error
|
||||
module procedure FoX_error_base
|
||||
end interface
|
||||
|
||||
interface FoX_fatal
|
||||
module procedure FoX_fatal_base
|
||||
end interface
|
||||
|
||||
public :: ERR_NULL
|
||||
public :: ERR_WARNING
|
||||
public :: ERR_ERROR
|
||||
public :: ERR_FATAL
|
||||
|
||||
public :: error_t
|
||||
public :: error_stack
|
||||
|
||||
public :: init_error_stack
|
||||
public :: destroy_error_stack
|
||||
|
||||
public :: FoX_warning
|
||||
public :: FoX_error
|
||||
public :: FoX_fatal
|
||||
|
||||
public :: FoX_warning_base
|
||||
public :: FoX_error_base
|
||||
public :: FoX_fatal_base
|
||||
|
||||
public :: add_error
|
||||
public :: in_error
|
||||
|
||||
#endif
|
||||
public :: FoX_set_fatal_errors
|
||||
public :: FoX_get_fatal_errors
|
||||
public :: FoX_set_fatal_warnings
|
||||
public :: FoX_get_fatal_warnings
|
||||
|
||||
contains
|
||||
#ifndef DUMMYLIB
|
||||
|
||||
subroutine FoX_warning_base(msg)
|
||||
! Emit warning, but carry on.
|
||||
character(len=*), intent(in) :: msg
|
||||
|
||||
if (warnings_are_fatal) then
|
||||
write(0,'(a)') 'FoX warning made fatal'
|
||||
call FoX_fatal_base(msg)
|
||||
endif
|
||||
|
||||
write(0,'(a)') 'WARNING(FoX)'
|
||||
write(0,'(a)') msg
|
||||
call pxfflush(0)
|
||||
|
||||
end subroutine FoX_warning_base
|
||||
|
||||
|
||||
subroutine FoX_error_base(msg)
|
||||
! Emit error message and stop.
|
||||
! No clean up is done here, but this can
|
||||
! be overridden to include clean-up routines
|
||||
character(len=*), intent(in) :: msg
|
||||
|
||||
if (errors_are_fatal) then
|
||||
write(0,'(a)') 'FoX error made fatal'
|
||||
call FoX_fatal_base(msg)
|
||||
endif
|
||||
|
||||
write(0,'(a)') 'ERROR(FoX)'
|
||||
write(0,'(a)') msg
|
||||
call pxfflush(0)
|
||||
|
||||
stop
|
||||
|
||||
end subroutine FoX_error_base
|
||||
|
||||
subroutine FoX_fatal_base(msg)
|
||||
!Emit error message and abort with coredump.
|
||||
!No clean-up occurs
|
||||
|
||||
character(len=*), intent(in) :: msg
|
||||
|
||||
write(0,'(a)') 'ABORT(FOX)'
|
||||
write(0,'(a)') msg
|
||||
call pxfflush(0)
|
||||
|
||||
call pxfabort()
|
||||
|
||||
end subroutine FoX_fatal_base
|
||||
|
||||
|
||||
subroutine init_error_stack(stack)
|
||||
type(error_stack), intent(inout) :: stack
|
||||
|
||||
allocate(stack%stack(0))
|
||||
end subroutine init_error_stack
|
||||
|
||||
|
||||
subroutine destroy_error_stack(stack)
|
||||
type(error_stack), intent(inout) :: stack
|
||||
|
||||
integer :: i
|
||||
|
||||
do i = 1, size(stack%stack)
|
||||
deallocate(stack%stack(i)%msg)
|
||||
enddo
|
||||
deallocate(stack%stack)
|
||||
end subroutine destroy_error_stack
|
||||
|
||||
|
||||
subroutine add_error(stack, msg, severity, error_code)
|
||||
type(error_stack), intent(inout) :: stack
|
||||
character(len=*), intent(in) :: msg
|
||||
integer, intent(in), optional :: severity
|
||||
integer, intent(in), optional :: error_code
|
||||
|
||||
integer :: i, n
|
||||
type(error_t), dimension(:), pointer :: temp_stack
|
||||
|
||||
if (.not.associated(stack%stack)) &
|
||||
call init_error_stack(stack)
|
||||
|
||||
n = size(stack%stack)
|
||||
|
||||
temp_stack => stack%stack
|
||||
allocate(stack%stack(n+1))
|
||||
do i = 1, size(temp_stack)
|
||||
stack%stack(i)%msg => temp_stack(i)%msg
|
||||
stack%stack(i)%severity = temp_stack(i)%severity
|
||||
stack%stack(i)%error_code = temp_stack(i)%error_code
|
||||
enddo
|
||||
deallocate(temp_stack)
|
||||
|
||||
stack%stack(n+1)%msg => vs_str_alloc(msg)
|
||||
if (present(severity)) then
|
||||
stack%stack(n+1)%severity = severity
|
||||
else
|
||||
stack%stack(n+1)%severity = ERR_ERROR
|
||||
endif
|
||||
if (present(error_code)) then
|
||||
stack%stack(n+1)%error_code = error_code
|
||||
else
|
||||
stack%stack(n+1)%error_code = -1
|
||||
endif
|
||||
|
||||
end subroutine add_error
|
||||
|
||||
|
||||
function in_error(stack) result(p)
|
||||
type(error_stack), intent(in) :: stack
|
||||
logical :: p
|
||||
|
||||
if (associated(stack%stack)) then
|
||||
p = (size(stack%stack) > 0)
|
||||
else
|
||||
p = .false.
|
||||
endif
|
||||
end function in_error
|
||||
|
||||
#endif
|
||||
subroutine FoX_set_fatal_errors(newvalue)
|
||||
logical, intent(in) :: newvalue
|
||||
errors_are_fatal = newvalue
|
||||
end subroutine FoX_set_fatal_errors
|
||||
|
||||
function FoX_get_fatal_errors()
|
||||
logical :: FoX_get_fatal_errors
|
||||
FoX_get_fatal_errors = errors_are_fatal
|
||||
end function FoX_get_fatal_errors
|
||||
|
||||
subroutine FoX_set_fatal_warnings(newvalue)
|
||||
logical, intent(in) :: newvalue
|
||||
warnings_are_fatal = newvalue
|
||||
end subroutine FoX_set_fatal_warnings
|
||||
|
||||
function FoX_get_fatal_warnings()
|
||||
logical :: FoX_get_fatal_warnings
|
||||
FoX_get_fatal_warnings = warnings_are_fatal
|
||||
end function FoX_get_fatal_warnings
|
||||
|
||||
end module m_common_error
|
||||
|
|
@ -1,102 +0,0 @@
|
|||
module m_common_io
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
use m_common_error, only : FoX_error
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
! Basic I/O tools
|
||||
|
||||
integer, save :: io_eor
|
||||
integer, save :: io_eof
|
||||
integer, save :: io_err
|
||||
|
||||
public :: io_eor
|
||||
public :: io_eof
|
||||
public :: io_err
|
||||
public :: get_unit
|
||||
public :: setup_io
|
||||
|
||||
contains
|
||||
|
||||
subroutine setup_io()
|
||||
call find_eor_eof(io_eor, io_eof)
|
||||
end subroutine setup_io
|
||||
|
||||
|
||||
subroutine get_unit(lun,iostat)
|
||||
! Get an available Fortran unit number
|
||||
integer, intent(out) :: lun
|
||||
integer, intent(out) :: iostat
|
||||
|
||||
integer :: i
|
||||
logical :: unit_used
|
||||
|
||||
do i = 10, 99
|
||||
lun = i
|
||||
inquire(unit=lun,opened=unit_used)
|
||||
if (.not. unit_used) then
|
||||
iostat = 0
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
iostat = -1
|
||||
lun = -1
|
||||
end subroutine get_unit
|
||||
|
||||
|
||||
subroutine find_eor_eof(io_eor,io_eof)
|
||||
! Determines the values of the iostat values for End of File and
|
||||
! End of Record (in non-advancing I/O)
|
||||
#ifdef __NAG__
|
||||
use f90_iostat
|
||||
#endif
|
||||
integer, intent(out) :: io_eor
|
||||
integer, intent(out) :: io_eof
|
||||
|
||||
#ifdef __NAG__
|
||||
io_eor = ioerr_eor
|
||||
io_eof = ioerr_eof
|
||||
#else
|
||||
integer :: lun, iostat
|
||||
character(len=1) :: c
|
||||
|
||||
call get_unit(lun,iostat)
|
||||
|
||||
if (iostat /= 0) call FoX_error("Out of unit numbers")
|
||||
|
||||
open(unit=lun,status="scratch",form="formatted", &
|
||||
action="readwrite",position="rewind",iostat=iostat)
|
||||
if (iostat /= 0) call FoX_error("Cannot open test file")
|
||||
|
||||
write(unit=lun,fmt=*) "a"
|
||||
write(unit=lun,fmt=*) "b"
|
||||
|
||||
rewind(unit=lun)
|
||||
|
||||
io_eor = 0
|
||||
do
|
||||
read(unit=lun,fmt="(a1)",advance="no",iostat=io_eor) c
|
||||
if (io_eor /= 0) exit
|
||||
enddo
|
||||
|
||||
io_eof = 0
|
||||
do
|
||||
read(unit=lun,fmt=*,iostat=io_eof)
|
||||
if (io_eof /= 0) exit
|
||||
enddo
|
||||
|
||||
close(unit=lun,status="delete")
|
||||
#endif
|
||||
|
||||
! Invent an io_err ...
|
||||
io_err = 1
|
||||
do
|
||||
if (io_err/=0.and.io_err/=io_eor.and.io_err/=io_eof) exit
|
||||
io_err = io_err + 1
|
||||
end do
|
||||
end subroutine find_eor_eof
|
||||
|
||||
#endif
|
||||
end module m_common_io
|
||||
|
|
@ -1,501 +0,0 @@
|
|||
module m_common_namecheck
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
! These are basically a collection of what would be regular
|
||||
! expressions in a more sensible language.
|
||||
! The only external dependency should be knowing how these
|
||||
! regular expressions may differ between XML-1.0 and 1.1 (which
|
||||
! is only in the areas of
|
||||
! 1: allowing character entity references to control characters
|
||||
! 2: More characters allowed in Names (but this only affects
|
||||
! unicode-aware programs, so is only skeleton here)
|
||||
|
||||
use fox_m_fsys_format, only: str_to_int_10, str_to_int_16, operator(//)
|
||||
use fox_m_fsys_string, only: toLower
|
||||
use m_common_charset, only: isLegalCharRef, isNCNameChar, &
|
||||
isInitialNCNameChar, isInitialNameChar, isNameChar, isRepCharRef
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
character(len=*), parameter :: lowerCase = "abcdefghijklmnopqrstuvwxyz"
|
||||
character(len=*), parameter :: upperCase = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
|
||||
character(len=*), parameter :: letters = lowerCase//upperCase
|
||||
character(len=*), parameter :: digits = "0123456789"
|
||||
character(len=*), parameter :: hexdigits = "0123456789abcdefABCDEF"
|
||||
character(len=*), parameter :: NameChars = lowerCase//upperCase//digits//".-_:"
|
||||
|
||||
public :: checkName
|
||||
public :: checkNames
|
||||
public :: checkQName
|
||||
public :: checkQNames
|
||||
public :: checkNmtoken
|
||||
public :: checkNmtokens
|
||||
public :: checkNCName
|
||||
public :: checkNCNames
|
||||
public :: checkEncName
|
||||
public :: checkPITarget
|
||||
public :: checkPublicId
|
||||
public :: checkPEDef
|
||||
public :: checkPseudoAttValue
|
||||
public :: checkAttValue
|
||||
public :: checkCharacterEntityReference
|
||||
public :: checkRepCharEntityReference
|
||||
public :: likeCharacterEntityReference
|
||||
|
||||
public :: prefixOfQName
|
||||
public :: localpartOfQName
|
||||
|
||||
contains
|
||||
|
||||
pure function checkEncName(name) result(good)
|
||||
![81] EncName ::= [A-Za-z] ([A-Za-z0-9._] | '-')*
|
||||
character(len=*), intent(in) :: name
|
||||
logical :: good
|
||||
|
||||
integer :: n
|
||||
|
||||
n = len(name)
|
||||
good = (n > 0)
|
||||
if (good) good = (scan(name(1:1), letters) /= 0)
|
||||
if (good .and. n > 1) &
|
||||
good = (verify(name(2:), letters//digits//'.-_') == 0)
|
||||
end function checkEncName
|
||||
|
||||
|
||||
function checkPITarget(name, xv) result(good)
|
||||
character(len=*), intent(in) :: name
|
||||
integer, intent(in) :: xv
|
||||
logical :: good
|
||||
! Validates a string against the XML requirements for a NAME
|
||||
! Is not fully compliant; ignores UTF issues.
|
||||
|
||||
good = checkName(name, xv) &
|
||||
.and.toLower(name)/="xml"
|
||||
|
||||
end function checkPITarget
|
||||
|
||||
|
||||
pure function checkName(name, xv) result(good)
|
||||
character(len=*), intent(in) :: name
|
||||
integer, intent(in) :: xv
|
||||
logical :: good
|
||||
! Validates a string against the XML requirements for a NAME
|
||||
! Is not fully compliant; ignores UTF issues.
|
||||
|
||||
good = (len(name) > 0)
|
||||
if (.not.good) return
|
||||
if (good) good = isInitialNameChar(name(1:1), xv)
|
||||
if (.not.good.or.len(name)==1) return
|
||||
good = isNameChar(name(2:), xv)
|
||||
|
||||
end function checkName
|
||||
|
||||
pure function checkNames(name, xv) result(good)
|
||||
character(len=*), intent(in) :: name
|
||||
integer, intent(in) :: xv
|
||||
logical :: good
|
||||
! Validates a string against the production for NAMES
|
||||
|
||||
integer :: i, j
|
||||
|
||||
good = (len(name) > 0)
|
||||
if (.not.good) return
|
||||
i = verify(name, " ")
|
||||
if (i==0) then
|
||||
good = .false.
|
||||
return
|
||||
endif
|
||||
j = scan(name(i:), " ")
|
||||
if (j==0) then
|
||||
j = len(name)
|
||||
else
|
||||
j = i + j - 2
|
||||
endif
|
||||
do
|
||||
good = checkName(name(i:j), xv)
|
||||
if (.not.good) return
|
||||
i = j + 1
|
||||
j = verify(name(i:), " ")
|
||||
if (j==0) exit
|
||||
i = i + j - 1
|
||||
j = scan(name(i:), " ")
|
||||
if (j==0) then
|
||||
j = len(name)
|
||||
else
|
||||
j = i + j - 2
|
||||
endif
|
||||
enddo
|
||||
|
||||
end function checkNames
|
||||
|
||||
|
||||
pure function checkQName(name, xv) result(good)
|
||||
character(len=*), intent(in) :: name
|
||||
integer, intent(in) :: xv
|
||||
logical :: good
|
||||
! Validates a string against the XML requirements for a NAME
|
||||
! Is not fully compliant; ignores UTF issues.
|
||||
|
||||
integer :: n
|
||||
|
||||
n = index(name, ':')
|
||||
if (n == 0) then
|
||||
good = checkNCName(name, xv)
|
||||
else
|
||||
good = (checkNCName(name(:n-1), xv) .and. checkNCName(name(n+1:), xv))
|
||||
endif
|
||||
end function checkQName
|
||||
|
||||
|
||||
pure function checkQNames(name, xv) result(good)
|
||||
character(len=*), intent(in) :: name
|
||||
integer, intent(in) :: xv
|
||||
logical :: good
|
||||
! Validates a string against the production for NAMES
|
||||
|
||||
integer :: i, j
|
||||
|
||||
good = (len(name) > 0)
|
||||
if (.not.good) return
|
||||
i = verify(name, " ")
|
||||
if (i==0) then
|
||||
good = .false.
|
||||
return
|
||||
endif
|
||||
j = scan(name(i:), " ")
|
||||
if (j==0) then
|
||||
j = len(name)
|
||||
else
|
||||
j = i + j - 2
|
||||
endif
|
||||
do
|
||||
good = checkQName(name(i:j), xv)
|
||||
if (.not.good) return
|
||||
i = j + 1
|
||||
j = verify(name(i:), " ")
|
||||
if (j==0) exit
|
||||
i = i + j - 1
|
||||
j = scan(name(i:), " ")
|
||||
if (j==0) then
|
||||
j = len(name)
|
||||
else
|
||||
j = i + j - 2
|
||||
endif
|
||||
enddo
|
||||
|
||||
end function checkQNames
|
||||
|
||||
|
||||
pure function checkNCName(name, xv) result(good)
|
||||
character(len=*), intent(in) :: name
|
||||
integer, intent(in) :: xv
|
||||
logical :: good
|
||||
! Validates a string against the XML requirements for an NCNAME
|
||||
! Is not fully compliant; ignores UTF issues.
|
||||
|
||||
good = (len(name)/=0)
|
||||
if (.not.good) return
|
||||
good = isInitialNCNameChar(name(1:1), xv)
|
||||
if (.not.good.or.len(name)==1) return
|
||||
good = isNCNameChar(name(2:), xv)
|
||||
|
||||
end function checkNCName
|
||||
|
||||
|
||||
pure function checkNCNames(name, xv) result(good)
|
||||
character(len=*), intent(in) :: name
|
||||
integer, intent(in) :: xv
|
||||
logical :: good
|
||||
! Validates a string against the production for NAMES
|
||||
|
||||
integer :: i, j
|
||||
|
||||
good = (len(name) > 0)
|
||||
if (.not.good) return
|
||||
i = verify(name, " ")
|
||||
if (i==0) then
|
||||
good = .false.
|
||||
return
|
||||
endif
|
||||
j = scan(name(i:), " ")
|
||||
if (j==0) then
|
||||
j = len(name)
|
||||
else
|
||||
j = i + j - 2
|
||||
endif
|
||||
do
|
||||
good = checkNCName(name(i:j), xv)
|
||||
if (.not.good) return
|
||||
i = j + 1
|
||||
j = verify(name(i:), " ")
|
||||
if (j==0) exit
|
||||
i = i + j - 1
|
||||
j = scan(name(i:), " ")
|
||||
if (j==0) then
|
||||
j = len(name)
|
||||
else
|
||||
j = i + j - 2
|
||||
endif
|
||||
enddo
|
||||
|
||||
end function checkNCNames
|
||||
|
||||
|
||||
pure function checkNmtoken(name, xv) result(good)
|
||||
character(len=*), intent(in) :: name
|
||||
integer, intent(in) :: xv
|
||||
logical :: good
|
||||
! Validates a string against the XML requirements for an NCNAME
|
||||
! Is not fully compliant; ignores UTF issues.
|
||||
|
||||
good = isNameChar(name, xv)
|
||||
|
||||
end function checkNmtoken
|
||||
|
||||
|
||||
pure function checkNmtokens(name, xv) result(good)
|
||||
character(len=*), intent(in) :: name
|
||||
integer, intent(in) :: xv
|
||||
logical :: good
|
||||
! Validates a string against the XML requirements for an NCNAME
|
||||
! Is not fully compliant; ignores UTF issues.
|
||||
|
||||
integer :: i, j
|
||||
|
||||
good = (len(name) > 0)
|
||||
if (.not.good) return
|
||||
i = verify(name, " ")
|
||||
if (i==0) then
|
||||
good = .false.
|
||||
return
|
||||
endif
|
||||
j = scan(name(i:), " ")
|
||||
if (j==0) then
|
||||
j = len(name)
|
||||
else
|
||||
j = i + j - 2
|
||||
endif
|
||||
do
|
||||
good = isNameChar(name(i:j), xv)
|
||||
if (.not.good) return
|
||||
i = j + 1
|
||||
j = verify(name(i:), " ")
|
||||
if (j==0) exit
|
||||
i = i + j - 1
|
||||
j = scan(name(i:), " ")
|
||||
if (j==0) then
|
||||
j = len(name)
|
||||
else
|
||||
j = i + j - 2
|
||||
endif
|
||||
enddo
|
||||
|
||||
end function checkNmtokens
|
||||
|
||||
|
||||
function checkPublicId(value) result(good)
|
||||
character(len=*), intent(in) :: value
|
||||
logical :: good
|
||||
character(len=*), parameter :: PubIdChars = &
|
||||
" "//achar(10)//achar(13)//lowerCase//upperCase//digits//"-'()+,./:=?;!*#@$_%"
|
||||
|
||||
good = (verify(value, PubIdChars)==0)
|
||||
end function checkPublicId
|
||||
|
||||
|
||||
function checkPEDef(value, xv) result(p)
|
||||
character(len=*), intent(in) :: value
|
||||
integer, intent(in) :: xv
|
||||
logical :: p
|
||||
|
||||
integer :: i1, i2
|
||||
|
||||
p = .false.
|
||||
if (scan(value, '%&')==0) then
|
||||
p = .true.
|
||||
elseif (scan(value, '"')==0) then
|
||||
i1 = scan(value, '%&')
|
||||
i2 = 0
|
||||
do while (i1>0)
|
||||
i1 = i2 + i1
|
||||
i2 = index(value(i1+1:),';')
|
||||
if (i2==0) return
|
||||
i2 = i1 + i2
|
||||
if (value(i1:i1)=='&') then
|
||||
if (.not.checkName(value(i1+1:i2-1), xv) .and. &
|
||||
.not.checkCharacterEntityReference(value(i1+1:i2-1), xv)) return
|
||||
else
|
||||
if (.not.checkName(value(i1+1:i2-1), xv)) &
|
||||
return
|
||||
endif
|
||||
i1 = scan(value(i2+1:), '%&')
|
||||
enddo
|
||||
p = .true.
|
||||
endif
|
||||
end function checkPEDef
|
||||
|
||||
function checkPseudoAttValue(value, xv) result(p)
|
||||
character(len=*), intent(in) :: value
|
||||
integer, intent(in) :: xv
|
||||
logical :: p
|
||||
|
||||
integer :: i1, i2
|
||||
!fixme can we have entrefs in PIs?
|
||||
p = .false.
|
||||
if (scan(value, '"<&')==0) then
|
||||
p = .true.
|
||||
elseif (index(value, '&') > 0) then
|
||||
i1 = index(value, '&')
|
||||
i2 = 0
|
||||
do while (i1 > 0)
|
||||
i1 = i2 + i1
|
||||
i2 = index(value(i1+1:),';')
|
||||
if (i2==0) return
|
||||
i2 = i1 + i2
|
||||
if (value(i1+1:i2-1) /= 'amp' .and. &
|
||||
value(i1+1:i2-1) /= 'lt' .and. &
|
||||
value(i1+1:i2-1) /= 'gt' .and. &
|
||||
value(i1+1:i2-1) /= 'quot' .and. &
|
||||
value(i1+1:i2-1) /= 'apos' .and. &
|
||||
.not.checkCharacterEntityReference(value(i1+1:i2-1), xv)) &
|
||||
return
|
||||
i1 = index(value(i2+1:), '&')
|
||||
enddo
|
||||
p = .true.
|
||||
endif
|
||||
end function checkPseudoAttValue
|
||||
|
||||
function checkAttValue(value, xv) result(p)
|
||||
character(len=*), intent(in) :: value
|
||||
integer, intent(in) :: xv
|
||||
logical :: p
|
||||
! This function is called basically to make sure
|
||||
! that any attribute value looks like one. It will
|
||||
! not flag up out-of-range character entities, and
|
||||
! is a very weak check. Only used from xml_AddAttribute
|
||||
! when escaping is off.
|
||||
integer :: i1, i2
|
||||
|
||||
p = .false.
|
||||
if (scan(value, '"<&'//"'")==0) then
|
||||
p = .true.
|
||||
elseif (index(value, '&') > 0) then
|
||||
i1 = index(value, '&')
|
||||
i2 = 0
|
||||
do while (i1 > 0)
|
||||
i1 = i1 + i2 + 1
|
||||
i2 = scan(value(i1+1:),';')
|
||||
if (i2 == 0) return
|
||||
i2 = i1 + i2
|
||||
if (.not.checkName(value(i1+1:i2-1), xv) .and. &
|
||||
.not.likeCharacterEntityReference(value(i1+1:i2-1))) then
|
||||
print*, value(i1+1:i2-1), " ", &
|
||||
likeCharacterEntityReference(value(i1+1:i2-1))
|
||||
return
|
||||
endif
|
||||
i1 = index(value(i2+1:), '&')
|
||||
enddo
|
||||
p = .true.
|
||||
endif
|
||||
end function checkAttValue
|
||||
|
||||
|
||||
function likeCharacterEntityReference(code) result(good)
|
||||
character(len=*), intent(in) :: code
|
||||
logical :: good
|
||||
|
||||
good = .false.
|
||||
if (len(code) > 0) then
|
||||
if (code(1:1) == "#") then
|
||||
if (code(2:2) == "x") then
|
||||
if (len(code) > 2) then
|
||||
good = (verify(code(3:), hexdigits) == 0)
|
||||
endif
|
||||
else
|
||||
good = (verify(code(2:), digits) == 0)
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
|
||||
end function likeCharacterEntityReference
|
||||
|
||||
function checkCharacterEntityReference(code, xv) result(good)
|
||||
character(len=*), intent(in) :: code
|
||||
integer, intent(in) :: xv
|
||||
logical :: good
|
||||
|
||||
integer :: i
|
||||
|
||||
good = .false.
|
||||
if (len(code) > 0) then
|
||||
if (code(1:1) == "#") then
|
||||
if (code(2:2) == "x") then
|
||||
if (len(code) > 2) then
|
||||
good = (verify(code(3:), hexdigits) == 0)
|
||||
if (good) then
|
||||
i = str_to_int_16(code(3:))
|
||||
endif
|
||||
endif
|
||||
else
|
||||
good = (verify(code(2:), digits) == 0)
|
||||
if (good) then
|
||||
i = str_to_int_10(code(2:))
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
if (good) good = isLegalCharRef(i, xv)
|
||||
|
||||
end function checkCharacterEntityReference
|
||||
|
||||
function checkRepCharEntityReference(code, xv) result(good)
|
||||
character(len=*), intent(in) :: code
|
||||
integer, intent(in) :: xv
|
||||
logical :: good
|
||||
|
||||
! Is this a reference to a character we can actually represent
|
||||
! in memory? ie without unicode, US-ASCII only.
|
||||
|
||||
integer :: i
|
||||
|
||||
good = .false.
|
||||
if (len(code) > 0) then
|
||||
if (code(1:1) == "#") then
|
||||
if (code(2:2) == "x") then
|
||||
if (len(code) > 2) then
|
||||
good = (verify(code(3:), hexdigits) == 0)
|
||||
if (good) then
|
||||
i = str_to_int_16(code(3:))
|
||||
endif
|
||||
endif
|
||||
else
|
||||
good = (verify(code(2:), digits) == 0)
|
||||
if (good) then
|
||||
i = str_to_int_10(code(2:))
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
if (good) good = isRepCharRef(i, xv)
|
||||
|
||||
end function checkRepCharEntityReference
|
||||
|
||||
|
||||
pure function prefixOfQName(qname) result(prefix)
|
||||
character(len=*), intent(in) :: qname
|
||||
character(len=max(index(qname, ':')-1,0)) :: prefix
|
||||
|
||||
prefix = qname ! automatic truncation
|
||||
end function prefixOfQName
|
||||
|
||||
|
||||
pure function localpartOfQname(qname) result(localpart)
|
||||
character(len=*), intent(in) :: qname
|
||||
character(len=max(len(qname)-index(qname,':'),0)) ::localpart
|
||||
|
||||
localpart = qname(index(qname,':')+1:)
|
||||
end function localpartOfQname
|
||||
|
||||
#endif
|
||||
end module m_common_namecheck
|
||||
|
|
@ -1,830 +0,0 @@
|
|||
module m_common_namespaces
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
use fox_m_fsys_array_str, only: str_vs, vs_str, vs_str_alloc
|
||||
|
||||
use fox_m_utils_uri, only: URI, parseURI, destroyURI, hasScheme
|
||||
use m_common_attrs, only: dictionary_t, get_key, get_value, remove_key, getLength, hasKey
|
||||
use m_common_attrs, only: set_nsURI, set_localName, get_prefix, add_item_to_dict
|
||||
use m_common_charset, only: XML1_0, XML1_1
|
||||
use m_common_error, only: FoX_error, FoX_warning, error_stack, add_error, in_error
|
||||
use m_common_namecheck, only: checkNCName
|
||||
use m_common_struct, only: xml_doc_state
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
character(len=*), parameter :: invalidNS = '::INVALID::'
|
||||
! an invalid URI name to indicate a namespace error.
|
||||
|
||||
type URIMapping
|
||||
character, dimension(:), pointer :: URI
|
||||
integer :: ix ! link back to node depth
|
||||
end type URIMapping
|
||||
!This is a single URI, and the node depth under which
|
||||
!its namespace applies.
|
||||
|
||||
type prefixMapping
|
||||
character, dimension(:), pointer :: prefix
|
||||
type(URIMapping), dimension(:), pointer :: urilist
|
||||
end type prefixMapping
|
||||
!This is the mapping for a single prefix; with the
|
||||
!list of namespaces which are in force at various
|
||||
!depths
|
||||
|
||||
type namespaceDictionary
|
||||
private
|
||||
type(URIMapping), dimension(:), pointer :: defaults
|
||||
type(prefixMapping), dimension(:), pointer :: prefixes
|
||||
end type namespaceDictionary
|
||||
!This is the full namespace dictionary; defaults is
|
||||
!the list of default namespaces in force; prefix a
|
||||
!list of all prefixes in force.
|
||||
|
||||
public :: invalidNS
|
||||
|
||||
public :: initNamespaceDictionary
|
||||
public :: destroyNamespaceDictionary
|
||||
public :: namespaceDictionary
|
||||
public :: checkNamespaces
|
||||
public :: checkNamespacesWriting
|
||||
public :: checkEndNamespaces
|
||||
public :: getnamespaceURI
|
||||
interface getnamespaceURI
|
||||
module procedure getURIofDefaultNS, getURIofPrefixedNS
|
||||
end interface
|
||||
public :: isPrefixInForce
|
||||
public :: isDefaultNSInForce
|
||||
public :: getNumberOfPrefixes
|
||||
public :: getPrefixByIndex
|
||||
|
||||
public :: dumpnsdict !FIXME
|
||||
|
||||
public :: addDefaultNS
|
||||
public :: removeDefaultNS
|
||||
public :: addPrefixedNS
|
||||
public :: removePrefixedNS
|
||||
|
||||
contains
|
||||
|
||||
|
||||
subroutine initNamespaceDictionary(nsDict)
|
||||
type(namespaceDictionary), intent(inout) :: nsDict
|
||||
|
||||
!We need to properly initialize 0th elements
|
||||
!(which are never used) in order to provide
|
||||
!sensible behaviour when trying to manipulate
|
||||
!an empty dictionary.
|
||||
|
||||
allocate(nsDict%defaults(0:0))
|
||||
allocate(nsDict%defaults(0)%URI(0))
|
||||
!The 0th element of the defaults NS is the empty namespace
|
||||
nsDict%defaults(0)%ix = -1
|
||||
|
||||
allocate(nsDict%prefixes(0:0))
|
||||
allocate(nsDict%prefixes(0)%prefix(0))
|
||||
allocate(nsDict%prefixes(0)%urilist(0:0))
|
||||
allocate(nsDict%prefixes(0)%urilist(0)%URI(len(invalidNS)))
|
||||
nsDict%prefixes(0)%urilist(0)%URI = vs_str(invalidNS)
|
||||
nsDict%prefixes(0)%urilist(0)%ix = -1
|
||||
|
||||
end subroutine initNamespaceDictionary
|
||||
|
||||
|
||||
subroutine destroyNamespaceDictionary(nsDict)
|
||||
type(namespaceDictionary), intent(inout) :: nsDict
|
||||
|
||||
integer :: i, j
|
||||
|
||||
do i = 0, ubound(nsDict%defaults,1)
|
||||
deallocate(nsDict%defaults(i)%URI)
|
||||
enddo
|
||||
deallocate(nsDict%defaults)
|
||||
do i = 0, ubound(nsDict%prefixes,1)
|
||||
do j = 0, ubound(nsDict%prefixes(i)%urilist,1)
|
||||
deallocate(nsDict%prefixes(i)%urilist(j)%URI)
|
||||
enddo
|
||||
deallocate(nsDict%prefixes(i)%prefix)
|
||||
deallocate(nsDict%prefixes(i)%urilist)
|
||||
enddo
|
||||
deallocate(nsDict%prefixes)
|
||||
end subroutine destroyNamespaceDictionary
|
||||
|
||||
|
||||
subroutine copyURIMapping(urilist1, urilist2, l_m)
|
||||
type(URIMapping), dimension(0:), intent(inout) :: urilist1
|
||||
type(URIMapping), dimension(0:), intent(inout) :: urilist2
|
||||
integer, intent(in):: l_m
|
||||
integer :: i
|
||||
|
||||
if (ubound(urilist1,1) < l_m .or. ubound(urilist2,1) < l_m) then
|
||||
call FoX_error('Internal error in m_sax_namespaces:copyURIMapping')
|
||||
endif
|
||||
! Now copy all defaults across (or rather - add pointers to them)
|
||||
do i = 0, l_m
|
||||
urilist2(i)%ix = urilist1(i)%ix
|
||||
urilist2(i)%URI => urilist1(i)%URI
|
||||
enddo
|
||||
|
||||
end subroutine copyURIMapping
|
||||
|
||||
|
||||
subroutine addDefaultNS(nsDict, uri, ix, es)
|
||||
type(namespaceDictionary), intent(inout) :: nsDict
|
||||
character(len=*), intent(in) :: uri
|
||||
integer, intent(in) :: ix
|
||||
type(error_stack), intent(inout), optional :: es
|
||||
|
||||
type(URIMapping), dimension(:), allocatable :: tempMap
|
||||
integer :: l_m, l_s
|
||||
|
||||
if (uri=="http://www.w3.org/XML/1998/namespace") then
|
||||
if (present(es)) then
|
||||
call add_error(es, "Attempt to assign incorrect URI to prefix 'xml'")
|
||||
else
|
||||
call FoX_error("Attempt to assign incorrect URI to prefix 'xml'")
|
||||
endif
|
||||
elseif (uri=="http://www.w3.org/2000/xmlns/") then
|
||||
if (present(es)) then
|
||||
call add_error(es, "Attempt to assign prefix to xmlns namespace")
|
||||
else
|
||||
call FoX_error("Attempt to assign prefix to xmlns namespace")
|
||||
endif
|
||||
endif
|
||||
|
||||
! FIXME check URI is valid ...
|
||||
|
||||
l_m = ubound(nsDict%defaults,1)
|
||||
allocate(tempMap(0:l_m))
|
||||
! Now copy all defaults across ...
|
||||
call copyURIMapping(nsDict%defaults, tempMap, l_m)
|
||||
deallocate(nsDict%defaults)
|
||||
l_m = l_m + 1
|
||||
allocate(nsDict%defaults(0:l_m))
|
||||
!Now copy everything back ...
|
||||
call copyURIMapping(tempMap, nsDict%defaults, l_m-1)
|
||||
deallocate(tempMap)
|
||||
! And finally, add the new default NS
|
||||
nsDict%defaults(l_m)%ix = ix
|
||||
l_s = len(uri)
|
||||
allocate(nsDict%defaults(l_m)%URI(l_s))
|
||||
nsDict%defaults(l_m)%URI = vs_str(uri)
|
||||
|
||||
end subroutine addDefaultNS
|
||||
|
||||
|
||||
subroutine addPrefixedURI(nsPrefix, uri, ix)
|
||||
type(PrefixMapping), intent(inout) :: nsPrefix
|
||||
character, dimension(:), intent(in) :: uri
|
||||
integer, intent(in) :: ix
|
||||
|
||||
type(URIMapping), dimension(:), allocatable :: tempMap
|
||||
integer :: l_m, l_s
|
||||
|
||||
l_m = ubound(nsPrefix%urilist,1)
|
||||
allocate(tempMap(0:l_m))
|
||||
! Now copy all across ...
|
||||
call copyURIMapping(nsPrefix%urilist, tempMap, l_m)
|
||||
deallocate(nsPrefix%urilist)
|
||||
l_m = l_m + 1
|
||||
allocate(nsPrefix%urilist(0:l_m))
|
||||
!Now copy everything back ...
|
||||
call copyURIMapping(tempMap, nsPrefix%urilist, l_m-1)
|
||||
deallocate(tempMap)
|
||||
! And finally, add the new default NS
|
||||
nsPrefix%urilist(l_m)%ix = ix
|
||||
l_s = size(uri)
|
||||
allocate(nsPrefix%urilist(l_m)%URI(l_s))
|
||||
nsPrefix%urilist(l_m)%URI = uri
|
||||
|
||||
end subroutine addPrefixedURI
|
||||
|
||||
subroutine removeDefaultNS(nsDict)
|
||||
type(namespaceDictionary), intent(inout) :: nsDict
|
||||
|
||||
type(URIMapping), dimension(:), allocatable :: tempMap
|
||||
integer :: l_m
|
||||
|
||||
l_m = ubound(nsDict%defaults,1)
|
||||
allocate(tempMap(0:l_m-1))
|
||||
! Now copy all defaults across ...
|
||||
call copyURIMapping(nsDict%defaults, tempMap, l_m-1)
|
||||
!And remove tail-end charlie
|
||||
deallocate(nsDict%defaults(l_m)%URI)
|
||||
deallocate(nsDict%defaults)
|
||||
l_m = l_m - 1
|
||||
allocate(nsDict%defaults(0:l_m))
|
||||
!Now copy everything back ...
|
||||
call copyURIMapping(tempMap, nsDict%defaults, l_m)
|
||||
deallocate(tempMap)
|
||||
|
||||
end subroutine removeDefaultNS
|
||||
|
||||
subroutine removePrefixedURI(nsPrefix)
|
||||
type(PrefixMapping), intent(inout) :: nsPrefix
|
||||
|
||||
type(URIMapping), dimension(:), allocatable :: tempMap
|
||||
integer :: l_m
|
||||
|
||||
l_m = ubound(nsPrefix%urilist,1)
|
||||
allocate(tempMap(0:l_m-1))
|
||||
! Now copy all defaults across ...
|
||||
call copyURIMapping(nsPrefix%urilist, tempMap, l_m-1)
|
||||
!And remove tail-end charlie
|
||||
deallocate(nsPrefix%urilist(l_m)%URI)
|
||||
deallocate(nsPrefix%urilist)
|
||||
l_m = l_m - 1
|
||||
allocate(nsPrefix%urilist(0:l_m))
|
||||
!Now copy everything back ...
|
||||
call copyURIMapping(tempMap, nsPrefix%urilist, l_m)
|
||||
deallocate(tempMap)
|
||||
|
||||
end subroutine removePrefixedURI
|
||||
|
||||
subroutine addPrefixedNS(nsDict, prefix, URI, ix, xds, xml, es)
|
||||
type(namespaceDictionary), intent(inout) :: nsDict
|
||||
character(len=*), intent(in) :: prefix
|
||||
character(len=*), intent(in) :: uri
|
||||
integer, intent(in) :: ix
|
||||
type(xml_doc_state), intent(in) :: xds
|
||||
logical, intent(in), optional :: xml
|
||||
type(error_stack), intent(inout), optional :: es
|
||||
|
||||
integer :: l_p, p_i, i
|
||||
logical :: xml_
|
||||
|
||||
if (present(xml)) then
|
||||
xml_ = xml
|
||||
else
|
||||
xml_ = .false.
|
||||
endif
|
||||
|
||||
if (prefix=='xml' .and. &
|
||||
URI/='http://www.w3.org/XML/1998/namespace') then
|
||||
if (present(es)) then
|
||||
call add_error(es, "Attempt to assign incorrect URI to prefix 'xml'")
|
||||
else
|
||||
call FoX_error("Attempt to assign incorrect URI to prefix 'xml'")
|
||||
endif
|
||||
elseif (prefix/='xml' .and. &
|
||||
URI=='http://www.w3.org/XML/1998/namespace') then
|
||||
if (present(es)) then
|
||||
call add_error(es, "Attempt to assign incorrect prefix to XML namespace")
|
||||
else
|
||||
call FoX_error("Attempt to assign incorrect prefix to XML namespace")
|
||||
endif
|
||||
elseif (prefix == 'xmlns') then
|
||||
if (present(es)) then
|
||||
call add_error(es, "Attempt to declare 'xmlns' prefix")
|
||||
else
|
||||
call FoX_error("Attempt to declare 'xmlns' prefix")
|
||||
endif
|
||||
elseif (URI=="http://www.w3.org/2000/xmlns/") then
|
||||
if (present(es)) then
|
||||
call add_error(es, "Attempt to assign prefix to xmlns namespace")
|
||||
else
|
||||
call FoX_error("Attempt to assign prefix to xmlns namespace")
|
||||
endif
|
||||
elseif (len(prefix) > 2) then
|
||||
if ((verify(prefix(1:1), 'xX') == 0) &
|
||||
.and. (verify(prefix(2:2), 'mM') == 0) &
|
||||
.and. (verify(prefix(3:3), 'lL') == 0)) then
|
||||
if (.not.xml_) then
|
||||
! FIXME need working warning infrastructure
|
||||
!if (present(es)) then
|
||||
! call add_error(es, "Attempt to declare reserved prefix: "//prefix)
|
||||
!else
|
||||
call FoX_warning("Attempt to declare reserved prefix: "//prefix)
|
||||
!endif
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
|
||||
if (.not.checkNCName(prefix, xds%xml_version)) &
|
||||
call FoX_error("Attempt to declare invalid prefix: "//prefix)
|
||||
|
||||
! FIXME check URI is valid
|
||||
|
||||
l_p = ubound(nsDict%prefixes, 1)
|
||||
|
||||
p_i = 0
|
||||
do i = 1, l_p
|
||||
if (str_vs(nsDict%prefixes(i)%prefix) == prefix) then
|
||||
p_i = i
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
|
||||
if (p_i == 0) then
|
||||
call addPrefix(nsDict, vs_str(prefix))
|
||||
p_i = l_p + 1
|
||||
endif
|
||||
|
||||
call addPrefixedURI(nsDict%prefixes(p_i), vs_str(URI), ix)
|
||||
|
||||
end subroutine addPrefixedNS
|
||||
|
||||
subroutine removePrefixedNS(nsDict, prefix)
|
||||
type(namespaceDictionary), intent(inout) :: nsDict
|
||||
character, dimension(:), intent(in) :: prefix
|
||||
integer :: l_p, p_i, i
|
||||
l_p = ubound(nsDict%prefixes, 1)
|
||||
|
||||
p_i = 0
|
||||
do i = 1, l_p
|
||||
if (str_vs(nsDict%prefixes(i)%prefix) == str_vs(prefix)) then
|
||||
p_i = i
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
|
||||
if (p_i /= 0) then
|
||||
call removePrefixedURI(nsDict%prefixes(p_i))
|
||||
if (ubound(nsDict%prefixes(p_i)%urilist,1) == 0) then
|
||||
!that was the last mapping for that prefix
|
||||
call removePrefix(nsDict, p_i)
|
||||
endif
|
||||
else
|
||||
call FoX_error('Internal error in m_sax_namespaces:removePrefixedNS')
|
||||
endif
|
||||
|
||||
end subroutine removePrefixedNS
|
||||
|
||||
subroutine addPrefix(nsDict, prefix)
|
||||
type(namespaceDictionary), intent(inout) :: nsDict
|
||||
character, dimension(:), intent(in) :: prefix
|
||||
integer :: l_p
|
||||
|
||||
type(prefixMapping), dimension(:), pointer :: tempPrefixMap
|
||||
|
||||
integer :: i
|
||||
|
||||
!Add a new prefix to the namespace dictionary.
|
||||
!Unfortunately this involves copying the entire
|
||||
!prefixes dictionary to a temporary structure, then
|
||||
!reallocating the prefixes dictionary to be one
|
||||
!longer, then copying everything back:
|
||||
|
||||
l_p = ubound(nsDict%prefixes, 1)
|
||||
allocate(tempPrefixMap(0:l_p))
|
||||
|
||||
!for each current prefix, append everything to temporary structure
|
||||
do i = 0, l_p
|
||||
tempPrefixMap(i)%prefix => nsDict%prefixes(i)%prefix
|
||||
tempPrefixMap(i)%urilist => nsDict%prefixes(i)%urilist
|
||||
enddo
|
||||
deallocate(nsDict%prefixes)
|
||||
!extend prefix dictionary by one ...
|
||||
l_p = l_p + 1
|
||||
allocate(nsDict%prefixes(0:l_p))
|
||||
!and copy back ...
|
||||
do i = 0, l_p-1
|
||||
nsDict%prefixes(i)%prefix => tempPrefixMap(i)%prefix
|
||||
nsDict%prefixes(i)%urilist => tempPrefixMap(i)%urilist
|
||||
enddo
|
||||
deallocate(tempPrefixMap)
|
||||
|
||||
allocate(nsDict%prefixes(l_p)%prefix(size(prefix)))
|
||||
nsDict%prefixes(l_p)%prefix = prefix
|
||||
allocate(nsDict%prefixes(l_p)%urilist(0:0))
|
||||
allocate(nsDict%prefixes(l_p)%urilist(0)%URI(len(invalidNS)))
|
||||
nsDict%prefixes(l_p)%urilist(0)%URI = vs_str(invalidNS)
|
||||
nsDict%prefixes(l_p)%urilist(0)%ix = -1
|
||||
|
||||
end subroutine addPrefix
|
||||
|
||||
subroutine removePrefix(nsDict, i_p)
|
||||
type(namespaceDictionary), intent(inout) :: nsDict
|
||||
integer, intent(in) :: i_p
|
||||
integer :: l_p
|
||||
|
||||
type(prefixMapping), dimension(:), pointer :: tempPrefixMap
|
||||
|
||||
integer :: i
|
||||
|
||||
!Remove a prefix from the namespace dictionary.
|
||||
!Unfortunately this involves copying the entire
|
||||
!prefixes dictionary to a temporary structure, then
|
||||
!reallocating the prefixes dictionary to be one
|
||||
!shorter, then copying everything back:
|
||||
|
||||
l_p = ubound(nsDict%prefixes, 1)
|
||||
allocate(tempPrefixMap(0:l_p-1))
|
||||
|
||||
!for each current prefix, append everything to temporary structure
|
||||
do i = 0, i_p-1
|
||||
tempPrefixMap(i)%prefix => nsDict%prefixes(i)%prefix
|
||||
tempPrefixMap(i)%urilist => nsDict%prefixes(i)%urilist
|
||||
enddo
|
||||
deallocate(nsDict%prefixes(i_p)%urilist(0)%URI)
|
||||
deallocate(nsDict%prefixes(i_p)%urilist)
|
||||
deallocate(nsDict%prefixes(i_p)%prefix)
|
||||
!this subroutine will only get called if the urilist is already
|
||||
!empty, so no need to deallocate it.
|
||||
do i = i_p+1, l_p
|
||||
tempPrefixMap(i-1)%prefix => nsDict%prefixes(i)%prefix
|
||||
tempPrefixMap(i-1)%urilist => nsDict%prefixes(i)%urilist
|
||||
enddo
|
||||
deallocate(nsDict%prefixes)
|
||||
!shorten prefix dictionary by one ...
|
||||
l_p = l_p - 1
|
||||
allocate(nsDict%prefixes(0:l_p))
|
||||
!and copy back ...
|
||||
do i = 0, l_p
|
||||
nsDict%prefixes(i)%prefix => tempPrefixMap(i)%prefix
|
||||
nsDict%prefixes(i)%urilist => tempPrefixMap(i)%urilist
|
||||
enddo
|
||||
deallocate(tempPrefixMap)
|
||||
|
||||
end subroutine removePrefix
|
||||
|
||||
|
||||
subroutine checkNamespaces(atts, nsDict, ix, xds, namespace_prefixes, xmlns_uris, es, &
|
||||
partial, start_prefix_handler, end_prefix_handler)
|
||||
type(dictionary_t), intent(inout) :: atts
|
||||
type(namespaceDictionary), intent(inout) :: nsDict
|
||||
integer, intent(in) :: ix ! depth of nesting of current element.
|
||||
type(xml_doc_state), intent(in) :: xds
|
||||
logical, intent(in) :: namespace_prefixes, xmlns_uris
|
||||
type(error_stack), intent(inout) :: es
|
||||
logical, intent(in) :: partial ! if so, don't try and resolve anything except xml & xmlns
|
||||
optional :: start_prefix_handler, end_prefix_handler
|
||||
|
||||
interface
|
||||
subroutine start_prefix_handler(namespaceURI, prefix)
|
||||
character(len=*), intent(in) :: namespaceURI
|
||||
character(len=*), intent(in) :: prefix
|
||||
end subroutine start_prefix_handler
|
||||
subroutine end_prefix_handler(prefix)
|
||||
character(len=*), intent(in) :: prefix
|
||||
end subroutine end_prefix_handler
|
||||
end interface
|
||||
|
||||
character(len=6) :: xmlns
|
||||
character, dimension(:), pointer :: QName, URIstring
|
||||
integer :: i, n
|
||||
type(URI), pointer :: URIref
|
||||
!Check for namespaces; *and* remove xmlns references from
|
||||
!the attributes dictionary.
|
||||
|
||||
! we can't do a simple loop across the attributes,
|
||||
! because we need to remove some as we go along ...
|
||||
i = 1
|
||||
do while (i <= getLength(atts))
|
||||
xmlns = get_key(atts, i)
|
||||
if (xmlns == 'xmlns ') then
|
||||
!Default namespace is being set
|
||||
URIstring => vs_str_alloc(get_value(atts, i))
|
||||
if (str_vs(URIstring)=="") then
|
||||
! Empty nsURI on default namespace has same effect in 1.0 and 1.1
|
||||
if (present(end_prefix_handler)) &
|
||||
call end_prefix_handler("")
|
||||
call addDefaultNS(nsDict, invalidNS, ix)
|
||||
deallocate(URIstring)
|
||||
else
|
||||
URIref => parseURI(str_vs(URIstring))
|
||||
if (.not.associated(URIref)) then
|
||||
call add_error(es, "Invalid URI: "//str_vs(URIstring))
|
||||
deallocate(URIstring)
|
||||
return
|
||||
elseif (.not.hasScheme(URIref)) then
|
||||
call add_error(es, "Relative namespace in URI deprecated: "//str_vs(URIstring))
|
||||
deallocate(URIstring)
|
||||
call destroyURI(URIref)
|
||||
return
|
||||
endif
|
||||
call destroyURI(URIref)
|
||||
if (present(start_prefix_handler)) &
|
||||
call start_prefix_handler(str_vs(URIstring), "")
|
||||
call addDefaultNS(nsDict, str_vs(URIstring), ix)
|
||||
deallocate(URIstring)
|
||||
endif
|
||||
if (namespace_prefixes) then
|
||||
i = i + 1
|
||||
else
|
||||
call remove_key(atts, i)
|
||||
endif
|
||||
elseif (xmlns == 'xmlns:') then
|
||||
!Prefixed namespace is being set
|
||||
QName => vs_str_alloc(get_key(atts, i))
|
||||
URIstring => vs_str_alloc(get_value(atts, i))
|
||||
if (str_vs(URIstring)=="") then
|
||||
if (xds%xml_version==XML1_0) then
|
||||
call add_error(es, "Empty nsURI is invalid in XML 1.0")
|
||||
deallocate(URIstring)
|
||||
deallocate(QName)
|
||||
return
|
||||
elseif (xds%xml_version==XML1_1) then
|
||||
call addPrefixedNS(nsDict, str_vs(QName(7:)), invalidNS, ix, xds, es=es)
|
||||
if (in_error(es)) then
|
||||
deallocate(URIstring)
|
||||
deallocate(QName)
|
||||
return
|
||||
elseif (present(end_prefix_handler)) then
|
||||
call end_prefix_handler(str_vs(QName(7:)))
|
||||
endif
|
||||
deallocate(URIstring)
|
||||
deallocate(QName)
|
||||
endif
|
||||
else
|
||||
URIref => parseURI(str_vs(URIstring))
|
||||
if (.not.associated(URIref)) then
|
||||
call add_error(es, "Invalid URI: "//str_vs(URIstring))
|
||||
deallocate(URIstring)
|
||||
deallocate(QName)
|
||||
return
|
||||
elseif (.not.hasScheme(URIref)) then
|
||||
call add_error(es, "Relative namespace in URI deprecated: "//str_vs(URIstring))
|
||||
deallocate(URIstring)
|
||||
deallocate(QName)
|
||||
call destroyURI(URIref)
|
||||
return
|
||||
endif
|
||||
call destroyURI(URIref)
|
||||
call addPrefixedNS(nsDict, str_vs(QName(7:)), str_vs(URIstring), ix, xds, es=es)
|
||||
if (in_error(es)) then
|
||||
deallocate(URIstring)
|
||||
deallocate(QName)
|
||||
return
|
||||
elseif (present(start_prefix_handler)) then
|
||||
call start_prefix_handler(str_vs(URIstring), str_vs(QName(7:)))
|
||||
endif
|
||||
deallocate(URIstring)
|
||||
deallocate(QName)
|
||||
endif
|
||||
if (namespace_prefixes) then
|
||||
i = i + 1
|
||||
else
|
||||
call remove_key(atts, i)
|
||||
endif
|
||||
else
|
||||
! we only increment if we haven't removed a key
|
||||
i = i + 1
|
||||
endif
|
||||
enddo
|
||||
|
||||
! having done that, now resolve all attribute namespaces:
|
||||
do i = 1, getLength(atts)
|
||||
QName => vs_str_alloc(get_key(atts,i))
|
||||
n = index(str_vs(QName), ":")
|
||||
if (n > 0) then
|
||||
if (str_vs(QName(1:n-1))=="xmlns") then
|
||||
! FIXME but this can be controlled by SAX configuration xmlns-uris
|
||||
if (xmlns_uris) then
|
||||
call set_nsURI(atts, i, "http://www.w3.org/2000/xmlns/")
|
||||
else
|
||||
call set_nsURI(atts, i, "")
|
||||
endif
|
||||
else
|
||||
if (str_vs(QName(1:n-1))=="xml") then
|
||||
call set_nsURI(atts, i, "http://www.w3.org/XML/1998/namespace")
|
||||
elseif (getnamespaceURI(nsDict, str_vs(QName(1:n-1)))==invalidNS) then
|
||||
! Sometimes we don't want to worry about unbound prefixes,
|
||||
! eg if we are in the middle of parsing an entity.
|
||||
if (.not.partial) then
|
||||
call add_error(es, "Unbound namespace prefix")
|
||||
deallocate(QName)
|
||||
return
|
||||
else
|
||||
call set_nsURI(atts, i, "")
|
||||
endif
|
||||
else
|
||||
call set_nsURI(atts, i, getnamespaceURI(nsDict, str_vs(QName(1:n-1))))
|
||||
endif
|
||||
endif
|
||||
else
|
||||
if (xmlns_uris.and.str_vs(QName)=="xmlns") then
|
||||
call set_nsURI(atts, i, "http://www.w3.org/2000/xmlns/")
|
||||
else
|
||||
call set_nsURI(atts, i, "") ! no such thing as a default namespace on attributes
|
||||
endif
|
||||
endif
|
||||
! Check for duplicates
|
||||
if (hasKey(atts, getnamespaceURI(nsDict, str_vs(QName(1:n-1))), str_vs(QName(n+1:)))) then
|
||||
call add_error(es, "Duplicate attribute names after namespace processing")
|
||||
deallocate(QName)
|
||||
return
|
||||
endif
|
||||
call set_localName(atts, i, QName(n+1:))
|
||||
deallocate(QName)
|
||||
enddo
|
||||
|
||||
end subroutine checkNamespaces
|
||||
|
||||
|
||||
subroutine checkNamespacesWriting(atts, nsdict, ix)
|
||||
type(dictionary_t), intent(inout) :: atts
|
||||
type(namespaceDictionary), intent(inout) :: nsDict
|
||||
integer, intent(in) :: ix
|
||||
! Read through a list of attributes, check with currently
|
||||
! active namespaces & add any necessary declarations
|
||||
|
||||
integer :: i, i_p, l_d, l_ps, n
|
||||
|
||||
n = getLength(atts) ! we need the length before we fiddle with it
|
||||
|
||||
!Does the default NS need added?
|
||||
l_d = ubound(nsDict%defaults,1)
|
||||
if (nsDict%defaults(l_d)%ix == ix) then
|
||||
!It's not been registered yet:
|
||||
call add_item_to_dict(atts, "xmlns", &
|
||||
str_vs(nsDict%defaults(l_d)%URI), type="CDATA")
|
||||
endif
|
||||
|
||||
!next, add any overdue prefixed NS's in the same way:
|
||||
! there should only ever be one. More would be an error,
|
||||
! but the check should have been done earlier.
|
||||
do i_p = 0, ubound(nsDict%prefixes, 1)
|
||||
l_ps = ubound(nsDict%prefixes(i_p)%urilist,1)
|
||||
if (nsDict%prefixes(i_p)%urilist(l_ps)%ix == ix) then
|
||||
call add_item_to_dict(atts, &
|
||||
"xmlns:"//str_vs(nsDict%prefixes(i_p)%prefix), &
|
||||
str_vs(nsDict%prefixes(i_p)%urilist(l_ps)%URI), &
|
||||
type="CDATA")
|
||||
endif
|
||||
enddo
|
||||
|
||||
|
||||
!Finally, we may have some we've added for attribute QNames
|
||||
! have to get those too:
|
||||
do i = 1, getLength(atts)
|
||||
! get prefix, and identify the relevant NS mapping
|
||||
i_p = getPrefixIndex(nsDict, get_prefix(atts, i))
|
||||
l_ps = ubound(nsDict%prefixes(i_p)%urilist,1)
|
||||
!If the index is greater than what it should be:
|
||||
if (nsDict%prefixes(i_p)%urilist(l_ps)%ix > ix) then
|
||||
!we only just added this, so we need to declare it
|
||||
call add_item_to_dict(atts, "xmlns:"//get_prefix(atts, i), &
|
||||
str_vs(nsDict%prefixes(i_p)%urilist(l_ps)%URI), &
|
||||
type="CDATA")
|
||||
!Reset the index to the right value:
|
||||
nsDict%prefixes(i_p)%urilist(l_ps)%ix = ix
|
||||
endif
|
||||
enddo
|
||||
|
||||
end subroutine checkNamespacesWriting
|
||||
|
||||
|
||||
subroutine checkEndNamespaces(nsDict, ix, end_prefix_handler)
|
||||
type(namespaceDictionary), intent(inout) :: nsDict
|
||||
integer, intent(in) :: ix
|
||||
|
||||
optional :: end_prefix_handler
|
||||
|
||||
interface
|
||||
subroutine end_prefix_handler(prefix)
|
||||
character(len=*), intent(in) :: prefix
|
||||
end subroutine end_prefix_handler
|
||||
end interface
|
||||
|
||||
integer :: l_d, l_p, l_ps, i
|
||||
character, pointer :: prefix(:)
|
||||
|
||||
!It will only ever be the final elements in the list which
|
||||
! might have expired.
|
||||
|
||||
l_d = ubound(nsDict%defaults,1)
|
||||
do while (nsDict%defaults(l_d)%ix == ix)
|
||||
if (present(end_prefix_handler)) &
|
||||
call end_prefix_handler("")
|
||||
call removeDefaultNS(nsDict)
|
||||
l_d = ubound(nsDict%defaults,1)
|
||||
enddo
|
||||
|
||||
l_p = ubound(nsDict%prefixes, 1)
|
||||
i = 1
|
||||
do while (i <= l_p)
|
||||
l_ps = ubound(nsDict%prefixes(l_p)%urilist,1)
|
||||
if (nsDict%prefixes(i)%urilist(l_ps)%ix == ix) then
|
||||
if (present(end_prefix_handler)) &
|
||||
call end_prefix_handler(str_vs(nsDict%prefixes(i)%prefix))
|
||||
! We have to assign this pointer explicitly, otherwise the next call
|
||||
! aliases its arguments illegally.
|
||||
prefix => nsDict%prefixes(i)%prefix
|
||||
call removePrefixedNS(nsDict, prefix)
|
||||
if (l_p > ubound(nsDict%prefixes, 1)) then
|
||||
! we just removed the last reference to that prefix,
|
||||
! so our list of prefixes has shrunk - update the running total.
|
||||
! and go to the next prefix, which is at the same index
|
||||
l_p = l_p - 1
|
||||
cycle
|
||||
endif
|
||||
endif
|
||||
i = i + 1
|
||||
enddo
|
||||
|
||||
end subroutine checkEndNamespaces
|
||||
|
||||
|
||||
subroutine dumpnsdict(nsdict)
|
||||
type(namespaceDictionary), intent(in) :: nsdict
|
||||
integer :: i, j
|
||||
write(*,'(a)')'* default namespaces *'
|
||||
|
||||
do i = 1, ubound(nsdict%defaults, 1)
|
||||
write(*,'(i0,a)') nsdict%defaults(i)%ix, str_vs(nsdict%defaults(i)%URI)
|
||||
enddo
|
||||
write(*,'(a)') '* Prefixed namespaces *'
|
||||
do i = 1, ubound(nsdict%prefixes, 1)
|
||||
write(*,'(2a)') '* prefix: ', str_vs(nsdict%prefixes(i)%prefix)
|
||||
do j = 1, ubound(nsdict%prefixes(i)%urilist, 1)
|
||||
write(*,'(i0,a)') nsdict%prefixes(i)%urilist(j)%ix, str_vs(nsdict%prefixes(i)%urilist(j)%URI)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end subroutine dumpnsdict
|
||||
|
||||
|
||||
pure function getURIofDefaultNS(nsDict) result(uri)
|
||||
type(namespaceDictionary), intent(in) :: nsDict
|
||||
character(len=size(nsDict%defaults(ubound(nsDict%defaults,1))%URI)) :: URI
|
||||
|
||||
integer :: l_d
|
||||
l_d = ubound(nsDict%defaults,1)
|
||||
uri = str_vs(nsDict%defaults(l_d)%URI)
|
||||
end function getURIofDefaultNS
|
||||
|
||||
|
||||
pure function isPrefixInForce(nsDict, prefix) result(force)
|
||||
type(namespaceDictionary), intent(in) :: nsDict
|
||||
character(len=*), intent(in) :: prefix
|
||||
logical :: force
|
||||
integer :: i, l_s
|
||||
|
||||
force = .false.
|
||||
do i = 1, ubound(nsDict%prefixes, 1)
|
||||
if (str_vs(nsDict%prefixes(i)%prefix) == prefix) then
|
||||
l_s = ubound(nsDict%prefixes(i)%urilist, 1)
|
||||
force = (size(nsdict%prefixes(i)%urilist(l_s)%URI) > 0)
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
|
||||
end function isPrefixInForce
|
||||
|
||||
|
||||
pure function isDefaultNSInForce(nsDict) result(force)
|
||||
type(namespaceDictionary), intent(in) :: nsDict
|
||||
logical :: force
|
||||
integer :: l_s
|
||||
|
||||
force = .false.
|
||||
l_s = ubound(nsDict%defaults, 1)
|
||||
if (l_s > 0) &
|
||||
force = (size(nsdict%defaults(l_s)%URI) > 0)
|
||||
|
||||
end function isDefaultNSInForce
|
||||
|
||||
|
||||
pure function getPrefixIndex(nsDict, prefix) result(p)
|
||||
type(namespaceDictionary), intent(in) :: nsDict
|
||||
character(len=*), intent(in) :: prefix
|
||||
integer :: p
|
||||
|
||||
integer :: i
|
||||
p = 0
|
||||
do i = 1, ubound(nsDict%prefixes, 1)
|
||||
if (str_vs(nsDict%prefixes(i)%prefix) == prefix) then
|
||||
p = i
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
end function getPrefixIndex
|
||||
|
||||
|
||||
function getNumberOfPrefixes(nsDict) result(n)
|
||||
type(namespaceDictionary), intent(in) :: nsDict
|
||||
integer :: n
|
||||
n = ubound(nsDict%prefixes, 1)
|
||||
end function getNumberOfPrefixes
|
||||
|
||||
|
||||
function getPrefixByIndex(nsDict, i) result(c)
|
||||
type(namespaceDictionary), intent(in) :: nsDict
|
||||
integer, intent(in) :: i
|
||||
character(len=size(nsDict%prefixes(i)%prefix)) :: c
|
||||
|
||||
c = str_vs(nsDict%prefixes(i)%prefix)
|
||||
end function getPrefixByIndex
|
||||
|
||||
|
||||
pure function getURIofPrefixedNS(nsDict, prefix) result(uri)
|
||||
type(namespaceDictionary), intent(in) :: nsDict
|
||||
character(len=*), intent(in) :: prefix
|
||||
character(len=size( &
|
||||
nsDict%prefixes( &
|
||||
getPrefixIndex(nsDict,prefix) &
|
||||
) &
|
||||
%urilist( &
|
||||
ubound(nsDict%prefixes(getPrefixIndex(nsDict,prefix))%urilist, 1) &
|
||||
) &
|
||||
%uri)) :: URI
|
||||
integer :: p_i, l_m
|
||||
p_i = getPrefixIndex(nsDict, prefix)
|
||||
l_m = ubound(nsDict%prefixes(p_i)%urilist, 1)
|
||||
uri = str_vs(nsDict%prefixes(p_i)%urilist(l_m)%URI)
|
||||
|
||||
end function getURIofPrefixedNS
|
||||
|
||||
#endif
|
||||
end module m_common_namespaces
|
||||
|
|
@ -1,120 +0,0 @@
|
|||
module m_common_notations
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
use fox_m_fsys_array_str, only: vs_str, str_vs
|
||||
use m_common_error, only: FoX_error
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
type notation
|
||||
character(len=1), dimension(:), pointer :: name
|
||||
character(len=1), dimension(:), pointer :: systemID
|
||||
character(len=1), dimension(:), pointer :: publicId
|
||||
end type notation
|
||||
|
||||
type notation_list
|
||||
type(notation), dimension(:), pointer :: list
|
||||
end type notation_list
|
||||
|
||||
public :: notation
|
||||
public :: notation_list
|
||||
public :: init_notation_list
|
||||
public :: destroy_notation_list
|
||||
public :: add_notation
|
||||
public :: notation_exists
|
||||
|
||||
contains
|
||||
|
||||
subroutine init_notation_list(nlist)
|
||||
! It is not clear how we should specify the
|
||||
! intent of this argument - different
|
||||
! compilers seem to have different semantics
|
||||
type(notation_list), intent(inout) :: nlist
|
||||
|
||||
allocate(nlist%list(0:0))
|
||||
allocate(nlist%list(0)%name(0))
|
||||
allocate(nlist%list(0)%systemId(0))
|
||||
allocate(nlist%list(0)%publicId(0))
|
||||
|
||||
end subroutine init_notation_list
|
||||
|
||||
|
||||
subroutine destroy_notation_list(nlist)
|
||||
type(notation_list), intent(inout) :: nlist
|
||||
|
||||
integer :: i
|
||||
|
||||
do i = 0, ubound(nlist%list, 1)
|
||||
deallocate(nlist%list(i)%name)
|
||||
deallocate(nlist%list(i)%systemId)
|
||||
deallocate(nlist%list(i)%publicId)
|
||||
enddo
|
||||
deallocate(nlist%list)
|
||||
end subroutine destroy_notation_list
|
||||
|
||||
|
||||
subroutine add_notation(nlist, name, systemId, publicId)
|
||||
type(notation_list), intent(inout) :: nlist
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=*), intent(in), optional :: systemId
|
||||
character(len=*), intent(in), optional :: publicId
|
||||
|
||||
integer :: i
|
||||
type(notation), dimension(:), pointer :: temp
|
||||
! pointer not allocatable to avoid bug on Lahey
|
||||
|
||||
if (.not.present(systemId) .and. .not.present(publicId)) &
|
||||
call FoX_error("Neither System nor Public Id specified for notation: "//name)
|
||||
|
||||
allocate(temp(0:ubound(nlist%list,1)))
|
||||
do i = 0, ubound(nlist%list, 1)
|
||||
temp(i)%name => nlist%list(i)%name
|
||||
temp(i)%systemId => nlist%list(i)%systemId
|
||||
temp(i)%publicId => nlist%list(i)%publicId
|
||||
enddo
|
||||
|
||||
deallocate(nlist%list)
|
||||
allocate(nlist%list(0:ubound(temp, 1)+1))
|
||||
do i = 0, ubound(temp, 1)
|
||||
nlist%list(i)%name => temp(i)%name
|
||||
nlist%list(i)%systemId => temp(i)%systemId
|
||||
nlist%list(i)%publicId => temp(i)%publicId
|
||||
enddo
|
||||
deallocate(temp)
|
||||
|
||||
allocate(nlist%list(i)%name(len(name)))
|
||||
nlist%list(i)%name = vs_str(name)
|
||||
if (present(systemId)) then
|
||||
allocate(nlist%list(i)%systemId(len(systemId)))
|
||||
nlist%list(i)%systemId = vs_str(systemId)
|
||||
else
|
||||
allocate(nlist%list(i)%systemId(0))
|
||||
endif
|
||||
if (present(publicId)) then
|
||||
allocate(nlist%list(i)%publicId(len(publicId)))
|
||||
nlist%list(i)%publicId = vs_str(publicId)
|
||||
else
|
||||
allocate(nlist%list(i)%publicId(0))
|
||||
endif
|
||||
end subroutine add_notation
|
||||
|
||||
|
||||
function notation_exists(nlist, name) result(p)
|
||||
type(notation_list), intent(in) :: nlist
|
||||
character(len=*), intent(in) :: name
|
||||
logical :: p
|
||||
|
||||
integer :: i
|
||||
|
||||
p = .false.
|
||||
do i = 1, ubound(nlist%list, 1)
|
||||
if (str_vs(nlist%list(i)%name) == name) then
|
||||
p = .true.
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
end function notation_exists
|
||||
|
||||
#endif
|
||||
end module m_common_notations
|
||||
|
|
@ -1,121 +0,0 @@
|
|||
module m_common_struct
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
! Common parts of an XML document. Shared by both SAX & WXML.
|
||||
|
||||
use FoX_utils, only: URI
|
||||
|
||||
use m_common_charset, only: XML1_0
|
||||
use m_common_entities, only: entity_list, init_entity_list, destroy_entity_list, &
|
||||
add_internal_entity, add_external_entity
|
||||
use m_common_element, only: element_list, init_element_list, destroy_element_list
|
||||
use m_common_notations, only: notation_list, init_notation_list, destroy_notation_list
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
type xml_doc_state
|
||||
logical :: building = .false. ! Are we in the middle of building this doc?
|
||||
integer :: xml_version = XML1_0
|
||||
logical :: standalone_declared = .false.
|
||||
logical :: standalone = .false.
|
||||
type(entity_list) :: entityList
|
||||
type(entity_list) :: PEList
|
||||
type(notation_list) :: nList
|
||||
type(element_list) :: element_list
|
||||
logical :: warning = .false. ! Do we care about warnings?
|
||||
logical :: valid = .true. ! Do we care about validity?
|
||||
logical :: liveNodeLists = .true. ! Do we want live nodelists?
|
||||
character, pointer :: encoding(:) => null()
|
||||
character, pointer :: inputEncoding(:) => null()
|
||||
character, pointer :: documentURI(:) => null()
|
||||
character, pointer :: intSubset(:) => null()
|
||||
end type xml_doc_state
|
||||
|
||||
public :: xml_doc_state
|
||||
|
||||
public :: init_xml_doc_state
|
||||
public :: destroy_xml_doc_state
|
||||
|
||||
public :: register_internal_PE
|
||||
public :: register_external_PE
|
||||
public :: register_internal_GE
|
||||
public :: register_external_GE
|
||||
|
||||
contains
|
||||
|
||||
subroutine init_xml_doc_state(xds)
|
||||
type(xml_doc_state), intent(inout) :: xds
|
||||
call init_entity_list(xds%entityList)
|
||||
call init_entity_list(xds%PEList)
|
||||
call init_notation_list(xds%nList)
|
||||
call init_element_list(xds%element_list)
|
||||
allocate(xds%inputEncoding(0))
|
||||
allocate(xds%intSubset(0))
|
||||
end subroutine init_xml_doc_state
|
||||
|
||||
subroutine destroy_xml_doc_state(xds)
|
||||
type(xml_doc_state), intent(inout) :: xds
|
||||
call destroy_entity_list(xds%entityList)
|
||||
call destroy_entity_list(xds%PEList)
|
||||
call destroy_notation_list(xds%nList)
|
||||
call destroy_element_list(xds%element_list)
|
||||
if (associated(xds%encoding)) deallocate(xds%encoding)
|
||||
if (associated(xds%inputEncoding)) deallocate(xds%inputEncoding)
|
||||
if (associated(xds%documentURI)) deallocate(xds%documentURI)
|
||||
deallocate(xds%intSubset)
|
||||
end subroutine destroy_xml_doc_state
|
||||
|
||||
subroutine register_internal_PE(xds, name, text, wfc, baseURI)
|
||||
type(xml_doc_state), intent(inout) :: xds
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=*), intent(in) :: text
|
||||
logical, intent(in) :: wfc
|
||||
type(URI), pointer :: baseURI
|
||||
|
||||
call add_internal_entity(xds%PEList, name=name, text=text, &
|
||||
wfc=wfc, baseURI=baseURI)
|
||||
|
||||
end subroutine register_internal_PE
|
||||
|
||||
subroutine register_external_PE(xds, name, systemId, wfc, baseURI, publicId)
|
||||
type(xml_doc_state), intent(inout) :: xds
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=*), intent(in) :: systemId
|
||||
logical, intent(in) :: wfc
|
||||
character(len=*), intent(in), optional :: publicId
|
||||
type(URI), pointer :: baseURI
|
||||
|
||||
call add_external_entity(xds%PEList, name=name, &
|
||||
publicId=publicId, systemId=systemId, &
|
||||
wfc=wfc, baseURI=baseURI)
|
||||
end subroutine register_external_PE
|
||||
|
||||
subroutine register_internal_GE(xds, name, text, wfc, baseURI)
|
||||
type(xml_doc_state), intent(inout) :: xds
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=*), intent(in) :: text
|
||||
logical, intent(in) :: wfc
|
||||
type(URI), pointer :: baseURI
|
||||
|
||||
call add_internal_entity(xds%entityList, name=name, text=text, &
|
||||
wfc=wfc, baseURI=baseURI)
|
||||
|
||||
end subroutine register_internal_GE
|
||||
|
||||
subroutine register_external_GE(xds, name, systemId, wfc, baseURI, publicId, notation)
|
||||
type(xml_doc_state), intent(inout) :: xds
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=*), intent(in) :: systemId
|
||||
logical, intent(in) :: wfc
|
||||
character(len=*), intent(in), optional :: publicId
|
||||
character(len=*), intent(in), optional :: notation
|
||||
type(URI), pointer :: baseURI
|
||||
|
||||
call add_external_entity(xds%entityList, name=name, &
|
||||
systemId=systemId, publicId=publicId, notation=notation, &
|
||||
wfc=wfc, baseURI=baseURI)
|
||||
end subroutine register_external_GE
|
||||
|
||||
#endif
|
||||
end module m_common_struct
|
||||
|
|
@ -1,266 +0,0 @@
|
|||
module FoX_dom
|
||||
|
||||
use fox_common, only: countrts
|
||||
use fox_m_fsys_array_str
|
||||
use fox_m_fsys_format
|
||||
|
||||
use m_dom_dom
|
||||
use m_dom_error
|
||||
use m_dom_extras
|
||||
use m_dom_parse
|
||||
use m_dom_utils
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
public :: str_vs, vs_vs_alloc, vs_str_alloc
|
||||
public :: str, operator(//)
|
||||
|
||||
public :: DOMImplementation
|
||||
public :: Node
|
||||
public :: NodeList
|
||||
public :: NamedNodeMap
|
||||
|
||||
! DOM DOMString
|
||||
! no
|
||||
|
||||
! DOM DOMTimestamp
|
||||
! public :: DOMTimestamp
|
||||
|
||||
! DOM Exceptions
|
||||
public :: DOMException
|
||||
public :: inException
|
||||
public :: getExceptionCode
|
||||
|
||||
public :: INDEX_SIZE_ERR
|
||||
public :: DOMSTRING_SIZE_ERR
|
||||
public :: HIERARCHY_REQUEST_ERR
|
||||
public :: WRONG_DOCUMENT_ERR
|
||||
public :: INVALID_CHARACTER_ERR
|
||||
public :: NO_DATA_ALLOWED_ERR
|
||||
public :: NO_MODIFICATION_ALLOWED_ERR
|
||||
public :: NOT_FOUND_ERR
|
||||
public :: NOT_SUPPORTED_ERR
|
||||
public :: INUSE_ATTRIBUTE_ERR
|
||||
public :: INVALID_STATE_ERR
|
||||
public :: SYNTAX_ERR
|
||||
public :: INVALID_MODIFICATION_ERR
|
||||
public :: NAMESPACE_ERR
|
||||
public :: INVALID_ACCESS_ERR
|
||||
public :: VALIDATION_ERR
|
||||
public :: TYPE_MISMATCH_ERR
|
||||
! XPath
|
||||
public :: INVALID_EXPRESSION_ERR
|
||||
public :: TYPE_ERR
|
||||
! LS
|
||||
public :: PARSE_ERR
|
||||
public :: SERIALIZE_ERR
|
||||
|
||||
! DOM Implementation
|
||||
public :: hasFeature
|
||||
public :: createDocumentType
|
||||
public :: createDocument
|
||||
|
||||
! DOM Document
|
||||
public :: getDocumentElement
|
||||
public :: getDocType
|
||||
public :: getImplementation
|
||||
public :: createDocumentFragment
|
||||
public :: createElement
|
||||
public :: createTextNode
|
||||
public :: createComment
|
||||
public :: createCDATASection
|
||||
public :: createProcessingInstruction
|
||||
public :: createAttribute
|
||||
public :: createEntityReference
|
||||
public :: getElementsByTagName
|
||||
public :: getChildrenByTagName
|
||||
public :: getElementById
|
||||
|
||||
public :: importNode
|
||||
public :: createElementNS
|
||||
public :: createAttributeNS
|
||||
public :: getElementsByTagNameNS
|
||||
|
||||
public :: getXmlStandalone
|
||||
public :: setXmlStandalone
|
||||
public :: getXmlVersion
|
||||
public :: setXmlVersion
|
||||
public :: getXmlEncoding
|
||||
public :: getInputEncoding
|
||||
public :: getDocumentURI
|
||||
public :: setDocumentURI
|
||||
public :: getStrictErrorChecking
|
||||
public :: setStrictErrorChecking
|
||||
public :: getDomConfig
|
||||
public :: normalizeDocument
|
||||
public :: renameNode
|
||||
public :: adoptNode
|
||||
|
||||
! DOM Node
|
||||
public :: ELEMENT_NODE
|
||||
public :: ATTRIBUTE_NODE
|
||||
public :: TEXT_NODE
|
||||
public :: CDATA_SECTION_NODE
|
||||
public :: ENTITY_REFERENCE_NODE
|
||||
public :: ENTITY_NODE
|
||||
public :: PROCESSING_INSTRUCTION_NODE
|
||||
public :: COMMENT_NODE
|
||||
public :: DOCUMENT_NODE
|
||||
public :: DOCUMENT_TYPE_NODE
|
||||
public :: DOCUMENT_FRAGMENT_NODE
|
||||
public :: NOTATION_NODE
|
||||
|
||||
public :: getNodeName
|
||||
public :: getNodeValue
|
||||
public :: setNodeValue
|
||||
public :: getNodeType
|
||||
public :: getFirstChild
|
||||
public :: getLastChild
|
||||
public :: getAttributes
|
||||
public :: getNextSibling
|
||||
public :: getPreviousSibling
|
||||
public :: getParentNode
|
||||
public :: getChildNodes
|
||||
public :: getOwnerDocument
|
||||
public :: insertBefore
|
||||
public :: replaceChild
|
||||
public :: removeChild
|
||||
public :: appendChild
|
||||
public :: hasChildNodes
|
||||
public :: cloneNode
|
||||
public :: normalize
|
||||
|
||||
public :: isSupported
|
||||
public :: getNamespaceURI
|
||||
public :: getPrefix
|
||||
public :: setPrefix
|
||||
public :: getLocalName
|
||||
public :: hasAttributes
|
||||
|
||||
public :: getTextContent
|
||||
public :: setTextContent
|
||||
public :: isEqualNode
|
||||
public :: isSameNode
|
||||
public :: isDefaultNamespace
|
||||
public :: lookupNamespaceURI
|
||||
public :: lookupPrefix
|
||||
|
||||
! DOM NodeList
|
||||
public :: item
|
||||
public :: append
|
||||
|
||||
! DOM NamedNodeMap
|
||||
public :: getLength
|
||||
public :: getNamedItem
|
||||
public :: setNamedItem
|
||||
public :: removeNamedItem
|
||||
! public :: item
|
||||
public :: getNamedItemNS
|
||||
public :: setNamedItemNS
|
||||
public :: removeNamedItemNS
|
||||
|
||||
! DOM CharacterData
|
||||
! NB We use the native Fortran string type here
|
||||
! rather than inventing a DOM String, thus no
|
||||
! string type to make public
|
||||
! public :: getData
|
||||
! public :: setData
|
||||
public :: substringData
|
||||
public :: appendData
|
||||
public :: insertData
|
||||
public :: deleteData
|
||||
public :: replaceData
|
||||
|
||||
! DOM Attr
|
||||
! public :: getName
|
||||
public :: getSpecified
|
||||
public :: getValue
|
||||
public :: setValue
|
||||
public :: getOwnerElement
|
||||
public :: getIsId
|
||||
|
||||
! DOM Element
|
||||
public :: getTagName
|
||||
public :: getAttribute
|
||||
public :: setAttribute
|
||||
public :: removeAttribute
|
||||
public :: getAttributeNode
|
||||
public :: setAttributeNode
|
||||
public :: removeAttributeNode
|
||||
! public :: getElementsByTagName
|
||||
public :: getAttributeNS
|
||||
public :: setAttributeNS
|
||||
public :: removeAttributeNS
|
||||
public :: getAttributeNodeNS
|
||||
public :: setAttributeNodeNS
|
||||
! public :: getElementsByTagNameNS
|
||||
public :: hasAttribute
|
||||
public :: hasAttributeNS
|
||||
public :: setIdAttribute
|
||||
public :: setIdAttributeNS
|
||||
public :: setIdAttributeNode
|
||||
|
||||
!DOM Text
|
||||
public :: splitText
|
||||
public :: getIsElementContentWhitespace
|
||||
|
||||
!DOM CData
|
||||
! public :: getData
|
||||
! public :: setData
|
||||
|
||||
!DOM DocumentType
|
||||
public :: getEntities
|
||||
public :: getNotations
|
||||
public :: getInternalSubset
|
||||
|
||||
!DOM Notation
|
||||
|
||||
!DOM Entity
|
||||
public :: getNotationName
|
||||
|
||||
!DOM EntityReference
|
||||
|
||||
!DOM ProcessingInstruction
|
||||
! public :: getData
|
||||
! public :: setData
|
||||
public :: getTarget
|
||||
|
||||
!DOM common
|
||||
public :: getData
|
||||
public :: setData
|
||||
public :: getName
|
||||
public :: getPublicId
|
||||
public :: getSystemId
|
||||
|
||||
!DOM Configuration
|
||||
public :: DOMConfiguration
|
||||
public :: getParameter
|
||||
public :: setParameter
|
||||
public :: canSetParameter
|
||||
public :: getParameterNames
|
||||
|
||||
! FoX-only interfaces
|
||||
public :: newDOMConfig
|
||||
|
||||
public :: getNodePath
|
||||
|
||||
public :: extractDataContent
|
||||
public :: extractDataAttribute
|
||||
public :: extractDataAttributeNS
|
||||
|
||||
public :: parseFile
|
||||
public :: parseString
|
||||
public :: serialize
|
||||
|
||||
public :: destroy
|
||||
public :: getFoX_checks
|
||||
public :: setFoX_checks
|
||||
public :: getLiveNodeLists
|
||||
public :: setLiveNodeLists
|
||||
public :: getNamespaceNodes
|
||||
|
||||
! Length of array
|
||||
public :: countrts
|
||||
|
||||
end module FoX_dom
|
||||
|
|
@ -1,49 +0,0 @@
|
|||
source = $(wildcard *.F90)
|
||||
objects = $(source:.F90=.o)
|
||||
|
||||
#===============================================================================
|
||||
# Compiler Options
|
||||
#===============================================================================
|
||||
|
||||
# Ignore unusd variables
|
||||
|
||||
ifeq ($(MACHINE),bluegene)
|
||||
override F90 = xlf2003
|
||||
endif
|
||||
|
||||
ifeq ($(F90),ifort)
|
||||
override F90FLAGS += -warn nounused
|
||||
endif
|
||||
|
||||
#===============================================================================
|
||||
# Targets
|
||||
#===============================================================================
|
||||
|
||||
all: $(objects)
|
||||
mv *.mod ../include
|
||||
mv *.o ../lib
|
||||
clean:
|
||||
@rm -f *.o *.mod
|
||||
neat:
|
||||
@rm -f *.o *.mod
|
||||
|
||||
#===============================================================================
|
||||
# Rules
|
||||
#===============================================================================
|
||||
|
||||
.SUFFIXES: .F90 .o
|
||||
|
||||
.PHONY: clean neat
|
||||
|
||||
%.o: %.F90
|
||||
$(F90) $(F90FLAGS) -c -I../include $<
|
||||
|
||||
#===============================================================================
|
||||
# Dependencies
|
||||
#===============================================================================
|
||||
|
||||
FoX_dom.o: m_dom_dom.o m_dom_error.o m_dom_extras.o m_dom_parse.o m_dom_utils.o
|
||||
m_dom_dom.o: m_dom_error.o
|
||||
m_dom_extras.o: m_dom_dom.o m_dom_error.o
|
||||
m_dom_parse.o: m_dom_dom.o m_dom_error.o
|
||||
m_dom_utils.o: m_dom_dom.o m_dom_error.o
|
||||
File diff suppressed because it is too large
Load diff
|
|
@ -1,211 +0,0 @@
|
|||
module m_dom_error
|
||||
|
||||
use fox_m_fsys_abort_flush, only: pxfabort
|
||||
|
||||
use m_common_error, only: error_stack, add_error, in_error, destroy_error_stack
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
type DOMException
|
||||
private
|
||||
type(error_stack) :: stack
|
||||
end type DOMException
|
||||
|
||||
integer, parameter, public :: INDEX_SIZE_ERR = 1
|
||||
integer, parameter, public :: DOMSTRING_SIZE_ERR = 2
|
||||
integer, parameter, public :: HIERARCHY_REQUEST_ERR = 3
|
||||
integer, parameter, public :: WRONG_DOCUMENT_ERR = 4
|
||||
integer, parameter, public :: INVALID_CHARACTER_ERR = 5
|
||||
integer, parameter, public :: NO_DATA_ALLOWED_ERR = 6
|
||||
integer, parameter, public :: NO_MODIFICATION_ALLOWED_ERR = 7
|
||||
integer, parameter, public :: NOT_FOUND_ERR = 8
|
||||
integer, parameter, public :: NOT_SUPPORTED_ERR = 9
|
||||
integer, parameter, public :: INUSE_ATTRIBUTE_ERR = 10
|
||||
integer, parameter, public :: INVALID_STATE_ERR = 11
|
||||
integer, parameter, public :: SYNTAX_ERR = 12
|
||||
integer, parameter, public :: INVALID_MODIFICATION_ERR = 13
|
||||
integer, parameter, public :: NAMESPACE_ERR = 14
|
||||
integer, parameter, public :: INVALID_ACCESS_ERR = 15
|
||||
integer, parameter, public :: VALIDATION_ERR = 16
|
||||
integer, parameter, public :: TYPE_MISMATCH_ERR = 17
|
||||
|
||||
integer, parameter, public :: INVALID_EXPRESSION_ERR = 51
|
||||
integer, parameter, public :: TYPE_ERR = 52
|
||||
|
||||
integer, parameter, public :: PARSE_ERR = 81
|
||||
integer, parameter, public :: SERIALIZE_ERR = 82
|
||||
|
||||
integer, parameter, public :: FoX_INVALID_NODE = 201
|
||||
integer, parameter, public :: FoX_INVALID_CHARACTER = 202
|
||||
integer, parameter, public :: FoX_NO_SUCH_ENTITY = 203
|
||||
integer, parameter, public :: FoX_INVALID_PI_DATA = 204
|
||||
integer, parameter, public :: FoX_INVALID_CDATA_SECTION = 205
|
||||
integer, parameter, public :: FoX_HIERARCHY_REQUEST_ERR = 206
|
||||
integer, parameter, public :: FoX_INVALID_PUBLIC_ID = 207
|
||||
integer, parameter, public :: FoX_INVALID_SYSTEM_ID = 208
|
||||
integer, parameter, public :: FoX_INVALID_COMMENT = 209
|
||||
integer, parameter, public :: FoX_NODE_IS_NULL = 210
|
||||
integer, parameter, public :: FoX_INVALID_ENTITY = 211
|
||||
integer, parameter, public :: FoX_INVALID_URI = 212
|
||||
integer, parameter, public :: FoX_IMPL_IS_NULL = 213
|
||||
integer, parameter, public :: FoX_MAP_IS_NULL = 214
|
||||
integer, parameter, public :: FoX_LIST_IS_NULL = 215
|
||||
|
||||
integer, parameter, public :: FoX_INTERNAL_ERROR = 999
|
||||
|
||||
|
||||
public :: DOMException
|
||||
public :: getExceptionCode
|
||||
public :: throw_exception
|
||||
public :: inException
|
||||
public :: dom_error
|
||||
public :: internal_error
|
||||
|
||||
contains
|
||||
|
||||
pure function errorString(code) result(s)
|
||||
integer, intent(in) :: code
|
||||
character(len=27) :: s
|
||||
|
||||
select case(code)
|
||||
case(1)
|
||||
s = "INDEX_SIZE_ERR"
|
||||
case(2)
|
||||
s = "DOMSTRING_SIZE_ERR"
|
||||
case(3)
|
||||
s = "HIERARCHY_REQUEST_ERR"
|
||||
case(4)
|
||||
s = "WRONG_DOCUMENT_ERR"
|
||||
case(5)
|
||||
s = "INVALID_CHARACTER_ERR"
|
||||
case(6)
|
||||
s = "NO_DATA_ALLOWED_ERR"
|
||||
case(7)
|
||||
s = "NO_MODIFICATION_ALLOWED_ERR"
|
||||
case(8)
|
||||
s = "NOT_FOUND_ERR"
|
||||
case(9)
|
||||
s = "NOT_SUPPORTED_ERR"
|
||||
case(10)
|
||||
s = "INUSE_ATTRIBUTE_ERR"
|
||||
case(11)
|
||||
s = "INVALID_STATE_ERR"
|
||||
case(12)
|
||||
s = "SYNTAX_ERR"
|
||||
case(13)
|
||||
s = "INVALID_MODIFICATION_ERR"
|
||||
case(14)
|
||||
s = "NAMESPACE_ERR"
|
||||
case(15)
|
||||
s = "INVALID_ACCESS_ERR"
|
||||
case(16)
|
||||
s = "VALIDATION_ERR"
|
||||
case(18)
|
||||
s = "TYPE_MISMATCH_ERR"
|
||||
case(51)
|
||||
s = "INVALID_EXPRESSION_ERR"
|
||||
case(52)
|
||||
s = "TYPE_ERR"
|
||||
case(81)
|
||||
s = "PARSE_ERR"
|
||||
case(82)
|
||||
s = "SERIALIZE_ERR"
|
||||
case(201)
|
||||
s = "FoX_INVALID_NODE"
|
||||
case(202)
|
||||
s = "FoX_INVALID_CHARACTER"
|
||||
case(203)
|
||||
s = "FoX_NO_SUCH_ENTITY"
|
||||
case(204)
|
||||
s = "FoX_INVALID_PI_DATA"
|
||||
case(205)
|
||||
s = "FoX_INVALID_CDATA_SECTION"
|
||||
case(206)
|
||||
s = "FoX_HIERARCHY_REQUEST_ERR"
|
||||
case(207)
|
||||
s = "FoX_INVALID_PUBLIC_ID"
|
||||
case(208)
|
||||
s = "FoX_INVALID_SYSTEM_ID"
|
||||
case(209)
|
||||
s = "FoX_INVALID_COMMENT"
|
||||
case(210)
|
||||
s = "FoX_NODE_IS_NULL"
|
||||
case(211)
|
||||
s = "FoX_INVALID_ENTITY"
|
||||
case(212)
|
||||
s = "FoX_NO_DOCTYPE"
|
||||
case(213)
|
||||
s = "FoX_IMPL_IS_NULL"
|
||||
case(214)
|
||||
s = "FoX_MAP_IS_NULL"
|
||||
case(215)
|
||||
s = "FoX_LIST_IS_NULL"
|
||||
case default
|
||||
s = "INTERNAL ERROR!!!!"
|
||||
end select
|
||||
|
||||
end function errorString
|
||||
|
||||
function getExceptionCode(ex) result(n)
|
||||
type(DOMException), intent(inout) :: ex
|
||||
integer :: n
|
||||
|
||||
if (in_error(ex%stack)) then
|
||||
n = ex%stack%stack(size(ex%stack%stack))%error_code
|
||||
call destroy_error_stack(ex%stack)
|
||||
else
|
||||
n = 0
|
||||
endif
|
||||
end function getExceptionCode
|
||||
|
||||
subroutine throw_exception(code, msg, ex)
|
||||
integer, intent(in) :: code
|
||||
character(len=*), intent(in) :: msg
|
||||
type(DOMException), intent(inout), optional :: ex
|
||||
|
||||
if (present(ex)) then
|
||||
call add_error(ex%stack, msg, error_code=code) ! FIXME
|
||||
else
|
||||
write(0,'(a)') errorString(code)
|
||||
write(0,'(i0,a)') code, " "//msg
|
||||
call pxfabort()
|
||||
endif
|
||||
|
||||
end subroutine throw_exception
|
||||
|
||||
|
||||
subroutine dom_error(name,code,msg)
|
||||
character(len=*), intent(in) :: name, msg
|
||||
integer, intent(in) :: code
|
||||
|
||||
write(0,'(4a)') "Routine ", name, ":", msg
|
||||
write(0,'(a)') errorString(code)
|
||||
call pxfabort()
|
||||
|
||||
end subroutine dom_error
|
||||
|
||||
|
||||
subroutine destroyDOMException(ex)
|
||||
type(DOMException), intent(inout) :: ex
|
||||
|
||||
call destroy_error_stack(ex%stack)
|
||||
end subroutine destroyDOMException
|
||||
|
||||
|
||||
subroutine internal_error(name,msg)
|
||||
character(len=*), intent(in) :: name, msg
|
||||
|
||||
write(0,'(4a)') "Internal error in ", name, ":", msg
|
||||
call pxfabort()
|
||||
|
||||
end subroutine internal_error
|
||||
|
||||
function inException(ex) result(p)
|
||||
type(DOMException), intent(in) :: ex
|
||||
logical :: p
|
||||
|
||||
p = in_error(ex%stack)
|
||||
end function inException
|
||||
|
||||
end module m_dom_error
|
||||
File diff suppressed because it is too large
Load diff
|
|
@ -1,577 +0,0 @@
|
|||
module m_dom_parse
|
||||
|
||||
use fox_m_fsys_array_str, only: str_vs, vs_str_alloc
|
||||
use fox_m_utils_uri, only: URI, parseURI, rebaseURI, expressURI, destroyURI
|
||||
use m_common_attrs, only: hasKey, getValue, getIndex, getIsId, getBase, &
|
||||
add_item_to_dict
|
||||
use m_common_entities, only: entity_t, size, getEntityByIndex
|
||||
use m_common_error, only: FoX_error, in_error
|
||||
use m_common_struct, only: xml_doc_state
|
||||
use FoX_common, only: dictionary_t, getLength
|
||||
use FoX_common, only: getQName, getValue, getURI, isSpecified
|
||||
use m_sax_parser, only: sax_parse
|
||||
use FoX_sax, only: xml_t
|
||||
use FoX_sax, only: open_xml_file, open_xml_string, close_xml_t
|
||||
|
||||
! Public interfaces
|
||||
use m_dom_dom, only: DOMConfiguration, Node, NamedNodeMap, &
|
||||
TEXT_NODE, &
|
||||
getAttributes, getData, getDocType, getEntities, getImplementation, &
|
||||
getLastChild, getNodeType, &
|
||||
getNotations, getParameter, getParentNode, getXmlVersion, &
|
||||
setAttribute, setAttributeNS, setData, setValue, &
|
||||
appendChild, createAttribute, createAttributeNS, createCdataSection, &
|
||||
createComment, createDocumentType, createElement, createElementNS, &
|
||||
createEntityReference, createProcessingInstruction, createTextNode, &
|
||||
getNamedItem, setAttributeNode, setAttributeNodeNS, setNamedItem, &
|
||||
getFoX_checks
|
||||
|
||||
! Private interfaces
|
||||
use m_dom_dom, only: copyDOMConfig, createEmptyDocument, setDocumentElement, &
|
||||
createEmptyEntityReference, createEntity, createNotation, &
|
||||
getReadOnly, getStringValue, getXds, destroy, destroyAllNodesRecursively, &
|
||||
namespaceFixup, setDocType, setDomConfig, setGCstate, setIllFormed, &
|
||||
setIsElementContentWhitespace, setIsId, setReadOnlyMap, setReadonlyNode, &
|
||||
setSpecified, setXds, setStringValue
|
||||
|
||||
use m_dom_error, only: DOMException, inException, throw_exception, &
|
||||
getExceptionCode, PARSE_ERR
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
public :: parsefile
|
||||
public :: parsestring
|
||||
|
||||
type(xml_t), target, save :: fxml
|
||||
|
||||
type(Node), pointer, save :: mainDoc => null()
|
||||
type(Node), pointer, save :: current => null()
|
||||
|
||||
type(DOMConfiguration), pointer :: domConfig
|
||||
|
||||
logical :: cdata
|
||||
character, pointer :: error(:) => null()
|
||||
character, pointer :: inEntity(:) => null()
|
||||
|
||||
contains
|
||||
|
||||
subroutine startElement_handler(nsURI, localname, name, attrs)
|
||||
character(len=*), intent(in) :: nsURI
|
||||
character(len=*), intent(in) :: localname
|
||||
character(len=*), intent(in) :: name
|
||||
type(dictionary_t), intent(in) :: attrs
|
||||
|
||||
type(URI), pointer :: URIref, URIbase, newURI
|
||||
type(Node), pointer :: el, attr, dummy
|
||||
character, pointer :: baseURI(:)
|
||||
integer :: i
|
||||
|
||||
if (getParameter(domConfig, "namespaces")) then
|
||||
el => createElementNS(mainDoc, nsURI, name)
|
||||
else
|
||||
el => createElement(mainDoc, name)
|
||||
endif
|
||||
|
||||
if (getBase(attrs)/="") then
|
||||
i = getIndex(attrs, "xml:base")
|
||||
if (i>0) then
|
||||
URIbase => parseURI(getBase(attrs))
|
||||
URIref => parseURI(getValue(attrs, i))
|
||||
newURI => rebaseURI(URIbase, URIref)
|
||||
call destroyURI(URIbase)
|
||||
call destroyURI(URIref)
|
||||
baseURI => vs_str_alloc(expressURI(newURI))
|
||||
call destroyURI(newURI)
|
||||
else
|
||||
baseURI => vs_str_alloc(getBase(attrs))
|
||||
endif
|
||||
if (getParameter(domConfig, "namespaces")) then
|
||||
attr => createAttributeNS(mainDoc, &
|
||||
"http://www.w3.org/XML/1998/namespace", "xml:base")
|
||||
else
|
||||
attr => createAttribute(mainDoc, "xml:base")
|
||||
endif
|
||||
call setValue(attr, str_vs(baseURI))
|
||||
deallocate(baseURI)
|
||||
if (i>0) then
|
||||
call setSpecified(attr, isSpecified(attrs, i))
|
||||
call setIsId(attr, getIsId(attrs, i))
|
||||
endif
|
||||
if (getParameter(domConfig, "namespaces")) then
|
||||
dummy => setAttributeNodeNS(el, attr)
|
||||
else
|
||||
dummy => setAttributeNode(el, attr)
|
||||
endif
|
||||
endif
|
||||
|
||||
do i = 1, getLength(attrs)
|
||||
if (getQName(attrs, i)=="xml:base") cycle
|
||||
if (getParameter(domConfig, "namespaces")) then
|
||||
attr => createAttributeNS(mainDoc, getURI(attrs, i), getQName(attrs, i))
|
||||
else
|
||||
attr => createAttribute(mainDoc, getQName(attrs, i))
|
||||
endif
|
||||
call setValue(attr, getValue(attrs, i))
|
||||
call setSpecified(attr, isSpecified(attrs, i))
|
||||
call setIsId(attr, getIsId(attrs, i))
|
||||
if (getParameter(domConfig, "namespaces")) then
|
||||
dummy => setAttributeNodeNS(el, attr)
|
||||
else
|
||||
dummy => setAttributeNode(el, attr)
|
||||
endif
|
||||
if (associated(inEntity)) call setReadOnlyNode(attr, .true., .true.)
|
||||
enddo
|
||||
|
||||
if (associated(current, mainDoc)) then
|
||||
current => appendChild(current,el)
|
||||
call setDocumentElement(mainDoc, current)
|
||||
else
|
||||
current => appendChild(current,el)
|
||||
endif
|
||||
if (getParameter(domConfig, "namespaces")) &
|
||||
call namespaceFixup(current, .false.)
|
||||
|
||||
if (associated(inEntity)) &
|
||||
call setReadOnlyMap(getAttributes(current), .true.)
|
||||
|
||||
cdata = .false.
|
||||
|
||||
end subroutine startElement_handler
|
||||
|
||||
subroutine endElement_handler(URI, localName, name)
|
||||
character(len=*), intent(in) :: URI
|
||||
character(len=*), intent(in) :: localname
|
||||
character(len=*), intent(in) :: name
|
||||
|
||||
if (associated(inEntity)) call setReadOnlyNode(current, .true., .false.)
|
||||
|
||||
current => getParentNode(current)
|
||||
end subroutine endElement_handler
|
||||
|
||||
! FIXME to pick up entity references within attribute values, we need
|
||||
! separate just_the_element, start_attribute, attribute_text etc. calls.
|
||||
|
||||
subroutine characters_handler(chunk)
|
||||
character(len=*), intent(in) :: chunk
|
||||
|
||||
type(Node), pointer :: temp
|
||||
logical :: readonly
|
||||
|
||||
temp => getLastChild(current)
|
||||
if (associated(temp)) then
|
||||
if (.not.cdata.and.getNodeType(temp)==TEXT_NODE) then
|
||||
readonly = getReadOnly(temp) ! Reset readonly status quickly
|
||||
call setReadOnlyNode(temp, .false., .false.)
|
||||
call setData(temp, getData(temp)//chunk)
|
||||
call setReadOnlyNode(temp, readonly, .false.)
|
||||
return
|
||||
endif
|
||||
endif
|
||||
if (cdata) then
|
||||
temp => createCdataSection(mainDoc, chunk)
|
||||
temp => appendChild(current, temp)
|
||||
else
|
||||
temp => createTextNode(mainDoc, chunk)
|
||||
temp => appendChild(current, temp)
|
||||
endif
|
||||
|
||||
if (associated(inEntity)) call setReadOnlyNode(temp, .true., .false.)
|
||||
|
||||
end subroutine characters_handler
|
||||
|
||||
subroutine ignorableWhitespace_handler(chunk)
|
||||
character(len=*), intent(in) :: chunk
|
||||
|
||||
type(Node), pointer :: temp
|
||||
logical :: readonly
|
||||
|
||||
if (getParameter(domConfig, "element-content-whitespace")) then
|
||||
temp => getLastChild(current)
|
||||
if (associated(temp)) then
|
||||
if (getNodeType(temp)==TEXT_NODE) then
|
||||
readonly = getReadOnly(temp) ! Reset readonly status quickly
|
||||
call setReadOnlyNode(temp, .false., .false.)
|
||||
call setData(temp, getData(temp)//chunk)
|
||||
call setReadOnlyNode(temp, readonly, .false.)
|
||||
call setIsElementContentWhitespace(temp, .true.)
|
||||
return
|
||||
endif
|
||||
endif
|
||||
temp => createTextNode(mainDoc, chunk)
|
||||
temp => appendChild(current, temp)
|
||||
call setIsElementContentWhitespace(temp, .true.)
|
||||
if (associated(inEntity)) call setReadOnlyNode(temp, .true., .false.)
|
||||
endif
|
||||
|
||||
end subroutine ignorableWhitespace_handler
|
||||
|
||||
subroutine comment_handler(comment)
|
||||
character(len=*), intent(in) :: comment
|
||||
|
||||
type(Node), pointer :: temp
|
||||
|
||||
if (getParameter(domConfig, "comments")) then
|
||||
temp => appendChild(current, createComment(mainDoc, comment))
|
||||
if (associated(inEntity)) call setReadOnlyNode(temp, .true., .false.)
|
||||
endif
|
||||
|
||||
end subroutine comment_handler
|
||||
|
||||
subroutine processingInstruction_handler(target, data)
|
||||
character(len=*), intent(in) :: target
|
||||
character(len=*), intent(in) :: data
|
||||
|
||||
type(Node), pointer :: temp
|
||||
|
||||
temp => appendChild(current, &
|
||||
createProcessingInstruction(mainDoc, target, data))
|
||||
|
||||
if (associated(inEntity)) call setReadOnlyNode(temp, .true., .false.)
|
||||
end subroutine processingInstruction_handler
|
||||
|
||||
subroutine startDocument_handler
|
||||
mainDoc => createEmptyDocument()
|
||||
current => mainDoc
|
||||
call setGCstate(mainDoc, .false.)
|
||||
call setDomConfig(mainDoc, domConfig)
|
||||
end subroutine startDocument_handler
|
||||
|
||||
subroutine endDocument_Handler
|
||||
call setGCstate(mainDoc, .true.)
|
||||
end subroutine endDocument_Handler
|
||||
|
||||
subroutine startDTD_handler(name, publicId, systemId)
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=*), intent(in) :: publicId
|
||||
character(len=*), intent(in) :: systemId
|
||||
|
||||
type(Node), pointer :: np
|
||||
|
||||
np => createDocumentType(getImplementation(mainDoc), name, publicId=publicId, systemId=systemId)
|
||||
np => appendChild(mainDoc, np)
|
||||
call setDocType(mainDoc, np)
|
||||
|
||||
end subroutine startDTD_handler
|
||||
|
||||
subroutine endDTD_handler
|
||||
|
||||
type(Node), pointer :: np, oldcurrent
|
||||
type(NamedNodeMap), pointer :: entities
|
||||
type(xml_t) :: subsax
|
||||
type(xml_doc_state), pointer :: xds
|
||||
type(entity_t), pointer :: ent
|
||||
integer :: i, ios
|
||||
logical :: ok
|
||||
|
||||
entities => getEntities(getDocType(mainDoc))
|
||||
xds => getXds(mainDoc)
|
||||
|
||||
do i = 1, size(xds%entityList)
|
||||
ent => getEntityByIndex(xds%entityList, i)
|
||||
np => getNamedItem(entities, str_vs(ent%name))
|
||||
|
||||
ok = .false.
|
||||
if (ent%external) then
|
||||
if (size(ent%notation)==0) then
|
||||
call open_xml_file(subsax, expressURI(ent%baseURI), iostat=ios)
|
||||
if (ios/=0) then
|
||||
call setIllFormed(np, .true.)
|
||||
else
|
||||
ok = .true.
|
||||
endif
|
||||
endif
|
||||
else
|
||||
call open_xml_string(subsax, getStringValue(np))
|
||||
ok = .true.
|
||||
endif
|
||||
if (ok) then
|
||||
oldcurrent => current
|
||||
current => np
|
||||
! Run the parser over value
|
||||
! We do this with all entities already declared.
|
||||
call sax_parse(subsax%fx, subsax%fb, &
|
||||
startElement_handler=startElement_handler, &
|
||||
endElement_handler=endElement_handler, &
|
||||
characters_handler=characters_handler, &
|
||||
startCdata_handler=startCdata_handler, &
|
||||
endCdata_handler=endCdata_handler, &
|
||||
comment_handler=comment_handler, &
|
||||
processingInstruction_handler=processingInstruction_handler, &
|
||||
fatalError_handler=entityErrorHandler, &
|
||||
startInCharData = .true., &
|
||||
externalEntity = ent%external, &
|
||||
xmlVersion = getXmlVersion(mainDoc), &
|
||||
namespaces=getParameter(domConfig, "namespaces"), &
|
||||
initial_entities = xds%entityList)
|
||||
call close_xml_t(subsax)
|
||||
|
||||
current => oldcurrent
|
||||
endif
|
||||
enddo
|
||||
|
||||
if (associated(getDocType(mainDoc))) then
|
||||
call setReadonlyMap(getEntities(getDocType(mainDoc)), .true.)
|
||||
call setReadonlyMap(getNotations(getDocType(mainDoc)), .true.)
|
||||
endif
|
||||
|
||||
end subroutine endDTD_handler
|
||||
|
||||
subroutine FoX_endDTD_handler(state)
|
||||
type(xml_doc_state), pointer :: state
|
||||
|
||||
call setXds(mainDoc, state)
|
||||
|
||||
end subroutine FoX_endDTD_handler
|
||||
|
||||
subroutine notationDecl_handler(name, publicId, systemId)
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=*), intent(in) :: publicId
|
||||
character(len=*), intent(in) :: systemId
|
||||
|
||||
type(Node), pointer :: np
|
||||
|
||||
np => createNotation(mainDoc, name, publicId=publicId, systemId=systemId)
|
||||
np => setNamedItem(getNotations(getDocType(mainDoc)), np)
|
||||
! The SAX parser will never give us duplicate entities,
|
||||
! so there is no need to check
|
||||
|
||||
end subroutine notationDecl_handler
|
||||
|
||||
subroutine startCdata_handler()
|
||||
if (getParameter(domConfig, "cdata-sections")) cdata = .true.
|
||||
end subroutine startCdata_handler
|
||||
subroutine endCdata_handler()
|
||||
cdata = .false.
|
||||
end subroutine endCdata_handler
|
||||
|
||||
subroutine internalEntityDecl_handler(name, value)
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=*), intent(in) :: value
|
||||
|
||||
type(Node), pointer :: np
|
||||
|
||||
if (name(1:1)=="%") return
|
||||
! Do nothing with parameter entities
|
||||
|
||||
! We only note that these exist here.
|
||||
! A second parsing stage is triggered at the end
|
||||
! of the DTD, in order to resolve entity references (which
|
||||
! need not be declared in order)
|
||||
|
||||
np => createEntity(mainDoc, name, "", "", "")
|
||||
call setStringValue(np, value)
|
||||
np => setNamedItem(getEntities(getDocType(mainDoc)), np)
|
||||
|
||||
end subroutine internalEntityDecl_handler
|
||||
|
||||
subroutine normalErrorHandler(msg)
|
||||
character(len=*), intent(in) :: msg
|
||||
! This is called if the main parsing routine fails
|
||||
error => vs_str_alloc(msg)
|
||||
end subroutine normalErrorHandler
|
||||
|
||||
subroutine entityErrorHandler(msg)
|
||||
character(len=*), intent(in) :: msg
|
||||
|
||||
!This gets called if parsing of an entity failed. If so,
|
||||
!then we need to destroy all nodes which were being generated as
|
||||
!children of this entity, then mark the entity as ill-formed - but
|
||||
!otherwise carry on parsing the document, and only throw an error
|
||||
!if a reference is made to it.
|
||||
|
||||
call destroyAllNodesRecursively(current, except=.true.)
|
||||
call setIllFormed(current, .true.)
|
||||
end subroutine entityErrorHandler
|
||||
|
||||
subroutine externalEntityDecl_handler(name, publicId, systemId)
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=*), intent(in) :: publicId
|
||||
character(len=*), intent(in) :: systemId
|
||||
type(Node), pointer :: np
|
||||
|
||||
if (name(1:1)=="%") return
|
||||
! Do nothing with parameter entities
|
||||
|
||||
np => createEntity(mainDoc, name, &
|
||||
publicId=publicId, systemId=systemId, notationName="")
|
||||
np => setNamedItem(getEntities(getDocType(mainDoc)), np)
|
||||
|
||||
end subroutine externalEntityDecl_handler
|
||||
|
||||
subroutine unparsedEntityDecl_handler(name, publicId, systemId, notationName)
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=*), intent(in) :: publicId
|
||||
character(len=*), intent(in) :: systemId
|
||||
character(len=*), intent(in) :: notationName
|
||||
type(Node), pointer :: np
|
||||
|
||||
np => getNamedItem(getEntities(getDocType(mainDoc)), name)
|
||||
if (.not.associated(np)) then
|
||||
np => createEntity(mainDoc, name, publicId=publicId, systemId=systemId, notationName=notationName)
|
||||
np => setNamedItem(getEntities(getDocType(mainDoc)), np)
|
||||
endif
|
||||
|
||||
end subroutine unparsedEntityDecl_handler
|
||||
|
||||
subroutine startEntity_handler(name)
|
||||
character(len=*), intent(in) :: name
|
||||
|
||||
if (name(1:1)=="%") return
|
||||
! Do nothing with parameter entities
|
||||
|
||||
if (getParameter(domConfig, "entities")) then
|
||||
if (.not.associated(inEntity)) then
|
||||
inEntity => vs_str_alloc(name)
|
||||
endif
|
||||
current => appendChild(current, createEmptyEntityReference(mainDoc, name))
|
||||
endif
|
||||
end subroutine startEntity_handler
|
||||
|
||||
subroutine endEntity_handler(name)
|
||||
character(len=*), intent(in) :: name
|
||||
|
||||
if (name(1:1)=="%") return
|
||||
! Do nothing with parameter entities
|
||||
|
||||
if (getParameter(domConfig, "entities")) then
|
||||
call setReadOnlyNode(current, .true., .false.)
|
||||
if (str_vs(inEntity)==name) deallocate(inEntity)
|
||||
current => getParentNode(current)
|
||||
endif
|
||||
|
||||
end subroutine endEntity_handler
|
||||
|
||||
subroutine skippedEntity_handler(name)
|
||||
character(len=*), intent(in) :: name
|
||||
|
||||
type(Node), pointer :: temp
|
||||
|
||||
if (name(1:1)=="%") return
|
||||
! Do nothing with parameter entities
|
||||
|
||||
temp => appendChild(current, createEntityReference(mainDoc, name))
|
||||
if (associated(inEntity)) call setReadonlyNode(temp, .true., .false.)
|
||||
end subroutine skippedEntity_handler
|
||||
|
||||
|
||||
subroutine runParser(fxml, configuration, ex)
|
||||
type(DOMException), intent(out), optional :: ex
|
||||
type(xml_t), intent(inout) :: fxml
|
||||
type(DOMConfiguration), pointer, optional :: configuration
|
||||
|
||||
allocate(DOMConfig)
|
||||
if (present(configuration)) call copyDOMConfig(DOMConfig, configuration)
|
||||
|
||||
! We use internal sax_parse rather than public interface in order
|
||||
! to use internal callbacks to get extra info.
|
||||
call sax_parse(fx=fxml%fx, fb=fxml%fb,&
|
||||
characters_handler=characters_handler, &
|
||||
endDocument_handler=endDocument_handler, &
|
||||
endElement_handler=endElement_handler, &
|
||||
!endPrefixMapping_handler, &
|
||||
ignorableWhitespace_handler=ignorableWhitespace_handler, &
|
||||
processingInstruction_handler=processingInstruction_handler, &
|
||||
! setDocumentLocator
|
||||
skippedEntity_handler=skippedEntity_handler, &
|
||||
startDocument_handler=startDocument_handler, &
|
||||
startElement_handler=startElement_handler, &
|
||||
!startPrefixMapping_handler, &
|
||||
notationDecl_handler=notationDecl_handler, &
|
||||
unparsedEntityDecl_handler=unparsedEntityDecl_handler, &
|
||||
!error_handler, &
|
||||
fatalError_handler=normalErrorHandler, &
|
||||
!warning_handler, &
|
||||
!attributeDecl_handler, &
|
||||
!elementDecl_handler, &
|
||||
externalEntityDecl_handler=externalEntityDecl_handler, &
|
||||
internalEntityDecl_handler=internalEntityDecl_handler, &
|
||||
comment_handler=comment_handler, &
|
||||
endCdata_handler=endCdata_handler, &
|
||||
endDTD_handler=endDTD_handler, &
|
||||
endEntity_handler=endEntity_handler, &
|
||||
startCdata_handler=startCdata_handler, &
|
||||
startDTD_handler=startDTD_handler, &
|
||||
startEntity_handler=startEntity_handler, &
|
||||
FoX_endDTD_handler=FoX_endDTD_handler, &
|
||||
namespaces = getParameter(domConfig, "namespaces"), &
|
||||
namespace_prefixes = .true., &
|
||||
validate = getParameter(domConfig, "validate"), & ! FIXME what about validate-if-present ...
|
||||
xmlns_uris = .true.)
|
||||
|
||||
call close_xml_t(fxml)
|
||||
|
||||
if (associated(error)) then
|
||||
if (associated(inEntity)) deallocate(inEntity)
|
||||
! FIXME pass the value of the error through
|
||||
! when we let exceptions do that
|
||||
deallocate(error)
|
||||
call destroy(mainDoc)
|
||||
if (getFoX_checks().or.PARSE_ERR<200) then
|
||||
call throw_exception(PARSE_ERR, "runParser", ex)
|
||||
if (present(ex)) then
|
||||
if (inException(ex)) then
|
||||
return
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
|
||||
endif
|
||||
|
||||
end subroutine runParser
|
||||
|
||||
|
||||
function parsefile(filename, configuration, iostat, ex)
|
||||
type(DOMException), intent(out), optional :: ex
|
||||
character(len=*), intent(in) :: filename
|
||||
type(DOMConfiguration), pointer, optional :: configuration
|
||||
integer, intent(out), optional :: iostat
|
||||
type(Node), pointer :: parsefile
|
||||
|
||||
type(DOMException) :: ex_
|
||||
integer :: iostat_
|
||||
|
||||
call open_xml_file(fxml, filename, iostat_)
|
||||
if (present(iostat)) then
|
||||
iostat = iostat_
|
||||
if (iostat/=0) return
|
||||
elseif (in_error(fxml%fx%error_stack)) then
|
||||
call FoX_error(str_vs(fxml%fx%error_stack%stack(1)%msg))
|
||||
elseif (iostat_/=0) then
|
||||
call FoX_error("Cannot open file")
|
||||
endif
|
||||
|
||||
if (present(ex)) then
|
||||
call runParser(fxml, configuration, ex)
|
||||
elseif (present(iostat)) then
|
||||
call runParser(fxml, configuration, ex_)
|
||||
else
|
||||
call runParser(fxml, configuration)
|
||||
endif
|
||||
|
||||
if (present(iostat).and.inException(ex_)) then
|
||||
iostat = getExceptionCode(ex_)
|
||||
endif
|
||||
|
||||
parsefile => mainDoc
|
||||
mainDoc => null()
|
||||
|
||||
end function parsefile
|
||||
|
||||
|
||||
function parsestring(string, configuration, ex)
|
||||
type(DOMException), intent(out), optional :: ex
|
||||
character(len=*), intent(in) :: string
|
||||
type(DOMConfiguration), pointer, optional :: configuration
|
||||
type(Node), pointer :: parsestring
|
||||
|
||||
call open_xml_string(fxml, string)
|
||||
|
||||
call runParser(fxml, configuration, ex)
|
||||
|
||||
parsestring => mainDoc
|
||||
mainDoc => null()
|
||||
|
||||
end function parsestring
|
||||
|
||||
end module m_dom_parse
|
||||
|
|
@ -1,437 +0,0 @@
|
|||
module m_dom_utils
|
||||
|
||||
use fox_m_fsys_array_str, only: str_vs, vs_str
|
||||
use fox_m_fsys_format, only: operator(//)
|
||||
use m_common_attrs, only: getValue
|
||||
use m_common_element, only: element_t, attribute_t, &
|
||||
get_attlist_size, get_attribute_declaration, express_attribute_declaration
|
||||
use m_common_struct, only: xml_doc_state
|
||||
|
||||
! Public interfaces
|
||||
use m_dom_dom, only: DOMConfiguration, NamedNodeMap, Node, &
|
||||
NodeList, &
|
||||
ATTRIBUTE_NODE, CDATA_SECTION_NODE, COMMENT_NODE, DOCUMENT_NODE, &
|
||||
DOCUMENT_TYPE_NODE, ELEMENT_NODE, ENTITY_REFERENCE_NODE, &
|
||||
PROCESSING_INSTRUCTION_NODE, TEXT_NODE, &
|
||||
getAttributes, getChildNodes, getData, getDomConfig, getEntities, &
|
||||
getFirstChild, getFoX_checks, getLength, getLocalName, getName, &
|
||||
getNamespaceURI, getNextSibling, getNodeName, getNodeType, getNotationName,&
|
||||
getNotations, getOwnerDocument, getOwnerElement, getParameter, &
|
||||
getParentNode, getPrefix, getPublicId, getSpecified, getSystemId, &
|
||||
getTagName, getTarget, getXmlStandalone, getXmlVersion, getValue, &
|
||||
haschildnodes, item, normalizeDocument
|
||||
|
||||
! Private interfaces
|
||||
use m_dom_dom, only: getNamespaceNodes, getStringValue, getXds, namespaceFixup
|
||||
|
||||
use m_dom_error, only: DOMException, inException, throw_exception, &
|
||||
getExceptionCode, &
|
||||
NAMESPACE_ERR, SERIALIZE_ERR, FoX_INTERNAL_ERROR, FoX_INVALID_NODE
|
||||
|
||||
use FoX_wxml, only: xmlf_t, &
|
||||
xml_AddAttribute, xml_AddCharacters, xml_AddComment, xml_AddElementToDTD, &
|
||||
xml_AddEntityReference, xml_AddExternalEntity, xml_AddInternalEntity, &
|
||||
xml_AddDOCTYPE, xml_AddNotation, xml_AddXMLDeclaration, xml_AddXMLPI, &
|
||||
xml_EndElement, xml_Close, xml_DeclareNamespace, xml_NewElement, &
|
||||
xml_OpenFile, xml_UndeclareNamespace, xml_AddAttlistToDTD
|
||||
|
||||
implicit none
|
||||
|
||||
public :: dumpTree
|
||||
public :: serialize
|
||||
|
||||
private
|
||||
|
||||
contains
|
||||
|
||||
subroutine dumpTree(startNode)
|
||||
|
||||
type(Node), pointer :: startNode
|
||||
|
||||
integer :: indent_level
|
||||
|
||||
indent_level = 0
|
||||
|
||||
call dump2(startNode)
|
||||
|
||||
contains
|
||||
|
||||
recursive subroutine dump2(input)
|
||||
type(Node), pointer :: input
|
||||
type(Node), pointer :: temp, np
|
||||
type(NamedNodeMap), pointer :: attrs
|
||||
type(NodeList), pointer :: nsnodes
|
||||
integer :: i
|
||||
temp => input
|
||||
do while(associated(temp))
|
||||
write(*,"(3a,i0)") repeat(" ", indent_level), &
|
||||
getNodeName(temp), " of type ", &
|
||||
getNodeType(temp)
|
||||
if (getNodeType(temp)==ELEMENT_NODE) then
|
||||
write(*,"(2a)") repeat(" ", indent_level), &
|
||||
" ATTRIBUTES:"
|
||||
attrs => getAttributes(temp)
|
||||
do i = 0, getLength(attrs) - 1
|
||||
np => item(attrs, i)
|
||||
write(*, "(2a)") repeat(" ", indent_level)//" ", &
|
||||
getName(np)
|
||||
enddo
|
||||
write(*,"(2a)") repeat(" ", indent_level), &
|
||||
" IN-SCOPE NAMESPACES:"
|
||||
nsnodes => getNamespaceNodes(temp)
|
||||
do i = 0, getLength(nsnodes) - 1
|
||||
np => item(nsnodes, i)
|
||||
write(*,"(4a)") repeat(" ", indent_level)//" ", &
|
||||
getPrefix(np), ':', &
|
||||
getNamespaceURI(np)
|
||||
enddo
|
||||
endif
|
||||
if (hasChildNodes(temp)) then
|
||||
indent_level = indent_level + 3
|
||||
call dump2(getFirstChild(temp))
|
||||
indent_level = indent_level - 3
|
||||
endif
|
||||
temp => getNextSibling(temp)
|
||||
enddo
|
||||
|
||||
end subroutine dump2
|
||||
|
||||
end subroutine dumpTree
|
||||
|
||||
|
||||
subroutine serialize(startNode, name, ex)
|
||||
type(DOMException), intent(out), optional :: ex
|
||||
type(Node), pointer :: startNode
|
||||
character(len=*), intent(in) :: name
|
||||
|
||||
type(Node), pointer :: doc
|
||||
type(xmlf_t) :: xf
|
||||
integer :: iostat
|
||||
logical :: xmlDecl
|
||||
|
||||
if (getNodeType(startNode)/=DOCUMENT_NODE &
|
||||
.and.getNodeType(startNode)/=ELEMENT_NODE) then
|
||||
if (getFoX_checks().or.FoX_INVALID_NODE<200) then
|
||||
call throw_exception(FoX_INVALID_NODE, "serialize", ex)
|
||||
if (present(ex)) then
|
||||
if (inException(ex)) then
|
||||
return
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
|
||||
endif
|
||||
|
||||
|
||||
if (getNodeType(startNode)==DOCUMENT_NODE) then
|
||||
doc => startNode
|
||||
if (getParameter(getDomConfig(doc), "canonical-form") &
|
||||
.and.getXmlVersion(doc)=="1.1") then
|
||||
if (getFoX_checks().or.SERIALIZE_ERR<200) then
|
||||
call throw_exception(SERIALIZE_ERR, "serialize", ex)
|
||||
if (present(ex)) then
|
||||
if (inException(ex)) then
|
||||
return
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
|
||||
endif
|
||||
call normalizeDocument(startNode, ex)
|
||||
if (present(ex)) then
|
||||
! Only possible error should be namespace error ...
|
||||
! but we should avoid turning an error of 0 into
|
||||
! an internal error!
|
||||
if (inException(ex)) then
|
||||
if (getExceptionCode(ex)/=NAMESPACE_ERR) then
|
||||
if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then
|
||||
call throw_exception(FoX_INTERNAL_ERROR, "serialize", ex)
|
||||
if (present(ex)) then
|
||||
if (inException(ex)) then
|
||||
return
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
|
||||
else
|
||||
if (getFoX_checks().or.SERIALIZE_ERR<200) then
|
||||
call throw_exception(SERIALIZE_ERR, "serialize", ex)
|
||||
if (present(ex)) then
|
||||
if (inException(ex)) then
|
||||
return
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
else
|
||||
doc => getOwnerDocument(startNode)
|
||||
! We need to do this namespace fixup or serialization will fail.
|
||||
! it doesn't change the semantics of the docs, but other
|
||||
! normalization would, so we done here
|
||||
! But only normalize if this is not a DOM level 1 node.
|
||||
if (getLocalName(startNode)/="" &
|
||||
.and.getParameter(getDomConfig(doc), "namespaces")) &
|
||||
call namespaceFixup(startNode, .true.)
|
||||
endif
|
||||
xmlDecl = getParameter(getDomConfig(doc), "xml-declaration")
|
||||
|
||||
! FIXME we shouldnt really normalize the Document here
|
||||
! (except for namespace Normalization) but rather just
|
||||
! pay attention to the DOMConfig values
|
||||
|
||||
! NOTE: We set pretty_print on the basis of the FoX specific
|
||||
! "invalid-pretty-print" config option. The DOM-L3-LS
|
||||
! option "format-pretty-print is always false and is
|
||||
! not settable by the user - this is because WXML
|
||||
! cannot preserve validity conditions that may be set
|
||||
! by a DTD. If WXML ever learns to do this we will need
|
||||
! to pass the value of "format-pretty-print" through.
|
||||
call xml_OpenFile(name, xf, iostat=iostat, unit=-1, &
|
||||
pretty_print=getParameter(getDomConfig(doc), "invalid-pretty-print"), &
|
||||
canonical=getParameter(getDomConfig(doc), "canonical-form"), &
|
||||
warning=.false., addDecl=.false.)
|
||||
if (iostat/=0) then
|
||||
if (getFoX_checks().or.SERIALIZE_ERR<200) then
|
||||
call throw_exception(SERIALIZE_ERR, "serialize", ex)
|
||||
if (present(ex)) then
|
||||
if (inException(ex)) then
|
||||
return
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
|
||||
endif
|
||||
|
||||
if (xmlDecl) then
|
||||
if (getXmlStandalone(doc)) then
|
||||
call xml_AddXMLDeclaration(xf, version=getXmlVersion(doc), standalone=.true.)
|
||||
else
|
||||
call xml_AddXMLDeclaration(xf, version=getXmlVersion(doc))
|
||||
endif
|
||||
endif
|
||||
|
||||
call iter_dmp_xml(xf, startNode, ex)
|
||||
call xml_Close(xf)
|
||||
|
||||
end subroutine serialize
|
||||
|
||||
subroutine iter_dmp_xml(xf, arg, ex)
|
||||
type(DOMException), intent(out), optional :: ex
|
||||
type(xmlf_t), intent(inout) :: xf
|
||||
|
||||
type(Node), pointer :: this, arg, treeroot
|
||||
type(Node), pointer :: doc, attrchild, np
|
||||
type(NamedNodeMap), pointer :: nnm
|
||||
type(DOMConfiguration), pointer :: dc
|
||||
type(xml_doc_state), pointer :: xds
|
||||
type(element_t), pointer :: elem
|
||||
type(attribute_t), pointer :: att_decl
|
||||
integer :: i_tree, j, k
|
||||
logical :: doneChildren, doneAttributes
|
||||
character, pointer :: attrvalue(:), tmp(:)
|
||||
|
||||
if (getNodeType(arg)==DOCUMENT_NODE) then
|
||||
doc => arg
|
||||
else
|
||||
doc => getOwnerDocument(arg)
|
||||
endif
|
||||
dc => getDomConfig(doc)
|
||||
xds => getXds(doc)
|
||||
|
||||
treeroot => arg
|
||||
|
||||
i_tree = 0
|
||||
doneChildren = .false.
|
||||
doneAttributes = .false.
|
||||
this => treeroot
|
||||
do
|
||||
if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then
|
||||
select case(getNodeType(this))
|
||||
case (ELEMENT_NODE)
|
||||
nnm => getAttributes(this)
|
||||
do j = 0, getLength(nnm) - 1
|
||||
attrchild => item(nnm, j)
|
||||
if (getLocalName(attrchild)=="xmlns") then
|
||||
if (len(getValue(attrchild))==0) then
|
||||
call xml_UndeclareNamespace(xf)
|
||||
else
|
||||
call xml_DeclareNamespace(xf, getValue(attrchild))
|
||||
endif
|
||||
elseif (getPrefix(attrchild)=="xmlns") then
|
||||
if (len(getValue(attrchild))==0) then
|
||||
call xml_UndeclareNamespace(xf, getLocalName(attrchild))
|
||||
else
|
||||
call xml_DeclareNamespace(xf, getValue(attrchild), &
|
||||
getLocalName(attrchild))
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
call xml_NewElement(xf, getTagName(this))
|
||||
case (ATTRIBUTE_NODE)
|
||||
if ((.not.getParameter(dc, "discard-default-content") &
|
||||
.or.getSpecified(this)) &
|
||||
! only output it if it is not a default, or we are outputting defaults
|
||||
.and. (getPrefix(this)/="xmlns".and.getLocalName(this)/="xmlns")) then
|
||||
! and we dont output NS declarations here.
|
||||
! complex loop below is because we might have to worry about entrefs
|
||||
! being preserved in the attvalue. If we dont, we only go through the loop once anyway.
|
||||
allocate(attrvalue(0))
|
||||
do j = 0, getLength(getChildNodes(this)) - 1
|
||||
attrchild => item(getChildNodes(this), j)
|
||||
if (getNodeType(attrchild)==TEXT_NODE) then
|
||||
tmp => attrvalue
|
||||
allocate(attrvalue(size(tmp)+getLength(attrchild)))
|
||||
attrvalue(:size(tmp)) = tmp
|
||||
attrvalue(size(tmp)+1:) = vs_str(getData(attrChild))
|
||||
deallocate(tmp)
|
||||
elseif (getNodeType(attrchild)==ENTITY_REFERENCE_NODE) then
|
||||
tmp => attrvalue
|
||||
allocate(attrvalue(size(tmp)+len(getNodeName(attrchild))+2))
|
||||
attrvalue(:size(tmp)) = tmp
|
||||
attrvalue(size(tmp)+1:) = vs_str("&"//getData(attrChild)//";")
|
||||
deallocate(tmp)
|
||||
else
|
||||
if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then
|
||||
call throw_exception(FoX_INTERNAL_ERROR, "iter_dmp_xml", ex)
|
||||
if (present(ex)) then
|
||||
if (inException(ex)) then
|
||||
return
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
|
||||
endif
|
||||
enddo
|
||||
call xml_AddAttribute(xf, getName(this), str_vs(attrvalue))
|
||||
deallocate(attrvalue)
|
||||
endif
|
||||
doneChildren = .true.
|
||||
case (TEXT_NODE)
|
||||
call xml_AddCharacters(xf, getData(this))
|
||||
case (CDATA_SECTION_NODE)
|
||||
if (getParameter(getDomConfig(doc), "canonical-form")) then
|
||||
call xml_AddCharacters(xf, getData(this))
|
||||
else
|
||||
call xml_AddCharacters(xf, getData(this), parsed = .false.)
|
||||
endif
|
||||
case (ENTITY_REFERENCE_NODE)
|
||||
if (.not.getParameter(getDomConfig(doc), "canonical-form")) then
|
||||
call xml_AddEntityReference(xf, getNodeName(this))
|
||||
doneChildren = .true.
|
||||
endif
|
||||
case (PROCESSING_INSTRUCTION_NODE)
|
||||
call xml_AddXMLPI(xf, getTarget(this), getData(this))
|
||||
case (COMMENT_NODE)
|
||||
if (.not.getParameter(getDomConfig(doc), "comments")) then
|
||||
call xml_AddComment(xf, getData(this))
|
||||
endif
|
||||
case (DOCUMENT_TYPE_NODE)
|
||||
if (.not.getParameter(getDomConfig(doc), "canonical-form")) then
|
||||
call xml_AddDOCTYPE(xf, getName(this))
|
||||
nnm => getNotations(this)
|
||||
do j = 0, getLength(nnm)-1
|
||||
np => item(nnm, j)
|
||||
if (getSystemId(np)=="") then
|
||||
call xml_AddNotation(xf, getNodeName(np), public=getPublicId(np))
|
||||
elseif (getPublicId(np)=="") then
|
||||
call xml_AddNotation(xf, getNodeName(np), system=getSystemId(np))
|
||||
else
|
||||
call xml_AddNotation(xf, getNodeName(np), system=getSystemId(np), &
|
||||
public=getPublicId(np))
|
||||
endif
|
||||
enddo
|
||||
nnm => getEntities(this)
|
||||
do j = 0, getLength(nnm)-1
|
||||
np => item(nnm, j)
|
||||
if (getSystemId(np)=="") then
|
||||
call xml_AddInternalEntity(xf, getNodeName(np), getStringValue(np))
|
||||
elseif (getPublicId(np)=="".and.getNotationName(np)=="") then
|
||||
call xml_AddExternalEntity(xf, getNodeName(np), system=getSystemId(np))
|
||||
elseif (getNotationName(np)=="") then
|
||||
call xml_AddExternalEntity(xf, getNodeName(np), system=getSystemId(np), &
|
||||
public=getPublicId(np))
|
||||
elseif (getPublicId(np)=="") then
|
||||
call xml_AddExternalEntity(xf, getNodeName(np), system=getSystemId(np), &
|
||||
notation=getNotationName(np))
|
||||
else
|
||||
call xml_AddExternalEntity(xf, getNodeName(np), system=getSystemId(np), &
|
||||
public=getPublicId(np), notation=getNotationName(np))
|
||||
endif
|
||||
enddo
|
||||
do j = 1, size(xds%element_list%list)
|
||||
elem => xds%element_list%list(j)
|
||||
if (associated(elem%model)) &
|
||||
call xml_AddElementToDTD(xf, str_vs(elem%name), str_vs(elem%model))
|
||||
! Because we may have some undeclared but referenced elements
|
||||
do k = 1, get_attlist_size(elem)
|
||||
att_decl => get_attribute_declaration(elem, k)
|
||||
call xml_AddAttlistToDTD(xf, str_vs(elem%name), &
|
||||
express_attribute_declaration(att_decl))
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
end select
|
||||
|
||||
else
|
||||
if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then
|
||||
doneAttributes = .true.
|
||||
else
|
||||
|
||||
if (getNodeType(this)==ELEMENT_NODE) then
|
||||
call xml_EndElement(xf, getTagName(this))
|
||||
endif
|
||||
|
||||
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)) 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 subroutine iter_dmp_xml
|
||||
|
||||
end module m_dom_utils
|
||||
1
src/xml/fox
Submodule
1
src/xml/fox
Submodule
|
|
@ -0,0 +1 @@
|
|||
Subproject commit bdc852f4f43d969fb1b179cba79295c1e095a455
|
||||
|
|
@ -1,48 +0,0 @@
|
|||
source = $(wildcard *.F90)
|
||||
objects = $(source:.F90=.o)
|
||||
|
||||
#===============================================================================
|
||||
# Compiler Options
|
||||
#===============================================================================
|
||||
|
||||
# Ignore unusd variables
|
||||
|
||||
ifeq ($(MACHINE),bluegene)
|
||||
override F90 = xlf2003
|
||||
endif
|
||||
|
||||
ifeq ($(F90),ifort)
|
||||
override F90FLAGS += -warn nounused
|
||||
endif
|
||||
|
||||
#===============================================================================
|
||||
# Targets
|
||||
#===============================================================================
|
||||
|
||||
all: $(objects)
|
||||
mv *.mod ../include
|
||||
mv *.o ../lib
|
||||
clean:
|
||||
@rm -f *.o *.mod
|
||||
neat:
|
||||
@rm -f *.o *.mod
|
||||
|
||||
#===============================================================================
|
||||
# Rules
|
||||
#===============================================================================
|
||||
|
||||
.SUFFIXES: .F90 .o
|
||||
|
||||
.PHONY: clean neat
|
||||
|
||||
%.o: %.F90
|
||||
$(F90) $(F90FLAGS) -I../include -c $<
|
||||
|
||||
#===============================================================================
|
||||
# Dependencies
|
||||
#===============================================================================
|
||||
|
||||
fox_m_fsys_format.o: fox_m_fsys_realtypes.o fox_m_fsys_abort_flush.o
|
||||
fox_m_fsys_parse_input.o: fox_m_fsys_realtypes.o
|
||||
fox_m_fsys_count_parse_input.o: fox_m_fsys_realtypes.o
|
||||
fox_m_fsys_string_list.o: fox_m_fsys_array_str.o
|
||||
|
|
@ -1,124 +0,0 @@
|
|||
module fox_m_fsys_abort_flush
|
||||
|
||||
implicit none
|
||||
|
||||
public :: pxfflush
|
||||
public :: pxfabort
|
||||
public :: pure_pxfabort
|
||||
! status values to write to stderr on termination
|
||||
integer, public, parameter :: STDERR_SUCCESS_STATUS = 0
|
||||
integer, public, parameter :: STDERR_FAILURE_STATUS = 1
|
||||
|
||||
! pxf.F90 - assortment of Fortran wrappers to various
|
||||
! unix-y system calls.
|
||||
!
|
||||
! Copyright Toby White, <tow21@cam.ac.uk> 2005
|
||||
|
||||
! The name pxf is intended to be reminiscent of the POSIX
|
||||
! fortran interfaces defined by IEEE 1003.9-1992, although
|
||||
! in fact I don't think that either flush or abort were
|
||||
! covered by said standard.
|
||||
|
||||
! Of the preprocessor defines used here, only xlC is
|
||||
! automatically defined by the appropriate compiler. All
|
||||
! others must be defined by some other mechanism - I
|
||||
! recommend autoconf.
|
||||
|
||||
|
||||
! FLUSH: flushes buffered output on a given unit. Not guaranteed
|
||||
! to do anything at all (particularly under MPI when even FLUSHed
|
||||
! buffers may not make it to the host cpu after an abort.
|
||||
!
|
||||
! IMPLEMENTATION: in F2003, this is a native operation called by the
|
||||
! FLUSH statement.
|
||||
! In almost every compiler, there is a FLUSH intrinsic subroutine
|
||||
! available which takes one argument, the unit to be flushed.
|
||||
! (some will flush all open units when no argument is given - this
|
||||
! facility is not used here.
|
||||
! NAG complicates matters by having to USE a module to get at flush.
|
||||
!
|
||||
! If no FLUSH is available, the subroutine is a no-op.
|
||||
|
||||
|
||||
CONTAINS
|
||||
|
||||
subroutine pxfflush(unit)
|
||||
#ifdef __NAG__
|
||||
use f90_unix_io, only : flush
|
||||
#endif
|
||||
integer, intent(in) :: unit
|
||||
integer :: i
|
||||
|
||||
#if defined(F2003)
|
||||
flush(unit)
|
||||
#elif defined(xlC)
|
||||
call flush_(unit)
|
||||
#elif defined (FC_HAVE_FLUSH)
|
||||
call flush(unit)
|
||||
#else
|
||||
i= unit ! pacify compiler
|
||||
continue
|
||||
#endif
|
||||
|
||||
end subroutine pxfflush
|
||||
|
||||
! ABORT: terminates program execution in such a way that a backtrace
|
||||
! is produced. (see abort() in the C Standard Library). No arguments.
|
||||
!
|
||||
! IMPLEMENTATION: In F2003, the C interoperability features mean that
|
||||
! the abort in stdlib.h is available to be linked against.
|
||||
! In several other compilers an ABORT intrinsic subroutine is available.
|
||||
! Again, NAG complicates matters by needing to USE a module.
|
||||
!
|
||||
! In the case where no native ABORT can be found, we emulate one
|
||||
! by dereferencing a null pointer. This has reliably produced coredumps
|
||||
! on every platform I've tried it with. Just in case it doesn't (it need
|
||||
! not even stop execution) a stop is given to force termination.
|
||||
|
||||
subroutine pxfabort()
|
||||
#ifdef __NAG__
|
||||
use f90_unix_proc, only : abort
|
||||
#endif
|
||||
#ifdef F2003
|
||||
interface
|
||||
subroutine abort() bind(c)
|
||||
end subroutine abort
|
||||
end interface
|
||||
#define FC_HAVE_ABORT
|
||||
#endif
|
||||
#ifndef FC_HAVE_ABORT
|
||||
integer, pointer :: i
|
||||
#endif
|
||||
|
||||
call pxfflush(6)
|
||||
|
||||
#ifdef FC_HAVE_ABORT
|
||||
#ifdef FC_ABORT_UNDERSCORE
|
||||
call abort_()
|
||||
#elif defined(FC_ABORT_ARG)
|
||||
call abort("")
|
||||
#else
|
||||
call abort()
|
||||
#endif
|
||||
#else
|
||||
i=>null()
|
||||
Print*,i
|
||||
#endif
|
||||
stop STDERR_FAILURE_STATUS
|
||||
|
||||
end subroutine pxfabort
|
||||
|
||||
! For where we need a pxfabort that is pure, we have
|
||||
! this below. I am less sure of its working everywhe
|
||||
! also it must be used as a function not a subroutine
|
||||
! (otherwise it would be optimized away as side-effect
|
||||
! free
|
||||
|
||||
pure function pure_pxfabort() result (crash)
|
||||
integer :: crash
|
||||
integer, pointer :: i
|
||||
nullify(i)
|
||||
crash = i
|
||||
end function pure_pxfabort
|
||||
|
||||
end module fox_m_fsys_abort_flush
|
||||
|
|
@ -1,94 +0,0 @@
|
|||
module fox_m_fsys_array_str
|
||||
#ifndef DUMMYLIB
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
interface destroy
|
||||
module procedure destroy_vs
|
||||
end interface
|
||||
|
||||
interface concat
|
||||
module procedure vs_s_concat
|
||||
end interface
|
||||
|
||||
interface alloc
|
||||
module procedure vs_str_alloc
|
||||
end interface
|
||||
|
||||
public :: str_vs
|
||||
public :: vs_str
|
||||
public :: vs_str_alloc
|
||||
public :: vs_vs_alloc
|
||||
|
||||
public :: concat
|
||||
public :: alloc
|
||||
|
||||
public :: destroy
|
||||
|
||||
contains
|
||||
|
||||
pure function str_vs(vs) result(s)
|
||||
character, dimension(:), intent(in) :: vs
|
||||
character(len=size(vs)) :: s
|
||||
integer :: i
|
||||
! Note that we could use s = transfer(vs, s)
|
||||
! here and (in principle) this could be an O(1)
|
||||
! operation. However, this leakes memory on all
|
||||
! recent gfortrans and crashes on some versions of
|
||||
! PGF90. So the loop would need to be included with
|
||||
! an #ifdef PGF90. In any case, the looping version
|
||||
! seems to be quickers (probably due to the character
|
||||
! copying being vectorized in the loop). See:
|
||||
! http://gcc.gnu.org/bugzilla/show_bug.cgi?id=51175
|
||||
do i = 1, size(vs)
|
||||
s(i:i) = vs(i)
|
||||
enddo
|
||||
end function str_vs
|
||||
|
||||
|
||||
pure function vs_str(s) result(vs)
|
||||
character(len=*), intent(in) :: s
|
||||
character, dimension(len(s)) :: vs
|
||||
|
||||
vs = transfer(s, vs)
|
||||
end function vs_str
|
||||
|
||||
pure function vs_str_alloc(s) result(vs)
|
||||
character(len=*), intent(in) :: s
|
||||
character, dimension(:), pointer :: vs
|
||||
|
||||
allocate(vs(len(s)))
|
||||
vs = vs_str(s)
|
||||
end function vs_str_alloc
|
||||
|
||||
pure function vs_vs_alloc(s) result(vs)
|
||||
character, dimension(:), pointer :: s
|
||||
character, dimension(:), pointer :: vs
|
||||
|
||||
if (associated(s)) then
|
||||
allocate(vs(size(s)))
|
||||
vs = s
|
||||
else
|
||||
vs => null()
|
||||
endif
|
||||
end function vs_vs_alloc
|
||||
|
||||
pure function vs_s_concat(vs, s) result(vs2)
|
||||
character, dimension(:), intent(in) :: vs
|
||||
character(len=*), intent(in) :: s
|
||||
character, dimension(:), pointer :: vs2
|
||||
|
||||
allocate(vs2(size(vs)+len(s)))
|
||||
vs2(:size(vs)) = vs
|
||||
vs2(size(vs)+1:) = vs_str(s)
|
||||
end function vs_s_concat
|
||||
|
||||
subroutine destroy_vs(vs)
|
||||
character, dimension(:), pointer :: vs
|
||||
|
||||
deallocate(vs)
|
||||
end subroutine destroy_vs
|
||||
|
||||
#endif
|
||||
end module fox_m_fsys_array_str
|
||||
|
|
@ -1,561 +0,0 @@
|
|||
module fox_m_fsys_count_parse_input
|
||||
|
||||
use fox_m_fsys_realtypes, only: sp, dp
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
character(len=1), parameter :: SPACE = achar(32)
|
||||
character(len=1), parameter :: NEWLINE = achar(10)
|
||||
character(len=1), parameter :: CARRIAGE_RETURN = achar(13)
|
||||
character(len=1), parameter :: TAB = achar(9)
|
||||
character(len=*), parameter :: whitespace = &
|
||||
SPACE//NEWLINE//CARRIAGE_RETURN//TAB
|
||||
|
||||
interface countrts
|
||||
module procedure countstring
|
||||
module procedure countlogical
|
||||
module procedure countinteger
|
||||
module procedure countrealsp
|
||||
module procedure countrealdp
|
||||
module procedure countcomplexsp
|
||||
module procedure countcomplexdp
|
||||
end interface
|
||||
|
||||
public :: countrts
|
||||
|
||||
contains
|
||||
|
||||
pure function countstring(s, datatype, separator, csv) result(num)
|
||||
character(len=*), intent(in) :: s
|
||||
character(len=*), intent(in) :: datatype
|
||||
character, intent(in), optional :: separator
|
||||
logical, intent(in), optional :: csv
|
||||
integer :: num
|
||||
#ifndef DUMMYLIB
|
||||
logical :: bracketed
|
||||
integer :: i, j, ij, k, s_i, err, ios, length
|
||||
real :: r, c
|
||||
|
||||
character(len=len(s)) :: s2
|
||||
logical :: csv_, eof
|
||||
integer :: m
|
||||
|
||||
csv_ = .false.
|
||||
if (present(csv)) then
|
||||
if (csv) csv_ = csv
|
||||
endif
|
||||
|
||||
s_i = 1
|
||||
err = 0
|
||||
eof = .false.
|
||||
ij = 0
|
||||
loop: do
|
||||
if (csv_) then
|
||||
if (s_i>len(s)) then
|
||||
ij = ij + 1
|
||||
exit loop
|
||||
endif
|
||||
k = verify(s(s_i:), achar(10)//achar(13))
|
||||
if (k==0) then
|
||||
ij = ij + 1
|
||||
exit loop
|
||||
elseif (s(s_i+k-1:s_i+k-1)=="""") then
|
||||
! we have a quote-delimited string;
|
||||
s_i = s_i + k
|
||||
s2 = ""
|
||||
quote: do
|
||||
k = index(s(s_i:), """")
|
||||
if (k==0) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
k = s_i + k - 1
|
||||
s2(m:) = s(s_i:k)
|
||||
m = m + (k-s_i+1)
|
||||
k = k + 2
|
||||
if (k>len(s)) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
if (s(k:k)/="""") exit
|
||||
s_i = k + 1
|
||||
if (s_i > len(s)) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
m = m + 1
|
||||
s2(m:m) = """"
|
||||
enddo quote
|
||||
k = scan(s(s_i:), whitespace)
|
||||
if (k==0) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
else
|
||||
s_i = s_i + k - 1
|
||||
k = scan(s(s_i:), achar(10)//achar(13)//",")
|
||||
if (k==0) then
|
||||
eof = .true.
|
||||
k = len(s)
|
||||
else
|
||||
k = s_i + k - 2
|
||||
endif
|
||||
if (index(s(s_i:k), """")/=0) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
endif
|
||||
ij = ij + 1
|
||||
s_i = k + 2
|
||||
if (eof) exit loop
|
||||
|
||||
else
|
||||
if (present(separator)) then
|
||||
k = index(s(s_i:), separator)
|
||||
else
|
||||
k = verify(s(s_i:), whitespace)
|
||||
if (k==0) exit loop
|
||||
s_i = s_i + k - 1
|
||||
k = scan(s(s_i:), whitespace)
|
||||
endif
|
||||
if (k==0) then
|
||||
k = len(s)
|
||||
else
|
||||
k = s_i + k - 2
|
||||
endif
|
||||
ij = ij + 1
|
||||
s_i = k + 2
|
||||
if (s_i>len(s)) exit loop
|
||||
|
||||
endif
|
||||
end do loop
|
||||
|
||||
num = ij
|
||||
if (err/=0) num=0
|
||||
|
||||
#else
|
||||
num = 0
|
||||
#endif
|
||||
end function countstring
|
||||
|
||||
pure function countlogical(s, datatype) result(num)
|
||||
character(len=*), intent(in) :: s
|
||||
logical, intent(in) :: datatype
|
||||
logical :: dummy_data
|
||||
integer :: num
|
||||
#ifndef DUMMYLIB
|
||||
logical :: bracketed
|
||||
integer :: i, j, ij, k, s_i, err, ios, length
|
||||
real :: r, c
|
||||
|
||||
|
||||
s_i = 1
|
||||
err = 0
|
||||
ij = 0
|
||||
length = 1
|
||||
loop: do
|
||||
k = verify(s(s_i:), whitespace)
|
||||
if (k==0) exit loop
|
||||
s_i = s_i + k - 1
|
||||
if (s(s_i:s_i)==",") then
|
||||
if (s_i+1>len(s)) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
k = verify(s(s_i+1:), whitespace)
|
||||
s_i = s_i + k - 1
|
||||
endif
|
||||
k = scan(s(s_i:), whitespace//",")
|
||||
if (k==0) then
|
||||
k = len(s)
|
||||
else
|
||||
k = s_i + k - 2
|
||||
endif
|
||||
if (.not.((s(s_i:k)=="true".or.s(s_i:k)=="1").or. &
|
||||
(s(s_i:k)=="false".or.s(s_i:k)=="0"))) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
ij = ij + 1
|
||||
s_i = k + 2
|
||||
if (ij<length.and.s_i>len(s)) exit loop
|
||||
|
||||
end do loop
|
||||
|
||||
num = ij
|
||||
if (verify(s(s_i:), whitespace)/=0) num = 0
|
||||
if (err/=0) num=0
|
||||
|
||||
|
||||
#else
|
||||
num = 0
|
||||
#endif
|
||||
end function countlogical
|
||||
|
||||
pure function countinteger(s, datatype) result(num)
|
||||
character(len=*), intent(in) :: s
|
||||
integer, intent(in) :: datatype
|
||||
integer :: dummy_data
|
||||
integer num
|
||||
#ifndef DUMMYLIB
|
||||
logical :: bracketed
|
||||
integer :: i, j, ij, k, s_i, err, ios, length
|
||||
real :: r, c
|
||||
|
||||
s_i = 1
|
||||
err = 0
|
||||
ij = 0
|
||||
length = 1
|
||||
loop: do
|
||||
k = verify(s(s_i:), whitespace)
|
||||
if (k==0) exit loop
|
||||
s_i = s_i + k - 1
|
||||
if (s(s_i:s_i)==",") then
|
||||
if (s_i+1>len(s)) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
k = verify(s(s_i+1:), whitespace)
|
||||
s_i = s_i + k - 1
|
||||
endif
|
||||
k = scan(s(s_i:), whitespace//",")
|
||||
if (k==0) then
|
||||
k = len(s)
|
||||
else
|
||||
k = s_i + k - 2
|
||||
endif
|
||||
read(s(s_i:k), *, iostat=ios) dummy_data
|
||||
if (ios/=0) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
ij = ij + 1
|
||||
s_i = k + 2
|
||||
if (ij<length.and.s_i>len(s)) exit loop
|
||||
|
||||
end do loop
|
||||
|
||||
num = ij
|
||||
if (verify(s(s_i:), whitespace)/=0) num = 0
|
||||
if (err/=0) num=0
|
||||
|
||||
|
||||
#else
|
||||
num = 0
|
||||
#endif
|
||||
end function countinteger
|
||||
|
||||
pure function countrealsp(s, datatype) result(num)
|
||||
character(len=*), intent(in) :: s
|
||||
real(sp), intent(in) :: datatype
|
||||
real(sp) :: dummy_data
|
||||
integer :: num
|
||||
#ifndef DUMMYLIB
|
||||
logical :: bracketed
|
||||
integer :: i, j, ij, k, s_i, err, ios, length
|
||||
real :: r, c
|
||||
|
||||
|
||||
s_i = 1
|
||||
err = 0
|
||||
ij = 0
|
||||
length = 1
|
||||
loop: do
|
||||
k = verify(s(s_i:), whitespace)
|
||||
if (k==0) exit loop
|
||||
s_i = s_i + k - 1
|
||||
if (s(s_i:s_i)==",") then
|
||||
if (s_i+1>len(s)) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
k = verify(s(s_i+1:), whitespace)
|
||||
s_i = s_i + k - 1
|
||||
endif
|
||||
k = scan(s(s_i:), whitespace//",")
|
||||
if (k==0) then
|
||||
k = len(s)
|
||||
else
|
||||
k = s_i + k - 2
|
||||
endif
|
||||
read(s(s_i:k), *, iostat=ios) dummy_data
|
||||
if (ios/=0) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
ij = ij + 1
|
||||
s_i = k + 2
|
||||
if (ij<length.and.s_i>len(s)) exit loop
|
||||
|
||||
end do loop
|
||||
|
||||
num = ij
|
||||
if (verify(s(s_i:), whitespace)/=0) num = 0
|
||||
if (err/=0) num=0
|
||||
|
||||
|
||||
#else
|
||||
num = 0
|
||||
#endif
|
||||
end function countrealsp
|
||||
|
||||
pure function countrealdp(s, datatype) result(num)
|
||||
character(len=*), intent(in) :: s
|
||||
real(dp), intent(in) :: datatype
|
||||
real(dp) :: dummy_data
|
||||
integer :: num
|
||||
#ifndef DUMMYLIB
|
||||
logical :: bracketed
|
||||
integer :: i, j, ij, k, s_i, err, ios, length
|
||||
real :: r, c
|
||||
|
||||
|
||||
s_i = 1
|
||||
err = 0
|
||||
ij = 0
|
||||
length = 1
|
||||
loop: do
|
||||
k = verify(s(s_i:), whitespace)
|
||||
if (k==0) exit loop
|
||||
s_i = s_i + k - 1
|
||||
if (s(s_i:s_i)==",") then
|
||||
if (s_i+1>len(s)) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
k = verify(s(s_i+1:), whitespace)
|
||||
s_i = s_i + k - 1
|
||||
endif
|
||||
k = scan(s(s_i:), whitespace//",")
|
||||
if (k==0) then
|
||||
k = len(s)
|
||||
else
|
||||
k = s_i + k - 2
|
||||
endif
|
||||
read(s(s_i:k), *, iostat=ios) dummy_data
|
||||
if (ios/=0) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
ij = ij + 1
|
||||
s_i = k + 2
|
||||
if (ij<length.and.s_i>len(s)) exit loop
|
||||
|
||||
end do loop
|
||||
|
||||
num = ij
|
||||
if (verify(s(s_i:), whitespace)/=0) num = 0
|
||||
if (err/=0) num=0
|
||||
|
||||
|
||||
#else
|
||||
num = 0
|
||||
#endif
|
||||
end function countrealdp
|
||||
|
||||
pure function countcomplexsp(s, datatype) result(num)
|
||||
character(len=*), intent(in) :: s
|
||||
complex(sp), intent(in) :: datatype
|
||||
complex(sp) :: dummy_data
|
||||
integer :: num
|
||||
#ifndef DUMMYLIB
|
||||
logical :: bracketed
|
||||
integer :: i, j, ij, k, s_i, err, ios, length
|
||||
real :: r, c
|
||||
|
||||
|
||||
s_i = 1
|
||||
err = 0
|
||||
ij = 0
|
||||
length = 1
|
||||
loop: do
|
||||
bracketed = .false.
|
||||
k = verify(s(s_i:), whitespace)
|
||||
if (k==0) exit loop
|
||||
s_i = s_i + k - 1
|
||||
select case (s(s_i:s_i))
|
||||
case ("(")
|
||||
bracketed = .true.
|
||||
k = verify(s(s_i:), whitespace)
|
||||
if (k==0) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
s_i = s_i + k
|
||||
case (",")
|
||||
k = verify(s(s_i:), whitespace)
|
||||
if (k==0) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
s_i = s_i + k - 1
|
||||
case ("+", "-", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
|
||||
continue
|
||||
case default
|
||||
err = 2
|
||||
exit loop
|
||||
end select
|
||||
if (bracketed) then
|
||||
k = index(s(s_i:), ")+i(")
|
||||
else
|
||||
k = scan(s(s_i:), whitespace//",")
|
||||
endif
|
||||
if (k==0) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
k = s_i + k - 2
|
||||
read(s(s_i:k), *, iostat=ios) r
|
||||
if (ios/=0) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
if (bracketed) then
|
||||
s_i = k + 5
|
||||
if (s_i>len(s)) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
else
|
||||
s_i = k + 2
|
||||
endif
|
||||
if (bracketed) then
|
||||
k = index(s(s_i:), ")")
|
||||
if (k==0) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
k = s_i + k - 2
|
||||
else
|
||||
k = scan(s(s_i:), whitespace//",")
|
||||
if (k==0) then
|
||||
k = len(s)
|
||||
else
|
||||
k = s_i + k - 2
|
||||
endif
|
||||
endif
|
||||
read(s(s_i:k), *, iostat=ios) c
|
||||
if (ios/=0) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
ij = ij + 1
|
||||
s_i = k + 2
|
||||
if (ij<length.and.s_i>len(s)) exit loop
|
||||
|
||||
end do loop
|
||||
|
||||
num = ij
|
||||
if (verify(s(s_i:), whitespace)/=0) num = 0
|
||||
if (err/=0) num=0
|
||||
|
||||
|
||||
#else
|
||||
num = 0
|
||||
#endif
|
||||
end function countcomplexsp
|
||||
|
||||
pure function countcomplexdp(s, datatype) result(num)
|
||||
character(len=*), intent(in) :: s
|
||||
complex(dp), intent(in) :: datatype
|
||||
complex(dp) :: dummy_data
|
||||
integer :: num
|
||||
#ifndef DUMMYLIB
|
||||
logical :: bracketed
|
||||
integer :: i, j, ij, k, s_i, err, ios, length
|
||||
real :: r, c
|
||||
|
||||
|
||||
s_i = 1
|
||||
err = 0
|
||||
ij = 0
|
||||
length = 1
|
||||
loop: do
|
||||
bracketed = .false.
|
||||
k = verify(s(s_i:), whitespace)
|
||||
if (k==0) exit loop
|
||||
s_i = s_i + k - 1
|
||||
select case (s(s_i:s_i))
|
||||
case ("(")
|
||||
bracketed = .true.
|
||||
k = verify(s(s_i:), whitespace)
|
||||
if (k==0) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
s_i = s_i + k
|
||||
case (",")
|
||||
k = verify(s(s_i:), whitespace)
|
||||
if (k==0) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
s_i = s_i + k - 1
|
||||
case ("+", "-", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
|
||||
continue
|
||||
case default
|
||||
err = 2
|
||||
exit loop
|
||||
end select
|
||||
if (bracketed) then
|
||||
k = index(s(s_i:), ")+i(")
|
||||
else
|
||||
k = scan(s(s_i:), whitespace//",")
|
||||
endif
|
||||
if (k==0) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
k = s_i + k - 2
|
||||
read(s(s_i:k), *, iostat=ios) r
|
||||
if (ios/=0) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
if (bracketed) then
|
||||
s_i = k + 5
|
||||
if (s_i>len(s)) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
else
|
||||
s_i = k + 2
|
||||
endif
|
||||
if (bracketed) then
|
||||
k = index(s(s_i:), ")")
|
||||
if (k==0) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
k = s_i + k - 2
|
||||
else
|
||||
k = scan(s(s_i:), whitespace//",")
|
||||
if (k==0) then
|
||||
k = len(s)
|
||||
else
|
||||
k = s_i + k - 2
|
||||
endif
|
||||
endif
|
||||
read(s(s_i:k), *, iostat=ios) c
|
||||
if (ios/=0) then
|
||||
err = 2
|
||||
exit loop
|
||||
endif
|
||||
ij = ij + 1
|
||||
s_i = k + 2
|
||||
if (ij<length.and.s_i>len(s)) exit loop
|
||||
|
||||
end do loop
|
||||
|
||||
num = ij
|
||||
if (verify(s(s_i:), whitespace)/=0) num = 0
|
||||
if (err/=0) num=0
|
||||
|
||||
|
||||
#else
|
||||
num = 0
|
||||
#endif
|
||||
end function countcomplexdp
|
||||
|
||||
end module fox_m_fsys_count_parse_input
|
||||
File diff suppressed because it is too large
Load diff
File diff suppressed because it is too large
Load diff
|
|
@ -1,12 +0,0 @@
|
|||
module fox_m_fsys_realtypes
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
integer, parameter :: sp = selected_real_kind(6,30)
|
||||
integer, parameter :: dp = selected_real_kind(14,100)
|
||||
|
||||
public :: sp
|
||||
public :: dp
|
||||
|
||||
end module fox_m_fsys_realtypes
|
||||
|
|
@ -1,35 +0,0 @@
|
|||
module fox_m_fsys_string
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
! Assorted generally useful string manipulation functions
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
character(len=26), parameter :: lowerAlphabet = &
|
||||
"abcdefghijklmnopqrstuvwxyz"
|
||||
character(len=26), parameter :: UPPERAlphabet = &
|
||||
"ABCDEFGHIJKLMNOPQRSTUVWXYZ"
|
||||
|
||||
public :: toLower
|
||||
|
||||
contains
|
||||
|
||||
function toLower(s_in) result(s)
|
||||
character(len=*), intent(in) :: s_in
|
||||
character(len=len(s_in)) :: s
|
||||
|
||||
integer :: i, n
|
||||
do i = 1, len(s)
|
||||
n = index(UPPERAlphabet, s_in(i:i))
|
||||
if (n>0) then
|
||||
s(i:i) = lowerAlphabet(n:n)
|
||||
else
|
||||
s(i:i) = s_in(i:i)
|
||||
endif
|
||||
enddo
|
||||
|
||||
end function toLower
|
||||
|
||||
#endif
|
||||
end module fox_m_fsys_string
|
||||
|
|
@ -1,191 +0,0 @@
|
|||
module fox_m_fsys_string_list
|
||||
#ifndef DUMMYLIB
|
||||
|
||||
use fox_m_fsys_array_str, only: str_vs, vs_str_alloc
|
||||
implicit none
|
||||
private
|
||||
|
||||
type string_t
|
||||
character, pointer :: s(:) => null()
|
||||
end type string_t
|
||||
|
||||
type string_list
|
||||
type(string_t), pointer :: list(:) => null()
|
||||
end type string_list
|
||||
|
||||
public :: string_t
|
||||
public :: string_list
|
||||
|
||||
public :: init_string_list
|
||||
public :: destroy_string_list
|
||||
public :: add_string
|
||||
public :: remove_last_string
|
||||
public :: get_last_string
|
||||
public :: tokenize_to_string_list
|
||||
public :: tokenize_and_add_strings
|
||||
public :: registered_string
|
||||
|
||||
interface destroy
|
||||
module procedure destroy_string_list
|
||||
end interface
|
||||
|
||||
public :: destroy
|
||||
|
||||
contains
|
||||
|
||||
subroutine init_string_list(s_list)
|
||||
type(string_list), intent(inout) :: s_list
|
||||
|
||||
allocate(s_list%list(0))
|
||||
end subroutine init_string_list
|
||||
|
||||
subroutine destroy_string_list(s_list)
|
||||
type(string_list), intent(inout) :: s_list
|
||||
|
||||
integer :: i
|
||||
|
||||
if (associated(s_list%list)) then
|
||||
do i = 1, ubound(s_list%list, 1)
|
||||
deallocate(s_list%list(i)%s)
|
||||
enddo
|
||||
deallocate(s_list%list)
|
||||
endif
|
||||
end subroutine destroy_string_list
|
||||
|
||||
subroutine add_string(s_list, s)
|
||||
type(string_list), intent(inout) :: s_list
|
||||
character(len=*), intent(in) :: s
|
||||
|
||||
integer :: i
|
||||
type(string_t), pointer :: temp(:)
|
||||
|
||||
temp => s_list%list
|
||||
allocate(s_list%list(size(temp)+1))
|
||||
do i = 1, size(temp)
|
||||
s_list%list(i)%s => temp(i)%s
|
||||
enddo
|
||||
deallocate(temp)
|
||||
s_list%list(i)%s => vs_str_alloc(s)
|
||||
end subroutine add_string
|
||||
|
||||
subroutine remove_last_string(s_list)
|
||||
type(string_list), intent(inout) :: s_list
|
||||
|
||||
integer :: i
|
||||
type(string_t), pointer :: temp(:)
|
||||
|
||||
temp => s_list%list
|
||||
allocate(s_list%list(size(temp)-1))
|
||||
do i = 1, size(temp)-1
|
||||
s_list%list(i)%s => temp(i)%s
|
||||
enddo
|
||||
deallocate(temp)
|
||||
|
||||
end subroutine remove_last_string
|
||||
|
||||
function get_last_string(s_list) result(s)
|
||||
type(string_list), intent(in) :: s_list
|
||||
character(len=size(s_list%list(size(s_list%list))%s)) :: s
|
||||
|
||||
s = str_vs(s_list%list(size(s_list%list))%s)
|
||||
end function get_last_string
|
||||
|
||||
function tokenize_to_string_list(s) result(s_list)
|
||||
character(len=*), intent(in) :: s
|
||||
type(string_list) :: s_list
|
||||
|
||||
! tokenize a whitespace-separated list of strings
|
||||
! and place results in a string list
|
||||
|
||||
character(len=*), parameter :: &
|
||||
WHITESPACE = achar(9)//achar(10)//achar(13)//achar(32)
|
||||
integer :: i, j
|
||||
|
||||
call init_string_list(s_list)
|
||||
|
||||
i = verify(s, WHITESPACE)
|
||||
if (i==0) return
|
||||
j = scan(s(i:), WHITESPACE)
|
||||
if (j==0) then
|
||||
j = len(s)
|
||||
else
|
||||
j = i + j - 2
|
||||
endif
|
||||
do
|
||||
call add_string(s_list, s(i:j))
|
||||
i = j + 1
|
||||
j = verify(s(i:), WHITESPACE)
|
||||
if (j==0) exit
|
||||
i = i + j - 1
|
||||
j = scan(s(i:), WHITESPACE)
|
||||
if (j==0) then
|
||||
j = len(s)
|
||||
else
|
||||
j = i + j - 2
|
||||
endif
|
||||
enddo
|
||||
|
||||
end function tokenize_to_string_list
|
||||
|
||||
function registered_string(s_list, s) result(p)
|
||||
type(string_list), intent(in) :: s_list
|
||||
character(len=*), intent(in) :: s
|
||||
logical :: p
|
||||
|
||||
integer :: i
|
||||
|
||||
p = .false.
|
||||
do i = 1, size(s_list%list)
|
||||
if (str_vs(s_list%list(i)%s)//"x"==s//"x") then
|
||||
p = .true.
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
end function registered_string
|
||||
|
||||
subroutine tokenize_and_add_strings(s_list, s, uniquify)
|
||||
type(string_list), intent(inout) :: s_list
|
||||
character(len=*), intent(in) :: s
|
||||
logical, intent(in), optional :: uniquify
|
||||
|
||||
! tokenize a whitespace-separated list of strings
|
||||
! and place results in the given string list
|
||||
|
||||
character(len=*), parameter :: &
|
||||
WHITESPACE = achar(9)//achar(10)//achar(13)//achar(32)
|
||||
integer :: i, j
|
||||
logical :: uniquify_
|
||||
|
||||
if (present(uniquify)) then
|
||||
uniquify_ = uniquify
|
||||
else
|
||||
uniquify_ = .false.
|
||||
endif
|
||||
|
||||
i = verify(s, WHITESPACE)
|
||||
if (i==0) return
|
||||
j = scan(s(i:), WHITESPACE)
|
||||
if (j==0) then
|
||||
j = len(s)
|
||||
else
|
||||
j = i + j - 2
|
||||
endif
|
||||
do
|
||||
if (uniquify_.and..not.registered_string(s_list, s(i:j))) &
|
||||
call add_string(s_list, s(i:j))
|
||||
i = j + 1
|
||||
j = verify(s(i:), WHITESPACE)
|
||||
if (j==0) exit
|
||||
i = i + j - 1
|
||||
j = scan(s(i:), WHITESPACE)
|
||||
if (j==0) then
|
||||
j = len(s)
|
||||
else
|
||||
j = i + j - 2
|
||||
endif
|
||||
enddo
|
||||
|
||||
end subroutine tokenize_and_add_strings
|
||||
|
||||
#endif
|
||||
end module fox_m_fsys_string_list
|
||||
|
|
@ -1,254 +0,0 @@
|
|||
module fox_m_fsys_varstr
|
||||
implicit none
|
||||
|
||||
private
|
||||
|
||||
public :: varstr
|
||||
public :: init_varstr
|
||||
public :: destroy_varstr
|
||||
public :: varstr_len
|
||||
public :: is_varstr_empty
|
||||
public :: set_varstr_empty
|
||||
public :: is_varstr_null
|
||||
public :: set_varstr_null
|
||||
public :: vs_varstr_alloc
|
||||
public :: move_varstr_vs
|
||||
public :: move_varstr_varstr
|
||||
public :: str_varstr
|
||||
public :: append_varstr
|
||||
public :: varstr_str
|
||||
public :: varstr_vs
|
||||
public :: equal_varstr_str
|
||||
public :: equal_varstr_varstr
|
||||
|
||||
! Allocation step in which the data within varstr will be allocated
|
||||
integer, parameter :: VARSTR_INIT_SIZE=1024
|
||||
integer, parameter :: VARSTR_ALLOC_SIZE=1024
|
||||
|
||||
! Variable size string type.
|
||||
! It is used for token field, so that it can be grown
|
||||
! by one character at a time without incurring constant
|
||||
! penalty on allocating/deallocating vs data.
|
||||
! See functions and subroutines at the end of this module.
|
||||
type varstr
|
||||
private
|
||||
character, dimension(:), pointer :: data
|
||||
integer :: length
|
||||
end type varstr
|
||||
|
||||
contains
|
||||
|
||||
! Initialise varstr type. The string is initialised as null (i.e. invalid)
|
||||
subroutine init_varstr(vstr)
|
||||
type(varstr), intent(inout) :: vstr
|
||||
allocate(vstr%data(VARSTR_INIT_SIZE))
|
||||
vstr%length = -1
|
||||
end subroutine init_varstr
|
||||
|
||||
! Clean up memory (leaves varstr null, and drops the data field)
|
||||
subroutine destroy_varstr(vstr)
|
||||
type(varstr), intent(inout) :: vstr
|
||||
if (associated(vstr%data)) deallocate(vstr%data)
|
||||
call set_varstr_null(vstr)
|
||||
end subroutine destroy_varstr
|
||||
|
||||
! Return real length of varstr
|
||||
function varstr_len(vstr) result(l)
|
||||
type(varstr), intent(in) :: vstr
|
||||
integer :: l
|
||||
if (vstr%length<0) print *, "WARNING: asking for length of null varstr"
|
||||
l = vstr%length
|
||||
end function varstr_len
|
||||
|
||||
|
||||
! Make sure that varstr is at least size-n.
|
||||
! The data will be kept (copied) if keep is true (default)
|
||||
! This can be called on a null varstr, but should noty be called on
|
||||
! one which was destroyed.
|
||||
subroutine ensure_varstr_size(vstr,n,keep)
|
||||
type(varstr), intent(inout) :: vstr
|
||||
integer, intent(in) :: n
|
||||
logical, optional, intent(in) :: keep
|
||||
|
||||
character, pointer, dimension(:) :: new_data
|
||||
integer :: new_size, old_size
|
||||
logical :: keep_flag
|
||||
|
||||
if (present(keep)) then
|
||||
keep_flag = keep
|
||||
else
|
||||
keep_flag = .true.
|
||||
end if
|
||||
|
||||
old_size = size(vstr%data)
|
||||
if (n <= old_size ) return
|
||||
|
||||
new_size = old_size + ((n-old_size)/VARSTR_ALLOC_SIZE+1) * VARSTR_ALLOC_SIZE
|
||||
allocate(new_data(new_size))
|
||||
|
||||
if (keep_flag) new_data(1:old_size) = vstr%data(1:old_size)
|
||||
|
||||
deallocate( vstr%data )
|
||||
vstr%data => new_data
|
||||
end subroutine ensure_varstr_size
|
||||
|
||||
! Returns whether varstr is empty: ""
|
||||
function is_varstr_empty(vstr)
|
||||
type(varstr), intent(in) :: vstr
|
||||
logical is_varstr_empty
|
||||
is_varstr_empty = (vstr%length == 0)
|
||||
end function is_varstr_empty
|
||||
|
||||
! Set vstr to empty string
|
||||
subroutine set_varstr_empty(vstr)
|
||||
type(varstr), intent(inout) :: vstr
|
||||
vstr%length = 0
|
||||
end subroutine set_varstr_empty
|
||||
|
||||
! Returns whether varstr is null (i.e. invalid)
|
||||
function is_varstr_null(vstr)
|
||||
type(varstr), intent(in) :: vstr
|
||||
logical is_varstr_null
|
||||
is_varstr_null = (vstr%length < 0)
|
||||
end function is_varstr_null
|
||||
|
||||
! Set vstr to null
|
||||
subroutine set_varstr_null(vstr)
|
||||
type(varstr), intent(inout) :: vstr
|
||||
vstr%length = -1
|
||||
end subroutine set_varstr_null
|
||||
|
||||
! Convert varstr to newly allocated array of characters
|
||||
function vs_varstr_alloc(vstr) result(vs)
|
||||
type(varstr) :: vstr
|
||||
character, dimension(:), pointer :: vs
|
||||
|
||||
if (is_varstr_null(vstr)) then
|
||||
print *, "WARNING: Converting null varstr to string... making it empty first"
|
||||
call set_varstr_empty(vstr)
|
||||
end if
|
||||
|
||||
allocate(vs(vstr%length))
|
||||
vs = vstr%data(1:vstr%length)
|
||||
end function vs_varstr_alloc
|
||||
|
||||
! This call moves data from varstr to vs (i.e. vs is overwritten and vstr is made null)
|
||||
subroutine move_varstr_vs(vstr,vs)
|
||||
type(varstr), intent(inout) :: vstr
|
||||
character, dimension(:), pointer, intent(inout) :: vs
|
||||
|
||||
if (associated(vs)) deallocate(vs)
|
||||
vs => vs_varstr_alloc(vstr)
|
||||
call set_varstr_null(vstr)
|
||||
end subroutine move_varstr_vs
|
||||
|
||||
! This call moves data from varstr to varstr (src becomes null)
|
||||
subroutine move_varstr_varstr(src,dst)
|
||||
type(varstr), intent(inout) :: src
|
||||
type(varstr), intent(inout) :: dst
|
||||
character, dimension(:), pointer :: tmpdata
|
||||
|
||||
tmpdata => dst%data
|
||||
dst%data => src%data
|
||||
src%data => tmpdata
|
||||
dst%length = src%length
|
||||
|
||||
call set_varstr_null(src)
|
||||
end subroutine move_varstr_varstr
|
||||
|
||||
|
||||
! Convert varstr to string type
|
||||
function str_varstr(vstr) result(s)
|
||||
type(varstr), intent(in) :: vstr
|
||||
character(len=vstr%length) :: s
|
||||
integer :: i
|
||||
|
||||
if (is_varstr_null(vstr)) then
|
||||
! Can we really end-up here? Or will it blow on allocation with len=-1 ?
|
||||
print *, "WARNING: Trying to convert null varstr to str... returning empty string"
|
||||
s = ""
|
||||
end if
|
||||
|
||||
do i = 1, vstr%length
|
||||
s(i:i) = vstr%data(i)
|
||||
enddo
|
||||
end function str_varstr
|
||||
|
||||
! Append string to varstr
|
||||
subroutine append_varstr(vstr,str)
|
||||
type(varstr), intent(inout) :: vstr
|
||||
character(len=*), intent(in) :: str
|
||||
character, dimension(:), pointer :: tmp
|
||||
integer :: i
|
||||
|
||||
if (is_varstr_null(vstr)) then
|
||||
print *, "WARNING: Trying to append to null varstr... making it empty first"
|
||||
call set_varstr_empty(vstr)
|
||||
end if
|
||||
|
||||
call ensure_varstr_size(vstr,vstr%length+len(str))
|
||||
|
||||
! Note: on a XML file with very large tokens, this loop
|
||||
! is consistently faster than equivalent 'transfer' intrinsic
|
||||
do i=1,len(str)
|
||||
vstr%data(vstr%length+i) = str(i:i)
|
||||
end do
|
||||
vstr%length = vstr%length + len(str)
|
||||
end subroutine append_varstr
|
||||
|
||||
! Convert string to varstr in place
|
||||
subroutine varstr_str(vstr,str)
|
||||
type(varstr), intent(inout) :: vstr
|
||||
character(len=*), intent(in) :: str
|
||||
integer :: i
|
||||
|
||||
call ensure_varstr_size(vstr,len(str),.false.)
|
||||
do i=1,len(str)
|
||||
vstr%data(i) = str(i:i)
|
||||
end do
|
||||
vstr%length = len(str)
|
||||
end subroutine varstr_str
|
||||
|
||||
! Convert character array to varstr in place
|
||||
subroutine varstr_vs(vstr,vs)
|
||||
type(varstr), intent(inout) :: vstr
|
||||
character, dimension(:), intent(in) :: vs
|
||||
|
||||
call ensure_varstr_size(vstr,size(vs),.false.)
|
||||
|
||||
vstr%length = size(vs)
|
||||
vstr%data(1:size(vs)) = vs
|
||||
end subroutine varstr_vs
|
||||
|
||||
! Compare varstr to str (true if equal)
|
||||
function equal_varstr_str(vstr,str) result(r)
|
||||
type(varstr), intent(in) :: vstr
|
||||
character(len=*) :: str
|
||||
logical :: r
|
||||
|
||||
integer :: i
|
||||
|
||||
r = .false.
|
||||
if ( len(str) /= varstr_len(vstr) ) return
|
||||
do i=1,len(str)
|
||||
if ( str(i:i) /= vstr%data(i) ) return
|
||||
end do
|
||||
r = .true.
|
||||
end function equal_varstr_str
|
||||
|
||||
! Compare varstr to varstr (true if equal)
|
||||
function equal_varstr_varstr(vstr1,vstr2) result(r)
|
||||
type(varstr), intent(in) :: vstr1, vstr2
|
||||
logical :: r
|
||||
|
||||
integer :: i
|
||||
|
||||
r = .false.
|
||||
if ( varstr_len(vstr1) /= varstr_len(vstr2) ) return
|
||||
do i=1,varstr_len(vstr1)
|
||||
if ( vstr1%data(i) /= vstr2%data(i) ) return
|
||||
end do
|
||||
r = .true.
|
||||
end function equal_varstr_varstr
|
||||
|
||||
end module fox_m_fsys_varstr
|
||||
|
|
@ -1,17 +0,0 @@
|
|||
module m_ieee
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
public :: generate_nan
|
||||
|
||||
contains
|
||||
|
||||
function generate_nan() result(nan)
|
||||
real :: nan
|
||||
real :: zero
|
||||
zero = 0.0
|
||||
nan = 0.0/zero
|
||||
end function generate_nan
|
||||
|
||||
end module m_ieee
|
||||
192
src/xml/openmc_fox.F90
Normal file
192
src/xml/openmc_fox.F90
Normal file
|
|
@ -0,0 +1,192 @@
|
|||
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
|
||||
|
||||
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
|
||||
|
|
@ -1,34 +0,0 @@
|
|||
module FoX_sax
|
||||
|
||||
use FoX_common
|
||||
use m_sax_operate
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
public :: open_xml_file
|
||||
public :: open_xml_string
|
||||
public :: close_xml_t
|
||||
public :: parse
|
||||
public :: stop_parser
|
||||
public :: SAX_OPEN_ERROR
|
||||
|
||||
public :: xml_t
|
||||
|
||||
public :: dictionary_t
|
||||
!SAX functions
|
||||
public :: getIndex
|
||||
public :: getLength
|
||||
public :: getLocalName
|
||||
public :: getQName
|
||||
public :: getURI
|
||||
public :: getValue
|
||||
public :: getType
|
||||
public :: isSpecified
|
||||
public :: isDeclared
|
||||
public :: setSpecified
|
||||
public :: setDeclared
|
||||
!For convenience
|
||||
public :: hasKey
|
||||
|
||||
end module FoX_sax
|
||||
|
|
@ -1,50 +0,0 @@
|
|||
source = $(wildcard *.F90)
|
||||
objects = $(source:.F90=.o)
|
||||
|
||||
#===============================================================================
|
||||
# Compiler Options
|
||||
#===============================================================================
|
||||
|
||||
# Ignore unusd variables
|
||||
|
||||
ifeq ($(MACHINE),bluegene)
|
||||
override F90 = xlf2003
|
||||
endif
|
||||
|
||||
ifeq ($(F90),ifort)
|
||||
override F90FLAGS += -warn nounused
|
||||
endif
|
||||
|
||||
#===============================================================================
|
||||
# Targets
|
||||
#===============================================================================
|
||||
|
||||
all: $(objects)
|
||||
mv *.mod ../include
|
||||
mv *.o ../lib
|
||||
clean:
|
||||
@rm -f *.o *.mod
|
||||
neat:
|
||||
@rm -f *.o *.mod
|
||||
|
||||
#===============================================================================
|
||||
# Rules
|
||||
#===============================================================================
|
||||
|
||||
.SUFFIXES: .F90 .o
|
||||
|
||||
.PHONY: clean neat
|
||||
|
||||
%.o: %.F90
|
||||
$(F90) $(F90FLAGS) -c -I../include $<
|
||||
|
||||
#===============================================================================
|
||||
# Dependencies
|
||||
#===============================================================================
|
||||
|
||||
FoX_sax.o: m_sax_operate.o
|
||||
m_sax_operate.o: m_sax_parser.o m_sax_reader.o m_sax_types.o
|
||||
m_sax_parser.o: m_sax_reader.o m_sax_tokenizer.o m_sax_types.o
|
||||
m_sax_reader.o: m_sax_xml_source.o
|
||||
m_sax_tokenizer.o: m_sax_reader.o m_sax_types.o
|
||||
m_sax_types.o: m_sax_reader.o
|
||||
|
|
@ -1,313 +0,0 @@
|
|||
module m_sax_operate
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
use m_common_error, only: FoX_error, in_error
|
||||
use FoX_common, only : str_vs
|
||||
|
||||
use m_sax_reader, only: open_file, close_file
|
||||
use m_sax_parser, only: sax_parser_init, sax_parser_destroy, sax_parse
|
||||
use m_sax_types, only: ST_STOP
|
||||
#endif
|
||||
use m_sax_types, only: xml_t
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
integer, parameter :: SAX_OPEN_ERROR = 1001
|
||||
|
||||
public :: xml_t
|
||||
public :: open_xml_file
|
||||
public :: open_xml_string
|
||||
public :: close_xml_t
|
||||
public :: parse
|
||||
public :: stop_parser
|
||||
public :: SAX_OPEN_ERROR
|
||||
|
||||
contains
|
||||
|
||||
subroutine open_xml_file(xt, file, iostat, lun)
|
||||
type(xml_t), intent(out) :: xt
|
||||
character(len=*), intent(in) :: file
|
||||
integer, intent(out), optional :: iostat
|
||||
integer, intent(in), optional :: lun
|
||||
#ifdef DUMMYLIB
|
||||
if (present(iostat)) iostat = 0
|
||||
#else
|
||||
integer :: i
|
||||
|
||||
call open_file(xt%fb, file=trim(file), iostat=i, lun=lun, es=xt%fx%error_stack)
|
||||
if (present(iostat)) then
|
||||
if (in_error(xt%fx%error_stack)) i = SAX_OPEN_ERROR
|
||||
iostat = i
|
||||
if (i/=0) return
|
||||
else
|
||||
if (i/=0) &
|
||||
call FoX_error("Error opening file in open_xml_file")
|
||||
if (in_error(xt%fx%error_stack)) &
|
||||
call FoX_error(str_vs(xt%fx%error_stack%stack(1)%msg))
|
||||
endif
|
||||
|
||||
if (i==0) call sax_parser_init(xt%fx, xt%fb)
|
||||
#endif
|
||||
end subroutine open_xml_file
|
||||
|
||||
subroutine open_xml_string(xt, string)
|
||||
type(xml_t), intent(out) :: xt
|
||||
character(len=*), intent(in) :: string
|
||||
#ifndef DUMMYLIB
|
||||
integer :: iostat
|
||||
|
||||
call open_file(xt%fb, string=string, iostat=iostat, es=xt%fx%error_stack)
|
||||
call sax_parser_init(xt%fx, xt%fb)
|
||||
#endif
|
||||
end subroutine open_xml_string
|
||||
|
||||
subroutine close_xml_t(xt)
|
||||
type(xml_t), intent(inout) :: xt
|
||||
#ifndef DUMMYLIB
|
||||
call close_file(xt%fb)
|
||||
call sax_parser_destroy(xt%fx)
|
||||
#endif
|
||||
end subroutine close_xml_t
|
||||
|
||||
|
||||
subroutine parse(xt, &
|
||||
characters_handler, &
|
||||
endDocument_handler, &
|
||||
endElement_handler, &
|
||||
endPrefixMapping_handler, &
|
||||
ignorableWhitespace_handler, &
|
||||
processingInstruction_handler, &
|
||||
! setDocumentLocator
|
||||
skippedEntity_handler, &
|
||||
startDocument_handler, &
|
||||
startElement_handler, &
|
||||
startPrefixMapping_handler, &
|
||||
notationDecl_handler, &
|
||||
unparsedEntityDecl_handler, &
|
||||
error_handler, &
|
||||
fatalError_handler, &
|
||||
warning_handler, &
|
||||
attributeDecl_handler, &
|
||||
elementDecl_handler, &
|
||||
externalEntityDecl_handler, &
|
||||
internalEntityDecl_handler, &
|
||||
comment_handler, &
|
||||
endCdata_handler, &
|
||||
endDTD_handler, &
|
||||
endEntity_handler, &
|
||||
startCdata_handler, &
|
||||
startDTD_handler, &
|
||||
startEntity_handler, &
|
||||
! Features / properties
|
||||
namespaces, &
|
||||
namespace_prefixes, &
|
||||
validate, &
|
||||
xmlns_uris)
|
||||
|
||||
type(xml_t), intent(inout) :: xt
|
||||
optional :: characters_handler
|
||||
optional :: endDocument_handler
|
||||
optional :: endElement_handler
|
||||
optional :: endPrefixMapping_handler
|
||||
optional :: ignorableWhitespace_handler
|
||||
optional :: processingInstruction_handler
|
||||
optional :: skippedEntity_handler
|
||||
optional :: startElement_handler
|
||||
optional :: startDocument_handler
|
||||
optional :: startPrefixMapping_handler
|
||||
optional :: notationDecl_handler
|
||||
optional :: unparsedEntityDecl_handler
|
||||
optional :: error_handler
|
||||
optional :: fatalError_handler
|
||||
optional :: warning_handler
|
||||
optional :: attributeDecl_handler
|
||||
optional :: elementDecl_handler
|
||||
optional :: externalEntityDecl_handler
|
||||
optional :: internalEntityDecl_handler
|
||||
optional :: comment_handler
|
||||
optional :: endCdata_handler
|
||||
optional :: endEntity_handler
|
||||
optional :: endDTD_handler
|
||||
optional :: startCdata_handler
|
||||
optional :: startDTD_handler
|
||||
optional :: startEntity_handler
|
||||
|
||||
logical, intent(in), optional :: namespaces
|
||||
logical, intent(in), optional :: namespace_prefixes
|
||||
logical, intent(in), optional :: validate
|
||||
logical, intent(in), optional :: xmlns_uris
|
||||
|
||||
interface
|
||||
|
||||
subroutine characters_handler(chunk)
|
||||
character(len=*), intent(in) :: chunk
|
||||
end subroutine characters_handler
|
||||
|
||||
subroutine endDocument_handler()
|
||||
end subroutine endDocument_handler
|
||||
|
||||
subroutine endElement_handler(namespaceURI, localName, name)
|
||||
character(len=*), intent(in) :: namespaceURI
|
||||
character(len=*), intent(in) :: localName
|
||||
character(len=*), intent(in) :: name
|
||||
end subroutine endElement_handler
|
||||
|
||||
subroutine endPrefixMapping_handler(prefix)
|
||||
character(len=*), intent(in) :: prefix
|
||||
end subroutine endPrefixMapping_handler
|
||||
|
||||
subroutine ignorableWhitespace_handler(chars)
|
||||
character(len=*), intent(in) :: chars
|
||||
end subroutine ignorableWhitespace_handler
|
||||
|
||||
subroutine processingInstruction_handler(name, content)
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=*), intent(in) :: content
|
||||
end subroutine processingInstruction_handler
|
||||
|
||||
subroutine skippedEntity_handler(name)
|
||||
character(len=*), intent(in) :: name
|
||||
end subroutine skippedEntity_handler
|
||||
|
||||
subroutine startDocument_handler()
|
||||
end subroutine startDocument_handler
|
||||
|
||||
subroutine startElement_handler(namespaceURI, localName, name, attributes)
|
||||
use FoX_common
|
||||
character(len=*), intent(in) :: namespaceUri
|
||||
character(len=*), intent(in) :: localName
|
||||
character(len=*), intent(in) :: name
|
||||
type(dictionary_t), intent(in) :: attributes
|
||||
end subroutine startElement_handler
|
||||
|
||||
subroutine startPrefixMapping_handler(namespaceURI, prefix)
|
||||
character(len=*), intent(in) :: namespaceURI
|
||||
character(len=*), intent(in) :: prefix
|
||||
end subroutine startPrefixMapping_handler
|
||||
|
||||
subroutine notationDecl_handler(name, publicId, systemId)
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=*), intent(in) :: publicId
|
||||
character(len=*), intent(in) :: systemId
|
||||
end subroutine notationDecl_handler
|
||||
|
||||
subroutine unparsedEntityDecl_handler(name, publicId, systemId, notation)
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=*), intent(in) :: publicId
|
||||
character(len=*), intent(in) :: systemId
|
||||
character(len=*), intent(in) :: notation
|
||||
end subroutine unparsedEntityDecl_handler
|
||||
|
||||
subroutine error_handler(msg)
|
||||
character(len=*), intent(in) :: msg
|
||||
end subroutine error_handler
|
||||
|
||||
subroutine fatalError_handler(msg)
|
||||
character(len=*), intent(in) :: msg
|
||||
end subroutine fatalError_handler
|
||||
|
||||
subroutine warning_handler(msg)
|
||||
character(len=*), intent(in) :: msg
|
||||
end subroutine warning_handler
|
||||
|
||||
subroutine attributeDecl_handler(eName, aName, type, mode, value)
|
||||
character(len=*), intent(in) :: eName
|
||||
character(len=*), intent(in) :: aName
|
||||
character(len=*), intent(in) :: type
|
||||
character(len=*), intent(in), optional :: mode
|
||||
character(len=*), intent(in), optional :: value
|
||||
end subroutine attributeDecl_handler
|
||||
|
||||
subroutine elementDecl_handler(name, model)
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=*), intent(in) :: model
|
||||
end subroutine elementDecl_handler
|
||||
|
||||
subroutine externalEntityDecl_handler(name, publicId, systemId)
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=*), intent(in) :: publicId
|
||||
character(len=*), intent(in) :: systemId
|
||||
end subroutine externalEntityDecl_handler
|
||||
|
||||
subroutine internalEntityDecl_handler(name, value)
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=*), intent(in) :: value
|
||||
end subroutine internalEntityDecl_handler
|
||||
|
||||
subroutine comment_handler(comment)
|
||||
character(len=*), intent(in) :: comment
|
||||
end subroutine comment_handler
|
||||
|
||||
subroutine endCdata_handler()
|
||||
end subroutine endCdata_handler
|
||||
|
||||
subroutine endDTD_handler()
|
||||
end subroutine endDTD_handler
|
||||
|
||||
subroutine endEntity_handler(name)
|
||||
character(len=*), intent(in) :: name
|
||||
end subroutine endEntity_handler
|
||||
|
||||
subroutine startCdata_handler()
|
||||
end subroutine startCdata_handler
|
||||
|
||||
subroutine startDTD_handler(name, publicId, systemId)
|
||||
character(len=*), intent(in) :: name
|
||||
character(len=*), intent(in) :: publicId
|
||||
character(len=*), intent(in) :: systemId
|
||||
end subroutine startDTD_handler
|
||||
|
||||
subroutine startEntity_handler(name)
|
||||
character(len=*), intent(in) :: name
|
||||
end subroutine startEntity_handler
|
||||
|
||||
end interface
|
||||
#ifndef DUMMYLIB
|
||||
! FIXME check xt is initialized
|
||||
|
||||
call sax_parse(xt%fx, xt%fb, &
|
||||
characters_handler, &
|
||||
endDocument_handler, &
|
||||
endElement_handler, &
|
||||
endPrefixMapping_handler, &
|
||||
ignorableWhitespace_handler, &
|
||||
processingInstruction_handler, &
|
||||
! setDocumentLocator
|
||||
skippedEntity_handler, &
|
||||
startDocument_handler, &
|
||||
startElement_handler, &
|
||||
startPrefixMapping_handler, &
|
||||
notationDecl_handler, &
|
||||
unparsedEntityDecl_handler, &
|
||||
error_handler, &
|
||||
fatalError_handler, &
|
||||
warning_handler, &
|
||||
attributeDecl_handler, &
|
||||
elementDecl_handler, &
|
||||
externalEntityDecl_handler, &
|
||||
internalEntityDecl_handler, &
|
||||
comment_handler, &
|
||||
endCdata_handler, &
|
||||
endDTD_handler, &
|
||||
endEntity_handler, &
|
||||
startCdata_handler, &
|
||||
startDTD_handler, &
|
||||
startEntity_handler, &
|
||||
namespaces=namespaces, &
|
||||
namespace_prefixes=namespace_prefixes, &
|
||||
validate=validate, &
|
||||
xmlns_uris=xmlns_uris)
|
||||
#endif
|
||||
end subroutine parse
|
||||
|
||||
subroutine stop_parser(xt)
|
||||
! To be called from within a callback function;
|
||||
! this will stop the parser.
|
||||
type(xml_t), intent(inout) :: xt
|
||||
#ifndef DUMMYLIB
|
||||
xt%fx%state = ST_STOP
|
||||
#endif
|
||||
end subroutine stop_parser
|
||||
|
||||
end module m_sax_operate
|
||||
File diff suppressed because it is too large
Load diff
|
|
@ -1,411 +0,0 @@
|
|||
module m_sax_reader
|
||||
#ifndef DUMMYLIB
|
||||
|
||||
use fox_m_fsys_array_str, only: str_vs, vs_str_alloc, vs_vs_alloc
|
||||
use fox_m_fsys_format, only: operator(//)
|
||||
use m_common_charset, only: XML1_0
|
||||
use m_common_error, only: error_stack, FoX_error, in_error, add_error
|
||||
use m_common_io, only: setup_io, get_unit, io_err
|
||||
|
||||
use FoX_utils, only: URI, parseURI, copyURI, destroyURI, &
|
||||
hasScheme, getScheme, getPath
|
||||
|
||||
use m_sax_xml_source, only: xml_source_t, &
|
||||
get_char_from_file, push_file_chars, parse_declaration
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
type file_buffer_t
|
||||
!FIXME private
|
||||
type(xml_source_t), pointer :: f(:) => null()
|
||||
logical :: standalone = .false.
|
||||
integer :: xml_version = XML1_0
|
||||
end type file_buffer_t
|
||||
|
||||
public :: file_buffer_t
|
||||
public :: line
|
||||
public :: column
|
||||
public :: add_error_position
|
||||
|
||||
public :: open_file
|
||||
public :: close_file
|
||||
|
||||
public :: open_new_file
|
||||
|
||||
public :: push_chars
|
||||
|
||||
public :: get_character
|
||||
public :: get_all_characters
|
||||
|
||||
public :: open_new_string
|
||||
public :: pop_buffer_stack
|
||||
|
||||
public :: parse_xml_declaration
|
||||
public :: parse_text_declaration
|
||||
|
||||
public :: reading_main_file
|
||||
public :: reading_first_entity
|
||||
|
||||
contains
|
||||
|
||||
subroutine open_file(fb, iostat, file, lun, string, es)
|
||||
type(file_buffer_t), intent(out) :: fb
|
||||
character(len=*), intent(in), optional :: file
|
||||
integer, intent(out) :: iostat
|
||||
integer, intent(in), optional :: lun
|
||||
character(len=*), intent(in), optional :: string
|
||||
type(error_stack), intent(inout) :: es
|
||||
|
||||
type(URI), pointer :: fileURI
|
||||
|
||||
iostat = 0
|
||||
|
||||
call setup_io()
|
||||
if (present(string)) then
|
||||
if (present(file)) then
|
||||
call FoX_error("Cannot specify both file and string input to open_xml")
|
||||
elseif (present(lun)) then
|
||||
call FoX_error("Cannot specify lun for string input to open_xml")
|
||||
endif
|
||||
fileURI => parseURI("")
|
||||
call open_new_string(fb, string, "", baseURI=fileURI)
|
||||
else
|
||||
fileURI => parseURI(file)
|
||||
if (.not.associated(fileURI)) then
|
||||
call add_error(es, "Could not open file "//file//" - not a valid URI")
|
||||
iostat=1
|
||||
return
|
||||
endif
|
||||
call open_new_file(fb, fileURI, iostat, lun)
|
||||
endif
|
||||
call destroyURI(fileURI)
|
||||
|
||||
end subroutine open_file
|
||||
|
||||
|
||||
subroutine open_new_file(fb, baseURI, iostat, lun, pe)
|
||||
type(file_buffer_t), intent(inout) :: fb
|
||||
integer, intent(out) :: iostat
|
||||
type(URI), pointer :: baseURI
|
||||
integer, intent(in), optional :: lun
|
||||
logical, intent(in), optional :: pe
|
||||
|
||||
integer :: i
|
||||
type(xml_source_t) :: f
|
||||
type(xml_source_t), pointer :: temp(:)
|
||||
logical :: pe_
|
||||
|
||||
if (present(pe)) then
|
||||
pe_ = pe
|
||||
else
|
||||
pe_ = .false.
|
||||
endif
|
||||
|
||||
if (hasScheme(baseURI)) then
|
||||
if (getScheme(baseURI)/="file") then
|
||||
iostat = io_err
|
||||
return
|
||||
endif
|
||||
endif
|
||||
|
||||
call open_actual_file(f, getPath(baseURI), iostat, lun)
|
||||
if (iostat==0) then
|
||||
if (.not.associated(fb%f)) allocate(fb%f(0))
|
||||
! First file
|
||||
|
||||
temp => fb%f
|
||||
allocate(fb%f(size(temp)+1))
|
||||
do i = 1, size(temp)
|
||||
fb%f(i+1)%lun = temp(i)%lun
|
||||
fb%f(i+1)%xml_version = temp(i)%xml_version
|
||||
fb%f(i+1)%encoding => temp(i)%encoding
|
||||
fb%f(i+1)%filename => temp(i)%filename
|
||||
fb%f(i+1)%line = temp(i)%line
|
||||
fb%f(i+1)%col = temp(i)%col
|
||||
fb%f(i+1)%startChar = temp(i)%startChar
|
||||
fb%f(i+1)%next_chars => temp(i)%next_chars
|
||||
fb%f(i+1)%input_string => temp(i)%input_string
|
||||
fb%f(i+1)%baseURI => temp(i)%baseURI
|
||||
fb%f(i+1)%pe = temp(i)%pe
|
||||
enddo
|
||||
deallocate(temp)
|
||||
fb%f(1)%lun = f%lun
|
||||
fb%f(1)%filename => f%filename
|
||||
if (pe_) then
|
||||
fb%f(1)%next_chars => vs_str_alloc(" ")
|
||||
else
|
||||
fb%f(1)%next_chars => vs_str_alloc("")
|
||||
endif
|
||||
fb%f(1)%pe = pe_
|
||||
fb%f(1)%baseURI => copyURI(baseURI)
|
||||
endif
|
||||
|
||||
end subroutine open_new_file
|
||||
|
||||
subroutine open_actual_file(f, file, iostat, lun)
|
||||
type(xml_source_t), intent(out) :: f
|
||||
character(len=*), intent(in) :: file
|
||||
integer, intent(out) :: iostat
|
||||
integer, intent(in), optional :: lun
|
||||
|
||||
if (present(lun)) then
|
||||
f%lun = lun
|
||||
else
|
||||
call get_unit(f%lun, iostat)
|
||||
if (iostat/=0) return
|
||||
endif
|
||||
open(unit=f%lun, file=file, form="formatted", status="old", &
|
||||
action="read", position="rewind", iostat=iostat)
|
||||
if (iostat/=0) return
|
||||
f%filename => vs_str_alloc(file)
|
||||
|
||||
end subroutine open_actual_file
|
||||
|
||||
subroutine close_file(fb)
|
||||
type(file_buffer_t), intent(inout) :: fb
|
||||
|
||||
integer :: i
|
||||
|
||||
do i = 1, size(fb%f)
|
||||
call close_actual_file(fb%f(i))
|
||||
enddo
|
||||
|
||||
if (associated(fb%f)) deallocate(fb%f)
|
||||
|
||||
end subroutine close_file
|
||||
|
||||
|
||||
subroutine close_actual_file(f)
|
||||
type(xml_source_t), intent(inout) :: f
|
||||
|
||||
deallocate(f%filename)
|
||||
|
||||
if (f%lun>0) then
|
||||
close(f%lun)
|
||||
else
|
||||
deallocate(f%input_string%s)
|
||||
deallocate(f%input_string)
|
||||
endif
|
||||
|
||||
if (associated(f%encoding)) deallocate(f%encoding)
|
||||
f%line = 0
|
||||
f%col = 0
|
||||
deallocate(f%next_chars)
|
||||
call destroyURI(f%baseURI)
|
||||
end subroutine close_actual_file
|
||||
|
||||
|
||||
subroutine open_new_string(fb, string, name, baseURI, pe)
|
||||
type(file_buffer_t), intent(inout) :: fb
|
||||
character(len=*), intent(in) :: string
|
||||
character(len=*), intent(in) :: name
|
||||
type(URI), pointer :: baseURI
|
||||
logical, intent(in), optional :: pe
|
||||
|
||||
integer :: i
|
||||
type(xml_source_t), pointer :: temp(:)
|
||||
logical :: pe_
|
||||
|
||||
if (present(pe)) then
|
||||
pe_ = pe
|
||||
else
|
||||
pe_ = .false.
|
||||
endif
|
||||
|
||||
if (.not.associated(fb%f)) allocate(fb%f(0))
|
||||
|
||||
temp => fb%f
|
||||
allocate(fb%f(size(temp)+1))
|
||||
do i = 1, size(temp)
|
||||
fb%f(i+1)%lun = temp(i)%lun
|
||||
fb%f(i+1)%xml_version = temp(i)%xml_version
|
||||
fb%f(i+1)%encoding => temp(i)%encoding
|
||||
fb%f(i+1)%filename => temp(i)%filename
|
||||
fb%f(i+1)%line = temp(i)%line
|
||||
fb%f(i+1)%col = temp(i)%col
|
||||
fb%f(i+1)%startChar = temp(i)%startChar
|
||||
fb%f(i+1)%next_chars => temp(i)%next_chars
|
||||
fb%f(i+1)%input_string => temp(i)%input_string
|
||||
fb%f(i+1)%baseURI => temp(i)%baseURI
|
||||
fb%f(i+1)%pe = temp(i)%pe
|
||||
enddo
|
||||
deallocate(temp)
|
||||
|
||||
allocate(fb%f(1)%input_string)
|
||||
fb%f(1)%filename => vs_str_alloc(name)
|
||||
fb%f(1)%input_string%s => vs_str_alloc(string)
|
||||
if (pe_) then
|
||||
fb%f(1)%next_chars => vs_str_alloc(" ")
|
||||
else
|
||||
fb%f(1)%next_chars => vs_str_alloc("")
|
||||
endif
|
||||
fb%f(1)%pe = pe_
|
||||
if (associated(baseURI)) then
|
||||
fb%f(1)%baseURI => copyURI(baseURI)
|
||||
else
|
||||
fb%f(1)%baseURI => copyURI(fb%f(2)%baseURI)
|
||||
endif
|
||||
|
||||
end subroutine open_new_string
|
||||
|
||||
subroutine pop_buffer_stack(fb)
|
||||
type(file_buffer_t), intent(inout) :: fb
|
||||
|
||||
integer :: i
|
||||
type(xml_source_t), pointer :: temp(:)
|
||||
|
||||
call close_actual_file(fb%f(1))
|
||||
|
||||
temp => fb%f
|
||||
allocate(fb%f(size(temp)-1))
|
||||
do i = 1, size(temp)-1
|
||||
fb%f(i)%lun = temp(i+1)%lun
|
||||
fb%f(i)%xml_version = temp(i+1)%xml_version
|
||||
fb%f(i)%encoding => temp(i+1)%encoding
|
||||
fb%f(i)%filename => temp(i+1)%filename
|
||||
fb%f(i)%line = temp(i+1)%line
|
||||
fb%f(i)%col = temp(i+1)%col
|
||||
fb%f(i)%startChar = temp(i+1)%startChar
|
||||
fb%f(i)%next_chars => temp(i+1)%next_chars
|
||||
fb%f(i)%input_string => temp(i+1)%input_string
|
||||
fb%f(i)%baseURI => temp(i+1)%baseURI
|
||||
fb%f(i)%pe = temp(i+1)%pe
|
||||
enddo
|
||||
deallocate(temp)
|
||||
|
||||
end subroutine pop_buffer_stack
|
||||
|
||||
|
||||
subroutine push_chars(fb, s)
|
||||
type(file_buffer_t), intent(inout) :: fb
|
||||
character(len=*), intent(in) :: s
|
||||
|
||||
call push_file_chars(fb%f(1), s)
|
||||
|
||||
end subroutine push_chars
|
||||
|
||||
function get_character(fb, eof, es) result(string)
|
||||
type(file_buffer_t), intent(inout) :: fb
|
||||
logical, intent(out) :: eof
|
||||
type(error_stack), intent(inout) :: es
|
||||
character(len=1) :: string
|
||||
|
||||
type(xml_source_t), pointer :: f
|
||||
character, pointer :: temp(:)
|
||||
|
||||
f => fb%f(1)
|
||||
|
||||
if (size(f%next_chars)>0) then
|
||||
eof = .false.
|
||||
string = f%next_chars(1)
|
||||
if (size(f%next_chars)>1) then
|
||||
temp => vs_str_alloc(str_vs(f%next_chars(2:)))
|
||||
else
|
||||
temp => vs_str_alloc("")
|
||||
endif
|
||||
deallocate(f%next_chars)
|
||||
f%next_chars => temp
|
||||
else
|
||||
string = get_char_from_file(f, fb%xml_version, eof, es)
|
||||
endif
|
||||
|
||||
end function get_character
|
||||
|
||||
function get_all_characters(fb, es) result(s)
|
||||
type(file_buffer_t), intent(inout) :: fb
|
||||
type(error_stack), intent(inout) :: es
|
||||
character, pointer :: s(:)
|
||||
|
||||
logical :: eof
|
||||
character :: c
|
||||
character, pointer :: temp(:)
|
||||
|
||||
eof = .false.
|
||||
s => vs_str_alloc("")
|
||||
do while (.not.eof)
|
||||
c = get_character(fb, eof, es)
|
||||
if (eof.or.in_error(es)) return
|
||||
temp => vs_str_alloc(str_vs(s)//c)
|
||||
deallocate(s)
|
||||
s => temp
|
||||
enddo
|
||||
end function get_all_characters
|
||||
|
||||
function line(fb) result(n)
|
||||
type(file_buffer_t), intent(in) :: fb
|
||||
integer :: n
|
||||
|
||||
n = fb%f(1)%line
|
||||
end function line
|
||||
|
||||
function column(fb) result(n)
|
||||
type(file_buffer_t), intent(in) :: fb
|
||||
integer :: n
|
||||
|
||||
n = fb%f(1)%col
|
||||
end function column
|
||||
|
||||
subroutine parse_xml_declaration(fb, xv, enc, sa, es)
|
||||
type(file_buffer_t), intent(inout) :: fb
|
||||
integer, intent(out) :: xv
|
||||
character, pointer :: enc(:)
|
||||
logical, intent(out) :: sa
|
||||
type(error_stack), intent(inout) :: es
|
||||
|
||||
logical :: eof
|
||||
|
||||
call parse_declaration(fb%f(1), eof, es, sa)
|
||||
if (eof.or.in_error(es)) then
|
||||
call add_error(es, "Error parsing XML declaration")
|
||||
else
|
||||
fb%xml_version = fb%f(1)%xml_version
|
||||
xv = fb%xml_version
|
||||
enc => vs_vs_alloc(fb%f(1)%encoding)
|
||||
endif
|
||||
end subroutine parse_xml_declaration
|
||||
|
||||
subroutine parse_text_declaration(fb, es)
|
||||
type(file_buffer_t), intent(inout) :: fb
|
||||
type(error_stack), intent(inout) :: es
|
||||
|
||||
logical :: eof
|
||||
integer :: xv
|
||||
|
||||
xv = fb%f(size(fb%f))%xml_version
|
||||
|
||||
call parse_declaration(fb%f(1), eof, es)
|
||||
if (in_error(es)) then
|
||||
call add_error(es, "Error parsing text declaration")
|
||||
return
|
||||
elseif (xv==XML1_0.and.fb%f(1)%xml_version/=XML1_0) then
|
||||
call add_error(es, "XML 1.0 document cannot reference entities with higher version numbers")
|
||||
return
|
||||
endif
|
||||
|
||||
end subroutine parse_text_declaration
|
||||
|
||||
|
||||
function reading_main_file(fb) result(p)
|
||||
type(file_buffer_t), intent(in) :: fb
|
||||
logical :: p
|
||||
|
||||
p = (size(fb%f)==1)
|
||||
end function reading_main_file
|
||||
|
||||
function reading_first_entity(fb) result(p)
|
||||
type(file_buffer_t), intent(in) :: fb
|
||||
logical :: p
|
||||
|
||||
p = (size(fb%f)==2)
|
||||
end function reading_first_entity
|
||||
|
||||
subroutine add_error_position(stack, fb)
|
||||
type(error_stack), intent(inout) :: stack
|
||||
type(file_buffer_t), intent(in) :: fb
|
||||
call add_error(stack,"(Possibly near line="//line(fb)//" col="//column(fb)//")")
|
||||
end subroutine add_error_position
|
||||
|
||||
#endif
|
||||
|
||||
end module m_sax_reader
|
||||
File diff suppressed because it is too large
Load diff
|
|
@ -1,163 +0,0 @@
|
|||
module m_sax_types
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
use m_common_attrs, only: dictionary_t
|
||||
use m_common_elstack, only: elstack_t
|
||||
use m_common_entities, only: entity_list
|
||||
use m_common_error, only: error_stack
|
||||
use m_common_namespaces, only: namespacedictionary
|
||||
use m_common_notations, only: notation_list
|
||||
use m_common_struct, only: xml_doc_state
|
||||
|
||||
use fox_m_fsys_varstr, only: varstr
|
||||
|
||||
use m_sax_reader, only: file_buffer_t
|
||||
|
||||
implicit none
|
||||
|
||||
! Context
|
||||
|
||||
integer, parameter :: CTXT_NULL = -1
|
||||
integer, parameter :: CTXT_INIT = 0
|
||||
integer, parameter :: CTXT_BEFORE_DTD = 1
|
||||
integer, parameter :: CTXT_IN_DTD = 2
|
||||
integer, parameter :: CTXT_IGNORE = 3
|
||||
integer, parameter :: CTXT_BEFORE_CONTENT = 4
|
||||
integer, parameter :: CTXT_IN_CONTENT = 5
|
||||
integer, parameter :: CTXT_AFTER_CONTENT = 6
|
||||
|
||||
! State
|
||||
|
||||
integer, parameter :: ST_STOP = -1
|
||||
integer, parameter :: ST_NULL = 0
|
||||
integer, parameter :: ST_MISC = 1
|
||||
integer, parameter :: ST_BANG_TAG = 2
|
||||
integer, parameter :: ST_START_PI = 3
|
||||
integer, parameter :: ST_PI_CONTENTS = 4
|
||||
integer, parameter :: ST_PI_END = 5
|
||||
integer, parameter :: ST_START_COMMENT = 6
|
||||
integer, parameter :: ST_COMMENT_END = 7
|
||||
integer, parameter :: ST_START_TAG = 8
|
||||
integer, parameter :: ST_START_CDATA_DECLARATION = 9
|
||||
integer, parameter :: ST_FINISH_CDATA_DECLARATION = 10
|
||||
integer, parameter :: ST_IN_TAG = 11
|
||||
integer, parameter :: ST_ATT_NAME = 12
|
||||
integer, parameter :: ST_ATT_EQUALS = 13
|
||||
integer, parameter :: ST_CHAR_IN_CONTENT = 14
|
||||
integer, parameter :: ST_CLOSING_TAG = 15
|
||||
integer, parameter :: ST_CDATA_CONTENTS = 16
|
||||
integer, parameter :: ST_IN_CLOSING_TAG = 17
|
||||
integer, parameter :: ST_TAG_IN_CONTENT = 18
|
||||
integer, parameter :: ST_CDATA_END = 19
|
||||
integer, parameter :: ST_IN_DOCTYPE = 20
|
||||
integer, parameter :: ST_DOC_NAME = 21
|
||||
integer, parameter :: ST_DOC_SYSTEM = 22
|
||||
integer, parameter :: ST_DOC_PUBLIC = 23
|
||||
integer, parameter :: ST_DOC_DECL = 24
|
||||
integer, parameter :: ST_CLOSE_DOCTYPE = 25
|
||||
integer, parameter :: ST_START_ENTITY = 26
|
||||
integer, parameter :: ST_START_PE = 27
|
||||
integer, parameter :: ST_IN_SUBSET = 28
|
||||
|
||||
! DTD states
|
||||
integer, parameter :: ST_DTD_NULL = 50
|
||||
integer, parameter :: ST_DTD_SUBSET = 51
|
||||
integer, parameter :: ST_DTD_START_SECTION_DECL = 52
|
||||
integer, parameter :: ST_DTD_FINISH_SECTION_DECL = 53
|
||||
integer, parameter :: ST_DTD_IN_IGNORE_SECTION = 54
|
||||
integer, parameter :: ST_DTD_BANG_TAG = 55
|
||||
integer, parameter :: ST_DTD_START_PI = 56
|
||||
integer, parameter :: ST_DTD_PI_CONTENTS = 57
|
||||
integer, parameter :: ST_DTD_PI_END = 58
|
||||
integer, parameter :: ST_DTD_COMMENT_END = 59
|
||||
integer, parameter :: ST_DTD_START_COMMENT = 60
|
||||
integer, parameter :: ST_DTD_ATTLIST = 61
|
||||
integer, parameter :: ST_DTD_ELEMENT = 62
|
||||
integer, parameter :: ST_DTD_ENTITY = 63
|
||||
integer, parameter :: ST_DTD_NOTATION = 64
|
||||
integer, parameter :: ST_DTD_NOTATION_ID = 65
|
||||
integer, parameter :: ST_DTD_NOTATION_SYSTEM = 66
|
||||
integer, parameter :: ST_DTD_NOTATION_PUBLIC = 67
|
||||
integer, parameter :: ST_DTD_NOTATION_PUBLIC_2 = 68
|
||||
integer, parameter :: ST_DTD_NOTATION_END = 69
|
||||
integer, parameter :: ST_DTD_ENTITY_PE = 70
|
||||
integer, parameter :: ST_DTD_ENTITY_ID = 71
|
||||
integer, parameter :: ST_DTD_ENTITY_PUBLIC = 72
|
||||
integer, parameter :: ST_DTD_ENTITY_SYSTEM = 73
|
||||
integer, parameter :: ST_DTD_ENTITY_NDATA = 74
|
||||
integer, parameter :: ST_DTD_ENTITY_NDATA_VALUE = 75
|
||||
integer, parameter :: ST_DTD_ENTITY_END = 76
|
||||
integer, parameter :: ST_DTD_ATTLIST_CONTENTS = 77
|
||||
integer, parameter :: ST_DTD_ATTLIST_END = 78
|
||||
integer, parameter :: ST_DTD_ELEMENT_CONTENTS = 79
|
||||
integer, parameter :: ST_DTD_ELEMENT_END = 80
|
||||
integer, parameter :: ST_DTD_DONE = 81
|
||||
|
||||
! token types
|
||||
|
||||
integer, parameter :: TOK_NULL = 0
|
||||
integer, parameter :: TOK_PI_TAG = 1 ! <?
|
||||
integer, parameter :: TOK_BANG_TAG = 2 ! <!
|
||||
integer, parameter :: TOK_OPEN_TAG = 3 ! <
|
||||
integer, parameter :: TOK_OPEN_SB = 4 ! [
|
||||
integer, parameter :: TOK_CLOSE_SB = 5 ! [
|
||||
integer, parameter :: TOK_OPEN_COMMENT = 6 ! --
|
||||
integer, parameter :: TOK_NAME = 7 ! name (+token)
|
||||
integer, parameter :: TOK_CHAR = 8 ! character data (+token)
|
||||
integer, parameter :: TOK_PI_END = 9 ! ?>
|
||||
integer, parameter :: TOK_COMMENT_END = 10 ! -->
|
||||
integer, parameter :: TOK_SECTION_START = 11 ! <![
|
||||
integer, parameter :: TOK_SECTION_END = 12 ! ]]>
|
||||
integer, parameter :: TOK_END_TAG = 13 ! >
|
||||
integer, parameter :: TOK_END_TAG_CLOSE = 14 ! />
|
||||
integer, parameter :: TOK_CLOSE_TAG = 15 ! </
|
||||
integer, parameter :: TOK_ENTITY = 16 ! % or &
|
||||
integer, parameter :: TOK_EQUALS = 17 ! =
|
||||
integer, parameter :: TOK_DTD_CONTENTS = 18 ! for element and attlist
|
||||
integer, parameter :: TOK_OPEN_PAR = 19 ! (
|
||||
integer, parameter :: TOK_CLOSE_PAR = 20 ! )
|
||||
|
||||
type sax_parser_t
|
||||
type(xml_doc_state), pointer :: xds
|
||||
logical :: xds_used = .false. ! is the xds used by DOM? If so, we must
|
||||
! not destroy it once we are finished
|
||||
integer :: context
|
||||
integer :: state = ST_NULL
|
||||
integer :: state_dtd = ST_DTD_SUBSET
|
||||
logical :: well_formed = .false.
|
||||
logical :: skippedExternal = .false.
|
||||
type(varstr) :: token
|
||||
type(varstr) :: content
|
||||
integer :: tokenType = TOK_NULL
|
||||
integer :: nextTokenType = TOK_NULL
|
||||
type(varstr) :: name
|
||||
type(varstr) :: attname
|
||||
logical :: error = .false.
|
||||
type(error_stack) :: error_stack
|
||||
! Aspects of document structure
|
||||
type(varstr) :: root_element
|
||||
type(elstack_t) :: elstack
|
||||
type(dictionary_t) :: attributes
|
||||
type(namespacedictionary) :: nsdict
|
||||
type(notation_list) :: nlist
|
||||
type(entity_list) :: predefined_e_list
|
||||
type(entity_list) :: forbidden_pe_list
|
||||
type(entity_list) :: forbidden_ge_list
|
||||
type(varstr) :: PublicId
|
||||
type(varstr) :: SystemId
|
||||
type(varstr) :: Ndata
|
||||
logical :: inIntSubset = .false.
|
||||
logical :: spaceBeforeEntity = .false.
|
||||
end type sax_parser_t
|
||||
#endif
|
||||
|
||||
type xml_t
|
||||
#ifndef DUMMYLIB
|
||||
type(file_buffer_t) :: fb
|
||||
type(sax_parser_t) :: fx
|
||||
#else
|
||||
integer :: i = 0
|
||||
#endif
|
||||
end type xml_t
|
||||
|
||||
end module m_sax_types
|
||||
|
|
@ -1,438 +0,0 @@
|
|||
module m_sax_xml_source
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
use fox_m_fsys_array_str, only: str_vs, vs_str_alloc
|
||||
use fox_m_fsys_format, only: operator(//)
|
||||
use m_common_error, only: error_stack, add_error, in_error
|
||||
use m_common_charset, only: XML_WHITESPACE, XML_INITIALENCODINGCHARS, &
|
||||
XML_ENCODINGCHARS, XML1_0, XML1_1, isXML1_0_NameChar, &
|
||||
isLegalChar, isUSASCII, allowed_encoding
|
||||
use m_common_io, only: io_eor, io_eof
|
||||
|
||||
use FoX_utils, only: URI
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
type buffer_t
|
||||
character, dimension(:), pointer :: s
|
||||
integer :: pos = 1
|
||||
end type buffer_t
|
||||
|
||||
type xml_source_t
|
||||
!FIXME private
|
||||
integer :: lun = -1
|
||||
integer :: xml_version = XML1_0
|
||||
character, pointer :: encoding(:) => null()
|
||||
logical :: isUSASCII
|
||||
character, pointer :: filename(:) => null()
|
||||
type(URI), pointer :: baseURI => null()
|
||||
integer :: line = 0
|
||||
integer :: col = 0
|
||||
integer :: startChar = 1 ! First character after XML decl
|
||||
character, pointer :: next_chars(:) => null() ! pushback buffer
|
||||
type(buffer_t), pointer :: input_string => null()
|
||||
logical :: pe = .false. ! is this a parameter entity?
|
||||
logical :: eof = .false.! need to keep track of this at the end of pes
|
||||
end type xml_source_t
|
||||
|
||||
public :: buffer_t
|
||||
public :: xml_source_t
|
||||
|
||||
public :: get_char_from_file
|
||||
public :: push_file_chars
|
||||
public :: parse_declaration
|
||||
|
||||
contains
|
||||
|
||||
|
||||
function get_char_from_file(f, xv, eof, es) result(string)
|
||||
type(xml_source_t), intent(inout) :: f
|
||||
integer, intent(in) :: xv
|
||||
logical, intent(out) :: eof
|
||||
type(error_stack), intent(inout) :: es
|
||||
character(len=1) :: string
|
||||
|
||||
integer :: iostat
|
||||
logical :: pending
|
||||
character :: c, c2
|
||||
|
||||
pending = .false.
|
||||
eof = .false.
|
||||
c = read_single_char(f, iostat)
|
||||
if (iostat==io_eof) then
|
||||
eof = .true.
|
||||
return
|
||||
elseif (iostat/=0) then
|
||||
call add_error(es, "Error reading "//str_vs(f%filename))
|
||||
return
|
||||
endif
|
||||
if (.not.isLegalChar(c, f%isUSASCII, xv)) then
|
||||
call add_error(es, "Illegal character found at " &
|
||||
//str_vs(f%filename)//":"//f%line//":"//f%col)
|
||||
return
|
||||
endif
|
||||
if (c==achar(13)) then
|
||||
c = achar(10)
|
||||
c2 = read_single_char(f, iostat)
|
||||
if (iostat==io_eof) then
|
||||
! the file has just ended on a single CR. Report is as a LF.
|
||||
! Ignore the eof just now, it'll be picked up if we need to
|
||||
! perform another read.
|
||||
eof = .false.
|
||||
elseif (iostat/=0) then
|
||||
call add_error(es, "Error reading "//str_vs(f%filename))
|
||||
return
|
||||
elseif (c2/=achar(10)) then
|
||||
! then we keep c2, otherwise we'd just ignore it.
|
||||
pending = .true.
|
||||
endif
|
||||
endif
|
||||
string = c
|
||||
|
||||
if (pending) then
|
||||
! we have one character left over, put in the pushback buffer
|
||||
deallocate(f%next_chars)
|
||||
allocate(f%next_chars(1))
|
||||
f%next_chars = c2
|
||||
endif
|
||||
|
||||
if (c==achar(10)) then
|
||||
f%line = f%line + 1
|
||||
f%col = 0
|
||||
else
|
||||
f%col = f%col + 1
|
||||
endif
|
||||
|
||||
end function get_char_from_file
|
||||
|
||||
function read_single_char(f, iostat) result(c)
|
||||
type(xml_source_t), intent(inout) :: f
|
||||
integer, intent(out) :: iostat
|
||||
character :: c
|
||||
|
||||
if (f%eof) then
|
||||
c = ""
|
||||
iostat = io_eof
|
||||
return
|
||||
endif
|
||||
if (f%lun==-1) then
|
||||
if (f%input_string%pos>size(f%input_string%s)) then
|
||||
c = ""
|
||||
if (f%pe) then
|
||||
iostat = 0
|
||||
else
|
||||
iostat = io_eof
|
||||
endif
|
||||
f%eof = .true.
|
||||
else
|
||||
iostat = 0
|
||||
c = f%input_string%s(f%input_string%pos)
|
||||
f%input_string%pos = f%input_string%pos + 1
|
||||
endif
|
||||
else
|
||||
read (unit=f%lun, iostat=iostat, advance="no", fmt="(a1)") c
|
||||
if (iostat==io_eor) then
|
||||
iostat = 0
|
||||
#ifdef FC_EOR_LF
|
||||
c = achar(10)
|
||||
#else
|
||||
c = achar(13)
|
||||
#endif
|
||||
elseif (iostat==io_eof) then
|
||||
if (f%pe) iostat = 0
|
||||
c = ""
|
||||
f%eof = .true.
|
||||
endif
|
||||
endif
|
||||
end function read_single_char
|
||||
|
||||
subroutine rewind_source(f)
|
||||
type(xml_source_t), intent(inout) :: f
|
||||
|
||||
if (f%lun==-1) then
|
||||
f%input_string%pos = 1
|
||||
else
|
||||
rewind(f%lun)
|
||||
endif
|
||||
end subroutine rewind_source
|
||||
|
||||
subroutine push_file_chars(f, s)
|
||||
type(xml_source_t), intent(inout) :: f
|
||||
character(len=*), intent(in) :: s
|
||||
character, dimension(:), pointer :: nc
|
||||
|
||||
nc => vs_str_alloc(s//str_vs(f%next_chars))
|
||||
deallocate(f%next_chars)
|
||||
f%next_chars => nc
|
||||
|
||||
end subroutine push_file_chars
|
||||
|
||||
|
||||
subroutine parse_declaration(f, eof, es, standalone)
|
||||
type(xml_source_t), intent(inout) :: f
|
||||
logical, intent(out) :: eof
|
||||
type(error_stack), intent(inout) :: es
|
||||
logical, intent(out), optional :: standalone
|
||||
|
||||
integer :: parse_state, xd_par
|
||||
character :: c, q
|
||||
character, pointer :: ch(:), ch2(:)
|
||||
|
||||
integer, parameter :: XD_0 = 0
|
||||
integer, parameter :: XD_START = 1
|
||||
integer, parameter :: XD_TARGET = 2
|
||||
integer, parameter :: XD_MISC = 3
|
||||
integer, parameter :: XD_PA = 4
|
||||
integer, parameter :: XD_EQ = 5
|
||||
integer, parameter :: XD_QUOTE = 6
|
||||
integer, parameter :: XD_PV = 7
|
||||
integer, parameter :: XD_END = 8
|
||||
integer, parameter :: XD_SPACE = 9
|
||||
|
||||
integer, parameter :: xd_nothing = 0
|
||||
integer, parameter :: xd_version = 1
|
||||
integer, parameter :: xd_encoding = 2
|
||||
integer, parameter :: xd_standalone = 3
|
||||
|
||||
f%xml_version = XML1_0
|
||||
if (present(standalone)) standalone = .false.
|
||||
|
||||
f%startChar = 1
|
||||
|
||||
parse_state = XD_0
|
||||
xd_par = xd_nothing
|
||||
ch => null()
|
||||
do
|
||||
c = get_char_from_file(f, XML1_0, eof, es)
|
||||
if (eof) then
|
||||
call rewind_source(f)
|
||||
exit
|
||||
elseif (in_error(es)) then
|
||||
goto 100
|
||||
endif
|
||||
f%startChar = f%startChar + 1
|
||||
|
||||
select case (parse_state)
|
||||
|
||||
case (XD_0)
|
||||
if (c=="<") then
|
||||
parse_state = XD_START
|
||||
else
|
||||
call rewind_source(f)
|
||||
exit
|
||||
endif
|
||||
|
||||
case (XD_START)
|
||||
if (c=="?") then
|
||||
parse_state = XD_TARGET
|
||||
ch => vs_str_alloc("")
|
||||
else
|
||||
call rewind_source(f)
|
||||
exit
|
||||
endif
|
||||
|
||||
case (XD_TARGET)
|
||||
if (isXML1_0_NameChar(c)) then
|
||||
ch2 => vs_str_alloc(str_vs(ch)//c)
|
||||
deallocate(ch)
|
||||
ch => ch2
|
||||
elseif (verify(c, XML_WHITESPACE)==0 &
|
||||
.and.str_vs(ch)=="xml") then
|
||||
deallocate(ch)
|
||||
parse_state = XD_MISC
|
||||
else
|
||||
call rewind_source(f)
|
||||
deallocate(ch)
|
||||
exit
|
||||
endif
|
||||
|
||||
case (XD_SPACE)
|
||||
if (verify(c, XML_WHITESPACE)==0) then
|
||||
parse_state = XD_MISC
|
||||
elseif (c=="?") then
|
||||
parse_state = XD_END
|
||||
else
|
||||
call add_error(es, &
|
||||
"Missing space in XML declaration")
|
||||
endif
|
||||
|
||||
case (XD_MISC)
|
||||
if (c=="?") then
|
||||
parse_state = XD_END
|
||||
elseif (isXML1_0_NameChar(c)) then
|
||||
ch => vs_str_alloc(c)
|
||||
parse_state = XD_PA
|
||||
elseif (verify(c, XML_WHITESPACE)>0) then
|
||||
call add_error(es, &
|
||||
"Unexpected character in XML declaration")
|
||||
endif
|
||||
|
||||
case (XD_PA)
|
||||
if (isXML1_0_NameChar(c)) then
|
||||
ch2 => vs_str_alloc(str_vs(ch)//c)
|
||||
deallocate(ch)
|
||||
ch => ch2
|
||||
elseif (verify(c, XML_WHITESPACE//"=")==0) then
|
||||
select case (str_vs(ch))
|
||||
|
||||
case ("version")
|
||||
select case (xd_par)
|
||||
case (xd_nothing)
|
||||
xd_par = xd_version
|
||||
case default
|
||||
call add_error(es, &
|
||||
"Cannot specify version twice in XML declaration")
|
||||
end select
|
||||
|
||||
case ("encoding")
|
||||
select case (xd_par)
|
||||
case (xd_nothing)
|
||||
if (present(standalone)) then
|
||||
call add_error(es, &
|
||||
"Must specify version before encoding in XML declaration")
|
||||
else
|
||||
xd_par = xd_encoding
|
||||
endif
|
||||
case (xd_version)
|
||||
xd_par = xd_encoding
|
||||
case (xd_encoding)
|
||||
call add_error(es, &
|
||||
"Cannot specify encoding twice in XML declaration")
|
||||
case (xd_standalone)
|
||||
call add_error(es, &
|
||||
"Cannot specify encoding after standalone in XML declaration")
|
||||
end select
|
||||
|
||||
case ("standalone")
|
||||
if (.not.present(standalone)) &
|
||||
call add_error(es, &
|
||||
"Cannot specify standalone in text declaration")
|
||||
select case (xd_par)
|
||||
case (xd_nothing)
|
||||
call add_error(es, &
|
||||
"Must specify version before standalone in XML declaration")
|
||||
case (xd_version, xd_encoding)
|
||||
xd_par = xd_standalone
|
||||
case (xd_standalone)
|
||||
call add_error(es, &
|
||||
"Cannot specify standalone twice in XML declaration")
|
||||
end select
|
||||
|
||||
case default
|
||||
call add_error(es, &
|
||||
"Unknown parameter "//str_vs(ch)//" in XML declaration, "//&
|
||||
"expecting version, encoding or standalone")
|
||||
|
||||
end select
|
||||
|
||||
deallocate(ch)
|
||||
if (c=="=") then
|
||||
parse_state = XD_QUOTE
|
||||
else
|
||||
parse_state = XD_EQ
|
||||
endif
|
||||
else
|
||||
call add_error(es, &
|
||||
"Unexpected character found in XML declaration")
|
||||
endif
|
||||
|
||||
case (XD_EQ)
|
||||
if (c=="=") then
|
||||
parse_state = XD_QUOTE
|
||||
elseif (verify(c, XML_WHITESPACE)>0) then
|
||||
call add_error(es, &
|
||||
"Unexpected character found in XML declaration; expecting ""=""")
|
||||
endif
|
||||
|
||||
case (XD_QUOTE)
|
||||
if (verify(c, "'""")==0) then
|
||||
q = c
|
||||
parse_state = XD_PV
|
||||
ch => vs_str_alloc("")
|
||||
elseif (verify(c, XML_WHITESPACE)>0) then
|
||||
call add_error(es, &
|
||||
"Unexpected character found in XML declaration; expecting "" or '")
|
||||
endif
|
||||
|
||||
case (XD_PV)
|
||||
if (c==q) then
|
||||
select case (xd_par)
|
||||
case (xd_version)
|
||||
if (str_vs(ch)//"x"=="1.0x") then
|
||||
f%xml_version = XML1_0
|
||||
deallocate(ch)
|
||||
elseif (str_vs(ch)//"x"=="1.1x") then
|
||||
f%xml_version = XML1_1
|
||||
deallocate(ch)
|
||||
else
|
||||
call add_error(es, &
|
||||
"Unknown version number "//str_vs(ch)//" found in XML declaration; expecting 1.0 or 1.1")
|
||||
endif
|
||||
case (xd_encoding)
|
||||
if (size(ch)==0) then
|
||||
call add_error(es, &
|
||||
"Empty value for encoding not allowed in XML declaration")
|
||||
elseif (size(ch)==1.and.verify(ch(1), XML_INITIALENCODINGCHARS)>0) then
|
||||
call add_error(es, &
|
||||
"Invalid encoding found in XML declaration; illegal characters in encoding name")
|
||||
elseif (size(ch)>1.and. &
|
||||
(verify(ch(1), XML_INITIALENCODINGCHARS)>0 &
|
||||
.or.verify(str_vs(ch(2:)), XML_ENCODINGCHARS)>0)) then
|
||||
call add_error(es, &
|
||||
"Invalid encoding found in XML declaration; illegal characters in encoding name")
|
||||
elseif (.not.allowed_encoding(str_vs(ch))) then
|
||||
call add_error(es, "Unknown character encoding in XML declaration")
|
||||
else
|
||||
f%encoding => ch
|
||||
f%isUSASCII = isUSASCII(str_vs(ch))
|
||||
ch => null()
|
||||
endif
|
||||
case (xd_standalone)
|
||||
if (str_vs(ch)//"x"=="yesx") then
|
||||
standalone = .true.
|
||||
deallocate(ch)
|
||||
elseif (str_vs(ch)//"x"=="nox") then
|
||||
standalone = .false.
|
||||
deallocate(ch)
|
||||
else
|
||||
call add_error(es, &
|
||||
"Invalid value for standalone found in XML declaration; expecting yes or no")
|
||||
|
||||
endif
|
||||
end select
|
||||
parse_state = XD_SPACE
|
||||
else
|
||||
ch2 => vs_str_alloc(str_vs(ch)//c)
|
||||
deallocate(ch)
|
||||
ch => ch2
|
||||
endif
|
||||
|
||||
case (XD_END)
|
||||
if (c==">") then
|
||||
exit
|
||||
else
|
||||
call add_error(es, &
|
||||
"Unexpected character found in XML declaration; expecting >")
|
||||
endif
|
||||
|
||||
end select
|
||||
|
||||
end do
|
||||
|
||||
if (.not.associated(f%encoding)) then
|
||||
if (present(standalone).or.parse_state/=XD_END) then
|
||||
f%encoding => vs_str_alloc("utf-8")
|
||||
else
|
||||
call add_error(es, "Missing encoding in text declaration")
|
||||
endif
|
||||
endif
|
||||
|
||||
100 if (associated(ch)) deallocate(ch)
|
||||
! if there is no XML declaraion, or if parsing caused an error, then
|
||||
if (parse_state/=XD_END.or.in_error(es)) f%startChar = 1
|
||||
|
||||
end subroutine parse_declaration
|
||||
#endif
|
||||
|
||||
end module m_sax_xml_source
|
||||
|
|
@ -1,22 +0,0 @@
|
|||
module FoX_utils
|
||||
|
||||
use fox_m_utils_uuid
|
||||
use fox_m_utils_uri
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
public :: generate_uuid
|
||||
|
||||
public :: URI
|
||||
public :: parseURI
|
||||
public :: rebaseURI
|
||||
public :: copyURI
|
||||
public :: destroyURI
|
||||
public :: expressURI
|
||||
public :: hasFragment
|
||||
public :: hasScheme
|
||||
public :: getScheme
|
||||
public :: getPath
|
||||
|
||||
end module FoX_utils
|
||||
|
|
@ -1,46 +0,0 @@
|
|||
source = $(wildcard *.F90)
|
||||
objects = $(source:.F90=.o)
|
||||
|
||||
#===============================================================================
|
||||
# Compiler Options
|
||||
#===============================================================================
|
||||
|
||||
# Ignore unusd variables
|
||||
|
||||
ifeq ($(MACHINE),bluegene)
|
||||
override F90 = xlf2003
|
||||
endif
|
||||
|
||||
ifeq ($(F90),ifort)
|
||||
override F90FLAGS += -warn nounused
|
||||
endif
|
||||
|
||||
#===============================================================================
|
||||
# Targets
|
||||
#===============================================================================
|
||||
|
||||
all: $(objects)
|
||||
mv *.mod ../include
|
||||
mv *.o ../lib
|
||||
clean:
|
||||
@rm -f *.o *.mod
|
||||
neat:
|
||||
@rm -f *.o *.mod
|
||||
|
||||
#===============================================================================
|
||||
# Rules
|
||||
#===============================================================================
|
||||
|
||||
.SUFFIXES: .F90 .o
|
||||
|
||||
.PHONY: clean neat
|
||||
|
||||
%.o: %.F90
|
||||
$(F90) $(F90FLAGS) -c -I../include $<
|
||||
|
||||
#===============================================================================
|
||||
# Dependencies
|
||||
#===============================================================================
|
||||
|
||||
FoX_utils.o: fox_m_utils_uuid.o fox_m_utils_uri.o
|
||||
fox_m_utils_uuid.o: fox_m_utils_mtprng.o
|
||||
|
|
@ -1,360 +0,0 @@
|
|||
module fox_m_utils_mtprng
|
||||
#ifndef DUMMYLIB
|
||||
!---------------------------------------------------------------------
|
||||
! From the Algorithmic Conjurings of Scott Robert Ladd comes...
|
||||
!---------------------------------------------------------------------
|
||||
!
|
||||
! mtprng.f90 (a Fortran 95 module)
|
||||
!
|
||||
! An implementation of the Mersenne Twister algorithm for generating
|
||||
! psuedo-random sequences.
|
||||
!
|
||||
! History
|
||||
! -------
|
||||
! 1.0.0 Initial release
|
||||
!
|
||||
! 1.1.0 6 February 2002
|
||||
! Updated to support algorithm revisions posted
|
||||
! by Matsumoto and Nishimura on 26 January 2002
|
||||
!
|
||||
! 1.5.0 12 December 2003
|
||||
! Added to hypatia project
|
||||
! Minor style changes
|
||||
! Tightened code
|
||||
! Now state based; no static variables
|
||||
! Removed mtprng_rand_real53
|
||||
!
|
||||
! 2.0.0 4 January 2004
|
||||
! Corrected erroneous unsigned bit manipulations
|
||||
! Doubled resolution by using 64-bit math
|
||||
! Added mtprng_rand64
|
||||
|
||||
! Version for distribution with FoX <http://uszla.me.uk/FoX>
|
||||
! Very small cosmetic changes to fit FoX naming scheme and
|
||||
! avoid additional dependencies.
|
||||
! Toby White <tow@uszla.me.uk>, 2007
|
||||
|
||||
!
|
||||
! ORIGINAL ALGORITHM COPYRIGHT
|
||||
! ============================
|
||||
! Copyright (C) 1997,2002 Makoto Matsumoto and Takuji Nishimura.
|
||||
! Any feedback is very welcome. For any question, comments, see
|
||||
! http://www.math.keio.ac.jp/matumoto/emt.html or email
|
||||
! matumoto@math.keio.ac.jp
|
||||
!---------------------------------------------------------------------
|
||||
!
|
||||
! COPYRIGHT NOTICE, DISCLAIMER, and LICENSE:
|
||||
!
|
||||
! This notice applies *only* to this specific expression of this
|
||||
! algorithm, and does not imply ownership or invention of the
|
||||
! implemented algorithm.
|
||||
!
|
||||
! If you modify this file, you may insert additional notices
|
||||
! immediately following this sentence.
|
||||
!
|
||||
! Copyright 2001, 2002, 2004 Scott Robert Ladd.
|
||||
! All rights reserved, except as noted herein.
|
||||
!
|
||||
! This computer program source file is supplied "AS IS". Scott Robert
|
||||
! Ladd (hereinafter referred to as "Author") disclaims all warranties,
|
||||
! expressed or implied, including, without limitation, the warranties
|
||||
! of merchantability and of fitness for any purpose. The Author
|
||||
! assumes no liability for direct, indirect, incidental, special,
|
||||
! exemplary, or consequential damages, which may result from the use
|
||||
! of this software, even if advised of the possibility of such damage.
|
||||
!
|
||||
! The Author hereby grants anyone permission to use, copy, modify, and
|
||||
! distribute this source code, or portions hereof, for any purpose,
|
||||
! without fee, subject to the following restrictions:
|
||||
!
|
||||
! 1. The origin of this source code must not be misrepresented.
|
||||
!
|
||||
! 2. Altered versions must be plainly marked as such and must not
|
||||
! be misrepresented as being the original source.
|
||||
!
|
||||
! 3. This Copyright notice may not be removed or altered from any
|
||||
! source or altered source distribution.
|
||||
!
|
||||
! The Author specifically permits (without fee) and encourages the use
|
||||
! of this source code for entertainment, education, or decoration. If
|
||||
! you use this source code in a product, acknowledgment is not required
|
||||
! but would be appreciated.
|
||||
!
|
||||
! Acknowledgement:
|
||||
! This license is based on the wonderful simple license that
|
||||
! accompanies libpng.
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! For more information on this software package, please visit
|
||||
! Scott's web site, Coyote Gulch Productions, at:
|
||||
!
|
||||
! http://www.coyotegulch.com
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
|
||||
implicit none
|
||||
|
||||
! Kind types for 64-, 32-, 16-, and 8-bit signed integers
|
||||
integer, parameter :: INT64 = selected_int_kind(18)
|
||||
integer, parameter :: INT32 = selected_int_kind(9)
|
||||
integer, parameter :: INT16 = selected_int_kind(4)
|
||||
integer, parameter :: INT08 = selected_int_kind(2)
|
||||
|
||||
! Kind types for IEEE 754/IEC 60559 single- and double-precision reals
|
||||
integer, parameter :: IEEE32 = selected_real_kind( 6, 37 )
|
||||
integer, parameter :: IEEE64 = selected_real_kind( 15, 307 )
|
||||
|
||||
!------------------------------------------------------------------------------
|
||||
! Everything is private unless explicitly made public
|
||||
private
|
||||
|
||||
public :: mtprng_state, &
|
||||
mtprng_init, mtprng_init_by_array, &
|
||||
mtprng_rand64, mtprng_rand, mtprng_rand_range, &
|
||||
mtprng_rand_real1, mtprng_rand_real2, mtprng_rand_real3
|
||||
|
||||
!------------------------------------------------------------------------------
|
||||
! Constants
|
||||
integer(INT32), parameter :: N = 624_INT32
|
||||
integer(INT32), parameter :: M = 397_INT32
|
||||
|
||||
!------------------------------------------------------------------------------
|
||||
! types
|
||||
type mtprng_state
|
||||
integer(INT32) :: mti = -1
|
||||
integer(INT64), dimension(0:N-1) :: mt
|
||||
end type
|
||||
|
||||
contains
|
||||
!--------------------------------------------------------------------------
|
||||
! Initializes the generator with "seed"
|
||||
subroutine mtprng_init(seed, state)
|
||||
|
||||
! arguments
|
||||
integer(INT32), intent(in) :: seed
|
||||
type(mtprng_state), intent(out) :: state
|
||||
|
||||
! working storage
|
||||
integer :: i
|
||||
|
||||
! save seed
|
||||
state%mt(0) = seed
|
||||
|
||||
! Set the seed using values suggested by Matsumoto & Nishimura, using
|
||||
! a generator by Knuth. See original source for details.
|
||||
do i = 1, N - 1
|
||||
state%mt(i) = iand(4294967295_INT64,1812433253_INT64 * ieor(state%mt(i-1),ishft(state%mt(i-1),-30_INT64)) + i)
|
||||
end do
|
||||
|
||||
state%mti = N
|
||||
|
||||
end subroutine mtprng_init
|
||||
|
||||
!--------------------------------------------------------------------------
|
||||
! Initialize with an array of seeds
|
||||
subroutine mtprng_init_by_array(init_key, state)
|
||||
|
||||
! arguments
|
||||
integer(INT32), dimension(:), intent(in) :: init_key
|
||||
type(mtprng_state), intent(out) :: state
|
||||
|
||||
! working storage
|
||||
integer :: key_length
|
||||
integer :: i
|
||||
integer :: j
|
||||
integer :: k
|
||||
|
||||
call mtprng_init(19650218_INT32,state)
|
||||
|
||||
i = 1
|
||||
j = 0
|
||||
key_length = size(init_key)
|
||||
|
||||
do k = max(N,key_length), 0, -1
|
||||
state%mt(i) = ieor(state%mt(i),(ieor(state%mt(i-1),ishft(state%mt(i-1),-30_INT64) * 1664525_INT64))) + init_key(j) + j
|
||||
|
||||
i = i + 1
|
||||
j = j + 1
|
||||
|
||||
if (i >= N) then
|
||||
state%mt(0) = state%mt(N-1)
|
||||
i = 1
|
||||
end if
|
||||
|
||||
if (j >= key_length) j = 0
|
||||
end do
|
||||
|
||||
do k = N-1, 0, -1
|
||||
state%mt(i) = ieor(state%mt(i),(ieor(state%mt(i-1),ishft(state%mt(i-1),-30_INT64) * 1566083941_INT64))) - i
|
||||
|
||||
i = i + 1
|
||||
|
||||
if (i>=N) then
|
||||
state%mt(0) = state%mt(N-1)
|
||||
i = 1
|
||||
end if
|
||||
end do
|
||||
|
||||
state%mt(0) = 1073741824_INT64 ! 0x40000000, assuring non-zero initial array
|
||||
|
||||
end subroutine mtprng_init_by_array
|
||||
|
||||
!--------------------------------------------------------------------------
|
||||
! Obtain the next 32-bit integer in the psuedo-random sequence
|
||||
function mtprng_rand64(state) result(r)
|
||||
|
||||
! arguments
|
||||
type(mtprng_state), intent(inout) :: state
|
||||
|
||||
!return type
|
||||
integer(INT64) :: r
|
||||
|
||||
! internal constants
|
||||
integer(INT64), dimension(0:1), parameter :: mag01 = (/ 0_INT64, -1727483681_INT64 /)
|
||||
|
||||
! Period parameters
|
||||
integer(INT64), parameter :: UPPER_MASK = 2147483648_INT64
|
||||
integer(INT64), parameter :: LOWER_MASK = 2147483647_INT64
|
||||
|
||||
! Tempering parameters
|
||||
integer(INT64), parameter :: TEMPERING_B = -1658038656_INT64
|
||||
integer(INT64), parameter :: TEMPERING_C = -272236544_INT64
|
||||
|
||||
! Note: variable names match those in original example
|
||||
integer(INT32) :: kk
|
||||
|
||||
! Generate N words at a time
|
||||
if (state%mti >= N) then
|
||||
! The value -1 acts as a flag saying that the seed has not been set.
|
||||
if (state%mti == -1) call mtprng_init(4357_INT32,state)
|
||||
|
||||
! Fill the mt array
|
||||
do kk = 0, N - M - 1
|
||||
r = ior(iand(state%mt(kk),UPPER_MASK),iand(state%mt(kk+1),LOWER_MASK))
|
||||
state%mt(kk) = ieor(ieor(state%mt(kk + M),ishft(r,-1_INT64)),mag01(iand(r,1_INT64)))
|
||||
end do
|
||||
|
||||
do kk = N - M, N - 2
|
||||
r = ior(iand(state%mt(kk),UPPER_MASK),iand(state%mt(kk+1),LOWER_MASK))
|
||||
state%mt(kk) = ieor(ieor(state%mt(kk + (M - N)),ishft(r,-1_INT64)),mag01(iand(r,1_INT64)))
|
||||
end do
|
||||
|
||||
r = ior(iand(state%mt(N-1),UPPER_MASK),iand(state%mt(0),LOWER_MASK))
|
||||
state%mt(N-1) = ieor(ieor(state%mt(M-1),ishft(r,-1)),mag01(iand(r,1_INT64)))
|
||||
|
||||
! Start using the array from first element
|
||||
state%mti = 0
|
||||
end if
|
||||
|
||||
! Here is where we actually calculate the number with a series of
|
||||
! transformations
|
||||
r = state%mt(state%mti)
|
||||
state%mti = state%mti + 1
|
||||
|
||||
r = ieor(r,ishft(r,-11))
|
||||
r = iand(4294967295_INT64,ieor(r,iand(ishft(r, 7),TEMPERING_B)))
|
||||
r = iand(4294967295_INT64,ieor(r,iand(ishft(r,15),TEMPERING_C)))
|
||||
r = ieor(r,ishft(r,-18))
|
||||
|
||||
end function mtprng_rand64
|
||||
|
||||
!--------------------------------------------------------------------------
|
||||
! Obtain the next 32-bit integer in the psuedo-random sequence
|
||||
function mtprng_rand(state) result(r)
|
||||
|
||||
! arguments
|
||||
type(mtprng_state), intent(inout) :: state
|
||||
|
||||
!return type
|
||||
integer(INT32) :: r
|
||||
|
||||
! working storage
|
||||
integer(INT64) :: x
|
||||
|
||||
! done
|
||||
x = mtprng_rand64(state)
|
||||
|
||||
if (x > 2147483647_INT64) then
|
||||
r = x - 4294967296_INT64
|
||||
else
|
||||
r = x
|
||||
end if
|
||||
|
||||
end function mtprng_rand
|
||||
|
||||
!---------------------------------------------------------------------------
|
||||
! Obtain a psuedorandom integer in the range [lo,hi]
|
||||
function mtprng_rand_range(state, lo, hi) result(r)
|
||||
|
||||
! arguments
|
||||
type(mtprng_state), intent(inout) :: state
|
||||
integer, intent(in) :: lo
|
||||
integer, intent(in) :: hi
|
||||
|
||||
! return type
|
||||
integer(INT32) :: r
|
||||
|
||||
! Use real value to caluclate range
|
||||
r = lo + floor((hi - lo + 1.0_IEEE64) * mtprng_rand_real2(state))
|
||||
|
||||
end function mtprng_rand_range
|
||||
|
||||
!--------------------------------------------------------------------------
|
||||
! Obtain a psuedorandom real number in the range [0,1], i.e., a number
|
||||
! greater than or equal to 0 and less than or equal to 1.
|
||||
function mtprng_rand_real1(state) result(r)
|
||||
|
||||
! arguments
|
||||
type(mtprng_state), intent(inout) :: state
|
||||
|
||||
! return type
|
||||
real(IEEE64) :: r
|
||||
|
||||
! Local constant; precalculated to avoid division below
|
||||
real(IEEE64), parameter :: factor = 1.0_IEEE64 / 4294967295.0_IEEE64
|
||||
|
||||
! compute
|
||||
r = real(mtprng_rand64(state),IEEE64) * factor
|
||||
|
||||
end function mtprng_rand_real1
|
||||
|
||||
!--------------------------------------------------------------------------
|
||||
! Obtain a psuedorandom real number in the range [0,1), i.e., a number
|
||||
! greater than or equal to 0 and less than 1.
|
||||
function mtprng_rand_real2(state) result(r)
|
||||
|
||||
! arguments
|
||||
type(mtprng_state), intent(inout) :: state
|
||||
|
||||
! return type
|
||||
real(IEEE64) :: r
|
||||
|
||||
! Local constant; precalculated to avoid division below
|
||||
real(IEEE64), parameter :: factor = 1.0_IEEE64 / 4294967296.0_IEEE64
|
||||
|
||||
! compute
|
||||
r = real(mtprng_rand64(state),IEEE64) * factor
|
||||
|
||||
end function mtprng_rand_real2
|
||||
|
||||
!--------------------------------------------------------------------------
|
||||
! Obtain a psuedorandom real number in the range (0,1), i.e., a number
|
||||
! greater than 0 and less than 1.
|
||||
function mtprng_rand_real3(state) result(r)
|
||||
|
||||
! arguments
|
||||
type(mtprng_state), intent(inout) :: state
|
||||
|
||||
! return type
|
||||
real(IEEE64) :: r
|
||||
|
||||
! Local constant; precalculated to avoid division below
|
||||
real(IEEE64), parameter :: factor = 1.0_IEEE64 / 4294967296.0_IEEE64
|
||||
|
||||
r = (real(mtprng_rand64(state),IEEE64) + 0.5_IEEE64) * factor
|
||||
|
||||
end function mtprng_rand_real3
|
||||
|
||||
#endif
|
||||
end module fox_m_utils_mtprng
|
||||
File diff suppressed because it is too large
Load diff
|
|
@ -1,247 +0,0 @@
|
|||
module fox_m_utils_uuid
|
||||
|
||||
!This generates UUIDs according to RFC 4122
|
||||
|
||||
! Only types 1 (time-based) and 4 (pseudo-RNG-based) are implemented.
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
use fox_m_utils_mtprng, only : mtprng_state, mtprng_init, mtprng_rand64
|
||||
#endif
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
integer, parameter :: i4b = selected_int_kind(9)
|
||||
integer, parameter :: i8b = selected_int_kind(18)
|
||||
|
||||
character, parameter :: hexdigits(0:15) = &
|
||||
(/'0','1','2','3','4','5','6','7','8','9','a','b','c','d','e','f'/)
|
||||
|
||||
type(mtprng_state), save :: rng_state
|
||||
logical, save :: initialized = .false.
|
||||
integer, save :: values_save ! must be default for date_and_time
|
||||
integer(kind=i4b), save :: hires_count = 0
|
||||
|
||||
! clock-seq holds a random number constant for the lifetime of the program
|
||||
! using this module. That's the best we can do per S 4.1.5
|
||||
integer, save :: clock_seq = 0
|
||||
|
||||
#endif
|
||||
|
||||
public :: generate_uuid
|
||||
|
||||
contains
|
||||
|
||||
function generate_uuid(version) result(uuid)
|
||||
integer, intent(in), optional :: version
|
||||
character(len=36) :: uuid
|
||||
|
||||
#ifdef DUMMYLIB
|
||||
uuid = ""
|
||||
#else
|
||||
integer(kind=i8b) :: timestamp, node
|
||||
integer(kind=i4b) :: clock_sequence
|
||||
|
||||
integer(kind=i4b) :: time_low, time_mid, time_hi_and_version
|
||||
integer(kind=i4b) :: clk_seq_hi_res, clk_seq_low
|
||||
|
||||
integer :: values(8) ! must be default for date_and_time
|
||||
integer(kind=i4b) :: variant, v
|
||||
|
||||
|
||||
if (.not.initialized) then
|
||||
! Use the current date and time to init mtprng
|
||||
! but this gives limited varaibility, so mix
|
||||
! the result up. Can we do better? In any
|
||||
! case, this gets passed through a quick
|
||||
! generator inside mtprng_init.
|
||||
call date_and_time(values=values)
|
||||
values(7) = values(7)*1000+values(5)*100+values(3)*10+values(1)
|
||||
values(8) = values(2)*1000+values(4)*100+values(6)*10+values(8)
|
||||
call mtprng_init(int(values(7)*10000+values(8), i4b), rng_state)
|
||||
clock_seq = int(mtprng_rand64(rng_state), i4b)
|
||||
initialized = .true.
|
||||
endif
|
||||
|
||||
variant = 1
|
||||
|
||||
if (present(version)) then
|
||||
v = version
|
||||
else
|
||||
v = 4
|
||||
endif
|
||||
|
||||
select case (v)
|
||||
case (0)
|
||||
! Nil UUID - S 4.1.7
|
||||
uuid = repeat('0',8)//'-'//repeat('0',4)//'-'//repeat('0',4)// &
|
||||
'-'//repeat('0',4)//'-'//repeat('0',12)
|
||||
return
|
||||
case(1)
|
||||
call date_and_time(values=values)
|
||||
! In case of too-frequent requests, we will replace time_low
|
||||
! with the count below ...
|
||||
if (all(values==values_save)) then
|
||||
hires_count = hires_count + 1
|
||||
else
|
||||
hires_count = 0
|
||||
endif
|
||||
case(2-3)
|
||||
!Unimplemented
|
||||
uuid = ''
|
||||
return
|
||||
case(4)
|
||||
continue
|
||||
case(5)
|
||||
!Unimplemented
|
||||
uuid = ''
|
||||
return
|
||||
case default
|
||||
!Unspecified
|
||||
uuid = ''
|
||||
return
|
||||
end select
|
||||
|
||||
!4.1.4 Timestamp
|
||||
|
||||
select case(v)
|
||||
case(1)
|
||||
timestamp = get_utc_since_1582(values)
|
||||
case(4)
|
||||
timestamp = ior(mtprng_rand64(rng_state), ishft(mtprng_rand64(rng_state), 28))
|
||||
end select
|
||||
|
||||
!4.1.5 Clock Sequence
|
||||
! 14 bits
|
||||
select case(v)
|
||||
case(1)
|
||||
clock_sequence = clock_seq
|
||||
case(4)
|
||||
clock_sequence = int(mtprng_rand64(rng_state), i4b)
|
||||
end select
|
||||
|
||||
!4.1.6 Node
|
||||
! 48 bits
|
||||
select case(v)
|
||||
case(1)
|
||||
node = ior(mtprng_rand64(rng_state), ishft(mtprng_rand64(rng_state), 16))
|
||||
! No MAC address accessible - see section 4.5 !FIXME
|
||||
case(4)
|
||||
node = ior(mtprng_rand64(rng_state), ishft(mtprng_rand64(rng_state), 16))
|
||||
end select
|
||||
|
||||
time_low = ibits(timestamp, 0, 32)
|
||||
time_mid = ibits(timestamp, 32, 16)
|
||||
if (hires_count==0) then
|
||||
time_hi_and_version = ior(int(ibits(timestamp, 48, 12), i4b), ishft(v, 12))
|
||||
else
|
||||
time_hi_and_version = ior(hires_count, ishft(v, 12))
|
||||
endif
|
||||
|
||||
clk_seq_low = ibits(clock_sequence, 0, 8)
|
||||
clk_seq_hi_res = ior(ibits(clock_sequence, 8, 6), ishft(variant, 6))
|
||||
|
||||
uuid = int32ToHexOctets(time_low, 4)//"-"// &
|
||||
int32ToHexOctets(time_mid, 2)//"-"// &
|
||||
int32ToHexOctets(time_hi_and_version, 2)//"-"// &
|
||||
int32ToHexOctets(clk_seq_hi_res, 1)// &
|
||||
int32ToHexOctets(clk_seq_low, 1)//"-"// &
|
||||
int64ToHexOctets(node, 6)
|
||||
|
||||
contains
|
||||
|
||||
function int32ToHexOctets(b, n) result(s)
|
||||
integer(i4b), intent(in) :: b
|
||||
integer, intent(in) :: n ! number of octets to print
|
||||
character(len=2*n) :: s
|
||||
|
||||
integer :: i
|
||||
|
||||
do i = 0, 2*n-1
|
||||
s(2*n-i:2*n-i) = hexdigits(ibits(b, i*4, 4))
|
||||
enddo
|
||||
|
||||
end function int32ToHexOctets
|
||||
function int64ToHexOctets(b, n) result(s)
|
||||
integer(i8b), intent(in) :: b
|
||||
integer, intent(in) :: n ! number of octets to print
|
||||
character(len=2*n) :: s
|
||||
|
||||
integer :: i
|
||||
|
||||
do i = 0, 2*n-1
|
||||
s(2*n-i:2*n-i) = hexdigits(ibits(b, i*4, 4))
|
||||
enddo
|
||||
|
||||
end function int64ToHexOctets
|
||||
|
||||
#endif
|
||||
end function generate_uuid
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
function get_utc_since_1582(values) result(ns)
|
||||
! This subroutine is a little broken. It only works
|
||||
! for times after 1/1/2006 and takes no account
|
||||
! of any future leapseconds. It ought to serve regardless.
|
||||
|
||||
! It returns the number of 100-ns intervals since 1582-10-15-00-00-00
|
||||
|
||||
integer, dimension(8), intent(in) :: values
|
||||
integer(kind=i8b) :: ns
|
||||
|
||||
integer :: days
|
||||
integer :: years
|
||||
|
||||
integer, parameter :: days_in_normal_year(12) = &
|
||||
(/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/)
|
||||
|
||||
ns = 23_i8b * 1000_i8b * 1000_i8b * 10_i8b ! 23 leap seconds until 24:00:00 31/12/2005
|
||||
|
||||
! A count of the 100-nanosecond intervals since the
|
||||
! beginning of the day.
|
||||
ns = ns &
|
||||
! milliseconds
|
||||
+ int(values(8), i8b) * 10_i8b * 1000_i8b &
|
||||
! seconds
|
||||
+ int(values(7), i8b) * 10_i8b * 1000_i8b * 1000_i8b &
|
||||
! minutes (with timezone adjustment)
|
||||
+ int(values(6) + values(4), i8b) * 10_i8b * 1000_i8b * 1000_i8b * 60_i8b &
|
||||
! hours
|
||||
+ int(values(5), i8b) * 10_i8b * 1000_i8b * 1000_i8b * 60_i8b * 60_i8b
|
||||
|
||||
! Number of days this year:
|
||||
days = sum(days_in_normal_year(:values(2)-1))
|
||||
days = days + values(3) - 1 !add days in current month
|
||||
if (values(2)>2 .and. isLeapYear(values(1))) then
|
||||
days = days + 1
|
||||
endif
|
||||
!That's all the time since the turn of this year
|
||||
|
||||
days = days + 78 ! From the start of 15th Oct to the end of 31st Dec in 1582
|
||||
!That's the additional time before the turn of the year 1583
|
||||
|
||||
days = days + 102 ! 102 leap years from 1584 to 2000 inclusive
|
||||
! That's all the intercalataed days until 2000
|
||||
|
||||
years = values(1) - 2000 - 1 ! years since 2000 - not including this year
|
||||
|
||||
days = days + years/4 - years/100 + years/400 !Add extra leap days to this total:
|
||||
! That's all out intercalated days - remaining years are all 365 days long.
|
||||
|
||||
years = years + 418 ! Add the years from 1583-2000 inclusive back on.
|
||||
|
||||
! Multiply by number of time units in one day & add to today's total.
|
||||
ns = ns + 864000000000_i8b * (int(days,i8b) + 365_i8b * int(years,i8b))
|
||||
|
||||
contains
|
||||
function isLeapYear(y) result(p)
|
||||
integer, intent(in) :: y
|
||||
logical :: p
|
||||
p = (mod(y,4)==0 .and. .not.mod(y,100)==0 .or. mod(y,400)==0)
|
||||
end function isLeapYear
|
||||
|
||||
end function get_utc_since_1582
|
||||
|
||||
#endif
|
||||
end module fox_m_utils_uuid
|
||||
|
|
@ -1,45 +0,0 @@
|
|||
module FoX_wxml
|
||||
|
||||
use m_wxml_core
|
||||
use m_wxml_overloads
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
public :: xmlf_t
|
||||
public :: xml_OpenFile
|
||||
public :: xml_Close
|
||||
public :: xml_NewElement
|
||||
public :: xml_EndElement
|
||||
public :: xml_AddXMLDeclaration
|
||||
public :: xml_AddXMLStylesheet
|
||||
public :: xml_AddXMLPI
|
||||
public :: xml_AddComment
|
||||
public :: xml_AddEntityReference
|
||||
|
||||
public :: xml_AddCharacters
|
||||
public :: xml_AddNewline
|
||||
public :: xml_AddAttribute
|
||||
public :: xml_AddPseudoAttribute
|
||||
|
||||
public :: xml_DeclareNamespace
|
||||
public :: xml_UndeclareNamespace
|
||||
|
||||
public :: xml_AddDOCTYPE
|
||||
public :: xml_AddParameterEntity
|
||||
public :: xml_AddInternalEntity
|
||||
public :: xml_AddExternalEntity
|
||||
public :: xml_AddNotation
|
||||
public :: xml_AddElementToDTD
|
||||
public :: xml_AddAttlistToDTD
|
||||
public :: xml_AddPEreferenceToDTD
|
||||
|
||||
public :: xmlf_GetPretty_print
|
||||
public :: xmlf_SetPretty_print
|
||||
public :: xmlf_GetExtendedData
|
||||
public :: xmlf_SetExtendedData
|
||||
|
||||
public :: xmlf_Name
|
||||
public :: xmlf_OpenTag
|
||||
|
||||
end module FoX_wxml
|
||||
|
|
@ -1,47 +0,0 @@
|
|||
source = $(wildcard *.F90)
|
||||
objects = $(source:.F90=.o)
|
||||
|
||||
#===============================================================================
|
||||
# Compiler Options
|
||||
#===============================================================================
|
||||
|
||||
# Ignore unusd variables
|
||||
|
||||
ifeq ($(MACHINE),bluegene)
|
||||
override F90 = xlf2003
|
||||
endif
|
||||
|
||||
ifeq ($(F90),ifort)
|
||||
override F90FLAGS += -warn nounused
|
||||
endif
|
||||
|
||||
#===============================================================================
|
||||
# Targets
|
||||
#===============================================================================
|
||||
|
||||
all: $(objects)
|
||||
mv *.mod ../include
|
||||
mv *.o ../lib
|
||||
clean:
|
||||
@rm -f *.o *.mod
|
||||
neat:
|
||||
@rm -f *.o *.mod
|
||||
|
||||
#===============================================================================
|
||||
# Rules
|
||||
#===============================================================================
|
||||
|
||||
.SUFFIXES: .F90 .o
|
||||
|
||||
.PHONY: clean neat
|
||||
|
||||
%.o: %.F90
|
||||
$(F90) $(F90FLAGS) -c -I../include $<
|
||||
|
||||
#===============================================================================
|
||||
# Dependencies
|
||||
#===============================================================================
|
||||
|
||||
FoX_wxml.o: m_wxml_core.o m_wxml_overloads.o
|
||||
m_wxml_core.o: m_wxml_escape.o
|
||||
m_wxml_overloads.o: m_wxml_core.o
|
||||
File diff suppressed because it is too large
Load diff
|
|
@ -1,140 +0,0 @@
|
|||
module m_wxml_escape
|
||||
|
||||
#ifndef DUMMYLIB
|
||||
!Ensure all characters are safe to go out into XML file.
|
||||
|
||||
use fox_m_fsys_format, only: str
|
||||
use m_common_charset, only: XML1_0
|
||||
use m_common_error, only: FoX_error, FoX_warning
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
integer, parameter :: AMP = iachar('&')
|
||||
integer, parameter :: LT = iachar('<')
|
||||
integer, parameter :: GT = iachar('>')
|
||||
integer, parameter :: QUOT = iachar('"')
|
||||
integer, parameter :: APOS = iachar("'")
|
||||
|
||||
public :: escape_string
|
||||
public :: escape_string_len
|
||||
|
||||
contains
|
||||
|
||||
pure function escape_string_len(s) result(c)
|
||||
character(len=*), intent(in) :: s
|
||||
integer :: c
|
||||
|
||||
integer :: i
|
||||
c = len(s)
|
||||
do i = 1, len(s)
|
||||
select case(iachar(s(i:i)))
|
||||
case (AMP)
|
||||
c = c + 4
|
||||
case (LT)
|
||||
c = c + 3
|
||||
case (GT)
|
||||
c = c + 3
|
||||
case (QUOT)
|
||||
c = c + 5
|
||||
case (APOS)
|
||||
c = c + 5
|
||||
case (1:8)
|
||||
c = c + 3
|
||||
case (11:12)
|
||||
c = c + 4
|
||||
case (14:31)
|
||||
c = c + 4
|
||||
case (127:)
|
||||
c = c + 5
|
||||
! a char can never contain more than 8 bits = 256 characters, so
|
||||
! we never need more than 3 chars to represent the int.
|
||||
end select
|
||||
enddo
|
||||
|
||||
end function escape_string_len
|
||||
|
||||
|
||||
function escape_string(s, version) result (s2)
|
||||
character(len=*), intent(in) :: s
|
||||
integer, intent(in) :: version
|
||||
character(len=escape_string_len(s)) :: s2
|
||||
|
||||
integer :: c, i, ic
|
||||
|
||||
! We have to do it this way (with achar etc) in case the native
|
||||
! platform encoding is not ASCII
|
||||
|
||||
c = 1
|
||||
do i = 1, len(s)
|
||||
ic = iachar(s(i:i))
|
||||
select case (ic)
|
||||
case (0)
|
||||
call FoX_error("Tried to output a NUL character")
|
||||
case (1:8)
|
||||
if (version==XML1_0) then
|
||||
call FoX_error("Tried to output a character invalid under XML 1.0")
|
||||
else
|
||||
s2(c:c+3) = "&#"//str(ic)//";"
|
||||
c = c + 4
|
||||
endif
|
||||
case(9:10)
|
||||
s2(c:c) = achar(ic)
|
||||
c = c + 1
|
||||
case(11:12)
|
||||
if (version==XML1_0) then
|
||||
call FoX_error("Tried to output a character invalid under XML 1.0")
|
||||
else
|
||||
s2(c:c+5) = "&#"//str(ic)//";"
|
||||
c = c + 5
|
||||
endif
|
||||
case(13)
|
||||
s2(c:c) = achar(13)
|
||||
c = c + 1
|
||||
case (14:31)
|
||||
if (version==XML1_0) then
|
||||
call FoX_error("Tried to output a character invalid under XML 1.0")
|
||||
else
|
||||
s2(c:c+5) = "&#"//str(ic)//";"
|
||||
c = c + 5
|
||||
endif
|
||||
case (32:126)
|
||||
select case (iachar(s(i:i)))
|
||||
case (AMP)
|
||||
s2(c:c+4) = "&"
|
||||
c = c + 5
|
||||
case (LT)
|
||||
s2(c:c+3) = "<"
|
||||
c = c + 4
|
||||
case (GT)
|
||||
s2(c:c+3) = ">"
|
||||
c = c + 4
|
||||
case (QUOT)
|
||||
s2(c:c+5) = """
|
||||
c = c + 6
|
||||
case (APOS)
|
||||
s2(c:c+5) = "'"
|
||||
c = c + 6
|
||||
case default
|
||||
s2(c:c) = achar(ic)
|
||||
c = c + 1
|
||||
end select
|
||||
case (127)
|
||||
s2(c:c+5) = ""
|
||||
c = c + 6
|
||||
case default
|
||||
!TOHW we should maybe just disallow this ...
|
||||
call FoX_warning("emitting non-ASCII character. Platform-dependent result!")
|
||||
s2(c:c+6) = "&#"//str(ic)//";"
|
||||
c = c + 6
|
||||
! a char can never contain more than 8 bits = 256 characters, so
|
||||
! we never need more than 3 chars to represent the int.
|
||||
! We have to encode it though, because UTF-8 x7F-x9F must be
|
||||
! encoded, and if they are in the native charset they'll be > 128
|
||||
end select
|
||||
enddo
|
||||
|
||||
end function escape_string
|
||||
|
||||
#endif
|
||||
end module m_wxml_escape
|
||||
File diff suppressed because it is too large
Load diff
|
|
@ -3,7 +3,7 @@ module xml_interface
|
|||
use constants, only: MAX_LINE_LEN
|
||||
use error, only: fatal_error
|
||||
use global, only: message
|
||||
use fox_dom
|
||||
use openmc_fox
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
|
|
|||
|
|
@ -18,6 +18,19 @@ full test suite run:
|
|||
|
||||
python run_tests.py
|
||||
|
||||
The test suite is configured to run with cross sections from NNDC_. To
|
||||
download these cross sections please do the following:
|
||||
|
||||
.. code-block:: sh
|
||||
|
||||
cd ../data
|
||||
python get_nndc.py
|
||||
export CROSS_SECTIONS=<path_to_data_folder>/nndc/cross_sections.xml
|
||||
|
||||
The environmental variable **CROSS_SECTIONS** can be used to quickly switch
|
||||
between the cross sections set for the test suite and cross section set for
|
||||
your simulations.
|
||||
|
||||
A subset of build configurations and/or tests can be run. To see how to use
|
||||
the script run:
|
||||
|
||||
|
|
@ -42,3 +55,4 @@ can run:
|
|||
python run_tests.py -p
|
||||
|
||||
.. _ctest: http://www.cmake.org/cmake/help/v2.8.12/ctest.html
|
||||
.. _NNDC: http://http://www.nndc.bnl.gov/endf/b7.1/acefiles.html
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@ from __future__ import print_function
|
|||
import os
|
||||
import shutil
|
||||
import re
|
||||
import sys
|
||||
from subprocess import call
|
||||
from collections import OrderedDict
|
||||
from optparse import OptionParser
|
||||
|
|
@ -34,17 +35,17 @@ PHDF5_DIR='/opt/phdf5/1.8.12-gnu'
|
|||
PETSC_DIR='/opt/petsc/3.4.4-gnu'
|
||||
|
||||
# Override default compiler paths if environmental vars are found
|
||||
if os.environ.has_key('FC'):
|
||||
if 'FC' in os.environ:
|
||||
FC = os.environ['FC']
|
||||
if FC is not 'gfortran':
|
||||
print('NOTE: Test suite only verifed for gfortran compiler.')
|
||||
if os.environ.has_key('MPI_DIR'):
|
||||
if 'MPI_DIR' in os.environ:
|
||||
MPI_DIR = os.environ['MPI_DIR']
|
||||
if os.environ.has_key('HDF5_DIR'):
|
||||
if 'HDF5_DIR' in os.environ:
|
||||
HDF5_DIR = os.environ['HDF5_DIR']
|
||||
if os.environ.has_key('PHDF5_DIR'):
|
||||
if 'PHDF5_DIR' in os.environ:
|
||||
PHDF5_DIR = os.environ['PHDF5_DIR']
|
||||
if os.environ.has_key('PETSC_DIR'):
|
||||
if 'PETSC_DIR' in os.environ:
|
||||
PETSC_DIR = os.environ['PETSC_DIR']
|
||||
|
||||
# Define test data structure
|
||||
|
|
@ -144,7 +145,7 @@ class Test(object):
|
|||
if os.path.isfile(self.fc):
|
||||
result = True
|
||||
for path in os.environ["PATH"].split(":"):
|
||||
if os.path.isfile(path + "/" + self.fc):
|
||||
if os.path.isfile(os.path.join(path, self.fc)):
|
||||
result = True
|
||||
if not result:
|
||||
raise Exception("Compiler path '{0}' does not exist."
|
||||
|
|
@ -216,6 +217,7 @@ for test in tests:
|
|||
print('-'*(len(test) + 6))
|
||||
print(test + ' tests')
|
||||
print('-'*(len(test) + 6))
|
||||
sys.stdout.flush()
|
||||
|
||||
# Verify fortran compiler exists
|
||||
tests[test].check_compiler()
|
||||
|
|
@ -247,10 +249,16 @@ for test in tests:
|
|||
print('\n' + '='*54)
|
||||
print('Summary of Compilation Option Testing:\n')
|
||||
|
||||
OK = '\033[92m'
|
||||
FAIL = '\033[91m'
|
||||
ENDC = '\033[0m'
|
||||
BOLD = '\033[1m'
|
||||
if sys.stdout.isatty():
|
||||
OK = '\033[92m'
|
||||
FAIL = '\033[91m'
|
||||
ENDC = '\033[0m'
|
||||
BOLD = '\033[1m'
|
||||
else:
|
||||
OK = ''
|
||||
FAIL = ''
|
||||
ENDC = ''
|
||||
BOLD = ''
|
||||
|
||||
for test in tests:
|
||||
print(test + '.'*(50 - len(test)), end='')
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
|
||||
<material id="1">
|
||||
<density value="4.5" units="g/cc" />
|
||||
<nuclide name="U-235" xs="70c" ao="1.0" />
|
||||
<nuclide name="U-235" xs="71c" ao="1.0" />
|
||||
</material>
|
||||
|
||||
</materials>
|
||||
|
|
|
|||
|
|
@ -1,2 +1,2 @@
|
|||
k-combined:
|
||||
3.011353E-01 2.854556E-03
|
||||
3.037843E-01 4.395619E-03
|
||||
|
|
|
|||
|
|
@ -24,13 +24,13 @@ def test_run():
|
|||
assert returncode == 0, 'OpenMC did not exit successfully.'
|
||||
|
||||
def test_created_statepoint():
|
||||
statepoint = glob.glob(cwd + '/statepoint.10.*')
|
||||
statepoint = glob.glob(os.path.join(cwd, 'statepoint.10.*'))
|
||||
assert len(statepoint) == 1, 'Either multiple or no statepoint files exist.'
|
||||
assert statepoint[0].endswith('binary') or statepoint[0].endswith('h5'),\
|
||||
'Statepoint file is not a binary or hdf5 file.'
|
||||
|
||||
def test_results():
|
||||
statepoint = glob.glob(cwd + '/statepoint.10.*')
|
||||
statepoint = glob.glob(os.path.join(cwd, 'statepoint.10.*'))
|
||||
call(['python', 'results.py', statepoint[0]])
|
||||
compare = filecmp.cmp('results_test.dat', 'results_true.dat')
|
||||
if not compare:
|
||||
|
|
@ -38,8 +38,8 @@ def test_results():
|
|||
assert compare, 'Results do not agree.'
|
||||
|
||||
def teardown():
|
||||
output = glob.glob(cwd + '/statepoint.10.*')
|
||||
output.append(cwd + '/results_test.dat')
|
||||
output = glob.glob(os.path.join(cwd, 'statepoint.10.*'))
|
||||
output.append(os.path.join(cwd, 'results_test.dat'))
|
||||
for f in output:
|
||||
if os.path.exists(f):
|
||||
os.remove(f)
|
||||
|
|
|
|||
|
|
@ -4,9 +4,9 @@
|
|||
<!-- Definition of materials -->
|
||||
<material id="1">
|
||||
<density value="19" units="g/cc" />
|
||||
<nuclide name="U-235" xs="70c" wo="0.21" />
|
||||
<nuclide name="U-238" xs="70c" wo="0.68" />
|
||||
<nuclide name="O-16" xs="70c" wo="0.11" />
|
||||
<nuclide name="U-235" xs="71c" wo="0.21" />
|
||||
<nuclide name="U-238" xs="71c" wo="0.68" />
|
||||
<nuclide name="O-16" xs="71c" wo="0.11" />
|
||||
</material>
|
||||
|
||||
</materials>
|
||||
|
|
|
|||
|
|
@ -1,128 +1,128 @@
|
|||
k-combined:
|
||||
1.167124E+00 1.217344E-02
|
||||
1.168987E+00 9.319802E-03
|
||||
tally 1:
|
||||
1.126891E+01
|
||||
1.275756E+01
|
||||
2.086557E+01
|
||||
4.369504E+01
|
||||
2.853629E+01
|
||||
8.169563E+01
|
||||
3.404507E+01
|
||||
1.165020E+02
|
||||
3.723908E+01
|
||||
1.389881E+02
|
||||
3.760048E+01
|
||||
1.416691E+02
|
||||
3.455469E+01
|
||||
1.197186E+02
|
||||
2.837503E+01
|
||||
8.086287E+01
|
||||
2.151788E+01
|
||||
4.648312E+01
|
||||
1.194541E+01
|
||||
1.432330E+01
|
||||
1.161802E+01
|
||||
1.359198E+01
|
||||
2.143662E+01
|
||||
4.616949E+01
|
||||
2.877199E+01
|
||||
8.293286E+01
|
||||
3.448996E+01
|
||||
1.190776E+02
|
||||
3.682808E+01
|
||||
1.360214E+02
|
||||
3.657679E+01
|
||||
1.345791E+02
|
||||
3.429289E+01
|
||||
1.180573E+02
|
||||
2.891482E+01
|
||||
8.382790E+01
|
||||
2.160634E+01
|
||||
4.690703E+01
|
||||
1.143469E+01
|
||||
1.321689E+01
|
||||
tally 2:
|
||||
2.292174E+01
|
||||
2.650794E+01
|
||||
1.598184E+01
|
||||
1.288693E+01
|
||||
2.194144E+00
|
||||
2.510560E-01
|
||||
4.217817E+01
|
||||
8.938588E+01
|
||||
2.974466E+01
|
||||
4.447040E+01
|
||||
3.939271E+00
|
||||
7.882419E-01
|
||||
5.742290E+01
|
||||
1.654599E+02
|
||||
4.067582E+01
|
||||
8.308457E+01
|
||||
5.566956E+00
|
||||
1.570073E+00
|
||||
6.810587E+01
|
||||
2.331019E+02
|
||||
4.831544E+01
|
||||
1.174673E+02
|
||||
6.245000E+00
|
||||
1.967939E+00
|
||||
7.258131E+01
|
||||
2.646756E+02
|
||||
5.185146E+01
|
||||
1.351426E+02
|
||||
6.622489E+00
|
||||
2.231695E+00
|
||||
7.246115E+01
|
||||
2.641295E+02
|
||||
5.159541E+01
|
||||
1.339441E+02
|
||||
6.702239E+00
|
||||
2.277825E+00
|
||||
6.716396E+01
|
||||
2.266815E+02
|
||||
4.765062E+01
|
||||
1.141626E+02
|
||||
6.384097E+00
|
||||
2.063760E+00
|
||||
5.549541E+01
|
||||
1.545360E+02
|
||||
3.940819E+01
|
||||
7.794877E+01
|
||||
5.183373E+00
|
||||
1.369482E+00
|
||||
4.155684E+01
|
||||
8.679434E+01
|
||||
2.926743E+01
|
||||
4.307143E+01
|
||||
3.938851E+00
|
||||
7.877944E-01
|
||||
2.335179E+01
|
||||
2.758239E+01
|
||||
1.622682E+01
|
||||
1.331995E+01
|
||||
2.248920E+00
|
||||
2.594933E-01
|
||||
2.380718E+01
|
||||
2.858317E+01
|
||||
1.660010E+01
|
||||
1.392000E+01
|
||||
2.336685E+00
|
||||
2.792430E-01
|
||||
4.284161E+01
|
||||
9.206393E+01
|
||||
3.023937E+01
|
||||
4.591230E+01
|
||||
4.136988E+00
|
||||
8.702960E-01
|
||||
5.639044E+01
|
||||
1.593962E+02
|
||||
4.001681E+01
|
||||
8.032996E+01
|
||||
5.370917E+00
|
||||
1.458444E+00
|
||||
6.755287E+01
|
||||
2.288270E+02
|
||||
4.800458E+01
|
||||
1.155855E+02
|
||||
6.206692E+00
|
||||
1.953289E+00
|
||||
7.267400E+01
|
||||
2.651402E+02
|
||||
5.165153E+01
|
||||
1.339918E+02
|
||||
6.649033E+00
|
||||
2.242577E+00
|
||||
7.087850E+01
|
||||
2.532369E+02
|
||||
5.046977E+01
|
||||
1.285086E+02
|
||||
6.659787E+00
|
||||
2.241565E+00
|
||||
6.771470E+01
|
||||
2.301651E+02
|
||||
4.798605E+01
|
||||
1.156576E+02
|
||||
6.557349E+00
|
||||
2.165589E+00
|
||||
5.782189E+01
|
||||
1.678253E+02
|
||||
4.097379E+01
|
||||
8.429047E+01
|
||||
5.448469E+00
|
||||
1.492910E+00
|
||||
4.267601E+01
|
||||
9.143833E+01
|
||||
3.024815E+01
|
||||
4.596012E+01
|
||||
3.996488E+00
|
||||
8.116438E-01
|
||||
2.323782E+01
|
||||
2.743368E+01
|
||||
1.625472E+01
|
||||
1.341590E+01
|
||||
2.400563E+00
|
||||
2.941915E-01
|
||||
tally 3:
|
||||
1.537807E+01
|
||||
1.193746E+01
|
||||
1.044189E+00
|
||||
5.627797E-02
|
||||
2.861614E+01
|
||||
4.118324E+01
|
||||
1.846208E+00
|
||||
1.729007E-01
|
||||
3.921463E+01
|
||||
7.723579E+01
|
||||
2.427723E+00
|
||||
2.983153E-01
|
||||
4.653208E+01
|
||||
1.089818E+02
|
||||
3.128394E+00
|
||||
4.945409E-01
|
||||
4.989896E+01
|
||||
1.251503E+02
|
||||
3.242191E+00
|
||||
5.330743E-01
|
||||
4.967378E+01
|
||||
1.241657E+02
|
||||
3.184751E+00
|
||||
5.164524E-01
|
||||
4.592989E+01
|
||||
1.061019E+02
|
||||
2.936424E+00
|
||||
4.356307E-01
|
||||
3.783938E+01
|
||||
7.188486E+01
|
||||
2.485680E+00
|
||||
3.117618E-01
|
||||
2.819358E+01
|
||||
3.997585E+01
|
||||
1.875908E+00
|
||||
1.772000E-01
|
||||
1.562420E+01
|
||||
1.236020E+01
|
||||
1.013140E+00
|
||||
5.260420E-02
|
||||
1.601304E+01
|
||||
1.295277E+01
|
||||
1.014990E+00
|
||||
5.490299E-02
|
||||
2.915045E+01
|
||||
4.266451E+01
|
||||
1.855154E+00
|
||||
1.746065E-01
|
||||
3.847223E+01
|
||||
7.425749E+01
|
||||
2.364988E+00
|
||||
2.821164E-01
|
||||
4.623125E+01
|
||||
1.072240E+02
|
||||
3.010613E+00
|
||||
4.553887E-01
|
||||
4.972651E+01
|
||||
1.242015E+02
|
||||
3.203223E+00
|
||||
5.219763E-01
|
||||
4.861443E+01
|
||||
1.192725E+02
|
||||
3.062976E+00
|
||||
4.759075E-01
|
||||
4.624341E+01
|
||||
1.074483E+02
|
||||
3.052902E+00
|
||||
4.696192E-01
|
||||
3.936021E+01
|
||||
7.779195E+01
|
||||
2.651339E+00
|
||||
3.569218E-01
|
||||
2.921293E+01
|
||||
4.286921E+01
|
||||
1.885471E+00
|
||||
1.806178E-01
|
||||
1.570474E+01
|
||||
1.252662E+01
|
||||
1.026659E+00
|
||||
5.454016E-02
|
||||
tally 4:
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -160,8 +160,8 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
3.126366E+00
|
||||
4.930686E-01
|
||||
3.159427E+00
|
||||
5.039513E-01
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -208,10 +208,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
5.456412E+00
|
||||
1.499417E+00
|
||||
2.727756E+00
|
||||
3.788869E-01
|
||||
5.607347E+00
|
||||
1.580624E+00
|
||||
2.836474E+00
|
||||
4.069013E-01
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -256,10 +256,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
7.453481E+00
|
||||
2.790160E+00
|
||||
5.240104E+00
|
||||
1.386896E+00
|
||||
7.379885E+00
|
||||
2.734564E+00
|
||||
5.154302E+00
|
||||
1.336403E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -304,10 +304,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
8.741565E+00
|
||||
3.830226E+00
|
||||
7.137969E+00
|
||||
2.555043E+00
|
||||
8.556064E+00
|
||||
3.671206E+00
|
||||
6.847455E+00
|
||||
2.352259E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -352,10 +352,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
9.221731E+00
|
||||
4.266573E+00
|
||||
8.474118E+00
|
||||
3.604648E+00
|
||||
9.292881E+00
|
||||
4.335081E+00
|
||||
8.363630E+00
|
||||
3.513313E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -400,10 +400,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
9.054937E+00
|
||||
4.124536E+00
|
||||
9.066120E+00
|
||||
4.133834E+00
|
||||
8.998331E+00
|
||||
4.072326E+00
|
||||
8.826553E+00
|
||||
3.913356E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -448,10 +448,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
8.362251E+00
|
||||
3.517244E+00
|
||||
9.086548E+00
|
||||
4.156118E+00
|
||||
8.375498E+00
|
||||
3.529161E+00
|
||||
8.907193E+00
|
||||
3.991044E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -496,10 +496,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
6.871571E+00
|
||||
2.369189E+00
|
||||
8.399583E+00
|
||||
3.549783E+00
|
||||
7.158924E+00
|
||||
2.577348E+00
|
||||
8.542098E+00
|
||||
3.679565E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -544,10 +544,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
4.998101E+00
|
||||
1.258193E+00
|
||||
7.145294E+00
|
||||
2.568114E+00
|
||||
5.227253E+00
|
||||
1.371151E+00
|
||||
7.321467E+00
|
||||
2.695871E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -592,10 +592,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
2.716075E+00
|
||||
3.753566E-01
|
||||
5.427591E+00
|
||||
1.484153E+00
|
||||
2.780685E+00
|
||||
3.908389E-01
|
||||
5.483813E+00
|
||||
1.510174E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -642,8 +642,8 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
3.056644E+00
|
||||
4.702345E-01
|
||||
3.124910E+00
|
||||
4.907485E-01
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -662,114 +662,114 @@ k cmfd
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
1.158665E+00
|
||||
1.173348E+00
|
||||
1.180514E+00
|
||||
1.168646E+00
|
||||
1.152485E+00
|
||||
1.154989E+00
|
||||
1.152285E+00
|
||||
1.152275E+00
|
||||
1.149476E+00
|
||||
1.154912E+00
|
||||
1.164393E+00
|
||||
1.170145E+00
|
||||
1.169161E+00
|
||||
1.167966E+00
|
||||
1.170153E+00
|
||||
1.170989E+00
|
||||
1.149004E+00
|
||||
1.154999E+00
|
||||
1.166063E+00
|
||||
1.162287E+00
|
||||
1.161378E+00
|
||||
1.154163E+00
|
||||
1.151524E+00
|
||||
1.159050E+00
|
||||
1.162134E+00
|
||||
1.165235E+00
|
||||
1.165263E+00
|
||||
1.161535E+00
|
||||
1.160751E+00
|
||||
1.167746E+00
|
||||
1.165987E+00
|
||||
1.167755E+00
|
||||
cmfd entropy
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
3.229801E+00
|
||||
3.226763E+00
|
||||
3.225011E+00
|
||||
3.230316E+00
|
||||
3.232043E+00
|
||||
3.228854E+00
|
||||
3.227439E+00
|
||||
3.228206E+00
|
||||
3.226749E+00
|
||||
3.222635E+00
|
||||
3.218882E+00
|
||||
3.219196E+00
|
||||
3.218057E+00
|
||||
3.220324E+00
|
||||
3.219099E+00
|
||||
3.219847E+00
|
||||
3.236776E+00
|
||||
3.233010E+00
|
||||
3.229202E+00
|
||||
3.227271E+00
|
||||
3.219914E+00
|
||||
3.223315E+00
|
||||
3.228017E+00
|
||||
3.223975E+00
|
||||
3.218940E+00
|
||||
3.221218E+00
|
||||
3.221165E+00
|
||||
3.223293E+00
|
||||
3.223455E+00
|
||||
3.222646E+00
|
||||
3.222918E+00
|
||||
3.221981E+00
|
||||
cmfd balance
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
6.244292E-03
|
||||
5.210436E-03
|
||||
4.212224E-03
|
||||
3.321578E-03
|
||||
3.067254E-03
|
||||
3.076634E-03
|
||||
2.601637E-03
|
||||
2.666441E-03
|
||||
2.490817E-03
|
||||
2.571411E-03
|
||||
3.013819E-03
|
||||
2.802836E-03
|
||||
2.725356E-03
|
||||
2.475281E-03
|
||||
2.279123E-03
|
||||
2.110816E-03
|
||||
5.434023E-03
|
||||
5.184659E-03
|
||||
4.280814E-03
|
||||
4.897635E-03
|
||||
4.447537E-03
|
||||
3.315560E-03
|
||||
2.774776E-03
|
||||
3.793924E-03
|
||||
3.793015E-03
|
||||
3.361464E-03
|
||||
3.099063E-03
|
||||
2.490216E-03
|
||||
2.381843E-03
|
||||
2.359820E-03
|
||||
2.091581E-03
|
||||
2.040911E-03
|
||||
cmfd dominance ratio
|
||||
0.000E+00
|
||||
0.000E+00
|
||||
0.000E+00
|
||||
0.000E+00
|
||||
5.509E-01
|
||||
5.473E-01
|
||||
5.461E-01
|
||||
5.519E-01
|
||||
5.540E-01
|
||||
5.585E-01
|
||||
5.548E-01
|
||||
5.528E-01
|
||||
5.534E-01
|
||||
5.442E-01
|
||||
5.457E-01
|
||||
5.514E-01
|
||||
5.505E-01
|
||||
5.499E-01
|
||||
5.486E-01
|
||||
5.450E-01
|
||||
5.438E-01
|
||||
5.422E-01
|
||||
5.417E-01
|
||||
5.437E-01
|
||||
5.430E-01
|
||||
5.428E-01
|
||||
5.466E-01
|
||||
5.452E-01
|
||||
5.456E-01
|
||||
5.467E-01
|
||||
5.412E-01
|
||||
5.462E-01
|
||||
5.464E-01
|
||||
5.475E-01
|
||||
5.466E-01
|
||||
cmfd openmc source comparison
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
1.136193E-02
|
||||
1.059214E-02
|
||||
9.675100E-03
|
||||
7.296572E-03
|
||||
5.812484E-03
|
||||
6.138879E-03
|
||||
6.070297E-03
|
||||
5.791570E-03
|
||||
6.020032E-03
|
||||
7.287183E-03
|
||||
7.068423E-03
|
||||
6.380521E-03
|
||||
5.828010E-03
|
||||
4.741191E-03
|
||||
4.848114E-03
|
||||
4.686772E-03
|
||||
1.144117E-02
|
||||
1.044995E-02
|
||||
9.694155E-03
|
||||
8.314824E-03
|
||||
9.579604E-03
|
||||
8.180957E-03
|
||||
6.943934E-03
|
||||
7.674700E-03
|
||||
6.981377E-03
|
||||
6.207631E-03
|
||||
5.756393E-03
|
||||
4.983780E-03
|
||||
4.907494E-03
|
||||
4.518721E-03
|
||||
4.194195E-03
|
||||
4.200582E-03
|
||||
cmfd source
|
||||
4.367444E-02
|
||||
7.866919E-02
|
||||
1.050799E-01
|
||||
1.366581E-01
|
||||
1.421824E-01
|
||||
1.393453E-01
|
||||
1.269612E-01
|
||||
1.060419E-01
|
||||
7.920472E-02
|
||||
4.218277E-02
|
||||
4.244854E-02
|
||||
7.896139E-02
|
||||
1.019601E-01
|
||||
1.313192E-01
|
||||
1.405949E-01
|
||||
1.343739E-01
|
||||
1.329222E-01
|
||||
1.140605E-01
|
||||
8.030756E-02
|
||||
4.305160E-02
|
||||
|
|
|
|||
|
|
@ -24,18 +24,18 @@ def test_run():
|
|||
assert returncode == 0, 'OpenMC did not exit successfully.'
|
||||
|
||||
def test_created_statepoint():
|
||||
statepoint = glob.glob(cwd + '/statepoint.20.*')
|
||||
statepoint = glob.glob(os.path.join(cwd, 'statepoint.20.*'))
|
||||
assert len(statepoint) == 1, 'Either multiple or no statepoint files exist.'
|
||||
assert statepoint[0].endswith('binary') or statepoint[0].endswith('h5'),\
|
||||
'Statepoint file is not a binary or hdf5 file.'
|
||||
|
||||
|
||||
def test_output_exists():
|
||||
assert os.path.exists(cwd + '/tallies.out'), 'Tally output file does not exist.'
|
||||
assert os.path.exists(os.path.join(cwd, 'tallies.out')), 'Tally output file does not exist.'
|
||||
|
||||
|
||||
def test_results():
|
||||
statepoint = glob.glob(cwd + '/statepoint.20.*')
|
||||
statepoint = glob.glob(os.path.join(cwd, 'statepoint.20.*'))
|
||||
call(['python', 'results.py', statepoint[0]])
|
||||
compare = filecmp.cmp('results_test.dat', 'results_true.dat')
|
||||
if not compare:
|
||||
|
|
@ -44,9 +44,9 @@ def test_results():
|
|||
|
||||
|
||||
def teardown():
|
||||
output = glob.glob(cwd + '/statepoint.20.*')
|
||||
output.append(cwd + '/tallies.out')
|
||||
output.append(cwd + '/results_test.dat')
|
||||
output = glob.glob(os.path.join(cwd, 'statepoint.20.*'))
|
||||
output.append(os.path.join(cwd, 'tallies.out'))
|
||||
output.append(os.path.join(cwd, 'results_test.dat'))
|
||||
for f in output:
|
||||
if os.path.exists(f):
|
||||
os.remove(f)
|
||||
|
|
|
|||
|
|
@ -4,9 +4,9 @@
|
|||
<!-- Definition of materials -->
|
||||
<material id="1">
|
||||
<density value="19" units="g/cc" />
|
||||
<nuclide name="U-235" xs="70c" wo="0.21" />
|
||||
<nuclide name="U-238" xs="70c" wo="0.68" />
|
||||
<nuclide name="O-16" xs="70c" wo="0.11" />
|
||||
<nuclide name="U-235" xs="71c" wo="0.21" />
|
||||
<nuclide name="U-238" xs="71c" wo="0.68" />
|
||||
<nuclide name="O-16" xs="71c" wo="0.11" />
|
||||
</material>
|
||||
|
||||
</materials>
|
||||
|
|
|
|||
|
|
@ -1,128 +1,128 @@
|
|||
k-combined:
|
||||
1.167124E+00 1.217344E-02
|
||||
1.168987E+00 9.319802E-03
|
||||
tally 1:
|
||||
1.126891E+01
|
||||
1.275756E+01
|
||||
2.086557E+01
|
||||
4.369504E+01
|
||||
2.853629E+01
|
||||
8.169563E+01
|
||||
3.404507E+01
|
||||
1.165020E+02
|
||||
3.723908E+01
|
||||
1.389881E+02
|
||||
3.760048E+01
|
||||
1.416691E+02
|
||||
3.455469E+01
|
||||
1.197186E+02
|
||||
2.837503E+01
|
||||
8.086287E+01
|
||||
2.151788E+01
|
||||
4.648312E+01
|
||||
1.194541E+01
|
||||
1.432330E+01
|
||||
1.161802E+01
|
||||
1.359198E+01
|
||||
2.143662E+01
|
||||
4.616949E+01
|
||||
2.877199E+01
|
||||
8.293286E+01
|
||||
3.448996E+01
|
||||
1.190776E+02
|
||||
3.682808E+01
|
||||
1.360214E+02
|
||||
3.657679E+01
|
||||
1.345791E+02
|
||||
3.429289E+01
|
||||
1.180573E+02
|
||||
2.891482E+01
|
||||
8.382790E+01
|
||||
2.160634E+01
|
||||
4.690703E+01
|
||||
1.143469E+01
|
||||
1.321689E+01
|
||||
tally 2:
|
||||
2.292174E+01
|
||||
2.650794E+01
|
||||
1.598184E+01
|
||||
1.288693E+01
|
||||
2.194144E+00
|
||||
2.510560E-01
|
||||
4.217817E+01
|
||||
8.938588E+01
|
||||
2.974466E+01
|
||||
4.447040E+01
|
||||
3.939271E+00
|
||||
7.882419E-01
|
||||
5.742290E+01
|
||||
1.654599E+02
|
||||
4.067582E+01
|
||||
8.308457E+01
|
||||
5.566956E+00
|
||||
1.570073E+00
|
||||
6.810587E+01
|
||||
2.331019E+02
|
||||
4.831544E+01
|
||||
1.174673E+02
|
||||
6.245000E+00
|
||||
1.967939E+00
|
||||
7.258131E+01
|
||||
2.646756E+02
|
||||
5.185146E+01
|
||||
1.351426E+02
|
||||
6.622489E+00
|
||||
2.231695E+00
|
||||
7.246115E+01
|
||||
2.641295E+02
|
||||
5.159541E+01
|
||||
1.339441E+02
|
||||
6.702239E+00
|
||||
2.277825E+00
|
||||
6.716396E+01
|
||||
2.266815E+02
|
||||
4.765062E+01
|
||||
1.141626E+02
|
||||
6.384097E+00
|
||||
2.063760E+00
|
||||
5.549541E+01
|
||||
1.545360E+02
|
||||
3.940819E+01
|
||||
7.794877E+01
|
||||
5.183373E+00
|
||||
1.369482E+00
|
||||
4.155684E+01
|
||||
8.679434E+01
|
||||
2.926743E+01
|
||||
4.307143E+01
|
||||
3.938851E+00
|
||||
7.877944E-01
|
||||
2.335179E+01
|
||||
2.758239E+01
|
||||
1.622682E+01
|
||||
1.331995E+01
|
||||
2.248920E+00
|
||||
2.594933E-01
|
||||
2.380718E+01
|
||||
2.858317E+01
|
||||
1.660010E+01
|
||||
1.392000E+01
|
||||
2.336685E+00
|
||||
2.792430E-01
|
||||
4.284161E+01
|
||||
9.206393E+01
|
||||
3.023937E+01
|
||||
4.591230E+01
|
||||
4.136988E+00
|
||||
8.702960E-01
|
||||
5.639044E+01
|
||||
1.593962E+02
|
||||
4.001681E+01
|
||||
8.032996E+01
|
||||
5.370917E+00
|
||||
1.458444E+00
|
||||
6.755287E+01
|
||||
2.288270E+02
|
||||
4.800458E+01
|
||||
1.155855E+02
|
||||
6.206692E+00
|
||||
1.953289E+00
|
||||
7.267400E+01
|
||||
2.651402E+02
|
||||
5.165153E+01
|
||||
1.339918E+02
|
||||
6.649033E+00
|
||||
2.242577E+00
|
||||
7.087850E+01
|
||||
2.532369E+02
|
||||
5.046977E+01
|
||||
1.285086E+02
|
||||
6.659787E+00
|
||||
2.241565E+00
|
||||
6.771470E+01
|
||||
2.301651E+02
|
||||
4.798605E+01
|
||||
1.156576E+02
|
||||
6.557349E+00
|
||||
2.165589E+00
|
||||
5.782189E+01
|
||||
1.678253E+02
|
||||
4.097379E+01
|
||||
8.429047E+01
|
||||
5.448469E+00
|
||||
1.492910E+00
|
||||
4.267601E+01
|
||||
9.143833E+01
|
||||
3.024815E+01
|
||||
4.596012E+01
|
||||
3.996488E+00
|
||||
8.116438E-01
|
||||
2.323782E+01
|
||||
2.743368E+01
|
||||
1.625472E+01
|
||||
1.341590E+01
|
||||
2.400563E+00
|
||||
2.941915E-01
|
||||
tally 3:
|
||||
1.537807E+01
|
||||
1.193746E+01
|
||||
1.044189E+00
|
||||
5.627797E-02
|
||||
2.861614E+01
|
||||
4.118324E+01
|
||||
1.846208E+00
|
||||
1.729007E-01
|
||||
3.921463E+01
|
||||
7.723579E+01
|
||||
2.427723E+00
|
||||
2.983153E-01
|
||||
4.653208E+01
|
||||
1.089818E+02
|
||||
3.128394E+00
|
||||
4.945409E-01
|
||||
4.989896E+01
|
||||
1.251503E+02
|
||||
3.242191E+00
|
||||
5.330743E-01
|
||||
4.967378E+01
|
||||
1.241657E+02
|
||||
3.184751E+00
|
||||
5.164524E-01
|
||||
4.592989E+01
|
||||
1.061019E+02
|
||||
2.936424E+00
|
||||
4.356307E-01
|
||||
3.783938E+01
|
||||
7.188486E+01
|
||||
2.485680E+00
|
||||
3.117618E-01
|
||||
2.819358E+01
|
||||
3.997585E+01
|
||||
1.875908E+00
|
||||
1.772000E-01
|
||||
1.562420E+01
|
||||
1.236020E+01
|
||||
1.013140E+00
|
||||
5.260420E-02
|
||||
1.601304E+01
|
||||
1.295277E+01
|
||||
1.014990E+00
|
||||
5.490299E-02
|
||||
2.915045E+01
|
||||
4.266451E+01
|
||||
1.855154E+00
|
||||
1.746065E-01
|
||||
3.847223E+01
|
||||
7.425749E+01
|
||||
2.364988E+00
|
||||
2.821164E-01
|
||||
4.623125E+01
|
||||
1.072240E+02
|
||||
3.010613E+00
|
||||
4.553887E-01
|
||||
4.972651E+01
|
||||
1.242015E+02
|
||||
3.203223E+00
|
||||
5.219763E-01
|
||||
4.861443E+01
|
||||
1.192725E+02
|
||||
3.062976E+00
|
||||
4.759075E-01
|
||||
4.624341E+01
|
||||
1.074483E+02
|
||||
3.052902E+00
|
||||
4.696192E-01
|
||||
3.936021E+01
|
||||
7.779195E+01
|
||||
2.651339E+00
|
||||
3.569218E-01
|
||||
2.921293E+01
|
||||
4.286921E+01
|
||||
1.885471E+00
|
||||
1.806178E-01
|
||||
1.570474E+01
|
||||
1.252662E+01
|
||||
1.026659E+00
|
||||
5.454016E-02
|
||||
tally 4:
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -160,8 +160,8 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
3.126366E+00
|
||||
4.930686E-01
|
||||
3.159427E+00
|
||||
5.039513E-01
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -208,10 +208,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
5.456412E+00
|
||||
1.499417E+00
|
||||
2.727756E+00
|
||||
3.788869E-01
|
||||
5.607347E+00
|
||||
1.580624E+00
|
||||
2.836474E+00
|
||||
4.069013E-01
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -256,10 +256,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
7.453481E+00
|
||||
2.790160E+00
|
||||
5.240104E+00
|
||||
1.386896E+00
|
||||
7.379885E+00
|
||||
2.734564E+00
|
||||
5.154302E+00
|
||||
1.336403E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -304,10 +304,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
8.741565E+00
|
||||
3.830226E+00
|
||||
7.137969E+00
|
||||
2.555043E+00
|
||||
8.556064E+00
|
||||
3.671206E+00
|
||||
6.847455E+00
|
||||
2.352259E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -352,10 +352,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
9.221731E+00
|
||||
4.266573E+00
|
||||
8.474118E+00
|
||||
3.604648E+00
|
||||
9.292881E+00
|
||||
4.335081E+00
|
||||
8.363630E+00
|
||||
3.513313E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -400,10 +400,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
9.054937E+00
|
||||
4.124536E+00
|
||||
9.066120E+00
|
||||
4.133834E+00
|
||||
8.998331E+00
|
||||
4.072326E+00
|
||||
8.826553E+00
|
||||
3.913356E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -448,10 +448,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
8.362251E+00
|
||||
3.517244E+00
|
||||
9.086548E+00
|
||||
4.156118E+00
|
||||
8.375498E+00
|
||||
3.529161E+00
|
||||
8.907193E+00
|
||||
3.991044E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -496,10 +496,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
6.871571E+00
|
||||
2.369189E+00
|
||||
8.399583E+00
|
||||
3.549783E+00
|
||||
7.158924E+00
|
||||
2.577348E+00
|
||||
8.542098E+00
|
||||
3.679565E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -544,10 +544,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
4.998101E+00
|
||||
1.258193E+00
|
||||
7.145294E+00
|
||||
2.568114E+00
|
||||
5.227253E+00
|
||||
1.371152E+00
|
||||
7.321467E+00
|
||||
2.695871E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -592,10 +592,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
2.716075E+00
|
||||
3.753566E-01
|
||||
5.427591E+00
|
||||
1.484153E+00
|
||||
2.780685E+00
|
||||
3.908389E-01
|
||||
5.483813E+00
|
||||
1.510174E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -642,8 +642,8 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
3.056644E+00
|
||||
4.702345E-01
|
||||
3.124910E+00
|
||||
4.907485E-01
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -662,64 +662,64 @@ k cmfd
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
1.158665E+00
|
||||
1.173348E+00
|
||||
1.180514E+00
|
||||
1.168646E+00
|
||||
1.152485E+00
|
||||
1.154989E+00
|
||||
1.152285E+00
|
||||
1.152275E+00
|
||||
1.149476E+00
|
||||
1.154912E+00
|
||||
1.164393E+00
|
||||
1.170145E+00
|
||||
1.169161E+00
|
||||
1.167966E+00
|
||||
1.170153E+00
|
||||
1.170989E+00
|
||||
1.149004E+00
|
||||
1.154999E+00
|
||||
1.166063E+00
|
||||
1.162287E+00
|
||||
1.161378E+00
|
||||
1.154163E+00
|
||||
1.151524E+00
|
||||
1.159050E+00
|
||||
1.162134E+00
|
||||
1.165235E+00
|
||||
1.165263E+00
|
||||
1.161535E+00
|
||||
1.160751E+00
|
||||
1.167746E+00
|
||||
1.165987E+00
|
||||
1.167755E+00
|
||||
cmfd entropy
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
3.229801E+00
|
||||
3.226763E+00
|
||||
3.225011E+00
|
||||
3.230316E+00
|
||||
3.232043E+00
|
||||
3.228854E+00
|
||||
3.227439E+00
|
||||
3.228206E+00
|
||||
3.226749E+00
|
||||
3.222635E+00
|
||||
3.218882E+00
|
||||
3.219196E+00
|
||||
3.218057E+00
|
||||
3.220324E+00
|
||||
3.219099E+00
|
||||
3.219847E+00
|
||||
3.236776E+00
|
||||
3.233010E+00
|
||||
3.229202E+00
|
||||
3.227271E+00
|
||||
3.219914E+00
|
||||
3.223315E+00
|
||||
3.228017E+00
|
||||
3.223975E+00
|
||||
3.218940E+00
|
||||
3.221218E+00
|
||||
3.221165E+00
|
||||
3.223293E+00
|
||||
3.223455E+00
|
||||
3.222646E+00
|
||||
3.222918E+00
|
||||
3.221981E+00
|
||||
cmfd balance
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
6.244292E-03
|
||||
5.210436E-03
|
||||
4.212224E-03
|
||||
3.321578E-03
|
||||
3.067254E-03
|
||||
3.076634E-03
|
||||
2.601637E-03
|
||||
2.666441E-03
|
||||
2.490817E-03
|
||||
2.571411E-03
|
||||
3.013819E-03
|
||||
2.802836E-03
|
||||
2.725356E-03
|
||||
2.475281E-03
|
||||
2.279123E-03
|
||||
2.110816E-03
|
||||
5.434023E-03
|
||||
5.184659E-03
|
||||
4.280814E-03
|
||||
4.897635E-03
|
||||
4.447537E-03
|
||||
3.315560E-03
|
||||
2.774776E-03
|
||||
3.793924E-03
|
||||
3.793015E-03
|
||||
3.361464E-03
|
||||
3.099063E-03
|
||||
2.490216E-03
|
||||
2.381843E-03
|
||||
2.359820E-03
|
||||
2.091581E-03
|
||||
2.040911E-03
|
||||
cmfd dominance ratio
|
||||
0.000E+00
|
||||
0.000E+00
|
||||
|
|
@ -746,30 +746,30 @@ cmfd openmc source comparison
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
1.136193E-02
|
||||
1.059214E-02
|
||||
9.675100E-03
|
||||
7.296571E-03
|
||||
5.812485E-03
|
||||
6.138879E-03
|
||||
6.070297E-03
|
||||
5.791569E-03
|
||||
6.020032E-03
|
||||
7.287183E-03
|
||||
7.068423E-03
|
||||
6.380521E-03
|
||||
5.828010E-03
|
||||
4.741191E-03
|
||||
4.848115E-03
|
||||
4.686773E-03
|
||||
1.144117E-02
|
||||
1.044995E-02
|
||||
9.694155E-03
|
||||
8.314824E-03
|
||||
9.579604E-03
|
||||
8.180957E-03
|
||||
6.943935E-03
|
||||
7.674701E-03
|
||||
6.981377E-03
|
||||
6.207631E-03
|
||||
5.756394E-03
|
||||
4.983779E-03
|
||||
4.907495E-03
|
||||
4.518722E-03
|
||||
4.194194E-03
|
||||
4.200582E-03
|
||||
cmfd source
|
||||
4.367444E-02
|
||||
7.866919E-02
|
||||
1.050799E-01
|
||||
1.366581E-01
|
||||
1.421824E-01
|
||||
1.393453E-01
|
||||
1.269612E-01
|
||||
1.060419E-01
|
||||
7.920472E-02
|
||||
4.218277E-02
|
||||
4.244854E-02
|
||||
7.896140E-02
|
||||
1.019601E-01
|
||||
1.313192E-01
|
||||
1.405949E-01
|
||||
1.343739E-01
|
||||
1.329222E-01
|
||||
1.140605E-01
|
||||
8.030756E-02
|
||||
4.305160E-02
|
||||
|
|
|
|||
|
|
@ -25,18 +25,18 @@ def test_run():
|
|||
|
||||
|
||||
def test_created_statepoint():
|
||||
statepoint = glob.glob(cwd + '/statepoint.20.*')
|
||||
statepoint = glob.glob(os.path.join(cwd, 'statepoint.20.*'))
|
||||
assert len(statepoint) == 1, 'Either multiple or no statepoint files exist.'
|
||||
assert statepoint[0].endswith('binary') or statepoint[0].endswith('h5'),\
|
||||
'Statepoint file is not a binary or hdf5 file.'
|
||||
|
||||
|
||||
def test_output_exists():
|
||||
assert os.path.exists(cwd + '/tallies.out'), 'Tally output file does not exist.'
|
||||
assert os.path.exists(os.path.join(cwd, 'tallies.out')), 'Tally output file does not exist.'
|
||||
|
||||
|
||||
def test_results():
|
||||
statepoint = glob.glob(cwd + '/statepoint.20.*')
|
||||
statepoint = glob.glob(os.path.join(cwd, 'statepoint.20.*'))
|
||||
call(['python', 'results.py', statepoint[0]])
|
||||
compare = filecmp.cmp('results_test.dat', 'results_true.dat')
|
||||
if not compare:
|
||||
|
|
@ -45,9 +45,9 @@ def test_results():
|
|||
|
||||
|
||||
def teardown():
|
||||
output = glob.glob(cwd + '/statepoint.20.*')
|
||||
output.append(cwd + '/tallies.out')
|
||||
output.append(cwd + '/results_test.dat')
|
||||
output = glob.glob(os.path.join(cwd, 'statepoint.20.*'))
|
||||
output.append(os.path.join(cwd, 'tallies.out'))
|
||||
output.append(os.path.join(cwd, 'results_test.dat'))
|
||||
for f in output:
|
||||
if os.path.exists(f):
|
||||
os.remove(f)
|
||||
|
|
|
|||
|
|
@ -4,9 +4,9 @@
|
|||
<!-- Definition of materials -->
|
||||
<material id="1">
|
||||
<density value="19" units="g/cc" />
|
||||
<nuclide name="U-235" xs="70c" wo="0.21" />
|
||||
<nuclide name="U-238" xs="70c" wo="0.68" />
|
||||
<nuclide name="O-16" xs="70c" wo="0.11" />
|
||||
<nuclide name="U-235" xs="71c" wo="0.21" />
|
||||
<nuclide name="U-238" xs="71c" wo="0.68" />
|
||||
<nuclide name="O-16" xs="71c" wo="0.11" />
|
||||
</material>
|
||||
|
||||
</materials>
|
||||
|
|
|
|||
|
|
@ -1,128 +1,128 @@
|
|||
k-combined:
|
||||
1.137460E+00 1.215114E-02
|
||||
1.161033E+00 5.331322E-03
|
||||
tally 1:
|
||||
1.168490E+01
|
||||
1.400522E+01
|
||||
2.192157E+01
|
||||
4.824543E+01
|
||||
2.936949E+01
|
||||
8.648246E+01
|
||||
3.435607E+01
|
||||
1.185184E+02
|
||||
3.612841E+01
|
||||
1.309721E+02
|
||||
3.552232E+01
|
||||
1.266988E+02
|
||||
3.314322E+01
|
||||
1.107274E+02
|
||||
2.765588E+01
|
||||
7.705156E+01
|
||||
2.044445E+01
|
||||
4.210167E+01
|
||||
1.125932E+01
|
||||
1.276689E+01
|
||||
1.143095E+01
|
||||
1.320951E+01
|
||||
2.110914E+01
|
||||
4.482660E+01
|
||||
2.820899E+01
|
||||
7.971781E+01
|
||||
3.353053E+01
|
||||
1.127902E+02
|
||||
3.625079E+01
|
||||
1.315588E+02
|
||||
3.619187E+01
|
||||
1.313928E+02
|
||||
3.413355E+01
|
||||
1.170241E+02
|
||||
2.981796E+01
|
||||
8.925595E+01
|
||||
2.238044E+01
|
||||
5.042900E+01
|
||||
1.223259E+01
|
||||
1.503695E+01
|
||||
tally 2:
|
||||
2.372613E+01
|
||||
2.862691E+01
|
||||
1.660400E+01
|
||||
1.404387E+01
|
||||
2.237703E+00
|
||||
2.562122E-01
|
||||
4.397041E+01
|
||||
9.722086E+01
|
||||
3.107800E+01
|
||||
4.859826E+01
|
||||
4.052018E+00
|
||||
8.364586E-01
|
||||
5.850026E+01
|
||||
1.715533E+02
|
||||
4.157400E+01
|
||||
8.666187E+01
|
||||
5.420325E+00
|
||||
1.492090E+00
|
||||
6.875182E+01
|
||||
2.377104E+02
|
||||
4.875600E+01
|
||||
1.196878E+02
|
||||
6.167355E+00
|
||||
1.922001E+00
|
||||
7.240156E+01
|
||||
2.639189E+02
|
||||
5.161800E+01
|
||||
1.342800E+02
|
||||
6.657325E+00
|
||||
2.248300E+00
|
||||
7.074222E+01
|
||||
2.516854E+02
|
||||
5.016500E+01
|
||||
1.266005E+02
|
||||
6.598272E+00
|
||||
2.224189E+00
|
||||
6.625191E+01
|
||||
2.209754E+02
|
||||
4.694400E+01
|
||||
1.110192E+02
|
||||
6.197674E+00
|
||||
1.947375E+00
|
||||
5.574790E+01
|
||||
1.561211E+02
|
||||
3.963100E+01
|
||||
7.893339E+01
|
||||
5.104628E+00
|
||||
1.314367E+00
|
||||
4.068463E+01
|
||||
8.316576E+01
|
||||
2.878400E+01
|
||||
4.165629E+01
|
||||
4.000895E+00
|
||||
8.100229E-01
|
||||
2.238335E+01
|
||||
2.532998E+01
|
||||
1.555300E+01
|
||||
1.221694E+01
|
||||
2.312206E+00
|
||||
2.751529E-01
|
||||
2.349354E+01
|
||||
2.790806E+01
|
||||
1.645100E+01
|
||||
1.370332E+01
|
||||
2.285204E+00
|
||||
2.668763E-01
|
||||
4.330854E+01
|
||||
9.412452E+01
|
||||
3.058300E+01
|
||||
4.694195E+01
|
||||
4.117792E+00
|
||||
8.553145E-01
|
||||
5.610458E+01
|
||||
1.580232E+02
|
||||
3.989800E+01
|
||||
7.993336E+01
|
||||
5.276532E+00
|
||||
1.410517E+00
|
||||
6.648084E+01
|
||||
2.216203E+02
|
||||
4.728600E+01
|
||||
1.121558E+02
|
||||
6.144320E+00
|
||||
1.912947E+00
|
||||
7.121996E+01
|
||||
2.543760E+02
|
||||
5.081500E+01
|
||||
1.295271E+02
|
||||
6.822357E+00
|
||||
2.351299E+00
|
||||
7.065744E+01
|
||||
2.510315E+02
|
||||
5.036100E+01
|
||||
1.276155E+02
|
||||
6.439371E+00
|
||||
2.089516E+00
|
||||
6.714135E+01
|
||||
2.263907E+02
|
||||
4.784300E+01
|
||||
1.149466E+02
|
||||
6.244217E+00
|
||||
1.966584E+00
|
||||
5.847493E+01
|
||||
1.717088E+02
|
||||
4.151300E+01
|
||||
8.653500E+01
|
||||
5.409126E+00
|
||||
1.478324E+00
|
||||
4.320570E+01
|
||||
9.386346E+01
|
||||
3.053700E+01
|
||||
4.691115E+01
|
||||
3.900699E+00
|
||||
7.745053E-01
|
||||
2.422667E+01
|
||||
2.972110E+01
|
||||
1.690300E+01
|
||||
1.447458E+01
|
||||
2.290913E+00
|
||||
2.736035E-01
|
||||
tally 3:
|
||||
1.599200E+01
|
||||
1.304060E+01
|
||||
1.075546E+00
|
||||
5.989825E-02
|
||||
2.991600E+01
|
||||
4.504778E+01
|
||||
2.016558E+00
|
||||
2.060921E-01
|
||||
4.008500E+01
|
||||
8.057644E+01
|
||||
2.465241E+00
|
||||
3.073562E-01
|
||||
4.690900E+01
|
||||
1.108192E+02
|
||||
3.050094E+00
|
||||
4.696181E-01
|
||||
4.972600E+01
|
||||
1.246434E+02
|
||||
3.127136E+00
|
||||
4.939882E-01
|
||||
4.836400E+01
|
||||
1.176964E+02
|
||||
3.102574E+00
|
||||
4.868820E-01
|
||||
4.524800E+01
|
||||
1.031819E+02
|
||||
2.966738E+00
|
||||
4.482948E-01
|
||||
3.809700E+01
|
||||
7.295318E+01
|
||||
2.526411E+00
|
||||
3.226394E-01
|
||||
2.772600E+01
|
||||
3.866039E+01
|
||||
1.852304E+00
|
||||
1.725388E-01
|
||||
1.494500E+01
|
||||
1.129101E+01
|
||||
9.995136E-01
|
||||
5.115569E-02
|
||||
1.581900E+01
|
||||
1.267388E+01
|
||||
1.050713E+00
|
||||
5.795096E-02
|
||||
2.946200E+01
|
||||
4.357307E+01
|
||||
1.981114E+00
|
||||
1.986434E-01
|
||||
3.837900E+01
|
||||
7.398695E+01
|
||||
2.376771E+00
|
||||
2.847865E-01
|
||||
4.554200E+01
|
||||
1.040508E+02
|
||||
2.960961E+00
|
||||
4.414905E-01
|
||||
4.889800E+01
|
||||
1.199442E+02
|
||||
3.165143E+00
|
||||
5.051206E-01
|
||||
4.846400E+01
|
||||
1.181976E+02
|
||||
3.062317E+00
|
||||
4.764952E-01
|
||||
4.612800E+01
|
||||
1.068662E+02
|
||||
2.952309E+00
|
||||
4.420907E-01
|
||||
3.991400E+01
|
||||
8.001053E+01
|
||||
2.642493E+00
|
||||
3.520581E-01
|
||||
2.948700E+01
|
||||
4.375637E+01
|
||||
1.962290E+00
|
||||
1.967932E-01
|
||||
1.628800E+01
|
||||
1.344132E+01
|
||||
1.095582E+00
|
||||
6.138877E-02
|
||||
tally 4:
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -160,8 +160,8 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
3.251000E+00
|
||||
5.355770E-01
|
||||
3.099000E+00
|
||||
4.849510E-01
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -208,10 +208,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
5.759000E+00
|
||||
1.676451E+00
|
||||
2.883000E+00
|
||||
4.269210E-01
|
||||
5.593000E+00
|
||||
1.573081E+00
|
||||
2.841000E+00
|
||||
4.083870E-01
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -256,10 +256,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
7.633000E+00
|
||||
2.922951E+00
|
||||
5.354000E+00
|
||||
1.442474E+00
|
||||
7.289000E+00
|
||||
2.667465E+00
|
||||
5.130000E+00
|
||||
1.324520E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -304,10 +304,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
8.787000E+00
|
||||
3.871605E+00
|
||||
7.137000E+00
|
||||
2.553987E+00
|
||||
8.447000E+00
|
||||
3.581195E+00
|
||||
6.813000E+00
|
||||
2.330599E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -352,10 +352,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
9.343000E+00
|
||||
4.385923E+00
|
||||
8.470000E+00
|
||||
3.603838E+00
|
||||
9.059000E+00
|
||||
4.117163E+00
|
||||
8.199000E+00
|
||||
3.378525E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -400,10 +400,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
9.076000E+00
|
||||
4.142704E+00
|
||||
8.977000E+00
|
||||
4.056459E+00
|
||||
8.944000E+00
|
||||
4.012912E+00
|
||||
8.856000E+00
|
||||
3.936246E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -448,10 +448,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
8.252000E+00
|
||||
3.428360E+00
|
||||
8.957000E+00
|
||||
4.041545E+00
|
||||
8.353000E+00
|
||||
3.510163E+00
|
||||
8.931000E+00
|
||||
4.018199E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -496,10 +496,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
6.868000E+00
|
||||
2.375736E+00
|
||||
8.404000E+00
|
||||
3.562144E+00
|
||||
7.163000E+00
|
||||
2.577601E+00
|
||||
8.514000E+00
|
||||
3.650062E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -544,10 +544,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
4.914000E+00
|
||||
1.211724E+00
|
||||
7.074000E+00
|
||||
2.511368E+00
|
||||
5.207000E+00
|
||||
1.364243E+00
|
||||
7.240000E+00
|
||||
2.639852E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -592,10 +592,10 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
2.634000E+00
|
||||
3.523220E-01
|
||||
5.349000E+00
|
||||
1.437693E+00
|
||||
2.912000E+00
|
||||
4.294700E-01
|
||||
5.608000E+00
|
||||
1.584696E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -642,8 +642,8 @@ tally 4:
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
3.050000E+00
|
||||
4.687600E-01
|
||||
3.092000E+00
|
||||
4.814500E-01
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
|
|
@ -662,114 +662,114 @@ k cmfd
|
|||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
1.158665E+00
|
||||
1.177323E+00
|
||||
1.179341E+00
|
||||
1.169660E+00
|
||||
1.179827E+00
|
||||
1.180220E+00
|
||||
1.177699E+00
|
||||
1.179321E+00
|
||||
1.180728E+00
|
||||
1.180996E+00
|
||||
1.186680E+00
|
||||
1.181455E+00
|
||||
1.178393E+00
|
||||
1.176470E+00
|
||||
1.172593E+00
|
||||
1.167042E+00
|
||||
1.149004E+00
|
||||
1.156072E+00
|
||||
1.162765E+00
|
||||
1.159868E+00
|
||||
1.158429E+00
|
||||
1.158122E+00
|
||||
1.160155E+00
|
||||
1.163013E+00
|
||||
1.162607E+00
|
||||
1.161321E+00
|
||||
1.163142E+00
|
||||
1.167861E+00
|
||||
1.169148E+00
|
||||
1.167355E+00
|
||||
1.168533E+00
|
||||
1.170762E+00
|
||||
cmfd entropy
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
3.229801E+00
|
||||
3.227279E+00
|
||||
3.224715E+00
|
||||
3.226705E+00
|
||||
3.226404E+00
|
||||
3.227329E+00
|
||||
3.227407E+00
|
||||
3.228601E+00
|
||||
3.230423E+00
|
||||
3.228093E+00
|
||||
3.226358E+00
|
||||
3.226226E+00
|
||||
3.227324E+00
|
||||
3.228594E+00
|
||||
3.229513E+00
|
||||
3.229820E+00
|
||||
3.236776E+00
|
||||
3.232370E+00
|
||||
3.229056E+00
|
||||
3.234649E+00
|
||||
3.234628E+00
|
||||
3.235872E+00
|
||||
3.233688E+00
|
||||
3.234460E+00
|
||||
3.236726E+00
|
||||
3.237964E+00
|
||||
3.237331E+00
|
||||
3.237618E+00
|
||||
3.237149E+00
|
||||
3.236127E+00
|
||||
3.236080E+00
|
||||
3.235280E+00
|
||||
cmfd balance
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
6.244292E-03
|
||||
5.300885E-03
|
||||
5.198276E-03
|
||||
3.759109E-03
|
||||
3.994559E-03
|
||||
3.064086E-03
|
||||
2.749389E-03
|
||||
2.388483E-03
|
||||
2.304428E-03
|
||||
2.188627E-03
|
||||
2.269076E-03
|
||||
2.016776E-03
|
||||
1.622043E-03
|
||||
1.470984E-03
|
||||
1.367144E-03
|
||||
1.402525E-03
|
||||
5.434023E-03
|
||||
5.156307E-03
|
||||
5.127977E-03
|
||||
3.220070E-03
|
||||
3.024046E-03
|
||||
2.877993E-03
|
||||
2.503128E-03
|
||||
2.466220E-03
|
||||
1.994804E-03
|
||||
1.940996E-03
|
||||
2.015415E-03
|
||||
1.988096E-03
|
||||
1.877781E-03
|
||||
1.790436E-03
|
||||
1.646314E-03
|
||||
1.580508E-03
|
||||
cmfd dominance ratio
|
||||
0.000E+00
|
||||
0.000E+00
|
||||
0.000E+00
|
||||
0.000E+00
|
||||
5.509E-01
|
||||
5.474E-01
|
||||
5.434E-01
|
||||
5.469E-01
|
||||
5.461E-01
|
||||
5.474E-01
|
||||
5.486E-01
|
||||
5.485E-01
|
||||
5.491E-01
|
||||
5.474E-01
|
||||
5.467E-01
|
||||
5.471E-01
|
||||
5.480E-01
|
||||
5.486E-01
|
||||
5.500E-01
|
||||
5.502E-01
|
||||
5.585E-01
|
||||
5.555E-01
|
||||
5.523E-01
|
||||
5.570E-01
|
||||
5.596E-01
|
||||
5.607E-01
|
||||
5.582E-01
|
||||
5.591E-01
|
||||
5.608E-01
|
||||
5.606E-01
|
||||
5.598E-01
|
||||
5.592E-01
|
||||
5.591E-01
|
||||
5.593E-01
|
||||
4.792E-01
|
||||
5.574E-01
|
||||
cmfd openmc source comparison
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
0.000000E+00
|
||||
1.136193E-02
|
||||
1.007349E-02
|
||||
8.776995E-03
|
||||
6.729971E-03
|
||||
6.921055E-03
|
||||
5.867589E-03
|
||||
4.366276E-03
|
||||
4.051899E-03
|
||||
3.406846E-03
|
||||
4.043983E-03
|
||||
4.864903E-03
|
||||
3.711687E-03
|
||||
3.124413E-03
|
||||
2.675579E-03
|
||||
2.523549E-03
|
||||
2.724884E-03
|
||||
1.144117E-02
|
||||
1.052638E-02
|
||||
9.003184E-03
|
||||
6.067585E-03
|
||||
5.467159E-03
|
||||
5.779475E-03
|
||||
5.745100E-03
|
||||
4.208508E-03
|
||||
3.661077E-03
|
||||
3.607423E-03
|
||||
4.518798E-03
|
||||
4.311505E-03
|
||||
4.144631E-03
|
||||
3.144288E-03
|
||||
2.966323E-03
|
||||
2.984596E-03
|
||||
cmfd source
|
||||
4.534769E-02
|
||||
8.593793E-02
|
||||
1.059054E-01
|
||||
1.317554E-01
|
||||
1.358070E-01
|
||||
1.352224E-01
|
||||
1.290227E-01
|
||||
1.093443E-01
|
||||
7.943056E-02
|
||||
4.222668E-02
|
||||
4.414206E-02
|
||||
8.436718E-02
|
||||
1.020567E-01
|
||||
1.279910E-01
|
||||
1.373582E-01
|
||||
1.331786E-01
|
||||
1.279289E-01
|
||||
1.134988E-01
|
||||
8.346075E-02
|
||||
4.601789E-02
|
||||
|
|
|
|||
|
|
@ -25,18 +25,18 @@ def test_run():
|
|||
|
||||
|
||||
def test_created_statepoint():
|
||||
statepoint = glob.glob(cwd + '/statepoint.20.*')
|
||||
statepoint = glob.glob(os.path.join(cwd, 'statepoint.20.*'))
|
||||
assert len(statepoint) == 1, 'Either multiple or no statepoint files exist.'
|
||||
assert statepoint[0].endswith('binary') or statepoint[0].endswith('h5'),\
|
||||
'Statepoint file is not a binary or hdf5 file.'
|
||||
|
||||
|
||||
def test_output_exists():
|
||||
assert os.path.exists(cwd + '/tallies.out'), 'Tally output file does not exist.'
|
||||
assert os.path.exists(os.path.join(cwd, 'tallies.out')), 'Tally output file does not exist.'
|
||||
|
||||
|
||||
def test_results():
|
||||
statepoint = glob.glob(cwd + '/statepoint.20.*')
|
||||
statepoint = glob.glob(os.path.join(cwd, 'statepoint.20.*'))
|
||||
call(['python', 'results.py', statepoint[0]])
|
||||
compare = filecmp.cmp('results_test.dat', 'results_true.dat')
|
||||
if not compare:
|
||||
|
|
@ -45,9 +45,9 @@ def test_results():
|
|||
|
||||
|
||||
def teardown():
|
||||
output = glob.glob(cwd + '/statepoint.20.*')
|
||||
output.append(cwd + '/tallies.out')
|
||||
output.append(cwd + '/results_test.dat')
|
||||
output = glob.glob(os.path.join(cwd, 'statepoint.20.*'))
|
||||
output.append(os.path.join(cwd, 'tallies.out'))
|
||||
output.append(os.path.join(cwd, 'results_test.dat'))
|
||||
for f in output:
|
||||
if os.path.exists(f):
|
||||
os.remove(f)
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
|
||||
<material id="1">
|
||||
<density value="4.5" units="g/cc" />
|
||||
<nuclide name="U-235" xs="70c" ao="1.0" />
|
||||
<nuclide name="U-235" xs="71c" ao="1.0" />
|
||||
</material>
|
||||
|
||||
</materials>
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
k-combined:
|
||||
2.937103E-01 7.391597E-03
|
||||
2.915988E-01 9.628515E-03
|
||||
tallies:
|
||||
6.267771E+01
|
||||
4.928030E+02
|
||||
6.325678E+01
|
||||
5.045863E+02
|
||||
|
|
|
|||
|
|
@ -24,16 +24,16 @@ def test_run():
|
|||
assert returncode == 0, 'OpenMC did not exit successfully.'
|
||||
|
||||
def test_created_statepoint():
|
||||
statepoint = glob.glob(cwd + '/statepoint.10.*')
|
||||
statepoint = glob.glob(os.path.join(cwd, 'statepoint.10.*'))
|
||||
assert len(statepoint) == 1, 'Either multiple or no statepoint files exist.'
|
||||
assert statepoint[0].endswith('binary') or statepoint[0].endswith('h5'),\
|
||||
'Statepoint file is not a binary or hdf5 file.'
|
||||
|
||||
def test_created_output():
|
||||
assert os.path.exists(cwd + '/tallies.out'), 'Tally output file does not exist.'
|
||||
assert os.path.exists(os.path.join(cwd, 'tallies.out')), 'Tally output file does not exist.'
|
||||
|
||||
def test_results():
|
||||
statepoint = glob.glob(cwd + '/statepoint.10.*')
|
||||
statepoint = glob.glob(os.path.join(cwd, 'statepoint.10.*'))
|
||||
call(['python', 'results.py', statepoint[0]])
|
||||
compare = filecmp.cmp('results_test.dat', 'results_true.dat')
|
||||
if not compare:
|
||||
|
|
@ -41,9 +41,9 @@ def test_results():
|
|||
assert compare, 'Results do not agree.'
|
||||
|
||||
def teardown():
|
||||
output = glob.glob(cwd + '/statepoint.10.*')
|
||||
output.append(cwd + '/results_test.dat')
|
||||
output.append(cwd + '/tallies.out')
|
||||
output = glob.glob(os.path.join(cwd, 'statepoint.10.*'))
|
||||
output.append(os.path.join(cwd, 'results_test.dat'))
|
||||
output.append(os.path.join(cwd, 'tallies.out'))
|
||||
for f in output:
|
||||
if os.path.exists(f):
|
||||
os.remove(f)
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
|
||||
<material id="1">
|
||||
<density value="0.1" units="atom/b-cm" />
|
||||
<nuclide name="U-235" xs="70c" ao="1.0" />
|
||||
<nuclide name="U-235" xs="71c" ao="1.0" />
|
||||
</material>
|
||||
|
||||
</materials>
|
||||
|
|
|
|||
|
|
@ -1,2 +1,2 @@
|
|||
k-combined:
|
||||
1.739614E+00 1.281892E-02
|
||||
1.779878E+00 8.291702E-03
|
||||
|
|
|
|||
|
|
@ -24,13 +24,13 @@ def test_run():
|
|||
assert returncode == 0, 'OpenMC did not exit successfully.'
|
||||
|
||||
def test_created_statepoint():
|
||||
statepoint = glob.glob(cwd + '/statepoint.10.*')
|
||||
statepoint = glob.glob(os.path.join(cwd, 'statepoint.10.*'))
|
||||
assert len(statepoint) == 1, 'Either multiple or no statepoint files exist.'
|
||||
assert statepoint[0].endswith('binary') or statepoint[0].endswith('h5'),\
|
||||
'Statepoint file is not a binary or hdf5 file.'
|
||||
|
||||
def test_results():
|
||||
statepoint = glob.glob(cwd + '/statepoint.10.*')
|
||||
statepoint = glob.glob(os.path.join(cwd, 'statepoint.10.*'))
|
||||
call(['python', 'results.py', statepoint[0]])
|
||||
compare = filecmp.cmp('results_test.dat', 'results_true.dat')
|
||||
if not compare:
|
||||
|
|
@ -38,8 +38,8 @@ def test_results():
|
|||
assert compare, 'Results do not agree.'
|
||||
|
||||
def teardown():
|
||||
output = glob.glob(cwd + '/statepoint.10.*')
|
||||
output.append(cwd + '/results_test.dat')
|
||||
output = glob.glob(os.path.join(cwd, 'statepoint.10.*'))
|
||||
output.append(os.path.join(cwd, 'results_test.dat'))
|
||||
for f in output:
|
||||
if os.path.exists(f):
|
||||
os.remove(f)
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
|
||||
<material id="1">
|
||||
<density value="4.5e22" units="atom/cm3" />
|
||||
<nuclide name="U-235" xs="70c" ao="1.0" />
|
||||
<nuclide name="U-235" xs="71c" ao="1.0" />
|
||||
</material>
|
||||
|
||||
</materials>
|
||||
|
|
|
|||
|
|
@ -1,2 +1,2 @@
|
|||
k-combined:
|
||||
1.081464E+00 2.283652E-02
|
||||
1.098761E+00 5.359381E-03
|
||||
|
|
|
|||
|
|
@ -24,13 +24,13 @@ def test_run():
|
|||
assert returncode == 0, 'OpenMC did not exit successfully.'
|
||||
|
||||
def test_created_statepoint():
|
||||
statepoint = glob.glob(cwd + '/statepoint.10.*')
|
||||
statepoint = glob.glob(os.path.join(cwd, 'statepoint.10.*'))
|
||||
assert len(statepoint) == 1, 'Either multiple or no statepoint files exist.'
|
||||
assert statepoint[0].endswith('binary') or statepoint[0].endswith('h5'),\
|
||||
'Statepoint file is not a binary or hdf5 file.'
|
||||
|
||||
def test_results():
|
||||
statepoint = glob.glob(cwd + '/statepoint.10.*')
|
||||
statepoint = glob.glob(os.path.join(cwd, 'statepoint.10.*'))
|
||||
call(['python', 'results.py', statepoint[0]])
|
||||
compare = filecmp.cmp('results_test.dat', 'results_true.dat')
|
||||
if not compare:
|
||||
|
|
@ -39,7 +39,7 @@ def test_results():
|
|||
|
||||
def teardown():
|
||||
output = glob.glob('statepoint.10.*')
|
||||
output.append(cwd + '/results_test.dat')
|
||||
output.append(os.path.join(cwd, 'results_test.dat'))
|
||||
for f in output:
|
||||
if os.path.exists(f):
|
||||
os.remove(f)
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
|
||||
<material id="1">
|
||||
<density value="12.3e3" units="kg/m3" />
|
||||
<nuclide name="U-235" xs="70c" ao="1.0" />
|
||||
<nuclide name="U-235" xs="71c" ao="1.0" />
|
||||
</material>
|
||||
|
||||
</materials>
|
||||
|
|
|
|||
|
|
@ -1,2 +1,2 @@
|
|||
k-combined:
|
||||
8.058880E-01 5.121476E-03
|
||||
8.114338E-01 1.672180E-02
|
||||
|
|
|
|||
|
|
@ -24,13 +24,13 @@ def test_run():
|
|||
assert returncode == 0, 'OpenMC did not exit successfully.'
|
||||
|
||||
def test_created_statepoint():
|
||||
statepoint = glob.glob(cwd + '/statepoint.10.*')
|
||||
statepoint = glob.glob(os.path.join(cwd, 'statepoint.10.*'))
|
||||
assert len(statepoint) == 1, 'Either multiple or no statepoint files exist.'
|
||||
assert statepoint[0].endswith('binary') or statepoint[0].endswith('h5'),\
|
||||
'Statepoint file is not a binary or hdf5 file.'
|
||||
|
||||
def test_results():
|
||||
statepoint = glob.glob(cwd + '/statepoint.10.*')
|
||||
statepoint = glob.glob(os.path.join(cwd, 'statepoint.10.*'))
|
||||
call(['python', 'results.py', statepoint[0]])
|
||||
compare = filecmp.cmp('results_test.dat', 'results_true.dat')
|
||||
if not compare:
|
||||
|
|
@ -38,8 +38,8 @@ def test_results():
|
|||
assert compare, 'Results do not agree.'
|
||||
|
||||
def teardown():
|
||||
output = glob.glob(cwd + '/statepoint.10.*')
|
||||
output.append(cwd + '/results_test.dat')
|
||||
output = glob.glob(os.path.join(cwd, 'statepoint.10.*'))
|
||||
output.append(os.path.join(cwd, 'results_test.dat'))
|
||||
for f in output:
|
||||
if os.path.exists(f):
|
||||
os.remove(f)
|
||||
|
|
|
|||
|
|
@ -3,9 +3,9 @@
|
|||
|
||||
<material id="1">
|
||||
<density units="sum" />
|
||||
<nuclide name="U-235" xs="70c" ao="0.3e-2" />
|
||||
<nuclide name="U-238" xs="70c" ao="0.5e-1" />
|
||||
<nuclide name="H-1" xs="70c" ao="0.1e-2" />
|
||||
<nuclide name="U-235" xs="71c" ao="0.3e-2" />
|
||||
<nuclide name="U-238" xs="71c" ao="0.5e-1" />
|
||||
<nuclide name="H-1" xs="71c" ao="0.1e-2" />
|
||||
</material>
|
||||
|
||||
</materials>
|
||||
|
|
|
|||
|
|
@ -1,2 +1,2 @@
|
|||
k-combined:
|
||||
3.166569E-01 6.367411E-03
|
||||
3.256817E-01 7.456300E-03
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ def test_run():
|
|||
assert returncode == 0, 'OpenMC did not exit successfully.'
|
||||
|
||||
def test_created_statepoint():
|
||||
statepoint = glob.glob(cwd + '/statepoint.10.*')
|
||||
statepoint = glob.glob(os.path.join(cwd, 'statepoint.10.*'))
|
||||
assert len(statepoint) == 1, 'Either multiple or no statepoint files exist.'
|
||||
assert statepoint[0].endswith('binary') or statepoint[0].endswith('h5'),\
|
||||
'Statepoint file is not a binary or hdf5 file.'
|
||||
|
|
@ -38,8 +38,8 @@ def test_results():
|
|||
assert compare, 'Results do not agree.'
|
||||
|
||||
def teardown():
|
||||
output = glob.glob(cwd + '/statepoint.10.*')
|
||||
output.append(cwd + '/results_test.dat')
|
||||
output = glob.glob(os.path.join(cwd, 'statepoint.10.*'))
|
||||
output.append(os.path.join(cwd, 'results_test.dat'))
|
||||
for f in output:
|
||||
if os.path.exists(f):
|
||||
os.remove(f)
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
|
||||
<material id="1">
|
||||
<density value="4.5" units="g/cc" />
|
||||
<nuclide name="U-235" xs="70c" ao="1.0" />
|
||||
<nuclide name="U-235" xs="71c" ao="1.0" />
|
||||
</material>
|
||||
|
||||
</materials>
|
||||
|
|
|
|||
|
|
@ -1,2 +1,2 @@
|
|||
k-combined:
|
||||
3.004375E-01 2.308696E-03
|
||||
3.001498E-01 8.253404E-04
|
||||
|
|
|
|||
|
|
@ -24,13 +24,13 @@ def test_run():
|
|||
assert returncode == 0, 'OpenMC did not exit successfully.'
|
||||
|
||||
def test_created_statepoint():
|
||||
statepoint = glob.glob(cwd + '/statepoint.7.*')
|
||||
statepoint = glob.glob(os.path.join(cwd, 'statepoint.7.*'))
|
||||
assert len(statepoint) == 1, 'Either multiple or no statepoint files exist.'
|
||||
assert statepoint[0].endswith('binary') or statepoint[0].endswith('h5'),\
|
||||
'Statepoint file is not a binary or hdf5 file.'
|
||||
|
||||
def test_results():
|
||||
statepoint = glob.glob(cwd + '/statepoint.7.*')
|
||||
statepoint = glob.glob(os.path.join(cwd, 'statepoint.7.*'))
|
||||
call(['python', 'results.py', statepoint[0]])
|
||||
compare = filecmp.cmp('results_test.dat', 'results_true.dat')
|
||||
if not compare:
|
||||
|
|
@ -38,8 +38,8 @@ def test_results():
|
|||
assert compare, 'Results do not agree.'
|
||||
|
||||
def teardown():
|
||||
output = glob.glob(cwd + '/statepoint.7.*')
|
||||
output.append(cwd + '/results_test.dat')
|
||||
output = glob.glob(os.path.join(cwd, 'statepoint.7.*'))
|
||||
output.append(os.path.join(cwd, 'results_test.dat'))
|
||||
for f in output:
|
||||
if os.path.exists(f):
|
||||
os.remove(f)
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show more
Loading…
Add table
Add a link
Reference in a new issue