Merge branch 'develop' into rng-streams

.gitignore

@@ -1,4 +1,5 @@
 # Compiled objects and modules
+*.a
 *.o
 *.mod
 *.log
@@ -26,4 +27,4 @@ src/xml-fortran/xmlreader
 src/templates/*.f90
 
 # Test results error file
-results_error.dat
+results_error.dat

docs/source/conf.py

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

docs/source/devguide/index.rst

@@ -15,6 +15,6 @@ as debugging.
     structures
     styleguide
     workflow
-    xml-fortran
+    xml-parsing
     statepoint
     voxel

docs/source/devguide/statepoint.rst

@@ -4,6 +4,544 @@
 State Point Binary File Specifications
 ======================================
 
+-----------
+Revision 10 
+-----------
+
+**integer(4) FILETYPE_STATEPOINT**
+
+    Flags whether this file is a statepoint file or a particle restart file.
+
+**integer(4) REVISION_STATEPOINT**
+
+    Revision of the binary state point file. Any time a change is made in the
+    format of the state-point file, this integer is incremented.
+
+**integer(4) VERSION_MAJOR**
+
+    Major version number for OpenMC
+
+**integer(4) VERSION_MINOR**
+
+    Minor version number for OpenMC
+
+**integer(4) VERSION_RELEASE**
+
+    Release version number for OpenMC
+
+**character(19) time_stamp**
+
+    Date and time the state point was written.
+
+**character(255) path**
+
+    Absolute path to directory containing input files.
+
+**integer(8) seed**
+
+    Pseudo-random number generator seed.
+
+**integer(4) run_mode**
+
+    run mode used. The modes are described in constants.F90.
+
+**integer(8) n_particles**
+
+    Number of particles used per generation.
+
+**integer(4) n_batches**
+
+    Total number of batches (active + inactive).
+
+**integer(4) current_batch**
+
+    The number of batches already simulated.
+
+if (run_mode == MODE_EIGENVALUE)
+
+    **integer(4) n_inactive**
+
+        Number of inactive batches
+
+    **integer(4) gen_per_batch**
+
+        Number of generations per batch for criticality calculations
+
+    *do i = 1, current_batch \* gen_per_batch*
+
+        **real(8) k_generation(i)**
+
+             k-effective for the i-th total generation
+
+    *do i = 1, current_batch \* gen_per_batch*
+
+        **real(8) entropy(i)**
+
+            Shannon entropy for the i-th total generation
+
+    **real(8) k_col_abs**
+
+        Sum of product of collision/absorption estimates of k-effective
+
+    **real(8) k_col_tra**
+
+        Sum of product of collision/track-length estimates of k-effective
+
+    **real(8) k_abs_tra**
+
+        Sum of product of absorption/track-length estimates of k-effective
+
+    **real(8) k_combined(2)**
+
+        Mean and standard deviation of a combined estimate of k-effective
+
+    **integer(4) cmfd_on**
+
+        Flag that cmfd is on
+
+    if (cmfd_on)
+
+        **integer(4) cmfd % indices**
+
+            Indices for cmfd mesh (i,j,k,g)
+
+        **real(8) cmfd % k_cmfd(1:current_batch)**
+
+            CMFD eigenvalues
+
+        **real(8) cmfd % src(1:I,1:J,1:K,1:G)**
+
+            CMFD fission source
+
+        **real(8) cmfd % entropy(1:current_batch)**
+
+            CMFD estimate of Shannon entropy
+
+        **real(8) cmfd % balance(1:current_batch)**
+
+            RMS of the residual neutron balance equation on CMFD mesh
+
+        **real(8) cmfd % dom(1:current_batch)**
+
+            CMFD estimate of dominance ratio
+
+        **real(8) cmfd % scr_cmp(1:current_batch)**
+
+            RMS comparison of difference between OpenMC and CMFD fission source
+
+**integer(4) n_meshes**
+
+    Number of meshes in tallies.xml file
+
+*do i = 1, n_meshes*
+
+    **integer(4) meshes(i) % id**
+
+        Unique ID of mesh.
+
+    **integer(4) meshes(i) % type**
+
+        Type of mesh.
+
+    **integer(4) meshes(i) % n_dimension**
+
+        Number of dimensions for mesh (2 or 3).
+
+    **integer(4) meshes(i) % dimension(:)**
+
+        Number of mesh cells in each dimension.
+
+    **real(8) meshes(i) % lower_left(:)**
+
+        Coordinates of lower-left corner of mesh.
+
+    **real(8) meshes(i) % upper_right(:)**
+
+        Coordinates of upper-right corner of mesh.
+
+    **real(8) meshes(i) % width(:)**
+
+        Width of each mesh cell in each dimension.
+
+**integer(4) n_tallies**
+
+*do i = 1, n_tallies*
+
+    **integer(4) tallies(i) % id**
+
+        Unique ID of tally.
+
+    **integer(4) tallies(i) % n_realizations**
+
+        Number of realizations for the i-th tally.
+
+    **integer(4) size(tallies(i) % scores, 1)**
+
+        Total number of score bins for the i-th tally
+
+    **integer(4) size(tallies(i) % scores, 2)**
+
+        Total number of filter bins for the i-th tally
+
+    **integer(4) tallies(i) % n_filters**
+
+    *do j = 1, tallies(i) % n_filters*
+
+        **integer(4) tallies(i) % filter(j) % type**
+
+            Type of tally filter.
+
+        **integer(4) tallies(i) % filter(j) % n_bins**
+
+            Number of bins for filter.
+
+        **integer(4)/real(8) tallies(i) % filter(j) % bins(:)**
+
+            Value for each filter bin of this type.
+
+    **integer(4) tallies(i) % n_nuclide_bins**
+
+        Number of nuclide bins. If none are specified, this is just one.
+
+    *do j = 1, tallies(i) % n_nuclide_bins*
+
+        **integer(4) tallies(i) % nuclide_bins(j)**
+
+            Values of specified nuclide bins
+
+    **integer(4) tallies(i) % n_score_bins**
+
+        Number of scoring bins.
+
+    *do j = 1, tallies(i) % n_score_bins*
+
+        **integer(4) tallies(i) % score_bins(j)**
+
+            Values of specified scoring bins (e.g. SCORE_FLUX).
+            
+    *do j = 1, tallies(i) % n_score_bins*
+
+        **integer(4) tallies(i) % scatt_order(j)**
+
+            Scattering Order specified scoring bins.
+            
+    **integer(4) tallies(i) % n_score_bins**
+
+        Number of scoring bins without accounting for those added by
+        the scatter-pn command.
+
+**integer(4) n_realizations**
+
+    Number of realizations for global tallies.
+
+**integer(4) N_GLOBAL_TALLIES**
+
+    Number of global tally scores
+
+*do i = 1, N_GLOBAL_TALLIES*
+
+    **real(8) global_tallies(i) % sum**
+
+        Accumulated sum for the i-th global tally
+
+    **real(8) global_tallies(i) % sum_sq**
+
+        Accumulated sum of squares for the i-th global tally
+
+**integer(4) tallies_on**
+
+    Flag indicated if tallies are present in the file.
+
+if (tallies_on > 0)
+
+    *do i = 1, n_tallies*
+
+        *do k = 1, size(tallies(i) % scores, 2)*
+
+            *do j = 1, size(tallies(i) % scores, 1)*
+
+                **real(8) tallies(i) % scores(j,k) % sum**
+            
+                    Accumulated sum for the j-th score and k-th filter of the
+                    i-th tally
+
+                **real(8) tallies(i) % scores(j,k) % sum_sq**
+
+                    Accumulated sum of squares for the j-th score and k-th
+                    filter of the i-th tally
+
+if (run_mode == MODE_EIGENVALUE)
+
+    *do i = 1, n_particles*
+
+        **real(8) source_bank(i) % wgt**
+
+            Weight of the i-th source particle
+
+        **real(8) source_bank(i) % xyz(1:3)**
+
+            Coordinates of the i-th source particle.
+
+        **real(8) source_bank(i) % uvw(1:3)**
+
+            Direction of the i-th source particle
+
+        **real(8) source_bank(i) % E**
+
+            Energy of the i-th source particle.
+
+----------
+Revision 9
+----------
+
+**integer(4) FILETYPE_STATEPOINT**
+
+    Flags whether this file is a statepoint file or a particle restart file.
+
+**integer(4) REVISION_STATEPOINT**
+
+    Revision of the binary state point file. Any time a change is made in the
+    format of the state-point file, this integer is incremented.
+
+**integer(4) VERSION_MAJOR**
+
+    Major version number for OpenMC
+
+**integer(4) VERSION_MINOR**
+
+    Minor version number for OpenMC
+
+**integer(4) VERSION_RELEASE**
+
+    Release version number for OpenMC
+
+**character(19) time_stamp**
+
+    Date and time the state point was written.
+
+**character(255) path**
+
+    Absolute path to directory containing input files.
+
+**integer(8) seed**
+
+    Pseudo-random number generator seed.
+
+**integer(4) run_mode**
+
+    run mode used. The modes are described in constants.F90.
+
+**integer(8) n_particles**
+
+    Number of particles used per generation.
+
+**integer(4) n_batches**
+
+    Total number of batches (active + inactive).
+
+**integer(4) current_batch**
+
+    The number of batches already simulated.
+
+if (run_mode == MODE_EIGENVALUE)
+
+    **integer(4) n_inactive**
+
+        Number of inactive batches
+
+    **integer(4) gen_per_batch**
+
+        Number of generations per batch for criticality calculations
+
+    *do i = 1, current_batch \* gen_per_batch*
+
+        **real(8) k_generation(i)**
+
+             k-effective for the i-th total generation
+
+    *do i = 1, current_batch \* gen_per_batch*
+
+        **real(8) entropy(i)**
+
+            Shannon entropy for the i-th total generation
+
+    **real(8) k_col_abs**
+
+        Sum of product of collision/absorption estimates of k-effective
+
+    **real(8) k_col_tra**
+
+        Sum of product of collision/track-length estimates of k-effective
+
+    **real(8) k_abs_tra**
+
+        Sum of product of absorption/track-length estimates of k-effective
+
+    **real(8) k_combined(2)**
+
+        Mean and standard deviation of a combined estimate of k-effective
+
+**integer(4) n_meshes**
+
+    Number of meshes in tallies.xml file
+
+*do i = 1, n_meshes*
+
+    **integer(4) meshes(i) % id**
+
+        Unique ID of mesh.
+
+    **integer(4) meshes(i) % type**
+
+        Type of mesh.
+
+    **integer(4) meshes(i) % n_dimension**
+
+        Number of dimensions for mesh (2 or 3).
+
+    **integer(4) meshes(i) % dimension(:)**
+
+        Number of mesh cells in each dimension.
+
+    **real(8) meshes(i) % lower_left(:)**
+
+        Coordinates of lower-left corner of mesh.
+
+    **real(8) meshes(i) % upper_right(:)**
+
+        Coordinates of upper-right corner of mesh.
+
+    **real(8) meshes(i) % width(:)**
+
+        Width of each mesh cell in each dimension.
+
+**integer(4) n_tallies**
+
+*do i = 1, n_tallies*
+
+    **integer(4) tallies(i) % id**
+
+        Unique ID of tally.
+
+    **integer(4) tallies(i) % n_realizations**
+
+        Number of realizations for the i-th tally.
+
+    **integer(4) size(tallies(i) % scores, 1)**
+
+        Total number of score bins for the i-th tally
+
+    **integer(4) size(tallies(i) % scores, 2)**
+
+        Total number of filter bins for the i-th tally
+
+    **integer(4) tallies(i) % n_filters**
+
+    *do j = 1, tallies(i) % n_filters*
+
+        **integer(4) tallies(i) % filter(j) % type**
+
+            Type of tally filter.
+
+        **integer(4) tallies(i) % filter(j) % n_bins**
+
+            Number of bins for filter.
+
+        **integer(4)/real(8) tallies(i) % filter(j) % bins(:)**
+
+            Value for each filter bin of this type.
+
+    **integer(4) tallies(i) % n_nuclide_bins**
+
+        Number of nuclide bins. If none are specified, this is just one.
+
+    *do j = 1, tallies(i) % n_nuclide_bins*
+
+        **integer(4) tallies(i) % nuclide_bins(j)**
+
+            Values of specified nuclide bins
+
+    **integer(4) tallies(i) % n_score_bins**
+
+        Number of scoring bins.
+
+    *do j = 1, tallies(i) % n_score_bins*
+
+        **integer(4) tallies(i) % score_bins(j)**
+
+            Values of specified scoring bins (e.g. SCORE_FLUX).
+            
+    *do j = 1, tallies(i) % n_score_bins*
+
+        **integer(4) tallies(i) % scatt_order(j)**
+
+            Scattering Order specified scoring bins.
+            
+    **integer(4) tallies(i) % n_score_bins**
+
+        Number of scoring bins without accounting for those added by
+        the scatter-pn command.
+
+**integer(4) n_realizations**
+
+    Number of realizations for global tallies.
+
+**integer(4) N_GLOBAL_TALLIES**
+
+    Number of global tally scores
+
+*do i = 1, N_GLOBAL_TALLIES*
+
+    **real(8) global_tallies(i) % sum**
+
+        Accumulated sum for the i-th global tally
+
+    **real(8) global_tallies(i) % sum_sq**
+
+        Accumulated sum of squares for the i-th global tally
+
+**integer(4) tallies_on**
+
+    Flag indicated if tallies are present in the file.
+
+if (tallies_on > 0)
+
+    *do i = 1, n_tallies*
+
+        *do k = 1, size(tallies(i) % scores, 2)*
+
+            *do j = 1, size(tallies(i) % scores, 1)*
+
+                **real(8) tallies(i) % scores(j,k) % sum**
+            
+                    Accumulated sum for the j-th score and k-th filter of the
+                    i-th tally
+
+                **real(8) tallies(i) % scores(j,k) % sum_sq**
+
+                    Accumulated sum of squares for the j-th score and k-th
+                    filter of the i-th tally
+
+if (run_mode == MODE_EIGENVALUE)
+
+    *do i = 1, n_particles*
+
+        **real(8) source_bank(i) % wgt**
+
+            Weight of the i-th source particle
+
+        **real(8) source_bank(i) % xyz(1:3)**
+
+            Coordinates of the i-th source particle.
+
+        **real(8) source_bank(i) % uvw(1:3)**
+
+            Direction of the i-th source particle
+
+        **real(8) source_bank(i) % E**
+
+            Energy of the i-th source particle.
+
 ----------
 Revision 8
 ----------

docs/source/devguide/workflow.rst

@@ -5,41 +5,113 @@ Development Workflow
 ====================
 
 Anyone wishing to make contributions to OpenMC should be fully acquianted and
-comfortable working with git_ and GitHub_. The primary means of modifying and
-making contributions to OpenMC is through GitHub `pull requests`_. This is
-what's known as a fork and pull development model. The steps for this are as
-follows:
+comfortable working with git_ and GitHub_. We assume here that you have git
+installed on your system, have a GitHub account, and have setup SSH keys to be
+able to create/push to repositories on GitHub. 
+
+Overview
+--------
+
+Development of OpenMC relies heavily on branching; specifically, we use a
+branching model sometimes referred to as `git flow`_. If you plan to contribute
+to OpenMC development, we highly recommend that you read the linked blog post to
+get a sense of how the branching model works. There are two main branches that
+always exist: *master* and *develop*. The *master* branch is a stable branch
+that contains the latest release of the code. The *develop* branch is where any
+ongoing development takes place prior to a release and is not guaranteed to be
+stable. When the development team decides that a release should occur, the
+*develop* branch is merged into *master*.
+
+Trivial changes to the code may be committed directly to the *develop* branch by
+a trusted developer. However, most new features should be developed on a branch
+that branches off of *develop*. When the feature is completed, a `pull request`_
+is initiated on GitHub that is then reviewed by a trusted developer. If the pull
+request is satisfactory, it is then merged into *develop*. Note that a trusted
+developer may not review their own pull request (i.e., an independent code
+review is required).
+
+Code Review Criteria
+--------------------
+
+In order to be considered suitable for inclusion in the *develop* branch, the
+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`_).
+- Passes the regression suite.
+- If appropriate, test cases are added to regression suite.
+- No memory leaks (checked with valgrind_).
+- Conforms to the OpenMC `style guide`_.
+- No degradation of performance or greatly increased memory usage. This is not a
+  hard rule -- in certain circumstances, a performance loss might be acceptable
+  if there are compelling reasons.
+- New features/input are documented.
+- No unnecessary external software dependencies are introduced.
+
+Contributing
+------------
+
+Now that you understand the basic development workflow, let's discuss how an
+individual to contribute to development. Note that this would apply to both new
+features and bug fixes. The general steps for contributing are as follows:
 
 1. Fork the main openmc repository from `mit-crpg/openmc`_. This will create a
-repository with the same name under your personal account. As such, you can
-commit to it as you please without disrupting other developers.
+   repository with the same name under your personal account. As such, you can
+   commit to it as you please without disrupting other developers.
 
-2. Create a branch that you want merged back to `mit-crpg/openmc`_ and make
-commits that you intend to go back. If you have made other changes that should
-not be merged back, those changes should be on another branch.
+   .. image:: ../../img/fork.png
 
-3. Issue a pull request from GitHub and select the branch you want merged.
+2. Clone your fork of OpenMC and create a branch that branches off of *develop*:
 
-4. The OpenMC integration manager will review your pull request and make sure it
-conforms to the :ref:`devguide_styleguide`, compiles correctly, runs in parallel
-correctly, does not break other features in the code, etc. Any issues with the
-pull request can be discussed directly on the pull request page itself.
+   .. code-block:: sh
 
-5. After the pull request has been thoroughly vetted, it is merged back into
-`mit-crpg/openmc`_.
+       git clone git@github.com:yourusername/openmc.git
+       cd openmc
+       git checkout -b newbranch develop
+
+3. Make your changes on the new branch that you intend to have included in
+   *develop*. If you have made other changes that should not be merged back, 
+   ensure that those changes are made on a different branch.
+
+4. Issue a pull request from GitHub and select the *develop* branch of
+   mit-crpg/openmc as the target.
+
+   .. image:: ../../img/pullrequest.png
+
+   At a minimum, you should describe what the changes you've made are and why
+   you are making them. If the changes are related to an oustanding issue, make
+   sure it is cross-referenced. A wise developer would also check whether their
+   changes do indeed pass the regression test suite.
+
+5. A trusted developer will review your pull request based on the criteria
+   above. Any issues with the pull request can be discussed directly on the pull
+   request page itself.
+
+6. After the pull request has been thoroughly vetted, it is merged back into the
+   *develop* branch of mit-crpg/openmc.
+
+Private Development
+-------------------
 
 While the process above depends on the fork of the OpenMC repository being
 publicly available on GitHub, you may also wish to do development on a private
 repository for research or commercial purposes. The proper way to do this is to
 create a complete copy of the OpenMC repository (not a fork from GitHub). The
 private repository can then either be stored just locally or in conjunction with
-a private repository on Github (this requires a `paid plan`_). If you want to
-merge some changes you've made in your private repository back to
-`mit-crpg/openmc`_ repository, simply follow the steps above with an extra step
-of pulling a branch from your private repository into your public fork.
+a private repository on Github (this requires a `paid plan`_). Alternatively,
+`Bitbucket`_ offers private repositories for free. If you want to merge some
+changes you've made in your private repository back to mit-crpg/openmc
+repository, simply follow the steps above with an extra step of pulling a branch
+from your private repository into a public fork.
 
 .. _git: http://git-scm.com/
 .. _GitHub: https://github.com/
-.. _pull requests: https://help.github.com/articles/using-pull-requests
+.. _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

docs/source/devguide/xml-fortran.rst

@@ -1,40 +0,0 @@
-.. _devguide_xml-fortran:
-
-=========================
-xml-fortran Input Parsing
-=========================
-
-OpenMC relies on the xml-fortran package for reading and intrepreting the XML
-input files for geometry, materials, settings, tallies, etc. The use of an XML
-format makes writing input files considerably more flexible than would otherwise
-be possible.
-
-With the xml-fortran package, extending the user input files to include new tags
-is fairly straightforward. A "template" file exists for each diferent type of
-input file that tells xml-fortran what to expect in a file. These template files
-can be found in the src/templates directory. The steps for modifying/adding
-input are as follows:
-
-1. Add a ``<variable>``` tag to the desired template file,
-e.g. src/templates/geometry_t.xml. See the `xml-fortran documentation`_ for a
-description of the acceptable fields.
-
-2. In the input_xml module, any input given in your new tag will be read
-automatically through a call to, e.g. read_xml_file_geometry_t. Whatever
-variable name you specified should have the data available.
-
-3. Add code in the appropriate subroutine to check the variable for any possible
-errors.
-
-4. Add a variable in OpenMC to copy the temporary variable into if there are no
-errors.
-
-A set of `RELAX NG`_ schemata exists that enables real-time validation of input
-files when using the GNU Emacs text editor. You should also modify the RELAX NG
-schema for the template you changed (e.g. src/templates/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`_.
-
-.. _xml-fortran documentation: http://xml-fortran.sourceforge.net/documentation.html
-.. _RELAX NG: http://relaxng.org/
-.. _compact syntax: http://relaxng.org/compact-tutorial-20030326.html

docs/source/devguide/xml-parsing.rst

@@ -0,0 +1,38 @@
+.. _devguide_xml-parsing:
+
+=================
+XML Input Parsing
+=================
+
+OpenMC relies on the FoX_ Fortran XML library for reading and intrepreting the
+XML input files for geometry, materials, settings, tallies, etc. The use of an
+XML format makes writing input files considerably more flexible than would
+otherwise be possible.
+
+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`_.
+
+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".
+
+3. Add code to check the variable for any possible errors.
+
+A set of `RELAX NG`_ schemata exists that enables real-time validation of input
+files when using the GNU Emacs text editor. You should also modify the RELAX NG
+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
+.. _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

docs/source/methods/eigenvalue.rst

@@ -108,6 +108,40 @@ at plots of :math:`k_{eff}` and the Shannon entropy. A number of methods have
 been proposed (see e.g. [Romano]_, [Ueki]_), but each of these is not without
 problems.
 
+---------------------------
+Uniform Fission Site Method
+---------------------------
+
+Generally speaking, the variance of a Monte Carlo tally will be inversely
+proportional to the number of events that score to the tally. In a reactor
+problem, this implies that regions with low relative power density will have
+higher variance that regions with high relative power density. One method to
+circumvent the uneven distribution of relative errors is the uniform fission
+site (UFS) method introduced by [Sutton]_. In this method, the portion of the
+problem containing fissionable material is subdivided into a number of cells
+(typically using a structured mesh). Rather than producing
+
+.. math::
+
+    m = \frac{w}{k} \frac{\nu\Sigma_f}{\Sigma_t}
+
+fission sites at each collision where :math:`w` is the weight of the neutron,
+:math:`k` is the previous-generation estimate of the neutron multiplication
+factor, :math:`\nu\Sigma_f` is the neutron production cross section, and
+:math:`\Sigma_t` is the total cross section, in the UFS method we produce
+
+.. math::
+
+    m_{UFS} = \frac{w}{k} \frac{\nu\Sigma_f}{\Sigma_t} \frac{v_i}{s_i}
+
+fission sites at each collision where :math:`v_i` is the fraction of the total
+volume occupied by cell :math:`i` and :math:`s_i` is the fraction of the fission
+source contained in cell :math:`i`. To ensure that no bias is introduced, the
+weight of each fission site stored in the fission bank is :math:`s_i/v_i` rather
+than unity. By ensuring that the expected number of fission sites in each mesh
+cell is constant, the collision density across all cells, and hence the variance
+of tallies, is more uniform than it would be otherwise.
+
 .. _Shannon entropy: https://laws.lanl.gov/vhosts/mcnp.lanl.gov/pdf_files/la-ur-06-3737_entropy.pdf
 
 .. [Lieberoth] J. Lieberoth, "A Monte Carlo Technique to Solve the Static
@@ -119,5 +153,9 @@ problems.
    *Proc. International Conference on Mathematics, Computational Methods, and
    Reactor Physics*, Saratoga Springs, New York (2009).
 
+.. [Sutton] Daniel J. Kelly, Thomas M. Sutton, and Stephen C. Wilson, "MC21
+   Analysis of the Nuclear Energy Agency Monte Carlo Performance Benchmark
+   Problem," *Proc. PHYSOR 2012*, Knoxville, Tennessee, Apr. 15--20 (2012).
+
 .. [Ueki] Taro Ueki, "On-the-Fly Judgments of Monte Carlo Fission Source
    Convergence," *Trans. Am. Nucl. Soc.*, **98**, 512 (2008).

docs/source/methods/physics.rst

@@ -790,6 +790,7 @@ outgoing angle is
 
     \mu = \frac{1}{A} \ln \left ( \xi_4 e^A + (1 - \xi_4) e^{-A} \right ).
 
+.. _ace-law-61:
 
 ACE Law 61 - Correlated Energy and Angle Distribution
 +++++++++++++++++++++++++++++++++++++++++++++++++++++
@@ -952,7 +953,7 @@ as
 
     v_n \bar{\sigma} (v_n, T) = \int d\mathbf{v}_T v_r \sigma(v_r)
     M (\mathbf{v}_T)
-    
+
 where :math:`v_n` is the magnitude of the velocity of the neutron,
 :math:`\bar{\sigma}` is an effective cross section, :math:`T` is the temperature
 of the target material, :math:`\mathbf{v}_T` is the velocity of the target
@@ -1321,7 +1322,7 @@ given analytically by
 
     \mu = 1 - \frac{E_i}{E}
 
-where :math:`E_i` is the energy of the Bragg edge that scattered the neutron. 
+where :math:`E_i` is the energy of the Bragg edge that scattered the neutron.
 
 Outgoing Angle for Incoherent Elastic Scattering
 ------------------------------------------------
@@ -1348,18 +1349,24 @@ where the interpolation factor is defined as
 Outgoing Energy and Angle for Inelastic Scattering
 --------------------------------------------------
 
-On each |sab| table, there is a correlated angle-energy secondary distribution
-for neutron thermal inelastic scattering. While the documentation for the ACE
-format implies that there are a series of equiprobable outgoing energies, the
-outgoing energies may have non-uniform probability distribution. In particular,
-if the thermal data were processed with :math:`iwt = 0` in NJOY, then the first
-and last outgoing energies have a relative probability of 1, the second and
-second to last energies have a relative probability of 4, and all other energies
-have a relative probability of 10. The procedure to determine the outgoing
-energy and angle is as such. First, the interpolation factor is determined from
-equation :eq:`sab-interpolation-factor`. Then, an outgoing energy bin is sampled
-either from a uniform distribution or from the aforementioned skewed
-distribution. The outgoing energy is then interpolated between values
+Each |sab| table provides a correlated angle-energy secondary distribution for
+neutron thermal inelastic scattering.  There are three representations used
+in the ACE thermal scattering data: equiprobable discrete outgoing
+energies, non-uniform yet still discrete outgoing energies, and continuous
+outgoing energies with corresponding probability and cumulative distribution
+functions provided in tabular format.  These three representations all
+represent the angular distribution in a common format, using a series of
+discrete equiprobable outgoing cosines.
+
+Equi-Probable Outgoing Energies
++++++++++++++++++++++++++++++++
+
+If the thermal data was processed with :math:`iwt = 1` in NJOY, then the
+outgoing energy spectra is represented in the ACE data as a set of discrete and
+equiprobable outgoing energies.  The procedure to determine the outgoing energy
+and angle is as such. First, the interpolation factor is determined from
+equation :eq:`sab-interpolation-factor`.  Then, an outgoing energy bin is
+sampled from a uniform distribution and then interpolated between values
 corresponding to neighboring incoming energies:
 
 .. math::
@@ -1380,6 +1387,37 @@ uniformly and then the final cosine is interpolated on the incoming energy grid:
 where :math:`\mu_{i,j,k}` is the k-th outgoing cosine corresponding to the j-th
 outgoing energy and the i-th incoming energy.
 
+Skewed Equi-Probable Outgoing Energies
+++++++++++++++++++++++++++++++++++++++
+
+If the thermal data was processed with :math:`iwt=0` in NJOY, then the
+outgoing energy spectra is represented in the ACE data according to the
+following: the first and last outgoing energies have a relative probability of
+1, the second and second-to-last energies have a relative probability of 4, and
+all other energies have a relative probability of 10.  The procedure to
+determine the outgoing energy and angle is similar to the method discussed
+above, except that the sampled probability distribution is now skewed
+accordingly.
+
+Continuous Outgoing Energies
+++++++++++++++++++++++++++++
+
+If the thermal data was processed with :math:`iwt=2` in NJOY, then the
+outgoing energy spectra is represented by a continuous outgoing energy spectra
+in tabular form with linear-linear interpolation.  The sampling of the outgoing
+energy portion of this format is very similar to :ref:`ACE Law 61<ace-law-61>`,
+but the sampling of the correlated angle is performed as it was in the other
+two representations discussed in this sub-section.  In the Law 61 algorithm,
+we found an interpolation factor :math:`f`, statistically sampled an incoming
+energy bin :math:`\ell`, and sampled an outgoing energy bin :math:`j` based on
+the tabulated cumulative distribution function. Once the outgoing energy has
+been determined with equation :eq:`ace-law-4-energy`, we then need to decide
+which angular distribution data to use.  Like the linear-linear interpolation
+case in Law 61, the angular distribution closest to the sampled value of the
+cumulative distribution function for the outgoing energy is utilized.  The
+actual algorithm utilized to sample the outgoing angle is shown in equation
+:eq:`inelastic-angle`.
+
 .. _probability_tables:
 
 ----------------------------------------------

docs/source/publications.rst

@@ -4,6 +4,53 @@
 Publications
 ============
 
+- Benoit Forget, Sheng Xu, and Kord Smith, "Direct Doppler broadening in Monte
+  Carlo simulations using the multipole representation," *Ann. Nucl. Energy*,
+  **64**, 78--85 (2014). `<http://dx.doi.org/10.1016/j.anucene.2013.09.043>`_
+
+- 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>`_
+
+- Jonathan A. Walsh, Benoit Forget, and Kord S. Smith, "Validation of OpenMC
+  Reactor Physics Simulations with the B&W 1810 Series Benchmarks,"
+  *Trans. Am. Nucl. Soc.*, **109**, 1301--1304 (2013).
+
+- Bryan R. Herman, Benoit Forget, and Kord Smith, "Utilizing CMFD in OpenMC to
+  Estimate Dominance Ratio and Adjoint," *Trans. Am. Nucl. Soc.*, **109**,
+  1389-1392 (2013).
+
+- Timothy P. Burke, Brian C. Kiedrowski, and William R. Martin, "Flux and
+  Reaction Rate Kernel Density Estimators in OpenMC," *Trans. Am. Nucl. Soc.*,
+  **109**, 683-686 (2013).
+
+- 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).
+
+- 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).
+
+- 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).
+
+- 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).
+
+- Andrew R. Siegel, Kord Smith, Paul K. Romano, Benoit Forget, and Kyle Felker,
+  "Multi-core performance studies of a Monte Carlo neutron transport code,"
+  *Int. J. High Perform. Comput. Appl.*
+  (2013). `<http://dx.doi.org/10.1177/1094342013492179>`_
+
 - Paul K. Romano, Andrew R. Siegel, Benoit Forget, and Kord Smith, "Data
   decomposition of Monte Carlo particle transport simulations via tally
   servers," *J. Comput. Phys.*, **252**, 20--36

docs/source/releasenotes/index.rst

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

docs/source/releasenotes/notes_0.5.3.rst

@@ -4,10 +4,6 @@
 Release Notes for OpenMC 0.5.3
 ==============================
 
-.. note::
-    These release notes are for an upcoming release of OpenMC and are still
-    subject to change.
-
 -------------------
 System Requirements
 -------------------
@@ -21,12 +17,20 @@ the problem at hand (mostly on the number of nuclides in the problem).
 New Features
 ------------
 
-- Special run mode --tallies removed.
+- Output interface enhanced to allow multiple files handles to be opened
+- Particle restart file linked to output interface
 - Particle restarts and state point restarts are both identified with the -r
   command line flag.
-- New regression test suite.
-- All memory leaks fixed.
-- Shared-memory parallelism with OpenMP.
+- Particle instance no longer global, passed to all physics routines
+- Physics routines refactored to rely less on global memory, more arguments
+  passed in
+- CMFD routines refactored and now can compute dominance ratio on the fly
+- PETSc 3.4.2 or higher must be used and compiled with fortran datatype support
+- Memory leaks fixed except for ones from xml-fortran package
+- Test suite enhanced to test output with different compiler options
+- Description of OpenMC development workflow added
+- OpenMP shared-memory parallelism added
+- Special run mode --tallies removed.
 
 ---------
 Bug Fixes
@@ -35,7 +39,7 @@ Bug Fixes
 - 2b1e8a_: Normalize direction vector after reflecting particle.
 - 5853d2_: Set blank default for cross section listing alias.
 - e178c7_: Fix infinite loop with words greater than 80 characters in write_message.
-- c18a6e_: Chcek for valid secondary mode on S(a,b) tables.
+- c18a6e_: Check for valid secondary mode on S(a,b) tables.
 - 82c456_: Fix bug where last process could have zero particles.
 
 .. _2b1e8a: https://github.com/mit-crpg/openmc/commit/2b1e8a

docs/source/usersguide/input.rst

@@ -198,19 +198,26 @@ tally data, this option can significantly improve the parallel efficiency.
 --------------------
 
 The ``<output>`` element determines what output files should be written to disk
-during the run. This element has no attributes or sub-elements and should be set
-to a list of strings separated by spaces. Valid options are "summary",
-"cross-sections", and "tallies". For example, if you want the summary and cross
-sections summary file to be written, this element should be given as:
+during the run. The sub-elements are described below, where "true" will write
+out the file and "false" will not.
 
-  .. code-block:: xml
+  :cross_sections:
+    Writes out an ASCII summary file of the cross sections that were read in.
 
-      <output>summary cross_sections</output>
+    *Default*: false
 
-  .. note:: The tally results will be written to a binary/HDF5 state point file by
-            default.
+  :summary: 
+    Writes out an ASCII summary file describing all of the user input files that
+    were read in.
 
-  *Default*: "tallies"
+    *Default*: false
+
+  :tallies:
+    Write out an ASCII file of tally results.
+
+    *Default*: true
+
+  .. note:: The tally results will always be written to a binary/HDF5 state point file.
 
 ``<output_path>`` Element
 -------------------------
@@ -398,6 +405,15 @@ integers: the batch number, generation number, and particle number.
 
   *Default*: None
 
+.. _track:
+
+``<track>`` Element
+-------------------
+
+The ``<track>`` element specifies particles for which OpenMC will output binary files describing particle position at every step of its transport. This element should be followed by triplets of integers.  Each triplet describes one particle.  The integers in each triplet specify the batch number, generation number, and particle number, respectively.
+
+  *Default*: None
+
 ``<uniform_fs>`` Element
 ------------------------
 
@@ -636,9 +652,10 @@ Each ``<cell>`` element can have the following attributes or sub-elements:
 ---------------------
 
 The ``<lattice>`` can be used to represent repeating structures (e.g. fuel pins
-in an assembly) or other geometry which naturally fits into a two-dimensional
-structured mesh. Each cell within the lattice is filled with a specified
-universe. A ``<lattice>`` accepts the following attributes or sub-elements:
+in an assembly) or other geometry which naturally fits into a two- or
+three-dimensional structured mesh. Each cell within the lattice is filled with a
+specified universe. A ``<lattice>`` accepts the following attributes or
+sub-elements:
 
   :id:
     A unique integer that can be used to identify the surface.
@@ -650,18 +667,19 @@ universe. A ``<lattice>`` accepts the following attributes or sub-elements:
     *Default*: rectangular
 
   :dimension:
-    Two integers representing the number of lattice cells in the x- and y-
-    directions, respectively.
+    Two or three integers representing the number of lattice cells in the x- and
+    y- (and z-) directions, respectively.
 
     *Default*: None
 
   :lower_left:
-    The coordinates of the lower-left corner of the lattice.
+    The coordinates of the lower-left corner of the lattice. If the lattice is
+    two-dimensional, only the x- and y-coordinates are specified.
 
     *Default*: None
 
   :width:
-    The width of the lattice cell in the x- and y- directions.
+    The width of the lattice cell in the x- and y- (and z-) directions.
 
     *Default*: None
 
@@ -1139,6 +1157,22 @@ The ``<begin>`` element controls what batch CMFD calculations should begin.
 
   *Default*: 1
 
+``<display>`` Element
+---------------------
+
+The ``<display>`` element sets one additional CMFD output column. Options are:
+
+* "balance" - prints the RMS [%] of the resdiual from the neutron balance equation
+  on CMFD tallies.
+* "dominance" - prints the estimated dominance ratio from the CMFD iterations.
+  **This will only work for power iteration eigensolver**.
+* "entropy" - prints the *entropy* of the CMFD predicted fission source.
+  **Can only be used if OpenMC entropy is active as well**.
+* "source" - prints the RMS [%] between the OpenMC fission source and CMFD
+  fission source.
+
+  *Default*: None
+
 ``<feedback>`` Element
 ----------------------
 
@@ -1158,14 +1192,14 @@ with "true" and off with "false"
 
   *Default*: true
 
-``<keff_tol>`` Element
-----------------------
+``<inactive_flush>`` Element
+----------------------------
 
-The ``<keff_tol>`` element specifies acceptance criteria of a CMFD eigenvalue.
-If the CMFD eigenvalue and OpenMC batch eigenvalue are within this tolerance, 
-CMFD is allowed to modify source neutron weights. 
+The ``<inactive_flush>`` element controls when CMFD tallies are reset during
+inactive batches. The integer set here is the interval at which this reset
+occurs. The amout of resets is controlled with the ``<num_flushes>`` element.
 
-  *Default*: 0.005
+  *Defualt*: 9999
 
 ``<ksp_monitor>`` Element
 -------------------------
@@ -1180,13 +1214,9 @@ with "false".
 ``<mesh>`` Element
 ------------------
 
-If a structured mesh is desired as a filter for a tally, it must be specified in
-a separate element with the tag name ``<mesh>``. This element has the following
+The CMFD mesh is a structured Cartesian mesh. This element has the following
 attributes/sub-elements:
 
-  :type:
-    The type of structured mesh. Only "rectangular" is currently supported.
-
   :lower_left:
     The lower-left corner of the structured mesh. If only two coordinate are
     given, it is assumed that the mesh is an x-y mesh.
@@ -1249,14 +1279,13 @@ not impact the calculation.
 
   *Default*: 1.0
 
-``<n_procs_cmfd>`` Element
---------------------------
+``<num_flushes>`` Element
+-------------------------
 
-The ``<n_procs_cmfd>`` element is used to set the number of processors used 
-for CMFD calculation. It should be less than or equal to the number of 
-processors used during OpenMC. 
+The ``<num_flushes>`` element controls the number of CMFD tally resets that
+occur during inactive CMFD batches.
 
-  *Default*: 1
+  *Default*: 9999
 
 ``<power_monitor>`` Element
 ---------------------------
@@ -1264,26 +1293,33 @@ processors used during OpenMC.
 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
+
+``<run_adjoint>`` Element
+-------------------------
+
+The ``<run_adjoint>`` element can be turned on with "true" to have an adjoint
+calculation be performed on the last batch when CMFD is active.
 
   *Default*: false
 
-``<write_balance>`` Element
----------------------------
+``<snes_monitor>`` Element
+--------------------------
 
-The ``<write_balance>`` element is used to view the balance of OpenMC tally
-residuals for every coarse mesh region and energy group. This option can be 
-turned on with "true" and off with "false". 
+The ``<snes_monitor>`` element is used to view the convergence of the nonlinear SNES
+function in PETSc. This option can be turned on with "true" and turned off with "false".
 
 
   *Default*: false
 
-``<write_hdf5>`` Element
-------------------------
+``<solver>`` Element
+--------------------
 
-The ``<write_hdf5>`` element can be turned on with "true" to get an 
-HDF5 output file of CMFD results. 
+The ``<solver>`` element controls whether the CMFD eigenproblem is solved with
+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*: false
+  *Default*: power
 
 ``<write_matrices>`` Element
 ----------------------------

docs/source/usersguide/install.rst

@@ -71,13 +71,29 @@ Prerequisites
       To compile with support for HDF5_ output (highly recommended), you will
       need to have HDF5 installed on your computer. The installed version will
       need to have been compiled with the same compiler you intend to compile
-      OpenMC with.
+      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 \
+                       --enable-fortran2003 --enable-parallel
+
+      You may omit ``--enable-parallel`` if you want to compile HDF5_ in serial.
 
     * PETSc_ for CMFD acceleration
 
-      To enable CMFD acceleration, you will need to have PETSc_ installed on
-      your computer. The installed version will need to have been compiled with
-      the same compiler you intend to compile OpenMC with.
+      To enable CMFD acceleration, you will need to have PETSc_ (3.4.2 or higher)
+      installed on your computer. The installed version will need to have been
+      compiled with the same compiler you intend to compile OpenMC with. OpenMC
+      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 \
+                       --with-fortran-datatypes
+
+      The BLAS/LAPACK library is not required to be downloaded and can be linked
+      explicitly (e.g., Intel MKL library).
 
     * git_ version control software for obtaining source code
 
@@ -342,6 +358,7 @@ OpenMC accepts the following command line flags:
 -r, --restart file     Restart a previous run from a state point or a particle
                        restart file
 -s, --threads N        Run with *N* OpenMP threads
+-t, --track            Write tracks for all particles
 -v, --version          Show version information
 
 -----------------------------------------------------

docs/source/usersguide/processing.rst

@@ -353,9 +353,89 @@ file. Note that the data contained in the output from
 ``StatePoint.extract_result`` is already in a Numpy array that can be reshaped
 and dumped to MATLAB in one step.
 
+----------------------------
+Particle Track Visualization
+----------------------------
 
+.. image:: ../../img/Tracks.png
+   :height: 200px
 
+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 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
+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:
 
+.. code-block:: xml
 
+      <track>
+        1 2 3
+        1 2 4
+      </track>
+
+After running OpenMC, the directory should contain a file of the form
+"track_(batch #)_(generation #)_(particle #).(binary or h5)" for each particle
+tracked.  These track files can be converted into VTK poly data files with the
+"track.py" utility.  The usage of track.py is of the form "track.py [-o OUT] IN"
+where OUT is the optional output filename and IN is one or more filenames
+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.
+
+----------------------
+Source Site Processing
+----------------------
+
+For eigenvalue problems, OpenMC will store information on the fission source
+sites in the statepoint file by default. For each source site, the weight,
+position, sampled direction, and sampled energy are stored. To extract this data
+from a statepoint file, the statepoint.py Python module can be used. Below is an
+example of an interactive ipython session using the statepoint.py Python module:
+
+.. code-block:: python
+
+    In [1]: import statepoint
+    
+    In [2]: sp = statepoint.StatePoint('statepoint.100.h5')
+    
+    In [3]: sp.read_source()
+    
+    In [4]: len(sp.source)
+    Out[4]: 1000
+    
+    In [5]: sp.source[0:10]
+    Out[5]: 
+    [<SourceSite: xyz=[  2.21980946  -8.92686048  87.93720485] at E=0.932923263566>,
+     <SourceSite: xyz=[  2.21980946  -8.92686048  87.93720485] at E=0.349240220512>,
+     <SourceSite: xyz=[-31.21542213 -30.26762771  72.10845757] at E=3.75843584486>,
+     <SourceSite: xyz=[-31.21542213 -30.26762771  72.10845757] at E=0.80550137267>,
+     <SourceSite: xyz=[   0.18805099  -69.13376508  103.67726838] at E=1.67922461097>,
+     <SourceSite: xyz=[   0.18805099  -69.13376508  103.67726838] at E=1.16304110199>,
+     <SourceSite: xyz=[ -50.42189115   -9.96571672  123.34077905] at E=0.710937974074>,
+     <SourceSite: xyz=[ -32.80427668  -15.49316628  125.26301151] at E=1.61907104162>,
+     <SourceSite: xyz=[  53.20376026  -15.38643708  120.58071044] at E=3.33962024907>,
+     <SourceSite: xyz=[  53.20376026  -15.38643708  120.58071044] at E=1.90185680329>]
+    
+    In [6]: site = sp.source[0]
+    
+    In [7]: site.weight
+    Out[7]: 1.0
+    
+    In [8]: site.xyz
+    Out[8]: array([  2.21980946,  -8.92686048,  87.93720485])
+    
+    In [9]: site.uvw
+    Out[9]: array([ 0.06740523,  0.50612814,  0.85982024])
+    
+    In [10]: site.E
+    Out[10]: 0.93292326356564159

docs/source/usersguide/troubleshoot.rst

@@ -19,25 +19,6 @@ you are using a compiler that does not support type-bound procedures from
 Fortran 2003. This affects any version of gfortran prior to 4.6. Downloading and
 installing the latest gfortran_ compiler should resolve this problem.
 
-Fatal Error: Wrong module version '4' (expected '9') for file 'xml_data_cmfd_t.mod' opened at (1)
-*************************************************************************************************
-
-The `.mod` modules files that are created by gfortran are versioned and
-sometimes are usually not backwards compatible. If gfortran is upgraded and the
-modules files for xml-fortran source files are not deleted, this error may
-occur. To fix this, clear out all module and object files with :program:`make
-distclean` and then recompiling.
-
-Fatal Error: File 'xml_data_cmfd_t.mod' opened at (1) is not a GFORTRAN module file
-***********************************************************************************
-
-When OpenMC compiles, the first thing it needs to do is compile source in the
-xml-fortran subdirectory. If you compiled everything with a compiler other than
-gfortran, performed a :program:`make clean`, and then tried to :program:`make`
-with gfortran, the xml-fortran modules would have been compiled with a different
-compiler. To fix this, try clearing out all module and object files with
-:program:`make distclean` and then recompiling.
-
 gfortran: unrecognized option '-cpp'
 ************************************
 

man/man1/openmc.1

@@ -27,6 +27,9 @@ Restart a previous run from a state point or a particle restart file named
 .BI \-s " N" "\fR,\fP \-\-threads" " N"
 Use \fIN\fP OpenMP threads.
 .TP
+.B "\-t\fR, \fP\-\-track"
+Write tracks for all particles.
+.TP
 .B "\-v\fR, \fP\-\-version"
 Show version information.
 .TP

schemas.xml

@@ -1,10 +1,10 @@
 <?xml version="1.0"?>
 <locatingRules xmlns="http://thaiopensource.com/ns/locating-rules/1.0">
-  <documentElement localName="geometry" uri="src/templates/geometry.rnc"/>
-  <documentElement localName="materials" uri="src/templates/materials.rnc"/>
-  <documentElement localName="settings" uri="src/templates/settings.rnc"/>
-  <documentElement localName="tallies" uri="src/templates/tallies.rnc"/>
-  <documentElement localName="plots" uri="src/templates/plots.rnc"/>
-  <documentElement localName="cmfd" uri="src/templates/cmfd.rnc"/>
-  <documentElement localName="cross_sections" uri="src/templates/cross_sections.rnc"/>
+  <documentElement localName="geometry" uri="src/relaxng/geometry.rnc"/>
+  <documentElement localName="materials" uri="src/relaxng/materials.rnc"/>
+  <documentElement localName="settings" uri="src/relaxng/settings.rnc"/>
+  <documentElement localName="tallies" uri="src/relaxng/tallies.rnc"/>
+  <documentElement localName="plots" uri="src/relaxng/plots.rnc"/>
+  <documentElement localName="cmfd" uri="src/relaxng/cmfd.rnc"/>
+  <documentElement localName="cross_sections" uri="src/relaxng/cross_sections.rnc"/>
 </locatingRules>

src/DEPENDENCIES

@@ -1,37 +1,29 @@
-set_header.o: constants.o
-set_header.o: list_header.o
+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
 
-energy_grid.o: constants.o
-energy_grid.o: global.o
-energy_grid.o: list_header.o
-energy_grid.o: output.o
+ace_header.o: constants.o
+ace_header.o: endf_header.o
 
-list_header.o: constants.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
-
-cmfd_loss_operator.o: constants.o
-cmfd_loss_operator.o: global.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
-
-doppler.o: constants.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_message_passing.o
+cmfd_execute.o: cmfd_jfnk_solver.o
 cmfd_execute.o: cmfd_power_solver.o
-cmfd_execute.o: cmfd_snes_solver.o
 cmfd_execute.o: constants.o
 cmfd_execute.o: error.o
 cmfd_execute.o: global.o
@@ -41,27 +33,100 @@ 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: string.o
+cmfd_power_solver.o: matrix_header.o
+cmfd_power_solver.o: solver_interface.o
+cmfd_power_solver.o: vector_header.o
 
-cmfd_message_passing.o: cmfd_header.o
-cmfd_message_passing.o: global.o
+cmfd_prod_operator.o: constants.o
+cmfd_prod_operator.o: global.o
+cmfd_prod_operator.o: matrix_header.o
 
-random_lcg.o: global.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
 
-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
+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
@@ -74,114 +139,15 @@ fixed_source.o: string.o
 fixed_source.o: tally.o
 fixed_source.o: tracking.o
 
-source.o: bank_header.o
-source.o: constants.o
-source.o: error.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
-
-cmfd_prod_operator.o: constants.o
-cmfd_prod_operator.o: global.o
-
-ace_header.o: constants.o
-ace_header.o: endf_header.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
-
-cmfd_jacobian_operator.o: cmfd_loss_operator.o
-cmfd_jacobian_operator.o: cmfd_prod_operator.o
-cmfd_jacobian_operator.o: constants.o
-cmfd_jacobian_operator.o: global.o
-
-cmfd_snes_solver.o: cmfd_jacobian_operator.o
-cmfd_snes_solver.o: cmfd_loss_operator.o
-cmfd_snes_solver.o: cmfd_power_solver.o
-cmfd_snes_solver.o: cmfd_prod_operator.o
-cmfd_snes_solver.o: constants.o
-cmfd_snes_solver.o: global.o
-cmfd_snes_solver.o: string.o
-
-cmfd_input.o: cmfd_message_passing.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: templates/cmfd_t.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: templates/cross_sections_t.o
-input_xml.o: templates/geometry_t.o
-input_xml.o: templates/materials_t.o
-input_xml.o: templates/plots_t.o
-input_xml.o: templates/settings_t.o
-input_xml.o: templates/tallies_t.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
-
-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
-
-timer_header.o: constants.o
-
-math.o: constants.o
-math.o: random_lcg.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
-
-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: tally_header.o
-
-cmfd_output.o: cmfd_data.o
-cmfd_output.o: cmfd_header.o
-cmfd_output.o: constants.o
-cmfd_output.o: global.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
@@ -198,51 +164,17 @@ global.o: source_header.o
 global.o: tally_header.o
 global.o: timer_header.o
 
-string.o: constants.o
-string.o: error.o
-string.o: global.o
-
-finalize.o: cmfd_output.o
-finalize.o: global.o
-finalize.o: hdf5_interface.o
-finalize.o: output.o
-finalize.o: tally.o
-
-tally_initialize.o: constants.o
-tally_initialize.o: global.o
-tally_initialize.o: tally_header.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
-
-particle_header.o: constants.o
-particle_header.o: geometry_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
-
-mesh.o: constants.o
-mesh.o: global.o
-mesh.o: mesh_header.o
-mesh.o: particle_header.o
-mesh.o: search.o
-
-endf.o: constants.o
-endf.o: string.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
@@ -265,97 +197,51 @@ initialize.o: string.o
 initialize.o: tally_header.o
 initialize.o: tally_initialize.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
+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
 
-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
+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
 
-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
+list_header.o: constants.o
 
-search.o: error.o
-search.o: global.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
 
-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
+math.o: constants.o
+math.o: random_lcg.o
 
-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
+matrix_header.o: constants.o
+matrix_header.o: vector_header.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
-
-plot_header.o: constants.o
-
-cmfd_header.o: constants.o
-
-tally_header.o: constants.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: hdf5_interface.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
-
-error.o: global.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
@@ -371,6 +257,32 @@ 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
@@ -388,3 +300,97 @@ 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

src/Makefile

@@ -3,10 +3,7 @@ prefix = /usr/local
 
 source = $(wildcard *.F90)
 objects = $(source:.F90=.o)
-templates = $(wildcard templates/*.o)
-xml_fort = xml-fortran/xmlparse.o \
-           xml-fortran/read_xml_primitives.o \
-           xml-fortran/write_xml_primitives.o
+xml_lib = -Lxml/lib -lxml
 
 #===============================================================================
 # User Options
@@ -42,12 +39,12 @@ GIT_SHA1 = $(shell git log -1 2>/dev/null | head -n 1 | awk '{print $$2}')
 
 ifeq ($(COMPILER),gnu)
   F90 = gfortran
-  F90FLAGS := -cpp -fbacktrace
+  F90FLAGS := -cpp -std=f2008 -fbacktrace
   LDFLAGS =
 
   # Debugging
   ifeq ($(DEBUG),yes)
-    F90FLAGS += -g -Wall -pedantic -std=f2008 -fbounds-check \
+    F90FLAGS += -g -Wall -pedantic -fbounds-check \
                 -ffpe-trap=invalid,overflow,underflow
     LDFLAGS  += -g
   endif
@@ -70,12 +67,12 @@ endif
 
 ifeq ($(COMPILER),intel)
   F90 = ifort
-  F90FLAGS := -fpp -warn -assume byterecl -traceback
+  F90FLAGS := -fpp -std08 -assume byterecl -traceback
   LDFLAGS =
 
   # Debugging
   ifeq ($(DEBUG),yes)
-    F90FLAGS += -g -ftrapuv -fp-stack-check -check all -fpe0
+    F90FLAGS += -g -warn -ftrapuv -fp-stack-check -check all -fpe0
     LDFLAGS  += -g
   endif
 
@@ -243,12 +240,11 @@ endif
 # Targets
 #===============================================================================
 
-all: xml-fortran $(program)
-xml-fortran:
-	cd xml-fortran; make MACHINE=$(MACHINE) F90=$(F90) F90FLAGS="$(F90FLAGS)" LDFLAGS="$(LDFLAGS)"
-	cd templates; make F90=$(F90) F90FLAGS="$(F90FLAGS)" LDFLAGS="$(LDFLAGS)"
+all: xml $(program)
+xml:
+	cd xml; make MACHINE=$(MACHINE) F90=$(F90) F90FLAGS="$(F90FLAGS)" LDFLAGS="$(LDFLAGS)"
 $(program): $(objects)
-	$(F90) $(objects) $(templates) $(xml_fort) $(LDFLAGS) -o $@
+	$(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
@@ -264,8 +260,7 @@ uninstall:
 	@rm $(DESTDIR)$(prefix)/share/man/man1/openmc.1
 	@rm $(DESTDIR)$(prefix)/share/doc/$(program)/copyright
 distclean: clean
-	cd xml-fortran; make clean
-	cd templates; make clean
+	cd xml; make clean
 clean:
 	@rm -f *.o *.mod $(program)
 neat:
@@ -275,10 +270,11 @@ neat:
 # Rules
 #===============================================================================
 
-.PHONY: all xml-fortran install uninstall clean neat distclean 
+.SUFFIXES: .F90 .o
+.PHONY: all xml install uninstall clean neat distclean 
 
 %.o: %.F90
-	$(F90) $(F90FLAGS) -DGIT_SHA1="\"$(GIT_SHA1)\"" -Ixml-fortran -Itemplates -c $<
+	$(F90) $(F90FLAGS) -DGIT_SHA1="\"$(GIT_SHA1)\"" -Ixml/include -c $<
 
 #===============================================================================
 # Dependencies

src/ace.F90

@@ -115,9 +115,9 @@ contains
         ! search through the list of nuclides for one which has a matching zaid
         sab => sab_tables(mat % i_sab_tables(k))
 
-        ! Loop through nuclides and find  match
+        ! Loop through nuclides and find match
         FIND_NUCLIDE: do j = 1, mat % n_nuclides
-          if (nuclides(mat % nuclide(j)) % zaid == sab % zaid) then
+          if (any(sab % zaid == nuclides(mat % nuclide(j)) % zaid)) then
             mat % i_sab_nuclides(k) = j
             exit FIND_NUCLIDE
           end if
@@ -161,16 +161,16 @@ contains
           mat % i_sab_tables(m)   = temp_table
         end do SORT_SAB
       end if
-      
+
       ! Deallocate temporary arrays for names of nuclides and S(a,b) tables
       if (allocated(mat % names)) deallocate(mat % names)
       if (allocated(mat % sab_names)) deallocate(mat % sab_names)
 
     end do MATERIAL_LOOP2
-    
+
     ! Avoid some valgrind leak errors
     call already_read % clear()
-    
+
   end subroutine read_xs
 
 !===============================================================================
@@ -244,8 +244,16 @@ contains
       ! Read first line of header
       read(UNIT=in, FMT='(A10,2G12.0,1X,A10)') name, awr, kT, date_
 
+      ! Check that correct xs was found -- if cross_sections.xml is broken, the
+      ! location of the table may be wrong
+      if(adjustl(name) /= adjustl(listing % name)) then
+        message = "XS listing entry " // trim(listing % name) // " did not &
+             &match ACE data, " // trim(name) // " found instead."
+        call fatal_error()
+      end if
+
       ! Read more header and NXS and JXS
-      read(UNIT=in, FMT=100) comment, mat, & 
+      read(UNIT=in, FMT=100) comment, mat, &
            (zaids(i), awrs(i), i=1,16), NXS, JXS
 100   format(A70,A10/4(I7,F11.0)/4(I7,F11.0)/4(I7,F11.0)/4(I7,F11.0)/&
            ,8I9/8I9/8I9/8I9/8I9/8I9)
@@ -269,7 +277,7 @@ contains
            ACCESS='direct', RECL=record_length)
 
       ! Read all header information
-      read(UNIT=in, REC=location) name, awr, kT, date_, & 
+      read(UNIT=in, REC=location) name, awr, kT, date_, &
            comment, mat, (zaids(i), awrs(i), i=1,16), NXS, JXS
 
       ! determine table length
@@ -325,7 +333,15 @@ contains
       sab % name = name
       sab % awr  = awr
       sab % kT   = kT
-      sab % zaid = zaids(1)
+      ! Find sab % n_zaid
+      do i = 1, 16
+        if (zaids(i) == 0) then
+          sab % n_zaid = i - 1
+          exit
+        end if
+      end do
+      allocate(sab % zaid(sab % n_zaid))
+      sab % zaid = zaids(1: sab % n_zaid)
 
       call read_thermal_data(sab)
     end select
@@ -398,7 +414,7 @@ contains
     integer :: LNU    ! type of nu data (polynomial or tabular)
     integer :: NC     ! number of polynomial coefficients
     integer :: NR     ! number of interpolation regions
-    integer :: NE     ! number of energies 
+    integer :: NE     ! number of energies
     integer :: NPCR   ! number of delayed neutron precursor groups
     integer :: LED    ! location of energy distribution locators
     integer :: LDIS   ! location of all energy distributions
@@ -801,7 +817,7 @@ contains
 
     LED  = JXS(10)
 
-    ! Loop over all reactions 
+    ! Loop over all reactions
     do i = 1, NXS(5)
       rxn => nuc % reactions(i+1) ! skip over elastic scattering
       rxn % has_energy_dist = .true.
@@ -832,7 +848,7 @@ contains
 
     integer :: LDIS   ! location of all energy distributions
     integer :: LNW    ! location of next energy distribution if multiple
-    integer :: LAW    ! secondary energy distribution law   
+    integer :: LAW    ! secondary energy distribution law
     integer :: NR     ! number of interpolation regions
     integer :: NE     ! number of incoming energies
     integer :: IDAT   ! location of first energy distribution for given MT
@@ -1179,15 +1195,10 @@ contains
     integer :: NE_out ! number of outgoing energies
     integer :: NMU    ! number of outgoing angles
     integer :: JXS4   ! location of elastic energy table
+    integer(8), allocatable :: LOCC(:) ! Location of inelastic data
 
-    ! read secondary energy mode for inelastic scattering and check
+    ! read secondary energy mode for inelastic scattering
     table % secondary_mode = NXS(7)
-    if (table % secondary_mode /= SAB_SECONDARY_EQUAL .and. &
-         table % secondary_mode /= SAB_SECONDARY_SKEWED) then
-      message = "Unsupported secondary mode on S(a,b) table " // &
-           trim(adjustl(table % name)) // ": " // to_str(table % secondary_mode)
-      call fatal_error()
-    end if
 
     ! read number of inelastic energies and allocate arrays
     NE_in = int(XSS(JXS(1)))
@@ -1205,29 +1216,67 @@ contains
 
     ! allocate space for outgoing energy/angle for inelastic
     ! scattering
-    NE_out = NXS(4)
-    NMU = NXS(3) + 1
-    table % n_inelastic_e_out = NE_out
-    table % n_inelastic_mu = NMU
-    allocate(table % inelastic_e_out(NE_out, NE_in))
-    allocate(table % inelastic_mu(NMU, NE_out, NE_in))
+    if (table % secondary_mode == SAB_SECONDARY_EQUAL .or. &
+         table % secondary_mode == SAB_SECONDARY_SKEWED) then
+      NMU = NXS(3) + 1
+      table % n_inelastic_mu = NMU
+      NE_out = NXS(4)
+      table % n_inelastic_e_out = NE_out
+      allocate(table % inelastic_e_out(NE_out, NE_in))
+      allocate(table % inelastic_mu(NMU, NE_out, NE_in))
+    else if (table % secondary_mode == SAB_SECONDARY_CONT) then
+      NMU = NXS(3) - 1
+      table % n_inelastic_mu = NMU
+      allocate(table % inelastic_data(NE_in))
+      allocate(LOCC(NE_in))
+      ! NE_out will be determined later
+    end if
 
     ! read outgoing energy/angle distribution for inelastic scattering
-    lc = JXS(3) - 1
-    do i = 1, NE_in
-      do j = 1, NE_out
-        ! read outgoing energy
-        table % inelastic_e_out(j,i) = XSS(lc + 1)
+    if (table % secondary_mode == SAB_SECONDARY_EQUAL .or. &
+         table % secondary_mode == SAB_SECONDARY_SKEWED) then
+      lc = JXS(3) - 1
+      do i = 1, NE_in
+        do j = 1, NE_out
+          ! read outgoing energy
+          table % inelastic_e_out(j,i) = XSS(lc + 1)
 
-        ! read outgoing angles for this outgoing energy
-        do k = 1, NMU
-          table % inelastic_mu(k,j,i) = XSS(lc + 1 + k)
+          ! read outgoing angles for this outgoing energy
+          do k = 1, NMU
+            table % inelastic_mu(k,j,i) = XSS(lc + 1 + k)
+          end do
+
+          ! advance pointer
+          lc = lc + 1 + NMU
         end do
-
-        ! advance pointer
-        lc = lc + 1 + NMU
       end do
-    end do
+    else if (table % secondary_mode == SAB_SECONDARY_CONT) then
+      ! Get the location pointers to each Ein's DistEnergySAB data
+      LOCC = get_int(NE_in)
+      ! Get the number of outgoing energies and allocate space accordingly
+      do i = 1, NE_in
+        NE_out = int(XSS(XSS_index + i - 1))
+        table % inelastic_data(i) % n_e_out = NE_out
+        allocate(table % inelastic_data(i) % e_out (NE_out))
+        allocate(table % inelastic_data(i) % e_out_pdf (NE_out))
+        allocate(table % inelastic_data(i) % e_out_cdf (NE_out))
+        allocate(table % inelastic_data(i) % mu (NMU, NE_out))
+      end do
+
+      ! Now we can fill the inelastic_data(i) attributes
+      do i = 1, NE_in
+        XSS_index = 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)
+          table % inelastic_data(i) % e_out_pdf(j) = XSS(XSS_index + 2)
+          table % inelastic_data(i) % e_out_cdf(j) = XSS(XSS_index + 3)
+          table % inelastic_data(i) % mu(:, j) = &
+            XSS(XSS_index + 4: XSS_index + 4 + NMU - 1)
+          XSS_index = XSS_index + 4 + NMU - 1
+        end do
+      end do
+    end if
 
     ! read number of elastic energies and allocate arrays
     JXS4 = JXS(4)

src/ace_header.F90

@@ -16,7 +16,7 @@ module ace_header
     integer, allocatable :: type(:)     ! type of distribution
     integer, allocatable :: location(:) ! location of each table
     real(8), allocatable :: data(:)     ! angular distribution data
-    
+
     ! Type-Bound procedures
     contains
       procedure :: clear => distangle_clear ! Deallocates DistAngle
@@ -32,10 +32,10 @@ module ace_header
     type(Tab1) :: p_valid             ! probability of law validity
     real(8), allocatable :: data(:)   ! energy distribution data
 
-    ! For reactions that may have multiple energy distributions such as (n.2n),
+    ! For reactions that may have multiple energy distributions such as (n,2n),
     ! this pointer allows multiple laws to be stored
     type(DistEnergy), pointer :: next => null()
-    
+
     ! Type-Bound procedures
     contains
       procedure :: clear => distenergy_clear ! Deallocates DistEnergy
@@ -57,7 +57,7 @@ module ace_header
     logical :: has_energy_dist         ! Energy distribution present?
     type(DistAngle)           :: adist ! Secondary angular distribution
     type(DistEnergy), pointer :: edist => null() ! Secondary energy distribution
-    
+
     ! Type-Bound procedures
     contains
       procedure :: clear => reaction_clear ! Deallocates Reaction
@@ -76,7 +76,7 @@ module ace_header
     logical :: multiply_smooth ! multiply by smooth cross section?
     real(8), allocatable :: energy(:)   ! incident energies
     real(8), allocatable :: prob(:,:,:) ! actual probabibility tables
-    
+
     ! Type-Bound procedures
     contains
       procedure :: clear => urrdata_clear ! Deallocates UrrData
@@ -137,22 +137,37 @@ module ace_header
     ! Reactions
     integer :: n_reaction ! # of reactions
     type(Reaction), pointer :: reactions(:) => null()
-    
+
     ! Type-Bound procedures
     contains
       procedure :: clear => nuclide_clear ! Deallocates Nuclide
   end type Nuclide
 
+!===============================================================================
+! DISTENERGYSAB contains the secondary energy/angle distributions for inelastic
+! thermal scattering collisions which utilize a continuous secondary energy
+! representation.
+!===============================================================================
+
+  type DistEnergySab
+    integer              :: n_e_out
+    real(8), allocatable :: e_out(:)
+    real(8), allocatable :: e_out_pdf(:)
+    real(8), allocatable :: e_out_cdf(:)
+    real(8), allocatable :: mu(:,:)
+  end type DistEnergySab
+
 !===============================================================================
 ! SALPHABETA contains S(a,b) data for thermal neutron scattering, typically off
 ! of light isotopes such as water, graphite, Be, etc
 !===============================================================================
-     
+
   type SAlphaBeta
-    character(10) :: name ! name of table, e.g. lwtr.10t
-    integer       :: zaid ! Z and A identifier, e.g. 6012 for Carbon-12
-    real(8)       :: awr  ! weight of nucleus in neutron masses
-    real(8)       :: kT   ! temperature in MeV (k*T)
+    character(10) :: name     ! name of table, e.g. lwtr.10t
+    real(8)       :: awr      ! weight of nucleus in neutron masses
+    real(8)       :: kT       ! temperature in MeV (k*T)
+    integer       :: n_zaid   ! Number of valid zaids
+    integer, allocatable :: zaid(:) ! List of valid Z and A identifiers, e.g. 6012
 
     ! threshold for S(a,b) treatment (usually ~4 eV)
     real(8) :: threshold_inelastic
@@ -162,11 +177,17 @@ module ace_header
     integer :: n_inelastic_e_in  ! # of incoming E for inelastic
     integer :: n_inelastic_e_out ! # of outgoing E for inelastic
     integer :: n_inelastic_mu    ! # of outgoing angles for inelastic
-    integer :: secondary_mode    ! secondary mode (equal/skewed)
+    integer :: secondary_mode    ! secondary mode (equal/skewed/continuous)
     real(8), allocatable :: inelastic_e_in(:)
-    real(8), allocatable :: inelastic_sigma(:) 
+    real(8), allocatable :: inelastic_sigma(:)
+    ! The following are used only if secondary_mode is 0 or 1
     real(8), allocatable :: inelastic_e_out(:,:)
     real(8), allocatable :: inelastic_mu(:,:,:)
+    ! The following is used only if secondary_mode is 3
+    ! The different implementation is necessary because the continuous
+    ! representation has a variable number of outgoing energy points for each
+    ! incoming energy
+    type(DistEnergySab), allocatable :: inelastic_data(:) ! One for each Ein
 
     ! Elastic scattering data
     integer :: elastic_mode   ! elastic mode (discrete/exact)
@@ -214,8 +235,9 @@ module ace_header
     real(8) :: kappa_fission   ! microscopic energy-released from fission
 
     ! Information for S(a,b) use
-    integer :: index_sab   ! index in sab_tables (zero means no table)
-    real(8) :: elastic_sab ! microscopic elastic scattering on S(a,b) table
+    integer :: index_sab          ! index in sab_tables (zero means no table)
+    integer :: last_index_sab = 0 ! index in sab_tables last used by this nuclide
+    real(8) :: elastic_sab        ! microscopic elastic scattering on S(a,b) table
 
     ! Information for URR probability table use
     logical :: use_ptable  ! in URR range with probability tables?
@@ -239,125 +261,125 @@ module ace_header
 
 !===============================================================================
 ! DISTANGLE_CLEAR resets and deallocates data in Reaction.
-!===============================================================================    
-  
+!===============================================================================
+
     subroutine distangle_clear(this)
-      
+
       class(DistAngle), intent(inout) :: this ! The DistAngle object to clear
-      
+
       if (allocated(this % energy)) &
            deallocate(this % energy, this % type, this % location, this % data)
-      
-    end subroutine distangle_clear    
+
+    end subroutine distangle_clear
 
 !===============================================================================
 ! DISTENERGY_CLEAR resets and deallocates data in DistEnergy.
-!===============================================================================    
-  
+!===============================================================================
+
     recursive subroutine distenergy_clear(this)
-      
+
       class(DistEnergy), intent(inout) :: this ! The DistEnergy object to clear
-      
+
       ! Clear p_valid
       call this % p_valid % clear()
-      
+
       if (allocated(this % data)) &
            deallocate(this % data)
-        
+
       if (associated(this % next)) then
         ! recursively clear this item
         call this % next % clear()
         deallocate(this % next)
       end if
-      
+
     end subroutine distenergy_clear
-    
+
 !===============================================================================
 ! REACTION_CLEAR resets and deallocates data in Reaction.
-!===============================================================================    
-  
+!===============================================================================
+
     subroutine reaction_clear(this)
-      
+
       class(Reaction), intent(inout) :: this ! The Reaction object to clear
-      
+
       if (allocated(this % sigma)) &
            deallocate(this % sigma)
-      
+
       if (associated(this % edist)) then
         call this % edist % clear()
         deallocate(this % edist)
       end if
-        
+
       call this % adist % clear()
-      
-    end subroutine reaction_clear    
-    
+
+    end subroutine reaction_clear
+
 !===============================================================================
 ! URRDATA_CLEAR resets and deallocates data in Reaction.
-!===============================================================================    
-  
+!===============================================================================
+
     subroutine urrdata_clear(this)
-      
+
       class(UrrData), intent(inout) :: this ! The UrrData object to clear
-      
+
       if (allocated(this % energy)) &
            deallocate(this % energy, this % prob)
-      
-    end subroutine urrdata_clear      
+
+    end subroutine urrdata_clear
 
 !===============================================================================
 ! NUCLIDE_CLEAR resets and deallocates data in Nuclide.
-!===============================================================================    
-  
+!===============================================================================
+
     subroutine nuclide_clear(this)
-      
+
       class(Nuclide), intent(inout) :: this ! The Nuclide object to clear
-      
+
       integer :: i ! Loop counter
-      
+
       if (allocated(this % grid_index)) &
            deallocate(this % grid_index)
-      
+
       if (allocated(this % energy)) &
            deallocate(this % total, this % elastic, this % fission,  &
           this % nu_fission, this % absorption)
       if (allocated(this % heating)) &
            deallocate(this % heating)
-      
+
       if (allocated(this % index_fission)) &
            deallocate(this % index_fission)
-        
+
       if (allocated(this % nu_t_data)) &
            deallocate(this % nu_t_data)
-        
+
       if (allocated(this % nu_p_data)) &
            deallocate(this % nu_p_data)
-        
+
       if (allocated(this % nu_d_data)) &
            deallocate(this % nu_d_data)
-        
+
       if (allocated(this % nu_d_precursor_data)) &
            deallocate(this % nu_d_precursor_data)
-        
+
       if (associated(this % nu_d_edist)) then
         do i = 1, size(this % nu_d_edist)
           call this % nu_d_edist(i) % clear()
         end do
         deallocate(this % nu_d_edist)
       end if
-      
+
       if (associated(this % urr_data)) then
         call this % urr_data % clear()
         deallocate(this % urr_data)
       end if
-      
+
       if (associated(this % reactions)) then
         do i = 1, size(this % reactions)
           call this % reactions(i) % clear()
         end do
         deallocate(this % reactions)
       end if
-      
-    end subroutine nuclide_clear    
+
+    end subroutine nuclide_clear
 
 end module ace_header

src/cmfd_execute.F90

@@ -5,81 +5,57 @@ module cmfd_execute
 ! cross section generation, diffusion calculation, and source re-weighting
 !==============================================================================
 
+  use global
+
   implicit none
   private
   public :: execute_cmfd, cmfd_init_batch
 
-# ifdef PETSC
-#   include <finclude/petsc.h90>
-# endif
-
 contains
 
 !==============================================================================
-! EXECUTE_CMFD
+! EXECUTE_CMFD runs the CMFD calculation
 !==============================================================================
 
   subroutine execute_cmfd()
 
-# ifdef PETSC
-
     use cmfd_data,              only: set_up_cmfd
-    use cmfd_message_passing,   only: petsc_init_mpi, cmfd_bcast
     use cmfd_power_solver,      only: cmfd_power_execute
-    use cmfd_snes_solver,       only: cmfd_snes_execute
+    use cmfd_jfnk_solver,       only: cmfd_jfnk_execute
     use error,                  only: warning, fatal_error 
-    use global,                 only: n_procs_cmfd, cmfd,                       &
-                                      cmfd_solver_type, time_cmfd,              &
-                                      cmfd_run_adjoint, cmfd_write_hdf5,        &
-                                      cmfd_feedback,cmfd_hold_weights,          &
-                                      cmfd_inact_flush, cmfd_keff_tol,          &
-                                      cmfd_act_flush, current_batch, keff,      &
-                                      n_batches, message, master, mpi_err, rank
 
-    ! stop cmfd timer
+    ! CMFD single processor on master
     if (master) then
+
+      ! Start cmfd timer
       call time_cmfd % start()
-    end if
 
-    ! filter processors (lowest PETSc group)
-    if (rank < n_procs_cmfd) then
+      ! Create cmfd data from OpenMC tallies 
+      call set_up_cmfd()
 
-      ! set up cmfd data (master only)
-      if (master) call set_up_cmfd()
-
-      ! broadcast cmfd to all petsc procs
-      call cmfd_bcast()
-
-      ! process solver options
+      ! Process solver options
       call process_cmfd_options()
 
-    end if
-
-    ! filter processors (lowest PETSc group)
-    if (rank < n_procs_cmfd) then
-
-      ! call solver
+      ! Call solver
       if (trim(cmfd_solver_type) == 'power') then
         call cmfd_power_execute()
       elseif (trim(cmfd_solver_type) == 'jfnk') then
-        call cmfd_snes_execute()
+        call cmfd_jfnk_execute()
       else
         message = 'solver type became invalid after input processing'
         call fatal_error() 
       end if
 
-      ! perform any last batch tasks 
-      if (current_batch == n_batches) then
+      ! Save k-effective
+      cmfd % k_cmfd(current_batch) = cmfd % keff
 
-        ! check for adjoint run
-        if (cmfd_run_adjoint) then
-          if (trim(cmfd_solver_type) == 'power') then
-            call cmfd_power_execute(adjoint = .true.)
-          elseif (trim(cmfd_solver_type) == 'jfnk') then
-            call cmfd_snes_execute(adjoint = .true.)
-          end if
+      ! check to perform adjoint on last batch
+      if (current_batch == n_batches .and. cmfd_run_adjoint) then
+        if (trim(cmfd_solver_type) == 'power') then
+          call cmfd_power_execute(adjoint = .true.)
+        elseif (trim(cmfd_solver_type) == 'jfnk') then
+          call cmfd_jfnk_execute(adjoint = .true.)
         end if
-
       end if
 
     end if
@@ -91,19 +67,12 @@ contains
     if (cmfd_feedback) call cmfd_reweight(.true.)
 
     ! stop cmfd timer
-    if (master) then
-      call time_cmfd % stop()
-    end if
-
-    ! wait here for all procs
-    call MPI_Barrier(MPI_COMM_WORLD, mpi_err)
-
-# endif
+    if (master) call time_cmfd % stop()
 
   end subroutine execute_cmfd
 
 !==============================================================================
-! CMFD_INIT_BATCH
+! CMFD_INIT_BATCH handles cmfd options at the start of every batch
 !==============================================================================
 
   subroutine cmfd_init_batch()
@@ -112,7 +81,7 @@ contains
                                  cmfd_inact_flush, cmfd_act_flush, cmfd_run, &
                                  current_batch, cmfd_hold_weights
 
-    ! check to activate CMFD diffusion and possible feedback
+    ! Check to activate CMFD diffusion and possible feedback
     ! this guarantees that when cmfd begins at least one batch of tallies are
     ! accumulated
     if (cmfd_run .and. cmfd_begin == current_batch) then
@@ -120,18 +89,19 @@ contains
       cmfd_tally_on = .true.
     end if
 
-    ! check to flush cmfd tallies for active batches, no more inactive flush
+    ! If this is a restart run and we are just replaying batches leave
+    if (restart_run .and. current_batch <= restart_batch) return
+
+    ! Check to flush cmfd tallies for active batches, no more inactive flush
     if (cmfd_run .and. cmfd_act_flush == current_batch) then
       call cmfd_tally_reset()
       cmfd_tally_on = .true.
       cmfd_inact_flush(2) = -1
     end if
 
-    ! check to flush cmfd tallies during inactive batches (>= on number of
+    ! Check to flush cmfd tallies during inactive batches (>= on number of
     ! flushes important as the code will flush on the first batch which we
     ! dont want to count)
-!    if (cmfd_run .and. current_batch < n_inactive .and. mod(current_batch-1,cmfd_inact_flush(1))   &
-!       == 0 .and. cmfd_inact_flush(2) >= 0) then
     if (cmfd_run .and. mod(current_batch,cmfd_inact_flush(1))   &
        == 0 .and. cmfd_inact_flush(2) > 0 .and. cmfd_begin < current_batch) then
         cmfd_hold_weights = .true.
@@ -141,23 +111,23 @@ contains
 
   end subroutine cmfd_init_batch
 
-# ifdef PETSC
-
 !==============================================================================
-! PROCESS_CMFD_OPTIONS 
+! PROCESS_CMFD_OPTIONS processes user options that interface with PETSc 
 !==============================================================================
 
   subroutine process_cmfd_options()
 
+#ifdef PETSC
     use global,       only: cmfd_snes_monitor, cmfd_ksp_monitor, mpi_err
 
-    ! check for snes monitor
+    ! Check for snes monitor
     if (cmfd_snes_monitor) call PetscOptionsSetValue("-snes_monitor", &
          "stdout", mpi_err)
 
-    ! check for ksp monitor
+    ! Check for ksp monitor
     if (cmfd_ksp_monitor) call PetscOptionsSetValue("-ksp_monitor", &
          "stdout", mpi_err)
+#endif
 
     end subroutine process_cmfd_options
 
@@ -168,39 +138,45 @@ contains
   subroutine calc_fission_source()
 
     use constants,  only: CMFD_NOACCEL, ZERO, TWO
-    use global,     only: cmfd, cmfd_coremap, master, mpi_err, entropy_on
+    use global,     only: cmfd, cmfd_coremap, master, entropy_on, current_batch
 
-    integer :: nx ! maximum number of cells in x direction
-    integer :: ny ! maximum number of cells in y direction
-    integer :: nz ! maximum number of cells in z direction
-    integer :: ng ! maximum number of energy groups
-    integer :: n  ! total size
-    integer :: i ! iteration counter for x
-    integer :: j ! iteration counter for y
-    integer :: k ! iteration counter for z
-    integer :: g ! iteration counter for groups
-    integer :: idx ! index in vector
+#ifdef MPI
+    use global,     only: mpi_err
+    use mpi
+#endif
+
+    integer :: nx      ! maximum number of cells in x direction
+    integer :: ny      ! maximum number of cells in y direction
+    integer :: nz      ! maximum number of cells in z direction
+    integer :: ng      ! maximum number of energy groups
+    integer :: n       ! total size
+    integer :: i       ! iteration counter for x
+    integer :: j       ! iteration counter for y
+    integer :: k       ! iteration counter for z
+    integer :: g       ! iteration counter for groups
+    integer :: idx     ! index in vector
     real(8) :: hxyz(3) ! cell dimensions of current ijk cell
     real(8) :: vol     ! volume of cell
     real(8),allocatable :: source(:,:,:,:)  ! tmp source array for entropy
 
-    ! get maximum of spatial and group indices
-    nx = cmfd%indices(1)
-    ny = cmfd%indices(2)
-    nz = cmfd%indices(3)
-    ng = cmfd%indices(4)
+    ! Get maximum of spatial and group indices
+    nx = cmfd % indices(1)
+    ny = cmfd % indices(2)
+    nz = cmfd % indices(3)
+    ng = cmfd % indices(4)
     n  = ng*nx*ny*nz
 
-    ! allocate cmfd source if not already allocated and allocate buffer
-    if (.not. allocated(cmfd%cmfd_src)) allocate(cmfd%cmfd_src(ng,nx,ny,nz))
+    ! Allocate cmfd source if not already allocated and allocate buffer
+    if (.not. allocated(cmfd % cmfd_src)) &
+       allocate(cmfd % cmfd_src(ng,nx,ny,nz))
 
-    ! reset cmfd source to 0
-    cmfd%cmfd_src = ZERO
+    ! Reset cmfd source to 0
+    cmfd % cmfd_src = ZERO
 
-    ! only perform for master
+    ! Only perform for master
     if (master) then
 
-      ! loop around indices to map to cmfd object
+      ! Loop around indices to map to cmfd object
       ZLOOP: do k = 1, nz
 
         YLOOP: do j = 1, ny
@@ -209,25 +185,25 @@ contains
 
             GROUP: do g = 1, ng
 
-              ! check for core map
+              ! Check for core map
               if (cmfd_coremap) then
-                if (cmfd%coremap(i,j,k) == CMFD_NOACCEL) then
+                if (cmfd % coremap(i,j,k) == CMFD_NOACCEL) then
                   cycle
                 end if
               end if
 
-              ! get dimensions of cell
-              hxyz = cmfd%hxyz(:,i,j,k)
+              ! Get dimensions of cell
+              hxyz = cmfd % hxyz(:,i,j,k)
 
-              ! calculate volume
+              ! Calculate volume
               vol = hxyz(1)*hxyz(2)*hxyz(3)
 
-              ! get first index
+              ! Get first index
               idx = get_matrix_idx(1,i,j,k,ng,nx,ny)
 
-              ! compute fission source
-              cmfd%cmfd_src(g,i,j,k) = sum(cmfd%nfissxs(:,g,i,j,k) * &
-                   cmfd%phi(idx:idx+(ng-1)))*vol
+              ! Compute fission source
+              cmfd % cmfd_src(g,i,j,k) = sum(cmfd % nfissxs(:,g,i,j,k) * &
+                     cmfd % phi(idx:idx + (ng - 1)))*vol
 
             end do GROUP
 
@@ -237,159 +213,172 @@ contains
 
       end do ZLOOP
 
-      ! normalize source such that it sums to 1.0
-      cmfd%cmfd_src = cmfd%cmfd_src/sum(cmfd%cmfd_src)
+      ! Normalize source such that it sums to 1.0
+      cmfd % cmfd_src = cmfd % cmfd_src/sum(cmfd % cmfd_src)
 
-      ! compute entropy
+      ! Compute entropy
       if (entropy_on) then
 
-        ! allocate tmp array
+        ! Allocate tmp array
         if (.not.allocated(source)) allocate(source(ng,nx,ny,nz))
 
-        ! initialize the source
+        ! Initialize the source
         source = ZERO
 
-        ! compute log
-        where (cmfd%cmfd_src > ZERO)
-          source = cmfd%cmfd_src*log(cmfd%cmfd_src)/log(TWO)
+        ! Compute log
+        where (cmfd % cmfd_src > ZERO)
+          source = cmfd % cmfd_src*log(cmfd % cmfd_src)/log(TWO)
         end where
 
-        ! sum that source
-        cmfd%entropy = -sum(source)
+        ! Sum that source
+        cmfd % entropy(current_batch) = -sum(source)
 
-        ! deallocate tmp array
+        ! Deallocate tmp array
         if (allocated(source)) deallocate(source)
 
       end if
 
-      ! normalize source so average is 1.0
-      cmfd%cmfd_src = cmfd%cmfd_src/sum(cmfd%cmfd_src)*cmfd%norm
+      ! Normalize source so average is 1.0
+      cmfd % cmfd_src = cmfd % cmfd_src/sum(cmfd % cmfd_src)*cmfd % norm
+
+      ! Calculate differences between normalized sources
+      cmfd % src_cmp(current_batch) = sqrt(ONE/cmfd % norm * &
+             sum((cmfd % cmfd_src - cmfd % openmc_src)**2))
 
     end if
 
-    ! broadcast full source to all procs
-    call MPI_BCAST(cmfd%cmfd_src, n, MPI_REAL8, 0, MPI_COMM_WORLD, mpi_err)
+#ifdef MPI
+    ! Broadcast full source to all procs
+    call MPI_BCAST(cmfd % cmfd_src, n, MPI_REAL8, 0, MPI_COMM_WORLD, mpi_err)
+#endif
 
   end subroutine calc_fission_source
 
 !===============================================================================
-! CMFD_REWEIGHT
+! CMFD_REWEIGHT performs weighting of particles in the source bank
 !===============================================================================
 
   subroutine cmfd_reweight(new_weights)
 
     use constants,   only: ZERO, ONE
     use error,       only: warning, fatal_error
-    use global,      only: n_particles, meshes, source_bank, work,             &
-                           n_user_meshes, message, cmfd, master, mpi_err
+    use global,      only: meshes, source_bank, work, n_user_meshes, message, &
+                           cmfd, master
     use mesh_header, only: StructuredMesh
     use mesh,        only: count_bank_sites, get_mesh_indices
     use search,      only: binary_search
 
-    ! local variables
-    integer :: nx ! maximum number of cells in x direction
-    integer :: ny ! maximum number of cells in y direction
-    integer :: nz ! maximum number of cells in z direction
-    integer :: ng ! maximum number of energy groups
-    integer :: i ! iteration counter
-    integer :: ijk(3) ! spatial bin location
-    integer :: e_bin ! energy bin of source particle
-    integer :: n_groups ! number of energy groups
-    logical :: outside ! any source sites outside mesh
-    logical :: in_mesh ! source site is inside mesh
-    logical :: new_weights ! calcualte new weights
-    type(StructuredMesh), pointer :: m ! point to mesh
-    real(8), allocatable :: egrid(:)
+#ifdef MPI
+    use global,      only: mpi_err
+    use mpi
+#endif
 
-    ! associate pointer
+    logical, intent(in) :: new_weights ! calcualte new weights
+
+    integer :: nx       ! maximum number of cells in x direction
+    integer :: ny       ! maximum number of cells in y direction
+    integer :: nz       ! maximum number of cells in z direction
+    integer :: ng       ! maximum number of energy groups
+    integer :: i        ! iteration counter
+    integer :: ijk(3)   ! spatial bin location
+    integer :: e_bin    ! energy bin of source particle
+    integer :: n_groups ! number of energy groups
+    logical :: outside  ! any source sites outside mesh
+    logical :: in_mesh  ! source site is inside mesh
+
+    type(StructuredMesh), pointer :: m ! point to mesh
+    real(8), allocatable :: egrid(:)   ! energy grid
+
+    ! Associate pointer
     m => meshes(n_user_meshes + 1)
 
-    ! get maximum of spatial and group indices
-    nx = cmfd%indices(1)
-    ny = cmfd%indices(2)
-    nz = cmfd%indices(3)
-    ng = cmfd%indices(4)
+    ! Get maximum of spatial and group indices
+    nx = cmfd % indices(1)
+    ny = cmfd % indices(2)
+    nz = cmfd % indices(3)
+    ng = cmfd % indices(4)
 
     ! allocate arrays in cmfd object (can take out later extend to multigroup)
     if (.not.allocated(cmfd%sourcecounts)) then 
       allocate(cmfd%sourcecounts(ng,nx,ny,nz))
       cmfd % sourcecounts = 0
     end if
-    if (.not.allocated(cmfd%weightfactors)) then 
-      allocate(cmfd%weightfactors(ng,nx,ny,nz))
+    if (.not.allocated(cmfd % weightfactors)) then 
+      allocate(cmfd % weightfactors(ng,nx,ny,nz))
       cmfd % weightfactors = ONE
     end if
 
-    ! allocate energy grid and reverse cmfd energy grid
-    if (.not. allocated(egrid)) allocate(egrid(ng+1))
-    egrid = (/(cmfd%egrid(ng-i+2),i = 1,ng+1)/)
+    ! Allocate energy grid and reverse cmfd energy grid
+    if (.not. allocated(egrid)) allocate(egrid(ng + 1))
+    egrid = (/(cmfd % egrid(ng - i + 2), i = 1, ng + 1)/)
 
-    ! compute new weight factors
+    ! Compute new weight factors
     if (new_weights) then
 
-      ! zero out weights
+      ! Zero out weights
       cmfd%weightfactors = ZERO
 
-      ! count bank sites in mesh
+      ! Count bank sites in mesh
       call count_bank_sites(m, source_bank, cmfd%sourcecounts, egrid, &
            sites_outside=outside, size_bank=work)
 
-      ! check for sites outside of the mesh
+      ! Check for sites outside of the mesh
       if (master .and. outside) then
         message = "Source sites outside of the CMFD mesh!"
         call fatal_error()
       end if
 
-      ! have master compute weight factors
+      ! Have master compute weight factors (watch for 0s)
       if (master) then
-        where(cmfd%cmfd_src > ZERO .and. cmfd%sourcecounts > ZERO)
-          cmfd%weightfactors = cmfd%cmfd_src/sum(cmfd%cmfd_src)* &
-                               sum(cmfd%sourcecounts) / cmfd%sourcecounts
+        where(cmfd % cmfd_src > ZERO .and. cmfd % sourcecounts > ZERO)
+          cmfd % weightfactors = cmfd % cmfd_src/sum(cmfd % cmfd_src)* &
+                               sum(cmfd % sourcecounts) / cmfd % sourcecounts
         end where
       end if
 
-      ! broadcast weight factors to all procs
-      call MPI_BCAST(cmfd%weightfactors, ng*nx*ny*nz, MPI_REAL8, 0, &
+      ! Broadcast weight factors to all procs
+#ifdef MPI
+      call MPI_BCAST(cmfd % weightfactors, ng*nx*ny*nz, MPI_REAL8, 0, &
            MPI_COMM_WORLD, mpi_err)
-
+#endif
    end if
 
     ! begin loop over source bank
     do i = 1, int(work,4)
 
-      ! determine spatial bin
-      call get_mesh_indices(m, source_bank(i)%xyz, ijk, in_mesh)
+      ! Determine spatial bin
+      call get_mesh_indices(m, source_bank(i) % xyz, ijk, in_mesh)
 
-      ! determine energy bin
-      n_groups = size(cmfd%egrid) - 1
-      if (source_bank(i) % E < cmfd%egrid(1)) then
+      ! Determine energy bin
+      n_groups = size(cmfd % egrid) - 1
+      if (source_bank(i) % E < cmfd % egrid(1)) then
         e_bin = 1
-        message = 'source pt below energy grid'
+        message = 'Source pt below energy grid'
         call warning()
-      elseif (source_bank(i) % E > cmfd%egrid(n_groups+1)) then
+      elseif (source_bank(i) % E > cmfd % egrid(n_groups + 1)) then
         e_bin = n_groups
-        message = 'source pt above energy grid'
+        message = 'Source pt above energy grid'
         call warning()
       else
-        e_bin = binary_search(cmfd%egrid, n_groups + 1, source_bank(i) % E)
+        e_bin = binary_search(cmfd % egrid, n_groups + 1, source_bank(i) % E)
       end if
 
-      ! reverese energy bin (lowest grp is highest energy bin)
+      ! Reverese energy bin (lowest grp is highest energy bin)
       e_bin = n_groups - e_bin + 1
 
-      ! check for outside of mesh
+      ! Check for outside of mesh
       if (.not. in_mesh) then
-        message = 'Source site found outside of CMFD mesh!'
+        message = 'Source site found outside of CMFD mesh'
         call fatal_error()
       end if
 
-      ! reweight particle
-      source_bank(i)%wgt = source_bank(i)%wgt * &
-           cmfd%weightfactors(e_bin,ijk(1),ijk(2),ijk(3))
+      ! Reweight particle
+      source_bank(i) % wgt = source_bank(i) % wgt * &
+             cmfd % weightfactors(e_bin, ijk(1), ijk(2), ijk(3))
 
     end do
 
-    ! deallocate
+    ! Deallocate all
     if (allocated(egrid)) deallocate(egrid)
 
   end subroutine cmfd_reweight
@@ -403,33 +392,31 @@ contains
     use global, only: cmfd, cmfd_coremap
 
     integer :: matidx ! the index location in matrix
-    integer :: i      ! current x index
-    integer :: j      ! current y index
-    integer :: k      ! current z index
-    integer :: g      ! current group index
-    integer :: nx     ! maximum number of cells in x direction
-    integer :: ny     ! maximum number of cells in y direction
-    integer :: ng     ! maximum number of energy groups
+    integer, intent(in) :: i  ! current x index
+    integer, intent(in) :: j  ! current y index
+    integer, intent(in) :: k  ! current z index
+    integer, intent(in) :: g  ! current group index
+    integer, intent(in) :: nx ! maximum number of cells in x direction
+    integer, intent(in) :: ny ! maximum number of cells in y direction
+    integer, intent(in) :: ng ! maximum number of energy groups
 
-    ! check if coremap is used
+    ! Check if coremap is used
     if (cmfd_coremap) then
 
-      ! get idx from core map
+      ! Get idx from core map
       matidx = ng*(cmfd % coremap(i,j,k)) - (ng - g)
 
     else
 
-      ! compute index
+      ! Compute index
       matidx = g + ng*(i - 1) + ng*nx*(j - 1) + ng*nx*ny*(k - 1)
 
     end if
 
   end function get_matrix_idx
 
-# endif
-
 !===============================================================================
-! CMFD_TALLY_RESET
+! CMFD_TALLY_RESET resets all cmfd tallies
 !===============================================================================
 
   subroutine cmfd_tally_reset()
@@ -440,14 +427,14 @@ contains
 
     integer :: i ! loop counter
 
-    ! print message
+    ! Print message
     message = "CMFD tallies reset"
     call write_message(7)
 
-    ! begin loop around CMFD tallies
+    ! Begin loop around CMFD tallies
     do i = 1, n_cmfd_tallies
 
-      ! reset that tally
+      ! Reset that tally
       cmfd_tallies(i) % n_realizations = 0
       call reset_result(cmfd_tallies(i) % results)
 

src/cmfd_header.F90

@@ -8,93 +8,106 @@ module cmfd_header
 
   type, public :: cmfd_type
 
-    ! indices for problem
+    ! Indices for problem
     integer :: indices(4)
 
-    ! albedo boundary condition
+    ! Albedo boundary condition
     real(8) :: albedo(6)
 
-    ! core overlay map
+    ! Core overlay map
     integer, allocatable :: coremap(:,:,:)
     integer, allocatable :: indexmap(:,:)
     integer :: mat_dim = CMFD_NOACCEL 
 
-    ! energy grid
+    ! Energy grid
     real(8), allocatable :: egrid(:)
 
-    ! cross sections
+    ! Cross sections
     real(8), allocatable :: totalxs(:,:,:,:)
     real(8), allocatable :: p1scattxs(:,:,:,:)
     real(8), allocatable :: scattxs(:,:,:,:,:)
     real(8), allocatable :: nfissxs(:,:,:,:,:)
 
-    ! diffusion coefficient
+    ! Diffusion coefficient
     real(8), allocatable :: diffcof(:,:,:,:)
 
-    ! current
+    ! Current
     real(8), allocatable :: current(:,:,:,:,:)
 
-    ! flux
+    ! Flux
     real(8), allocatable :: flux(:,:,:,:)
 
-    ! coupling coefficients and equivalence parameters
+    ! Coupling coefficients and equivalence parameters
     real(8), allocatable :: dtilde(:,:,:,:,:)
     real(8), allocatable :: dhat(:,:,:,:,:)
 
-    ! dimensions of mesh cells ([hu,hv,hw],xloc,yloc,zloc)
+    ! Dimensions of mesh cells ([hu,hv,hw],xloc,yloc,zloc)
     real(8), allocatable :: hxyz(:,:,:,:)
 
-    ! source distributions
+    ! Source distributions
     real(8), allocatable :: cmfd_src(:,:,:,:)
     real(8), allocatable :: openmc_src(:,:,:,:)
 
-    ! source sites in each mesh box
+    ! Source sites in each mesh box
     real(8), allocatable :: sourcecounts(:,:,:,:)
 
-    ! weight adjustment factors 
+    ! Weight adjustment factors 
     real(8), allocatable :: weightfactors(:,:,:,:)
 
-    ! eigenvector/eigenvalue from cmfd run
+    ! Eigenvector/eigenvalue from cmfd run
     real(8), allocatable :: phi(:)
     real(8) :: keff = ZERO
 
-    ! eigenvector/eigenvalue from adjoint run
+    ! Eigenvector/eigenvalue from adjoint run
     real(8), allocatable :: adj_phi(:)
     real(8) :: adj_keff = ZERO
 
-    ! residual for neutron balance
+    ! Residual for neutron balance
     real(8), allocatable :: resnb(:,:,:,:)
 
-    ! openmc source normalization factor
+    ! Openmc source normalization factor
     real(8) :: norm = ONE
 
-    ! Shannon entropy from cmfd fission source
-    real(8) :: entropy 
+    ! "Shannon entropy" from cmfd fission source
+    real(8), allocatable :: entropy(:)
+
+    ! RMS of neutron balance equations
+    real(8), allocatable :: balance(:)
+
+    ! RMS deviation of OpenMC and CMFD normalized source
+    real(8), allocatable :: src_cmp(:)
+
+    ! Dominance ratio
+    real(8), allocatable :: dom(:)
+
+    ! List of CMFD k
+    real(8), allocatable :: k_cmfd(:)
 
   end type cmfd_type
 
 contains
 
 !==============================================================================
-! ALLOCATE_CMFD
+! ALLOCATE_CMFD allocates all data in of cmfd type
 !==============================================================================
 
-  subroutine allocate_cmfd(this)
+  subroutine allocate_cmfd(this, n_batches)
 
-    type(cmfd_type) :: this 
+    integer, intent(in)            :: n_batches ! number of batches in calc
+    type(cmfd_type), intent(inout) :: this      ! cmfd instance
 
     integer :: nx  ! number of mesh cells in x direction
     integer :: ny  ! number of mesh cells in y direction
     integer :: nz  ! number of mesh cells in z direction
     integer :: ng  ! number of energy groups
 
-   ! extract spatial and energy indices from object
+   ! Extract spatial and energy indices from object
     nx = this % indices(1)
     ny = this % indices(2)
     nz = this % indices(3)
     ng = this % indices(4)
 
-    ! allocate flux, cross sections and diffusion coefficient
+    ! Allocate flux, cross sections and diffusion coefficient
     if (.not. allocated(this % flux))       allocate(this % flux(ng,nx,ny,nz))
     if (.not. allocated(this % totalxs))    allocate(this % totalxs(ng,nx,ny,nz))
     if (.not. allocated(this % p1scattxs))  allocate(this % p1scattxs(ng,nx,ny,nz))
@@ -102,25 +115,32 @@ contains
     if (.not. allocated(this % nfissxs))    allocate(this % nfissxs(ng,ng,nx,ny,nz))
     if (.not. allocated(this % diffcof))    allocate(this % diffcof(ng,nx,ny,nz))
 
-    ! allocate dtilde and dhat 
+    ! Allocate dtilde and dhat 
     if (.not. allocated(this % dtilde))     allocate(this % dtilde(6,ng,nx,ny,nz))
     if (.not. allocated(this % dhat))       allocate(this % dhat(6,ng,nx,ny,nz))
 
-    ! allocate dimensions for each box (here for general case)
+    ! Allocate dimensions for each box (here for general case)
     if (.not. allocated(this % hxyz))       allocate(this % hxyz(3,nx,ny,nz))
 
-    ! allocate surface currents
+    ! Allocate surface currents
     if (.not. allocated(this % current))    allocate(this % current(12,ng,nx,ny,nz))
 
-    ! allocate source distributions
+    ! Allocate source distributions
     if (.not. allocated(this % cmfd_src)) allocate(this % cmfd_src(ng,nx,ny,nz))
     if (.not. allocated(this % openmc_src)) allocate(this % openmc_src(ng,nx,ny,nz))
 
-    ! allocate source weight modification vars
+    ! Allocate source weight modification vars
     if (.not. allocated(this % sourcecounts)) allocate(this % sourcecounts(ng,nx,ny,nz))
     if (.not. allocated(this % weightfactors)) allocate(this % weightfactors(ng,nx,ny,nz))
 
-    ! set everthing to 0 except weight multiply factors if feedback isnt on
+    ! Allocate batchwise parameters
+    if (.not. allocated(this % entropy)) allocate(this % entropy(n_batches))
+    if (.not. allocated(this % balance)) allocate(this % balance(n_batches))
+    if (.not. allocated(this % src_cmp)) allocate(this % src_cmp(n_batches))
+    if (.not. allocated(this % dom)) allocate(this % dom(n_batches))
+    if (.not. allocated(this % k_cmfd)) allocate(this % k_cmfd(n_batches))
+
+    ! Set everthing to 0 except weight multiply factors if feedback isnt on
     this % flux          = ZERO
     this % totalxs       = ZERO
     this % p1scattxs     = ZERO
@@ -135,16 +155,21 @@ contains
     this % openmc_src    = ZERO
     this % sourcecounts  = ZERO
     this % weightfactors = ONE
+    this % balance       = ZERO
+    this % src_cmp       = ZERO
+    this % dom           = ZERO
+    this % k_cmfd        = ZERO
+    this % entropy       = ZERO
 
   end subroutine allocate_cmfd
 
 !===============================================================================
-! DEALLOCATE_CMFD 
+! DEALLOCATE_CMFD frees all memory of cmfd type 
 !===============================================================================
 
   subroutine deallocate_cmfd(this)
 
-    type(cmfd_type) :: this
+    type(cmfd_type), intent(inout) :: this ! cmfd instance
 
     if (allocated(this % egrid))         deallocate(this % egrid)
     if (allocated(this % totalxs))       deallocate(this % totalxs)
@@ -164,6 +189,11 @@ contains
     if (allocated(this % weightfactors)) deallocate(this % weightfactors)
     if (allocated(this % cmfd_src))      deallocate(this % cmfd_src)
     if (allocated(this % openmc_src))    deallocate(this % openmc_src)
+    if (allocated(this % balance))       deallocate(this % balance)
+    if (allocated(this % src_cmp))       deallocate(this % src_cmp)
+    if (allocated(this % dom))           deallocate(this % dom)
+    if (allocated(this % k_cmfd))        deallocate(this % k_cmfd)
+    if (allocated(this % entropy))       deallocate(this % entropy)
 
   end subroutine deallocate_cmfd
 

src/cmfd_input.F90

@@ -1,5 +1,11 @@
 module cmfd_input
 
+  use global
+
+#ifdef PETSC
+  use petscsys
+#endif
+
   implicit none
   private
   public :: configure_cmfd 
@@ -7,22 +13,48 @@ module cmfd_input
 contains
 
 !===============================================================================
-! CONFIGURE_CMFD
+! CONFIGURE_CMFD initializes PETSc and CMFD parameters
 !===============================================================================
 
   subroutine configure_cmfd()
 
-# ifdef PETSC
-    use cmfd_message_passing,   only: petsc_init_mpi
-# endif
+    use cmfd_header,  only: allocate_cmfd
 
-    ! read in cmfd input file
+#ifdef PETSC
+    integer :: new_comm ! new mpi communicator
+#endif
+    integer :: color    ! color group of processor
+
+    ! Read in cmfd input file
     call read_cmfd_xml()
 
-    ! initialize petsc on mpi
-# ifdef PETSC
-    call petsc_init_mpi()
-# endif
+    ! Assign color
+    if (master) then
+      color = 1
+    else
+      color = 2
+    end if
+
+    ! Split up procs
+#ifdef PETSC
+    call MPI_COMM_SPLIT(MPI_COMM_WORLD, color, 0, new_comm, mpi_err)
+#endif
+
+    ! assign to PETSc
+#ifdef PETSC
+    PETSC_COMM_WORLD = new_comm
+
+    ! Initialize PETSc on all procs
+    call PetscInitialize(PETSC_NULL_CHARACTER, mpi_err)
+#endif
+
+    ! Initialize timers
+    call time_cmfd % reset()
+    call time_cmfdbuild % reset()
+    call time_cmfdsolve % reset()
+
+    ! Allocate cmfd object
+    call allocate_cmfd(cmfd, n_batches)
 
   end subroutine configure_cmfd
 
@@ -31,19 +63,24 @@ contains
 !===============================================================================
 
   subroutine read_cmfd_xml()
-    
-    use error,   only: fatal_error
+
+    use error,   only: fatal_error, warning
     use global
     use output,  only: write_message
     use string,  only: lower_case
-    use xml_data_cmfd_t
+    use xml_interface
     use, intrinsic :: ISO_FORTRAN_ENV
 
     integer :: ng
+    integer, allocatable :: iarray(:)
     logical :: file_exists ! does cmfd.xml exist?
+    logical :: found
     character(MAX_LINE_LEN) :: filename
+    character(MAX_LINE_LEN) :: temp_str
+    type(Node), pointer :: doc => null()
+    type(Node), pointer :: node_mesh => null()
 
-    ! read cmfd infput file
+    ! Read cmfd input file
     filename = trim(path_input) // "cmfd.xml"
     inquire(FILE=filename, EXIST=file_exists)
     if (.not. file_exists) then
@@ -55,129 +92,160 @@ contains
       return
     else
 
-      ! tell user
+      ! Tell user
       message = "Reading CMFD XML file..."
       call write_message(5)
 
     end if
 
-    ! parse cmfd.xml file
-    call read_xml_file_cmfd_t(filename)
+    ! Parse cmfd.xml file
+    call open_xmldoc(doc, filename)
 
-    ! set spatial dimensions in cmfd object
-    cmfd % indices(1:3) = mesh_ % dimension(1:3) ! sets spatial dimensions
+    ! Get pointer to mesh XML node
+    call get_node_ptr(doc, "mesh", node_mesh, found = found)
 
-    ! get number of energy groups
-    if (associated(mesh_ % energy)) then
-      ng = size(mesh_ % energy)
+    ! Check if mesh is there
+    if (.not.found) then
+      message = "No CMFD mesh specified in CMFD XML file."
+      call fatal_error()
+    end if
+
+    ! Set spatial dimensions in cmfd object
+    call get_node_array(node_mesh, "dimension", cmfd % indices(1:3))
+
+    ! Get number of energy groups
+    if (check_for_node(node_mesh, "energy")) then
+      ng = get_arraysize_double(node_mesh, "energy")
       if(.not.allocated(cmfd%egrid)) allocate(cmfd%egrid(ng))
-      cmfd%egrid = mesh_ % energy 
+      call get_node_array(node_mesh, "energy", cmfd%egrid)
       cmfd % indices(4) = ng - 1 ! sets energy group dimension
     else
-      if(.not.allocated(cmfd%egrid)) allocate(cmfd%egrid(2))
-      cmfd%egrid = (/0.0_8,20.0_8/)
+      if(.not.allocated(cmfd % egrid)) allocate(cmfd % egrid(2))
+      cmfd % egrid = (/0.0_8,20.0_8/)
       cmfd % indices(4) = 1 ! one energy group
     end if
     
-    ! set global albedo
-    if (associated(mesh_ % albedo)) then
-      cmfd % albedo = mesh_ % albedo
+    ! Set global albedo
+    if (check_for_node(node_mesh, "albedo")) then
+      call get_node_array(node_mesh, "albedo", cmfd % albedo)
     else
       cmfd % albedo = (/1.0, 1.0, 1.0, 1.0, 1.0, 1.0/)
     end if
 
-    ! get acceleration map
-    if (associated(mesh_ % map)) then
+    ! Get acceleration map
+    if (check_for_node(node_mesh, "map")) then
       allocate(cmfd % coremap(cmfd % indices(1), cmfd % indices(2), &
            cmfd % indices(3)))
-      if (size(mesh_ % map) /= product(cmfd % indices(1:3))) then
+      if (get_arraysize_integer(node_mesh, "map") /= &
+          product(cmfd % indices(1:3))) then
         message = 'FATAL==>CMFD coremap not to correct dimensions'
         call fatal_error() 
       end if
-      cmfd % coremap = reshape(mesh_ % map,(cmfd % indices(1:3)))
+      allocate(iarray(get_arraysize_integer(node_mesh, "map")))
+      call get_node_array(node_mesh, "map", iarray)
+      cmfd % coremap = reshape(iarray,(cmfd % indices(1:3)))
       cmfd_coremap = .true.
-   end if
-
-    ! check for core map activation by printing note
-    if (cmfd_coremap .and. master) then
-      message = "Core Map Overlay Activated"
-      call write_message()
+      deallocate(iarray)
     end if
 
-    ! check for normalization constant
-    cmfd % norm = norm_
+    ! Check for normalization constant
+    if (check_for_node(doc, "norm")) then
+      call get_node_value(doc, "norm", cmfd % norm)
+    end if
 
-    ! set feedback logical
-    call lower_case(feedback_)
-    if (feedback_ == 'true' .or. feedback_ == '1') cmfd_feedback = .true.
+    ! Set feedback logical
+    if (check_for_node(doc, "feedback")) then
+      call get_node_value(doc, "feedback", temp_str)
+      call lower_case(temp_str)
+      if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
+        cmfd_feedback = .true.
+    end if
 
-    ! set balance logical
-    ! call lower_case(balance_)
-    ! if (balance_ == 'true' .or. balance == '1') cmfd_balance = .true.
+    ! Set downscatter logical
+    if (check_for_node(doc, "downscatter")) then
+      call get_node_value(doc, "downscatter", temp_str)
+      call lower_case(temp_str)
+      if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
+        cmfd_downscatter = .true.
+    end if
 
-    ! set downscatter logical
-    ! call lower_case(downscatter_)
-    ! if (downscatter_ == 'true' .or. downscatter == '1') &
-    !      cmfd_downscatter = downscatter_
+    ! Set the solver type
+    if (check_for_node(doc, "solver")) &
+      call get_node_value(doc, "solver", cmfd_solver_type)
 
-    ! set 2 group fix
-    call lower_case(run_2grp_)
-    if (run_2grp_ == 'true' .or. run_2grp_ == '1') cmfd_run_2grp = .true.
+    ! Set monitoring
+    if (check_for_node(doc, "snes_monitor")) then
+      call get_node_value(doc, "snes_monitor", temp_str)
+      call lower_case(temp_str)
+      if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
+        cmfd_snes_monitor = .true.
+    end if
+    if (check_for_node(doc, "ksp_monitor")) then
+      call get_node_value(doc, "ksp_monitor", temp_str)
+      call lower_case(temp_str)
+      if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
+        cmfd_ksp_monitor = .true.
+    end if
+    if (check_for_node(doc, "power_monitor")) then
+      call get_node_value(doc, "power_monitor", temp_str)
+      call lower_case(temp_str)
+      if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
+        cmfd_power_monitor = .true.
+    end if
 
-    ! set the solver type
-    cmfd_solver_type = solver_(1:10)
+    ! Output logicals
+    if (check_for_node(doc, "write_matrices")) then
+      call get_node_value(doc, "write_matices", temp_str)
+      call lower_case(temp_str)
+      if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
+        cmfd_write_matrices = .true.
+    end if
 
-    ! set monitoring 
-    call lower_case(snes_monitor_)
-    call lower_case(ksp_monitor_)
-    call lower_case(power_monitor_)
-    if (snes_monitor_ == 'true' .or. snes_monitor_ == '1') &
-         cmfd_snes_monitor = .true.
-    if (ksp_monitor_ == 'true' .or. ksp_monitor_ == '1') &
-         cmfd_ksp_monitor = .true.
-    if (power_monitor_ == 'true' .or. power_monitor_ == '1') &
-         cmfd_power_monitor = .true.
+    ! Run an adjoint calc
+    if (check_for_node(doc, "run_adjoint")) then
+      call get_node_value(doc, "run_adjoint", temp_str)
+      call lower_case(temp_str)
+      if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
+        cmfd_run_adjoint = .true.
+    end if
 
-    ! output logicals
-    call lower_case(write_balance_)
-    call lower_case(write_matrices_)
-    ! call lower_case(write_hdf5_)
-    if (write_balance_ == 'true' .or. write_balance_ == '1') &
-         cmfd_write_balance = .true.
-    if (write_matrices_ == 'true' .or. write_matrices_ == '1') &
-         cmfd_write_matrices = .true.
-    ! if (write_hdf5_ == 'true' .or. write_hdf5_ == '1') &
-    !      cmfd_write_hdf5 = .true.
+    ! Batch to begin cmfd
+    if (check_for_node(doc, "begin")) &
+      call get_node_value(doc, "begin", cmfd_begin) 
 
-    ! run an adjoint calc
-    call lower_case(run_adjoint_)
-    if (run_adjoint_ == 'true' .or. run_adjoint_ == '1') &
-         cmfd_run_adjoint = .true.
+    ! Tally during inactive batches
+    if (check_for_node(doc, "inactive")) then
+      call get_node_value(doc, "inactive", temp_str)
+      call lower_case(temp_str)
+      if (trim(temp_str) == 'false' .or. trim(temp_str) == '0') &
+        cmfd_tally_on = .false.
+    end if
 
-    ! batch to begin cmfd
-    cmfd_begin = begin_
+    ! Inactive batch flush window
+    if (check_for_node(doc, "inactive_flush")) &
+      call get_node_value(doc, "inactive_flush", cmfd_inact_flush(1))
+    if (check_for_node(doc, "num_flushes")) &
+      call get_node_value(doc, "num_flushes", cmfd_inact_flush(2))
 
-    ! tally during inactive batches
-    call lower_case(inactive_)
-    if (inactive_ == 'false' .or. inactive_ == '0') cmfd_tally_on = .false.
+    ! Last flush before active batches
+    if (check_for_node(doc, "active_flush")) &
+      call get_node_value(doc, "active_flush", cmfd_act_flush)
 
-    ! inactive batch flush window
-    cmfd_inact_flush(1) = inactive_flush_
-    cmfd_inact_flush(2) = num_flushes_
+    ! Get display
+    if (check_for_node(doc, "display")) &
+      call get_node_value(doc, "display", cmfd_display)
+    if (trim(cmfd_display) == 'dominance' .and. &
+        trim(cmfd_solver_type) /= 'power') then
+      message = 'Dominance Ratio only aviable with power iteration solver'
+      call warning()
+      cmfd_display = ''
+    end if
 
-    ! last flush before active batches
-    cmfd_act_flush = active_flush_
+    ! Create tally objects
+    call create_cmfd_tally(doc)
 
-    ! tolerance on keff
-    cmfd_keff_tol = keff_tol_
-    
-    ! create tally objects
-    call create_cmfd_tally()
-
-    ! set number of CMFD processors and report to user
-    n_procs_cmfd = n_cmfd_procs_ 
-    if (master) write(OUTPUT_UNIT,'(A,1X,I0,1X,A)') "CMFD Running on", &
-       n_procs_cmfd," processors."
+    ! Close CMFD XML file
+    call close_xmldoc(doc)
 
   end subroutine read_cmfd_xml
 
@@ -190,47 +258,51 @@ contains
 !   3: Surface current
 !===============================================================================
 
-  subroutine create_cmfd_tally()
+  subroutine create_cmfd_tally(doc)
 
+    use constants,        only: MAX_LINE_LEN
     use error,            only: fatal_error, warning
-    use global
     use mesh_header,      only: StructuredMesh
     use string
     use tally,            only: setup_active_cmfdtallies
     use tally_header,     only: TallyObject, TallyFilter
     use tally_initialize, only: add_tallies
-    use xml_data_cmfd_t
+    use xml_interface
 
+    type(Node), pointer :: doc ! pointer to XML doc info
+
+    character(MAX_LINE_LEN) :: temp_str ! temp string
     integer :: i           ! loop counter
     integer :: n           ! size of arrays in mesh specification
     integer :: ng          ! number of energy groups (default 1)
     integer :: n_filters   ! number of filters
     integer :: i_filter_mesh ! index for mesh filter
-    character(MAX_LINE_LEN) :: filename
+    integer :: iarray3(3) ! temp integer array
+    real(8) :: rarray3(3) ! temp double array
     type(TallyObject),    pointer :: t => null()
     type(StructuredMesh), pointer :: m => null()
     type(TallyFilter) :: filters(N_FILTER_TYPES) ! temporary filters
+    type(Node), pointer :: node_mesh => null()
 
-    ! parse cmfd.xml file
-     filename = trim(path_input) // "cmfd.xml"
-     call read_xml_file_cmfd_t(filename)
-
-    ! set global variables if they are 0 (this can happen if there is no tally
+    ! Set global variables if they are 0 (this can happen if there is no tally
     ! file)
     if (n_meshes == 0) n_meshes = n_user_meshes + n_cmfd_meshes
 
-    ! allocate mesh
+    ! Allocate mesh
     if (.not. allocated(meshes)) allocate(meshes(n_meshes))
     m => meshes(n_user_meshes+1)
 
-    ! set mesh id
+    ! Set mesh id
     m % id = n_user_meshes + 1 
 
-    ! set mesh type to rectangular
+    ! Set mesh type to rectangular
     m % type = LATTICE_RECT
 
+    ! Get pointer to mesh XML node
+    call get_node_ptr(doc, "mesh", node_mesh)
+
     ! Determine number of dimensions for mesh
-    n = size(mesh_ % dimension)
+    n = get_arraysize_integer(node_mesh, "dimension")
     if (n /= 2 .and. n /= 3) then
        message = "Mesh must be two or three dimensions."
        call fatal_error()
@@ -244,75 +316,80 @@ contains
     allocate(m % upper_right(n))
 
     ! Check that dimensions are all greater than zero
-    if (any(mesh_ % dimension <= 0)) then
-       message = "All entries on the <dimension> element for a tally mesh &
-            &must be positive."
-       call fatal_error()
+    call get_node_array(node_mesh, "dimension", iarray3(1:n))
+    if (any(iarray3(1:n) <= 0)) then
+      message = "All entries on the <dimension> element for a tally mesh &
+           &must be positive."
+      call fatal_error()
     end if
 
     ! Read dimensions in each direction
-    m % dimension = mesh_ % dimension
+    m % dimension = iarray3(1:n)
 
     ! Read mesh lower-left corner location
-    if (m % n_dimension /= size(mesh_ % lower_left)) then
-       message = "Number of entries on <lower_left> must be the same as &
-            &the number of entries on <dimension>."
-       call fatal_error()
+    if (m % n_dimension /= get_arraysize_double(node_mesh, "lower_left")) then
+      message = "Number of entries on <lower_left> must be the same as &
+           &the number of entries on <dimension>."
+      call fatal_error()
     end if
-    m % lower_left = mesh_ % lower_left
+    call get_node_array(node_mesh, "lower_left", m % lower_left)
 
-    ! Make sure either upper-right or width was specified
-    if (associated(mesh_ % upper_right) .and. &
-         associated(mesh_ % width)) then
-       message = "Cannot specify both <upper_right> and <width> on a &
-             &tally mesh."
-       call fatal_error()
+    ! Make sure both upper-right or width were specified
+    if (check_for_node(node_mesh, "upper_right") .and. &
+        check_for_node(node_mesh, "width")) then
+      message = "Cannot specify both <upper_right> and <width> on a &
+           &tally mesh."
+      call fatal_error()
     end if
 
     ! Make sure either upper-right or width was specified
-    if (.not. associated(mesh_ % upper_right) .and. &
-         .not. associated(mesh_ % width)) then
-       message = "Must specify either <upper_right> and <width> on a &
-            &tally mesh."
-       call fatal_error()
+    if (.not.check_for_node(node_mesh, "upper_right") .and. &
+        .not.check_for_node(node_mesh, "width")) then
+      message = "Must specify either <upper_right> and <width> on a &
+           &tally mesh."
+      call fatal_error()
     end if
 
-    if (associated(mesh_ % width)) then
-       ! Check to ensure width has same dimensions
-       if (size(mesh_ % width) /= size(mesh_ % lower_left)) then
-          message = "Number of entries on <width> must be the same as the &
-               &number of entries on <lower_left>."
-          call fatal_error()
-       end if
+    if (check_for_node(node_mesh, "width")) then
+      ! Check to ensure width has same dimensions
+      if (get_arraysize_double(node_mesh, "width") /= &
+          get_arraysize_double(node_mesh, "lower_left")) then
+        message = "Number of entries on <width> must be the same as the &
+             &number of entries on <lower_left>."
+        call fatal_error()
+      end if
 
-       ! Check for negative widths
-       if (any(mesh_ % width < ZERO)) then
-          message = "Cannot have a negative <width> on a tally mesh."
-          call fatal_error()
-       end if
+      ! Check for negative widths
+      call get_node_array(node_mesh, "width", rarray3(1:n))
+      if (any(rarray3(1:n) < ZERO)) then
+        message = "Cannot have a negative <width> on a tally mesh."
+        call fatal_error()
+      end if
 
-       ! Set width and upper right coordinate
-       m % width = mesh_ % width
-       m % upper_right = m % lower_left + m % dimension * m % width
+      ! Set width and upper right coordinate
+      m % width = rarray3(1:n)
+      m % upper_right = m % lower_left + m % dimension * m % width
 
-    elseif (associated(mesh_ % upper_right)) then
-       ! Check to ensure width has same dimensions
-       if (size(mesh_ % upper_right) /= size(mesh_ % lower_left)) then
-          message = "Number of entries on <upper_right> must be the same as &
-               &the number of entries on <lower_left>."
-          call fatal_error()
-       end if
+    elseif (check_for_node(node_mesh, "upper_right")) then
+      ! Check to ensure width has same dimensions
+      if (get_arraysize_double(node_mesh, "upper_right") /= &
+          get_arraysize_double(node_mesh, "lower_left")) then
+        message = "Number of entries on <upper_right> must be the same as &
+             &the number of entries on <lower_left>."
+        call fatal_error()
+      end if
 
-       ! Check that upper-right is above lower-left
-       if (any(mesh_ % upper_right < mesh_ % lower_left)) then
-          message = "The <upper_right> coordinates must be greater than the &
-               &<lower_left> coordinates on a tally mesh."
-          call fatal_error()
-       end if
+      ! Check that upper-right is above lower-left
+      call get_node_array(node_mesh, "upper_right", rarray3(1:n))
+      if (any(rarray3(1:n) < m % lower_left)) then
+        message = "The <upper_right> coordinates must be greater than the &
+             &<lower_left> coordinates on a tally mesh."
+        call fatal_error()
+      end if
 
-       ! Set width and upper right coordinate
-       m % upper_right = mesh_ % upper_right
-       m % width = (m % upper_right - m % lower_left) / m % dimension
+      ! Set upper right coordinate and width
+      m % upper_right = rarray3(1:n)
+      m % width = (m % upper_right - m % lower_left) / real(m % dimension, 8)
     end if
 
     ! Set volume fraction
@@ -321,20 +398,24 @@ contains
     ! Add mesh to dictionary
     call mesh_dict % add_key(m % id, n_user_meshes + 1)
 
-    ! allocate tallies
+    ! Allocate tallies
     call add_tallies("cmfd", n_cmfd_tallies)
 
-    ! begin loop around tallies
+    ! Begin loop around tallies
     do i = 1, n_cmfd_tallies
 
-      ! point t to tally variable
+      ! Point t to tally variable
       t => cmfd_tallies(i)
 
-      ! set reset property
-      call lower_case(reset_)
-      if (reset_ == 'true' .or. reset_ == '1') t % reset = .true.
+      ! Set reset property
+      if (check_for_node(doc, "reset")) then
+        call get_node_value(doc, "reset", temp_str)
+        call lower_case(temp_str)
+        if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') &
+          t % reset = .true.
+      end if
 
-      ! set up mesh filter
+      ! Set up mesh filter
       n_filters = 1
       filters(n_filters) % type = FILTER_MESH
       filters(n_filters) % n_bins = product(m % dimension)
@@ -342,51 +423,52 @@ contains
       filters(n_filters) % int_bins(1) = n_user_meshes + 1
       t % find_filter(FILTER_MESH) = n_filters
 
-      ! read and set incoming energy mesh filter
-      if (associated(mesh_ % energy)) then
+      ! Read and set incoming energy mesh filter
+      if (check_for_node(node_mesh, "energy")) then
         n_filters = n_filters + 1
         filters(n_filters) % type = FILTER_ENERGYIN
-        ng = size(mesh_ % energy)
+        ng = get_arraysize_double(node_mesh, "energy") 
         filters(n_filters) % n_bins = ng - 1
         allocate(filters(n_filters) % real_bins(ng))
-        filters(n_filters) % real_bins = mesh_ % energy
+        call get_node_array(node_mesh, "energy", &
+             filters(n_filters) % real_bins)
         t % find_filter(FILTER_ENERGYIN) = n_filters
       end if
 
-      ! set number of nucilde bins
+      ! Set number of nucilde bins
       allocate(t % nuclide_bins(1))
       t % nuclide_bins(1) = -1
       t % n_nuclide_bins = 1
 
-      ! record tally id which is equivalent to loop number
+      ! Record tally id which is equivalent to loop number
       t % id = i_cmfd_tallies + i
 
       if (i == 1) then
 
-        ! set label
+        ! Set label
         t % label = "CMFD flux, total, scatter-1"
 
-        ! set tally estimator to analog
+        ! Set tally estimator to analog
         t % estimator = ESTIMATOR_ANALOG
 
-        ! set tally type to volume
+        ! Set tally type to volume
         t % type = TALLY_VOLUME
 
-        ! allocate and set filters
+        ! Allocate and set filters
         t % n_filters = n_filters
         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 scattering order data
         allocate(t % scatt_order(3))
         t % scatt_order = 0
         
-        ! set macro_bins
+        ! Set macro_bins
         t % score_bins(1)  = SCORE_FLUX
         t % score_bins(2)  = SCORE_TOTAL
         t % score_bins(3)  = SCORE_SCATTER_N
@@ -394,54 +476,55 @@ contains
 
       else if (i == 2) then
 
-        ! set label
+        ! Set label
         t % label = "CMFD neutron production"
 
-        ! set tally estimator to analog
+        ! Set tally estimator to analog
         t % estimator = ESTIMATOR_ANALOG
 
-        ! set tally type to volume
+        ! Set tally type to volume
         t % type = TALLY_VOLUME
 
         ! read and set outgoing energy mesh filter
-        if (associated(mesh_ % energy)) then
+        if (check_for_node(node_mesh, "energy")) then
           n_filters = n_filters + 1
           filters(n_filters) % type = FILTER_ENERGYOUT
-          ng = size(mesh_ % energy)
+          ng = get_arraysize_double(node_mesh, "energy")
           filters(n_filters) % n_bins = ng - 1
           allocate(filters(n_filters) % real_bins(ng))
-          filters(n_filters) % real_bins = mesh_ % energy
+          call get_node_array(node_mesh, "energy", &
+               filters(n_filters) % real_bins)
           t % find_filter(FILTER_ENERGYOUT) = n_filters
         end if
 
-        ! allocate and set filters
+        ! Allocate and set filters
         t % n_filters = n_filters
         allocate(t % filters(n_filters))
         t % filters = filters(1:n_filters)
 
         ! deallocate filters bins array
-        if (associated(mesh_ % energy)) &
+        if (check_for_node(node_mesh, "energy")) &
              deallocate(filters(n_filters) % real_bins)
 
-        ! allocate macro reactions
+        ! Allocate macro reactions
         allocate(t % score_bins(2))
         t % n_score_bins = 2
         t % n_user_score_bins = 2
 
-        ! allocate scattering order data
+        ! Allocate scattering order data
         allocate(t % scatt_order(2))
         t % scatt_order = 0
 
-        ! set macro_bins
+        ! Set macro_bins
         t % score_bins(1) = SCORE_NU_SCATTER
         t % score_bins(2) = SCORE_NU_FISSION
 
       else if (i == 3) then
 
-        ! set label
+        ! Set label
         t % label = "CMFD surface currents"
 
-        ! set tally estimator to analog
+        ! Set tally estimator to analog
         t % estimator = ESTIMATOR_ANALOG
 
         ! Add extra filter for surface
@@ -458,41 +541,45 @@ contains
         end if
         t % find_filter(FILTER_SURFACE) = n_filters
 
-        ! allocate and set filters
+        ! Allocate and set filters
         t % n_filters = n_filters
         allocate(t % filters(n_filters))
         t % filters = filters(1:n_filters)
 
-        ! deallocate filters bins array
+        ! Deallocate filters bins array
         deallocate(filters(n_filters) % int_bins)
 
-        ! allocate macro reactions
+        ! Allocate macro reactions
         allocate(t % score_bins(1))
         t % n_score_bins = 1
         t % n_user_score_bins = 1
 
-        ! allocate scattering order data
+        ! Allocate scattering order data
         allocate(t % scatt_order(1))
         t % scatt_order = 0
 
-        ! set macro bins
+        ! Set macro bins
         t % score_bins(1) = SCORE_CURRENT
         t % type = TALLY_SURFACE_CURRENT
 
-        ! we need to increase the dimension by one since we also need
+        ! We need to increase the dimension by one since we also need
         ! currents coming into and out of the boundary mesh cells.
         i_filter_mesh = t % find_filter(FILTER_MESH)
         t % filters(i_filter_mesh) % n_bins = product(m % dimension + 1)
 
       end if
 
-      ! deallocate filter bins
+      ! Deallocate filter bins
       deallocate(filters(1) % int_bins)
-      if (associated(mesh_ % energy)) deallocate(filters(2) % real_bins)
+      if (check_for_node(node_mesh, "energy")) &
+        deallocate(filters(2) % real_bins)
 
     end do
 
+    ! Put cmfd tallies into active tally array and turn tallies on
+!$omp parallel
     call setup_active_cmfdtallies()
+!$omp end parallel
     tallies_on = .true.
 
   end subroutine create_cmfd_tally

src/cmfd_jacobian_operator.F90

@@ -1,357 +0,0 @@
-module cmfd_jacobian_operator
-
-# ifdef PETSC
-
-  use cmfd_loss_operator, only: loss_operator,init_M_operator, &
-                                build_loss_matrix,destroy_M_operator
-  use cmfd_prod_operator, only: prod_operator,init_F_operator, &
-                                build_prod_matrix,destroy_F_operator
-  implicit none
-  private
-  public :: init_J_operator, build_jacobian_matrix, destroy_J_operator
-
-# include <finclude/petsc.h90>
-
-  integer  :: nx   ! maximum number of x cells
-  integer  :: ny   ! maximum number of y cells
-  integer  :: nz   ! maximum number of z cells
-  integer  :: ng   ! maximum number of groups
-  integer  :: ierr ! petsc error code
-    
-  type, public :: jacobian_operator
-    Mat      :: J    ! petsc matrix for neutronic prod operator
-    integer  :: n    ! dimensions of matrix
-    integer  :: nnz  ! max number of nonzeros
-    integer  :: localn ! local size on proc
-    integer, allocatable :: d_nnz(:) ! vector of diagonal preallocation
-    integer, allocatable :: o_nnz(:) ! vector of off-diagonal preallocation
-  end type jacobian_operator
-
-  type, public :: operators 
-    type(loss_operator) :: loss
-    type(prod_operator) :: prod
-  end type operators
-
-contains
-
-!==============================================================================
-! INIT_J_OPERATOR
-!==============================================================================
-
-  subroutine init_J_operator(this,ctx)
-
-    type(jacobian_operator) :: this
-    type(operators)         :: ctx
-
-    ! get indices
-    call get_J_indices(this)
-
-    ! get preallocation
-    call preallocate_jacobian_matrix(this,ctx)
-
-    ! set up M operator
-    call MatCreateAIJ(PETSC_COMM_WORLD, this%localn, this%localn, PETSC_DECIDE,&
-         PETSC_DECIDE, PETSC_NULL_INTEGER, this%d_nnz, PETSC_NULL_INTEGER, &
-         this%o_nnz, this%J,ierr)
-    call MatSetOption(this%J, MAT_NEW_NONZERO_LOCATIONS, PETSC_TRUE, ierr)
-    call MatSetOption(this%J, MAT_IGNORE_ZERO_ENTRIES, PETSC_TRUE, ierr)
-
-  end subroutine init_J_operator
-
-!==============================================================================
-! GET_J_INDICES
-!==============================================================================
-
-  subroutine get_J_indices(this)
-
-    use global,  only: cmfd, cmfd_coremap
-
-    type(jacobian_operator) :: this
-
-    ! get maximum number of cells in each direction
-    nx = cmfd%indices(1)
-    ny = cmfd%indices(2)
-    nz = cmfd%indices(3)
-    ng = cmfd%indices(4)
-
-    ! get number of nonzeros
-    this%nnz = 7 + ng - 1
-
-    ! calculate dimensions of matrix
-    this%n = nx*ny*nz*ng
-
-    ! calculate dimensions of matrix
-    if (cmfd_coremap) then
-      this%n = cmfd % mat_dim * ng
-    else
-      this%n = nx*ny*nz*ng
-    end if
-
-    ! add 1 for eigenvalue row
-!   this%n = this%n + 1
-
-  end subroutine get_J_indices
-
-!===============================================================================
-! PREALLOCATE_JACOBIAN_MATRIX
-!===============================================================================
-
-  subroutine preallocate_jacobian_matrix(this,ctx)
-
-    use global,      only: cmfd, n_procs_cmfd, rank
-
-    type(jacobian_operator) :: this
-    type(operators)         :: ctx
-
-    integer :: n             ! the extent of the matrix
-    integer :: row_start     ! index of local starting row
-    integer :: row_end       ! index of local final row
-
-    ! get local problem size
-    n = this%n
-
-    ! determine local size, divide evenly between all other procs
-    this%localn = n/(n_procs_cmfd)
-
-    ! add 1 more if less proc id is less than mod
-    if (rank < mod(n,n_procs_cmfd)) this%localn = this%localn + 1
-
-    ! add another 1 on last proc
-    if (rank == n_procs_cmfd - 1) this%localn = this%localn + 1
-
-    ! determine local starting row
-    row_start = 0
-    if (rank < mod(n,n_procs_cmfd)) then
-      row_start = rank*(n/n_procs_cmfd+1)
-    else
-      row_start = min(mod(n,n_procs_cmfd)*(n/n_procs_cmfd+1) + (rank - &
-           mod(n,n_procs_cmfd))*(n/n_procs_cmfd),n)
-    end if
-
-    ! determine local final row
-    row_end = row_start + this%localn - 1
-
-    ! allocate counters
-    if (.not. allocated(this%d_nnz)) allocate(this%d_nnz(row_start:row_end))
-    if (.not. allocated(this%o_nnz)) allocate(this%o_nnz(row_start:row_end))
-    this % d_nnz = 0
-    this % o_nnz = 0
-
-    ! start with pattern from loss matrix
-    if (rank == n_procs_cmfd - 1) then
-      this % d_nnz(row_start:row_end-1) = ctx%loss%d_nnz
-      this % o_nnz(row_start:row_end-1) = ctx%loss%o_nnz
-    else
-      this % d_nnz = ctx%loss%d_nnz
-      this % o_nnz = ctx%loss%o_nnz
-    end if
-
-    ! append -F*phi term for last processor will take care of 1 for lambda
-    if (rank == n_procs_cmfd - 1) then
-      this%d_nnz = this%d_nnz + 1
-    else
-      this%o_nnz = this%o_nnz + 1
-    end if
-
-    ! do last row which has all filled (already did lower left corner above)
-    if (rank == n_procs_cmfd - 1) then
-      this % d_nnz(row_end) = this % d_nnz(row_end) + (row_end - row_start)
-      this % o_nnz(row_end) = this % o_nnz(row_end) + (this%n  - (row_end - &
-           row_start))
-    end if
-
-  end subroutine preallocate_jacobian_matrix
-
-!===============================================================================
-! BUILD_JACOBIAN_MATRIX creates the matrix representing loss of neutrons
-!===============================================================================
-
-  subroutine build_jacobian_matrix(snes,x,jac,jac_prec,flag,ctx,ierr)
-
-    use constants,    only: ZERO, ONE
-    use global,       only: n_procs_cmfd, cmfd_write_matrices, rank
-
-    SNES            :: snes      ! the snes context
-    Vec             :: x         ! the solution vector
-    Mat             :: jac       ! the jacobian matrix
-    Mat             :: jac_prec  ! the jacobian preconditioner
-    MatStructure    :: flag      ! not used
-    type(operators) :: ctx       ! not used
-    integer         :: ierr      ! petsc error flag
-
-    Vec                  :: phi      ! flux vector
-    Vec                  :: source   ! source vector
-    integer              :: n        ! problem size
-    integer              :: k        ! implied do loop counter
-    integer              :: ncols    ! number of nonzeros in cols
-    integer              :: irow     ! row counter
-    integer              :: row_start! starting local row on process
-    integer              :: row_end  ! ending local row on process
-    integer, allocatable :: dims(:)  ! vec of starting and ending rows
-    integer, allocatable :: dims1(:) ! vec of sizes on each proc
-    integer, allocatable :: cols(:)  ! vector of column numbers
-    real(8)              :: lambda   ! eigenvalue
-    real(8), pointer     :: xptr(:)  ! pointer to solution vector
-    real(8), pointer     :: sptr(:)  ! pointer to source vector
-    real(8), allocatable :: vals(:)  ! vector of row values
-    real(8), allocatable :: phi_tmp(:) ! temp buffer for flux
-
-    ! create operators
-    call build_loss_matrix(ctx%loss)
-    call build_prod_matrix(ctx%prod)
-
-    ! get problem size
-    n = ctx%loss%n
-
-    ! get local size on each processor
-    call MatGetOwnershipRange(jac_prec, row_start, row_end, ierr)
-
-    ! allocate cols and  initialize to zero
-    if (.not. allocated(cols)) allocate(cols(&
-         maxval(ctx%loss%d_nnz + ctx%loss%o_nnz)))
-    if (.not. allocated(vals)) allocate(vals(&
-         maxval(ctx%loss%d_nnz + ctx%loss%o_nnz)))
-    cols = 0
-    vals = ZERO
-
-    ! get pointers to residual vector 
-    call VecGetArrayF90(x, xptr, ierr)
-
-    ! create petsc vector for flux
-    call VecCreateMPI(PETSC_COMM_WORLD, ctx%loss%localn, PETSC_DECIDE, phi, ierr)
-
-    ! extract flux and eigenvalue
-    call VecPlaceArray(phi, xptr, ierr)
-    if (rank == n_procs_cmfd - 1) lambda = xptr(size(xptr))
-    call MPI_BCAST(lambda, 1, MPI_REAL8, n_procs_cmfd-1, PETSC_COMM_WORLD, ierr)
-
-    ! compute math (M-lambda*F) M is overwritten here
-    call MatAXPY(ctx%loss%M, -lambda, ctx%prod%F, &
-         DIFFERENT_NONZERO_PATTERN, ierr)
-
-    ! create tmp petsc vector for source
-    call VecCreateMPI(PETSC_COMM_WORLD, ctx%loss%localn, PETSC_DECIDE, &
-         source, ierr)
-
-    ! perform math (-F*phi --> source)
-    call MatMult(ctx%prod%F, phi, source, ierr)
-    call VecScale(source, -ONE, ierr)
-
-    ! get pointer to source
-    call VecGetArrayF90(source, sptr, ierr)
-
-    ! begin loop to insert things into matrix
-    do irow = row_start, row_end - 1
-
-      ! don't do last row
-      if (irow == n) cycle 
-
-      ! get row of matrix
-      call MatGetRow(ctx%loss%M, irow, ncols, cols, vals, ierr)
-
-      ! set that row to Jacobian matrix
-      call MatSetValues(jac_prec, 1, (/irow/), ncols, cols(1:ncols), vals, &
-           INSERT_VALUES, ierr)
-
-      ! restore the row
-      call MatRestoreRow(ctx%loss%M, irow, ncols, cols, vals, ierr)
-
-      ! insert source value
-      call MatSetValue(jac_prec, irow, n, sptr(irow-row_start+1), &
-           INSERT_VALUES, ierr)
-
-    end do
-
-    ! allocate space for flux vector buffer
-    if (rank == n_procs_cmfd - 1) then
-      if (.not. allocated(phi_tmp)) allocate(phi_tmp(0:n-1))
-    end if
-
-    ! get size on each proc
-    if (.not. allocated(dims)) allocate(dims(0:n_procs_cmfd))
-    if (.not. allocated(dims1)) allocate(dims1(0:n_procs_cmfd-1))
-    call VecGetOwnershipRanges(phi, dims, ierr)
-    do k = 0, n_procs_cmfd-1
-      dims1(k) = dims(k+1) - dims(k)
-    end do
-
-    ! gather data on all procs (will truncate xptr if needed for last proc)
-    call MPI_GATHERV(xptr, dims1(rank), MPI_REAL8, phi_tmp, dims1, &
-         dims(0:n_procs_cmfd-1), MPI_REAL8, n_procs_cmfd-1, &
-         PETSC_COMM_WORLD, ierr)
-
-    ! set values in last row of matrix
-    if (rank == n_procs_cmfd - 1) then
-      phi_tmp = -phi_tmp ! negate the transpose
-      call MatSetValues(jac_prec, 1, (/n/), n, (/(k,k=0,n-1)/), phi_tmp, &
-           INSERT_VALUES, ierr)
-      call MatSetValue(jac_prec, n, n, ONE, INSERT_VALUES, ierr)
-    end if
-
-    ! assemble matrix
-    call MatAssemblyBegin(jac_prec, MAT_FINAL_ASSEMBLY, ierr)
-    call MatAssemblyEnd(jac_prec, MAT_FINAL_ASSEMBLY, ierr)
-    call MatAssemblyBegin(jac, MAT_FINAL_ASSEMBLY, ierr)
-    call MatAssemblyEnd(jac, MAT_FINAL_ASSEMBLY, ierr)
-
-    ! reset all vectors
-    call VecResetArray(phi,ierr)
-
-    ! restore all vectors
-    call VecRestoreArrayF90(x, xptr, ierr)
-    call VecRestoreArrayF90(source, sptr, ierr)
-
-    ! destroy all temporary objects
-    call VecDestroy(phi, ierr)
-    call VecDestroy(source, ierr)
-
-    ! deallocate all temporary space
-    if (allocated(cols)) deallocate(cols)
-    if (allocated(vals)) deallocate(vals)
-    if (allocated(phi_tmp)) deallocate(phi_tmp)
-    if (allocated(dims)) deallocate(dims)
-    if (allocated(dims1)) deallocate(dims1)
-
-    ! print jacobian out
-    if (cmfd_write_matrices) call print_J_operator(jac_prec)
-
-  end subroutine build_jacobian_matrix 
-
-!===============================================================================
-! PRINT_J_OPERATOR
-!===============================================================================
-
-  subroutine print_J_operator(jac)
-
-    Mat :: jac
- 
-    PetscViewer :: viewer
-
-    ! write out matrix in binary file (debugging)
-    call PetscViewerBinaryOpen(PETSC_COMM_WORLD, 'jacobian.bin', &
-         FILE_MODE_WRITE, viewer, ierr)
-    call MatView(jac, viewer, ierr)
-    call PetscViewerDestroy(viewer, ierr)
-
-  end subroutine print_J_operator
-
-!==============================================================================
-! DESTROY_J_OPERATOR
-!==============================================================================
-
-  subroutine destroy_J_operator(this)
-
-    type(jacobian_operator) :: this
-
-    ! deallocate matrix
-    call MatDestroy(this%J,ierr)
-
-    ! deallocate other parameters
-    if (allocated(this%d_nnz)) deallocate(this%d_nnz)
-    if (allocated(this%o_nnz)) deallocate(this%o_nnz)
-
-  end subroutine destroy_J_operator
-
-# endif
-
-end module cmfd_jacobian_operator

src/cmfd_jfnk_solver.F90

@@ -0,0 +1,398 @@
+module cmfd_jfnk_solver
+
+  use cmfd_loss_operator,  only: init_loss_matrix, build_loss_matrix
+  use cmfd_power_solver,   only: cmfd_power_execute
+  use cmfd_prod_operator,  only: init_prod_matrix, build_prod_matrix
+  use matrix_header,       only: Matrix
+  use solver_interface,    only: JFNKSolver, Jfnk_ctx
+  use vector_header,       only: Vector
+
+  implicit none
+  private
+  public :: cmfd_jfnk_execute
+
+  logical          :: adjoint_calc ! true if an adjoint is to be calculated
+  type(Jfnk_ctx)   :: jfnk_data    ! object that holds pointers to user routines
+  type(Matrix)     :: jac_prec     ! Jacobian preconditioner object
+  type(Matrix)     :: loss         ! CMFD loss matrix
+  type(Matrix)     :: prod         ! CMFD production matrix
+  type(JFNKSolver) :: jfnk         ! JFNK solver object
+  type(Vector)     :: resvec       ! JFNK residual vector
+  type(Vector)     :: xvec         ! JFNK solution vector
+
+contains
+
+!===============================================================================
+! CMFD_JFNK_EXECUTE main routine for JFNK solver
+!===============================================================================
+
+  subroutine cmfd_jfnk_execute(adjoint)
+
+    use global,  only: time_cmfdbuild, time_cmfdsolve
+
+    logical, intent(in), optional :: adjoint ! adjoint calculation
+
+    ! Check for adjoint
+    adjoint_calc = .false.
+    if (present(adjoint)) adjoint_calc = adjoint
+
+    ! Seed with power iteration to help converge to fundamental mode
+    call cmfd_power_execute(k_tol=1.E-3_8, s_tol=1.E-3_8, adjoint=adjoint_calc)
+
+    ! Start timer for build
+    call time_cmfdbuild % start()
+
+    ! Initialize data
+    call init_data()
+
+    ! Initialize solver
+#ifdef PETSC
+    call jfnk % create()
+#endif
+
+    ! Set up residual and jacobian routines
+    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
+
+    ! Stop timer for build
+    call time_cmfdbuild % stop()
+
+    ! Solve the system
+    call time_cmfdsolve % start()
+#ifdef PETSC
+    call jfnk % solve(xvec)
+#endif
+    call time_cmfdsolve % stop()
+
+    ! Extracts results to cmfd object
+    call extract_results()
+
+    ! Deallocate all slepc data
+    call finalize()
+
+  end subroutine cmfd_jfnk_execute
+
+!===============================================================================
+! INIT_DATA allocates matrices vectors for CMFD solution
+!===============================================================================
+
+  subroutine init_data()
+
+    use constants, only: ZERO, ONE
+    use global,    only: cmfd, cmfd_adjoint_type, current_batch
+
+    logical :: physical_adjoint ! physical adjoing calculation logical
+    integer :: n ! size of matrices
+
+    ! Set up all matrices
+    call init_loss_matrix(loss)
+    call init_prod_matrix(prod)
+    call init_jacobian_matrix()
+
+    ! Check for physical adjoint
+    physical_adjoint = .false.
+    if (adjoint_calc .and. trim(cmfd_adjoint_type) == 'physical') &
+         physical_adjoint = .true.
+
+    ! Create matrix operators
+    call build_loss_matrix(loss, adjoint = physical_adjoint)
+    call build_prod_matrix(prod, adjoint = physical_adjoint)
+
+    ! Assemble matrices and use PETSc
+    call loss % assemble()
+    call prod % assemble()
+    call loss % setup_petsc()
+    call prod % setup_petsc()
+
+    ! Check for mathematical adjoint
+    if (adjoint_calc .and. trim(cmfd_adjoint_type) == 'math') &
+         call compute_adjoint()
+
+    ! Get problem size
+    n = loss % n
+
+    ! Create problem vectors
+    call resvec % create(n + 1)
+    call xvec % create(n + 1)
+
+    ! Set flux in guess from rough power iteration
+    if (adjoint_calc) then
+      xvec % val(1:n) = cmfd % adj_phi
+    else
+      xvec % val(1:n) = cmfd % phi
+    end if
+
+    ! Set keff in guess from rough power iteration
+    if (adjoint_calc) then
+      xvec % val(n + 1) = ONE/cmfd % adj_keff
+    else
+      xvec % val(n + 1) = ONE/cmfd % keff
+    end if
+
+    ! Set up vectors for PETSc 
+    call resvec   % setup_petsc()
+    call xvec     % setup_petsc()
+
+    ! Build jacobian from initial guess
+    call build_jacobian_matrix(xvec)
+
+    ! Set up Jacobian for PETSc
+    call jac_prec % setup_petsc()
+
+    ! Set dominance ratio to 0
+    cmfd % dom(current_batch) = ZERO
+
+  end subroutine init_data
+
+!==============================================================================
+! INIT_JACOBIAN_MATRIX preallocates jacobian matrix and initializes it
+!==============================================================================
+
+  subroutine init_jacobian_matrix()
+
+    integer :: nnz ! number of nonzeros in matrix
+    integer :: n   ! dimension of matrix
+
+    ! Get length of matrix and number of nonzeros total in loss matrix
+    nnz = loss % nnz
+    n   = loss % n
+
+    ! There is one more nonzero for each row and and additional row of nonzeros
+    nnz = nnz + 2*n + 1
+
+    ! We need 1 more row for the jacobian
+    n = n + 1
+
+    ! Configure Jacobian matrix
+    call jac_prec % create(n, nnz)
+
+  end subroutine init_jacobian_matrix
+
+!===============================================================================
+! BUILD_JACOBIAN_MATRIX creates the Jacobian of nonlinear eigenvalue problem
+!===============================================================================
+
+  subroutine build_jacobian_matrix(x)
+
+    use constants,  only: ONE
+
+    type(Vector), intent(in) :: x ! solution vector
+
+    integer      :: i      ! loop counter for jacobian rows
+    integer      :: jjac   ! loop counter for jacobian cols
+    integer      :: jloss  ! loop counter for loss matrix cols
+    integer      :: jprod  ! loop counter for prod matrix cols
+    integer      :: n      ! problem size
+    real(8)      :: lambda ! eigenvalue
+    real(8)      :: val    ! temporary real scalar
+    type(Vector) :: flux   ! flux vector
+    type(Vector) :: fsrc   ! fission source vector
+
+    ! Get the problem size
+    n = loss % n
+
+    ! Get flux and eigenvalue
+    flux % val => x % val(1:n)
+    lambda = x % val(n + 1)
+
+    ! Create fission source vector
+    call fsrc % create(n)
+    call prod % vector_multiply(flux, fsrc)
+
+    ! Reset counters in Jacobian matrix
+    jac_prec % n_count  = 1
+    jac_prec % nz_count = 1
+
+    ! Begin loop around rows of Jacobian matrix
+    ROWS: do i = 1, n
+
+      ! Add a new row in Jacobian
+      call jac_prec % new_row()
+
+      ! Begin loop around columns of loss matrix
+      COLS_LOSS: do jloss = loss % get_row(i), loss % get_row(i + 1) - 1
+
+        ! Start with the value in the loss matrix
+        val = loss % val(jloss)
+
+        ! Loop around columns of prod matrix
+        COLS_PROD: do jprod = prod % get_row(i), prod % get_row(i + 1) - 1
+
+          ! See if columns agree with loss matrix
+          if (prod % get_col(jprod) == loss % get_col(jloss)) then
+            val = val - lambda*prod % val(jprod)
+            exit
+          end if
+
+        end do COLS_PROD 
+
+        ! Record value in jacobian
+        call jac_prec % add_value(loss % get_col(jloss), val)
+
+      end do COLS_LOSS
+
+      ! Add fission source value
+      val = -fsrc % val(i)
+      call jac_prec % add_value(n + 1, val)
+
+    end do ROWS
+
+    ! Need to add negative transpose of flux vector on last row
+    call jac_prec % new_row()
+    do jjac = 1, n
+      val = -flux % val(jjac)
+      call jac_prec % add_value(jjac, val)
+    end do
+
+    ! Add unity on bottom right corner of matrix
+    call jac_prec % add_value(n + 1, ONE)
+
+    ! CRS requires a final value in row
+    call jac_prec % new_row()
+
+    ! Free all allocated memory
+    flux % val => null()
+    call fsrc % destroy()
+
+  end subroutine build_jacobian_matrix
+
+!===============================================================================
+! COMPUTE_NONLINEAR_RESIDUAL computes the residual of the nonlinear equations
+!===============================================================================
+
+  subroutine compute_nonlinear_residual(x, res)
+
+    use global,       only: cmfd_write_matrices
+
+    type(Vector), intent(in)    :: x   ! solution vector
+    type(Vector), intent(inout) :: res ! residual vector
+
+    character(len=25) :: filename
+    integer           :: n
+    real(8)           :: lambda
+    type(Vector)      :: res_loss
+    type(Vector)      :: res_prod
+    type(Vector)      :: flux
+
+    ! Get problem size
+    n = loss % n
+
+    ! Set up temporary vectors
+    call res_loss % create(n)
+    call res_prod % create(n)
+
+    ! Extract flux
+    flux % n = n
+    flux % val => x % val(1:n)
+
+    ! Extract eigenvalue
+    lambda = x % val(n + 1)
+
+    ! Calculate M*flux then F*flux
+    call loss % vector_multiply(flux, res_loss)
+    call prod % vector_multiply(flux, res_prod)
+
+    ! Put flux component values in residual vector
+    res % val(1:n) = res_loss % val - lambda*res_prod % val
+
+    ! Put eigenvalue component in residual vector
+    res % val(n+1) = 0.5_8 - 0.5_8*sum(flux % val * flux % val)
+
+    ! Write out data in binary files (debugging)
+    if (cmfd_write_matrices) then
+
+      ! Write out residual vector 
+      if (adjoint_calc) then
+        filename = 'adj_res.bin'
+      else
+        filename = 'res.bin'
+      end if
+      call res % write_petsc_binary(filename)
+
+      ! Write out solution vector
+      if (adjoint_calc) then
+        filename = 'adj_x.bin'
+      else
+        filename = 'x.bin'
+      end if
+      call x % write_petsc_binary(filename)
+
+    end if
+
+  end subroutine compute_nonlinear_residual
+
+!===============================================================================
+! COMPUTE_ADJOINT calculates mathematical adjoint by taking transposes
+!===============================================================================
+
+  subroutine compute_adjoint()
+
+    use global,  only: cmfd_write_matrices
+
+    ! Transpose matrices
+    call loss % transpose()
+    call prod % transpose()
+
+    ! Write out matrix in binary file (debugging)
+    if (cmfd_write_matrices) then
+      call loss % write_petsc_binary('adj_lossmat.bin')
+      call loss % write_petsc_binary('adj_prodmat.bin')
+    end if
+
+  end subroutine compute_adjoint
+
+!===============================================================================
+! EXTRACT_RESULTS gets the results and puts them in global CMFD object
+!===============================================================================
+
+  subroutine extract_results()
+
+    use constants, only: ZERO, ONE
+    use global,    only: cmfd
+
+    integer :: n ! problem size
+
+    ! Get problem size
+    n = loss % n
+
+    ! Also allocate in cmfd object
+    if (adjoint_calc) then
+      if (.not. allocated(cmfd % adj_phi)) allocate(cmfd % adj_phi(n))
+    else
+      if (.not. allocated(cmfd % phi)) allocate(cmfd % phi(n))
+    end if
+
+    ! Get flux and eigenvalue
+    if (adjoint_calc) then
+      cmfd % adj_phi  = xvec % val(1:n)
+      cmfd % adj_keff = ONE / xvec % val(n+1)
+    else
+      cmfd % phi  = xvec % val(1:n)
+      cmfd % keff = ONE / xvec % val(n+1)
+    end if
+
+  end subroutine extract_results
+
+!===============================================================================
+! FINALIZE frees all memory from a JFNK calculation
+!===============================================================================
+
+  subroutine finalize()
+
+    call loss % destroy()
+    call prod % destroy()
+    call jac_prec % destroy()
+    call xvec % destroy()
+    call resvec % destroy()
+#ifdef PETSC
+    call jfnk % destroy()
+#endif
+    nullify(jfnk_data % res_proc_ptr)
+    nullify(jfnk_data % jac_proc_ptr)
+
+  end subroutine finalize
+
+end module cmfd_jfnk_solver

src/cmfd_loss_operator.F90

@@ -1,103 +1,91 @@
 module cmfd_loss_operator
 
-# ifdef PETSC
+  use constants,      only: CMFD_NOACCEL, ZERO
+  use global,         only: cmfd, cmfd_coremap
+  use matrix_header,  only: Matrix
 
   implicit none
   private
-  public :: init_M_operator, build_loss_matrix, destroy_M_operator
-
-# include <finclude/petsc.h90>
-
-  integer  :: nx   ! maximum number of x cells
-  integer  :: ny   ! maximum number of y cells
-  integer  :: nz   ! maximum number of z cells
-  integer  :: ng   ! maximum number of groups
-  integer  :: ierr ! petsc error code
-
-  type, public :: loss_operator
-    Mat      :: M      ! petsc matrix for neutronic loss operator
-    integer  :: n      ! dimensions of matrix
-    integer  :: nnz    ! max number of nonzeros
-    integer  :: localn ! local size on proc
-    integer, allocatable :: d_nnz(:) ! vector of diagonal preallocation
-    integer, allocatable :: o_nnz(:) ! vector of off-diagonal preallocation
-  end type loss_operator
-
-  logical :: adjoint_calc = .false. ! adjoint calculation
+  public :: init_loss_matrix, build_loss_matrix
 
 contains
 
 !===============================================================================
-! INIT_M_OPERATOR
+! INIT_LOSS_MATRIX preallocates loss matrix and initializes it
 !===============================================================================
 
-  subroutine init_M_operator(this)
+  subroutine init_loss_matrix(loss_matrix)
 
-    type(loss_operator) :: this
+    type(Matrix), intent(inout) :: loss_matrix ! cmfd loss matrix
 
-    ! get indices
-    call get_M_indices(this)
+    integer :: nx   ! maximum number of x cells
+    integer :: ny   ! maximum number of y cells
+    integer :: nz   ! maximum number of z cells
+    integer :: ng   ! maximum number of groups
+    integer :: n    ! total length of matrix
+    integer :: nnz  ! number of nonzeros in matrix
+    integer :: n_i  ! number of interior cells
+    integer :: n_c  ! number of corner cells
+    integer :: n_s  ! number of side cells
+    integer :: n_e  ! number of edge cells
+    integer :: nz_c ! number of non-zero corner cells
+    integer :: nz_e ! number of non-zero edge cells
+    integer :: nz_s ! number of non-zero side cells
+    integer :: nz_i ! number of non-zero interior cells
 
-    ! get preallocation
-    call preallocate_loss_matrix(this)
-
-    ! set up M operator
-    call MatCreateAIJ(PETSC_COMM_WORLD, this%localn, this%localn, PETSC_DECIDE,&
-         PETSC_DECIDE, PETSC_NULL_INTEGER, this%d_nnz, PETSC_NULL_INTEGER, &
-         this%o_nnz, this%M,ierr)
-    call MatSetOption(this%M, MAT_NEW_NONZERO_LOCATIONS, PETSC_TRUE, ierr)
-    call MatSetOption(this%M, MAT_IGNORE_ZERO_ENTRIES, PETSC_TRUE, ierr)
-
-  end subroutine init_M_operator
-
-!===============================================================================
-! GET_M_INDICES
-!===============================================================================
-
-  subroutine get_M_indices(this)
-
-    use global,  only: cmfd, cmfd_coremap
-
-    type(loss_operator) :: this
-
-    ! get maximum number of cells in each direction
+    ! Get maximum number of cells in each direction
     nx = cmfd%indices(1)
     ny = cmfd%indices(2)
     nz = cmfd%indices(3)
     ng = cmfd%indices(4)
 
-    ! get number of nonzeros
-    this%nnz = 7 + ng - 1
-
-    ! calculate dimensions of matrix
+    ! Calculate dimensions of matrix
     if (cmfd_coremap) then
-      this%n = cmfd % mat_dim * ng
+      n = cmfd % mat_dim * ng
     else
-      this%n = nx*ny*nz*ng
+      n = nx*ny*nz*ng
     end if
 
-  end subroutine get_M_indices
+    ! Calculate number of nonzeros, if core map -> need to determine manually
+    if (cmfd_coremap) then
+      nnz = preallocate_loss_matrix(nx, ny, nz, ng, n)
+    else ! structured Cartesian grid
+      n_c  = 8                   ! define # of corners
+      n_e  = 4*(nx - 2) + 4*(ny - 2) + 4*(nz - 2) ! define # of edges
+      n_s  = 2*(nx - 2)*(ny - 2) + 2*(nx - 2)*(nz - 2) &
+           + 2*(ny - 2)*(nz - 2) ! define # of sides
+      n_i  = nx*ny*nz - (n_c + n_e + n_s) ! define # of interiors  
+      nz_c = ng*n_c*(4 + ng - 1) ! define # nonzero corners
+      nz_e = ng*n_e*(5 + ng - 1) ! define # nonzero edges
+      nz_s = ng*n_s*(6 + ng - 1) ! define # nonzero sides
+      nz_i = ng*n_i*(7 + ng - 1) ! define # nonzero interiors
+      nnz  = nz_c + nz_e + nz_s + nz_i
+    end if
+
+    ! Configure loss matrix
+    call loss_matrix % create(n, nnz)
+
+  end subroutine init_loss_matrix
 
 !===============================================================================
-! PREALLOCATE_LOSS_MATRIX
+! PREALLOCATE_LOSS_MATRIX manually preallocates the loss matrix
 !===============================================================================
 
-  subroutine preallocate_loss_matrix(this)
+  function preallocate_loss_matrix(nx, ny, nz, ng, n) result(nnz)
 
-    use constants,  only: CMFD_NOACCEL
-    use global,     only: cmfd, cmfd_coremap
+    integer, intent(in) :: nx  ! maximum number of x cells
+    integer, intent(in) :: ny  ! maximum number of y cells
+    integer, intent(in) :: nz  ! maximum number of z cells
+    integer, intent(in) :: ng  ! maximum number of groups
+    integer, intent(in) :: n   ! total length of matrix
+    integer             :: nnz ! number of nonzeros
 
-    type(loss_operator) :: this
-
-    integer :: rank          ! rank of processor
-    integer :: sizen         ! number of procs
     integer :: i             ! iteration counter for x
     integer :: j             ! iteration counter for y
     integer :: k             ! iteration counter for z
     integer :: g             ! iteration counter for groups
     integer :: l             ! iteration counter for leakages
     integer :: h             ! energy group when doing scattering
-    integer :: n             ! the extent of the matrix
     integer :: irow          ! row counter
     integer :: bound(6)      ! vector for comparing when looking for bound
     integer :: xyz_idx       ! index for determining if x,y or z leakage
@@ -105,113 +93,68 @@ contains
     integer :: neig_idx(3)   ! spatial indices of neighbour
     integer :: nxyz(3,2)     ! single vector containing bound. locations
     integer :: shift_idx     ! parameter to shift index by +1 or -1
-    integer :: row_start     ! index of local starting row
-    integer :: row_end       ! index of local final row
     integer :: neig_mat_idx  ! matrix index of neighbor cell
     integer :: scatt_mat_idx ! matrix index for h-->g scattering terms
 
-    ! initialize size and rank
-    sizen = 0
-    rank = 0
+    ! Reset number of nonzeros to 0
+    nnz = 0
 
-    ! get rank and max rank of procs
-    call MPI_COMM_RANK(PETSC_COMM_WORLD, rank, ierr)
-    call MPI_COMM_SIZE(PETSC_COMM_WORLD, sizen, ierr)
-
-    ! get local problem size
-    n = this%n
-
-    ! determine local size, divide evenly between all other procs
-    this%localn = n/(sizen)
-        
-    ! add 1 more if less proc id is less than mod
-    if (rank < mod(n,sizen)) this%localn = this%localn + 1
-
-    ! determine local starting row
-    row_start = 0
-    if (rank < mod(n,sizen)) then
-      row_start = rank*(n/sizen+1)
-    else
-      row_start = min(mod(n,sizen)*(n/sizen+1) + &
-           (rank - mod(n,sizen))*(n/sizen),n) 
-    end if
-
-    ! determine local final row
-    row_end = row_start + this%localn - 1
-
-    ! allocate counters
-    if (.not. allocated(this%d_nnz)) allocate(this%d_nnz(row_start:row_end))
-    if (.not. allocated(this%o_nnz)) allocate(this%o_nnz(row_start:row_end))
-    this % d_nnz = 0
-    this % o_nnz = 0
-
-    ! create single vector of these indices for boundary calculation
+    ! Create single vector of these indices for boundary calculation
     nxyz(1,:) = (/1,nx/)
     nxyz(2,:) = (/1,ny/)
     nxyz(3,:) = (/1,nz/)
 
-    ! begin loop around local rows
-    ROWS: do irow = row_start,row_end
+    ! Begin loop around local rows
+    ROWS: do irow = 1, n
 
-      ! initialize counters 
-      this%d_nnz(irow) = 1 ! already add in matrix diagonal
-      this%o_nnz(irow) = 0
+      ! Set a nonzero for diagonal
+      nnz = nnz + 1
 
-      ! get location indices
-      call matrix_to_indices(irow, g, i, j, k)
+      ! Get location indices
+      call matrix_to_indices(irow, g, i, j, k, ng, nx, ny, nz)
 
-      ! create boundary vector
+      ! Create boundary vector
       bound = (/i,i,j,j,k,k/)
 
-      ! begin loop over leakages
+      ! Begin loop over leakages
       LEAK: do l = 1,6
 
-        ! define (x,y,z) and (-,+) indices
+        ! Define (x,y,z) and (-,+) indices
         xyz_idx = int(ceiling(real(l)/real(2)))  ! x=1, y=2, z=3
         dir_idx = 2 - mod(l,2) ! -=1, +=2
 
-        ! calculate spatial indices of neighbor
+        ! Calculate spatial indices of neighbor
         neig_idx = (/i,j,k/)                ! begin with i,j,k
         shift_idx = -2*mod(l,2) +1          ! shift neig by -1 or +1
         neig_idx(xyz_idx) = shift_idx + neig_idx(xyz_idx)
 
-        ! check for global boundary
+        ! Check for global boundary
         if (bound(l) /= nxyz(xyz_idx,dir_idx)) then
 
-          ! check for coremap 
+          ! Check for coremap 
           if (cmfd_coremap) then
 
-            ! check for neighbor that is non-acceleartred
+            ! Check for neighbor that is non-acceleartred
             if (cmfd % coremap(neig_idx(1),neig_idx(2),neig_idx(3)) /= &
                  CMFD_NOACCEL) then
 
-              ! get neighbor matrix index
+              ! Get neighbor matrix index
               call indices_to_matrix(g,neig_idx(1), neig_idx(2), & 
-                   neig_idx(3), neig_mat_idx)
+                   neig_idx(3), neig_mat_idx, ng, nx, ny)
 
-              ! record nonzero
-              if (((neig_mat_idx-1) >= row_start) .and. &
-                   ((neig_mat_idx-1) <= row_end)) then
-                this%d_nnz(irow) = this%d_nnz(irow) + 1
-              else
-                this%o_nnz(irow) = this%o_nnz(irow) + 1
-              end if
+              ! Record nonzero
+              nnz = nnz + 1 
 
             end if
 
           else
 
-            ! get neighbor matrix index
+            ! Get neighbor matrix index
             call indices_to_matrix(g, neig_idx(1), neig_idx(2), neig_idx(3), &
-                 neig_mat_idx)
+                 neig_mat_idx, ng, nx, ny)
 
-            ! record nonzero
-            if (((neig_mat_idx-1) >= row_start) .and. &
-                 ((neig_mat_idx-1) <= row_end)) then
-              this%d_nnz(irow) = this%d_nnz(irow) + 1
-            else
-              this%o_nnz(irow) = this%o_nnz(irow) + 1
-            end if
+            ! Record nonzero
+            nnz = nnz + 1
 
           end if
 
@@ -219,214 +162,206 @@ contains
 
       end do LEAK
 
-      ! begin loop over off diagonal in-scattering
+      ! Begin loop over off diagonal in-scattering
       SCATTR: do h = 1, ng
 
-        ! cycle though if h=g
+        ! Cycle though if h=g, it was already banked in removal xs
         if (h == g) cycle
 
-        ! get neighbor matrix index
-        call indices_to_matrix(h, i, j, k, scatt_mat_idx)
+        ! Get neighbor matrix index
+        call indices_to_matrix(h, i, j, k, scatt_mat_idx, ng, nx, ny)
 
-        ! record nonzero
-        if (((scatt_mat_idx-1) >= row_start) .and. &
-             ((scatt_mat_idx-1) <= row_end)) then
-          this%d_nnz(irow) = this%d_nnz(irow) + 1
-        else
-          this%o_nnz(irow) = this%o_nnz(irow) + 1
-        end if
+        ! Record nonzero
+        nnz = nnz + 1
 
       end do SCATTR
 
     end do ROWS
 
-  end subroutine preallocate_loss_matrix
+  end function preallocate_loss_matrix
 
 !===============================================================================
 ! BUILD_LOSS_MATRIX creates the matrix representing loss of neutrons
 !===============================================================================
 
-  subroutine build_loss_matrix(this, adjoint)
+  subroutine build_loss_matrix(loss_matrix, adjoint)
 
-    use constants,  only: CMFD_NOACCEL, ZERO
-    use global,     only: cmfd, cmfd_coremap, cmfd_write_matrices
+    type(Matrix), intent(inout)   :: loss_matrix ! cmfd loss matrix
+    logical, intent(in), optional :: adjoint     ! set up the adjoint
 
-    type(loss_operator) :: this
-    logical, optional :: adjoint    ! set up the adjoint
+    integer :: nxyz(3,2)     ! single vector containing bound. locations
+    integer :: i             ! iteration counter for x
+    integer :: j             ! iteration counter for y
+    integer :: k             ! iteration counter for z
+    integer :: g             ! iteration counter for groups
+    integer :: l             ! iteration counter for leakages
+    integer :: h             ! energy group when doing scattering
+    integer :: nx            ! maximum number of x cells
+    integer :: ny            ! maximum number of y cells
+    integer :: nz            ! maximum number of z cells
+    integer :: ng            ! maximum number of groups
+    integer :: neig_mat_idx  ! matrix index of neighbor cell
+    integer :: scatt_mat_idx ! matrix index for h-->g scattering terms
+    integer :: bound(6)      ! vector for comparing when looking for bound
+    integer :: xyz_idx       ! index for determining if x,y or z leakage
+    integer :: dir_idx       ! index for determining - or + face of cell
+    integer :: neig_idx(3)   ! spatial indices of neighbour
+    integer :: shift_idx     ! parameter to shift index by +1 or -1
+    integer :: irow          ! iteration counter over row
+    logical :: adjoint_calc  ! is this a physical adjoint calculation?
+    real(8) :: totxs         ! total macro cross section
+    real(8) :: scattxsgg     ! scattering macro cross section g-->g
+    real(8) :: scattxshg     ! scattering macro cross section h-->g
+    real(8) :: dtilde(6)     ! finite difference coupling parameter
+    real(8) :: dhat(6)       ! nonlinear coupling parameter
+    real(8) :: hxyz(3)       ! cell lengths in each direction
+    real(8) :: jn            ! direction dependent leakage coeff to neig
+    real(8) :: jo(6)         ! leakage coeff in front of cell flux
+    real(8) :: jnet          ! net leakage from jo
+    real(8) :: val           ! temporary variable before saving to 
 
-    integer :: nxyz(3,2)            ! single vector containing bound. locations
-    integer :: i                    ! iteration counter for x
-    integer :: j                    ! iteration counter for y
-    integer :: k                    ! iteration counter for z
-    integer :: g                    ! iteration counter for groups
-    integer :: l                    ! iteration counter for leakages
-    integer :: h                    ! energy group when doing scattering
-    integer :: neig_mat_idx         ! matrix index of neighbor cell
-    integer :: scatt_mat_idx        ! matrix index for h-->g scattering terms
-    integer :: bound(6)             ! vector for comparing when looking for bound
-    integer :: xyz_idx              ! index for determining if x,y or z leakage
-    integer :: dir_idx              ! index for determining - or + face of cell
-    integer :: neig_idx(3)          ! spatial indices of neighbour
-    integer :: shift_idx            ! parameter to shift index by +1 or -1
-    integer :: row_start            ! the first local row on the processor
-    integer :: row_finish           ! the last local row on the processor
-    integer :: irow                 ! iteration counter over row
-    real(8) :: totxs                ! total macro cross section
-    real(8) :: scattxsgg            ! scattering macro cross section g-->g
-    real(8) :: scattxshg            ! scattering macro cross section h-->g
-    real(8) :: dtilde(6)            ! finite difference coupling parameter
-    real(8) :: dhat(6)              ! nonlinear coupling parameter
-    real(8) :: hxyz(3)              ! cell lengths in each direction
-    real(8) :: jn                   ! direction dependent leakage coeff to neig
-    real(8) :: jo(6)                ! leakage coeff in front of cell flux
-    real(8) :: jnet                 ! net leakage from jo
-    real(8) :: val                  ! temporary variable before saving to 
-
-    ! check for adjoint
+    ! Check for adjoint
+    adjoint_calc = .false.
     if (present(adjoint)) adjoint_calc = adjoint 
 
-    ! create single vector of these indices for boundary calculation
+    ! Get maximum number of cells in each direction
+    nx = cmfd%indices(1)
+    ny = cmfd%indices(2)
+    nz = cmfd%indices(3)
+    ng = cmfd%indices(4)
+
+    ! Create single vector of these indices for boundary calculation
     nxyz(1,:) = (/1,nx/)
     nxyz(2,:) = (/1,ny/)
     nxyz(3,:) = (/1,nz/)
 
-    ! initialize row start and finish
-    row_start = 0
-    row_finish = 0
+    ! Begin iteration loops
+    ROWS: do irow = 1, loss_matrix % n
 
-    ! get row bounds for this processor
-    call MatGetOwnershipRange(this%M, row_start, row_finish, ierr)
+      ! Set up a new row in matrix
+      call loss_matrix % new_row()
 
-    ! begin iteration loops
-    ROWS: do irow = row_start, row_finish-1
+      ! Get indices for that row
+      call matrix_to_indices(irow, g, i, j, k, ng, nx, ny, nz)
 
-      ! get indices for that row
-      call matrix_to_indices(irow, g, i, j, k)
-
-      ! retrieve cell data
+      ! Retrieve cell data
       totxs = cmfd%totalxs(g,i,j,k)
       scattxsgg = cmfd%scattxs(g,g,i,j,k)
       dtilde = cmfd%dtilde(:,g,i,j,k)
       hxyz = cmfd%hxyz(:,i,j,k)
 
-      ! check and get dhat
+      ! Check and get dhat
       if (allocated(cmfd%dhat)) then
         dhat = cmfd%dhat(:,g,i,j,k)
       else
         dhat = ZERO
       end if
 
-      ! create boundary vector 
+      ! Create boundary vector 
       bound = (/i,i,j,j,k,k/)
 
-      ! begin loop over leakages
+      ! Begin loop over leakages
       ! 1=-x, 2=+x, 3=-y, 4=+y, 5=-z, 6=+z 
       LEAK: do l = 1,6
 
-        ! define (x,y,z) and (-,+) indices
+        ! Define (x,y,z) and (-,+) indices
         xyz_idx = int(ceiling(real(l)/real(2)))  ! x=1, y=2, z=3
         dir_idx = 2 - mod(l,2) ! -=1, +=2
 
-        ! calculate spatial indices of neighbor
+        ! Calculate spatial indices of neighbor
         neig_idx = (/i,j,k/)                ! begin with i,j,k
         shift_idx = -2*mod(l,2) +1          ! shift neig by -1 or +1
         neig_idx(xyz_idx) = shift_idx + neig_idx(xyz_idx)
 
-        ! check for global boundary
+        ! Check for global boundary
         if (bound(l) /= nxyz(xyz_idx,dir_idx)) then
 
-          ! check for core map
+          ! Check for core map
           if (cmfd_coremap) then
 
-            ! check that neighbor is not reflector
+            ! Check that neighbor is not reflector
             if (cmfd % coremap(neig_idx(1),neig_idx(2),neig_idx(3)) /= &
                  CMFD_NOACCEL) then
 
-              ! compute leakage coefficient for neighbor
+              ! Compute leakage coefficient for neighbor
               jn = -dtilde(l) + shift_idx*dhat(l)
 
-              ! get neighbor matrix index
+              ! Get neighbor matrix index
               call indices_to_matrix(g, neig_idx(1), neig_idx(2), neig_idx(3), &
-                   neig_mat_idx)
+                   neig_mat_idx, ng, nx, ny)
 
-              ! compute value and record to bank
+              ! Compute value and record to bank
               val = jn/hxyz(xyz_idx)
 
-              ! record value in matrix
-              call MatSetValue(this%M, irow, neig_mat_idx-1, val, &
-                   INSERT_VALUES, ierr)
+              ! Record value in matrix
+              call loss_matrix % add_value(neig_mat_idx, val)
 
             end if
 
           else
 
-            ! compute leakage coefficient for neighbor
+            ! Compute leakage coefficient for neighbor
             jn = -dtilde(l) + shift_idx*dhat(l)
 
-            ! get neighbor matrix index
+            ! Get neighbor matrix index
             call indices_to_matrix(g, neig_idx(1), neig_idx(2), neig_idx(3), &
-                 neig_mat_idx)
+                 neig_mat_idx, ng, nx, ny)
 
-            ! compute value and record to bank
+            ! Compute value and record to bank
             val = jn/hxyz(xyz_idx)
 
-            ! record value in matrix
-            call MatSetValue(this%M, irow, neig_mat_idx-1, val, &
-                 INSERT_VALUES, ierr)
+            ! Record value in matrix
+            call loss_matrix % add_value(neig_mat_idx, val)
 
           end if
 
         end if
 
-        ! compute leakage coefficient for target
+        ! Compute leakage coefficient for target
         jo(l) = shift_idx*dtilde(l) + dhat(l)
 
       end do LEAK
 
-      ! calate net leakage coefficient for target
+      ! Calculate net leakage coefficient for target
       jnet = (jo(2) - jo(1))/hxyz(1) + (jo(4) - jo(3))/hxyz(2) + &
            (jo(6) - jo(5))/hxyz(3)
 
-      ! calculate loss of neutrons
+      ! Calculate loss of neutrons
       val = jnet + totxs - scattxsgg
 
-      ! record diagonal term
-      call MatSetValue(this%M, irow, irow, val, INSERT_VALUES, ierr)
+      ! Record diagonal term
+      call loss_matrix % add_value(irow, val)
 
-      ! begin loop over off diagonal in-scattering
+      ! Begin loop over off diagonal in-scattering
       SCATTR: do h = 1, ng
 
-        ! cycle though if h=g
+        ! Cycle though if h=g, value already banked in removal xs
         if (h == g) cycle
 
-        ! get neighbor matrix index
-        call indices_to_matrix(h, i, j, k, scatt_mat_idx)
+        ! Get neighbor matrix index
+        call indices_to_matrix(h, i, j, k, scatt_mat_idx, ng, nx, ny)
 
-        ! get scattering macro xs
-        scattxshg = cmfd%scattxs(h, g, i, j, k)
+        ! Check for adjoint
+        if (adjoint_calc) then
+          ! Get scattering macro xs, transposed!
+          scattxshg = cmfd%scattxs(g, h, i, j, k)
+        else
+          ! Get scattering macro xs
+          scattxshg = cmfd%scattxs(h, g, i, j, k)
+        end if
 
-        ! record value in matrix (negate it)
+        ! Negate the scattering xs 
         val = -scattxshg
 
-        ! check for adjoint and bank value
-        if (adjoint_calc) then
-          call MatSetValue(this%M, scatt_mat_idx-1, irow, val, &
-               INSERT_VALUES, ierr)
-        else
-          call MatSetValue(this%M, irow, scatt_mat_idx-1, val, &
-               INSERT_VALUES, ierr)
-        end if
+        ! Record value in matrix
+        call loss_matrix % add_value(scatt_mat_idx, val)
 
       end do SCATTR
 
     end do ROWS 
 
-    ! assemble matrix
-    call MatAssemblyBegin(this%M, MAT_FLUSH_ASSEMBLY, ierr)
-    call MatAssemblyEnd(this%M, MAT_FINAL_ASSEMBLY, ierr)
-
-    ! print out operator to file
-    if (cmfd_write_matrices) call print_M_operator(this)
+    ! CSR requires n+1 row
+    call loss_matrix % new_row()
 
   end subroutine build_loss_matrix
 
@@ -434,25 +369,26 @@ contains
 ! INDICES_TO_MATRIX takes (x,y,z,g) indices and computes location in matrix
 !===============================================================================
 
-  subroutine indices_to_matrix(g, i, j, k, matidx)
+  subroutine indices_to_matrix(g, i, j, k, matidx, ng, nx, ny)
 
-    use global,  only: cmfd, cmfd_coremap
+    integer, intent(out) :: matidx ! the index location in matrix
+    integer, intent(in)  :: i      ! current x index
+    integer, intent(in)  :: j      ! current y index
+    integer, intent(in)  :: k      ! current z index
+    integer, intent(in)  :: g      ! current group index
+    integer, intent(in)  :: nx     ! maximum number of x cells
+    integer, intent(in)  :: ny     ! maximum number of y cells
+    integer, intent(in)  :: ng     ! maximum number of groups
 
-    integer :: matidx ! the index location in matrix
-    integer :: i      ! current x index
-    integer :: j      ! current y index
-    integer :: k      ! current z index
-    integer :: g      ! current group index
-
-    ! check if coremap is used
+    ! Check if coremap is used
     if (cmfd_coremap) then
 
-      ! get idx from core map
+      ! Get idx from core map
       matidx = ng*(cmfd % coremap(i,j,k)) - (ng - g)
 
     else
 
-      ! compute index
+      ! Compute index
       matidx = g + ng*(i - 1) + ng*nx*(j - 1) + ng*nx*ny*(k - 1)
 
     end if
@@ -460,80 +396,40 @@ contains
   end subroutine indices_to_matrix
 
 !===============================================================================
-! MATRIX_TO_INDICES
+! MATRIX_TO_INDICES converts a matrix index to spatial and group indicies
 !===============================================================================
 
-  subroutine matrix_to_indices(irow, g, i, j, k)
+  subroutine matrix_to_indices(irow, g, i, j, k, ng, nx, ny, nz)
 
-    use global,  only: cmfd, cmfd_coremap
+    integer, intent(out) :: i     ! iteration counter for x
+    integer, intent(out) :: j     ! iteration counter for y
+    integer, intent(out) :: k     ! iteration counter for z
+    integer, intent(out) :: g     ! iteration counter for groups
+    integer, intent(in)  :: irow  ! iteration counter over row (0 reference)
+    integer, intent(in)  :: nx    ! maximum number of x cells
+    integer, intent(in)  :: ny    ! maximum number of y cells
+    integer, intent(in)  :: nz    ! maximum number of z cells
+    integer, intent(in)  :: ng    ! maximum number of groups
 
-    integer :: i     ! iteration counter for x
-    integer :: j     ! iteration counter for y
-    integer :: k     ! iteration counter for z
-    integer :: g     ! iteration counter for groups
-    integer :: irow  ! iteration counter over row (0 reference)
-
-    ! check for core map
+    ! Check for core map
     if (cmfd_coremap) then
 
-      ! get indices from indexmap
-      g = mod(irow, ng) + 1
-      i = cmfd % indexmap(irow/ng+1,1)
-      j = cmfd % indexmap(irow/ng+1,2)
-      k = cmfd % indexmap(irow/ng+1,3)
+      ! Get indices from indexmap
+      g = mod(irow-1, ng) + 1
+      i = cmfd % indexmap((irow-1)/ng+1,1)
+      j = cmfd % indexmap((irow-1)/ng+1,2)
+      k = cmfd % indexmap((irow-1)/ng+1,3)
 
     else
 
-      ! compute indices
-      g = mod(irow, ng) + 1
-      i = mod(irow, ng*nx)/ng + 1
-      j = mod(irow, ng*nx*ny)/(ng*nx)+ 1
-      k = mod(irow, ng*nx*ny*nz)/(ng*nx*ny) + 1
+      ! Compute indices
+      g = mod(irow-1, ng) + 1
+      i = mod(irow-1, ng*nx)/ng + 1
+      j = mod(irow-1, ng*nx*ny)/(ng*nx)+ 1
+      k = mod(irow-1, ng*nx*ny*nz)/(ng*nx*ny) + 1
 
     end if
 
   end subroutine matrix_to_indices
 
-!===============================================================================
-! PRINT_M_OPERATOR
-!===============================================================================
-
-  subroutine print_M_operator(this)
-
-    type(loss_operator) :: this
-
-    PetscViewer :: viewer
-
-    ! write out matrix in binary file (debugging)
-    if (adjoint_calc) then
-      call PetscViewerBinaryOpen(PETSC_COMM_WORLD, 'adj_lossmat.bin', &
-           FILE_MODE_WRITE, viewer, ierr)
-    else
-      call PetscViewerBinaryOpen(PETSC_COMM_WORLD, 'lossmat.bin', &
-           FILE_MODE_WRITE, viewer, ierr)
-    end if
-    call MatView(this%M, viewer, ierr)
-    call PetscViewerDestroy(viewer, ierr)
-
-  end subroutine print_M_operator
-
-!==============================================================================
-! DESTROY_M_OPERATOR
-!==============================================================================
-
-  subroutine destroy_M_operator(this)
-
-    type(loss_operator) :: this
-
-    ! deallocate matrix
-    call MatDestroy(this%M, ierr)
-
-    ! deallocate other parameters
-    if (allocated(this%d_nnz)) deallocate(this%d_nnz)
-    if (allocated(this%o_nnz)) deallocate(this%o_nnz)
-
-  end subroutine destroy_M_operator
-
-# endif
-
 end module cmfd_loss_operator

src/cmfd_message_passing.F90

@@ -1,98 +0,0 @@
-module cmfd_message_passing
-
-# ifdef PETSC
-
-! This module contains MPI routines related to the CMFD calculation
-
-  implicit none
-  private
-  public :: petsc_init_mpi, cmfd_bcast 
-
-# include <finclude/petsc.h90>
-
-contains
-
-!===============================================================================
-! PETSC_INIT_MPI
-!===============================================================================
-
-  subroutine petsc_init_mpi()
-
-    use global,       only: n_procs_cmfd, time_cmfd, rank, mpi_err
-
-    integer               :: new_comm   ! new communicator
-    integer               :: color      ! communicator color
-
-    ! assign color
-    if (rank < n_procs_cmfd) then
-      color = 1
-    else
-      color = 2
-    end if
-
-    ! split up procs
-    call MPI_COMM_SPLIT(MPI_COMM_WORLD,color,0,new_comm,mpi_err)
-
-    ! assign to PETSc
-    PETSC_COMM_WORLD = new_comm
-
-    ! initialize petsc on all procs
-    call PetscInitialize(PETSC_NULL_CHARACTER,mpi_err)
-
-    ! initialize timer
-    call time_cmfd % reset()
-
-  end subroutine petsc_init_mpi
-
-!===============================================================================
-! CMFD_BCAST
-!===============================================================================
-
-  subroutine cmfd_bcast()
-
-    use global,       only: cmfd_coremap, cmfd, mpi_err
-    use cmfd_header,  only: allocate_cmfd
-
-    integer :: nx  ! number of mesh cells in x direction
-    integer :: ny  ! number of mesh cells in y direction
-    integer :: nz  ! number of mesh cells in z direction
-    integer :: ng  ! number of energy groups
-
-    ! extract spatial and energy indices from object
-    nx = cmfd % indices(1)
-    ny = cmfd % indices(2)
-    nz = cmfd % indices(3)
-    ng = cmfd % indices(4)
-
-    ! initialize data
-    if (.not. allocated(cmfd%flux)) call allocate_cmfd(cmfd)
-
-    ! sync up procs
-    call MPI_Barrier(PETSC_COMM_WORLD, mpi_err)
-
-    ! broadcast all data
-    call MPI_BCAST(cmfd%flux, ng*nx*ny*nz, MPI_REAL8, 0, PETSC_COMM_WORLD, mpi_err)
-    call MPI_BCAST(cmfd%totalxs, ng*nx*ny*nz, MPI_REAL8, 0, PETSC_COMM_WORLD, mpi_err)
-    call MPI_BCAST(cmfd%p1scattxs, ng*nx*ny*nz, MPI_REAL8, 0, PETSC_COMM_WORLD, mpi_err)
-    call MPI_BCAST(cmfd%scattxs, ng*ng*nx*ny*nz, MPI_REAL8, 0, PETSC_COMM_WORLD, mpi_err)
-    call MPI_BCAST(cmfd%nfissxs, ng*ng*nx*ny*nz, MPI_REAL8, 0, PETSC_COMM_WORLD, mpi_err)
-    call MPI_BCAST(cmfd%diffcof, ng*nx*ny*nz, MPI_REAL8, 0, PETSC_COMM_WORLD, mpi_err)
-    call MPI_BCAST(cmfd%dtilde, 6*ng*nx*ny*nz, MPI_REAL8, 0, PETSC_COMM_WORLD, mpi_err)
-    call MPI_BCAST(cmfd%dhat, 6*ng*nx*ny*nz, MPI_REAL8, 0, PETSC_COMM_WORLD, mpi_err)
-    call MPI_BCAST(cmfd%hxyz, 3*nx*ny*nz, MPI_REAL8, 0, PETSC_COMM_WORLD, mpi_err)
-    call MPI_BCAST(cmfd%current, 12*ng*nx*ny*nz, MPI_REAL8, 0, PETSC_COMM_WORLD, mpi_err)
-
-    ! broadcast coremap info
-    if (cmfd_coremap) then
-      call MPI_BCAST(cmfd%coremap, nx*ny*nz, MPI_INTEGER8, 0, PETSC_COMM_WORLD, mpi_err)
-      call MPI_BCAST(cmfd%mat_dim, 1, MPI_INTEGER8, 0, PETSC_COMM_WORLD, mpi_err)
-      if (.not. allocated(cmfd % indexmap)) &
-           allocate(cmfd % indexmap(cmfd % mat_dim,3))
-      call MPI_BCAST(cmfd%indexmap, cmfd%mat_dim*3, MPI_INTEGER8, 0, PETSC_COMM_WORLD, mpi_err)
-    end if
-
-  end subroutine cmfd_bcast
-
-# endif
-
-end module cmfd_message_passing

src/cmfd_output.F90

@@ -1,61 +0,0 @@
-module cmfd_output
-
-#ifdef PETSC
-
-! This modules cleans up cmfd objects and echos the results
-
-  implicit none
-  private
-  public :: finalize_cmfd
-
-contains
-
-!===============================================================================
-! FINALIZE_CMFD
-!===============================================================================
-
-  subroutine finalize_cmfd() 
-
-    use global,      only: cmfd, cmfd_write_balance, cmfd_write_hdf5, &
-                           master, mpi_err
-    use cmfd_header, only: deallocate_cmfd
-
-    ! finalize petsc
-    call PetscFinalize(mpi_err)
-
-    ! write out final neutron balance
-    if (master .and. cmfd_write_balance) call write_neutron_balance()
-
-    ! deallocate cmfd object
-    call deallocate_cmfd(cmfd)
-
-  end subroutine finalize_cmfd 
-
-!===============================================================================
-! WRITE_NEUTRON_BALANCE 
-!===============================================================================
-
-  subroutine write_neutron_balance()
-
-    use cmfd_data,    only: neutron_balance
-    use constants,    only: CMFD_BALANCE, MAX_FILE_LEN
-    use global,       only: path_output
-
-    character(MAX_FILE_LEN) :: filename
-
-    filename = trim(path_output) // 'neutron_balance.out'
-
-    ! open file for output
-    open(UNIT=CMFD_BALANCE, FILE=filename, ACTION='write')
-
-    ! write out the tally
-    call neutron_balance(CMFD_BALANCE) 
-
-    ! close file
-    close(CMFD_BALANCE)
-
-  end subroutine write_neutron_balance
-
-#endif
-
-end module cmfd_output

src/cmfd_power_solver.F90

@@ -1,445 +1,348 @@
 module cmfd_power_solver
 
-# ifdef PETSC
-
 ! This module contains routines to execute the power iteration solver
 
-  use cmfd_loss_operator, only: loss_operator,init_M_operator, &
-                                build_loss_matrix,destroy_M_operator
-  use cmfd_prod_operator, only: prod_operator,init_F_operator, &
-                                build_prod_matrix,destroy_F_operator
+  use cmfd_loss_operator, only: init_loss_matrix, build_loss_matrix
+  use cmfd_prod_operator, only: init_prod_matrix, build_prod_matrix
+  use matrix_header,      only: Matrix
+  use solver_interface,   only: GMRESSolver
+  use vector_header,      only: Vector
 
   implicit none
   private
   public :: cmfd_power_execute 
 
-# include <finclude/petsc.h90>
-
-  type(loss_operator) :: loss   ! M loss matrix
-  type(prod_operator) :: prod   ! F production matrix
-
-  Vec     :: phi_n                ! new flux eigenvector
-  Vec     :: phi_o                ! old flux eigenvector
-  Vec     :: S_n                  ! new source vector
-  Vec     :: S_o                  ! old source vector
-  KSP     :: krylov               ! krylov solver
-  KSP     :: sub_krylov           ! sub-ksp for bjacobi
-  PC      :: prec                 ! preconditioner for krylov
-  PC      :: sub_prec             ! sub-prec for bjacobi
-  integer :: ierr                 ! error flag
-  integer :: nlocal
-  integer :: first
+  logical :: iconv                ! did the problem converged
   real(8) :: k_n                  ! new k-eigenvalue
   real(8) :: k_o                  ! old k-eigenvalue
   real(8) :: ktol = 1.e-8_8       ! tolerance on keff
   real(8) :: stol = 1.e-8_8       ! tolerance on source
-  logical :: iconv                ! did the problem converged
-
-  logical :: adjoint_calc = .false. ! run an adjoint calculation
+  real(8) :: norm_n               ! current norm of source vector
+  real(8) :: norm_o               ! old norm of source vector
+  real(8) :: kerr                 ! error in keff
+  real(8) :: serr                 ! error in source
+  logical :: adjoint_calc         ! run an adjoint calculation
+  type(Matrix) :: loss            ! cmfd loss matrix
+  type(Matrix) :: prod            ! cmfd prod matrix
+  type(Vector) :: phi_n           ! new flux vector
+  type(Vector) :: phi_o           ! old flux vector
+  type(Vector) :: s_n             ! new source vector
+  type(Vector) :: s_o             ! old flux vector
+  type(Vector) :: serr_v          ! error in source
+  type(GMRESSolver) :: gmres      ! gmres solver
 
 contains
 
 !===============================================================================
-! CMFD_POWER_EXECUTE
+! CMFD_POWER_EXECUTE sets up and runs power iteration solver for CMFD
 !===============================================================================
 
   subroutine cmfd_power_execute(k_tol, s_tol, adjoint)
 
-    use global,  only: cmfd_adjoint_type, n_procs_cmfd
+    use global,  only: cmfd_adjoint_type, time_cmfdbuild, time_cmfdsolve
 
-    real(8), optional :: k_tol    ! tolerance on keff
-    real(8), optional :: s_tol    ! tolerance on source
-    logical, optional :: adjoint  ! adjoint calc
+    real(8), intent(in), optional :: k_tol    ! tolerance on keff
+    real(8), intent(in), optional :: s_tol    ! tolerance on source
+    logical, intent(in), optional :: adjoint  ! adjoint calc
 
-    logical :: physical_adjoint = .false.
+    logical :: physical_adjoint = .false. ! physical adjoint default false
 
-    ! set tolerances if present
+    ! Set tolerances if present
     if (present(k_tol)) ktol = k_tol
     if (present(s_tol)) stol = s_tol
 
-    ! check for adjoint execution
+    ! Check for adjoint execution
+    adjoint_calc = .false.
     if (present(adjoint)) adjoint_calc = adjoint
 
-    ! check for physical adjoint
+    ! Check for physical adjoint
     if (adjoint_calc .and. trim(cmfd_adjoint_type) == 'physical') &
         physical_adjoint = .true.
 
-    ! initialize solver
-    call init_solver()
+    ! Start timer for build
+    call time_cmfdbuild % start()
 
-    ! initialize matrices and vectors
-    call init_data()
+    ! Initialize solver
+#ifdef PETSC
+    call gmres % create()
+#endif
 
-    ! set up M loss matrix
-    call build_loss_matrix(loss, adjoint=physical_adjoint) 
+    ! Initialize matrices and vectors
+    call init_data(physical_adjoint)
 
-    ! set up F production matrix
-    call build_prod_matrix(prod, adjoint=physical_adjoint)
-
-    ! check for adjoint calculation
+    ! Check for mathematical adjoint calculation
     if (adjoint_calc .and. trim(cmfd_adjoint_type) == 'math') &
         call compute_adjoint()
 
-    ! set up krylov info
-    call KSPSetOperators(krylov, loss%M, loss%M, SAME_NONZERO_PATTERN, ierr)
+    ! Set up krylov info
+#ifdef PETSC
+    call gmres % set_oper(loss, loss)
+#endif
 
-    ! precondition matrix
-    call precondition_matrix()
+    ! Stop timer for build
+    call time_cmfdbuild % stop()
 
-    ! begin power iteration 
+    ! Begin power iteration 
+    call time_cmfdsolve % start()
     call execute_power_iter()
+    call time_cmfdsolve % stop()
 
-    ! extract results
+    ! Extract results
     call extract_results()
 
-    ! deallocate petsc objects
+    ! Deallocate data 
     call finalize()
 
   end subroutine cmfd_power_execute
 
 !===============================================================================
-! INIT_DATA allocates matrices vectors for CMFD solution
+! INIT_DATA allocates matrices and vectors for CMFD solution
 !===============================================================================
 
-  subroutine init_data()
+  subroutine init_data(adjoint)
 
-    use constants, only: ONE
+    use constants, only: ONE, ZERO
+#ifdef PETSC
+    use global,    only: cmfd_write_matrices
+#endif
+
+    logical, intent(in) :: adjoint ! adjoint calcualtion
 
     integer :: n      ! problem size
     real(8) :: guess  ! initial guess
 
-    ! set up matrices
-    call init_M_operator(loss)
-    call init_F_operator(prod)
+    ! Set up matrices
+    call init_loss_matrix(loss)
+    call init_prod_matrix(prod)
 
-    ! get problem size
-    n = loss%localn
+    ! Get problem size
+    n = loss % n
 
-    ! set up flux vectors
-    call VecCreateMPI(PETSC_COMM_WORLD, n, PETSC_DECIDE, phi_n, ierr)
-    call VecCreateMPI(PETSC_COMM_WORLD, n, PETSC_DECIDE, phi_o, ierr)
+    ! Set up flux vectors
+    call phi_n % create(n)
+    call phi_o % create(n)
 
-    ! set up source vectors
-    call VecCreateMPI(PETSC_COMM_WORLD, n, PETSC_DECIDE, S_n, ierr)
-    call VecCreateMPI(PETSC_COMM_WORLD, n, PETSC_DECIDE, S_o, ierr)
+    ! Set up source vectors
+    call s_n % create(n)
+    call s_o % create(n)
+    call serr_v % create(n)
 
-    ! set initial guess
+    ! Set initial guess
     guess = ONE
-    call VecSet(phi_n, guess, ierr)
-    call VecSet(phi_o, guess, ierr)
+    phi_n % val = guess
+    phi_o % val = guess
     k_n = guess
     k_o = guess
 
+    ! Fill in loss matrix
+    call build_loss_matrix(loss, adjoint=adjoint) 
+
+    ! Fill in production matrix
+    call build_prod_matrix(prod, adjoint=adjoint)
+
+    ! Setup petsc for everything
+    call loss % assemble()
+    call prod % assemble()
+#ifdef PETSC
+    call loss % setup_petsc()
+    call prod % setup_petsc()
+    call phi_n % setup_petsc()
+    call phi_o % setup_petsc()
+    call s_o % setup_petsc()
+    call s_n % setup_petsc()
+    if (cmfd_write_matrices) call loss % write_petsc_binary('loss.bin')
+    if (cmfd_write_matrices) call prod % write_petsc_binary('prod.bin')
+#endif
+
+    ! Set norms to 0
+    norm_n = ZERO
+    norm_o = ZERO
+
   end subroutine init_data
 
 !===============================================================================
-! INIT_SOLVER
-!===============================================================================
-
-  subroutine init_solver()
-
-    real(8)  :: rtol ! relative tolerance
-    real(8)  :: atol ! absolute tolerance  
-
-    ! set tolerance
-    rtol = 1.0e-10_8
-    atol = 1.0e-10_8
-
-    ! set up krylov solver
-    call KSPCreate(PETSC_COMM_WORLD, krylov, ierr)
-    call KSPSetTolerances(krylov, rtol, atol, PETSC_DEFAULT_DOUBLE_PRECISION, &
-         PETSC_DEFAULT_INTEGER, ierr)
-    call KSPSetType(krylov, KSPGMRES, ierr)
-    call KSPSetInitialGuessNonzero(krylov, PETSC_TRUE, ierr)
-
-  end subroutine init_solver
-
-!===============================================================================
-! PRECONDITION_MATRIX 
-!===============================================================================
-
-  subroutine precondition_matrix()
-
-    use global, only: cmfd_power_monitor, cmfd_solver_type, &
-                      n_procs_cmfd, cmfd_ilu_levels, master
-    use string, only: to_str
-    use, intrinsic :: ISO_FORTRAN_ENV
-
-    character(len=20) :: ksptype,pctype
- 
-    ! set up preconditioner
-    call KSPGetPC(krylov, prec, ierr)
-    if (n_procs_cmfd == 1) then
-      call PCSetType(prec, PCILU, ierr)
-      call PCFactorSetLevels(prec, cmfd_ilu_levels, ierr)
-      call KSPSetUp(krylov, ierr)
-      call PCFactorGetMatrix(prec, loss%M, ierr)
-    else
-      call PetscOptionsSetValue("-pc_type", "bjacobi", ierr)
-      call PetscOptionsSetValue("-sub_pc_type", "ilu", ierr)  
-      call PetscOptionsSetValue("-sub_pc_factor_levels", &
-           trim(to_str(cmfd_ilu_levels)), ierr)
-      call PCSetFromOptions(prec, ierr)
-      call KSPSetUp(krylov, ierr)
-    end if
-
-    ! get options
-    if (trim(cmfd_solver_type) == 'power') call KSPSetFromOptions(krylov, ierr)
-
-    ! get all types and print
-    call KSPGetType(krylov, ksptype, ierr)
-    call PCGetType(prec, pctype, ierr)
-
-    ! print heading information
-    if (cmfd_power_monitor .and. master) then
-      write(OUTPUT_UNIT,'(A)') ''
-      write(OUTPUT_UNIT,'(A)') '########################################################'
-      write(OUTPUT_UNIT,'(A)') '################ Power Iteration Solver ################'
-      write(OUTPUT_UNIT,'(A)') '########################################################'
-      write(OUTPUT_UNIT,'(A)')
-      write(OUTPUT_UNIT,100)   'Eigenvalue Tolerance:', ktol
-      write(OUTPUT_UNIT,100)   'Source Tolerance:    ', stol
-      write(OUTPUT_UNIT,'(A)') ''
-      write(OUTPUT_UNIT,102)   'Linear Solver Type:  ', ksptype
-      write(OUTPUT_UNIT,102)   'Preconditioner Type: ', pctype
-      write(OUTPUT_UNIT,101)   'ILU Fill Levels:', cmfd_ilu_levels
-      write(OUTPUT_UNIT,'(A)') ''
-      write(OUTPUT_UNIT,'(A)') '---------------------------------------------'
-      write(OUTPUT_UNIT,'(A)') ''
-    end if
-
- 100 FORMAT(A,1X,1PE11.4)
- 101 FORMAT(A,1X,I0)
- 102 FORMAT(A,1X,A)
-
-  end subroutine precondition_matrix
-
-!===============================================================================
-! COMPUTE_ADJOINT 
+! COMPUTE_ADJOINT computes a mathematical adjoint of CMFD problem 
 !===============================================================================
 
   subroutine compute_adjoint()
 
     use global,  only: cmfd_write_matrices
 
-    PetscViewer :: viewer
+    ! Transpose matrices
+    call loss % transpose()
+    call prod % transpose()
 
-    ! transpose matrices
-    call MatTranspose(loss%M, MAT_REUSE_MATRIX, loss%M, ierr)
-    call MatTranspose(prod%F, MAT_REUSE_MATRIX, prod%F, ierr)
-
-    ! write out matrix in binary file (debugging)
+    ! Write out matrix in binary file (debugging)
     if (cmfd_write_matrices) then
-      call PetscViewerBinaryOpen(PETSC_COMM_WORLD, 'adj_lossmat.bin', &
-           FILE_MODE_WRITE, viewer, ierr)
-      call MatView(loss%M, viewer, ierr)
-      call PetscViewerDestroy(viewer, ierr)
-
-      call PetscViewerBinaryOpen(PETSC_COMM_WORLD, 'adj_prodmat.bin', &
-           FILE_MODE_WRITE, viewer, ierr)
-      call MatView(prod%F, viewer, ierr)
-      call PetscViewerDestroy(viewer, ierr)
+      call loss % write_petsc_binary('adj_lossmat.bin')
+      call prod % write_petsc_binary('adj_prodmat.bin')
     end if
 
   end subroutine compute_adjoint
 
 !===============================================================================
-! EXECUTE_POWER_ITER  in the main power iteration routine
+! EXECUTE_POWER_ITER  is the main power iteration routine
 !                     for the cmfd calculation
 !===============================================================================
 
   subroutine execute_power_iter()
 
-    use constants, only: ONE
+    integer :: i ! iteration counter
 
-    real(8)     :: num       ! numerator for eigenvalue update
-    real(8)     :: den       ! denominator for eigenvalue update
-    integer     :: i         ! iteration counter
-
-    ! reset convergence flag
+    ! Reset convergence flag
     iconv = .false.
 
-    ! begin power iteration
+    ! Begin power iteration
     do i = 1, 10000
 
-      ! compute source vector
-      call MatMult(prod%F, phi_o, S_o, ierr)
+      ! Compute source vector
+      call prod % vector_multiply(phi_o, s_o)
 
-      ! normalize source vector
-      call VecScale(S_o, ONE/k_o, ierr)
+      ! Normalize source vector
+      s_o % val = s_o % val / k_o
 
-      ! compute new flux vector
-      call KSPSolve(krylov, S_o, phi_n, ierr)
+      ! Compute new flux vector
+#ifdef PETSC
+      call gmres % solve(s_o, phi_n)
+#endif
 
-      ! compute new source vector
-      call MatMult(prod%F, phi_n, S_n, ierr)
+      ! Compute new source vector
+      call prod % vector_multiply(phi_n, s_n)
 
-      ! compute new k-eigenvalue
-      call VecSum(S_n, num, ierr)
-      call VecSum(S_o, den, ierr)
-      k_n = num/den
+      ! Compute new k-eigenvalue
+      k_n = sum(s_n % val) / sum(s_o % val)
 
-      ! renormalize the old source
-      call VecScale(S_o, k_o, ierr)
+      ! Renormalize the old source
+      s_o % val = s_o % val * k_o
 
-      ! check convergence
+      ! Check convergence
       call convergence(i)
 
-      ! to break or not to break
+      ! Break loop if converged
       if (iconv) exit
 
-      ! record old values
-      call VecCopy(phi_n, phi_o, ierr)
+      ! Record old values
+      phi_o % val = phi_n % val
       k_o = k_n
+      norm_o = norm_n
 
     end do
 
   end subroutine execute_power_iter 
 
 !===============================================================================
-! CONVERGENCE
+! CONVERGENCE checks the convergence of the CMFD problem
 !===============================================================================
 
   subroutine convergence(iter)
 
-    use global,  only: cmfd_power_monitor, master
+    use constants,  only: ONE, TINY_BIT
+    use global,     only: cmfd_power_monitor, master
     use, intrinsic :: ISO_FORTRAN_ENV
 
-    integer     :: iter           ! iteration number
+    integer, intent(in) :: iter ! iteration number
 
-    real(8)     :: kerr           ! error in keff
-    real(8)     :: serr           ! error in source
-    real(8)     :: norm_n         ! L2 norm of new source
-    real(8)     :: norm_o         ! L2 norm of old source
-    integer     :: ierr           ! petsc error code
-
-    ! reset convergence flag
+    ! Reset convergence flag
     iconv = .false.
 
-    ! calculate error in keff
+    ! Calculate error in keff
     kerr = abs(k_o - k_n)/k_n
 
-    ! calculate max error in source
-    call VecNorm(S_n, NORM_2, norm_n, ierr)
-    call VecNorm(S_o, NORM_2, norm_o, ierr)
-    serr = abs(norm_n-norm_o)/norm_n
+    ! Calculate max error in source
+    where (s_n % val > TINY_BIT)
+      serr_v % val = ((s_n % val - s_o % val)/s_n % val)**2
+    end where
+    serr = sqrt(ONE/dble(s_n % n) * sum(serr_v % val))
 
-    ! check for convergence
+    ! Check for convergence
     if(kerr < ktol .and. serr < stol) iconv = .true.
 
-    ! print out to user
+    ! Save the L2 norm of the source
+    norm_n = serr
+
+    ! Print out to user
     if (cmfd_power_monitor .and. master) then
-      write(OUTPUT_UNIT,FMT='(I0,":",T10,"k-eff: ",F0.8,T30,"k-error: ",1PE12.5,T55, &
-           "src-error: ",1PE12.5)') iter, k_n, kerr, serr
+      write(OUTPUT_UNIT,FMT='(I0,":",T10,"k-eff: ",F0.8,T30,"k-error: ", &
+           &1PE12.5,T55, "src-error: ",1PE12.5)') iter, k_n, kerr, serr
     end if
 
   end subroutine convergence
 
 !===============================================================================
-! EXTRACT_RESULTS 
+! EXTRACT_RESULTS takes results and puts them in CMFD global data object
 !===============================================================================
 
   subroutine extract_results()
 
-    use constants,        only: ZERO
-    use global,           only: cmfd, n_procs_cmfd, cmfd_write_matrices
+    use global, only: cmfd, cmfd_write_matrices, current_batch
 
+    character(len=25)    :: filename  ! name of file to write data 
     integer              :: n         ! problem size
-    integer              :: row_start ! local row start
-    integer              :: row_end   ! local row end
-    real(8),allocatable  :: mybuf(:)  ! temp buffer
-    PetscScalar, pointer :: phi_v(:)  ! pointer to eigenvector info
-    PetscViewer          :: viewer    ! petsc viewer for binary write
 
-    ! get problem size
-    n = loss%n
+    ! Get problem size
+    n = loss % n
 
-    ! also allocate in cmfd object
+    ! Allocate in cmfd object if not already allocated
     if (adjoint_calc) then
       if (.not. allocated(cmfd%adj_phi)) allocate(cmfd%adj_phi(n))
     else
       if (.not. allocated(cmfd%phi)) allocate(cmfd%phi(n))
     end if
-    if (.not. allocated(mybuf)) allocate(mybuf(n))
 
-    ! get ownership range
-    call VecGetOwnershipRange(phi_n, row_start, row_end, ierr)
-
-    ! convert petsc phi_object to cmfd_obj
-    call VecGetArrayF90(phi_n, phi_v, ierr)
+    ! Save values 
     if (adjoint_calc) then
-      cmfd%adj_phi(row_start+1:row_end) = phi_v
+      cmfd % adj_phi = phi_n % val
     else
-      cmfd%phi(row_start+1:row_end) = phi_v 
+      cmfd % phi = phi_n % val 
     end if
-    call VecRestoreArrayF90(phi_n, phi_v, ierr)
 
-    ! save eigenvalue
+    ! Save eigenvalue
     if(adjoint_calc) then
       cmfd%adj_keff = k_n
     else
       cmfd%keff = k_n
     end if
 
-    ! reduce result to all 
-    mybuf = ZERO
-    if (adjoint_calc) then
-      call MPI_ALLREDUCE(cmfd%adj_phi, mybuf, n, MPI_REAL8, MPI_SUM, &
-           PETSC_COMM_WORLD, ierr)
-    else
-      call MPI_ALLREDUCE(cmfd%phi, mybuf, n, MPI_REAL8, MPI_SUM, &
-           PETSC_COMM_WORLD, ierr)
-    end if
-
-    ! normalize phi to 1
+    ! Normalize phi to 1
     if (adjoint_calc) then
       cmfd%adj_phi = cmfd%adj_phi/sqrt(sum(cmfd%adj_phi*cmfd%adj_phi))
     else
       cmfd%phi = cmfd%phi/sqrt(sum(cmfd%phi*cmfd%phi))
     end if
 
-    ! write out results
+    ! Save dominance ratio
+    cmfd % dom(current_batch) = norm_n/norm_o
+
+    ! Write out results
     if (cmfd_write_matrices) then
       if (adjoint_calc) then
-        call PetscViewerBinaryOpen(PETSC_COMM_WORLD, 'adj_fluxvec.bin', &
-             FILE_MODE_WRITE, viewer, ierr)
+        filename = 'adj_fluxvec.bin'
       else
-        call PetscViewerBinaryOpen(PETSC_COMM_WORLD, 'fluxvec.bin', &
-             FILE_MODE_WRITE, viewer, ierr)
+        filename = 'fluxvec.bin'
       end if
-      call VecView(phi_n, viewer, ierr)
-      call PetscViewerDestroy(viewer, ierr)
+      call phi_n % write_petsc_binary(filename)
     end if
 
-    ! nullify pointer and deallocate local vars
-    if (associated(phi_v)) nullify(phi_v)
-    if (allocated(mybuf)) deallocate(mybuf)
-
   end subroutine extract_results
 
 !===============================================================================
-! FINALIZE 
+! FINALIZE frees all memory associated with power iteration
 !===============================================================================
 
   subroutine finalize()
 
-    use global,  only: n_procs_cmfd
-
-    ! finalize solver objects
-    call KSPDestroy(krylov, ierr)
-    call KSPDestroy(sub_krylov, ierr)
-
-    ! finalize data objects
-    if (n_procs_cmfd > 1) call destroy_M_operator(loss) ! only destroy for jacobi
-    call destroy_F_operator(prod)
-
-    call VecDestroy(phi_n, ierr)
-    call VecDestroy(phi_o, ierr)
-    call VecDestroy(S_n, ierr)
-    call VecDestroy(S_o, ierr)
+    ! Destroy all objects 
+#ifdef PETSC
+    call gmres  % destroy()
+#endif
+    call loss   % destroy() 
+    call prod   % destroy()
+    call phi_n  % destroy()
+    call phi_o  % destroy()
+    call s_n    % destroy()
+    call s_o    % destroy()
+    call serr_v % destroy
 
   end subroutine finalize
 
-# endif
-
 end module cmfd_power_solver

src/cmfd_prod_operator.F90

@@ -1,66 +1,72 @@
 module cmfd_prod_operator
 
-# ifdef PETSC
+  use constants,      only: CMFD_NOACCEL
+  use global,         only: cmfd, cmfd_coremap
+  use matrix_header,  only: Matrix
 
   implicit none
   private
-  public :: init_F_operator,build_prod_matrix,destroy_F_operator
-
-# include <finclude/petsc.h90>
-
-  integer  :: nx   ! maximum number of x cells
-  integer  :: ny   ! maximum number of y cells
-  integer  :: nz   ! maximum number of z cells
-  integer  :: ng   ! maximum number of groups
-  integer  :: ierr ! petsc error code
-
-  type, public :: prod_operator
-
-    Mat      :: F    ! petsc matrix for neutronic prod operator
-    integer  :: n    ! dimensions of matrix
-    integer  :: nnz  ! max number of nonzeros
-    integer  :: localn ! local size on proc
-    integer, allocatable :: d_nnz(:) ! vector of diagonal preallocation
-    integer, allocatable :: o_nnz(:) ! vector of off-diagonal preallocation
-
-  end type prod_operator
-
-  logical :: adjoint_calc = .false. ! adjoint calculation 
+  public :: init_prod_matrix, build_prod_matrix
 
 contains
 
 !==============================================================================
-! INIT_F_OPERATOR
+! INIT_PROD_MATRIX preallocates prod matrix and initializes it
 !==============================================================================
 
-  subroutine init_F_operator(this)
+  subroutine init_prod_matrix(prod_matrix)
 
-    type(prod_operator) :: this
+    type(Matrix), intent(inout) :: prod_matrix ! production matrix
 
-    ! get indices
-    call get_F_indices(this)
+    integer :: nx   ! maximum number of x cells
+    integer :: ny   ! maximum number of y cells
+    integer :: nz   ! maximum number of z cells
+    integer :: ng   ! maximum number of groups
+    integer :: n    ! total length of matrix
+    integer :: nnz  ! number of nonzeros in matrix
 
-    ! get preallocation
-    call preallocate_prod_matrix(this)
+    ! Get maximum number of cells in each direction
+    nx = cmfd%indices(1)
+    ny = cmfd%indices(2)
+    nz = cmfd%indices(3)
+    ng = cmfd%indices(4)
 
-    ! set up M operator
-    call MatCreateAIJ(PETSC_COMM_WORLD, this%localn, this%localn, PETSC_DECIDE, &
-         PETSC_DECIDE, PETSC_NULL_INTEGER, this%d_nnz, PETSC_NULL_INTEGER, &
-         this%o_nnz, this%F, ierr)
-    call MatSetOption(this%F, MAT_NEW_NONZERO_LOCATIONS, PETSC_TRUE, ierr)
-    call MatSetOption(this%F, MAT_IGNORE_ZERO_ENTRIES, PETSC_TRUE, ierr)
+    ! Calculate dimensions and number of nonzeros in matrix
+    if (cmfd_coremap) then
+      n = cmfd % mat_dim * ng
+    else
+      n = nx*ny*nz*ng
+    end if
+    nnz = n * ng
 
-  end subroutine init_F_operator
+    ! Configure prod matrix
+    call prod_matrix % create(n, nnz)
 
-!==============================================================================
-! GET_F_INDICES
-!==============================================================================
+  end subroutine init_prod_matrix
 
-  subroutine get_F_indices(this)
+!===============================================================================
+! BUILD_PROD_MATRIX creates the matrix representing production of neutrons
+!===============================================================================
 
-    use global,  only: cmfd, cmfd_coremap
+  subroutine build_prod_matrix(prod_matrix, adjoint)
 
-    type(prod_operator) :: this
+    type(Matrix), intent(inout)   :: prod_matrix ! production matrix
+    logical, intent(in), optional :: adjoint     ! adjoint calculation logical
+
+    integer :: i                  ! iteration counter for x
+    integer :: j                  ! iteration counter for y
+    integer :: k                  ! iteration counter for z
+    integer :: g                  ! iteration counter for groups
+    integer :: h                  ! energy group when doing scattering
+    integer :: nx                 ! maximum number of x cells
+    integer :: ny                 ! maximum number of y cells
+    integer :: nz                 ! maximum number of z cells
+    integer :: ng                 ! maximum number of groups
+    integer :: hmat_idx           ! index in matrix for energy group h
+    integer :: irow               ! iteration counter over row
+    logical :: adjoint_calc       ! is this a physical adjoint?
+    real(8) :: nfissxs            ! nufission cross section h-->g
+    real(8) :: val                ! temporary variable for nfissxs
 
     ! get maximum number of cells in each direction
     nx = cmfd%indices(1)
@@ -68,162 +74,18 @@ contains
     nz = cmfd%indices(3)
     ng = cmfd%indices(4)
 
-    ! get number of nonzeros
-    this%nnz = 7 + ng - 1
-
-    ! calculate dimensions of matrix
-    if (cmfd_coremap) then
-      this%n = cmfd % mat_dim * ng
-    else
-      this%n = nx*ny*nz*ng
-    end if
-
-  end subroutine get_F_indices
-
-!===============================================================================
-! PREALLOCATE_PROD_MATRIX
-!===============================================================================
-
-  subroutine preallocate_prod_matrix(this)
-
-    use constants,  only: CMFD_NOACCEL
-    use global,     only: cmfd, cmfd_coremap
-
-    type(prod_operator) :: this
-
-    integer :: rank          ! rank of processor
-    integer :: sizen         ! number of procs
-    integer :: i             ! iteration counter for x
-    integer :: j             ! iteration counter for y
-    integer :: k             ! iteration counter for z
-    integer :: g             ! iteration counter for groups
-    integer :: h             ! energy group when doing scattering
-    integer :: n             ! the extent of the matrix
-    integer :: irow          ! row counter
-    integer :: row_start     ! index of local starting row
-    integer :: row_end       ! index of local final row
-    integer :: hmat_idx      ! index in matrix for energy group h
-
-    ! initialize size and rank
-    rank = 0
-    sizen = 0
-
-    ! get rank and max rank of procs
-    call MPI_COMM_RANK(PETSC_COMM_WORLD, rank, ierr)
-    call MPI_COMM_SIZE(PETSC_COMM_WORLD, sizen, ierr)
-
-    ! get local problem size
-    n = this%n
-
-    ! determine local size, divide evenly between all other procs
-    this%localn = n/(sizen)
-
-    ! add 1 more if less proc id is less than mod
-    if (rank < mod(n, sizen)) this%localn = this%localn + 1
-
-    ! determine local starting row
-    row_start = 0
-    if (rank < mod(n, sizen)) then
-      row_start = rank*(n/sizen+1)
-    else
-      row_start = min(mod(n, sizen)*(n/sizen+1) + &
-           (rank - mod(n, sizen))*(n/sizen), n)
-    end if
-
-    ! determine local final row
-    row_end = row_start + this%localn - 1
-
-    ! allocate counters
-    if (.not. allocated(this%d_nnz)) allocate(this%d_nnz(row_start:row_end))
-    if (.not. allocated(this%o_nnz)) allocate(this%o_nnz(row_start:row_end))
-    this % d_nnz = 0
-    this % o_nnz = 0
-
-    ! begin loop around local rows
-    ROWS: do irow = row_start, row_end
-
-      ! initialize counters 
-      this%d_nnz(irow) = 1 ! already add in matrix diagonal
-      this%o_nnz(irow) = 0
-
-      ! get location indices
-      call matrix_to_indices(irow, g, i, j, k)
-
-      ! check if not including reflector
-      if (cmfd_coremap) then
-
-        ! check if at a reflector
-        if (cmfd % coremap(i,j,k) == CMFD_NOACCEL) then
-          cycle
-        end if
-
-      end if
-
-      ! begin loop over off diagonal in-scattering
-      NFISS: do h = 1, ng
-
-        ! cycle though if h=g
-        if (h == g) then
-          cycle
-        end if
-
-        ! get neighbor matrix index
-        call indices_to_matrix(h, i, j, k, hmat_idx)
-
-        ! record nonzero
-        if (((hmat_idx-1) >= row_start) .and. &
-             ((hmat_idx-1) <= row_end)) then
-          this%d_nnz(irow) = this%d_nnz(irow) + 1
-        else
-          this%o_nnz(irow) = this%o_nnz(irow) + 1
-        end if
-
-      end do NFISS
-
-    end do ROWS
-
-  end subroutine preallocate_prod_matrix
-
-!===============================================================================
-! BUILD_PROD_MATRIX creates the matrix representing loss of neutrons
-!===============================================================================
-
-  subroutine build_prod_matrix(this, adjoint)
-
-    use constants,  only: CMFD_NOACCEL
-    use global,     only: cmfd, cmfd_coremap, cmfd_write_matrices
-
-    type(prod_operator) :: this
-    logical, optional :: adjoint
-
-    integer :: i                  ! iteration counter for x
-    integer :: j                  ! iteration counter for y
-    integer :: k                  ! iteration counter for z
-    integer :: g                  ! iteration counter for groups
-    integer :: h                  ! energy group when doing scattering
-    integer :: hmat_idx           ! index in matrix for energy group h
-    integer :: ierr               ! Petsc error code
-    integer :: row_start          ! the first local row on the processor
-    integer :: row_finish         ! the last local row on the processor
-    integer :: irow               ! iteration counter over row
-    real(8) :: nfissxs            ! nufission cross section h-->g
-    real(8) :: val                ! temporary variable for nfissxs
-
     ! check for adjoint
+    adjoint_calc = .false.
     if (present(adjoint)) adjoint_calc = adjoint
 
-    ! initialize row start and finish
-    row_start = 0
-    row_finish = 0
-
-    ! get row bounds for this processor
-    call MatGetOwnershipRange(this%F, row_start, row_finish, ierr)
-
     ! begin iteration loops
-    ROWS: do irow = row_start, row_finish-1
+    ROWS: do irow = 1, prod_matrix % n
+
+      ! add a new row to matrix
+      call prod_matrix % new_row()
 
       ! get indices for that row
-      call matrix_to_indices(irow, g, i, j, k)
+      call matrix_to_indices(irow, g, i, j, k, ng, nx, ny, nz)
 
       ! check if not including reflector
       if (cmfd_coremap) then
@@ -236,34 +98,34 @@ contains
       end if
 
       ! loop around all other groups 
+
       NFISS: do h = 1, ng
 
-        ! get cell data
-        nfissxs = cmfd%nfissxs(h,g,i,j,k)
-
         ! get matrix column location
-        call indices_to_matrix(h, i, j, k, hmat_idx)
-
-        ! reocrd value in matrix
-        val = nfissxs
+        call indices_to_matrix(h, i, j, k, hmat_idx, ng, nx, ny)
 
         ! check for adjoint and bank val
         if (adjoint_calc) then
-          call MatSetValue(this%F, hmat_idx-1, irow, val, INSERT_VALUES, ierr)
+          ! get nu-fission cross section from cell
+          nfissxs = cmfd%nfissxs(g,h,i,j,k)
         else
-          call MatSetValue(this%F, irow, hmat_idx-1, val, INSERT_VALUES, ierr)
+          ! get nu-fission cross section from cell
+          nfissxs = cmfd%nfissxs(h,g,i,j,k)
         end if
 
+        ! set as value to be recorded
+        val = nfissxs
+
+        ! record value in matrix
+
+        call prod_matrix % add_value(hmat_idx, val)
+
       end do NFISS
 
     end do ROWS 
 
-    ! assemble matrix 
-    call MatAssemblyBegin(this%F, MAT_FLUSH_ASSEMBLY, ierr)
-    call MatAssemblyEnd(this%F, MAT_FINAL_ASSEMBLY, ierr)
-
-    ! print out operator to file
-    if (cmfd_write_matrices) call print_F_operator(this)
+    ! CSR requires n+1 row
+    call prod_matrix % new_row()
 
   end subroutine build_prod_matrix
 
@@ -271,19 +133,20 @@ contains
 ! INDICES_TO_MATRIX takes (x,y,z,g) indices and computes location in matrix
 !===============================================================================
 
-  subroutine indices_to_matrix(g, i, j, k, matidx)
+  subroutine indices_to_matrix(g, i, j, k, matidx, ng, nx, ny)
 
-    use global,  only: cmfd, cmfd_coremap
+    integer, intent(out) :: matidx ! the index location in matrix
+    integer, intent(in)  :: i      ! current x index
+    integer, intent(in)  :: j      ! current y index
+    integer, intent(in)  :: k      ! current z index
+    integer, intent(in)  :: g      ! current group index
+    integer, intent(in)  :: nx     ! maximum number of x cells
+    integer, intent(in)  :: ny     ! maximum number of y cells
+    integer, intent(in)  :: ng     ! maximum number of groups
 
-    integer :: matidx         ! the index location in matrix
-    integer :: i              ! current x index
-    integer :: j              ! current y index
-    integer :: k              ! current z index
-    integer :: g              ! current group index
-    
     ! check if coremap is used
     if (cmfd_coremap) then
-    
+
       ! get idx from core map
       matidx = ng*(cmfd % coremap(i,j,k)) - (ng - g)
 
@@ -297,80 +160,40 @@ contains
   end subroutine indices_to_matrix
 
 !===============================================================================
-! MATRIX_TO_INDICES
+! MATRIX_TO_INDICES converts matrix index to spatial and group indices
 !===============================================================================
 
-  subroutine matrix_to_indices(irow, g, i, j, k)
+  subroutine matrix_to_indices(irow, g, i, j, k, ng, nx, ny, nz)
 
-    use global,  only: cmfd, cmfd_coremap
-
-    integer :: i                    ! iteration counter for x
-    integer :: j                    ! iteration counter for y
-    integer :: k                    ! iteration counter for z
-    integer :: g                    ! iteration counter for groups
-    integer :: irow                 ! iteration counter over row (0 reference)
+    integer, intent(out) :: i    ! iteration counter for x
+    integer, intent(out) :: j    ! iteration counter for y
+    integer, intent(out) :: k    ! iteration counter for z
+    integer, intent(out) :: g    ! iteration counter for groups
+    integer, intent(in)  :: irow ! iteration counter over row (0 reference)
+    integer, intent(in)  :: nx   ! maximum number of x cells
+    integer, intent(in)  :: ny   ! maximum number of y cells
+    integer, intent(in)  :: nz   ! maximum number of z cells
+    integer, intent(in)  :: ng   ! maximum number of groups
 
     ! check for core map
     if (cmfd_coremap) then
 
       ! get indices from indexmap
-      g = mod(irow,ng) + 1
-      i = cmfd % indexmap(irow/ng+1,1)
-      j = cmfd % indexmap(irow/ng+1,2)
-      k = cmfd % indexmap(irow/ng+1,3)
+      g = mod(irow-1, ng) + 1
+      i = cmfd % indexmap((irow-1)/ng+1,1)
+      j = cmfd % indexmap((irow-1)/ng+1,2)
+      k = cmfd % indexmap((irow-1)/ng+1,3)
 
     else
 
       ! compute indices
-      g = mod(irow, ng) + 1
-      i = mod(irow, ng*nx)/ng + 1
-      j = mod(irow, ng*nx*ny)/(ng*nx)+ 1
-      k = mod(irow, ng*nx*ny*nz)/(ng*nx*ny) + 1
+      g = mod(irow-1, ng) + 1
+      i = mod(irow-1, ng*nx)/ng + 1
+      j = mod(irow-1, ng*nx*ny)/(ng*nx)+ 1
+      k = mod(irow-1, ng*nx*ny*nz)/(ng*nx*ny) + 1
 
     end if
 
   end subroutine matrix_to_indices
 
-!===============================================================================
-! PRINT_F_OPERATOR
-!===============================================================================
-
-  subroutine print_F_operator(this)
-
-    type(prod_operator) :: this
-
-    PetscViewer :: viewer
-
-    ! write out matrix in binary file (debugging)
-    if (adjoint_calc) then
-      call PetscViewerBinaryOpen(PETSC_COMM_WORLD, 'adj_prodmat.bin', &   
-           FILE_MODE_WRITE, viewer, ierr)
-    else
-      call PetscViewerBinaryOpen(PETSC_COMM_WORLD, 'prodmat.bin', &
-           FILE_MODE_WRITE, viewer, ierr)
-    end if
-    call MatView(this%F, viewer, ierr)
-    call PetscViewerDestroy(viewer, ierr)
-
-  end subroutine print_F_operator
-
-!==============================================================================
-! DESTROY_F_OPERATOR
-!==============================================================================
-
-  subroutine destroy_F_operator(this)
-
-    type(prod_operator) :: this
-
-    ! deallocate matrix
-    call MatDestroy(this%F, ierr)
-
-    ! deallocate other parameters
-    if (allocated(this%d_nnz)) deallocate(this%d_nnz)
-    if (allocated(this%o_nnz)) deallocate(this%o_nnz)
-
-  end subroutine destroy_F_operator
-
-# endif 
-
 end module cmfd_prod_operator

src/cmfd_snes_solver.F90

@@ -1,473 +0,0 @@
-module cmfd_snes_solver
-
-# ifdef PETSC
-
-  use cmfd_loss_operator,     only: loss_operator,init_M_operator,           &
-                                    build_loss_matrix,destroy_M_operator
-  use cmfd_prod_operator,     only: prod_operator,init_F_operator,           &
-                                    build_prod_matrix,destroy_F_operator
-  use cmfd_jacobian_operator, only: jacobian_operator,init_J_operator,       &
-                                    build_jacobian_matrix,destroy_J_operator,&
-                                    operators
-  use cmfd_power_solver,      only: cmfd_power_execute
-
-  implicit none
-  private
-  public :: cmfd_snes_execute
-
-# include <finclude/petsc.h90>
-
-  type(jacobian_operator) :: jac_prec
-  type(operators) :: ctx
-
-  Mat         :: jac                    ! jacobian matrix
-  Vec         :: resvec                 ! residual vector
-  Vec         :: xvec                   ! results
-  KSP         :: ksp                    ! linear solver context
-  PC          :: pc                     ! preconditioner
-  SNES        :: snes                   ! nonlinear solver context
-  integer     :: ierr                   ! error flag
-
-  logical     :: adjoint_calc = .false. ! adjoint calculation
-
-contains
-
-!===============================================================================
-! CMFD_SNES_EXECUTE
-!===============================================================================
-
-  subroutine cmfd_snes_execute(adjoint)
-
-    logical, optional :: adjoint ! adjoint calculation
-
-    ! check for adjoint
-    if (present(adjoint)) adjoint_calc = adjoint
-
-    ! seed with power iteration
-    call cmfd_power_execute(k_tol=1.E-3_8, s_tol=1.E-3_8, adjoint=adjoint_calc)
-
-    ! initialize data
-    call init_data()
-
-    ! initialize solver
-    call init_solver()
-
-    ! precondition
-    call precondition_matrix()
-
-    ! solve the system
-    call SNESSolve(snes, PETSC_NULL_DOUBLE, xvec, ierr)
-
-    ! extracts results to cmfd object
-    call extract_results()
-
-    ! deallocate all slepc data
-    call finalize()
-
-  end subroutine cmfd_snes_execute
-
-!===============================================================================
-! INIT_DATA allocates matrices vectors for CMFD solution
-!===============================================================================
-
-  subroutine init_data()
-
-    use constants, only: ONE
-    use global,    only: cmfd, n_procs_cmfd, rank
-
-    integer              :: k         ! implied do counter
-    integer              :: n         ! problem size
-    integer              :: row_start ! local row start
-    integer              :: row_end   ! local row end
-    real(8), pointer     :: xptr(:)   ! solution pointer
-
-    ! set up operator matrices
-    call init_M_operator(ctx%loss)
-    call init_F_operator(ctx%prod)
-    call init_J_operator(jac_prec, ctx)
-
-    ! get problem size
-    n = jac_prec%n
-
-    ! create PETSc vectors
-    call VecCreateMPI(PETSC_COMM_WORLD, jac_prec%localn, PETSC_DECIDE, &
-         resvec, ierr)
-    call VecCreateMPI(PETSC_COMM_WORLD, jac_prec%localn, PETSC_DECIDE, &
-         xvec, ierr)
-
-    ! get the local dimensions for each process
-    call VecGetOwnershipRange(xvec, row_start, row_end, ierr)
-
-    if (rank == n_procs_cmfd - 1) row_end = n
-
-    ! set flux in guess
-    if (adjoint_calc) then
-      call VecSetValues(xvec, row_end-row_start, (/(k,k=row_start,row_end-1)/), &
-           cmfd%adj_phi(row_start+1:row_end), INSERT_VALUES, ierr)
-    else
-      call VecSetValues(xvec, row_end-row_start, (/(k,k=row_start,row_end-1)/), &
-           cmfd%phi(row_start+1:row_end), INSERT_VALUES, ierr)
-    end if
-    call VecAssemblyBegin(xvec, ierr)
-    call VecAssemblyEnd(xvec, ierr)
-
-    ! set keff in guess
-    if (rank == n_procs_cmfd - 1) then
-      call VecGetArrayF90(xvec, xptr, ierr)
-      if (adjoint_calc) then
-        xptr(size(xptr)) = ONE/cmfd%adj_keff
-      else
-        xptr(size(xptr)) = ONE/cmfd%keff
-      end if
-      call VecRestoreArrayF90(xvec, xptr, ierr)
-    end if
-
-    ! nullify pointers
-    if (associated(xptr)) nullify(xptr)
-
-  end subroutine init_data
-
-!===============================================================================
-! INIT_SOLVER
-!===============================================================================
-
-  subroutine init_solver()
-
-    use global,  only: cmfd_snes_monitor, n_procs_cmfd
-
-    ! turn on mf_operator option
-    call PetscOptionsSetValue("-snes_mf_operator", "TRUE", ierr)
-
-    ! create SNES context
-    call SNESCreate(PETSC_COMM_WORLD, snes, ierr)
-
-    ! set the residual function
-    call SNESSetFunction(snes, resvec, compute_nonlinear_residual, &
-         PETSC_NULL_DOUBLE, ierr)
-
-    ! set GMRES solver
-    call SNESGetKSP(snes, ksp, ierr)
-    call KSPSetType(ksp, KSPGMRES, ierr)
-
-    ! create matrix free jacobian
-    call MatCreateSNESMF(snes, jac, ierr)
-
-    ! set matrix free finite difference
-    call SNESSetJacobian(snes, jac, jac_prec, build_jacobian_matrix, ctx, ierr)
-
-    ! set lags
-    call SNESSetLagJacobian(snes, -2, ierr)
-    call SNESSetLagPreconditioner(snes, -1, ierr)
-
-    ! set convergence
-!   call SNESSetTolerances(snes, 1.0e-8_8, 1.0e-8_8, 1.0e-8_8, 50, 10000, ierr)
-
-    ! set SNES options
-    call SNESSetFromOptions(snes, ierr)
-
-    ! turn off line searching
-!   call SNESLineSearchSet(snes, SNESLineSearchNo, PETSC_NULL_OBJECT, ierr)
-
-  end subroutine init_solver
-
-!===============================================================================
-! PRECONDITION_MATRIX 
-!===============================================================================
-
-  subroutine precondition_matrix()
-
-    use global,                 only: cmfd_snes_monitor, cmfd_solver_type, &
-                                      n_procs_cmfd, cmfd_ilu_levels, master
-    use string,                 only: to_str
-    use, intrinsic :: ISO_FORTRAN_ENV
-
-    character(LEN=20) :: snestype, ksptype, pctype
-
-    ! set up preconditioner
-    call KSPGetPC(ksp, pc, ierr)
-    if (n_procs_cmfd == 1) then
-      call PCSetType(pc, PCILU, ierr)
-      call PCFactorSetLevels(pc, cmfd_ilu_levels, ierr)
-    else
-      call PetscOptionsSetValue("-pc_type", "bjacobi", ierr)
-      call PetscOptionsSetValue("-sub_pc_type", "ilu", ierr)
-      call PetscOptionsSetValue("-sub_pc_factor_levels", &
-           trim(to_str(cmfd_ilu_levels)), ierr)
-    end if
-
-    ! get options
-    call PCSetFromOptions(pc, ierr)
-    call KSPSetFromOptions(ksp, ierr)
-
-    ! finalize ksp setup
-!   call KSPSetUp(ksp, ierr)
-
-    ! get all types and print
-    call SNESGetType(snes, snestype, ierr)
-    call KSPGetType(ksp, ksptype, ierr)
-    call PCGetType(pc, pctype, ierr)
-
-    ! display solver info to user
-    if (cmfd_snes_monitor .and. master) then
-      write(OUTPUT_UNIT,'(A)') ''
-      write(OUTPUT_UNIT,'(A)') '########################################################'
-      write(OUTPUT_UNIT,'(A)') '################ JFNK Nonlinear Solver  ################'
-      write(OUTPUT_UNIT,'(A)') '########################################################'
-      write(OUTPUT_UNIT,'(A)') ''
-      write(OUTPUT_UNIT,101) 'NONLINEAR SOLVER: ', snestype
-      write(OUTPUT_UNIT,101) 'LINEAR SOLVER:    ', ksptype
-      write(OUTPUT_UNIT,101) 'PRECONDITIONER:   ', pctype
-      write(OUTPUT_UNIT,100) 'ILU levels: ', cmfd_ilu_levels
-      write(OUTPUT_UNIT,'(A)') ''
-      write(OUTPUT_UNIT,'(A)') '---------------------------------------------'
-      write(OUTPUT_UNIT,'(A)') ''
-    end if
-
- 100 FORMAT(A,1X,I0)
- 101 FORMAT(A,1X,A)
- 
-  end subroutine precondition_matrix
-
-!===============================================================================
-! COMPUTE_NONLINEAR_RESIDUAL
-!===============================================================================
-
-  subroutine compute_nonlinear_residual(snes, x, res, ierr)
-
-    use global,       only: n_procs_cmfd, cmfd_write_matrices, &
-                            cmfd_adjoint_type, rank
-
-    SNES        :: snes          ! nonlinear solver context
-    Vec         :: x             ! independent vector
-    Vec         :: res           ! residual vector
-    integer     :: ierr          ! error flag
-
-    Vec         :: phi           ! flux vector
-    Vec         :: rphi          ! flux part of residual
-    Vec         :: phiM          ! M part of residual flux calc
-    integer     :: n             ! problem size
-    real(8)     :: lambda        ! eigenvalue
-    real(8)     :: reslamb       ! residual for lambda
-
-    real(8), pointer :: xptr(:)  ! pointer to solution vector
-    real(8), pointer :: rptr(:)  ! pointer to residual vector
-    PetscViewer :: viewer
-
-    logical :: physical_adjoint = .false.
-
-    ! check for physical adjoint
-    if (adjoint_calc .and. trim(cmfd_adjoint_type) == 'physical') &
-         physical_adjoint = .true.
-
-    ! create operators
-    call build_loss_matrix(ctx%loss, adjoint = physical_adjoint)
-    call build_prod_matrix(ctx%prod, adjoint = physical_adjoint)
-
-    ! check for adjoint
-    if (adjoint_calc .and. trim(cmfd_adjoint_type) == 'math') &
-         call compute_adjoint()
-
-    ! get problem size
-    n = ctx%loss%n 
-
-    ! get pointers to vectors
-    call VecGetArrayF90(x, xptr, ierr)
-    call VecGetArrayF90(res, rptr, ierr)
-
-    ! create petsc vector for flux
-    call VecCreateMPI(PETSC_COMM_WORLD, ctx%loss%localn, &
-         PETSC_DECIDE, phi, ierr)
-    call VecCreateMPI(PETSC_COMM_WORLD, ctx%loss%localn, &
-         PETSC_DECIDE, rphi, ierr)
-
-    ! extract flux and place in petsc vector 
-    call VecPlaceArray(phi, xptr, ierr)
-    call VecPlaceArray(rphi, rptr, ierr)
-
-    ! extract eigenvalue and broadcast (going to want to make this more general in future)
-    if (rank == n_procs_cmfd - 1) lambda = xptr(size(xptr)) 
-    call MPI_BCAST(lambda, 1, MPI_REAL8, n_procs_cmfd-1, PETSC_COMM_WORLD, ierr)
-
-    ! create new petsc vectors to perform math
-    call VecCreateMPI(PETSC_COMM_WORLD, ctx%loss%localn, PETSC_DECIDE, &
-         phiM, ierr)
-
-    ! calculate flux part of residual vector
-    call MatMult(ctx%loss%M, phi, phiM, ierr)
-    call MatMult(ctx%prod%F, phi, rphi, ierr)
-    call VecAYPX(rphi, -lambda, phiM, ierr)
-
-    ! set eigenvalue part of residual vector
-    call VecDot(phi, phi, reslamb, ierr)
-
-    ! map to ptr
-    if (rank == n_procs_cmfd - 1) rptr(size(rptr)) = 0.5_8 - 0.5_8*reslamb
-
-    ! reset arrays that are not used
-    call VecResetArray(phi, ierr)
-    call VecResetArray(rphi, ierr)
-
-    ! restore arrays for residual and solution
-    call VecRestoreArrayF90(x, xptr, ierr)
-    call VecRestoreArrayF90(res, rptr, ierr)
-
-    ! destroy all temp vectors
-    call VecDestroy(phi, ierr)
-    call VecDestroy(phiM, ierr)
-    call VecDestroy(rphi, ierr)
-
-    ! nullify all pointers
-    if (associated(xptr)) nullify(xptr)
-    if (associated(rptr)) nullify(rptr)
-
-    ! write out matrix in binary file (debugging)
-    if (cmfd_write_matrices) then
-      if (adjoint_calc) then
-        call PetscViewerBinaryOpen(PETSC_COMM_WORLD, 'adj_res.bin', &
-             FILE_MODE_WRITE, viewer, ierr)
-      else
-        call PetscViewerBinaryOpen(PETSC_COMM_WORLD, 'res.bin', &
-             FILE_MODE_WRITE, viewer, ierr)
-      end if
-      call VecView(res, viewer, ierr)
-      call PetscViewerDestroy(viewer, ierr)
-
-      if (adjoint_calc) then
-        call PetscViewerBinaryOpen(PETSC_COMM_WORLD, 'adj_x.bin', &
-             FILE_MODE_WRITE, viewer, ierr)
-      else
-        call PetscViewerBinaryOpen(PETSC_COMM_WORLD, 'x.bin', &
-             FILE_MODE_WRITE, viewer, ierr)
-      end if
-       call VecView(x, viewer, ierr)
-       call PetscViewerDestroy(viewer, ierr)
-
-    end if
-
-  end subroutine compute_nonlinear_residual
-
-!===============================================================================
-! COMPUTE_ADJOINT
-!===============================================================================
-
-  subroutine compute_adjoint()
-
-    use global,  only: cmfd_write_matrices
-
-    PetscViewer :: viewer
-
-    ! transpose matrices
-    call MatTranspose(ctx%loss%M, MAT_REUSE_MATRIX, ctx%loss%M, ierr)
-    call MatTranspose(ctx%prod%F, MAT_REUSE_MATRIX, ctx%prod%F, ierr)
-
-    ! write out matrix in binary file (debugging)
-    if (cmfd_write_matrices) then
-      call PetscViewerBinaryOpen(PETSC_COMM_WORLD, 'adj_lossmat.bin', &
-           FILE_MODE_WRITE, viewer, ierr)
-      call MatView(ctx%loss%M, viewer, ierr)
-      call PetscViewerDestroy(viewer, ierr)
-
-      call PetscViewerBinaryOpen(PETSC_COMM_WORLD, 'adj_prodmat.bin', &
-           FILE_MODE_WRITE, viewer, ierr)
-      call MatView(ctx%prod%F, viewer, ierr)
-      call PetscViewerDestroy(viewer, ierr)
-    end if
-
-  end subroutine compute_adjoint
-
-!===============================================================================
-! EXTRACT_RESULTS 
-!===============================================================================
-
-  subroutine extract_results()
-
-    use constants, only: ZERO, ONE
-    use global,    only: cmfd, n_procs_cmfd, rank
-
-    integer              :: n         ! problem size
-    integer              :: row_start ! local row start
-    integer              :: row_end   ! local row end
-    real(8)              :: keff      ! keff of problem
-    real(8),allocatable  :: mybuf(:)  ! temp buffer
-    PetscScalar, pointer :: xptr(:)   ! pointer to eigenvector info
-
-    ! get problem size
-    n = ctx%loss%n
-
-    ! also allocate in cmfd object
-    if (adjoint_calc) then
-      if (.not. allocated(cmfd%adj_phi)) allocate(cmfd%adj_phi(n))
-    else
-      if (.not. allocated(cmfd%phi)) allocate(cmfd%phi(n))
-    end if
-    if (.not. allocated(mybuf)) allocate(mybuf(n))
-
-    ! get ownership range
-    call VecGetOwnershipRange(xvec, row_start, row_end, ierr)
-
-    ! resize the last proc
-    if (rank == n_procs_cmfd - 1) row_end = row_end - 1
-
-    ! convert petsc phi_object to cmfd_obj
-    call VecGetArrayF90(xvec, xptr, ierr)
-    if (adjoint_calc) then
-      cmfd%adj_phi(row_start+1:row_end) = xptr(1:row_end - row_start)
-    else
-      cmfd%phi(row_start+1:row_end) = xptr(1:row_end - row_start) 
-    end if
-
-    ! reduce result to all 
-    mybuf = ZERO
-    if (adjoint_calc) then
-      call MPI_ALLREDUCE(cmfd%adj_phi, mybuf, n, MPI_REAL8, MPI_SUM, &
-           PETSC_COMM_WORLD, ierr)
-    else
-      call MPI_ALLREDUCE(cmfd%phi, mybuf, n, MPI_REAL8, MPI_SUM, &
-           PETSC_COMM_WORLD, ierr)
-    end if
-
-    ! move buffer to object and deallocate
-    cmfd%phi = mybuf
-    if(allocated(mybuf)) deallocate(mybuf)
-
-    ! save eigenvalue
-    if(rank == n_procs_cmfd - 1) keff = ONE / xptr(size(xptr))
-    if (adjoint_calc) then
-      cmfd%adj_keff = keff
-      call MPI_BCAST(cmfd%adj_keff, 1, MPI_REAL8, n_procs_cmfd-1, &
-           PETSC_COMM_WORLD, ierr)
-    else
-      cmfd%keff = keff
-      call MPI_BCAST(cmfd%keff, 1, MPI_REAL8, n_procs_cmfd-1, &
-           PETSC_COMM_WORLD, ierr)
-    end if
-    call VecRestoreArrayF90(xvec, xptr, ierr)
-
-    ! nullify pointers and deallocate local variables
-    if (associated(xptr)) nullify(xptr)
-    if (allocated(mybuf)) deallocate(mybuf)
-
-  end subroutine extract_results
-
-!===============================================================================
-! FINALIZE 
-!===============================================================================
-
-  subroutine finalize()
-
-    ! finalize data objects
-    call destroy_M_operator(ctx%loss)
-    call destroy_F_operator(ctx%prod)
-    call destroy_J_operator(jac_prec)
-    call VecDestroy(xvec, ierr)
-    call VecDestroy(resvec, ierr)
-    call MatDestroy(jac, ierr)
-
-    ! finalize solver objects
-    call SNESDestroy(snes, ierr)
-
-  end subroutine finalize
-
-# endif
-
-end module cmfd_snes_solver

src/constants.F90

@@ -8,10 +8,10 @@ module constants
   ! OpenMC major, minor, and release numbers
   integer, parameter :: VERSION_MAJOR   = 0
   integer, parameter :: VERSION_MINOR   = 5
-  integer, parameter :: VERSION_RELEASE = 2
+  integer, parameter :: VERSION_RELEASE = 3
 
   ! Revision numbers for binary files
-  integer, parameter :: REVISION_STATEPOINT       = 9
+  integer, parameter :: REVISION_STATEPOINT       = 10
   integer, parameter :: REVISION_PARTICLE_RESTART = 1
 
   ! Binary file types
@@ -20,7 +20,7 @@ module constants
        FILETYPE_PARTICLE_RESTART = -2
 
   ! ============================================================================
-  ! ADJUSTABLE PARAMETERS 
+  ! ADJUSTABLE PARAMETERS
 
   ! NOTE: This is the only section of the constants module that should ever be
   ! adjusted. Modifying constants in other sections may cause the code to fail.
@@ -50,6 +50,10 @@ module constants
   integer, parameter :: MAX_WORD_LEN = 150
   integer, parameter :: MAX_FILE_LEN = 255
 
+  ! Maximum number of external source spatial resamples to encounter before an
+  ! error is thrown.
+  integer, parameter :: MAX_EXTSRC_RESAMPLES = 10000
+
   ! ============================================================================
   ! PHYSICAL CONSTANTS
 
@@ -110,9 +114,9 @@ module constants
 
   ! Surface types
   integer, parameter ::  &
-       SURF_PX     =  1, & ! Plane parallel to x-plane 
-       SURF_PY     =  2, & ! Plane parallel to y-plane 
-       SURF_PZ     =  3, & ! Plane parallel to z-plane 
+       SURF_PX     =  1, & ! Plane parallel to x-plane
+       SURF_PY     =  2, & ! Plane parallel to y-plane
+       SURF_PZ     =  3, & ! Plane parallel to z-plane
        SURF_PLANE  =  4, & ! Arbitrary plane
        SURF_CYL_X  =  5, & ! Cylinder along x-axis
        SURF_CYL_Y  =  6, & ! Cylinder along y-axis
@@ -143,7 +147,7 @@ module constants
        ELECTRON = 3
 
   ! Angular distribution type
-  integer, parameter :: & 
+  integer, parameter :: &
        ANGLE_ISOTROPIC = 1, & ! Isotropic angular distribution
        ANGLE_32_EQUI   = 2, & ! 32 equiprobable bins
        ANGLE_TABULAR   = 3    ! Tabular angular distribution
@@ -151,7 +155,8 @@ module constants
   ! Secondary energy mode for S(a,b) inelastic scattering
   integer, parameter :: &
        SAB_SECONDARY_EQUAL  = 0, & ! Equally-likely outgoing energy bins
-       SAB_SECONDARY_SKEWED = 1    ! Skewed outgoing energy bins
+       SAB_SECONDARY_SKEWED = 1, & ! Skewed outgoing energy bins
+       SAB_SECONDARY_CONT   = 2    ! Continuous, linear-linear interpolation
 
   ! Elastic mode for S(a,b) elastic scattering
   integer, parameter :: &
@@ -275,7 +280,7 @@ module constants
        SCORE_KAPPA_FISSION = -12, & ! fission energy production rate
        SCORE_CURRENT       = -13, & ! partial current
        SCORE_EVENTS        = -14    ! number of events
-       
+
   ! Maximum scattering order supported
   integer, parameter :: SCATT_ORDER_MAX = 10
   character(len=*), parameter :: SCATT_ORDER_MAX_PNSTR = "scatter-p10"
@@ -322,7 +327,7 @@ module constants
 
   ! Source angular distribution types
   integer, parameter :: &
-       SRC_ANGLE_ISOTROPIC = 1, & ! Isotropic angular 
+       SRC_ANGLE_ISOTROPIC = 1, & ! Isotropic angular
        SRC_ANGLE_MONO      = 2, & ! Monodirectional source
        SRC_ANGLE_TABULAR   = 3    ! Tabular distribution
 
@@ -332,7 +337,7 @@ module constants
        SRC_ENERGY_MAXWELL = 2, & ! Maxwell fission spectrum
        SRC_ENERGY_WATT    = 3, & ! Watt fission spectrum
        SRC_ENERGY_TABULAR = 4    ! Tabular distribution
-       
+
   ! ============================================================================
   ! MISCELLANEOUS CONSTANTS
 
@@ -362,9 +367,8 @@ module constants
   integer, parameter :: UNIT_TALLY    = 12 ! unit # for writing tally file
   integer, parameter :: UNIT_PLOT     = 13 ! unit # for writing plot file
   integer, parameter :: UNIT_XS       = 14 ! unit # for writing xs summary file
-  integer, parameter :: CMFD_BALANCE  = 15 ! unit # for writing cmfd balance file
-  integer, parameter :: UNIT_PARTICLE = 16 ! unit # for writing particle restart
-  integer, parameter :: UNIT_OUTPUT   = 17 ! unit # for writing output
+  integer, parameter :: UNIT_PARTICLE = 15 ! unit # for writing particle restart
+  integer, parameter :: UNIT_OUTPUT   = 16 ! unit # for writing output
 
   !=============================================================================
   ! CMFD CONSTANTS

src/cross_section.F90

@@ -93,6 +93,8 @@ contains
       ! Calculate microscopic cross section for this nuclide
       if (p % E /= micro_xs(i_nuclide) % last_E) then
         call calculate_nuclide_xs(i_nuclide, i_sab, p % E)
+      else if (i_sab /= micro_xs(i_nuclide) % last_index_sab) then
+        call calculate_nuclide_xs(i_nuclide, i_sab, p % E)
       end if
 
       ! ========================================================================
@@ -235,13 +237,8 @@ contains
       end if
     end if
 
-    ! Set last evaluated energy -- if we're in S(a,b) region, force
-    ! re-calculation of cross-section
-    if (i_sab == 0) then
-      micro_xs(i_nuclide) % last_E = E
-    else
-      micro_xs(i_nuclide) % last_E = ZERO
-    end if
+    micro_xs(i_nuclide) % last_E = E
+    micro_xs(i_nuclide) % last_index_sab = i_sab
 
   end subroutine calculate_nuclide_xs
 

src/doppler.F90

@@ -87,7 +87,7 @@ contains
        ! =======================================================================
        ! EXTEND CROSS SECTION TO 0 ASSUMING 1/V SHAPE
 
-       if (k == 1 .and. a >= 4.0) then
+       if (k == 1 .and. a >= -4.0) then
           ! Since x = 0, this implies that a = -y
           F_b = F_a
           a = -y
@@ -101,7 +101,7 @@ contains
        end if
 
        ! =======================================================================
-       ! EVALUATE FIRST TERM FROM x(k) - y = 0 to -4
+       ! EVALUATE FIRST TERM FROM x(k) - y = 0 to 4
 
        k = i
        b = ZERO

src/eigenvalue.F90

@@ -44,7 +44,7 @@ contains
     if (master) call header("K EIGENVALUE SIMULATION", level=1)
 
     ! Display column titles
-    call print_columns()
+    if(master) call print_columns()
 
     ! Turn on inactive timer
     call time_inactive % start()

src/finalize.F90

@@ -1,8 +1,5 @@
 module finalize
 
-# ifdef PETSC
-  use cmfd_output,    only: finalize_cmfd
-# endif
   use global
   use output,         only: print_runtime, print_results, &
                             print_overlap_check, write_tallies
@@ -42,11 +39,11 @@ contains
     end if
 
 #ifdef PETSC
-    ! finalize cmfd
-    if (cmfd_run) call finalize_cmfd()
+    ! Finalize PETSc
+    if (cmfd_run) call PetscFinalize(mpi_err)
 #endif
 
-    ! stop timers and show timing statistics
+    ! Stop timers and show timing statistics
     call time_finalize % stop()
     call time_total % stop()
     if (master .and. (run_mode /= MODE_PLOTTING .and. &
@@ -56,7 +53,7 @@ contains
       if (check_overlaps) call print_overlap_check()
     end if
 
-    ! deallocate arrays
+    ! Deallocate arrays
     call free_memory()
 
 #ifdef HDF5

src/global.F90

@@ -15,10 +15,6 @@ module global
   use tally_header,     only: TallyObject, TallyMap, TallyResult
   use timer_header,     only: Timer
 
-#ifdef MPI
-  use mpi
-#endif
-
 #ifdef HDF5
   use hdf5_interface,  only: HID_T
 #endif
@@ -287,6 +283,10 @@ module global
   integer    :: trace_gen
   integer(8) :: trace_particle
 
+  ! Particle tracks
+  logical :: write_all_tracks = .false.
+  integer, allocatable :: track_identifiers(:,:)
+
   ! Particle restart run
   logical :: particle_restart_run = .false.
 
@@ -300,80 +300,64 @@ module global
   logical :: cmfd_run = .false.
  
   ! Timing objects
-  type(Timer) :: time_cmfd   ! timer for whole cmfd calculation
-  type(Timer) :: time_solver ! timer for solver 
+  type(Timer) :: time_cmfd      ! timer for whole cmfd calculation
+  type(Timer) :: time_cmfdbuild ! timer for matrix build
+  type(Timer) :: time_cmfdsolve ! timer for solver 
 
-  ! Flag for CMFD only
-  logical :: cmfd_only = .false.
-
-  ! Flag for coremap accelerator
+  ! Flag for active core map
   logical :: cmfd_coremap = .false.
 
-  ! number of processors for cmfd
-  integer :: n_procs_cmfd
-
-  ! reset dhats to zero
+  ! Flag to reset dhats to zero
   logical :: dhat_reset = .false.
 
-  ! activate neutronic feedback
+  ! Flag to activate neutronic feedback via source weights
   logical :: cmfd_feedback = .false.
 
-  ! activate auto-balance of tallies (2grp only)
-! logical :: cmfd_balance = .false.
+  ! User-defined tally information
+  integer :: n_cmfd_meshes  = 1 ! # of structured meshes
+  integer :: n_cmfd_tallies = 3 ! # of user-defined tallies
 
-  ! calculate effective downscatter
-! logical :: cmfd_downscatter = .false.
-
-  ! user-defined tally information
-  integer :: n_cmfd_meshes              = 1 ! # of structured meshes
-  integer :: n_cmfd_tallies             = 3 ! # of user-defined tallies
-
-  ! overwrite with 2grp xs
-  logical :: cmfd_run_2grp = .false.
-
-  ! hold cmfd weight adjustment factors
+  ! Flag to hold cmfd weight adjustment factors
   logical :: cmfd_hold_weights = .false.
 
-  ! eigenvalue solver type
+  ! Eigenvalue solver type
   character(len=10) :: cmfd_solver_type = 'power'
 
-  ! adjoint method type
+  ! Adjoint method type
   character(len=10) :: cmfd_adjoint_type = 'physical'
 
-  ! number of incomplete ilu factorization levels
+  ! Number of incomplete ilu factorization levels
   integer :: cmfd_ilu_levels = 1
 
-  ! batch to begin cmfd
+  ! Batch to begin cmfd
   integer :: cmfd_begin = 1
 
-  ! when and how long to flush cmfd tallies during inactive batches
+  ! When and how long to flush cmfd tallies during inactive batches
   integer :: cmfd_inact_flush(2) = (/9999,1/)
 
-  ! batch to last flush before active batches
+  ! Batch to last flush before active batches
   integer :: cmfd_act_flush = 0
 
-  ! compute effective downscatter cross section
+  ! Compute effective downscatter cross section
   logical :: cmfd_downscatter = .false.
 
-  ! convergence monitoring
+  ! Convergence monitoring
   logical :: cmfd_snes_monitor  = .false.
   logical :: cmfd_ksp_monitor   = .false.
   logical :: cmfd_power_monitor = .false.
 
-  ! cmfd output
-  logical :: cmfd_write_balance  = .false.
+  ! Cmfd output
   logical :: cmfd_write_matrices = .false.
-  logical :: cmfd_write_hdf5     = .false.
 
-  ! run an adjoint calculation (last batch only)
+  ! Run an adjoint calculation (last batch only)
   logical :: cmfd_run_adjoint = .false.
 
-  ! cmfd run logicals
+  ! CMFD run logicals
   logical :: cmfd_on             = .false.
   logical :: cmfd_tally_on       = .true. 
 
-  ! tolerance on keff to run cmfd
-  real(8) :: cmfd_keff_tol = 0.005_8
+  ! CMFD display info
+  character(len=25) :: cmfd_display
 
   ! Information about state points to be written
   integer :: n_state_points = 0
@@ -463,7 +447,7 @@ contains
     ! Deallocate array of work indices
     if (allocated(work_index)) deallocate(work_index)
 
-    ! Deallocate cmfd
+    ! Deallocate CMFD
     call deallocate_cmfd(cmfd)
 
     ! Deallocate tally node lists
@@ -471,6 +455,9 @@ contains
     call active_tracklength_tallies % clear()
     call active_current_tallies % clear()
     call active_tallies % clear()
+
+    ! Deallocate track_identifiers
+    if (allocated(track_identifiers)) deallocate(track_identifiers)
     
     ! Deallocate dictionaries
     call cell_dict % clear()

src/hdf5_summary.F90

@@ -100,6 +100,7 @@ contains
 
     integer          :: i, j, k, m
     integer          :: n_x, n_y, n_z
+    integer          :: length(3)
     integer, allocatable :: lattice_universes(:,:,:)
     type(Cell),     pointer :: c => null()
     type(Surface),  pointer :: s => null()
@@ -312,8 +313,8 @@ contains
           end do
         end do
       end do
-      call su % write_data(lattice_universes, "universes", &
-           length=(/n_x, n_y, n_z/), &
+      length = [n_x, n_y, n_z]
+      call su % write_data(lattice_universes, "universes", length=length, &
            group="geometry/lattices/lattice " // trim(to_str(lat % id)))
       deallocate(lattice_universes)
 

src/initialize.F90

@@ -394,6 +394,9 @@ contains
         case ('-eps_tol', '-ksp_gmres_restart')
           ! Handle options that would be based to PETSC
           i = i + 1
+        case ('-t', '-track', '--track')
+          write_all_tracks = .true.
+          i = i + 1
         case default
           message = "Unknown command line option: " // argv(i)
           call fatal_error()

src/matrix_header.F90

@@ -0,0 +1,358 @@
+module matrix_header
+
+#ifdef PETSC
+  use petscmat
+#endif
+
+  implicit none
+  private
+
+  type, public :: Matrix
+    integer :: n        ! number of rows/cols in matrix
+    integer :: nnz      ! number of nonzeros in matrix
+    integer :: n_count  ! counter for length of matrix
+    integer :: nz_count ! counter for number of non zeros
+    integer, allocatable :: row(:) ! csr row vector
+    integer, allocatable :: col(:) ! column vector
+    real(8), allocatable :: val(:) ! matrix value vector
+#  ifdef PETSC
+    type(mat) :: petsc_mat
+#  endif
+    logical :: petsc_active
+   contains
+     procedure :: create       => matrix_create
+     procedure :: destroy      => matrix_destroy
+     procedure :: add_value    => matrix_add_value
+     procedure :: new_row      => matrix_new_row
+     procedure :: assemble     => matrix_assemble
+     procedure :: get_row      => matrix_get_row
+     procedure :: get_col      => matrix_get_col
+     procedure :: setup_petsc        => matrix_setup_petsc
+     procedure :: write_petsc_binary => matrix_write_petsc_binary
+     procedure :: transpose          => matrix_transpose
+     procedure :: vector_multiply    => matrix_vector_multiply
+  end type matrix
+
+  integer :: petsc_err
+
+contains
+
+!===============================================================================
+! MATRIX_CREATE allocates CSR vectors
+!===============================================================================
+
+  subroutine matrix_create(self, n, nnz)
+
+    integer, intent(in) :: n             ! dimension of matrix
+    integer, intent(in) :: nnz           ! number of nonzeros
+    class(Matrix), intent(inout) :: self ! matrix instance
+
+    ! Preallocate vectors
+    if (.not.allocated(self % row)) allocate(self % row(n+1))
+    if (.not.allocated(self % col)) allocate(self % col(nnz))
+    if (.not.allocated(self % val)) allocate(self % val(nnz))
+
+    ! Set counters to 1
+    self % n_count  = 1
+    self % nz_count = 1
+
+    ! Set n and nnz
+    self % n = n
+    self % nnz = nnz
+
+    ! Set PETSc active by default to false
+    self % petsc_active = .false.
+
+  end subroutine matrix_create
+
+!===============================================================================
+! MATRIX_DESTROY deallocates all space associated with a matrix
+!===============================================================================
+
+  subroutine matrix_destroy(self)
+
+    class(Matrix), intent(inout) :: self ! matrix instance
+
+#ifdef PETSC
+    if (self % petsc_active) call MatDestroy(self % petsc_mat, petsc_err)
+#endif
+
+    if (allocated(self % row)) deallocate(self % row)
+    if (allocated(self % col)) deallocate(self % col)
+    if (allocated(self % val)) deallocate(self % val)
+
+  end subroutine matrix_destroy
+
+!===============================================================================
+! MATRIX_ADD_VALUE adds a value to the matrix
+!===============================================================================
+
+  subroutine matrix_add_value(self, col, val)
+
+    integer, intent(in) :: col           ! col location in matrix
+    real(8), intent(in) :: val           ! value to store in matrix
+    class(Matrix), intent(inout) :: self ! matrix instance
+
+    ! Record the data
+    self % col(self % nz_count) = col
+    self % val(self % nz_count) = val
+
+    ! Need to adjust column indices if PETSc is active
+    if (self % petsc_active) self % col(self % nz_count) = &
+                             self % col(self % nz_count) - 1
+
+    ! Increment the number of nonzeros currently stored
+    self % nz_count = self % nz_count + 1
+
+  end subroutine matrix_add_value
+
+!===============================================================================
+! MATRIX_NEW_ROW adds a new row by saving the column position of the new row
+!===============================================================================
+
+  subroutine matrix_new_row(self)
+
+    class(Matrix), intent(inout) :: self ! matrix instance
+
+    ! Record the current number of nonzeros
+    self % row(self % n_count) = self % nz_count
+
+    ! If PETSc is active, we have to reference indices off 0
+    if (self % petsc_active) self % row(self % n_count) = &
+                             self % row(self % n_count) - 1
+
+    ! Increment the current row that we are on
+    self % n_count = self % n_count + 1
+
+  end subroutine matrix_new_row
+
+!===============================================================================
+! MATRIX_ASSEMBLE main rountine to sort all the columns in CSR matrix
+!===============================================================================
+
+  subroutine matrix_assemble(self)
+
+    class(Matrix), intent(inout) :: self ! matrix instance
+
+    integer :: i
+    integer :: first
+    integer :: last
+
+    ! Loop around row vector
+    do i = 1, self % n
+
+      ! Get bounds
+      first = self % row(i)
+      last  = self % row(i+1) - 1
+
+      ! Sort a row
+      call sort_csr(self % col, self % val, first, last)
+
+    end do
+
+  end subroutine matrix_assemble
+
+!===============================================================================
+! SORT_CSR main routine that performs a sort on a CSR col/val subvector
+!===============================================================================
+
+  recursive subroutine sort_csr(col, val, first, last)
+
+    integer :: col(:) ! column vector to sort
+    integer :: first  ! first value in sort
+    integer :: last   ! last value in sort
+    real(8) :: val(:) ! value vector to be sorted like columns
+
+    integer :: mid ! midpoint value
+
+    if (first < last) then
+      call split(col, val, first, last, mid)
+      call sort_csr(col, val, first, mid-1)
+      call sort_csr(col, val, mid+1, last)
+    end if
+
+  end subroutine sort_csr
+
+!===============================================================================
+! SPLIT bisects the search space for the sorting routine
+!===============================================================================
+
+  subroutine split(col, val, low, high, mid)
+
+    integer :: col(:) ! column vector to sort
+    integer :: low    ! low index to sort
+    integer :: high   ! high index to sort
+    integer :: mid    ! middle of sort
+    real(8) :: val(:) ! value vector to be sorted like columns
+
+    integer :: left  ! contains left value in sort
+    integer :: right ! contains right value in sort
+    integer :: iswap ! temporary interger swap
+    integer :: pivot ! pivotting variable for columns
+    real(8) :: rswap ! temporary real swap
+    real(8) :: val0  ! pivot for value vector
+
+    left = low
+    right = high
+    pivot = col(low)
+    val0 = val(low)
+
+    ! Repeat the following while left and right havent met
+    do while (left < right)
+
+      ! Scan right to left to find element < pivot
+      do while (left < right .and. col(right) >= pivot)
+        right = right - 1
+      end do
+
+      ! Scan left to right to find element > pivot
+      do while (left < right .and. col(left) <= pivot)
+        left = left + 1
+      end do
+
+      ! If left and right havent met, exchange the items
+      if (left < right) then
+        iswap = col(left)
+        col(left) = col(right)
+        col(right) = iswap
+        rswap = val(left)
+        val(left) = val(right)
+        val(right) = rswap
+      end if
+
+    end do
+
+    ! Switch the element in split position with pivot
+    col(low) = col(right)
+    col(right) = pivot
+    mid = right
+    val(low) = val(right)
+    val(right) = val0
+
+  end subroutine split
+
+!===============================================================================
+! MATRIX_GET_ROW is a method to get row and checks for PETSc C indexing use
+!===============================================================================
+
+  function matrix_get_row(self, i) result(row)
+
+    class(Matrix), intent(in) :: self ! matrix instance
+    integer, intent(in)       :: i    ! row to get
+    integer                   :: row  ! index in col where row begins
+
+    row = self % row(i)
+
+    if (self % petsc_active) row = row + 1
+
+  end function matrix_get_row
+
+!===============================================================================
+! MATRIX_GET_COL is a method to get column and checks for PETSc C index use
+!===============================================================================
+
+  function matrix_get_col(self, i) result(col)
+
+    class(Matrix), intent(in) :: self ! matrix instance
+    integer, intent(in)       :: i    ! index from row vector
+    integer                   :: col  ! the actual column
+
+    col = self % col(i)
+
+    if (self % petsc_active) col = col + 1
+
+  end function matrix_get_col
+
+!===============================================================================
+! MATRIX_SETUP_PETSC configures the row/col vectors and links to a PETSc object
+!===============================================================================
+
+  subroutine matrix_setup_petsc(self)
+
+    class(Matrix), intent(inout) :: self ! matrix instance
+
+    ! change indices to c notation
+    self % row = self % row - 1
+    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
+
+!===============================================================================
+! MATRIX_WRITE_PETSC_BINARY writes a PETSc matrix binary file
+!===============================================================================
+
+  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
+
+!===============================================================================
+! MATRIX_TRANSPOSE uses PETSc to transpose a matrix
+!===============================================================================
+
+  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
+
+!===============================================================================
+! MATRIX_VECTOR_MULTIPLY allow a vector to multiply the matrix
+!===============================================================================
+
+  subroutine matrix_vector_multiply(self, vec_in, vec_out)
+
+    use constants,      only: ZERO
+    use vector_header,  only: Vector
+
+    class(Matrix), intent(in)   :: self    ! matrix instance
+    type(Vector), intent(in)    :: vec_in  ! vector to multiply matrix against
+    type(Vector), intent(inout) :: vec_out ! resulting vector
+
+    integer :: i ! row iteration counter
+    integer :: j ! column iteration counter
+
+    ! Begin loop around rows
+    ROWS: do i = 1, self % n
+
+      ! Initialize target location in vector
+      vec_out % val(i) = ZERO
+
+      ! Begin loop around columns
+      COLS: do j = self % get_row(i), self % get_row(i + 1) - 1
+
+        vec_out % val(i) = vec_out % val(i) + self % val(j) * &
+                           vec_in % val(self % get_col(j))
+
+      end do COLS
+
+    end do ROWS
+
+  end subroutine matrix_vector_multiply
+
+end module matrix_header

src/output.F90

@@ -31,6 +31,10 @@ contains
 
   subroutine title()
 
+#ifdef OPENMP
+    use omp_lib
+#endif
+
     write(UNIT=OUTPUT_UNIT, FMT='(/11(A/))') &
          '       .d88888b.                             888b     d888  .d8888b.', &
          '      d88P" "Y88b                            8888b   d8888 d88P  Y88b', &
@@ -46,25 +50,31 @@ contains
 
     ! Write version information
     write(UNIT=OUTPUT_UNIT, FMT=*) &
-         '     Copyright:     2011-2013 Massachusetts Institute of Technology'
+         '     Copyright:      2011-2013 Massachusetts Institute of Technology'
     write(UNIT=OUTPUT_UNIT, FMT=*) &
-         '     License:       http://mit-crpg.github.io/openmc/license.html'
-    write(UNIT=OUTPUT_UNIT, FMT='(6X,"Version:",7X,I1,".",I1,".",I1)') &
+         '     License:        http://mit-crpg.github.io/openmc/license.html'
+    write(UNIT=OUTPUT_UNIT, FMT='(6X,"Version:",8X,I1,".",I1,".",I1)') &
          VERSION_MAJOR, VERSION_MINOR, VERSION_RELEASE
 #ifdef GIT_SHA1
-    write(UNIT=OUTPUT_UNIT, FMT='(6X,"Git SHA1:",6X,A)') GIT_SHA1
+    write(UNIT=OUTPUT_UNIT, FMT='(6X,"Git SHA1:",7X,A)') GIT_SHA1
 #endif
 
     ! Write the date and time
-    write(UNIT=OUTPUT_UNIT, FMT='(6X,"Date/Time:",5X,A)') &
+    write(UNIT=OUTPUT_UNIT, FMT='(6X,"Date/Time:",6X,A)') &
          time_stamp()
 
 #ifdef MPI
     ! Write number of processors
-    write(UNIT=OUTPUT_UNIT, FMT='(6X,"MPI Processes:",1X,A)') &
+    write(UNIT=OUTPUT_UNIT, FMT='(6X,"MPI Processes:",2X,A)') &
          trim(to_str(n_procs))
 #endif
 
+#ifdef OPENMP
+    ! Write number of OpenMP threads
+    write(UNIT=OUTPUT_UNIT, FMT='(6X,"OpenMP Threads:",1X,A)') &
+         trim(to_str(omp_get_max_threads()))
+#endif
+
   end subroutine title
 
 !===============================================================================
@@ -126,7 +136,7 @@ contains
     ! print header based on level
     select case (header_level)
     case (1)
-      write(UNIT=unit_, FMT='(/3(1X,A/))') repeat('=', 75), & 
+      write(UNIT=unit_, FMT='(/3(1X,A/))') repeat('=', 75), &
            repeat('=', n) // '>     ' // trim(line) // '     <' // &
            repeat('=', m), repeat('=', 75)
     case (2)
@@ -172,6 +182,7 @@ contains
       write(OUTPUT_UNIT,*) '  -r, --restart          Restart a previous run from a state point'
       write(OUTPUT_UNIT,*) '                         or a particle restart file'
       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'
     end if
@@ -179,7 +190,7 @@ contains
   end subroutine print_usage
 
 !===============================================================================
-! WRITE_MESSAGE displays an informational message to the log file and the 
+! WRITE_MESSAGE displays an informational message to the log file and the
 ! standard output stream.
 !===============================================================================
 
@@ -214,7 +225,7 @@ contains
           ! Determine last space in current line
           last_space = index(message(i_start+1:i_start+line_wrap), &
                ' ', BACK=.true.)
-          if (last_space == 0) then 
+          if (last_space == 0) then
             i_end = min(length + 1, i_start+line_wrap) - 1
             write(ou, fmt='(1X,A)') message(i_start+1:i_end)
           else
@@ -1027,8 +1038,10 @@ contains
     type(SAlphaBeta), pointer :: sab
     integer,         optional :: unit
 
-    integer :: size_sab ! memory used by S(a,b) table
-    integer :: unit_    ! unit to write to
+    integer :: size_sab   ! memory used by S(a,b) table
+    integer :: unit_      ! unit to write to
+    integer :: i          ! Loop counter for parsing through sab % zaid
+    integer :: char_count ! Counter for the number of characters on a line
 
     ! set default unit for writing information
     if (present(unit)) then
@@ -1039,7 +1052,30 @@ contains
 
     ! Basic S(a,b) table information
     write(unit_,*) 'S(a,b) Table ' // trim(sab % name)
-    write(unit_,*) '  zaid = ' // trim(to_str(sab % zaid))
+    write(unit_,'(A)',advance="no") '   zaids = '
+    ! Initialize the counter based on the above string
+    char_count = 11
+    do i = 1, sab % n_zaid
+      ! Deal with a line thats too long
+      if (char_count >= 73) then  ! 73 = 80 - (5 ZAID chars + 1 space + 1 comma)
+        ! End the line
+        write(unit_,*) ""
+        ! Add 11 leading blanks
+        write(unit_,'(A)', advance="no") "           "
+        ! reset the counter to 11
+        char_count = 11
+      end if
+      if (i < sab % n_zaid) then
+        ! Include a comma
+        write(unit_,'(A)',advance="no") trim(to_str(sab % zaid(i))) // ", "
+        char_count = char_count + len(trim(to_str(sab % zaid(i)))) + 2
+      else
+        ! Don't include a comma, since we are all done
+        write(unit_,'(A)',advance="no") trim(to_str(sab % zaid(i)))
+      end if
+
+    end do
+    write(unit_,*) "" ! Move to next line
     write(unit_,*) '  awr = ' // trim(to_str(sab % awr))
     write(unit_,*) '  kT = ' // trim(to_str(sab % kT))
 
@@ -1223,37 +1259,40 @@ contains
 
   subroutine print_columns()
 
-    if (entropy_on) then
-      if (cmfd_run) then
-        message = " Bat./Gen.      k       Entropy         Average k          CMFD k    CMFD Ent"
-        call write_message(1)
-        message = " =========   ========   ========   ====================   ========   ========"
-        call write_message(1)
-      else
-        message = " Bat./Gen.      k       Entropy         Average k"
-        call write_message(1)
-        message = " =========   ========   ========   ===================="
-        call write_message(1)
-      end if
-    else
-      if (cmfd_run) then
-        message = " Bat./Gen.      k            Average k          CMFD k"
-        call write_message(1)
-        message = " =========   ========   ====================   ========"
-        call write_message(1)
-      else
-        message = " Bat./Gen.      k            Average k"
-        call write_message(1)
-        message = " =========   ========   ===================="
-        call write_message(1)
-      end if
+    write(UNIT=ou, FMT='(2X,A9,3X)', ADVANCE='NO') "Bat./Gen."
+    write(UNIT=ou, FMT='(A8,3X)', ADVANCE='NO') "   k    "
+    if (entropy_on) write(UNIT=ou, FMT='(A8,3X)', ADVANCE='NO') "Entropy "
+    write(UNIT=ou, FMT='(A20,3X)', ADVANCE='NO') "     Average k      "
+    if (cmfd_run) then
+      write(UNIT=ou, FMT='(A8,3X)', ADVANCE='NO') " CMFD k "
+      select case(trim(cmfd_display))
+        case('entropy')
+          write(UNIT=ou, FMT='(A8,3X)', ADVANCE='NO') "CMFD Ent"
+        case('balance')
+          write(UNIT=ou, FMT='(A8,3X)', ADVANCE='NO') "RMS Bal "
+        case('source')
+          write(UNIT=ou, FMT='(A8,3X)', ADVANCE='NO') "RMS Src "
+        case('dominance')
+          write(UNIT=ou, FMT='(A8,3X)', ADVANCE='NO') "Dom Rat "
+      end select
     end if
+    write(UNIT=ou, FMT=*)
+
+    write(UNIT=ou, FMT='(2X,A9,3X)', ADVANCE='NO') "========="
+    write(UNIT=ou, FMT='(A8,3X)', ADVANCE='NO') "========"
+    if (entropy_on) write(UNIT=ou, FMT='(A8,3X)', ADVANCE='NO') "========"
+    write(UNIT=ou, FMT='(A20,3X)', ADVANCE='NO') "===================="
+    if (cmfd_run) then
+      write(UNIT=ou, FMT='(A8,3X)', ADVANCE='NO') "========"
+      if (cmfd_display /= '') &
+        write(UNIT=ou, FMT='(A8,3X)', ADVANCE='NO') "========"
+    end if
+    write(UNIT=ou, FMT=*)
 
   end subroutine print_columns
 
 !===============================================================================
-! PRINT_GENERATION displays information for a generation of neutrons. For now,
-! if the user has entropy on, it will print out the entropy
+! PRINT_GENERATION displays information for a generation of neutrons.
 !===============================================================================
 
   subroutine print_generation()
@@ -1268,7 +1307,7 @@ contains
     if (entropy_on) write(UNIT=OUTPUT_UNIT, FMT='(3X, F8.5)', ADVANCE='NO') &
          entropy(overall_gen)
 
-    if (overall_gen - n_inactive*gen_per_batch > 1) then 
+    if (overall_gen - n_inactive*gen_per_batch > 1) then
       write(UNIT=OUTPUT_UNIT, FMT='(3X, F8.5," +/-",F8.5)', ADVANCE='NO') &
            keff, keff_std
     end if
@@ -1296,21 +1335,32 @@ contains
          entropy(current_batch*gen_per_batch)
 
     ! write out accumulated k-effective if after first active batch
-    if (overall_gen - n_inactive*gen_per_batch > 1) then 
+    if (overall_gen - n_inactive*gen_per_batch > 1) then
       write(UNIT=OUTPUT_UNIT, FMT='(3X, F8.5," +/-",F8.5)', ADVANCE='NO') &
            keff, keff_std
     else
       write(UNIT=OUTPUT_UNIT, FMT='(23X)', ADVANCE='NO')
     end if
 
-
-    ! write out cmfd keff if it is active
-    if (cmfd_on) write(UNIT=OUTPUT_UNIT, FMT='(3X, F8.5)', ADVANCE='NO') &
-         cmfd % keff 
-
-    ! write out cmfd entopy
-    if (cmfd_on .and. entropy_on) write(UNIT=OUTPUT_UNIT, &
-         FMT='(3X, F8.5)', ADVANCE='NO') cmfd % entropy
+    ! write out cmfd keff if it is active and other display info
+    if (cmfd_on) then
+      write(UNIT=OUTPUT_UNIT, FMT='(3X, F8.5)', ADVANCE='NO') &
+         cmfd % k_cmfd(current_batch)
+      select case(trim(cmfd_display))
+        case('entropy')
+          write(UNIT=OUTPUT_UNIT, FMT='(3X, F8.5)', ADVANCE='NO') &
+            cmfd % entropy(current_batch)
+        case('balance')
+          write(UNIT=OUTPUT_UNIT, FMT='(3X, F8.5)', ADVANCE='NO') &
+            cmfd % balance(current_batch)
+        case('source')
+          write(UNIT=OUTPUT_UNIT, FMT='(3X, F8.5)', ADVANCE='NO') &
+            cmfd % src_cmp(current_batch)
+        case('dominance')
+          write(UNIT=OUTPUT_UNIT, FMT='(3X, F8.5)', ADVANCE='NO') &
+            cmfd % dom(current_batch)
+      end select
+    end if
 
     ! next line
     write(UNIT=OUTPUT_UNIT, FMT=*)
@@ -1334,7 +1384,7 @@ contains
 
       ! Plot id
       write(ou,100) "Plot ID:", trim(to_str(pl % id))
-      
+
       ! Plot type
       if (pl % type == PLOT_TYPE_SLICE) then
         write(ou,100) "Plot Type:", "Slice"
@@ -1372,7 +1422,7 @@ contains
              trim(to_str(pl % pixels(2)))
       else if (pl % type == PLOT_TYPE_VOXEL) then
         write(ou,100) "Voxels:", trim(to_str(pl % pixels(1))) // " " // &
-             trim(to_str(pl % pixels(2))) // " " // trim(to_str(pl % pixels(3))) 
+             trim(to_str(pl % pixels(2))) // " " // trim(to_str(pl % pixels(3)))
       end if
 
       write(ou,*)
@@ -1405,13 +1455,17 @@ contains
     write(ou,100) "Total time in simulation", time_inactive % elapsed + &
          time_active % elapsed
     write(ou,100) "  Time in transport only", time_transport % elapsed
-    if(cmfd_run) write(ou,100) "Total CMFD time", time_cmfd % elapsed
     write(ou,100) "  Time in inactive batches", time_inactive % elapsed
     write(ou,100) "  Time in active batches", time_active % elapsed
     write(ou,100) "  Time synchronizing fission bank", time_bank % elapsed
     write(ou,100) "    Sampling source sites", time_bank_sample % elapsed
     write(ou,100) "    SEND/RECV source sites", time_bank_sendrecv % elapsed
     write(ou,100) "  Time accumulating tallies", time_tallies % elapsed
+    if (cmfd_run) write(ou,100) "  Time in CMFD", time_cmfd % elapsed
+    if (cmfd_run) write(ou,100) "    Building matrices", &
+                  time_cmfdbuild % elapsed
+    if (cmfd_run) write(ou,100) "    Solving matrices", &
+                  time_cmfdsolve % elapsed
     write(ou,100) "Total time for finalization", time_finalize % elapsed
     write(ou,100) "Total time elapsed", time_total % elapsed
 
@@ -1520,7 +1574,7 @@ contains
 
     write(ou,100) 'Cell ID','No. Overlap Checks'
 
-    do i = 1, n_cells    
+    do i = 1, n_cells
       write(ou,101) cells(i) % id, overlap_check_cnt(i)
       if (overlap_check_cnt(i) < 10) num_sparse = num_sparse + 1
     end do
@@ -1554,7 +1608,7 @@ contains
     integer :: k            ! loop index for scoring bins
     integer :: n            ! loop index for nuclides
     integer :: l            ! loop index for user scores
-    integer :: type         ! type of tally filter        
+    integer :: type         ! type of tally filter
     integer :: indent       ! number of spaces to preceed output
     integer :: filter_index ! index in results array for filters
     integer :: score_index  ! scoring bin index
@@ -1730,13 +1784,13 @@ contains
                 score_name = 'P' // trim(to_str(t % scatt_order(k))) // &
                   ' Scattering Moment'
               end if
-              write(UNIT=UNIT_TALLY, FMT='(1X,2A,1X,A,"+/- ",A)') & 
+              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)') & 
+              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))
@@ -1744,7 +1798,7 @@ contains
                 score_index = score_index + 1
                 score_name = 'P' // trim(to_str(n_order)) // &
                   ' Scattering Moment'
-                write(UNIT=UNIT_TALLY, FMT='(1X,2A,1X,A,"+/- ",A)') & 
+                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))
@@ -1756,7 +1810,7 @@ contains
               else
                 score_name = score_names(abs(t % score_bins(k)))
               end if
-              write(UNIT=UNIT_TALLY, FMT='(1X,2A,1X,A,"+/- ",A)') & 
+              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))
@@ -1794,8 +1848,8 @@ contains
     integer :: i_filter_ein         ! index for incoming energy filter
     integer :: i_filter_surf        ! index for surface filter
     integer :: n                    ! number of incoming energy bins
-    integer :: len1                 ! length of string 
-    integer :: len2                 ! length of string 
+    integer :: len1                 ! length of string
+    integer :: len2                 ! length of string
     integer :: filter_index         ! index in results array for filters
     logical :: print_ebin           ! should incoming energy bin be displayed?
     character(MAX_LINE_LEN) :: string
@@ -1845,14 +1899,14 @@ contains
                  mesh_indices_to_bin(m, (/ i-1, j, k /) + 1, .true.)
             matching_bins(i_filter_surf) = IN_RIGHT
             filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1
-            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & 
+            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') &
                  "Outgoing Current to Left", &
                  to_str(t % results(1,filter_index) % sum), &
                  trim(to_str(t % results(1,filter_index) % sum_sq))
 
             matching_bins(i_filter_surf) = OUT_RIGHT
             filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1
-            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & 
+            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') &
                  "Incoming Current from Left", &
                  to_str(t % results(1,filter_index) % sum), &
                  trim(to_str(t % results(1,filter_index) % sum_sq))
@@ -1862,14 +1916,14 @@ contains
                  mesh_indices_to_bin(m, (/ i, j, k /) + 1, .true.)
             matching_bins(i_filter_surf) = IN_RIGHT
             filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1
-            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & 
+            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') &
                  "Incoming Current from Right", &
                  to_str(t % results(1,filter_index) % sum), &
                  trim(to_str(t % results(1,filter_index) % sum_sq))
 
             matching_bins(i_filter_surf) = OUT_RIGHT
             filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1
-            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & 
+            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') &
                  "Outgoing Current to Right", &
                  to_str(t % results(1,filter_index) % sum), &
                  trim(to_str(t % results(1,filter_index) % sum_sq))
@@ -1879,14 +1933,14 @@ contains
                  mesh_indices_to_bin(m, (/ i, j-1, k /) + 1, .true.)
             matching_bins(i_filter_surf) = IN_FRONT
             filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1
-            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & 
+            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') &
                  "Outgoing Current to Back", &
                  to_str(t % results(1,filter_index) % sum), &
                  trim(to_str(t % results(1,filter_index) % sum_sq))
 
             matching_bins(i_filter_surf) = OUT_FRONT
             filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1
-            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & 
+            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') &
                  "Incoming Current from Back", &
                  to_str(t % results(1,filter_index) % sum), &
                  trim(to_str(t % results(1,filter_index) % sum_sq))
@@ -1896,14 +1950,14 @@ contains
                  mesh_indices_to_bin(m, (/ i, j, k /) + 1, .true.)
             matching_bins(i_filter_surf) = IN_FRONT
             filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1
-            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & 
+            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') &
                  "Incoming Current from Front", &
                  to_str(t % results(1,filter_index) % sum), &
                  trim(to_str(t % results(1,filter_index) % sum_sq))
 
             matching_bins(i_filter_surf) = OUT_FRONT
             filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1
-            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & 
+            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') &
                  "Outgoing Current to Front", &
                  to_str(t % results(1,filter_index) % sum), &
                  trim(to_str(t % results(1,filter_index) % sum_sq))
@@ -1913,14 +1967,14 @@ contains
                  mesh_indices_to_bin(m, (/ i, j, k-1 /) + 1, .true.)
             matching_bins(i_filter_surf) = IN_TOP
             filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1
-            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & 
+            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') &
                  "Outgoing Current to Bottom", &
                  to_str(t % results(1,filter_index) % sum), &
                  trim(to_str(t % results(1,filter_index) % sum_sq))
 
             matching_bins(i_filter_surf) = OUT_TOP
             filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1
-            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & 
+            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') &
                  "Incoming Current from Bottom", &
                  to_str(t % results(1,filter_index) % sum), &
                  trim(to_str(t % results(1,filter_index) % sum_sq))
@@ -1930,14 +1984,14 @@ contains
                  mesh_indices_to_bin(m, (/ i, j, k /) + 1, .true.)
             matching_bins(i_filter_surf) = IN_TOP
             filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1
-            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & 
+            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') &
                  "Incoming Current from Top", &
                  to_str(t % results(1,filter_index) % sum), &
                  trim(to_str(t % results(1,filter_index) % sum_sq))
 
             matching_bins(i_filter_surf) = OUT_TOP
             filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1
-            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & 
+            write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') &
                  "Outgoing Current to Top", &
                  to_str(t % results(1,filter_index) % sum), &
                  trim(to_str(t % results(1,filter_index) % sum_sq))

src/output_interface.F90

@@ -1644,6 +1644,12 @@ contains
     call h5dclose_f(dset, hdf5_err)
     if (present(group)) call hdf5_close_group(self % hdf5_grp)
 
+# elif MPI
+
+    ! Write out tally buffer
+    call MPI_FILE_READ(self % unit_fh, buffer, n1*n2, MPI_TALLYRESULT, &
+         MPI_STATUS_IGNORE, mpiio_err)
+
 #else
 
     ! Read tally result

src/particle_header.F90

@@ -76,6 +76,9 @@ module particle_header
     ! Statistical data
     integer    :: n_collision   ! # of collisions
 
+    ! Track output
+    logical    :: write_track = .false.
+
   contains
     procedure :: initialize => initialize_particle
     procedure :: clear => clear_particle

src/physics.F90

@@ -47,7 +47,7 @@ contains
     if (verbosity >= 10 .or. trace) then
       message = "    " // trim(reaction_name(p % event_MT)) // " with " // &
            trim(adjustl(nuclides(p % event_nuclide) % name)) // &
-           ". Energy = " // trim(to_str(p % E * 1e6_8)) // " eV." 
+           ". Energy = " // trim(to_str(p % E * 1e6_8)) // " eV."
       call write_message()
     end if
 
@@ -158,7 +158,7 @@ contains
         call fatal_error()
       end if
 
-      ! Find atom density 
+      ! Find atom density
       i_nuclide    = mat % nuclide(i)
       atom_density = mat % atom_density(i)
 
@@ -209,7 +209,7 @@ contains
       i_reaction = nuc % index_fission(1)
       return
     end if
-    
+
     ! Get grid index and interpolatoin factor and sample fission cdf
     i_grid = micro_xs(i_nuclide) % index_grid
     f      = micro_xs(i_nuclide) % interp_factor
@@ -226,7 +226,7 @@ contains
       if (i_grid < rxn % threshold) cycle
 
       ! add to cumulative probability
-      prob = prob + ((ONE - f)*rxn%sigma(i_grid - rxn%threshold + 1) & 
+      prob = prob + ((ONE - f)*rxn%sigma(i_grid - rxn%threshold + 1) &
            + f*(rxn%sigma(i_grid - rxn%threshold + 2)))
 
       ! Create fission bank sites if fission occus
@@ -382,7 +382,7 @@ contains
         if (i_grid < rxn % threshold) cycle
 
         ! add to cumulative probability
-        prob = prob + ((ONE - f)*rxn%sigma(i_grid - rxn%threshold + 1) & 
+        prob = prob + ((ONE - f)*rxn%sigma(i_grid - rxn%threshold + 1) &
              + f*(rxn%sigma(i_grid - rxn%threshold + 2)))
       end do
 
@@ -490,13 +490,24 @@ contains
     integer :: k            ! outgoing cosine bin
     integer :: n_energy_out ! number of outgoing energy bins
     real(8) :: f            ! interpolation factor
-    real(8) :: r            ! used for skewed sampling
+    real(8) :: r            ! used for skewed sampling & continuous
     real(8) :: E_ij         ! outgoing energy j for E_in(i)
     real(8) :: E_i1j        ! outgoing energy j for E_in(i+1)
     real(8) :: mu_ijk       ! outgoing cosine k for E_in(i) and E_out(j)
     real(8) :: mu_i1jk      ! outgoing cosine k for E_in(i+1) and E_out(j)
     real(8) :: prob         ! probability for sampling Bragg edge
     type(SAlphaBeta), pointer, save :: sab => null()
+    ! Following are needed only for SAB_SECONDARY_CONT scattering
+    integer :: l              ! sampled incoming E bin (is i or i + 1)
+    real(8) :: E_i_1, E_i_J   ! endpoints on outgoing grid i
+    real(8) :: E_i1_1, E_i1_J ! endpoints on outgoing grid i+1
+    real(8) :: E_1, E_J       ! endpoints interpolated between i and i+1
+    real(8) :: E_l_j, E_l_j1  ! adjacent E on outgoing grid l
+    real(8) :: p_l_j, p_l_j1  ! adjacent p on outgoing grid l
+    real(8) :: c_j, c_j1      ! cumulative probability
+    real(8) :: frac           ! interpolation factor on outgoing energy
+    real(8) :: r1             ! RNG for outgoing energy
+
 !$omp threadprivate(sab)
 
     ! Get pointer to S(a,b) table
@@ -513,7 +524,7 @@ contains
         f = ZERO
       else
         i = binary_search(sab % elastic_e_in, sab % n_elastic_e_in, E)
-        f = (E - sab%elastic_e_in(i)) / & 
+        f = (E - sab%elastic_e_in(i)) / &
              (sab%elastic_e_in(i+1) - sab%elastic_e_in(i))
       end if
 
@@ -554,8 +565,7 @@ contains
       ! Outgoing energy is same as incoming energy -- no need to do anything
 
     else
-      ! Determine number of outgoing energy and angle bins
-      n_energy_out = sab % n_inelastic_e_out
+      ! Perform inelastic calculations
 
       ! Get index and interpolation factor for inelastic grid
       if (E < sab % inelastic_e_in(1)) then
@@ -563,61 +573,150 @@ contains
         f = ZERO
       else
         i = binary_search(sab % inelastic_e_in, sab % n_inelastic_e_in, E)
-        f = (E - sab%inelastic_e_in(i)) / & 
+        f = (E - sab%inelastic_e_in(i)) / &
              (sab%inelastic_e_in(i+1) - sab%inelastic_e_in(i))
       end if
 
       ! Now that we have an incoming energy bin, we need to determine the
       ! outgoing energy bin. This will depend on the "secondary energy
       ! mode". If the mode is 0, then the outgoing energy bin is chosen from a
-      ! set of equally-likely bins. However, if the mode is 1, then the first
+      ! set of equally-likely bins. If the mode is 1, then the first
       ! two and last two bins are skewed to have lower probabilities than the
       ! other bins (0.1 for the first and last bins and 0.4 for the second and
-      ! second to last bins, relative to a normal bin probability of 1)
+      ! second to last bins, relative to a normal bin probability of 1).
+      ! Finally, if the mode is 2, then a continuous distribution (with
+      ! accompanying PDF and CDF is utilized)
 
-      if (sab % secondary_mode == SAB_SECONDARY_EQUAL) then
-        ! All bins equally likely
-        j = 1 + int(prn() * n_energy_out)
-      elseif (sab % secondary_mode == SAB_SECONDARY_SKEWED) then
-        r = prn() * (n_energy_out - 3)
-        if (r > ONE) then
-          ! equally likely N-4 middle bins
-          j = int(r) + 2
-        elseif (r > 0.6) then
-          ! second to last bin has relative probability of 0.4
-          j = n_energy_out - 1
-        elseif (r > 0.5) then
-          ! last bin has relative probability of 0.1
-          j = n_energy_out
-        elseif (r > 0.1) then
-          ! second bin has relative probability of 0.4
-          j = 2
-        else
-          ! first bin has relative probability of 0.1
-          j = 1
+      if ((sab % secondary_mode == SAB_SECONDARY_EQUAL) .or. &
+          (sab % secondary_mode == SAB_SECONDARY_SKEWED)) then
+        if (sab % secondary_mode == SAB_SECONDARY_EQUAL) then
+          ! All bins equally likely
+
+          j = 1 + int(prn() * sab % n_inelastic_e_out)
+        elseif (sab % secondary_mode == SAB_SECONDARY_SKEWED) then
+          ! Distribution skewed away from edge points
+
+          ! Determine number of outgoing energy and angle bins
+          n_energy_out = sab % n_inelastic_e_out
+
+          r = prn() * (n_energy_out - 3)
+          if (r > ONE) then
+            ! equally likely N-4 middle bins
+            j = int(r) + 2
+          elseif (r > 0.6) then
+            ! second to last bin has relative probability of 0.4
+            j = n_energy_out - 1
+          elseif (r > 0.5) then
+            ! last bin has relative probability of 0.1
+            j = n_energy_out
+          elseif (r > 0.1) then
+            ! second bin has relative probability of 0.4
+            j = 2
+          else
+            ! first bin has relative probability of 0.1
+            j = 1
+          end if
         end if
+
+        ! Determine outgoing energy corresponding to E_in(i) and E_in(i+1)
+        E_ij  = sab % inelastic_e_out(j,i)
+        E_i1j = sab % inelastic_e_out(j,i+1)
+
+        ! Outgoing energy
+        E = (1 - f)*E_ij + f*E_i1j
+
+        ! Sample outgoing cosine bin
+        k = 1 + int(prn() * sab % n_inelastic_mu)
+
+        ! Determine outgoing cosine corresponding to E_in(i) and E_in(i+1)
+        mu_ijk  = sab % inelastic_mu(k,j,i)
+        mu_i1jk = sab % inelastic_mu(k,j,i+1)
+
+        ! Cosine of angle between incoming and outgoing neutron
+        mu = (1 - f)*mu_ijk + f*mu_i1jk
+
+      else if (sab % secondary_mode == SAB_SECONDARY_CONT) then
+        ! Continuous secondary energy - this is to be similar to
+        ! Law 61 interpolation on outgoing energy
+
+        ! Sample between ith and (i+1)th bin
+        r = prn()
+        if (f > r) then
+          l = i + 1
+        else
+          l = i
+        end if
+
+        ! Determine endpoints on grid i
+        n_energy_out = sab % inelastic_data(i) % n_e_out
+        E_i_1 = sab % inelastic_data(i) % e_out(1)
+        E_i_J = sab % inelastic_data(i) % e_out(n_energy_out)
+
+        ! Determine endpoints on grid i + 1
+        n_energy_out = sab % inelastic_data(i + 1) % n_e_out
+        E_i1_1 = sab % inelastic_data(i + 1) % e_out(1)
+        E_i1_J = sab % inelastic_data(i + 1) % e_out(n_energy_out)
+
+        E_1 = E_i_1 + f * (E_i1_1 - E_i_1)
+        E_J = E_i_J + f * (E_i1_J - E_i_J)
+
+        ! Determine outgoing energy bin
+        ! (First reset n_energy_out to the right value)
+        n_energy_out = sab % inelastic_data(l) % n_e_out
+        r1 = prn()
+        c_j = sab % inelastic_data(l) % e_out_cdf(1)
+        do j = 1, n_energy_out - 1
+          c_j1 = sab % inelastic_data(l) % e_out_cdf(j + 1)
+          if (r1 < c_j1) exit
+          c_j = c_j1
+        end do
+
+        ! check to make sure k is <= n_energy_out - 1
+        j = min(j, n_energy_out - 1)
+
+        ! Get the data to interpolate between
+        E_l_j = sab % inelastic_data(l) % e_out(j)
+        p_l_j = sab % inelastic_data(l) % e_out_pdf(j)
+
+        ! Next part assumes linear-linear interpolation in standard
+        E_l_j1 = sab % inelastic_data(l) % e_out(j + 1)
+        p_l_j1 = sab % inelastic_data(l) % e_out_pdf(j + 1)
+
+        ! Find secondary energy (variable E)
+        frac = (p_l_j1 - p_l_j) / (E_l_j1 - E_l_j)
+        if (frac == ZERO) then
+          E = E_l_j + (r1 - c_j) / p_l_j
+        else
+          E = E_l_j + (sqrt(max(ZERO, p_l_j * p_l_j + &
+                       TWO * frac * (r1 - c_j))) - p_l_j) / frac
+        end if
+
+        ! Now interpolate between incident energy bins i and i + 1
+        if (l == i) then
+          E = E_1 + (E - E_i_1) * (E_J - E_1) / (E_i_J - E_i_1)
+        else
+          E = E_1 + (E - E_i1_1) * (E_J - E_1) / (E_i1_J - E_i1_1)
+        end if
+
+        ! Find angular distribution for closest outgoing energy bin
+        if (r1 - c_j < c_j1 - r1) then
+          j = j
+        else
+          j = j + 1
+        end if
+
+        ! Sample outgoing cosine bin
+        k = 1 + int(prn() * sab % n_inelastic_mu)
+
+        ! Will use mu from the randomly chosen incoming and closest outgoing
+        ! energy bins
+        mu = sab % inelastic_data(l) % mu(k, j)
+
       else
         message = "Invalid secondary energy mode on S(a,b) table " // &
              trim(sab % name)
-      end if
-
-      ! Determine outgoing energy corresponding to E_in(i) and E_in(i+1)
-      E_ij  = sab % inelastic_e_out(j,i)
-      E_i1j = sab % inelastic_e_out(j,i+1)
-
-      ! Outgoing energy
-      E = (1 - f)*E_ij + f*E_i1j
-
-      ! Sample outgoing cosine bin
-      k = 1 + int(prn() * sab % n_inelastic_mu)
-
-      ! Determine outgoing cosine corresponding to E_in(i) and E_in(i+1)
-      mu_ijk  = sab % inelastic_mu(k,j,i)
-      mu_i1jk = sab % inelastic_mu(k,j,i+1)
-
-      ! Cosine of angle between incoming and outgoing neutron
-      mu = (1 - f)*mu_ijk + f*mu_i1jk
-    end if
+      end if  ! (inelastic secondary energy treatment)
+    end if  ! (elastic or inelastic)
 
     ! change direction of particle
     uvw = rotate_angle(uvw, mu)
@@ -974,7 +1073,7 @@ contains
       E_cm = E
 
       ! determine outgoing energy in lab
-      E = E_cm + (E_in + TWO * mu * (A+ONE) * sqrt(E_in * E_cm)) & 
+      E = E_cm + (E_in + TWO * mu * (A+ONE) * sqrt(E_in * E_cm)) &
            / ((A+ONE)*(A+ONE))
 
       ! determine outgoing angle in lab
@@ -1037,7 +1136,7 @@ contains
       r = ONE
     else
       i = binary_search(rxn % adist % energy, n, E)
-      r = (E - rxn % adist % energy(i)) / & 
+      r = (E - rxn % adist % energy(i)) / &
            (rxn % adist % energy(i+1) - rxn % adist % energy(i))
     end if
 
@@ -1166,7 +1265,7 @@ contains
     end if
 
   end function rotate_angle
-    
+
 !===============================================================================
 ! SAMPLE_ENERGY samples an outgoing energy distribution, either for a secondary
 ! neutron from a collision or for a prompt/delayed fission neutron
@@ -1322,7 +1421,7 @@ contains
       ! =======================================================================
       ! CONTINUOUS TABULAR DISTRIBUTION
 
-      ! read number of interpolation regions and incoming energies 
+      ! read number of interpolation regions and incoming energies
       NR  = int(edist % data(1))
       NE  = int(edist % data(2 + 2*NR))
       if (NR == 1) then
@@ -1348,7 +1447,7 @@ contains
         r = ONE
       else
         i = binary_search(edist % data(lc+1:lc+NE), NE, E_in)
-        r = (E_in - edist%data(lc+i)) / & 
+        r = (E_in - edist%data(lc+i)) / &
              (edist%data(lc+i+1) - edist%data(lc+i))
       end if
 
@@ -1452,7 +1551,7 @@ contains
       ! =======================================================================
       ! MAXWELL FISSION SPECTRUM
 
-      ! read number of interpolation regions and incoming energies 
+      ! read number of interpolation regions and incoming energies
       NR = int(edist % data(1))
       NE = int(edist % data(2 + 2*NR))
 
@@ -1484,7 +1583,7 @@ contains
       ! =======================================================================
       ! EVAPORATION SPECTRUM
 
-      ! read number of interpolation regions and incoming energies 
+      ! read number of interpolation regions and incoming energies
       NR = int(edist % data(1))
       NE = int(edist % data(2 + 2*NR))
 
@@ -1565,7 +1664,7 @@ contains
         call fatal_error()
       end if
 
-      ! read number of interpolation regions and incoming energies 
+      ! read number of interpolation regions and incoming energies
       NR = int(edist % data(1))
       NE = int(edist % data(2 + 2*NR))
       if (NR > 0) then
@@ -1587,7 +1686,7 @@ contains
         r = ONE
       else
         i = binary_search(edist % data(lc+1:lc+NE), NE, E_in)
-        r = (E_in - edist%data(lc+i)) / & 
+        r = (E_in - edist%data(lc+i)) / &
              (edist%data(lc+i+1) - edist%data(lc+i))
       end if
 
@@ -1714,11 +1813,11 @@ contains
 
       if (.not. present(mu_out)) then
         ! call write_particle_restart()
-        message = "Law 44 called without giving mu_out as argument."
+        message = "Law 61 called without giving mu_out as argument."
         call fatal_error()
       end if
 
-      ! read number of interpolation regions and incoming energies 
+      ! read number of interpolation regions and incoming energies
       NR = int(edist % data(1))
       NE = int(edist % data(2 + 2*NR))
       if (NR > 0) then
@@ -1740,7 +1839,7 @@ contains
         r = ONE
       else
         i = binary_search(edist % data(lc+1:lc+NE), NE, E_in)
-        r = (E_in - edist%data(lc+i)) / & 
+        r = (E_in - edist%data(lc+i)) / &
              (edist%data(lc+i+1) - edist%data(lc+i))
       end if
 

src/relaxng/cross_sections.rnc

@@ -10,7 +10,9 @@ element cross_sections {
     (element temperature { xsd:double } | attribute temperature { xsd:double }) &
     (element path { xsd:string { maxLength = "255" } } |
       attribute path { xsd:string { maxLength = "255" } }) &
-    (element location { xsd:int } | attribute location { xsd:int })?
+    (element location { xsd:int } | attribute location { xsd:int })? &
+    (element filetype { ( "ascii" | "binary" ) } |
+      attribute filetype { ( "ascii" | "binary" ) })?
   }* &
 
   element directory { xsd:string { maxLength = "255" } }? &

src/relaxng/settings.rnc

@@ -40,8 +40,12 @@ element settings {
 
   element no_reduce { xsd:boolean }? &
 
-  element output { list { 
-    ( "summary" | "cross_sections" | "tallies" )+ } }? &
+  element output {
+    (element summary { xsd:boolean } | attribute summary { xsd:boolean })? &
+    (element cross_sections { xsd:boolean } |
+      attribute cross_sections { xsd:boolean })? &
+    (element tallies { xsd:boolean } | attribute tallies { xsd:boolean })?
+  }? &
 
   element output_path { xsd:string { maxLength = "255" } }? &
 
@@ -101,6 +105,8 @@ element settings {
 
   element trace { list { xsd:positiveInteger+ } }? &
 
+  element track { list { xsd:positiveInteger+ } }? &
+
   element verbosity { xsd:positiveInteger }? &
 
   element uniform_fs{

src/solver_interface.F90

@@ -0,0 +1,294 @@
+module solver_interface
+
+  use error,          only: fatal_error
+  use global,         only: message
+  use matrix_header,  only: Matrix
+  use vector_header,  only: Vector
+
+#ifdef PETSC
+  use petscksp
+  use petscsnes
+#endif
+
+  implicit none
+  private
+
+  ! GMRES solver type 
+  type, public :: GMRESSolver 
+#ifdef PETSC
+    type(ksp) :: ksp_ ! Krylov linear solver instance
+    type(pc)  :: pc_  ! Preconditioner instance
+#endif
+   contains
+#ifdef PETSC
+     procedure :: create       => petsc_gmres_create
+     procedure :: set_oper     => petsc_gmres_set_oper
+     procedure :: destroy      => petsc_gmres_destroy
+     procedure :: solve        => petsc_gmres_solve
+#endif
+  end type GMRESSolver
+
+  ! Derived type to contain list of data needed to be passed to procedures
+  type, public :: Jfnk_ctx
+    procedure (res_interface), pointer, nopass :: res_proc_ptr
+    procedure (jac_interface), pointer, nopass :: jac_proc_ptr
+  end type Jfnk_ctx
+
+  ! JFNK solver type 
+  type, public :: JFNKSolver 
+#ifdef PETSC
+    type(ksp)  :: ksp_   ! Krylov linear solver instance
+    type(pc)   :: pc_    ! Preconditioner instance
+    type(snes) :: snes_  ! Nonlinear solver instance
+    type(mat)  :: jac_mf ! Matrix free jacobian instance
+    integer    :: ls     ! Line search instance
+#endif
+   contains
+#ifdef PETSC
+     procedure :: create        => petsc_jfnk_create
+     procedure :: destroy       => petsc_jfnk_destroy
+     procedure :: set_functions => petsc_jfnk_set_functions
+     procedure :: solve         => petsc_jfnk_solve
+#endif
+  end type JFNKSolver
+
+  ! Abstract interface stating how jacobian and residual routines look
+  abstract interface
+    subroutine res_interface(x, res)
+      import :: Vector
+      type(Vector), intent(in)    :: x   ! solution vector
+      type(Vector), intent(inout) :: res ! residual vector
+    end subroutine res_interface
+
+    subroutine jac_interface(x)
+      import :: Vector
+      type(Vector), intent(in) :: x ! solution vector
+    end subroutine jac_interface
+  end interface
+
+#ifdef PETSC
+  integer :: petsc_err ! petsc error code
+#endif
+
+contains
+
+#ifdef PETSC
+!===============================================================================
+! PETSC_GMRES_CREATE sets up a PETSc GMRES solver
+!===============================================================================
+
+  subroutine petsc_gmres_create(self)
+
+    class(GMRESSolver), intent(inout) :: self ! GMRES solver instance
+
+    integer :: ilu_levels = 5
+    real(8) :: rtol = 1.0e-10_8
+    real(8) :: atol = 1.0e-10_8
+
+    call KSPCreate(PETSC_COMM_WORLD, self % ksp_, petsc_err)
+    call KSPSetTolerances(self % ksp_, rtol, atol, &
+         PETSC_DEFAULT_DOUBLE_PRECISION, PETSC_DEFAULT_INTEGER, petsc_err)
+    call KSPSetType(self % ksp_, 'gmres', petsc_err)
+    call KSPSetInitialGuessNonzero(self % ksp_, PETSC_TRUE, petsc_err)
+    call KSPGetPC(self % ksp_, self % pc_, petsc_err)
+    call PCFactorSetLevels(self % pc_, ilu_levels, petsc_err)
+    call KSPSetFromOptions(self % ksp_, petsc_err)
+
+  end subroutine petsc_gmres_create
+
+!===============================================================================
+! PETSC_GMRES_SET_OPER sets the matrix opetors for the GMRES solver
+!===============================================================================
+
+  subroutine petsc_gmres_set_oper(self, prec_mat, mat_in)
+
+    class(GMRESSolver), intent(inout) :: self     ! GMRES solver instanace
+    type(Matrix), intent(inout)       :: prec_mat ! preconditioner matrix
+    type(Matrix), intent(inout)       :: mat_in   ! coefficient matrix
+
+    call KSPSetOperators(self % ksp_, mat_in % petsc_mat, prec_mat % petsc_mat, &
+         SAME_NONZERO_PATTERN, petsc_err)
+    call KSPSetUp(self % ksp_, petsc_err) 
+
+  end subroutine petsc_gmres_set_oper
+
+!===============================================================================
+! PETSC_GMRES_DESTROY frees all memory associated with the GMRES solver
+!===============================================================================
+
+  subroutine petsc_gmres_destroy(self)
+
+   class(GMRESSolver), intent(inout) :: self ! GMRES solver instance
+
+    call KSPDestroy(self % ksp_, petsc_err)
+
+  end subroutine petsc_gmres_destroy
+
+!===============================================================================
+! PETSC_GMRES_SOLVE solves the linear system
+!===============================================================================
+
+  subroutine petsc_gmres_solve(self, b, x)
+
+    class(GMRESSolver), intent(inout) :: self ! GMRES solver instance
+    type(Vector), intent(inout)       :: b    ! right hand side vector
+    type(Vector), intent(inout)       :: x    ! solution vector
+
+    call KSPSolve(self % ksp_, b % petsc_vec, x % petsc_vec, petsc_err)
+
+  end subroutine petsc_gmres_solve
+
+!===============================================================================
+! PETSC_JFNK_CREATE sets up a JFNK solver using PETSc SNES
+!===============================================================================
+
+  subroutine petsc_jfnk_create(self)
+
+    class(JFNKSolver), intent(inout) :: self ! JFNK solver instance
+
+    ! Turn on mf_operator option for matrix free jacobian
+    call PetscOptionsSetValue("-snes_mf_operator", "TRUE", petsc_err)
+
+    ! Create the SNES context
+    call SNESCreate(PETSC_COMM_WORLD, self % snes_, petsc_err)
+
+    ! Set up the GMRES solver
+    call SNESGetKSP(self % snes_, self % ksp_, petsc_err)
+    call KSPSetType(self % ksp_, 'gmres', petsc_err)    
+
+    ! Apply options
+    call SNESGetLineSearch(self % snes_, self % ls, petsc_err)
+    call SNESLineSearchSetType(self % ls, 'basic', petsc_err)
+    call SNESSetFromOptions(self % snes_, petsc_err)
+
+    ! Set up preconditioner
+    call KSPGetPC(self % ksp_, self % pc_, petsc_err)
+    call PCSetType(self % pc_, 'ilu', petsc_err)
+    call PCFactorSetLevels(self % pc_, 5, petsc_err)
+    call PCSetFromOptions(self % pc_, petsc_err)
+    call KSPSetFromOptions(self % ksp_, petsc_err)
+
+  end subroutine petsc_jfnk_create
+
+!===============================================================================
+! PETSC_JFNK_DESTROY frees all memory associated with JFNK solver
+!===============================================================================
+
+  subroutine petsc_jfnk_destroy(self)
+
+    class(JFNKSolver), intent(inout) :: self ! JFNK solver instance
+
+    call MatDestroy(self % jac_mf, petsc_err)
+    call SNESDestroy(self % snes_, petsc_err)
+
+  end subroutine petsc_jfnk_destroy
+
+!===============================================================================
+! PETSC_JFNK_SET_FUNCTIONS sets user functions and matrix free objects
+!===============================================================================
+
+  subroutine petsc_jfnk_set_functions(self, ctx, res, jac_prec)
+
+    class(JFNKSolver), intent(inout) :: self     ! JFNK solver instance
+    type(Jfnk_ctx),    intent(inout) :: ctx      ! JFNK context instance
+    type(Vector),      intent(inout) :: res      ! residual vector
+    type(Matrix),      intent(inout) :: jac_prec ! preconditioner matrix
+
+    ! Set residual procedure
+    call SNESSetFunction(self % snes_, res % petsc_vec, &
+         petsc_jfnk_compute_residual, ctx, petsc_err)
+
+    ! Create the matrix free jacobian
+    call MatCreateSNESMF(self % snes_, self % jac_mf, petsc_err)
+
+    ! Set Jacobian procedure
+    call SNESSetJacobian(self % snes_, self % jac_mf, jac_prec % petsc_mat, &
+         petsc_jfnk_compute_jacobian, ctx, petsc_err)
+
+    ! Set up Jacobian Lags
+    call SNESSetLagJacobian(self % snes_, -2, petsc_err)
+    call SNESSetLagPreconditioner(self % snes_, -1, petsc_err)
+
+  end subroutine petsc_jfnk_set_functions
+
+!===============================================================================
+! PETSC_JFNK_SOLVE solves the nonlinear system
+!===============================================================================
+
+  subroutine petsc_jfnk_solve(self, xvec)
+
+    class(JFNKSolver), intent(inout) :: self ! JFNK instance
+    type(Vector), intent(inout)      :: xvec ! solution vector
+
+    call SNESSolve(self % snes_, PETSC_NULL_DOUBLE, xvec % petsc_vec, petsc_err)
+
+  end subroutine petsc_jfnk_solve
+
+!===============================================================================
+! PETSC_JFNK_COMPUTE_RESIDUAL buffer routine to user specifed residual routine
+!===============================================================================
+
+  subroutine petsc_jfnk_compute_residual(snes_, x, res, ctx, ierr)
+
+    type(snes), intent(inout)     :: snes_ ! PETSc SNES object
+    type(vec), intent(inout)      :: x     ! PETSc solution vector
+    type(vec), intent(inout)      :: res   ! PETSc residual vector
+    integer, intent(inout)        :: ierr  ! error code
+    type(Jfnk_ctx), intent(inout) :: ctx ! JFNK context instance
+
+    type(Vector) :: xvec   ! solution vector
+    type(Vector) :: resvec ! residual vector
+
+    ! We need to use the x and res that come from PETSc because the pointer
+    ! location changes and therefore we can not use module variables
+    ! for the residual and x vectors here
+
+    ! Need to point an OpenMC vector to PETSc vector
+    call VecGetArrayF90(x, xvec % val, ierr)
+    call VecGetArrayF90(res, resvec % val, ierr)
+
+    ! Call user residual routine
+    call ctx % res_proc_ptr(xvec, resvec)
+
+    ! Need to restore the PETSc vector
+    call VecRestoreArrayF90(x, xvec % val, ierr)
+    call VecRestoreArrayF90(res, resvec % val, ierr)
+
+  end subroutine petsc_jfnk_compute_residual
+
+!===============================================================================
+! PETSC_JFNK_COMPUTE_JACOBIAN buffer routine to user specified jacobian routine
+!===============================================================================
+
+  subroutine petsc_jfnk_compute_jacobian(snes_, x, jac_mf, jac_prec, flag, &
+             ctx, ierr)
+
+    type(snes), intent(inout)     :: snes_     ! PETSc snes instance
+    type(vec), intent(inout)      :: x         ! PETSc solution vector
+    type(mat), intent(inout)      :: jac_mf    ! PETSc matrix free jacobian
+    type(mat), intent(inout)      :: jac_prec  ! PETSc matrix jacobian precond.
+    integer, intent(inout)        :: flag      ! unused madatory flag
+    type(Jfnk_ctx), intent(inout) :: ctx       ! JFNK context instance
+    integer, intent(inout)        :: ierr      ! error code
+
+    type(Vector) :: xvec ! solution vector
+
+    ! Again, we use the vector that comes from Petsc to build the Jacobian
+    ! matrix
+
+    ! Need to point OpenMC vector to PETSc Vector
+    call VecGetArrayF90(x, xvec % val, ierr)
+
+    ! Evaluate user jacobian routine
+    call ctx % jac_proc_ptr(xvec)
+
+    ! Restore the PETSc vector
+    call VecRestoreArrayF90(x, xvec % val, ierr)
+
+    call MatAssemblyBegin(jac_mf, MAT_FINAL_ASSEMBLY, petsc_err)
+    call MatAssemblyEnd(jac_mf, MAT_FINAL_ASSEMBLY, petsc_err)
+
+  end subroutine petsc_jfnk_compute_jacobian
+#endif
+
+end module solver_interface

src/source.F90

@@ -3,6 +3,7 @@ module source
   use bank_header,     only: Bank
   use constants
   use error,           only: fatal_error
+  use geometry,        only: find_cell
   use geometry_header, only: BASE_UNIVERSE
   use global
   use math,            only: maxwell_spectrum, watt_spectrum
@@ -73,6 +74,9 @@ contains
     real(8) :: p_max(3)   ! maximum coordinates of source
     real(8) :: a          ! Arbitrary parameter 'a'
     real(8) :: b          ! Arbitrary parameter 'b'
+    logical :: found      ! Does the source particle exist within geometry?
+    type(Particle) :: p   ! Temporary particle for using find_cell
+    integer, save :: num_resamples = 0 ! Number of resamples encountered
 
     ! Set weight to one by default
     site % wgt = ONE
@@ -80,11 +84,32 @@ contains
     ! Sample position
     select case (external_source % type_space)
     case (SRC_SPACE_BOX)
-      ! Coordinates sampled uniformly over a box
-      p_min = external_source % params_space(1:3)
-      p_max = external_source % params_space(4:6)
-      r = (/ (prn(), i = 1,3) /)
-      site % xyz = p_min + r*(p_max - p_min)
+      ! Set particle defaults
+      call p % initialize()
+      ! Repeat sampling source location until a good site has been found
+      found = .false.
+      do while (.not.found)
+        ! Coordinates sampled uniformly over a box
+        p_min = external_source % params_space(1:3)
+        p_max = external_source % params_space(4:6)
+        r = (/ (prn(), i = 1,3) /)
+        site % xyz = p_min + r*(p_max - p_min)
+
+        ! Fill p with needed data
+        p % coord0 % xyz = site % xyz
+        p % coord0 % uvw = [ ONE, ZERO, ZERO ]
+
+        ! Now search to see if location exists in geometry
+        call find_cell(p, found)
+        if (.not. found) then
+          num_resamples = num_resamples + 1
+          if (num_resamples == MAX_EXTSRC_RESAMPLES) then
+            message = "Maximum number of external source spatial resamples &
+                      &reached!"
+            call fatal_error()
+          end if
+        end if
+      end do
 
     case (SRC_SPACE_POINT)
       ! Point source
@@ -146,7 +171,7 @@ contains
   end subroutine sample_external_source
 
 !===============================================================================
-! GET_SOURCE_PARTICLE returns the next source particle 
+! GET_SOURCE_PARTICLE returns the next source particle
 !===============================================================================
 
   subroutine get_source_particle(p, index_source)
@@ -155,6 +180,7 @@ contains
     integer(8),     intent(in)    :: index_source
 
     integer(8) :: particle_seed  ! unique index for particle
+    integer :: i
     type(Bank), pointer, save :: src => null()
 !$omp threadprivate(src)
 
@@ -177,6 +203,21 @@ contains
     if (current_batch == trace_batch .and. current_gen == trace_gen .and. &
          p % id == trace_particle) trace = .true.
 
+    ! Set particle track.
+    p % write_track = .false.
+    if (write_all_tracks) then
+      p % write_track = .true.
+    else if (allocated(track_identifiers)) then
+      do i=1, size(track_identifiers(1,:))
+        if (current_batch == track_identifiers(1,i) .and. &
+             &current_gen == track_identifiers(2,i) .and. &
+             &p % id == track_identifiers(3,i)) then
+          p % write_track = .true.
+          exit
+        end if
+      end do
+    end if
+
   end subroutine get_source_particle
 
 !===============================================================================

src/state_point.F90

@@ -20,6 +20,10 @@ module state_point
   use output_interface
   use tally_header,       only: TallyObject
 
+#ifdef MPI
+  use mpi
+#endif
+
   implicit none
 
   type(BinaryOutput) :: sp ! statepoint/source output file
@@ -96,6 +100,28 @@ contains
         call sp % write_data(k_col_tra, "k_col_tra")
         call sp % write_data(k_abs_tra, "k_abs_tra")
         call sp % write_data(k_combined, "k_combined", length=2)
+
+        ! Write out CMFD info
+        if (cmfd_on) then
+          call sp % write_data(1, "cmfd_on")
+          call sp % write_data(cmfd % indices, "indicies", length=4, group="cmfd")
+          call sp % write_data(cmfd % k_cmfd, "k_cmfd", length=current_batch, &
+               group="cmfd")
+          call sp % write_data(cmfd % cmfd_src, "cmfd_src", &
+               length=(/cmfd % indices(4), cmfd % indices(1), &
+               cmfd % indices(2), cmfd % indices(3)/), &
+               group="cmfd")
+          call sp % write_data(cmfd % entropy, "cmfd_entropy", &
+                          length=current_batch, group="cmfd")
+          call sp % write_data(cmfd % balance, "cmfd_balance", &
+               length=current_batch, group="cmfd")
+          call sp % write_data(cmfd % dom, "cmfd_dominance", &
+               length = current_batch, group="cmfd")
+          call sp % write_data(cmfd % src_cmp, "cmfd_srccmp", &
+               length = current_batch, group="cmfd")
+        else
+          call sp % write_data(0, "cmfd_on")
+        end if
       end if
 
       ! Write number of meshes
@@ -438,6 +464,7 @@ contains
     character(19)           :: current_time
     integer                 :: i
     integer                 :: j
+    integer                 :: length(4)
     integer                 :: int_array(3)
     integer, allocatable    :: temp_array(:)
     real(8)                 :: real_array(3) 
@@ -448,7 +475,7 @@ contains
     call write_message(1)
 
     ! Open file for reading
-    call sp % file_open(path_state_point, 'r')
+    call sp % file_open(path_state_point, 'r', serial = .false.)
 
     ! Read filetype
     call sp % read_data(int_array(1), "filetype")
@@ -507,6 +534,27 @@ contains
 
       ! Take maximum of statepoint n_inactive and input n_inactive
       n_inactive = max(n_inactive, int_array(1))
+
+      ! Read in to see if CMFD was on
+      call sp % read_data(int_array(1), "cmfd_on")
+
+      ! Write out CMFD info
+      if (int_array(1) == 1) then
+        call sp % read_data(cmfd % indices, "indicies", length=4, group="cmfd")
+        call sp % read_data(cmfd % k_cmfd, "k_cmfd", length=restart_batch, &
+             group="cmfd")
+        length = cmfd % indices([4,1,2,3])
+        call sp % read_data(cmfd % cmfd_src, "cmfd_src", &
+             length=length, group="cmfd")
+        call sp % read_data(cmfd % entropy, "cmfd_entropy", &
+                       length=restart_batch, group="cmfd")
+        call sp % read_data(cmfd % balance, "cmfd_balance", &
+             length=restart_batch, group="cmfd")
+        call sp % read_data(cmfd % dom, "cmfd_dominance", &
+             length = restart_batch, group="cmfd")
+        call sp % read_data(cmfd % src_cmp, "cmfd_srccmp", &
+             length = restart_batch, group="cmfd")
+      end if
     end if
 
     ! Read number of meshes
@@ -657,13 +705,6 @@ contains
 
         end do TALLY_RESULTS
       end if
-
-#ifdef MPI
-      ! If using MPI, file needs to be closed and reopened in parallel
-      ! If serial, we cannot close the file or we will lose our file position
-      call sp % file_close()
-# endif
-
     end if
 
     ! Read source if in eigenvalue mode 
@@ -691,14 +732,6 @@ contains
         ! Open source file 
         call sp % file_open(filename, 'r', serial = .false.)
 
-      else
-
-#ifdef MPI
-      ! Reopen statepoint file in parallel, but only if MPI
-      ! We will compute the position where the source begins
-      call sp % file_open(path_state_point, 'r', serial = .false.)
-#endif
-
       end if
 
       ! Write out source

src/templates/cmfd_t.xml

@@ -1,39 +0,0 @@
-<?xml version="1.0"?>
-<template>
-
-  <options rootname="cmfd" />
-
-  <typedef name="mesh_xml">
-    <component name="dimension"   type="integer-array" />
-    <component name="lower_left"  type="double-array"  />
-    <component name="upper_right" type="double-array"  />
-    <component name="width"       type="double-array"  />
-    <component name="albedo"      type="double-array"  />
-    <component name="map"         type="integer-array" />
-    <component name="energy"      type="double-array"  />
-  </typedef>
-
-  <variable name="mesh_"           tag="mesh"           type="mesh_xml"                                     />
-  <variable name="norm_"           tag="norm"           type="double"        default="1.0"                  />
-  <variable name="feedback_"       tag="feedback"       type="word"          length="5"                     />
-  <variable name="n_cmfd_procs_"   tag="n_procs"        type="integer"       default="1"                    />
-  <variable name="reset_"          tag="reset"          type="word"          length="5"                     />
-  <variable name="balance_"        tag="balance"        type="word"          length="5"                     />
-  <variable name="downscatter_"    tag="downscatter"    type="word"          length="5"                     />
-  <variable name="run_2grp_"       tag="run_2grp"       type="word"          length="5"                     />
-  <variable name="solver_"         tag="solver"         type="word"          default="'power'" length="250" />
-  <variable name="snes_monitor_"   tag="snes_monitor"   type="word"          length="5"                     />
-  <variable name="ksp_monitor_"    tag="ksp_monitor"    type="word"          length="5"                     />
-  <variable name="power_monitor_"  tag="power_monitor"  type="word"          length="5"                     />
-  <variable name="write_balance_"  tag="write_balance"  type="word"          length="5"                     />
-  <variable name="write_matrices_" tag="write_matrices" type="word"          length="5"                     />
-  <variable name="run_adjoint_"    tag="run_adjoint"    type="word"          length="5"                     />
-  <variable name="write_hdf5_"     tag="write_hdf5"     type="word"          length="5"                     />
-  <variable name="begin_"          tag="begin"          type="integer"       default="1"                    />
-  <variable name="inactive_"       tag="inactive"       type="word"          length="5"                     />
-  <variable name="active_flush_"   tag="active_flush"   type="integer"       default="0"                    />
-  <variable name="keff_tol_"       tag="keff_tol"       type="double"        default="0.005"                />
-  <variable name="inactive_flush_" tag="inactive_flush" type="integer"       default="9999"                 />
-  <variable name="num_flushes_"    tag="num_flushes"    type="integer"       default="1"                    />
-
-</template>

src/templates/cross_sections_t.xml

@@ -1,26 +0,0 @@
-<?xml version="1.0"?>
-<template>
-
-  <!-- This is the template for reading cross section listings in OpenMC -->
-
-  <options rootname="cross_sections" />
-
-  <typedef name="ace_table_xml">
-    <component name="name" type="word" length="15" />
-    <component name="alias" type="word" length="15" default="''" />
-    <component name="type" type="word" length="10" default="'neutron'" />
-    <component name="zaid" type="integer" default="0" />
-    <component name="metastable" type="integer" default="0" />
-    <component name="awr" type="double" default="0.0" />
-    <component name="temperature" type="double" default="0.0" />
-    <component name="path" type="word" length="255" />
-    <component name="location" type="integer" default="0" />
-  </typedef>
-
-  <variable name="ace_tables_" tag="ace_table" type="ace_table_xml" dimension="1" />
-  <variable name="directory_" tag="directory" type="word" length="255" />
-  <variable name="filetype_" tag="filetype" type="word" length="255" />
-  <variable name="record_length_" tag="record_length" type="integer" />
-  <variable name="entries_" tag="entries" type="integer" />
-
-</template>

src/templates/geometry_t.xml

@@ -1,39 +0,0 @@
-<?xml version="1.0"?>
-<template>
-
-  <!-- This is the template for reading geometry in OpenMC -->
-
-  <options rootname="geometry" />
-
-  <typedef name="cell_xml">
-    <component name="id" type="integer" />
-    <component name="universe" type="integer" default="0" />
-    <component name="material" type="word" length="12" default="''" />
-    <component name="fill" type="integer" default="0" />
-    <component name="surfaces" type="integer-array" />
-    <component name="rotation" type="double-array" />
-    <component name="translation" type="double-array" />
-  </typedef>
-
-  <typedef name="surface_xml">
-    <component name="id" type="integer" />
-    <component name="type" type="word" length="15" />
-    <component name="coeffs" type="double-array" />
-    <component name="boundary" type="word" length="12" default="'transmit'" />
-  </typedef>
-
-  <typedef name="lattice_xml">
-    <component name="id" type="integer" />
-    <component name="type" type="word" length="12" default="'rectangular'" />
-    <component name="dimension" type="integer-array" />
-    <component name="lower_left" type="double-array" />
-    <component name="width" type="double-array" />
-    <component name="universes" type="integer-array" />
-    <component name="outside" type="integer" default="0"/>
-  </typedef>
-
-  <variable name="cell_" tag="cell" type="cell_xml" dimension="1" />
-  <variable name="surface_" tag="surface" type="surface_xml" dimension="1" />
-  <variable name="lattice_" tag="lattice" type="lattice_xml" dimension="1" />
-
-</template>

src/templates/materials_t.xml

@@ -1,44 +0,0 @@
-<?xml version="1.0"?>
-<template>
-
-  <!-- This is the template for reading materials in OpenMC -->
-
-  <options rootname="materials" />
-
-  <!-- Type for specifying density of a material -->
-
-  <typedef name="density_xml">
-    <component name="value" type="double" default="0.0" />
-    <component name="units" type="word" length="10" default="'atom/b-cm'" />
-  </typedef>
-
-  <!-- Type for specifying a nuclide -->
-
-  <typedef name="nuclide_xml">
-    <component name="name" type="word" length="7" default="''" />
-    <component name="xs" type="word" length="3" default="''" />
-    <component name="ao" type="double" default="0.0" />
-    <component name="wo" type="double" default="0.0" />
-  </typedef>
-
-  <!-- Type for specifying S(a,b) data -->
-
-  <typedef name="sab_xml">
-    <component name="name" type="word" length="10" />
-    <component name="xs" type="word" length="3" />
-  </typedef>
-
-  <!-- Type for specifying a material -->
-
-  <typedef name="material_xml">
-    <component name="id" type="integer" />
-    <component name="density" type="density_xml" />
-    <component name="nuclides" tag="nuclide" type="nuclide_xml" dimension="1" />
-    <component name="elements" tag="element" type="nuclide_xml" dimension="1" />
-    <component name="sab" type="sab_xml" dimension="1" />
-  </typedef>
-
-  <variable name="material_" tag="material" type="material_xml" dimension="1" />
-  <variable name="default_xs_" tag="default_xs" type="word" length="3" />
-
-</template>

src/templates/plots_t.xml

@@ -1,32 +0,0 @@
-<?xml version="1.0"?>
-<template>
-
-  <options rootname="plots" />
-
-  <typedef name="col_spec_xml">
-    <component name="id" type="integer" />
-    <component name="rgb" type="integer-array" />
-  </typedef>
-
-  <typedef name="mask_xml">
-    <component name="components" type="integer-array" />
-    <component name="background" type="integer-array" />
-  </typedef>
-
-  <typedef name="plot_xml">
-    <component name="id" type="integer" />
-    <component name="filename" type="word" length="50" default="'plot'" />
-    <component name="type" type="word" length="10" default="'slice'"/>
-    <component name="color" type="word" length="10" default="'cell'"/>
-    <component name="origin" type="double-array" />
-    <component name="width" type="double-array" />
-    <component name="basis" type="word" length="3" default="'xy'" />
-    <component name="pixels" type="integer-array" />
-    <component name="background" type="integer-array"/>
-    <component name="col_spec_" tag="col_spec" type="col_spec_xml" dimension="1" />
-    <component name="mask_" tag="mask" type="mask_xml" dimension="1" />
-  </typedef>
-
-  <variable name="plot_" tag="plot" type="plot_xml" dimension="1" />
-
-</template>

src/templates/settings_t.xml

@@ -1,69 +0,0 @@
-<?xml version="1.0"?>
-<template>
-
-  <options rootname="settings" />
-
-  <typedef name="run_parameters_xml">
-    <component name="batches" type="integer" default="0" />
-    <component name="inactive" type="integer" />
-    <component name="particles" type="word" length="25" default="''" />
-    <component name="generations_per_batch" type="integer" default="1" />
-  </typedef>
-
-  <typedef name="distribution_xml">
-    <component name="type" type="word" length="16" />
-    <component name="length" type="integer" />
-    <component name="interpolation" type="word" length="10" />
-    <component name="parameters" type="double-array" />
-  </typedef>
-
-  <typedef name="source_xml">
-    <component name="file" type="word" length="255" />
-    <component name="space" type="distribution_xml" />
-    <component name="angle" type="distribution_xml"  />
-    <component name="energy" type="distribution_xml" />
-  </typedef>
-
-  <typedef name="cutoff_xml">
-    <component name="weight" type="double" default="0.25" />
-    <component name="weight_avg" type="double" default="1.0" />
-  </typedef>
-
-  <typedef name="mesh_xml">
-    <component name="dimension" type="integer-array" />
-    <component name="lower_left" type="double-array" />
-    <component name="upper_right" type="double-array" />
-  </typedef>
-
-  <typedef name="statepoint_xml">
-    <component name="batches" type="integer-array" />
-    <component name="interval" type="integer" default="0" />
-    <component name="source_separate" type="word" length="5" default="''" />
-    <component name="source_write" type="word" length="5" default="''" />
-  </typedef>
-
-  <variable name="confidence_intervals_" tag="confidence_intervals" type="word" length="5" />
-  <variable name="cross_sections_" tag="cross_sections" type="word" length="255" />
-  <variable name="cutoff_" tag="cutoff" type="cutoff_xml" dimension="1" />
-  <variable name="eigenvalue_" tag="eigenvalue" type="run_parameters_xml" />
-  <variable name="energy_grid_" tag="energy_grid" type="word" length="7" />
-  <variable name="entropy_" tag="entropy" type="mesh_xml" dimension="1" />
-  <variable name="fixed_source_" tag="fixed_source" type="run_parameters_xml" />
-  <variable name="no_reduce_" tag="no_reduce" type="word" length="5" />
-  <variable name="output_" tag="output" type="word-array" length="20" />
-  <variable name="output_path_" tag="output_path" type="word" length="255" />
-  <variable name="ptables_" tag="ptables" type="word" length="5" />
-  <variable name="run_cmfd_" tag="run_cmfd" type="word" length="5" />
-  <variable name="seed_" tag="seed" type="integer" />
-  <variable name="source_" tag="source" type="source_xml" />
-  <variable name="state_point_" tag="state_point" type="statepoint_xml" dimension="1" />
-  <variable name="survival_" tag="survival_biasing" type="word" length="5" />
-  <variable name="threads_" tag="threads" type="integer" />
-  <variable name="trace_" tag="trace" type="integer-array" />
-  <variable name="uniform_fs_" tag="uniform_fs" type="mesh_xml" dimension="1" />
-  <variable name="verbosity_" tag="verbosity" type="integer" />
-
-  <!-- Check for old criticality tag -->
-  <variable name="criticality_" tag="criticality" type="run_parameters_xml" />
-
-</template>

src/templates/tallies_t.xml

@@ -1,37 +0,0 @@
-<?xml version="1.0"?>
-<template>
-
-  <options rootname="tallies" />
-
-  <typedef name="mesh_xml">
-    <component name="id" type="integer" />
-    <component name="type" type="word" length="12" />
-    <component name="dimension" type="integer-array" />
-    <component name="lower_left" type="double-array" />
-    <component name="upper_right" type="double-array" />
-    <component name="width" type="double-array" />
-  </typedef>
-
-  <typedef name="filter_xml">
-    <component name="type" type="word" length="20" default = "''" />
-    <component name="bins" type="word-array" length="20" />
-    <component name="groups" type="word" length="20" default = "''" />
-  </typedef>
-
-  <typedef name="tally_xml">
-    <component name="id" type="integer" />
-    <component name="label" type="word" length="52" default="''" />
-    <component name="estimator" type="word" length="12" default="''" />
-    <component name="filter" type="filter_xml" dimension="1" />
-    <component name="scores" type="word-array" length="20" />
-    <component name="nuclides" type="word-array" length="12" />
-
-    <!-- Check for old tally filter format -->
-    <component name="filters" type="filter_xml" dimension="1" />
-  </typedef>
-
-  <variable name="mesh_" tag="mesh" type="mesh_xml" dimension="1" />
-  <variable name="tally_" tag="tally" type="tally_xml" dimension="1" />
-  <variable name="separate_" tag="assume_separate" type="word" length="3" />
-
-</template>

src/track_output.F90

@@ -0,0 +1,79 @@
+!===============================================================================
+! TRACK_OUTPUT handles output of particle tracks (the paths taken by particles
+! as they are transported through the geometry).
+!===============================================================================
+
+module track_output
+
+  use global
+  use output_interface,  only: BinaryOutput
+  use particle_header,   only: Particle
+  use string,            only: to_str
+
+  implicit none
+
+  integer, private                  :: n_tracks     ! total number of tracks
+  real(8), private, allocatable     :: coords(:,:)  ! track coordinates
+!$omp threadprivate(n_tracks, coords)
+
+contains
+
+!===============================================================================
+! INITIALIZE_PARTICLE_TRACK
+!===============================================================================
+
+  subroutine initialize_particle_track()
+    n_tracks = 0
+  end subroutine initialize_particle_track
+
+!===============================================================================
+! WRITE_PARTICLE_TRACK copies particle position to an array.
+!===============================================================================
+
+  subroutine write_particle_track(p)
+    type(Particle), intent(in)  :: p
+
+    real(8), allocatable :: new_coords(:, :)
+
+    ! Add another column to coords
+    n_tracks = n_tracks + 1
+    if (allocated(coords)) then
+      allocate(new_coords(3, n_tracks))
+      new_coords(:, 1:n_tracks-1) = coords
+      call move_alloc(FROM=new_coords, TO=coords)
+    else
+      allocate(coords(3,1))
+    end if
+
+    ! Write current coordinates into the newest column.
+    coords(:, n_tracks) = p % coord0 % xyz
+  end subroutine write_particle_track
+
+!===============================================================================
+! FINALIZE_PARTICLE_TRACK writes the particle track array to disk.
+!===============================================================================
+
+  subroutine finalize_particle_track(p)
+    type(Particle), intent(in)  :: p
+
+    integer                  :: length(2)
+    character(MAX_FILE_LEN)  :: fname
+    type(BinaryOutput)       :: binout
+
+#ifdef HDF5
+    fname = trim(path_output) // 'track_' // trim(to_str(current_batch)) &
+         // '_' // trim(to_str(current_gen)) // '_' // trim(to_str(p % id)) &
+         // '.h5'
+#else
+    fname = trim(path_output) // 'track_' // trim(to_str(current_batch)) &
+         // '_' // trim(to_str(current_gen)) // '_' // trim(to_str(p % id)) &
+         // '.binary'
+#endif
+    call binout % file_create(fname)
+    length = [3, n_tracks]
+    call binout % write_data(coords, 'coordinates', length=length)
+    call binout % file_close()
+    deallocate(coords)
+  end subroutine finalize_particle_track
+
+end module track_output

src/tracking.F90

@@ -13,6 +13,8 @@ module tracking
   use string,          only: to_str
   use tally,           only: score_analog_tally, score_tracklength_tally, &
                              score_surface_current
+  use track_output,    only: initialize_particle_track, write_particle_track, &
+                             finalize_particle_track
 
 contains
 
@@ -67,8 +69,16 @@ contains
     ! Force calculation of cross-sections by setting last energy to zero 
     micro_xs % last_E = ZERO
 
+    ! Prepare to write out particle track.
+    if (p % write_track) then
+      call initialize_particle_track()
+    endif
+
     do while (p % alive)
 
+      ! Write particle track.
+      if (p % write_track) call write_particle_track(p)
+
       if (check_overlaps) call check_cell_overlap(p)
 
       ! Calculate microscopic and macroscopic cross sections -- note: if the
@@ -196,6 +206,12 @@ contains
 
     end do
 
+    ! Finish particle track output.
+    if (p % write_track) then
+      call write_particle_track(p)
+      call finalize_particle_track(p)
+    endif
+
   end subroutine transport
 
 end module tracking

src/utils/build_dependencies.py

@@ -11,16 +11,15 @@ for src in glob.iglob('*.F90'):
     d = re.findall(r'\n\s*use\s+(\w+)',
                    open(src, 'r').read())
     for name in d:
-        if name in ['mpi', 'hdf5', 'h5lt']:
+        if name in ['mpi', 'hdf5', 'h5lt', 'petscsys', 'petscmat', 'petscksp',
+                    'petscsnes', 'petscvec', 'omp_lib', 'fox_dom']:
             continue
-        if name.startswith('xml_data_'):
-            name = name.replace('xml_data_', 'templates/')
         deps.add(name)
     if deps:
         dependencies[module] = sorted(list(deps))
 
 
-for module in dependencies.keys():
+for module in sorted(dependencies.keys()):
     for dep in dependencies[module]:
         print("{0}.o: {1}.o".format(module, dep))
     print('')

src/utils/convert_xsdir.py

@@ -71,7 +71,7 @@ class Xsdir(object):
             # Handle continuation lines
             while words[-1] == '+':
                 extraWords = self.f.readline().split()
-                words = words + extraWords
+                words = words[:-1] + extraWords
             assert len(words) >= 7
 
             # Create XsdirTable object and add to line

src/utils/plot_mesh_tally.py

@@ -16,123 +16,161 @@ from matplotlib.backends.backend_qt4agg import NavigationToolbar2QTAgg as Naviga
 import numpy as np
 
 class AppForm(QMainWindow):
-    def __init__(self, parent=None):
+    def __init__(self, argv, parent=None):
         QMainWindow.__init__(self, parent)
 
         # Read data from source or leakage fraction file
-        self.get_file_data()
-        self.main_frame = QWidget() 
-        self.setCentralWidget(self.main_frame)
-       
-        # Create the Figure, Canvas, and Axes
-        self.dpi = 100
-        self.fig = Figure((5.0, 15.0), dpi=self.dpi)
-        self.canvas = FigureCanvas(self.fig)
-        self.canvas.setParent(self.main_frame)
-        self.axes = self.fig.add_subplot(111)
-        
-        # Create the navigation toolbar, tied to the canvas
-        self.mpl_toolbar = NavigationToolbar(self.canvas, self.main_frame)
+        self.all_good = False
+        while not self.all_good:
+            if len(argv) > 1:
+                cl_file = str(argv[1])
+            else:
+                cl_file = None
+            self.get_file_data(cl_file)
+            # Check that there are any mesh tallies at all
+            if len(self.tally_ids) != 0:
+                self.all_good = True
+            else:
+                # if there are not, the user will be given the choice to choose
+                # another file (but only if using interactive chooser)
+                if cl_file is None:
+                    choice = QMessageBox.critical(None, "Invalid StatePoint File",
+                                                  "File Does Not Contain Mesh " +
+                                                  "Tallies!" +
+                                                  "\nSelect Another File Or Quit",
+                                                  QMessageBox.Retry,
+                                                  QMessageBox.Abort)
+                    if choice == QMessageBox.Abort:
+                        self.all_good = False
+                        break
+                else:
+                    print("Invalid StatePoint File; File Does Not Contain " +
+                          "Mesh Tallies!")
+                    self.all_good = False
+                    break
 
-        # Grid layout at bottom
-        self.grid = QGridLayout()
 
-        # Overall layout
-        self.vbox = QVBoxLayout()
-        self.vbox.addWidget(self.canvas)
-        self.vbox.addWidget(self.mpl_toolbar)
-        self.vbox.addLayout(self.grid)
-        self.main_frame.setLayout(self.vbox)
+        if self.all_good:
+            # Set maximum colorbar value by maximum tally data value
+            self.maxvalue = self.datafile.tallies[0].results.max()
 
-        # Tally selections
-        label_tally = QLabel("Tally:")
-        self.tally = QComboBox()
-        self.tally.addItems([(str(i + 1)) for i in range(self.n_tallies)])
-        self.connect(self.tally, SIGNAL('activated(int)'),
-                     self._update)
-        self.connect(self.tally, SIGNAL('activated(int)'),
-                     self.populate_boxes)
-        self.connect(self.tally, SIGNAL('activated(int)'),
-                     self.on_draw)
+            self.main_frame = QWidget()
+            self.setCentralWidget(self.main_frame)
 
-        # Planar basis
-        label_basis = QLabel("Basis:")
-        self.basis = QComboBox()
-        self.basis.addItems(['xy', 'yz', 'xz'])
+            # Create the Figure, Canvas, and Axes
+            self.dpi = 100
+            self.fig = Figure((5.0, 15.0), dpi=self.dpi)
+            self.canvas = FigureCanvas(self.fig)
+            self.canvas.setParent(self.main_frame)
+            self.axes = self.fig.add_subplot(111)
 
-        # Update window when 'Basis' selection is changed
-        self.connect(self.basis, SIGNAL('activated(int)'),
-                     self._update)
-        self.connect(self.basis, SIGNAL('activated(int)'),
-                     self.populate_boxes)
-        self.connect(self.basis, SIGNAL('activated(int)'),
-                     self.on_draw)
+            # Create the navigation toolbar, tied to the canvas
+            self.mpl_toolbar = NavigationToolbar(self.canvas, self.main_frame)
 
-        # Axial level within selected basis
-        label_axial_level = QLabel("Axial Level:")
-        self.axial_level = QComboBox()
-        self.connect(self.axial_level, SIGNAL('activated(int)'),
-                     self.on_draw)
-                     
-        # Add Option to plot mean or uncertainty
-        label_mean = QLabel("Mean or Uncertainty:")
-        self.mean = QComboBox()
-        self.mean.addItems(['Mean','Absolute Uncertainty', 
-                            'Relative Uncertainty'])
-        
-        # Update window when mean selection is changed
-        self.connect(self.mean, SIGNAL('activated(int)'),
-                     self.on_draw)
-        
+            # Grid layout at bottom
+            self.grid = QGridLayout()
 
-        self.label_filters = QLabel("Filter options:")
+            # Overall layout
+            self.vbox = QVBoxLayout()
+            self.vbox.addWidget(self.canvas)
+            self.vbox.addWidget(self.mpl_toolbar)
+            self.vbox.addLayout(self.grid)
+            self.main_frame.setLayout(self.vbox)
 
-        # Labels for all possible filters
-        self.labels = {'cell': 'Cell: ', 'cellborn': 'Cell born: ',
-                       'surface': 'Surface: ', 'material': 'Material',
-                       'universe': 'Universe: ', 'energyin': 'Energy in: ',
-                       'energyout': 'Energy out: '}
-
-        # Empty reusable labels
-        self.qlabels = {}
-        for j in range(8):
-            self.nextLabel = QLabel
-            self.qlabels[j] = self.nextLabel
-
-        # Reusable comboboxes labelled with filter names
-        self.boxes = {}
-        for key in self.labels.keys():
-            self.nextBox = QComboBox()
-            self.connect(self.nextBox, SIGNAL('activated(int)'),
+            # Tally selections
+            label_tally = QLabel("Tally:")
+            self.tally = QComboBox()
+            # Only show options for the tallies with meshes
+            self.tally.addItems([str(i + 1) for i in self.tally_ids])
+            self.connect(self.tally, SIGNAL('activated(int)'),
+                         self._update)
+            self.connect(self.tally, SIGNAL('activated(int)'),
+                         self.populate_boxes)
+            self.connect(self.tally, SIGNAL('activated(int)'),
                          self.on_draw)
-            self.boxes[key] = self.nextBox
 
-        # Combobox to select among scores
-        self.score_label = QLabel("Score:")
-        self.scoreBox = QComboBox()
-        for item in self.tally_scores[0]:
-            self.scoreBox.addItems(str(item))
-        self.connect(self.scoreBox, SIGNAL('activated(int)'),
-                     self.on_draw)
+            # Planar basis
+            label_basis = QLabel("Basis:")
+            self.basis = QComboBox()
+            self.basis.addItems(['xy', 'yz', 'xz'])
 
-        # Fill layout
-        self.grid.addWidget(label_tally, 0, 0)
-        self.grid.addWidget(self.tally, 0, 1)
-        self.grid.addWidget(label_basis, 1, 0)
-        self.grid.addWidget(self.basis, 1, 1)
-        self.grid.addWidget(label_axial_level, 2, 0)
-        self.grid.addWidget(self.axial_level, 2, 1)
-        self.grid.addWidget(label_mean, 3, 0)
-        self.grid.addWidget(self.mean, 3, 1)
-        self.grid.addWidget(self.label_filters, 4, 0)
+            # Update window when 'Basis' selection is changed
+            self.connect(self.basis, SIGNAL('activated(int)'),
+                         self._update)
+            self.connect(self.basis, SIGNAL('activated(int)'),
+                         self.populate_boxes)
+            self.connect(self.basis, SIGNAL('activated(int)'),
+                         self.on_draw)
 
-        self._update()
-        self.populate_boxes() 
-        self.on_draw()
+            # Axial level within selected basis
+            label_axial_level = QLabel("Axial Level:")
+            self.axial_level = QComboBox()
+            self.connect(self.axial_level, SIGNAL('activated(int)'),
+                         self.on_draw)
 
-    def get_file_data(self):
+            # Add Option to plot mean or uncertainty
+            label_mean = QLabel("Mean or Uncertainty:")
+            self.mean = QComboBox()
+            self.mean.addItems(['Mean','Absolute Uncertainty',
+                                'Relative Uncertainty'])
+
+            # Update window when mean selection is changed
+            self.connect(self.mean, SIGNAL('activated(int)'),
+                         self.on_draw)
+
+
+            self.label_filters = QLabel("Filter options:")
+
+            # Labels for all possible filters
+            self.labels = {'cell': 'Cell: ', 'cellborn': 'Cell born: ',
+                           'surface': 'Surface: ', 'material': 'Material',
+                           'universe': 'Universe: ', 'energyin': 'Energy in: ',
+                           'energyout': 'Energy out: '}
+
+            # Empty reusable labels
+            self.qlabels = {}
+            for j in range(8):
+                self.nextLabel = QLabel
+                self.qlabels[j] = self.nextLabel
+
+            # Reusable comboboxes labelled with filter names
+            self.boxes = {}
+            for key in self.labels.keys():
+                self.nextBox = QComboBox()
+                self.connect(self.nextBox, SIGNAL('activated(int)'),
+                             self.on_draw)
+                self.boxes[key] = self.nextBox
+
+            # Combobox to select among scores
+            self.score_label = QLabel("Score:")
+            self.scoreBox = QComboBox()
+            for item in self.tally_scores[0]:
+                self.scoreBox.addItems(str(item))
+            self.connect(self.scoreBox, SIGNAL('activated(int)'),
+                         self.on_draw)
+
+            # Fill layout
+            self.grid.addWidget(label_tally, 0, 0)
+            self.grid.addWidget(self.tally, 0, 1)
+            self.grid.addWidget(label_basis, 1, 0)
+            self.grid.addWidget(self.basis, 1, 1)
+            self.grid.addWidget(label_axial_level, 2, 0)
+            self.grid.addWidget(self.axial_level, 2, 1)
+            self.grid.addWidget(label_mean, 3, 0)
+            self.grid.addWidget(self.mean, 3, 1)
+            self.grid.addWidget(self.label_filters, 4, 0)
+
+            self._update()
+            self.populate_boxes()
+            self.on_draw()
+
+    def get_file_data(self, cl_file=None):
         # Get data file name from "open file" browser
-        filename = QFileDialog.getOpenFileName(self, 'Select statepoint file', '.')
+        if cl_file is None:
+            filename = QFileDialog.getOpenFileName(self,
+                                                   'Select statepoint file', '.')
+        else:
+            filename = cl_file
 
         # Create StatePoint object and read in data
         self.datafile = StatePoint(str(filename))
@@ -141,32 +179,31 @@ class AppForm(QMainWindow):
 
         self.setWindowTitle('Core Map Tool : ' + str(self.datafile.path))
 
-        # Set maximum colorbar value by maximum tally data value
-        self.maxvalue = self.datafile.tallies[0].results.max()
-
         self.labelList = []
 
         # Read mesh dimensions
-#        for mesh in self.datafile.meshes:
-#            self.nx, self.ny, self.nz = mesh.dimension
+        # for mesh in self.datafile.meshes:
+        #  self.nx, self.ny, self.nz = mesh.dimension
 
-        # Read filter types from statepoint file
+        # Find which tallies have meshes so the rest can be ignored,
+        # and for these tallies read the filter and score types
+        self.tally_ids = []
         self.n_tallies = len(self.datafile.tallies)
         self.tally_list = []
-        for tally in self.datafile.tallies:
-            self.filter_types = []
-            for f in tally.filters:
-                self.filter_types.append(f)
-            self.tally_list.append(self.filter_types)
-
-        # Read score types from statepoint file
         self.tally_scores = []
-        for tally in self.datafile.tallies:
-            self.score_types = []
-            for s in tally.scores:
-                self.score_types.append(s)
-            self.tally_scores.append(self.score_types)
-#        print 'self.tally_scores = ', self.tally_scores
+        for itally, tally in enumerate(self.datafile.tallies):
+            if 'mesh' in tally.filters:
+                # Then we have a good tally, store the ID, filters and
+                # scores
+                self.tally_ids.append(itally)
+                self.filter_types = []
+                for f in tally.filters:
+                    self.filter_types.append(f)
+                self.tally_list.append(self.filter_types)
+                self.score_types = []
+                for s in tally.scores:
+                    self.score_types.append(s)
+                self.tally_scores.append(self.score_types)
 
     def on_draw(self):
         """ Redraws the figure
@@ -178,70 +215,73 @@ class AppForm(QMainWindow):
         axial_level = self.axial_level.currentIndex() + 1
         is_mean = self.mean.currentIndex()
 
+        # get current tally index
+        tally_id = self.tally_ids[self.tally.currentIndex()]
+
         # Create spec_list
         spec_list = []
-        for tally in self.datafile.tallies[self.tally.currentIndex()].filters.values():
+        for tally in self.datafile.tallies[tally_id].filters.values():
             if tally.type == 'mesh':
                 continue
             index = self.boxes[tally.type].currentIndex()
             spec_list.append((tally.type, index))
-        
+
         # Take is_mean and convert it to an index of the score
         score_loc = is_mean
         if score_loc > 1:
             score_loc = 1
-        
+
         if self.basis.currentText() == 'xy':
             matrix = np.zeros((self.nx, self.ny))
             for i in range(self.nx):
                 for j in range(self.ny):
-                    matrix[i,j] = self.datafile.get_value(self.tally.currentIndex(), 
-                        spec_list + [('mesh', (i, j, axial_level))], 
+                    matrix[i,j] = self.datafile.get_value(tally_id,
+                        spec_list + [('mesh', (i + 1, j + 1, axial_level))],
                         self.scoreBox.currentIndex())[score_loc]
                     # Calculate relative uncertainty from absolute, if
                     # requested
                     if is_mean == 2:
                         # Take care to handle zero means when normalizing
-                        mean_val = self.datafile.get_value(self.tally.currentIndex(), 
-                            spec_list + [('mesh', (i, j, axial_level))], 
+                        mean_val = self.datafile.get_value(tally_id,
+                            spec_list + [('mesh', (i + 1, j + 1, axial_level))],
                             self.scoreBox.currentIndex())[0]
                         if mean_val > 0.0:
                             matrix[i,j] = matrix[i,j] / mean_val
                         else:
                             matrix[i,j] = 0.0
-                        
+
         elif self.basis.currentText() == 'yz':
             matrix = np.zeros((self.ny, self.nz))
             for i in range(self.ny):
                 for j in range(self.nz):
-                    matrix[i,j] = self.datafile.get_value(self.tally.currentIndex(), 
-                        spec_list + [('mesh', (axial_level, i, j))], 
+                    matrix[i,j] = self.datafile.get_value(tally_id,
+                        spec_list + [('mesh', (axial_level, i + 1, j + 1))],
                         self.scoreBox.currentIndex())[score_loc]
                     # Calculate relative uncertainty from absolute, if
                     # requested
                     if is_mean == 2:
                         # Take care to handle zero means when normalizing
-                        mean_val = self.datafile.get_value(self.tally.currentIndex(), 
-                            spec_list + [('mesh', (axial_level, i, j))], 
+                        mean_val = self.datafile.get_value(tally_id,
+                            spec_list + [('mesh', (axial_level, i + 1, j + 1))],
                             self.scoreBox.currentIndex())[0]
                         if mean_val > 0.0:
                             matrix[i,j] = matrix[i,j] / mean_val
                         else:
                             matrix[i,j] = 0.0
-                   
+
         else:
             matrix = np.zeros((self.nx, self.nz))
             for i in range(self.nx):
                 for j in range(self.nz):
-                    matrix[i,j] = self.datafile.get_value(self.tally.currentIndex(), 
-                        spec_list + [('mesh', (i, axial_level, j))], 
+                    matrix[i,j] = self.datafile.get_value(tally_id,
+                        spec_list + [('mesh', (i + 1, axial_level, j + 1))],
                         self.scoreBox.currentIndex())[score_loc]
                     # Calculate relative uncertainty from absolute, if
                     # requested
                     if is_mean == 2:
                         # Take care to handle zero means when normalizing
-                        mean_val = self.datafile.get_value(self.tally.currentIndex(), 
-                            spec_list + [('mesh', (i, axial_level, j))], 
+                        mean_val = self.datafile.get_value(tally_id,
+                            spec_list + [('mesh', (i + 1, axial_level, j + 1))],
                             self.scoreBox.currentIndex())[0]
                         if mean_val > 0.0:
                             matrix[i,j] = matrix[i,j] / mean_val
@@ -255,8 +295,8 @@ class AppForm(QMainWindow):
 
         # Make figure, set up color bar
         self.axes = self.fig.add_subplot(111)
-        cax = self.axes.imshow(matrix, vmin=0.0, vmax=matrix.max(), 
-          interpolation="nearest")
+        cax = self.axes.imshow(matrix.transpose(), vmin=0.0, vmax=matrix.max(),
+          interpolation="nearest", origin='lower')
         self.fig.colorbar(cax)
 
         self.axes.set_xticks([])
@@ -271,9 +311,11 @@ class AppForm(QMainWindow):
         '''
 #        print 'Calling _update...'
 
+        # get current tally index
+        tally_id = self.tally_ids[self.tally.currentIndex()]
+
         self.mesh = self.datafile.meshes[
-          self.datafile.tallies[
-          self.tally.currentIndex()].filters['mesh'].bins[0] - 1]
+          self.datafile.tallies[tally_id].filters['mesh'].bins[0] - 1]
 
         self.nx, self.ny, self.nz = self.mesh.dimension
 
@@ -289,8 +331,7 @@ class AppForm(QMainWindow):
             self.axial_level.addItems([str(i+1) for i in range(self.ny)])
 
         # Determine maximum value from current tally data set
-        self.maxvalue = self.datafile.tallies[
-          self.tally.currentIndex()].results.max()
+        self.maxvalue = self.datafile.tallies[tally_id].results.max()
 #        print self.maxvalue
 
         # Clear and hide old filter labels
@@ -307,6 +348,9 @@ class AppForm(QMainWindow):
     def populate_boxes(self):
 #        print 'Calling populate_boxes...'
 
+        # get current tally index
+        tally_id = self.tally_ids[self.tally.currentIndex()]
+
         n = 5
         labels = {'cell': 'Cell : ',
                        'cellborn': 'Cell born: ',
@@ -317,8 +361,7 @@ class AppForm(QMainWindow):
         # For each filter in newly-selected tally, name a label and fill the
         # relevant combobox with options
         for element in self.tally_list[self.tally.currentIndex()]:
-            nextFilter = self.datafile.tallies[
-              self.tally.currentIndex()].filters[element]
+            nextFilter = self.datafile.tallies[tally_id].filters[element]
             if element == 'mesh':
                 continue
 
@@ -337,7 +380,7 @@ class AppForm(QMainWindow):
 
             elif element == 'energyin' or element == 'energyout':
                 for i in range(nextFilter.length):
-                    text = (str(nextFilter.bins[i]) + ' to ' + 
+                    text = (str(nextFilter.bins[i]) + ' to ' +
                       str(nextFilter.bins[i+1]))
                     combobox.addItem(text)
 
@@ -351,9 +394,10 @@ class AppForm(QMainWindow):
 
 def main():
     app = QApplication(sys.argv)
-    form = AppForm()
-    form.show()
-    app.exec_()
+    form = AppForm(app.arguments())
+    if form.all_good:
+        form.show()
+        app.exec_()
 
 
 if __name__ == "__main__":

src/utils/statepoint.py

@@ -1,7 +1,6 @@
 #!/usr/bin/env python2
 
 import struct
-from math import sqrt
 from collections import OrderedDict
 
 import numpy as np
@@ -10,10 +9,10 @@ import scipy.stats
 filter_types = {1: 'universe', 2: 'material', 3: 'cell', 4: 'cellborn',
                 5: 'surface', 6: 'mesh', 7: 'energyin', 8: 'energyout'}
 
-score_types = {-1: 'flux', 
+score_types = {-1: 'flux',
                 -2: 'total',
                 -3: 'scatter',
-                -4: 'nu-scatter', 
+                -4: 'nu-scatter',
                 -5: 'scatter-n',
                 -6: 'scatter-pn',
                 -7: 'transport',
@@ -152,6 +151,8 @@ class StatePoint(object):
 
         # Read statepoint revision
         self.revision = self._get_int(path='revision')[0]
+        if self.revision != 10:
+          raise Exception('Statepoint Revision is not consistent.')
 
         # Read OpenMC version
         if self._hdf5:
@@ -186,11 +187,29 @@ class StatePoint(object):
                 self.current_batch*self.gen_per_batch, path='k_generation')
             self.entropy = self._get_double(
                 self.current_batch*self.gen_per_batch, path='entropy')
-            if self.revision >= 8:
-                self.k_col_abs = self._get_double(path='k_col_abs')[0]
-                self.k_col_tra = self._get_double(path='k_col_tra')[0]
-                self.k_abs_tra = self._get_double(path='k_abs_tra')[0]
-                self.k_combined = self._get_double(2, path='k_combined')
+            self.k_col_abs = self._get_double(path='k_col_abs')[0]
+            self.k_col_tra = self._get_double(path='k_col_tra')[0]
+            self.k_abs_tra = self._get_double(path='k_abs_tra')[0]
+            self.k_combined = self._get_double(2, path='k_combined')
+
+            # Read CMFD information
+            cmfd_present = self._get_int(path='cmfd_on')[0]
+            if cmfd_present == 1:
+                self.cmfd_indices = self._get_int(4, path='cmfd/indicies')
+                self.k_cmfd = self._get_double(self.current_batch,
+                              path='cmfd/k_cmfd')
+                self.cmfd_src = self._get_double_array(np.product(self.cmfd_indices),
+                                path='cmfd/cmfd_src')
+                self.cmfd_src = np.reshape(self.cmfd_src,
+                                tuple(self.cmfd_indices), order='F')
+                self.cmfd_entropy = self._get_double(self.current_batch,
+                                    path='cmfd/cmfd_entropy')
+                self.cmfd_balance = self._get_double(self.current_batch,
+                                    path='cmfd/cmfd_balance')
+                self.cmfd_dominance = self._get_double(self.current_batch,
+                                      path='cmfd/cmfd_dominance')
+                self.cmfd_srccmp = self._get_double(self.current_batch,
+                                   path='cmfd/cmfd_srccmp')
 
         # Read number of meshes
         n_meshes = self._get_int(path='tallies/n_meshes')[0]
@@ -256,7 +275,7 @@ class StatePoint(object):
                     f.bins = self._get_int(path=base+'bins')
                 else:
                     f.bins = self._get_int(f.length, path=base+'bins')
-            
+
             base = 'tallies/tally' + str(i+1) + '/'
 
             # Read nuclide bins
@@ -309,7 +328,8 @@ class StatePoint(object):
                 if self._hdf5:
                     path = 'tallies/tally{0}/results'.format(i+1)
                     data = self._f[path].value
-                    t.results = np.dstack((data['sum'], data['sum_sq']))
+                    t.results = np.column_stack((data['sum'], data['sum_sq']))
+                    t.results.shape = (t.total_filter_bins, t.total_score_bins, 2)
                 else:
                     t.results = np.array(self._get_double(2*n))
                     t.results.shape = (t.total_filter_bins, t.total_score_bins, 2)
@@ -358,7 +378,7 @@ class StatePoint(object):
         Calculates the sample mean and standard deviation of the mean for each
         tally bin.
         """
-        
+
         # Determine number of realizations
         n = self.n_realizations
 
@@ -366,14 +386,14 @@ class StatePoint(object):
         for i in range(len(self.global_tallies)):
             # Get sum and sum of squares
             s, s2 = self.global_tallies[i]
-                    
+
             # Calculate sample mean and replace value
             s /= n
             self.global_tallies[i,0] = s
 
             # Calculate standard deviation
             if s != 0.0:
-                self.global_tallies[i,1] = t_value*sqrt((s2/n - s*s)/(n-1))
+                self.global_tallies[i,1] = t_value*np.sqrt((s2/n - s*s)/(n-1))
 
         # Regular tallies
         for t in self.tallies:
@@ -381,14 +401,14 @@ class StatePoint(object):
                 for j in range(t.results.shape[1]):
                     # Get sum and sum of squares
                     s, s2 = t.results[i,j]
-                    
+
                     # Calculate sample mean and replace value
                     s /= n
                     t.results[i,j,0] = s
 
                     # Calculate standard deviation
                     if s != 0.0:
-                        t.results[i,j,1] = t_value*sqrt((s2/n - s*s)/(n-1))
+                        t.results[i,j,1] = t_value*np.sqrt((s2/n - s*s)/(n-1))
 
     def get_value(self, tally_index, spec_list, score_index):
         """Returns a tally score given a list of filters to satisfy.
@@ -437,7 +457,7 @@ class StatePoint(object):
                 filter_index += value*t.filters[f_type].stride
             else:
                 filter_index += f_index*t.filters[f_type].stride
-        
+
         # Return the desired result from Tally.results. This could be the sum and
         # sum of squares, or it could be mean and stdev if self.generate_stdev()
         # has been called already.
@@ -510,7 +530,7 @@ class StatePoint(object):
         for i in range(n_filters):
 
             # compute indices for filter combination
-            filters[:,n_filters - i - 1] = np.floor((np.arange(n_bins) % 
+            filters[:,n_filters - i - 1] = np.floor((np.arange(n_bins) %
                    np.prod(filtmax[0:i+2]))/(np.prod(filtmax[0:i+1]))) + 1
 
             # append in dictionary bin with filter
@@ -523,14 +543,14 @@ class StatePoint(object):
                 dims.reverse()
                 dims = np.asarray(dims)
                 if score_str == 'current':
-                    dims += 1 
-                meshmax[1:4] = dims 
+                    dims += 1
+                meshmax[1:4] = dims
                 mesh_bins = np.zeros((n_bins,3))
-                mesh_bins[:,2] = np.floor(((filters[:,n_filters - i - 1] - 1) % 
+                mesh_bins[:,2] = np.floor(((filters[:,n_filters - i - 1] - 1) %
                             np.prod(meshmax[0:2]))/(np.prod(meshmax[0:1]))) + 1
-                mesh_bins[:,1] = np.floor(((filters[:,n_filters - i - 1] - 1) % 
+                mesh_bins[:,1] = np.floor(((filters[:,n_filters - i - 1] - 1) %
                             np.prod(meshmax[0:3]))/(np.prod(meshmax[0:2]))) + 1
-                mesh_bins[:,0] = np.floor(((filters[:,n_filters - i - 1] - 1) % 
+                mesh_bins[:,0] = np.floor(((filters[:,n_filters - i - 1] - 1) %
                             np.prod(meshmax[0:4]))/(np.prod(meshmax[0:3]))) + 1
                 data.update({'mesh':zip(mesh_bins[:,0],mesh_bins[:,1],
                             mesh_bins[:,2])})
@@ -555,7 +575,7 @@ class StatePoint(object):
     def _get_data(self, n, typeCode, size):
         return list(struct.unpack('={0}{1}'.format(n,typeCode),
                                   self._f.read(n*size)))
-    
+
     def _get_int(self, n=1, path=None):
         if self._hdf5:
             return [int(v) for v in self._f[path].value]
@@ -580,6 +600,12 @@ class StatePoint(object):
         else:
             return [float(v) for v in self._get_data(n, 'd', 8)]
 
+    def _get_double_array(self, n=1, path=None):
+        if self._hdf5:
+            return self._f[path].value
+        else:
+            return self._get_data(n, 'd', 8)
+
     def _get_string(self, n=1, path=None):
         if self._hdf5:
             return str(self._f[path].value)

src/utils/track.py

@@ -0,0 +1,99 @@
+#!/usr/bin/env python2
+"""Convert binary particle track to VTK poly data.
+
+Usage information can be obtained by running 'track.py --help':
+
+    usage: track.py [-h] [-o OUT] IN [IN ...]
+
+    Convert particle track file to a .pvtp file.
+
+    positional arguments:
+      IN                 Input particle track data filename(s).
+
+    optional arguments:
+      -h, --help         show this help message and exit
+      -o OUT, --out OUT  Output VTK poly data filename.
+
+"""
+
+import os
+import argparse
+import struct
+import vtk
+
+
+def _parse_args():
+    # Create argument parser.
+    parser = argparse.ArgumentParser(
+        description='Convert particle track file to a .pvtp file.')
+    parser.add_argument('input', metavar='IN', type=str, nargs='+',
+                        help='Input particle track data filename(s).')
+    parser.add_argument('-o', '--out', metavar='OUT', type=str, dest='out',
+                        help='Output VTK poly data filename.')
+
+    # Parse and return commandline arguments.
+    return parser.parse_args()
+
+
+def main():
+    # Parse commandline arguments.
+    args = _parse_args()
+
+    # Check input file extensions.
+    for fname in args.input:
+        if not (fname.endswith('.h5') or fname.endswith('.binary')):
+            raise ValueError("Input file names must either end with '.h5' or"
+                             "'.binary'.")
+    
+    # Make sure that the output filename ends with '.pvtp'.
+    if not args.out:
+        args.out = 'tracks.pvtp'
+    elif os.path.splitext(args.out)[1] != '.pvtp':
+        args.out = ''.join([args.out, '.pvtp'])
+
+    # Import HDF library if HDF files are present
+    for fname in args.input:
+        if fname.endswith('.h5'):
+            import h5py
+            break
+
+    # Initialize data arrays and offset.
+    points = vtk.vtkPoints()
+    cells = vtk.vtkCellArray()
+    point_offset = 0
+    for fname in args.input:
+        # Write coordinate values to points array.
+        if fname.endswith('.binary'):
+            track = open(fname, 'rb').read()
+            coords = [struct.unpack("ddd", track[24*i : 24*(i+1)])
+                      for i in range(len(track)/24)]
+            n_points = len(coords)
+            for triplet in coords:
+                points.InsertNextPoint(triplet)
+        else:
+            coords = h5py.File(fname).get('coordinates')
+            n_points = coords.shape[0]
+            for i in range(n_points):
+                points.InsertNextPoint(coords[i,:])
+                
+        # Create VTK line and assign points to line.
+        line = vtk.vtkPolyLine()
+        line.GetPointIds().SetNumberOfIds(n_points)
+        for i in range(n_points):
+            line.GetPointIds().SetId(i, point_offset+i)
+        
+        cells.InsertNextCell(line)
+        point_offset += n_points
+    data = vtk.vtkPolyData()
+    data.SetPoints(points)
+    data.SetLines(cells)
+    
+    writer = vtk.vtkXMLPPolyDataWriter()
+    writer.SetInput(data)
+    writer.SetFileName(args.out)
+    writer.Write()
+
+
+
+if __name__ == '__main__':
+    main()

src/vector_header.F90

@@ -0,0 +1,126 @@
+module vector_header
+
+  use constants,  only: ZERO
+
+#ifdef PETSC
+  use petscvec
+#endif
+
+  implicit none
+  private
+
+  type, public :: Vector 
+    integer :: n        ! number of rows/cols in matrix
+    real(8), allocatable :: data(:) ! where vector data is stored
+    real(8), pointer :: val(:) ! pointer to vector data
+#  ifdef PETSC
+    type(vec) :: petsc_vec ! PETSc vector
+#  endif
+    logical :: petsc_active ! Logical if PETSc is being used
+   contains
+     procedure :: create       => vector_create
+     procedure :: destroy      => vector_destroy
+     procedure :: add_value    => vector_add_value
+     procedure :: setup_petsc  => vector_setup_petsc
+     procedure :: write_petsc_binary => vector_write_petsc_binary
+  end type Vector
+
+  integer :: petsc_err ! petsc error code
+
+contains
+
+!===============================================================================
+! VECTOR_CREATE allocates and initializes a vector 
+!===============================================================================
+
+  subroutine vector_create(self, n)
+
+    integer, intent(in)                    :: n    ! size of vector
+    class(Vector), intent(inout), target   :: self ! vector instance
+
+    ! Preallocate vector
+    if (.not.allocated(self % data)) allocate(self % data(n))
+    self % val => self % data(1:n)
+
+    ! Set n
+    self % n = n
+
+    ! Initialize to zero
+    self % val = ZERO
+
+    ! Petsc is default not active
+    self % petsc_active = .false.
+
+  end subroutine vector_create
+
+!===============================================================================
+! VECTOR_DESTROY deallocates all space associated with a vector
+!===============================================================================
+
+  subroutine vector_destroy(self)
+
+    class(Vector), intent(inout) :: self ! vector instance
+
+#ifdef PETSC
+    if (self % petsc_active) call VecDestroy(self % petsc_vec, petsc_err)
+#endif
+
+    if (associated(self % val)) nullify(self % val)
+    if (allocated(self % data)) deallocate(self % data)
+
+  end subroutine vector_destroy
+
+!===============================================================================
+! VECTOR_ADD_VALUE adds a value to the vector
+!===============================================================================
+
+  subroutine vector_add_value(self, idx, val)
+
+    integer, intent(in)          :: idx  ! index location in vector
+    real(8), intent(in)          :: val  ! value to add
+    class(Vector), intent(inout) :: self ! vector instance
+
+    self % val(idx) = val
+
+  end subroutine vector_add_value
+
+!===============================================================================
+! VECTOR_SETUP_PETSC links the data to a PETSc vector
+!===============================================================================
+
+  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
+
+!===============================================================================
+! VECTOR_WRITE_PETSC_BINARY writes the PETSc vector to a binary file
+!===============================================================================
+
+  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
+
+end module vector_header

src/xml-fortran/read_from_buffer.inc

@@ -1,79 +0,0 @@
-! Part of XML-Fortran library:
-!
-! $Id: read_from_buffer.inc,v 1.2 2006/03/26 19:05:48 arjenmarkus Exp $
-!
-   character(len=*), intent(in)                  :: buffer
-   integer, intent(inout)                        :: ierror
-
-   integer                                       :: n
-   integer                                       :: i
-   integer                                       :: step
-   integer                                       :: ierr
-   !
-   ! First allocate an array that is surely large enough
-   ! Note:
-   ! This is not completely failsafe: with list-directed
-   ! input you can also use repeat counts (10000*1.0 for
-   ! instance).
-   !
-   allocate( work(len(buffer)/2+1) )
-
-   !
-   ! NOTE:
-   ! This is not portable!!
-   !
-   ! read( buffer, *, iostat = ierror ) (work(n), n=1,size(work))
-   !
-   ! So, use a different strategy: a binary search
-   ! First: establish that we have at least one item to read
-   ! Second: do the binary search
-   !
-!   read( buffer, *, iostat = ierr ) work(1)
-!   if ( ierr /= 0 ) then
-!      n = 0
-!   else
-      n = 1
-      do while ( n <= size(work) )
-         n = 2 * n
-      enddo
-      n    = n / 2
-      step = n / 2
-!      step = n / 2
-
-      do while ( step > 0 )
-         read( buffer, *, iostat = ierr ) (work(i), i = 1,n)
-         if ( ierr /= 0 ) then
-            ierror = ierr       ! Store the error code for later use
-            n = n - step
-         else
-            n = n + step
-         endif
-         step = step / 2
-      enddo
-!   endif
-
-   !
-   ! Then allocate an array of the actual size needed
-   ! and copy the data
-   !
-   !
-   if ( associated( var ) ) then
-      deallocate( var )
-   endif
-   !
-   ! One complication: we may have one too many
-   ! (consequence of the binary search)
-   !
-   read( buffer, *, iostat = ierr ) (work(i), i = 1,n)
-   if ( ierr < 0 ) then
-      n = n - 1
-   endif
-
-   allocate( var(n) )
-   var(1:n) = work(1:n)
-   deallocate( work )
-
-   if ( ierror .lt. 0 ) then
-      ierror = 0
-   endif
-

src/xml-fortran/read_xml_array.inc

@@ -1,54 +0,0 @@
-! Part of XML-Fortran library:
-!
-! $Id: read_xml_array.inc,v 1.3 2007/02/26 20:33:38 arjenmarkus Exp $
-!
-   type(XML_PARSE), intent(inout)                :: info
-   character(len=*), intent(in)                  :: tag
-   logical, intent(inout)                        :: endtag
-   character(len=*), dimension(:,:), intent(in)  :: attribs
-   integer, intent(in)                           :: noattribs
-   character(len=*), dimension(:), intent(in)    :: data
-   integer, intent(in)                           :: nodata
-   logical, intent(inout)                        :: has_var
-
-   character(len=len(attribs(1,1)))              :: buffer
-   integer                                       :: idx
-   integer                                       :: ierr
-
-   !
-   ! The big trick:
-   ! A string long enough to hold all data strings
-   !
-   character(len=nodata*(len(data(1))+1))        :: bufferd
-   integer                                       :: start
-
-   !
-   ! The value can be stored in an attribute values="..." or in
-   ! the data
-   !
-   has_var = .false.
-   idx = xml_find_attrib( attribs, noattribs, 'values', buffer )
-   if ( idx .gt. 0 ) then
-      call read_from_buffer( buffer, var, ierr )
-      if ( buffer .ne. ' ' ) then
-         has_var = .true.
-      endif
-   else
-      bufferd = ' '
-      start   = 1
-      do idx = 1,nodata
-         if ( data(idx) .ne. ' ' ) then
-            bufferd(start:) = data(idx)
-            start           = start + len(data(idx)) + 1
-         endif
-      enddo
-      call read_from_buffer( bufferd, var, ierr )
-      if ( bufferd .ne. ' ' ) then
-         has_var = .true.
-      endif
-   endif
-
-   if ( ierr .ne. 0 ) then
-      write(*,*) 'Error reading variable - tag = ', trim(tag)
-      has_var = .false.
-   endif

src/xml-fortran/read_xml_primitives.f90

@@ -1,527 +0,0 @@
-! read_xml_prims.f90 - Read routines for primitive data
-!
-! $Id: read_xml_prims.f90,v 1.7 2007/12/07 10:38:41 arjenmarkus Exp $
-!
-! Arjen Markus
-!
-! General information:
-! This module is part of the XML-Fortran library. Its
-! purpose is to help read individual items from an XML
-! file into the variables that have been connected to
-! the various tags. It is used by the code generated
-! by the make_xml_reader program.
-!
-! Because the routines differ mostly by the type of the
-! output variable, the body is included, to prevent
-! too much repeated blocks of code with all the maintenance
-! issues that causes.
-!
-module read_xml_primitives
-   use xmlparse
-   implicit none
-
-   private :: read_from_buffer
-   private :: read_from_buffer_integers
-   private :: read_from_buffer_reals
-   private :: read_from_buffer_doubles
-   private :: read_from_buffer_logicals
-   private :: read_from_buffer_words
-
-   interface read_from_buffer
-      module procedure read_from_buffer_integers
-      module procedure read_from_buffer_reals
-      module procedure read_from_buffer_doubles
-      module procedure read_from_buffer_logicals
-      module procedure read_from_buffer_words
-   end interface
-
-contains
-
-! skip_until_endtag --
-!    Routine to read the XML file until the end tag is encountered
-!
-! Arguments:
-!    info        The XML file data structure
-!    tag         The tag in question
-!    attribs     Array of attributes and their values
-!    data        Array of strings, representing the data
-!    error       Has an error occurred?
-!
-subroutine skip_until_endtag( info, tag, attribs, data, error )
-   type(XML_PARSE), intent(inout)                  :: info
-   character(len=*), intent(in)                    :: tag
-   character(len=*), dimension(:,:), intent(inout) :: attribs
-   character(len=*), dimension(:), intent(inout)   :: data
-   logical, intent(out)                            :: error
-
-   integer                                         :: noattribs
-   integer                                         :: nodata
-   integer                                         :: ierr
-   logical                                         :: endtag
-   character(len=len(tag))                         :: newtag
-
-   error = .true.
-   do
-      call xml_get( info, newtag, endtag, attribs, noattribs, &
-                    data, nodata )
-      if ( xml_error(info) ) then
-         error = .true.
-         exit
-      endif
-      if ( endtag .and. newtag == tag ) then
-         exit
-      endif
-   enddo
-end subroutine skip_until_endtag
-
-! read_xml_integer --
-!    Routine to read a single integer from the parsed data
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question (error message only)
-!    endtag      End tag found? (Dummy argument, actually)
-!    attribs     Array of attributes and their values
-!    noattribs   Number of attributes found
-!    data        Array of strings, representing the data
-!    nodata      Number of data strings
-!    var         Variable to be filled
-!    has_var     Has the variable been set?
-!
-subroutine read_xml_integer( info, tag, endtag, attribs, noattribs, data, nodata, &
-                             var, has_var )
-   integer, intent(inout)                       :: var
-
-   include 'read_xml_scalar.inc'
-
-end subroutine read_xml_integer
-
-! read_xml_line --
-!    Routine to read a single line of text from the parsed data
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question (error message only)
-!    endtag      End tag found? (Dummy argument, actually)
-!    attribs     Array of attributes and their values
-!    noattribs   Number of attributes found
-!    data        Array of strings, representing the data
-!    nodata      Number of data strings
-!    var         Variable to be filled
-!    has_var     Has the variable been set?
-!
-subroutine read_xml_line( info, tag, endtag, attribs, noattribs, data, nodata, &
-                          var, has_var )
-   type(XML_PARSE), intent(inout)               :: info
-   character(len=*), intent(in)                 :: tag
-   logical, intent(inout)                       :: endtag
-   character(len=*), dimension(:,:), intent(in) :: attribs
-   integer, intent(in)                          :: noattribs
-   character(len=*), dimension(:), intent(in)   :: data
-   integer, intent(in)                          :: nodata
-   character(len=*), intent(inout)              :: var
-   logical, intent(inout)                       :: has_var
-
-   character(len=len(attribs(1,1)))             :: buffer
-   integer                                      :: idx
-   integer                                      :: ierr
-
-   !
-   ! The value can be stored in an attribute value="..." or in
-   ! the data
-   !
-   has_var = .false.
-   idx = xml_find_attrib( attribs, noattribs, 'value', buffer )
-   if ( idx > 0 ) then
-      var     = buffer
-      has_var = .true.
-   else
-      do idx = 1,nodata
-         if ( data(idx) /= ' ' ) then
-            var = data(idx)
-            has_var = .true.
-            exit
-         endif
-      enddo
-   endif
-end subroutine read_xml_line
-
-! read_xml_real, ... --
-!    See read_xml_integer for an explanation
-!
-subroutine read_xml_real( info, tag, endtag, attribs, noattribs, data, nodata, &
-                          var, has_var )
-   real, intent(inout)                          :: var
-
-   include 'read_xml_scalar.inc'
-
-end subroutine read_xml_real
-
-subroutine read_xml_double( info, tag, endtag, attribs, noattribs, data, nodata, &
-                            var, has_var )
-   real(kind=kind(1.0d00)), intent(inout)       :: var
-
-   include 'read_xml_scalar.inc'
-
-end subroutine read_xml_double
-
-subroutine read_xml_logical( info, tag, endtag, attribs, noattribs, data, nodata, &
-                             var, has_var )
-   logical, intent(inout)       :: var
-
-   include 'read_xml_scalar.inc'
-
-end subroutine read_xml_logical
-
-subroutine read_xml_word( info, tag, endtag, attribs, noattribs, data, nodata, &
-                          var, has_var )
-   character(len=*), intent(inout)       :: var
-
-   include 'read_xml_word.inc'
-
-end subroutine read_xml_word
-
-! read_xml_integer_array --
-!    Routine to read a one-dimensional integer array from the parsed
-!    ata
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question (error message only)
-!    endtag      End tag found? (Dummy argument, actually)
-!    attribs     Array of attributes and their values
-!    noattribs   Number of attributes found
-!    data        Array of strings, representing the data
-!    nodata      Number of data strings
-!    var         Variable to be filled
-!    has_var     Has the variable been set?
-!
-subroutine read_xml_integer_array( info, tag, endtag, attribs, noattribs, data, &
-                                   nodata, var, has_var )
-   integer, dimension(:), pointer                :: var
-
-   include 'read_xml_array.inc'
-
-end subroutine read_xml_integer_array
-
-! read_xml_line_array --
-!    Routine to read an array of lines of text from the parsed data
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question (error message only)
-!    attribs     Array of attributes and their values
-!    noattribs   Number of attributes found
-!    data        Array of strings, representing the data
-!    nodata      Number of data strings
-!    var         Variable to be filled
-!    has_var     Has the variable been set?
-!
-subroutine read_xml_line_array( info, tag, endtag, attribs, noattribs, data, &
-                                nodata, var, has_var )
-   type(XML_PARSE), intent(inout)                :: info
-   character(len=*), intent(in)                  :: tag
-   logical, intent(inout)                        :: endtag
-   character(len=*), dimension(:,:), intent(in)  :: attribs
-   integer, intent(in)                           :: noattribs
-   character(len=*), dimension(:), intent(in)    :: data
-   integer, intent(in)                           :: nodata
-   character(len=*), dimension(:), pointer       :: var
-   logical, intent(inout)                        :: has_var
-
-   character(len=len(attribs(1,1)))              :: buffer
-   integer                                       :: idx
-   integer                                       :: idxv
-   integer                                       :: ierr
-   logical                                       :: started
-
-   !
-   ! The value can be stored in an attribute values="..." or in
-   ! the data
-   !
-   has_var = .false.
-   idx = xml_find_attrib( attribs, noattribs, 'values', buffer )
-   if ( idx > 0 ) then
-      allocate( var(1:1) )
-      var(1) = buffer
-      if ( buffer /= ' ' ) then
-         has_var = .true.
-      endif
-   else
-      idxv    = 0
-      started = .false.
-      do idx = 1,nodata
-         if ( data(idx) /= ' ' .or. started ) then
-            if ( .not. started ) then
-               allocate( var(1:nodata-idx+1) )
-               started = .true.
-            endif
-            idxv = idxv + 1
-            var(idxv) = data(idx)
-         endif
-      enddo
-      if ( started ) then
-         has_var = .true.
-      endif
-   endif
-end subroutine read_xml_line_array
-
-! read_xml_real_array, ... --
-!    See read_xml_integer_array for an explanation
-!
-subroutine read_xml_real_array( info, tag, endtag, attribs, noattribs, data, &
-                                nodata, var, has_var )
-   real, dimension(:), pointer :: var
-
-   include 'read_xml_array.inc'
-
-end subroutine read_xml_real_array
-
-subroutine read_xml_double_array( info, tag, endtag, attribs, noattribs, data, &
-                                  nodata, var, has_var )
-   real(kind=kind(1.0d00)), dimension(:), pointer :: var
-
-   include 'read_xml_array.inc'
-
-end subroutine read_xml_double_array
-
-subroutine read_xml_logical_array( info, tag, endtag, attribs, noattribs, data, &
-                                   nodata, var, has_var )
-   logical, dimension(:), pointer :: var
-
-   include 'read_xml_array.inc'
-
-end subroutine read_xml_logical_array
-
-subroutine read_xml_word_array( info, tag, endtag, attribs, noattribs, data, &
-                                nodata, var, has_var )
-   character(len=*), dimension(:), pointer :: var
-
-   include 'read_xml_array.inc'
-
-end subroutine read_xml_word_array
-
-! read_from_buffer_integers --
-!    Routine to read all integers from a long string
-!
-! Arguments:
-!    buffer      String containing the data
-!    var         Variable to be filled
-!    ierror      Error flag
-!
-subroutine read_from_buffer_integers( buffer, var, ierror )
-   integer, dimension(:), pointer                :: var
-   integer, dimension(:), pointer                :: work
-
-   include 'read_from_buffer.inc'
-
-end subroutine read_from_buffer_integers
-
-! read_xml_from_buffer_reals, ... -
-!    See read_xml_from_buffer_integers for an explanation
-!
-subroutine read_from_buffer_reals( buffer, var, ierror )
-   real, dimension(:), pointer                :: var
-   real, dimension(:), pointer                :: work
-
-   include 'read_from_buffer.inc'
-
-end subroutine read_from_buffer_reals
-
-subroutine read_from_buffer_doubles( buffer, var, ierror )
-   real(kind=kind(1.0d00)), dimension(:), pointer :: var
-   real(kind=kind(1.0d00)), dimension(:), pointer :: work
-
-   include 'read_from_buffer.inc'
-
-end subroutine read_from_buffer_doubles
-
-subroutine read_from_buffer_logicals( buffer, var, ierror )
-   logical, dimension(:), pointer :: var
-   logical, dimension(:), pointer :: work
-
-   include 'read_from_buffer.inc'
-
-end subroutine read_from_buffer_logicals
-
-subroutine read_from_buffer_words( buffer, var, ierror )
-   character(len=*), dimension(:), pointer :: var
-   character(len=len(var)), dimension(:), pointer :: work
-
-   include 'read_from_buffer.inc'
-
-end subroutine read_from_buffer_words
-
-! read_xml_word_1dim, ... -
-!    Read an array of "words" (or ...) but from different elements
-!
-subroutine read_xml_integer_1dim( info, tag, endtag, attribs, noattribs, data, nodata, &
-                                  var, has_var )
-   type(XML_PARSE), intent(inout)                :: info
-   character(len=*), intent(in)                  :: tag
-   logical, intent(inout)                        :: endtag
-   character(len=*), dimension(:,:), intent(in)  :: attribs
-   integer, intent(in)                           :: noattribs
-   character(len=*), dimension(:), intent(in)    :: data
-   integer, intent(in)                           :: nodata
-   integer, dimension(:), pointer                :: var
-   logical, intent(inout)                        :: has_var
-
-   integer,dimension(:), pointer                 :: newvar
-   character(len=len(attribs(1,1)))              :: buffer
-   integer                                       :: newsize
-   integer                                       :: ierr
-
-   newsize = size(var) + 1
-   allocate( newvar(1:newsize) )
-   newvar(1:newsize-1) = var
-   deallocate( var )
-   var => newvar
-
-   call read_xml_integer( info, tag, endtag, attribs, noattribs, data, nodata, &
-                          var(newsize), has_var )
-
-end subroutine read_xml_integer_1dim
-
-subroutine read_xml_real_1dim( info, tag, endtag, attribs, noattribs, data, nodata, &
-                               var, has_var )
-   type(XML_PARSE), intent(inout)                :: info
-   character(len=*), intent(in)                  :: tag
-   logical, intent(inout)                        :: endtag
-   character(len=*), dimension(:,:), intent(in)  :: attribs
-   integer, intent(in)                           :: noattribs
-   character(len=*), dimension(:), intent(in)    :: data
-   integer, intent(in)                           :: nodata
-   real, dimension(:), pointer                   :: var
-   logical, intent(inout)                        :: has_var
-
-   real, dimension(:), pointer                   :: newvar
-   character(len=len(attribs(1,1)))              :: buffer
-   integer                                       :: newsize
-   integer                                       :: ierr
-
-   newsize = size(var) + 1
-   allocate( newvar(1:newsize) )
-   newvar(1:newsize-1) = var
-   deallocate( var )
-   var => newvar
-
-   call read_xml_real( info, tag, endtag, attribs, noattribs, data, nodata, &
-                       var(newsize), has_var )
-
-end subroutine read_xml_real_1dim
-
-subroutine read_xml_double_1dim( info, tag, endtag, attribs, noattribs, data, nodata, &
-                                 var, has_var )
-   type(XML_PARSE), intent(inout)                :: info
-   character(len=*), intent(in)                  :: tag
-   logical, intent(inout)                        :: endtag
-   character(len=*), dimension(:,:), intent(in)  :: attribs
-   integer, intent(in)                           :: noattribs
-   character(len=*), dimension(:), intent(in)    :: data
-   integer, intent(in)                           :: nodata
-   real(kind=kind(1.0d00)), dimension(:), pointer:: var
-   logical, intent(inout)                        :: has_var
-
-   real(kind=kind(1.0d00)), dimension(:), pointer:: newvar
-   character(len=len(attribs(1,1)))              :: buffer
-   integer                                       :: newsize
-   integer                                       :: ierr
-
-   newsize = size(var) + 1
-   allocate( newvar(1:newsize) )
-   newvar(1:newsize-1) = var
-   deallocate( var )
-   var => newvar
-
-   call read_xml_double( info, tag, endtag, attribs, noattribs, data, nodata, &
-                       var(newsize), has_var )
-
-end subroutine read_xml_double_1dim
-
-subroutine read_xml_logical_1dim( info, tag, endtag, attribs, noattribs, data, nodata, &
-                                  var, has_var )
-   type(XML_PARSE), intent(inout)                :: info
-   character(len=*), intent(in)                  :: tag
-   logical, intent(inout)                        :: endtag
-   character(len=*), dimension(:,:), intent(in)  :: attribs
-   integer, intent(in)                           :: noattribs
-   character(len=*), dimension(:), intent(in)    :: data
-   integer, intent(in)                           :: nodata
-   logical, dimension(:), pointer                :: var
-   logical, intent(inout)                        :: has_var
-
-   logical, dimension(:), pointer                :: newvar
-   character(len=len(attribs(1,1)))              :: buffer
-   integer                                       :: newsize
-   integer                                       :: ierr
-
-   newsize = size(var) + 1
-   allocate( newvar(1:newsize) )
-   newvar(1:newsize-1) = var
-   deallocate( var )
-   var => newvar
-
-   call read_xml_logical( info, tag, endtag, attribs, noattribs, data, nodata, &
-                          var(newsize), has_var )
-
-end subroutine read_xml_logical_1dim
-
-subroutine read_xml_word_1dim( info, tag, endtag, attribs, noattribs, data, nodata, &
-                             var, has_var )
-   type(XML_PARSE), intent(inout)                :: info
-   character(len=*), intent(in)                  :: tag
-   logical, intent(inout)                        :: endtag
-   character(len=*), dimension(:,:), intent(in)  :: attribs
-   integer, intent(in)                           :: noattribs
-   character(len=*), dimension(:), intent(in)    :: data
-   integer, intent(in)                           :: nodata
-   character(len=*), dimension(:), pointer       :: var
-   logical, intent(inout)                        :: has_var
-
-   character(len=len(var)),dimension(:), pointer :: newvar
-   character(len=len(attribs(1,1)))              :: buffer
-   integer                                       :: newsize
-   integer                                       :: ierr
-
-   newsize = size(var) + 1
-   allocate( newvar(1:newsize) )
-   newvar(1:newsize-1) = var
-   deallocate( var )
-   var => newvar
-
-   call read_xml_word( info, tag, endtag, attribs, noattribs, data, nodata, &
-                       var(newsize), has_var )
-
-end subroutine read_xml_word_1dim
-
-subroutine read_xml_line_1dim( info, tag, endtag, attribs, noattribs, data, nodata, &
-                             var, has_var )
-   type(XML_PARSE), intent(inout)                :: info
-   character(len=*), intent(in)                  :: tag
-   logical, intent(inout)                        :: endtag
-   character(len=*), dimension(:,:), intent(in)  :: attribs
-   integer, intent(in)                           :: noattribs
-   character(len=*), dimension(:), intent(in)    :: data
-   integer, intent(in)                           :: nodata
-   character(len=*), dimension(:), pointer       :: var
-   logical, intent(inout)                        :: has_var
-
-   character(len=len(var)),dimension(:), pointer :: newvar
-   character(len=len(attribs(1,1)))              :: buffer
-   integer                                       :: newsize
-   integer                                       :: ierr
-
-   newsize = size(var) + 1
-   allocate( newvar(1:newsize) )
-   newvar(1:newsize-1) = var
-   deallocate( var )
-   var => newvar
-
-   call read_xml_line( info, tag, endtag, attribs, noattribs, data, nodata, &
-                       var(newsize), has_var )
-
-end subroutine read_xml_line_1dim
-
-
-end module read_xml_primitives

src/xml-fortran/read_xml_scalar.inc

@@ -1,40 +0,0 @@
-! Part of XML-Fortran library:
-!
-! $Id: read_xml_scalar.inc,v 1.3 2007/02/26 20:33:38 arjenmarkus Exp $
-!
-   type(XML_PARSE), intent(inout)               :: info
-   character(len=*), intent(in)                 :: tag
-   logical, intent(inout)                       :: endtag
-   character(len=*), dimension(:,:), intent(in) :: attribs
-   integer, intent(in)                          :: noattribs
-   character(len=*), dimension(:), intent(in)   :: data
-   integer, intent(in)                          :: nodata
-   logical, intent(inout)                       :: has_var
-
-   character(len=len(attribs(1,1)))             :: buffer
-   integer                                      :: idx
-   integer                                      :: ierr
-
-   !
-   ! The value can be stored in an attribute value="..." or in
-   ! the data
-   !
-   has_var = .false.
-   idx = xml_find_attrib( attribs, noattribs, 'value', buffer )
-   if ( idx .gt. 0 ) then
-      read( buffer, *, iostat=ierr ) var
-      has_var = .true.
-   else
-      do idx = 1,nodata
-         if ( data(idx) .ne. ' ' ) then
-            read( data(idx), *, iostat=ierr ) var
-            has_var = .true.
-            exit
-         endif
-      enddo
-   endif
-
-   if ( ierr .ne. 0 ) then
-      write(*,*) 'Error reading variable - tag = ', trim(tag)
-      has_var = .false.
-   endif

src/xml-fortran/read_xml_word.inc

@@ -1,38 +0,0 @@
-! Part of XML-Fortran library:
-!
-   type(XML_PARSE), intent(inout)               :: info
-   character(len=*), intent(in)                 :: tag
-   logical, intent(inout)                       :: endtag
-   character(len=*), dimension(:,:), intent(in) :: attribs
-   integer, intent(in)                          :: noattribs
-   character(len=*), dimension(:), intent(in)   :: data
-   integer, intent(in)                          :: nodata
-   logical, intent(inout)                       :: has_var
-
-   character(len=len(attribs(1,1)))             :: buffer
-   integer                                      :: idx
-   integer                                      :: ierr
-
-   !
-   ! The value can be stored in an attribute value="..." or in
-   ! the data
-   !
-   has_var = .false.
-   idx = xml_find_attrib( attribs, noattribs, 'value', buffer )
-   if ( idx .gt. 0 ) then
-      read( buffer, *, iostat=ierr ) var
-      has_var = .true.
-   else
-      do idx = 1,nodata
-         if ( data(idx) .ne. ' ' ) then
-            read( data(idx), '(A)', iostat=ierr ) var
-            has_var = .true.
-            exit
-         endif
-      enddo
-   endif
-
-   if ( ierr .ne. 0 ) then
-      write(*,*) 'Error reading variable - tag = ', trim(tag)
-      has_var = .false.
-   endif

src/xml-fortran/write_xml_primitives.f90

@@ -1,489 +0,0 @@
-! write_xml_prims.f90 - Write routines for primitive data
-!
-! $Id: write_xml_prims.f90,v 1.2 2007/12/27 05:13:59 arjenmarkus Exp $
-!
-! Arjen Markus
-!
-! General information:
-! This module is part of the XML-Fortran library. Its
-! purpose is to write individual items to an XML
-! file using the right tag. It is used by the code generated
-! by the make_xml_reader program.
-!
-module write_xml_primitives
-    use xmlparse
-    implicit none
-
-!   interface write_to_xml
-!       module procedure write_to_xml_integers
-!       module procedure write_to_xml_reals
-!       module procedure write_to_xml_doubles
-!       module procedure write_to_xml_logicals
-!       module procedure write_to_xml_words
-!   end interface
-    interface write_to_xml_word
-       module procedure write_to_xml_string
-    end interface
-    interface write_to_xml_line
-       module procedure write_to_xml_string
-    end interface
-
-contains
-
-! write_to_xml_integer --
-!    Routine to write a single integer to the XML file
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question
-!    indent      Number of spaces for indentation
-!    value       Value to be written
-!
-subroutine write_to_xml_integer( info, tag, indent, value )
-    type(XML_PARSE), intent(in)                  :: info
-    character(len=*), intent(in)                 :: tag
-    integer, intent(in)                          :: indent
-    integer, intent(in)                          :: value
-
-    character(len=100)                           :: indentation
-
-    indentation = ' '
-    write( info%lun, '(4a,i0,3a)' ) indentation(1:min(indent,100)), &
-        '<', trim(tag), '>', value, '</', trim(tag), '>'
-
-end subroutine write_to_xml_integer
-
-! write_to_xml_integer_1dim --
-!    Routine to write an array of integers to the XML file
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question
-!    indent      Number of spaces for indentation
-!    values      Values to be written
-!
-subroutine write_to_xml_integer_1dim( info, tag, indent, values )
-    type(XML_PARSE), intent(in)                  :: info
-    character(len=*), intent(in)                 :: tag
-    integer, intent(in)                          :: indent
-    integer, dimension(:), intent(in)            :: values
-
-    integer                                      :: i
-
-    do i = 1,size(values)
-        call write_to_xml_integer( info, tag, indent, values(i) )
-    enddo
-
-end subroutine write_to_xml_integer_1dim
-
-! write_to_xml_real --
-!    Routine to write a single real value (single precision) to the XML file
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question
-!    indent      Number of spaces for indentation
-!    value       Value to be written
-!
-subroutine write_to_xml_real( info, tag, indent, value )
-    type(XML_PARSE), intent(in)                  :: info
-    character(len=*), intent(in)                 :: tag
-    integer, intent(in)                          :: indent
-    real, intent(in)                             :: value
-
-    character(len=100)                           :: indentation
-    character(len=12)                            :: buffer
-
-    indentation = ' '
-    write( buffer, '(1pg12.4)' ) value
-    write( info%lun, '(8a)' ) indentation(1:min(indent,100)), &
-        '<', trim(tag), '>', trim(adjustl(buffer)), '</', trim(tag), '>'
-
-end subroutine write_to_xml_real
-
-! write_to_xml_real_1dim --
-!    Routine to write an array of reals to the XML file
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question
-!    indent      Number of spaces for indentation
-!    values      Values to be written
-!
-subroutine write_to_xml_real_1dim( info, tag, indent, values )
-    type(XML_PARSE), intent(in)                  :: info
-    character(len=*), intent(in)                 :: tag
-    integer, intent(in)                          :: indent
-    real, dimension(:), intent(in)               :: values
-
-    integer                                      :: i
-
-    do i = 1,size(values)
-        call write_to_xml_real( info, tag, indent, values(i) )
-    enddo
-
-end subroutine write_to_xml_real_1dim
-
-! write_to_xml_double --
-!    Routine to write one real value (double precision) to the XML file
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question
-!    indent      Number of spaces for indentation
-!    value       Value to be written
-!
-subroutine write_to_xml_double( info, tag, indent, value )
-    type(XML_PARSE), intent(in)                  :: info
-    character(len=*), intent(in)                 :: tag
-    integer, intent(in)                          :: indent
-    real(kind=kind(1.0d0)), intent(in)           :: value
-
-    character(len=100)                           :: indentation
-    character(len=16)                            :: buffer
-
-    indentation = ' '
-    write( buffer, '(1pg16.7)' ) value
-    write( info%lun, '(8a)' ) indentation(1:min(indent,100)), &
-        '<', trim(tag), '>', trim(adjustl(buffer)), '</', trim(tag), '>'
-
-end subroutine write_to_xml_double
-
-! write_to_xml_double_1dim --
-!    Routine to write an array of double precision reals to the XML file
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question
-!    indent      Number of spaces for indentation
-!    values      Values to be written
-!
-subroutine write_to_xml_double_1dim( info, tag, indent, values )
-    type(XML_PARSE), intent(in)                  :: info
-    character(len=*), intent(in)                 :: tag
-    integer, intent(in)                          :: indent
-    real(kind=kind(1.0d00)), dimension(:), intent(in) :: values
-
-    integer                                      :: i
-
-    do i = 1,size(values)
-        call write_to_xml_double( info, tag, indent, values(i) )
-    enddo
-
-end subroutine write_to_xml_double_1dim
-
-! write_to_xml_string --
-!    Routine to write one string to the XML file
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question
-!    indent      Number of spaces for indentation
-!    value       Value to be written
-!
-subroutine write_to_xml_string( info, tag, indent, value )
-    type(XML_PARSE), intent(in)                  :: info
-    character(len=*), intent(in)                 :: tag
-    integer, intent(in)                          :: indent
-    character(len=*), intent(in)                 :: value
-
-    character(len=100)                           :: indentation
-
-    !
-    ! NOTE: No guards against <, >, & and " yet!
-    ! NOTE: difference needed between words and lines?
-    !
-    indentation = ' '
-    write( info%lun, '(8a)' ) indentation(1:min(indent,100)), &
-        '<', trim(tag), '>', trim(value), '</', trim(tag), '>'
-
-end subroutine write_to_xml_string
-
-! write_to_xml_word_1dim --
-!    Routine to write an array of single words to the XML file
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question
-!    indent      Number of spaces for indentation
-!    value       Value to be written
-!
-subroutine write_to_xml_word_1dim( info, tag, indent, values )
-    type(XML_PARSE), intent(in)                  :: info
-    character(len=*), intent(in)                 :: tag
-    integer, intent(in)                          :: indent
-    character(len=*), dimension(:), intent(in)   :: values
-
-    integer                                      :: i
-
-    do i = 1,size(values)
-        call write_to_xml_string( info, tag, indent, values(i) )
-    enddo
-end subroutine write_to_xml_word_1dim
-
-! write_to_xml_string_1dim --
-!    Routine to write an array of strings to the XML file
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question
-!    indent      Number of spaces for indentation
-!    values      Values to be written
-!
-subroutine write_to_xml_string_1dim( info, tag, indent, values )
-    type(XML_PARSE), intent(in)                  :: info
-    character(len=*), intent(in)                 :: tag
-    integer, intent(in)                          :: indent
-    character(len=*), dimension(:), intent(in)   :: values
-
-    integer                                      :: i
-
-    do i = 1,size(values)
-        call write_to_xml_string( info, tag, indent, values(i) )
-    enddo
-
-end subroutine write_to_xml_string_1dim
-
-! write_to_xml_logical --
-!    Routine to write one logical to the XML file
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question
-!    indent      Number of spaces for indentation
-!    value       Value to be written
-!
-subroutine write_to_xml_logical( info, tag, indent, value )
-    type(XML_PARSE), intent(in)                  :: info
-    character(len=*), intent(in)                 :: tag
-    integer, intent(in)                          :: indent
-    logical, intent(in)                          :: value
-
-    character(len=100)                           :: indentation
-
-    indentation = ' '
-    if ( value ) then
-        write( info%lun, '(8a)' ) indentation(1:min(indent,100)), &
-            '<', trim(tag), '>true</', trim(tag), '>'
-    else
-        write( info%lun, '(8a)' ) indentation(1:min(indent,100)), &
-            '<', trim(tag), '>false</', trim(tag), '>'
-    endif
-
-end subroutine write_to_xml_logical
-
-! write_to_xml_logical_1dim --
-!    Routine to write an array of logicals to the XML file
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question
-!    indent      Number of spaces for indentation
-!    values      Values to be written
-!
-subroutine write_to_xml_logical_1dim( info, tag, indent, values )
-    type(XML_PARSE), intent(in)                  :: info
-    character(len=*), intent(in)                 :: tag
-    integer, intent(in)                          :: indent
-    logical, dimension(:), intent(in)            :: values
-
-    integer                                      :: i
-
-    do i = 1,size(values)
-        call write_to_xml_logical( info, tag, indent, values(i) )
-    enddo
-
-end subroutine write_to_xml_logical_1dim
-
-! write_to_xml_integer_array --
-!    Routine to write an array of integers to the XML file
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question
-!    indent      Number of spaces for indentation
-!    array       Values to be written
-!
-subroutine write_to_xml_integer_array( info, tag, indent, array )
-    type(XML_PARSE), intent(in)                  :: info
-    character(len=*), intent(in)                 :: tag
-    integer, intent(in)                          :: indent
-    integer, dimension(:), intent(in)            :: array
-
-    character(len=100)                           :: indentation
-    integer                                      :: i, i2, j
-
-    indentation = ' '
-
-    write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
-        '<', trim(tag), '>'
-    do i = 1,size(array),10
-        i2 = min( i + 9, size(array) )
-        write( info%lun, '(a,10i12)' ) indentation(1:min(indent+4,100)), &
-            ( array(j) ,j = i,i2 )
-    enddo
-    write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
-        '</', trim(tag), '>'
-
-end subroutine write_to_xml_integer_array
-
-! write_to_xml_real_array --
-!    Routine to write an array of single precision reals to the XML file
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question
-!    indent      Number of spaces for indentation
-!    array       Values to be written
-!
-subroutine write_to_xml_real_array( info, tag, indent, array )
-    type(XML_PARSE), intent(in)                  :: info
-    character(len=*), intent(in)                 :: tag
-    integer, intent(in)                          :: indent
-    real, dimension(:), intent(in)               :: array
-
-    character(len=100)                           :: indentation
-    integer                                      :: i, i2, j
-
-    indentation = ' '
-
-    write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
-        '<', trim(tag), '>'
-    do i = 1,size(array),10
-        i2 = min( i + 9, size(array) )
-        write( info%lun, '(a,10g12.4)' ) indentation(1:min(indent+4,100)), &
-            ( array(j) ,j = i,i2 )
-    enddo
-    write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
-        '</', trim(tag), '>'
-
-end subroutine write_to_xml_real_array
-
-! write_to_xml_double_array --
-!    Routine to write an array of double precision reals to the XML file
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question
-!    indent      Number of spaces for indentation
-!    array       Values to be written
-!
-subroutine write_to_xml_double_array( info, tag, indent, array )
-    type(XML_PARSE), intent(in)                  :: info
-    character(len=*), intent(in)                 :: tag
-    integer, intent(in)                          :: indent
-    real(kind=kind(1.0d0)), dimension(:), intent(in) :: array
-
-    character(len=100)                           :: indentation
-    integer                                      :: i, i2, j
-
-    indentation = ' '
-
-    write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
-        '<', trim(tag), '>'
-    do i = 1,size(array),5
-        i2 = min( i + 4, size(array) )
-        write( info%lun, '(a,5g20.7)' ) indentation(1:min(indent+4,100)), &
-            ( array(j) ,j = i,i2 )
-    enddo
-    write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
-        '</', trim(tag), '>'
-
-end subroutine write_to_xml_double_array
-
-! write_to_xml_logical_array --
-!    Routine to write an array of logicals to the XML file
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question
-!    indent      Number of spaces for indentation
-!    array       Values to be written
-!
-subroutine write_to_xml_logical_array( info, tag, indent, array )
-    type(XML_PARSE), intent(in)                  :: info
-    character(len=*), intent(in)                 :: tag
-    integer, intent(in)                          :: indent
-    logical, dimension(:), intent(in)            :: array
-
-    character(len=100)                           :: indentation
-    integer                                      :: i, i2, j
-
-    indentation = ' '
-
-    write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
-        '<', trim(tag), '>'
-    do i = 1,size(array),10
-        i2 = min( i + 9, size(array) )
-        write( info%lun, '(a,10a)' ) indentation(1:min(indent+4,100)), &
-            ( merge('true  ', 'false ', array(j)) ,j = i,i2 )
-    enddo
-    write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
-        '</', trim(tag), '>'
-
-end subroutine write_to_xml_logical_array
-
-! write_to_xml_word_array --
-!    Routine to write an array of words to the XML file
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question
-!    indent      Number of spaces for indentation
-!    array       Values to be written
-!
-subroutine write_to_xml_word_array( info, tag, indent, array )
-    type(XML_PARSE), intent(in)                  :: info
-    character(len=*), intent(in)                 :: tag
-    integer, intent(in)                          :: indent
-    character(len=*), dimension(:), intent(in)   :: array
-
-    character(len=100)                           :: indentation
-    integer                                      :: i, i2, j
-
-    indentation = ' '
-
-    write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
-        '<', trim(tag), '>'
-    do i = 1,size(array),10
-        i2 = min( i + 9, size(array) )
-        write( info%lun, '(a,20a)' ) indentation(1:min(indent+4,100)), &
-            ( trim(array(j)) , ' ' ,j = i,i2 )
-    enddo
-    write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
-        '</', trim(tag), '>'
-
-end subroutine write_to_xml_word_array
-
-! write_to_xml_line_array --
-!    Routine to write an array of lines to the XML file
-!
-! Arguments:
-!    info        XML parser structure
-!    tag         The tag in question
-!    indent      Number of spaces for indentation
-!    array       Values to be written
-!
-subroutine write_to_xml_line_array( info, tag, indent, array )
-    type(XML_PARSE), intent(in)                  :: info
-    character(len=*), intent(in)                 :: tag
-    integer, intent(in)                          :: indent
-    logical, dimension(:), intent(in)            :: array
-
-    character(len=100)                           :: indentation
-    integer                                      :: i
-
-    indentation = ' '
-
-    write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
-        '<', trim(tag), '>'
-    do i = 1,size(array)
-        write( info%lun, '(a)' ) indentation(1:min(indent+4,100)), &
-            array(i)
-    enddo
-    write( info%lun, '(4a)' ) indentation(1:min(indent,100)), &
-        '</', trim(tag), '>'
-
-end subroutine write_to_xml_line_array
-
-end module write_xml_primitives

src/xml-fortran/xml-fortran.LICENSE

@@ -1,37 +0,0 @@
-Note: The official xml-fortran repository on sourceforge
-<http://xml-fortran.sourceforge.net> only lists the license as "BSD License". It
-is assumed that this refers to the 3-clause BSD license ("modified" or "new")
-that is shown below.
-
-The license for xml-fortran covers all source code in the xml-fortran/
-directory.
-
-================================================================================
-
-Copyright (c) 2008 Arjen Markus
-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 Arjen Markus 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 ARJEN MARKUS 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.

src/xml/LICENSE

@@ -0,0 +1,71 @@
+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. 

src/xml/Makefile

@@ -0,0 +1,32 @@
+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

src/xml/README

@@ -0,0 +1,3 @@
+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/

src/xml/common/FoX_common.F90

@@ -0,0 +1,55 @@
+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

src/xml/common/Makefile

@@ -0,0 +1,59 @@
+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

src/xml/common/m_common_buffer.F90

@@ -0,0 +1,261 @@
+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

src/xml/common/m_common_charset.F90

@@ -0,0 +1,447 @@
+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

src/xml/common/m_common_content_model.F90

@@ -0,0 +1,490 @@
+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

src/xml/common/m_common_elstack.F90

@@ -0,0 +1,236 @@
+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

src/xml/common/m_common_entities.F90

@@ -0,0 +1,475 @@
+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

src/xml/common/m_common_entity_expand.F90

@@ -0,0 +1,86 @@
+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

src/xml/common/m_common_error.F90

@@ -0,0 +1,211 @@
+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

src/xml/common/m_common_io.F90

@@ -0,0 +1,102 @@
+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