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

Merge branch 'release-0.6.0'

Browse source
This commit is contained in:
Paul Romano 2014-07-08 22:53:42 -04:00
commit 8406340972
396 changed files with 197764 additions and 229383 deletions
Download patch file Download diff file Expand all files Collapse all files

9
.gitignore vendored
View file

@ -21,6 +21,12 @@ src/openmc
docs/build
docs/source/_images/*.pdf
# Source build
src/build
# build from src/utils/setup.py
src/utils/build
# xml-fortran reader
src/xml-fortran/xmlreader
@ -32,3 +38,6 @@ results_error.dat
# HDF5 files
*.h5
# Data downloaded from NNDC
data/nndc

3
.gitmodules vendored Normal file
View file

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

59
data/get_nndc_data.py
View file

@ -6,17 +6,19 @@ 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',
'ENDF-B-VII.1-neutron-900K.tar.gz',
'ENDF-B-VII.1-neutron-1500K.tar.gz',
'ENDF-B-VII.1-tsl.tar.gz']
block_size = 16384
@ -73,6 +75,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 +107,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)

4
docs/source/conf.py
View file

@ -46,9 +46,9 @@ copyright = u'2011-2014, Massachusetts Institute of Technology'
# built documents.
#
# The short X.Y version.
version = "0.5"
version = "0.6"
# The full version, including alpha/beta/rc tags.
release = "0.5.3"
release = "0.6.0"
# The language for content autogenerated by Sphinx. Refer to documentation
# for a list of supported languages.

2
docs/source/devguide/index.rst
View file

@ -10,7 +10,7 @@ as debugging.
.. toctree::
:numbered:
:maxdepth: 2
:maxdepth: 3
structures
styleguide

132
docs/source/devguide/workflow.rst
View file

@ -38,7 +38,7 @@ following criteria must be satisfied for all proposed changes:
- Changes have a clear purpose and are useful.
- Compiles under all conditions (MPI, OpenMP, HDF5, etc.). This is checked as
part of the test suite (see `test_compile.py`_).
part of the test suite.
- Passes the regression suite.
- If appropriate, test cases are added to regression suite.
- No memory leaks (checked with valgrind_).
@ -91,6 +91,133 @@ features and bug fixes. The general steps for contributing are as follows:
6. After the pull request has been thoroughly vetted, it is merged back into the
*develop* branch of mit-crpg/openmc.
.. _test suite:
OpenMC Test Suite
-----------------
The purpose of this test suite is to ensure that OpenMC compiles using various
combinations of compiler flags and options, and that all user input options can
be used successfully without breaking the code. The test suite is comprised of
regression tests where different types of input files are configured and the
full OpenMC code is executed. Results from simulations are compared with
expected results. The test suite is comprised of many build configurations
(e.g. debug, mpi, hdf5) and the actual tests which reside in sub-directories
in the tests directory. We recommend to developers to test their branches
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
cd build
make test
or
.. code-block:: sh
cd build
ctest
There are numerous ctest_ command line options that can be set to have
more control over which tests are executed.
Before running the test suite python script, the following environmental
variables should be set if the default paths are incorrect:
* **FC** - The command of the Fortran compiler (e.g. gfotran, ifort).
* Default - *gfortran*
* **MPI_DIR** - The path to the MPI directory.
* Default - */opt/mpich/3.1-gnu*
* **HDF5_DIR** - The path to the HDF5 directory.
* Default - */opt/hdf5/1.8.12-gnu*
* **PHDF5_DIR** - The path to the parallel HDF5 directory.
* Default - */opt/phdf5/1.8.12-gnu*
* **PETSC_DIR** - The path to the PETSc directory.
* Default - */opt/petsc/3.4.4-gnu*
To run the full test suite, the following command can be executed in the
tests directory:
.. code-block:: sh
python run_tests.py
A subset of build configurations and/or tests can be run. To see how to use
the script run:
.. code-block:: sh
python run_tests.py --help
As an example, say we want to run all tests with debug flags only on tests
that have cone and plot in their name. Also, we would like to run this on
4 processors. We can run:
.. code-block:: sh
python run_tests.py -j 4 -C debug -R "cone|plot"
Note that standard regular expression syntax is used for selecting build
configurations and tests. To print out a list of build configurations, we
can run:
.. code-block:: sh
python run_tests.py -p
Adding tests to test suite
++++++++++++++++++++++++++
To add a new test to the test suite, create a sub-directory in the tests
directory that conforms to the regular expression *test_*. To configure
a test you need to add the following files to your new test directory,
*test_name* for example:
* OpenMC input XML files
* **test_name.py** - python test driver script, please refer to other
tests to see how to construct. Any output files that are generated
during testing must be removed at the end of this script.
* **results.py** - python script that extracts results from statepoint
output files. By default it should look for a binary file, but can
take an argument to overwrite which statepoint file is processed,
whether it is at a different batch or with an HDF5 extension. This
script must output a results file that is named *results_test.dat*.
It is recommended that any real numbers reported use *12.6E* format.
* **results_true.dat** - ASCII file that contains the expected results
from the test. The file *results_test.dat* is compared to this file
during the execution of the python test driver script. When the
above files have been created, generate a *results_test.dat* file and
copy it to this name and commit. It should be noted that this file
should be generated with basic compiler options during openmc
configuration and build (e.g., no MPI/HDF5, no debug/optimization).
In addition to this description, please see the various types of tests that
are already included in the test suite to see how to create them. If all is
implemented correctly, the new test directory will automatically be added
to the CTest framework.
Private Development
-------------------
@ -108,10 +235,11 @@ from your private repository into a public fork.
.. _git: http://git-scm.com/
.. _GitHub: https://github.com/
.. _git flow: http://nvie.com/git-model
.. _test_compile.py: https://github.com/mit-crpg/openmc/blob/develop/tests/test_compile/test_compile.py
.. _valgrind: http://valgrind.org/
.. _style guide: http://mit-crpg.github.io/openmc/devguide/styleguide.html
.. _pull request: https://help.github.com/articles/using-pull-requests
.. _mit-crpg/openmc: https://github.com/mit-crpg/openmc
.. _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

92
docs/source/devguide/xml-parsing.rst
View file

@ -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

14
docs/source/publications.rst
View file

@ -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,"
@ -28,23 +28,25 @@ Publications
- Paul K. Romano, Benoit Forget, Kord Smith, and Andrew Siegel, "On the use of
tally servers in Monte Carlo simulations of light-water reactors,"
*Proc. Joint International Conference on Supercomputing in Nuclear
Applications and Monte Carlo*, Paris, France, Oct. 27--31 (2013).
Applications and Monte Carlo*, Paris, France, Oct. 27--31
(2013). `<http://dx.doi.org/10.1051/snamc/201404301>`_
- Paul K. Romano, Nicholas E. Horelik, Bryan R. Herman, Adam G. Nelson, Benoit
Forget, and Kord Smith, "OpenMC: A State-of-the-Art Monte Carlo Code for
Research and Development," *Proc. Joint International Conference on
Supercomputing in Nuclear Applications and Monte Carlo*, Paris, France,
Oct. 27--31 (2013).
Oct. 27--31 (2013). `<http://dx.doi.org/10.1051/snamc/201406016>`_
- Kyle G. Felker, Andrew R. Siegel, Kord S. Smith, Paul K. Romano, and Benoit
Forget, "The energy band memory server algorithm for parallel Monte Carlo
calculations," *Proc. Joint International Conference on Supercomputing in
Nuclear Applications and Monte Carlo*, Paris, France, Oct. 27--31 (2013).
Nuclear Applications and Monte Carlo*, Paris, France, Oct. 27--31
(2013). `<http://dx.doi.org/10.1051/snamc/201404207>`_
- John R. Tramm and Andrew R. Siegel, "Memory Bottlenecks and Memory Contention
in Multi-Core Monte Carlo Transport Codes," *Proc. Joint International
Conference on Supercomputing in Nuclear Applications and Monte Carlo*, Paris,
France, Oct. 27--31 (2013).
France, Oct. 27--31 (2013). `<http://dx.doi.org/10.1051/snamc/201404208>`_
- Andrew R. Siegel, Kord Smith, Paul K. Romano, Benoit Forget, and Kyle Felker,
"Multi-core performance studies of a Monte Carlo neutron transport code,"

1
docs/source/releasenotes/index.rst
View file

@ -10,6 +10,7 @@ bugs fixed, and known issues for each successive release.
.. toctree::
:maxdepth: 1
notes_0.6.0
notes_0.5.4
notes_0.5.3
notes_0.5.2

59
docs/source/releasenotes/notes_0.6.0.rst Normal file
View file

@ -0,0 +1,59 @@
.. _notes_0.6.0:
==============================
Release Notes for OpenMC 0.6.0
==============================
-------------------
System Requirements
-------------------
There are no special requirements for running the OpenMC code. As of this
release, OpenMC has been tested on a variety of Linux distributions, Mac OS X,
and Microsoft Windows 7. Memory requirements will vary depending on the size of
the problem at hand (mostly on the number of nuclides in the problem).
------------
New Features
------------
- Legendre and spherical harmonic expansion tally scores
- CMake is now default build system
- Regression test suite based on CTests and NNDC cross sections
- FoX is now a git submodule
- Support for older cross sections (e.g. MCNP 66c)
- Progress bar for plots
- Expanded support for natural elements via <natural_elements> in settings.xml
---------
Bug Fixes
---------
- 41f7ca_: Fixed erroneous results from survival biasing
- 038736_: Fix tallies over void materials
- 46f9e8_: Check for negative values in probability tables
- d1ca35_: Fixed sampling of angular distribution
- 0291c0_: Fixed indexing error in plotting
- d7a7d0_: Fix bug with <element> specifying xs attribute
- 85b3cb_: Fix out-of-bounds error with OpenMP threading
.. _41f7ca: https://github.com/mit-crpg/openmc/commit/41f7ca
.. _038736: https://github.com/mit-crpg/openmc/commit/038736
.. _46f9e8: https://github.com/mit-crpg/openmc/commit/46f9e8
.. _d1ca35: https://github.com/mit-crpg/openmc/commit/d1ca35
.. _0291c0: https://github.com/mit-crpg/openmc/commit/0291c0
.. _d7a7d0: https://github.com/mit-crpg/openmc/commit/d7a7d0
.. _85b3cb: https://github.com/mit-crpg/openmc/commit/85b3cb
------------
Contributors
------------
This release contains new contributions from the following people:
- `Sterling Harper <smharper@mit.edu>`_
- `Bryan Herman <bherman@mit.edu>`_
- `Nick Horelik <nhorelik@mit.edu>`_
- `Adam Nelson <nelsonag@umich.edu>`_
- `Paul Romano <paul.k.romano@gmail.com>`_
- `Jon Walsh <walshjon@mit.edu>`_

222
docs/source/usersguide/input.rst
View file

@ -41,7 +41,7 @@ for the geometry, materials, and settings. Additionally, there are three optiona
input files. The first is a tallies XML file that specifies physical quantities
to be tallied. The second is a plots XML file that specifies regions of geometry
which should be plotted. The third is a CMFD XML file that specifies coarse mesh
acceleration geometry and execution parameters. OpenMC expects that these
acceleration geometry and execution parameters. OpenMC expects that these
files are called:
* ``geometry.xml``
@ -105,7 +105,7 @@ default. This element has the following attributes/sub-elements:
The ``<eigenvalue>`` element indicates that a :math:`k`-eigenvalue calculation
should be performed. It has the following attributes/sub-elements:
:batches:
:batches:
The total number of batches, where each batch corresponds to multiple
fission source iterations. Batching is done to eliminate correlation between
realizations of random variables.
@ -171,7 +171,7 @@ problem. It has the following attributes/sub-elements:
The ``<fixed_source>`` element indicates that a fixed source calculation should be
performed. It has the following attributes/sub-elements:
:batches:
:batches:
The total number of batches. For fixed source calculations, each batch
represents a realization of random variables for tallies.
@ -182,6 +182,29 @@ performed. It has the following attributes/sub-elements:
*Default*: None
.. _natural_elements:
``<natural_elements>`` Element
------------------------------
The ``<natural_elements>`` element indicates to OpenMC what nuclides are
available in the cross section library when expanding an ``<element>`` into
separate isotopes (see :ref:`material`). The accepted values are:
- ENDF/B-VII.0
- ENDF/B-VII.1
- JEFF-3.1.1
- JEFF-3.1.2
- JEFF-3.2
- JENDL-3.2
- JENDL-3.3
- JENDL-4.0
Note that the value is case-insensitive, so "ENDF/B-VII.1" is equivalent to
"endf/b-vii.1".
*Default*: ENDF/B-VII.1
``<no_reduce>`` Element
-----------------------
@ -206,7 +229,7 @@ out the file and "false" will not.
*Default*: false
:summary:
:summary:
Writes out an ASCII summary file describing all of the user input files that
were read in.
@ -274,7 +297,7 @@ attributes/sub-elements:
An element specifying the spatial distribution of source sites. This element
has the following attributes:
:type:
:type:
The type of spatial distribution. Valid options are "box" and "point". A
"box" spatial distribution has coordinates sampled uniformly in a
parallelepiped. A "point" spatial distribution has coordinates specified
@ -298,7 +321,7 @@ attributes/sub-elements:
An element specifying the angular distribution of source sites. This element
has the following attributes:
:type:
:type:
The type of angular distribution. Valid options are "isotropic" and
"monodirectional". The angle of the particle emitted from a source site is
isotropic if the "isotropic" option is given. The angle of the particle
@ -321,7 +344,7 @@ attributes/sub-elements:
An element specifying the energy distribution of source sites. This element
has the following attributes:
:type:
:type:
The type of energy distribution. Valid options are "monoenergetic",
"watt", and "maxwell". The "monoenergetic" option produces source sites at
@ -350,8 +373,8 @@ attributes/sub-elements:
The ``<state_point>`` element indicates at what batches a state point file
should be written. A state point file can be used to restart a run or to get
tally results at any batch. The default behavior when using this tag is to
write out the source bank in the state_point file. This behavior can be
tally results at any batch. The default behavior when using this tag is to
write out the source bank in the state_point file. This behavior can be
customized by using the ``<source_point>`` element. This element has the
following attributes/sub-elements:
@ -371,28 +394,29 @@ following attributes/sub-elements:
``<source_point>`` Element
--------------------------
The ``<source_point>`` element indicates at what batches the source bank
should be written. The source bank can be either written out within a state
The ``<source_point>`` element indicates at what batches the source bank
should be written. The source bank can be either written out within a state
point file or separately in a source point file. This element has the following
attributes/sub-elements:
:batches:
A list of integers separated by spaces indicating at what batches a state
point file should be written. It should be noted that if source_separate
tag is not set to "true", this list must be a subset of state point batches.
point file should be written. It should be noted that if the ``separate``
attribute is not set to "true", this list must be a subset of state point
batches.
*Default*: Last batch only
:interval:
A single integer :math:`n` indicating that a state point should be written
every :math:`n` batches. This option can be given in lieu of listing
batches explicitly. It should be noted that if source_separate tag is not
set to "true", this value should produce a list of batches that is a subset
of state point batches.
every :math:`n` batches. This option can be given in lieu of listing batches
explicitly. It should be noted that if the ``separate`` attribute is not set
to "true", this value should produce a list of batches that is a subset of
state point batches.
*Default*: None
:source_separate:
:separate:
If this element is set to "true", a separate binary source point file will be
written. Otherwise, the source sites will be written in the state point
directly.
@ -401,17 +425,17 @@ attributes/sub-elements:
:source_write:
If this element is set to "false", source sites are not written
to the state point or source point file. This can substantially reduce the
to the state point or source point file. This can substantially reduce the
size of state points if large numbers of particles per batch are used.
*Default*: true
:overwrite_latest:
If this element is set to "true", a source point file containing
the source bank will be written out to a separate file named
``source.binary`` or ``source.h5`` depending on if HDF5 is enabled.
the source bank will be written out to a separate file named
``source.binary`` or ``source.h5`` depending on if HDF5 is enabled.
This file will be overwritten at every single batch so that the latest
source bank will be available. It should be noted that a user can set both
source bank will be available. It should be noted that a user can set both
this element to "true" and specify batches to write a permanent source bank.
*Default*: false
@ -741,6 +765,8 @@ sub-elements:
Materials Specification -- materials.xml
----------------------------------------
.. _material:
``<material>`` Element
----------------------
@ -780,12 +806,13 @@ Each ``material`` element can have the following attributes or sub-elements:
:element:
Specifies that a natural element is present in the material. The natural
element is split up into individual isotopes based on IUPAC Isotopic
Compositions of the Elements 1997. This element has attributes/sub-elements
called ``name``, ``xs``, and ``ao``. The ``name`` attribute is the atomic
symbol of the element while the ``xs`` attribute is the cross-section
identifier. Finally, the ``ao`` attribute specifies the atom percent of the
element within the material, respectively. One example would be as follows:
element is split up into individual isotopes based on `IUPAC Isotopic
Compositions of the Elements 2009`_. This element has
attributes/sub-elements called ``name``, ``xs``, and ``ao``. The ``name``
attribute is the atomic symbol of the element while the ``xs`` attribute is
the cross-section identifier. Finally, the ``ao`` attribute specifies the
atom percent of the element within the material, respectively. One example
would be as follows:
.. code-block:: xml
@ -794,6 +821,10 @@ Each ``material`` element can have the following attributes or sub-elements:
<element name="Mn" ao="2.7426e-05" />
<element name="Cu" ao="1.6993e-04" />
In some cross section libraries, certain naturally occurring isotopes do not
have cross sections. The :ref:`natural_elements` option determines how a
natural element is split into isotopes in these cases.
*Default*: None
@ -805,6 +836,9 @@ Each ``material`` element can have the following attributes or sub-elements:
*Default*: None
.. _IUPAC Isotopic Compositions of the Elements 2009:
http://pac.iupac.org/publications/pac/pdf/2011/pdf/8302x0397.pdf
``<default_xs>`` Element
------------------------
@ -845,7 +879,7 @@ The ``<tally>`` element accepts the following sub-elements:
:label:
This is an optional sub-element specifying the name of this tally to be used
for output purposes. This string is limited to 52 characters for formatting
for output purposes. This string is limited to 52 characters for formatting
purposes.
:filter:
@ -915,10 +949,11 @@ The ``<tally>`` element accepts the following sub-elements:
:scores:
A space-separated list of the desired responses to be accumulated. Accepted
options are "flux", "total", "scatter", "nu-scatter", "scatter-N",
"scatter-PN", "absorption", "fission", "nu-fission", "kappa-fission",
"current", and "events". These corresponding to the following physical
quantities.
options are "flux", "total", "scatter", "absorption", "fission",
"nu-fission", "kappa-fission", "nu-scatter", "scatter-N", "scatter-PN",
"scatter-YN", "nu-scatter-N", "nu-scatter-PN", "nu-scatter-YN", "flux-YN",
"total-YN", "current", and "events". These corresponding to the following
physical quantities:
:flux:
Total flux
@ -930,24 +965,6 @@ The ``<tally>`` element accepts the following sub-elements:
Total scattering rate. Can also be identified with the ``scatter-0``
response type.
:nu-scatter:
Total production of neutrons due to scattering. This accounts for
multiplicity from (n,2n), (n,3n), and (n,4n) reactions and should be
slightly higher than the scattering rate.
:scatter-N:
Tally the N\ :sup:`th` \ scattering moment, where N is the Legendre
expansion order. N must be between 0 and 10. As an example, tallying the
2\ :sup:`nd` \ scattering moment would be specified as ``<scores>
scatter-2 </scores>``.
:scatter-PN:
Tally all of the scattering moments from order 0 to N, where N is the
Legendre expansion order. That is, ``scatter-P1`` is equivalent to
requesting tallies of ``scatter-0`` and ``scatter-1``. N must be between
0 and 10. As an example, tallying up to the 2\ :sup:`nd` \ scattering
moment would be specified as ``<scores> scatter-P2 </scores>``.
:absorption:
Total absorption rate. This accounts for all reactions which do not
produce secondary neutrons.
@ -957,7 +974,7 @@ The ``<tally>`` element accepts the following sub-elements:
:nu-fission:
Total production of neutrons due to fission
:kappa-fission:
The recoverable energy production rate due to fission. The recoverable
energy is defined as the fission product kinetic energy, prompt and
@ -967,6 +984,47 @@ The ``<tally>`` element accepts the following sub-elements:
prompt and delayed :math:`\gamma`-rays are assumed to deposit their energy
locally.
:scatter-N:
Tally the N\ :sup:`th` \ scattering moment, where N is the Legendre
expansion order of the change in particle angle :math:`\left(\mu\right)`.
N must be between 0 and 10. As an example, tallying the
2\ :sup:`nd` \ scattering moment would be specified as
``<scores> scatter-2 </scores>``.
:scatter-PN:
Tally all of the scattering moments from order 0 to N, where N is the
Legendre expansion order of the change in particle angle :math:`\left(\mu\right)`.
That is, ``scatter-P1`` is equivalent to requesting tallies of
``scatter-0`` and ``scatter-1``. Like for ``scatter-N``,
N must be between 0 and 10. As an example, tallying up to the
2\ :sup:`nd` \ scattering moment would be specified as
``<scores> scatter-P2 </scores>``.
:scatter-YN:
``scatter-YN`` is similar to ``scatter-PN`` except an additional
expansion is performed for the incoming particle direction
:math:`\left(\Omega\right)` using the real spherical harmonics. This is useful
for performing angular flux moment weighting of the scattering moments.
Like ``scatter-PN``, ``scatter-YN`` will tally all of the moments from
order 0 to N; N again must be between 0 and 10.
:nu-scatter, nu-scatter-N, nu-scatter-PN, nu-scatter-YN:
These scores are similar in functionality to their ``scatter*``
equivalents except the total production of neutrons due to
scattering is scored vice simply the scattering rate. This accounts for
multiplicity from (n,2n), (n,3n), and (n,4n) reactions.
:flux-YN:
Spherical harmonic expansion of the direction of motion
:math:`\left(\Omega\right)` of the total flux. This score will tally
all of the harmonic moments of order 0 to N. N must be between 0 and 10.
:total-YN:
Spherical harmonic expansion of the incoming particle's direction of
motion :math:`\left(\Omega\right)` of the total flux. This score will
tally all of the harmonic moments of order 0 to N. N must be between 0
and 10.
:current:
Partial currents on the boundaries of each cell in a mesh.
@ -1137,7 +1195,7 @@ attributes or sub-elements. These are not used in "voxel" plots:
Any number of this optional tag may be included in each ``<plot>`` element,
which can override the default random colors for cells or materials. Each
``col_spec`` element must contain ``id`` and ``rgb`` sub-elements.
:id:
Specifies the cell or material unique id for the color specification.
@ -1174,20 +1232,20 @@ attributes or sub-elements. These are not used in "voxel" plots:
------------------------------
CMFD Specification -- cmfd.xml
------------------------------
Coarse mesh finite difference acceleration method has been implemented in OpenMC.
Currently, it allows users to accelerate fission source convergence during
inactive neutron batches. To run CMFD, the ``<run_cmfd>`` element in
Currently, it allows users to accelerate fission source convergence during
inactive neutron batches. To run CMFD, the ``<run_cmfd>`` element in
``settings.xml`` should be set to "true".
``<active_flush>`` Element
--------------------------
The ``<active_flush>`` element controls the batch where CMFD tallies should be
reset. CMFD tallies should be reset before active batches so they are accumulated
reset. CMFD tallies should be reset before active batches so they are accumulated
without bias.
*Default*: 0
*Default*: 0
``<begin>`` Element
-------------------
@ -1224,9 +1282,9 @@ It can be turned on with "true" and off with "false".
``<inactive>`` Element
----------------------
The ``<inactive>`` element controls if cmfd tallies should be accumulated
during inactive batches. For some applications, CMFD tallies may not be
needed until the start of active batches. This option can be turned on
The ``<inactive>`` element controls if cmfd tallies should be accumulated
during inactive batches. For some applications, CMFD tallies may not be
needed until the start of active batches. This option can be turned on
with "true" and off with "false"
*Default*: true
@ -1243,12 +1301,12 @@ occurs. The amout of resets is controlled with the ``<num_flushes>`` element.
``<ksp_monitor>`` Element
-------------------------
The ``<ksp_monitor>`` element is used to view the convergence of linear GMRES
iterations in PETSc. This option can be turned on with "true" and turned off
The ``<ksp_monitor>`` element is used to view the convergence of linear GMRES
iterations in PETSc. This option can be turned on with "true" and turned off
with "false".
*Default*: false
*Default*: false
``<mesh>`` Element
------------------
@ -1261,7 +1319,7 @@ attributes/sub-elements:
given, it is assumed that the mesh is an x-y mesh.
:upper_right:
The upper-right corner of the structrued mesh. If only two coordinate are
The upper-right corner of the structrued mesh. If only two coordinate are
given, it is assumed that the mesh is an x-y mesh.
:dimension:
@ -1272,8 +1330,8 @@ attributes/sub-elements:
:energy:
Energy bins [in MeV], listed in ascending order (e.g. 0.0 0.625e-7 20.0)
for CMFD tallies and acceleration. If no energy bins are listed, OpenMC
automatically assumes a one energy group calculation over the entire
for CMFD tallies and acceleration. If no energy bins are listed, OpenMC
automatically assumes a one energy group calculation over the entire
energy range.
:albedo:
@ -1283,10 +1341,10 @@ attributes/sub-elements:
*Default*: 1.0 1.0 1.0 1.0 1.0 1.0
:map:
An optional acceleration map can be specified to overlay on the coarse
mesh spatial grid. If this option is used a ``1`` is used for a
An optional acceleration map can be specified to overlay on the coarse
mesh spatial grid. If this option is used a ``1`` is used for a
non-accelerated region and a ``2`` is used for an accelerated region.
For a simple 4x4 coarse mesh with a 2x2 fuel lattice surrounded by
For a simple 4x4 coarse mesh with a 2x2 fuel lattice surrounded by
reflector, the map is:
``1 1 1 1``
@ -1297,24 +1355,24 @@ attributes/sub-elements:
``1 1 1 1``
Therefore a 2x2 system of equations is solved rather than a 4x4. This
is extremely important to use in reflectors as neutrons will not
Therefore a 2x2 system of equations is solved rather than a 4x4. This
is extremely important to use in reflectors as neutrons will not
contribute to any tallies far away from fission source neutron regions.
A ``2`` must be used to identify any fission source region.
.. note:: Only two of the following three sub-elements are needed:
``lower_left``, ``upper_right`` and ``width``. Any combination
.. note:: Only two of the following three sub-elements are needed:
``lower_left``, ``upper_right`` and ``width``. Any combination
of two of these will yield the third.
``<norm>`` Element
------------------
The ``<norm>`` element is used to normalize the CMFD fission source distribution
to a particular value. For example, if a fission source is calculated for a
17 x 17 lattice of pins, the fission source may be normalized to the number of
fission source regions, in this case 289. This is useful when visualizing this
distribution as the average peaking factor will be unity. This parameter will
not impact the calculation.
The ``<norm>`` element is used to normalize the CMFD fission source distribution
to a particular value. For example, if a fission source is calculated for a
17 x 17 lattice of pins, the fission source may be normalized to the number of
fission source regions, in this case 289. This is useful when visualizing this
distribution as the average peaking factor will be unity. This parameter will
not impact the calculation.
*Default*: 1.0
@ -1329,7 +1387,7 @@ occur during inactive CMFD batches.
``<power_monitor>`` Element
---------------------------
The ``<power_monitor>`` element is used to view the convergence of power iteration.
The ``<power_monitor>`` element is used to view the convergence of power iteration.
This option can be turned on with "true" and turned off with "false".
*Default*: false
@ -1355,7 +1413,7 @@ function in PETSc. This option can be turned on with "true" and turned off with
--------------------
The ``<solver>`` element controls whether the CMFD eigenproblem is solved with
standard power iteration or nonlinear Jacobian-free Newton Krylov (JFNK).
standard power iteration or nonlinear Jacobian-free Newton Krylov (JFNK).
By setting "power", power iteration is used and by setting "jfnk", JFNK is used.
*Default*: power

151
docs/source/usersguide/install.rst
View file

@ -50,6 +50,15 @@ Prerequisites
sudo apt-get install gfortran
* CMake_ cross-platform build system
The compiling and linking of source files is handled by CMake in a
platform-independent manner. If you are using Debian or a Debian
derivative such as Ubuntu, you can install CMake using the following
command::
sudo apt-get install cmake
.. admonition:: Optional
* An MPI implementation for distributed-memory parallel runs
@ -74,8 +83,8 @@ Prerequisites
OpenMC with. HDF5_ must be built with parallel I/O features if you intend
to use HDF5_ with MPI. An example of configuring HDF5_ is listed below::
FC=/opt/mpich/3.0.4-gnu/bin/mpif90 CC=/opt/mpich/3.0.4-gnu/bin/mpicc \
./configure --prefix=/opt/hdf5/1.8.11-gnu --enable-fortran \
FC=/opt/mpich/3.1/bin/mpif90 CC=/opt/mpich/3.1/bin/mpicc \
./configure --prefix=/opt/hdf5/1.8.12 --enable-fortran \
--enable-fortran2003 --enable-parallel
You may omit ``--enable-parallel`` if you want to compile HDF5_ in serial.
@ -88,8 +97,8 @@ Prerequisites
requires PETSc_ to be configured with Fortran datatypes. An example of
configuring PETSc_ is listed below::
./configure --prefix=/opt/petsc/3.4.2-gnu --download-f-blas-lapack \
--with-mpi-dir=/opt/mpich/3.0.4-gnu/ --with-shared-libraries=0 \
./configure --prefix=/opt/petsc/3.4.4 --download-f-blas-lapack \
--with-mpi-dir=/opt/mpich/3.1 --with-shared-libraries \
--with-fortran-datatypes
The BLAS/LAPACK library is not required to be downloaded and can be linked
@ -98,6 +107,7 @@ Prerequisites
* git_ version control software for obtaining source code
.. _gfortran: http://gcc.gnu.org/wiki/GFortran
.. _CMake: http://www.cmake.org
.. _OpenMPI: http://www.open-mpi.org
.. _MPICH: http://www.mpich.org
.. _HDF5: http://www.hdfgroup.org/HDF5/
@ -131,50 +141,95 @@ switch to the source of the latest stable release, run the following commands::
Build Configuration
-------------------
All configuration for OpenMC is done within the Makefile located in
``src/Makefile``. In the Makefile, you will see that there are a number of User
Options which can be changed. It is recommended that you do not change anything
else in the Makefile unless you are experienced with compiling and building
software using Makefiles. The following parameters can be set from the User
Options sections in the Makefile:
Compiling OpenMC with CMake is carried out in two steps. First, ``cmake`` is run
to determine the compiler, whether optional packages (MPI, HDF5, PETSc) are
available, to generate a list of dependencies between source files so that they
may be compiled in the correct order, and to generate a normal Makefile. The
Makefile is then used by ``make`` to actually carry out the compile and linking
commands. A typical out-of-source build would thus look something like the
following
COMPILER
This variable tells the Makefile which compiler to use. Valid options are
gnu, intel, pgi, ibm, and cray. The default is gnu (gfortran).
.. code-block:: sh
DEBUG
mkdir src/build
cd src/build
cmake ..
make
Note that first a build directory is created as a subdirectory of the source
directory. The Makefile in ``src/`` will automatically perform an out-of-source
build with default options.
CMakeLists.txt Options
++++++++++++++++++++++
The following options are available in the CMakeLists.txt file:
debug
Enables debugging when compiling. The flags added are dependent on which
compiler is used.
PROFILE
profile
Enables profiling using the GNU profiler, gprof.
OPTIMIZE
optimize
Enables high-optimization using compiler-dependent flags. For gfortran and
Intel Fortran, this compiles with -O3.
MPI
Enables parallel runs using the Message Passing Interface. The MPI_DIR
variable should be set to the base directory of the MPI implementation.
OPENMP
openmp
Enables shared-memory parallelism using the OpenMP API. The Fortran compiler
being used must support OpenMP.
HDF5
Enables HDF5 output in addition to normal screen and text file output. The
HDF5_DIR variable should be set to the base directory of the HDF5
installation.
PETSC
petsc
Enables PETSc for use in CMFD acceleration. The PETSC_DIR variable should be
set to the base directory of the PETSc installation.
It is also possible to change these options from the command line itself. For
example, if you want to compile with DEBUG turned on without actually change the
Makefile, you can enter the following from a terminal::
To set any of these options (e.g. turning on debug mode), the following form
should be used:
make DEBUG=yes
.. code-block:: sh
cmake -Ddebug=on /path/to/src
Compiling with MPI
++++++++++++++++++
To compile with MPI, set the :envvar:`FC` environment variable to the path to
the MPI Fortran wrapper. For example, in a bash shell:
.. code-block:: sh
export FC=mpif90
cmake /path/to/src
Note that in many shells, an environment variable can be set for a single
command, i.e.
.. code-block:: sh
FC=mpif90 cmake /path/to/src
Compiling with HDF5
+++++++++++++++++++
To compile with MPI, set the :envvar:`FC` environment variable to the path to
the HDF5 Fortran wrapper. For example, in a bash shell:
.. code-block:: sh
export FC=h5fc
cmake /path/to/src
As noted above, an environment variable can typically be set for a single
command, i.e.
.. code-block:: sh
FC=h5fc cmake /path/to/src
To compile with support for both MPI and HDF5, use the parallel HDF5 wrapper
``h5pfc`` instead. Note that this requires that your HDF5 installation be
compiled with ``--enable-parallel``.
Compiling on Linux and Mac OS X
-------------------------------
@ -210,9 +265,10 @@ a Linux-like environment for Windows. You will need to first `install
Cygwin`_. When you are asked to select packages, make sure the following are
selected:
* Devel: gcc4-core
* Devel: gcc4-fortran
* Devel: gcc-core
* Devel: gcc-fortran
* Devel: make
* Devel: cmake
If you plan on obtaining the source code directly using git, select the
following packages:
@ -266,6 +322,31 @@ This will build an executable named ``openmc``.
.. _MinGW: http://www.mingw.org
.. _SourceForge: http://sourceforge.net/projects/mingw
Testing 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:
.. code-block:: sh
cd src
make test
If you want more options for testing you can use ctest_ command. For example,
if we wanted to run only the plot tests with 4 processors, we run:
.. code-block:: sh
cd src/build
ctest -j 4 -R plot
If you want to run the full test suite with different build options please
refer to our :ref:`test suite` documentation.
---------------------------
Cross Section Configuration
---------------------------
@ -291,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
---------------------------------------
@ -411,3 +493,4 @@ schemas.xml file in your own OpenMC source directory.
.. _GNU Emacs: http://www.gnu.org/software/emacs/
.. _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

25
docs/source/usersguide/processing.rst
View file

@ -17,7 +17,6 @@ for your Python installation to contain:
* [3]_ `Matplotlib <http://matplotlib.org/>`_
* [3]_ `Silomesh <https://github.com/nhorelik/silomesh>`_
* [3]_ `VTK <http://www.vtk.org/>`_
* [4]_ `PyQt <http://www.riverbankcomputing.com/software/pyqt>`_
Most of these are easily obtainable in Ubuntu through the package manager, or
are easily installed with distutils.
@ -25,7 +24,6 @@ are easily installed with distutils.
.. [1] Required for tally data extraction from statepoints with statepoint.py
.. [2] Required only if reading HDF5 statepoint files.
.. [3] Optional for plotting utilities
.. [4] Optional for interactive GUIs
----------------------
Geometry Visualization
@ -94,9 +92,9 @@ After running OpenMC to obtain PPM files, images should be saved to another
format before using them elsewhere. This cuts down the size of the file by
orders of magnitude. Most image viewers and editors that can view PPM images
can also save to other formats (e.g. `Gimp <http://www.gimp.org/>`_, `IrfanView
<http://www.irfanview.com/>`_, etc.). However, more likey the user will want to
<http://www.irfanview.com/>`_, etc.). However, more likely the user will want to
convert to another format on the command line. This is easily accomplished with
the ``convert`` command available on most linux distributions as part of the
the ``convert`` command available on most Linux distributions as part of the
`ImageMagick <http://www.imagemagick.org/script/convert.php>`_ package. (On
Ubuntu: ``sudo apt-get install imagemagick``). Images are then converted like:
@ -172,7 +170,7 @@ doing this will depend on the 3D viewer, but should be straightforward.
:height: 200px
.. note:: 3D voxel plotting can be very computer intensive for the viewing
program (Visit, Paraview, etc.) if the number of voxels is large (>10
program (Visit, ParaView, etc.) if the number of voxels is large (>10
million or so). Thus if you want an accurate picture that renders
smoothly, consider using only one voxel in a certain direction. For
instance, the 3D pin lattice figure at the beginning of this section
@ -235,13 +233,13 @@ combination:
filters = [('mesh', (1, 1, 5)), ('energyin', 0)]
value, error = sp.get_value(tallyid, filters, score)
In the future more documentaion may become available here for statepoint.py and
In the future more documentation may become available here for statepoint.py and
the data extraction functions of StatePoint objects. However, for now it is up
to the user to explore the classes in statepoint.py to discover what data is
available in StatePoint objects (we highly recommend interactively exploring
with `IPython <http://ipython.org/>`_). Many exmaples can be found by looking
through the other utilies that use statepoint.py, and a few common visualization
tasks will be described here in the following sections.
with `IPython <http://ipython.org/>`_). Many examples can be found by looking
through the other utilities that use statepoint.py, and a few common
visualization tasks will be described here in the following sections.
Plotting in 2D
--------------
@ -251,8 +249,7 @@ Plotting in 2D
For simple viewing of 2D slices of a mesh plot, the utility plot_mesh_tally.py
is provided. This utility provides an interactive GUI to explore and plot
mesh tallies for any scores and filter bins. It requires statepoint.py, as well
as `PyQt <http://www.riverbankcomputing.com/software/pyqt>`_.
mesh tallies for any scores and filter bins. It requires statepoint.py.
.. image:: ../_images/fluxplot.png
:height: 200px
@ -446,14 +443,14 @@ Particle Track Visualization
OpenMC can dump particle tracks—the position of particles as they are
transported through the geometry. There are two ways to make OpenMC output
tracks: all particle tracks through a commandline argument or specific particle
tracks: all particle tracks through a command line argument or specific particle
tracks through settings.xml.
Running OpenMC with the argument "-t", "-track", or "--track" will cause a track
file to be created for every particle transported in the code.
The settings.xml file can dictate that specific particle tracks are output.
These particles are specified withen a ''track'' element. The ''track'' element
These particles are specified within a ''track'' element. The ''track'' element
should contain triplets of integers specifying the batch, generation, and
particle numbers, respectively. For example, to output the tracks for particles
3 and 4 of batch 1 and generation 2 the settings.xml file should contain:
@ -474,7 +471,7 @@ describing track files. The default output name is "track.pvtp". A common
usage of track.py is "track.py track*.binary" which will use the data from all
binary track files in the directory to write a "track.pvtp" VTK output file.
The .pvtp file can then be read and plotted by 3d visualization programs such as
Paraview.
ParaView.
----------------------
Source Site Processing

8
docs/source/usersguide/troubleshoot.rst
View file

@ -79,14 +79,6 @@ with the :envvar:`CROSS_SECTIONS` environment variable. It is recommended to add
a line in your ``.profile`` or ``.bash_profile`` setting the
:envvar:`CROSS_SECTIONS` environment variable.
ERROR: Invalid usage of L(I) in ACE data; Consider using more recent data set.
******************************************************************************
The cross-sections requested in ``materials.xml`` do not conform to the current
standard format. This typically happens with fissionable nuclides in a ``.6*c``
library as distributed with MCNP. Please try a newer library such as any from
the ``.7*c`` set.
Geometry Debugging
******************

4
examples/basic/materials.xml
View file

@ -1,7 +1,7 @@
<?xml version="1.0"?>
<materials>
<default_xs>70c</default_xs>
<default_xs>71c</default_xs>
<material id="40">
<density value="4.5" units="g/cc" />
@ -12,7 +12,7 @@
<density value="1.0" units="g/cc" />
<nuclide name="H-1" ao="2.0" />
<nuclide name="O-16" ao="1.0" />
<sab name="lwtr" xs="10t" />
<sab name="HH2O" xs="71t" />
</material>
</materials>

4
examples/lattice/nested/materials.xml
View file

@ -1,7 +1,7 @@
<?xml version="1.0"?>
<materials>
<default_xs>70c</default_xs>
<default_xs>71c</default_xs>
<!-- Definition of materials -->
<material id="1">
@ -13,7 +13,7 @@
<density value="1.0" units="g/cc" />
<nuclide name="H-1" ao="2.0" />
<nuclide name="O-16" ao="1.0" />
<sab name="lwtr" xs="10t" />
<sab name="HH2O" xs="71t" />
</material>
</materials>

4
examples/lattice/simple/materials.xml
View file

@ -1,7 +1,7 @@
<?xml version="1.0"?>
<materials>
<default_xs>70c</default_xs>
<default_xs>71c</default_xs>
<!-- Definition of materials -->
<material id="1">
@ -13,7 +13,7 @@
<density value="1.0" units="g/cc" />
<nuclide name="H-1" ao="2.0" />
<nuclide name="O-16" ao="1.0" />
<sab name="lwtr" xs="10t" />
<sab name="HH2O" xs="71t" />
</material>
</materials>

6
examples/pincell/materials.xml
View file

@ -1,7 +1,7 @@
<?xml version="1.0"?>
<materials>
<!-- By default, use 600K cross sections -->
<!-- By default, use 300K cross sections -->
<default_xs>71c</default_xs>
<!--
@ -64,7 +64,7 @@
<nuclide name="H-2" ao="7.4196e-06" />
<nuclide name="O-16" ao="2.4672e-02" />
<nuclide name="O-17" ao="6.0099e-05" />
<sab name="lwtr" xs="15t" />
<sab name="HH2O" xs="71t" />
</material>
</materials>
</materials>

2
examples/reflective/materials.xml
View file

@ -1,7 +1,7 @@
<?xml version="1.0"?>
<materials>
<default_xs>70c</default_xs>
<default_xs>71c</default_xs>
<material id="1">
<density value="4.5" units="g/cc" />

2
man/man1/openmc.1
View file

@ -33,7 +33,7 @@ Write tracks for all particles.
.B "\-v\fR, \fP\-\-version"
Show version information.
.TP
.B "\-?\fR, \fP\-\-help"
.B "\-h\fR, \fP\-\-help"
Show help message.
.SH ENVIRONMENT VARIABLES
The behavior of

395
src/CMakeLists.txt Normal file
View file

@ -0,0 +1,395 @@
cmake_minimum_required(VERSION 2.8 FATAL_ERROR)
project(openmc Fortran)
# Setup output directories
set(CMAKE_ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/lib)
set(CMAKE_LIBRARY_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/lib)
set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin)
set(CMAKE_Fortran_MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/include)
#===============================================================================
# Architecture specific definitions
#===============================================================================
if (${UNIX})
add_definitions(-DUNIX)
endif()
#===============================================================================
# Command line options
#===============================================================================
option(openmp "Enable shared-memory parallelism with OpenMP" OFF)
option(profile "Compile with profiling flags" OFF)
option(petsc "Enable PETSC for use in CMFD acceleration" OFF)
option(debug "Compile with debug flags" OFF)
option(optimize "Turn on all compiler optimization flags" OFF)
option(verbose "Create verbose Makefiles" OFF)
option(coverage "Compile with flags" OFF)
if (verbose)
set(CMAKE_VERBOSE_MAKEFILE on)
endif()
#===============================================================================
# MPI for distributed-memory parallelism / HDF5 for binary output
#===============================================================================
set(MPI_ENABLED FALSE)
set(HDF5_ENABLED FALSE)
if($ENV{FC} MATCHES "mpi.*")
message("-- Detected MPI wrapper: $ENV{FC}")
add_definitions(-DMPI)
set(MPI_ENABLED TRUE)
elseif($ENV{FC} MATCHES "h5fc$")
message("-- Detected HDF5 wrapper: $ENV{FC}")
add_definitions(-DHDF5)
set(HDF5_ENABLED TRUE)
elseif($ENV{FC} MATCHES "h5pfc$")
message("-- Detected parallel HDF5 wrapper: $ENV{FC}")
add_definitions(-DMPI -DHDF5)
set(MPI_ENABLED TRUE)
set(HDF5_ENABLED TRUE)
endif()
#===============================================================================
# Set compile/link flags based on which compiler is being used
#===============================================================================
if(CMAKE_Fortran_COMPILER_ID STREQUAL "GNU")
# GNU Fortran compiler options
set(f90flags "-cpp -std=f2008 -fbacktrace")
if(debug)
set(f90flags "-g -Wall -pedantic -fbounds-check -ffpe-trap=invalid,overflow,underflow ${f90flags}")
set(ldflags "-g")
endif()
if(profile)
set(f90flags "-pg ${f90flags}")
set(ldflags "-pg ${ldflags}")
endif()
if(optimize)
set(f90flags "-O3 ${f90flags}")
endif()
if(openmp)
set(f90flags "-fopenmp ${f90flags}")
set(ldflags "-fopenmp ${ldflags}")
endif()
if(coverage)
set(f90flags "-coverage ${f90flags}")
set(ldflags "-coverage ${ldflags}")
endif()
elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "Intel")
# Intel Fortran compiler options
set(f90flags "-fpp -std08 -assume byterecl -traceback")
if(debug)
set(f90flags "-g -warn -ftrapuv -fp-stack-check -check all -fpe0 ${f90flags}")
set(ldflags "-g")
endif()
if(profile)
set(f90flags "-pg ${f90flags}")
set(ldflags "-pg ${ldflags}")
endif()
if(optimize)
set(f90flags "-O3 ${f90flags}")
endif()
if(openmp)
set(f90flags "-openmp ${f90flags}")
set(ldflags "-openmp ${ldflags}")
endif()
elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "PGI")
# PGI Fortran compiler options
set(f90flags "-Mpreprocess -Minform=inform -traceback")
add_definitions(-DNO_F2008)
if(debug)
set(f90flags "-g -Mbounds -Mchkptr -Mchkstk ${f90flags}")
set(ldflags "-g")
endif()
if(profile)
set(f90flags "-pg ${f90flags}")
set(ldflags "-pg ${ldflags}")
endif()
if(optimize)
set(f90flags "-fast -Mipa ${f90flags}")
endif()
elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "XL")
# IBM XL compiler options
set(f90flags "-WF,-DNO_F2008 -O2")
if(debug)
set(f90flags "-g -C -qflag=i:i -u")
set(ldflags "-g")
endif()
if(profile)
set(f90flags "-p ${f90flags}")
set(ldflags "-p ${ldflags}")
endif()
if(optimize)
set(f90flags "-O3 ${f90flags}")
endif()
if(openmp)
set(f90flags "-qsmp=omp ${f90flags}")
set(ldflags "-qsmp=omp ${ldflags}")
endif()
elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "Cray")
# Cray Fortran compiler options
set(f90flags "-e Z -m 0")
if(debug)
set(f90flags "-g -R abcnsp -O0 ${f90flags}")
set(ldflags "-g")
endif()
endif()
#===============================================================================
# PETSc for CMFD functionality
#===============================================================================
set (PETSC_ENABLED FALSE)
if(petsc)
set(PETSC_ENABLED TRUE)
find_package(PETSc REQUIRED HINTS $ENV{PETSC_DIR}/conf)
find_library(libpetsc petsc $ENV{PETSC_DIR}/lib)
# If libfblas wasn't found, search the PETSc lib directory
if(PETSC_FBLAS_LIB STREQUAL "PETSC_FBLAS_LIB-NOTFOUND")
find_library(PETSC_FBLAS_LIB fblas $ENV{PETSC_DIR}/lib)
list(REMOVE_ITEM PETSC_PACKAGE_LIBS PETSC_FBLAS_LIB-NOTFOUND)
list(INSERT PETSC_PACKAGE_LIBS 0 ${PETSC_FBLAS_LIB})
endif()
# If libflapack wasn't found, search the PETSc lib directory
if(PETSC_FLAPACK_LIB STREQUAL "PETSC_FLAPACK_LIB-NOTFOUND")
find_library(PETSC_FLAPACK_LIB flapack $ENV{PETSC_DIR}/lib)
list(REMOVE_ITEM PETSC_PACKAGE_LIBS PETSC_FLAPACK_LIB-NOTFOUND)
list(INSERT PETSC_PACKAGE_LIBS 0 ${PETSC_FLAPACK_LIB})
endif()
# If libdl wasn't found, search /usr/lib64
if(PETSC_DL_LIB STREQUAL "PETSC_DL_LIB-NOTFOUND")
find_library(PETSC_DL_LIB libdl.so /usr/lib64)
list(REMOVE_ITEM PETSC_PACKAGE_LIBS PETSC_DL_LIB-NOTFOUND)
list(INSERT PETSC_PACKAGE_LIBS 0 ${PETSC_DL_LIB})
endif()
# If libm wasn't found, search /usr/lib64
if(PETSC_M_LIB STREQUAL "PETSC_M_LIB-NOTFOUND")
find_library(PETSC_M_LIB libm.so /usr/lib64)
list(REMOVE_ITEM PETSC_PACKAGE_LIBS PETSC_M_LIB-NOTFOUND)
list(INSERT PETSC_PACKAGE_LIBS 0 ${PETSC_M_LIB})
endif()
# If libpthread wasn't found, search /usr/lib64
if(PETSC_PTHREAD_LIB STREQUAL "PETSC_PTHREAD_LIB-NOTFOUND")
find_library(PETSC_PTHREAD_LIB libpthread.so /usr/lib64)
list(REMOVE_ITEM PETSC_PACKAGE_LIBS PETSC_PTHREAD_LIB-NOTFOUND)
list(INSERT PETSC_PACKAGE_LIBS 0 ${PETSC_PTHREAD_LIB})
endif()
# If librt wasn't found, search /usr/lib64
if(PETSC_RT_LIB STREQUAL "PETSC_RT_LIB-NOTFOUND")
find_library(PETSC_RT_LIB librt.so /usr/lib64)
list(REMOVE_ITEM PETSC_PACKAGE_LIBS PETSC_RT_LIB-NOTFOUND)
list(INSERT PETSC_PACKAGE_LIBS 0 ${PETSC_RT_LIB})
endif()
message("-- Using PETSC: ${libpetsc}")
add_definitions(-DPETSC)
include_directories($ENV{PETSC_DIR}/include)
set(libraries "${libpetsc};${PETSC_PACKAGE_LIBS};${libraries}")
endif()
#===============================================================================
# git SHA1 hash
#===============================================================================
execute_process(COMMAND git rev-parse HEAD
WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}
RESULT_VARIABLE GIT_SHA1_SUCCESS
OUTPUT_VARIABLE GIT_SHA1
ERROR_QUIET OUTPUT_STRIP_TRAILING_WHITESPACE)
if(GIT_SHA1_SUCCESS EQUAL 0)
add_definitions(-DGIT_SHA1="${GIT_SHA1}")
endif()
#===============================================================================
# FoX Fortran XML Library
#===============================================================================
# Only initialize git submodules if it is not there. User is responsible
# for future updates of fox xml submodule.
if(NOT EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/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 xml/openmc_fox.F90)
add_executable(${program} ${source})
target_link_libraries(${program} ${libraries} fox_dom)
set_target_properties(${program} PROPERTIES
COMPILE_FLAGS "${f90flags}"
LINK_FLAGS "${ldflags}")
#===============================================================================
# Install executable, scripts, manpage, license
#===============================================================================
install(TARGETS ${program} RUNTIME DESTINATION bin)
install(PROGRAMS utils/statepoint_cmp.py
DESTINATION bin
RENAME statepoint_cmp)
install(PROGRAMS utils/statepoint_histogram.py
DESTINATION bin
RENAME statepoint_histogram)
install(PROGRAMS utils/statepoint_meshplot.py
DESTINATION bin
RENAME statepoint_meshplot)
install(FILES ../man/man1/openmc.1 DESTINATION share/man/man1)
install(FILES ../LICENSE DESTINATION "share/doc/${program}/copyright")
find_package(PythonInterp)
if(PYTHONINTERP_FOUND)
install(CODE "execute_process(
COMMAND ${PYTHON_EXECUTABLE} setup.py install --user
WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/utils)")
endif()
#===============================================================================
# Regression tests
#===============================================================================
# This allows for dashboard configuration
include(CTest)
# Get a list of all the tests to run
file(GLOB_RECURSE TESTS ${CMAKE_CURRENT_SOURCE_DIR}/../tests/test_*.py)
# Check to see if PETSC is compiled for CMFD tests
if (NOT ${PETSC_ENABLED})
file(GLOB_RECURSE CMFD_TESTS ${CMAKE_CURRENT_SOURCE_DIR}/../tests/test_cmfd*.py)
foreach(cmfd_test in ${CMFD_TESTS})
list(REMOVE_ITEM TESTS ${cmfd_test})
endforeach(cmfd_test)
endif(NOT ${PETSC_ENABLED})
# Check for MEM_CHECK and COVERAGE variables
if (DEFINED ENV{MEM_CHECK})
set(MEM_CHECK $ENV{MEM_CHECK})
else(DEFINED ENV{MEM_CHECK})
set(MEM_CHECK FALSE)
endif(DEFINED ENV{MEM_CHECK})
if (DEFINED ENV{COVERAGE})
set(COVERAGE $ENV{COVERAGE})
else(DEFINED ENV{COVERAGE})
set(COVERAGE FALSE)
endif(DEFINED ENV{COVERAGE})
# Loop through all the tests
foreach(test ${TESTS})
# Get test information
get_filename_component(TEST_NAME ${test} NAME)
get_filename_component(TEST_PATH ${test} PATH)
# Check for running standard tests (no valgrind, no gcov)
if(NOT ${MEM_CHECK} AND NOT ${COVERAGE})
# Check serial/parallel
if (${MPI_ENABLED})
# Preform a parallel test
add_test(NAME ${TEST_NAME}
WORKING_DIRECTORY ${TEST_PATH}
COMMAND ${PYTHON_EXECUTABLE} ${TEST_NAME} --exe $<TARGET_FILE:openmc>
--mpi_exec $ENV{MPI_DIR}/bin/mpiexec)
else(${MPI_ENABLED})
# Perform a serial test
add_test(NAME ${TEST_NAME}
WORKING_DIRECTORY ${TEST_PATH}
COMMAND ${PYTHON_EXECUTABLE} ${TEST_NAME} --exe $<TARGET_FILE:openmc>)
endif(${MPI_ENABLED})
# Handle special case for valgrind and gcov (run openmc directly, no python)
else(NOT ${MEM_CHECK} AND NOT ${COVERAGE})
# If a plot test is encountered, run with "-p"
if (${test} MATCHES "test_plot")
# Perform serial valgrind and coverage test with plot flag
add_test(NAME ${TEST_NAME}
WORKING_DIRECTORY ${TEST_PATH}
COMMAND $<TARGET_FILE:openmc> -p ${TEST_PATH})
# If a restart test is encounted, need to run with -r and restart file(s)
elseif(${test} MATCHES "restart")
# Set restart file names
if (${HDF5_ENABLED})
# Handle restart tests separately
if(${test} MATCHES "test_statepoint_restart")
set(RESTART_FILE statepoint.7.h5)
elseif(${test} MATCHES "test_sourcepoint_restart")
set(RESTART_FILE statepoint.7.h5 source.7.h5)
elseif(${test} MATCHES "test_particle_restart")
set(RESTART_FILE particle_12_192.h5)
else(${test} MATCHES "test_statepoint_restart")
message(FATAL_ERROR "Restart test ${test} not recognized")
endif(${test} MATCHES "test_statepoint_restart")
else(${HDF5_ENABLED})
# Handle restart tests separately
if(${test} MATCHES "test_statepoint_restart")
set(RESTART_FILE statepoint.7.binary)
elseif(${test} MATCHES "test_sourcepoint_restart")
set(RESTART_FILE statepoint.7.binary source.7.binary)
elseif(${test} MATCHES "test_particle_restart")
set(RESTART_FILE particle_12_192.binary)
else(${test} MATCHES "test_statepoint_restart")
message(FATAL_ERROR "Restart test ${test} not recognized")
endif(${test} MATCHES "test_statepoint_restart")
endif(${HDF5_ENABLED})
# Perform serial valgrind and coverage test
add_test(NAME ${TEST_NAME}
WORKING_DIRECTORY ${TEST_PATH}
COMMAND $<TARGET_FILE:openmc> ${TEST_PATH})
# Perform serial valgrind and coverage restart test
add_test(NAME ${TEST_NAME}_restart
WORKING_DIRECTORY ${TEST_PATH}
COMMAND $<TARGET_FILE:openmc> -r ${RESTART_FILE} ${TEST_PATH})
# Set test dependency
set_tests_properties(${TEST_NAME}_restart PROPERTIES DEPENDS ${TEST_NAME})
# Handle standard tests for valgrind and gcov
else(${test} MATCHES "test_plot")
# Perform serial valgrind and coverage test
add_test(NAME ${TEST_NAME}
WORKING_DIRECTORY ${TEST_PATH}
COMMAND $<TARGET_FILE:openmc> ${TEST_PATH})
endif(${test} MATCHES "test_plot")
endif(NOT ${MEM_CHECK} AND NOT ${COVERAGE})
endforeach(test)

25
src/CTestConfig.cmake Normal file
View file

@ -0,0 +1,25 @@
## This file should be placed in the root directory of your project.
## Then modify the CMakeLists.txt file in the root directory of your
## project to incorporate the testing dashboard.
## # The following are required to uses Dart and the Cdash dashboard
## ENABLE_TESTING()
## INCLUDE(CTest)
# Generic information about CDASH site
set(CTEST_PROJECT_NAME "OpenMC")
set(CTEST_NIGHTLY_START_TIME "01:00:00 UTC")
set(CTEST_DROP_METHOD "http")
set(CTEST_DROP_SITE "openmc.mit.edu")
set(CTEST_DROP_LOCATION "/cdash/submit.php?project=OpenMC")
set(CTEST_DROP_SITE_CDASH TRUE)
# Set file size larger to see more output
set(CTEST_CUSTOM_MAXIMUM_FAILED_TEST_OUTPUT_SIZE "20000")
set(CTEST_CUSTOM_MAXIMUM_PASSED_TEST_OUTPUT_SIZE "20000")
# User/password to CDASH site
# Please contact Nick Horelik <nhorelik@mit.edu> or
# Bryan Herman <bherman@mit.edu> if you want to push
# test suite information to our CDASH site.
set(CTEST_DROP_SITE_USER "")
set(CTEST_DROP_SITE_PASSWORD "")

396
src/DEPENDENCIES
View file

@ -1,396 +0,0 @@
ace.o: ace_header.o
ace.o: constants.o
ace.o: endf.o
ace.o: error.o
ace.o: fission.o
ace.o: global.o
ace.o: material_header.o
ace.o: output.o
ace.o: set_header.o
ace.o: string.o
ace_header.o: constants.o
ace_header.o: endf_header.o
cmfd_data.o: cmfd_header.o
cmfd_data.o: constants.o
cmfd_data.o: error.o
cmfd_data.o: global.o
cmfd_data.o: mesh.o
cmfd_data.o: mesh_header.o
cmfd_data.o: string.o
cmfd_data.o: tally_header.o
cmfd_execute.o: cmfd_data.o
cmfd_execute.o: cmfd_jfnk_solver.o
cmfd_execute.o: cmfd_power_solver.o
cmfd_execute.o: constants.o
cmfd_execute.o: error.o
cmfd_execute.o: global.o
cmfd_execute.o: mesh.o
cmfd_execute.o: mesh_header.o
cmfd_execute.o: output.o
cmfd_execute.o: search.o
cmfd_execute.o: tally.o
cmfd_header.o: constants.o
cmfd_input.o: cmfd_header.o
cmfd_input.o: constants.o
cmfd_input.o: error.o
cmfd_input.o: global.o
cmfd_input.o: mesh_header.o
cmfd_input.o: output.o
cmfd_input.o: string.o
cmfd_input.o: tally.o
cmfd_input.o: tally_header.o
cmfd_input.o: tally_initialize.o
cmfd_input.o: xml_interface.o
cmfd_jfnk_solver.o: cmfd_loss_operator.o
cmfd_jfnk_solver.o: cmfd_power_solver.o
cmfd_jfnk_solver.o: cmfd_prod_operator.o
cmfd_jfnk_solver.o: constants.o
cmfd_jfnk_solver.o: global.o
cmfd_jfnk_solver.o: matrix_header.o
cmfd_jfnk_solver.o: solver_interface.o
cmfd_jfnk_solver.o: vector_header.o
cmfd_loss_operator.o: constants.o
cmfd_loss_operator.o: global.o
cmfd_loss_operator.o: matrix_header.o
cmfd_power_solver.o: cmfd_loss_operator.o
cmfd_power_solver.o: cmfd_prod_operator.o
cmfd_power_solver.o: constants.o
cmfd_power_solver.o: global.o
cmfd_power_solver.o: matrix_header.o
cmfd_power_solver.o: solver_interface.o
cmfd_power_solver.o: vector_header.o
cmfd_prod_operator.o: constants.o
cmfd_prod_operator.o: global.o
cmfd_prod_operator.o: matrix_header.o
cmfd_slepc_solver.o: cmfd_loss_operator.o
cmfd_slepc_solver.o: cmfd_prod_operator.o
cmfd_slepc_solver.o: constants.o
cmfd_slepc_solver.o: global.o
cross_section.o: ace_header.o
cross_section.o: constants.o
cross_section.o: error.o
cross_section.o: fission.o
cross_section.o: global.o
cross_section.o: material_header.o
cross_section.o: particle_header.o
cross_section.o: random_lcg.o
cross_section.o: search.o
doppler.o: constants.o
eigenvalue.o: cmfd_execute.o
eigenvalue.o: constants.o
eigenvalue.o: error.o
eigenvalue.o: global.o
eigenvalue.o: math.o
eigenvalue.o: mesh.o
eigenvalue.o: mesh_header.o
eigenvalue.o: output.o
eigenvalue.o: particle_header.o
eigenvalue.o: random_lcg.o
eigenvalue.o: search.o
eigenvalue.o: source.o
eigenvalue.o: state_point.o
eigenvalue.o: string.o
eigenvalue.o: tally.o
eigenvalue.o: tracking.o
endf.o: constants.o
endf.o: string.o
energy_grid.o: constants.o
energy_grid.o: global.o
energy_grid.o: list_header.o
energy_grid.o: output.o
error.o: global.o
finalize.o: global.o
finalize.o: hdf5_interface.o
finalize.o: output.o
finalize.o: tally.o
fission.o: ace_header.o
fission.o: constants.o
fission.o: error.o
fission.o: global.o
fission.o: interpolation.o
fission.o: search.o
fixed_source.o: constants.o
fixed_source.o: global.o
fixed_source.o: output.o
fixed_source.o: particle_header.o
fixed_source.o: random_lcg.o
fixed_source.o: source.o
fixed_source.o: state_point.o
fixed_source.o: string.o
fixed_source.o: tally.o
fixed_source.o: tracking.o
geometry.o: constants.o
geometry.o: error.o
geometry.o: geometry_header.o
geometry.o: global.o
geometry.o: output.o
geometry.o: particle_header.o
geometry.o: particle_restart_write.o
geometry.o: string.o
geometry.o: tally.o
global.o: ace_header.o
global.o: bank_header.o
global.o: cmfd_header.o
global.o: constants.o
global.o: dict_header.o
global.o: geometry_header.o
global.o: hdf5_interface.o
global.o: material_header.o
global.o: mesh_header.o
global.o: plot_header.o
global.o: set_header.o
global.o: source_header.o
global.o: tally_header.o
global.o: timer_header.o
hdf5_summary.o: ace_header.o
hdf5_summary.o: constants.o
hdf5_summary.o: endf.o
hdf5_summary.o: geometry_header.o
hdf5_summary.o: global.o
hdf5_summary.o: material_header.o
hdf5_summary.o: mesh_header.o
hdf5_summary.o: output.o
hdf5_summary.o: output_interface.o
hdf5_summary.o: string.o
hdf5_summary.o: tally_header.o
initialize.o: ace.o
initialize.o: bank_header.o
initialize.o: constants.o
initialize.o: dict_header.o
initialize.o: energy_grid.o
initialize.o: error.o
initialize.o: geometry.o
initialize.o: geometry_header.o
initialize.o: global.o
initialize.o: hdf5_interface.o
initialize.o: hdf5_summary.o
initialize.o: input_xml.o
initialize.o: output.o
initialize.o: output_interface.o
initialize.o: random_lcg.o
initialize.o: source.o
initialize.o: state_point.o
initialize.o: string.o
initialize.o: tally_header.o
initialize.o: tally_initialize.o
input_xml.o: cmfd_input.o
input_xml.o: constants.o
input_xml.o: dict_header.o
input_xml.o: error.o
input_xml.o: geometry_header.o
input_xml.o: global.o
input_xml.o: list_header.o
input_xml.o: mesh_header.o
input_xml.o: output.o
input_xml.o: plot_header.o
input_xml.o: random_lcg.o
input_xml.o: string.o
input_xml.o: tally_header.o
input_xml.o: tally_initialize.o
input_xml.o: xml_interface.o
interpolation.o: constants.o
interpolation.o: endf_header.o
interpolation.o: error.o
interpolation.o: global.o
interpolation.o: search.o
interpolation.o: string.o
list_header.o: constants.o
main.o: constants.o
main.o: eigenvalue.o
main.o: finalize.o
main.o: fixed_source.o
main.o: global.o
main.o: initialize.o
main.o: particle_restart.o
main.o: plot.o
math.o: constants.o
math.o: random_lcg.o
matrix_header.o: constants.o
matrix_header.o: vector_header.o
mesh.o: constants.o
mesh.o: global.o
mesh.o: mesh_header.o
mesh.o: particle_header.o
mesh.o: search.o
output.o: ace_header.o
output.o: constants.o
output.o: endf.o
output.o: error.o
output.o: geometry_header.o
output.o: global.o
output.o: math.o
output.o: mesh.o
output.o: mesh_header.o
output.o: particle_header.o
output.o: plot_header.o
output.o: string.o
output.o: tally_header.o
output_interface.o: constants.o
output_interface.o: error.o
output_interface.o: global.o
output_interface.o: hdf5_interface.o
output_interface.o: mpiio_interface.o
output_interface.o: tally_header.o
particle_header.o: constants.o
particle_header.o: geometry_header.o
particle_restart.o: bank_header.o
particle_restart.o: constants.o
particle_restart.o: geometry_header.o
particle_restart.o: global.o
particle_restart.o: output.o
particle_restart.o: output_interface.o
particle_restart.o: particle_header.o
particle_restart.o: random_lcg.o
particle_restart.o: tracking.o
particle_restart_write.o: bank_header.o
particle_restart_write.o: global.o
particle_restart_write.o: output_interface.o
particle_restart_write.o: particle_header.o
particle_restart_write.o: string.o
physics.o: ace_header.o
physics.o: constants.o
physics.o: endf.o
physics.o: error.o
physics.o: fission.o
physics.o: global.o
physics.o: interpolation.o
physics.o: material_header.o
physics.o: math.o
physics.o: mesh.o
physics.o: output.o
physics.o: particle_header.o
physics.o: particle_restart_write.o
physics.o: random_lcg.o
physics.o: search.o
physics.o: string.o
plot.o: constants.o
plot.o: error.o
plot.o: geometry.o
plot.o: geometry_header.o
plot.o: global.o
plot.o: output.o
plot.o: particle_header.o
plot.o: plot_header.o
plot.o: ppmlib.o
plot.o: string.o
plot_header.o: constants.o
random_lcg.o: global.o
search.o: error.o
search.o: global.o
set_header.o: constants.o
set_header.o: list_header.o
solver_interface.o: error.o
solver_interface.o: global.o
solver_interface.o: matrix_header.o
solver_interface.o: vector_header.o
source.o: bank_header.o
source.o: constants.o
source.o: error.o
source.o: geometry.o
source.o: geometry_header.o
source.o: global.o
source.o: math.o
source.o: output.o
source.o: particle_header.o
source.o: random_lcg.o
source.o: string.o
state_point.o: constants.o
state_point.o: error.o
state_point.o: global.o
state_point.o: output.o
state_point.o: output_interface.o
state_point.o: string.o
state_point.o: tally_header.o
string.o: constants.o
string.o: error.o
string.o: global.o
tally.o: ace_header.o
tally.o: constants.o
tally.o: error.o
tally.o: global.o
tally.o: math.o
tally.o: mesh.o
tally.o: mesh_header.o
tally.o: output.o
tally.o: particle_header.o
tally.o: search.o
tally.o: string.o
tally.o: tally_header.o
tally_header.o: constants.o
tally_initialize.o: constants.o
tally_initialize.o: global.o
tally_initialize.o: tally_header.o
timer_header.o: constants.o
track_output.o: global.o
track_output.o: output_interface.o
track_output.o: particle_header.o
track_output.o: string.o
tracking.o: cross_section.o
tracking.o: error.o
tracking.o: geometry.o
tracking.o: geometry_header.o
tracking.o: global.o
tracking.o: output.o
tracking.o: particle_header.o
tracking.o: physics.o
tracking.o: random_lcg.o
tracking.o: string.o
tracking.o: tally.o
tracking.o: track_output.o
vector_header.o: constants.o
xml_interface.o: constants.o
xml_interface.o: error.o
xml_interface.o: global.o

293
src/Makefile
View file

@ -1,283 +1,14 @@
program = openmc
prefix = /usr/local
source = $(wildcard *.F90)
objects = $(source:.F90=.o)
xml_lib = -Lxml/lib -lxml
#===============================================================================
# User Options
#===============================================================================
COMPILER = gnu
DEBUG = no
PROFILE = no
OPTIMIZE = no
MPI = no
OPENMP = no
HDF5 = no
PETSC = no
#===============================================================================
# External Library Paths
#===============================================================================
MPI_DIR = /opt/mpich/3.0.4-$(COMPILER)
HDF5_DIR = /opt/hdf5/1.8.11-$(COMPILER)
PHDF5_DIR = /opt/phdf5/1.8.11-$(COMPILER)
PETSC_DIR = /opt/petsc/3.4.2-$(COMPILER)
#===============================================================================
# Add git SHA-1 hash
#===============================================================================
GIT_SHA1 = $(shell git log -1 2>/dev/null | head -n 1 | awk '{print $$2}')
#===============================================================================
# GNU Fortran compiler options
#===============================================================================
ifeq ($(COMPILER),gnu)
F90 = gfortran
F90FLAGS := -cpp -std=f2008 -fbacktrace
LDFLAGS =
# Debugging
ifeq ($(DEBUG),yes)
F90FLAGS += -g -Wall -pedantic -fbounds-check \
-ffpe-trap=invalid,overflow,underflow
LDFLAGS += -g
endif
# Profiling
ifeq ($(PROFILE),yes)
F90FLAGS += -pg
LDFLAGS += -pg
endif
# Optimization
ifeq ($(OPTIMIZE),yes)
F90FLAGS += -O3
endif
endif
#===============================================================================
# Intel Fortran compiler options
#===============================================================================
ifeq ($(COMPILER),intel)
F90 = ifort
F90FLAGS := -fpp -std08 -assume byterecl -traceback
LDFLAGS =
# Debugging
ifeq ($(DEBUG),yes)
F90FLAGS += -g -warn -ftrapuv -fp-stack-check -check all -fpe0
LDFLAGS += -g
endif
# Profiling
ifeq ($(PROFILE),yes)
F90FLAGS += -pg
LDFLAGS += -pg
endif
# Optimization
ifeq ($(OPTIMIZE),yes)
F90FLAGS += -O3
endif
endif
#===============================================================================
# PGI compiler options
#===============================================================================
ifeq ($(COMPILER),pgi)
F90 = pgf90
F90FLAGS := -Mpreprocess -DNO_F2008 -Minform=inform -traceback
LDFLAGS =
# Debugging
ifeq ($(DEBUG),yes)
F90FLAGS += -g -Mbounds -Mchkptr -Mchkstk
LDFLAGS += -g
endif
# Profiling
ifeq ($(PROFILE),yes)
F90FLAGS += -pg
LDFLAGS += -pg
endif
# Optimization
ifeq ($(OPTIMIZE),yes)
F90FLAGS += -fast -Mipa
endif
endif
#===============================================================================
# IBM XL compiler options
#===============================================================================
ifeq ($(COMPILER),ibm)
F90 = xlf2003
F90FLAGS := -WF,-DNO_F2008 -O2
# Debugging
ifeq ($(DEBUG),yes)
F90FLAGS += -g -C -qflag=i:i -u
LDFLAGS += -g
endif
# Profiling
ifeq ($(PROFILE),yes)
F90FLAGS += -p
LDFLAGS += -p
endif
# Optimization
ifeq ($(OPTIMIZE),yes)
F90FLAGS += -O3
endif
endif
#===============================================================================
# Cray compiler options
#===============================================================================
ifeq ($(COMPILER),cray)
F90 = ftn
F90FLAGS := -e Z -m 0
# Debugging
ifeq ($(DEBUG),yes)
F90FLAGS += -g -R abcnsp -O0
LDFLAGS += -g
endif
endif
#===============================================================================
# Setup External Libraries
#===============================================================================
# MPI for distributed-memory parallelism and HDF5 for I/O
ifeq ($(MPI),yes)
ifeq ($(HDF5),yes)
F90 = $(PHDF5_DIR)/bin/h5pfc
F90FLAGS += -DHDF5
else
F90 = $(MPI_DIR)/bin/mpif90
endif
F90FLAGS += -DMPI
else
ifeq ($(HDF5),yes)
F90 = $(HDF5_DIR)/bin/h5fc
F90FLAGS += -DHDF5
endif
endif
# OpenMP for shared-memory parallelism
ifeq ($(OPENMP),yes)
ifeq ($(COMPILER),intel)
F90FLAGS += -openmp
LDFLAGS += -openmp
endif
ifeq ($(COMPILER),gnu)
F90FLAGS += -fopenmp
LDFLAGS += -fopenmp
endif
ifeq ($(COMPILER),ibm)
F90FLAGS += -qsmp=omp
LDFLAGS += -qsmp=omp
endif
endif
# PETSC for CMFD functionality
ifeq ($(PETSC),yes)
# Check to make sure MPI is set
ifneq ($(MPI),yes)
$(error MPI must be enabled to compile with PETSC!)
endif
# Set up PETSc environment
include $(PETSC_DIR)/conf/petscvariables
F90FLAGS += -I$(PETSC_DIR)/include -DPETSC
LDFLAGS += $(PETSC_LIB)
endif
#===============================================================================
# Machine-specific setup
#===============================================================================
# IBM Blue Gene/P ANL supercomputer
ifeq ($(MACHINE),bluegene)
F90 = /bgsys/drivers/ppcfloor/comm/xl/bin/mpixlf2003
F90FLAGS = -WF,-DNO_F2008,-DMPI,-DRESTRICTED_ASSOCIATED_BUG -O3
LDFLAGS = -lmpich.cnkf90
endif
# Cray XK6 ORNL Titan supercomputer
ifeq ($(MACHINE),crayxk6)
F90 = ftn
F90FLAGS += -DMPI
endif
# IBM Blue Gene/Q ANL supercomputer
ifeq ($(MACHINE),bluegeneq)
F90 = mpixlf2003
F90FLAGS = -WF,-DNO_F2008,-DMPI,-DRESTRICTED_ASSOCIATED_BUG -O5
endif
#===============================================================================
# Targets
#===============================================================================
all: xml $(program)
xml:
cd xml; make MACHINE=$(MACHINE) F90=$(F90) F90FLAGS="$(F90FLAGS)" LDFLAGS="$(LDFLAGS)"
$(program): $(objects)
$(F90) $(objects) $(xml_lib) $(LDFLAGS) -o $@
install:
@install -D $(program) $(DESTDIR)$(prefix)/bin/$(program)
@install -D utils/statepoint_cmp.py $(DESTDIR)$(prefix)/bin/statepoint_cmp
@install -D utils/statepoint_histogram.py $(DESTDIR)$(prefix)/bin/statepoint_histogram
@install -D utils/statepoint_meshplot.py $(DESTDIR)$(prefix)/bin/statepoint_meshplot
@install -D ../man/man1/openmc.1 $(DESTDIR)$(prefix)/share/man/man1/openmc.1
@install -D ../LICENSE $(DESTDIR)$(prefix)/share/doc/$(program)/copyright
uninstall:
@rm $(DESTDIR)$(prefix)/bin/$(program)
@rm $(DESTDIR)$(prefix)/bin/statepoint_cmp
@rm $(DESTDIR)$(prefix)/bin/statepoint_histogram
@rm $(DESTDIR)$(prefix)/bin/statepoint_meshplot
@rm $(DESTDIR)$(prefix)/share/man/man1/openmc.1
@rm $(DESTDIR)$(prefix)/share/doc/$(program)/copyright
distclean: clean
cd xml; make clean
all:
mkdir -p build
cmake -H. -Bbuild
make -s -C build
clean:
@rm -f *.o *.mod $(program)
neat:
@rm -f *.o *.mod
make -s -C build clean
distclean:
rm -fr build
test:
make -s -C build test
install:
make -s -C build install
#===============================================================================
# Rules
#===============================================================================
.SUFFIXES: .F90 .o
.PHONY: all xml install uninstall clean neat distclean
%.o: %.F90
$(F90) $(F90FLAGS) -DGIT_SHA1="\"$(GIT_SHA1)\"" -Ixml/include -c $<
#===============================================================================
# Dependencies
#===============================================================================
include DEPENDENCIES
.PHONY: all clean distclean test install

107
src/ace.F90
View file

@ -789,14 +789,19 @@ contains
! read angular distribution -- currently this does not actually parse the
! angular distribution tables for each incoming energy, that must be done
! on-the-fly
LC = rxn % adist % location(1)
XSS_index = JXS9 + abs(LC) - 1
XSS_index = JXS9 + LOCB + 2 * NE
rxn % adist % data = get_real(length)
! change location pointers since they are currently relative to JXS(9)
LC = abs(rxn % adist % location(1))
rxn % adist % location = abs(rxn % adist % location) - LC
LC = LOCB + 2 * NE + 1
do j = 1, NE
! For consistency, leave location as 0 if type is isotropic.
! This is not necessary for current correctness, but can avoid
! future issues
if (rxn % adist % location(j) /= 0) then
rxn % adist % location(j) = abs(rxn % adist % location(j)) - LC
end if
end do
end do
end subroutine read_angular_dist
@ -967,24 +972,23 @@ contains
! Continuous tabular distribution
NR = int(XSS(lc + 1))
NE = int(XSS(lc + 2 + 2*NR))
! Before progressing, check to see if data set uses L(I) values
! in a way inconsistent with the current form of the ACE Format Guide
! (MCNP5 Manual, Vol 3)
allocate(L(NE))
L = int(XSS(lc + 3 + 2*NR + NE: lc + 3 + 2*NR + 2*NE - 1))
do i = 1,NE
! Now check to see if L(i) is equal to any other entries
! If so, then we must exit
if (count(L == L(i)) > 1) then
message = "Invalid usage of L(I) in ACE data; &
&Consider using more recent data set."
call fatal_error()
end if
end do
deallocate(L)
! Continue with finding data length
length = length + 2 + 2*NR + 2*NE
do i = 1,NE
! Some older data sets use the same LDAT for multiple Ein tables.
! If this is the case, we should skip incrementing length when it is
! not needed.
if (i < NE) then
if (any(L(i) == L(i + 1: NE))) then
! adjust location for this block
j = lc + 2 + 2*NR + NE + i
XSS(j) = XSS(j) - LOCC - lid
cycle
end if
end if
! determine length
NP = int(XSS(lc + length + 2))
length = length + 2 + 3*NP
@ -993,6 +997,7 @@ contains
j = lc + 2 + 2*NR + NE + i
XSS(j) = XSS(j) - LOCC - lid
end do
deallocate(L)
case (5)
! General evaporation spectrum
@ -1025,24 +1030,23 @@ contains
! Kalbach-Mann correlated scattering
NR = int(XSS(lc + 1))
NE = int(XSS(lc + 2 + 2*NR))
! Before progressing, check to see if data set uses L(I) values
! in a way inconsistent with the current form of the ACE Format Guide
! (MCNP5 Manual, Vol 3)
allocate(L(NE))
L = int(XSS(lc + 3 + 2*NR + NE: lc + 3 + 2*NR + 2*NE - 1))
do i = 1,NE
! Now check to see if L(i) is equal to any other entries
! If so, then we must exit
if (count(L == L(i)) > 1) then
message = "Invalid usage of L(I) in ACE data; &
&Consider using more recent data set."
call fatal_error()
end if
end do
deallocate(L)
! Continue with finding data length
length = length + 2 + 2*NR + 2*NE
do i = 1,NE
! Some older data sets use the same LDAT for multiple Ein tables.
! If this is the case, we should skip incrementing length when it is
! not needed.
if (i < NE) then
if (any(L(i) == L(i + 1: NE))) then
! adjust location for this block
j = lc + 2 + 2*NR + NE + i
XSS(j) = XSS(j) - LOCC - lid
cycle
end if
end if
NP = int(XSS(lc + length + 2))
length = length + 2 + 5*NP
@ -1050,29 +1054,30 @@ contains
j = lc + 2 + 2*NR + NE + i
XSS(j) = XSS(j) - LOCC - lid
end do
deallocate(L)
case (61)
! Correlated energy and angle distribution
NR = int(XSS(lc + 1))
NE = int(XSS(lc + 2 + 2*NR))
! Before progressing, check to see if data set uses L(I) values
! in a way inconsistent with the current form of the ACE Format Guide
! (MCNP5 Manual, Vol 3)
allocate(L(NE))
L = int(XSS(lc + 3 + 2*NR + NE: lc + 3 + 2*NR + 2*NE - 1))
do i = 1,NE
! Now check to see if L(i) is equal to any other entries
! If so, then we must exit
if (count(L == L(i)) > 1) then
message = "Invalid usage of L(I) in ACE data; &
&Consider using more recent data set."
call fatal_error()
end if
end do
deallocate(L)
! Continue with finding data length
length = length + 2 + 2*NR + 2*NE
do i = 1,NE
! Some older data sets use the same LDAT for multiple Ein tables.
! If this is the case, we should skip incrementing length when it is
! not needed.
if (i < NE) then
if (any(L(i) == L(i + 1: NE))) then
! adjust locators for energy distribution
j = lc + 2 + 2*NR + NE + i
XSS(j) = XSS(j) - LOCC - lid
cycle
end if
end if
! outgoing energy distribution
NP = int(XSS(lc + length + 2))
@ -1094,7 +1099,7 @@ contains
j = lc + 2 + 2*NR + NE + i
XSS(j) = XSS(j) - LOCC - lid
end do
deallocate(L)
case (66)
! N-body phase space distribution
length = 2
@ -1108,15 +1113,7 @@ contains
! (MCNP5 Manual, Vol 3)
allocate(L(NE))
L = int(XSS(lc + 3 + 2*NR + NE: lc + 3 + 2*NR + 2*NE - 1))
do i = 1,NE
! Now check to see if L(i) is equal to any other entries
! If so, then we must exit
if (count(L == L(i)) > 1) then
message = "Invalid usage of L(I) in ACE data; &
&Consider using more recent data set."
call fatal_error()
end if
end do
! Don't currently do anything with L
deallocate(L)
! Continue with finding data length
NMU = int(XSS(lc + 4 + 2*NR + 2*NE))
@ -1330,7 +1327,7 @@ contains
! Now we can fill the inelastic_data(i) attributes
do i = 1, NE_in
XSS_index = LOCC(i)
XSS_index = int(LOCC(i))
NE_out = table % inelastic_data(i) % n_e_out
do j = 1, NE_out
table % inelastic_data(i) % e_out(j) = XSS(XSS_index + 1)

3
src/cmfd_data.F90
View file

@ -800,7 +800,7 @@ contains
!===============================================================================
! FIX_NEUTRON_BALANCE is a method to adjust parameters to have perfect balance
!===============================================================================
#ifdef DEVELOPMENTAL
subroutine fix_neutron_balance()
use constants, only: ONE, ZERO, CMFD_NOACCEL
@ -926,6 +926,7 @@ contains
end do ZLOOP
end subroutine fix_neutron_balance
#endif
!===============================================================================
! COMPUTE_EFFECTIVE_DOWNSCATTER changes downscatter rate for zero upscatter

1
src/cmfd_header.F90
View file

@ -194,6 +194,7 @@ contains
if (allocated(this % dom)) deallocate(this % dom)
if (allocated(this % k_cmfd)) deallocate(this % k_cmfd)
if (allocated(this % entropy)) deallocate(this % entropy)
if (allocated(this % resnb)) deallocate(this % resnb)
end subroutine deallocate_cmfd

39
src/cmfd_input.F90
View file

@ -8,7 +8,7 @@ module cmfd_input
implicit none
private
public :: configure_cmfd
public :: configure_cmfd
contains
@ -20,9 +20,6 @@ contains
use cmfd_header, only: allocate_cmfd
#ifdef PETSC
integer :: new_comm ! new mpi communicator
#endif
integer :: color ! color group of processor
! Read in cmfd input file
@ -37,12 +34,10 @@ contains
! Split up procs
#ifdef PETSC
call MPI_COMM_SPLIT(MPI_COMM_WORLD, color, 0, new_comm, mpi_err)
#endif
call MPI_COMM_SPLIT(MPI_COMM_WORLD, color, 0, cmfd_comm, mpi_err)
! assign to PETSc
#ifdef PETSC
PETSC_COMM_WORLD = new_comm
PETSC_COMM_WORLD = cmfd_comm
! Initialize PETSc on all procs
call PetscInitialize(PETSC_NULL_CHARACTER, mpi_err)
@ -124,7 +119,7 @@ contains
cmfd % egrid = (/0.0_8,20.0_8/)
cmfd % indices(4) = 1 ! one energy group
end if
! Set global albedo
if (check_for_node(node_mesh, "albedo")) then
call get_node_array(node_mesh, "albedo", cmfd % albedo)
@ -139,7 +134,7 @@ contains
if (get_arraysize_integer(node_mesh, "map") /= &
product(cmfd % indices(1:3))) then
message = 'FATAL==>CMFD coremap not to correct dimensions'
call fatal_error()
call fatal_error()
end if
allocate(iarray(get_arraysize_integer(node_mesh, "map")))
call get_node_array(node_mesh, "map", iarray)
@ -211,7 +206,7 @@ contains
! Batch to begin cmfd
if (check_for_node(doc, "begin")) &
call get_node_value(doc, "begin", cmfd_begin)
call get_node_value(doc, "begin", cmfd_begin)
! Tally during inactive batches
if (check_for_node(doc, "inactive")) then
@ -293,7 +288,7 @@ contains
m => meshes(n_user_meshes+1)
! Set mesh id
m % id = n_user_meshes + 1
m % id = n_user_meshes + 1
! Set mesh type to rectangular
m % type = LATTICE_RECT
@ -427,7 +422,7 @@ contains
if (check_for_node(node_mesh, "energy")) then
n_filters = n_filters + 1
filters(n_filters) % type = FILTER_ENERGYIN
ng = get_arraysize_double(node_mesh, "energy")
ng = get_arraysize_double(node_mesh, "energy")
filters(n_filters) % n_bins = ng - 1
allocate(filters(n_filters) % real_bins(ng))
call get_node_array(node_mesh, "energy", &
@ -459,20 +454,20 @@ contains
allocate(t % filters(n_filters))
t % filters = filters(1:n_filters)
! Allocate scoring bins
! Allocate scoring bins
allocate(t % score_bins(3))
t % n_score_bins = 3
t % n_user_score_bins = 3
! Allocate scattering order data
allocate(t % scatt_order(3))
t % scatt_order = 0
allocate(t % moment_order(3))
t % moment_order = 0
! Set macro_bins
t % score_bins(1) = SCORE_FLUX
t % score_bins(2) = SCORE_TOTAL
t % score_bins(3) = SCORE_SCATTER_N
t % scatt_order(3) = 1
t % moment_order(3) = 1
else if (i == 2) then
@ -512,8 +507,8 @@ contains
t % n_user_score_bins = 2
! Allocate scattering order data
allocate(t % scatt_order(2))
t % scatt_order = 0
allocate(t % moment_order(2))
t % moment_order = 0
! Set macro_bins
t % score_bins(1) = SCORE_NU_SCATTER
@ -555,8 +550,8 @@ contains
t % n_user_score_bins = 1
! Allocate scattering order data
allocate(t % scatt_order(1))
t % scatt_order = 0
allocate(t % moment_order(1))
t % moment_order = 0
! Set macro bins
t % score_bins(1) = SCORE_CURRENT

21
src/cmfd_jfnk_solver.F90
View file

@ -16,7 +16,9 @@ module cmfd_jfnk_solver
type(Matrix) :: jac_prec ! Jacobian preconditioner object
type(Matrix) :: loss ! CMFD loss matrix
type(Matrix) :: prod ! CMFD production matrix
#ifdef PETSC
type(JFNKSolver) :: jfnk ! JFNK solver object
#endif
type(Vector) :: resvec ! JFNK residual vector
type(Vector) :: xvec ! JFNK solution vector
@ -51,9 +53,9 @@ contains
#endif
! Set up residual and jacobian routines
#ifdef PETSC
jfnk_data % res_proc_ptr => compute_nonlinear_residual
jfnk_data % jac_proc_ptr => build_jacobian_matrix
#ifdef PETSC
call jfnk % set_functions(jfnk_data, resvec, jac_prec)
#endif
@ -104,8 +106,10 @@ contains
! Assemble matrices and use PETSc
call loss % assemble()
call prod % assemble()
#ifdef PETSC
call loss % setup_petsc()
call prod % setup_petsc()
#endif
! Check for mathematical adjoint
if (adjoint_calc .and. trim(cmfd_adjoint_type) == 'math') &
@ -133,14 +137,18 @@ contains
end if
! Set up vectors for PETSc
#ifdef PETSC
call resvec % setup_petsc()
call xvec % setup_petsc()
#endif
! Build jacobian from initial guess
call build_jacobian_matrix(xvec)
! Set up Jacobian for PETSc
#ifdef PETSC
call jac_prec % setup_petsc()
#endif
! Set dominance ratio to 0
cmfd % dom(current_batch) = ZERO
@ -262,7 +270,7 @@ contains
!===============================================================================
! COMPUTE_NONLINEAR_RESIDUAL computes the residual of the nonlinear equations
!===============================================================================
#ifdef PETSC
subroutine compute_nonlinear_residual(x, res)
use global, only: cmfd_write_matrices
@ -310,7 +318,9 @@ contains
else
filename = 'res.bin'
end if
#ifdef PETSC
call res % write_petsc_binary(filename)
#endif
! Write out solution vector
if (adjoint_calc) then
@ -318,11 +328,14 @@ contains
else
filename = 'x.bin'
end if
#ifdef PETSC
call x % write_petsc_binary(filename)
#endif
end if
end subroutine compute_nonlinear_residual
#endif
!===============================================================================
! COMPUTE_ADJOINT calculates mathematical adjoint by taking transposes
@ -333,13 +346,17 @@ contains
use global, only: cmfd_write_matrices
! Transpose matrices
#ifdef PETSC
call loss % transpose()
call prod % transpose()
#endif
! Write out matrix in binary file (debugging)
if (cmfd_write_matrices) then
#ifdef PETSC
call loss % write_petsc_binary('adj_lossmat.bin')
call loss % write_petsc_binary('adj_prodmat.bin')
#endif
end if
end subroutine compute_adjoint

8
src/cmfd_power_solver.F90
View file

@ -29,7 +29,9 @@ module cmfd_power_solver
type(Vector) :: s_n ! new source vector
type(Vector) :: s_o ! old flux vector
type(Vector) :: serr_v ! error in source
#ifdef PETSC
type(GMRESSolver) :: gmres ! gmres solver
#endif
contains
@ -169,13 +171,17 @@ contains
use global, only: cmfd_write_matrices
! Transpose matrices
#ifdef PETSC
call loss % transpose()
call prod % transpose()
#endif
! Write out matrix in binary file (debugging)
if (cmfd_write_matrices) then
#ifdef PETSC
call loss % write_petsc_binary('adj_lossmat.bin')
call prod % write_petsc_binary('adj_prodmat.bin')
#endif
end if
end subroutine compute_adjoint
@ -320,7 +326,9 @@ contains
else
filename = 'fluxvec.bin'
end if
#ifdef PETSC
call phi_n % write_petsc_binary(filename)
#endif
end if
end subroutine extract_results

58
src/constants.F90
View file

@ -7,11 +7,11 @@ module constants
! OpenMC major, minor, and release numbers
integer, parameter :: VERSION_MAJOR = 0
integer, parameter :: VERSION_MINOR = 5
integer, parameter :: VERSION_RELEASE = 4
integer, parameter :: VERSION_MINOR = 6
integer, parameter :: VERSION_RELEASE = 0
! Revision numbers for binary files
integer, parameter :: REVISION_STATEPOINT = 11
integer, parameter :: REVISION_STATEPOINT = 12
integer, parameter :: REVISION_PARTICLE_RESTART = 1
! Binary file types
@ -244,6 +244,17 @@ module constants
! Maximum number of partial fission reactions
integer, parameter :: PARTIAL_FISSION_MAX = 4
! Major cross section libraries
integer, parameter :: &
ENDF_BVII0 = 1, &
ENDF_BVII1 = 2, &
JEFF_311 = 3, &
JEFF_312 = 4, &
JEFF_32 = 5, &
JENDL_32 = 6, &
JENDL_33 = 7, &
JENDL_40 = 8
! ============================================================================
! TALLY-RELATED CONSTANTS
@ -265,7 +276,7 @@ module constants
EVENT_ABSORB = 2
! Tally score type
integer, parameter :: N_SCORE_TYPES = 14
integer, parameter :: N_SCORE_TYPES = 20
integer, parameter :: &
SCORE_FLUX = -1, & ! flux
SCORE_TOTAL = -2, & ! total reaction rate
@ -273,18 +284,37 @@ module constants
SCORE_NU_SCATTER = -4, & ! scattering production rate
SCORE_SCATTER_N = -5, & ! arbitrary scattering moment
SCORE_SCATTER_PN = -6, & ! system for scoring 0th through nth moment
SCORE_TRANSPORT = -7, & ! transport reaction rate
SCORE_N_1N = -8, & ! (n,1n) rate
SCORE_ABSORPTION = -9, & ! absorption rate
SCORE_FISSION = -10, & ! fission rate
SCORE_NU_FISSION = -11, & ! neutron production rate
SCORE_KAPPA_FISSION = -12, & ! fission energy production rate
SCORE_CURRENT = -13, & ! partial current
SCORE_EVENTS = -14 ! number of events
SCORE_NU_SCATTER_N = -7, & ! arbitrary nu-scattering moment
SCORE_NU_SCATTER_PN = -8, & ! system for scoring 0th through nth nu-scatter moment
SCORE_TRANSPORT = -9, & ! transport reaction rate
SCORE_N_1N = -10, & ! (n,1n) rate
SCORE_ABSORPTION = -11, & ! absorption rate
SCORE_FISSION = -12, & ! fission rate
SCORE_NU_FISSION = -13, & ! neutron production rate
SCORE_KAPPA_FISSION = -14, & ! fission energy production rate
SCORE_CURRENT = -15, & ! partial current
SCORE_FLUX_YN = -16, & ! angular moment of flux
SCORE_TOTAL_YN = -17, & ! angular moment of total reaction rate
SCORE_SCATTER_YN = -18, & ! angular flux-weighted scattering moment (0:N)
SCORE_NU_SCATTER_YN = -19, & ! angular flux-weighted nu-scattering moment (0:N)
SCORE_EVENTS = -20 ! number of events
! Maximum scattering order supported
integer, parameter :: SCATT_ORDER_MAX = 10
character(len=*), parameter :: SCATT_ORDER_MAX_PNSTR = "scatter-p10"
integer, parameter :: MAX_ANG_ORDER = 10
! Names of *-PN & *-YN scores (MOMENT_STRS) and *-N moment scores
character(*), parameter :: &
MOMENT_STRS(6) = (/ "scatter-p ", &
"nu-scatter-p", &
"flux-y ", &
"total-y ", &
"scatter-y ", &
"nu-scatter-y"/), &
MOMENT_N_STRS(2) = (/ "scatter- ", &
"nu-scatter- "/)
! Location in MOMENT_STRS where the YN data begins
integer, parameter :: YN_LOC = 3
! Tally map bin finding
integer, parameter :: NO_BIN_FOUND = -1

9
src/cross_section.F90
View file

@ -393,7 +393,8 @@ contains
! Calculate elastic cross section/factor
elastic = ZERO
if (urr % prob(i_energy, URR_ELASTIC, i_table) > ZERO) then
if (urr % prob(i_energy, URR_ELASTIC, i_table) > ZERO .and. &
urr % prob(i_energy + 1, URR_ELASTIC, i_table) > ZERO) then
elastic = exp((ONE - f) * log(urr % prob(i_energy, URR_ELASTIC, &
i_table)) + f * log(urr % prob(i_energy + 1, URR_ELASTIC, &
i_table)))
@ -401,7 +402,8 @@ contains
! Calculate fission cross section/factor
fission = ZERO
if (urr % prob(i_energy, URR_FISSION, i_table) > ZERO) then
if (urr % prob(i_energy, URR_FISSION, i_table) > ZERO .and. &
urr % prob(i_energy + 1, URR_FISSION, i_table) > ZERO) then
fission = exp((ONE - f) * log(urr % prob(i_energy, URR_FISSION, &
i_table)) + f * log(urr % prob(i_energy + 1, URR_FISSION, &
i_table)))
@ -409,7 +411,8 @@ contains
! Calculate capture cross section/factor
capture = ZERO
if (urr % prob(i_energy, URR_N_GAMMA, i_table) > ZERO) then
if (urr % prob(i_energy, URR_N_GAMMA, i_table) > ZERO .and. &
urr % prob(i_energy + 1, URR_N_GAMMA, i_table) > ZERO) then
capture = exp((ONE - f) * log(urr % prob(i_energy, URR_N_GAMMA, &
i_table)) + f * log(urr % prob(i_energy + 1, URR_N_GAMMA, &
i_table)))

8
src/eigenvalue.F90
View file

@ -39,7 +39,7 @@ contains
subroutine run_eigenvalue()
type(Particle) :: p
integer :: i_work
integer(8) :: i_work
if (master) call header("K EIGENVALUE SIMULATION", level=1)
@ -256,7 +256,7 @@ contains
& temp_sites(:) ! local array of extra sites on each node
#ifdef MPI
integer :: n ! number of sites to send/recv
integer(8) :: n ! number of sites to send/recv
integer :: neighbor ! processor to send/recv data from
integer :: request(20) ! communication request for send/recving sites
integer :: n_request ! number of communication requests
@ -834,8 +834,8 @@ contains
subroutine join_bank_from_threads()
integer :: total ! total number of fission bank sites
integer :: i ! loop index for threads
integer(8) :: total ! total number of fission bank sites
integer :: i ! loop index for threads
! Initialize the total number of fission bank sites
total = 0

5
src/finalize.F90
View file

@ -40,7 +40,10 @@ contains
#ifdef PETSC
! Finalize PETSc
if (cmfd_run) call PetscFinalize(mpi_err)
if (cmfd_run) then
call PetscFinalize(mpi_err)
call MPI_COMM_FREE(cmfd_comm, mpi_err)
end if
#endif
! Stop timers and show timing statistics

31
src/global.F90
View file

@ -88,6 +88,9 @@ module global
! Default xs identifier (e.g. 70c)
character(3):: default_xs
! What to assume for expanding natural elements
integer :: default_expand = ENDF_BVII1
! ============================================================================
! TALLY-RELATED VARIABLES
@ -266,7 +269,7 @@ module global
character(MAX_FILE_LEN) :: path_output = '' ! Path to output directory
! Message used in message/warning/fatal_error
character(MAX_LINE_LEN) :: message
character(2*MAX_LINE_LEN) :: message
! Random number seed
integer(8) :: seed = 1_8
@ -300,6 +303,9 @@ module global
! Is CMFD active
logical :: cmfd_run = .false.
! CMFD communicator
integer :: cmfd_comm
! Timing objects
type(Timer) :: time_cmfd ! timer for whole cmfd calculation
@ -478,8 +484,29 @@ contains
call sab_dict % clear()
call xs_listing_dict % clear()
! Clear statepoint batch set
! Clear statepoint and sourcepoint batch set
call statepoint_batch % clear()
call sourcepoint_batch % clear()
! Deallocate entropy mesh
if (associated(entropy_mesh)) then
if (allocated(entropy_mesh % lower_left)) &
deallocate(entropy_mesh % lower_left)
if (allocated(entropy_mesh % upper_right)) &
deallocate(entropy_mesh % upper_right)
if (allocated(entropy_mesh % width)) deallocate(entropy_mesh % width)
deallocate(entropy_mesh)
end if
! Deallocate ufs
if (allocated(source_frac)) deallocate(source_frac)
if (associated(ufs_mesh)) then
if (allocated(ufs_mesh % lower_left)) deallocate(ufs_mesh % lower_left)
if (allocated(ufs_mesh % upper_right)) &
deallocate(ufs_mesh % upper_right)
if (allocated(ufs_mesh % width)) deallocate(ufs_mesh % width)
deallocate(ufs_mesh)
end if
end subroutine free_memory

4
src/initialize.F90
View file

@ -416,7 +416,7 @@ contains
#ifdef _OPENMP
! Read and set number of OpenMP threads
n_threads = str_to_int(argv(i))
n_threads = int(str_to_int(argv(i)), 4)
if (n_threads < 1) then
message = "Invalid number of threads specified on command line."
call fatal_error()
@ -427,7 +427,7 @@ contains
call warning()
#endif
case ('-?', '-help', '--help')
case ('-?', '-h', '-help', '--help')
call print_usage()
stop
case ('-v', '-version', '--version')

556
src/input_xml.F90
View file

@ -80,7 +80,11 @@ contains
filename = trim(path_input) // "settings.xml"
inquire(FILE=filename, EXIST=file_exists)
if (.not. file_exists) then
message = "Settings XML file '" // trim(filename) // "' does not exist!"
message = "Settings XML file '" // trim(filename) // "' does not exist! &
&In order to run OpenMC, you first need a set of input files; at a &
&minimum, this includes settings.xml, geometry.xml, and &
&materials.xml. Please consult the user's guide at &
&http://mit-crpg.github.io/openmc for further information."
call fatal_error()
end if
@ -98,7 +102,11 @@ contains
call get_environment_variable("CROSS_SECTIONS", env_variable)
if (len_trim(env_variable) == 0) then
message = "No cross_sections.xml file was specified in settings.xml &
&or in the CROSS_SECTIONS environment variable."
&or in the CROSS_SECTIONS environment variable. OpenMC needs a &
&cross_sections.xml file to identify where to find ACE cross &
&section libraries. Please consult the user's guide at &
&http://mit-crpg.github.io/openmc for information on how to set &
&up ACE cross section libraries."
call fatal_error()
else
path_cross_sections = trim(env_variable)
@ -177,7 +185,7 @@ contains
! If the number of particles was specified as a command-line argument, we
! don't set it here
if (n_particles == 0) n_particles = temp_long
if (n_particles == 0) n_particles = temp_long
! Copy batch information
call get_node_value(node_mode, "batches", n_batches)
@ -270,10 +278,10 @@ contains
else
! Spatial distribution for external source
if (check_for_node(node_source, "space")) then
if (check_for_node(node_source, "space")) then
! Get pointer to spatial distribution
call get_node_ptr(node_source, "space", node_dist)
call get_node_ptr(node_source, "space", node_dist)
! Check for type of spatial distribution
type = ''
@ -616,7 +624,7 @@ contains
elseif (check_for_node(node_sp, "interval")) then
! User gave an interval for writing state points
call get_node_value(node_sp, "interval", temp_int)
n_state_points = n_batches / temp_int
n_state_points = n_batches / temp_int
do i = 1, n_state_points
call statepoint_batch % add(temp_int * i)
end do
@ -640,7 +648,7 @@ contains
! Determine number of batches at which to store source points
if (check_for_node(node_sp, "batches")) then
n_source_points = get_arraysize_integer(node_sp, "batches")
n_source_points = get_arraysize_integer(node_sp, "batches")
else
n_source_points = 0
end if
@ -692,7 +700,7 @@ contains
end if
else
! If no <source_point> tag was present, by default we keep source bank in
! statepoint file and write it out at statepoints intervals
! statepoint file and write it out at statepoints intervals
source_separate = .false.
n_source_points = n_state_points
do i = 1, n_state_points
@ -778,6 +786,33 @@ contains
end if
end if
! Natural element expansion option
if (check_for_node(doc, "natural_elements")) then
call get_node_value(doc, "natural_elements", temp_str)
call lower_case(temp_str)
select case (temp_str)
case ('endf/b-vii.0')
default_expand = ENDF_BVII0
case ('endf/b-vii.1')
default_expand = ENDF_BVII1
case ('jeff-3.1.1')
default_expand = JEFF_311
case ('jeff-3.1.2')
default_expand = JEFF_312
case ('jeff-3.2')
default_expand = JEFF_32
case ('jendl-3.2')
default_expand = JENDL_32
case ('jendl-3.3')
default_expand = JENDL_33
case ('jendl-4.0')
default_expand = JENDL_40
case default
message = "Unknown natural element expansion option: " // trim(temp_str)
call fatal_error()
end select
end if
! Close settings XML file
call close_xmldoc(doc)
@ -909,7 +944,7 @@ contains
! Check to make sure that either material or fill was specified
if (c % material == NONE .and. c % fill == NONE) then
message = "Neither material nor fill was specified for cell " // &
message = "Neither material nor fill was specified for cell " // &
trim(to_str(c % id))
call fatal_error()
end if
@ -1104,7 +1139,7 @@ contains
n = get_arraysize_double(node_surf, "coeffs")
if (n < coeffs_reqd) then
message = "Not enough coefficients specified for surface: " // &
message = "Not enough coefficients specified for surface: " // &
trim(to_str(s % id))
call fatal_error()
elseif (n > coeffs_reqd) then
@ -1520,7 +1555,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))
@ -1578,7 +1615,7 @@ contains
! Check to make sure cross-section is continuous energy neutron table
n = len_trim(name)
if (name(n:n) /= 'c') then
message = "Cross-section table " // trim(name) // &
message = "Cross-section table " // trim(name) // &
" is not a continuous-energy neutron table."
call fatal_error()
end if
@ -1607,7 +1644,7 @@ contains
! Check to make sure either all atom percents or all weight percents are
! given
if (.not. (all(mat % atom_density > ZERO) .or. &
if (.not. (all(mat % atom_density > ZERO) .or. &
all(mat % atom_density < ZERO))) then
message = "Cannot mix atom and weight percents in material " // &
to_str(mat % id)
@ -1708,12 +1745,14 @@ contains
integer :: n ! size of arrays in mesh specification
integer :: n_words ! number of words read
integer :: n_filters ! number of filters
integer :: n_new ! number of new scores to add based on Pn tally
integer :: n_scores ! number of tot scores after adjusting for Pn tally
integer :: n_order ! Scattering order requested
integer :: n_new ! number of new scores to add based on Yn/Pn tally
integer :: n_scores ! number of tot scores after adjusting for Yn/Pn tally
integer :: n_bins ! Total new bins for this score
integer :: n_order ! Moment order requested
integer :: n_order_pos ! Position of Scattering order in score name string
integer :: MT ! user-specified MT for score
integer :: iarray3(3) ! temporary integer array
integer :: imomstr ! Index of MOMENT_STRS & MOMENT_N_STRS
logical :: file_exists ! does tallies.xml file exist?
real(8) :: rarray3(3) ! temporary double prec. array
character(MAX_LINE_LEN) :: filename
@ -2131,7 +2170,7 @@ contains
case default
! Specified tally filter is invalid, raise error
message = "Unknown filter type '" // &
message = "Unknown filter type '" // &
trim(temp_str) // "' on tally " // &
trim(to_str(t % id)) // "."
call fatal_error()
@ -2183,7 +2222,7 @@ contains
t % all_nuclides = .true.
else
! Any other case, e.g. <nuclides>U-235 Pu-239</nuclides>
n_words = get_arraysize_string(node_tal, "nuclides")
n_words = get_arraysize_string(node_tal, "nuclides")
allocate(t % nuclide_bins(n_words))
do j = 1, n_words
! Check if total material was specified
@ -2205,7 +2244,7 @@ contains
word = pair_list % key(1:150)
exit
end if
! Advance to next
pair_list => pair_list % next
end do
@ -2254,79 +2293,110 @@ contains
! READ DATA FOR SCORES
if (check_for_node(node_tal, "scores")) then
! Loop through scores and determine if a scatter-p# input was used
! to allow for proper pre-allocating of t % score_bins
! This scheme allows multiple scatter-p# to be requested by the user
! if so desired
n_words = get_arraysize_string(node_tal, "scores")
allocate(sarray(n_words))
call get_node_array(node_tal, "scores", sarray)
! Before we can allocate storage for scores, we must determine the
! number of additional scores required due to the moment scores
! (i.e., scatter-p#, flux-y#)
n_new = 0
do j = 1, n_words
call lower_case(sarray(j))
! Find if scores(j) is of the form 'scatter-p'
! If so, get the number and do a select case on that.
! Find if scores(j) is of the form 'moment-p' or 'moment-y' present in
! MOMENT_STRS(:)
! If so, check the order, store if OK, then reset the number to 'n'
score_name = trim(sarray(j))
if (starts_with(score_name,'scatter-p')) then
n_order_pos = scan(score_name,'0123456789')
n_order = int(str_to_int( &
score_name(n_order_pos:(len_trim(score_name)))),4)
if (n_order > SCATT_ORDER_MAX) then
! Throw a warning. Set to the maximum number.
! The above scheme will essentially take the absolute value
message = "Invalid scattering order of " // trim(to_str(n_order)) // &
" requested. Setting to the maximum permissible value, " // &
trim(to_str(SCATT_ORDER_MAX))
call warning()
n_order = SCATT_ORDER_MAX
sarray(j) = SCATT_ORDER_MAX_PNSTR
do imomstr = 1, size(MOMENT_STRS)
if (starts_with(score_name,trim(MOMENT_STRS(imomstr)))) then
n_order_pos = scan(score_name,'0123456789')
n_order = int(str_to_int( &
score_name(n_order_pos:(len_trim(score_name)))),4)
if (n_order > MAX_ANG_ORDER) then
! User requested too many orders; throw a warning and set to the
! maximum order.
! The above scheme will essentially take the absolute value
message = "Invalid scattering order of " // trim(to_str(n_order)) // &
" requested. Setting to the maximum permissible value, " // &
trim(to_str(MAX_ANG_ORDER))
call warning()
n_order = MAX_ANG_ORDER
sarray(j) = trim(MOMENT_STRS(imomstr)) // &
trim(to_str(MAX_ANG_ORDER))
end if
! Find total number of bins for this case
if (imomstr >= YN_LOC) then
n_bins = (n_order + 1)**2
else
n_bins = n_order + 1
end if
! We subtract one since n_words already included
n_new = n_new + n_bins - 1
exit
end if
n_new = n_new + n_order
end if
end do
end do
n_scores = n_words + n_new
! Allocate accordingly
! Allocate score storage accordingly
allocate(t % score_bins(n_scores))
allocate(t % scatt_order(n_scores))
t % scatt_order = 0
allocate(t % moment_order(n_scores))
t % moment_order = 0
j = 0
do l = 1, n_words
j = j + 1
! Get the input string in scores(l) but if scatter-n or scatter-pn
! then strip off the n, and store it as an integer to be used later
! Peform the select case on this modified (number removed) string
! Get the input string in scores(l) but if score is one of the moment
! scores then strip off the n and store it as an integer to be used
! later. Then perform the select case on this modified (number removed) string
score_name = sarray(l)
if (starts_with(score_name,'scatter-p')) then
n_order_pos = scan(score_name,'0123456789')
n_order = int(str_to_int( &
score_name(n_order_pos:(len_trim(score_name)))),4)
if (n_order > SCATT_ORDER_MAX) then
! Throw a warning. Set to the maximum number.
! The above scheme will essentially take the absolute value
message = "Invalid scattering order of " // trim(to_str(n_order)) // &
" requested. Setting to the maximum permissible value, " // &
trim(to_str(SCATT_ORDER_MAX))
call warning()
n_order = SCATT_ORDER_MAX
do imomstr = 1, size(MOMENT_STRS)
if (starts_with(score_name,trim(MOMENT_STRS(imomstr)))) then
n_order_pos = scan(score_name,'0123456789')
n_order = int(str_to_int( &
score_name(n_order_pos:(len_trim(score_name)))),4)
if (n_order > MAX_ANG_ORDER) then
! User requested too many orders; throw a warning and set to the
! maximum order.
! The above scheme will essentially take the absolute value
message = "Invalid scattering order of " // trim(to_str(n_order)) // &
" requested. Setting to the maximum permissible value, " // &
trim(to_str(MAX_ANG_ORDER))
call warning()
n_order = MAX_ANG_ORDER
end if
score_name = trim(MOMENT_STRS(imomstr)) // "n"
! Find total number of bins for this case
if (imomstr >= YN_LOC) then
n_bins = (n_order + 1)**2
else
n_bins = n_order + 1
end if
exit
end if
score_name = "scatter-pn"
else if (starts_with(score_name,'scatter-')) then
n_order_pos = scan(score_name,'0123456789')
n_order = int(str_to_int( &
score_name(n_order_pos:(len_trim(score_name)))),4)
if (n_order > SCATT_ORDER_MAX) then
! Throw a warning. Set to the maximum number.
! The above scheme will essentially take the absolute value
message = "Invalid scattering order of " // trim(to_str(n_order)) // &
" requested. Setting to the maximum permissible value, " // &
trim(to_str(SCATT_ORDER_MAX))
call warning()
n_order = SCATT_ORDER_MAX
end if
score_name = "scatter-n"
end do
! Now check the Moment_N_Strs, but only if we werent successful above
if (imomstr > size(MOMENT_STRS)) then
do imomstr = 1, size(MOMENT_N_STRS)
if (starts_with(score_name,trim(MOMENT_N_STRS(imomstr)))) then
n_order_pos = scan(score_name,'0123456789')
n_order = int(str_to_int( &
score_name(n_order_pos:(len_trim(score_name)))),4)
if (n_order > MAX_ANG_ORDER) then
! User requested too many orders; throw a warning and set to the
! maximum order.
! The above scheme will essentially take the absolute value
message = "Invalid scattering order of " // trim(to_str(n_order)) // &
" requested. Setting to the maximum permissible value, " // &
trim(to_str(MAX_ANG_ORDER))
call warning()
n_order = MAX_ANG_ORDER
end if
score_name = trim(MOMENT_N_STRS(imomstr)) // "n"
exit
end if
end do
end if
select case (trim(score_name))
case ('flux')
! Prohibit user from tallying flux for an individual nuclide
@ -2341,6 +2411,23 @@ contains
message = "Cannot tally flux with an outgoing energy filter."
call fatal_error()
end if
case ('flux-yn')
! Prohibit user from tallying flux for an individual nuclide
if (.not. (t % n_nuclide_bins == 1 .and. &
t % nuclide_bins(1) == -1)) then
message = "Cannot tally flux for an individual nuclide."
call fatal_error()
end if
if (t % find_filter(FILTER_ENERGYOUT) > 0) then
message = "Cannot tally flux with an outgoing energy filter."
call fatal_error()
end if
t % score_bins(j : j + n_bins - 1) = SCORE_FLUX_YN
t % moment_order(j : j + n_bins - 1) = n_order
j = j + n_bins - 1
case ('total')
t % score_bins(j) = SCORE_TOTAL
if (t % find_filter(FILTER_ENERGYOUT) > 0) then
@ -2348,9 +2435,21 @@ contains
&outgoing energy filter."
call fatal_error()
end if
case ('total-yn')
if (t % find_filter(FILTER_ENERGYOUT) > 0) then
message = "Cannot tally total reaction rate with an &
&outgoing energy filter."
call fatal_error()
end if
t % score_bins(j : j + n_bins - 1) = SCORE_TOTAL_YN
t % moment_order(j : j + n_bins - 1) = n_order
j = j + n_bins - 1
case ('scatter')
t % score_bins(j) = SCORE_SCATTER
case ('nu-scatter')
t % score_bins(j) = SCORE_NU_SCATTER
@ -2364,22 +2463,53 @@ contains
! Set tally estimator to analog
t % estimator = ESTIMATOR_ANALOG
end if
t % scatt_order(j) = n_order
t % moment_order(j) = n_order
case ('nu-scatter-n')
! Set tally estimator to analog
t % estimator = ESTIMATOR_ANALOG
if (n_order == 0) then
t % score_bins(j) = SCORE_NU_SCATTER
else
t % score_bins(j) = SCORE_NU_SCATTER_N
end if
t % moment_order(j) = n_order
case ('scatter-pn')
t % estimator = ESTIMATOR_ANALOG
! Setup P0:Pn
t % score_bins(j : j + n_order) = SCORE_SCATTER_PN
t % scatt_order(j : j + n_order) = n_order
j = j + n_order
t % score_bins(j : j + n_bins - 1) = SCORE_SCATTER_PN
t % moment_order(j : j + n_bins - 1) = n_order
j = j + n_bins - 1
case ('nu-scatter-pn')
t % estimator = ESTIMATOR_ANALOG
! Setup P0:Pn
t % score_bins(j : j + n_bins - 1) = SCORE_NU_SCATTER_PN
t % moment_order(j : j + n_bins - 1) = n_order
j = j + n_bins - 1
case ('scatter-yn')
t % estimator = ESTIMATOR_ANALOG
! Setup P0:Pn
t % score_bins(j : j + n_bins - 1) = SCORE_SCATTER_YN
t % moment_order(j : j + n_bins - 1) = n_order
j = j + n_bins - 1
case ('nu-scatter-yn')
t % estimator = ESTIMATOR_ANALOG
! Setup P0:Pn
t % score_bins(j : j + n_bins - 1) = SCORE_NU_SCATTER_YN
t % moment_order(j : j + n_bins - 1) = n_order
j = j + n_bins - 1
case('transport')
t % score_bins(j) = SCORE_TRANSPORT
! Set tally estimator to analog
t % estimator = ESTIMATOR_ANALOG
case ('diffusion')
message = "Diffusion score no longer supported for tallies, &
message = "Diffusion score no longer supported for tallies, &
&please remove"
call fatal_error()
case ('n1n')
@ -2482,14 +2612,14 @@ contains
t % score_bins(j) = MT
else
message = "Invalid MT on <scores>: " // &
trim(sarray(j))
trim(sarray(l))
call fatal_error()
end if
else
! Specified score was not an integer
message = "Unknown scoring function: " // &
trim(sarray(j))
trim(sarray(l))
call fatal_error()
end if
@ -2638,7 +2768,7 @@ contains
pl % path_plot = trim(path_input) // trim(to_str(pl % id)) // &
"_" // trim(filename) // ".voxel"
end select
! Copy plot pixel size
if (pl % type == PLOT_TYPE_SLICE) then
if (get_arraysize_integer(node_plot, "pixels") == 2) then
@ -2661,7 +2791,7 @@ contains
! Copy plot background color
if (check_for_node(node_plot, "background")) then
if (pl % type == PLOT_TYPE_VOXEL) then
message = "Background color ignored in voxel plot " // &
message = "Background color ignored in voxel plot " // &
trim(to_str(pl % id))
call warning()
end if
@ -2675,7 +2805,7 @@ contains
else
pl % not_found % rgb = (/ 255, 255, 255 /)
end if
! Copy plot basis
if (pl % type == PLOT_TYPE_SLICE) then
temp_str = 'xy'
@ -2690,12 +2820,12 @@ contains
case ("yz")
pl % basis = PLOT_BASIS_YZ
case default
message = "Unsupported plot basis '" // trim(temp_str) &
message = "Unsupported plot basis '" // trim(temp_str) &
// "' in plot " // trim(to_str(pl % id))
call fatal_error()
end select
end if
! Copy plotting origin
if (get_arraysize_double(node_plot, "origin") == 3) then
call get_node_array(node_plot, "origin", pl % origin)
@ -2762,13 +2892,13 @@ contains
! Copy user specified colors
if (n_cols /= 0) then
if (pl % type == PLOT_TYPE_VOXEL) then
message = "Color specifications ignored in voxel plot " // &
message = "Color specifications ignored in voxel plot " // &
trim(to_str(pl % id))
call warning()
end if
do j = 1, n_cols
! Get pointer to color spec XML node
@ -2778,7 +2908,7 @@ contains
if (get_arraysize_double(node_col, "rgb") /= 3) then
message = "Bad RGB " &
// "in plot " // trim(to_str(pl % id))
call fatal_error()
call fatal_error()
end if
! Ensure that there is an id for this color specification
@ -2821,13 +2951,13 @@ contains
call get_node_list(node_plot, "mask", node_mask_list)
n_masks = get_list_size(node_mask_list)
if (n_masks /= 0) then
if (pl % type == PLOT_TYPE_VOXEL) then
message = "Mask ignored in voxel plot " // &
message = "Mask ignored in voxel plot " // &
trim(to_str(pl % id))
call warning()
end if
select case(n_masks)
case default
message = "Mutliple masks" // &
@ -2848,14 +2978,14 @@ contains
end if
allocate(iarray(n_comp))
call get_node_array(node_mask, "components", iarray)
! First we need to change the user-specified identifiers to indices
! in the cell and material arrays
do j=1, n_comp
col_id = iarray(j)
if (pl % color_by == PLOT_COLOR_CELLS) then
if (cell_dict % has_key(col_id)) then
iarray(j) = cell_dict % get_key(col_id)
else
@ -2863,9 +2993,9 @@ contains
" specified in the mask in plot " // trim(to_str(pl % id))
call fatal_error()
end if
else if (pl % color_by == PLOT_COLOR_MATS) then
if (material_dict % has_key(col_id)) then
iarray(j) = material_dict % get_key(col_id)
else
@ -2873,10 +3003,10 @@ contains
" specified in the mask in plot " // trim(to_str(pl % id))
call fatal_error()
end if
end if
end if
end do
! Alter colors based on mask information
do j=1,size(pl % colors)
if (.not. any(j .eq. iarray)) then
@ -2891,9 +3021,9 @@ contains
end do
deallocate(iarray)
end select
end if
! Add plot to dictionary
@ -2933,7 +3063,7 @@ contains
"' does not exist!"
call fatal_error()
end if
message = "Reading cross sections XML file..."
call write_message(5)
@ -3114,8 +3244,7 @@ contains
call list_density % append(density * 0.801_8)
case ('c')
! The evaluation of Carbon in ENDF/B-VII.1 and JEFF 3.1.2 is a natural
! element, i.e. it's not possible to split into C-12 and C-13.
! No evaluations split up Carbon into isotopes yet
call list_names % append('6000.' // xs)
call list_density % append(density)
@ -3126,12 +3255,22 @@ contains
call list_density % append(density * 0.00364_8)
case ('o')
! O-18 does not exist in ENDF/B-VII.1 or JEFF 3.1.2 so its 0.205% has been
! added to O-16. The isotopic abundance for O-16 is ordinarily 99.757%.
call list_names % append('8016.' // xs)
call list_density % append(density * 0.99962_8)
call list_names % append('8017.' // xs)
call list_density % append(density * 0.00038_8)
if (default_expand == JEFF_32) then
call list_names % append('8016.' // xs)
call list_density % append(density * 0.99757_8)
call list_names % append('8017.' // xs)
call list_density % append(density * 0.00038_8)
call list_names % append('8018.' // xs)
call list_density % append(density * 0.00205_8)
elseif (default_expand >= JENDL_32 .and. default_expand <= JENDL_40) then
call list_names % append('8016.' // xs)
call list_density % append(density)
else
call list_names % append('8016.' // xs)
call list_density % append(density * 0.99962_8)
call list_names % append('8017.' // xs)
call list_density % append(density * 0.00038_8)
end if
case ('f')
call list_names % append('9019.' // xs)
@ -3236,13 +3375,17 @@ contains
call list_density % append(density * 0.0518_8)
case ('v')
! The evaluation of Vanadium in ENDF/B-VII.1 and JEFF 3.1.2 is a natural
! element. The IUPAC isotopic composition specifies the following
! breakdown which is not used:
! V-50 = 0.250%
! V-51 = 99.750%
call list_names % append('23000.' // xs)
call list_density % append(density)
if (default_expand == ENDF_BVII0 .or. default_expand == JEFF_311 &
.or. default_expand == JEFF_32 .or. &
(default_expand >= JENDL_32 .and. default_expand <= JENDL_33)) then
call list_names % append('23000.' // xs)
call list_density % append(density)
else
call list_names % append('23050.' // xs)
call list_density % append(density * 0.0025_8)
call list_names % append('23051.' // xs)
call list_density % append(density * 0.9975_8)
end if
case ('cr')
call list_names % append('24050.' // xs)
@ -3291,24 +3434,33 @@ contains
call list_density % append(density * 0.3085_8)
case ('zn')
! The evaluation of Zinc in ENDF/B-VII.1 is a natural element. The IUPAC
! isotopic composition specifies the following breakdown which is not used
! here:
! Zn-64 = 48.63%
! Zn-66 = 27.90%
! Zn-67 = 4.10%
! Zn-68 = 18.75%
! Zn-70 = 0.62%
call list_names % append('30000.' // xs)
call list_density % append(density)
if (default_expand == ENDF_BVII0 .or. default_expand == &
JEFF_311 .or. default_expand == JEFF_312) then
call list_names % append('30000.' // xs)
call list_density % append(density)
else
call list_names % append('30064.' // xs)
call list_density % append(density * 0.4917_8)
call list_names % append('30066.' // xs)
call list_density % append(density * 0.2773_8)
call list_names % append('30067.' // xs)
call list_density % append(density * 0.0404_8)
call list_names % append('30068.' // xs)
call list_density % append(density * 0.1845_8)
call list_names % append('30070.' // xs)
call list_density % append(density * 0.0061_8)
end if
case ('ga')
! JEFF 3.1.2 does not have evaluations for Ga-69 and Ga-71, only for
! natural Gallium, so this may cause problems.
call list_names % append('31069.' // xs)
call list_density % append(density * 0.60108_8)
call list_names % append('31071.' // xs)
call list_density % append(density * 0.39892_8)
if (default_expand == JEFF_311 .or. default_expand == JEFF_312) then
call list_names % append('31000.' // xs)
call list_density % append(density)
else
call list_names % append('31069.' // xs)
call list_density % append(density * 0.60108_8)
call list_names % append('31071.' // xs)
call list_density % append(density * 0.39892_8)
end if
case ('ge')
call list_names % append('32070.' // xs)
@ -3719,24 +3871,43 @@ contains
call list_density % append(density * 0.3508_8)
case ('ta')
call list_names % append('73180.' // xs)
call list_density % append(density * 0.0001201_8)
call list_names % append('73181.' // xs)
call list_density % append(density * 0.9998799_8)
if (default_expand == ENDF_BVII0 .or. &
(default_expand >= JEFF_311 .and. default_expand <= JEFF_312) .or. &
(default_expand >= JENDL_32 .and. default_expand <= JENDL_40)) then
call list_names % append('73181.' // xs)
call list_density % append(density)
else
call list_names % append('73180.' // xs)
call list_density % append(density * 0.0001201_8)
call list_names % append('73181.' // xs)
call list_density % append(density * 0.9998799_8)
end if
case ('w')
! ENDF/B-VII.0 does not have W-180 so this may cause problems. However, it
! has been added as of ENDF/B-VII.1
call list_names % append('74180.' // xs)
call list_density % append(density * 0.0012_8)
call list_names % append('74182.' // xs)
call list_density % append(density * 0.2650_8)
call list_names % append('74183.' // xs)
call list_density % append(density * 0.1431_8)
call list_names % append('74184.' // xs)
call list_density % append(density * 0.3064_8)
call list_names % append('74186.' // xs)
call list_density % append(density * 0.2843_8)
if (default_expand == ENDF_BVII0 .or. default_expand == JEFF_311 &
.or. default_expand == JEFF_312 .or. &
(default_expand >= JENDL_32 .and. default_expand <= JENDL_33)) then
! Combine W-180 with W-182
call list_names % append('74182.' // xs)
call list_density % append(density * 0.2662_8)
call list_names % append('74183.' // xs)
call list_density % append(density * 0.1431_8)
call list_names % append('74184.' // xs)
call list_density % append(density * 0.3064_8)
call list_names % append('74186.' // xs)
call list_density % append(density * 0.2843_8)
else
call list_names % append('74180.' // xs)
call list_density % append(density * 0.0012_8)
call list_names % append('74182.' // xs)
call list_density % append(density * 0.2650_8)
call list_names % append('74183.' // xs)
call list_density % append(density * 0.1431_8)
call list_names % append('74184.' // xs)
call list_density % append(density * 0.3064_8)
call list_names % append('74186.' // xs)
call list_density % append(density * 0.2843_8)
end if
case ('re')
call list_names % append('75185.' // xs)
@ -3745,20 +3916,25 @@ contains
call list_density % append(density * 0.6260_8)
case ('os')
call list_names % append('76184.' // xs)
call list_density % append(density * 0.0002_8)
call list_names % append('76186.' // xs)
call list_density % append(density * 0.0159_8)
call list_names % append('76187.' // xs)
call list_density % append(density * 0.0196_8)
call list_names % append('76188.' // xs)
call list_density % append(density * 0.1324_8)
call list_names % append('76189.' // xs)
call list_density % append(density * 0.1615_8)
call list_names % append('76190.' // xs)
call list_density % append(density * 0.2626_8)
call list_names % append('76192.' // xs)
call list_density % append(density * 0.4078_8)
if (default_expand == JEFF_311 .or. default_expand == JEFF_312) then
call list_names % append('76000.' // xs)
call list_density % append(density)
else
call list_names % append('76184.' // xs)
call list_density % append(density * 0.0002_8)
call list_names % append('76186.' // xs)
call list_density % append(density * 0.0159_8)
call list_names % append('76187.' // xs)
call list_density % append(density * 0.0196_8)
call list_names % append('76188.' // xs)
call list_density % append(density * 0.1324_8)
call list_names % append('76189.' // xs)
call list_density % append(density * 0.1615_8)
call list_names % append('76190.' // xs)
call list_density % append(density * 0.2626_8)
call list_names % append('76192.' // xs)
call list_density % append(density * 0.4078_8)
end if
case ('ir')
call list_names % append('77191.' // xs)
@ -3767,18 +3943,23 @@ contains
call list_density % append(density * 0.627_8)
case ('pt')
call list_names % append('78190.' // xs)
call list_density % append(density * 0.00012_8)
call list_names % append('78192.' // xs)
call list_density % append(density * 0.00782_8)
call list_names % append('78194.' // xs)
call list_density % append(density * 0.3286_8)
call list_names % append('78195.' // xs)
call list_density % append(density * 0.3378_8)
call list_names % append('78196.' // xs)
call list_density % append(density * 0.2521_8)
call list_names % append('78198.' // xs)
call list_density % append(density * 0.07356_8)
if (default_expand == JEFF_311 .or. default_expand == JEFF_312) then
call list_names % append('78000.' // xs)
call list_density % append(density)
else
call list_names % append('78190.' // xs)
call list_density % append(density * 0.00012_8)
call list_names % append('78192.' // xs)
call list_density % append(density * 0.00782_8)
call list_names % append('78194.' // xs)
call list_density % append(density * 0.3286_8)
call list_names % append('78195.' // xs)
call list_density % append(density * 0.3378_8)
call list_names % append('78196.' // xs)
call list_density % append(density * 0.2521_8)
call list_names % append('78198.' // xs)
call list_density % append(density * 0.07356_8)
end if
case ('au')
call list_names % append('79197.' // xs)
@ -3801,10 +3982,15 @@ contains
call list_density % append(density * 0.0687_8)
case ('tl')
call list_names % append('81203.' // xs)
call list_density % append(density * 0.2952_8)
call list_names % append('81205.' // xs)
call list_density % append(density * 0.7048_8)
if (default_expand == JEFF_311 .or. default_expand == JEFF_312) then
call list_names % append('81000.' // xs)
call list_density % append(density)
else
call list_names % append('81203.' // xs)
call list_density % append(density * 0.2952_8)
call list_names % append('81205.' // xs)
call list_density % append(density * 0.7048_8)
end if
case ('pb')
call list_names % append('82204.' // xs)

400
src/math.F90
View file

@ -1,6 +1,6 @@
module math
use constants, only: PI, ONE, TWO
use constants, only: PI, ONE, TWO, ZERO
use random_lcg, only: prn
implicit none
@ -116,20 +116,20 @@ contains
!===============================================================================
! CALC_PN calculates the n-th order Legendre polynomial at the value of x.
! Since this function is called repeatedly during the neutron transport process,
! neither n or x is checked to see if they are in the applicable range.
! neither n or x is checked to see if they are in the applicable range.
! This is left to the client developer to use where applicable. x is to be in
! the domain of [-1,1], and 0<=n<=5. If x is outside of the range, the return
! value will be outside the expected range; if n is outside the stated range,
! value will be outside the expected range; if n is outside the stated range,
! the return value will be 1.0.
!===============================================================================
pure function calc_pn(n,x) result(pnx)
integer, intent(in) :: n ! Legendre order requested
real(8), intent(in) :: x ! Independent variable the Legendre is to be
real(8), intent(in) :: x ! Independent variable the Legendre is to be
! evaluated at; x must be in the domain [-1,1]
real(8) :: pnx ! The Legendre poly of order n evaluated at x
select case(n)
case(1)
pnx = x
@ -144,7 +144,7 @@ contains
case(6)
pnx = 14.4375_8 * (x ** 6) - 19.6875_8 * (x ** 4) + &
6.5625_8 * x * x - 0.3125_8
case(7)
case(7)
pnx = 26.8125_8 * (x ** 7) - 43.3125_8 * (x ** 5) + &
19.6875_8 * x * x * x - 2.1875_8 * x
case(8)
@ -160,9 +160,393 @@ contains
case default
pnx = ONE ! correct for case(0), incorrect for the rest
end select
end function calc_pn
!===============================================================================
! CALC_RN calculates the n-th order spherical harmonics for a given angle
! (in terms of (u,v,w)). All Rn,m values are provided (where -n<=m<=n)
!===============================================================================
pure function calc_rn(n,uvw) result(rn)
integer, intent(in) :: n ! Order requested
real(8), intent(in) :: uvw(3) ! Direction of travel, assumed to be on unit sphere
real(8) :: rn(2*n + 1) ! The resultant R_n(uvw)
real(8) :: phi, w ! Azimuthal and Cosine of Polar angles (from uvw)
real(8) :: w2m1 ! (w^2 - 1), frequently used in these
w = uvw(3) ! z = cos(polar)
if (uvw(1) == ZERO) then
phi = ZERO
else
! phi = atan(uvw(2) / uvw(1))
phi = atan2(uvw(2), uvw(1))
end if
w2m1 = (ONE - w**2)
select case(n)
case (0)
! l = 0, m = 0
rn(1) = ONE
case (1)
! l = 1, m = -1
rn(1) = ONE*sqrt(w2m1) * sin(phi)
! l = 1, m = 0
rn(2) = ONE * w
! l = 1, m = 1
rn(3) = ONE*sqrt(w2m1) * cos(phi)
case (2)
! l = 2, m = -2
rn(1) = 0.288675134594813_8 * (-3.0_8 * w**2 + 3.0_8) * sin(TWO*phi)
! l = 2, m = -1
rn(2) = 1.73205080756888_8 * w*sqrt(w2m1) * sin(phi)
! l = 2, m = 0
rn(3) = 1.5_8 * w**2 - 0.5_8
! l = 2, m = 1
rn(4) = 1.73205080756888_8 * w*sqrt(w2m1) * cos(phi)
! l = 2, m = 2
rn(5) = 0.288675134594813_8 * (-3.0_8 * w**2 + 3.0_8) * cos(TWO*phi)
case (3)
! l = 3, m = -3
rn(1) = 0.790569415042095_8 * (w2m1)**(3.0_8/TWO) * sin(3.0_8 * phi)
! l = 3, m = -2
rn(2) = 1.93649167310371_8 * w*(w2m1) * sin(TWO*phi)
! l = 3, m = -1
rn(3) = 0.408248290463863_8*sqrt(w2m1)*((15.0_8/TWO)*w**2 - 3.0_8/TWO) * &
sin(phi)
! l = 3, m = 0
rn(4) = 2.5_8 * w**3 - 1.5_8 * w
! l = 3, m = 1
rn(5) = 0.408248290463863_8*sqrt(w2m1)*((15.0_8/TWO)*w**2 - 3.0_8/TWO) * &
cos(phi)
! l = 3, m = 2
rn(6) = 1.93649167310371_8 * w*(w2m1) * cos(TWO*phi)
! l = 3, m = 3
rn(7) = 0.790569415042095_8 * (w2m1)**(3.0_8/TWO) * cos(3.0_8* phi)
case (4)
! l = 4, m = -4
rn(1) = 0.739509972887452_8 * (w2m1)**2 * sin(4.0_8*phi)
! l = 4, m = -3
rn(2) = 2.09165006633519_8 * w*(w2m1)**(3.0_8/TWO) * sin(3.0_8* phi)
! l = 4, m = -2
rn(3) = 0.074535599249993_8 * (w2m1)*((105.0_8/TWO)*w**2 - 15.0_8/TWO) * &
sin(TWO*phi)
! l = 4, m = -1
rn(4) = 0.316227766016838_8*sqrt(w2m1)*((35.0_8/TWO)*w**3 - 15.0_8/TWO*w) * &
sin(phi)
! l = 4, m = 0
rn(5) = 4.375_8 * w**4 - 3.75_8 * w**2 + 0.375_8
! l = 4, m = 1
rn(6) = 0.316227766016838_8*sqrt(w2m1)*((35.0_8/TWO)*w**3 - 15.0_8/TWO*w) * &
cos(phi)
! l = 4, m = 2
rn(7) = 0.074535599249993_8 * (w2m1)*((105.0_8/TWO)*w**2 - 15.0_8/TWO) * &
cos(TWO*phi)
! l = 4, m = 3
rn(8) = 2.09165006633519_8 * w*(w2m1)**(3.0_8/TWO) * cos(3.0_8* phi)
! l = 4, m = 4
rn(9) = 0.739509972887452_8 * (w2m1)**2 * cos(4.0_8*phi)
case (5)
! l = 5, m = -5
rn(1) = 0.701560760020114_8 * (w2m1)**(5.0_8/TWO) * sin(5.0_8*phi)
! l = 5, m = -4
rn(2) = 2.21852991866236_8 * w*(w2m1)**2 * sin(4.0_8*phi)
! l = 5, m = -3
rn(3) = 0.00996023841111995_8 * (w2m1)**(3.0_8/TWO)* &
((945.0_8 /TWO)*w**2 - 105.0_8/TWO) * sin(3.0_8*phi)
! l = 5, m = -2
rn(4) = 0.0487950036474267_8 * (w2m1)*((315.0_8/TWO)*w**3 - 105.0_8/TWO*w) * &
sin(TWO*phi)
! l = 5, m = -1
rn(5) = 0.258198889747161_8*sqrt(w2m1)* &
((315.0_8/8.0_8)*w**4 - 105.0_8/4.0_8 * w**2 + 15.0_8/8.0_8) * sin(phi)
! l = 5, m = 0
rn(6) = 7.875_8 * w**5 - 8.75_8 * w**3 + 1.875_8 * w
! l = 5, m = 1
rn(7) = 0.258198889747161_8*sqrt(w2m1)* &
((315.0_8/8.0_8)*w**4 - 105.0_8/4.0_8 * w**2 + 15.0_8/8.0_8) * cos(phi)
! l = 5, m = 2
rn(8) = 0.0487950036474267_8 * (w2m1)* &
((315.0_8/TWO)*w**3 - 105.0_8/TWO*w) * cos(TWO*phi)
! l = 5, m = 3
rn(9) = 0.00996023841111995_8 * (w2m1)**(3.0_8/TWO)* &
((945.0_8 /TWO)*w**2 - 105.0_8/TWO) * cos(3.0_8*phi)
! l = 5, m = 4
rn(10) = 2.21852991866236_8 * w*(w2m1)**2 * cos(4.0_8*phi)
! l = 5, m = 5
rn(11) = 0.701560760020114_8 * (w2m1)**(5.0_8/TWO) * cos(5.0_8* phi)
case (6)
! l = 6, m = -6
rn(1) = 0.671693289381396_8 * (w2m1)**3 * sin(6.0_8*phi)
! l = 6, m = -5
rn(2) = 2.32681380862329_8 * w*(w2m1)**(5.0_8/TWO) * sin(5.0_8*phi)
! l = 6, m = -4
rn(3) = 0.00104990131391452_8 * (w2m1)**2 * &
((10395.0_8/TWO)*w**2 - 945.0_8/TWO) * sin(4.0_8*phi)
! l = 6, m = -3
rn(4) = 0.00575054632785295_8 * (w2m1)**(3.0_8/TWO) * &
((3465.0_8/TWO)*w**3 - 945.0_8/TWO*w) * sin(3.0_8*phi)
! l = 6, m = -2
rn(5) = 0.0345032779671177_8 * (w2m1) * &
((3465.0_8/8.0_8)*w**4 - 945.0_8/4.0_8 * w**2 + 105.0_8/8.0_8) * sin(TWO*phi)
! l = 6, m = -1
rn(6) = 0.218217890235992_8*sqrt(w2m1) * &
((693.0_8/8.0_8)*w**5- 315.0_8/4.0_8 * w**3 + (105.0_8/8.0_8)*w) * sin(phi)
! l = 6, m = 0
rn(7) = 14.4375_8 * w**6 - 19.6875_8 * w**4 + 6.5625_8 * w**2 - 0.3125_8
! l = 6, m = 1
rn(8) = 0.218217890235992_8*sqrt(w2m1) * &
((693.0_8/8.0_8)*w**5- 315.0_8/4.0_8 * w**3 + (105.0_8/8.0_8)*w) * cos(phi)
! l = 6, m = 2
rn(9) = 0.0345032779671177_8 * (w2m1) * &
((3465.0_8/8.0_8)*w**4 -945.0_8/4.0_8 * w**2 + 105.0_8/8.0_8) * cos(TWO*phi)
! l = 6, m = 3
rn(10) = 0.00575054632785295_8 * (w2m1)**(3.0_8/TWO) * &
((3465.0_8/TWO)*w**3 - 945.0_8/TWO*w) * cos(3.0_8*phi)
! l = 6, m = 4
rn(11) = 0.00104990131391452_8 * (w2m1)**2 * &
((10395.0_8/TWO)*w**2 - 945.0_8/TWO) * cos(4.0_8*phi)
! l = 6, m = 5
rn(12) = 2.32681380862329_8 * w*(w2m1)**(5.0_8/TWO) * cos(5.0_8*phi)
! l = 6, m = 6
rn(13) = 0.671693289381396_8 * (w2m1)**3 * cos(6.0_8*phi)
case (7)
! l = 7, m = -7
rn(1) = 0.647259849287749_8 * (w2m1)**(7.0_8/TWO) * sin(7.0_8*phi)
! l = 7, m = -6
rn(2) = 2.42182459624969_8 * w*(w2m1)**3 * sin(6.0_8*phi)
! l = 7, m = -5
rn(3) = 9.13821798555235d-5*(w2m1)**(5.0_8/TWO)* &
((135135.0_8/TWO)*w**2 - 10395.0_8/TWO) * sin(5.0_8*phi)
! l = 7, m = -4
rn(4) = 0.000548293079133141_8 * (w2m1)**2* &
((45045.0_8/TWO)*w**3 - 10395.0_8/TWO*w) * sin(4.0_8*phi)
! l = 7, m = -3
rn(5) = 0.00363696483726654_8 * (w2m1)**(3.0_8/TWO)* &
((45045.0_8/8.0_8)*w**4 - 10395.0_8/4.0_8 * w**2 + 945.0_8/8.0_8)* &
sin(3.0_8*phi)
! l = 7, m = -2
rn(6) = 0.025717224993682_8 * (w2m1)* &
((9009.0_8/8.0_8)*w**5 -3465.0_8/4.0_8 * w**3 + (945.0_8/8.0_8)*w)* &
sin(TWO*phi)
! l = 7, m = -1
rn(7) = 0.188982236504614_8*sqrt(w2m1)* &
((3003.0_8/16.0_8)*w**6 - 3465.0_8/16.0_8 * w**4 + &
(945.0_8/16.0_8)*w**2 - 35.0_8/16.0_8) * sin(phi)
! l = 7, m = 0
rn(8) = 26.8125_8 * w**7 - 43.3125_8 * w**5 + 19.6875_8 * w**3 -2.1875_8 * w
! l = 7, m = 1
rn(9) = 0.188982236504614_8*sqrt(w2m1)* &
((3003.0_8/16.0_8)*w**6 - 3465.0_8/16.0_8 * w**4 + &
(945.0_8/16.0_8)*w**2 - 35.0_8/16.0_8) * cos(phi)
! l = 7, m = 2
rn(10) = 0.025717224993682_8 * (w2m1)* &
((9009.0_8/8.0_8)*w**5 -3465.0_8/4.0_8 * w**3 + (945.0_8/8.0_8)*w)* &
cos(TWO*phi)
! l = 7, m = 3
rn(11) = 0.00363696483726654_8 * (w2m1)**(3.0_8/TWO)* &
((45045.0_8/8.0_8)*w**4 - 10395.0_8/4.0_8 * w**2 + 945.0_8/8.0_8)* &
cos(3.0_8*phi)
! l = 7, m = 4
rn(12) = 0.000548293079133141_8 * (w2m1)**2 * &
((45045.0_8/TWO)*w**3 - 10395.0_8/TWO*w) * cos(4.0_8*phi)
! l = 7, m = 5
rn(13) = 9.13821798555235d-5*(w2m1)**(5.0_8/TWO)* &
((135135.0_8/TWO)*w**2 - 10395.0_8/TWO) * cos(5.0_8*phi)
! l = 7, m = 6
rn(14) = 2.42182459624969_8 * w*(w2m1)**3 * cos(6.0_8*phi)
! l = 7, m = 7
rn(15) = 0.647259849287749_8 * (w2m1)**(7.0_8/TWO) * cos(7.0_8*phi)
case (8)
! l = 8, m = -8
rn(1) = 0.626706654240044_8 * (w2m1)**4 * sin(8.0_8*phi)
! l = 8, m = -7
rn(2) = 2.50682661696018_8 * w*(w2m1)**(7.0_8/TWO) * sin(7.0_8*phi)
! l = 8, m = -6
rn(3) = 6.77369783729086d-6*(w2m1)**3* &
((2027025.0_8/TWO)*w**2 - 135135.0_8/TWO) * sin(6.0_8*phi)
! l = 8, m = -5
rn(4) = 4.38985792528482d-5*(w2m1)**(5.0_8/TWO)* &
((675675.0_8/TWO)*w**3 - 135135.0_8/TWO*w) * sin(5.0_8*phi)
! l = 8, m = -4
rn(5) = 0.000316557156832328_8 * (w2m1)**2* &
((675675.0_8/8.0_8)*w**4 - 135135.0_8/4.0_8 * w**2 + 10395.0_8/8.0_8) * sin(4.0_8*phi)
! l = 8, m = -3
rn(6) = 0.00245204119306875_8 * (w2m1)**(3.0_8/TWO)* &
((135135.0_8/8.0_8)*w**5 - 45045.0_8/4.0_8 * w**3 + (10395.0_8/8.0_8)*w) * sin(3.0_8*phi)
! l = 8, m = -2
rn(7) = 0.0199204768222399_8 * (w2m1)* &
((45045.0_8/16.0_8)*w**6- 45045.0_8/16.0_8 * w**4 + &
(10395.0_8/16.0_8)*w**2 - 315.0_8/16.0_8) * sin(TWO*phi)
! l = 8, m = -1
rn(8) = 0.166666666666667_8*sqrt(w2m1)* &
((6435.0_8/16.0_8)*w**7 - 9009.0_8/16.0_8 * w**5 + &
(3465.0_8/16.0_8)*w**3 - 315.0_8/16.0_8 * w) * sin(phi)
! l = 8, m = 0
rn(9) = 50.2734375_8 * w**8 - 93.84375_8 * w**6 + 54.140625_8 * w**4 -&
9.84375_8 * w**2 + 0.2734375_8
! l = 8, m = 1
rn(10) = 0.166666666666667_8*sqrt(w2m1)* &
((6435.0_8/16.0_8)*w**7 - 9009.0_8/16.0_8 * w**5 + &
(3465.0_8/16.0_8)*w**3 - 315.0_8/16.0_8 * w) * cos(phi)
! l = 8, m = 2
rn(11) = 0.0199204768222399_8 * (w2m1)*((45045.0_8/16.0_8)*w**6- &
45045.0_8/16.0_8 * w**4 + (10395.0_8/16.0_8)*w**2 - &
315.0_8/16.0_8) * cos(TWO*phi)
! l = 8, m = 3
rn(12) = 0.00245204119306875_8 * (w2m1)**(3.0_8/TWO)* &
((135135.0_8/8.0_8)*w**5 - 45045.0_8/4.0_8 * w**3 + &
(10395.0_8/8.0_8)*w) * cos(3.0_8*phi)
! l = 8, m = 4
rn(13) = 0.000316557156832328_8 * (w2m1)**2*((675675.0_8/8.0_8)*w**4 - &
135135.0_8/4.0_8 * w**2 + 10395.0_8/8.0_8) * cos(4.0_8*phi)
! l = 8, m = 5
rn(14) = 4.38985792528482d-5*(w2m1)**(5.0_8/TWO)*((675675.0_8/TWO)*w**3 - &
135135.0_8/TWO*w) * cos(5.0_8*phi)
! l = 8, m = 6
rn(15) = 6.77369783729086d-6*(w2m1)**3*((2027025.0_8/TWO)*w**2 - &
135135.0_8/TWO) * cos(6.0_8*phi)
! l = 8, m = 7
rn(16) = 2.50682661696018_8 * w*(w2m1)**(7.0_8/TWO) * cos(7.0_8*phi)
! l = 8, m = 8
rn(17) = 0.626706654240044_8 * (w2m1)**4 * cos(8.0_8*phi)
case (9)
! l = 9, m = -9
rn(1) = 0.609049392175524_8 * (w2m1)**(9.0_8/TWO) * sin(9.0_8*phi)
! l = 9, m = -8
rn(2) = 2.58397773170915_8 * w*(w2m1)**4 * sin(8.0_8*phi)
! l = 9, m = -7
rn(3) = 4.37240315267812d-7*(w2m1)**(7.0_8/TWO)* &
((34459425.0_8/TWO)*w**2 - 2027025.0_8/TWO) * sin(7.0_8*phi)
! l = 9, m = -6
rn(4) = 3.02928976464514d-6*(w2m1)**3* &
((11486475.0_8/TWO)*w**3 - 2027025.0_8/TWO*w) * sin(6.0_8*phi)
! l = 9, m = -5
rn(5) = 2.34647776186144d-5*(w2m1)**(5.0_8/TWO)* &
((11486475.0_8/8.0_8)*w**4 - 2027025.0_8/4.0_8 * w**2 + &
135135.0_8/8.0_8) * sin(5.0_8*phi)
! l = 9, m = -4
rn(6) = 0.000196320414650061_8 * (w2m1)**2*((2297295.0_8/8.0_8)*w**5 - &
675675.0_8/4.0_8 * w**3 + (135135.0_8/8.0_8)*w) * sin(4.0_8*phi)
! l = 9, m = -3
rn(7) = 0.00173385495536766_8 * (w2m1)**(3.0_8/TWO)* &
((765765.0_8/16.0_8)*w**6 - 675675.0_8/16.0_8 * w**4 + &
(135135.0_8/16.0_8)*w**2 - 3465.0_8/16.0_8) * sin(3.0_8*phi)
! l = 9, m = -2
rn(8) = 0.0158910431540932_8 * (w2m1)*((109395.0_8/16.0_8)*w**7- &
135135.0_8/16.0_8 * w**5 + (45045.0_8/16.0_8)*w**3 - 3465.0_8/16.0_8 * w)* &
sin(TWO*phi)
! l = 9, m = -1
rn(9) = 0.149071198499986_8*sqrt(w2m1)*((109395.0_8/128.0_8)*w**8 - &
45045.0_8/32.0_8 * w**6 + (45045.0_8/64.0_8)*w**4 - 3465.0_8/32.0_8 * w**2 + 315.0_8/128.0_8) * sin(phi)
! l = 9, m = 0
rn(10) = 94.9609375_8 * w**9 - 201.09375_8 * w**7 + 140.765625_8 * w**5- &
36.09375_8 * w**3 + 2.4609375_8 * w
! l = 9, m = 1
rn(11) = 0.149071198499986_8*sqrt(w2m1)*((109395.0_8/128.0_8)*w**8 - &
45045.0_8/32.0_8 * w**6 + (45045.0_8/64.0_8)*w**4 -3465.0_8/32.0_8 * w**2 + 315.0_8/128.0_8) * cos(phi)
! l = 9, m = 2
rn(12) = 0.0158910431540932_8 * (w2m1)*((109395.0_8/16.0_8)*w**7 - &
135135.0_8/16.0_8 * w**5 + (45045.0_8/16.0_8)*w**3 - 3465.0_8/ 16.0_8 * w) * &
cos(TWO*phi)
! l = 9, m = 3
rn(13) = 0.00173385495536766_8 * (w2m1)**(3.0_8/TWO)*((765765.0_8/16.0_8)*w**6 - &
675675.0_8/16.0_8 * w**4 + (135135.0_8/16.0_8)*w**2 - 3465.0_8/16.0_8)* &
cos(3.0_8*phi)
! l = 9, m = 4
rn(14) = 0.000196320414650061_8 * (w2m1)**2*((2297295.0_8/8.0_8)*w**5 - &
675675.0_8/4.0_8 * w**3 + (135135.0_8/8.0_8)*w) * cos(4.0_8*phi)
! l = 9, m = 5
rn(15) = 2.34647776186144d-5*(w2m1)**(5.0_8/TWO)*((11486475.0_8/8.0_8)* &
w**4 - 2027025.0_8/4.0_8 * w**2 + 135135.0_8/8.0_8) * cos(5.0_8*phi)
! l = 9, m = 6
rn(16) = 3.02928976464514d-6*(w2m1)**3*((11486475.0_8/TWO)*w**3 - &
2027025.0_8/TWO*w) * cos(6.0_8*phi)
! l = 9, m = 7
rn(17) = 4.37240315267812d-7*(w2m1)**(7.0_8/TWO)* &
((34459425.0_8/TWO)*w**2 - 2027025.0_8/TWO) * cos(7.0_8*phi)
! l = 9, m = 8
rn(18) = 2.58397773170915_8 * w*(w2m1)**4 * cos(8.0_8*phi)
! l = 9, m = 9
rn(19) = 0.609049392175524_8 * (w2m1)**(9.0_8/TWO) * cos(9.0_8*phi)
case (10)
! l = 10, m = -10
rn(1) = 0.593627917136573_8 * (w2m1)**5 * sin(10.0_8*phi)
! l = 10, m = -9
rn(2) = 2.65478475211798_8 * w*(w2m1)**(9.0_8/TWO) * sin(9.0_8*phi)
! l = 10, m = -8
rn(3) = 2.49953651452314d-8*(w2m1)**4*((654729075.0_8/TWO)*w**2 - &
34459425.0_8/TWO) * sin(8.0_8*phi)
! l = 10, m = -7
rn(4) = 1.83677671621093d-7*(w2m1)**(7.0_8/TWO)* &
((218243025.0_8/TWO)*w**3 - 34459425.0_8/TWO*w) * sin(7.0_8*phi)
! l = 10, m = -6
rn(5) = 1.51464488232257d-6*(w2m1)**3*((218243025.0_8/8.0_8)*w**4 - &
34459425.0_8/4.0_8 * w**2 + 2027025.0_8/8.0_8) * sin(6.0_8*phi)
! l = 10, m = -5
rn(6) = 1.35473956745817d-5*(w2m1)**(5.0_8/TWO)* &
((43648605.0_8/8.0_8)*w**5 - 11486475.0_8/4.0_8 * w**3 + &
(2027025.0_8/8.0_8)*w) * sin(5.0_8*phi)
! l = 10, m = -4
rn(7) = 0.000128521880085575_8 * (w2m1)**2*((14549535.0_8/16.0_8)*w**6 - &
11486475.0_8/16.0_8 * w**4 + (2027025.0_8/16.0_8)*w**2 - &
45045.0_8/16.0_8) * sin(4.0_8*phi)
! l = 10, m = -3
rn(8) = 0.00127230170115096_8 * (w2m1)**(3.0_8/TWO)* &
((2078505.0_8/16.0_8)*w**7 - 2297295.0_8/16.0_8 * w**5 + &
(675675.0_8/16.0_8)*w**3 - 45045.0_8/16.0_8 * w) * sin(3.0_8*phi)
! l = 10, m = -2
rn(9) = 0.012974982402692_8 * (w2m1)*((2078505.0_8/128.0_8)*w**8 - &
765765.0_8/32.0_8 * w**6 + (675675.0_8/64.0_8)*w**4 - &
45045.0_8/32.0_8 * w**2 + 3465.0_8/128.0_8) * sin(TWO*phi)
! l = 10, m = -1
rn(10) = 0.134839972492648_8*sqrt(w2m1)*((230945.0_8/128.0_8)*w**9 - &
109395.0_8/32.0_8 * w**7 + (135135.0_8/64.0_8)*w**5 - &
15015.0_8/32.0_8 * w**3 + (3465.0_8/128.0_8)*w) * sin(phi)
! l = 10, m = 0
rn(11) = 180.42578125_8 * w**10 - 427.32421875_8 * w**8 +351.9140625_8 * w**6 - &
117.3046875_8 * w**4 + 13.53515625_8 * w**2 -0.24609375_8
! l = 10, m = 1
rn(12) = 0.134839972492648_8*sqrt(w2m1)*((230945.0_8/128.0_8)*w**9 - &
109395.0_8/32.0_8 * w**7 + (135135.0_8/64.0_8)*w**5 -15015.0_8/ &
32.0_8 * w**3 + (3465.0_8/128.0_8)*w) * cos(phi)
! l = 10, m = 2
rn(13) = 0.012974982402692_8 * (w2m1)*((2078505.0_8/128.0_8)*w**8 - &
765765.0_8/32.0_8 * w**6 + (675675.0_8/64.0_8)*w**4 -&
45045.0_8/32.0_8 * w**2 + 3465.0_8/128.0_8) * cos(TWO*phi)
! l = 10, m = 3
rn(14) = 0.00127230170115096_8 * (w2m1)**(3.0_8/TWO)* &
((2078505.0_8/16.0_8)*w**7 - 2297295.0_8/16.0_8 * w**5 + &
(675675.0_8/16.0_8)*w**3 - 45045.0_8/16.0_8 * w) * cos(3.0_8*phi)
! l = 10, m = 4
rn(15) = 0.000128521880085575_8 * (w2m1)**2*((14549535.0_8/16.0_8)*w**6 - &
11486475.0_8/16.0_8 * w**4 + (2027025.0_8/16.0_8)*w**2 - &
45045.0_8/16.0_8) * cos(4.0_8*phi)
! l = 10, m = 5
rn(16) = 1.35473956745817d-5*(w2m1)**(5.0_8/TWO)* &
((43648605.0_8/8.0_8)*w**5 - 11486475.0_8/4.0_8 * w**3 + &
(2027025.0_8/8.0_8)*w) * cos(5.0_8*phi)
! l = 10, m = 6
rn(17) = 1.51464488232257d-6*(w2m1)**3*((218243025.0_8/8.0_8)*w**4 - &
34459425.0_8/4.0_8 * w**2 + 2027025.0_8/8.0_8) * cos(6.0_8*phi)
! l = 10, m = 7
rn(18) = 1.83677671621093d-7*(w2m1)**(7.0_8/TWO)* &
((218243025.0_8/TWO)*w**3 - 34459425.0_8/TWO*w) * cos(7.0_8*phi)
! l = 10, m = 8
rn(19) = 2.49953651452314d-8*(w2m1)**4* &
((654729075.0_8/TWO)*w**2 - 34459425.0_8/TWO) * cos(8.0_8*phi)
! l = 10, m = 9
rn(20) = 2.65478475211798_8 * w*(w2m1)**(9.0_8/TWO) * cos(9.0_8*phi)
! l = 10, m = 10
rn(21) = 0.593627917136573_8 * (w2m1)**5 * cos(10.0_8*phi)
case default
rn = ONE
end select
end function calc_rn
!===============================================================================
! MAXWELL_SPECTRUM samples an energy from the Maxwell fission distribution based
! on a direct sampling scheme. The probability distribution function for a

20
src/matrix_header.F90
View file

@ -27,13 +27,17 @@ module matrix_header
procedure :: assemble => matrix_assemble
procedure :: get_row => matrix_get_row
procedure :: get_col => matrix_get_col
procedure :: vector_multiply => matrix_vector_multiply
#ifdef PETSC
procedure :: transpose => matrix_transpose
procedure :: setup_petsc => matrix_setup_petsc
procedure :: write_petsc_binary => matrix_write_petsc_binary
procedure :: transpose => matrix_transpose
procedure :: vector_multiply => matrix_vector_multiply
#endif
end type matrix
#ifdef PETSC
integer :: petsc_err
#endif
contains
@ -267,6 +271,7 @@ contains
! MATRIX_SETUP_PETSC configures the row/col vectors and links to a PETSc object
!===============================================================================
#ifdef PETSC
subroutine matrix_setup_petsc(self)
class(Matrix), intent(inout) :: self ! matrix instance
@ -276,50 +281,49 @@ contains
self % col = self % col - 1
! Link to petsc
#ifdef PETSC
call MatCreateSeqAIJWithArrays(PETSC_COMM_WORLD, self % n, self % n, &
self % row, self % col, self % val, self % petsc_mat, petsc_err)
#endif
! Petsc is now active
self % petsc_active = .true.
end subroutine matrix_setup_petsc
#endif
!===============================================================================
! MATRIX_WRITE_PETSC_BINARY writes a PETSc matrix binary file
!===============================================================================
#ifdef PETSC
subroutine matrix_write_petsc_binary(self, filename)
character(*), intent(in) :: filename ! file name to write to
class(Matrix), intent(in) :: self ! matrix instance
#ifdef PETSC
type(PetscViewer) :: viewer ! a petsc viewer instance
call PetscViewerBinaryOpen(PETSC_COMM_WORLD, trim(filename), &
FILE_MODE_WRITE, viewer, petsc_err)
call MatView(self % petsc_mat, viewer, petsc_err)
call PetscViewerDestroy(viewer, petsc_err)
#endif
end subroutine matrix_write_petsc_binary
#endif
!===============================================================================
! MATRIX_TRANSPOSE uses PETSc to transpose a matrix
!===============================================================================
#ifdef PETSC
subroutine matrix_transpose(self)
class(Matrix), intent(inout) :: self ! matrix instance
#ifdef PETSC
call MatTranspose(self % petsc_mat, MAT_REUSE_MATRIX, self % petsc_mat, &
petsc_err)
#endif
end subroutine matrix_transpose
#endif
!===============================================================================
! MATRIX_VECTOR_MULTIPLY allow a vector to multiply the matrix

116
src/output.F90
View file

@ -184,7 +184,7 @@ contains
write(OUTPUT_UNIT,*) ' -s, --threads Number of OpenMP threads'
write(OUTPUT_UNIT,*) ' -t, --track Write tracks for all particles'
write(OUTPUT_UNIT,*) ' -v, --version Show version information'
write(OUTPUT_UNIT,*) ' -?, --help Show this message'
write(OUTPUT_UNIT,*) ' -h, --help Show this message'
end if
end subroutine print_usage
@ -672,7 +672,7 @@ contains
integer :: j ! index in filters array
integer :: id ! user-specified id
integer :: unit_ ! unit to write to
integer :: n ! scattering order to include in name
integer :: n ! moment order to include in name
character(MAX_LINE_LEN) :: string
character(MAX_WORD_LEN) :: pn_string
type(Cell), pointer :: c => null()
@ -825,20 +825,63 @@ contains
select case (t % score_bins(j))
case (SCORE_FLUX)
string = trim(string) // ' flux'
case (SCORE_FLUX_YN)
pn_string = ' flux'
string = trim(string) // pn_string
do n = 1, t % moment_order(j)
pn_string = ' flux-y' // trim(to_str(n))
string = trim(string) // pn_string
end do
j = j + n - 1
case (SCORE_TOTAL)
string = trim(string) // ' total'
case (SCORE_TOTAL_YN)
pn_string = ' total'
string = trim(string) // pn_string
do n = 1, t % moment_order(j)
pn_string = ' total-y' // trim(to_str(n))
string = trim(string) // pn_string
end do
j = j + n - 1
case (SCORE_SCATTER)
string = trim(string) // ' scatter'
case (SCORE_NU_SCATTER)
string = trim(string) // ' nu-scatter'
case (SCORE_SCATTER_N)
pn_string = ' scatter-' // trim(to_str(t % scatt_order(j)))
pn_string = ' scatter-' // trim(to_str(t % moment_order(j)))
string = trim(string) // pn_string
case (SCORE_SCATTER_PN)
pn_string = ' scatter'
string = trim(string) // pn_string
do n = 1, t % scatt_order(j)
pn_string = ' scatter-' // trim(to_str(n))
do n = 1, t % moment_order(j)
pn_string = ' scatter-p' // trim(to_str(n))
string = trim(string) // pn_string
end do
j = j + n - 1
case (SCORE_NU_SCATTER_N)
pn_string = ' nu-scatter-' // trim(to_str(t % moment_order(j)))
string = trim(string) // pn_string
case (SCORE_NU_SCATTER_PN)
pn_string = ' nu-scatter'
string = trim(string) // pn_string
do n = 1, t % moment_order(j)
pn_string = ' nu-scatter-p' // trim(to_str(n))
string = trim(string) // pn_string
end do
j = j + n - 1
case (SCORE_SCATTER_YN)
pn_string = ' scatter'
string = trim(string) // pn_string
do n = 1, t % moment_order(j)
pn_string = ' scatter-y' // trim(to_str(n))
string = trim(string) // pn_string
end do
j = j + n - 1
case (SCORE_NU_SCATTER_YN)
pn_string = ' nu-scatter'
string = trim(string) // pn_string
do n = 1, t % moment_order(j)
pn_string = ' nu-scatter-y' // trim(to_str(n))
string = trim(string) // pn_string
end do
j = j + n - 1
@ -1614,13 +1657,14 @@ contains
integer :: score_index ! scoring bin index
integer :: i_nuclide ! index in nuclides array
integer :: i_listing ! index in xs_listings array
integer :: n_order ! loop index for scattering orders
integer :: n_order ! loop index for moment orders
integer :: nm_order ! loop index for Ynm moment orders
real(8) :: t_value ! t-values for confidence intervals
real(8) :: alpha ! significance level for CI
character(MAX_FILE_LEN) :: filename ! name of output file
character(15) :: filter_name(N_FILTER_TYPES) ! names of tally filters
character(27) :: score_names(N_SCORE_TYPES) ! names of scoring function
character(27) :: score_name ! names of scoring function
character(36) :: score_names(N_SCORE_TYPES) ! names of scoring function
character(36) :: score_name ! names of scoring function
! to be applied at write-time
type(TallyObject), pointer :: t
@ -1642,8 +1686,6 @@ contains
score_names(abs(SCORE_TOTAL)) = "Total Reaction Rate"
score_names(abs(SCORE_SCATTER)) = "Scattering Rate"
score_names(abs(SCORE_NU_SCATTER)) = "Scattering Production Rate"
score_names(abs(SCORE_SCATTER_N)) = ""
score_names(abs(SCORE_SCATTER_PN)) = ""
score_names(abs(SCORE_TRANSPORT)) = "Transport Rate"
score_names(abs(SCORE_N_1N)) = "(n,1n) Rate"
score_names(abs(SCORE_ABSORPTION)) = "Absorption Rate"
@ -1651,6 +1693,14 @@ contains
score_names(abs(SCORE_NU_FISSION)) = "Nu-Fission Rate"
score_names(abs(SCORE_KAPPA_FISSION)) = "Kappa-Fission Rate"
score_names(abs(SCORE_EVENTS)) = "Events"
score_names(abs(SCORE_FLUX_YN)) = "Flux Moment"
score_names(abs(SCORE_TOTAL_YN)) = "Total Reaction Rate Moment"
score_names(abs(SCORE_SCATTER_N)) = "Scattering Rate Moment"
score_names(abs(SCORE_SCATTER_PN)) = "Scattering Rate Moment"
score_names(abs(SCORE_SCATTER_YN)) = "Scattering Rate Moment"
score_names(abs(SCORE_NU_SCATTER_N)) = "Scattering Prod. Rate Moment"
score_names(abs(SCORE_NU_SCATTER_PN)) = "Scattering Prod. Rate Moment"
score_names(abs(SCORE_NU_SCATTER_YN)) = "Scattering Prod. Rate Moment"
! Create filename for tally output
filename = trim(path_output) // "tallies.out"
@ -1777,34 +1827,42 @@ contains
do l = 1, t % n_user_score_bins
k = k + 1
score_index = score_index + 1
if (t % score_bins(k) == SCORE_SCATTER_N) then
if (t % scatt_order(k) == 0) then
score_name = "Scattering Rate"
else
score_name = 'P' // trim(to_str(t % scatt_order(k))) // &
' Scattering Moment'
end if
select case(t % score_bins(k))
case (SCORE_SCATTER_N, SCORE_NU_SCATTER_N)
score_name = 'P' // trim(to_str(t % moment_order(k))) // " " // &
score_names(abs(t % score_bins(k)))
write(UNIT=UNIT_TALLY, FMT='(1X,2A,1X,A,"+/- ",A)') &
repeat(" ", indent), score_name, &
to_str(t % results(score_index,filter_index) % sum), &
trim(to_str(t % results(score_index,filter_index) % sum_sq))
else if (t % score_bins(k) == SCORE_SCATTER_PN) then
score_name = "Scattering Rate"
write(UNIT=UNIT_TALLY, FMT='(1X,2A,1X,A,"+/- ",A)') &
repeat(" ", indent), score_name, &
to_str(t % results(score_index,filter_index) % sum), &
trim(to_str(t % results(score_index,filter_index) % sum_sq))
do n_order = 1, t % scatt_order(k)
case (SCORE_SCATTER_PN, SCORE_NU_SCATTER_PN)
score_index = score_index - 1
do n_order = 0, t % moment_order(k)
score_index = score_index + 1
score_name = 'P' // trim(to_str(n_order)) // &
' Scattering Moment'
score_name = 'P' // trim(to_str(n_order)) // " " //&
score_names(abs(t % score_bins(k)))
write(UNIT=UNIT_TALLY, FMT='(1X,2A,1X,A,"+/- ",A)') &
repeat(" ", indent), score_name, &
to_str(t % results(score_index,filter_index) % sum), &
trim(to_str(t % results(score_index,filter_index) % sum_sq))
end do
k = k + n_order - 1
else
k = k + t % moment_order(k)
case (SCORE_SCATTER_YN, SCORE_NU_SCATTER_YN, SCORE_FLUX_YN, &
SCORE_TOTAL_YN)
score_index = score_index - 1
do n_order = 0, t % moment_order(k)
do nm_order = -n_order, n_order
score_index = score_index + 1
score_name = 'Y' // trim(to_str(n_order)) // ',' // &
trim(to_str(nm_order)) // " " // score_names(abs(t % score_bins(k)))
write(UNIT=UNIT_TALLY, FMT='(1X,2A,1X,A,"+/- ",A)') &
repeat(" ", indent), score_name, &
to_str(t % results(score_index,filter_index) % sum), &
trim(to_str(t % results(score_index,filter_index) % sum_sq))
end do
end do
k = k + (t % moment_order(k) + 1)**2 - 1
case default
if (t % score_bins(k) > 0) then
score_name = reaction_name(t % score_bins(k))
else
@ -1814,7 +1872,7 @@ contains
repeat(" ", indent), score_name, &
to_str(t % results(score_index,filter_index) % sum), &
trim(to_str(t % results(score_index,filter_index) % sum_sq))
end if
end select
end do
indent = indent - 2

516
src/output_interface.F90
View file

File diff suppressed because it is too large Load diff

5
src/particle_header.F90
View file

@ -30,7 +30,7 @@ module particle_header
! Pointer to next (more local) set of coordinates
type(LocalCoord), pointer :: next => null()
end type LocalCoord
!===============================================================================
! PARTICLE describes the state of a particle being transported through the
! geometry
@ -53,6 +53,7 @@ module particle_header
! Pre-collision physical data
real(8) :: last_xyz(3) ! previous coordinates
real(8) :: last_uvw(3) ! previous direction coordinates
real(8) :: last_wgt ! pre-collision particle weight
real(8) :: last_E ! pre-collision energy
real(8) :: absorb_wgt ! weight absorbed for survival biasing
@ -96,7 +97,7 @@ contains
type(LocalCoord), pointer :: coord
if (associated(coord)) then
if (associated(coord)) then
! recursively deallocate lower coordinates
if (associated(coord % next)) call deallocate_coord(coord%next)

3
src/particle_restart.F90
View file

@ -1,4 +1,4 @@
module particle_restart
module particle_restart
use, intrinsic :: ISO_FORTRAN_ENV
@ -88,6 +88,7 @@ contains
! Set particle last attributes
p % last_wgt = p % wgt
p % last_xyz = p % coord % xyz
p % last_uvw = p % coord % uvw
p % last_E = p % E
! Close hdf5 file

33
src/physics.F90
View file

@ -36,6 +36,7 @@ contains
! Store pre-collision particle properties
p % last_wgt = p % wgt
p % last_E = p % E
p % last_uvw = p % coord0 % uvw
! Add to collision counter for particle
p % n_collision = p % n_collision + 1
@ -98,9 +99,17 @@ contains
! If survival biasing is being used, the following subroutine adjusts the
! weight of the particle. Otherwise, it checks to see if absorption occurs
call absorption(p, i_nuclide)
if (micro_xs(i_nuclide) % absorption > ZERO) then
call absorption(p, i_nuclide)
else
p % absorb_wgt = ZERO
end if
if (.not. p % alive) return
! Sample a scattering reaction and determine the secondary energy of the
! exiting neutron
call scatter(p, i_nuclide)
! Play russian roulette if survival biasing is turned on
if (survival_biasing) then
@ -108,11 +117,6 @@ contains
if (.not. p % alive) return
end if
! Sample a scattering reaction and determine the secondary energy of the
! exiting neutron
call scatter(p, i_nuclide)
end subroutine sample_reaction
!===============================================================================
@ -293,6 +297,7 @@ contains
p % last_wgt = p % wgt
else
p % wgt = ZERO
p % last_wgt = ZERO
p % alive = .false.
end if
end if
@ -866,10 +871,18 @@ contains
nu = int(nu_t) + 1
end if
! Check for fission bank size getting hit
if (n_bank + nu > size(fission_bank)) then
message = "Maximum number of sites in fission bank reached. This can &
&result in irreproducible results using different numbers of &
&processes/threads."
call warning()
end if
! Bank source neutrons
if (nu == 0 .or. n_bank == 3*work) return
if (nu == 0 .or. n_bank == size(fission_bank)) return
p % fission = .true. ! Fission neutrons will be banked
do i = int(n_bank,4) + 1, int(min(n_bank + nu, 3*work),4)
do i = int(n_bank,4) + 1, int(min(n_bank + nu, int(size(fission_bank),8)),4)
! Bank source neutrons by copying particle data
fission_bank(i) % xyz = p % coord0 % xyz
@ -894,7 +907,7 @@ contains
end do
! increment number of bank sites
n_bank = min(n_bank + nu, 3*work)
n_bank = min(n_bank + nu, int(size(fission_bank),8))
! Store total weight banked for analog fission tallies
p % n_bank = nu
@ -1156,7 +1169,7 @@ contains
! calculate cosine
mu0 = rxn % adist % data(lc + k)
mu1 = rxn % adist % data(lc + k+1)
mu = mu0 + (32.0_8 * xi - k) * (mu1 - mu0)
mu = mu0 + (32.0_8 * xi - k + ONE) * (mu1 - mu0)
elseif (type == ANGLE_TABULAR) then
interp = int(rxn % adist % data(lc + 1))

16
src/plot.F90
View file

@ -10,6 +10,7 @@ module plot
use plot_header
use ppmlib, only: Image, init_image, allocate_image, &
deallocate_image, set_pixel
use progress_header, only: ProgressBar
use string, only: to_str
implicit none
@ -109,8 +110,9 @@ contains
real(8) :: in_pixel
real(8) :: out_pixel
real(8) :: xyz(3)
type(Image) :: img
type(Particle) :: p
type(Image) :: img
type(Particle) :: p
type(ProgressBar) :: progress
! Initialize and allocate space for image
call init_image(img)
@ -149,13 +151,14 @@ contains
p % coord % universe = BASE_UNIVERSE
do y = 1, img % height
call progress % set_value(dble(y)/dble(img % height)*100.)
do x = 1, img % width
! get pixel color
call position_rgb(p, pl, rgb, id)
! Create a pixel at (x,y) with color (r,g,b)
call set_pixel(img, x, y, rgb(1), rgb(2), rgb(3))
call set_pixel(img, x-1, y-1, rgb(1), rgb(2), rgb(3))
! Advance pixel in first direction
p % coord0 % xyz(in_i) = p % coord0 % xyz(in_i) + in_pixel
@ -172,6 +175,9 @@ contains
! Free up space
call deallocate_image(img)
! Clear particle
call p % clear()
end subroutine create_ppm
!===============================================================================
@ -228,7 +234,8 @@ contains
integer :: id ! id of cell or material
real(8) :: vox(3) ! x, y, and z voxel widths
real(8) :: ll(3) ! lower left starting point for each sweep direction
type(Particle) :: p
type(Particle) :: p
type(ProgressBar) :: progress
! compute voxel widths in each direction
vox = pl % width/dble(pl % pixels)
@ -253,6 +260,7 @@ contains
ll = ll + vox / 2.0
do x = 1, pl % pixels(1)
call progress % set_value(dble(x)/dble(pl % pixels(1))*100.)
do y = 1, pl % pixels(2)
do z = 1, pl % pixels(3)

102
src/progress_header.F90 Normal file
View file

@ -0,0 +1,102 @@
module progress_header
use, intrinsic :: ISO_FORTRAN_ENV, only: OUTPUT_UNIT
implicit none
#ifdef UNIX
interface
function check_isatty(fd) bind(C, name = 'isatty')
use, intrinsic :: ISO_C_BINDING, only: c_int
integer(c_int) :: check_isatty
integer(c_int), value :: fd
end function check_isatty
end interface
#endif
!===============================================================================
! PROGRESSBAR
!===============================================================================
type ProgressBar
private
character(len=72) :: bar="???% | " // &
" |"
contains
procedure :: set_value => bar_set_value
end type ProgressBar
contains
!===============================================================================
! IS_TERMINAL checks if output is currently being output to a terminal. Relies
! on a POSIX implementation of isatty, and defaults to false if that is not
! available
!===============================================================================
function is_terminal() result(istty)
logical :: istty
istty = .true.
#ifdef UNIX
if (check_isatty(1) == 0) istty = .false.
#else
istty = .false.
#endif
end function is_terminal
!===============================================================================
! BAR_SET_VALUE prints the progress bar without advancing. The value is
! specified as percent completion, from 0 to 100. If the value is ever set to
! 100 or above, the bar is set to 100 and a newline is written.
!===============================================================================
subroutine bar_set_value(self, val)
class(ProgressBar), intent(inout) :: self
real(8), intent(in) :: val
integer :: i
if (.not. is_terminal()) return
! set the percentage
if (val >= 100.) then
write(self % bar(1:3), "(I3)") 100
else if (val <= 0.) then
write(self % bar(1:3), "(I3)") 0
else
write(self % bar(1:3), "(I3)") int(val)
end if
! set the bar width
if (val >= 100.) then
do i=1,65
write(self % bar(i+6:i+6), '(A)') '='
end do
else
do i=1,int(dble(65)*val/100.)
write(self % bar(i+6:i+6), '(A)') '='
end do
end if
write(OUTPUT_UNIT, '(A1,A1,A72)', ADVANCE='no') '+', char(13), self % bar
flush(OUTPUT_UNIT)
if (val >= 100.) then
! make new line
write(OUTPUT_UNIT, "(A)") ""
flush(OUTPUT_UNIT)
! reset the bar in case we want to use this instance again
self % bar = "???% | " // &
" |"
end if
end subroutine bar_set_value
end module progress_header

2
src/relaxng/settings.rnc
View file

@ -38,6 +38,8 @@ element settings {
attribute upper_right { list { xsd:double+ } })
}? &
element natural_elements { xsd:string { maxLength = "20" } }? &
element no_reduce { xsd:boolean }? &
element output {

2
src/source.F90
View file

@ -130,6 +130,7 @@ contains
end if
end if
end do
call p % clear()
case (SRC_SPACE_POINT)
! Point source
@ -255,6 +256,7 @@ contains
p % coord % xyz = src % xyz
p % coord % uvw = src % uvw
p % last_xyz = src % xyz
p % last_uvw = src % uvw
p % E = src % E
p % last_E = src % E

24
src/state_point.F90
View file

@ -58,7 +58,7 @@ contains
call write_message(1)
if (master) then
! Create statepoint file
! Create statepoint file
call sp % file_create(filename)
! Write file type
@ -216,12 +216,12 @@ contains
group="tallies/tally" // to_str(i), length=t % n_nuclide_bins)
deallocate(temp_array)
! Write number of score bins, score bins, and scatt order
! Write number of score bins, score bins, and moment order
call sp % write_data(t % n_score_bins, "n_score_bins", &
group="tallies/tally" // to_str(i))
call sp % write_data(t % score_bins, "score_bins", &
group="tallies/tally" // to_str(i), length=t % n_score_bins)
call sp % write_data(t % scatt_order, "scatt_order", &
call sp % write_data(t % moment_order, "moment_order", &
group="tallies/tally" // to_str(i), length=t % n_score_bins)
! Write number of user score bins
@ -409,7 +409,7 @@ contains
! Copy global tallies into temporary array for reducing
n_bins = 2 * N_GLOBAL_TALLIES
global_temp(1,:) = global_tallies(:) % sum
global_temp(2,:) = global_tallies(:) % sum_sq
global_temp(2,:) = global_tallies(:) % sum_sq
if (master) then
! The MPI_IN_PLACE specifier allows the master to copy values into a
@ -430,7 +430,7 @@ contains
tallyresult_temp(:,1) % sum = global_temp(1,:)
tallyresult_temp(:,1) % sum_sq = global_temp(2,:)
! Write out global tallies sum and sum_sq
call sp % write_tally_result(tallyresult_temp, "global_tallies", &
n1=N_GLOBAL_TALLIES, n2=1)
@ -484,7 +484,7 @@ contains
allocate(tallyresult_temp(m,n))
tallyresult_temp(:,:) % sum = tally_temp(1,:,:)
tallyresult_temp(:,:) % sum_sq = tally_temp(2,:,:)
! Write reduced tally results to file
call sp % write_tally_result(t % results, "results", &
group="tallies/tally" // to_str(i), n1=m, n2=n)
@ -525,7 +525,7 @@ contains
integer :: int_array(3)
integer, allocatable :: temp_array(:)
logical :: source_present
real(8) :: real_array(3)
real(8) :: real_array(3)
type(TallyObject), pointer :: t => null()
! Write message
@ -720,7 +720,7 @@ contains
group="tallies/tally" // to_str(i))
call sp % read_data(t % score_bins, "score_bins", &
group="tallies/tally" // to_str(i), length=t % n_score_bins)
call sp % read_data(t % scatt_order, "scatt_order", &
call sp % read_data(t % moment_order, "moment_order", &
group="tallies/tally" // to_str(i), length=t % n_score_bins)
! Write number of user score bins
@ -741,7 +741,7 @@ contains
if (path_source_point == path_state_point .and. .not. source_present) then
message = "Source bank must be contained in statepoint restart file"
call fatal_error()
end if
end if
! Read tallies to master
if (master) then
@ -779,20 +779,20 @@ contains
end if
end if
! Read source if in eigenvalue mode
! Read source if in eigenvalue mode
if (run_mode == MODE_EIGENVALUE) then
! Check if source was written out separately
if (.not. source_present) then
! Close statepoint file
! Close statepoint file
call sp % file_close()
! Write message
message = "Loading source file " // trim(path_source_point) // "..."
call write_message(1)
! Open source file
! Open source file
call sp % file_open(path_source_point, 'r', serial = .false.)
! Read file type

708
src/tally.F90
View file

@ -4,7 +4,7 @@ module tally
use constants
use error, only: fatal_error
use global
use math, only: t_percentile, calc_pn
use math, only: t_percentile, calc_pn, calc_rn
use mesh, only: get_mesh_bin, bin_to_mesh_indices, &
get_mesh_indices, mesh_indices_to_bin, &
mesh_intersects_2d, mesh_intersects_3d
@ -41,8 +41,9 @@ contains
integer :: i_tally
integer :: j ! loop index for scoring bins
integer :: k ! loop index for nuclide bins
integer :: n ! loop index for scattering order
integer :: l ! scoring bin loop index, allowing for changing
integer :: n ! loop index for legendre order
integer :: num_nm ! Number of N,M orders in harmonic
integer :: l ! scoring bin loop index, allowing for changing
! position during the loop
integer :: filter_index ! single index for single bin
integer :: score_bin ! scoring bin, e.g. SCORE_FLUX
@ -139,7 +140,51 @@ contains
! estimator since there is no way to count 'events' exactly for
! the flux
score = last_wgt / material_xs % total
if (survival_biasing) then
! We need to account for the fact that some weight was already
! absorbed
score = last_wgt + p % absorb_wgt
else
score = last_wgt
end if
score = score / material_xs % total
case (SCORE_FLUX_YN)
! All events score to a flux bin. We actually use a collision
! estimator since there is no way to count 'events' exactly for
! the flux
score_index = score_index - 1
! get the score
if (survival_biasing) then
! We need to account for the fact that some weight was already
! absorbed
score = last_wgt + p % absorb_wgt
else
score = last_wgt
end if
score = score / material_xs % total
num_nm = 1
! Find the order for a collection of requested moments
! and store the moment contribution of each
do n = 0, t % moment_order(j)
! determine scoring bin index
score_index = score_index + num_nm
! Update number of total n,m bins for this n (m = [-n: n])
num_nm = 2 * n + 1
! multiply score by the angular flux moments and store
!$omp critical
t % results(score_index: score_index + num_nm - 1, filter_index) % value = &
t % results(score_index: score_index + num_nm - 1, filter_index) % value + &
score * calc_rn(n, p % last_uvw)
!$omp end critical
end do
j = j + (t % moment_order(j) + 1)**2 - 1
cycle SCORE_LOOP
case (SCORE_TOTAL)
! All events will score to the total reaction rate. We can just
@ -154,6 +199,41 @@ contains
score = last_wgt
end if
case (SCORE_TOTAL_YN)
! All events will score to the total reaction rate. We can just
! use the weight of the particle entering the collision as the
! score
score_index = score_index - 1
! get the score
if (survival_biasing) then
! We need to account for the fact that some weight was already
! absorbed
score = last_wgt + p % absorb_wgt
else
score = last_wgt
end if
num_nm = 1
! Find the order for a collection of requested moments
! and store the moment contribution of each
do n = 0, t % moment_order(j)
! determine scoring bin index
score_index = score_index + num_nm
! Update number of total n,m bins for this n (m = [-n: n])
num_nm = 2 * n + 1
! multiply score by the angular flux moments and store
!$omp critical
t % results(score_index: score_index + num_nm - 1, filter_index) % value = &
t % results(score_index: score_index + num_nm - 1, filter_index) % value + &
score * calc_rn(n, p % last_uvw)
!$omp end critical
end do
j = j + (t % moment_order(j) + 1)**2 - 1
cycle SCORE_LOOP
case (SCORE_SCATTER)
! Skip any event where the particle didn't scatter
if (p % event /= EVENT_SCATTER) cycle SCORE_LOOP
@ -164,7 +244,7 @@ contains
score = last_wgt
case (SCORE_NU_SCATTER)
case (SCORE_NU_SCATTER)
! Skip any event where the particle didn't scatter
if (p % event /= EVENT_SCATTER) cycle SCORE_LOOP
@ -173,7 +253,7 @@ contains
! reaction with neutrons in the exit channel
score = wgt
case (SCORE_SCATTER_N)
! Skip any event where the particle didn't scatter
if (p % event /= EVENT_SCATTER) cycle SCORE_LOOP
@ -181,33 +261,129 @@ contains
! Find the scattering order for a singly requested moment, and
! store its moment contribution.
if (t % scatt_order(j) == 1) then
if (t % moment_order(j) == 1) then
score = last_wgt * mu ! avoid function call overhead
else
score = last_wgt * calc_pn(t % scatt_order(j), mu)
score = last_wgt * calc_pn(t % moment_order(j), mu)
endif
case (SCORE_SCATTER_PN)
! Skip any event where the particle didn't scatter
if (p % event /= EVENT_SCATTER) then
j = j + t % scatt_order(j)
j = j + t % moment_order(j)
cycle SCORE_LOOP
end if
score_index = score_index - 1
! Find the scattering order for a collection of requested moments
! and store the moment contribution of each
do n = 0, t % scatt_order(j)
do n = 0, t % moment_order(j)
! determine scoring bin index
score_index = score_index + 1
! get the score and tally it
score = last_wgt * calc_pn(n, mu)
!$omp critical
t % results(score_index, filter_index) % value = &
t % results(score_index, filter_index) % value + score
!$omp end critical
end do
j = j + t % scatt_order(j)
j = j + t % moment_order(j)
cycle SCORE_LOOP
case (SCORE_SCATTER_YN)
! Skip any event where the particle didn't scatter
if (p % event /= EVENT_SCATTER) then
j = j + t % moment_order(j)
cycle SCORE_LOOP
end if
score_index = score_index - 1
! Calculate the number of moments from t % moment_order
num_nm = 1
! Find the order for a collection of requested moments
! and store the moment contribution of each
do n = 0, t % moment_order(j)
! determine scoring bin index
score_index = score_index + num_nm
! Update number of total n,m bins for this n (m = [-n: n])
num_nm = 2 * n + 1
! get the score of the scattering moment
score = last_wgt * calc_pn(n, mu)
! multiply score by the angular flux moments and store
!$omp critical
t % results(score_index: score_index + num_nm - 1, filter_index) % value = &
t % results(score_index: score_index + num_nm - 1, filter_index) % value + &
score * calc_rn(n, p % last_uvw)
!$omp end critical
end do
j = j + (t % moment_order(j) + 1)**2 - 1
cycle SCORE_LOOP
case (SCORE_NU_SCATTER_N)
! Skip any event where the particle didn't scatter
if (p % event /= EVENT_SCATTER) cycle SCORE_LOOP
! Find the scattering order for a singly requested moment, and
! store its moment contribution.
if (t % moment_order(j) == 1) then
score = wgt * mu ! avoid function call overhead
else
score = wgt * calc_pn(t % moment_order(j), mu)
endif
case (SCORE_NU_SCATTER_PN)
! Skip any event where the particle didn't scatter
if (p % event /= EVENT_SCATTER) then
j = j + t % moment_order(j)
cycle SCORE_LOOP
end if
score_index = score_index - 1
! Find the scattering order for a collection of requested moments
! and store the moment contribution of each
do n = 0, t % moment_order(j)
! determine scoring bin index
score_index = score_index + 1
! get the score and tally it
score = wgt * calc_pn(n, mu)
!$omp critical
t % results(score_index, filter_index) % value = &
t % results(score_index, filter_index) % value + score
!$omp end critical
end do
j = j + t % moment_order(j)
cycle SCORE_LOOP
case (SCORE_NU_SCATTER_YN)
! Skip any event where the particle didn't scatter
if (p % event /= EVENT_SCATTER) then
j = j + t % moment_order(j)
cycle SCORE_LOOP
end if
score_index = score_index - 1
! Calculate the number of moments from t % moment_order
num_nm = 1
! Find the order for a collection of requested moments
! and store the moment contribution of each
do n = 0, t % moment_order(j)
! determine scoring bin index
score_index = score_index + num_nm
! Update number of total n,m bins for this n (m = [-n: n])
num_nm = 2 * n + 1
! get the score of the scattering moment
score = wgt * calc_pn(n, mu)
! multiply score by the angular flux moments and store
!$omp critical
t % results(score_index: score_index + num_nm - 1, filter_index) % value = &
t % results(score_index: score_index + num_nm - 1, filter_index) % value + &
score * calc_rn(n, p % last_uvw)
!$omp end critical
end do
j = j + (t % moment_order(j) + 1)**2 - 1
cycle SCORE_LOOP
case (SCORE_TRANSPORT)
@ -220,7 +396,7 @@ contains
! Score total rate - p1 scatter rate Note estimator needs to be
! adjusted since tallying is only occuring when a scatter has
! happend. Effectively this means multiplying the estimator by
! happened. Effectively this means multiplying the estimator by
! total/scatter macro
score = (macro_total - mu*macro_scatt)*(ONE/macro_scatt)
@ -257,18 +433,23 @@ contains
! calculate fraction of absorptions that would have resulted in
! fission
score = p % absorb_wgt * micro_xs(p % event_nuclide) % fission / &
micro_xs(p % event_nuclide) % absorption
if (micro_xs(p % event_nuclide) % absorption > ZERO) then
score = p % absorb_wgt * micro_xs(p % event_nuclide) % fission / &
micro_xs(p % event_nuclide) % absorption
else
score = ZERO
end if
else
! Skip any non-fission events
if (.not. p % fission) cycle SCORE_LOOP
! Skip any non-absorption events
if (p % event == EVENT_SCATTER) cycle SCORE_LOOP
! All fission events will contribute, so again we can use
! particle's weight entering the collision as the estimate for the
! fission reaction rate
score = last_wgt
score = last_wgt * micro_xs(p % event_nuclide) % fission / &
micro_xs(p % event_nuclide) % absorption
end if
case (SCORE_NU_FISSION)
@ -277,8 +458,25 @@ contains
! calculate fraction of absorptions that would have resulted in
! nu-fission
score = p % absorb_wgt * micro_xs(p % event_nuclide) % &
nu_fission / micro_xs(p % event_nuclide) % absorption
if (t % find_filter(FILTER_ENERGYOUT) > 0) then
! Normally, we only need to make contributions to one scoring
! bin. However, in the case of fission, since multiple fission
! neutrons were emitted with different energies, multiple
! outgoing energy bins may have been scored to. The following
! logic treats this special case and results to multiple bins
call score_fission_eout(p, t, score_index)
cycle SCORE_LOOP
else
if (micro_xs(p % event_nuclide) % absorption > ZERO) then
score = p % absorb_wgt * micro_xs(p % event_nuclide) % &
nu_fission / micro_xs(p % event_nuclide) % absorption
else
score = ZERO
end if
end if
else
! Skip any non-fission events
@ -305,28 +503,31 @@ contains
end if
end if
case (SCORE_KAPPA_FISSION)
if (survival_biasing) then
! No fission events occur if survival biasing is on -- need to
! calculate fraction of absorptions that would have resulted in
! fission and multiply by Q
! fission scale by kappa-fission
if (micro_xs(p % event_nuclide) % absorption > ZERO) then
score = p % absorb_wgt * &
micro_xs(p % event_nuclide) % kappa_fission / &
micro_xs(p % event_nuclide) % absorption
else
score = ZERO
end if
score = p % absorb_wgt * &
micro_xs(p % event_nuclide) % kappa_fission / &
micro_xs(p % event_nuclide) % absorption
else
! Skip any non-fission events
if (.not. p % fission) cycle SCORE_LOOP
! Skip any non-absorption events
if (p % event == EVENT_SCATTER) cycle SCORE_LOOP
! All fission events will contribute, so again we can use
! particle's weight entering the collision as the estimate for
! the fission energy production rate
n = nuclides(p % event_nuclide) % index_fission(1)
score = last_wgt * &
nuclides(p % event_nuclide) % reactions(n) % Q_value
micro_xs(p % event_nuclide) % kappa_fission / &
micro_xs(p % event_nuclide) % absorption
end if
case (SCORE_EVENTS)
! Simply count number of scoring events
@ -383,7 +584,7 @@ contains
integer :: k ! loop index for bank sites
integer :: bin_energyout ! original outgoing energy bin
integer :: i_filter ! index for matching filter bin combination
real(8) :: score ! actualy score
real(8) :: score ! actual score
real(8) :: E_out ! energy of fission bank site
! save original outgoing energy bin and score index
@ -446,6 +647,9 @@ contains
integer :: k ! loop index for nuclide bins
integer :: l ! loop index for nuclides in material
integer :: m ! loop index for reactions
integer :: n ! loop index for legendre order
integer :: num_nm ! Number of N,M orders in harmonic
integer :: q ! loop index for scoring bins
integer :: filter_index ! single index for single bin
integer :: i_nuclide ! index in nuclides array (from bins)
integer :: i_nuc ! index in nuclides array (from material)
@ -498,7 +702,9 @@ contains
filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1
if (t % all_nuclides) then
call score_all_nuclides(p, i_tally, flux, filter_index)
if (p % material /= MATERIAL_VOID) then
call score_all_nuclides(p, i_tally, flux, filter_index)
end if
else
NUCLIDE_BIN_LOOP: do k = 1, t % n_nuclide_bins
@ -506,30 +712,39 @@ contains
i_nuclide = t % nuclide_bins(k)
if (i_nuclide > 0) then
! Get pointer to current material
mat => materials(p % material)
if (p % material /= MATERIAL_VOID) then
! Get pointer to current material
mat => materials(p % material)
! Determine if nuclide is actually in material
NUCLIDE_MAT_LOOP: do j = 1, mat % n_nuclides
! If index of nuclide matches the j-th nuclide listed in the
! material, break out of the loop
if (i_nuclide == mat % nuclide(j)) exit
! Determine if nuclide is actually in material
NUCLIDE_MAT_LOOP: do j = 1, mat % n_nuclides
! If index of nuclide matches the j-th nuclide listed in the
! material, break out of the loop
if (i_nuclide == mat % nuclide(j)) exit
! If we've reached the last nuclide in the material, it means
! the specified nuclide to be tallied is not in this material
if (j == mat % n_nuclides) then
cycle NUCLIDE_BIN_LOOP
end if
end do NUCLIDE_MAT_LOOP
! If we've reached the last nuclide in the material, it means
! the specified nuclide to be tallied is not in this material
if (j == mat % n_nuclides) then
cycle NUCLIDE_BIN_LOOP
end if
end do NUCLIDE_MAT_LOOP
atom_density = mat % atom_density(j)
atom_density = mat % atom_density(j)
else
atom_density = ZERO
end if
end if
! Determine score for each bin
SCORE_LOOP: do j = 1, t % n_score_bins
j = 0
SCORE_LOOP: do q = 1, t % n_user_score_bins
j = j + 1
! determine what type of score bin
score_bin = t % score_bins(j)
! determine scoring bin index
score_index = (k - 1)*t % n_score_bins + j
if (i_nuclide > 0) then
! ================================================================
! DETERMINE NUCLIDE CROSS SECTION
@ -539,11 +754,58 @@ contains
! For flux, we need no cross section
score = flux
case (SCORE_FLUX_YN)
score_index = score_index - 1
! For flux, we need no cross section
score = flux
num_nm = 1
! Find the order for a collection of requested moments
! and store the moment contribution of each
do n = 0, t % moment_order(j)
! determine scoring bin index
score_index = score_index + num_nm
! Update number of total n,m bins for this n (m = [-n: n])
num_nm = 2 * n + 1
! multiply score by the angular flux moments and store
!$omp critical
t % results(score_index: score_index + num_nm - 1, filter_index) % value = &
t % results(score_index: score_index + num_nm - 1, filter_index) % value + &
score * calc_rn(n, p % coord0 % uvw)
!$omp end critical
end do
j = j + (t % moment_order(j) + 1)**2 - 1
cycle SCORE_LOOP
case (SCORE_TOTAL)
! Total cross section is pre-calculated
score = micro_xs(i_nuclide) % total * &
atom_density * flux
case (SCORE_TOTAL_YN)
score_index = score_index - 1
num_nm = 1
! Find the order for a collection of requested moments
! and store the moment contribution of each
do n = 0, t % moment_order(j)
! determine scoring bin index
score_index = score_index + num_nm
! Update number of total n,m bins for this n (m = [-n: n])
num_nm = 2 * n + 1
! multiply score by the angular flux moments and store
!$omp critical
t % results(score_index: score_index + num_nm - 1, filter_index) % value = &
t % results(score_index: score_index + num_nm - 1, filter_index) % value + &
score * calc_rn(n, p % coord0 % uvw)
!$omp end critical
end do
j = j + (t % moment_order(j) + 1)**2 - 1
cycle SCORE_LOOP
case (SCORE_SCATTER)
! Scattering cross section is pre-calculated
score = (micro_xs(i_nuclide) % total - &
@ -623,10 +885,60 @@ contains
! For flux, we need no cross section
score = flux
case (SCORE_FLUX_YN)
score_index = score_index - 1
! For flux, we need no cross section
score = flux
num_nm = 1
! Find the order for a collection of requested moments
! and store the moment contribution of each
do n = 0, t % moment_order(j)
! determine scoring bin index
score_index = score_index + num_nm
! Update number of total n,m bins for this n (m = [-n: n])
num_nm = 2 * n + 1
! multiply score by the angular flux moments and store
!$omp critical
t % results(score_index: score_index + num_nm - 1, filter_index) % value = &
t % results(score_index: score_index + num_nm - 1, filter_index) % value + &
score * calc_rn(n, p % coord0 % uvw)
!$omp end critical
end do
j = j + (t % moment_order(j) + 1)**2 - 1
cycle SCORE_LOOP
case (SCORE_TOTAL)
! Total cross section is pre-calculated
score = material_xs % total * flux
case (SCORE_TOTAL_YN)
score_index = score_index - 1
! Total cross section is pre-calculated
score = material_xs % total * flux
num_nm = 1
! Find the order for a collection of requested moments
! and store the moment contribution of each
do n = 0, t % moment_order(j)
! determine scoring bin index
score_index = score_index + num_nm
! Update number of total n,m bins for this n (m = [-n: n])
num_nm = 2 * n + 1
! multiply score by the angular flux moments and store
!$omp critical
t % results(score_index: score_index + num_nm - 1, filter_index) % value = &
t % results(score_index: score_index + num_nm - 1, filter_index) % value + &
score * calc_rn(n, p % coord0 % uvw)
!$omp end critical
end do
j = j + (t % moment_order(j) + 1)**2 - 1
cycle SCORE_LOOP
case (SCORE_SCATTER)
! Scattering cross section is pre-calculated
score = (material_xs % total - material_xs % absorption) * flux
@ -665,7 +977,7 @@ contains
do l = 1, mat % n_nuclides
! Get atom density
atom_density = mat % atom_density(l)
! Get index in nuclides array
i_nuc = mat % nuclide(l)
@ -703,9 +1015,6 @@ contains
end select
end if
! Determine scoring bin index
score_index = (k - 1)*t % n_score_bins + j
! Add score to tally
!$omp critical
t % results(score_index, filter_index) % value = &
@ -746,6 +1055,9 @@ contains
integer :: i ! loop index for nuclides in material
integer :: j ! loop index for scoring bin types
integer :: m ! loop index for reactions in nuclide
integer :: n ! loop index for legendre order
integer :: num_nm ! Number of N,M orders in harmonic
integer :: q ! loop index for scoring bins
integer :: i_nuclide ! index in nuclides array
integer :: score_bin ! type of score, e.g. SCORE_FLUX
integer :: score_index ! scoring bin index
@ -776,18 +1088,73 @@ contains
atom_density = mat % atom_density(i)
! Loop over score types for each bin
SCORE_LOOP: do j = 1, t % n_score_bins
j = 0
SCORE_LOOP: do q = 1, t % n_user_score_bins
j = j + 1
! determine what type of score bin
score_bin = t % score_bins(j)
! Determine macroscopic nuclide cross section
! Determine scoring bin index based on what the index of the nuclide
! is in the nuclides array
score_index = (i_nuclide - 1)*t % n_score_bins + j
! Determine macroscopic nuclide cross section
select case(score_bin)
case (SCORE_FLUX)
score = flux
case (SCORE_FLUX_YN)
score_index = score_index - 1
! For flux, we need no cross section
score = flux
num_nm = 1
! Find the order for a collection of requested moments
! and store the moment contribution of each
do n = 0, t % moment_order(j)
! determine scoring bin index
score_index = score_index + num_nm
! Update number of total n,m bins for this n (m = [-n: n])
num_nm = 2 * n + 1
! multiply score by the angular flux moments and store
!$omp critical
t % results(score_index: score_index + num_nm - 1, filter_index) % value = &
t % results(score_index: score_index + num_nm - 1, filter_index) % value + &
score * calc_rn(n, p % coord0 % uvw)
!$omp end critical
end do
j = j + (t % moment_order(j) + 1)**2 - 1
cycle SCORE_LOOP
case (SCORE_TOTAL)
score = micro_xs(i_nuclide) % total * atom_density * flux
case (SCORE_TOTAL_YN)
score_index = score_index - 1
score = micro_xs(i_nuclide) % total * atom_density * flux
num_nm = 1
! Find the order for a collection of requested moments
! and store the moment contribution of each
do n = 0, t % moment_order(j)
! determine scoring bin index
score_index = score_index + num_nm
! Update number of total n,m bins for this n (m = [-n: n])
num_nm = 2 * n + 1
! multiply score by the angular flux moments and store
!$omp critical
t % results(score_index: score_index + num_nm - 1, filter_index) % value = &
t % results(score_index: score_index + num_nm - 1, filter_index) % value + &
score * calc_rn(n, p % coord0 % uvw)
!$omp end critical
end do
j = j + (t % moment_order(j) + 1)**2 - 1
cycle SCORE_LOOP
case (SCORE_SCATTER)
score = (micro_xs(i_nuclide) % total - &
micro_xs(i_nuclide) % absorption) * atom_density * flux
@ -812,7 +1179,7 @@ contains
! sections that are used often (e.g. n2n, ngamma, etc. for depletion),
! it might make sense to optimize this section or pre-calculate cross
! sections
if (score_bin > 1) then
! Set default score
score = ZERO
@ -847,10 +1214,6 @@ contains
end if
end select
! Determine scoring bin index based on what the index of the nuclide
! is in the nuclides array
score_index = (i_nuclide - 1)*t % n_score_bins + j
! Add score to tally
!$omp critical
t % results(score_index, filter_index) % value = &
@ -865,18 +1228,74 @@ contains
! SCORE TOTAL MATERIAL REACTION RATES
! Loop over score types for each bin
MATERIAL_SCORE_LOOP: do j = 1, t % n_score_bins
j = 0
MATERIAL_SCORE_LOOP: do q = 1, t % n_user_score_bins
j = j + 1
! determine what type of score bin
score_bin = t % score_bins(j)
! Determine macroscopic material cross section
! Determine scoring bin index based on what the index of the nuclide
! is in the nuclides array
score_index = n_nuclides_total*t % n_score_bins + j
! Determine macroscopic material cross section
select case(score_bin)
case (SCORE_FLUX)
score = flux
case (SCORE_FLUX_YN)
score_index = score_index - 1
! For flux, we need no cross section
score = flux
num_nm = 1
! Find the order for a collection of requested moments
! and store the moment contribution of each
do n = 0, t % moment_order(j)
! determine scoring bin index
score_index = score_index + num_nm
! Update number of total n,m bins for this n (m = [-n: n])
num_nm = 2 * n + 1
! multiply score by the angular flux moments and store
!$omp critical
t % results(score_index: score_index + num_nm - 1, filter_index) % value = &
t % results(score_index: score_index + num_nm - 1, filter_index) % value + &
score * calc_rn(n, p % coord0 % uvw)
!$omp end critical
end do
j = j + (t % moment_order(j) + 1)**2 - 1
cycle MATERIAL_SCORE_LOOP
case (SCORE_TOTAL)
score = material_xs % total * flux
case (SCORE_TOTAL_YN)
score_index = score_index - 1
! Total cross section is pre-calculated
score = material_xs % total * flux
num_nm = 1
! Find the order for a collection of requested moments
! and store the moment contribution of each
do n = 0, t % moment_order(j)
! determine scoring bin index
score_index = score_index + num_nm
! Update number of total n,m bins for this n (m = [-n: n])
num_nm = 2 * n + 1
! multiply score by the angular flux moments and store
!$omp critical
t % results(score_index: score_index + num_nm - 1, filter_index) % value = &
t % results(score_index: score_index + num_nm - 1, filter_index) % value + &
score * calc_rn(n, p % coord0 % uvw)
!$omp end critical
end do
j = j + (t % moment_order(j) + 1)**2 - 1
cycle MATERIAL_SCORE_LOOP
case (SCORE_SCATTER)
score = (material_xs % total - material_xs % absorption) * flux
@ -899,7 +1318,7 @@ contains
! Any other cross section has to be calculated on-the-fly. This is
! somewhat costly since it requires a loop over each nuclide in a
! material and each reaction in the nuclide
if (score_bin > 1) then
! Set default score
score = ZERO
@ -947,10 +1366,6 @@ contains
end if
end select
! Determine scoring bin index based on what the index of the nuclide
! is in the nuclides array
score_index = n_nuclides_total*t % n_score_bins + j
! Add score to tally
!$omp critical
t % results(score_index, filter_index) % value = &
@ -977,6 +1392,9 @@ contains
integer :: j ! loop index for direction
integer :: k ! loop index for mesh cell crossings
integer :: b ! loop index for nuclide bins
integer :: n ! loop index for legendre order
integer :: num_nm ! Number of N,M orders in harmonic
integer :: q ! loop index for scoring bins
integer :: ijk0(3) ! indices of starting coordinates
integer :: ijk1(3) ! indices of ending coordinates
integer :: ijk_cross(3) ! indices of mesh cell crossed
@ -1167,48 +1585,110 @@ contains
filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1
if (t % all_nuclides) then
! Score reaction rates for each nuclide in material
call score_all_nuclides(p, i_tally, flux, filter_index)
if (p % material /= MATERIAL_VOID) then
! Score reaction rates for each nuclide in material
call score_all_nuclides(p, i_tally, flux, filter_index)
end if
else
NUCLIDE_BIN_LOOP: do b = 1, t % n_nuclide_bins
! Get index of nuclide in nuclides array
i_nuclide = t % nuclide_bins(b)
if (i_nuclide > 0) then
! Get pointer to current material
mat => materials(p % material)
if (p % material /= MATERIAL_VOID) then
! Get pointer to current material
mat => materials(p % material)
! Determine if nuclide is actually in material
NUCLIDE_MAT_LOOP: do j = 1, mat % n_nuclides
! If index of nuclide matches the j-th nuclide listed in
! the material, break out of the loop
if (i_nuclide == mat % nuclide(j)) exit
! Determine if nuclide is actually in material
NUCLIDE_MAT_LOOP: do j = 1, mat % n_nuclides
! If index of nuclide matches the j-th nuclide listed in
! the material, break out of the loop
if (i_nuclide == mat % nuclide(j)) exit
! If we've reached the last nuclide in the material, it
! means the specified nuclide to be tallied is not in this
! material
if (j == mat % n_nuclides) then
cycle NUCLIDE_BIN_LOOP
end if
end do NUCLIDE_MAT_LOOP
! If we've reached the last nuclide in the material, it
! means the specified nuclide to be tallied is not in this
! material
if (j == mat % n_nuclides) then
cycle NUCLIDE_BIN_LOOP
end if
end do NUCLIDE_MAT_LOOP
atom_density = mat % atom_density(j)
atom_density = mat % atom_density(j)
else
atom_density = ZERO
end if
end if
! Determine score for each bin
SCORE_LOOP: do j = 1, t % n_score_bins
j = 0
SCORE_LOOP: do q = 1, t % n_user_score_bins
j = j + 1
! determine what type of score bin
score_bin = t % score_bins(j)
! Determine scoring bin index
score_index = (b - 1)*t % n_score_bins + j
if (i_nuclide > 0) then
! Determine macroscopic nuclide cross section
! Determine macroscopic nuclide cross section
select case(score_bin)
case (SCORE_FLUX)
score = flux
case (SCORE_FLUX_YN)
score_index = score_index - 1
score = flux
num_nm = 1
! Find the order for a collection of requested moments
! and store the moment contribution of each
do n = 0, t % moment_order(j)
! determine scoring bin index
score_index = score_index + num_nm
! Update number of total n,m bins for this n (m = [-n: n])
num_nm = 2 * n + 1
! multiply score by the angular flux moments and store
!$omp critical
t % results(score_index: score_index + num_nm - 1, filter_index) % value = &
t % results(score_index: score_index + num_nm - 1, filter_index) % value + &
score * calc_rn(n, p % coord0 % uvw)
!$omp end critical
end do
j = j + (t % moment_order(j) + 1)**2 - 1
cycle SCORE_LOOP
case (SCORE_TOTAL)
score = micro_xs(i_nuclide) % total * &
atom_density * flux
case (SCORE_TOTAL_YN)
score_index = score_index - 1
! Total cross section is pre-calculated
score = micro_xs(i_nuclide) % total * &
atom_density * flux
num_nm = 1
! Find the order for a collection of requested moments
! and store the moment contribution of each
do n = 0, t % moment_order(j)
! determine scoring bin index
score_index = score_index + num_nm
! Update number of total n,m bins for this n (m = [-n: n])
num_nm = 2 * n + 1
! multiply score by the angular flux moments and store
!$omp critical
t % results(score_index: score_index + num_nm - 1, filter_index) % value = &
t % results(score_index: score_index + num_nm - 1, filter_index) % value + &
score * calc_rn(n, p % coord0 % uvw)
!$omp end critical
end do
j = j + (t % moment_order(j) + 1)**2 - 1
cycle SCORE_LOOP
case (SCORE_SCATTER)
score = (micro_xs(i_nuclide) % total - &
micro_xs(i_nuclide) % absorption) * &
@ -1233,12 +1713,63 @@ contains
end select
else
! Determine macroscopic material cross section
! Determine macroscopic material cross section
select case(score_bin)
case (SCORE_FLUX)
score = flux
case (SCORE_FLUX_YN)
score_index = score_index - 1
score = flux
num_nm = 1
! Find the order for a collection of requested moments
! and store the moment contribution of each
do n = 0, t % moment_order(j)
! determine scoring bin index
score_index = score_index + num_nm
! Update number of total n,m bins for this n (m = [-n: n])
num_nm = 2 * n + 1
! multiply score by the angular flux moments and store
!$omp critical
t % results(score_index: score_index + num_nm - 1, filter_index) % value = &
t % results(score_index: score_index + num_nm - 1, filter_index) % value + &
score * calc_rn(n, p % coord0 % uvw)
!$omp end critical
end do
j = j + (t % moment_order(j) + 1)**2 - 1
cycle SCORE_LOOP
case (SCORE_TOTAL)
score = material_xs % total * flux
case (SCORE_TOTAL_YN)
score_index = score_index - 1
! Total cross section is pre-calculated
score = material_xs % total * flux
num_nm = 1
! Find the order for a collection of requested moments
! and store the moment contribution of each
do n = 0, t % moment_order(j)
! determine scoring bin index
score_index = score_index + num_nm
! Update number of total n,m bins for this n (m = [-n: n])
num_nm = 2 * n + 1
! multiply score by the angular flux moments and store
!$omp critical
t % results(score_index: score_index + num_nm - 1, filter_index) % value = &
t % results(score_index: score_index + num_nm - 1, filter_index) % value + &
score * calc_rn(n, p % coord0 % uvw)
!$omp end critical
end do
j = j + (t % moment_order(j) + 1)**2 - 1
cycle SCORE_LOOP
case (SCORE_SCATTER)
score = (material_xs % total - material_xs % absorption) * flux
case (SCORE_ABSORPTION)
@ -1258,9 +1789,6 @@ contains
end select
end if
! Determine scoring bin index
score_index = (b - 1)*t % n_score_bins + j
! Add score to tally
!$omp critical
t % results(score_index, filter_index) % value = &

44
src/tally_header.F90
View file

@ -47,7 +47,7 @@ module tally_header
!===============================================================================
! TALLYFILTER describes a filter that limits what events score to a tally. For
! example, a cell filter indicates that only particles in a specified cell
! should score to the tally.
! should score to the tally.
!===============================================================================
type TallyFilter
@ -55,7 +55,7 @@ module tally_header
integer :: n_bins = 0
integer, allocatable :: int_bins(:)
real(8), allocatable :: real_bins(:) ! Only used for energy filters
! Type-Bound procedures
contains
procedure :: clear => tallyfilter_clear ! Deallocates TallyFilter
@ -105,7 +105,7 @@ module tally_header
! scattering response.
integer :: n_score_bins = 0
integer, allocatable :: score_bins(:)
integer, allocatable :: scatt_order(:)
integer, allocatable :: moment_order(:)
integer :: n_user_score_bins = 0
! Results for each bin -- the first dimension of the array is for scores
@ -122,14 +122,14 @@ module tally_header
! Number of realizations of tally random variables
integer :: n_realizations = 0
! Type-Bound procedures
contains
procedure :: clear => tallyobject_clear ! Deallocates TallyObject
end type TallyObject
contains
!===============================================================================
! TALLYFILTER_CLEAR deallocates a TallyFilter element and sets it to its as
! initialized state.
@ -137,16 +137,16 @@ module tally_header
subroutine tallyfilter_clear(this)
class(TallyFilter), intent(inout) :: this ! The TallyFilter to be cleared
this % type = NONE
this % n_bins = 0
if (allocated(this % int_bins)) &
deallocate(this % int_bins)
if (allocated(this % real_bins)) &
deallocate(this % real_bins)
end subroutine tallyfilter_clear
!===============================================================================
! TALLYOBJECT_CLEAR deallocates a TallyObject element and sets it to its as
! initialized state.
@ -154,44 +154,44 @@ module tally_header
subroutine tallyobject_clear(this)
class(TallyObject), intent(inout) :: this ! The TallyObject to be cleared
integer :: i ! Loop Index
! This routine will go through each item in TallyObject and set the value
! to its default, as-initialized values, including deallocations.
this % label = ""
if (allocated(this % filters)) then
do i = 1, size(this % filters)
call this % filters(i) % clear()
end do
deallocate(this % filters)
end if
if (allocated(this % stride)) &
deallocate(this % stride)
this % find_filter = 0
this % n_nuclide_bins = 0
if (allocated(this % nuclide_bins)) &
deallocate(this % nuclide_bins)
this % all_nuclides = .false.
this % n_score_bins = 0
if (allocated(this % score_bins)) &
deallocate(this % score_bins)
if (allocated(this % scatt_order)) &
deallocate(this % scatt_order)
if (allocated(this % moment_order)) &
deallocate(this % moment_order)
this % n_user_score_bins = 0
if (allocated(this % results)) &
deallocate(this % results)
this % reset = .false.
this % n_realizations = 0
end subroutine tallyobject_clear
end module tally_header

2
src/tracking.F90
View file

@ -66,7 +66,7 @@ contains
total_weight = total_weight + p % wgt
!$omp end critical
! Force calculation of cross-sections by setting last energy to zero
! Force calculation of cross-sections by setting last energy to zero
micro_xs % last_E = ZERO
! Prepare to write out particle track.

77
src/utils/convert_binary.py Executable file
View 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])

11
src/utils/setup.py Normal file
View file

@ -0,0 +1,11 @@
#!/usr/bin/env python
from distutils.core import setup
setup(name='statepoint',
version='0.6.0',
description='OpenMC StatePoint',
author='Paul Romano',
author_email='paul.k.romano@gmail.com',
url='https://github.com/mit-crpg/openmc',
py_modules=['statepoint'])

156
src/utils/statepoint.py
View file

@ -6,81 +6,89 @@ from collections import OrderedDict
import numpy as np
import scipy.stats
REVISION_STATEPOINT = 12
filter_types = {1: 'universe', 2: 'material', 3: 'cell', 4: 'cellborn',
5: 'surface', 6: 'mesh', 7: 'energyin', 8: 'energyout'}
score_types = {-1: 'flux',
-2: 'total',
-3: 'scatter',
-4: 'nu-scatter',
-5: 'scatter-n',
-6: 'scatter-pn',
-7: 'transport',
-8: 'n1n',
-9: 'absorption',
-10: 'fission',
-11: 'nu-fission',
-12: 'kappa-fission',
-13: 'current',
-14: 'events',
1: '(n,total)',
2: '(n,elastic)',
4: '(n,level)',
11: '(n,2nd)',
16: '(n,2n)',
17: '(n,3n)',
18: '(n,fission)',
19: '(n,f)',
20: '(n,nf)',
21: '(n,2nf)',
22: '(n,na)',
23: '(n,n3a)',
24: '(n,2na)',
25: '(n,3na)',
28: '(n,np)',
29: '(n,n2a)',
30: '(n,2n2a)',
32: '(n,nd)',
33: '(n,nt)',
34: '(n,nHe-3)',
35: '(n,nd2a)',
36: '(n,nt2a)',
37: '(n,4n)',
38: '(n,3nf)',
41: '(n,2np)',
42: '(n,3np)',
44: '(n,n2p)',
45: '(n,npa)',
91: '(n,nc)',
101: '(n,disappear)',
102: '(n,gamma)',
103: '(n,p)',
104: '(n,d)',
105: '(n,t)',
106: '(n,3He)',
107: '(n,a)',
108: '(n,2a)',
109: '(n,3a)',
111: '(n,2p)',
112: '(n,pa)',
113: '(n,t2a)',
114: '(n,d2a)',
115: '(n,pd)',
116: '(n,pt)',
117: '(n,da)',
201: '(n,Xn)',
202: '(n,Xgamma)',
203: '(n,Xp)',
204: '(n,Xd)',
205: '(n,Xt)',
206: '(n,X3He)',
207: '(n,Xa)',
444: '(damage)',
649: '(n,pc)',
699: '(n,dc)',
749: '(n,tc)',
799: '(n,3Hec)',
849: '(n,tc)'}
-2: 'total',
-3: 'scatter',
-4: 'nu-scatter',
-5: 'scatter-n',
-6: 'scatter-pn',
-7: 'nu-scatter-n',
-8: 'nu-scatter-pn',
-9: 'transport',
-10: 'n1n',
-11: 'absorption',
-12: 'fission',
-13: 'nu-fission',
-14: 'kappa-fission',
-15: 'current',
-16: 'flux-yn',
-17: 'total-yn',
-18: 'scatter-yn',
-19: 'nu-scatter-yn',
-20: 'events',
1: '(n,total)',
2: '(n,elastic)',
4: '(n,level)',
11: '(n,2nd)',
16: '(n,2n)',
17: '(n,3n)',
18: '(n,fission)',
19: '(n,f)',
20: '(n,nf)',
21: '(n,2nf)',
22: '(n,na)',
23: '(n,n3a)',
24: '(n,2na)',
25: '(n,3na)',
28: '(n,np)',
29: '(n,n2a)',
30: '(n,2n2a)',
32: '(n,nd)',
33: '(n,nt)',
34: '(n,nHe-3)',
35: '(n,nd2a)',
36: '(n,nt2a)',
37: '(n,4n)',
38: '(n,3nf)',
41: '(n,2np)',
42: '(n,3np)',
44: '(n,n2p)',
45: '(n,npa)',
91: '(n,nc)',
101: '(n,disappear)',
102: '(n,gamma)',
103: '(n,p)',
104: '(n,d)',
105: '(n,t)',
106: '(n,3He)',
107: '(n,a)',
108: '(n,2a)',
109: '(n,3a)',
111: '(n,2p)',
112: '(n,pa)',
113: '(n,t2a)',
114: '(n,d2a)',
115: '(n,pd)',
116: '(n,pt)',
117: '(n,da)',
201: '(n,Xn)',
202: '(n,Xgamma)',
203: '(n,Xp)',
204: '(n,Xd)',
205: '(n,Xt)',
206: '(n,X3He)',
207: '(n,Xa)',
444: '(damage)',
649: '(n,pc)',
699: '(n,dc)',
749: '(n,tc)',
799: '(n,3Hec)',
849: '(n,tc)'}
score_types.update({MT: '(n,n' + str(MT-50) + ')' for MT in range(51,91)})
score_types.update({MT: '(n,p' + str(MT-600) + ')' for MT in range(600,649)})
score_types.update({MT: '(n,d' + str(MT-650) + ')' for MT in range(650,699)})
@ -151,7 +159,7 @@ class StatePoint(object):
# Read statepoint revision
self.revision = self._get_int(path='revision')[0]
if self.revision != 11:
if self.revision != REVISION_STATEPOINT:
raise Exception('Statepoint Revision is not consistent.')
# Read OpenMC version
@ -287,7 +295,7 @@ class StatePoint(object):
t.n_scores = self._get_int(path=base+'n_score_bins')[0]
t.scores = [score_types[j] for j in self._get_int(
t.n_scores, path=base+'score_bins')]
t.scatt_order = self._get_int(t.n_scores, path=base+'scatt_order')
t.moment_order = self._get_int(t.n_scores, path=base+'moment_order')
# Read number of user score bins
t.n_user_scores = self._get_int(path=base+'n_user_score_bins')[0]
@ -301,7 +309,7 @@ class StatePoint(object):
# Source bank present
source_present = self._get_int(path='source_present')[0]
if source_present == 1:
self.source_present = True
self.source_present = True
else:
self.source_present = False

12
src/vector_header.F90
View file

@ -21,11 +21,15 @@ module vector_header
procedure :: create => vector_create
procedure :: destroy => vector_destroy
procedure :: add_value => vector_add_value
#ifdef PETSC
procedure :: setup_petsc => vector_setup_petsc
procedure :: write_petsc_binary => vector_write_petsc_binary
#endif
end type Vector
#ifdef PETSC
integer :: petsc_err ! petsc error code
#endif
contains
@ -88,39 +92,39 @@ contains
! VECTOR_SETUP_PETSC links the data to a PETSc vector
!===============================================================================
#ifdef PETSC
subroutine vector_setup_petsc(self)
class(Vector), intent(inout) :: self ! vector instance
! Link to PETSc
#ifdef PETSC
call VecCreateSeqWithArray(PETSC_COMM_WORLD, 1, self % n, self % val, &
self % petsc_vec, petsc_err)
#endif
! Set that PETSc is now active
self % petsc_active = .true.
end subroutine vector_setup_petsc
#endif
!===============================================================================
! VECTOR_WRITE_PETSC_BINARY writes the PETSc vector to a binary file
!===============================================================================
#ifdef PETSC
subroutine vector_write_petsc_binary(self, filename)
character(*), intent(in) :: filename ! name of file to write to
class(Vector), intent(in) :: self ! vector instance
#ifdef PETSC
type(PetscViewer) :: viewer ! PETSc viewer instance
call PetscViewerBinaryOpen(PETSC_COMM_WORLD, trim(filename), &
FILE_MODE_WRITE, viewer, petsc_err)
call VecView(self % petsc_vec, viewer, petsc_err)
call PetscViewerDestroy(viewer, petsc_err)
#endif
end subroutine vector_write_petsc_binary
#endif
end module vector_header

71
src/xml/LICENSE
View file

@ -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.

32
src/xml/Makefile
View file

@ -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

3
src/xml/README
View file

@ -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/

55
src/xml/common/FoX_common.F90
View file

@ -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

59
src/xml/common/Makefile
View file

@ -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

1081
src/xml/common/m_common_attrs.F90
View file

File diff suppressed because it is too large Load diff

261
src/xml/common/m_common_buffer.F90
View file

@ -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

447
src/xml/common/m_common_charset.F90
View file

@ -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

490
src/xml/common/m_common_content_model.F90
View file

@ -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

1645
src/xml/common/m_common_element.F90
View file

File diff suppressed because it is too large Load diff

236
src/xml/common/m_common_elstack.F90
View file

@ -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

475
src/xml/common/m_common_entities.F90
View file

@ -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

86
src/xml/common/m_common_entity_expand.F90
View file

@ -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

211
src/xml/common/m_common_error.F90
View file

@ -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

102
src/xml/common/m_common_io.F90
View file

@ -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

501
src/xml/common/m_common_namecheck.F90
View file

@ -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

830
src/xml/common/m_common_namespaces.F90
View file

@ -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

120
src/xml/common/m_common_notations.F90
View file

@ -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

121
src/xml/common/m_common_struct.F90
View file

@ -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

266
src/xml/dom/FoX_dom.F90
View file

@ -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

49
src/xml/dom/Makefile
View file

@ -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

12484
src/xml/dom/m_dom_dom.F90
View file

File diff suppressed because it is too large Load diff

211
src/xml/dom/m_dom_error.F90
View file

@ -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

2444
src/xml/dom/m_dom_extras.F90
View file

File diff suppressed because it is too large Load diff

577
src/xml/dom/m_dom_parse.F90
View file

@ -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

437
src/xml/dom/m_dom_utils.F90
View file

@ -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

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

48
src/xml/fsys/Makefile
View file

@ -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

124
src/xml/fsys/fox_m_fsys_abort_flush.F90
View file

@ -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

94
src/xml/fsys/fox_m_fsys_array_str.F90
View file

@ -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

561
src/xml/fsys/fox_m_fsys_count_parse_input.F90
View file

@ -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

2250
src/xml/fsys/fox_m_fsys_format.F90
View file

File diff suppressed because it is too large Load diff

2281
src/xml/fsys/fox_m_fsys_parse_input.F90
View file

File diff suppressed because it is too large Load diff

12
src/xml/fsys/fox_m_fsys_realtypes.F90
View file

@ -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

35
src/xml/fsys/fox_m_fsys_string.F90
View file

@ -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

191
src/xml/fsys/fox_m_fsys_string_list.F90
View file

@ -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

254
src/xml/fsys/fox_m_fsys_varstr.F90
View file

@ -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

17
src/xml/fsys/m_ieee.F90
View file

@ -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

194
src/xml/openmc_fox.F90 Normal file
View file

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

34
src/xml/sax/FoX_sax.F90
View file

@ -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

50
src/xml/sax/Makefile
View file

@ -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

313
src/xml/sax/m_sax_operate.F90
View file

@ -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

3029
src/xml/sax/m_sax_parser.F90
View file

File diff suppressed because it is too large Load diff

411
src/xml/sax/m_sax_reader.F90
View file

@ -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

Some files were not shown because too many files have changed in this diff Show more