diff --git a/.gitignore b/.gitignore index f67c611db..2dae450d0 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ # Compiled objects and modules +*.a *.o *.mod *.log @@ -18,6 +19,7 @@ src/openmc # Documentation builds docs/build +docs/source/_images/*.pdf # xml-fortran reader src/xml-fortran/xmlreader @@ -26,4 +28,7 @@ src/xml-fortran/xmlreader src/templates/*.f90 # Test results error file -results_error.dat \ No newline at end of file +results_error.dat + +# HDF5 files +*.h5 diff --git a/LICENSE b/LICENSE index f8d9cd7c0..0b9c35137 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2011-2013 Massachusetts Institute of Technology +Copyright (c) 2011-2014 Massachusetts Institute of Technology Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in diff --git a/data/cross_sections_nndc.xml b/data/cross_sections_nndc.xml new file mode 100644 index 000000000..2e421d7ab --- /dev/null +++ b/data/cross_sections_nndc.xml @@ -0,0 +1,1716 @@ + + + ascii + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/data/get_nndc_data.py b/data/get_nndc_data.py new file mode 100755 index 000000000..2e76401a4 --- /dev/null +++ b/data/get_nndc_data.py @@ -0,0 +1,96 @@ +#!/usr/bin/env python + +from __future__ import print_function +import os +import shutil +import subprocess +import sys +import tarfile + +try: + from urllib.request import urlopen +except ImportError: + from urllib2 import urlopen + +baseUrl = 'http://www.nndc.bnl.gov/endf/b7.1/aceFiles/' +files = ['ENDF-B-VII.1-neutron-293.6K.tar.gz', + 'ENDF-B-VII.1-neutron-300K.tar.gz', + 'ENDF-B-VII.1-neutron-900K.tar.gz', + 'ENDF-B-VII.1-neutron-1500K.tar.gz', + 'ENDF-B-VII.1-tsl.tar.gz'] +block_size = 16384 + +# ============================================================================== +# DOWNLOAD FILES FROM NNDC SITE + +filesComplete = [] +for f in files: + # Establish connection to URL + url = baseUrl + f + req = urlopen(url) + + # Get file size from header + file_size = int(req.info().getheaders('Content-Length')[0]) + downloaded = 0 + + # Check if file already downloaded + if os.path.exists(f): + if os.path.getsize(f) == file_size: + print('Skipping ' + f) + filesComplete.append(f) + continue + else: + if sys.version_info[0] < 3: + overwrite = raw_input('Overwrite {0}? ([y]/n) '.format(f)) + else: + overwrite = input('Overwrite {0}? ([y]/n) '.format(f)) + if overwrite.lower().startswith('n'): + continue + + # Copy file to disk + print('Downloading {0}... '.format(f), end='') + with open(f, 'wb') as fh: + while True: + chunk = req.read(block_size) + if not chunk: break + fh.write(chunk) + downloaded += len(chunk) + status = '{0:10} [{1:3.2f}%]'.format(downloaded, downloaded * 100. / file_size) + print(status + chr(8)*len(status), end='') + print('') + filesComplete.append(f) + +# ============================================================================== +# EXTRACT FILES FROM TGZ + +for f in files: + if not f in filesComplete: + continue + + # Extract files + suffix = f[f.rindex('-') + 1:].rstrip('.tar.gz') + with tarfile.open(f, 'r') as tgz: + print('Extracting {0}...'.format(f)) + tgz.extractall(path='nndc/' + suffix) + +# ============================================================================== +# COPY CROSS_SECTIONS.XML + +print('Copying cross_sections_nndc.xml...') +shutil.copyfile('cross_sections_nndc.xml', 'nndc/cross_sections.xml') + +# ============================================================================== +# PROMPT USER TO DELETE .TAR.GZ FILES + +# Ask user to delete +if sys.version_info[0] < 3: + response = raw_input('Delete *.tar.gz files? ([y]/n) ') +else: + response = input('Delete *.tar.gz files? ([y]/n) ') + +# Delete files if requested +if not response or response.lower().startswith('y'): + for f in files: + if os.path.exists(f): + print('Removing {0}...'.format(f)) + os.remove(f) diff --git a/data/readme.rst b/data/readme.rst index d975723b5..03685491d 100644 --- a/data/readme.rst +++ b/data/readme.rst @@ -15,6 +15,9 @@ work with a few common cross section sources. - **cross_sections_ascii.xml** -- This file matches ENDF/B-VII.0 cross sections distributed with MCNP5 / MCNP6 beta. +- **cross_sections_nndc.xml** -- This file matches ENDF/B-VII.1 cross sections + distributed from the `NNDC website`_. + - **cross_sections_serpent.xml** -- This file matches ENDF/B-VII.0 cross sections distributed with Serpent 1.1.7. @@ -31,3 +34,4 @@ element in your settings.xml, or set the CROSS_SECTIONS environment variable to the full path of the cross_sections.xml file. .. _user's guide: http://mit-crpg.github.io/openmc/usersguide/install.html#cross-section-configuration +.. _NNDC website: http://www.nndc.bnl.gov/endf/b7.1/acefiles.html diff --git a/docs/Makefile b/docs/Makefile index 8909256f3..89c71dc07 100644 --- a/docs/Makefile +++ b/docs/Makefile @@ -6,13 +6,19 @@ SPHINXOPTS = SPHINXBUILD = sphinx-build PAPER = BUILDDIR = build +IMAGEDIR = source/_images # Internal variables. PAPEROPT_a4 = -D latex_paper_size=a4 PAPEROPT_letter = -D latex_paper_size=letter ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) source -.PHONY: help clean html dirhtml singlehtml pickle json htmlhelp qthelp devhelp epub latex latexpdf text man changes linkcheck doctest +# SVG to PDF conversion +SVG2PDF = inkscape +PDFS = $(patsubst %.svg,%.pdf,$(wildcard $(IMAGEDIR)/*.svg)) + + +.PHONY: help images clean html dirhtml singlehtml pickle json htmlhelp qthelp devhelp epub latex latexpdf text man changes linkcheck doctest help: @echo "Please use \`make ' where is one of" @@ -33,8 +39,16 @@ help: @echo " linkcheck to check all external links for integrity" @echo " doctest to run all doctests embedded in the documentation (if enabled)" +# Pattern rule for converting SVG to PDF +%.pdf: %.svg + $(SVG2PDF) -f $< -A $@ + +# Rule to build PDFs +images: $(PDFS) + clean: -rm -rf $(BUILDDIR)/* + -rm $(PDFS) html: $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/html @@ -91,14 +105,14 @@ epub: @echo @echo "Build finished. The epub file is in $(BUILDDIR)/epub." -latex: +latex: images $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex @echo @echo "Build finished; the LaTeX files are in $(BUILDDIR)/latex." @echo "Run \`make' in that directory to run these through (pdf)latex" \ "(use \`make latexpdf' here to do that automatically)." -latexpdf: +latexpdf: images $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex @echo "Running LaTeX files through pdflatex..." make -C $(BUILDDIR)/latex all-pdf diff --git a/docs/source/_images/3dba.png b/docs/source/_images/3dba.png new file mode 100644 index 000000000..69de65414 Binary files /dev/null and b/docs/source/_images/3dba.png differ diff --git a/docs/img/3dcore.png b/docs/source/_images/3dcore.png similarity index 100% rename from docs/img/3dcore.png rename to docs/source/_images/3dcore.png diff --git a/docs/img/3dgeomplot.png b/docs/source/_images/3dgeomplot.png similarity index 100% rename from docs/img/3dgeomplot.png rename to docs/source/_images/3dgeomplot.png diff --git a/docs/source/_images/Tracks.png b/docs/source/_images/Tracks.png new file mode 100644 index 000000000..39c83cd59 Binary files /dev/null and b/docs/source/_images/Tracks.png differ diff --git a/docs/img/atr.png b/docs/source/_images/atr.png similarity index 100% rename from docs/img/atr.png rename to docs/source/_images/atr.png diff --git a/docs/img/fluxplot.png b/docs/source/_images/fluxplot.png similarity index 100% rename from docs/img/fluxplot.png rename to docs/source/_images/fluxplot.png diff --git a/docs/img/fork.png b/docs/source/_images/fork.png similarity index 100% rename from docs/img/fork.png rename to docs/source/_images/fork.png diff --git a/docs/img/halfspace.svg b/docs/source/_images/halfspace.svg similarity index 100% rename from docs/img/halfspace.svg rename to docs/source/_images/halfspace.svg diff --git a/docs/img/master-slave.png b/docs/source/_images/master-slave.png similarity index 100% rename from docs/img/master-slave.png rename to docs/source/_images/master-slave.png diff --git a/docs/img/nearest-neighbor-example.png b/docs/source/_images/nearest-neighbor-example.png similarity index 100% rename from docs/img/nearest-neighbor-example.png rename to docs/source/_images/nearest-neighbor-example.png diff --git a/docs/img/nearest-neighbor.png b/docs/source/_images/nearest-neighbor.png similarity index 100% rename from docs/img/nearest-neighbor.png rename to docs/source/_images/nearest-neighbor.png diff --git a/docs/img/openmc.png b/docs/source/_images/openmc.png similarity index 100% rename from docs/img/openmc.png rename to docs/source/_images/openmc.png diff --git a/docs/img/plotmeshtally.png b/docs/source/_images/plotmeshtally.png similarity index 100% rename from docs/img/plotmeshtally.png rename to docs/source/_images/plotmeshtally.png diff --git a/docs/img/pullrequest.png b/docs/source/_images/pullrequest.png similarity index 100% rename from docs/img/pullrequest.png rename to docs/source/_images/pullrequest.png diff --git a/docs/img/union.svg b/docs/source/_images/union.svg similarity index 100% rename from docs/img/union.svg rename to docs/source/_images/union.svg diff --git a/docs/img/uniongrid.svg b/docs/source/_images/uniongrid.svg similarity index 100% rename from docs/img/uniongrid.svg rename to docs/source/_images/uniongrid.svg diff --git a/docs/source/conf.py b/docs/source/conf.py index 8752b4898..7fb622631 100644 --- a/docs/source/conf.py +++ b/docs/source/conf.py @@ -39,7 +39,7 @@ master_doc = 'index' # General information about the project. project = u'OpenMC' -copyright = u'2011-2013, Massachusetts Institute of Technology' +copyright = u'2011-2014, Massachusetts Institute of Technology' # The version info for the project you're documenting, acts as replacement for # |version| and |release|, also used in various other places throughout the @@ -121,7 +121,7 @@ html_title = "OpenMC Documentation" # The name of an image file (relative to this directory) to place at the top # of the sidebar. -html_logo = '../img/openmc.png' +html_logo = '_images/openmc.png' # The name of an image file (within the static path) to use as favicon of the # docs. This file should be a Windows icon file (.ico) being 16x16 or 32x32 @@ -188,6 +188,8 @@ latex_documents = [ u'Massachusetts Institute of Technology', 'manual'), ] +latex_elements = {'preamble': '\\usepackage{enumitem}\\setlistdepth{9}'} + # The name of an image file (relative to this directory) to place at the top of # the title page. #latex_logo = None diff --git a/docs/source/devguide/index.rst b/docs/source/devguide/index.rst index 1eb7436d0..1ceba324c 100644 --- a/docs/source/devguide/index.rst +++ b/docs/source/devguide/index.rst @@ -15,6 +15,6 @@ as debugging. structures styleguide workflow - xml-fortran + xml-parsing statepoint voxel diff --git a/docs/source/devguide/statepoint.rst b/docs/source/devguide/statepoint.rst index 9862a4528..5f05c92c8 100644 --- a/docs/source/devguide/statepoint.rst +++ b/docs/source/devguide/statepoint.rst @@ -4,6 +4,296 @@ State Point Binary File Specifications ====================================== +----------- +Revision 11 +----------- + +**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:G,1:I,1:J,1:K)** + + 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) source_present** + + Flag indicated if source bank is present in the file + +**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 and source_present) + + *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 10 ----------- diff --git a/docs/source/devguide/workflow.rst b/docs/source/devguide/workflow.rst index 9562c9584..f3793628a 100644 --- a/docs/source/devguide/workflow.rst +++ b/docs/source/devguide/workflow.rst @@ -60,7 +60,7 @@ features and bug fixes. The general steps for contributing are as follows: repository with the same name under your personal account. As such, you can commit to it as you please without disrupting other developers. - .. image:: ../../img/fork.png + .. image:: ../_images/fork.png 2. Clone your fork of OpenMC and create a branch that branches off of *develop*: @@ -77,7 +77,7 @@ features and bug fixes. The general steps for contributing are as follows: 4. Issue a pull request from GitHub and select the *develop* branch of mit-crpg/openmc as the target. - .. image:: ../../img/pullrequest.png + .. image:: ../_images/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 diff --git a/docs/source/devguide/xml-fortran.rst b/docs/source/devguide/xml-fortran.rst deleted file mode 100644 index 456cd662f..000000000 --- a/docs/source/devguide/xml-fortran.rst +++ /dev/null @@ -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 ````` 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 diff --git a/docs/source/devguide/xml-parsing.rst b/docs/source/devguide/xml-parsing.rst new file mode 100644 index 000000000..8310d53e4 --- /dev/null +++ b/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 diff --git a/docs/source/license.rst b/docs/source/license.rst index a7d7f2976..e7f4b3a69 100644 --- a/docs/source/license.rst +++ b/docs/source/license.rst @@ -4,7 +4,7 @@ License Agreement ================= -Copyright © 2011-2013 Massachusetts Institute of Technology +Copyright © 2011-2014 Massachusetts Institute of Technology Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in diff --git a/docs/source/methods/cross_sections.rst b/docs/source/methods/cross_sections.rst index c564896c7..a193dde96 100644 --- a/docs/source/methods/cross_sections.rst +++ b/docs/source/methods/cross_sections.rst @@ -80,7 +80,7 @@ dashed box would need to be stored on a per-nuclide basis, and the union grid would need to be stored once. This method is also referred to as *double indexing* and is available as an option in Serpent (see paper by Leppanen_). -.. figure:: ../../img/uniongrid.svg +.. figure:: ../_images/uniongrid.* :width: 600px :align: center :figclass: align-center diff --git a/docs/source/methods/eigenvalue.rst b/docs/source/methods/eigenvalue.rst index a5ba0bf45..fe99ba22e 100644 --- a/docs/source/methods/eigenvalue.rst +++ b/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). diff --git a/docs/source/methods/geometry.rst b/docs/source/methods/geometry.rst index d4824f5d1..1515ffa89 100644 --- a/docs/source/methods/geometry.rst +++ b/docs/source/methods/geometry.rst @@ -45,7 +45,7 @@ surface by a combination of the unique ID of the surface and a positive/negative sign. The following illustration shows an example of an ellipse with unique ID 1 dividing space into two half-spaces. -.. figure:: ../../img/halfspace.svg +.. figure:: ../_images/halfspace.* :align: center :figclass: align-center @@ -60,7 +60,7 @@ half-space references whose intersection defines the region. The region is then assigned a material defined elsewhere. The following illustration shows an example of a cell defined as the intersection of an ellipse and two planes. -.. figure:: ../../img/union.svg +.. figure:: ../_images/union.* :align: center :figclass: align-center diff --git a/docs/source/methods/parallelization.rst b/docs/source/methods/parallelization.rst index 7f0b9bd6e..66ead52a2 100644 --- a/docs/source/methods/parallelization.rst +++ b/docs/source/methods/parallelization.rst @@ -65,7 +65,7 @@ in the case of an eigenvalue calculation). This idea is illustrated in .. _figure-master-slave: -.. figure:: ../../img/master-slave.png +.. figure:: ../_images/master-slave.png :align: center :figclass: align-center @@ -122,7 +122,7 @@ needed. This concept is illustrated in :ref:`Figure 2 .. _figure-nearest-neighbor: -.. figure:: ../../img/nearest-neighbor.png +.. figure:: ../_images/nearest-neighbor.png :align: center :figclass: align-center @@ -203,7 +203,7 @@ communicated between adjacent nodes. .. _figure-neighbor-example: -.. figure:: ../../img/nearest-neighbor-example.png +.. figure:: ../_images/nearest-neighbor-example.png :align: center :figclass: align-center diff --git a/docs/source/methods/physics.rst b/docs/source/methods/physics.rst index c79144dfe..54dc91345 100644 --- a/docs/source/methods/physics.rst +++ b/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`, +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: ---------------------------------------------- diff --git a/docs/source/publications.rst b/docs/source/publications.rst index d757b9c3c..df7ca639b 100644 --- a/docs/source/publications.rst +++ b/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). ``_ + +- 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). ``_ + +- 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.*, **28** (1), 87--96 + (2014). ``_ + - 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 diff --git a/docs/source/quickinstall.rst b/docs/source/quickinstall.rst index 2cee56987..ccbfabebe 100644 --- a/docs/source/quickinstall.rst +++ b/docs/source/quickinstall.rst @@ -48,7 +48,12 @@ following commands in a terminal: sudo make install This will build an executable named ``openmc`` and install it (by default in -/usr/local/bin). +/usr/local/bin). If you do not have administrator privileges, the last command +can be replaced with a local install, e.g. + +.. code-block:: sh + + make install -e prefix=$HOME/.local .. _GitHub: https://github.com/mit-crpg/openmc .. _git: http://git-scm.com diff --git a/docs/source/releasenotes/index.rst b/docs/source/releasenotes/index.rst index 9164fa594..d649b1403 100644 --- a/docs/source/releasenotes/index.rst +++ b/docs/source/releasenotes/index.rst @@ -10,6 +10,7 @@ bugs fixed, and known issues for each successive release. .. toctree:: :maxdepth: 1 + notes_0.5.4 notes_0.5.3 notes_0.5.2 notes_0.5.1 diff --git a/docs/source/releasenotes/notes_0.5.3.rst b/docs/source/releasenotes/notes_0.5.3.rst index c9c7aee38..6d93f9aec 100644 --- a/docs/source/releasenotes/notes_0.5.3.rst +++ b/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 ------------------- diff --git a/docs/source/releasenotes/notes_0.5.4.rst b/docs/source/releasenotes/notes_0.5.4.rst new file mode 100644 index 000000000..a69354aa0 --- /dev/null +++ b/docs/source/releasenotes/notes_0.5.4.rst @@ -0,0 +1,64 @@ +.. _notes_0.5.4: + +============================== +Release Notes for OpenMC 0.5.4 +============================== + +------------------- +System Requirements +------------------- + +There are no special requirements for running the OpenMC code. As of this +release, OpenMC has been tested on a variety of Linux distributions, Mac OS X, +and Microsoft Windows 7. Memory requirements will vary depending on the size of +the problem at hand (mostly on the number of nuclides in the problem). + +------------ +New Features +------------ + +- Source sites outside geometry are resampled +- XML-Fortran backend replaced by FoX XML +- Ability to write particle track files +- Handle lost particles more gracefully (via particle track files) +- Multiple random number generator streams +- Mesh tally plotting utility converted to use Tkinter rather than PyQt +- Script added to download ACE data from NNDC +- Mixed ASCII/binary cross_sections.xml now allowed +- Expanded options for writing source bank +- Re-enabled ability to use source file as starting source +- S(a,b) recalculation avoided when same nuclide and S(a,b) table are accessed + +--------- +Bug Fixes +--------- + +- 32c03c_: Check for valid data in cross_sections.xml +- c71ef5_: Fix bug in statepoint.py +- 8884fb_: Check for all ZAIDs for S(a,b) tables +- b38af0_: Fix XML reading on multiple levels of input +- d28750_: Fix bug in convert_xsdir.py +- cf567c_: ENDF/B-VI data checked for compatibility +- 6b9461_: Fix p_valid sampling inside of sample_energy + +.. _32c03c: https://github.com/mit-crpg/openmc/commit/32c03c +.. _c71ef5: https://github.com/mit-crpg/openmc/commit/c71ef5 +.. _8884fb: https://github.com/mit-crpg/openmc/commit/8884fb +.. _b38af0: https://github.com/mit-crpg/openmc/commit/b38af0 +.. _d28750: https://github.com/mit-crpg/openmc/commit/d28750 +.. _cf567c: https://github.com/mit-crpg/openmc/commit/cf567c +.. _6b9461: https://github.com/mit-crpg/openmc/commit/6b9461 + +------------ +Contributors +------------ + +This release contains new contributions from the following people: + +- `Sterling Harper `_ +- `Bryan Herman `_ +- `Nick Horelik `_ +- `Adam Nelson `_ +- `Paul Romano `_ +- `Tuomas Viitanen `_ +- `Jon Walsh `_ diff --git a/docs/source/usersguide/input.rst b/docs/source/usersguide/input.rst index 1ae061f4c..eebe6bfc1 100644 --- a/docs/source/usersguide/input.rst +++ b/docs/source/usersguide/input.rst @@ -198,19 +198,26 @@ tally data, this option can significantly improve the parallel efficiency. -------------------- The ```` 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. - summary cross_sections + *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. ```` Element ------------------------- @@ -257,7 +264,9 @@ attributes/sub-elements: :file: If this attribute is given, it indicates that the source is to be read from - a binary source file whose path is given by the value of this element + a binary source file whose path is given by the value of this element. Note, + the number of source sites needs to be the same as the number of particles + simulated in a fission source generation. *Default*: None @@ -341,8 +350,10 @@ attributes/sub-elements: The ```` element indicates at what batches a state point file should be written. A state point file can be used to restart a run or to get -tally results at any batch. This element has the following -attributes/sub-elements: +tally results at any batch. The default behavior when using this tag is to +write out the source bank in the state_point file. This behavior can be +customized by using the ```` element. This element has the +following attributes/sub-elements: :batches: A list of integers separated by spaces indicating at what batches a state @@ -357,19 +368,54 @@ attributes/sub-elements: *Default*: None +```` Element +-------------------------- + +The ```` element indicates at what batches the source bank +should be written. The source bank can be either written out within a state +point file or separately in a source point file. This element has the following +attributes/sub-elements: + + :batches: + A list of integers separated by spaces indicating at what batches a state + point file should be written. It should be noted that if source_separate + tag is not set to "true", this list must be a subset of state point batches. + + *Default*: Last batch only + + :interval: + A single integer :math:`n` indicating that a state point should be written + every :math:`n` batches. This option can be given in lieu of listing + batches explicitly. It should be noted that if source_separate tag is not + set to "true", this value should produce a list of batches that is a subset + of state point batches. + + *Default*: None + :source_separate: - If this element is set to "true", a separate binary source file will be + If this element is set to "true", a separate binary source point file will be written. Otherwise, the source sites will be written in the state point directly. *Default*: false - :source_write: If this element is set to "false", source sites are not written - to the state point file. This can substantially reduce the size of state - points if large numbers of particles per batch are used. + :source_write: + If this element is set to "false", source sites are not written + to the state point or source point file. This can substantially reduce the + size of state points if large numbers of particles per batch are used. *Default*: true + :overwrite_latest: + If this element is set to "true", a source point file containing + the source bank will be written out to a separate file named + ``source.binary`` or ``source.h5`` depending on if HDF5 is enabled. + This file will be overwritten at every single batch so that the latest + source bank will be available. It should be noted that a user can set both + this element to "true" and specify batches to write a permanent source bank. + + *Default*: false + ```` Element ------------------------------ @@ -398,6 +444,15 @@ integers: the batch number, generation number, and particle number. *Default*: None +.. _track: + +```` Element +------------------- + +The ```` 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 + ```` Element ------------------------ @@ -1036,7 +1091,7 @@ sub-elements: the PNG format can often times reduce the file size by orders of magnitude without any loss of image quality. Likewise, high-resolution voxel files produced by OpenMC can be quite large, - but the equivalent SILO files will by significantly smaller. + but the equivalent SILO files will be significantly smaller. *Default*: "slice" diff --git a/docs/source/usersguide/install.rst b/docs/source/usersguide/install.rst index 84f7633c2..2084878b7 100644 --- a/docs/source/usersguide/install.rst +++ b/docs/source/usersguide/install.rst @@ -78,7 +78,7 @@ Prerequisites ./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. + You may omit ``--enable-parallel`` if you want to compile HDF5_ in serial. * PETSc_ for CMFD acceleration @@ -93,7 +93,7 @@ Prerequisites --with-fortran-datatypes The BLAS/LAPACK library is not required to be downloaded and can be linked - explicitly (e.g., Intel MLK library). + explicitly (e.g., Intel MKL library). * git_ version control software for obtaining source code @@ -189,7 +189,15 @@ the root directory of the source code: sudo make install This will build an executable named ``openmc`` and install it (by default in -/usr/local/bin). +/usr/local/bin). If you do not have administrative privileges, you can install +OpenMC locally by replacing the last command with: + +.. code-block:: sh + + make install -e prefix=$HOME/.local + +The ``prefix`` variable can be changed to any path for which you have +write-access. Compiling on Windows -------------------- @@ -264,10 +272,27 @@ Cross Section Configuration In order to run a simulation with OpenMC, you will need cross section data for each nuclide in your problem. Since OpenMC uses ACE format cross sections, you -can use nuclear data that was processed with NJOY, such as that distributed with -MCNP_ or Serpent_. The TALYS-based evaluated nuclear data library, TENDL_, is +can use nuclear data that was processed with NJOY_, such as that distributed +with MCNP_ or Serpent_. Several sources provide free processed ACE data as +described below. The TALYS-based evaluated nuclear data library, TENDL_, is also openly available in ACE format. +Using ENDF/B-VII.1 Cross Sections from NNDC +------------------------------------------- + +The NNDC_ provides ACE data from the ENDF/B-VII.1 neutron and thermal scattering +sublibraries at four temperatures processed using NJOY_. To use this data with +OpenMC, a script is provided with OpenMC that will automatically download, +extract, and set up a confiuration file: + +.. code-block:: sh + + cd openmc/data + python get_nndc_data.py + +At this point, you should set the :envvar:`CROSS_SECTIONS` environment variable +to the absolute path of the file ``openmc/data/nndc/cross_sections.xml``. + Using JEFF Cross Sections from OECD/NEA --------------------------------------- @@ -314,6 +339,8 @@ distribution to the location of the Serpent cross sections. Then, either set the environment variable to the absolute path of the ``cross_sections_serpent.xml`` file. +.. _NJOY: http://t2.lanl.gov/nis/codes.shtml +.. _NNDC: http://www.nndc.bnl.gov/endf/b7.1/acefiles.html .. _NEA: http://www.oecd-nea.org .. _JEFF: http://www.oecd-nea.org/dbdata/jeff/ .. _here: http://www.oecd-nea.org/dbdata/pubs/jeff312-cd.html @@ -358,6 +385,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 ----------------------------------------------------- diff --git a/docs/source/usersguide/processing.rst b/docs/source/usersguide/processing.rst index 7105e9f7d..c3a1ccaca 100644 --- a/docs/source/usersguide/processing.rst +++ b/docs/source/usersguide/processing.rst @@ -5,11 +5,11 @@ Data Processing and Visualization ================================= This section is intended to explain in detail the recommended procedures for -carrying out common tasks with OpenMC. While several utilities of varying -complexity are provided to help automate the process, in many cases it will be -extremely beneficial to do some coding in Python to quickly obtain results. In -these cases, and for many of the provided utilities, it is necessary for your -Python installation to contain: +carrying out common post-processing tasks with OpenMC. While several utilities +of varying complexity are provided to help automate the process, in many cases +it will be extremely beneficial to do some coding in Python to quickly obtain +results. In these cases, and for many of the provided utilities, it is necessary +for your Python installation to contain: * [1]_ `Numpy `_ * [1]_ `Scipy `_ @@ -38,9 +38,58 @@ running OpenMC with the -plot or -p command-line option (See Plotting in 2D -------------- -.. image:: ../../img/atr.png +.. image:: ../_images/atr.png :height: 200px +See below for a simple example of a plots xml file that demonstrates the +capabilities of 2D slice plots. Here we assume that there is a ``geometry.xml`` +file containing 7 cells. + +.. code-block:: xml + + + + + + myplot + 0 0 + 10 10 + 2000 2000 + 0 0 0 + + + + + + + 1 3 4 5 6 + + + + + + +In this example, OpenMC will produce a plot named ``myplot.ppm`` when run in +plotting mode. The picture will be on the xy-plane, depicting the rectangle +between points (-5,-5) and (5,5) with 2000 pixels along each dimension. The +color of each pixel is determined by placing a particle at the center of that +pixel and using OpenMC's internal ``find_cell`` routine (the same one used for +particle tracking during simulation) to determine the cell and material at that +location. In this example, pixels are 10/2000=0.005 cm wide, so points will be +at (-4.9975,-4.9975), (-4.9950,-4.9975), (-4.9925,-4.9975), etc. This is pointed +out to demonstrate that this plot may miss any features smaller than 0.005 cm, +since they could exist between pixel centers. More pixels can be used to resolve +finer features, but could result in larger files. + +The ``background``, ``col_spec``, and ``mask`` elements define how to set pixel +colors based on the cell ids at each pixel center. In this example, RGB colors +are specified for cells 1,2,3,4, and 7, a random color will be assigned to cells +5 and 6, and a black background color (``rgb="0 0 0"``) will be applied to +locations where no cell is defined. However, the ``mask`` element here says that +only cells 1,3,4,5, and 6 should be displayed, with other cells taking a white +color (``rgb="255 255 255"``), which overrides the ``col_spec`` for cell 2 and +the random color assigned to cell 7. + After running OpenMC to obtain PPM files, images should be saved to another format before using them elsewhere. This cuts down the size of the file by orders of magnitude. Most image viewers and editors that can view PPM images @@ -53,18 +102,45 @@ Ubuntu: ``sudo apt-get install imagemagick``). Images are then converted like: .. code-block:: sh - convert plot.ppm plot.png + convert myplot.ppm myplot.png Plotting in 3D -------------- -.. image:: ../../img/3dgeomplot.png +.. image:: ../_images/3dgeomplot.png :height: 200px +See below for a simple example of a plots xml file that demonstrates the +capabilities of 3D voxel plots. + +.. code-block:: xml + + + + + + myplot + 0 0 0 + 10 10 10 + 500 500 500 + + + + +Voxel plots are built the same way 2D slice plots are, by determining the cell +or material id of a particle at the center of each voxel. In this example, the +space covered is the cube between the points (-5,-5,-5) and (5,5,5), with voxel +centers 10/500 = 0.02 cm apart. The binary VOXEL files that are produced do not +specify any color - instead containing only material or cell ids (material id +in this example) - and thus the ``background``, ``col_spec``, and ``mask`` +elements are not used. If no cell is found at a voxel center, an id of -1 is +stored. + The binary VOXEL files output by OpenMC can not be viewed directly by any existing viewers. In order to view them, they must be converted into a standard -mesh format that can be viewed in ParaView, Visit, etc. The provided utility -voxel.py accomplishes this for SILO: +mesh format that can be viewed in ParaView, Visit, etc. This typically will +compress the size of the file significantly. The provided utility voxel.py +accomplishes this for SILO: .. code-block:: sh @@ -88,13 +164,21 @@ or Users can process the binary into any other format if desired by following the example of voxel.py. For the binary file structure, see :ref:`devguide_voxel`. +Once processed into a standard 3D file format, colors and masks can be defined +using the stored id numbers to better explore the geometry. The process for +doing this will depend on the 3D viewer, but should be straightforward. + +.. image:: ../_images/3dba.png + :height: 200px + .. note:: 3D voxel plotting can be very computer intensive for the viewing program (Visit, Paraview, etc.) if the number of voxels is large (>10 million or so). Thus if you want an accurate picture that renders smoothly, consider using only one voxel in a certain direction. For - instance, the 3D pin lattice figure above was generated with a - 500x500x1 voxel mesh, which allows for resolution of the cylinders - without wasting too many voxels on the axial dimension. + instance, the 3D pin lattice figure at the beginning of this section + was generated with a 500x500x1 voxel mesh, which allows for resolution + of the cylinders without wasting too many voxels on the axial + dimension. ------------------- @@ -162,7 +246,7 @@ tasks will be described here in the following sections. Plotting in 2D -------------- -.. image:: ../../img/plotmeshtally.png +.. image:: ../_images/plotmeshtally.png :height: 200px For simple viewing of 2D slices of a mesh plot, the utility plot_mesh_tally.py @@ -170,7 +254,7 @@ is provided. This utility provides an interactive GUI to explore and plot mesh tallies for any scores and filter bins. It requires statepoint.py, as well as `PyQt `_. -.. image:: ../../img/fluxplot.png +.. image:: ../_images/fluxplot.png :height: 200px Alternatively, the user can write their own Python script to manipulate the data @@ -249,7 +333,7 @@ two heatmaps in the previous figure. Plotting in 3D -------------- -.. image:: ../../img/3dcore.png +.. image:: ../_images/3dcore.png :height: 200px As with 3D plots of the geometry, meshtally data needs to be put into a standard @@ -353,9 +437,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:: ../_images/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 + + 1 2 3 + 1 2 4 + + +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]: + [, + , + , + , + , + , + , + , + , + ] + + 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 diff --git a/docs/source/usersguide/troubleshoot.rst b/docs/source/usersguide/troubleshoot.rst index 49cf41c8d..ba7e4405c 100644 --- a/docs/source/usersguide/troubleshoot.rst +++ b/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' ************************************ @@ -98,6 +79,14 @@ with the :envvar:`CROSS_SECTIONS` environment variable. It is recommended to add a line in your ``.profile`` or ``.bash_profile`` setting the :envvar:`CROSS_SECTIONS` environment variable. +ERROR: Invalid usage of L(I) in ACE data; Consider using more recent data set. +****************************************************************************** + +The cross-sections requested in ``materials.xml`` do not conform to the current +standard format. This typically happens with fissionable nuclides in a ``.6*c`` +library as distributed with MCNP. Please try a newer library such as any from +the ``.7*c`` set. + Geometry Debugging ****************** @@ -126,8 +115,8 @@ have many particles travelling through them there will not be many locations where overlaps are checked for in that region. The user should refer to the output after a geometry debug run to see how many checks were performed in each cell, and then adjust the number of starting particles or starting source -distributions accordingly to achieve good coverage. - +distributions accordingly to achieve good coverage. + ERROR: After particle __ crossed surface __ it could not be located in any cell and it did not leak. ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ diff --git a/man/man1/openmc.1 b/man/man1/openmc.1 index fb0fdd717..db91d7a8f 100644 --- a/man/man1/openmc.1 +++ b/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 @@ -43,7 +46,7 @@ to locate ACE format cross section libraries if the user has not specified the tag in .I settings.xml\fP. .SH LICENSE -Copyright \(co 2011-2013 Massachusetts Institute of Technology. +Copyright \(co 2011-2014 Massachusetts Institute of Technology. .PP Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in diff --git a/schemas.xml b/schemas.xml index 982979001..465b9b398 100644 --- a/schemas.xml +++ b/schemas.xml @@ -1,10 +1,10 @@ - - - - - - - + + + + + + + diff --git a/src/DEPENDENCIES b/src/DEPENDENCIES index eeb538fc1..579bf26fb 100644 --- a/src/DEPENDENCIES +++ b/src/DEPENDENCIES @@ -36,6 +36,7 @@ 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 @@ -44,7 +45,7 @@ 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 +cmfd_input.o: xml_interface.o cmfd_jfnk_solver.o: cmfd_loss_operator.o cmfd_jfnk_solver.o: cmfd_power_solver.o @@ -210,12 +211,7 @@ 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 +input_xml.o: xml_interface.o interpolation.o: constants.o interpolation.o: endf_header.o @@ -333,6 +329,7 @@ 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 @@ -374,6 +371,11 @@ 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 @@ -385,6 +387,10 @@ 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 diff --git a/src/Makefile b/src/Makefile index 4300d42e6..ad2c36730 100644 --- a/src/Makefile +++ b/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 @@ -184,17 +181,17 @@ endif ifeq ($(OPENMP),yes) ifeq ($(COMPILER),intel) - F90FLAGS += -openmp -DOPENMP + F90FLAGS += -openmp LDFLAGS += -openmp endif ifeq ($(COMPILER),gnu) - F90FLAGS += -fopenmp -DOPENMP + F90FLAGS += -fopenmp LDFLAGS += -fopenmp endif ifeq ($(COMPILER),ibm) - F90FLAGS += -qsmp=omp -WF,-DOPENMP + F90FLAGS += -qsmp=omp LDFLAGS += -qsmp=omp endif endif @@ -221,7 +218,7 @@ endif ifeq ($(MACHINE),bluegene) F90 = /bgsys/drivers/ppcfloor/comm/xl/bin/mpixlf2003 - F90FLAGS = -WF,-DNO_F2008,-DMPI -O3 + F90FLAGS = -WF,-DNO_F2008,-DMPI,-DRESTRICTED_ASSOCIATED_BUG -O3 LDFLAGS = -lmpich.cnkf90 endif @@ -236,19 +233,18 @@ endif ifeq ($(MACHINE),bluegeneq) F90 = mpixlf2003 - F90FLAGS = -WF,-DNO_F2008,-DMPI -O5 + F90FLAGS = -WF,-DNO_F2008,-DMPI,-DRESTRICTED_ASSOCIATED_BUG -O5 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 diff --git a/src/ace.F90 b/src/ace.F90 index c37a546c0..ea97c80be 100644 --- a/src/ace.F90 +++ b/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 @@ -926,6 +942,7 @@ contains integer :: NEa ! number of energies for Watt 'a' integer :: NRb ! number of interpolation regions for Watt 'b' integer :: NEb ! number of energies for Watt 'b' + real(8), allocatable :: L(:) ! locations of distributions for each Ein ! initialize length length = 0 @@ -950,6 +967,22 @@ contains ! Continuous tabular distribution NR = int(XSS(lc + 1)) NE = int(XSS(lc + 2 + 2*NR)) + ! Before progressing, check to see if data set uses L(I) values + ! in a way inconsistent with the current form of the ACE Format Guide + ! (MCNP5 Manual, Vol 3) + allocate(L(NE)) + L = int(XSS(lc + 3 + 2*NR + NE: lc + 3 + 2*NR + 2*NE - 1)) + do i = 1,NE + ! Now check to see if L(i) is equal to any other entries + ! If so, then we must exit + if (count(L == L(i)) > 1) then + message = "Invalid usage of L(I) in ACE data; & + &Consider using more recent data set." + call fatal_error() + end if + end do + deallocate(L) + ! Continue with finding data length length = length + 2 + 2*NR + 2*NE do i = 1,NE ! determine length @@ -992,6 +1025,22 @@ contains ! Kalbach-Mann correlated scattering NR = int(XSS(lc + 1)) NE = int(XSS(lc + 2 + 2*NR)) + ! Before progressing, check to see if data set uses L(I) values + ! in a way inconsistent with the current form of the ACE Format Guide + ! (MCNP5 Manual, Vol 3) + allocate(L(NE)) + L = int(XSS(lc + 3 + 2*NR + NE: lc + 3 + 2*NR + 2*NE - 1)) + do i = 1,NE + ! Now check to see if L(i) is equal to any other entries + ! If so, then we must exit + if (count(L == L(i)) > 1) then + message = "Invalid usage of L(I) in ACE data; & + &Consider using more recent data set." + call fatal_error() + end if + end do + deallocate(L) + ! Continue with finding data length length = length + 2 + 2*NR + 2*NE do i = 1,NE NP = int(XSS(lc + length + 2)) @@ -1006,6 +1055,22 @@ contains ! Correlated energy and angle distribution NR = int(XSS(lc + 1)) NE = int(XSS(lc + 2 + 2*NR)) + ! Before progressing, check to see if data set uses L(I) values + ! in a way inconsistent with the current form of the ACE Format Guide + ! (MCNP5 Manual, Vol 3) + allocate(L(NE)) + L = int(XSS(lc + 3 + 2*NR + NE: lc + 3 + 2*NR + 2*NE - 1)) + do i = 1,NE + ! Now check to see if L(i) is equal to any other entries + ! If so, then we must exit + if (count(L == L(i)) > 1) then + message = "Invalid usage of L(I) in ACE data; & + &Consider using more recent data set." + call fatal_error() + end if + end do + deallocate(L) + ! Continue with finding data length length = length + 2 + 2*NR + 2*NE do i = 1,NE ! outgoing energy distribution @@ -1038,6 +1103,22 @@ contains ! Laboratory energy-angle law NR = int(XSS(lc + 1)) NE = int(XSS(lc + 2 + 2*NR)) + ! Before progressing, check to see if data set uses L(I) values + ! in a way inconsistent with the current form of the ACE Format Guide + ! (MCNP5 Manual, Vol 3) + allocate(L(NE)) + L = int(XSS(lc + 3 + 2*NR + NE: lc + 3 + 2*NR + 2*NE - 1)) + do i = 1,NE + ! Now check to see if L(i) is equal to any other entries + ! If so, then we must exit + if (count(L == L(i)) > 1) then + message = "Invalid usage of L(I) in ACE data; & + &Consider using more recent data set." + call fatal_error() + end if + end do + deallocate(L) + ! Continue with finding data length NMU = int(XSS(lc + 4 + 2*NR + 2*NE)) length = 4 + 2*(NR + NE + NMU) @@ -1179,15 +1260,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 +1281,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) diff --git a/src/ace_header.F90 b/src/ace_header.F90 index d075c2288..e5bf1bb3a 100644 --- a/src/ace_header.F90 +++ b/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 diff --git a/src/cmfd_data.F90 b/src/cmfd_data.F90 index d0e80aaa9..8dd0fa35f 100644 --- a/src/cmfd_data.F90 +++ b/src/cmfd_data.F90 @@ -934,7 +934,7 @@ contains subroutine compute_effective_downscatter() use constants, only: ZERO, CMFD_NOACCEL - use global, only: cmfd, cmfd_downscatter + use global, only: cmfd integer :: nx ! number of mesh cells in x direction integer :: ny ! number of mesh cells in y direction diff --git a/src/cmfd_execute.F90 b/src/cmfd_execute.F90 index 7a35a1214..6234d9fcf 100644 --- a/src/cmfd_execute.F90 +++ b/src/cmfd_execute.F90 @@ -117,9 +117,9 @@ contains subroutine process_cmfd_options() +#ifdef PETSC use global, only: cmfd_snes_monitor, cmfd_ksp_monitor, mpi_err -#ifdef PETSC ! Check for snes monitor if (cmfd_snes_monitor) call PetscOptionsSetValue("-snes_monitor", & "stdout", mpi_err) @@ -138,9 +138,10 @@ contains subroutine calc_fission_source() use constants, only: CMFD_NOACCEL, ZERO, TWO - use global, only: cmfd, cmfd_coremap, master, mpi_err, entropy_on, & - current_batch + use global, only: cmfd, cmfd_coremap, master, entropy_on, current_batch + #ifdef MPI + use global, only: mpi_err use mpi #endif @@ -261,13 +262,14 @@ contains 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 #ifdef MPI + use global, only: mpi_err use mpi #endif diff --git a/src/cmfd_input.F90 b/src/cmfd_input.F90 index d893d7bc7..6f259f949 100644 --- a/src/cmfd_input.F90 +++ b/src/cmfd_input.F90 @@ -20,7 +20,9 @@ contains use cmfd_header, only: allocate_cmfd +#ifdef PETSC integer :: new_comm ! new mpi communicator +#endif integer :: color ! color group of processor ! Read in cmfd input file @@ -34,17 +36,17 @@ contains end if ! Split up procs -# ifdef PETSC +#ifdef PETSC call MPI_COMM_SPLIT(MPI_COMM_WORLD, color, 0, new_comm, mpi_err) -# endif +#endif ! assign to PETSc -# ifdef PETSC +#ifdef PETSC PETSC_COMM_WORLD = new_comm ! Initialize PETSc on all procs call PetscInitialize(PETSC_NULL_CHARACTER, mpi_err) -# endif +#endif ! Initialize timers call time_cmfd % reset() @@ -61,16 +63,22 @@ contains !=============================================================================== subroutine read_cmfd_xml() - + 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 ! number of energy groups - logical :: file_exists ! does cmfd.xml exist? - character(MAX_LINE_LEN) :: filename ! name of input file + 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 input file filename = trim(path_input) // "cmfd.xml" @@ -91,16 +99,25 @@ contains end if ! Parse cmfd.xml file - call read_xml_file_cmfd_t(filename) + call open_xmldoc(doc, filename) - ! Set spatial dimensions in cmfd object (structed Cartesian mesh) - cmfd % indices(1:3) = mesh_ % dimension(1:3) + ! Get pointer to mesh XML node + call get_node_ptr(doc, "mesh", node_mesh, found = found) - ! Get number of energy groups or set to 1 group default - if (associated(mesh_ % energy)) then - ng = size(mesh_ % energy) - if(.not.allocated(cmfd % egrid)) allocate(cmfd % egrid(ng)) - cmfd % egrid = 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)) + 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)) @@ -108,90 +125,115 @@ contains cmfd % indices(4) = 1 ! one energy group end if - ! Set global albedo, these can be overwritten by coremap - 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 core map overlay for a subset mesh for CMFD - if (associated(mesh_ % map)) then - - ! Allocate a core map with appropriate dimensions + ! Get acceleration map + if (check_for_node(node_mesh, "map")) then allocate(cmfd % coremap(cmfd % indices(1), cmfd % indices(2), & cmfd % indices(3))) - - ! Check and make sure it is of correct size - if (size(mesh_ % map) /= product(cmfd % indices(1:3))) then - message = 'CMFD coremap not to correct dimensions' + 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 - - ! Reshape core map vector into (x,y,z) array - cmfd % coremap = reshape(mesh_ % map,(cmfd % indices(1:3))) - - ! Indicate to cmfd that a core map overlay is active + 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. - - ! Write to stdout that a core map overlay is active - message = "Core Map Overlay Activated" - call write_message(10) - + deallocate(iarray) end if - ! Get normalization constant for source (default is 1.0 from XML) - 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. + 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 downscatter logical - call lower_case(downscatter_) - if (downscatter_ == 'true' .or. downscatter_ == '1') & - cmfd_downscatter = .true. + 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 the solver type (default power from XML) - cmfd_solver_type = solver_(1:10) + ! Set the solver type + if (check_for_node(doc, "solver")) & + call get_node_value(doc, "solver", cmfd_solver_type) - ! Set convergence 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. + ! 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 ! Output logicals - call lower_case(write_matrices_) - if (write_matrices_ == 'true' .or. write_matrices_ == '1') & - cmfd_write_matrices = .true. + 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 ! Run an adjoint calc - call lower_case(run_adjoint_) - if (run_adjoint_ == 'true' .or. run_adjoint_ == '1') & - cmfd_run_adjoint = .true. + 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 - ! Batch to begin cmfd (default is 1 from XML) - cmfd_begin = begin_ + ! Batch to begin cmfd + if (check_for_node(doc, "begin")) & + call get_node_value(doc, "begin", cmfd_begin) - ! Tally during inactive batches (by default we will always tally from 1) - call lower_case(inactive_) - if (inactive_ == 'false' .or. inactive_ == '0') cmfd_tally_on = .false. + ! 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 ! Inactive batch flush window - cmfd_inact_flush(1) = inactive_flush_ ! the interval of batches - cmfd_inact_flush(2) = num_flushes_ ! number of times to do this + 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)) ! Last flush before active batches - cmfd_act_flush = active_flush_ + if (check_for_node(doc, "active_flush")) & + call get_node_value(doc, "active_flush", cmfd_act_flush) ! Get display - cmfd_display = 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' @@ -200,7 +242,10 @@ contains end if ! Create tally objects - call create_cmfd_tally() + call create_cmfd_tally(doc) + + ! Close CMFD XML file + call close_xmldoc(doc) end subroutine read_cmfd_xml @@ -213,29 +258,31 @@ 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 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 ! name of cmfd file + 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 - - ! Parse cmfd.xml file - filename = trim(path_input) // "cmfd.xml" - call read_xml_file_cmfd_t(filename) + type(Node), pointer :: node_mesh => null() ! Set global variables if they are 0 (this can happen if there is no tally ! file) @@ -251,8 +298,11 @@ contains ! 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() @@ -266,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 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 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 must be the same as & - &the number of entries on ." - call fatal_error() + if (m % n_dimension /= get_arraysize_double(node_mesh, "lower_left")) then + message = "Number of entries on must be the same as & + &the number of entries on ." + 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 and 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 and 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 and 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 and 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 must be the same as the & - &number of entries on ." - 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 must be the same as the & + &number of entries on ." + call fatal_error() + end if - ! Check for negative widths - if (any(mesh_ % width < ZERO)) then - message = "Cannot have a negative 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 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 must be the same as & - &the number of entries on ." - 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 must be the same as & + &the number of entries on ." + call fatal_error() + end if - ! Check that upper-right is above lower-left - if (any(mesh_ % upper_right < mesh_ % lower_left)) then - message = "The coordinates must be greater than the & - & 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 coordinates must be greater than the & + & 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 @@ -353,8 +408,12 @@ contains t => cmfd_tallies(i) ! Set reset property - call lower_case(reset_) - if (reset_ == 'true' .or. reset_ == '1') t % reset = .true. + 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 n_filters = 1 @@ -365,13 +424,14 @@ contains t % find_filter(FILTER_MESH) = n_filters ! Read and set incoming 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_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 @@ -425,14 +485,15 @@ contains ! Set tally type to volume t % type = TALLY_VOLUME - ! Read and set outgoing energy mesh filter - if (associated(mesh_ % energy)) then + ! read and set outgoing energy mesh filter + 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 @@ -441,8 +502,8 @@ contains allocate(t % filters(n_filters)) t % filters = filters(1:n_filters) - ! Deallocate filters bins array - if (associated(mesh_ % energy)) & + ! deallocate filters bins array + if (check_for_node(node_mesh, "energy")) & deallocate(filters(n_filters) % real_bins) ! Allocate macro reactions @@ -510,12 +571,15 @@ contains ! 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 diff --git a/src/cmfd_loss_operator.F90 b/src/cmfd_loss_operator.F90 index 69be01764..b89f0f577 100644 --- a/src/cmfd_loss_operator.F90 +++ b/src/cmfd_loss_operator.F90 @@ -396,7 +396,7 @@ contains end subroutine indices_to_matrix !=============================================================================== -! MATRIX_TO_INDICES converts a matrix index to spatial and group indicies +! MATRIX_TO_INDICES converts a matrix index to spatial and group indices !=============================================================================== subroutine matrix_to_indices(irow, g, i, j, k, ng, nx, ny, nz) diff --git a/src/cmfd_power_solver.F90 b/src/cmfd_power_solver.F90 index c1309b72c..f2761d0a1 100644 --- a/src/cmfd_power_solver.F90 +++ b/src/cmfd_power_solver.F90 @@ -102,7 +102,9 @@ contains subroutine init_data(adjoint) use constants, only: ONE, ZERO +#ifdef PETSC use global, only: cmfd_write_matrices +#endif logical, intent(in) :: adjoint ! adjoint calcualtion diff --git a/src/constants.F90 b/src/constants.F90 index e9999c0bd..ef0d7c8ef 100644 --- a/src/constants.F90 +++ b/src/constants.F90 @@ -8,19 +8,20 @@ module constants ! OpenMC major, minor, and release numbers integer, parameter :: VERSION_MAJOR = 0 integer, parameter :: VERSION_MINOR = 5 - integer, parameter :: VERSION_RELEASE = 3 + integer, parameter :: VERSION_RELEASE = 4 ! Revision numbers for binary files - integer, parameter :: REVISION_STATEPOINT = 10 + integer, parameter :: REVISION_STATEPOINT = 11 integer, parameter :: REVISION_PARTICLE_RESTART = 1 ! Binary file types integer, parameter :: & FILETYPE_STATEPOINT = -1, & - FILETYPE_PARTICLE_RESTART = -2 + FILETYPE_PARTICLE_RESTART = -2, & + FILETYPE_SOURCE = -3 ! ============================================================================ - ! 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 +51,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 +115,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 +148,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 +156,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 +281,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 +328,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 +338,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 diff --git a/src/cross_section.F90 b/src/cross_section.F90 index 4c9ffb8c8..299033590 100644 --- a/src/cross_section.F90 +++ b/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 diff --git a/src/doppler.F90 b/src/doppler.F90 index 12fb34bbf..e888eb2b1 100644 --- a/src/doppler.F90 +++ b/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 diff --git a/src/eigenvalue.F90 b/src/eigenvalue.F90 index f5375bf3a..4d3202569 100644 --- a/src/eigenvalue.F90 +++ b/src/eigenvalue.F90 @@ -17,7 +17,7 @@ module eigenvalue use random_lcg, only: prn, set_particle_seed, prn_skip use search, only: binary_search use source, only: get_source_particle - use state_point, only: write_state_point + use state_point, only: write_state_point, write_source_point use string, only: to_str use tally, only: synchronize_tallies, setup_active_usertallies, & reset_result @@ -166,7 +166,7 @@ contains subroutine finalize_generation() -#ifdef OPENMP +#ifdef _OPENMP ! Join the fission bank from each thread into one global fission bank call join_bank_from_threads() #endif @@ -222,6 +222,12 @@ contains call write_state_point() end if + ! Write out source point if it's been specified for this batch + if ((sourcepoint_batch % contains(current_batch) .or. source_latest) .and. & + source_write) then + call write_source_point() + end if + if (master .and. current_batch == n_batches) then ! Make sure combined estimate of k-effective is calculated at the last ! batch in case no state point is written @@ -821,7 +827,7 @@ contains end subroutine replay_batch_history -#ifdef OPENMP +#ifdef _OPENMP !=============================================================================== ! JOIN_BANK_FROM_THREADS !=============================================================================== diff --git a/src/global.F90 b/src/global.F90 index f12171b25..515b774bf 100644 --- a/src/global.F90 +++ b/src/global.F90 @@ -158,7 +158,7 @@ module global ! Source and fission bank type(Bank), allocatable, target :: source_bank(:) type(Bank), allocatable, target :: fission_bank(:) -#ifdef OPENMP +#ifdef _OPENMP type(Bank), allocatable, target :: master_fission_bank(:) #endif integer(8) :: n_bank ! # of sites in fission bank @@ -189,6 +189,7 @@ module global ! Write source at end of simulation logical :: source_separate = .false. logical :: source_write = .true. + logical :: source_latest = .false. ! ============================================================================ ! PARALLEL PROCESSING VARIABLES @@ -205,7 +206,7 @@ module global integer :: MPI_BANK ! MPI datatype for fission bank integer :: MPI_TALLYRESULT ! MPI datatype for TallyResult -#ifdef OPENMP +#ifdef _OPENMP integer :: n_threads = NONE ! number of OpenMP threads integer :: thread_id ! ID of a given thread #endif @@ -260,6 +261,7 @@ module global character(MAX_FILE_LEN) :: path_cross_sections ! Path to cross_sections.xml character(MAX_FILE_LEN) :: path_source = '' ! Path to binary source character(MAX_FILE_LEN) :: path_state_point ! Path to binary state point + character(MAX_FILE_LEN) :: path_source_point ! Path to binary source point character(MAX_FILE_LEN) :: path_particle_restart ! Path to particle restart character(MAX_FILE_LEN) :: path_output = '' ! Path to output directory @@ -283,6 +285,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. @@ -353,12 +359,16 @@ module global logical :: cmfd_tally_on = .true. ! CMFD display info - character(len=25) :: cmfd_display + character(len=25) :: cmfd_display = 'balance' ! Information about state points to be written integer :: n_state_points = 0 type(SetInt) :: statepoint_batch + ! Information about source points to be written + integer :: n_source_points = 0 + type(SetInt) :: sourcepoint_batch + ! Various output options logical :: output_summary = .false. logical :: output_xs = .false. @@ -434,7 +444,7 @@ contains !$omp parallel if (allocated(fission_bank)) deallocate(fission_bank) !$omp end parallel -#ifdef OPENMP +#ifdef _OPENMP if (allocated(master_fission_bank)) deallocate(master_fission_bank) #endif if (allocated(source_bank)) deallocate(source_bank) @@ -451,6 +461,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() diff --git a/src/hdf5_summary.F90 b/src/hdf5_summary.F90 index 915e6af07..c9e367200 100644 --- a/src/hdf5_summary.F90 +++ b/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) diff --git a/src/initialize.F90 b/src/initialize.F90 index dea901fb6..52869a281 100644 --- a/src/initialize.F90 +++ b/src/initialize.F90 @@ -26,7 +26,7 @@ module initialize use mpi #endif -#ifdef OPENMP +#ifdef _OPENMP use omp_lib #endif @@ -363,8 +363,50 @@ contains case (FILETYPE_PARTICLE_RESTART) path_particle_restart = argv(i) particle_restart_run = .true. + case default + message = "Unrecognized file after restart flag." + call fatal_error() end select + ! If its a restart run check for additional source file + if (restart_run .and. i + 1 <= argc) then + + ! Increment arg + i = i + 1 + + ! Check if it has extension we can read + if ((ends_with(argv(i), '.binary') .or. & + ends_with(argv(i), '.h5'))) then + + ! Check file type is a source file + call sp % file_open(argv(i), 'r', serial = .false.) + call sp % read_data(filetype, 'filetype') + call sp % file_close() + if (filetype /= FILETYPE_SOURCE) then + message = "Second file after restart flag must be a source file" + call fatal_error() + end if + + ! It is a source file + path_source_point = argv(i) + + else ! Different option is specified not a source file + + ! Source is in statepoint file + path_source_point = path_state_point + + ! Set argument back + i = i - 1 + + end if + + else ! No command line arg after statepoint + + ! Source is assumed to be in statepoint file + path_source_point = path_state_point + + end if + case ('-g', '-geometry-debug', '--geometry-debug') check_overlaps = .true. @@ -372,7 +414,7 @@ contains ! Read number of threads i = i + 1 -#ifdef OPENMP +#ifdef _OPENMP ! Read and set number of OpenMP threads n_threads = str_to_int(argv(i)) if (n_threads < 1) then @@ -394,6 +436,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() @@ -827,14 +872,15 @@ contains call fatal_error() end if -#ifdef OPENMP +#ifdef _OPENMP ! If OpenMP is being used, each thread needs its own private fission ! bank. Since the private fission banks need to be combined at the end of a ! generation, there is also a 'master_fission_bank' that is used to collect ! the sites from each thread. + n_threads = omp_get_max_threads() + !$omp parallel - n_threads = omp_get_num_threads() thread_id = omp_get_thread_num() if (thread_id == 0) then diff --git a/src/input_xml.F90 b/src/input_xml.F90 index f50a4557c..76b1f696f 100644 --- a/src/input_xml.F90 +++ b/src/input_xml.F90 @@ -15,6 +15,7 @@ module input_xml starts_with, ends_with use tally_header, only: TallyObject, TallyFilter use tally_initialize, only: add_tallies + use xml_interface implicit none save @@ -47,15 +48,29 @@ contains subroutine read_settings_xml() - use xml_data_settings_t - - integer :: i ! loop index + character(MAX_LINE_LEN) :: temp_str + integer :: i integer :: n integer :: coeffs_reqd + integer :: temp_int + integer :: temp_int_array3(3) + integer, allocatable :: temp_int_array(:) + integer(8) :: temp_long + integer :: n_tracks logical :: file_exists character(MAX_FILE_LEN) :: env_variable character(MAX_WORD_LEN) :: type character(MAX_LINE_LEN) :: filename + type(Node), pointer :: doc => null() + type(Node), pointer :: node_mode => null() + type(Node), pointer :: node_source => null() + type(Node), pointer :: node_dist => null() + type(Node), pointer :: node_cutoff => null() + type(Node), pointer :: node_entropy => null() + type(Node), pointer :: node_ufs => null() + type(Node), pointer :: node_sp => null() + type(Node), pointer :: node_output => null() + type(Node), pointer :: node_verb => null() ! Display output message message = "Reading settings XML file..." @@ -69,84 +84,73 @@ contains call fatal_error() end if - ! Initialize XML scalar variables - cross_sections_ = '' - output_path_ = '' - verbosity_ = 0 - threads_ = NONE - energy_grid_ = 'union' - seed_ = 0_8 - source_ % file = '' - source_ % space % type = '' - source_ % angle % type = '' - source_ % energy % type = '' - ! Parse settings.xml file - call read_xml_file_settings_t(filename) + call open_xmldoc(doc, filename) ! Find cross_sections.xml file -- the first place to look is the ! settings.xml file. If no file is found there, then we check the ! CROSS_SECTIONS environment variable - - if (len_trim(cross_sections_) == 0 .and. run_mode /= MODE_PLOTTING) then - ! No cross_sections.xml file specified in settings.xml, check environment - ! variable - call get_environment_variable("CROSS_SECTIONS", env_variable) - if (len_trim(env_variable) == 0) then - message = "No cross_sections.xml file was specified in settings.xml & - &or in the CROSS_SECTIONS environment variable." - call fatal_error() + if (run_mode /= MODE_PLOTTING) then + if (.not. check_for_node(doc, "cross_sections") .and. & + run_mode /= MODE_PLOTTING) then + ! No cross_sections.xml file specified in settings.xml, check + ! environment variable + call get_environment_variable("CROSS_SECTIONS", env_variable) + if (len_trim(env_variable) == 0) then + message = "No cross_sections.xml file was specified in settings.xml & + &or in the CROSS_SECTIONS environment variable." + call fatal_error() + else + path_cross_sections = trim(env_variable) + end if else - path_cross_sections = trim(env_variable) + call get_node_value(doc, "cross_sections", path_cross_sections) end if - else - path_cross_sections = trim(cross_sections_) end if ! Set output directory if a path has been specified on the ! element - if (len_trim(output_path_) > 0) then - path_output = output_path_ + if (check_for_node(doc, "output_path")) then + call get_node_value(doc, "output_path", path_output) if (.not. ends_with(path_output, "/")) & path_output = trim(path_output) // "/" end if - ! Make sure that either criticality or fixed source was specified - if (eigenvalue_ % batches == 0 .and. fixed_source_ % batches == 0 & - .and. criticality_ % batches == 0) then - message = "Number of batches on or & - &tag was zero." + ! Make sure that either eigenvalue or fixed source was specified + if (.not.check_for_node(doc, "eigenvalue") .and. & + .not.check_for_node(doc, "fixed_source")) then + message = " or not specified." call fatal_error() end if - ! Check for old tag - if (criticality_ % batches > 0) then - eigenvalue_ = criticality_ - message = "The element has been deprecated and & - &replaced by ." - call warning() - end if - ! Eigenvalue information - if (eigenvalue_ % batches > 0) then + if (check_for_node(doc, "eigenvalue")) then ! Set run mode if (run_mode == NONE) run_mode = MODE_EIGENVALUE + ! Get pointer to eigenvalue XML block + call get_node_ptr(doc, "eigenvalue", node_mode) + ! Check number of particles - if (len_trim(eigenvalue_ % particles) == 0) then - message = "Need to specify number of particles per cycles." + if (.not.check_for_node(node_mode, "particles")) then + message = "Need to specify number of particles per generation." call fatal_error() end if + ! Get number of particles + call get_node_value(node_mode, "particles", temp_long) + ! If the number of particles was specified as a command-line argument, we ! don't set it here - if (n_particles == 0) n_particles = str_to_int(eigenvalue_ % particles) + if (n_particles == 0) n_particles = temp_long ! Copy batch and generation information - n_batches = eigenvalue_ % batches - n_inactive = eigenvalue_ % inactive - n_active = n_batches - n_inactive - gen_per_batch = eigenvalue_ % generations_per_batch + call get_node_value(node_mode, "batches", n_batches) + call get_node_value(node_mode, "inactive", n_inactive) + n_active = n_batches - n_inactive + if (check_for_node(node_mode, "generations_per_batch")) then + call get_node_value(node_mode, "generations_per_batch", gen_per_batch) + end if ! Allocate array for batch keff and entropy allocate(k_generation(n_batches*gen_per_batch)) @@ -155,23 +159,29 @@ contains end if ! Fixed source calculation information - if (fixed_source_ % batches > 0) then + if (check_for_node(doc, "fixed_source")) then ! Set run mode if (run_mode == NONE) run_mode = MODE_FIXEDSOURCE + ! Get pointer to fixed_source XML block + call get_node_ptr(doc, "fixed_source", node_mode) + ! Check number of particles - if (len_trim(fixed_source_ % particles) == 0) then - message = "Need to specify number of particles per cycles." + if (.not.check_for_node(node_mode, "particles")) then + message = "Need to specify number of particles per batch." call fatal_error() end if + ! Get number of particles + call get_node_value(node_mode, "particles", temp_long) + ! If the number of particles was specified as a command-line argument, we ! don't set it here - if (n_particles == 0) n_particles = str_to_int(fixed_source_ % particles) + if (n_particles == 0) n_particles = temp_long ! Copy batch information - n_batches = fixed_source_ % batches - n_active = fixed_source_ % batches + call get_node_value(node_mode, "batches", n_batches) + n_active = n_batches n_inactive = 0 gen_per_batch = 1 end if @@ -189,10 +199,15 @@ contains end if ! Copy random number seed if specified - if (seed_ > 0) seed = seed_ + if (check_for_node(doc, "seed")) call get_node_value(doc, "seed", seed) ! Energy grid methods - select case (energy_grid_) + if (check_for_node(doc, "energy_grid")) then + call get_node_value(doc, "energy_grid", temp_str) + else + temp_str = 'union' + end if + select case (trim(temp_str)) case ('nuclide') grid_method = GRID_NUCLIDE case ('union') @@ -201,18 +216,21 @@ contains message = "Lethargy mapped energy grid not yet supported." call fatal_error() case default - message = "Unknown energy grid method: " // energy_grid_ + message = "Unknown energy grid method: " // trim(temp_str) call fatal_error() end select ! Verbosity - if (verbosity_ > 0) verbosity = verbosity_ + if (check_for_node(doc, "verbosity")) then + call get_node_ptr(doc, "verbosity", node_verb) + call get_node_value(node_verb, "value", verbosity) + end if ! Number of OpenMP threads - if (threads_ /= NONE) then -#ifdef OPENMP + if (check_for_node(doc, "threads")) then +#ifdef _OPENMP if (n_threads == NONE) then - n_threads = threads_ + call get_node_value(doc, "threads", n_threads) if (n_threads < 1) then message = "Invalid number of threads: " // to_str(n_threads) call fatal_error() @@ -228,9 +246,18 @@ contains ! ========================================================================== ! EXTERNAL SOURCE - if (source_ % file /= '') then + ! Get pointer to source + if (check_for_node(doc, "source")) then + call get_node_ptr(doc, "source", node_source) + else + message = "No source specified in settings XML file." + call fatal_error() + end if + + ! Check for external source file + if (check_for_node(node_source, "file")) then ! Copy path of source file - path_source = source_ % file + call get_node_value(node_source, "file", path_source) ! Check if source file exists inquire(FILE=path_source, EXIST=file_exists) @@ -241,12 +268,19 @@ contains end if else + ! Spatial distribution for external source - if (source_ % space % type /= '') then - ! Read type of spatial distribution - type = source_ % space % type + if (check_for_node(node_source, "space")) then + + ! Get pointer to spatial distribution + call get_node_ptr(node_source, "space", node_dist) + + ! Check for type of spatial distribution + type = '' + if (check_for_node(node_dist, "type")) & + call get_node_value(node_dist, "type", type) call lower_case(type) - select case (type) + select case (trim(type)) case ('box') external_source % type_space = SRC_SPACE_BOX coeffs_reqd = 6 @@ -255,13 +289,13 @@ contains coeffs_reqd = 3 case default message = "Invalid spatial distribution for external source: " & - // trim(source_ % space % type) + // trim(type) call fatal_error() end select ! Determine number of parameters specified - if (associated(source_ % space % parameters)) then - n = size(source_ % space % parameters) + if (check_for_node(node_dist, "parameters")) then + n = get_arraysize_double(node_dist, "parameters") else n = 0 end if @@ -277,19 +311,26 @@ contains call fatal_error() elseif (n > 0) then allocate(external_source % params_space(n)) - external_source % params_space = source_ % space % parameters + call get_node_array(node_dist, "parameters", & + external_source % params_space) end if else - message = "No spatial distribution specified for external source!" + message = "No spatial distribution specified for external source." call fatal_error() end if ! Determine external source angular distribution - if (source_ % angle % type /= '') then - ! Read type of angular distribution - type = source_ % angle % type + if (check_for_node(node_source, "angle")) then + + ! Get pointer to angular distribution + call get_node_ptr(node_source, "angle", node_dist) + + ! Check for type of angular distribution + type = '' + if (check_for_node(node_dist, "type")) & + call get_node_value(node_dist, "type", type) call lower_case(type) - select case (type) + select case (trim(type)) case ('isotropic') external_source % type_angle = SRC_ANGLE_ISOTROPIC coeffs_reqd = 0 @@ -300,13 +341,13 @@ contains external_source % type_angle = SRC_ANGLE_TABULAR case default message = "Invalid angular distribution for external source: " & - // trim(source_ % angle % type) + // trim(type) call fatal_error() end select ! Determine number of parameters specified - if (associated(source_ % angle % parameters)) then - n = size(source_ % angle % parameters) + if (check_for_node(node_dist, "parameters")) then + n = get_arraysize_double(node_dist, "parameters") else n = 0 end if @@ -322,7 +363,8 @@ contains call fatal_error() elseif (n > 0) then allocate(external_source % params_angle(n)) - external_source % params_angle = source_ % angle % parameters + call get_node_array(node_dist, "parameters", & + external_source % params_angle) end if else ! Set default angular distribution isotropic @@ -330,11 +372,17 @@ contains end if ! Determine external source energy distribution - if (source_ % energy % type /= '') then - ! Read type of energy distribution - type = source_ % energy % type + if (check_for_node(node_source, "energy")) then + + ! Get pointer to energy distribution + call get_node_ptr(node_source, "energy", node_dist) + + ! Check for type of energy distribution + type = '' + if (check_for_node(node_dist, "type")) & + call get_node_value(node_dist, "type", type) call lower_case(type) - select case (type) + select case (trim(type)) case ('monoenergetic') external_source % type_energy = SRC_ENERGY_MONO coeffs_reqd = 1 @@ -348,13 +396,13 @@ contains external_source % type_energy = SRC_ENERGY_TABULAR case default message = "Invalid energy distribution for external source: " & - // trim(source_ % energy % type) + // trim(type) call fatal_error() end select ! Determine number of parameters specified - if (associated(source_ % energy % parameters)) then - n = size(source_ % energy % parameters) + if (check_for_node(node_dist, "parameters")) then + n = get_arraysize_double(node_dist, "parameters") else n = 0 end if @@ -370,7 +418,8 @@ contains call fatal_error() elseif (n > 0) then allocate(external_source % params_energy(n)) - external_source % params_energy = source_ % energy % parameters + call get_node_array(node_dist, "parameters", & + external_source % params_energy) end if else ! Set default energy distribution to Watt fission spectrum @@ -381,33 +430,66 @@ contains end if ! Survival biasing - call lower_case(survival_) - if (survival_ == 'true' .or. survival_ == '1') survival_biasing = .true. + if (check_for_node(doc, "survival_biasing")) then + call get_node_value(doc, "survival_biasing", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') & + survival_biasing = .true. + end if ! Probability tables - call lower_case(ptables_) - if (ptables_ == 'false' .or. ptables_ == '0') urr_ptables_on = .false. + if (check_for_node(doc, "ptables")) then + call get_node_value(doc, "ptables", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'false' .or. trim(temp_str) == '0') & + urr_ptables_on = .false. + end if ! Cutoffs - if (size(cutoff_) > 0) then - weight_cutoff = cutoff_(1) % weight - weight_survive = cutoff_(1) % weight_avg + if (check_for_node(doc, "cutoff")) then + call get_node_ptr(doc, "cutoff", node_cutoff) + call get_node_value(node_cutoff, "weight", weight_cutoff) + call get_node_value(node_cutoff, "weight_avg", weight_survive) end if ! Particle trace - if (associated(trace_)) then - trace_batch = trace_(1) - trace_gen = trace_(2) - trace_particle = trace_(3) + if (check_for_node(doc, "trace")) then + call get_node_array(doc, "trace", temp_int_array3) + trace_batch = temp_int_array3(1) + trace_gen = temp_int_array3(2) + trace_particle = int(temp_int_array3(3), 8) + end if + + ! Particle tracks + if (check_for_node(doc, "track")) then + ! Make sure that there are three values per particle + n_tracks = get_arraysize_integer(doc, "track") + if (mod(n_tracks, 3) /= 0) then + message = "Number of integers specified in 'track' is not divisible & + &by 3. Please provide 3 integers per particle to be tracked." + call fatal_error() + end if + + ! Allocate space and get list of tracks + allocate(temp_int_array(n_tracks)) + call get_node_array(doc, "track", temp_int_array) + + ! Reshape into track_identifiers + allocate(track_identifiers(3, n_tracks/3)) + track_identifiers = reshape(temp_int_array, [3, n_tracks/3]) end if ! Shannon Entropy mesh - if (size(entropy_) > 0) then + if (check_for_node(doc, "entropy")) then + + ! Get pointer to entropy node + call get_node_ptr(doc, "entropy", node_entropy) + ! Check to make sure enough values were supplied - if (size(entropy_(1) % lower_left) /= 3) then + if (get_arraysize_double(node_entropy, "lower_left") /= 3) then message = "Need to specify (x,y,z) coordinates of lower-left corner & &of Shannon entropy mesh." - elseif (size(entropy_(1) % upper_right) /= 3) then + elseif (get_arraysize_double(node_entropy, "upper_right") /= 3) then message = "Need to specify (x,y,z) coordinates of upper-right corner & &of Shannon entropy mesh." end if @@ -418,8 +500,10 @@ contains allocate(entropy_mesh % upper_right(3)) ! Copy values - entropy_mesh % lower_left = entropy_(1) % lower_left - entropy_mesh % upper_right = entropy_(1) % upper_right + call get_node_array(node_entropy, "lower_left", & + entropy_mesh % lower_left) + call get_node_array(node_entropy, "upper_right", & + entropy_mesh % upper_right) ! Check on values provided if (.not. all(entropy_mesh % upper_right > entropy_mesh % lower_left)) then @@ -430,10 +514,10 @@ contains ! Check if dimensions were specified -- if not, they will be calculated ! automatically upon first entry into shannon_entropy + if (check_for_node(node_entropy, "dimension")) then - if (associated(entropy_(1) % dimension)) then ! If so, make sure proper number of values were given - if (size(entropy_(1) % dimension) /= 3) then + if (get_arraysize_integer(node_entropy, "dimension") /= 3) then message = "Dimension of entropy mesh must be given as three & &integers." call fatal_error() @@ -444,7 +528,7 @@ contains allocate(entropy_mesh % dimension(3)) ! Copy dimensions - entropy_mesh % dimension = entropy_(1) % dimension + call get_node_array(node_entropy, "dimension", entropy_mesh % dimension) end if ! Turn on Shannon entropy calculation @@ -452,15 +536,19 @@ contains end if ! Uniform fission source weighting mesh - if (size(uniform_fs_) > 0) then + if (check_for_node(doc, "uniform_fs")) then + + ! Get pointer to ufs node + call get_node_ptr(doc, "uniform_fs", node_ufs) + ! Check to make sure enough values were supplied - if (size(uniform_fs_(1) % lower_left) /= 3) then + if (get_arraysize_double(node_ufs, "lower_left") /= 3) then message = "Need to specify (x,y,z) coordinates of lower-left corner & &of UFS mesh." - elseif (size(uniform_fs_(1) % upper_right) /= 3) then + elseif (get_arraysize_double(node_ufs, "upper_right") /= 3) then message = "Need to specify (x,y,z) coordinates of upper-right corner & &of UFS mesh." - elseif (size(uniform_fs_(1) % dimension) /= 3) then + elseif (get_arraysize_integer(node_ufs, "dimension") /= 3) then message = "Dimension of UFS mesh must be given as three integers." call fatal_error() end if @@ -476,11 +564,11 @@ contains allocate(ufs_mesh % dimension(3)) ! Copy dimensions - ufs_mesh % dimension = uniform_fs_(1) % dimension + call get_node_array(node_ufs, "dimension", ufs_mesh % dimension) ! Copy values - ufs_mesh % lower_left = uniform_fs_(1) % lower_left - ufs_mesh % upper_right = uniform_fs_(1) % upper_right + call get_node_array(node_ufs, "lower_left", ufs_mesh % lower_left) + call get_node_array(node_ufs, "upper_right", ufs_mesh % upper_right) ! Check on values provided if (.not. all(ufs_mesh % upper_right > ufs_mesh % lower_left)) then @@ -505,39 +593,38 @@ contains end if ! Check if the user has specified to write state points - if (size(state_point_) > 0) then + if (check_for_node(doc, "state_point")) then + + ! Get pointer to state_point node + call get_node_ptr(doc, "state_point", node_sp) + ! Determine number of batches at which to store state points - if (associated(state_point_(1) % batches)) then - n_state_points = size(state_point_(1) % batches) + if (check_for_node(node_sp, "batches")) then + n_state_points = get_arraysize_integer(node_sp, "batches") else n_state_points = 0 end if if (n_state_points > 0) then ! User gave specific batches to write state points + allocate(temp_int_array(n_state_points)) + call get_node_array(node_sp, "batches", temp_int_array) do i = 1, n_state_points - call statepoint_batch % add(state_point_(1) % batches(i)) + call statepoint_batch % add(temp_int_array(i)) end do - - elseif (state_point_(1) % interval /= 0) then + deallocate(temp_int_array) + elseif (check_for_node(node_sp, "interval")) then ! User gave an interval for writing state points - n_state_points = n_batches / state_point_(1) % interval + call get_node_value(node_sp, "interval", temp_int) + n_state_points = n_batches / temp_int do i = 1, n_state_points - call statepoint_batch % add(state_point_(1) % interval * i) + call statepoint_batch % add(temp_int * i) end do else ! If neither were specified, write state point at last batch n_state_points = 1 call statepoint_batch % add(n_batches) end if - - ! Check if the user has specified to write binary source file - call lower_case(state_point_(1) % source_separate) - call lower_case(state_point_(1) % source_write) - if (state_point_(1) % source_separate == 'true' .or. & - state_point_(1) % source_separate == '1') source_separate = .true. - if (state_point_(1) % source_write == 'false' .or. & - state_point_(1) % source_write == '0') source_write = .false. else ! If no tag was present, by default write state point at ! last batch only @@ -545,46 +632,155 @@ contains call statepoint_batch % add(n_batches) end if - ! Check if the user has specified to not reduce tallies at the end of every - ! batch - call lower_case(no_reduce_) - if (no_reduce_ == 'true' .or. no_reduce_ == '1') reduce_tallies = .false. + ! Check if the user has specified to write source points + if (check_for_node(doc, "source_point")) then - ! Check if the user has specified to use confidence intervals for - ! uncertainties rather than standard deviations - call lower_case(confidence_intervals_) - if (confidence_intervals_ == 'true' .or. & - confidence_intervals_ == '1') confidence_intervals = .true. + ! Get pointer to source_point node + call get_node_ptr(doc, "source_point", node_sp) - ! Check for output options - if (associated(output_)) then - do i = 1, size(output_) - call lower_case(output_(i)) - select case (output_(i)) - case ('summary') - output_summary = .true. - case ('cross_sections') - output_xs = .true. - case ('tallies') - output_tallies = .true. - case ('none') - output_summary = .false. - output_xs = .false. - output_tallies = .false. - end select + ! Determine number of batches at which to store source points + if (check_for_node(node_sp, "batches")) then + n_source_points = get_arraysize_integer(node_sp, "batches") + else + n_source_points = 0 + end if + + if (n_source_points > 0) then + ! User gave specific batches to write source points + allocate(temp_int_array(n_source_points)) + call get_node_array(node_sp, "batches", temp_int_array) + do i = 1, n_source_points + call sourcepoint_batch % add(temp_int_array(i)) + end do + deallocate(temp_int_array) + elseif (check_for_node(node_sp, "interval")) then + ! User gave an interval for writing source points + call get_node_value(node_sp, "interval", temp_int) + n_source_points = n_batches / temp_int + do i = 1, n_source_points + call sourcepoint_batch % add(temp_int * i) + end do + else + ! If neither were specified, write source points with state points + n_source_points = n_state_points + do i = 1, n_state_points + call sourcepoint_batch % add(statepoint_batch % get_item(i)) + end do + end if + + ! Check if the user has specified to write binary source file + if (check_for_node(node_sp, "separate")) then + call get_node_value(node_sp, "separate", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'true' .or. & + trim(temp_str) == '1') source_separate = .true. + end if + if (check_for_node(node_sp, "write")) then + call get_node_value(node_sp, "write", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'false' .or. & + trim(temp_str) == '0') source_write = .false. + end if + if (check_for_node(node_sp, "overwrite_latest")) then + call get_node_value(node_sp, "overwrite_latest", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'true' .or. & + trim(temp_str) == '1') then + source_latest = .true. + source_separate = .true. + end if + end if + else + ! If no tag was present, by default we keep source bank in + ! statepoint file and write it out at statepoints intervals + source_separate = .false. + n_source_points = n_state_points + do i = 1, n_state_points + call sourcepoint_batch % add(statepoint_batch % get_item(i)) end do end if - ! Check for cmfd run - call lower_case(run_cmfd_) - if (run_cmfd_ == 'true' .or. run_cmfd_ == '1') then - cmfd_run = .true. -#ifndef PETSC - message = 'CMFD is not available, recompile OpenMC with PETSc' - call fatal_error() -#endif + ! If source is not seperate and is to be written out in the statepoint file, + ! make sure that the sourcepoint batch numbers are contained in the + ! statepoint list + if (.not. source_separate) then + do i = 1, n_source_points + if (.not. statepoint_batch % contains(sourcepoint_batch % & + get_item(i))) then + message = 'Sourcepoint batches are not a subset& + & of statepoint batches.' + call fatal_error() + end if + end do end if + ! Check if the user has specified to not reduce tallies at the end of every + ! batch + if (check_for_node(doc, "no_reduce")) then + call get_node_value(doc, "no_reduce", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') & + reduce_tallies = .false. + end if + + ! Check if the user has specified to use confidence intervals for + ! uncertainties rather than standard deviations + if (check_for_node(doc, "confidence_intervals")) then + call get_node_value(doc, "confidence_intervals", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'true' .or. & + trim(temp_str) == '1') confidence_intervals = .true. + end if + + ! Check for output options + if (check_for_node(doc, "output")) then + + ! Get pointer to output node + call get_node_ptr(doc, "output", node_output) + + ! Check for summary option + if (check_for_node(node_output, "summary")) then + call get_node_value(node_output, "summary", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'true' .or. & + trim(temp_str) == '1') output_summary = .true. + end if + + ! Check for cross sections option + if (check_for_node(node_output, "cross_sections")) then + call get_node_value(node_output, "cross_sections", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'true' .or. & + trim(temp_str) == '1') output_xs = .true. + end if + + ! Check for ASCII tallies output option + if (check_for_node(node_output, "tallies")) then + call get_node_value(node_output, "tallies", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'false' .or. & + trim(temp_str) == '0') output_tallies = .false. + end if + end if + + ! Check for cmfd run + if (check_for_node(doc, "run_cmfd")) then + call get_node_value(doc, "run_cmfd", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') then + cmfd_run = .true. +#ifndef PETSC + if (master) then + message = 'CMFD is not available, compile OpenMC with PETSc' + call fatal_error() + end if +#endif + end if + end if + + ! Close settings XML file + call close_xmldoc(doc) + end subroutine read_settings_xml !=============================================================================== @@ -594,8 +790,6 @@ contains subroutine read_geometry_xml() - use xml_data_geometry_t - integer :: i, j, k, m integer :: n integer :: n_x, n_y, n_z @@ -603,6 +797,8 @@ contains integer :: n_cells_in_univ integer :: coeffs_reqd integer :: mid + integer :: temp_int_array3(3) + integer, allocatable :: temp_int_array(:) real(8) :: phi, theta, psi logical :: file_exists logical :: boundary_exists @@ -611,6 +807,13 @@ contains type(Cell), pointer :: c => null() type(Surface), pointer :: s => null() type(Lattice), pointer :: lat => null() + type(Node), pointer :: doc => null() + type(Node), pointer :: node_cell => null() + type(Node), pointer :: node_surf => null() + type(Node), pointer :: node_lat => null() + type(NodeList), pointer :: node_cell_list => null() + type(NodeList), pointer :: node_surf_list => null() + type(NodeList), pointer :: node_lat_list => null() ! Display output message message = "Reading geometry XML file..." @@ -628,10 +831,13 @@ contains end if ! Parse geometry.xml file - call read_xml_file_geometry_t(filename) + call open_xmldoc(doc, filename) + + ! Get pointer to list of XML + call get_node_list(doc, "cell", node_cell_list) ! Get number of tags - n_cells = size(cell_) + n_cells = get_list_size(node_cell_list) ! Check for no cells if (n_cells == 0) then @@ -651,10 +857,26 @@ contains do i = 1, n_cells c => cells(i) + ! Get pointer to i-th cell node + call get_list_item(node_cell_list, i, node_cell) + ! Copy data into cells - c % id = cell_(i) % id - c % universe = cell_(i) % universe - c % fill = cell_(i) % fill + if (check_for_node(node_cell, "id")) then + call get_node_value(node_cell, "id", c % id) + else + message = "Must specify id of cell in geometry XML file." + call fatal_error() + end if + if (check_for_node(node_cell, "universe")) then + call get_node_value(node_cell, "universe", c % universe) + else + c % universe = NONE + end if + if (check_for_node(node_cell, "fill")) then + call get_node_value(node_cell, "fill", c % fill) + else + c % fill = NONE + end if ! Check to make sure 'id' hasn't been used if (cell_dict % has_key(c % id)) then @@ -663,7 +885,9 @@ contains end if ! Read material - word = cell_(i) % material + word = '' + if (check_for_node(node_cell, "material")) & + call get_node_value(node_cell, "material", word) call lower_case(word) select case(word) case ('void') @@ -671,7 +895,7 @@ contains case ('') ! This case is called if no material was specified - c % material = 0 + c % material = NONE case default c % material = int(str_to_int(word), 4) @@ -698,20 +922,20 @@ contains end if ! Check to make sure that surfaces were specified - if (.not. associated(cell_(i) % surfaces)) then + if (.not. check_for_node(node_cell, "surfaces")) then message = "No surfaces specified for cell " // & trim(to_str(c % id)) call fatal_error() end if ! Allocate array for surfaces and copy - n = size(cell_(i) % surfaces) + n = get_arraysize_integer(node_cell, "surfaces") c % n_surfaces = n allocate(c % surfaces(n)) - c % surfaces = cell_(i) % surfaces + call get_node_array(node_cell, "surfaces", c % surfaces) ! Rotation matrix - if (associated(cell_(i) % rotation)) then + if (check_for_node(node_cell, "rotation")) then ! Rotations can only be applied to cells that are being filled with ! another universe if (c % fill == NONE) then @@ -721,7 +945,7 @@ contains end if ! Read number of rotation parameters - n = size(cell_(i) % rotation) + n = get_arraysize_double(node_cell, "rotation") if (n /= 3) then message = "Incorrect number of rotation parameters on cell " // & to_str(c % id) @@ -729,9 +953,10 @@ contains end if ! Copy rotation angles in x,y,z directions - phi = -cell_(i) % rotation(1) * PI/180.0 - theta = -cell_(i) % rotation(2) * PI/180.0 - psi = -cell_(i) % rotation(3) * PI/180.0 + call get_node_array(node_cell, "rotation", temp_int_array3) + phi = -temp_int_array3(1) * PI/180.0_8 + theta = -temp_int_array3(2) * PI/180.0_8 + psi = -temp_int_array3(3) * PI/180.0_8 ! Calculate rotation matrix based on angles given allocate(c % rotation(3,3)) @@ -746,7 +971,7 @@ contains end if ! Translation vector - if (associated(cell_(i) % translation)) then + if (check_for_node(node_cell, "translation")) then ! Translations can only be applied to cells that are being filled with ! another universe if (c % fill == NONE) then @@ -756,7 +981,7 @@ contains end if ! Read number of translation parameters - n = size(cell_(i) % translation) + n = get_arraysize_double(node_cell, "translation") if (n /= 3) then message = "Incorrect number of translation parameters on cell " & // to_str(c % id) @@ -765,7 +990,7 @@ contains ! Copy translation vector allocate(c % translation(3)) - c % translation = cell_(i) % translation + call get_node_array(node_cell, "translation", c % translation) end if ! Add cell to dictionary @@ -774,7 +999,7 @@ contains ! For cells, we also need to check if there's a new universe -- ! also for every cell add 1 to the count of cells for the ! specified universe - universe_num = cell_(i) % universe + universe_num = c % universe if (.not. cells_in_univ_dict % has_key(universe_num)) then n_universes = n_universes + 1 n_cells_in_univ = 1 @@ -793,8 +1018,11 @@ contains ! applied to a surface boundary_exists = .false. + ! get pointer to list of xml + call get_node_list(doc, "surface", node_surf_list) + ! Get number of tags - n_surfaces = size(surface_) + n_surfaces = get_list_size(node_surf_list) ! Check for no surfaces if (n_surfaces == 0) then @@ -808,8 +1036,16 @@ contains do i = 1, n_surfaces s => surfaces(i) + ! Get pointer to i-th surface node + call get_list_item(node_surf_list, i, node_surf) + ! Copy data into cells - s % id = surface_(i) % id + if (check_for_node(node_surf, "id")) then + call get_node_value(node_surf, "id", s % id) + else + message = "Must specify id of surface in geometry XML file." + call fatal_error() + end if ! Check to make sure 'id' hasn't been used if (surface_dict % has_key(s % id)) then @@ -819,7 +1055,9 @@ contains end if ! Copy and interpret surface type - word = surface_(i) % type + word = '' + if (check_for_node(node_surf, "type")) & + call get_node_value(node_surf, "type", word) call lower_case(word) select case(trim(word)) case ('x-plane') @@ -856,7 +1094,7 @@ contains s % type = SURF_CONE_Z coeffs_reqd = 4 case default - message = "Invalid surface type: " // trim(surface_(i) % type) + message = "Invalid surface type: " // trim(word) call fatal_error() end select @@ -864,7 +1102,7 @@ contains ! have been specified for the given type of surface. Then copy ! surface coordinates. - n = size(surface_(i) % coeffs) + n = get_arraysize_double(node_surf, "coeffs") if (n < coeffs_reqd) then message = "Not enough coefficients specified for surface: " // & trim(to_str(s % id)) @@ -875,11 +1113,13 @@ contains call fatal_error() else allocate(s % coeffs(n)) - s % coeffs = surface_(i) % coeffs + call get_node_array(node_surf, "coeffs", s % coeffs) end if ! Boundary conditions - word = surface_(i) % boundary + word = '' + if (check_for_node(node_surf, "boundary")) & + call get_node_value(node_surf, "boundary", word) call lower_case(word) select case (trim(word)) case ('transmission', 'transmit', '') @@ -911,15 +1151,26 @@ contains ! ========================================================================== ! READ LATTICES FROM GEOMETRY.XML + ! Get pointer to list of XML + call get_node_list(doc, "lattice", node_lat_list) + ! Allocate lattices array - n_lattices = size(lattice_) + n_lattices = get_list_size(node_lat_list) allocate(lattices(n_lattices)) do i = 1, n_lattices lat => lattices(i) + ! Get pointer to i-th lattice + call get_list_item(node_lat_list, i, node_lat) + ! ID of lattice - lat % id = lattice_(i) % id + if (check_for_node(node_lat, "id")) then + call get_node_value(node_lat, "id", lat % id) + else + message = "Must specify id of lattice in geometry XML file." + call fatal_error() + end if ! Check to make sure 'id' hasn't been used if (lattice_dict % has_key(lat % id)) then @@ -929,7 +1180,9 @@ contains end if ! Read lattice type - word = lattice_(i) % type + word = '' + if (check_for_node(node_lat, "type")) & + call get_node_value(node_lat, "type", word) call lower_case(word) select case (trim(word)) case ('rect', 'rectangle', 'rectangular') @@ -937,12 +1190,12 @@ contains case ('hex', 'hexagon', 'hexagonal') lat % type = LATTICE_HEX case default - message = "Invalid lattice type: " // trim(lattice_(i) % type) + message = "Invalid lattice type: " // trim(word) call fatal_error() end select ! Read number of lattice cells in each dimension - n = size(lattice_(i) % dimension) + n = get_arraysize_integer(node_lat, "dimension") if (n /= 2 .and. n /= 3) then message = "Lattice must be two or three dimensions." call fatal_error() @@ -950,27 +1203,29 @@ contains lat % n_dimension = n allocate(lat % dimension(n)) - lat % dimension = lattice_(i) % dimension + call get_node_array(node_lat, "dimension", lat % dimension) ! Read lattice lower-left location - if (size(lattice_(i) % dimension) /= size(lattice_(i) % lower_left)) then + if (size(lat % dimension) /= & + get_arraysize_double(node_lat, "lower_left")) then message = "Number of entries on must be the same as & &the number of entries on ." call fatal_error() end if allocate(lat % lower_left(n)) - lat % lower_left = lattice_(i) % lower_left + call get_node_array(node_lat, "lower_left", lat % lower_left) ! Read lattice widths - if (size(lattice_(i) % width) /= size(lattice_(i) % lower_left)) then + if (size(lat % dimension) /= & + get_arraysize_double(node_lat, "width")) then message = "Number of entries on must be the same as & &the number of entries on ." call fatal_error() end if allocate(lat % width(n)) - lat % width = lattice_(i) % width + call get_node_array(node_lat, "width", lat % width) ! Copy number of dimensions n_x = lat % dimension(1) @@ -983,28 +1238,36 @@ contains allocate(lat % universes(n_x, n_y, n_z)) ! Check that number of universes matches size - if (size(lattice_(i) % universes) /= n_x*n_y*n_z) then + n = get_arraysize_integer(node_lat, "universes") + if (n /= n_x*n_y*n_z) then message = "Number of universes on does not match size of & &lattice " // trim(to_str(lat % id)) // "." call fatal_error() end if + allocate(temp_int_array(n)) + call get_node_array(node_lat, "universes", temp_int_array) + ! Read universes do m = 1, n_z do k = 0, n_y - 1 do j = 1, n_x - lat % universes(j, n_y - k, m) = lattice_(i) % & - universes(j + n_x*k + n_x*n_y*(m-1)) + lat % universes(j, n_y - k, m) = & + temp_int_array(j + n_x*k + n_x*n_y*(m-1)) end do end do end do + deallocate(temp_int_array) ! Read material for area outside lattice - mid = lattice_(i) % outside - if (mid == 0 .or. mid == MATERIAL_VOID) then - lat % outside = MATERIAL_VOID - else - lat % outside = mid + lat % outside = MATERIAL_VOID + if (check_for_node(node_lat, "outside")) then + call get_node_value(node_lat, "outside", mid) + if (mid == 0 .or. mid == MATERIAL_VOID) then + lat % outside = MATERIAL_VOID + else + lat % outside = mid + end if end if ! Add lattice to dictionary @@ -1012,6 +1275,9 @@ contains end do + ! Close geometry XML file + call close_xmldoc(doc) + end subroutine read_geometry_xml !=============================================================================== @@ -1019,9 +1285,7 @@ contains ! for errors and placing properly-formatted data in the right data structures !=============================================================================== - subroutine read_materials_xml - - use xml_data_materials_t + subroutine read_materials_xml() integer :: i ! loop index for materials integer :: j ! loop index for nuclides @@ -1031,17 +1295,27 @@ contains integer :: index_nuclide ! index in nuclides integer :: index_sab ! index in sab_tables real(8) :: val ! value entered for density + real(8) :: temp_dble ! temporary double prec. real logical :: file_exists ! does materials.xml exist? logical :: sum_density ! density is taken to be sum of nuclide densities character(12) :: name ! name of isotope, e.g. 92235.03c character(12) :: alias ! alias of nuclide, e.g. U-235.03c character(MAX_WORD_LEN) :: units ! units on density character(MAX_LINE_LEN) :: filename ! absolute path to materials.xml + character(MAX_LINE_LEN) :: temp_str ! temporary string when reading type(ListChar) :: list_names ! temporary list of nuclide names type(ListReal) :: list_density ! temporary list of nuclide densities type(Material), pointer :: mat => null() - type(nuclide_xml), pointer :: nuc => null() - type(sab_xml), pointer :: sab => null() + type(Node), pointer :: doc => null() + type(Node), pointer :: node_mat => null() + type(Node), pointer :: node_dens => null() + type(Node), pointer :: node_nuc => null() + type(Node), pointer :: node_ele => null() + type(Node), pointer :: node_sab => null() + type(NodeList), pointer :: node_mat_list => null() + type(NodeList), pointer :: node_nuc_list => null() + type(NodeList), pointer :: node_ele_list => null() + type(NodeList), pointer :: node_sab_list => null() ! Display output message message = "Reading materials XML file..." @@ -1056,16 +1330,20 @@ contains end if ! Initialize default cross section variable - default_xs_ = "" + default_xs = "" ! Parse materials.xml file - call read_xml_file_materials_t(filename) + call open_xmldoc(doc, filename) ! Copy default cross section if present - default_xs = default_xs_ + if (check_for_node(doc, "default_xs")) & + call get_node_value(doc, "default_xs", default_xs) + + ! Get pointer to list of XML + call get_node_list(doc, "material", node_mat_list) ! Allocate cells array - n_materials = size(material_) + n_materials = get_list_size(node_mat_list) allocate(materials(n_materials)) ! Initialize count for number of nuclides/S(a,b) tables @@ -1075,8 +1353,16 @@ contains do i = 1, n_materials mat => materials(i) + ! Get pointer to i-th material node + call get_list_item(node_mat_list, i, node_mat) + ! Copy material id - mat % id = material_(i) % id + if (check_for_node(node_mat, "id")) then + call get_node_value(node_mat, "id", mat % id) + else + message = "Must specify id of material in materials XML file" + call fatal_error() + end if ! Check to make sure 'id' hasn't been used if (material_dict % has_key(mat % id)) then @@ -1094,9 +1380,20 @@ contains ! ======================================================================= ! READ AND PARSE TAG - ! Copy value and units - val = material_(i) % density % value - units = material_(i) % density % units + ! Get pointer to density element + if (check_for_node(node_mat, "density")) then + call get_node_ptr(node_mat, "density", node_dens) + else + message = "Must specify density element in material " // & + trim(to_str(mat % id)) + call fatal_error() + end if + + ! Initialize value to zero + val = ZERO + + ! Copy units + call get_node_value(node_dens, "units", units) if (units == 'sum') then ! If the user gave the units as 'sum', then the total density of the @@ -1106,6 +1403,9 @@ contains sum_density = .true. else + ! Copy value + call get_node_value(node_dens, "value", val) + ! Check for erroneous density sum_density = .false. if (val <= ZERO) then @@ -1126,7 +1426,7 @@ contains case ('atom/cm3', 'atom/cc') mat % density = 1.0e-24 * val case default - message = "Unkwown units '" // trim(material_(i) % density % units) & + message = "Unkwown units '" // trim(units) & // "' specified on material " // trim(to_str(mat % id)) call fatal_error() end select @@ -1136,101 +1436,118 @@ contains ! READ AND PARSE TAGS ! Check to ensure material has at least one nuclide - if (.not. associated(material_(i) % nuclides) .and. & - .not. associated(material_(i) % elements)) then + if (.not. check_for_node(node_mat, "nuclide") .and. & + .not. check_for_node(node_mat, "element")) then message = "No nuclides or natural elements specified on material " // & trim(to_str(mat % id)) call fatal_error() end if + ! Get pointer list of XML + call get_node_list(node_mat, "nuclide", node_nuc_list) + ! Create list of nuclides based on those specified plus natural elements - INDIVIDUAL_NUCLIDES: do j = 1, size(material_(i) % nuclides) + INDIVIDUAL_NUCLIDES: do j = 1, get_list_size(node_nuc_list) ! Combine nuclide identifier and cross section and copy into names - nuc => material_(i) % nuclides(j) + call get_list_item(node_nuc_list, j, node_nuc) ! Check for empty name on nuclide - if (len_trim(nuc % name) == 0) then + if (.not.check_for_node(node_nuc, "name")) then message = "No name specified on nuclide in material " // & trim(to_str(mat % id)) call fatal_error() end if ! Check for cross section - if (len_trim(nuc % xs) == 0) then + if (.not.check_for_node(node_nuc, "xs")) then if (default_xs == '') then message = "No cross section specified for nuclide in material " & // trim(to_str(mat % id)) call fatal_error() else - nuc % xs = default_xs + name = trim(default_xs) end if end if ! store full name - name = trim(nuc % name) // "." // trim(nuc % xs) + call get_node_value(node_nuc, "name", temp_str) + if (check_for_node(node_nuc, "xs")) & + call get_node_value(node_nuc, "xs", name) + name = trim(temp_str) // "." // trim(name) ! save name and density to list call list_names % append(name) ! Check if no atom/weight percents were specified or if both atom and ! weight percents were specified - if (nuc % ao == ZERO .and. nuc % wo == ZERO) then + if (.not.check_for_node(node_nuc, "ao") .and. & + .not.check_for_node(node_nuc, "wo")) then message = "No atom or weight percent specified for nuclide " // & trim(name) call fatal_error() - elseif (nuc % ao /= ZERO .and. nuc % wo /= ZERO) then + elseif (check_for_node(node_nuc, "ao") .and. & + check_for_node(node_nuc, "wo")) then message = "Cannot specify both atom and weight percents for a & &nuclide: " // trim(name) call fatal_error() end if ! Copy atom/weight percents - if (nuc % ao /= ZERO) then - call list_density % append(nuc % ao) + if (check_for_node(node_nuc, "ao")) then + call get_node_value(node_nuc, "ao", temp_dble) + call list_density % append(temp_dble) else - call list_density % append(-nuc % wo) + call get_node_value(node_nuc, "wo", temp_dble) + call list_density % append(-temp_dble) end if end do INDIVIDUAL_NUCLIDES ! ======================================================================= ! READ AND PARSE TAGS - NATURAL_ELEMENTS: do j = 1, size(material_(i) % elements) - nuc => material_(i) % elements(j) + ! Get pointer list of XML + call get_node_list(node_mat, "element", node_ele_list) + + NATURAL_ELEMENTS: do j = 1, get_list_size(node_ele_list) + call get_list_item(node_ele_list, j, node_ele) ! Check for empty name on natural element - if (len_trim(nuc % name) == 0) then + if (.not.check_for_node(node_ele, "name")) then message = "No name specified on nuclide in material " // & trim(to_str(mat % id)) call fatal_error() end if + call get_node_value(node_ele, "name", name) ! Check for cross section - if (len_trim(nuc % xs) == 0) then + if (.not.check_for_node(node_ele, "xs")) then if (default_xs == '') then message = "No cross section specified for nuclide in material " & // trim(to_str(mat % id)) call fatal_error() else - nuc % xs = default_xs + temp_str = trim(default_xs) end if end if ! Check if no atom/weight percents were specified or if both atom and ! weight percents were specified - if (nuc % ao == ZERO .and. nuc % wo == ZERO) then - message = "No atom or weight percent specified for nuclide " // & + if (.not.check_for_node(node_ele, "ao") .and. & + .not.check_for_node(node_ele, "wo")) then + message = "No atom or weight percent specified for element " // & trim(name) call fatal_error() - elseif (nuc % ao /= ZERO .and. nuc % wo /= ZERO) then + elseif (check_for_node(node_ele, "ao") .and. & + check_for_node(node_ele, "wo")) then message = "Cannot specify both atom and weight percents for a & - &nuclide: " // trim(name) + &element: " // trim(name) call fatal_error() end if ! Expand element into naturally-occurring isotopes - if (nuc % ao /= ZERO) then - call expand_natural_element(nuc % name, nuc % xs, nuc % ao, & + if (check_for_node(node_ele, "ao")) then + call get_node_value(node_ele, "ao", temp_dble) + call expand_natural_element(name, temp_str, temp_dble, & list_names, list_density) else message = "The ability to expand a natural element based on weight & @@ -1251,7 +1568,7 @@ contains ALL_NUCLIDES: do j = 1, mat % n_nuclides ! Check that this nuclide is listed in the cross_sections.xml file - name = list_names % get_item(j) + name = trim(list_names % get_item(j)) if (.not. xs_listing_dict % has_key(name)) then message = "Could not find nuclide " // trim(name) // & " in cross_sections.xml file!" @@ -1307,7 +1624,10 @@ contains ! ======================================================================= ! READ AND PARSE TAG FOR S(a,b) DATA - n_sab = size(material_(i) % sab) + ! Get pointer list to XML + call get_node_list(node_mat, "sab", node_sab_list) + + n_sab = get_list_size(node_sab_list) if (n_sab > 0) then ! Set number of S(a,b) tables mat % n_sab = n_sab @@ -1322,10 +1642,17 @@ contains do j = 1, n_sab ! Get pointer to S(a,b) table - sab => material_(i) % sab(j) + call get_list_item(node_sab_list, j, node_sab) ! Determine name of S(a,b) table - name = trim(sab % name) // "." // trim(sab % xs) + if (.not.check_for_node(node_sab, "name") .or. & + .not.check_for_node(node_sab, "xs")) then + message = "Need to specify and for S(a,b) table." + call fatal_error() + end if + call get_node_value(node_sab, "name", name) + call get_node_value(node_sab, "xs", temp_str) + name = trim(name) // "." // trim(temp_str) mat % sab_names(j) = name ! Check that this nuclide is listed in the cross_sections.xml file @@ -1339,16 +1666,13 @@ contains ! listing index_list = xs_listing_dict % get_key(name) name = xs_listings(index_list) % name - alias = xs_listings(index_list) % alias ! If this S(a,b) table hasn't been encountered yet, we need to add its ! name and alias to the sab_dict if (.not. sab_dict % has_key(name)) then - index_sab = index_sab + 1 + index_sab = index_sab + 1 mat % i_sab_tables(j) = index_sab - call sab_dict % add_key(name, index_sab) - call sab_dict % add_key(alias, index_sab) else mat % i_sab_tables(j) = sab_dict % get_key(name) end if @@ -1363,6 +1687,9 @@ contains n_nuclides_total = index_nuclide n_sab_tables = index_sab + ! Close materials XML file + call close_xmldoc(doc) + end subroutine read_materials_xml !=============================================================================== @@ -1370,9 +1697,7 @@ contains ! for errors and placing properly-formatted data in the right data structures !=============================================================================== - subroutine read_tallies_xml - - use xml_data_tallies_t + subroutine read_tallies_xml() integer :: i ! loop over user-specified tallies integer :: j ! loop over words @@ -1388,14 +1713,25 @@ contains integer :: n_order ! Scattering order requested integer :: n_order_pos ! Position of Scattering order in score name string integer :: MT ! user-specified MT for score + integer :: iarray3(3) ! temporary integer array logical :: file_exists ! does tallies.xml file exist? + real(8) :: rarray3(3) ! temporary double prec. array character(MAX_LINE_LEN) :: filename character(MAX_WORD_LEN) :: word character(MAX_WORD_LEN) :: score_name + character(MAX_WORD_LEN) :: temp_str + character(MAX_WORD_LEN), allocatable :: sarray(:) type(ElemKeyValueCI), pointer :: pair_list => null() type(TallyObject), pointer :: t => null() type(StructuredMesh), pointer :: m => null() type(TallyFilter), allocatable :: filters(:) ! temporary filters + type(Node), pointer :: doc => null() + type(Node), pointer :: node_mesh => null() + type(Node), pointer :: node_tal => null() + type(Node), pointer :: node_filt => null() + type(NodeList), pointer :: node_mesh_list => null() + type(NodeList), pointer :: node_tal_list => null() + type(NodeList), pointer :: node_filt_list => null() ! Check if tallies.xml exists filename = trim(path_input) // "tallies.xml" @@ -1410,33 +1746,33 @@ contains call write_message(5) ! Parse tallies.xml file - call read_xml_file_tallies_t(filename) + call open_xmldoc(doc, filename) ! ========================================================================== ! DETERMINE SIZE OF ARRAYS AND ALLOCATE + ! Get pointer list to XML + call get_node_list(doc, "mesh", node_mesh_list) + + ! Get pointer list to XML + call get_node_list(doc, "tally", node_tal_list) + ! Check for user meshes - if (.not. associated(mesh_)) then - n_user_meshes = 0 + n_user_meshes = get_list_size(node_mesh_list) + if (cmfd_run) then + n_meshes = n_user_meshes + n_cmfd_meshes else - n_user_meshes = size(mesh_) - if (cmfd_run) then - n_meshes = n_user_meshes + n_cmfd_meshes - else - n_meshes = n_user_meshes - end if + n_meshes = n_user_meshes end if ! Allocate mesh array if (n_meshes > 0) allocate(meshes(n_meshes)) ! Check for user tallies - if (.not. associated(tally_)) then - n_user_tallies = 0 + n_user_tallies = get_list_size(node_tal_list) + if (n_user_tallies == 0) then message = "No tallies present in tallies.xml file!" call warning() - else - n_user_tallies = size(tally_) end if ! Allocate tally array @@ -1445,8 +1781,12 @@ contains end if ! Check for setting - call lower_case(separate_) - if (separate_ == 'true' .or. separate_ == '1') assume_separate = .true. + if (check_for_node(doc, "assume_separate")) then + call get_node_value(doc, "assume_separate", temp_str) + call lower_case(temp_str) + if (trim(temp_str) == 'true' .or. trim(temp_str) == '1') & + assume_separate = .true. + end if ! ========================================================================== ! READ MESH DATA @@ -1454,8 +1794,16 @@ contains do i = 1, n_user_meshes m => meshes(i) - ! copy mesh id - m % id = mesh_(i) % id + ! Get pointer to mesh node + call get_list_item(node_mesh_list, i, node_mesh) + + ! Copy mesh id + if (check_for_node(node_mesh, "id")) then + call get_node_value(node_mesh, "id", m % id) + else + message = "Must specify id for mesh in tally XML file." + call fatal_error() + end if ! Check to make sure 'id' hasn't been used if (mesh_dict % has_key(m % id)) then @@ -1465,19 +1813,22 @@ contains end if ! Read mesh type - call lower_case(mesh_(i) % type) - select case (mesh_(i) % type) + temp_str = '' + if (check_for_node(node_mesh, "type")) & + call get_node_value(node_mesh, "type", temp_str) + call lower_case(temp_str) + select case (trim(temp_str)) case ('rect', 'rectangle', 'rectangular') m % type = LATTICE_RECT case ('hex', 'hexagon', 'hexagonal') m % type = LATTICE_HEX case default - message = "Invalid mesh type: " // trim(mesh_(i) % type) + message = "Invalid mesh type: " // trim(temp_str) call fatal_error() end select ! Determine number of dimensions for mesh - n = size(mesh_(i) % 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() @@ -1491,74 +1842,79 @@ contains allocate(m % upper_right(n)) ! Check that dimensions are all greater than zero - if (any(mesh_(i) % dimension <= 0)) then + call get_node_array(node_mesh, "dimension", iarray3(1:n)) + if (any(iarray3(1:n) <= 0)) then message = "All entries on the element for a tally mesh & &must be positive." call fatal_error() end if ! Read dimensions in each direction - m % dimension = mesh_(i) % dimension + m % dimension = iarray3(1:n) ! Read mesh lower-left corner location - if (m % n_dimension /= size(mesh_(i) % lower_left)) then + if (m % n_dimension /= get_arraysize_double(node_mesh, "lower_left")) then message = "Number of entries on must be the same as & &the number of entries on ." call fatal_error() end if - m % lower_left = mesh_(i) % 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_(i) % upper_right) .and. & - associated(mesh_(i) % width)) then + ! 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 and on a & &tally mesh." call fatal_error() end if ! Make sure either upper-right or width was specified - if (.not. associated(mesh_(i) % upper_right) .and. & - .not. associated(mesh_(i) % width)) then + if (.not.check_for_node(node_mesh, "upper_right") .and. & + .not.check_for_node(node_mesh, "width")) then message = "Must specify either and on a & &tally mesh." call fatal_error() end if - if (associated(mesh_(i) % width)) then + if (check_for_node(node_mesh, "width")) then ! Check to ensure width has same dimensions - if (size(mesh_(i) % width) /= size(mesh_(i) % lower_left)) then + if (get_arraysize_double(node_mesh, "width") /= & + get_arraysize_double(node_mesh, "lower_left")) then message = "Number of entries on must be the same as the & &number of entries on ." call fatal_error() end if ! Check for negative widths - if (any(mesh_(i) % width < ZERO)) then + call get_node_array(node_mesh, "width", rarray3(1:n)) + if (any(rarray3(1:n) < ZERO)) then message = "Cannot have a negative on a tally mesh." call fatal_error() end if ! Set width and upper right coordinate - m % width = mesh_(i) % width + m % width = rarray3(1:n) m % upper_right = m % lower_left + m % dimension * m % width - elseif (associated(mesh_(i) % upper_right)) then + elseif (check_for_node(node_mesh, "upper_right")) then ! Check to ensure width has same dimensions - if (size(mesh_(i) % upper_right) /= size(mesh_(i) % lower_left)) then + if (get_arraysize_double(node_mesh, "upper_right") /= & + get_arraysize_double(node_mesh, "lower_left")) then message = "Number of entries on must be the same as & &the number of entries on ." call fatal_error() end if ! Check that upper-right is above lower-left - if (any(mesh_(i) % upper_right < mesh_(i) % lower_left)) then + call get_node_array(node_mesh, "upper_right", rarray3(1:n)) + if (any(rarray3(1:n) < m % lower_left)) then message = "The coordinates must be greater than the & & coordinates on a tally mesh." call fatal_error() end if ! Set width and upper right coordinate - m % upper_right = mesh_(i) % upper_right + m % upper_right = rarray3(1:n) m % width = (m % upper_right - m % lower_left) / m % dimension end if @@ -1576,6 +1932,9 @@ contains ! Get pointer to tally t => tallies(i) + ! Get pointer to tally xml node + call get_list_item(node_tal_list, i, node_tal) + ! Set tally type to volume by default t % type = TALLY_VOLUME @@ -1588,7 +1947,12 @@ contains t % estimator = ESTIMATOR_TRACKLENGTH ! Copy material id - t % id = tally_(i) % id + if (check_for_node(node_tal, "id")) then + call get_node_value(node_tal, "id", t % id) + else + message = "Must specify id for tally in tally XML file." + call fatal_error() + end if ! Check to make sure 'id' hasn't been used if (tally_dict % has_key(t % id)) then @@ -1598,7 +1962,9 @@ contains end if ! Copy tally label - t % label = tally_(i) % label + t % label = '' + if (check_for_node(node_tal, "label")) & + call get_node_value(node_tal, "label", t % label) ! ======================================================================= ! READ DATA FOR FILTERS @@ -1607,29 +1973,47 @@ contains ! element followed by sub-elements , , etc. This checks for ! the old format and if it is present, raises an error - if (size(tally_(i) % filters) > 0) then - message = "Tally filters should be specified with multiple & - &elements. Did you forget to change your element?" - call fatal_error() - end if +! if (get_number_nodes(node_tal, "filters") > 0) then +! message = "Tally filters should be specified with multiple & +! &elements. Did you forget to change your element?" +! call fatal_error() +! end if - if (associated(tally_(i) % filter)) then - ! Determine number of filters - n_filters = size(tally_(i) % filter) + ! Get pointer list to XML and get number of filters + call get_node_list(node_tal, "filter", node_filt_list) + n_filters = get_list_size(node_filt_list) + + if (n_filters /= 0) then ! Allocate filters array t % n_filters = n_filters allocate(t % filters(n_filters)) READ_FILTERS: do j = 1, n_filters + ! Get pointer to filter xml node + call get_list_item(node_filt_list, j, node_filt) + ! Convert filter type to lower case - call lower_case(tally_(i) % filter(j) % type) + temp_str = '' + if (check_for_node(node_filt, "type")) & + call get_node_value(node_filt, "type", temp_str) + call lower_case(temp_str) ! Determine number of bins - n_words = size(tally_(i) % filter(j) % bins) + if (check_for_node(node_filt, "bins")) then + if (trim(temp_str) == 'energy' .or. & + trim(temp_str) == 'energyout') then + n_words = get_arraysize_double(node_filt, "bins") + else + n_words = get_arraysize_integer(node_filt, "bins") + end if + else + message = "Bins not set in filter on tally " // trim(to_str(t % id)) + call fatal_error() + end if ! Determine type of filter - select case (tally_(i) % filter(j) % type) + select case (temp_str) case ('cell') ! Set type of filter t % filters(j) % type = FILTER_CELL @@ -1639,10 +2023,7 @@ contains ! Allocate and store bins allocate(t % filters(j) % int_bins(n_words)) - do k = 1, n_words - t % filters(j) % int_bins(k) = int(str_to_int(& - tally_(i) % filter(j) % bins(k)),4) - end do + call get_node_array(node_filt, "bins", t % filters(j) % int_bins) case ('cellborn') ! Set type of filter @@ -1653,10 +2034,7 @@ contains ! Allocate and store bins allocate(t % filters(j) % int_bins(n_words)) - do k = 1, n_words - t % filters(j) % int_bins(k) = int(str_to_int(& - tally_(i) % filter(j) % bins(k)),4) - end do + call get_node_array(node_filt, "bins", t % filters(j) % int_bins) case ('material') ! Set type of filter @@ -1667,10 +2045,7 @@ contains ! Allocate and store bins allocate(t % filters(j) % int_bins(n_words)) - do k = 1, n_words - t % filters(j) % int_bins(k) = int(str_to_int(& - tally_(i) % filter(j) % bins(k)),4) - end do + call get_node_array(node_filt, "bins", t % filters(j) % int_bins) case ('universe') ! Set type of filter @@ -1681,10 +2056,7 @@ contains ! Allocate and store bins allocate(t % filters(j) % int_bins(n_words)) - do k = 1, n_words - t % filters(j) % int_bins(k) = int(str_to_int(& - tally_(i) % filter(j) % bins(k)),4) - end do + call get_node_array(node_filt, "bins", t % filters(j) % int_bins) case ('surface') message = "Surface filter is not yet supported!" @@ -1698,10 +2070,7 @@ contains ! Allocate and store bins allocate(t % filters(j) % int_bins(n_words)) - do k = 1, n_words - t % filters(j) % int_bins(k) = int(str_to_int(& - tally_(i) % filter(j) % bins(k)),4) - end do + call get_node_array(node_filt, "bins", t % filters(j) % int_bins) case ('mesh') ! Set type of filter @@ -1714,7 +2083,7 @@ contains end if ! Determine id of mesh - id = int(str_to_int(tally_(i) % filter(j) % bins(1)),4) + call get_node_value(node_filt, "bins", id) ! Get pointer to mesh if (mesh_dict % has_key(id)) then @@ -1744,10 +2113,7 @@ contains ! Allocate and store bins allocate(t % filters(j) % real_bins(n_words)) - do k = 1, n_words - t % filters(j) % real_bins(k) = str_to_real(& - tally_(i) % filter(j) % bins(k)) - end do + call get_node_array(node_filt, "bins", t % filters(j) % real_bins) case ('energyout') ! Set type of filter @@ -1758,18 +2124,15 @@ contains ! Allocate and store bins allocate(t % filters(j) % real_bins(n_words)) - do k = 1, n_words - t % filters(j) % real_bins(k) = str_to_real(& - tally_(i) % filter(j) % bins(k)) - end do + call get_node_array(node_filt, "bins", t % filters(j) % real_bins) ! Set to analog estimator t % estimator = ESTIMATOR_ANALOG case default ! Specified tally filter is invalid, raise error - message = "Unknown filter type '" // trim(tally_(i) % & - filter(j) % type) // "' on tally " // & + message = "Unknown filter type '" // & + trim(temp_str) // "' on tally " // & trim(to_str(t % id)) // "." call fatal_error() @@ -1798,8 +2161,13 @@ contains ! ======================================================================= ! READ DATA FOR NUCLIDES - if (associated(tally_(i) % nuclides)) then - if (tally_(i) % nuclides(1) == 'all') then + if (check_for_node(node_tal, "nuclides")) then + + ! Allocate a temporary string array for nuclides and copy values over + allocate(sarray(get_arraysize_string(node_tal, "nuclides"))) + call get_node_array(node_tal, "nuclides", sarray) + + if (trim(sarray(1)) == 'all') then ! Handle special case all allocate(t % nuclide_bins(n_nuclides_total + 1)) @@ -1815,25 +2183,25 @@ contains t % all_nuclides = .true. else ! Any other case, e.g. U-235 Pu-239 - n_words = size(tally_(i) % nuclides) + n_words = get_arraysize_string(node_tal, "nuclides") allocate(t % nuclide_bins(n_words)) do j = 1, n_words ! Check if total material was specified - if (tally_(i) % nuclides(j) == 'total') then + if (trim(sarray(j)) == 'total') then t % nuclide_bins(j) = -1 cycle end if ! Check if xs specifier was given - if (ends_with(tally_(i) % nuclides(j), 'c')) then - word = tally_(i) % nuclides(j) + if (ends_with(sarray(j), 'c')) then + word = sarray(j) else if (default_xs == '') then ! No default cross section specified, search through nuclides pair_list => nuclide_dict % keys() do while (associated(pair_list)) if (starts_with(pair_list % key, & - tally_(i) % nuclides(j))) then + sarray(j))) then word = pair_list % key(1:150) exit end if @@ -1845,14 +2213,14 @@ contains ! Check if no nuclide was found if (.not. associated(pair_list)) then message = "Could not find the nuclide " // trim(& - tally_(i) % nuclides(j)) // " specified in tally " & + sarray(j)) // " specified in tally " & // trim(to_str(t % id)) // " in any material." call fatal_error() end if deallocate(pair_list) else ! Set nuclide to default xs - word = trim(tally_(i) % nuclides(j)) // "." // default_xs + word = trim(sarray(j)) // "." // default_xs end if end if @@ -1871,6 +2239,9 @@ contains t % n_nuclide_bins = n_words end if + ! Deallocate temporary string array + deallocate(sarray) + else ! No were specified -- create only one bin will be added ! for the total material. @@ -1882,18 +2253,20 @@ contains ! ======================================================================= ! READ DATA FOR SCORES - if (associated(tally_(i) % scores)) then + if (check_for_node(node_tal, "scores")) then ! Loop through scores and determine if a scatter-p# input was used ! to allow for proper pre-allocating of t % score_bins ! This scheme allows multiple scatter-p# to be requested by the user ! if so desired - n_words = size(tally_(i) % scores) + n_words = get_arraysize_string(node_tal, "scores") + allocate(sarray(n_words)) + call get_node_array(node_tal, "scores", sarray) n_new = 0 do j = 1, n_words - call lower_case(tally_(i) % scores(j)) + call lower_case(sarray(j)) ! Find if scores(j) is of the form 'scatter-p' ! If so, get the number and do a select case on that. - score_name = tally_(i) % scores(j) + score_name = trim(sarray(j)) if (starts_with(score_name,'scatter-p')) then n_order_pos = scan(score_name,'0123456789') n_order = int(str_to_int( & @@ -1906,7 +2279,7 @@ contains trim(to_str(SCATT_ORDER_MAX)) call warning() n_order = SCATT_ORDER_MAX - tally_(i) % scores(j) = SCATT_ORDER_MAX_PNSTR + sarray(j) = SCATT_ORDER_MAX_PNSTR end if n_new = n_new + n_order end if @@ -1923,7 +2296,7 @@ contains ! Get the input string in scores(l) but if scatter-n or scatter-pn ! then strip off the n, and store it as an integer to be used later ! Peform the select case on this modified (number removed) string - score_name = tally_(i) % scores(l) + score_name = sarray(l) if (starts_with(score_name,'scatter-p')) then n_order_pos = scan(score_name,'0123456789') n_order = int(str_to_int( & @@ -1954,7 +2327,7 @@ contains score_name = "scatter-n" end if - select case (score_name) + select case (trim(score_name)) case ('flux') ! Prohibit user from tallying flux for an individual nuclide if (.not. (t % n_nuclide_bins == 1 .and. & @@ -2109,14 +2482,14 @@ contains t % score_bins(j) = MT else message = "Invalid MT on : " // & - trim(tally_(i) % scores(j)) + trim(sarray(j)) call fatal_error() end if else ! Specified score was not an integer message = "Unknown scoring function: " // & - trim(tally_(i) % scores(j)) + trim(sarray(j)) call fatal_error() end if @@ -2124,6 +2497,9 @@ contains end do t % n_score_bins = n_scores t % n_user_score_bins = n_words + + ! Deallocate temporary string array of scores + deallocate(sarray) else message = "No specified on tally " // trim(to_str(t % id)) & // "." @@ -2134,8 +2510,10 @@ contains ! SET TALLY ESTIMATOR ! Check if user specified estimator - if (len_trim(tally_(i) % estimator) > 0) then - select case(tally_(i) % estimator) + if (check_for_node(node_tal, "estimator")) then + temp_str = '' + call get_node_value(node_tal, "estimator", temp_str) + select case(trim(temp_str)) case ('analog') t % estimator = ESTIMATOR_ANALOG @@ -2152,7 +2530,7 @@ contains t % estimator = ESTIMATOR_TRACKLENGTH case default - message = "Invalid estimator '" // trim(tally_(i) % estimator) & + message = "Invalid estimator '" // trim(temp_str) & // "' on tally " // to_str(t % id) call fatal_error() end select @@ -2163,21 +2541,31 @@ contains end do READ_TALLIES + ! Close XML document + call close_xmldoc(doc) + end subroutine read_tallies_xml !=============================================================================== ! READ_PLOTS_XML reads data from a plots.xml file !=============================================================================== - subroutine read_plots_xml - - use xml_data_plots_t + subroutine read_plots_xml() integer i, j - integer n_cols, col_id + integer n_cols, col_id, n_comp, n_masks + integer, allocatable :: iarray(:) logical :: file_exists ! does plots.xml file exist? character(MAX_LINE_LEN) :: filename ! absolute path to plots.xml + character(MAX_LINE_LEN) :: temp_str type(ObjectPlot), pointer :: pl => null() + type(Node), pointer :: doc => null() + type(Node), pointer :: node_plot => null() + type(Node), pointer :: node_col => null() + type(Node), pointer :: node_mask => null() + type(NodeList), pointer :: node_plot_list => null() + type(NodeList), pointer :: node_col_list => null() + type(NodeList), pointer :: node_mask_list => null() ! Check if plots.xml exists filename = trim(path_input) // "plots.xml" @@ -2192,17 +2580,28 @@ contains call write_message(5) ! Parse plots.xml file - call read_xml_file_plots_t(filename) + call open_xmldoc(doc, filename) + + ! Get list pointer to XML + call get_node_list(doc, "plot", node_plot_list) ! Allocate plots array - n_plots = size(plot_) + n_plots = get_list_size(node_plot_list) allocate(plots(n_plots)) READ_PLOTS: do i = 1, n_plots pl => plots(i) + ! Get pointer to plot XML node + call get_list_item(node_plot_list, i, node_plot) + ! Copy data into plots - pl % id = plot_(i) % id + if (check_for_node(node_plot, "id")) then + call get_node_value(node_plot, "id", pl % id) + else + message = "Must specify plot id in plots XML file." + call fatal_error() + end if ! Check to make sure 'id' hasn't been used if (plot_dict % has_key(pl % id)) then @@ -2212,40 +2611,46 @@ contains end if ! Copy plot type - select case (plot_(i) % type) + temp_str = 'slice' + if (check_for_node(node_plot, "type")) & + call get_node_value(node_plot, "type", temp_str) + call lower_case(temp_str) + select case (trim(temp_str)) case ("slice") pl % type = PLOT_TYPE_SLICE case ("voxel") pl % type = PLOT_TYPE_VOXEL case default - message = "Unsupported plot type '" // trim(plot_(i) % type) & + message = "Unsupported plot type '" // trim(temp_str) & // "' in plot " // trim(to_str(pl % id)) call fatal_error() end select ! Set output file path + filename = "plot" + if (check_for_node(node_plot, "filename")) & + call get_node_value(node_plot, "filename", filename) select case (pl % type) case (PLOT_TYPE_SLICE) pl % path_plot = trim(path_input) // trim(to_str(pl % id)) // & - "_" // trim(plot_(i) % filename) // ".ppm" + "_" // trim(filename) // ".ppm" case (PLOT_TYPE_VOXEL) pl % path_plot = trim(path_input) // trim(to_str(pl % id)) // & - "_" // trim(plot_(i) % filename) // ".voxel" + "_" // trim(filename) // ".voxel" end select ! Copy plot pixel size if (pl % type == PLOT_TYPE_SLICE) then - if (size(plot_(i) % pixels) == 2) then - pl % pixels(1) = plot_(i) % pixels(1) - pl % pixels(2) = plot_(i) % pixels(2) + if (get_arraysize_integer(node_plot, "pixels") == 2) then + call get_node_array(node_plot, "pixels", pl % pixels(1:2)) else message = " must be length 2 in slice plot " // & trim(to_str(pl % id)) call fatal_error() end if else if (pl % type == PLOT_TYPE_VOXEL) then - if (size(plot_(i) % pixels) == 3) then - pl % pixels = plot_(i) % pixels + if (get_arraysize_integer(node_plot, "pixels") == 3) then + call get_node_array(node_plot, "pixels", pl % pixels(1:3)) else message = " must be length 3 in voxel plot " // & trim(to_str(pl % id)) @@ -2254,14 +2659,14 @@ contains end if ! Copy plot background color - if (associated(plot_(i) % background)) then + if (check_for_node(node_plot, "background")) then if (pl % type == PLOT_TYPE_VOXEL) then message = "Background color ignored in voxel plot " // & trim(to_str(pl % id)) call warning() end if - if (size(plot_(i) % background) == 3) then - pl % not_found % rgb = plot_(i) % background + if (get_arraysize_integer(node_plot, "background") == 3) then + call get_node_array(node_plot, "background", pl % not_found % rgb) else message = "Bad background RGB " & // "in plot " // trim(to_str(pl % id)) @@ -2273,7 +2678,11 @@ contains ! Copy plot basis if (pl % type == PLOT_TYPE_SLICE) then - select case (plot_(i) % basis) + temp_str = 'xy' + if (check_for_node(node_plot, "basis")) & + call get_node_value(node_plot, "basis", temp_str) + call lower_case(temp_str) + select case (trim(temp_str)) case ("xy") pl % basis = PLOT_BASIS_XY case ("xz") @@ -2281,15 +2690,15 @@ contains case ("yz") pl % basis = PLOT_BASIS_YZ case default - message = "Unsupported plot basis '" // plot_(i) % basis & + message = "Unsupported plot basis '" // trim(temp_str) & // "' in plot " // trim(to_str(pl % id)) call fatal_error() end select end if ! Copy plotting origin - if (size(plot_(i) % origin) == 3) then - pl % origin = plot_(i) % origin + if (get_arraysize_double(node_plot, "origin") == 3) then + call get_node_array(node_plot, "origin", pl % origin) else message = "Origin must be length 3 " & // "in plot " // trim(to_str(pl % id)) @@ -2298,17 +2707,16 @@ contains ! Copy plotting width if (pl % type == PLOT_TYPE_SLICE) then - if (size(plot_(i) % width) == 2) then - pl % width(1) = plot_(i) % width(1) - pl % width(2) = plot_(i) % width(2) + if (get_arraysize_double(node_plot, "width") == 2) then + call get_node_array(node_plot, "width", pl % width(1:2)) else message = " must be length 2 in slice plot " // & trim(to_str(pl % id)) call fatal_error() end if else if (pl % type == PLOT_TYPE_VOXEL) then - if (size(plot_(i) % width) == 3) then - pl % width = plot_(i) % width + if (get_arraysize_double(node_plot, "width") == 3) then + call get_node_array(node_plot, "width", pl % width(1:3)) else message = " must be length 3 in voxel plot " // & trim(to_str(pl % id)) @@ -2317,7 +2725,11 @@ contains end if ! Copy plot color type and initialize all colors randomly - select case (plot_(i) % color) + temp_str = "cell" + if (check_for_node(node_plot, "color")) & + call get_node_value(node_plot, "color", temp_str) + call lower_case(temp_str) + select case (trim(temp_str)) case ("cell") pl % color_by = PLOT_COLOR_CELLS @@ -2339,13 +2751,17 @@ contains end do case default - message = "Unsupported plot color type '" // plot_(i) % color & + message = "Unsupported plot color type '" // trim(temp_str) & // "' in plot " // trim(to_str(pl % id)) call fatal_error() end select + ! Get the number of nodes and get a list of them + call get_node_list(node_plot, "col_spec", node_col_list) + n_cols = get_list_size(node_col_list) + ! Copy user specified colors - if (associated(plot_(i) % col_spec_)) then + if (n_cols /= 0) then if (pl % type == PLOT_TYPE_VOXEL) then message = "Color specifications ignored in voxel plot " // & @@ -2353,21 +2769,33 @@ contains call warning() end if - n_cols = size(plot_(i) % col_spec_) do j = 1, n_cols - if (size(plot_(i) % col_spec_(j) % rgb) /= 3) then + + ! Get pointer to color spec XML node + call get_list_item(node_col_list, j, node_col) + + ! Check and make sure 3 values are specified for RGB + if (get_arraysize_double(node_col, "rgb") /= 3) then message = "Bad RGB " & // "in plot " // trim(to_str(pl % id)) call fatal_error() end if - col_id = plot_(i) % col_spec_(j) % id + ! Ensure that there is an id for this color specification + if (check_for_node(node_col, "id")) then + call get_node_value(node_col, "id", col_id) + else + message = "Must specify id for color specification in plot " // & + trim(to_str(pl % id)) + call fatal_error() + end if + ! Add RGB if (pl % color_by == PLOT_COLOR_CELLS) then if (cell_dict % has_key(col_id)) then col_id = cell_dict % get_key(col_id) - pl % colors(col_id) % rgb = plot_(i) % col_spec_(j) % rgb + call get_node_array(node_col, "rgb", pl % colors(col_id) % rgb) else message = "Could not find cell " // trim(to_str(col_id)) // & " specified in plot " // trim(to_str(pl % id)) @@ -2378,7 +2806,7 @@ contains if (material_dict % has_key(col_id)) then col_id = material_dict % get_key(col_id) - pl % colors(col_id) % rgb = plot_(i) % col_spec_(j) % rgb + call get_node_array(node_col, "rgb", pl % colors(col_id) % rgb) else message = "Could not find material " // trim(to_str(col_id)) // & " specified in plot " // trim(to_str(pl % id)) @@ -2390,7 +2818,9 @@ contains end if ! Deal with masks - if (associated(plot_(i) % mask_)) then + call get_node_list(node_plot, "mask", node_mask_list) + n_masks = get_list_size(node_mask_list) + if (n_masks /= 0) then if (pl % type == PLOT_TYPE_VOXEL) then message = "Mask ignored in voxel plot " // & @@ -2398,23 +2828,36 @@ contains call warning() end if - select case(size(plot_(i) % mask_)) + select case(n_masks) case default message = "Mutliple masks" // & " specified in plot " // trim(to_str(pl % id)) call fatal_error() - case (0) case (1) - + + ! Get pointer to mask + call get_list_item(node_mask_list, 1, node_mask) + + ! Determine how many components there are and allocate + n_comp = 0 + n_comp = get_arraysize_integer(node_mask, "components") + if (n_comp == 0) then + message = "Missing in mask of plot " // & + trim(to_str(pl % id)) + call fatal_error() + end if + allocate(iarray(n_comp)) + call get_node_array(node_mask, "components", iarray) + ! First we need to change the user-specified identifiers to indices ! in the cell and material arrays - do j=1,size(plot_(i) % mask_(1) % components) - col_id = plot_(i) % mask_(1) % components(j) + do j=1, n_comp + col_id = iarray(j) if (pl % color_by == PLOT_COLOR_CELLS) then if (cell_dict % has_key(col_id)) then - plot_(i) % mask_(1) % components(j) = cell_dict % get_key(col_id) + iarray(j) = cell_dict % get_key(col_id) else message = "Could not find cell " // trim(to_str(col_id)) // & " specified in the mask in plot " // trim(to_str(pl % id)) @@ -2424,7 +2867,7 @@ contains else if (pl % color_by == PLOT_COLOR_MATS) then if (material_dict % has_key(col_id)) then - plot_(i) % mask_(1) % components(j) = material_dict % get_key(col_id) + iarray(j) = material_dict % get_key(col_id) else message = "Could not find material " // trim(to_str(col_id)) // & " specified in the mask in plot " // trim(to_str(pl % id)) @@ -2436,10 +2879,18 @@ contains ! Alter colors based on mask information do j=1,size(pl % colors) - if (.not. any(j .eq. plot_(i) % mask_(1) % components)) then - pl % colors(j) % rgb = plot_(i) % mask_(1) % background + if (.not. any(j .eq. iarray)) then + if (check_for_node(node_mask, "background")) then + call get_node_array(node_mask, "background", pl % colors(j) % rgb) + else + message = "Missing in mask of plot " // & + trim(to_str(pl % id)) + call fatal_error() + end if end if end do + + deallocate(iarray) end select @@ -2450,6 +2901,9 @@ contains end do READ_PLOTS + ! Close plots XML file + call close_xmldoc(doc) + end subroutine read_plots_xml !=============================================================================== @@ -2459,15 +2913,17 @@ contains subroutine read_cross_sections_xml() - use xml_data_cross_sections_t - integer :: i ! loop index integer :: filetype ! default file type integer :: recl ! default record length integer :: entries ! default number of entries logical :: file_exists ! does cross_sections.xml exist? character(MAX_WORD_LEN) :: directory ! directory with cross sections + character(MAX_LINE_LEN) :: temp_str type(XsListing), pointer :: listing => null() + type(Node), pointer :: doc => null() + type(Node), pointer :: node_ace => null() + type(NodeList), pointer :: node_ace_list => null() ! Check if cross_sections.xml exists inquire(FILE=path_cross_sections, EXIST=file_exists) @@ -2481,18 +2937,12 @@ contains message = "Reading cross sections XML file..." call write_message(5) - ! Initialize variables that may go unused - directory_ = "" - filetype_ = "" - record_length_ = 0 - entries_ = 0 - ! Parse cross_sections.xml file - call read_xml_file_cross_sections_t(path_cross_sections) + call open_xmldoc(doc, path_cross_sections) - if (len_trim(directory_) > 0) then + if (check_for_node(doc, "directory")) then ! Copy directory information if present - directory = trim(directory_) + call get_node_value(doc, "directory", directory) else ! If no directory is listed in cross_sections.xml, by default select the ! directory in which the cross_sections.xml file resides @@ -2501,40 +2951,53 @@ contains end if ! determine whether binary/ascii - if (filetype_ == 'ascii') then + temp_str = '' + if (check_for_node(doc, "filetype")) & + call get_node_value(doc, "filetype", temp_str) + if (trim(temp_str) == 'ascii') then filetype = ASCII - elseif (filetype_ == 'binary') then + elseif (trim(temp_str) == 'binary') then filetype = BINARY - elseif (len_trim(filetype_) == 0) then + elseif (len_trim(temp_str) == 0) then filetype = ASCII else - message = "Unknown filetype in cross_sections.xml: " // trim(filetype_) + message = "Unknown filetype in cross_sections.xml: " // trim(temp_str) call fatal_error() end if ! copy default record length and entries for binary files - recl = record_length_ - entries = entries_ + if (filetype == BINARY) then + call get_node_value(doc, "record_length", recl) + call get_node_value(doc, "entries", entries) + end if + + ! Get node list of all + call get_node_list(doc, "ace_table", node_ace_list) + n_listings = get_list_size(node_ace_list) ! Allocate xs_listings array - if (.not. associated(ace_tables_)) then + if (n_listings == 0) then message = "No ACE table listings present in cross_sections.xml file!" call fatal_error() else - n_listings = size(ace_tables_) allocate(xs_listings(n_listings)) end if do i = 1, n_listings listing => xs_listings(i) + ! Get pointer to ace table XML node + call get_list_item(node_ace_list, i, node_ace) + ! copy a number of attributes - listing % name = trim(ace_tables_(i) % name) - listing % alias = trim(ace_tables_(i) % alias) - listing % zaid = ace_tables_(i) % zaid - listing % awr = ace_tables_(i) % awr - listing % kT = ace_tables_(i) % temperature - listing % location = ace_tables_(i) % location + call get_node_value(node_ace, "name", listing % name) + if (check_for_node(node_ace, "alias")) & + call get_node_value(node_ace, "alias", listing % alias) + call get_node_value(node_ace, "zaid", listing % zaid) + call get_node_value(node_ace, "awr", listing % awr) + if (check_for_node(node_ace, "temperature")) & + call get_node_value(node_ace, "temperature", listing % kT) + call get_node_value(node_ace, "location", listing % location) ! determine type of cross section if (ends_with(listing % name, 'c')) then @@ -2544,35 +3007,59 @@ contains end if ! set filetype, record length, and number of entries - listing % filetype = filetype - listing % recl = recl - listing % entries = entries + if (check_for_node(node_ace, "filetype")) then + temp_str = '' + call get_node_value(node_ace, "filetype", temp_str) + if (temp_str == 'ascii') then + listing % filetype = ASCII + else if (temp_str == 'binary') then + listing % filetype = BINARY + end if + else + listing % filetype = filetype + end if + + ! Set record length and entries for binary files + if (filetype == BINARY) then + listing % recl = recl + listing % entries = entries + end if ! determine metastable state - if (ace_tables_(i) % metastable == 0) then + if (.not.check_for_node(node_ace, "metastable")) then listing % metastable = .false. else listing % metastable = .true. end if ! determine path of cross section table - if (starts_with(ace_tables_(i) % path, '/')) then - listing % path = ace_tables_(i) % path + if (check_for_node(node_ace, "path")) then + call get_node_value(node_ace, "path", temp_str) + else + message = "Path missing for isotope " // listing % name + call fatal_error() + end if + + if (starts_with(temp_str, '/')) then + listing % path = trim(temp_str) else if (ends_with(directory,'/')) then - listing % path = trim(directory) // trim(ace_tables_(i) % path) + listing % path = trim(directory) // trim(temp_str) else - listing % path = trim(directory) // '/' // trim(ace_tables_(i) % path) + listing % path = trim(directory) // '/' // trim(temp_str) end if end if ! create dictionary entry for both name and alias call xs_listing_dict % add_key(listing % name, i) - if (listing % alias /= '') then + if (check_for_node(node_ace, "alias")) then call xs_listing_dict % add_key(listing % alias, i) end if end do + ! Close cross sections XML file + call close_xmldoc(doc) + end subroutine read_cross_sections_xml !=============================================================================== diff --git a/src/output.F90 b/src/output.F90 index b1290f057..ee0a8391c 100644 --- a/src/output.F90 +++ b/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-2014 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)) @@ -1241,7 +1277,7 @@ contains 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') "========" @@ -1271,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 @@ -1299,7 +1335,7 @@ 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 @@ -1309,7 +1345,7 @@ contains ! 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) + cmfd % k_cmfd(current_batch) select case(trim(cmfd_display)) case('entropy') write(UNIT=OUTPUT_UNIT, FMT='(3X, F8.5)', ADVANCE='NO') & @@ -1348,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" @@ -1386,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,*) @@ -1538,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 @@ -1572,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 @@ -1748,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)) @@ -1762,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)) @@ -1774,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)) @@ -1812,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 @@ -1863,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)) @@ -1880,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)) @@ -1897,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)) @@ -1914,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)) @@ -1931,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)) @@ -1948,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)) diff --git a/src/particle_header.F90 b/src/particle_header.F90 index 201de518e..e1c696ff1 100644 --- a/src/particle_header.F90 +++ b/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 diff --git a/src/physics.F90 b/src/physics.F90 index fb1f89194..8c98e0b79 100644 --- a/src/physics.F90 +++ b/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 @@ -1232,19 +1331,17 @@ contains ! SAMPLE ENERGY DISTRIBUTION IF THERE ARE MULTIPLE if (associated(edist % next)) then - if (edist % p_valid % n_regions > 0) then - p_valid = interpolate_tab1(edist % p_valid, E_in) + p_valid = interpolate_tab1(edist % p_valid, E_in) - if (prn() > p_valid) then - if (edist % law == 44 .or. edist % law == 61) then - call sample_energy(edist%next, E_in, E_out, mu_out) - elseif (edist % law == 66) then - call sample_energy(edist%next, E_in, E_out, A=A, Q=Q) - else - call sample_energy(edist%next, E_in, E_out) - end if - return + if (prn() > p_valid) then + if (edist % law == 44 .or. edist % law == 61) then + call sample_energy(edist%next, E_in, E_out, mu_out) + elseif (edist % law == 66) then + call sample_energy(edist%next, E_in, E_out, A=A, Q=Q) + else + call sample_energy(edist%next, E_in, E_out) end if + return end if end if @@ -1322,7 +1419,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 +1445,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 +1549,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 +1581,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 +1662,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 +1684,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 +1811,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 +1837,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 diff --git a/src/random_lcg.F90 b/src/random_lcg.F90 index 83ff6409f..e3a9885af 100644 --- a/src/random_lcg.F90 +++ b/src/random_lcg.F90 @@ -5,8 +5,13 @@ module random_lcg private save + ! Random number streams + integer, parameter :: N_STREAMS = 2 + integer, parameter :: STREAM_TRACKING = 1 + integer, parameter :: STREAM_TALLIES = 2 + integer(8) :: prn_seed0 ! original seed - integer(8) :: prn_seed ! current seed + integer(8) :: prn_seed(N_STREAMS) ! current seed integer(8) :: prn_mult ! multiplication factor, g integer(8) :: prn_add ! additive factor, c integer :: prn_bits ! number of bits, M @@ -14,6 +19,7 @@ module random_lcg integer(8) :: prn_mask ! 2^M - 1 integer(8) :: prn_stride ! stride between particles real(8) :: prn_norm ! 2^(-M) + integer :: stream ! current RNG stream !$omp threadprivate(prn_seed) @@ -21,6 +27,8 @@ module random_lcg public :: initialize_prng public :: set_particle_seed public :: prn_skip + public :: prn_set_stream + public :: STREAM_TRACKING, STREAM_TALLIES contains @@ -35,12 +43,12 @@ contains ! This algorithm uses bit-masking to find the next integer(8) value to be ! used to calculate the random number - prn_seed = iand(prn_mult*prn_seed + prn_add, prn_mask) + prn_seed(stream) = iand(prn_mult*prn_seed(stream) + prn_add, prn_mask) ! Once the integer is calculated, we just need to divide by 2**m, ! represented here as multiplying by a pre-calculated factor - pseudo_rn = prn_seed * prn_norm + pseudo_rn = prn_seed(stream) * prn_norm end function prn @@ -53,8 +61,13 @@ contains use global, only: seed + integer :: i + + stream = STREAM_TRACKING prn_seed0 = seed - prn_seed = prn_seed + do i = 1, N_STREAMS + prn_seed(i) = prn_seed0 + i - 1 + end do prn_mult = 2806196910506780709_8 prn_add = 1_8 prn_bits = 63 @@ -74,7 +87,11 @@ contains integer(8), intent(in) :: id - prn_seed = prn_skip_ahead(id*prn_stride, prn_seed0) + integer :: i + + do i = 1, N_STREAMS + prn_seed(i) = prn_skip_ahead(id*prn_stride, prn_seed0 + i - 1) + end do end subroutine set_particle_seed @@ -86,7 +103,7 @@ contains integer(8), intent(in) :: n ! number of seeds to skip - prn_seed = prn_skip_ahead(n, prn_seed) + prn_seed(stream) = prn_skip_ahead(n, prn_seed(stream)) end subroutine prn_skip @@ -151,4 +168,18 @@ contains end function prn_skip_ahead +!=============================================================================== +! PRN_SET_STREAM changes the random number stream. If random numbers are needed +! in routines not used directly for tracking (e.g. physics), this allows the +! numbers to be generated without affecting reproducibility of the physics. +!=============================================================================== + + subroutine prn_set_stream(i) + + integer, intent(in) :: i + + stream = i + + end subroutine prn_set_stream + end module random_lcg diff --git a/src/templates/cmfd.rnc b/src/relaxng/cmfd.rnc similarity index 100% rename from src/templates/cmfd.rnc rename to src/relaxng/cmfd.rnc diff --git a/src/templates/cross_sections.rnc b/src/relaxng/cross_sections.rnc similarity index 89% rename from src/templates/cross_sections.rnc rename to src/relaxng/cross_sections.rnc index e82bb986f..75c0ea29c 100644 --- a/src/templates/cross_sections.rnc +++ b/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" } }? & diff --git a/src/templates/geometry.rnc b/src/relaxng/geometry.rnc similarity index 100% rename from src/templates/geometry.rnc rename to src/relaxng/geometry.rnc diff --git a/src/templates/materials.rnc b/src/relaxng/materials.rnc similarity index 100% rename from src/templates/materials.rnc rename to src/relaxng/materials.rnc diff --git a/src/templates/plots.rnc b/src/relaxng/plots.rnc similarity index 100% rename from src/templates/plots.rnc rename to src/relaxng/plots.rnc diff --git a/src/templates/settings.rnc b/src/relaxng/settings.rnc similarity index 82% rename from src/templates/settings.rnc rename to src/relaxng/settings.rnc index cd4ed4beb..58699a2a2 100644 --- a/src/templates/settings.rnc +++ b/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" } }? & @@ -88,11 +92,22 @@ element settings { attribute batches { list { xsd:positiveInteger+ } }) | (element interval { xsd:positiveInteger } | attribute interval { xsd:positiveInteger }) - ) & - (element source_separate { xsd:boolean } | - attribute source_separate { xsd:boolean })? & - (element source_write { xsd:boolean } | - attribute source_write { xsd:boolean })? + ) + }? & + + element source_point { + ( + (element batches { list { xsd:positiveInteger+ } } | + attribute batches { list { xsd:positiveInteger+ } }) | + (element interval { xsd:positiveInteger } | + attribute interval { xsd:positiveInteger }) + )? & + (element separate { xsd:boolean } | + attribute separate { xsd:boolean })? & + (element write { xsd:boolean } | + attribute write { xsd:boolean })? & + (element overwrite_latest { xsd:boolean} | + attribute overwrite_latest {xsd:boolean})? }? & element survival_biasing { xsd:boolean }? & @@ -101,6 +116,8 @@ element settings { element trace { list { xsd:positiveInteger+ } }? & + element track { list { xsd:positiveInteger+ } }? & + element verbosity { xsd:positiveInteger }? & element uniform_fs{ diff --git a/src/templates/tallies.rnc b/src/relaxng/tallies.rnc similarity index 100% rename from src/templates/tallies.rnc rename to src/relaxng/tallies.rnc diff --git a/src/source.F90 b/src/source.F90 index 67d8ec801..2d3f74ec9 100644 --- a/src/source.F90 +++ b/src/source.F90 @@ -1,15 +1,17 @@ module source - use bank_header, only: Bank + use bank_header, only: Bank use constants - use error, only: fatal_error - use geometry_header, only: BASE_UNIVERSE + 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 - use output, only: write_message - use particle_header, only: Particle - use random_lcg, only: prn, set_particle_seed - use string, only: to_str + use math, only: maxwell_spectrum, watt_spectrum + use output, only: write_message + use output_interface, only: BinaryOutput + use particle_header, only: Particle + use random_lcg, only: prn, set_particle_seed + use string, only: to_str #ifdef MPI use mpi @@ -27,8 +29,9 @@ contains integer(8) :: i ! loop index over bank sites integer(8) :: id ! particle id - + integer(4) :: itmp ! temporary integer type(Bank), pointer :: src => null() ! source bank site + type(BinaryOutput) :: sp ! statepoint/source binary file message = "Initializing source particles..." call write_message(6) @@ -37,8 +40,26 @@ contains ! Read the source from a binary file instead of sampling from some ! assumed source distribution - message = 'This feature is currently disabled and will be added back in.' - call fatal_error() + message = 'Reading source file from ' // trim(path_source) // '...' + call write_message(6) + + ! Open the binary file + call sp % file_open(path_source, 'r', serial = .false.) + + ! Read the file type + call sp % read_data(itmp, "filetype") + + ! Check to make sure this is a source file + if (itmp /= FILETYPE_SOURCE) then + message = "Specified starting source file not a source file type." + call fatal_error() + end if + + ! Read in the source bank + call sp % read_source_bank() + + ! Close file + call sp % file_close() else ! Generation source sites from specified distribution in user input @@ -73,6 +94,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 +104,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 +191,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 +200,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 +223,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. & + ¤t_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 !=============================================================================== diff --git a/src/state_point.F90 b/src/state_point.F90 index 3793923bb..6884620e2 100644 --- a/src/state_point.F90 +++ b/src/state_point.F90 @@ -104,7 +104,7 @@ contains ! 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 % indices, "indices", 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", & @@ -230,6 +230,13 @@ contains end do TALLY_METADATA + ! Indicate where source bank is stored in statepoint + if (source_separate) then + call sp % write_data(0, "source_present") + else + call sp % write_data(1, "source_present") + end if + end if ! Check for the no-tally-reduction method @@ -280,14 +287,45 @@ contains end if - ! Check for eigenvalue calculation - if (run_mode == MODE_EIGENVALUE .and. source_write) then + end subroutine write_state_point - ! Check for writing source out separately +!=============================================================================== +! WRITE_SOURCE_POINT +!=============================================================================== + + subroutine write_source_point() + + type(BinaryOutput) :: sp + character(MAX_FILE_LEN) :: filename + + ! Check to write out source for a specified batch + if (sourcepoint_batch % contains(current_batch)) then + + ! Create or open up file if (source_separate) then - ! Set filename for source - filename = trim(path_output) // 'source.' // & + ! Set filename + filename = trim(path_output) // 'source.' // trim(to_str(current_batch)) +#ifdef HDF5 + filename = trim(filename) // '.h5' +#else + filename = trim(filename) // '.binary' +#endif + + ! Write message for new file creation + message = "Creating source file " // trim(filename) // "..." + call write_message(1) + + ! Create separate source file + call sp % file_create(filename, serial = .false.) + + ! Write file type + call sp % write_data(FILETYPE_SOURCE, "filetype") + + else + + ! Set filename for state point + filename = trim(path_output) // 'statepoint.' // & trim(to_str(current_batch)) #ifdef HDF5 filename = trim(filename) // '.h5' @@ -295,16 +333,7 @@ contains filename = trim(filename) // '.binary' #endif - ! Write message - message = "Creating source file " // trim(filename) // "..." - call write_message(1) - - ! Create source file - call sp % file_create(filename, serial = .false.) - - else - - ! Reopen state point file in parallel + ! Reopen statepoint file in parallel call sp % file_open(filename, 'w', serial = .false.) end if @@ -317,7 +346,36 @@ contains end if - end subroutine write_state_point + ! Also check to write source separately in overwritten file + if (source_latest) then + + ! Set filename + filename = trim(path_output) // 'source' +#ifdef HDF5 + filename = trim(filename) // '.h5' +#else + filename = trim(filename) // '.binary' +#endif + + ! Write message for new file creation + message = "Creating source file " // trim(filename) // "..." + call write_message(1) + + ! Always create this file because it will be overwritten + call sp % file_create(filename, serial = .false.) + + ! Write file type + call sp % write_data(FILETYPE_SOURCE, "filetype") + + ! Write out source + call sp % write_source_bank() + + ! Close file + call sp % file_close() + + end if + + end subroutine write_source_point !=============================================================================== ! WRITE_TALLY_RESULTS_NR @@ -459,13 +517,14 @@ contains subroutine load_state_point() - character(MAX_FILE_LEN) :: filename character(MAX_FILE_LEN) :: path_temp character(19) :: current_time integer :: i integer :: j + integer :: length(4) integer :: int_array(3) integer, allocatable :: temp_array(:) + logical :: source_present real(8) :: real_array(3) type(TallyObject), pointer :: t => null() @@ -539,13 +598,12 @@ contains ! 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 % indices, "indices", 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=(/cmfd % indices(4), cmfd % indices(1), & - cmfd % indices(2), cmfd % indices(3)/), & - group="cmfd") + 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", & @@ -671,6 +729,20 @@ contains end do TALLY_METADATA + ! Check for source in statepoint if needed + call sp % read_data(int_array(1), "source_present") + if (int_array(1) == 1) then + source_present = .true. + else + source_present = .false. + end if + + ! Check to make sure source bank is present + if (path_source_point == path_state_point .and. .not. source_present) then + message = "Source bank must be contained in statepoint restart file" + call fatal_error() + end if + ! Read tallies to master if (master) then @@ -711,26 +783,20 @@ contains if (run_mode == MODE_EIGENVALUE) then ! Check if source was written out separately - if (source_separate) then + if (.not. source_present) then ! Close statepoint file call sp % file_close() - ! Set filename for source - filename = trim(path_output) // 'source.' // & - trim(to_str(restart_batch)) -#ifdef HDF5 - filename = trim(filename) // '.h5' -#else - filename = trim(filename) // '.binary' -#endif - ! Write message - message = "Loading source file " // trim(filename) // "..." + message = "Loading source file " // trim(path_source_point) // "..." call write_message(1) ! Open source file - call sp % file_open(filename, 'r', serial = .false.) + call sp % file_open(path_source_point, 'r', serial = .false.) + + ! Read file type + call sp % read_data(int_array(1), "filetype") end if diff --git a/src/templates/cmfd_t.xml b/src/templates/cmfd_t.xml deleted file mode 100644 index 0e49e0e5a..000000000 --- a/src/templates/cmfd_t.xml +++ /dev/null @@ -1,34 +0,0 @@ - - diff --git a/src/templates/cross_sections_t.xml b/src/templates/cross_sections_t.xml deleted file mode 100644 index 0852b8504..000000000 --- a/src/templates/cross_sections_t.xml +++ /dev/null @@ -1,26 +0,0 @@ - - diff --git a/src/templates/geometry_t.xml b/src/templates/geometry_t.xml deleted file mode 100644 index 539a23f6b..000000000 --- a/src/templates/geometry_t.xml +++ /dev/null @@ -1,39 +0,0 @@ - - diff --git a/src/templates/materials_t.xml b/src/templates/materials_t.xml deleted file mode 100644 index 99950e035..000000000 --- a/src/templates/materials_t.xml +++ /dev/null @@ -1,44 +0,0 @@ - - diff --git a/src/templates/plots_t.xml b/src/templates/plots_t.xml deleted file mode 100644 index b3b86fc44..000000000 --- a/src/templates/plots_t.xml +++ /dev/null @@ -1,32 +0,0 @@ - - diff --git a/src/templates/settings_t.xml b/src/templates/settings_t.xml deleted file mode 100644 index 8f1cc7b00..000000000 --- a/src/templates/settings_t.xml +++ /dev/null @@ -1,69 +0,0 @@ - - diff --git a/src/templates/tallies_t.xml b/src/templates/tallies_t.xml deleted file mode 100644 index cf653968d..000000000 --- a/src/templates/tallies_t.xml +++ /dev/null @@ -1,37 +0,0 @@ - - diff --git a/src/track_output.F90 b/src/track_output.F90 new file mode 100644 index 000000000..79a280906 --- /dev/null +++ b/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 diff --git a/src/tracking.F90 b/src/tracking.F90 index 04175b243..c7ee31f0b 100644 --- a/src/tracking.F90 +++ b/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 diff --git a/src/utils/build_dependencies.py b/src/utils/build_dependencies.py index 19ac97885..2a42b0745 100755 --- a/src/utils/build_dependencies.py +++ b/src/utils/build_dependencies.py @@ -12,10 +12,8 @@ for src in glob.iglob('*.F90'): open(src, 'r').read()) for name in d: if name in ['mpi', 'hdf5', 'h5lt', 'petscsys', 'petscmat', 'petscksp', - 'petscsnes', 'petscvec']: + '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)) diff --git a/src/utils/convert_xsdir.py b/src/utils/convert_xsdir.py index fa29f46ec..edee1a66c 100755 --- a/src/utils/convert_xsdir.py +++ b/src/utils/convert_xsdir.py @@ -35,8 +35,12 @@ class Xsdir(object): words = line.split() if words: if words[0].lower().startswith('datapath'): - index = line.index('=') - self.datapath = line[index+1:].strip() + if '=' in words[0]: + index = line.index('=') + self.datapath = line[index+1:].strip() + else: + if len(line.strip()) > 8: + self.datapath = line[8:].strip() else: self.f.seek(0) @@ -71,7 +75,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 diff --git a/src/utils/plot_mesh_tally.py b/src/utils/plot_mesh_tally.py index 04b6b4592..fb5b8cb83 100755 --- a/src/utils/plot_mesh_tally.py +++ b/src/utils/plot_mesh_tally.py @@ -1,262 +1,279 @@ #!/usr/bin/env python2 -'''Python script to plot tally data generated by OpenMC.''' +"""Python script to plot tally data generated by OpenMC.""" +import os import sys -from statepoint import * -# Color intensity dependent on individual score? - -from PyQt4.QtCore import * -from PyQt4.QtGui import * -import matplotlib.pyplot as plt +from matplotlib.backends.backend_tkagg import FigureCanvasTkAgg +from matplotlib.backends.backend_tkagg import NavigationToolbar2TkAgg from matplotlib.figure import Figure -from matplotlib.backends.backend_qt4agg import FigureCanvasQTAgg as FigureCanvas -from matplotlib.backends.backend_qt4agg import NavigationToolbar2QTAgg as NavigationToolbar +import matplotlib.pyplot as plt import numpy as np -class AppForm(QMainWindow): - def __init__(self, parent=None): - QMainWindow.__init__(self, parent) +from statepoint import * + +if sys.version_info[0] < 3: + import Tkinter as tk +else: + import tkinter as tk +import tkFileDialog +import tkFont +import tkMessageBox +import ttk + + +class MeshPlotter(tk.Frame): + def __init__(self, parent, filename): + tk.Frame.__init__(self, parent) + + self.labels = {'cell': 'Cell:', 'cellborn': 'Cell born:', + 'surface': 'Surface:', 'material': 'Material:', + 'universe': 'Universe:', 'energyin': 'Energy in:', + 'energyout': 'Energy out:'} + + self.filterBoxes = {} # 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.get_file_data(filename) + + # Set up top-level window + top = self.winfo_toplevel() + top.title('Mesh Tally Plotter: ' + filename) + top.rowconfigure(0, weight=1) + top.columnconfigure(0, weight=1) + self.grid(sticky=tk.W+tk.N) + + # Create widgets and draw to screen + self.create_widgets() + self.update() + + def create_widgets(self): + figureFrame = tk.Frame(self) + figureFrame.grid(row=0, column=0) + + # Create the Figure and Canvas 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) - + self.fig = Figure((5.0, 5.0), dpi=self.dpi) + self.canvas = FigureCanvasTkAgg(self.fig, master=figureFrame) + self.canvas.get_tk_widget().pack(side=tk.TOP, fill=tk.BOTH, expand=1) + # Create the navigation toolbar, tied to the canvas - self.mpl_toolbar = NavigationToolbar(self.canvas, self.main_frame) + self.mpl_toolbar = NavigationToolbar2TkAgg(self.canvas, figureFrame) + self.mpl_toolbar.update() + self.canvas._tkcanvas.pack(side=tk.TOP, fill=tk.BOTH, expand=1) - # Grid layout at bottom - self.grid = QGridLayout() + # Create frame for comboboxes + self.selectFrame = tk.Frame(self) + self.selectFrame.grid(row=1, column=0, sticky=tk.W+tk.E) - # 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) + # Tally selection + labelTally = tk.Label(self.selectFrame, text='Tally:') + labelTally.grid(row=0, column=0, sticky=tk.W) + self.tallyBox = ttk.Combobox(self.selectFrame, state='readonly') + self.tallyBox['values'] = [self.datafile.tallies[i].id + for i in self.meshTallies] + self.tallyBox.current(0) + self.tallyBox.grid(row=0, column=1, sticky=tk.W+tk.E) + self.tallyBox.bind('<>', self.update) - # 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) + # Planar basis selection + labelBasis = tk.Label(self.selectFrame, text='Basis:') + labelBasis.grid(row=1, column=0, sticky=tk.W) + self.basisBox = ttk.Combobox(self.selectFrame, state='readonly') + self.basisBox['values'] = ('xy', 'yz', 'xz') + self.basisBox.current(0) + self.basisBox.grid(row=1, column=1, sticky=tk.W+tk.E) + self.basisBox.bind('<>', self.update) - # Planar basis - label_basis = QLabel("Basis:") - self.basis = QComboBox() - self.basis.addItems(['xy', 'yz', 'xz']) + # Axial level + labelAxial = tk.Label(self.selectFrame, text='Axial level:') + labelAxial.grid(row=2, column=0, sticky=tk.W) + self.axialBox = ttk.Combobox(self.selectFrame, state='readonly') + self.axialBox.grid(row=2, column=1, sticky=tk.W+tk.E) + self.axialBox.bind('<>', self.redraw) - # 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) + # Option for mean/uncertainty + labelMean = tk.Label(self.selectFrame, text='Mean/Uncertainty:') + labelMean.grid(row=3, column=0, sticky=tk.W) + self.meanBox = ttk.Combobox(self.selectFrame, state='readonly') + self.meanBox['values'] = ('Mean', 'Absolute uncertainty', + 'Relative uncertainty') + self.meanBox.current(0) + self.meanBox.grid(row=3, column=1, sticky=tk.W+tk.E) + self.meanBox.bind('<>', self.update) - # 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) - + # Scores + labelScore = tk.Label(self.selectFrame, text='Score:') + labelScore.grid(row=4, column=0, sticky=tk.W) + self.scoreBox = ttk.Combobox(self.selectFrame, state='readonly') + self.scoreBox.grid(row=4, column=1, sticky=tk.W+tk.E) + self.scoreBox.bind('<>', self.redraw) - self.label_filters = QLabel("Filter options:") + # Filter label + font = tkFont.Font(weight='bold') + labelFilters = tk.Label(self.selectFrame, text='Filters:', font=font) + labelFilters.grid(row=5, column=0, sticky=tk.W) - # Labels for all possible filters - self.labels = {'cell': 'Cell: ', 'cellborn': 'Cell born: ', - 'surface': 'Surface: ', 'material': 'Material', - 'universe': 'Universe: ', 'energyin': 'Energy in: ', - 'energyout': 'Energy out: '} + def update(self, event=None): + if not event: + widget = None + else: + widget = event.widget - # Empty reusable labels - self.qlabels = {} - for j in range(8): - self.nextLabel = QLabel - self.qlabels[j] = self.nextLabel + tally_id = self.meshTallies[self.tallyBox.current()] + selectedTally = self.datafile.tallies[tally_id] - # 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 + # Get mesh for selected tally + self.mesh = self.datafile.meshes[ + selectedTally.filters['mesh'].bins[0] - 1] - # 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) + # Get mesh dimensions + self.nx, self.ny, self.nz = self.mesh.dimension - # 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) + # Repopulate comboboxes baesd on current basis selection + text = self.basisBox['values'][self.basisBox.current()] + if text == 'xy': + self.axialBox['values'] = [str(i+1) for i in range(self.nz)] + elif text == 'yz': + self.axialBox['values'] = [str(i+1) for i in range(self.nx)] + else: + self.axialBox['values'] = [str(i+1) for i in range(self.ny)] + self.axialBox.current(0) - self._update() - self.populate_boxes() - self.on_draw() + # If update() was called by a change in the basis combobox, we don't + # need to repopulate the filters + if widget == self.basisBox: + self.redraw() + return - def get_file_data(self): - # Get data file name from "open file" browser - filename = QFileDialog.getOpenFileName(self, 'Select statepoint file', '.') + # Update scores + self.scoreBox['values'] = selectedTally.scores + self.scoreBox.current(0) - # Create StatePoint object and read in data - self.datafile = StatePoint(str(filename)) - self.datafile.read_results() - self.datafile.generate_stdev() + # Remove any filter labels/comboboxes that exist + for row in range(6, self.selectFrame.grid_size()[1]): + for w in self.selectFrame.grid_slaves(row=row): + w.grid_forget() + w.destroy() - self.setWindowTitle('Core Map Tool : ' + str(self.datafile.path)) + # create a label/combobox for each filter in selected tally + count = 0 + for filterType in selectedTally.filters: + if filterType == 'mesh': + continue + count += 1 - # Set maximum colorbar value by maximum tally data value - self.maxvalue = self.datafile.tallies[0].results.max() + # Create label and combobox for this filter + label = tk.Label(self.selectFrame, text=self.labels[filterType]) + label.grid(row=count+6, column=0, sticky=tk.W) + combobox = ttk.Combobox(self.selectFrame, state='readonly') + self.filterBoxes[filterType] = combobox - self.labelList = [] + # Set combobox items + f = selectedTally.filters[filterType] + if filterType in ['energyin', 'energyout']: + combobox['values'] = ['{0} to {1}'.format(*f.bins[i:i+2]) + for i in range(f.length)] + else: + combobox['values'] = [str(i) for i in f.bins] - # Read mesh dimensions -# for mesh in self.datafile.meshes: -# self.nx, self.ny, self.nz = mesh.dimension + combobox.current(0) + combobox.grid(row=count+6, column=1, sticky=tk.W+tk.E) + combobox.bind('<>', self.redraw) - # Read filter types from statepoint file - 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) + # If There are no filters, leave a 'None available' message + if count == 0: + count += 1 + label = tk.Label(self.selectFrame, text="None Available") + label.grid(row=count+6, column=0, sticky=tk.W) - # 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 + self.redraw() - def on_draw(self): - """ Redraws the figure - """ + def redraw(self, event=None): + basis = self.basisBox.current() + 1 + axial_level = self.axialBox.current() + 1 + is_mean = self.meanBox.current() -# print 'Calling on_draw...' - # Get selected basis, axial_level and stage - basis = self.basis.currentIndex() + 1 - axial_level = self.axial_level.currentIndex() + 1 - is_mean = self.mean.currentIndex() + # Get selected tally + tally_id = self.meshTallies[self.tallyBox.current()] + selectedTally = self.datafile.tallies[tally_id] # Create spec_list spec_list = [] - for tally in self.datafile.tallies[self.tally.currentIndex()].filters.values(): - if tally.type == 'mesh': + for f in selectedTally.filters.values(): + if f.type == 'mesh': continue - index = self.boxes[tally.type].currentIndex() - spec_list.append((tally.type, index)) - + index = self.filterBoxes[f.type].current() + spec_list.append((f.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': + + text = self.basisBox['values'][self.basisBox.current()] + if text == '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))], - self.scoreBox.currentIndex())[score_loc] - # Calculate relative uncertainty from absolute, if - # requested + matrix[i, j] = self.datafile.get_value(tally_id, + spec_list + [('mesh', (i + 1, j + 1, axial_level))], + self.scoreBox.current())[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))], - self.scoreBox.currentIndex())[0] + mean_val = self.datafile.get_value(tally_id, + spec_list + [('mesh', (i + 1, j + 1, axial_level))], + self.scoreBox.current())[0] if mean_val > 0.0: - matrix[i,j] = matrix[i,j] / mean_val + matrix[i, j] = matrix[i, j] / mean_val else: - matrix[i,j] = 0.0 - - elif self.basis.currentText() == 'yz': + matrix[i, j] = 0.0 + + elif text == '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))], - self.scoreBox.currentIndex())[score_loc] - # Calculate relative uncertainty from absolute, if - # requested + matrix[i, j] = self.datafile.get_value(tally_id, + spec_list + [('mesh', (axial_level, i + 1, j + 1))], + self.scoreBox.current())[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))], - self.scoreBox.currentIndex())[0] + mean_val = self.datafile.get_value(tally_id, + spec_list + [('mesh', (axial_level, i + 1, j + 1))], + self.scoreBox.current())[0] if mean_val > 0.0: - matrix[i,j] = matrix[i,j] / mean_val + matrix[i, j] = matrix[i, j] / mean_val else: - matrix[i,j] = 0.0 - + 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))], - self.scoreBox.currentIndex())[score_loc] - # Calculate relative uncertainty from absolute, if - # requested + matrix[i, j] = self.datafile.get_value(tally_id, + spec_list + [('mesh', (i + 1, axial_level, j + 1))], + self.scoreBox.current())[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))], - self.scoreBox.currentIndex())[0] + mean_val = self.datafile.get_value(tally_id, + spec_list + [('mesh', (i + 1, axial_level, j + 1))], + self.scoreBox.current())[0] if mean_val > 0.0: - matrix[i,j] = matrix[i,j] / mean_val + matrix[i, j] = matrix[i, j] / mean_val else: - matrix[i,j] = 0.0 - -# print spec_list + matrix[i, j] = 0.0 # Clear the figure self.fig.clear() # 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='none', origin='lower') self.fig.colorbar(cax) self.axes.set_xticks([]) @@ -266,95 +283,43 @@ class AppForm(QMainWindow): # Draw canvas self.canvas.draw() - def _update(self): - '''Updates widget to display new relevant comboboxes and figure data - ''' -# print 'Calling _update...' + def get_file_data(self, filename): + # Create StatePoint object and read in data + self.datafile = StatePoint(filename) + self.datafile.read_results() + self.datafile.generate_stdev() - self.mesh = self.datafile.meshes[ - self.datafile.tallies[ - self.tally.currentIndex()].filters['mesh'].bins[0] - 1] + # Find which tallies are mesh tallies + self.meshTallies = [] + for itally, tally in enumerate(self.datafile.tallies): + if 'mesh' in tally.filters: + self.meshTallies.append(itally) - self.nx, self.ny, self.nz = self.mesh.dimension - - # Clear axial level combobox - self.axial_level.clear() - - # Repopulate axial level combobox based on current basis selection - if (self.basis.currentText() == 'xy'): - self.axial_level.addItems([str(i+1) for i in range(self.nz)]) - elif (self.basis.currentText() == 'yz'): - self.axial_level.addItems([str(i+1) for i in range(self.nx)]) - else: - 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() -# print self.maxvalue - - # Clear and hide old filter labels - for item in self.labelList: - item.clear() - - # Clear and hide old filter boxes - for j in self.labels: - self.boxes[j].clear() - self.boxes[j].setParent(None) - - self.update() - - def populate_boxes(self): -# print 'Calling populate_boxes...' - - n = 5 - labels = {'cell': 'Cell : ', - 'cellborn': 'Cell born: ', - 'surface': 'Surface: ', - 'material': 'Material: ', - 'universe': 'Universe: '} - - # 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] - if element == 'mesh': - continue - - label = QLabel(self.labels[element]) - self.labelList.append(label) - combobox = self.boxes[element] - self.grid.addWidget(label, n, 0) - self.grid.addWidget(combobox, n, 1) - n += 1 - -# print element - if element in ['cell', 'cellborn', 'surface', 'material', 'universe']: - combobox.addItems([str(i) for i in nextFilter.bins]) -# for i in nextFilter.bins: -# print i - - elif element == 'energyin' or element == 'energyout': - for i in range(nextFilter.length): - text = (str(nextFilter.bins[i]) + ' to ' + - str(nextFilter.bins[i+1])) - combobox.addItem(text) - - self.scoreBox.clear() - for item in self.tally_scores[self.tally.currentIndex()]: - self.scoreBox.addItem(str(item)) - self.grid.addWidget(self.score_label, n, 0) - self.grid.addWidget(self.scoreBox, n, 1) + if not self.meshTallies: + tkMessageBox.showerror("Invalid StatePoint File", + "File does not contain mesh tallies!") + sys.exit(1) +if __name__ == '__main__': + # Hide root window + root = tk.Tk() + root.withdraw() -def main(): - app = QApplication(sys.argv) - form = AppForm() - form.show() - app.exec_() + # If no filename given as command-line argument, open file dialog + if len(sys.argv) < 2: + filename = tkFileDialog.askopenfilename(title='Select statepoint file', + initialdir='.') + else: + filename = sys.argv[1] + if filename: + # Check to make sure file exists + if not os.path.isfile(filename): + tkMessageBox.showerror("File not found", + "Could not find regular file: " + filename) + sys.exit(1) -if __name__ == "__main__": - main() + app = MeshPlotter(root, filename) + root.deiconify() + root.mainloop() diff --git a/src/utils/statepoint.py b/src/utils/statepoint.py index ec9d9edf7..9613421e0 100644 --- a/src/utils/statepoint.py +++ b/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,7 +151,7 @@ class StatePoint(object): # Read statepoint revision self.revision = self._get_int(path='revision')[0] - if self.revision != 10: + if self.revision != 11: raise Exception('Statepoint Revision is not consistent.') # Read OpenMC version @@ -196,7 +195,7 @@ class StatePoint(object): # 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.cmfd_indices = self._get_int(4, path='cmfd/indices') 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), @@ -276,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 @@ -299,6 +298,13 @@ class StatePoint(object): f.stride = stride stride *= f.length + # Source bank present + source_present = self._get_int(path='source_present')[0] + if source_present == 1: + self.source_present = True + else: + self.source_present = False + # Set flag indicating metadata has already been read self._metadata = True @@ -343,6 +349,11 @@ class StatePoint(object): if not self._results: self.read_results() + # Check if source bank is in statepoint + if not self.source_present: + print('Source not in statepoint file.') + return + # For HDF5 state points, copy entire bank if self._hdf5: source_sites = self._f['source_bank'].value @@ -379,7 +390,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 @@ -387,14 +398,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: @@ -402,14 +413,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. @@ -458,7 +469,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. @@ -531,7 +542,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 @@ -544,14 +555,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])}) @@ -576,7 +587,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] diff --git a/src/utils/track.py b/src/utils/track.py new file mode 100755 index 000000000..a2dca34e1 --- /dev/null +++ b/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() diff --git a/src/xml-fortran/read_from_buffer.inc b/src/xml-fortran/read_from_buffer.inc deleted file mode 100644 index 0cb6ee959..000000000 --- a/src/xml-fortran/read_from_buffer.inc +++ /dev/null @@ -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 - diff --git a/src/xml-fortran/read_xml_array.inc b/src/xml-fortran/read_xml_array.inc deleted file mode 100644 index a88086e74..000000000 --- a/src/xml-fortran/read_xml_array.inc +++ /dev/null @@ -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 diff --git a/src/xml-fortran/read_xml_primitives.f90 b/src/xml-fortran/read_xml_primitives.f90 deleted file mode 100644 index 1fb63d57b..000000000 --- a/src/xml-fortran/read_xml_primitives.f90 +++ /dev/null @@ -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 diff --git a/src/xml-fortran/read_xml_scalar.inc b/src/xml-fortran/read_xml_scalar.inc deleted file mode 100644 index b28ba3c7a..000000000 --- a/src/xml-fortran/read_xml_scalar.inc +++ /dev/null @@ -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 diff --git a/src/xml-fortran/read_xml_word.inc b/src/xml-fortran/read_xml_word.inc deleted file mode 100644 index 4c1848dcf..000000000 --- a/src/xml-fortran/read_xml_word.inc +++ /dev/null @@ -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 diff --git a/src/xml-fortran/write_xml_primitives.f90 b/src/xml-fortran/write_xml_primitives.f90 deleted file mode 100644 index 7d2cf90ba..000000000 --- a/src/xml-fortran/write_xml_primitives.f90 +++ /dev/null @@ -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, '' - -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)), '' - -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)), '' - -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), '' - -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' - else - write( info%lun, '(8a)' ) indentation(1:min(indent,100)), & - '<', trim(tag), '>false' - 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)), & - '' - -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)), & - '' - -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)), & - '' - -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)), & - '' - -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)), & - '' - -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)), & - '' - -end subroutine write_to_xml_line_array - -end module write_xml_primitives diff --git a/src/xml-fortran/xml-fortran.LICENSE b/src/xml-fortran/xml-fortran.LICENSE deleted file mode 100644 index cd0ba2912..000000000 --- a/src/xml-fortran/xml-fortran.LICENSE +++ /dev/null @@ -1,37 +0,0 @@ -Note: The official xml-fortran repository on sourceforge - 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. diff --git a/src/xml-fortran/xmlparse.f90 b/src/xml-fortran/xmlparse.f90 deleted file mode 100644 index eb522078a..000000000 --- a/src/xml-fortran/xmlparse.f90 +++ /dev/null @@ -1,1076 +0,0 @@ -!=============================================================================== -! XMLPARSE - Simple, limited XML parser in Fortran -! -! General information: -! The module reads XML files by: -! - Identifying the tag and all attributes and data belonging -! to the tag. -! - Returning to the calling subprogram to let it take care of -! the tag, attributes and data. -! - If the tag is actually an ending tag, then this is flagged -! too. -! - Handling all the data is left to the calling subprogram, -! the module merely facilitates in the parsing. -! -! Note: -! The module in its current version has a number of limitations: -! - It does not handle escape sequences (like >. to signify -! a ">" sign) -! - It does not handle tags with attributes that are spread -! over more than one line -! - The maximum length of a line is 1000 characters -! - It may report too many lines of data (empty lines) -! - No DOM support nor support for an object tree -! - It is probably not very robust in detecting malformed XML files -! -! Some questions: -! - What to do with leading blanks? -! -! Update - several ideas: -! - Introduce at least two options (via xml_options): -! - ignore_whitespace - remove leading blanks and leading and trailing -! empty lines from the PCDATA -! - no_data_truncation - consider truncation of data (more -! attributes or lines of character data than -! can be stored) a read error -! - Introduce convenience functions and subroutines: -! - xml_ok() - all is well, reading can continue -! - xml_data_trunc() - was there truncation of the data? -! - xml_find_attrib() - find an attribute by name -! -! Further ideas: -! - simple checking via a table: parent, tag, id, min, max -!=============================================================================== - -module xmlparse - - implicit none - - integer, parameter :: XML_BUFFER_LENGTH = 10000 - -!=============================================================================== -! XML_PARSE defines the data type that holds the parser information -!=============================================================================== - - type XML_PARSE - integer :: lun ! LU-number of the XML-file - integer :: level ! Indentation level (output) - integer :: lineno ! Line in file - logical :: ignore_whitespace ! Ignore leading blanks etc. - logical :: no_data_truncation ! Do not allow data truncation - logical :: too_many_attribs ! More attributes than could be stored? - logical :: too_many_data ! More lines of data than could be stored? - logical :: eof ! End of file? - logical :: error ! Invalid XML file or other error? - character(len=XML_BUFFER_LENGTH) :: line ! Buffer - end type XML_PARSE - -!=============================================================================== -! Global options -!=============================================================================== - - integer, parameter :: XML_STDOUT = -1 - integer, private :: report_lun_ = XML_STDOUT - logical, private :: report_errors_ = .false. - logical, private :: report_details_ = .false. - -!=============================================================================== -! Global data (the ampersand must come first) -!=============================================================================== - - character(len=10), dimension(2,3), save, private :: entities = & - reshape( (/ '& ', '&', & - '> ', '> ', & - '< ', '< ' /), (/2,3/) ) - -!=============================================================================== -! Auxiliary routines - private -!=============================================================================== - - private :: xml_compress_ - private :: xml_put_open_tag_ - private :: xml_put_element_ - private :: xml_put_close_tag_ - private :: xml_replace_entities_ - private :: xml_remove_tabs_ - -!=============================================================================== -! Interfaces to reporting routines -!=============================================================================== - - private :: xml_report_details_int_ - private :: xml_report_details_string_ - private :: xml_report_errors_int_ - private :: xml_report_errors_string_ - - interface xml_report_details - module procedure xml_report_details_int_ - module procedure xml_report_details_string_ - end interface - interface xml_report_errors - module procedure xml_report_errors_int_ - module procedure xml_report_errors_string_ - module procedure xml_report_errors_extern_ - end interface - -contains - -!=============================================================================== -! XML_REPORT_DETAILS_INT_ -- -! Routine to write a text with an integer value -! Arguments: -! text Text to be written -! int Integer value to be added -!=============================================================================== - -subroutine xml_report_details_int_( text, int ) - character(len=*), intent(in) :: text - integer, intent(in) :: int - - if ( report_details_ ) then - if ( report_lun_ == XML_STDOUT ) then - write(*,*) trim(text), int - else - write(report_lun_,*) trim(text), int - endif - endif -end subroutine xml_report_details_int_ - -!=============================================================================== -! XML_REPORT_DETAILS_STRING_ -- -! Routine to write a text with a string value -! Arguments: -! text Text to be written -! string String to be added -!=============================================================================== - -subroutine xml_report_details_string_( text, string ) - character(len=*), intent(in) :: text - character(len=*), intent(in) :: string - - if ( report_details_ ) then - if ( report_lun_ == XML_STDOUT ) then - write(*,*) trim(text), ' ', trim(string) - else - write(report_lun_,*) trim(text), ' ', trim(string) - endif - endif -end subroutine xml_report_details_string_ - -!=============================================================================== -! XML_REPORT_ERRORS_INT_ -- -! Routine to write an error message text with an integer value -! Arguments: -! text Text to be written -! int Integer value to be added -! lineno Line number in the file -!=============================================================================== - -subroutine xml_report_errors_int_( text, int, lineno ) - character(len=*), intent(in) :: text - integer, intent(in) :: int - integer, optional, intent(in) :: lineno - - if ( report_errors_ .or. report_details_ ) then - if ( report_lun_ == XML_STDOUT ) then - write(*,*) trim(text), int - if ( present(lineno) ) then - write(*,*) ' At or near line', lineno - endif - else - write(report_lun_,*) trim(text), int - if ( present(lineno) ) then - write(report_lun_,*) ' At or near line', lineno - endif - endif - endif -end subroutine xml_report_errors_int_ - -!=============================================================================== -! XML_REPORT_ERRORS_STRING_ -- -! Routine to write an error message text with a string value -! Arguments: -! text Text to be written -! string String to be added -! lineno Line number in the file -!=============================================================================== - -subroutine xml_report_errors_string_( text, string, lineno ) - character(len=*), intent(in) :: text - character(len=*), intent(in) :: string - integer, optional, intent(in) :: lineno - - if ( report_errors_ .or. report_details_ ) then - if ( report_lun_ == XML_STDOUT ) then - write(*,*) trim(text), ' ', trim(string) - if ( present(lineno) ) then - write(*,*) ' At or near line', lineno - endif - else - write(report_lun_,*) trim(text), ' ', trim(string) - if ( present(lineno) ) then - write(report_lun_,*) ' At or near line', lineno - endif - endif - endif -end subroutine xml_report_errors_string_ - -!=============================================================================== -! XML_REPORT_ERRORS_EXTERN_ -- -! Routine to write an error message text with a string value -! Arguments: -! info Structure holding information on the XML-file -! text Text to be written -! Note: -! This routine is meant for use by routines outside -! this module -!=============================================================================== - -subroutine xml_report_errors_extern_( info, text ) - type(XML_PARSE), intent(in) :: info - character(len=*), intent(in) :: text - - if ( report_errors_ .or. report_details_ ) then - if ( report_lun_ == XML_STDOUT ) then - write(*,*) trim(text), ' - at or near line', info%lineno - else - write(report_lun_,*) trim(text), ' - at or near line', info%lineno - endif - end if - -end subroutine xml_report_errors_extern_ - -!=============================================================================== -! XML_OPEN -- -! Routine to open an XML file for reading or writing -! Arguments: -! info Structure holding information on the XML-file -! fname Name of the file -! mustread The file will be read (.true.) or written (.false.) -!=============================================================================== - -subroutine xml_open( info, fname, mustread ) - character(len=*), intent(in) :: fname - logical, intent(in) :: mustread - type(XML_PARSE), intent(out) :: info - - integer :: i - integer :: k - integer :: kend - integer :: ierr - logical :: opend - logical :: exists - - info%lun = 10 - info%ignore_whitespace = .false. - info%no_data_truncation = .false. - info%too_many_attribs = .false. - info%too_many_data = .false. - info%eof = .false. - info%error = .false. - info%level = -1 - info%lineno = 0 - - do i = 10,99 - inquire( unit = i, opened = opend ) - if ( .not. opend ) then - info%lun = i - inquire( file = fname, exist = exists ) - if ( .not. exists .and. mustread ) then - call xml_report_errors( 'XML_OPEN: file does not exist:', trim(fname)) - info%lun = -1 - info%error = .true. - else - open( unit = info%lun, file = fname ) - call xml_report_details( 'XML_OPEN: opened file ', trim(fname) ) - call xml_report_details( 'at LU-number: ', info%lun ) - endif - exit - endif - enddo - if ( .not. info%error .and. mustread ) then - k = 1 - do while ( k >= 1 ) - read( info%lun, '(a)', iostat = ierr ) info%line - - ! If we encounter a blank line, skip it and read the next line - if (len_trim(info%line) == 0) cycle - - call xml_remove_tabs_(info%line) - if ( ierr == 0 ) then - info%line = adjustl( info%line ) - k = index( info%line, ' appears on a single line! - ! - if ( k >= 1 ) then - kend = index( info%line, '?>' ) - if ( kend <= 0 ) then - call xml_report_errors( 'XML_OPEN: error reading file with LU-number: ', info%lun ) - call xml_report_errors( 'Line starting with ""', ' ' ) - info%error = .true. - exit - endif - endif - else - call xml_report_errors( 'XML_OPEN: error reading file with LU-number: ', info%lun ) - call xml_report_errors( 'Possibly no line starting with "' - endif -end subroutine xml_open - -!=============================================================================== -! XML_CLOSE -- -! Routine to close an XML file -! Arguments: -! info Structure holding information on the XML-file -!=============================================================================== - -subroutine xml_close( info ) - type(XML_PARSE), intent(inout) :: info - - close( info%lun ) - - ! - ! Only clean up the LU-number, so that the calling program - ! can examine the last condition - ! - call xml_report_details( 'XML_CLOSE: Closing file with LU-number ', info%lun ) - info%lun = -1 -end subroutine xml_close - -!=============================================================================== -! XML_GET -- -! Routine to get the next bit of information from an XML file -! Arguments: -! info Structure holding information on the XML-file -! tag Tag that was encountered -! endtag Whether the end of the element was encountered -! attribs List of attribute-value pairs -! no_attribs Number of pairs in the list -! data Lines of character data found -! no_data Number of lines of character data -!=============================================================================== - -subroutine xml_get( info, tag, endtag, attribs, no_attribs, & - data, no_data ) - type(XML_PARSE), intent(inout) :: info - character(len=*), intent(out) :: tag - logical, intent(out) :: endtag - character(len=*), intent(out), dimension(:,:) :: attribs - integer, intent(out) :: no_attribs - character(len=*), intent(out), dimension(:) :: data - integer, intent(out) :: no_data - - integer :: kspace - integer :: kend - integer :: kcend - integer :: keq - integer :: kfirst - integer :: ksecond - integer :: idxat - integer :: idxdat - integer :: ierr - logical :: close_bracket - logical :: comment_tag - character(len=XML_BUFFER_LENGTH) :: nextline - - ! - ! Initialise the output - ! - endtag = .false. - no_attribs = 0 - no_data = 0 - - info%too_many_attribs = .false. - info%too_many_data = .false. - - if ( info%lun < 0 ) then - call xml_report_details( 'XML_GET on closed file ', ' ' ) - return - endif - - ! - ! From the previous call or the call to xmlopen we have - ! the line that we need to parse already in memory: - ! - ! - comment_tag = .false. - close_bracket = .false. - kspace = index( info%line, ' ' ) - kend = index( info%line, '>' ) - kcend = index( info%line, '-->' ) - do while ( kend <= 0 ) - read( info%lun, '(a)', iostat = ierr ) nextline - call xml_remove_tabs_(nextline) - info%lineno = info%lineno + 1 - - if ( ierr == 0 ) then - info%line = trim(info%line) // ' ' // adjustl(nextline) - else - info%error = .true. - call xml_report_errors( 'XML_GET - end of tag not found ', & - '(buffer too small?)', info%lineno ) - call xml_close( info ) - return - endif - kend = index( info%line, '>' ) - enddo - if ( kend > kspace ) then - kend = kspace - else if (info%line(1:4) == '' ) then - endtag = .true. - tag = info%line(4:kend-1) - else if ( info%line(1:2) == '' ) - if ( keq > kend ) keq = 0 ! Guard against multiple tags - ! with attributes on one line - - ! - ! No attributes any more? - ! - if ( keq < 1 ) then - kend = index( info%line, '/>' ) - if ( kend >= 1 ) then - kend = kend + 1 ! To go beyond the ">" character - endtag = .true. - else - kend = index( info%line, '>' ) - if ( kend < 1 ) then - call xml_report_errors( 'XML_GET - wrong ending of tag ', & - trim(info%line), info%lineno ) - info%error = .true. ! Wrong ending of line! - call xml_close( info ) - return - else - close_bracket = .true. - endif - endif - if ( kend >= 1 ) then - info%line = adjustl( info%line(kend+1:) ) - endif - exit - endif - - idxat = idxat + 1 - if ( idxat <= size(attribs,2) ) then - no_attribs = idxat - attribs(1,idxat) = adjustl(info%line(1:keq-1)) ! Use adjustl() to avoid - ! multiple spaces, etc - info%line = adjustl( info%line(keq+1:) ) - - ! - ! We have almost found the start of the attribute's value - ! - kfirst = index( info%line, '"' ) - if ( kfirst < 1 ) then - call xml_report_errors( 'XML_GET - malformed attribute-value pair: ', & - trim(info%line), info%lineno ) - info%error = .true. ! Wrong form of attribute-value pair - call xml_close( info ) - return - endif - - ksecond = index( info%line(kfirst+1:), '"' ) + kfirst - if ( ksecond < 1 ) then - call xml_report_errors( 'XML_GET - malformed attribute-value pair: ', & - trim(info%line), info%lineno ) - info%error = .true. ! Wrong form of attribute-value pair - call xml_close( info ) - return - endif - - attribs(2,idxat) = info%line(kfirst+1:ksecond-1) - info%line = adjustl( info%line(ksecond+1:) ) - endif - - if ( idxat > size(attribs,2) ) then - call xml_report_errors( 'XML_GET - more attributes than could be stored: ', & - trim(info%line), info%lineno ) - info%too_many_attribs = .true. - info%line = ' ' - exit - endif - enddo - - ! - ! Now read the data associated with the current tag - ! - all the way to the next "<" character - ! - ! To do: reduce the number of data lines - empty ones - ! at the end should not count. - ! - do - if ( comment_tag ) then - kend = index( info%line, '-->' ) - else - kend = index( info%line, '<' ) - endif - idxdat = idxdat + 1 - if ( idxdat <= size(data) ) then - no_data = idxdat - if ( kend >= 1 ) then - data(idxdat) = info%line(1:kend-1) - info%line = info%line(kend:) - else - data(idxdat) = info%line - endif - else - call xml_report_errors( 'XML_GET - more data lines than could be stored: ', & - trim(info%line), info%lineno ) - info%too_many_data = .true. - exit - endif - - ! - ! No more data? Otherwise, read on - ! - if ( kend >= 1 ) then - exit - else - read( info%lun, '(a)', iostat = ierr ) info%line - call xml_remove_tabs_(info%line) - info%lineno = info%lineno + 1 - - if ( ierr < 0 ) then - call xml_report_details( 'XML_GET - end of file found - LU-number: ', & - info%lun ) - info%eof = .true. - elseif ( ierr > 0 ) then - call xml_report_errors( 'XML_GET - error reading file with LU-number ', & - info%lun, info%lineno ) - info%error = .true. - endif - if ( ierr /= 0 ) then - exit - endif - endif - enddo - - ! - ! Compress the data? - ! - if ( info%ignore_whitespace ) then - call xml_compress_( data, no_data ) - endif - - ! - ! Replace the entities, if any - ! - call xml_replace_entities_( data, no_data ) - - call xml_report_details( 'XML_GET - number of attributes: ', no_attribs ) - call xml_report_details( 'XML_GET - number of data lines: ', no_data ) - -end subroutine xml_get - -!=============================================================================== -! XML_PUT -- -! Routine to write a tag with the associated data to an XML file -! Arguments: -! info Structure holding information on the XML-file -! tag Tag that was encountered -! endtag Whether the end of the element was encountered -! attribs List of attribute-value pairs -! no_attribs Number of pairs in the list -! data Lines of character data found -! no_data Number of lines of character data -! type Type of action: -! open - just the opening tag with attributes -! elem - complete element -! close - just the closing tag -!=============================================================================== - -subroutine xml_put(info, tag, attribs, no_attribs, & - data, no_data, type) - - type(XML_PARSE), intent(inout) :: info - character(len=*), intent(in) :: tag - character(len=*), intent(in), dimension(:,:) :: attribs - integer, intent(in) :: no_attribs - character(len=*), intent(in), dimension(:) :: data - integer, intent(in) :: no_data - character(len=*) :: type - - select case(type) - case('open') - call xml_put_open_tag_(info, tag, attribs, no_attribs) - case('elem') - call xml_put_element_(info, tag, attribs, no_attribs, & - data, no_data) - case('close') - call xml_put_close_tag_(info, tag) - end select - -end subroutine xml_put - -!=============================================================================== -! XML_PUT_OPEN_TAG_ -- -! Routine to write the opening tag with the attributes -! Arguments: -! info Structure holding information on the XML-file -! tag Tag that was encountered -! endtag Whether the end of the element was encountered -! attribs List of attribute-value pairs -! no_attribs Number of pairs in the list -! data Lines of character data found -! no_data Number of lines of character data -!=============================================================================== - -subroutine xml_put_open_tag_(info, tag, attribs, no_attribs) - - type(XML_PARSE), intent(inout) :: info - character(len=*), intent(in) :: tag - character(len=*), intent(in), dimension(:,:) :: attribs - integer, intent(in) :: no_attribs - - integer :: i - character(len=300), parameter :: indent = ' ' - - write( info%lun, '(3a)', advance = 'no' ) & - indent(1:3*info%level), '<', adjustl(tag) - do i=1,no_attribs - if (attribs(2,i)/='') then - write( info%lun, '(5a)', advance = 'no' ) & - ' ',trim(attribs(1,i)),'="', trim(attribs(2,i)),'"' - endif - enddo - write( info%lun, '(a)' ) '>' - info%level = info%level + 1 - -end subroutine xml_put_open_tag_ - -!=============================================================================== -! XML_PUT_ELEMENT_ -- -! Routine to write the complete element -! Arguments: -! info Structure holding information on the XML-file -! tag Tag that was encountered -! endtag Whether the end of the element was encountered -! attribs List of attribute-value pairs -! no_attribs Number of pairs in the list -! data Lines of character data found -! no_data Number of lines of character data -!=============================================================================== - -subroutine xml_put_element_(info, tag, attribs, no_attribs, & - data, no_data) - - type(XML_PARSE), intent(inout) :: info - character(len=*), intent(in) :: tag - character(len=*), intent(in), dimension(:,:) :: attribs - integer, intent(in) :: no_attribs - character(len=*), intent(in), dimension(:) :: data - integer, intent(in) :: no_data - - logical :: logic - character(len=1) :: aa - integer :: i, ii - - character(len=300), parameter :: indent = ' ' - - if ( (no_attribs==0 .and. no_data==0) ) then - return - else - logic = .true. - do ii = 1,no_attribs - logic = logic .and. (attribs(2,ii)=='') - enddo - do ii = 1,no_data - logic = logic .and. (data(ii)=='') - enddo - if ( logic ) then - return - else - write( info%lun, '(3a)', advance = 'no' ) & - indent(1:3*info%level), '<', adjustl(tag) - do i = 1,no_attribs - if (attribs(2,i)/='') then - write( info%lun, '(5a)', advance = 'no' ) & - ' ',trim(attribs(1,i)),'="', trim(attribs(2,i)),'"' - endif - enddo - if ( no_attribs>0 .and. no_data==0 ) then - aa='a' - elseif ( (no_attribs>0 .and. no_data>0) .or. & - (no_attribs==0 .and. no_data>0) ) then - aa='b' - else - write(*,*) no_attribs, no_data - endif - endif - endif - - select case(aa) - case('a') - write( info%lun, '(a)' ) '/>' - case('b') - write( info%lun, '(a)',advance='no' ) '>' - write( info%lun, '(2a)', advance='no') ( ' ', trim(data(i)), i=1,no_data ) - write( info%lun, '(4a)' ) ' ','' - end select - -end subroutine xml_put_element_ - -!=============================================================================== -! XML_PUT_CLOSE_TAG_ -- -! Routine to write the closing tag -! Arguments: -! info Structure holding information on the XML-file -! tag Tag that was encountered -! endtag Whether the end of the element was encountered -! attribs List of attribute-value pairs -! no_attribs Number of pairs in the list -! data Lines of character data found -! no_data Number of lines of character data -!=============================================================================== - -subroutine xml_put_close_tag_(info, tag) - - type(XML_PARSE), intent(inout) :: info - character(len=*), intent(in) :: tag - - character(len=300), parameter :: indent = ' ' - - info%level = info%level - 1 - write(info%lun, '(4a)') indent(1:3*info%level), '' - -end subroutine xml_put_close_tag_ - -!=============================================================================== -! XML_COMPRESS_ -- -! Routine to remove empty lines from the character data -! Arguments: -! data Lines of character data found -! no_data (Nett) number of lines of character data -!=============================================================================== - -subroutine xml_compress_( data, no_data ) - character(len=*), intent(inout), dimension(:) :: data - integer, intent(inout) :: no_data - - integer :: i - integer :: j - logical :: empty - - j = 0 - empty = .true. - do i = 1,no_data - if ( len_trim(data(i)) /= 0 .or. .not. empty ) then - j = j + 1 - data(j) = adjustl(data(i)) - empty = .false. - endif - enddo - - no_data = j - - do i = no_data,1,-1 - if ( len_trim(data(i)) /= 0 ) then - exit - else - no_data = no_data - 1 - endif - enddo - -end subroutine xml_compress_ - -!=============================================================================== -! XML_REPLACE_ENTITIES_ -- -! Routine to replace entities such as > by their -! proper character representation -! Arguments: -! data Lines of character data found -! no_data (Nett) number of lines of character data -!=============================================================================== - -subroutine xml_replace_entities_( data, no_data ) - character(len=*), intent(inout), dimension(:) :: data - integer, intent(inout) :: no_data - - integer :: i - integer :: j - integer :: j2 - integer :: k - integer :: pos - logical :: found - - do i = 1,no_data - j = 1 - do - do k = 1,size(entities,2) - found = .false. - pos = index( data(i)(j:), trim(entities(2,k)) ) - if ( pos > 0 ) then - found = .true. - j = j + pos - 1 - j2 = j + len_trim(entities(2,k)) - data(i)(j:) = trim(entities(1,k)) // data(i)(j2:) - j = j2 - endif - enddo - if ( .not. found ) exit - enddo - enddo - -end subroutine xml_replace_entities_ - -!=============================================================================== -! XML_OPTIONS -- -! Routine to handle the parser options -! Arguments: -! info Structure holding information on the XML-file -! ignore_whitespace Ignore whitespace (leading blanks, empty lines) or not -! no_data_truncation Consider truncation of strings an error or not -! report_lun LU-number for reporting information -! report_errors Write messages about errors or not -! report_details Write messages about all kinds of actions or not -!=============================================================================== - -subroutine xml_options( info, ignore_whitespace, no_data_truncation, & - report_lun, report_errors, & - report_details ) - type(XML_PARSE), intent(inout) :: info - logical, intent(in), optional :: ignore_whitespace - logical, intent(in), optional :: no_data_truncation - - integer, intent(in), optional :: report_lun - logical, intent(in), optional :: report_errors - logical, intent(in), optional :: report_details - - if ( present(ignore_whitespace) ) then - info%ignore_whitespace = ignore_whitespace - endif - if ( present(no_data_truncation) ) then - info%no_data_truncation = no_data_truncation - endif - if ( present(report_lun) ) then - report_lun_ = report_lun - endif - if ( present(report_errors) ) then - report_errors_ = report_errors - endif - if ( present(report_details) ) then - report_details_ = report_details - endif -end subroutine xml_options - -!=============================================================================== -! XML_OK -- -! Function that returns whether all was okay or not -! Arguments: -! info Structure holding information on the XML-file -! Returns: -! .true. if there was no error, .false. otherwise -!=============================================================================== - -logical function xml_ok( info ) - type(XML_PARSE), intent(in) :: info - - xml_ok = info%eof .or. info%error .or. & - ( info%no_data_truncation .and. & - ( info%too_many_attribs .or. info%too_many_data ) ) - xml_ok = .not. xml_ok -end function xml_ok - -!=============================================================================== -! XML_ERROR -- -! Function that returns whether there was an error -! Arguments: -! info Structure holding information on the XML-file -! Returns: -! .true. if there was an error, .false. if there was none -!=============================================================================== - -logical function xml_error( info ) - type(XML_PARSE), intent(in) :: info - - xml_error = info%error .or. & - ( info%no_data_truncation .and. & - ( info%too_many_attribs .or. info%too_many_data ) ) -end function xml_error - -!=============================================================================== -! XML_DATA_TRUNC -- -! Function that returns whether data were truncated or not -! Arguments: -! info Structure holding information on the XML-file -! Returns: -! .true. if data were truncated, .false. otherwise -!=============================================================================== - -logical function xml_data_trunc( info ) - type(XML_PARSE), intent(in) :: info - - xml_data_trunc = info%too_many_attribs .or. info%too_many_data -end function xml_data_trunc - -!=============================================================================== -! XML_FIND_ATTRIB -!=============================================================================== - -integer function xml_find_attrib( attribs, no_attribs, name, value ) - character(len=*), dimension(:,:) :: attribs - integer :: no_attribs - character(len=*) :: name - character(len=*) :: value - - integer :: i - - xml_find_attrib = -1 - do i = 1,no_attribs - if ( name == attribs(1,i) ) then - value = attribs(2,i) - xml_find_attrib = i - exit - endif - enddo - -end function xml_find_attrib - -!=============================================================================== -! XML_PROCESS -- -! Routine to read the XML file as a whole and distribute processing -! the contents over three user-defined subroutines -! Arguments: -! filename Name of the file to process -! attribs Array for holding the attributes -! data Array for holding the character data -! startfunc Subroutine to handle the start of elements -! datafunc Subroutine to handle the character data -! endfunc Subroutine to handle the end of elements -! error Indicates if there was an error or not -! Note: -! The routine is declared recursive to allow inclusion of XML files -! (common with XSD schemas). This extends to the auxiliary routines. -!=============================================================================== - -recursive & -subroutine xml_process( filename, attribs, data, startfunc, datafunc, endfunc, lunrep, error ) - character(len=*) :: filename - character(len=*), dimension(:,:) :: attribs - character(len=*), dimension(:) :: data - integer :: lunrep - logical :: error - - interface - recursive subroutine startfunc( tag, attribs, error ) - character(len=*) :: tag - character(len=*), dimension(:,:) :: attribs - logical :: error - end subroutine - end interface - - interface - recursive subroutine datafunc( tag, data, error ) - character(len=*) :: tag - character(len=*), dimension(:) :: data - logical :: error - end subroutine - end interface - - interface - recursive subroutine endfunc( tag, error ) - character(len=*) :: tag - logical :: error - end subroutine - end interface - - type(XML_PARSE) :: info - character(len=80) :: tag - logical :: endtag - integer :: noattribs - integer :: nodata - - call xml_options( info, report_lun = lunrep, report_details = .false. ) - call xml_open( info, filename, .true. ) - - error = .false. - do - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( .not. xml_ok(info) ) then - exit - endif - - if ( xml_error(info) ) then - write(lunrep,*) 'Error reading XML file!' - error = .true. - exit - endif - - if ( .not. endtag .or. noattribs /= 0 ) then - call startfunc( tag, attribs(:,1:noattribs), error ) - if ( error ) exit - - call datafunc( tag, data(1:nodata), error ) - if ( error ) exit - endif - - if ( endtag ) then - call endfunc( tag, error ) - if ( error ) exit - endif - enddo - call xml_close( info ) -end subroutine xml_process - -!=============================================================================== -! XML_REMOVE_TABS_ -- -! Routine to change any horizontal tab characters to spaces when reading a -! new line of data -! Arguments: -! line Line of character data to modify -!=============================================================================== - -subroutine xml_remove_tabs_(line) - character(len=*), intent(inout) :: line - - integer :: i - - do i = 1, len_trim(line) - if (line(i:i) == achar(9)) then - line(i:i) = ' ' - end if - end do - -end subroutine xml_remove_tabs_ - -end module xmlparse diff --git a/src/xml-fortran/xmlreader.f90 b/src/xml-fortran/xmlreader.f90 deleted file mode 100644 index 390324b63..000000000 --- a/src/xml-fortran/xmlreader.f90 +++ /dev/null @@ -1,1241 +0,0 @@ -!=============================================================================== -! XMLREADER: -! Read an XML-file that contains a template for the data and the XML files -! that will be used in a program and generate a module with reading routines. -! -! TODO: -! - Private routines! -! - Error for unknown data types -! - Length for character items -!=============================================================================== - -program xmlreader - use XMLPARSE - implicit none - - character(len=60) :: fname - type(XML_PARSE) :: info - - character(len=80) :: tag - character(len=80) :: starttag - logical :: endtag - character(len=80), dimension(1:2,1:20) :: attribs - integer :: noattribs - character(len=1000), dimension(1:1000) :: data - integer :: nodata - integer :: i - integer :: j - integer, parameter :: notmps = 6 ! Number of temporary files needed! - integer :: ludef - integer :: ludeflt - integer :: luinit - integer :: lusubs - integer :: luprolog - integer :: lustart - integer :: luloop - integer :: luend - integer :: lumain - integer :: luwrite - integer :: luwritp - integer :: luwrv - integer :: argc - logical :: prolog_written - logical :: comp - logical :: error - logical :: begin_loop = .true. - logical :: begin_main_loop = .true. - logical :: begin_component = .false. - logical :: strict - logical :: global_type - logical :: dyn_strings - - character(len=32) :: root_name - character(len=32) :: global_name - character(len=32) :: typename - character(len=32), dimension(1:20) :: placeholder - integer :: no_placeholders - - character(len=50) :: declare - character(len=50), dimension(:,:), pointer :: types - character(len=50), dimension(:,:), pointer :: new_types - - ! TODO: arrays of integers etc, in addition to integer-arrays - see: word - integer, parameter :: notypes_predefined = 27 - character(len=50), dimension(1:4,1:notypes_predefined) :: predefined_types - integer :: notypes = notypes_predefined - data ((predefined_types(i,j) , i=1,4), j=1,notypes_predefined ) / & -'logical' ,' logical' , 'read_xml_logical', 'write_to_xml_logical', & -'logical-1dim' ,' logical, dimension(:), pointer' , 'read_xml_logical_1dim', 'write_to_xml_logical_1dim', & -'logical-array' ,' logical, dimension(:), pointer' , 'read_xml_logical_array', 'write_to_xml_logical_array', & -'logical-shape' ,' logical, dimension(SHAPE)' , 'read_xml_logical_array', 'write_to_xml_logical_array', & -'integer' ,' integer' , 'read_xml_integer', 'write_to_xml_integer', & -'integer-1dim' ,' integer, dimension(:), pointer' , 'read_xml_integer_1dim', 'write_to_xml_integer_1dim', & -'integer-array' ,' integer, dimension(:), pointer' , 'read_xml_integer_array', 'write_to_xml_integer_array', & -'integer-shape' ,' integer, dimension(SHAPE)' , 'read_xml_integer_array', 'write_to_xml_integer_array', & -'real' ,' real' , 'read_xml_real' , 'write_to_xml_real' , & -'real-1dim' ,' real, dimension(:), pointer' , 'read_xml_real_1dim', 'write_to_xml_real_1dim', & -'real-array' ,' real, dimension(:), pointer' , 'read_xml_real_array', 'write_to_xml_real_array', & -'real-shape' ,' real, dimension(SHAPE)' , 'read_xml_real_array', 'write_to_xml_real_array', & -'double' ,' real(kind=kind(1.0d0))' , 'read_xml_double', 'write_to_xml_double', & -'double-1dim' ,' real(kind=kind(1.0d0)), dimension(:), pointer' , & - 'read_xml_double_1dim', 'write_to_xml_double_1dim', & -'double-array' ,' real(kind=kind(1.0d0)), dimension(:), pointer' , & - 'read_xml_double_array', 'write_to_xml_double_array', & -'double-shape' ,' real(kind=kind(1.0d0)), dimension(SHAPE)' , & - 'read_xml_double_array', 'write_to_xml_double_array', & -'word' ,' character(len=?)' , 'read_xml_word', 'write_to_xml_word', & -'word-1dim' ,' character(len=?), dimension(:), pointer' , 'read_xml_word_1dim', 'write_to_xml_word_1dim', & -'word-array' ,' character(len=?), dimension(:), pointer' , 'read_xml_word_array', 'write_to_xml_word_array', & -'word-shape' ,' character(len=?), dimension(SHAPE)' , 'read_xml_word_array', 'write_to_xml_word_array', & -'line' ,' character(len=?)' , 'read_xml_line', 'write_to_xml_line', & -'line-1dim' ,' character(len=?), dimension(:), pointer' , 'read_xml_line_1dim', 'write_to_xml_line_1dim', & -'line-array' ,' character(len=?), dimension(:), pointer' , 'read_xml_line_array', 'write_to_xml_line_array', & -'line-shape' ,' character(len=?), dimension(SHAPE)' , 'read_xml_line_array', 'write_to_xml_line_array', & -'character' ,' character(len=?)' , 'read_xml_line', 'write_to_xml_line', & -'character-array',' character(len=?), dimension(:), pointer' , 'read_xml_line_array', 'write_to_xml_line_array', & -'character-shape',' character(len=?), dimension(SHAPE)' , 'read_xml_line_array', 'write_to_xml_line_array' / - - allocate( types(1:4,1:notypes) ) - types = predefined_types(:,1:notypes) - - ! - ! Read the global options file, if present - ! - strict = .false. - global_type = .false. - dyn_strings = .true. - call get_global_options( attribs, noattribs, strict, global_type, global_name, & - root_name, dyn_strings ) - - ! - ! Open the input file and read the name of the template. - ! Load the template into a tree and then generate it all - ! in stages - ! - argc = COMMAND_ARGUMENT_COUNT() - if (argc > 0) then - call GET_COMMAND_ARGUMENT(1, fname) - else - open(UNIT=10, FILE='xmlreader.inp') - read(UNIT=10, FMT='(a)') fname - close(UNIT=10) - end if - - open( 20, file = 'xmlreader.out' ) - call xml_options( info, report_lun = 20, report_details = .true. ) - - prolog_written = .false. - ! - ! Set the defaults - ! - global_type = .false. - global_name = fname - root_name = fname - - ludef = 21 - lusubs = 22 - luinit = 23 - luwritp = 24 - luwrv = luwritp - open( ludef, file = trim(fname)//'.f90' ) - open( lusubs, status = 'scratch' ) - open( luinit, status = 'scratch' ) - open( luwritp, status = 'scratch' ) - call open_tmp_files( 31 ) - - lumain = luloop - - ! Read the template file and act as we go along: - ! - write the declarations - ! - write the main reading routine - ! - write the individual reading routines - ! - the root element is needed because of the definition of XML files, - ! but we ignore it. - ! - call xml_open( info, trim(fname)//'.xml', .true. ) - - error = .false. - comp = .false. - no_placeholders = 0 - - call xml_get( info, starttag, endtag, attribs, noattribs, data, nodata ) - - do - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - write(20,*) 'tag: ',tag - write(20,*) 'attribs: ',noattribs - if ( noattribs > 0 ) then - write(20,'(4a)') ( ' ', trim(attribs(1,i)), ' = ', trim(attribs(2,i)), i=1,noattribs ) - endif - write(20,*) 'data: ',nodata - if ( nodata > 0 ) then - write(20,'(3a)') ( ' >', trim(data(i)), '<', i=1,nodata ) - endif - if ( xml_error(info) ) then - write(*,*) 'Error reading template file!' - !stop - exit - endif - - ! - ! When encountering the endtag, then close the - ! current definition - ! - if ( endtag .and. noattribs == 0 ) then - select case ( tag ) - case ( 'typedef' ) - call close_typedef( begin_component ) - case ( 'placeholder' ) - !if ( comp ) then - ! call close_placeholder - !endif - !comp = .false. - call close_placeholder - luwrv = luwritp - case default - ! - ! Have we found the end of the definition? - ! - if ( tag == starttag ) then - exit - endif - end select - - if ( xml_ok(info) ) then - cycle - else - exit - endif - - endif - - ! - ! Opening tags: dispatch on the actual tag - ! - select case( tag ) - case( 'options' ) - call set_options( attribs, noattribs, strict, global_type, & - global_name, root_name, dyn_strings ) - if ( .not. prolog_written ) then - prolog_written = .true. - call write_prolog - else - write(20,*) 'Options element should be the first child of the root element',& - 'Otherwise it has no effect!' - endif - - if ( strict ) then - write( lumain, '(a)' ) ' strict_ = .true.' - else - write( lumain, '(a)' ) ' strict_ = .false.' - endif - - case( 'comment', '!--' ) - ! Do nothing - - case( 'placeholder' ) - if ( .not. prolog_written ) then - prolog_written = .true. - call write_prolog - endif - if ( begin_loop .or. begin_main_loop ) then - begin_main_loop = .false. - call add_begin_loop( .true., .false. ) - endif - call add_placeholder(dyn_strings) - begin_component = .false. - luwrv = luwrite - - case( 'typedef' ) - if ( .not. prolog_written ) then - prolog_written = .true. - call write_prolog - endif - call add_typedef(dyn_strings) - - case( 'variable' ) - if ( .not. prolog_written ) then - prolog_written = .true. - call write_prolog - endif - if ( begin_loop .or. begin_main_loop ) then - begin_main_loop = .false. - call add_begin_loop( .true., begin_component ) - endif - call add_variable( component=comp ) - - case( 'component' ) - ! - ! Components of derived types are treated in much the - ! same way as ordinary variables - with one syntactic - ! difference - ! - if ( .not. prolog_written ) then - prolog_written = .true. - call write_prolog - endif - if ( begin_loop ) then - call add_begin_loop( .true., .true. ) - endif - call add_variable( component=.true. ) - begin_component = .true. - - case default - write(20,*) 'Unknown tag: ',trim(tag) - write(20,*) '-- terminating the program!' - stop - end select - end do - - ! - ! Now finish it all - ! - write( luend, '(a)' ) & - & ' if ( present(errout) ) errout = error', & - & ' call xml_close(info)', & - & 'end subroutine', & - & ' ' - write( luwritp, '(a)' ) & - & ' write(info%lun,''(a)'') ''''', & - & ' call xml_close(info)', & - & 'end subroutine', & - & ' ' - - call append_files( luprolog ) - call merge_files - - write( ludef, '(/,a)' ) & - & 'end subroutine', & - & 'end module' - - if ( error ) then - write(*,*) 'Errors found in the definition - please check!' - endif - stop -contains - -!=============================================================================== -! GET_GLOBAL_OPTIONS -- -! Routine to get the global options from the configuration file -! Arguments: -! strict Option to make the parser check for unknown tags -! global_type Option to generate an overall derived type -! global_name Name of that overall derived type (if requested) -! root_name Name of the root element of the XML file -! dyn_strings Whether to use dynamic strings or not -!=============================================================================== - -subroutine get_global_options( attribs, noattribs, strict, global_type, global_name, & - root_name, dyn_strings ) - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - logical, intent(inout) :: strict - logical, intent(inout) :: global_type - character(len=*), intent(inout) :: global_name - character(len=*), intent(inout) :: root_name - logical, intent(inout) :: dyn_strings - - character(len=20) :: tag - character(len=20), dimension(1) :: data - integer :: nodata - logical :: exists - logical :: endtag - type(XML_PARSE) :: info - - inquire( file = 'xmlreader.conf', exist = exists ) - if ( exists ) then - call xml_open( info, 'xmlreader.conf', .true. ) - do while ( xml_ok(info) ) - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( tag == 'xmlreader' ) then - call set_options( attribs, noattribs, strict, global_type, & - global_name, root_name, dyn_strings ) - endif - enddo - call xml_close( info ) - endif -end subroutine get_global_options - -!=============================================================================== -! SET_OPTIONS -- -! Routine to set the options that influence the parser -! Arguments: -! attribs List of attributes -! noattribs Number of attributes -! strict Option to make the parser check for unknown tags -! global_type Option to generate an overall derived type -! global_name Name of that overall derived type (if requested) -! root_name Name of the root element of the XML file -! dyn_strings Whether to use dynamic strings or not -!=============================================================================== - -subroutine set_options( attribs, noattribs, strict, global_type, global_name, root_name, dyn_strings ) - character(len=*), dimension(:,:), intent(in) :: attribs - integer, intent(in) :: noattribs - logical, intent(inout) :: strict - logical, intent(inout) :: global_type - character(len=*), intent(inout) :: global_name - character(len=*), intent(inout) :: root_name - logical, intent(inout) :: dyn_strings - - integer :: i - - do i = 1,noattribs - select case (attribs(1,i)) - case ('strict') - if ( attribs(2,i) == 'yes' ) then - strict = .true. - else - strict = .false. - endif - case ('globaltype') - if ( attribs(2,i) == 'yes' ) then - global_type = .true. - else - global_type = .false. - endif - case ('globalname') - global_name = attribs(2,i) - case ('rootname') - root_name = attribs(2,i) - case ('dynamicstrings') - if ( attribs(2,i) == 'yes' ) then - dyn_strings = .true. - else - dyn_strings = .false. - endif - case default - write(20,*) 'Unknown option: ',trim(attribs(1,i)), ' - ignored' - end select - enddo -end subroutine set_options - -!=============================================================================== -! OPEN_TMP_FILES -- -! Routine to open the temporary files -! Arguments: -! lufirst First LU-number to use -!=============================================================================== - -subroutine open_tmp_files( lufirst ) - integer, intent(in) :: lufirst - - luprolog = lufirst - lustart = lufirst + 1 - luloop = lufirst + 2 - luend = lufirst + 3 - ludeflt = lufirst + 4 - luwrite = lufirst + 5 - open( luprolog, status = 'scratch' ) - open( lustart, status = 'scratch' ) - open( luloop, status = 'scratch' ) - open( luend, status = 'scratch' ) - open( ludeflt, status = 'scratch' ) - open( luwrite, status = 'scratch' ) -end subroutine open_tmp_files - -!=============================================================================== -! CLOSE_TMP_FILES -- -! Routine to close the temporary files -! Arguments: -! None -!=============================================================================== - -subroutine close_tmp_files - close( luprolog ) - close( lustart ) - close( luloop ) - close( luend ) - close( ludeflt ) - close( luwrite ) - - luprolog = luprolog - notmps - lustart = lustart - notmps - luloop = luloop - notmps - luend = luend - notmps - ludeflt = ludeflt - notmps - luwrite = luwrite - notmps -end subroutine close_tmp_files - -!=============================================================================== -! APPEND_TMP_FILES -- -! Routine to append the contents of the temporary files -! Arguments: -! lufirst First LU-number to use -!=============================================================================== - -subroutine append_files( lufirst ) - integer, intent(in) :: lufirst - - integer :: lu - integer :: io - character(len=120) :: line - - ! - ! If we have not written a subroutine yet, then - ! now is the time to close the overall initialisation - ! routine - ! -- no longer needed - ! - !if ( .not. contains ) then - ! write( lusubs, '(a,/)' ) 'end subroutine' - ! contains = .true. - !endif - - ! - ! Copy the contents of the scratch files - ! - do lu = lufirst,lufirst+notmps-1 - rewind( lu ) - do - read( lu, '(a)', iostat=io ) line - if ( io /= 0 ) exit - write( lusubs, '(a)' ) trim(line) - enddo - rewind( lu ) - enddo -end subroutine append_files - -!=============================================================================== -! MERGE_FILES -- -! Routine to merge all temporary files into the definite file -! Arguments: -! None -!=============================================================================== - -subroutine merge_files - - integer :: io - character(len=120) :: line - - ! - ! Copy the contents of the "subroutines" file - ! - rewind( lusubs ) - do - read( lusubs, '(a)', iostat=io ) line - if ( io /= 0 ) exit - write( ludef, '(a)' ) trim(line) - enddo - - ! - ! Copy the contents of the "write xml file subroutine" file - ! - rewind( luwritp ) - do - read( luwritp, '(a)', iostat=io ) line - if ( io /= 0 ) exit - write( ludef, '(a)' ) trim(line) - enddo - - ! - ! Copy the contents of the "initialisation subroutine" file - ! - rewind( luinit ) - do - read( luinit, '(a)', iostat=io ) line - if ( io /= 0 ) exit - write( ludef, '(a)' ) trim(line) - enddo -end subroutine merge_files - -!=============================================================================== -! WRITE_PROLOG -- -! Routine to write the beginning of the module -! Arguments: -! None -!=============================================================================== - -subroutine write_prolog - write( ludef, '(a)' ) & - & 'module xml_data_' // trim(fname), & - & ' use READ_XML_PRIMITIVES', & - & ' use WRITE_XML_PRIMITIVES', & - & ' use XMLPARSE', & - & ' implicit none', & - & ' save', & - & ' integer, private :: lurep_', & - & ' logical, private :: strict_' - - write( luprolog, '(a)' ) & - & 'subroutine read_xml_file_'//trim(fname)//'(fname, lurep, errout)' , & - & ' character(len=*), intent(in) :: fname' , & - & ' integer, intent(in), optional :: lurep' , & - & ' logical, intent(out), optional :: errout' , & - & ' ' , & - & ' type(XML_PARSE) :: info' , & - & ' logical :: error' , & - & ' character(len=80) :: tag' , & - & ' character(len=80) :: starttag' , & - & ' logical :: endtag' , & - & ' character(len=250), dimension(1:2,1:20) :: attribs' , & - & ' integer :: noattribs' , & - & ' character(len=1000), dimension(1:1000) :: data' , & - & ' integer :: nodata' - - write( lusubs, '(a)' ) & - & 'contains' - write( luinit, '(a)' ) & - & 'subroutine init_xml_file_'//trim(fname) - - write( luwritp, '(a)' ) & - & 'subroutine write_xml_file_'//trim(fname)//'(fname, lurep)' , & - & ' character(len=*), intent(in) :: fname' , & - & ' integer, intent(in), optional :: lurep' , & - & ' ' , & - & ' type(XML_PARSE) :: info' , & - & ' integer :: indent = 0', & - & ' ' , & - & ' call xml_open( info, fname, .false. )' , & - & ' call xml_options( info, report_errors=.true.)' , & - & ' if ( present(lurep) ) then' , & - & ' call xml_options( info, report_errors=.true.)' , & - & ' endif' , & - & ' write(info%lun,''(a)'') &' , & - & ' ''<' // trim(root_name) // '>''' - - write( lumain, '(a)' ) & - & ' ', & - & ' call init_xml_file_'//trim(fname), & - & ' call xml_open( info, fname, .true. )', & - & ' call xml_options( info, report_errors=.false., ignore_whitespace=.true.)', & - & ' lurep_ = 0', & - & ' if ( present(lurep) ) then', & - & ' lurep_ = lurep', & - & ' call xml_options( info, report_lun=lurep )', & - & ' endif', & - & ' do', & - & ' call xml_get( info, starttag, endtag, attribs, noattribs, &', & - & ' data, nodata)', & - & ' if ( starttag /= ''!--'' ) exit', & - & ' enddo', & - & ' if ( starttag /= "' // trim(root_name) // '" ) then', & - & ' call xml_report_errors( info, &', & - & ' ''XML-file should have root element "' // trim(root_name) // '"'')', & - & ' error = .true.', & - & ' call xml_close(info)', & - & ' return', & - & ' endif' - - call add_end_loop -end subroutine write_prolog - -!=============================================================================== -! ADD_BEGIN_LOOP -- -! Routine to write the start of the reading loop -! Arguments: -! checktag Whether code for checking the tag is required -! component Whether this is an ordinary variable or a component -! in a derived type -!=============================================================================== - -subroutine add_begin_loop( checktag, component ) - logical :: checktag - logical :: component - - if ( component ) then - write( luloop, '(a)' ) & - & ' call init_xml_type_'//trim(typename)//'(dvar)', & - & ' has_dvar = .true.' - endif - - begin_loop = .false. - - if ( component ) then - write( luloop, '(a)' ) & - & ' error = .false.' ,& - & ' att_ = 0' ,& - & ' noatt_ = noattribs+1' ,& - & ' endtag_org = endtag' ,& - & ' do', & - & ' if ( nodata /= 0 ) then' ,& - & ' noattribs = 0' ,& - & ' tag = starttag' ,& - & ' elseif ( att_ < noatt_ .and. noatt_ > 1 ) then' ,& - & ' att_ = att_ + 1' ,& - & ' if ( att_ <= noatt_-1 ) then' ,& - & ' tag = attribs(1,att_)' ,& - & ' data(1) = attribs(2,att_)' ,& - & ' noattribs = 0' ,& - & ' nodata = 1' ,& - & ' endtag = .false.' ,& - & ' else' ,& - & ' tag = starttag' ,& - & ' noattribs = 0' ,& - & ' nodata = 0' ,& - & ' endtag = .true.' ,& - & ' cycle' ,& - & ' endif' ,& - & ' else', & - & ' if ( endtag_org ) then', & - & ' return', & - & ' else', & - & ' call xml_get( info, tag, endtag, attribs, noattribs, data, nodata )' ,& - & ' if ( xml_error(info) ) then' ,& - & ' write(lurep_,*) ''Error reading input file!''',& - & ' error = .true.' ,& - & ' return' ,& - & ' endif' ,& - & ' endif' ,& - & ' endif' - else - write( luloop, '(a)' ) & - & ' error = .false.' ,& - & ' do', & - & ' call xml_get( info, tag, endtag, attribs, noattribs, data, nodata )' ,& - & ' if ( xml_error(info) ) then' ,& - & ' write(lurep_,*) ''Error reading input file!''' ,& - & ' error = .true.' ,& - & ' return' ,& - & ' endif' - endif - if ( checktag ) then - write( luloop, '(a)' ) & - & ' if ( endtag .and. tag == starttag ) then' ,& - & ' exit' ,& - & ' endif' - endif - write( luloop, '(a)' ) & - & ' if ( endtag .and. noattribs == 0 ) then' ,& - & ' if ( xml_ok(info) ) then' ,& - & ' cycle' ,& - & ' else' ,& - & ' exit' ,& - & ' endif' ,& - & ' endif' ,& - & ' select case( tag )' -end subroutine add_begin_loop - -!=============================================================================== -! ADD_END_LOOP -- -! Routine to write the end of the reading loop -! Arguments: -! None -!=============================================================================== - -subroutine add_end_loop - - write( luend, '(a)' ) & - & ' case (''comment'', ''!--'')' ,& - & ' ! Simply ignore', & - & ' case default' ,& - & ' if ( strict_ ) then', & - & ' error = .true.', & - & ' call xml_report_errors( info, &', & - & ' ''Unknown or wrongly placed tag: '' // trim(tag))',& - & ' endif' - - write( luend, '(a)' ) & - & ' end select' ,& - & ' nodata = 0' ,& - & ' if ( .not. xml_ok(info) ) exit' , & - & ' end do' -end subroutine add_end_loop - -!=============================================================================== -! ADD_VARIABLE -- -! Routine to write the definition of variables or components of -! derived types -! Arguments: -! component Whether this is an ordinary variable or a component -! in a derived type -!=============================================================================== - -subroutine add_variable( component ) - logical :: component - - integer :: idx1 - integer :: idx2 - integer :: idx3 - integer :: idx4 - integer :: idx5 - integer :: idx6 - integer :: idx7 - integer :: k - integer :: vdim - - character(len=32) :: varname - character(len=40) :: varcomp - character(len=40) :: varshape - character(len=100) :: vardefault - character(len=32) :: vartype - character(len=32) :: vartag - character(len=10) :: dim - character(len=10) :: strlength - character(len=32) :: initptr - - idx1 = xml_find_attrib( attribs, noattribs, 'name', varname ) - idx2 = xml_find_attrib( attribs, noattribs, 'type', vartype ) - strlength = "--" - idx5 = xml_find_attrib( attribs, noattribs, 'length', strlength ) - if ( idx1 <= 0 ) then - write( 20, * ) 'Variable/component found which has no name' - error = .true. - endif - if ( idx2 <= 0 ) then - write( 20, * ) 'Variable/component found which has no type - ',trim(varname) - error = .true. - else - dim = '--' - idx7 = xml_find_attrib( attribs, noattribs, 'dimension', dim ) - idx6 = xml_find_attrib( attribs, noattribs, 'shape', varshape ) - if ( idx7 >= 1 ) then - if ( dim == '1' ) then - idx3 = xml_find_attrib( types, notypes, vartype, declare ) - if ( idx3 > notypes_predefined ) then - vartype = trim(vartype) // '-array' - else - vartype = trim(vartype) // '-1dim' - endif - else - error = .true. - write(20,*) 'Dimension not supported: ',dim - endif - endif - if ( idx6 >= 1 ) then - vartype = trim(vartype) // '-shape' - vdim = 1 - if ( index(varshape, ',') > 0 ) then - vdim = 2 - endif - endif - - idx3 = xml_find_attrib( types, notypes, vartype, declare ) - if ( idx3 <= 0 ) then - write( 20, * ) & - 'Variable/component with unknown type - ',trim(varname) - error = .true. - endif - endif - - idx4 = xml_find_attrib( attribs, noattribs, 'default', vardefault ) - - if ( component ) then - varcomp = 'dvar%'//varname - else - varcomp = varname - endif - - idx1 = xml_find_attrib( attribs, noattribs, 'tag', vartag ) - if ( idx1 < 1 ) then - vartag = varname - endif - - if ( .not. error ) then - if ( index( declare, "pointer" ) > 0 ) then - initptr = " => null()" - else - initptr = "" - endif - - k = index( declare, 'SHAPE' ) - if ( k > 0 ) then - declare = declare(1:k-1) // trim(varshape) // declare(k+5:) - endif - - if ( index( declare, "?" ) <= 0 ) then - write( ludef, '(4a)' ) declare, ' :: ', trim(varname), trim(initptr) - else - if ( strlength == "--" ) then - strlength = "1" ! Hm, error is better? - endif - idx5 = index( declare, "?" ) - write( ludef, '(6a)' ) declare(1:idx5-1), trim(strlength), declare(idx5+1:), & - ' :: ', trim(varname), trim(initptr) - endif - - if ( idx6 > 0 ) then - k = index( types(2,idx3-1), '?' ) - if ( k <= 0 ) then - write( luprolog, '(3a)' ) types(2,idx3-1), ' :: ', 'p_'//trim(varname) - else - write( luprolog, '(6a)' ) types(2,idx3-1)(1:k-1), trim(strlength), & - types(2,idx3-1)(k+1:), ' :: ', 'p_'//trim(varname) - endif - endif - write( luprolog, '(3a)' ) types(2,1), ' :: ', 'has_'//trim(varname) - write( lustart, '(3a)' ) ' has_', varname, ' = .false.' - if ( dim /= '--' ) then - write( lustart, '(3a)' ) ' allocate(' // trim(varcomp), '(0))' - endif - write( luloop, '(a)' ) ' case('''//trim(vartag)//''')' - - if ( idx6 <= 0 ) then - write( luloop, '(a)' ) & - &' call '//trim(types(3,idx3))//'( &', & - &' info, tag, endtag, attribs, noattribs, data, nodata, &',& - &' ' // trim(varcomp) // ', has_'//trim(varname) // ' )' - else - write( luloop, '(a)' ) & - &' call '//trim(types(3,idx3))//'( &', & - &' info, tag, endtag, attribs, noattribs, data, nodata, &',& - &' p_' // trim(varname) // ', has_'//trim(varname) // ' )',& - &' if ( has_'//trim(varname) // ') then' - if ( vdim == 1 ) then - write( luloop, '(a)' ) & - &' if ( size('//trim(varcomp)//') <= size(p_'//trim(varname)//') ) then', & - &' '//trim(varcomp) // ' = p_'//trim(varname)//'(1:size('//trim(varcomp)//'))', & - &' else', & - &' '//trim(varcomp) // '(1:size(p_'//trim(varname)//')) = p_'//trim(varname), & - &' endif' - else - write( luloop, '(a)' ) & - &' if ( size(p_'//trim(varname)//') >= size('//trim(varcomp)//') ) then',& - &' '//trim(varcomp)//' = reshape(p_'//trim(varname)//', shape('//trim(varcomp)//'))',& - &' else',& - &' has_'//trim(varname)//' = .false.',& - &' call xml_report_errors(info, ''Incorrect number of values for '//trim(varname)//''')', & - &' endif' - endif - write( luloop, '(a)' ) & - &' deallocate( p_'//trim(varname)//' )', & - &' endif' - endif - if ( idx4 <= 0 ) then - write( luend, '(a)' ) & - &' if ( .not. has_'//trim(varname)//' ) then' - - if ( component ) then - write( luend, '(a)' ) & - &' has_dvar = .false.' - else - write( luend, '(a)' ) & - &' error = .true.' - endif - - write( luend, '(a)' ) & - &' call xml_report_errors(info, ''Missing data on '//trim(varname)//''')', & - &' endif' - else - ! - ! Note: the attribute value is supposed to have the quotes, if that - ! is relevant for the variable's type - ! - if ( component ) then - write( ludeflt, '(4a)' ) & - &' dvar%', trim(varname), ' = ', attribs(2,idx4) - else - write( luinit, '(4a)' ) & - &' ', trim(varname), ' = ', attribs(2,idx4) - endif - endif - ! - ! Write the component/variable - ! - if ( component ) then - write( luwrite, '(4a)' ) & - &' call '//trim(types(4,idx3))//'(', & - &' info, '''//trim(vartag)//''', indent+3, dvar%', trim(varname), ')' - else - write( luwrv, '(4a)' ) & - &' call '//trim(types(4,idx3))//'(', & - &' info, '''//trim(vartag)//''', indent+3, ', trim(varname), ')' - endif - endif - -end subroutine add_variable - -!=============================================================================== -! ADD_TYPEDEF -- -! Routine to write the definition and other code for a derived type -! Arguments: -! dyn_strings Whether dynamic string lengths are allowed -!=============================================================================== - -subroutine add_typedef( dyn_strings ) - logical, intent(in) :: dyn_strings - - integer :: idx1 - integer :: idx2 - - character(len=32) :: typetag - - idx1 = xml_find_attrib( attribs, noattribs, 'name', typename ) - if ( idx1 <= 0 ) then - write( 20, * ) 'Type definition found which has no name' - error = .true. - endif - - ! - ! We need a new set of temporary files - ! - call open_tmp_files( luprolog+notmps ) - - idx2 = xml_find_attrib( attribs, noattribs, 'tag', typetag ) - if ( idx1 < 1 ) then - typetag = typename - endif - - if ( .not. error ) then - write( ludef, '(/,2a)' ) 'type ',trim(typename) - write( luprolog, '(a)' ) & - & 'subroutine read_xml_type_'//trim(typename)//'_array( &' ,& - & ' info, tag, endtag, attribs, noattribs, data, nodata, &',& - & ' dvar, has_dvar )' ,& - & ' type(XML_PARSE) :: info' ,& - & ' character(len=*), intent(inout) :: tag ',& - & ' logical, intent(inout) :: endtag ',& - & ' character(len=*), dimension(:,:), intent(inout) :: attribs',& - & ' integer, intent(inout) :: noattribs',& - & ' character(len=*), dimension(:), intent(inout) :: data ',& - & ' integer, intent(inout) :: nodata ',& - & ' type('//trim(typename)//'), dimension(:), pointer :: dvar ',& - & ' logical, intent(inout) :: has_dvar ',& - & ' ' ,& - & ' integer :: newsize ',& - & ' type('//trim(typename)//'), dimension(:), pointer :: newvar',& - & ' ' ,& - & ' newsize = size(dvar) + 1' ,& - & ' allocate( newvar(1:newsize) )' ,& - & ' newvar(1:newsize-1) = dvar' ,& - & ' deallocate( dvar )' ,& - & ' dvar => newvar' ,& - & ' ' ,& - & ' call read_xml_type_'//trim(typename)// & - & '( info, tag, endtag, attribs, noattribs, data, nodata, &',& - & ' dvar(newsize), has_dvar )' ,& - & 'end subroutine read_xml_type_'//trim(typename)//'_array' ,& - & ' ' - - write( luwrite, '(a)' ) & - & 'subroutine write_xml_type_'//trim(typename)//'_array( &' ,& - & ' info, tag, indent, dvar )' ,& - & ' type(XML_PARSE) :: info' ,& - & ' character(len=*), intent(in) :: tag' ,& - & ' integer :: indent',& - & ' type('//trim(typename)//'), dimension(:) :: dvar' ,& - & ' integer :: i' ,& - & ' do i = 1,size(dvar)' ,& - & ' call write_xml_type_'//trim(typename)// & - & '( info, tag, indent, dvar(i) )' ,& - & ' enddo' ,& - & 'end subroutine write_xml_type_'//trim(typename)//'_array' ,& - & ' ', & - & 'subroutine write_xml_type_'//trim(typename)//'( &' ,& - & ' info, tag, indent, dvar )' ,& - & ' type(XML_PARSE) :: info' ,& - & ' character(len=*), intent(in) :: tag' ,& - & ' integer :: indent',& - & ' type('//trim(typename)//') :: dvar' ,& - & ' character(len=100) :: indentation' ,& - & ' indentation = '' ''' ,& - & ' write(info%lun, ''(4a)'' ) indentation(1:min(indent,100)),&',& - & ' ''<'',trim(tag), ''>''' - - write( luprolog, '(a)' ) & - & 'subroutine read_xml_type_'//trim(typename)//& - & '( info, starttag, endtag, attribs, noattribs, data, nodata, &' ,& - & ' dvar, has_dvar )' ,& - & ' type(XML_PARSE) :: info' ,& - & ' character(len=*), intent(in) :: starttag',& - & ' logical, intent(inout) :: endtag ',& - & ' character(len=*), dimension(:,:), intent(inout) :: attribs',& - & ' integer, intent(inout) :: noattribs',& - & ' character(len=*), dimension(:), intent(inout) :: data ',& - & ' integer, intent(inout) :: nodata ',& - & ' type('//trim(typename)//'), intent(inout) :: dvar' ,& - & ' logical, intent(inout) :: has_dvar ',& - & ' ' ,& - & ' integer :: att_ ',& - & ' integer :: noatt_ ',& - & ' logical :: error ',& - & ' logical :: endtag_org' - if ( dyn_strings ) then - write( luprolog, '(a)' ) & - & ' character(len=len(starttag)) :: tag ' - else - write( luprolog, '(a)' ) & - & ' character(len=80) :: tag ' - endif - - ! - ! Note: this may require a more sophisticated approach - ! when the components of the type are also pointers ... - ! - write( ludeflt, '(a)' ) & - & 'subroutine init_xml_type_'//trim(typename)//'_array( dvar ) ',& - & ' type('//trim(typename)//'), dimension(:), pointer :: dvar ',& - & ' if ( associated( dvar ) ) then' ,& - & ' deallocate( dvar )' ,& - & ' endif' ,& - & ' allocate( dvar(0) )' ,& - & 'end subroutine init_xml_type_'//trim(typename)//'_array' ,& - & 'subroutine init_xml_type_'//trim(typename)//'(dvar)' ,& - & ' type('//trim(typename)//') :: dvar ' - - begin_loop = .true. - - call add_end_loop - - ! - ! Add the names of the two new types to the list - ! - allocate( new_types(1:4,1:notypes+3) ) - new_types(:,1:notypes) = types - deallocate( types ) - types => new_types - - types(1,notypes+1) = typename - types(2,notypes+1) = ' type('//trim(typename)//')' - types(3,notypes+1) = 'read_xml_type_'//trim(typename) - types(4,notypes+1) = 'write_xml_type_'//trim(typename) - - types(1,notypes+2) = trim(typename) // '-array' - types(2,notypes+2) = ' type('//trim(typename)//'), dimension(:), pointer' - types(3,notypes+2) = 'read_xml_type_'//trim(typename)//'_array' - types(4,notypes+2) = 'write_xml_type_'//trim(typename)//'_array' - - types(1,notypes+3) = trim(typename) // '-shape' - types(2,notypes+3) = ' type('//trim(typename)//'), dimension(SHAPE)' - types(3,notypes+3) = 'read_xml_type_'//trim(typename)//'_array' - types(4,notypes+3) = 'write_xml_type_'//trim(typename)//'_array' - - notypes = notypes + 3 - - endif -end subroutine add_typedef - -!=============================================================================== -! CLOSE_TYPEDEF -- -! Routine to write the last code fragments for a derived type -! Arguments: -! component Turn off the "component" parameter -!=============================================================================== - -subroutine close_typedef( component ) - logical, intent(out) :: component - - component = .false. - write( ludef, '(a)' ) 'end type '//trim(typename) - write( luend, '(a)' ) & - & 'end subroutine read_xml_type_'//trim(typename) - write( ludeflt, '(a)' ) & - & 'end subroutine init_xml_type_'//trim(typename) - write( luwrite, '(a)' ) & - & ' write(info%lun,''(4a)'') indentation(1:min(indent,100)), &' ,& - & ' ''''', & - & 'end subroutine write_xml_type_'//trim(typename) ,& - & ' ' - call append_files( luprolog ) - call close_tmp_files - -end subroutine close_typedef - -!=============================================================================== -! ADD_PLACEHOLDER -- -! Routine to write the starting code fragments for a placeholder tag -! Arguments: -! dyn_strings Whether dynamic string lengths are allowed -!=============================================================================== - -subroutine add_placeholder( dyn_strings ) - logical, intent(in) :: dyn_strings - - integer :: idx1 - integer :: idx2 - - character(len=32) :: tag - character(len=20) :: optional - - idx1 = xml_find_attrib( attribs, noattribs, 'tag', tag ) - if ( idx1 <= 0 ) then - write( 20, * ) 'Placeholder definition found which has no tag name' - error = .true. - endif - - optional = 'no' - idx2 = xml_find_attrib( attribs, noattribs, 'optional', optional ) - - if ( optional == 'yes' ) then - if ( begin_loop ) then - call add_begin_loop( .false., .false. ) - endif - write( luloop, '(a)' ) & - ' case('''//trim(tag)//''')',& - ' ! Simply ignore the tag' - else - no_placeholders = no_placeholders + 1 - placeholder(no_placeholders) = tag - - write( luloop, '(a)' ) & - ' case('''//trim(tag)//''')',& - &' call read_xml_place_'//trim(tag)//'( info, &', & - &' tag, attribs, noattribs, data, nodata )' - comp = .false. - - ! - ! We need a new set of temporary files - ! - call open_tmp_files( luprolog+notmps ) - - ! - ! Write the first part of the routine - ! NOTE: - ! Will require an extra argument when collecting all variables - ! in one derived type - ! - write( luprolog, '(a)' ) & - & 'subroutine read_xml_place_'//trim(tag)//& - & '( info, starttag, attribs, noattribs, data, nodata )' ,& - & ' type(XML_PARSE) :: info' ,& - & ' character(len=*), intent(in) :: starttag',& - & ' character(len=*), dimension(:,:), intent(inout) :: attribs',& - & ' integer, intent(inout) :: noattribs',& - & ' character(len=*), dimension(:), intent(inout) :: data ',& - & ' integer, intent(inout) :: nodata ',& - & ' ' ,& - & ' logical :: error ',& - & ' logical :: endtag ' - if ( dyn_strings ) then - write( luprolog, '(a)' ) & - & ' character(len=len(starttag)) :: tag ' - else - write( luprolog, '(a)' ) & - & ' character(len=80) :: tag ' - endif - - begin_loop = .true. - - call add_end_loop - - write(luwrite,'(a)') & - &'subroutine write_xml_place_'//trim(tag)//'( &' ,& - &' info, indent )' ,& - &' type(XML_PARSE) :: info' ,& - &' integer :: indent',& - &' character(len=100) :: indentation' ,& - &' indentation = '' ''' ,& - &' write(info%lun, ''(4a)'' ) indentation(1:min(indent,100)),&',& - &' ''<'// trim(tag) // '>''' - write(luwritp,'(a)') & - &' call write_xml_place_'//trim(tag)//'( info, indent+3 )' - - endif -end subroutine add_placeholder - -!=============================================================================== -! CLOSE_PLACEHOLDER -- -! Routine to write the last code fragments for a placeholder -! Arguments: -! None -!=============================================================================== - -subroutine close_placeholder - - write( luend, '(a)' ) & - & 'end subroutine read_xml_place_'//trim(placeholder(no_placeholders)) - - write( luwrite, '(a)' ) & - & ' write(info%lun,''(4a)'') indentation(1:min(indent,100)), &' ,& - & ' ''''' ,& - & 'end subroutine write_xml_place_'//trim(placeholder(no_placeholders)) ,& - & ' ' - - call append_files( luprolog ) - call close_tmp_files - - no_placeholders = no_placeholders - 1 - -end subroutine close_placeholder - -end program diff --git a/src/xml/LICENSE b/src/xml/LICENSE new file mode 100644 index 000000000..53df0326a --- /dev/null +++ b/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 , which is licensed +as shown in the file utils/fox_m_utils_mtprng.f90 + +This version of FoX is: +(c) 2005-2009 Toby White +(c) 2007-2009 Gen-Tao Chiang +(c) 2008-2012 Andrew Walker + +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
+! Ladd (hereinafter referred to as "Author") disclaims all warranties,
+! expressed or implied, including, without limitation, the warranties
+! of merchantability and of fitness for any purpose. The Author
+! assumes no liability for direct, indirect, incidental, special,
+! exemplary, or consequential damages, which may result from the use
+! of this software, even if advised of the possibility of such damage.
+!
+! The Author hereby grants anyone permission to use, copy, modify, and
+! distribute this source code, or portions hereof, for any purpose,
+! without fee, subject to the following restrictions:
+!
+! 1. The origin of this source code must not be misrepresented.
+!
+! 2. Altered versions must be plainly marked as such and must not
+! be misrepresented as being the original source.
+!
+! 3. This Copyright notice may not be removed or altered from any
+! source or altered source distribution.
+!
+! The Author specifically permits (without fee) and encourages the use
+! of this source code for entertainment, education, or decoration. If
+! you use this source code in a product, acknowledgment is not required
+! but would be appreciated. diff --git a/src/xml/Makefile b/src/xml/Makefile new file mode 100644 index 000000000..f9151178c --- /dev/null +++ b/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 diff --git a/src/xml/README b/src/xml/README new file mode 100644 index 000000000..5707d4524 --- /dev/null +++ b/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/ diff --git a/src/xml/common/FoX_common.F90 b/src/xml/common/FoX_common.F90 new file mode 100644 index 000000000..eaa7e684f --- /dev/null +++ b/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 diff --git a/src/xml/common/Makefile b/src/xml/common/Makefile new file mode 100644 index 000000000..a4874b3b5 --- /dev/null +++ b/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 diff --git a/src/xml/common/m_common_attrs.F90 b/src/xml/common/m_common_attrs.F90 new file mode 100644 index 000000000..33a2cdb48 --- /dev/null +++ b/src/xml/common/m_common_attrs.F90 @@ -0,0 +1,1081 @@ +module m_common_attrs + +#ifndef DUMMYLIB + use fox_m_fsys_array_str, only : str_vs, vs_str_alloc + use m_common_element, only: get_att_type_enum, ATT_CDATA, ATT_CDAMB, ATT_TYPES + use m_common_error, only : FoX_error, FoX_fatal + + implicit none + private + + !Initial length of dictionary + integer, parameter :: DICT_INIT_LEN = 10 + !Multiplier if we need to extend it. + real, parameter :: DICT_LEN_MULT = 1.5 + + type dict_item + character(len=1), pointer, dimension(:) :: nsURI => null() + character(len=1), pointer, dimension(:) :: localName => null() + character(len=1), pointer, dimension(:) :: prefix => null() + character(len=1), pointer, dimension(:) :: key => null() + character(len=1), pointer, dimension(:) :: value => null() + logical :: specified = .true. + logical :: declared = .false. + logical :: isId = .false. + integer :: type = 11 + end type dict_item + + type dict_item_ptr + type(dict_item), pointer :: d => null() + end type dict_item_ptr +#endif + + type dictionary_t + private +#ifndef DUMMYLIB + type(dict_item_ptr), dimension(:), pointer :: list => null() + character, dimension(:), pointer :: base => null() +#else + integer :: i +#endif + end type dictionary_t + + public :: dictionary_t + + ! Building procedures +#ifndef DUMMYLIB + public :: init_dict + public :: reset_dict + public :: add_item_to_dict + public :: destroy_dict +#endif + ! Query and extraction procedures + + ! SAX names: + public :: getIndex + public :: getLength + public :: getLocalName + public :: getQName + public :: getURI + public :: getValue + public :: getType + public :: isSpecified + public :: setSpecified + public :: isDeclared + public :: setDeclared + public :: hasKey + +#ifndef DUMMYLIB + public :: len + public :: get_key + public :: get_value + public :: remove_key + public :: has_key + public :: print_dict + + ! Namespaces + public :: get_prefix + public :: get_localName + public :: set_nsURI + public :: set_prefix + public :: set_localName +#endif + + ! For internal FoX use only: + public :: get_att_index_pointer + public :: getWhitespaceHandling + public :: setIsId + public :: getIsId + + public :: setBase + public :: getBase + + public :: sortAttrs + + interface len + module procedure getLength + end interface + + interface hasKey + module procedure has_key, has_key_ns + end interface + + interface getIndex + module procedure get_key_index, get_key_index_ns + end interface + + interface getQName + module procedure get_key + end interface + + interface getValue + module procedure get_value_by_key, get_value_by_index, get_value_by_key_ns + end interface +#ifndef DUMMYLIB + interface get_value + module procedure get_value_by_key, get_value_by_index + end interface + interface remove_key + module procedure remove_key_by_index + end interface +#endif + + interface getURI + module procedure get_nsURI_by_index + end interface +#ifndef DUMMYLIB + interface get_prefix + module procedure get_prefix_by_index + end interface +#endif + interface getLocalName + module procedure get_localName_by_index + end interface +#ifndef DUMMYLIB + interface get_localName + module procedure get_localName_by_index + end interface + interface set_nsURI + module procedure set_nsURI_by_index + end interface + interface set_prefix + module procedure set_prefix_by_index + end interface + interface set_localName + module procedure set_localName_by_index_s + module procedure set_localName_by_index_vs + end interface +#endif + + interface getType + module procedure getType_by_index + module procedure getType_by_keyname + end interface + + interface isSpecified + module procedure isSpecified_by_index + module procedure isSpecified_by_key + module procedure isSpecified_by_keyNS + end interface + + interface isDeclared + module procedure isDeclared_by_index + module procedure isDeclared_by_key + module procedure isDeclared_by_keyNS + end interface + +#ifndef DUMMYLIB + interface getIsId + module procedure getIsId_by_index + end interface + + interface setIsId + module procedure setIsId_by_index + end interface + + interface destroy + module procedure destroy_dict_item + module procedure destroy_dict + end interface + +#endif + +contains + + pure function getLength(dict) result(n) + type(dictionary_t), intent(in) :: dict + integer :: n + +#ifndef DUMMYLIB + n = ubound(dict%list, 1) +#else + n = 0 +#endif + end function getLength + + + function has_key(dict, key) result(found) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: key + logical :: found + +#ifndef DUMMYLIB + integer :: i + + do i = 1, ubound(dict%list, 1) + if (key==str_vs(dict%list(i)%d%key)) then + found = .true. + return + endif + enddo + found = .false. +#else + found = .false. +#endif + end function has_key + + function has_key_ns(dict, uri, localname) result(found) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: uri, localname + logical :: found + +#ifndef DUMMYLIB + integer :: i + found = .false. + do i = 1, ubound(dict%list, 1) + ! FIXME xlf 10.01 segfaults if the below is done as + ! an AND rather than two separate ifs. This is + ! probably due to the Heisenbug + if (uri==str_vs(dict%list(i)%d%nsURI)) then + if (localname==str_vs(dict%list(i)%d%localname)) then + found = .true. + exit + endif + endif + enddo +#else + found = .false. +#endif + end function has_key_ns + + pure function get_key_index(dict, key) result(ind) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: key + integer :: ind + +#ifndef DUMMYLIB + integer :: i + do i = 1, ubound(dict%list, 1) + if (key == str_vs(dict%list(i)%d%key)) then + ind = i + return + endif + enddo + ind = 0 +#else + ind = 0 +#endif + end function get_key_index + + pure function get_key_index_ns(dict, uri, localname) result(ind) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: uri, localname + integer :: ind + +#ifndef DUMMYLIB + integer :: i + ind = -1 + do i = 1, ubound(dict%list, 1) + if (uri==str_vs(dict%list(i)%d%nsURI) & + .and. localname==str_vs(dict%list(i)%d%localname)) then + ind = i + exit + endif + enddo +#else + ind = 0 +#endif + end function get_key_index_ns + +#ifndef DUMMYLIB + pure function get_value_by_key_len(dict, key) result(n) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: key + integer :: n + + integer :: i + + do i = 1, ubound(dict%list, 1) + if (key == str_vs(dict%list(i)%d%key)) then + n = size(dict%list(i)%d%value) + return + endif + enddo + n = 0 + end function get_value_by_key_len +#endif + + function get_value_by_key(dict, key) result(value) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: key +#ifndef DUMMYLIB + character(len=get_value_by_key_len(dict,key)) :: value + + integer :: i + + do i = 1, ubound(dict%list, 1) + if (key == str_vs(dict%list(i)%d%key)) then + value = str_vs(dict%list(i)%d%value) + return + endif + enddo + value = "" +#else + character(len=1) :: value + value = "" +#endif + end function get_value_by_key + +#ifndef DUMMYLIB + pure function get_value_by_key_ns_len(dict, nsUri, localname) result(n) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: nsUri + character(len=*), intent(in) :: localname + integer :: n + + integer :: i + + do i = 1, ubound(dict%list, 1) + if (nsUri==str_vs(dict%list(i)%d%nsURI) & + .and.localname==str_vs(dict%list(i)%d%localname)) then + n = size(dict%list(i)%d%value) + return + endif + enddo + n = 0 + end function get_value_by_key_ns_len +#endif + + function get_value_by_key_ns(dict, nsUri, localname) result(value) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: nsUri + character(len=*), intent(in) :: localname +#ifndef DUMMYLIB + character(len=get_value_by_key_ns_len(dict, nsURI, localname)) :: value + + integer :: i + + do i = 1, ubound(dict%list, 1) + if (nsUri==str_vs(dict%list(i)%d%nsURI) & + .and.localname==str_vs(dict%list(i)%d%localname)) then + value = str_vs(dict%list(i)%d%value) + return + endif + enddo + value = "" +#else + character(len=1) :: value + value = "" +#endif + end function get_value_by_key_ns + +#ifndef DUMMYLIB + subroutine get_att_index_pointer(dict, key, i, value) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: key + integer, intent(out) :: i + character, pointer :: value(:) + + value => null() + do i = 1, ubound(dict%list, 1) + if (key == str_vs(dict%list(i)%d%key)) then + value => dict%list(i)%d%value + return + endif + enddo + i = 0 + end subroutine get_att_index_pointer + + subroutine remove_key_by_index(dict, ind) + type(dictionary_t), intent(inout) :: dict + integer, intent(in) :: ind + + integer :: i, n + type(dict_item_ptr), pointer :: tempList(:) + + n = ubound(dict%list, 1) + + if (ind<=0.or.ind>n) return + + allocate(tempList(0:n-1)) + do i = 0, ind-1 + tempList(i)%d => dict%list(i)%d + enddo + call destroy(dict%list(ind)%d) + do i = ind+1, n + tempList(i-1)%d => dict%list(i)%d + enddo + deallocate(dict%list) + dict%list => tempList + end subroutine remove_key_by_index +#endif + + pure function get_value_by_index_len(dict, i) result(n) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i + integer :: n + +#ifdef DUMMYLIB + n = 1 +#else + if (i>0.and.i<=ubound(dict%list, 1)) then + n = size(dict%list(i)%d%value) + else + n = 0 + endif +#endif + end function get_value_by_index_len + + function get_value_by_index(dict, i) result(value) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i +#ifndef DUMMYLIB + character(len=get_value_by_index_len(dict, i)) :: value + + if (i>0.and.i<=ubound(dict%list, 1)) then + value = str_vs(dict%list(i)%d%value) + else + value = "" + endif +#else + character(len=1) :: value + value = "" +#endif + end function get_value_by_index + +#ifndef DUMMYLIB + pure function get_key_len(dict, i) result(n) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i + integer :: n + + if (i>0.and.i<=ubound(dict%list, 1)) then + n = size(dict%list(i)%d%key) + else + n = 0 + endif + end function get_key_len +#endif + + function get_key(dict, i) result(key) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i +#ifndef DUMMYLIB + character(len=get_key_len(dict,i)) :: key + + if (i>0.and.i<=ubound(dict%list, 1)) then + key = str_vs(dict%list(i)%d%key) + else + key = "" + endif +#else + character(len=1) :: key + key = "" +#endif + end function get_key + +#ifndef DUMMYLIB + subroutine add_item_to_dict(dict, key, value, prefix, nsURI, type, itype, specified, declared) + type(dictionary_t), intent(inout) :: dict + character(len=*), intent(in) :: key + character(len=*), intent(in) :: value + character(len=*), intent(in), optional :: prefix + character(len=*), intent(in), optional :: nsURI + character(len=*), intent(in), optional :: type + integer, intent(in), optional :: itype + logical, intent(in), optional :: specified + logical, intent(in), optional :: declared + + type(dict_item_ptr), pointer :: tempList(:) + integer :: i, n + + if (present(prefix) .eqv. .not.present(nsURI)) & + call FoX_Error('Namespace improperly specified') + + n = ubound(dict%list, 1) + allocate(tempList(0:n+1)) + do i = 0, n + tempList(i)%d => dict%list(i)%d + enddo + n = n + 1 + + allocate(tempList(n)%d) + tempList(n)%d%value => vs_str_alloc(value) + if (present(prefix)) then + tempList(n)%d%key => vs_str_alloc(prefix//":"//key) + tempList(n)%d%localname => vs_str_alloc(key) + tempList(n)%d%prefix => vs_str_alloc(prefix) + tempList(n)%d%nsURI => vs_str_alloc(nsURI) + else + tempList(n)%d%key => vs_str_alloc(key) + tempList(n)%d%localname => vs_str_alloc(key) + allocate(tempList(n)%d%prefix(0)) + allocate(tempList(n)%d%nsURI(0)) + endif + if (present(type)) then + if (present(itype)) & + call FoX_fatal("internal library error in add_item_to_dict") + tempList(n)%d%type = get_att_type_enum(type) + elseif (present(itype)) then + tempList(n)%d%type = itype + else + tempList(n)%d%type = ATT_CDAMB + endif + if (present(specified)) then + tempList(n)%d%specified = specified + else + tempList(n)%d%specified = .true. + endif + if (present(declared)) then + tempList(n)%d%declared = declared + else + tempList(n)%d%declared = .false. + endif + + deallocate(dict%list) + dict%list => tempList + + end subroutine add_item_to_dict + + subroutine set_nsURI_by_index(dict, i, nsURI) + type(dictionary_t), intent(inout) :: dict + integer, intent(in) :: i + character(len=*), intent(in) :: nsURI + + if (associated(dict%list(i)%d%nsURI)) & + deallocate(dict%list(i)%d%nsURI) + dict%list(i)%d%nsURI => vs_str_alloc(nsURI) + end subroutine set_nsURI_by_index + + subroutine set_prefix_by_index(dict, i, prefix) + type(dictionary_t), intent(inout) :: dict + integer, intent(in) :: i + character(len=*), intent(in) :: prefix + + if (associated(dict%list(i)%d%prefix)) & + deallocate(dict%list(i)%d%prefix) + dict%list(i)%d%prefix => vs_str_alloc(prefix) + end subroutine set_prefix_by_index + + subroutine set_localName_by_index_s(dict, i, localName) + type(dictionary_t), intent(inout) :: dict + integer, intent(in) :: i + character(len=*), intent(in) :: localName + + if (associated(dict%list(i)%d%localName)) & + deallocate(dict%list(i)%d%localName) + dict%list(i)%d%localName => vs_str_alloc(localName) + end subroutine set_localName_by_index_s + + subroutine set_localName_by_index_vs(dict, i, localName) + type(dictionary_t), intent(inout) :: dict + integer, intent(in) :: i + character(len=1), dimension(:), intent(in) :: localName + + if (associated(dict%list(i)%d%localName)) & + deallocate(dict%list(i)%d%localName) + allocate(dict%list(i)%d%localName(size(localName))) + dict%list(i)%d%localName = localName + end subroutine set_localName_by_index_vs +#endif + + pure function get_nsURI_by_index(dict, i) result(nsURI) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i +#ifndef DUMMYLIB + character(len=size(dict%list(i)%d%nsURI)) :: nsURI + nsURI = str_vs(dict%list(i)%d%nsURI) +#else + character(len=1) :: nsURI + nsURI = "" +#endif + end function get_nsURI_by_index + +#ifndef DUMMYLIB + pure function get_prefix_by_index(dict, i) result(prefix) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i + character(len=size(dict%list(i)%d%prefix)) :: prefix + + prefix = str_vs(dict%list(i)%d%prefix) + end function get_prefix_by_index +#endif + + pure function get_localName_by_index(dict, i) result(localName) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i +#ifndef DUMMYLIB + character(len=size(dict%list(i)%d%localName)) :: localName + localName = str_vs(dict%list(i)%d%localName) +#else + character(len=1) :: localName + localName = "" +#endif + end function get_localName_by_index + +#ifndef DUMMYLIB + pure function get_nsURI_by_keyname_len(dict, keyname) result(n) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: keyname + integer :: n + + integer :: i + + i = get_key_index(dict, keyname) + n = size(dict%list(i)%d%nsURI) + end function get_nsURI_by_keyname_len +#endif + +#ifndef DUMMYLIB + pure function get_nsURI_by_keyname(dict, keyname) result(nsURI) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: keyname + character(len=get_nsURI_by_keyname_len(dict, keyname)) :: nsURI + integer :: i + + i = get_key_index(dict, keyname) + nsURI = str_vs(dict%list(i)%d%nsURI) + end function get_nsURI_by_keyname + + pure function get_prefix_by_keyname_len(dict, keyname) result(n) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: keyname + integer :: n + + integer :: i + + i = get_key_index(dict, keyname) + n = size(dict%list(i)%d%prefix) + + end function get_prefix_by_keyname_len + + pure function get_prefix_by_keyname(dict, keyname) result(prefix) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: keyname + character(len=get_prefix_by_keyname_len(dict,keyname)) :: prefix + integer :: i + + i = get_key_index(dict, keyname) + prefix = str_vs(dict%list(i)%d%prefix) + + end function get_prefix_by_keyname + + pure function get_localname_by_keyname_len(dict, keyname) result(n) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: keyname + integer :: n + + integer :: i + + i = get_key_index(dict, keyname) + n = size(dict%list(i)%d%localName) + + end function get_localname_by_keyname_len + + pure function get_localName_by_keyname(dict, keyname) result(localName) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: keyname + character(get_localname_by_keyname_len(dict, keyname)) :: localname + integer :: i + + i=get_key_index(dict, keyname) + localName = str_vs(dict%list(i)%d%localName) + + end function get_localName_by_keyname +#endif + +#ifndef DUMMYLIB + pure function getType_by_index_len(dict, i) result(n) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i + integer :: n + + if (i>0.and.i<=ubound(dict%list, 1)) then + n = len_trim(ATT_TYPES(dict%list(i)%d%type)) + else + n = 0 + endif + end function getType_by_index_len +#endif + + function getType_by_index(dict, i) result(type) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i +#ifndef DUMMYLIB + character(len=getType_by_index_len(dict, i)) :: type + + if (i>0.and.i<=ubound(dict%list, 1)) then + type = ATT_TYPES(dict%list(i)%d%type) + else + type = "" + endif +#else + character(len=1) :: type + type = "" +#endif + end function getType_by_index + +#ifndef DUMMYLIB + pure function getType_by_keyname_len(dict, keyname) result(n) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: keyname + integer :: n + + integer :: i + i = get_key_index(dict, keyname) + + if (i>0) then + n = len_trim(ATT_TYPES(i)) + else + n = 0 + endif + end function getType_by_keyname_len +#endif + + function getType_by_keyname(dict, keyname) result(type) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: keyname +#ifndef DUMMYLIB + character(len=getType_by_keyname_len(dict, keyname)) :: type + + integer :: i + i = get_key_index(dict, keyname) + if (i>0) then + type = ATT_TYPES(dict%list(i)%d%type) + else + type = "" + endif +#else + character(len=1) :: type + type = "" +#endif + end function getType_by_keyname + + function isSpecified_by_index(dict, i) result(p) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i + logical :: p + +#ifndef DUMMYLIB + if (i>0.and.i<=ubound(dict%list, 1)) then + p = dict%list(i)%d%specified + else + p = .false. + endif +#else + p = .false. +#endif + end function isSpecified_by_index + + function isSpecified_by_key(dict, qName) result(p) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: qName + logical :: p + +#ifndef DUMMYLIB + integer :: i + i = getIndex(dict, qName) + if (i>0.and.i<=ubound(dict%list, 1)) then + p = dict%list(i)%d%specified + else + p = .false. + endif +#else + p = .false. +#endif + end function isSpecified_by_key + + subroutine setSpecified(dict, i, p) + type(dictionary_t), intent(inout) :: dict + integer, intent(in) :: i + logical, intent(in) :: p + +#ifndef DUMMYLIB + if (i>0.and.i<=ubound(dict%list, 1)) then + dict%list(i)%d%specified = p + endif +#endif + end subroutine setSpecified + + function isSpecified_by_keyNS(dict, uri, localName) result(p) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: uri + character(len=*), intent(in) :: localName + logical :: p + +#ifndef DUMMYLIB + integer :: i + i = getIndex(dict, uri, localName) + if (i>0.and.i<=ubound(dict%list, 1)) then + p = dict%list(i)%d%specified + else + p = .false. + endif +#else + p = .false. +#endif + end function isSpecified_by_keyNS + + function isDeclared_by_index(dict, i) result(p) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i + logical :: p + +#ifndef DUMMYLIB + if (i>0.and.i<=ubound(dict%list, 1)) then + p = dict%list(i)%d%declared + else + p = .false. + endif +#else + p = .false. +#endif + end function isDeclared_by_index + + function isDeclared_by_key(dict, qName) result(p) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: qName + logical :: p + +#ifndef DUMMYLIB + integer :: i + i = getIndex(dict, qName) + if (i>0.and.i<=ubound(dict%list, 1)) then + p = dict%list(i)%d%declared + else + p = .false. + endif +#else + p = .false. +#endif + end function isDeclared_by_key + + function isDeclared_by_keyNS(dict, uri, localName) result(p) + type(dictionary_t), intent(in) :: dict + character(len=*), intent(in) :: uri + character(len=*), intent(in) :: localName + logical :: p + +#ifndef DUMMYLIB + integer :: i + i = getIndex(dict, uri, localName) + if (i>0.and.i<=ubound(dict%list, 1)) then + p = dict%list(i)%d%declared + else + p = .false. + endif +#else + p = .false. +#endif + end function isDeclared_by_keyNS + + subroutine setDeclared(dict, i, p) + type(dictionary_t), intent(inout) :: dict + integer, intent(in) :: i + logical, intent(in) :: p + +#ifndef DUMMYLIB + if (i>0.and.i<=ubound(dict%list, 1)) then + dict%list(i)%d%declared = p + endif +#endif + end subroutine setDeclared + +#ifndef DUMMYLIB + function getIsId_by_index(dict, i) result(p) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i + logical :: p + + if (i>0.and.i<=ubound(dict%list, 1)) then + p = dict%list(i)%d%isId + else + p = .false. + endif + + end function getIsId_by_index + + subroutine setIsId_by_index(dict, i, p) + type(dictionary_t), intent(inout) :: dict + integer, intent(in) :: i + logical, intent(in) :: p + + if (i>0.and.i<=ubound(dict%list, 1)) then + dict%list(i)%d%isId = p + endif + end subroutine setIsId_by_index + + function getWhitespaceHandling(dict, i) result(j) + type(dictionary_t), intent(in) :: dict + integer, intent(in) :: i + integer :: j + + if (i<=ubound(dict%list, 1)) then + select case(dict%list(i)%d%type) + case (ATT_CDATA) + j = 0 ! + case (ATT_CDAMB) + j = 1 + case default + j = 2 + end select + else + j = 2 + endif + + end function getWhitespaceHandling + + subroutine setBase(dict, base) + type(dictionary_t), intent(inout) :: dict + character(len=*), intent(in) :: base + + if (associated(dict%base)) deallocate(dict%base) + dict%base => vs_str_alloc(base) + end subroutine setBase + + pure function getBase_len(dict) result(n) + type(dictionary_t), intent(in) :: dict + integer :: n + + if (associated(dict%base)) then + n = size(dict%base) + else + n = 0 + endif + end function getBase_len + + function getBase(dict) result(base) + type(dictionary_t), intent(in) :: dict + character(len=getBase_len(dict)) :: base + + if (associated(dict%base)) then + base = str_vs(dict%base) + else + base = "" + endif + end function getBase + + subroutine destroy_dict_item(d) + type(dict_item), pointer :: d + + if (associated(d)) then + deallocate(d%key) + deallocate(d%value) + deallocate(d%nsURI) + deallocate(d%prefix) + deallocate(d%localName) + deallocate(d) + endif + end subroutine destroy_dict_item + + subroutine init_dict(dict) + type(dictionary_t), intent(out) :: dict + + + allocate(dict%list(0:0)) + allocate(dict%list(0)%d) + allocate(dict%list(0)%d%key(0)) + + end subroutine init_dict + + subroutine destroy_dict(dict) + type(dictionary_t), intent(inout) :: dict + integer :: i + + if (associated(dict%list)) then + deallocate(dict%list(0)%d%key) + deallocate(dict%list(0)%d) + do i = 1, ubound(dict%list, 1) + call destroy(dict%list(i)%d) + enddo + deallocate(dict%list) + endif + if (associated(dict%base)) deallocate(dict%base) + + end subroutine destroy_dict + + + subroutine reset_dict(dict) + type(dictionary_t), intent(inout) :: dict + + call destroy_dict(dict) + call init_dict(dict) + + end subroutine reset_dict + + subroutine sortAttrs(dict) + type(dictionary_t), intent(inout) :: dict + + logical :: done(ubound(dict%list, 1)) + type(dict_item_ptr), dimension(:), pointer :: list => null() + integer :: i, j, n, firstIndex + character, pointer :: firstKey(:) + + !Ridiculously naive sort algorithm. We are unlikely + !to ever be sorting more then ten or so attributes though + + n = ubound(dict%list, 1) + + allocate(list(0:n)) + list(0)%d => dict%list(0)%d + + j = 1 + done = .false. + + firstIndex = 1 + do while (firstIndex/=0) + firstIndex = 0 + firstKey => null() + do i = 1, n + if (.not.done(i).and.str_vs(dict%list(i)%d%key)=="xmlns" & + .or. str_vs(dict%list(i)%d%prefix)=="xmlns") then + firstIndex = i + if (associated(firstKey)) then + if (llt(str_vs(dict%list(i)%d%key),str_vs(firstKey))) then + firstIndex = i + firstKey => dict%list(i)%d%key + endif + else + firstIndex = i + firstKey => dict%list(i)%d%key + endif + endif + enddo + if (firstIndex/=0) then + done(firstIndex) = .true. + list(j)%d => dict%list(firstIndex)%d + j = j + 1 + endif + enddo + + do while (any(.not.done)) + firstIndex = 0 + firstKey => null() + do i = 1, n + if (.not.done(i)) then + if (associated(firstKey)) then + if (llt(str_vs(dict%list(i)%d%key),str_vs(firstKey))) then + firstIndex = i + firstKey => dict%list(i)%d%key + endif + else + firstIndex = i + firstKey => dict%list(i)%d%key + endif + endif + enddo + done(firstIndex) = .true. + list(j)%d => dict%list(firstIndex)%d + j = j + 1 + enddo + + deallocate(dict%list) + dict%list => list + + end subroutine sortAttrs + + + subroutine print_dict(dict) + type(dictionary_t), intent(in) :: dict + + integer :: i + + do i = 1, ubound(dict%list, 1) + write(*,'(7a)') str_vs(dict%list(i)%d%key), " [ {", str_vs(dict%list(i)%d%nsURI), & + "}", str_vs(dict%list(i)%d%localName), " ] = ", str_vs(dict%list(i)%d%value) + enddo + + end subroutine print_dict + +#endif +end module m_common_attrs diff --git a/src/xml/common/m_common_buffer.F90 b/src/xml/common/m_common_buffer.F90 new file mode 100644 index 000000000..0bf518362 --- /dev/null +++ b/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 diff --git a/src/xml/common/m_common_charset.F90 b/src/xml/common/m_common_charset.F90 new file mode 100644 index 000000000..d46a95ec2 --- /dev/null +++ b/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 diff --git a/src/xml/common/m_common_content_model.F90 b/src/xml/common/m_common_content_model.F90 new file mode 100644 index 000000000..1b5df709e --- /dev/null +++ b/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 diff --git a/src/xml/common/m_common_element.F90 b/src/xml/common/m_common_element.F90 new file mode 100644 index 000000000..5eecbbfdc --- /dev/null +++ b/src/xml/common/m_common_element.F90 @@ -0,0 +1,1645 @@ +module m_common_element + +#ifndef DUMMYLIB + ! Structure and manipulation of element specification + + use fox_m_fsys_array_str, only: str_vs, vs_str_alloc, vs_vs_alloc + use fox_m_fsys_string_list, only: string_list, init_string_list, & + destroy_string_list, add_string, tokenize_to_string_list, & + registered_string + use m_common_charset, only: isInitialNameChar, isNameChar, & + upperCase, XML_WHITESPACE + use m_common_content_model, only: content_particle_t, newCP, destroyCPtree, & + OP_MIXED, OP_CHOICE, OP_SEQ, OP_NAME, & + REP_QUESTION_MARK, REP_ASTERISK, & + transformCPPlus ! , dumpCPtree ! For debugging - see below. + use m_common_error, only: error_stack, add_error, in_error + use m_common_namecheck, only: checkName, checkNames, checkNCName, & + checkNCNames, checkQName, checkNmtoken, checkNmtokens + + implicit none + private + + integer, parameter :: ST_START = 0 + integer, parameter :: ST_EMPTYANY = 1 + integer, parameter :: ST_FIRSTCHILD = 2 + integer, parameter :: ST_END = 3 + integer, parameter :: ST_PCDATA = 4 + integer, parameter :: ST_NAME = 5 + integer, parameter :: ST_CHILD = 6 + integer, parameter :: ST_AFTERBRACKET = 7 + integer, parameter :: ST_AFTERLASTBRACKET = 8 + integer, parameter :: ST_SEPARATOR = 9 + integer, parameter :: ST_AFTERNAME = 10 + integer, parameter :: ST_ATTTYPE = 11 + integer, parameter :: ST_AFTER_NOTATION = 12 + integer, parameter :: ST_NOTATION_LIST = 13 + integer, parameter :: ST_ENUMERATION = 14 + integer, parameter :: ST_ENUM_NAME = 15 + integer, parameter :: ST_AFTER_ATTTYPE_SPACE = 16 + integer, parameter :: ST_AFTER_ATTTYPE = 17 + integer, parameter :: ST_DEFAULT_DECL = 18 + integer, parameter :: ST_AFTERDEFAULTDECL = 19 + integer, parameter :: ST_DEFAULTVALUE = 20 + + integer, parameter :: ATT_NULL = 0 + + integer, parameter :: ATT_CDATA = 1 + integer, parameter :: ATT_ID = 2 + integer, parameter :: ATT_IDREF = 3 + integer, parameter :: ATT_IDREFS = 4 + integer, parameter :: ATT_ENTITY = 5 + integer, parameter :: ATT_ENTITIES = 6 + integer, parameter :: ATT_NMTOKEN = 7 + integer, parameter :: ATT_NMTOKENS = 8 + integer, parameter :: ATT_NOTATION = 9 + integer, parameter :: ATT_ENUM = 10 + integer, parameter :: ATT_CDANO = 11 + integer, parameter :: ATT_CDAMB = 12 + + character(len=8), parameter :: ATT_TYPES(12) = (/ & + "CDATA ", & + "ID ", & + "IDREF ", & + "IDREFS ", & + "ENTITY ", & + "ENTITIES", & + "NMTOKEN ", & + "NMTOKENS", & + "NOTATION", & + "ENUM ", & + "CDANO ", & + "CDAMB "/) + + integer, parameter :: ATT_REQUIRED = 1 + integer, parameter :: ATT_IMPLIED = 2 + integer, parameter :: ATT_DEFAULT = 4 + integer, parameter :: ATT_FIXED = 3 + + + type attribute_t + character, pointer :: name(:) => null() + integer :: attType = ATT_NULL + integer :: attDefault = ATT_NULL + type(string_list) :: enumerations + character, pointer :: default(:) => null() + logical :: internal = .true. + end type attribute_t + + type attribute_list + type(attribute_t), pointer :: list(:) => null() + end type attribute_list + + type element_t + character, pointer :: name(:) => null() + logical :: empty = .false. + logical :: any = .false. + logical :: mixed = .false. + logical :: id_declared = .false. + logical :: internal = .true. + type (content_particle_t), pointer :: cp => null() + character, pointer :: model(:) => null() + type(attribute_list) :: attlist + end type element_t + + type element_list + type(element_t), pointer :: list(:) => null() + end type element_list + + + public :: element_t + public :: element_list + + public :: attribute_t + public :: attribute_list + + public :: init_element_list + public :: destroy_element_list + public :: existing_element + public :: declared_element + public :: get_element + public :: add_element + + public :: parse_dtd_element + + public :: init_attribute_list + public :: destroy_attribute_list + + + public :: parse_dtd_attlist + + public :: report_declarations + + public :: attribute_has_default + public :: get_attlist_size + public :: get_attribute_declaration + public :: express_attribute_declaration + + public :: att_value_normalize + + public :: get_att_type_enum + + public :: ATT_NULL + public :: ATT_CDATA + public :: ATT_ID + public :: ATT_IDREF + public :: ATT_IDREFS + public :: ATT_ENTITY + public :: ATT_ENTITIES + public :: ATT_NMTOKEN + public :: ATT_NMTOKENS + public :: ATT_NOTATION + public :: ATT_ENUM + + public :: ATT_CDANO + public :: ATT_CDAMB + + public :: ATT_REQUIRED + public :: ATT_IMPLIED + public :: ATT_DEFAULT + public :: ATT_FIXED + + public :: ATT_TYPES + + interface get_attribute_declaration + module procedure get_attdecl_by_index + module procedure get_attdecl_by_name + end interface + +contains + + subroutine init_element_list(e_list) + type(element_list), intent(inout) :: e_list + + allocate(e_list%list(0)) + end subroutine init_element_list + + subroutine destroy_element_list(e_list) + type(element_list), intent(inout) :: e_list + + integer :: i + + do i = 1, size(e_list%list) + deallocate(e_list%list(i)%name) + if (associated(e_list%list(i)%cp)) call destroyCPtree(e_list%list(i)%cp) + if (associated(e_list%list(i)%model)) deallocate(e_list%list(i)%model) + call destroy_attribute_list(e_list%list(i)%attlist) + enddo + deallocate(e_list%list) + end subroutine destroy_element_list + + function existing_element(e_list, name) result(p) + type(element_list), intent(in) :: e_list + character(len=*), intent(in) :: name + logical :: p + + integer :: i + + p = .false. + do i = 1, size(e_list%list) + if (str_vs(e_list%list(i)%name)==name) then + p = .true. + exit + endif + enddo + end function existing_element + + function declared_element(e_list, name) result(p) + type(element_list), intent(in) :: e_list + character(len=*), intent(in) :: name + logical :: p + + integer :: i + + p = .false. + do i = 1, size(e_list%list) + if (str_vs(e_list%list(i)%name)==name) then + p = associated(e_list%list(i)%model) + exit + endif + enddo + end function declared_element + + function get_element(e_list, name) result(e) + type(element_list), intent(in) :: e_list + character(len=*), intent(in) :: name + type(element_t), pointer :: e + + integer :: i + + do i = 1, size(e_list%list) + if (str_vs(e_list%list(i)%name)==name) then + e => e_list%list(i) + return + endif + enddo + e => null() + end function get_element + + function add_element(e_list, name) result(e) + type(element_list), intent(inout) :: e_list + character(len=*), intent(in) :: name + type(element_t), pointer :: e + + type(element_t), pointer :: temp(:) + integer :: i + + temp => e_list%list + + allocate(e_list%list(size(temp)+1)) + do i = 1, size(temp) + e_list%list(i)%name => temp(i)%name + e_list%list(i)%model => temp(i)%model + e_list%list(i)%empty = temp(i)%empty + e_list%list(i)%any = temp(i)%any + e_list%list(i)%mixed = temp(i)%mixed + e_list%list(i)%cp => temp(i)%cp + e_list%list(i)%id_declared = temp(i)%id_declared + e_list%list(i)%internal = temp(i)%internal + e_list%list(i)%attlist%list => temp(i)%attlist%list + enddo + deallocate(temp) + e => e_list%list(i) + e%name => vs_str_alloc(name) + call init_attribute_list(e%attlist) + + end function add_element + + subroutine parse_dtd_element(contents, xv, stack, element, internal) + character(len=*), intent(in) :: contents + integer, intent(in) :: xv + type(error_stack), intent(inout) :: stack + type(element_t), pointer :: element + logical, intent(in) :: internal + + integer :: state + integer :: i, nbrackets + logical :: mixed, empty, any + character :: c + character, pointer :: order(:), name(:), temp(:) + type(content_particle_t), pointer :: top, current, tcp + logical :: mixed_additional, firstChild + + ! FIXME should we check namespaces here (for element names) + ! checking duplicates - valid or wf? - and only for MIXED? + + order => null() + name => null() + temp => null() + + any = .false. + empty = .false. + mixed = .false. + nbrackets = 0 + mixed_additional = .false. + firstChild = .true. + state = ST_START + + top => null() + + do i = 1, len(contents) + 1 + if (i<=len(contents)) then + c = contents(i:i) + else + c = ' ' + endif + + if (state==ST_START) then + !write(*,*)'ST_START' + if (verify(c, XML_WHITESPACE)==0) then + continue + elseif (verify(c, 'EMPTYANY')==0) then + name => vs_str_alloc(c) + state = ST_EMPTYANY + elseif (c=='(') then + order => vs_str_alloc(" ") + nbrackets = 1 + top => newCP() + current => top + state = ST_FIRSTCHILD + else + call add_error(stack, & + 'Unexpected character "'//c//'" at start of ELEMENT specification') + goto 100 + endif + + elseif (state==ST_EMPTYANY) then + !write(*,*)'ST_EMPTYANY' + if (verify(c, upperCase)==0) then + temp => name + name => vs_str_alloc(str_vs(temp)//c) + deallocate(temp) + elseif (verify(c, XML_WHITESPACE)==0) then + if (str_vs(name)=='EMPTY') then + empty = .true. + top => newCP(empty=.true.) + current => top + elseif (str_vs(name)=='ANY') then + any = .true. + top => newCP(any=.true.) + current => top + else + call add_error(stack, & + 'Unexpected ELEMENT specification; expecting EMPTY or ANY') + goto 100 + endif + deallocate(name) + state = ST_END + else + call add_error(stack, & + 'Unexpected ELEMENT specification; expecting EMPTY or ANY') + goto 100 + endif + + elseif (state==ST_FIRSTCHILD) then + !write(*,*)'ST_FIRSTCHILD' + if (verify(c, XML_WHITESPACE)==0) cycle + if (c=='#') then + mixed = .true. + state = ST_PCDATA + name => vs_str_alloc("") + elseif (isInitialNameChar(c, xv)) then + allocate(name(1)) + name(1) = c + state = ST_NAME + elseif (c=='(') then + nbrackets = nbrackets + 1 + deallocate(order) + tcp => newCP() + current%firstChild => tcp + tcp%parent => current + current => tcp + order => vs_str_alloc(" ") + state = ST_CHILD + else + call add_error(stack, & + 'Unexpected character in ELEMENT specification') + goto 100 + endif + + elseif (state==ST_PCDATA) then + !write(*,*)'ST_PCDATA' + if (verify(c, 'PCDATA')==0) then + temp => name + name => vs_str_alloc(str_vs(temp)//c) + deallocate(temp) + elseif (verify(c, XML_WHITESPACE)==0) then + if (str_vs(name)=='PCDATA') then + deallocate(name) + else + call add_error(stack, & + 'Unexpected token after #') + goto 100 + endif + ! Must be first child + current%operator = OP_MIXED + tcp => newCP(name="#PCDATA") + current%firstChild => tcp + tcp%parent => current + current => tcp + firstChild = .false. + state = ST_SEPARATOR + elseif (c==')') then + if (str_vs(name)=='PCDATA') then + deallocate(name) + nbrackets = 0 + state = ST_AFTERLASTBRACKET + deallocate(order) + else + call add_error(stack, & + 'Unexpected token after #') + goto 100 + endif + ! Must be first child + current%operator = OP_MIXED + tcp => newCP(name="#PCDATA") + current%firstChild => tcp + tcp%parent => current + firstChild = .false. + elseif (c=='|') then + if (str_vs(name)=='PCDATA') then + firstChild = .false. + deallocate(name) + else + call add_error(stack, & + 'Unexpected token after #') + goto 100 + endif + ! Must be first child + current%operator = OP_MIXED + tcp => newCP(name="#PCDATA") + current%firstChild => tcp + tcp%parent => current + current => tcp + firstChild = .false. + order(1) = '|' + state = ST_CHILD + elseif (c==',') then + call add_error(stack, & + 'Ordered specification not allowed for Mixed elements') + goto 100 + else + call add_error(stack, & + 'Unexpected character in ELEMENT specification') + goto 100 + endif + + elseif (state==ST_NAME) then + !write(*,*)'ST_NAME' + if (isNameChar(c, xv)) then + temp => name + name => vs_str_alloc(str_vs(temp)//c) + deallocate(temp) + elseif (scan(c, "?+*")>0) then + if (mixed) then + call add_error(stack, & + 'Repeat operators forbidden for Mixed elements') + goto 100 + endif + tcp => newCP(name=str_vs(name), repeat=c) + deallocate(name) + if (firstChild) then + current%firstChild => tcp + tcp%parent => current + firstChild = .false. + else + current%nextSibling => tcp + tcp%parent => current%parent + endif + current => tcp + if (c=="+") call transformCPPlus(current) + state = ST_SEPARATOR + elseif (verify(c, XML_WHITESPACE)==0) then + if (mixed) mixed_additional = .true. + tcp => newCP(name=str_vs(name)) + deallocate(name) + if (firstChild) then + current%firstChild => tcp + tcp%parent => current + firstChild = .false. + else + current%nextSibling => tcp + tcp%parent => current%parent + endif + current => tcp + state = ST_SEPARATOR + elseif (scan(c,',|')>0) then + if (order(nbrackets)=='') then + order(nbrackets)=c + elseif (order(nbrackets)/=c) then + call add_error(stack, & + 'Cannot mix ordered and unordered elements') + goto 100 + endif + if (mixed) mixed_additional = .true. + tcp => newCP(name=str_vs(name)) + deallocate(name) + if (firstChild) then + current%firstChild => tcp + tcp%parent => current + firstChild = .false. + else + current%nextSibling => tcp + tcp%parent => current%parent + endif + current => tcp + if (c=="|".and.current%parent%operator/=OP_MIXED) & + current%parent%operator = OP_CHOICE + state = ST_CHILD + elseif (c==')') then + if (mixed) mixed_additional = .true. + nbrackets = nbrackets - 1 + if (nbrackets==0) then + state = ST_AFTERLASTBRACKET + deallocate(order) + else + temp => order + allocate(order(nbrackets)) + order = temp(:size(order)) + deallocate(temp) + state = ST_AFTERBRACKET + endif + tcp => newCP(name=str_vs(name)) + deallocate(name) + if (firstChild) then + current%firstChild => tcp + tcp%parent => current + firstChild = .false. + else + current%nextSibling => tcp + tcp%parent => current%parent + current => current%parent + if (.not.check_duplicates(current)) & + goto 100 + endif + else + call add_error(stack, & + 'Unexpected character found after element name') + goto 100 + endif + + elseif (state==ST_CHILD) then + !write(*,*)'ST_CHILD' + if (verify(c, XML_WHITESPACE)==0) cycle + if (c=='#') then + call add_error(stack, & + '# forbidden except as first child element') + goto 100 + elseif (isInitialNameChar(c, xv)) then + name => vs_str_alloc(c) + state = ST_NAME + elseif (c=='(') then + if (mixed) then + call add_error(stack, & + 'Nested brackets forbidden for Mixed content') + goto 100 + endif + tcp => newCP() + if (firstChild) then + current%firstChild => tcp + tcp%parent => current + else + current%nextSibling => tcp + tcp%parent => current%parent + firstChild = .true. + endif + current => tcp + nbrackets = nbrackets + 1 + temp => order + order => vs_str_alloc(str_vs(temp)//" ") + deallocate(temp) + else + call add_error(stack, & + 'Unexpected character "'//c//'" found after (') + goto 100 + endif + + elseif (state==ST_SEPARATOR) then + !write(*,*)'ST_SEPARATOR' + if (verify(c, XML_WHITESPACE)==0) cycle + if (c=='#') then + call add_error(stack, & + '#PCDATA must be first in list') + goto 100 + elseif (scan(c,'|,')>0) then + if (order(nbrackets)=='') then + order(nbrackets) = c + elseif (order(nbrackets)/=c) then + call add_error(stack, & + 'Cannot mix ordered and unordered elements') + goto 100 + endif + if (c=="|".and.current%parent%operator/=OP_MIXED) & + current%parent%operator = OP_CHOICE + state = ST_CHILD + elseif (c==')') then + nbrackets = nbrackets - 1 + if (nbrackets==0) then + state = ST_AFTERLASTBRACKET + deallocate(order) + else + temp => order + allocate(order(nbrackets)) + order = temp(:size(order)) + deallocate(temp) + state = ST_AFTERBRACKET + endif + current => current%parent + if (.not.check_duplicates(current)) & + goto 100 + else + call add_error(stack, & + 'Unexpected character found in element declaration.') + goto 100 + endif + + elseif (state==ST_AFTERBRACKET) then + !write(*,*)'ST_AFTERBRACKET' + if (c=='*') then + current%repeater = REP_ASTERISK + state = ST_SEPARATOR + elseif (c=='+') then + call transformCPPlus(current) + state = ST_SEPARATOR + elseif (c=='?') then + current%repeater = REP_QUESTION_MARK + state = ST_SEPARATOR + elseif (verify(c, XML_WHITESPACE)==0) then + state = ST_SEPARATOR + elseif (scan(c,'|,')>0) then + if (order(nbrackets)=='') then + order(nbrackets) = c + elseif (order(nbrackets)/=c) then + call add_error(stack, & + 'Cannot mix ordered and unordered elements') + goto 100 + endif + if (c=="|".and.current%parent%operator/=OP_MIXED) & + current%parent%operator = OP_CHOICE + state = ST_CHILD + elseif (c==')') then + nbrackets = nbrackets - 1 + if (nbrackets==0) then + deallocate(order) + state = ST_AFTERLASTBRACKET + else + temp => order + allocate(order(nbrackets)) + order = temp(:size(order)) + deallocate(temp) + state = ST_AFTERBRACKET + endif + current => current%parent + if (.not.check_duplicates(current)) & + goto 100 + else + call add_error(stack, & + 'Unexpected character "'//c//'"found after ")"') + goto 100 + endif + + elseif (state==ST_AFTERLASTBRACKET) then + !write(*,*)'ST_AFTERLASTBRACKET' + if (c=='*') then + state = ST_END + current%repeater = REP_ASTERISK + elseif (c=='+') then + if (mixed) then + call add_error(stack, & + '+ operator disallowed for Mixed elements') + goto 100 + endif + call transformCPPlus(current) + state = ST_END + elseif (c=='?') then + if (mixed) then + call add_error(stack, & + '? operator disallowed for Mixed elements') + goto 100 + endif + current%repeater = REP_QUESTION_MARK + state = ST_END + elseif (verify(c, XML_WHITESPACE)==0) then + if (mixed) then + if (mixed_additional) then + call add_error(stack, & + 'Missing "*" at end of Mixed element specification') + goto 100 + endif + endif + state = ST_END + else + call add_error(stack, & + 'Unexpected character "'//c//'" found after final ")"') + goto 100 + endif + + elseif (state==ST_END) then + !write(*,*)'ST_END' + if (verify(c, XML_WHITESPACE)==0) then + continue + else + call add_error(stack, & + 'Unexpected token found after end of element specification') + goto 100 + endif + + endif + + enddo + + if (state/=ST_END) then + call add_error(stack, "Error in parsing contents of element declaration") + goto 100 + endif + + if (associated(element)) then + element%any = any + element%empty = empty + element%mixed = mixed + element%model => vs_str_alloc(trim(strip_spaces(contents))) + element%cp => top + element%internal = internal +! For debugging it may be useful to dump the result here... +! Also need to use the subroutine. +! call dumpCPtree(top) + else + if (associated(top)) call destroyCPtree(top) + endif + return + +100 if (associated(order)) deallocate(order) + if (associated(name)) deallocate(name) + if (associated(top)) call destroyCPtree(top) + + contains + function strip_spaces(s1) result(s2) + character(len=*) :: s1 + character(len=len(s1)) :: s2 + integer :: i, i2 + i2 = 1 + do i = 1, len(s1) + if (verify(s1(i:i), XML_WHITESPACE)==0) cycle + s2(i2:i2) = s1(i:i) + i2 = i2 + 1 + end do + s2(i2:) = '' + end function strip_spaces + + function check_duplicates(cp) result(p) + type(content_particle_t), pointer :: cp + logical :: p + + type(string_list) :: sl + type(content_particle_t), pointer :: tcp + + if (cp%operator==OP_SEQ) then + p = .true. + return + endif + + call init_string_list(sl) + tcp => cp%firstChild + p = .false. + do while (associated(tcp)) + if (tcp%operator==OP_NAME) then + if (registered_string(sl, str_vs(tcp%name))) then + call destroy_string_list(sl) + if (cp%operator==OP_MIXED) then + call add_error(stack, & + "Duplicate element names found in MIXED") + elseif (cp%operator==OP_CHOICE) then + call add_error(stack, & + "Duplicate element names found in CHOICE") + endif + return + else + call add_string(sl, str_vs(tcp%name)) + endif + endif + tcp => tcp%nextSibling + enddo + p = .true. + call destroy_string_list(sl) + end function check_duplicates + end subroutine parse_dtd_element + + + subroutine init_attribute_list(a_list) + type(attribute_list), intent(inout) :: a_list + + allocate(a_list%list(0)) + end subroutine init_attribute_list + + subroutine destroy_attribute_t(a) + type(attribute_t), pointer :: a + + if (associated(a%name)) deallocate(a%name) + if (associated(a%default)) deallocate(a%default) + call destroy_string_list(a%enumerations) + + deallocate(a) + end subroutine destroy_attribute_t + + subroutine destroy_attribute_list(a_list) + type(attribute_list), intent(inout) :: a_list + + integer :: i + + do i = 1, size(a_list%list) + deallocate(a_list%list(i)%name) + if (associated(a_list%list(i)%default)) deallocate(a_list%list(i)%default) + call destroy_string_list(a_list%list(i)%enumerations) + enddo + deallocate(a_list%list) + + end subroutine destroy_attribute_list + + function existing_attribute(a_list, name) result(p) + type(attribute_list), intent(inout) :: a_list + character(len=*), intent(in) :: name + logical :: p + + integer :: i + p = .false. + do i = 1, size(a_list%list) + p = (str_vs(a_list%list(i)%name)==name) + if (p) exit + enddo + end function existing_attribute + + function add_attribute(a_list, name, internal) result(a) + type(attribute_list), intent(inout) :: a_list + character(len=*), intent(in) :: name + logical, intent(in) :: internal + type(attribute_t), pointer :: a + + integer :: i + type(attribute_t), pointer :: temp(:) + + temp => a_list%list + allocate(a_list%list(size(temp)+1)) + do i = 1, size(temp) + a_list%list(i)%name => temp(i)%name + a_list%list(i)%atttype = temp(i)%atttype + a_list%list(i)%attdefault = temp(i)%attdefault + a_list%list(i)%default => temp(i)%default + a_list%list(i)%enumerations%list => temp(i)%enumerations%list + a_list%list(i)%internal = temp(i)%internal + enddo + deallocate(temp) + a => a_list%list(i) + + a%name => vs_str_alloc(name) + call init_string_list(a%enumerations) + a%internal = internal + + end function add_attribute + + function get_attribute(a_list, name) result(a) + type(attribute_list), intent(inout) :: a_list + character(len=*), intent(in) :: name + type(attribute_t), pointer :: a + + integer :: i + do i = 1, size(a_list%list) + if (str_vs(a_list%list(i)%name)==name) then + a => a_list%list(i) + exit + endif + enddo + end function get_attribute + + subroutine parse_dtd_attlist(contents, xv, namespaces, validCheck, stack, elem, internal) + character(len=*), intent(in) :: contents + integer, intent(in) :: xv + logical, intent(in) :: validCheck + logical, intent(in) :: namespaces + type(error_stack), intent(inout) :: stack + type(element_t), pointer :: elem + logical, intent(in) :: internal + + integer :: i + integer :: state + character :: c, q + character, pointer :: name(:), attType(:), default(:), value(:), temp(:) + + type(attribute_t), pointer :: ca + type(attribute_t), pointer :: ignore_att + + ignore_att => null() + ! We need ignore_att to process but not take account of duplicate attributes + ! elem is optional so we can not record declarations if necessary. + ca => null() + name => null() + attType => null() + default => null() + value => null() + temp => null() + + state = ST_START + + do i = 1, len(contents) + 1 + if (in_error(stack)) exit + if (i<=len(contents)) then + c = contents(i:i) + else + c = " " + endif + + if (state==ST_START) then + !write(*,*)'ST_START' + if (verify(c, XML_WHITESPACE)==0) cycle + if (isInitialNameChar(c, xv)) then + name => vs_str_alloc(c) + state = ST_NAME + else + call add_error(stack, & + 'Unexpected character in Attlist') + endif + + elseif (state==ST_NAME) then + !write(*,*)'ST_NAME' + if (isNameChar(c, xv)) then + temp => vs_str_alloc(str_vs(name)//c) + deallocate(name) + name => temp + elseif (verify(c, XML_WHITESPACE)==0) then + if (namespaces.and..not.checkQName(str_vs(name), xv)) then + call add_error(stack, & + "Attribute name in ATTLIST must be QName") + elseif (associated(elem)) then + if (existing_attribute(elem%attlist, str_vs(name))) then + if (associated(ignore_att)) call destroy_attribute_t(ignore_att) + allocate(ignore_att) + call init_string_list(ignore_att%enumerations) + ignore_att%name => vs_vs_alloc(name) + ca => ignore_att + else + ca => add_attribute(elem%attlist, str_vs(name), internal) + endif + else + if (associated(ignore_att)) call destroy_attribute_t(ignore_att) + allocate(ignore_att) + call init_string_list(ignore_att%enumerations) + ignore_att%name => vs_vs_alloc(name) + ca => ignore_att + endif + deallocate(name) + state = ST_AFTERNAME + else + call add_error(stack, & + 'Unexpected character in Attlist Name') + endif + + elseif (state==ST_AFTERNAME) then + !write(*,*)'ST_AFTERNAME' + if (verify(c, XML_WHITESPACE)==0) cycle + if (verify(c, upperCase)==0) then + attType => vs_str_alloc(c) + state = ST_ATTTYPE + elseif (c=='(') then + allocate(value(0)) + ca%attType = ATT_ENUM + state = ST_ENUMERATION + else + call add_error(stack, & + 'Unexpected error after Attlist Name') + endif + + elseif (state==ST_ATTTYPE) then + !write(*,*)'ST_ATTTYPE' + if (verify(c, upperCase)==0) then + temp => attType + attType => vs_str_alloc(str_vs(temp)//c) + deallocate(temp) + elseif (verify(c, XML_WHITESPACE)==0) then + ! xml:id constraint + if (str_vs(ca%name)=="xml:id" & + .and..not.str_vs(attType)=="ID") then + call add_error(stack, & + "xml:id attribute must be declared as type ID") + elseif (str_vs(attType)=='CDATA') then + ca%attType = ATT_CDATA + state = ST_AFTER_ATTTYPE + elseif (str_vs(attType)=='ID') then + if (validCheck) then + ! Validity Constraint: One ID per Element Type + if (associated(elem)) then + if (elem%id_declared) then + call add_error(stack, & + "Cannot have two declared attributes of type ID on one element type.") + else + elem%id_declared = .true. + endif + endif + endif + ca%attType = ATT_ID + state = ST_AFTER_ATTTYPE + elseif (str_vs(attType)=='IDREF') then + ca%attType = ATT_IDREF + state = ST_AFTER_ATTTYPE + elseif (str_vs(attType)=='IDREFS') then + ca%attType = ATT_IDREFS + state = ST_AFTER_ATTTYPE + elseif (str_vs(attType)=='ENTITY') then + ca%attType = ATT_ENTITY + state = ST_AFTER_ATTTYPE + elseif (str_vs(attType)=='ENTITIES') then + ca%attType = ATT_ENTITIES + state = ST_AFTER_ATTTYPE + elseif (str_vs(attType)=='NMTOKEN') then + ca%attType = ATT_NMTOKEN + state = ST_AFTER_ATTTYPE + elseif (str_vs(attType)=='NMTOKENS') then + ca%attType = ATT_NMTOKENS + state = ST_AFTER_ATTTYPE + elseif (str_vs(attType)=='NOTATION') then + ca%attType = ATT_NOTATION + state = ST_AFTER_NOTATION + else + call add_error(stack, & + 'Unknown AttType') + endif + deallocate(attType) + else + call add_error(stack, & + 'Unexpected character in AttType') + endif + + elseif (state==ST_AFTER_NOTATION) then + !write(*,*)'ST_AFTER_NOTATION' + if (verify(c, XML_WHITESPACE)==0) cycle + if (c=='(') then + state = ST_NOTATION_LIST + else + call add_error(stack, & + 'Unexpected character after Notation') + endif + + elseif (state==ST_NOTATION_LIST) then + !write(*,*)'ST_NOTATION_LIST' + if (verify(c, XML_WHITESPACE)==0) cycle + if (isInitialNameChar(c, xv)) then + value => vs_str_alloc(c) + state = ST_ENUM_NAME + else + call add_error(stack, & + 'Unexpected character in Notation list') + endif + + elseif (state==ST_ENUMERATION) then + !write(*,*)'ST_ENUMERATION' + if (verify(c, XML_WHITESPACE)==0) cycle + if (isNameChar(c, xv)) then + temp => vs_str_alloc(str_vs(value)//c) + deallocate(value) + value => temp + state = ST_ENUM_NAME + elseif (c=='|') then + call add_error(stack, & + "Missing token in Enumeration") + elseif (c==')') then + call add_error(stack, & + "Missing tokens in Enumeration") + else + call add_error(stack, & + 'Unexpected character in attlist enumeration') + endif + + elseif (state==ST_ENUM_NAME) then + !write(*,*)'ST_ENUM_NAME' + if (isNameChar(c, xv)) then + temp => vs_str_alloc(str_vs(value)//c) + deallocate(value) + value => temp + elseif (verify(c, XML_WHITESPACE)==0) then + if (validCheck.and.registered_string(ca%enumerations, str_vs(value))) then + call add_error(stack, & + "Duplicate enumeration value in ATTLIST") + elseif (namespaces.and.ca%attType==ATT_NOTATION & + .and..not.checkNCName(str_vs(value), xv)) then + call add_error(stack, & + "Notation name must be NCName") + else + call add_string(ca%enumerations, str_vs(value)) + endif + deallocate(value) + state = ST_SEPARATOR + elseif (c=='|') then + if (validCheck.and.registered_string(ca%enumerations, str_vs(value))) then + call add_error(stack, & + "Duplicate enumeration value in ATTLIST") + elseif (namespaces.and.ca%attType==ATT_NOTATION & + .and..not.checkNCName(str_vs(value), xv)) then + call add_error(stack, & + "Notation name must be NCName") + else + call add_string(ca%enumerations, str_vs(value)) + endif + deallocate(value) + if (ca%attType==ATT_NOTATION) then + state = ST_NOTATION_LIST + else + allocate(value(0)) + state = ST_ENUMERATION + endif + elseif (c==')') then + if (size(value)==0) then + call add_error(stack, & + 'Missing token in Enumeration list') + endif + if (validCheck.and.registered_string(ca%enumerations, str_vs(value))) then + call add_error(stack, & + "Duplicate enumeration value in ATTLIST") + elseif (namespaces.and.ca%attType==ATT_NOTATION & + .and..not.checkNCName(str_vs(value), xv)) then + call add_error(stack, & + "Notation name must be NCName") + else + call add_string(ca%enumerations, str_vs(value)) + endif + deallocate(value) + state = ST_AFTER_ATTTYPE_SPACE + else + call add_error(stack, & + 'Unexpected character in attlist enumeration') + endif + + elseif (state==ST_SEPARATOR) then + !write(*,*)'ST_SEPARATOR' + if (verify(c, XML_WHITESPACE)==0) cycle + if (c=='|') then + if (ca%attType==ATT_NOTATION) then + state = ST_NOTATION_LIST + else + allocate(value(0)) + state = ST_ENUMERATION + endif + elseif (c==')') then + state = ST_AFTER_ATTTYPE_SPACE + else + call add_error(stack, & + 'Unexpected character in attlist enumeration') + endif + + elseif (state==ST_AFTER_ATTTYPE_SPACE) then + if (verify(c, XML_WHITESPACE)/=0) then + call add_error(stack, & + 'Missing whitespace in attlist enumeration') + endif + state = ST_AFTER_ATTTYPE + + elseif (state==ST_AFTER_ATTTYPE) then + !write(*,*)'ST_AFTER_ATTTYPE' + if (verify(c, XML_WHITESPACE)==0) cycle + if (c=='#') then + allocate(default(0)) + state = ST_DEFAULT_DECL + elseif (c=='"'.or.c=="'") then + if (validCheck) then + ! Validity Constraint: ID Attribute Default + if (ca%attType==ATT_ID) & + call add_error(stack, & + "Attribute of type ID may not have default value") + endif + ca%attDefault = ATT_DEFAULT + q = c + allocate(value(0)) + state = ST_DEFAULTVALUE + else + call add_error(stack, & + 'Unexpected character after AttType') + endif + + elseif (state==ST_DEFAULT_DECL) then + !write(*,*)'ST_DEFAULT_DECL' + if (verify(c, upperCase)==0) then + temp => vs_str_alloc(str_vs(default)//c) + deallocate(default) + default => temp + elseif (verify(c, XML_WHITESPACE)==0) then + if (str_vs(default)=='REQUIRED') then + ca%attdefault = ATT_REQUIRED + deallocate(default) + state = ST_START + elseif (str_vs(default)=='IMPLIED') then + ca%attdefault = ATT_IMPLIED + deallocate(default) + state = ST_START + elseif (str_vs(default)=='FIXED') then + if (validCheck) then + ! Validity Constraint: ID Attribute Default + if (ca%attType==ATT_ID) & + call add_error(stack, & + "Attribute of type ID may not have FIXED value") + endif + ca%attdefault = ATT_FIXED + deallocate(default) + state = ST_AFTERDEFAULTDECL + else + call add_error(stack, & + 'Unknown Default declaration') + endif + else + call add_error(stack, & + 'Unexpected character in Default declaration') + endif + + elseif (state==ST_AFTERDEFAULTDECL) then + !write(*,*)'ST_AFTERDEFAULTDECL' + if (verify(c, XML_WHITESPACE)==0) cycle + if (c=='"') then + q = c + allocate(value(0)) + state = ST_DEFAULTVALUE + elseif (c=="'") then + q = c + allocate(value(0)) + state = ST_DEFAULTVALUE + else + call add_error(stack, & + 'Unexpected character after Default declaration') + endif + + elseif (state==ST_DEFAULTVALUE) then + !write(*,*)'ST_DEFAULTVALUE' + if (c==q) then + if (ca%attType/=ATT_CDATA) then + temp => vs_str_alloc(att_value_normalize(str_vs(value))) + deallocate(value) + value => temp + endif + if (validCheck) then + select case(ca%attType) + ! Can't have ID with defaults + case (ATT_IDREF) + ! VC: IDREF + if (namespaces) then + if (.not.checkNCName(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type IDREF must have a value which is an XML NCName") + else + if (.not.checkName(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type IDREF must have a value which is an XML Name") + endif + case (ATT_IDREFS) + ! VC: IDREF + if (namespaces) then + if (.not.checkNCNames(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type IDREFS must have a value which contains only XML NCNames") + else + if (.not.checkNames(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type IDREFS must have a value which contains only XML Names") + endif + case (ATT_ENTITY) + ! VC: Entity Name + if (namespaces) then + if (.not.checkNCName(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type ENTITY must have a value which is an XML NCName") + else + if (.not.checkName(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type ENTITY must have a value which is an XML Name") + endif + case (ATT_ENTITIES) + ! VC: Entity Name + if (namespaces) then + if (.not.checkNames(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type ENTITIES must have a value which contains only XML NCNames") + else + if (.not.checkNames(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type ENTITIES must have a value which contains only XML Names") + endif + case (ATT_NMTOKEN) + ! VC Name Token + if (.not.checkNmtoken(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type NMTOKEN must have a value which is a NMTOKEN") + case (ATT_NMTOKENS) + ! VC: Name Token + if (.not.checkNmtokens(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type NMTOKENS must have a value which contain only NMTOKENs") + case (ATT_NOTATION) + ! VC: Notation Attributes + if (namespaces) then + if (.not.checkNCName(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type NOTATION must have a value which is an XMLNCName") + else + if (.not.checkName(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type NOTATION must have a value which is an XML Name") + endif + case (ATT_ENUM) + ! VC: Enumeration + if (.not.checkNmtoken(str_vs(value), xv)) & + call add_error(stack, & + "Attributes of type ENUM must have a value which is an NMTOKENs") + if (.not.registered_string(ca%enumerations, str_vs(value))) & + call add_error(stack, & + "Default value of ENUM does not match permitted values") + end select + endif + if (.not.in_error(stack)) then + if (ca%attType==ATT_ENTITIES) then + call destroy_string_list(ca%enumerations) + ca%enumerations = tokenize_to_string_list(str_vs(value)) + endif + ca%default => value + value => null() + state = ST_START + endif + else + temp => vs_str_alloc(str_vs(value)//c) + deallocate(value) + value => temp + endif + + endif + + enddo + + if (associated(ignore_att)) call destroy_attribute_t(ignore_att) + + if (.not.in_error(stack)) then + if (state==ST_START) then + return + else + call add_error(stack, & + 'Incomplete Attlist declaration') + endif + endif + + if (associated(name)) deallocate(name) + if (associated(attType)) deallocate(attType) + if (associated(default)) deallocate(default) + if (associated(value)) deallocate(value) + + end subroutine parse_dtd_attlist + + subroutine report_declarations(elem, attributeDecl_handler) + type(element_t), intent(in) :: elem + interface + subroutine attributeDecl_handler(eName, aName, type, mode, value) + character(len=*), intent(in) :: eName + character(len=*), intent(in) :: aName + character(len=*), intent(in) :: type + character(len=*), intent(in), optional :: mode + character(len=*), intent(in), optional :: value + end subroutine attributeDecl_handler + end interface + + integer :: i + character(len=8) :: type + character(len=8) :: mode + type(attribute_t), pointer :: a + + do i = 1, size(elem%attlist%list) + a => elem%attlist%list(i) + type = ATT_TYPES(a%attType) + select case (a%attDefault) + case (ATT_REQUIRED) + mode = "REQUIRED" + case (ATT_IMPLIED) + mode = "IMPLIED" + case (ATT_FIXED) + mode = "FIXED" + end select + + if (a%attType==ATT_NOTATION) then + if (a%attDefault==ATT_DEFAULT) then + if (associated(a%default)) then + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + 'NOTATION '//make_token_group(a%enumerations), value=str_vs(a%default)) + else + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + 'NOTATION '//make_token_group(a%enumerations)) + endif + else + if (associated(a%default)) then + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + 'NOTATION '//make_token_group(a%enumerations), mode=trim(mode), & + value=str_vs(a%default)) + else + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + 'NOTATION '//make_token_group(a%enumerations), mode=trim(mode)) + endif + endif + elseif (a%attType==ATT_ENUM) then + if (a%attDefault==ATT_DEFAULT) then + if (associated(a%default)) then + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + make_token_group(a%enumerations), value=str_vs(a%default)) + else + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + make_token_group(a%enumerations)) + endif + else + if (associated(a%default)) then + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + make_token_group(a%enumerations), mode=trim(mode), & + value=str_vs(a%default)) + else + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + make_token_group(a%enumerations), mode=trim(mode)) + endif + endif + else + if (a%attDefault==ATT_DEFAULT) then + if (associated(a%default)) then + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + trim(type), value=str_vs(a%default)) + else + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + trim(type)) + endif + else + if (associated(a%default)) then + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + trim(type), mode=trim(mode), value=str_vs(a%default)) + else + call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & + trim(type), mode=trim(mode)) + endif + endif + endif + enddo + + + end subroutine report_declarations + + pure function make_token_group_len(s_list) result(n) + type(string_list), intent(in) :: s_list + integer :: n + + integer :: i + n = size(s_list%list) + 1 + do i = 1, size(s_list%list) + n = n + size(s_list%list(i)%s) + enddo + end function make_token_group_len + + function make_token_group(s_list) result(s) + type(string_list), intent(in) :: s_list + character(len=make_token_group_len(s_list)) :: s + + integer :: i, m, n + s(1:1) = '(' + n = 2 + do i = 1, size(s_list%list)-1 + m = size(s_list%list(i)%s) + s(n:n+m) = str_vs(s_list%list(i)%s)//'|' + n = n + m + 1 + enddo + s(n:) = str_vs(s_list%list(i)%s)//')' + end function make_token_group + + function attribute_has_default(att) result(p) + type(attribute_t), pointer :: att + logical :: p + + if (associated(att)) then + p = att%attDefault==ATT_DEFAULT.or.att%attDefault==ATT_FIXED + else + p = .false. + endif + end function attribute_has_default + + function get_attlist_size(elem) result(n) + type(element_t), pointer :: elem + integer :: n + + if (associated(elem)) then + n = size(elem%attlist%list) + else + n = 0 + endif + end function get_attlist_size + + function get_attdecl_by_index(elem, n) result(att) + type(element_t), pointer :: elem + integer, intent(in) :: n + type(attribute_t), pointer :: att + + att => null() + if (associated(elem)) then + if (n>0.and.n<=size(elem%attlist%list)) then + att => elem%attlist%list(n) + endif + endif + end function get_attdecl_by_index + + function get_attdecl_by_name(elem, name) result(att) + type(element_t), pointer :: elem + character(len=*), intent(in) :: name + type(attribute_t), pointer :: att + + integer :: i + att => null() + if (associated(elem)) then + do i = 1, size(elem%attlist%list) + if (str_vs(elem%attlist%list(i)%name)==name) then + att => elem%attlist%list(i) + return + endif + enddo + endif + end function get_attdecl_by_name + + pure function express_att_decl_len(a) result(n) + type(attribute_t), intent(in) :: a + integer :: n + + if (a%attType==ATT_ENUM) then + n = size(a%name) + else + n = size(a%name)+1+len_trim(ATT_TYPES(a%attType)) + endif + + if (a%attType==ATT_NOTATION & + .or.a%attType==ATT_ENUM) & + n = n + 1 + make_token_group_len(a%enumerations) + + select case(a%attDefault) + case (ATT_REQUIRED) + n = n + len(" #REQUIRED") + case (ATT_IMPLIED) + n = n + len(" #IMPLIED") + case (ATT_DEFAULT) + n = n + len(" ") + case (ATT_FIXED) + n = n + len(" #FIXED") + end select + + if (associated(a%default)) & + n = n + 3 + size(a%default) + end function express_att_decl_len + + function express_attribute_declaration(a) result(s) + type(attribute_t), intent(in) :: a + character(len=express_att_decl_len(a)) :: s + + if (a%attType==ATT_ENUM) then + s = str_vs(a%name) + else + s = str_vs(a%name)//" "//ATT_TYPES(a%attType) + endif + if (a%attType==ATT_NOTATION & + .or.a%attType==ATT_ENUM) & + s = trim(s)//" "//make_token_group(a%enumerations) + + select case(a%attDefault) + case (ATT_REQUIRED) + s = trim(s)//" #REQUIRED" + case (ATT_IMPLIED) + s = trim(s)//" #IMPLIED" + case (ATT_DEFAULT) + s = trim(s)//" " + case (ATT_FIXED) + s = trim(s)//" #FIXED" + end select + + if (associated(a%default)) & + s = trim(s)//" """//str_vs(a%default)//"""" + end function express_attribute_declaration + + function get_att_type_enum(s) result(n) + character(len=*), intent(in) :: s + integer :: n + + select case(s) + case ('CDATA') + n = ATT_CDATA + case ('ID') + n = ATT_ID + case ('IDREF') + n = ATT_IDREF + case ('IDREFS') + n = ATT_IDREFS + case ('NMTOKEN') + n = ATT_NMTOKEN + case ('NMTOKENS') + n = ATT_NMTOKENS + case ('ENTITY') + n = ATT_ENTITY + case ('ENTITIES') + n = ATT_ENTITIES + case ('NOTATION') + n = ATT_NOTATION + case ('CDANO') + n= ATT_CDANO + case ('CDAMB') + n = ATT_CDAMB + end select + end function get_att_type_enum + + pure function att_value_normalize_len(s1) result(n) + character(len=*), intent(in) :: s1 + integer :: n + + integer :: i + logical :: w + + n = 0 + w = .true. + do i = 1, len(s1) + if (w.and.(verify(s1(i:i),XML_WHITESPACE)==0)) cycle + w = .false. + n = n + 1 + if (verify(s1(i:i),XML_WHITESPACE)==0) w = .true. + enddo + if (w) n = n - 1 ! Discard final space + + end function att_value_normalize_len + + function att_value_normalize(s1) result(s2) + character(len=*), intent(in) :: s1 + character(len=att_value_normalize_len(s1)) :: s2 + + integer :: i, i2 + logical :: w + + i = 0 + i2 = 1 + w = .true. + do while (i2<=len(s2)) + i = i + 1 + if (w.and.(verify(s1(i:i),XML_WHITESPACE)==0)) cycle + w = .false. + s2(i2:i2) = s1(i:i) + i2 = i2 + 1 + if (verify(s1(i:i),XML_WHITESPACE)==0) w = .true. + enddo + + end function att_value_normalize + +#endif +end module m_common_element diff --git a/src/xml/common/m_common_elstack.F90 b/src/xml/common/m_common_elstack.F90 new file mode 100644 index 000000000..ccfca15dc --- /dev/null +++ b/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 diff --git a/src/xml/common/m_common_entities.F90 b/src/xml/common/m_common_entities.F90 new file mode 100644 index 000000000..071455b29 --- /dev/null +++ b/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)') ' 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 diff --git a/src/xml/common/m_common_entity_expand.F90 b/src/xml/common/m_common_entity_expand.F90 new file mode 100644 index 000000000..565700710 --- /dev/null +++ b/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 diff --git a/src/xml/common/m_common_error.F90 b/src/xml/common/m_common_error.F90 new file mode 100644 index 000000000..0a1f1c1a8 --- /dev/null +++ b/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 diff --git a/src/xml/common/m_common_io.F90 b/src/xml/common/m_common_io.F90 new file mode 100644 index 000000000..a15a25dbc --- /dev/null +++ b/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 diff --git a/src/xml/common/m_common_namecheck.F90 b/src/xml/common/m_common_namecheck.F90 new file mode 100644 index 000000000..a796732e7 --- /dev/null +++ b/src/xml/common/m_common_namecheck.F90 @@ -0,0 +1,501 @@ +module m_common_namecheck + +#ifndef DUMMYLIB + ! These are basically a collection of what would be regular + ! expressions in a more sensible language. + ! The only external dependency should be knowing how these + ! regular expressions may differ between XML-1.0 and 1.1 (which + ! is only in the areas of + ! 1: allowing character entity references to control characters + ! 2: More characters allowed in Names (but this only affects + ! unicode-aware programs, so is only skeleton here) + + use fox_m_fsys_format, only: str_to_int_10, str_to_int_16, operator(//) + use fox_m_fsys_string, only: toLower + use m_common_charset, only: isLegalCharRef, isNCNameChar, & + isInitialNCNameChar, isInitialNameChar, isNameChar, isRepCharRef + + implicit none + private + + character(len=*), parameter :: lowerCase = "abcdefghijklmnopqrstuvwxyz" + character(len=*), parameter :: upperCase = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + character(len=*), parameter :: letters = lowerCase//upperCase + character(len=*), parameter :: digits = "0123456789" + character(len=*), parameter :: hexdigits = "0123456789abcdefABCDEF" + character(len=*), parameter :: NameChars = lowerCase//upperCase//digits//".-_:" + + public :: checkName + public :: checkNames + public :: checkQName + public :: checkQNames + public :: checkNmtoken + public :: checkNmtokens + public :: checkNCName + public :: checkNCNames + public :: checkEncName + public :: checkPITarget + public :: checkPublicId + public :: checkPEDef + public :: checkPseudoAttValue + public :: checkAttValue + public :: checkCharacterEntityReference + public :: checkRepCharEntityReference + public :: likeCharacterEntityReference + + public :: prefixOfQName + public :: localpartOfQName + +contains + + pure function checkEncName(name) result(good) + ![81] EncName ::= [A-Za-z] ([A-Za-z0-9._] | '-')* + character(len=*), intent(in) :: name + logical :: good + + integer :: n + + n = len(name) + good = (n > 0) + if (good) good = (scan(name(1:1), letters) /= 0) + if (good .and. n > 1) & + good = (verify(name(2:), letters//digits//'.-_') == 0) + end function checkEncName + + + function checkPITarget(name, xv) result(good) + character(len=*), intent(in) :: name + integer, intent(in) :: xv + logical :: good + ! Validates a string against the XML requirements for a NAME + ! Is not fully compliant; ignores UTF issues. + + good = checkName(name, xv) & + .and.toLower(name)/="xml" + + end function checkPITarget + + + pure function checkName(name, xv) result(good) + character(len=*), intent(in) :: name + integer, intent(in) :: xv + logical :: good + ! Validates a string against the XML requirements for a NAME + ! Is not fully compliant; ignores UTF issues. + + good = (len(name) > 0) + if (.not.good) return + if (good) good = isInitialNameChar(name(1:1), xv) + if (.not.good.or.len(name)==1) return + good = isNameChar(name(2:), xv) + + end function checkName + + pure function checkNames(name, xv) result(good) + character(len=*), intent(in) :: name + integer, intent(in) :: xv + logical :: good + ! Validates a string against the production for NAMES + + integer :: i, j + + good = (len(name) > 0) + if (.not.good) return + i = verify(name, " ") + if (i==0) then + good = .false. + return + endif + j = scan(name(i:), " ") + if (j==0) then + j = len(name) + else + j = i + j - 2 + endif + do + good = checkName(name(i:j), xv) + if (.not.good) return + i = j + 1 + j = verify(name(i:), " ") + if (j==0) exit + i = i + j - 1 + j = scan(name(i:), " ") + if (j==0) then + j = len(name) + else + j = i + j - 2 + endif + enddo + + end function checkNames + + + pure function checkQName(name, xv) result(good) + character(len=*), intent(in) :: name + integer, intent(in) :: xv + logical :: good + ! Validates a string against the XML requirements for a NAME + ! Is not fully compliant; ignores UTF issues. + + integer :: n + + n = index(name, ':') + if (n == 0) then + good = checkNCName(name, xv) + else + good = (checkNCName(name(:n-1), xv) .and. checkNCName(name(n+1:), xv)) + endif + end function checkQName + + + pure function checkQNames(name, xv) result(good) + character(len=*), intent(in) :: name + integer, intent(in) :: xv + logical :: good + ! Validates a string against the production for NAMES + + integer :: i, j + + good = (len(name) > 0) + if (.not.good) return + i = verify(name, " ") + if (i==0) then + good = .false. + return + endif + j = scan(name(i:), " ") + if (j==0) then + j = len(name) + else + j = i + j - 2 + endif + do + good = checkQName(name(i:j), xv) + if (.not.good) return + i = j + 1 + j = verify(name(i:), " ") + if (j==0) exit + i = i + j - 1 + j = scan(name(i:), " ") + if (j==0) then + j = len(name) + else + j = i + j - 2 + endif + enddo + + end function checkQNames + + + pure function checkNCName(name, xv) result(good) + character(len=*), intent(in) :: name + integer, intent(in) :: xv + logical :: good + ! Validates a string against the XML requirements for an NCNAME + ! Is not fully compliant; ignores UTF issues. + + good = (len(name)/=0) + if (.not.good) return + good = isInitialNCNameChar(name(1:1), xv) + if (.not.good.or.len(name)==1) return + good = isNCNameChar(name(2:), xv) + + end function checkNCName + + + pure function checkNCNames(name, xv) result(good) + character(len=*), intent(in) :: name + integer, intent(in) :: xv + logical :: good + ! Validates a string against the production for NAMES + + integer :: i, j + + good = (len(name) > 0) + if (.not.good) return + i = verify(name, " ") + if (i==0) then + good = .false. + return + endif + j = scan(name(i:), " ") + if (j==0) then + j = len(name) + else + j = i + j - 2 + endif + do + good = checkNCName(name(i:j), xv) + if (.not.good) return + i = j + 1 + j = verify(name(i:), " ") + if (j==0) exit + i = i + j - 1 + j = scan(name(i:), " ") + if (j==0) then + j = len(name) + else + j = i + j - 2 + endif + enddo + + end function checkNCNames + + + pure function checkNmtoken(name, xv) result(good) + character(len=*), intent(in) :: name + integer, intent(in) :: xv + logical :: good + ! Validates a string against the XML requirements for an NCNAME + ! Is not fully compliant; ignores UTF issues. + + good = isNameChar(name, xv) + + end function checkNmtoken + + + pure function checkNmtokens(name, xv) result(good) + character(len=*), intent(in) :: name + integer, intent(in) :: xv + logical :: good + ! Validates a string against the XML requirements for an NCNAME + ! Is not fully compliant; ignores UTF issues. + + integer :: i, j + + good = (len(name) > 0) + if (.not.good) return + i = verify(name, " ") + if (i==0) then + good = .false. + return + endif + j = scan(name(i:), " ") + if (j==0) then + j = len(name) + else + j = i + j - 2 + endif + do + good = isNameChar(name(i:j), xv) + if (.not.good) return + i = j + 1 + j = verify(name(i:), " ") + if (j==0) exit + i = i + j - 1 + j = scan(name(i:), " ") + if (j==0) then + j = len(name) + else + j = i + j - 2 + endif + enddo + + end function checkNmtokens + + + function checkPublicId(value) result(good) + character(len=*), intent(in) :: value + logical :: good + character(len=*), parameter :: PubIdChars = & + " "//achar(10)//achar(13)//lowerCase//upperCase//digits//"-'()+,./:=?;!*#@$_%" + + good = (verify(value, PubIdChars)==0) + end function checkPublicId + + + function checkPEDef(value, xv) result(p) + character(len=*), intent(in) :: value + integer, intent(in) :: xv + logical :: p + + integer :: i1, i2 + + p = .false. + if (scan(value, '%&')==0) then + p = .true. + elseif (scan(value, '"')==0) then + i1 = scan(value, '%&') + i2 = 0 + do while (i1>0) + i1 = i2 + i1 + i2 = index(value(i1+1:),';') + if (i2==0) return + i2 = i1 + i2 + if (value(i1:i1)=='&') then + if (.not.checkName(value(i1+1:i2-1), xv) .and. & + .not.checkCharacterEntityReference(value(i1+1:i2-1), xv)) return + else + if (.not.checkName(value(i1+1:i2-1), xv)) & + return + endif + i1 = scan(value(i2+1:), '%&') + enddo + p = .true. + endif + end function checkPEDef + + function checkPseudoAttValue(value, xv) result(p) + character(len=*), intent(in) :: value + integer, intent(in) :: xv + logical :: p + + integer :: i1, i2 +!fixme can we have entrefs in PIs? + p = .false. + if (scan(value, '"<&')==0) then + p = .true. + elseif (index(value, '&') > 0) then + i1 = index(value, '&') + i2 = 0 + do while (i1 > 0) + i1 = i2 + i1 + i2 = index(value(i1+1:),';') + if (i2==0) return + i2 = i1 + i2 + if (value(i1+1:i2-1) /= 'amp' .and. & + value(i1+1:i2-1) /= 'lt' .and. & + value(i1+1:i2-1) /= 'gt' .and. & + value(i1+1:i2-1) /= 'quot' .and. & + value(i1+1:i2-1) /= 'apos' .and. & + .not.checkCharacterEntityReference(value(i1+1:i2-1), xv)) & + return + i1 = index(value(i2+1:), '&') + enddo + p = .true. + endif + end function checkPseudoAttValue + + function checkAttValue(value, xv) result(p) + character(len=*), intent(in) :: value + integer, intent(in) :: xv + logical :: p + ! This function is called basically to make sure + ! that any attribute value looks like one. It will + ! not flag up out-of-range character entities, and + ! is a very weak check. Only used from xml_AddAttribute + ! when escaping is off. + integer :: i1, i2 + + p = .false. + if (scan(value, '"<&'//"'")==0) then + p = .true. + elseif (index(value, '&') > 0) then + i1 = index(value, '&') + i2 = 0 + do while (i1 > 0) + i1 = i1 + i2 + 1 + i2 = scan(value(i1+1:),';') + if (i2 == 0) return + i2 = i1 + i2 + if (.not.checkName(value(i1+1:i2-1), xv) .and. & + .not.likeCharacterEntityReference(value(i1+1:i2-1))) then + print*, value(i1+1:i2-1), " ", & + likeCharacterEntityReference(value(i1+1:i2-1)) + return + endif + i1 = index(value(i2+1:), '&') + enddo + p = .true. + endif + end function checkAttValue + + + function likeCharacterEntityReference(code) result(good) + character(len=*), intent(in) :: code + logical :: good + + good = .false. + if (len(code) > 0) then + if (code(1:1) == "#") then + if (code(2:2) == "x") then + if (len(code) > 2) then + good = (verify(code(3:), hexdigits) == 0) + endif + else + good = (verify(code(2:), digits) == 0) + endif + endif + endif + + end function likeCharacterEntityReference + + function checkCharacterEntityReference(code, xv) result(good) + character(len=*), intent(in) :: code + integer, intent(in) :: xv + logical :: good + + integer :: i + + good = .false. + if (len(code) > 0) then + if (code(1:1) == "#") then + if (code(2:2) == "x") then + if (len(code) > 2) then + good = (verify(code(3:), hexdigits) == 0) + if (good) then + i = str_to_int_16(code(3:)) + endif + endif + else + good = (verify(code(2:), digits) == 0) + if (good) then + i = str_to_int_10(code(2:)) + endif + endif + endif + endif + if (good) good = isLegalCharRef(i, xv) + + end function checkCharacterEntityReference + + function checkRepCharEntityReference(code, xv) result(good) + character(len=*), intent(in) :: code + integer, intent(in) :: xv + logical :: good + + ! Is this a reference to a character we can actually represent + ! in memory? ie without unicode, US-ASCII only. + + integer :: i + + good = .false. + if (len(code) > 0) then + if (code(1:1) == "#") then + if (code(2:2) == "x") then + if (len(code) > 2) then + good = (verify(code(3:), hexdigits) == 0) + if (good) then + i = str_to_int_16(code(3:)) + endif + endif + else + good = (verify(code(2:), digits) == 0) + if (good) then + i = str_to_int_10(code(2:)) + endif + endif + endif + endif + if (good) good = isRepCharRef(i, xv) + + end function checkRepCharEntityReference + + + pure function prefixOfQName(qname) result(prefix) + character(len=*), intent(in) :: qname + character(len=max(index(qname, ':')-1,0)) :: prefix + + prefix = qname ! automatic truncation + end function prefixOfQName + + + pure function localpartOfQname(qname) result(localpart) + character(len=*), intent(in) :: qname + character(len=max(len(qname)-index(qname,':'),0)) ::localpart + + localpart = qname(index(qname,':')+1:) + end function localpartOfQname + +#endif +end module m_common_namecheck diff --git a/src/xml/common/m_common_namespaces.F90 b/src/xml/common/m_common_namespaces.F90 new file mode 100644 index 000000000..e3bdff60c --- /dev/null +++ b/src/xml/common/m_common_namespaces.F90 @@ -0,0 +1,830 @@ +module m_common_namespaces + +#ifndef DUMMYLIB + use fox_m_fsys_array_str, only: str_vs, vs_str, vs_str_alloc + + use fox_m_utils_uri, only: URI, parseURI, destroyURI, hasScheme + use m_common_attrs, only: dictionary_t, get_key, get_value, remove_key, getLength, hasKey + use m_common_attrs, only: set_nsURI, set_localName, get_prefix, add_item_to_dict + use m_common_charset, only: XML1_0, XML1_1 + use m_common_error, only: FoX_error, FoX_warning, error_stack, add_error, in_error + use m_common_namecheck, only: checkNCName + use m_common_struct, only: xml_doc_state + + implicit none + private + + character(len=*), parameter :: invalidNS = '::INVALID::' + ! an invalid URI name to indicate a namespace error. + + type URIMapping + character, dimension(:), pointer :: URI + integer :: ix ! link back to node depth + end type URIMapping + !This is a single URI, and the node depth under which + !its namespace applies. + + type prefixMapping + character, dimension(:), pointer :: prefix + type(URIMapping), dimension(:), pointer :: urilist + end type prefixMapping + !This is the mapping for a single prefix; with the + !list of namespaces which are in force at various + !depths + + type namespaceDictionary + private + type(URIMapping), dimension(:), pointer :: defaults + type(prefixMapping), dimension(:), pointer :: prefixes + end type namespaceDictionary + !This is the full namespace dictionary; defaults is + !the list of default namespaces in force; prefix a + !list of all prefixes in force. + + public :: invalidNS + + public :: initNamespaceDictionary + public :: destroyNamespaceDictionary + public :: namespaceDictionary + public :: checkNamespaces + public :: checkNamespacesWriting + public :: checkEndNamespaces + public :: getnamespaceURI + interface getnamespaceURI + module procedure getURIofDefaultNS, getURIofPrefixedNS + end interface + public :: isPrefixInForce + public :: isDefaultNSInForce + public :: getNumberOfPrefixes + public :: getPrefixByIndex + + public :: dumpnsdict !FIXME + + public :: addDefaultNS + public :: removeDefaultNS + public :: addPrefixedNS + public :: removePrefixedNS + +contains + + + subroutine initNamespaceDictionary(nsDict) + type(namespaceDictionary), intent(inout) :: nsDict + + !We need to properly initialize 0th elements + !(which are never used) in order to provide + !sensible behaviour when trying to manipulate + !an empty dictionary. + + allocate(nsDict%defaults(0:0)) + allocate(nsDict%defaults(0)%URI(0)) + !The 0th element of the defaults NS is the empty namespace + nsDict%defaults(0)%ix = -1 + + allocate(nsDict%prefixes(0:0)) + allocate(nsDict%prefixes(0)%prefix(0)) + allocate(nsDict%prefixes(0)%urilist(0:0)) + allocate(nsDict%prefixes(0)%urilist(0)%URI(len(invalidNS))) + nsDict%prefixes(0)%urilist(0)%URI = vs_str(invalidNS) + nsDict%prefixes(0)%urilist(0)%ix = -1 + + end subroutine initNamespaceDictionary + + + subroutine destroyNamespaceDictionary(nsDict) + type(namespaceDictionary), intent(inout) :: nsDict + + integer :: i, j + + do i = 0, ubound(nsDict%defaults,1) + deallocate(nsDict%defaults(i)%URI) + enddo + deallocate(nsDict%defaults) + do i = 0, ubound(nsDict%prefixes,1) + do j = 0, ubound(nsDict%prefixes(i)%urilist,1) + deallocate(nsDict%prefixes(i)%urilist(j)%URI) + enddo + deallocate(nsDict%prefixes(i)%prefix) + deallocate(nsDict%prefixes(i)%urilist) + enddo + deallocate(nsDict%prefixes) + end subroutine destroyNamespaceDictionary + + + subroutine copyURIMapping(urilist1, urilist2, l_m) + type(URIMapping), dimension(0:), intent(inout) :: urilist1 + type(URIMapping), dimension(0:), intent(inout) :: urilist2 + integer, intent(in):: l_m + integer :: i + + if (ubound(urilist1,1) < l_m .or. ubound(urilist2,1) < l_m) then + call FoX_error('Internal error in m_sax_namespaces:copyURIMapping') + endif + ! Now copy all defaults across (or rather - add pointers to them) + do i = 0, l_m + urilist2(i)%ix = urilist1(i)%ix + urilist2(i)%URI => urilist1(i)%URI + enddo + + end subroutine copyURIMapping + + + subroutine addDefaultNS(nsDict, uri, ix, es) + type(namespaceDictionary), intent(inout) :: nsDict + character(len=*), intent(in) :: uri + integer, intent(in) :: ix + type(error_stack), intent(inout), optional :: es + + type(URIMapping), dimension(:), allocatable :: tempMap + integer :: l_m, l_s + + if (uri=="http://www.w3.org/XML/1998/namespace") then + if (present(es)) then + call add_error(es, "Attempt to assign incorrect URI to prefix 'xml'") + else + call FoX_error("Attempt to assign incorrect URI to prefix 'xml'") + endif + elseif (uri=="http://www.w3.org/2000/xmlns/") then + if (present(es)) then + call add_error(es, "Attempt to assign prefix to xmlns namespace") + else + call FoX_error("Attempt to assign prefix to xmlns namespace") + endif + endif + + ! FIXME check URI is valid ... + + l_m = ubound(nsDict%defaults,1) + allocate(tempMap(0:l_m)) + ! Now copy all defaults across ... + call copyURIMapping(nsDict%defaults, tempMap, l_m) + deallocate(nsDict%defaults) + l_m = l_m + 1 + allocate(nsDict%defaults(0:l_m)) + !Now copy everything back ... + call copyURIMapping(tempMap, nsDict%defaults, l_m-1) + deallocate(tempMap) + ! And finally, add the new default NS + nsDict%defaults(l_m)%ix = ix + l_s = len(uri) + allocate(nsDict%defaults(l_m)%URI(l_s)) + nsDict%defaults(l_m)%URI = vs_str(uri) + + end subroutine addDefaultNS + + + subroutine addPrefixedURI(nsPrefix, uri, ix) + type(PrefixMapping), intent(inout) :: nsPrefix + character, dimension(:), intent(in) :: uri + integer, intent(in) :: ix + + type(URIMapping), dimension(:), allocatable :: tempMap + integer :: l_m, l_s + + l_m = ubound(nsPrefix%urilist,1) + allocate(tempMap(0:l_m)) + ! Now copy all across ... + call copyURIMapping(nsPrefix%urilist, tempMap, l_m) + deallocate(nsPrefix%urilist) + l_m = l_m + 1 + allocate(nsPrefix%urilist(0:l_m)) + !Now copy everything back ... + call copyURIMapping(tempMap, nsPrefix%urilist, l_m-1) + deallocate(tempMap) + ! And finally, add the new default NS + nsPrefix%urilist(l_m)%ix = ix + l_s = size(uri) + allocate(nsPrefix%urilist(l_m)%URI(l_s)) + nsPrefix%urilist(l_m)%URI = uri + + end subroutine addPrefixedURI + + subroutine removeDefaultNS(nsDict) + type(namespaceDictionary), intent(inout) :: nsDict + + type(URIMapping), dimension(:), allocatable :: tempMap + integer :: l_m + + l_m = ubound(nsDict%defaults,1) + allocate(tempMap(0:l_m-1)) + ! Now copy all defaults across ... + call copyURIMapping(nsDict%defaults, tempMap, l_m-1) + !And remove tail-end charlie + deallocate(nsDict%defaults(l_m)%URI) + deallocate(nsDict%defaults) + l_m = l_m - 1 + allocate(nsDict%defaults(0:l_m)) + !Now copy everything back ... + call copyURIMapping(tempMap, nsDict%defaults, l_m) + deallocate(tempMap) + + end subroutine removeDefaultNS + + subroutine removePrefixedURI(nsPrefix) + type(PrefixMapping), intent(inout) :: nsPrefix + + type(URIMapping), dimension(:), allocatable :: tempMap + integer :: l_m + + l_m = ubound(nsPrefix%urilist,1) + allocate(tempMap(0:l_m-1)) + ! Now copy all defaults across ... + call copyURIMapping(nsPrefix%urilist, tempMap, l_m-1) + !And remove tail-end charlie + deallocate(nsPrefix%urilist(l_m)%URI) + deallocate(nsPrefix%urilist) + l_m = l_m - 1 + allocate(nsPrefix%urilist(0:l_m)) + !Now copy everything back ... + call copyURIMapping(tempMap, nsPrefix%urilist, l_m) + deallocate(tempMap) + + end subroutine removePrefixedURI + + subroutine addPrefixedNS(nsDict, prefix, URI, ix, xds, xml, es) + type(namespaceDictionary), intent(inout) :: nsDict + character(len=*), intent(in) :: prefix + character(len=*), intent(in) :: uri + integer, intent(in) :: ix + type(xml_doc_state), intent(in) :: xds + logical, intent(in), optional :: xml + type(error_stack), intent(inout), optional :: es + + integer :: l_p, p_i, i + logical :: xml_ + + if (present(xml)) then + xml_ = xml + else + xml_ = .false. + endif + + if (prefix=='xml' .and. & + URI/='http://www.w3.org/XML/1998/namespace') then + if (present(es)) then + call add_error(es, "Attempt to assign incorrect URI to prefix 'xml'") + else + call FoX_error("Attempt to assign incorrect URI to prefix 'xml'") + endif + elseif (prefix/='xml' .and. & + URI=='http://www.w3.org/XML/1998/namespace') then + if (present(es)) then + call add_error(es, "Attempt to assign incorrect prefix to XML namespace") + else + call FoX_error("Attempt to assign incorrect prefix to XML namespace") + endif + elseif (prefix == 'xmlns') then + if (present(es)) then + call add_error(es, "Attempt to declare 'xmlns' prefix") + else + call FoX_error("Attempt to declare 'xmlns' prefix") + endif + elseif (URI=="http://www.w3.org/2000/xmlns/") then + if (present(es)) then + call add_error(es, "Attempt to assign prefix to xmlns namespace") + else + call FoX_error("Attempt to assign prefix to xmlns namespace") + endif + elseif (len(prefix) > 2) then + if ((verify(prefix(1:1), 'xX') == 0) & + .and. (verify(prefix(2:2), 'mM') == 0) & + .and. (verify(prefix(3:3), 'lL') == 0)) then + if (.not.xml_) then + ! FIXME need working warning infrastructure + !if (present(es)) then + ! call add_error(es, "Attempt to declare reserved prefix: "//prefix) + !else + call FoX_warning("Attempt to declare reserved prefix: "//prefix) + !endif + endif + endif + endif + + if (.not.checkNCName(prefix, xds%xml_version)) & + call FoX_error("Attempt to declare invalid prefix: "//prefix) + + ! FIXME check URI is valid + + l_p = ubound(nsDict%prefixes, 1) + + p_i = 0 + do i = 1, l_p + if (str_vs(nsDict%prefixes(i)%prefix) == prefix) then + p_i = i + exit + endif + enddo + + if (p_i == 0) then + call addPrefix(nsDict, vs_str(prefix)) + p_i = l_p + 1 + endif + + call addPrefixedURI(nsDict%prefixes(p_i), vs_str(URI), ix) + + end subroutine addPrefixedNS + + subroutine removePrefixedNS(nsDict, prefix) + type(namespaceDictionary), intent(inout) :: nsDict + character, dimension(:), intent(in) :: prefix + integer :: l_p, p_i, i + l_p = ubound(nsDict%prefixes, 1) + + p_i = 0 + do i = 1, l_p + if (str_vs(nsDict%prefixes(i)%prefix) == str_vs(prefix)) then + p_i = i + exit + endif + enddo + + if (p_i /= 0) then + call removePrefixedURI(nsDict%prefixes(p_i)) + if (ubound(nsDict%prefixes(p_i)%urilist,1) == 0) then + !that was the last mapping for that prefix + call removePrefix(nsDict, p_i) + endif + else + call FoX_error('Internal error in m_sax_namespaces:removePrefixedNS') + endif + + end subroutine removePrefixedNS + + subroutine addPrefix(nsDict, prefix) + type(namespaceDictionary), intent(inout) :: nsDict + character, dimension(:), intent(in) :: prefix + integer :: l_p + + type(prefixMapping), dimension(:), pointer :: tempPrefixMap + + integer :: i + + !Add a new prefix to the namespace dictionary. + !Unfortunately this involves copying the entire + !prefixes dictionary to a temporary structure, then + !reallocating the prefixes dictionary to be one + !longer, then copying everything back: + + l_p = ubound(nsDict%prefixes, 1) + allocate(tempPrefixMap(0:l_p)) + + !for each current prefix, append everything to temporary structure + do i = 0, l_p + tempPrefixMap(i)%prefix => nsDict%prefixes(i)%prefix + tempPrefixMap(i)%urilist => nsDict%prefixes(i)%urilist + enddo + deallocate(nsDict%prefixes) + !extend prefix dictionary by one ... + l_p = l_p + 1 + allocate(nsDict%prefixes(0:l_p)) + !and copy back ... + do i = 0, l_p-1 + nsDict%prefixes(i)%prefix => tempPrefixMap(i)%prefix + nsDict%prefixes(i)%urilist => tempPrefixMap(i)%urilist + enddo + deallocate(tempPrefixMap) + + allocate(nsDict%prefixes(l_p)%prefix(size(prefix))) + nsDict%prefixes(l_p)%prefix = prefix + allocate(nsDict%prefixes(l_p)%urilist(0:0)) + allocate(nsDict%prefixes(l_p)%urilist(0)%URI(len(invalidNS))) + nsDict%prefixes(l_p)%urilist(0)%URI = vs_str(invalidNS) + nsDict%prefixes(l_p)%urilist(0)%ix = -1 + + end subroutine addPrefix + + subroutine removePrefix(nsDict, i_p) + type(namespaceDictionary), intent(inout) :: nsDict + integer, intent(in) :: i_p + integer :: l_p + + type(prefixMapping), dimension(:), pointer :: tempPrefixMap + + integer :: i + + !Remove a prefix from the namespace dictionary. + !Unfortunately this involves copying the entire + !prefixes dictionary to a temporary structure, then + !reallocating the prefixes dictionary to be one + !shorter, then copying everything back: + + l_p = ubound(nsDict%prefixes, 1) + allocate(tempPrefixMap(0:l_p-1)) + + !for each current prefix, append everything to temporary structure + do i = 0, i_p-1 + tempPrefixMap(i)%prefix => nsDict%prefixes(i)%prefix + tempPrefixMap(i)%urilist => nsDict%prefixes(i)%urilist + enddo + deallocate(nsDict%prefixes(i_p)%urilist(0)%URI) + deallocate(nsDict%prefixes(i_p)%urilist) + deallocate(nsDict%prefixes(i_p)%prefix) + !this subroutine will only get called if the urilist is already + !empty, so no need to deallocate it. + do i = i_p+1, l_p + tempPrefixMap(i-1)%prefix => nsDict%prefixes(i)%prefix + tempPrefixMap(i-1)%urilist => nsDict%prefixes(i)%urilist + enddo + deallocate(nsDict%prefixes) + !shorten prefix dictionary by one ... + l_p = l_p - 1 + allocate(nsDict%prefixes(0:l_p)) + !and copy back ... + do i = 0, l_p + nsDict%prefixes(i)%prefix => tempPrefixMap(i)%prefix + nsDict%prefixes(i)%urilist => tempPrefixMap(i)%urilist + enddo + deallocate(tempPrefixMap) + + end subroutine removePrefix + + + subroutine checkNamespaces(atts, nsDict, ix, xds, namespace_prefixes, xmlns_uris, es, & + partial, start_prefix_handler, end_prefix_handler) + type(dictionary_t), intent(inout) :: atts + type(namespaceDictionary), intent(inout) :: nsDict + integer, intent(in) :: ix ! depth of nesting of current element. + type(xml_doc_state), intent(in) :: xds + logical, intent(in) :: namespace_prefixes, xmlns_uris + type(error_stack), intent(inout) :: es + logical, intent(in) :: partial ! if so, don't try and resolve anything except xml & xmlns + optional :: start_prefix_handler, end_prefix_handler + + interface + subroutine start_prefix_handler(namespaceURI, prefix) + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: prefix + end subroutine start_prefix_handler + subroutine end_prefix_handler(prefix) + character(len=*), intent(in) :: prefix + end subroutine end_prefix_handler + end interface + + character(len=6) :: xmlns + character, dimension(:), pointer :: QName, URIstring + integer :: i, n + type(URI), pointer :: URIref + !Check for namespaces; *and* remove xmlns references from + !the attributes dictionary. + + ! we can't do a simple loop across the attributes, + ! because we need to remove some as we go along ... + i = 1 + do while (i <= getLength(atts)) + xmlns = get_key(atts, i) + if (xmlns == 'xmlns ') then + !Default namespace is being set + URIstring => vs_str_alloc(get_value(atts, i)) + if (str_vs(URIstring)=="") then + ! Empty nsURI on default namespace has same effect in 1.0 and 1.1 + if (present(end_prefix_handler)) & + call end_prefix_handler("") + call addDefaultNS(nsDict, invalidNS, ix) + deallocate(URIstring) + else + URIref => parseURI(str_vs(URIstring)) + if (.not.associated(URIref)) then + call add_error(es, "Invalid URI: "//str_vs(URIstring)) + deallocate(URIstring) + return + elseif (.not.hasScheme(URIref)) then + call add_error(es, "Relative namespace in URI deprecated: "//str_vs(URIstring)) + deallocate(URIstring) + call destroyURI(URIref) + return + endif + call destroyURI(URIref) + if (present(start_prefix_handler)) & + call start_prefix_handler(str_vs(URIstring), "") + call addDefaultNS(nsDict, str_vs(URIstring), ix) + deallocate(URIstring) + endif + if (namespace_prefixes) then + i = i + 1 + else + call remove_key(atts, i) + endif + elseif (xmlns == 'xmlns:') then + !Prefixed namespace is being set + QName => vs_str_alloc(get_key(atts, i)) + URIstring => vs_str_alloc(get_value(atts, i)) + if (str_vs(URIstring)=="") then + if (xds%xml_version==XML1_0) then + call add_error(es, "Empty nsURI is invalid in XML 1.0") + deallocate(URIstring) + deallocate(QName) + return + elseif (xds%xml_version==XML1_1) then + call addPrefixedNS(nsDict, str_vs(QName(7:)), invalidNS, ix, xds, es=es) + if (in_error(es)) then + deallocate(URIstring) + deallocate(QName) + return + elseif (present(end_prefix_handler)) then + call end_prefix_handler(str_vs(QName(7:))) + endif + deallocate(URIstring) + deallocate(QName) + endif + else + URIref => parseURI(str_vs(URIstring)) + if (.not.associated(URIref)) then + call add_error(es, "Invalid URI: "//str_vs(URIstring)) + deallocate(URIstring) + deallocate(QName) + return + elseif (.not.hasScheme(URIref)) then + call add_error(es, "Relative namespace in URI deprecated: "//str_vs(URIstring)) + deallocate(URIstring) + deallocate(QName) + call destroyURI(URIref) + return + endif + call destroyURI(URIref) + call addPrefixedNS(nsDict, str_vs(QName(7:)), str_vs(URIstring), ix, xds, es=es) + if (in_error(es)) then + deallocate(URIstring) + deallocate(QName) + return + elseif (present(start_prefix_handler)) then + call start_prefix_handler(str_vs(URIstring), str_vs(QName(7:))) + endif + deallocate(URIstring) + deallocate(QName) + endif + if (namespace_prefixes) then + i = i + 1 + else + call remove_key(atts, i) + endif + else + ! we only increment if we haven't removed a key + i = i + 1 + endif + enddo + + ! having done that, now resolve all attribute namespaces: + do i = 1, getLength(atts) + QName => vs_str_alloc(get_key(atts,i)) + n = index(str_vs(QName), ":") + if (n > 0) then + if (str_vs(QName(1:n-1))=="xmlns") then + ! FIXME but this can be controlled by SAX configuration xmlns-uris + if (xmlns_uris) then + call set_nsURI(atts, i, "http://www.w3.org/2000/xmlns/") + else + call set_nsURI(atts, i, "") + endif + else + if (str_vs(QName(1:n-1))=="xml") then + call set_nsURI(atts, i, "http://www.w3.org/XML/1998/namespace") + elseif (getnamespaceURI(nsDict, str_vs(QName(1:n-1)))==invalidNS) then + ! Sometimes we don't want to worry about unbound prefixes, + ! eg if we are in the middle of parsing an entity. + if (.not.partial) then + call add_error(es, "Unbound namespace prefix") + deallocate(QName) + return + else + call set_nsURI(atts, i, "") + endif + else + call set_nsURI(atts, i, getnamespaceURI(nsDict, str_vs(QName(1:n-1)))) + endif + endif + else + if (xmlns_uris.and.str_vs(QName)=="xmlns") then + call set_nsURI(atts, i, "http://www.w3.org/2000/xmlns/") + else + call set_nsURI(atts, i, "") ! no such thing as a default namespace on attributes + endif + endif + ! Check for duplicates + if (hasKey(atts, getnamespaceURI(nsDict, str_vs(QName(1:n-1))), str_vs(QName(n+1:)))) then + call add_error(es, "Duplicate attribute names after namespace processing") + deallocate(QName) + return + endif + call set_localName(atts, i, QName(n+1:)) + deallocate(QName) + enddo + + end subroutine checkNamespaces + + + subroutine checkNamespacesWriting(atts, nsdict, ix) + type(dictionary_t), intent(inout) :: atts + type(namespaceDictionary), intent(inout) :: nsDict + integer, intent(in) :: ix + ! Read through a list of attributes, check with currently + ! active namespaces & add any necessary declarations + + integer :: i, i_p, l_d, l_ps, n + + n = getLength(atts) ! we need the length before we fiddle with it + + !Does the default NS need added? + l_d = ubound(nsDict%defaults,1) + if (nsDict%defaults(l_d)%ix == ix) then + !It's not been registered yet: + call add_item_to_dict(atts, "xmlns", & + str_vs(nsDict%defaults(l_d)%URI), type="CDATA") + endif + + !next, add any overdue prefixed NS's in the same way: + ! there should only ever be one. More would be an error, + ! but the check should have been done earlier. + do i_p = 0, ubound(nsDict%prefixes, 1) + l_ps = ubound(nsDict%prefixes(i_p)%urilist,1) + if (nsDict%prefixes(i_p)%urilist(l_ps)%ix == ix) then + call add_item_to_dict(atts, & + "xmlns:"//str_vs(nsDict%prefixes(i_p)%prefix), & + str_vs(nsDict%prefixes(i_p)%urilist(l_ps)%URI), & + type="CDATA") + endif + enddo + + + !Finally, we may have some we've added for attribute QNames + ! have to get those too: + do i = 1, getLength(atts) + ! get prefix, and identify the relevant NS mapping + i_p = getPrefixIndex(nsDict, get_prefix(atts, i)) + l_ps = ubound(nsDict%prefixes(i_p)%urilist,1) + !If the index is greater than what it should be: + if (nsDict%prefixes(i_p)%urilist(l_ps)%ix > ix) then + !we only just added this, so we need to declare it + call add_item_to_dict(atts, "xmlns:"//get_prefix(atts, i), & + str_vs(nsDict%prefixes(i_p)%urilist(l_ps)%URI), & + type="CDATA") + !Reset the index to the right value: + nsDict%prefixes(i_p)%urilist(l_ps)%ix = ix + endif + enddo + + end subroutine checkNamespacesWriting + + + subroutine checkEndNamespaces(nsDict, ix, end_prefix_handler) + type(namespaceDictionary), intent(inout) :: nsDict + integer, intent(in) :: ix + + optional :: end_prefix_handler + + interface + subroutine end_prefix_handler(prefix) + character(len=*), intent(in) :: prefix + end subroutine end_prefix_handler + end interface + + integer :: l_d, l_p, l_ps, i + character, pointer :: prefix(:) + + !It will only ever be the final elements in the list which + ! might have expired. + + l_d = ubound(nsDict%defaults,1) + do while (nsDict%defaults(l_d)%ix == ix) + if (present(end_prefix_handler)) & + call end_prefix_handler("") + call removeDefaultNS(nsDict) + l_d = ubound(nsDict%defaults,1) + enddo + + l_p = ubound(nsDict%prefixes, 1) + i = 1 + do while (i <= l_p) + l_ps = ubound(nsDict%prefixes(l_p)%urilist,1) + if (nsDict%prefixes(i)%urilist(l_ps)%ix == ix) then + if (present(end_prefix_handler)) & + call end_prefix_handler(str_vs(nsDict%prefixes(i)%prefix)) + ! We have to assign this pointer explicitly, otherwise the next call + ! aliases its arguments illegally. + prefix => nsDict%prefixes(i)%prefix + call removePrefixedNS(nsDict, prefix) + if (l_p > ubound(nsDict%prefixes, 1)) then + ! we just removed the last reference to that prefix, + ! so our list of prefixes has shrunk - update the running total. + ! and go to the next prefix, which is at the same index + l_p = l_p - 1 + cycle + endif + endif + i = i + 1 + enddo + + end subroutine checkEndNamespaces + + + subroutine dumpnsdict(nsdict) + type(namespaceDictionary), intent(in) :: nsdict + integer :: i, j + write(*,'(a)')'* default namespaces *' + + do i = 1, ubound(nsdict%defaults, 1) + write(*,'(i0,a)') nsdict%defaults(i)%ix, str_vs(nsdict%defaults(i)%URI) + enddo + write(*,'(a)') '* Prefixed namespaces *' + do i = 1, ubound(nsdict%prefixes, 1) + write(*,'(2a)') '* prefix: ', str_vs(nsdict%prefixes(i)%prefix) + do j = 1, ubound(nsdict%prefixes(i)%urilist, 1) + write(*,'(i0,a)') nsdict%prefixes(i)%urilist(j)%ix, str_vs(nsdict%prefixes(i)%urilist(j)%URI) + enddo + enddo + + end subroutine dumpnsdict + + + pure function getURIofDefaultNS(nsDict) result(uri) + type(namespaceDictionary), intent(in) :: nsDict + character(len=size(nsDict%defaults(ubound(nsDict%defaults,1))%URI)) :: URI + + integer :: l_d + l_d = ubound(nsDict%defaults,1) + uri = str_vs(nsDict%defaults(l_d)%URI) + end function getURIofDefaultNS + + + pure function isPrefixInForce(nsDict, prefix) result(force) + type(namespaceDictionary), intent(in) :: nsDict + character(len=*), intent(in) :: prefix + logical :: force + integer :: i, l_s + + force = .false. + do i = 1, ubound(nsDict%prefixes, 1) + if (str_vs(nsDict%prefixes(i)%prefix) == prefix) then + l_s = ubound(nsDict%prefixes(i)%urilist, 1) + force = (size(nsdict%prefixes(i)%urilist(l_s)%URI) > 0) + exit + endif + enddo + + end function isPrefixInForce + + + pure function isDefaultNSInForce(nsDict) result(force) + type(namespaceDictionary), intent(in) :: nsDict + logical :: force + integer :: l_s + + force = .false. + l_s = ubound(nsDict%defaults, 1) + if (l_s > 0) & + force = (size(nsdict%defaults(l_s)%URI) > 0) + + end function isDefaultNSInForce + + + pure function getPrefixIndex(nsDict, prefix) result(p) + type(namespaceDictionary), intent(in) :: nsDict + character(len=*), intent(in) :: prefix + integer :: p + + integer :: i + p = 0 + do i = 1, ubound(nsDict%prefixes, 1) + if (str_vs(nsDict%prefixes(i)%prefix) == prefix) then + p = i + exit + endif + enddo + end function getPrefixIndex + + + function getNumberOfPrefixes(nsDict) result(n) + type(namespaceDictionary), intent(in) :: nsDict + integer :: n + n = ubound(nsDict%prefixes, 1) + end function getNumberOfPrefixes + + + function getPrefixByIndex(nsDict, i) result(c) + type(namespaceDictionary), intent(in) :: nsDict + integer, intent(in) :: i + character(len=size(nsDict%prefixes(i)%prefix)) :: c + + c = str_vs(nsDict%prefixes(i)%prefix) + end function getPrefixByIndex + + + pure function getURIofPrefixedNS(nsDict, prefix) result(uri) + type(namespaceDictionary), intent(in) :: nsDict + character(len=*), intent(in) :: prefix + character(len=size( & + nsDict%prefixes( & + getPrefixIndex(nsDict,prefix) & + ) & + %urilist( & + ubound(nsDict%prefixes(getPrefixIndex(nsDict,prefix))%urilist, 1) & + ) & + %uri)) :: URI + integer :: p_i, l_m + p_i = getPrefixIndex(nsDict, prefix) + l_m = ubound(nsDict%prefixes(p_i)%urilist, 1) + uri = str_vs(nsDict%prefixes(p_i)%urilist(l_m)%URI) + + end function getURIofPrefixedNS + +#endif +end module m_common_namespaces diff --git a/src/xml/common/m_common_notations.F90 b/src/xml/common/m_common_notations.F90 new file mode 100644 index 000000000..ee404da35 --- /dev/null +++ b/src/xml/common/m_common_notations.F90 @@ -0,0 +1,120 @@ +module m_common_notations + +#ifndef DUMMYLIB + use fox_m_fsys_array_str, only: vs_str, str_vs + use m_common_error, only: FoX_error + + implicit none + private + + type notation + character(len=1), dimension(:), pointer :: name + character(len=1), dimension(:), pointer :: systemID + character(len=1), dimension(:), pointer :: publicId + end type notation + + type notation_list + type(notation), dimension(:), pointer :: list + end type notation_list + + public :: notation + public :: notation_list + public :: init_notation_list + public :: destroy_notation_list + public :: add_notation + public :: notation_exists + +contains + + subroutine init_notation_list(nlist) +! It is not clear how we should specify the +! intent of this argument - different +! compilers seem to have different semantics + type(notation_list), intent(inout) :: nlist + + allocate(nlist%list(0:0)) + allocate(nlist%list(0)%name(0)) + allocate(nlist%list(0)%systemId(0)) + allocate(nlist%list(0)%publicId(0)) + + end subroutine init_notation_list + + + subroutine destroy_notation_list(nlist) + type(notation_list), intent(inout) :: nlist + + integer :: i + + do i = 0, ubound(nlist%list, 1) + deallocate(nlist%list(i)%name) + deallocate(nlist%list(i)%systemId) + deallocate(nlist%list(i)%publicId) + enddo + deallocate(nlist%list) + end subroutine destroy_notation_list + + + subroutine add_notation(nlist, name, systemId, publicId) + type(notation_list), intent(inout) :: nlist + character(len=*), intent(in) :: name + character(len=*), intent(in), optional :: systemId + character(len=*), intent(in), optional :: publicId + + integer :: i + type(notation), dimension(:), pointer :: temp + ! pointer not allocatable to avoid bug on Lahey + + if (.not.present(systemId) .and. .not.present(publicId)) & + call FoX_error("Neither System nor Public Id specified for notation: "//name) + + allocate(temp(0:ubound(nlist%list,1))) + do i = 0, ubound(nlist%list, 1) + temp(i)%name => nlist%list(i)%name + temp(i)%systemId => nlist%list(i)%systemId + temp(i)%publicId => nlist%list(i)%publicId + enddo + + deallocate(nlist%list) + allocate(nlist%list(0:ubound(temp, 1)+1)) + do i = 0, ubound(temp, 1) + nlist%list(i)%name => temp(i)%name + nlist%list(i)%systemId => temp(i)%systemId + nlist%list(i)%publicId => temp(i)%publicId + enddo + deallocate(temp) + + allocate(nlist%list(i)%name(len(name))) + nlist%list(i)%name = vs_str(name) + if (present(systemId)) then + allocate(nlist%list(i)%systemId(len(systemId))) + nlist%list(i)%systemId = vs_str(systemId) + else + allocate(nlist%list(i)%systemId(0)) + endif + if (present(publicId)) then + allocate(nlist%list(i)%publicId(len(publicId))) + nlist%list(i)%publicId = vs_str(publicId) + else + allocate(nlist%list(i)%publicId(0)) + endif + end subroutine add_notation + + + function notation_exists(nlist, name) result(p) + type(notation_list), intent(in) :: nlist + character(len=*), intent(in) :: name + logical :: p + + integer :: i + + p = .false. + do i = 1, ubound(nlist%list, 1) + if (str_vs(nlist%list(i)%name) == name) then + p = .true. + exit + endif + enddo + end function notation_exists + +#endif +end module m_common_notations diff --git a/src/xml/common/m_common_struct.F90 b/src/xml/common/m_common_struct.F90 new file mode 100644 index 000000000..ec92b5291 --- /dev/null +++ b/src/xml/common/m_common_struct.F90 @@ -0,0 +1,121 @@ +module m_common_struct + +#ifndef DUMMYLIB + ! Common parts of an XML document. Shared by both SAX & WXML. + + use FoX_utils, only: URI + + use m_common_charset, only: XML1_0 + use m_common_entities, only: entity_list, init_entity_list, destroy_entity_list, & + add_internal_entity, add_external_entity + use m_common_element, only: element_list, init_element_list, destroy_element_list + use m_common_notations, only: notation_list, init_notation_list, destroy_notation_list + + implicit none + private + + type xml_doc_state + logical :: building = .false. ! Are we in the middle of building this doc? + integer :: xml_version = XML1_0 + logical :: standalone_declared = .false. + logical :: standalone = .false. + type(entity_list) :: entityList + type(entity_list) :: PEList + type(notation_list) :: nList + type(element_list) :: element_list + logical :: warning = .false. ! Do we care about warnings? + logical :: valid = .true. ! Do we care about validity? + logical :: liveNodeLists = .true. ! Do we want live nodelists? + character, pointer :: encoding(:) => null() + character, pointer :: inputEncoding(:) => null() + character, pointer :: documentURI(:) => null() + character, pointer :: intSubset(:) => null() + end type xml_doc_state + + public :: xml_doc_state + + public :: init_xml_doc_state + public :: destroy_xml_doc_state + + public :: register_internal_PE + public :: register_external_PE + public :: register_internal_GE + public :: register_external_GE + +contains + + subroutine init_xml_doc_state(xds) + type(xml_doc_state), intent(inout) :: xds + call init_entity_list(xds%entityList) + call init_entity_list(xds%PEList) + call init_notation_list(xds%nList) + call init_element_list(xds%element_list) + allocate(xds%inputEncoding(0)) + allocate(xds%intSubset(0)) + end subroutine init_xml_doc_state + + subroutine destroy_xml_doc_state(xds) + type(xml_doc_state), intent(inout) :: xds + call destroy_entity_list(xds%entityList) + call destroy_entity_list(xds%PEList) + call destroy_notation_list(xds%nList) + call destroy_element_list(xds%element_list) + if (associated(xds%encoding)) deallocate(xds%encoding) + if (associated(xds%inputEncoding)) deallocate(xds%inputEncoding) + if (associated(xds%documentURI)) deallocate(xds%documentURI) + deallocate(xds%intSubset) + end subroutine destroy_xml_doc_state + + subroutine register_internal_PE(xds, name, text, wfc, baseURI) + type(xml_doc_state), intent(inout) :: xds + character(len=*), intent(in) :: name + character(len=*), intent(in) :: text + logical, intent(in) :: wfc + type(URI), pointer :: baseURI + + call add_internal_entity(xds%PEList, name=name, text=text, & + wfc=wfc, baseURI=baseURI) + + end subroutine register_internal_PE + + subroutine register_external_PE(xds, name, systemId, wfc, baseURI, publicId) + type(xml_doc_state), intent(inout) :: xds + character(len=*), intent(in) :: name + character(len=*), intent(in) :: systemId + logical, intent(in) :: wfc + character(len=*), intent(in), optional :: publicId + type(URI), pointer :: baseURI + + call add_external_entity(xds%PEList, name=name, & + publicId=publicId, systemId=systemId, & + wfc=wfc, baseURI=baseURI) + end subroutine register_external_PE + + subroutine register_internal_GE(xds, name, text, wfc, baseURI) + type(xml_doc_state), intent(inout) :: xds + character(len=*), intent(in) :: name + character(len=*), intent(in) :: text + logical, intent(in) :: wfc + type(URI), pointer :: baseURI + + call add_internal_entity(xds%entityList, name=name, text=text, & + wfc=wfc, baseURI=baseURI) + + end subroutine register_internal_GE + + subroutine register_external_GE(xds, name, systemId, wfc, baseURI, publicId, notation) + type(xml_doc_state), intent(inout) :: xds + character(len=*), intent(in) :: name + character(len=*), intent(in) :: systemId + logical, intent(in) :: wfc + character(len=*), intent(in), optional :: publicId + character(len=*), intent(in), optional :: notation + type(URI), pointer :: baseURI + + call add_external_entity(xds%entityList, name=name, & + systemId=systemId, publicId=publicId, notation=notation, & + wfc=wfc, baseURI=baseURI) + end subroutine register_external_GE + +#endif +end module m_common_struct diff --git a/src/xml/dom/FoX_dom.F90 b/src/xml/dom/FoX_dom.F90 new file mode 100644 index 000000000..4e2fc1e9c --- /dev/null +++ b/src/xml/dom/FoX_dom.F90 @@ -0,0 +1,266 @@ +module FoX_dom + + use fox_common, only: countrts + use fox_m_fsys_array_str + use fox_m_fsys_format + + use m_dom_dom + use m_dom_error + use m_dom_extras + use m_dom_parse + use m_dom_utils + + implicit none + private + + public :: str_vs, vs_vs_alloc, vs_str_alloc + public :: str, operator(//) + + public :: DOMImplementation + public :: Node + public :: NodeList + public :: NamedNodeMap + + ! DOM DOMString + ! no + + ! DOM DOMTimestamp + ! public :: DOMTimestamp + + ! DOM Exceptions + public :: DOMException + public :: inException + public :: getExceptionCode + + public :: INDEX_SIZE_ERR + public :: DOMSTRING_SIZE_ERR + public :: HIERARCHY_REQUEST_ERR + public :: WRONG_DOCUMENT_ERR + public :: INVALID_CHARACTER_ERR + public :: NO_DATA_ALLOWED_ERR + public :: NO_MODIFICATION_ALLOWED_ERR + public :: NOT_FOUND_ERR + public :: NOT_SUPPORTED_ERR + public :: INUSE_ATTRIBUTE_ERR + public :: INVALID_STATE_ERR + public :: SYNTAX_ERR + public :: INVALID_MODIFICATION_ERR + public :: NAMESPACE_ERR + public :: INVALID_ACCESS_ERR + public :: VALIDATION_ERR + public :: TYPE_MISMATCH_ERR + ! XPath + public :: INVALID_EXPRESSION_ERR + public :: TYPE_ERR + ! LS + public :: PARSE_ERR + public :: SERIALIZE_ERR + + ! DOM Implementation + public :: hasFeature + public :: createDocumentType + public :: createDocument + + ! DOM Document + public :: getDocumentElement + public :: getDocType + public :: getImplementation + public :: createDocumentFragment + public :: createElement + public :: createTextNode + public :: createComment + public :: createCDATASection + public :: createProcessingInstruction + public :: createAttribute + public :: createEntityReference + public :: getElementsByTagName + public :: getChildrenByTagName + public :: getElementById + + public :: importNode + public :: createElementNS + public :: createAttributeNS + public :: getElementsByTagNameNS + + public :: getXmlStandalone + public :: setXmlStandalone + public :: getXmlVersion + public :: setXmlVersion + public :: getXmlEncoding + public :: getInputEncoding + public :: getDocumentURI + public :: setDocumentURI + public :: getStrictErrorChecking + public :: setStrictErrorChecking + public :: getDomConfig + public :: normalizeDocument + public :: renameNode + public :: adoptNode + + ! DOM Node + public :: ELEMENT_NODE + public :: ATTRIBUTE_NODE + public :: TEXT_NODE + public :: CDATA_SECTION_NODE + public :: ENTITY_REFERENCE_NODE + public :: ENTITY_NODE + public :: PROCESSING_INSTRUCTION_NODE + public :: COMMENT_NODE + public :: DOCUMENT_NODE + public :: DOCUMENT_TYPE_NODE + public :: DOCUMENT_FRAGMENT_NODE + public :: NOTATION_NODE + + public :: getNodeName + public :: getNodeValue + public :: setNodeValue + public :: getNodeType + public :: getFirstChild + public :: getLastChild + public :: getAttributes + public :: getNextSibling + public :: getPreviousSibling + public :: getParentNode + public :: getChildNodes + public :: getOwnerDocument + public :: insertBefore + public :: replaceChild + public :: removeChild + public :: appendChild + public :: hasChildNodes + public :: cloneNode + public :: normalize + + public :: isSupported + public :: getNamespaceURI + public :: getPrefix + public :: setPrefix + public :: getLocalName + public :: hasAttributes + + public :: getTextContent + public :: setTextContent + public :: isEqualNode + public :: isSameNode + public :: isDefaultNamespace + public :: lookupNamespaceURI + public :: lookupPrefix + + ! DOM NodeList + public :: item + public :: append + + ! DOM NamedNodeMap + public :: getLength + public :: getNamedItem + public :: setNamedItem + public :: removeNamedItem +! public :: item + public :: getNamedItemNS + public :: setNamedItemNS + public :: removeNamedItemNS + + ! DOM CharacterData + ! NB We use the native Fortran string type here + ! rather than inventing a DOM String, thus no + ! string type to make public +! public :: getData +! public :: setData + public :: substringData + public :: appendData + public :: insertData + public :: deleteData + public :: replaceData + + ! DOM Attr +! public :: getName + public :: getSpecified + public :: getValue + public :: setValue + public :: getOwnerElement + public :: getIsId + + ! DOM Element + public :: getTagName + public :: getAttribute + public :: setAttribute + public :: removeAttribute + public :: getAttributeNode + public :: setAttributeNode + public :: removeAttributeNode +! public :: getElementsByTagName + public :: getAttributeNS + public :: setAttributeNS + public :: removeAttributeNS + public :: getAttributeNodeNS + public :: setAttributeNodeNS +! public :: getElementsByTagNameNS + public :: hasAttribute + public :: hasAttributeNS + public :: setIdAttribute + public :: setIdAttributeNS + public :: setIdAttributeNode + + !DOM Text + public :: splitText + public :: getIsElementContentWhitespace + + !DOM CData +! public :: getData +! public :: setData + + !DOM DocumentType + public :: getEntities + public :: getNotations + public :: getInternalSubset + + !DOM Notation + + !DOM Entity + public :: getNotationName + + !DOM EntityReference + + !DOM ProcessingInstruction +! public :: getData +! public :: setData + public :: getTarget + + !DOM common + public :: getData + public :: setData + public :: getName + public :: getPublicId + public :: getSystemId + + !DOM Configuration + public :: DOMConfiguration + public :: getParameter + public :: setParameter + public :: canSetParameter + public :: getParameterNames + + ! FoX-only interfaces + public :: newDOMConfig + + public :: getNodePath + + public :: extractDataContent + public :: extractDataAttribute + public :: extractDataAttributeNS + + public :: parseFile + public :: parseString + public :: serialize + + public :: destroy + public :: getFoX_checks + public :: setFoX_checks + public :: getLiveNodeLists + public :: setLiveNodeLists + public :: getNamespaceNodes + + ! Length of array + public :: countrts + +end module FoX_dom diff --git a/src/xml/dom/Makefile b/src/xml/dom/Makefile new file mode 100644 index 000000000..1f597ddbc --- /dev/null +++ b/src/xml/dom/Makefile @@ -0,0 +1,49 @@ +source = $(wildcard *.F90) +objects = $(source:.F90=.o) + +#=============================================================================== +# Compiler Options +#=============================================================================== + +# Ignore unusd variables + +ifeq ($(MACHINE),bluegene) + override F90 = xlf2003 +endif + +ifeq ($(F90),ifort) + override F90FLAGS += -warn nounused +endif + +#=============================================================================== +# Targets +#=============================================================================== + +all: $(objects) + mv *.mod ../include + mv *.o ../lib +clean: + @rm -f *.o *.mod +neat: + @rm -f *.o *.mod + +#=============================================================================== +# Rules +#=============================================================================== + +.SUFFIXES: .F90 .o + +.PHONY: clean neat + +%.o: %.F90 + $(F90) $(F90FLAGS) -c -I../include $< + +#=============================================================================== +# Dependencies +#=============================================================================== + +FoX_dom.o: m_dom_dom.o m_dom_error.o m_dom_extras.o m_dom_parse.o m_dom_utils.o +m_dom_dom.o: m_dom_error.o +m_dom_extras.o: m_dom_dom.o m_dom_error.o +m_dom_parse.o: m_dom_dom.o m_dom_error.o +m_dom_utils.o: m_dom_dom.o m_dom_error.o diff --git a/src/xml/dom/m_dom_dom.F90 b/src/xml/dom/m_dom_dom.F90 new file mode 100644 index 000000000..ec5b788d9 --- /dev/null +++ b/src/xml/dom/m_dom_dom.F90 @@ -0,0 +1,12484 @@ +! ATTENTION +! THIS FILE IS AUTOGENERATED +! DO NOT EDIT DIRECTLY +! EDIT FILES dom/m_dom_***.m4 +! +module m_dom_dom + + use fox_m_fsys_array_str, only: str_vs, vs_str, vs_str_alloc + use fox_m_fsys_format, only: operator(//) + use fox_m_fsys_string, only: toLower + use fox_m_utils_uri, only: URI, parseURI, destroyURI, isAbsoluteURI, & + rebaseURI, expressURI + use m_common_charset, only: checkChars, XML1_0, XML1_1 + use m_common_element, only: element_t, get_element, attribute_t, & + attribute_has_default, get_attribute_declaration, get_attlist_size + use m_common_namecheck, only: checkQName, prefixOfQName, localPartOfQName, & + checkName, checkPublicId, checkNCName + use m_common_struct, only: xml_doc_state, init_xml_doc_state, destroy_xml_doc_state + + use m_dom_error, only: DOMException, throw_exception, inException, getExceptionCode, & + NO_MODIFICATION_ALLOWED_ERR, NOT_FOUND_ERR, HIERARCHY_REQUEST_ERR, & + WRONG_DOCUMENT_ERR, FoX_INTERNAL_ERROR, FoX_NODE_IS_NULL, FoX_LIST_IS_NULL, & + INUSE_ATTRIBUTE_ERR, FoX_MAP_IS_NULL, INVALID_CHARACTER_ERR, NAMESPACE_ERR, & + FoX_INVALID_PUBLIC_ID, FoX_INVALID_SYSTEM_ID, FoX_IMPL_IS_NULL, FoX_INVALID_NODE, & + FoX_INVALID_CHARACTER, FoX_INVALID_COMMENT, FoX_INVALID_CDATA_SECTION, & + FoX_INVALID_PI_DATA, NOT_SUPPORTED_ERR, FoX_INVALID_ENTITY, & + INDEX_SIZE_ERR, FoX_NO_SUCH_ENTITY, FoX_HIERARCHY_REQUEST_ERR, & + FoX_INVALID_URI + + implicit none + private + + + integer, parameter :: configParamLen = 42 + + character(len=configParamLen), parameter :: configParams(24) = (/ & + ! DOM 3 Core: + "canonical-form ", & + "cdata-sections ", & + "check-character-normalization ", & + "comments ", & + "datatype-normalization ", & + "element-content-whitespace ", & + "entities ", & + "error-handler ", & +! "infoset ", & is not a real config option + "namespaces ", & + "namespace-declarations ", & + "normalize-characters ", & +! "schema-location ", & we dont implement +! "schema-type ", & we dont implement + "split-cdata-sections ", & + "validate ", & + "validate-if-schema ", & + "well-formed ", & + ! DOM 3 LS (Parser): + "charset-overrides-xml-encoding ", & + "disallow-doctype ", & + "ignore-unknown-character-denormalizations", & + "resource-resolver ", & + "supported-media-types-only ", & + ! DOM 3 LS (Serializer) + "discard-default-content ", & + "format-pretty-print ", & + "xml-declaration ", & + ! Extra (FoX) configuration options + "invalid-pretty-print " /) + + integer, parameter :: paramSettable = 27293398 + integer, parameter :: paramDefaults = 10786516 + + type DOMConfiguration + private + integer :: parameters = paramDefaults + ! FIXME make sure this is 32 bit at least. + end type DOMConfiguration + + interface canSetParameter + module procedure canSetParameter_log + module procedure canSetParameter_ch + end interface canSetParameter + + public :: setParameter + public :: getParameter + public :: canSetParameter + public :: getParameterNames + + public :: newDOMConfig + public :: copyDOMConfig + + + integer, parameter :: ELEMENT_NODE = 1 + integer, parameter :: ATTRIBUTE_NODE = 2 + integer, parameter :: TEXT_NODE = 3 + integer, parameter :: CDATA_SECTION_NODE = 4 + integer, parameter :: ENTITY_REFERENCE_NODE = 5 + integer, parameter :: ENTITY_NODE = 6 + integer, parameter :: PROCESSING_INSTRUCTION_NODE = 7 + integer, parameter :: COMMENT_NODE = 8 + integer, parameter :: DOCUMENT_NODE = 9 + integer, parameter :: DOCUMENT_TYPE_NODE = 10 + integer, parameter :: DOCUMENT_FRAGMENT_NODE = 11 + integer, parameter :: NOTATION_NODE = 12 + integer, parameter :: XPATH_NAMESPACE_NODE = 13 + + type DOMImplementation + private + character(len=7) :: id = "FoX_DOM" + logical :: FoX_checks = .true. ! Do extra checks not mandated by DOM + end type DOMImplementation + + type ListNode + private + type(Node), pointer :: this => null() + end type ListNode + + type NodeList + private + character, pointer :: nodeName(:) => null() ! What was getByTagName run on? + character, pointer :: localName(:) => null() ! What was getByTagNameNS run on? + character, pointer :: namespaceURI(:) => null() ! What was getByTagNameNS run on? + type(Node), pointer :: element => null() ! which element or document was the getByTagName run from? + type(ListNode), pointer :: nodes(:) => null() + integer :: length = 0 + end type NodeList + + type NodeListptr + private + type(NodeList), pointer :: this + end type NodeListptr + + type NamedNodeMap + private + logical :: readonly = .false. + type(Node), pointer :: ownerElement => null() + type(ListNode), pointer :: nodes(:) => null() + integer :: length = 0 + end type NamedNodeMap + + type documentExtras + type(DOMImplementation), pointer :: implementation => null() ! only for doctype + type(Node), pointer :: docType => null() + type(Node), pointer :: documentElement => null() + character, pointer :: inputEncoding(:) => null() + character, pointer :: xmlEncoding(:) => null() + type(NodeListPtr), pointer :: nodelists(:) => null() ! document + ! In order to keep track of all nodes not connected to the document + logical :: liveNodeLists ! For the document, are nodelists live? + type(NodeList) :: hangingNodes ! For the document, list of nodes not associated with doc + type(xml_doc_state), pointer :: xds => null() + logical :: strictErrorChecking = .true. + logical :: brokenNS = .false. ! FIXME consolidate these logical variables into bitmask + type(DOMConfiguration), pointer :: domConfig => null() + end type documentExtras + + type elementOrAttributeExtras + ! Needed for all: + character, pointer, dimension(:) :: namespaceURI => null() + character, pointer, dimension(:) :: prefix => null() + character, pointer, dimension(:) :: localName => null() + ! Needed for elements: + type(NamedNodeMap) :: attributes + type(NodeList) :: namespaceNodes + ! Needed for attributes: + type(Node), pointer :: ownerElement => null() + logical :: specified = .true. + logical :: isId = .false. + logical :: dom1 = .false. + end type elementOrAttributeExtras + + type docTypeExtras + character, pointer :: publicId(:) => null() ! doctype, entity, notation + character, pointer :: systemId(:) => null() ! doctype, entity, notation + character, pointer :: notationName(:) => null() ! entity + logical :: illFormed = .false. ! entity + type(namedNodeMap) :: entities ! doctype + type(namedNodeMap) :: notations ! doctype + end type docTypeExtras + + type Node + private + logical :: readonly = .false. + character, pointer, dimension(:) :: nodeName => null() + character, pointer, dimension(:) :: nodeValue => null() + integer :: nodeType = 0 + type(Node), pointer :: parentNode => null() + type(Node), pointer :: firstChild => null() + type(Node), pointer :: lastChild => null() + type(Node), pointer :: previousSibling => null() + type(Node), pointer :: nextSibling => null() + type(Node), pointer :: ownerDocument => null() + type(NodeList) :: childNodes ! not for text, cdata, PI, comment, notation, docType, XPath + logical :: inDocument = .false.! For a node, is this node associated to the doc? + logical :: ignorableWhitespace = .false. ! Text nodes only + type(documentExtras), pointer :: docExtras => null() + type(elementOrAttributeExtras), pointer :: elExtras => null() + type(docTypeExtras), pointer :: dtdExtras => null() + integer :: textContentLength = 0 + end type Node + + type(DOMImplementation), save, target :: FoX_DOM + + interface destroy + module procedure destroyNode + module procedure destroyNodeList + module procedure destroyNamedNodeMap + module procedure destroyDOMConfig + end interface destroy + + public :: ELEMENT_NODE + public :: ATTRIBUTE_NODE + public :: TEXT_NODE + public :: CDATA_SECTION_NODE + public :: ENTITY_REFERENCE_NODE + public :: ENTITY_NODE + public :: PROCESSING_INSTRUCTION_NODE + public :: COMMENT_NODE + public :: DOCUMENT_NODE + public :: DOCUMENT_TYPE_NODE + public :: DOCUMENT_FRAGMENT_NODE + public :: NOTATION_NODE + + public :: DOMImplementation + public :: DOMConfiguration + public :: Node + + public :: ListNode + public :: NodeList + public :: NamedNodeMap + + public :: destroy + public :: destroyAllNodesRecursively + + + + public :: getNodeName + public :: getNodeValue + public :: setNodeValue + public :: getNodeType + public :: getParentNode + public :: getChildNodes + public :: getFirstChild + public :: getLastChild + public :: getNextSibling + public :: getPreviousSibling + public :: getAttributes + public :: getOwnerDocument + public :: insertBefore + public :: replaceChild + public :: removeChild + public :: appendChild + public :: hasChildNodes + public :: cloneNode + public :: normalize + public :: isSupported + public :: getNamespaceURI + public :: getPrefix + public :: setPrefix + public :: getLocalName + public :: hasAttributes + public :: isEqualNode + public :: isSameNode + public :: isDefaultNamespace + public :: lookupNamespaceURI + public :: lookupPrefix + public :: getTextContent + public :: setTextContent + + public :: getNodePath + + public :: setStringValue + public :: getStringValue + public :: setReadonlyNode + public :: getReadOnly + + public :: getBaseURI + + + + public :: item + public :: append + public :: pop_nl + public :: remove_nl + public :: destroyNodeList + + interface append + module procedure append_nl + end interface + + interface item + module procedure item_nl + end interface + + interface getLength + module procedure getLength_nl + end interface getLength + + + public :: getNamedItem + public :: setNamedItem + public :: removeNamedItem +! public :: item +! public :: getLength + public :: getNamedItemNS + public :: setNamedItemNS + public :: removeNamedItemNS + +! public :: append + public :: setReadOnlyMap + public :: destroyNamedNodeMap + + + interface item + module procedure item_nnm + end interface + + interface getLength + module procedure getLength_nnm + end interface + + + + public :: hasFeature + public :: createDocument + public :: createDocumentType + + public :: destroyDocument + public :: createEmptyDocument + + public :: getFoX_checks + public :: setFoX_checks + + + +!FIXME lots of these should have a check if(namespaces) checkNCName + + public :: getDocType + public :: getImplementation + public :: getDocumentElement + public :: setDocumentElement + + public :: createElement + public :: createDocumentFragment + public :: createTextNode + public :: createComment + public :: createCdataSection + public :: createProcessingInstruction + public :: createAttribute + public :: createEntityReference + public :: createEmptyEntityReference + public :: getElementsByTagName + public :: getChildrenByTagName + public :: importNode + public :: createElementNS + public :: createAttributeNS + public :: getElementsByTagNameNS + public :: getElementById + public :: getXmlStandalone + public :: setXmlStandalone + public :: getXmlVersion + public :: setXmlVersion + public :: getXmlEncoding + public :: getInputEncoding + public :: getDocumentURI + public :: setDocumentURI + public :: getStrictErrorChecking + public :: setStrictErrorChecking + public :: getDomConfig + public :: renameNode + public :: adoptNode + + public :: setDocType + public :: setDomConfig + public :: setXds + public :: createNamespaceNode + public :: createEntity + public :: createNotation + public :: setGCstate + public :: getXds + public :: getLiveNodeLists + public :: setLiveNodeLists + + + !public :: getName + public :: getEntities + public :: getNotations +! public :: getPublicId +! public :: getSystemId + public :: getInternalSubset + + + + public :: getTagName + public :: getAttribute + public :: setAttribute + public :: removeAttribute + public :: getAttributeNode + public :: setAttributeNode + public :: removeAttributeNode + public :: getAttributeNS + public :: setAttributeNS + public :: removeAttributeNS + public :: getAttributeNodeNS + public :: setAttributeNodeNS + public :: removeAttributeNodeNS + public :: hasAttribute + public :: hasAttributeNS + public :: setIdAttribute + public :: setIdAttributeNS + public :: setIdAttributeNode + + + + !public :: getName + public :: getSpecified + public :: setSpecified + interface getValue + module procedure getValue_DOM + end interface + public :: getValue + public :: setValue + public :: getOwnerElement + + public :: getIsId + public :: setIsId + interface getIsId + module procedure getIsId_DOM + end interface + interface setIsId + module procedure setIsId_DOM + end interface + + + + public :: getLength +! public :: getData +! public :: setData + public :: substringData + public :: appendData + public :: insertData + public :: deleteData + public :: replaceData + + interface getLength + module procedure getLength_characterdata + end interface + + + + public :: getNotationName + + public :: getIllFormed + public :: setIllFormed + + + + public :: getTarget + + + public :: splitText + public :: getIsElementContentWhitespace + public :: setIsElementContentWhitespace + + +! Assorted functions with identical signatures despite belonging to different types. + + public :: getData + public :: setData + public :: getName + public :: getPublicId + public :: getSystemId + + + + public :: normalizeDocument + + public :: getNamespaceNodes + public :: namespaceFixup + + +contains + + + subroutine resetParameter(domConfig, name) + type(DOMConfiguration), pointer :: domConfig + character(len=*), intent(in) :: name + + integer :: i, n + do i = 1, size(configParams) + if (toLower(name)==trim(configParams(i))) then + n = i + exit + endif + enddo + if (i>size(configParams)) return + if (.not.btest(paramSettable, n)) return + if (btest(paramDefaults, n)) then + domConfig%parameters = ibset(domConfig%parameters, n) + else + domConfig%parameters = ibclr(domConfig%parameters, n) + endif + end subroutine resetParameter + + recursive subroutine setParameter(domConfig, name, value, ex) + type(DOMException), intent(out), optional :: ex + type(DOMConfiguration), pointer :: domConfig + character(len=*), intent(in) :: name + logical, intent(in) :: value + integer :: i, n + + if (toLower(name)=="infoset") then + if (value) then + call setParameter(domConfig, "validate-if-schema", .false.) + call setParameter(domConfig, "entities", .false.) + ! cant do datatype-normalization + call setParameter(domConfig, "cdata-sections", .false.) + call setParameter(domConfig, "namespace-declarations", .true.) + ! well-formed cannot be changed + call setParameter(domConfig, "element-content-whitespace", .true.) + call setParameter(domConfig, "comments", .true.) + call setParameter(domConfig, "namespaces", .true.) + endif + return + endif + + do i = 1, size(configParams) + if (toLower(name)==trim(configParams(i))) then + n = i + exit + endif + enddo + if (i > size(configParams)) then + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "setParameter", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (.not.canSetParameter(domConfig, name, value)) then + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "setParameter", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (value) then + domConfig%parameters = ibset(domConfig%parameters, n) + else + domConfig%parameters = ibclr(domConfig%parameters, n) + endif + + select case (toLower(name)) + case ("canonical-form") + if (value) then + domConfig%parameters = ibclr(domConfig%parameters, 7) + ! cant do normalize-characters + domConfig%parameters = ibclr(domConfig%parameters, 2) + domConfig%parameters = ibset(domConfig%parameters, 9) + domConfig%parameters = ibset(domConfig%parameters, 10) + ! well-formed cannot be changed + domConfig%parameters = ibset(domConfig%parameters, 6) + ! FIXME when we work out pretty-print/preserve-whitespace semantics + ! call setParameter(domConfig, "format-pretty-print", .false.) + domConfig%parameters = ibclr(domConfig%parameters, 21) + domConfig%parameters = ibclr(domConfig%parameters, 23) + domConfig%parameters = ibclr(domConfig%parameters, 24) + else + call resetParameter(domConfig, "entities") + ! cant do normalize-characters + call resetParameter(domConfig, "cdata-sections") + call resetParameter(domConfig, "namespaces") + call resetParameter(domConfig, "namespace-declarations") + ! well-formed cannot be changed + call resetParameter(domConfig, "element-content-whitespace") + call resetParameter(domConfig, "format-pretty-print") + call resetParameter(domConfig, "discard-default-content") + call resetParameter(domConfig, "xml-declaration") + call resetParameter(domConfig, "invalid-pretty-print") + endif + case ("cdata-sections") + if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) + case ("element-content-whitespace") + if (.not.value) domConfig%parameters = ibclr(domConfig%parameters, 1) + case ("entities") + if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) + case ("namespaces") + if (.not.value) domConfig%parameters = ibclr(domConfig%parameters, 1) + case ("namespaces-declarations") + if (.not.value) domConfig%parameters = ibclr(domConfig%parameters, 1) + case("validate") + if (value) domConfig%parameters = ibclr(domConfig%parameters, 14) + case ("validate-if-schema") + if (value) domConfig%parameters = ibclr(domConfig%parameters, 13) + case ("format-pretty-print") + if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) + case ("discard-default-content") + if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) + case ("xml-declaration") + if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) + case ("invalid-pretty-print") + if (value) domConfig%parameters = ibclr(domConfig%parameters, 1) + end select + + end subroutine setParameter + + recursive function getParameter(domConfig, name, ex)result(value) + type(DOMException), intent(out), optional :: ex + type(DOMConfiguration), pointer :: domConfig + character(len=*), intent(in) :: name + logical :: value + + integer :: i, n + + if (toLower(name)=="infoset") then + value = & + .not.getParameter(domConfig, "validate-if-schema") & + .and..not.getParameter(domConfig, "entities") & + .and..not.getParameter(domConfig, "datatype-normalization") & + .and..not.getParameter(domConfig, "cdata-sections") & + .and.getParameter(domConfig, "namespace-declarations") & + .and.getParameter(domConfig, "well-formed") & + .and.getParameter(domConfig, "element-content-whitespace") & + .and.getParameter(domConfig, "comments") & + .and.getParameter(domConfig, "namespaces") + return + endif + + do i = 1, size(configParams) + if (toLower(name)==trim(configParams(i))) then + n = i + exit + endif + enddo + if (i > size(configParams)) then + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "getParameter", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + value = btest(domConfig%parameters, n) + + end function getParameter + + function canSetParameter_log(domConfig, name, value, ex)result(p) + type(DOMException), intent(out), optional :: ex + type(DOMConfiguration), pointer :: domConfig + character(len=*), intent(in) :: name + logical, intent(in) :: value + logical :: p + + integer :: i, n + + if (toLower(name)=="infoset") then + p = .true. + return + endif + do i = 1, size(configParams) + if (toLower(name)==trim(configParams(i))) then + n = i + exit + endif + enddo + if (i > size(configParams)) then + p = .false. + return + endif + + p = btest(paramSettable, n) + + end function canSetParameter_log + + function canSetParameter_ch(domConfig, name, value, ex)result(p) + type(DOMException), intent(out), optional :: ex + type(DOMConfiguration), pointer :: domConfig + character(len=*), intent(in) :: name + character(len=*), intent(in) :: value + logical :: p + + ! DOM 3 allows some config options to be set to strings + ! (eg schemaLocation) but we dont support any of these, + ! so no parameter can be set to a string. + p = .false. + + end function canSetParameter_ch + + function getParameterNames(domConfig, ex)result(s) + type(DOMException), intent(out), optional :: ex + type(DOMConfiguration), pointer :: domConfig + character(len=configParamLen) :: s(size(configParams)) + + s = configParams + end function getParameterNames + + function newDOMConfig() result(dc) + type(DOMConfiguration), pointer :: dc + allocate(dc) + end function newDOMConfig + + subroutine copyDOMConfig(dc1, dc2) + type(DOMConfiguration), pointer :: dc1, dc2 + + dc1%parameters = dc2%parameters + end subroutine copyDOMConfig + + subroutine destroyDOMConfig(dc) + type(DOMConfiguration), pointer :: dc + + deallocate(dc) + end subroutine destroyDOMConfig + + + + function createNode(arg, nodeType, nodeName, nodeValue, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer, intent(in) :: nodeType + character(len=*), intent(in) :: nodeName + character(len=*), intent(in) :: nodeValue + type(Node), pointer :: np + + allocate(np) + np%ownerDocument => arg + np%nodeType = nodeType + np%nodeName => vs_str_alloc(nodeName) + np%nodeValue => vs_str_alloc(nodeValue) + + allocate(np%childNodes%nodes(0)) + + end function createNode + + recursive subroutine destroyNode(np, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + + if (.not.associated(np)) return + + select case(np%nodeType) + case (ELEMENT_NODE, ATTRIBUTE_NODE, XPATH_NAMESPACE_NODE) + call destroyElementOrAttribute(np, ex) + case (DOCUMENT_TYPE_NODE) + call destroyDocumentType(np, ex) + case (ENTITY_NODE, NOTATION_NODE) + call destroyEntityOrNotation(np, ex) + case (DOCUMENT_NODE) + call destroyDocument(np,ex) + end select + call destroyNodeContents(np) + deallocate(np) + + end subroutine destroyNode + + recursive subroutine destroyElementOrAttribute(np, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + + integer :: i + + if (np%nodeType /= ELEMENT_NODE & + .and. np%nodeType /= ATTRIBUTE_NODE & + .and. np%nodeType /= XPATH_NAMESPACE_NODE) then + if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then + call throw_exception(FoX_INTERNAL_ERROR, "destroyElementOrAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (associated(np%elExtras%attributes%nodes)) deallocate(np%elExtras%attributes%nodes) + do i = 1, np%elExtras%namespaceNodes%length + call destroyNode(np%elExtras%namespaceNodes%nodes(i)%this) + enddo + if (associated(np%elExtras%namespaceNodes%nodes)) deallocate(np%elExtras%namespaceNodes%nodes) + if (associated(np%elExtras%namespaceURI)) deallocate(np%elExtras%namespaceURI) + if (associated(np%elExtras%prefix)) deallocate(np%elExtras%prefix) + if (associated(np%elExtras%localName)) deallocate(np%elExtras%localName) + deallocate(np%elExtras) + + end subroutine destroyElementOrAttribute + + subroutine destroyEntityOrNotation(np, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + + if (np%nodeType /= ENTITY_NODE & + .and. np%nodeType /= NOTATION_NODE) then + if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then + call throw_exception(FoX_INTERNAL_ERROR, "destroyEntityOrNotation", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (associated(np%dtdExtras%publicId)) deallocate(np%dtdExtras%publicId) + if (associated(np%dtdExtras%systemId)) deallocate(np%dtdExtras%systemId) + if (associated(np%dtdExtras%notationName)) deallocate(np%dtdExtras%notationName) + + deallocate(np%dtdExtras) + + end subroutine destroyEntityOrNotation + + subroutine destroyDocumentType(np, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + + integer :: i + + if (np%nodeType /= DOCUMENT_TYPE_NODE) then + if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then + call throw_exception(FoX_INTERNAL_ERROR, "destroyDocumentType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (associated(np%dtdExtras%publicId)) deallocate(np%dtdExtras%publicId) + if (associated(np%dtdExtras%systemId)) deallocate(np%dtdExtras%systemId) + + ! Destroy all entities & notations (docType only) + if (associated(np%dtdExtras%entities%nodes)) then + do i = 1, size(np%dtdExtras%entities%nodes) + call destroyAllNodesRecursively(np%dtdExtras%entities%nodes(i)%this) + enddo + deallocate(np%dtdExtras%entities%nodes) + endif + if (associated(np%dtdExtras%notations%nodes)) then + do i = 1, size(np%dtdExtras%notations%nodes) + call destroy(np%dtdExtras%notations%nodes(i)%this) + enddo + deallocate(np%dtdExtras%notations%nodes) + endif + + deallocate(np%dtdExtras) + + end subroutine destroyDocumentType + + recursive subroutine destroyAllNodesRecursively(arg, except) + ! Only recurses once into destroyDocumentType + type(Node), pointer :: arg + logical, intent(in), optional :: except + + type(Node), pointer :: this, deadNode, treeroot + logical :: doneChildren, doneAttributes + integer :: i_tree + + if (.not.associated(arg)) return + + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + deadNode => null() + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + deadNode => null() + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + deadNode => this + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + endif + call destroy(deadNode) + endif + + enddo + + + + deallocate(arg%childNodes%nodes) + allocate(arg%childNodes%nodes(0)) + arg%firstChild => null() + arg%lastChild => null() + + if (.not.present(except)) call destroyNode(arg) + + end subroutine destroyAllNodesRecursively + + subroutine destroyNodeContents(np) + type(Node), intent(inout) :: np + + if (associated(np%nodeName)) deallocate(np%nodeName) + if (associated(np%nodeValue)) deallocate(np%nodeValue) + + deallocate(np%childNodes%nodes) + + end subroutine destroyNodeContents + + + + + pure function getnodeName_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + if (p) then + n = size(np%nodeName) + else + n = 0 + endif + end function getnodeName_len +function getnodeName(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getnodeName_len(np, .true.)) :: c +#else + character(len=getnodeName_len(np, associated(np))) :: c +#endif + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getnodeName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + c = str_vs(np%nodeName) + + end function getnodeName + + + pure function getNodeValue_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + n = 0 + if (.not.p) return + + select case(np%nodeType) + case (ATTRIBUTE_NODE) + n = getTextContent_len(np, .true.) + case (CDATA_SECTION_NODE, COMMENT_NODE, PROCESSING_INSTRUCTION_NODE, TEXT_NODE) + n = size(np%nodeValue) + end select + + end function getNodeValue_len + + function getNodeValue(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getNodeValue_len(np, .true.)) :: c +#else + character(len=getNodeValue_len(np, associated(np))) :: c +#endif + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getNodeValue", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + select case(np%nodeType) + case (ATTRIBUTE_NODE) + c = getTextContent(np) + case (CDATA_SECTION_NODE, COMMENT_NODE, PROCESSING_INSTRUCTION_NODE, TEXT_NODE) + c = str_vs(np%nodeValue) + case default + c = "" + end select + + end function getNodeValue + + subroutine setNodeValue(arg, nodeValue, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*) :: nodeValue + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setNodeValue", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (associated(getOwnerDocument(arg))) then + if (.not.checkChars(nodeValue, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then + call throw_exception(FoX_INVALID_CHARACTER, "setNodeValue", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + endif ! Otherwise its a document node, and nothing will happen anyway + + select case(arg%nodeType) + case (ATTRIBUTE_NODE) + call setValue(arg, nodeValue, ex) + case (CDATA_SECTION_NODE, COMMENT_NODE, PROCESSING_INSTRUCTION_NODE, TEXT_NODE) + call setData(arg, nodeValue, ex) + end select + + end subroutine setNodeValue + +function getnodeType(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + integer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getnodeType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + c = np%nodeType + + end function getnodeType + + +function getparentNode(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(Node), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getparentNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + c => np%parentNode + + end function getparentNode + + +function getchildNodes(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(NodeList), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getchildNodes", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + c => np%childNodes + + end function getchildNodes + + +function getfirstChild(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(Node), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getfirstChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + c => np%firstChild + + end function getfirstChild + + +function getlastChild(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(Node), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getlastChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + c => np%lastChild + + end function getlastChild + + +function getpreviousSibling(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(Node), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getpreviousSibling", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + c => np%previousSibling + + end function getpreviousSibling + + +function getnextSibling(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(Node), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getnextSibling", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + c => np%nextSibling + + end function getnextSibling + + + function getAttributes(arg, ex)result(nnm) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(NamedNodeMap), pointer :: nnm + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getAttributes", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(arg)==ELEMENT_NODE) then + nnm => arg%elExtras%attributes + else + nnm => null() + endif + end function getAttributes + + function getOwnerDocument(arg, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getOwnerDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType==DOCUMENT_NODE) then + np => null() + else + np => arg%ownerDocument + endif + end function getOwnerDocument + +subroutine setownerDocument(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(Node), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setownerDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setownerDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np%ownerDocument => c + + end subroutine setownerDocument + + + function insertBefore(arg, newChild, refChild, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: newChild + type(Node), pointer :: refChild + type(Node), pointer :: np + + type(Node), pointer :: testChild, testParent, treeroot, this + type(ListNode), pointer :: temp_nl(:) + integer :: i, i2, i_t, i_tree + logical :: doneChildren, doneAttributes + + if (.not.associated(arg).or..not.associated(newChild)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.associated(refChild)) then + np => appendChild(arg, newChild, ex) + return + endif + + if (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + testParent => arg + ! Check if you are allowed to put a newChild nodetype under a arg nodetype + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + do i = 1, newChild%childNodes%length + testChild => newChild%childNodes%nodes(i)%this + select case(testParent%nodeType) + case (ELEMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ATTRIBUTE_NODE) + if (testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (testChild%nodeType==ENTITY_REFERENCE_NODE) then + treeroot => testChild + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + if (getNodeType(this)/=TEXT_NODE.and.getNodeType(this)/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.FoX_HIERARCHY_REQUEST_ERR<200) then + call throw_exception(FoX_HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + endif + endif + + enddo + + + endif + case (DOCUMENT_NODE) + if ((testChild%nodeType/=ELEMENT_NODE .or. & + (testChild%nodeType==ELEMENT_NODE & + .and.associated(testParent%docExtras%documentElement))) & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. (testChild%nodeType/=DOCUMENT_TYPE_NODE .or. & + (testChild%nodeType==DOCUMENT_TYPE_NODE & + .and.associated(testParent%docExtras%docType)))) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (DOCUMENT_FRAGMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ENTITY_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case (ENTITY_REFERENCE_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case default + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + end select + + enddo + else + testChild => newChild + select case(testParent%nodeType) + case (ELEMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ATTRIBUTE_NODE) + if (testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (testChild%nodeType==ENTITY_REFERENCE_NODE) then + treeroot => testChild + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + if (getNodeType(this)/=TEXT_NODE.and.getNodeType(this)/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.FoX_HIERARCHY_REQUEST_ERR<200) then + call throw_exception(FoX_HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + endif + endif + + enddo + + + endif + case (DOCUMENT_NODE) + if ((testChild%nodeType/=ELEMENT_NODE .or. & + (testChild%nodeType==ELEMENT_NODE & + .and.associated(testParent%docExtras%documentElement))) & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. (testChild%nodeType/=DOCUMENT_TYPE_NODE .or. & + (testChild%nodeType==DOCUMENT_TYPE_NODE & + .and.associated(testParent%docExtras%docType)))) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (DOCUMENT_FRAGMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ENTITY_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case (ENTITY_REFERENCE_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case default + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + end select + + ! And then check that newChild is not arg or one of args ancestors + ! (this would never be true if newChild is a documentFragment) + testParent => arg + do while (associated(testParent)) + if (associated(testParent, newChild)) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + testParent => testParent%parentNode + enddo + endif + + if (getNodeType(newChild)/=DOCUMENT_TYPE_NODE.and. & + .not.(associated(arg%ownerDocument, newChild%ownerDocument) & + .or.associated(arg, newChild%ownerDocument))) then + if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then + call throw_exception(WRONG_DOCUMENT_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE & + .and. newChild%childNodes%length==0) then + np => newChild + return + ! Nothing to do + endif + if (associated(getParentNode(newChild))) then + np => removeChild(getParentNode(newChild), newChild, ex) + newChild => np + endif + + if (arg%childNodes%length==0) then + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + allocate(temp_nl(arg%childNodes%length+newChild%childNodes%length)) + else + allocate(temp_nl(arg%childNodes%length+1)) + endif + + i_t = 0 + np => null() + do i = 1, arg%childNodes%length + if (associated(arg%childNodes%nodes(i)%this, refChild)) then + np => refChild + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + do i2 = 1, newChild%childNodes%length + i_t = i_t + 1 + temp_nl(i_t)%this => newChild%childNodes%nodes(i2)%this + temp_nl(i_t)%this%parentNode => arg +! call namespaceFixup(temp_nl(i_t)%this) + enddo + else + i_t = i_t + 1 + temp_nl(i_t)%this => newChild + temp_nl(i_t)%this%parentNode => arg +! call namespaceFixup(temp_nl(i_t)%this) + endif + if (i==1) then + arg%firstChild => temp_nl(1)%this + !temp_nl(1)%this%previousSibling => null() ! This is a no-op + else + temp_nl(i-1)%this%nextSibling => temp_nl(i)%this + temp_nl(i)%this%previousSibling => temp_nl(i-1)%this + endif + arg%childNodes%nodes(i)%this%previousSibling => temp_nl(i_t)%this + temp_nl(i_t)%this%nextSibling => arg%childNodes%nodes(i)%this + endif + i_t = i_t + 1 + temp_nl(i_t)%this => arg%childNodes%nodes(i)%this + enddo + + if (.not.associated(np)) then + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "insertBefore", ex) + if (present(ex)) then + if (inException(ex)) then + + if (associated(temp_nl)) deallocate(temp_nl) + return + endif + endif +endif + + endif + + np => newChild + if (getGCstate(arg%ownerDocument)) then + if (arg%inDocument) then + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + do i = 1, newChild%childNodes%length + call putNodesInDocument(arg%ownerDocument, newChild%childNodes%nodes(i)%this) + enddo + else + call putNodesInDocument(arg%ownerDocument, newChild) + endif + ! If newChild was originally in document, it was removed above so must be re-added + ! Ideally we would avoid the cost of removal & readding to hanging nodelist + endif + ! If arg was not in the document, then newChildren were either + ! a) removed above in call to removeChild or + ! b) in a document fragment and therefore not part of doc either + endif + + + if (getNodeType(newChild)==DOCUMENT_FRAGMENT_NODE) then + deallocate(newChild%childNodes%nodes) + allocate(newChild%childNodes%nodes(0)) + newChild%childNodes%length = 0 + endif + deallocate(arg%childNodes%nodes) + arg%childNodes%nodes => temp_nl + arg%childNodes%length = size(arg%childNodes%nodes) + + call updateNodeLists(arg%ownerDocument) + + call updateTextContentLength(arg, newChild%textContentLength) + + end function insertBefore + + + function replaceChild(arg, newChild, oldChild, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: newChild + type(Node), pointer :: oldChild + type(Node), pointer :: np + + type(Node), pointer :: testChild, testParent, treeroot, this + type(ListNode), pointer :: temp_nl(:) + integer :: i, i2, i_t, i_tree + logical :: doneChildren, doneAttributes + + if (.not.associated(arg).or..not.associated(newChild).or..not.associated(oldChild)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + testParent => arg + ! Check if you are allowed to put a newChild nodetype under a arg nodetype + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + do i = 1, newChild%childNodes%length + testChild => newChild%childNodes%nodes(i)%this + select case(testParent%nodeType) + case (ELEMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ATTRIBUTE_NODE) + if (testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (testChild%nodeType==ENTITY_REFERENCE_NODE) then + treeroot => testChild + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + if (getNodeType(this)/=TEXT_NODE.and.getNodeType(this)/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.FoX_HIERARCHY_REQUEST_ERR<200) then + call throw_exception(FoX_HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + endif + endif + + enddo + + + endif + case (DOCUMENT_NODE) + if ((testChild%nodeType/=ELEMENT_NODE .or. & + (testChild%nodeType==ELEMENT_NODE & + .and.associated(testParent%docExtras%documentElement) & + .and.oldChild%nodeType/=ELEMENT_NODE)) & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. (testChild%nodeType/=DOCUMENT_TYPE_NODE .or. & + (testChild%nodeType==DOCUMENT_TYPE_NODE & + .and.associated(testParent%docExtras%docType) & + .and.oldChild%nodeType/=DOCUMENT_TYPE_NODE))) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (DOCUMENT_FRAGMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ENTITY_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case (ENTITY_REFERENCE_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case default + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + end select + + enddo + else + testChild => newChild + select case(testParent%nodeType) + case (ELEMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ATTRIBUTE_NODE) + if (testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (testChild%nodeType==ENTITY_REFERENCE_NODE) then + treeroot => testChild + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + if (getNodeType(this)/=TEXT_NODE.and.getNodeType(this)/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.FoX_HIERARCHY_REQUEST_ERR<200) then + call throw_exception(FoX_HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + endif + endif + + enddo + + + endif + case (DOCUMENT_NODE) + if ((testChild%nodeType/=ELEMENT_NODE .or. & + (testChild%nodeType==ELEMENT_NODE & + .and.associated(testParent%docExtras%documentElement) & + .and.oldChild%nodeType/=ELEMENT_NODE)) & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. (testChild%nodeType/=DOCUMENT_TYPE_NODE .or. & + (testChild%nodeType==DOCUMENT_TYPE_NODE & + .and.associated(testParent%docExtras%docType) & + .and.oldChild%nodeType/=DOCUMENT_TYPE_NODE))) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (DOCUMENT_FRAGMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ENTITY_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case (ENTITY_REFERENCE_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case default + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + end select + + ! And then check that newChild is not arg or one of args ancestors + ! (this would never be true if newChild is a documentFragment) + testParent => arg + do while (associated(testParent)) + if (associated(testParent, newChild)) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + testParent => testParent%parentNode + enddo + endif + + if (getNodeType(newChild)/=DOCUMENT_TYPE_NODE.and. & + .not.(associated(arg%ownerDocument, newChild%ownerDocument) & + .or.associated(arg, newChild%ownerDocument))) then + if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then + call throw_exception(WRONG_DOCUMENT_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (associated(getParentNode(newChild))) & + newChild => removeChild(getParentNode(newChild), newChild, ex) + + if (arg%childNodes%length==0) then + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + allocate(temp_nl(arg%childNodes%length+newChild%childNodes%length-1)) + else + temp_nl => arg%childNodes%nodes + endif + + i_t = 0 + np => null() + do i = 1, arg%childNodes%length + if (associated(arg%childNodes%nodes(i)%this, oldChild)) then + np => oldChild + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + do i2 = 1, newChild%childNodes%length + i_t = i_t + 1 + temp_nl(i_t)%this => newChild%childNodes%nodes(i2)%this + temp_nl(i_t)%this%parentNode => arg +! call namespaceFixup(temp_nl(i_t)%this) + enddo + else + i_t = i_t + 1 + temp_nl(i_t)%this => newChild + temp_nl(i_t)%this%parentNode => arg +! call namespaceFixup(temp_nl(i_t)%this) + endif + if (i==1) then + arg%firstChild => temp_nl(1)%this + !temp_nl(1)%this%previousSibling => null() ! This is a no-op + else + temp_nl(i-1)%this%nextSibling => temp_nl(i)%this + temp_nl(i)%this%previousSibling => temp_nl(i-1)%this + endif + if (i==arg%childNodes%length) then + arg%lastChild => temp_nl(i_t)%this + !temp_nl(i_t)%this%nextSibling => null() ! This is a no-op + else + arg%childNodes%nodes(i+1)%this%previousSibling => temp_nl(i_t)%this + temp_nl(i_t)%this%nextSibling => arg%childNodes%nodes(i+1)%this + endif + else + i_t = i_t + 1 + temp_nl(i_t)%this => arg%childNodes%nodes(i)%this + endif + enddo + + if (.not.associated(np)) then + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "replaceChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + np%parentNode => null() + np%previousSibling => null() + np%nextSibling => null() + +! call namespaceFixup(np) + + if (getGCstate(arg%ownerDocument)) then + if (arg%inDocument) then + call removeNodesFromDocument(arg%ownerDocument, oldChild) + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + do i = 1, newChild%childNodes%length + call putNodesInDocument(arg%ownerDocument, newChild%childNodes%nodes(i)%this) + enddo + else + call putNodesInDocument(arg%ownerDocument, newChild) + endif + ! If newChild was originally in document, it was removed above so must be re-added + ! Ideally we would avoid the cost of removing & re-adding to hangingnodelist + endif + ! If arg was not in the document, then newChildren were either + ! a) removed above in call to removeChild or + ! b) in a document fragment and therefore not part of doc either + endif + + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + deallocate(newChild%childNodes%nodes) + allocate(newChild%childNodes%nodes(0)) + newChild%childNodes%length = 0 + deallocate(arg%childNodes%nodes) + arg%childNodes%nodes => temp_nl + arg%childNodes%length = size(arg%childNodes%nodes) + endif + + call updateNodeLists(arg%ownerDocument) + + call updateTextContentLength(arg, newChild%textContentLength-oldChild%textContentLength) + + end function replaceChild + + + function removeChild(arg, oldChild, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: oldChild + type(Node), pointer :: np + + type(ListNode), pointer :: temp_nl(:) + integer :: i, i_t + + if (.not.associated(arg).or..not.associated(oldChild)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "removeChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "removeChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + allocate(temp_nl(size(arg%childNodes%nodes)-1)) + i_t = 1 + do i = 1, size(arg%childNodes%nodes) + if (associated(arg%childNodes%nodes(i)%this, oldChild)) then + if (associated(arg%firstChild, arg%lastChild)) then + ! There is only one child, we are removing it. + arg%firstChild => null() + arg%lastChild => null() + elseif (i==1) then + ! We are removing the first child, but there is a second + arg%firstChild => arg%childNodes%nodes(2)%this + arg%childNodes%nodes(2)%this%previousSibling => null() + elseif (i==size(arg%childNodes%nodes)) then + ! We are removing the last child, but there is a second-to-last + arg%lastChild => arg%childNodes%nodes(i-1)%this + arg%childNodes%nodes(i-1)%this%nextSibling => null() + else + ! We are removing a child in the middle + arg%childNodes%nodes(i-1)%this%nextSibling => arg%childNodes%nodes(i+1)%this + arg%childNodes%nodes(i+1)%this%previousSibling => arg%childNodes%nodes(i-1)%this + endif + else + if (i_t==size(arg%childNodes%nodes)) exit ! We have failed to find the child + temp_nl(i_t)%this => arg%childNodes%nodes(i)%this + i_t = i_t + 1 + endif + enddo + + deallocate(arg%childNodes%nodes) + arg%childNodes%nodes => temp_nl + arg%childNodes%length = size(temp_nl) + if (i==i_t) then + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "removeChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + oldChild%parentNode => null() + oldChild%previousSibling => null() + oldChild%nextSibling => null() + +! call namespaceFixup(oldChild) + + if (getGCstate(arg%ownerDocument)) then + if (arg%inDocument) then + call removeNodesFromDocument(arg%ownerDocument, oldChild) + endif + endif + + np => oldChild + + call updateNodeLists(arg%ownerDocument) + + call updateTextContentLength(arg, -oldChild%textContentLength) + + end function removeChild + + + function appendChild(arg, newChild, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: newChild + type(Node), pointer :: np + + type(Node), pointer :: testChild, testParent, treeroot, this + type(ListNode), pointer :: temp_nl(:) + integer :: i, i_t, i_tree + logical :: doneChildren, doneAttributes + + if (.not.associated(arg).or..not.associated(newChild)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + testParent => arg + ! Check if you are allowed to put a newChild nodetype under a arg nodetype + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + do i = 1, newChild%childNodes%length + testChild => newChild%childNodes%nodes(i)%this + select case(testParent%nodeType) + case (ELEMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ATTRIBUTE_NODE) + if (testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (testChild%nodeType==ENTITY_REFERENCE_NODE) then + treeroot => testChild + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + if (getNodeType(this)/=TEXT_NODE.and.getNodeType(this)/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.FoX_HIERARCHY_REQUEST_ERR<200) then + call throw_exception(FoX_HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + endif + endif + + enddo + + + endif + case (DOCUMENT_NODE) + if ((testChild%nodeType/=ELEMENT_NODE .or. & + (testChild%nodeType==ELEMENT_NODE & + .and.associated(testParent%docExtras%documentElement))) & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. (testChild%nodeType/=DOCUMENT_TYPE_NODE .or. & + (testChild%nodeType==DOCUMENT_TYPE_NODE & + .and.associated(testParent%docExtras%docType)))) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (DOCUMENT_FRAGMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ENTITY_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case (ENTITY_REFERENCE_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case default + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + end select + + enddo + else + testChild => newChild + select case(testParent%nodeType) + case (ELEMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ATTRIBUTE_NODE) + if (testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (testChild%nodeType==ENTITY_REFERENCE_NODE) then + treeroot => testChild + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + if (getNodeType(this)/=TEXT_NODE.and.getNodeType(this)/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.FoX_HIERARCHY_REQUEST_ERR<200) then + call throw_exception(FoX_HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + endif + endif + + enddo + + + endif + case (DOCUMENT_NODE) + if ((testChild%nodeType/=ELEMENT_NODE .or. & + (testChild%nodeType==ELEMENT_NODE & + .and.associated(testParent%docExtras%documentElement))) & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. (testChild%nodeType/=DOCUMENT_TYPE_NODE .or. & + (testChild%nodeType==DOCUMENT_TYPE_NODE & + .and.associated(testParent%docExtras%docType)))) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (DOCUMENT_FRAGMENT_NODE) + if (testChild%nodeType/=ELEMENT_NODE & + .and. testChild%nodeType/=TEXT_NODE & + .and. testChild%nodeType/=COMMENT_NODE & + .and. testChild%nodeType/=PROCESSING_INSTRUCTION_NODE & + .and. testChild%nodeType/=CDATA_SECTION_NODE & + .and. testChild%nodeType/=ENTITY_REFERENCE_NODE) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (ENTITY_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case (ENTITY_REFERENCE_NODE) + continue ! only allowed by DOM parser, not by user. + ! but entity nodes are always readonly anyway, so no problem + case default + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + end select + + ! And then check that newChild is not arg or one of args ancestors + ! (this would never be true if newChild is a documentFragment) + testParent => arg + do while (associated(testParent)) + if (associated(testParent, newChild)) then + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + testParent => testParent%parentNode + enddo + endif + + if (getNodeType(newChild)/=DOCUMENT_TYPE_NODE.and. & + .not.(associated(arg%ownerDocument, newChild%ownerDocument) & + .or.associated(arg, newChild%ownerDocument))) then + if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then + call throw_exception(WRONG_DOCUMENT_ERR, "appendChild", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE & + .and. newChild%childNodes%length==0) then + np => newChild + return + ! Nothing to do + endif + + if (associated(getParentNode(newChild))) & + newChild => removeChild(getParentNode(newChild), newChild, ex) + + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + allocate(temp_nl(arg%childNodes%length+newChild%childNodes%length)) + else + allocate(temp_nl(arg%childNodes%length+1)) + endif + + do i = 1, arg%childNodes%length + temp_nl(i)%this => arg%childNodes%nodes(i)%this + enddo + + if (newChild%nodeType==DOCUMENT_FRAGMENT_NODE) then + i_t = arg%childNodes%length + do i = 1, newChild%childNodes%length + i_t = i_t + 1 + temp_nl(i_t)%this => newChild%childNodes%nodes(i)%this + if (arg%inDocument) & + call putNodesInDocument(arg%ownerDocument, temp_nl(i_t)%this) + temp_nl(i_t)%this%parentNode => arg +! call namespaceFixup(temp_nl(i_t)%this) + enddo + if (arg%childNodes%length==0) then + arg%firstChild => newChild%firstChild + else + newChild%firstChild%previousSibling => arg%lastChild + arg%lastChild%nextSibling => newChild%firstChild + endif + arg%lastChild => newChild%lastChild + newChild%firstChild => null() + newChild%lastChild => null() + deallocate(newChild%childNodes%nodes) + allocate(newChild%childNodes%nodes(0)) + newChild%childNodes%length = 0 + else + temp_nl(i)%this => newChild + if (i==1) then + arg%firstChild => newChild + newChild%previousSibling => null() + else + temp_nl(i-1)%this%nextSibling => newChild + newChild%previousSibling => temp_nl(i-1)%this + endif + if (getGCstate(arg%ownerDocument)) then + if (arg%inDocument.and..not.newChild%inDocument) then + call putNodesInDocument(arg%ownerDocument, newChild) + endif + endif + newChild%nextSibling => null() + arg%lastChild => newChild + newChild%parentNode => arg +! call namespaceFixup(newChild) + endif + + deallocate(arg%childNodes%nodes) + arg%childNodes%nodes => temp_nl + arg%childNodes%length = size(temp_nl) + + np => newChild + + call updateNodeLists(arg%ownerDocument) + + call updateTextContentLength(arg, newChild%textContentLength) + + end function appendChild + + + function hasChildNodes(arg, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + logical :: hasChildNodes + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "hasChildNodes", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + hasChildNodes = associated(arg%firstChild) + + end function hasChildNodes + + recursive function cloneNode(arg, deep, ex)result(np) + type(DOMException), intent(out), optional :: ex + ! Needs to be recursive in case of entity-references within each other. + type(Node), pointer :: arg + logical, intent(in) :: deep + type(Node), pointer :: np + + type(Node), pointer :: doc, treeroot, thatParent, this, new, ERchild + + logical :: doneAttributes, doneChildren, readonly, brokenNS + integer :: i_tree + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "cloneNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + thatParent => null() + ERchild => null() + doc => getOwnerDocument(arg) + if (.not.associated(doc)) return + np => null() + brokenNS = doc%docExtras%brokenNS + doc%docExtras%brokenNS = .true. ! May need to do stupid NS things + readonly = .false. + + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + + new => null() + select case(getNodeType(this)) + case (ELEMENT_NODE) + if (getParameter(getDomConfig(doc), "namespaces")) then + new => createEmptyElementNS(doc, getNamespaceURI(this), getTagName(this)) + else + new => createEmptyElement(doc, getTagName(this)) + endif + case (ATTRIBUTE_NODE) + if (getParameter(getDomConfig(doc), "namespaces")) then + new => createAttributeNS(doc, getNamespaceURI(this), getName(this)) + else + new => createAttribute(doc, getName(this)) + endif + if (associated(this, arg)) then + call setSpecified(new, .true.) + else + call setSpecified(new, getSpecified(this)) + endif + case (TEXT_NODE) + new => createTextNode(doc, getData(this)) + case (CDATA_SECTION_NODE) + new => createCDataSection(doc, getData(this)) + case (ENTITY_REFERENCE_NODE) + ERchild => this + readonly = .true. + new => createEntityReference(doc, getNodeName(this)) + doneChildren = .true. + case (ENTITY_NODE) + return + case (PROCESSING_INSTRUCTION_NODE) + new => createProcessingInstruction(doc, getTarget(this), getData(this)) + case (COMMENT_NODE) + new => createComment(doc, getData(this)) + case (DOCUMENT_NODE) + return + case (DOCUMENT_TYPE_NODE) + return + case (DOCUMENT_FRAGMENT_NODE) + new => createDocumentFragment(doc) + case (NOTATION_NODE) + return + end select + + if (.not.associated(thatParent)) then + thatParent => new + elseif (associated(new)) then + if (this%nodeType==ATTRIBUTE_NODE) then + new => setAttributeNode(thatParent, new) + else + new => appendChild(thatParent, new) + endif + endif + + if (.not.deep) then + if (getNodeType(arg)==ATTRIBUTE_NODE.or.getNodeType(arg)==ELEMENT_NODE) then + continue + else + exit + endif + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + + if (getNodeType(this)==ENTITY_REFERENCE_NODE & + .and.associated(ERchild, this)) then + ERchild => null() + readonly = .false. + endif + this%readonly = readonly + + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + if (.not.associated(this, treeroot)) thatParent => getLastChild(thatParent) + this => item(getAttributes(this), 0) + else + if (.not.deep) exit + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + if (getNodeType(this)==ELEMENT_NODE.and..not.deep) exit + if (.not.associated(this, treeroot)) then + if (getNodeType(this)==ATTRIBUTE_NODE) then + thatParent => item(getAttributes(thatParent), i_tree) + else + thatParent => getLastChild(thatParent) + endif + endif + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + if (associated(getParentNode(thatParent))) thatParent => getParentNode(thatParent) + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + if (.not.associated(this, treeroot)) then + if (getNodeType(this)==ATTRIBUTE_NODE) then + thatParent => getOwnerElement(thatParent) + else + thatParent => getParentNode(thatParent) + endif + endif + endif + endif + + enddo + + + + np => thatParent + doc%docExtras%brokenNS = brokenNS + + end function cloneNode + + + function hasAttributes(arg, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + logical :: hasAttributes + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "hasAttributes", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType == ELEMENT_NODE) then + hasAttributes = (getLength(getAttributes(arg)) > 0) + else + hasAttributes = .false. + endif + + end function hasAttributes + +! function getBaseURI FIXME + +! function compareDocumentPosition FIXME + + subroutine normalize(arg, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: this, tempNode, oldNode, treeroot + integer :: i_tree, i_t + logical :: doneChildren, doneAttributes + character, pointer :: temp(:) + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "normalize", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + +! DOM standard requires we ignore readonly status + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + + if (getNodeType(this)==TEXT_NODE) then + if (associated(this, arg)) exit ! If we are called on a text node itself, then do nothing. + i_t = getLength(this) + tempNode => getNextSibling(this) + do while (associated(tempNode)) + if (getNodeType(tempNode)/=TEXT_NODE) exit + i_t = i_t + getLength(tempNode) + tempNode => getNextSibling(tempNode) + enddo + if (.not.associated(tempNode, getNextSibling(this))) then + allocate(temp(i_t)) + temp(:getLength(this)) = vs_str(getData(this)) + i_t = getLength(this) + tempNode => getNextSibling(this) + do while (associated(tempNode)) + if (getNodeType(tempNode)/=TEXT_NODE) exit + temp(i_t+1:i_t+getLength(tempNode)) = vs_str(getData(tempNode)) + i_t = i_t + getLength(tempNode) + oldNode => tempNode + tempNode => getNextSibling(tempNode) + oldNode => removeChild(getParentNode(oldNode), oldNode) + call remove_node_nl(arg%ownerDocument%docExtras%hangingNodes, oldNode) + call destroy(oldNode) + enddo + deallocate(this%nodeValue) + this%nodeValue => temp + endif + end if + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + endif + endif + + enddo + + + + + end subroutine normalize + + function isSupported(arg, feature, version, ex)result(p) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: feature + character(len=*), intent(in) :: version + logical :: p + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "isSupported", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + p = hasFeature(getImplementation(arg%ownerDocument), feature, version) + end function isSupported + + pure function getNamespaceURI_len(arg, p) result(n) + type(Node), intent(in) :: arg + logical, intent(in) :: p + integer :: n + + n = 0 + if (p) then + if (arg%nodeType==ELEMENT_NODE & + .or. arg%nodeType==ATTRIBUTE_NODE & + .or. arg%nodeType==XPATH_NAMESPACE_NODE) then + n = size(arg%elExtras%namespaceURI) + endif + endif + + end function getNamespaceURI_len + + function getNamespaceURI(arg, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getNamespaceURI_len(arg, .true.)) :: c +#else + character(len=getNamespaceURI_len(arg, associated(arg))) :: c +#endif + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getNamespaceURI", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = "" + if (arg%nodeType==ELEMENT_NODE & + .or. arg%nodeType==ATTRIBUTE_NODE & + .or. arg%nodeType==XPATH_NAMESPACE_NODE) then + c = str_vs(arg%elExtras%namespaceURI) + endif + end function getNamespaceURI + +subroutine setnamespaceURI(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + character(len=*) :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setnamespaceURI", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=XPATH_NAMESPACE_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setnamespaceURI", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (associated(np%elExtras%namespaceURI)) deallocate(np%elExtras%namespaceURI) + np%elExtras%namespaceURI => vs_str_alloc(c) + + end subroutine setnamespaceURI + + + pure function getPrefix_len(arg, p) result(n) + type(Node), intent(in) :: arg + logical, intent(in) :: p + integer :: n + + n = 0 + if (p) then + if (arg%nodeType==ELEMENT_NODE & + .or. arg%nodeType==ATTRIBUTE_NODE & + .or. arg%nodeType==XPATH_NAMESPACE_NODE) then + n = size(arg%elExtras%prefix) + endif + endif + + end function getPrefix_len + + function getPrefix(arg, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getPrefix_len(arg, .true.)) :: c +#else + character(len=getPrefix_len(arg, associated(arg))) :: c +#endif + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getPrefix", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = "" + if (arg%nodeType==ELEMENT_NODE & + .or. arg%nodeType==ATTRIBUTE_NODE & + .or. arg%nodeType==XPATH_NAMESPACE_NODE) then + c = str_vs(arg%elExtras%prefix) + endif + + end function getPrefix + + subroutine setPrefix(arg, prefix, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*) :: prefix + + character, pointer :: tmp(:) + integer :: i + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setPrefix", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType==ELEMENT_NODE & + .or. arg%nodeType==ATTRIBUTE_NODE & + .or. arg%nodeType==XPATH_NAMESPACE_NODE) then + if (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setPrefix", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(prefix, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "setPrefix", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkNCName(prefix, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "setPrefix", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (size(arg%elExtras%namespaceURI)==0) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "setPrefix", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (prefix=="xml" .and. & + str_vs(arg%elExtras%namespaceURI)/="http://www.w3.org/XML/1998/namespace") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "setPrefix", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (prefix=="xmlns" .and. (getNodeType(arg)/=ATTRIBUTE_NODE & + .or. str_vs(arg%elExtras%namespaceURI)/="http://www.w3.org/2000/xmlns/")) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "setPrefix", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)==ATTRIBUTE_NODE.and.getName(arg)=="xmlns") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "setPrefix", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif +! FIXME check if prefix is declared and already points to same namespace +! but only if we ever get full error-checking up and running. + deallocate(arg%elExtras%prefix) + arg%elExtras%prefix => vs_str_alloc(prefix) + tmp => arg%nodeName + i = index(str_vs(arg%nodeName), ":") + if (i==0) then + arg%nodeName => vs_str_alloc(prefix//":"//str_vs(tmp)) + else + arg%nodeName => vs_str_alloc(prefix//str_vs(tmp(i:))) + endif + deallocate(tmp) + endif + + call updateNodeLists(arg%ownerDocument) + + end subroutine setPrefix + + pure function getLocalName_len(arg, p) result(n) + type(Node), intent(in) :: arg + logical, intent(in) :: p + integer :: n + + n = 0 + if (p) then + if (arg%nodeType==ELEMENT_NODE & + .or. arg%nodeType==ATTRIBUTE_NODE & + .or. arg%nodeType==XPATH_NAMESPACE_NODE) then + n = size(arg%elExtras%localName) + endif + endif + + end function getLocalName_len + + function getLocalName(arg, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getLocalName_len(arg, .true.)) :: c +#else + character(len=getLocalName_len(arg, associated(arg))) :: c +#endif + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getLocalName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = "" + if (arg%nodeType==ELEMENT_NODE & + .or. arg%nodeType==ATTRIBUTE_NODE & + .or. arg%nodeType==XPATH_NAMESPACE_NODE) then + c = str_vs(arg%elExtras%localName) + endif + + end function getLocalName + + recursive function isEqualNode(arg, other, ex)result(p) + type(DOMException), intent(out), optional :: ex + ! We only have one level of recursion, in case of element attributes + type(Node), pointer :: arg + type(Node), pointer :: other + logical :: p + + type(Node), pointer :: this, that, treeroot, treeroot2, att1, att2 + type(NodeList), pointer :: children1, children2 + type(NamedNodeMap), pointer :: atts1, atts2 + + integer :: i_tree, i + logical :: doneChildren, doneAttributes, equal + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "isEqualNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (isSameNode(arg, other)) then + ! Shortcut the treewalking + p = .true. + return + else + p = .false. + endif + + treeroot => arg + treeroot2 => other + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + that => treeroot2 + equal = .false. + do + if (getNodeType(this)/=getNodeType(that)) exit + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + + if (getNodeType(this)/=getNodeType(that)) return + ! Check necessary equal attributes ... + if (getNodeName(this)/=getNodeName(that) & + .or. getLocalName(this)/=getLocalName(that) & + .or. getNamespaceURI(this)/=getNamespaceURI(that) & + .or. getPrefix(this)/=getPrefix(that) & + .or. getNodeValue(this)/=getNodeValue(that)) & + return + children1 => getChildNodes(this) + children2 => getChildNodes(that) + if (getLength(children1)/=getLength(children2)) return + ! Well get to the contents of the children later on anyway. + if (getNodeType(this)==ELEMENT_NODE) then + ! We must treat attributes specially here (rather than relying on + ! treewalk) since the order can legitimately change. + atts1 => getAttributes(this) + atts2 => getAttributes(that) + if (getLength(atts1)/=getLength(atts2)) return + do i = 0, getLength(atts1)-1 + att1 => item(atts1, i) + if (getNamespaceURI(att1)=="") then + att2 => getNamedItem(atts2, getNodeName(att1)) + else + att2 => getNamedItemNS(atts2, getLocalName(att1), getNamespaceURI(att1)) + endif + if (.not.associated(att2)) return + if (.not.isEqualNode(att1, att2)) return + enddo + doneAttributes = .true. + elseif (getNodeType(this)==DOCUMENT_TYPE_NODE) then + if (getPublicId(this)/=getPublicId(that) & + .or. getSystemId(this)/=getSystemId(that) & + .or. getInternalSubset(this)/=getInternalSubset(that)) return + atts1 => getEntities(this) + atts2 => getEntities(that) + if (getLength(atts1)/=getLength(atts2)) return + do i = 0, getLength(atts1)-1 + att1 => item(atts1, i) + att2 => getNamedItem(atts2, getNodeName(att1)) + if (.not.associated(att2)) return + if (.not.isEqualNode(att1, att2)) return + enddo + atts1 => getNotations(this) + atts2 => getNotations(that) + if (getLength(atts1)/=getLength(atts2)) return + do i = 0, getLength(atts1)-1 + att1 => item(atts1, i) + att2 => getNamedItem(atts2, getNodeName(att1)) + if (.not.associated(att2)) return + if (.not.isEqualNode(att1, att2)) return + enddo + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))/=getLength(getAttributes(that))) exit + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + that => item(getAttributes(that), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this).or.hasChildNodes(that)) then + if (getLength(getChildNodes(this))/=getLength(getChildNodes(that))) exit + this => getFirstChild(this) + that => getFirstChild(that) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + that => item(getAttributes(getOwnerElement(that)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + that => getOwnerElement(that) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + that => getNextSibling(that) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + that => getParentNode(that) + endif + endif + + enddo + + + + p = .true. + + end function isEqualNode + + + function isSameNode(arg, other, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: other + logical :: isSameNode + + if (.not.associated(arg).or..not.associated(other)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "isSameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + isSameNode = associated(arg, other) + + end function isSameNode + + !FIXME all the lookup* functions below are out of spec, + ! since they rely on a statically-calculated set of NSnodes + ! which is only generated at parse time, and updated after + ! normalize. + ! the spec reckons it should be dynamic, but because we need + ! to know string lengths, which must be calculated inside + ! a pure function, we cant do the recursive walk we need to. + ! (although isDefaultNamespace could be fixed easily enough) + + function isDefaultNamespace(np, namespaceURI, ex)result(p) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + character(len=*), intent(in) :: namespaceURI + logical :: p + + type(Node), pointer :: el + integer :: i + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "isDefaultNamespace", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + el => null() + select case(getNodeType(np)) + case (ELEMENT_NODE) + el => np + case (ATTRIBUTE_NODE) + el => getOwnerElement(np) + case (DOCUMENT_NODE) + el => getDocumentElement(np) + end select + + p = .false. + if (associated(el)) then + do i = 1, el%elExtras%namespaceNodes%length + if (size(el%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix)==0) then + p = (str_vs(el%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) + return + endif + enddo + endif + end function isDefaultNamespace + + pure function lookupNamespaceURI_len(np, prefix, p) result(n) + type(Node), intent(in) :: np + character(len=*), intent(in) :: prefix + logical, intent(in) :: p + integer :: n + + integer :: i + + n = 0 + if (.not.p) return + if (np%nodeType/=ELEMENT_NODE & + .and. np%nodeType/=ATTRIBUTE_NODE & + .and. np%nodeType/=DOCUMENT_NODE) return + + if (prefix=="xml".or.prefix=="xmlns") then + n = 0 + return + endif + + select case(np%nodeType) + case (ELEMENT_NODE) + do i = 1, np%elExtras%namespaceNodes%length + if (str_vs(np%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix)==prefix) then + n = size(np%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI) + return + endif + enddo + case (ATTRIBUTE_NODE) + if (associated(np%elExtras%ownerElement)) then + do i = 1, np%elExtras%ownerElement%elExtras%namespaceNodes%length + if (str_vs(np%elExtras%ownerElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix)==prefix) then + n = size(np%elExtras%ownerElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI) + return + endif + enddo + endif + case (DOCUMENT_NODE) + if (associated(np%docExtras%documentElement)) then + do i = 1, np%docExtras%documentElement%elExtras%namespaceNodes%length + if (str_vs(np%docExtras%documentElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix)==prefix) then + n = size(np%docExtras%documentElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI) + return + endif + enddo + endif + end select + + end function lookupNamespaceURI_len + + function lookupNamespaceURI(np, prefix, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + character(len=*), intent(in) :: prefix +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=lookupNamespaceURI_len(np, prefix, .true.)) :: c +#else + character(len=lookupNamespaceURI_len(np, prefix, associated(np))) :: c +#endif + + type(Node), pointer :: el + integer :: i + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "lookupNamespaceURI", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (len(c)==0) then + c = "" + return + endif + + el => null() + select case(getNodeType(np)) + case (ELEMENT_NODE) + el => np + case (ATTRIBUTE_NODE) + el => getOwnerElement(np) + case (DOCUMENT_NODE) + el => getDocumentElement(np) + end select + + if (associated(el)) then + do i = 1, el%elExtras%namespaceNodes%length + if (str_vs(el%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix)==prefix) then + c = str_vs(el%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI) + return + endif + enddo + endif + + end function lookupNamespaceURI + + pure function lookupPrefix_len(np, namespaceURI, p) result(n) + type(Node), intent(in) :: np + character(len=*), intent(in) :: namespaceURI + logical, intent(in) :: p + integer :: n + + integer :: i + + n = 0 + if (.not.p) return + if (np%nodeType/=ELEMENT_NODE & + .and. np%nodeType/=ATTRIBUTE_NODE & + .and. np%nodeType/=DOCUMENT_NODE) return + + if (namespaceURI=="" & + .or. namespaceURI=="http://www.w3.org/XML/1998/namespace" & + .or. namespaceURI=="http://www.w3.org/2000/xmlns/") then + return + endif + + select case(np%nodeType) + case (ELEMENT_NODE) + do i = 1, np%elExtras%namespaceNodes%length + if (str_vs(np%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) then + n = size(np%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix) + return + endif + enddo + case (ATTRIBUTE_NODE) + if (associated(np%elExtras%ownerElement)) then + do i = 1, np%elExtras%ownerElement%elExtras%namespaceNodes%length + if (str_vs(np%elExtras%ownerElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) then + n = size(np%elExtras%ownerElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix) + return + endif + enddo + endif + case (DOCUMENT_NODE) + if (associated(np%docExtras%documentElement)) then + do i = 1, np%docExtras%documentElement%elExtras%namespaceNodes%length + if (str_vs(np%docExtras%documentElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) then + n = size(np%docExtras%documentElement%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix) + return + endif + enddo + endif + end select + + end function lookupPrefix_len + + function lookupPrefix(np, namespaceURI, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + character(len=*), intent(in) :: namespaceURI +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=lookupPrefix_len(np, namespaceURI, .true.)) :: c +#else + character(len=lookupPrefix_len(np, namespaceURI, associated(np))) :: c +#endif + + type(Node), pointer :: el + integer :: i + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "lookupPrefix", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (len(c)==0) then + c = "" + return + endif + + el => null() + select case(getNodeType(np)) + case (ELEMENT_NODE) + el => np + case (ATTRIBUTE_NODE) + el => getOwnerElement(np) + case (DOCUMENT_NODE) + el => getDocumentElement(np) + end select + + if (associated(el)) then + do i = 1, el%elExtras%namespaceNodes%length + if (str_vs(el%elExtras%namespaceNodes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) then + c = str_vs(el%elExtras%namespaceNodes%nodes(i)%this%elExtras%prefix) + return + endif + enddo + endif + end function lookupPrefix + + ! function getUserData + ! function setUserData + ! will not implement ... + + subroutine updateTextContentLength(np, n) + type(Node), pointer :: np + integer, intent(in) :: n + + type(Node), pointer :: this + + if (n/=0) then + this => np + do while (associated(this)) + this%textContentLength = this%textContentLength + n + this => getParentNode(this) + if (associated(this)) then + if (getNodeType(this)==DOCUMENT_NODE) exit + endif + enddo + endif + end subroutine updateTextContentLength + + pure function getTextContent_len(arg, p) result(n) + type(Node), intent(in) :: arg + logical, intent(in) :: p + integer :: n + + if (p) then + n = arg%textContentLength + else + n = 0 + endif + end function getTextContent_len + + function getTextContent(arg, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getTextContent_len(arg, .true.)) :: c +#else + character(len=getTextContent_len(arg, associated(arg))) :: c +#endif + + type(Node), pointer :: this, treeroot + integer :: i, i_tree + logical :: doneChildren, doneAttributes + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getTextContent", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (len(c) == 0) then + c = "" + return + endif + + i = 1 + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + if (associated(this, treeroot).and.isCharData(getNodeType(this))) then + c = getData(this) + return + endif + select case(getNodeType(this)) + case (ELEMENT_NODE) + doneAttributes = .true. + ! Ignore attributes for text content (unless this is an attribute!) + case(TEXT_NODE, CDATA_SECTION_NODE) + if (.not.getIsElementContentWhitespace(this)) then + c(i:i+size(this%nodeValue)-1) = str_vs(this%nodeValue) + i = i + size(this%nodeValue) + endif + end select + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + endif + endif + + enddo + + + end function getTextContent + + subroutine setTextContent(arg, textContent, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: textContent + + type(Node), pointer :: np + integer :: i + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setTextContent", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.checkChars(textContent, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then + call throw_exception(FoX_INVALID_CHARACTER, "setTextContent", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + select case(getNodeType(arg)) + case (ELEMENT_NODE, ATTRIBUTE_NODE, DOCUMENT_FRAGMENT_NODE) + if (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setTextContent", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + do i = 1, getLength(getChildNodes(arg)) + call destroyNode(arg%childNodes%nodes(i)%this) + enddo + deallocate(arg%childNodes%nodes) + allocate(arg%childNodes%nodes(0)) + arg%childNodes%length = 0 + arg%firstChild => null() + arg%lastChild => null() + arg%textContentLength = 0 + np => createTextNode(getOwnerDocument(arg), textContent) + np => appendChild(arg, np) + case (TEXT_NODE, CDATA_SECTION_NODE, PROCESSING_INSTRUCTION_NODE, COMMENT_NODE) + call setData(arg, textContent) + case (ENTITY_NODE, ENTITY_REFERENCE_NODE) + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setTextContent", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + end select + end subroutine setTextContent + + function getBaseURI(arg, ex)result(baseURI) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=200) :: baseURI + + type(Node), pointer :: el + type(URI), pointer :: URIref, URIbase, newURI + + select case(getNodeType(arg)) + case (ELEMENT_NODE) + el => arg + case (ATTRIBUTE_NODE) + if (getName(arg)=="xml:base") then + if (associated(getOwnerElement(arg))) then + el => getParentNode(getOwnerElement(arg)) + else + el => null() + endif + else + el => getOwnerElement(arg) + endif + case (TEXT_NODE) + ! then are we in an attribute or textContent? + el => getParentNode(arg) + do while (associated(el)) + if (getNodeType(el)==ELEMENT_NODE) then + exit + elseif (getNodeType(el)==ATTRIBUTE_NODE) then + el => getOwnerElement(el) + exit + else + el => getParentNode(el) + endif + enddo + case (PROCESSING_INSTRUCTION_NODE) + ! then are we in or out of element content? + el => getParentNode(arg) + do while (associated(el)) + if (getNodeType(el)==ELEMENT_NODE) then + exit + elseif (getNodeType(el)==DOCUMENT_NODE) then + el => getOwnerElement(el) + exit + else + el => getParentNode(el) + endif + enddo + case default + el => null() + end select + + URIref => parseURI("") + + do while (associated(el)) + select case (getNodeType(el)) + case (ELEMENT_NODE) + if (hasAttribute(el, "xml:base")) then + URIbase => parseURI(getAttribute(el, "xml:base")) + newURI => rebaseURI(URIbase, URIref) + call destroyURI(URIbase) + call destroyURI(URIref) + URIref => newURI + if (isAbsoluteURI(URIref)) exit + endif + case (ENTITY_REFERENCE_NODE) + if (getSystemId(el)/="") then + URIbase => parseURI(getSystemId(el)) + newURI => rebaseURI(URIbase, URIref) + call destroyURI(URIbase) + call destroyURI(URIref) + URIref => newURI + if (isAbsoluteURI(URIref)) exit + endif + case default + exit + end select + el => getParentNode(el) + end do + + if (isAbsoluteURI(URIref)) then + baseURI = expressURI(URIref) + else + baseURI = "" + endif + call destroyURI(URIref) + + end function getBaseURI + + recursive function getNodePath(arg, ex)result(c) + type(DOMException), intent(out), optional :: ex + ! recursive only for atts and text + type(Node), pointer :: arg + character(len=100) :: c + + type(Node), pointer :: this, this2 + character(len=len(c)) :: c2 + integer :: n + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getNodePath", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = "" + if (.not.arg%inDocument) return + select case(getNodeType(arg)) + + case (ELEMENT_NODE) + this => arg + do while (getNodeType(this)/=DOCUMENT_NODE) + c2 = "" + this2 => getPreviousSibling(this) + n = 0 + do while (associated(this2)) + if (getNodeType(this2)==ELEMENT_NODE & + .and.getNodeName(this2)==getNodeName(this)) n = n + 1 + this2 => getPreviousSibling(this2) + enddo + if (n==0) then + this2 => getNextSibling(this) + do while (associated(this2)) + if (getNodeType(this2)==ELEMENT_NODE & + .and.getNodeName(this2)==getNodeName(this)) then + n = 1 + exit + endif + this2 => getNextSibling(this2) + enddo + else + n = n + 1 + endif + if (n>0) c2 = "["//n//"]" + ! What name to use: + if (getNamespaceURI(this)/="".and.getPrefix(this)=="") then + ! default namespace; need to do the * trick + ! how many previous siblings? + c2 = "/*"//c2 + else + c2 = "/"//getNodeName(this)//c2 + endif + c = trim(c2)//c + this => getParentNode(this) + enddo + + case (ATTRIBUTE_NODE) + c = trim(getNodePath(getOwnerElement(arg)))//"/@"//getNodeName(arg) + + case (TEXT_NODE, CDATA_SECTION_NODE) + ! FIXME this will give wrong answers sometimes if + ! the tree contains entity references + this => getParentNode(arg) + do while (associated(this)) + if (getNodeType(this)==ELEMENT_NODE) exit + this => getParentNode(this) + enddo + if (getNodeType(this)/=ELEMENT_NODE) & + this => getOwnerElement(this) + c = trim(getNodePath(this))//"/text()" + this => getPreviousSibling(arg) + n = 0 + do while (associated(this)) + if (getNodeType(this)==TEXT_NODE & + .or.getNodeType(this)==CDATA_SECTION_NODE) n = n + 1 + this => getPreviousSibling(this) + enddo + if (n==0) then + this => getNextSibling(arg) + do while (associated(this)) + if (getNodeType(this)==COMMENT_NODE & + .or.getNodeType(this)==CDATA_SECTION_NODE) then + n = 1 + exit + endif + this => getNextSibling(this) + enddo + else + n = n + 1 + endif + if (n>0) c = trim(c)//"["//n//"]" + + case (PROCESSING_INSTRUCTION_NODE) + this => getParentNode(arg) + c = trim(getNodePath(this))//"/processing-instruction("//getNodeName(arg)//")" + this => getPreviousSibling(arg) + n = 0 + do while (associated(this)) + if (getNodeType(this)==PROCESSING_INSTRUCTION_NODE & + .and.getNodeName(this)==getNodeName(arg)) n = n + 1 + this => getPreviousSibling(this) + enddo + if (n==0) then + this => getNextSibling(arg) + do while (associated(this)) + if (getNodeType(this)==PROCESSING_INSTRUCTION_NODE & + .and.getNodeName(this)==getNodeName(arg)) then + n = 1 + exit + endif + this => getNextSibling(this) + enddo + else + n = n + 1 + endif + if (n>0) c = trim(c)//"["//n//"]" + + case (COMMENT_NODE) + this => getParentNode(arg) + c = trim(getNodePath(this))//"/comment()" + this => getPreviousSibling(arg) + n = 0 + do while (associated(this)) + if (getNodeType(this)==COMMENT_NODE) n = n + 1 + this => getPreviousSibling(this) + enddo + if (n==0) then + this => getNextSibling(arg) + do while (associated(this)) + if (getNodeType(this)==COMMENT_NODE) then + n = 1 + exit + endif + this => getNextSibling(this) + enddo + else + n = n + 1 + endif + if (n>0) c = trim(c)//"["//n//"]" + + case (DOCUMENT_NODE) + c = "/" + + case (XPATH_NAMESPACE_NODE) + this => getOwnerElement(arg) + if (getPrefix(arg)=="") then + c = trim(getNodePath(this))//"/namespace::xmlns" + else + c = trim(getNodePath(this))//"/namespace::"//getPrefix(arg) + endif + ! FIXME namespace nodes are not marked as inDocument correctly + + end select + + end function getNodePath + + subroutine putNodesInDocument(doc, arg) + type(Node), pointer :: doc, arg + type(Node), pointer :: this, treeroot + logical :: doneChildren, doneAttributes + integer :: i_tree + + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + this%inDocument = .true. + call remove_node_nl(doc%docExtras%hangingNodes, this) + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + endif + endif + + enddo + + + + + end subroutine putNodesInDocument + + subroutine removeNodesFromDocument(doc, arg) + type(Node), pointer :: doc, arg + type(Node), pointer :: this, treeroot + logical :: doneChildren, doneAttributes + integer :: i_tree + + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + this%inDocument = .false. + call append_nl(doc%docExtras%hangingNodes, this) + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + endif + endif + + enddo + + + + end subroutine removeNodesFromDocument + + subroutine setReadOnlyNode(arg, p, deep) + type(Node), pointer :: arg + logical, intent(in) :: p + logical, intent(in) :: deep + + type(Node), pointer :: this, treeroot + integer :: i_tree + logical :: doneAttributes, doneChildren + + if (deep) then + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + this%readonly = p + if (this%nodeType==ELEMENT_NODE) & + this%elExtras%attributes%readonly = p + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + endif + endif + + enddo + + + else + arg%readonly = p + if (arg%nodeType==ELEMENT_NODE) & + arg%elExtras%attributes%readonly = p + endif + + end subroutine setReadOnlyNode + +function getreadonly(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getreadonly", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + c = np%readonly + + end function getreadonly + + + + + function item_nl(list, index, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(NodeList), pointer :: list + integer, intent(in) :: index + type(Node), pointer :: np + + if (.not.associated(list)) then + if (getFoX_checks().or.FoX_LIST_IS_NULL<200) then + call throw_exception(FoX_LIST_IS_NULL, "item_nl", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (index>=0.and.index list%nodes(index+1)%this + else + np => null() + endif + + end function item_nl + + subroutine append_nl(list, arg) + type(NodeList), intent(inout) :: list + type(Node), pointer :: arg + + type(ListNode), pointer :: temp_nl(:) + integer :: i + + if (.not.associated(list%nodes)) then + allocate(list%nodes(1)) + list%nodes(1)%this => arg + list%length = 1 + else + temp_nl => list%nodes + allocate(list%nodes(size(temp_nl)+1)) + do i = 1, size(temp_nl) + list%nodes(i)%this => temp_nl(i)%this + enddo + deallocate(temp_nl) + list%nodes(size(list%nodes))%this => arg + list%length = size(list%nodes) + endif + + end subroutine append_nl + + function pop_nl(list, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(NodeList), pointer :: list + type(Node), pointer :: np + + type(ListNode), pointer :: temp_nl(:) + integer :: i + + if (list%length==0) then + if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then + call throw_exception(FoX_INTERNAL_ERROR, "pop_nl", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => list%nodes(size(list%nodes))%this + + if (list%length==1) then + deallocate(list%nodes) + list%length = 0 + else + temp_nl => list%nodes + allocate(list%nodes(size(temp_nl)-1)) + do i = 1, size(temp_nl)-1 + list%nodes(i)%this => temp_nl(i)%this + enddo + deallocate(temp_nl) + list%length = size(list%nodes) + endif + + end function pop_nl + + + function remove_nl(nl, index, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(NodeList), intent(inout) :: nl + integer, intent(in) :: index + type(Node), pointer :: np + + type(ListNode), pointer :: temp_nl(:) + + integer :: i + + if (index>nl%length) then + if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then + call throw_exception(FoX_INTERNAL_ERROR, "remove_nl", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => nl%nodes(index)%this + temp_nl => nl%nodes + allocate(nl%nodes(size(temp_nl)-1)) + nl%length = nl%length - 1 + do i = 1, index - 1 + nl%nodes(i)%this => temp_nl(i)%this + enddo + do i = index, nl%length + nl%nodes(i)%this => temp_nl(i+1)%this + enddo + deallocate(temp_nl) + + end function remove_nl + + + subroutine remove_node_nl(nl, np) + type(NodeList), intent(inout) :: nl + type(Node), pointer :: np + + integer :: i + + do i = 1, nl%length + if (associated(nl%nodes(i)%this, np)) exit + enddo + np => remove_nl(nl, i) + + end subroutine remove_node_nl + + + function getLength_nl(nl, ex)result(n) + type(DOMException), intent(out), optional :: ex + type(NodeList), pointer :: nl + integer :: n + + if (.not.associated(nl)) then + if (getFoX_checks().or.FoX_LIST_IS_NULL<200) then + call throw_exception(FoX_LIST_IS_NULL, "getLength_nl", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + n = size(nl%nodes) + end function getLength_nl + + subroutine destroyNodeList(nl) + type(NodeList), pointer :: nl + + if (associated(nl%nodes)) deallocate(nl%nodes) + if (associated(nl%nodeName)) deallocate(nl%nodeName) + if (associated(nl%localName)) deallocate(nl%localName) + if (associated(nl%namespaceURI)) deallocate(nl%namespaceURI) + deallocate(nl) + end subroutine destroyNodeList + + subroutine updateNodeLists(doc) + ! When triggered, update all nodelists + type(Node), pointer :: doc + + type(NodeList), pointer :: nl, nl_orig + type(NodeListPtr), pointer :: temp_nll(:) + integer :: i, i_t + + if (.not.getGCstate(doc)) return + if (.not.doc%docExtras%liveNodeLists) return + if (.not.associated(doc%docExtras%nodelists)) return + + ! We point the old list of nodelists to temp_nll, then recalculate + ! them all (which repopulates nodelists) + temp_nll => doc%docExtras%nodelists + i_t = size(temp_nll) + allocate(doc%docExtras%nodelists(0)) + do i = 1, i_t + nl_orig => temp_nll(i)%this + ! + ! Although all nodes should be searched whatever the result, + ! we should only do the appropriate sort of search for this + ! list - according to namespaces or not. + ! + if (associated(nl_orig%nodeName)) then + ! this was made by getElementsByTagName + nl => getElementsByTagName(nl_orig%element, str_vs(nl_orig%nodeName)) + elseif (associated(nl_orig%namespaceURI)) then + ! this was made by getElementsByTagNameNS + nl => getElementsByTagNameNS(nl_orig%element, & + str_vs(nl_orig%localName), str_vs(nl_orig%namespaceURI)) + endif + enddo + ! We dont care about the nodelists weve calculated now + nullify(nl) + + deallocate(temp_nll) + + end subroutine updateNodeLists + + + + function getNamedItem(map, name, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(NamedNodeMap), pointer :: map + character(len=*), intent(in) :: name + type(Node), pointer :: np + + integer :: i + + if (.not.associated(map)) then + if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then + call throw_exception(FoX_MAP_IS_NULL, "getNamedItem", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + do i = 1, map%length + if (str_vs(map%nodes(i)%this%nodeName)==name) then + np => map%nodes(i)%this + return + endif + enddo + + np => null() + + end function getNamedItem + + + function setNamedItem(map, arg, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(NamedNodeMap), pointer :: map + type(Node), pointer :: arg + type(Node), pointer :: np + + integer :: i + + if (.not.associated(map)) then + if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then + call throw_exception(FoX_MAP_IS_NULL, "setNamedItem", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setNamedItem", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (map%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setNamedItem", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (map%ownerElement%nodeType==ELEMENT_NODE) then + if (.not.associated(map%ownerElement%ownerDocument, arg%ownerDocument)) then + if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then + call throw_exception(WRONG_DOCUMENT_ERR, "setNamedItem", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ATTRIBUTE_NODE) then + !Additional check from DOM 3 + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "setNamedItem", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + endif + + if (getNodeType(arg)==ATTRIBUTE_NODE) then + if (associated(map%ownerElement, getOwnerElement(arg))) then + ! we are looking at literally the same node + np => arg + return + elseif (associated(getOwnerElement(arg))) then + if (getFoX_checks().or.INUSE_ATTRIBUTE_ERR<200) then + call throw_exception(INUSE_ATTRIBUTE_ERR, "setNamedItem", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + arg%elExtras%ownerElement => map%ownerElement + endif + + do i = 0, getLength(map)-1 + np => item(map, i) + if (getNodeName(np)==getNodeName(arg)) then + map%nodes(i+1)%this => arg + exit + endif + enddo + + if (i null() + call append_nnm(map, arg) + endif + + if (map%ownerElement%nodeType==ELEMENT_NODE) then + if (getGCstate(getOwnerDocument(map%ownerElement))) then + ! We need to worry about importing this node + if (map%ownerElement%inDocument) then + if (.not.arg%inDocument) & + call putNodesInDocument(getOwnerDocument(map%ownerElement), arg) + else + if (arg%inDocument) & + call removeNodesFromDocument(getOwnerDocument(map%ownerElement), arg) + endif + endif + endif + ! Otherwise we only ever setNNM when building the doc, so we know this + ! does not matter + + end function setNamedItem + + + function removeNamedItem(map, name, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(NamedNodeMap), pointer :: map + character(len=*), intent(in) :: name + type(Node), pointer :: np + + type(xml_doc_state), pointer :: xds + type(element_t), pointer :: elem + type(attribute_t), pointer :: att + type(ListNode), pointer :: temp_nl(:) + integer :: i, i2 + + if (.not.associated(map)) then + if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then + call throw_exception(FoX_MAP_IS_NULL, "removeNamedItem", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (map%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "removeNamedItem", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + do i = 0, map%length-1 + np => item(map, i) + if (getNodeName(np)==name) then + xds => getXds(getOwnerDocument(map%ownerElement)) + elem => get_element(xds%element_list, getNodeName(map%ownerElement)) + att => get_attribute_declaration(elem, name) + if (associated(att)) then + if (attribute_has_default(att)) then ! there is a default value + ! Well swap the old one out & put a new one in. + ! Do *nothing* about namespace handling at this stage, + ! wait until we are asked for namespace normalization + if (getParameter( & + getDomConfig(getOwnerDocument(map%ownerElement)), & + "namespaces")) then + np => createAttributeNS(getOwnerDocument(map%ownerElement), "", name) + else + np => createAttribute(getOwnerDocument(map%ownerElement), name) + endif + call setValue(np, str_vs(att%default)) + call setSpecified(np, .false.) + np => setNamedItem(map, np) + call setSpecified(np, .true.) + return + endif + endif + ! Otherwise there was no default value, so we just remove the node. + ! Grab this node + if (getNodeType(np)==ATTRIBUTE_NODE) np%elExtras%ownerElement => null() + ! and shrink the node list + temp_nl => map%nodes + allocate(map%nodes(size(temp_nl)-1)) + do i2 = 1, i + map%nodes(i2)%this => temp_nl(i2)%this + enddo + do i2 = i + 2, map%length + map%nodes(i2-1)%this => temp_nl(i2)%this + enddo + map%length = size(map%nodes) + deallocate(temp_nl) + if (np%inDocument.and.getGCstate(getOwnerDocument(map%ownerElement))) & + call removeNodesFromDocument(getOwnerDocument(map%ownerElement), np) + !otherwise we are only going to destroy these nodes anyway, + ! and finish + return + endif + enddo + + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "removeNamedItem", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + + end function removeNamedItem + + + function item_nnm(map, index, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(NamedNodeMap), pointer :: map + integer, intent(in) :: index + type(Node), pointer :: np + + if (.not.associated(map)) then + if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then + call throw_exception(FoX_MAP_IS_NULL, "item_nnm", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (index<0 .or. index>map%length-1) then + np => null() + else + np => map%nodes(index+1)%this + endif + + end function item_nnm + + function getLength_nnm(map, ex)result(n) + type(DOMException), intent(out), optional :: ex + type(namedNodeMap), pointer :: map + integer :: n + + if (.not.associated(map)) then + if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then + call throw_exception(FoX_MAP_IS_NULL, "getLength_nnm", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + n = map%length + + end function getLength_nnm + + + function getNamedItemNS(map, namespaceURI, localName, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(NamedNodeMap), pointer :: map + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: localName + type(Node), pointer :: np + + integer :: i + + if (.not.associated(map)) then + if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then + call throw_exception(FoX_MAP_IS_NULL, "getNamedItemNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (map%ownerElement%nodeType/=ELEMENT_NODE) then + np => null() + return + endif + + do i = 0, getLength(map) - 1 + np => item(map, i) + if (getNamespaceURI(np)==namespaceURI & + .and. getLocalName(np)==localName) then + return + endif + enddo + np => null() + + end function getNamedItemNS + + + function setNamedItemNS(map, arg, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(NamedNodeMap), pointer :: map + type(Node), pointer :: arg + type(Node), pointer :: np + + integer :: i + + if (.not.associated(map)) then + if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then + call throw_exception(FoX_MAP_IS_NULL, "setNamedItemNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setNamedItemNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (map%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setNamedItemNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (map%ownerElement%nodeType==ELEMENT_NODE) then + if (.not.associated(map%ownerElement%ownerDocument, arg%ownerDocument)) then + if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then + call throw_exception(WRONG_DOCUMENT_ERR, "setNamedItemNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ATTRIBUTE_NODE) then + !Additional check from DOM 3 + if (getFoX_checks().or.HIERARCHY_REQUEST_ERR<200) then + call throw_exception(HIERARCHY_REQUEST_ERR, "setNamedItemNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + endif + + if (getNodeType(arg)==ATTRIBUTE_NODE) then + if (associated(map%ownerElement, getOwnerElement(arg))) then + ! we are looking at literally the same node, so do nothing else + np => arg + return + elseif (associated(getOwnerElement(arg))) then + if (getFoX_checks().or.INUSE_ATTRIBUTE_ERR<200) then + call throw_exception(INUSE_ATTRIBUTE_ERR, "setNamedItemNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + arg%elExtras%ownerElement => map%ownerElement + endif + + do i = 0, getLength(map) - 1 + np => item(map, i) + if ((getLocalName(arg)==getLocalName(np) & + .and.getNamespaceURI(arg)==getNamespaceURI(np)) & + ! Additional case to catch adding of specified attributeNS over + ! default (NS but unspecified URI) attribute + .or.(getNamespaceURI(arg)=="".and.getName(arg)==getName(np))) then + map%nodes(i+1)%this => arg + exit + endif + enddo + + if (i null() + call append_nnm(map, arg) + endif + + if (map%ownerElement%nodeType==ELEMENT_NODE) then + if (getGCstate(getOwnerDocument(map%ownerElement))) then + ! We need to worry about importing this node + if (map%ownerElement%inDocument) then + if (.not.arg%inDocument) & + call putNodesInDocument(getOwnerDocument(map%ownerElement), arg) + else + if (arg%inDocument) & + call removeNodesFromDocument(getOwnerDocument(map%ownerElement), arg) + endif + endif + endif + + end function setNamedItemNS + + + function removeNamedItemNS(map, namespaceURI, localName, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(NamedNodeMap), pointer :: map + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: localName + type(Node), pointer :: np + + type(xml_doc_state), pointer :: xds + type(element_t), pointer :: elem + type(attribute_t), pointer :: att + type(ListNode), pointer :: temp_nl(:) + integer :: i, i2 + + if (.not.associated(map)) then + if (getFoX_checks().or.FoX_MAP_IS_NULL<200) then + call throw_exception(FoX_MAP_IS_NULL, "removeNamedItemNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (map%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "removeNamedItemNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + do i = 0, getLength(map) - 1 + np => item(map, i) + if (getNamespaceURI(np)==namespaceURI & + .and. getLocalName(np)==localName) then + ! Grab this node + xds => getXds(getOwnerDocument(map%ownerElement)) + elem => get_element(xds%element_list, getNodeName(map%ownerElement)) + att => get_attribute_declaration(elem, getName(np)) + if (associated(att)) then + if (attribute_has_default(att)) then ! there is a default value + ! Well swap the old one out & put a new one in. + ! Do *nothing* about namespace handling at this stage, + ! wait until we are asked for namespace normalization + np => createAttributeNS(getOwnerDocument(map%ownerElement), getNamespaceURI(np), getName(np)) + call setValue(np, str_vs(att%default)) + call setSpecified(np, .false.) + np => setNamedItemNS(map, np) + call setSpecified(np, .true.) + return + endif + endif + ! Otherwise there was no default value, so we just remove the node. + ! and shrink the node list + if (getNodeType(np)==ATTRIBUTE_NODE) np%elExtras%ownerElement => null() + temp_nl => map%nodes + allocate(map%nodes(size(temp_nl)-1)) + do i2 = 1, i + map%nodes(i2)%this => temp_nl(i2)%this + enddo + do i2 = i + 2, map%length + map%nodes(i2-1)%this => temp_nl(i2)%this + enddo + map%length = size(map%nodes) + deallocate(temp_nl) + if (np%inDocument.and.getGCstate(getOwnerDocument(map%ownerElement))) & + call removeNodesFromDocument(getOwnerDocument(map%ownerElement), np) + !otherwise we are only going to destroy these nodes anyway, + ! and finish + return + endif + enddo + + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "removeNamedItemNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + + end function removeNamedItemNS + + + subroutine append_nnm(map, arg) + type(namedNodeMap), pointer :: map + type(node), pointer :: arg + + type(ListNode), pointer :: temp_nl(:) + integer :: i + + if (.not.associated(map%nodes)) then + allocate(map%nodes(1)) + map%nodes(1)%this => arg + map%length = 1 + else + temp_nl => map%nodes + allocate(map%nodes(size(temp_nl)+1)) + do i = 1, size(temp_nl) + map%nodes(i)%this => temp_nl(i)%this + enddo + deallocate(temp_nl) + map%nodes(size(map%nodes))%this => arg + map%length = size(map%nodes) + endif + if (getNodeType(arg)==ATTRIBUTE_NODE) arg%elExtras%ownerElement => map%ownerElement + + end subroutine append_nnm + + + subroutine setReadOnlyMap(map, r) + type(namedNodeMap), pointer :: map + logical, intent(in) :: r + + map%readonly = r + end subroutine setReadOnlyMap + + subroutine destroyNamedNodeMap(map) + type(namedNodeMap), pointer :: map + + if (associated(map%nodes)) deallocate(map%nodes) + deallocate(map) + end subroutine destroyNamedNodeMap + + + + function hasFeature(impl, feature, version, ex)result(p) + type(DOMException), intent(out), optional :: ex + type(DOMImplementation), pointer :: impl + character(len=*), intent(in) :: feature + character(len=*), intent(in) :: version + logical :: p + + if (.not.associated(impl)) then + if (getFoX_checks().or.FoX_IMPL_IS_NULL<200) then + call throw_exception(FoX_IMPL_IS_NULL, "hasFeature", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (version=="1.0".or.version=="2.0".or.version=="") then + p = (toLower(feature)=="core".or.toLower(feature)=="xml") + else + p = .false. + endif + + end function hasFeature + + function createDocumentType(impl, qualifiedName, publicId, systemId, ex)result(dt) + type(DOMException), intent(out), optional :: ex + type(DOMImplementation), pointer :: impl + character(len=*), intent(in) :: qualifiedName + character(len=*), intent(in) :: publicId + character(len=*), intent(in) :: systemId + type(Node), pointer :: dt + + type(URI), pointer :: URIref + + dt => null() + + if (.not.associated(impl)) then + if (getFoX_checks().or.FoX_IMPL_IS_NULL<200) then + call throw_exception(FoX_IMPL_IS_NULL, "createDocumentType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.checkName(qualifiedName, XML1_0)) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "createDocumentType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkQName(qualifiedName, XML1_0)) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createDocumentType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkPublicId(publicId)) then + if (getFoX_checks().or.FoX_INVALID_PUBLIC_ID<200) then + call throw_exception(FoX_INVALID_PUBLIC_ID, "createDocumentType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + URIref => parseURI(systemId) + if (.not.associated(URIref)) then + if (getFoX_checks().or.FoX_INVALID_SYSTEM_ID<200) then + call throw_exception(FoX_INVALID_SYSTEM_ID, "createDocumentType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + call destroyURI(URIref) + +! Dont use raw null() below or PGI will complain + dt => createNode(dt, DOCUMENT_TYPE_NODE, qualifiedName, "") + allocate(dt%dtdExtras) + dt%readonly = .true. + dt%dtdExtras%publicId => vs_str_alloc(publicId) + dt%dtdExtras%systemId => vs_str_alloc(systemId) + dt%dtdExtras%entities%ownerElement => dt + dt%dtdExtras%notations%ownerElement => dt + + dt%ownerDocument => null() + + end function createDocumentType + + + function createDocument(impl, namespaceURI, qualifiedName, docType, ex)result(doc) + type(DOMException), intent(out), optional :: ex + type(DOMImplementation), pointer :: impl + character(len=*), intent(in), optional :: namespaceURI + character(len=*), intent(in), optional :: qualifiedName + type(Node), pointer :: docType + type(Node), pointer :: doc, dt, de + + doc => null() + + if (.not.associated(impl)) then + if (getFoX_checks().or.FoX_IMPL_IS_NULL<200) then + call throw_exception(FoX_IMPL_IS_NULL, "createDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (associated(docType)) then + if (associated(getOwnerDocument(docType))) then + if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then + call throw_exception(WRONG_DOCUMENT_ERR, "createDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + endif + + if (.not.checkName(qualifiedName, XML1_0)) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "createDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif(.not.checkQName(qualifiedName, XML1_0)) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (prefixOfQName(qualifiedName)/="".and.namespaceURI=="") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (prefixOfQName(qualifiedName)=="xml".neqv.namespaceURI=="http://www.w3.org/XML/1998/namespace") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (namespaceURI=="http://www.w3.org/2000/xmlns/") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (qualifiedName=="xmlns" .or. prefixOfQName(qualifiedName)=="xmlns") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + +! Dont use raw null() below or PGI will complain + doc => createNode(doc, DOCUMENT_NODE, "#document", "") + doc%ownerDocument => doc ! Makes life easier. DOM compliance in getter + doc%inDocument = .true. + + allocate(doc%docExtras) + doc%docExtras%implementation => FoX_DOM + allocate(doc%docExtras%nodelists(0)) + allocate(doc%docExtras%xds) + call init_xml_doc_state(doc%docExtras%xds) + allocate(doc%docExtras%xds%documentURI(0)) + allocate(doc%docExtras%domConfig) + + if (associated(docType)) then + dt => docType + dt%ownerDocument => doc + doc%docExtras%docType => appendChild(doc, dt, ex) + endif + + if (qualifiedName/="") then + ! NB It is impossible to create a non-namespaced document. + ! since createDocument doesnt exist in DOM Core 1 + de => createElementNS(doc, namespaceURI, qualifiedName) + de => appendChild(doc, de) + call setDocumentElement(doc, de) + endif + + call setGCstate(doc, .true.) + + end function createDocument + + + function createEmptyDocument() result(doc) + type(Node), pointer :: doc + +! PGI again + doc => null() + doc => createNode(doc, DOCUMENT_NODE, "#document", "") + doc%ownerDocument => doc ! Makes life easier. DOM compliance maintained in getter + doc%inDocument = .true. + + allocate(doc%docExtras) + doc%docExtras%implementation => FoX_DOM + allocate(doc%docExtras%nodelists(0)) + allocate(doc%docExtras%xds) + call init_xml_doc_state(doc%docExtras%xds) + + end function createEmptyDocument + + + subroutine destroyDocument(arg, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + + integer :: i + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "destroyDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "destroyDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + +! Switch off all GC - since this is GC! + call setGCstate(arg, .false., ex) + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "destroyDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + +! Destroy all remaining nodelists + + do i = 1, size(arg%docExtras%nodelists) + call destroy(arg%docExtras%nodelists(i)%this) + enddo + deallocate(arg%docExtras%nodelists) + + ! Destroy all remaining hanging nodes + do i = 1, arg%docExtras%hangingNodes%length + call destroy(arg%docExtras%hangingNodes%nodes(i)%this) + enddo + if (associated(arg%docExtras%hangingNodes%nodes)) deallocate(arg%docExtras%hangingNodes%nodes) + + call destroy_xml_doc_state(arg%docExtras%xds) + if (present(ex)) then + if (inException(ex)) return + endif + if (associated(arg%docExtras%xds)) deallocate(arg%docExtras%xds) + if (associated(arg%docExtras%domConfig)) deallocate(arg%docExtras%domConfig) + if (associated(arg%docExtras)) deallocate(arg%docExtras) + + call destroyAllNodesRecursively(arg, except=.true.) + + end subroutine destroyDocument + + function getFoX_checks() result(FoX_checks) + logical :: FoX_checks + + FoX_checks = FoX_DOM%FoX_checks + end function getFoX_checks + + subroutine setFoX_checks(FoX_checks) + logical, intent(in) :: FoX_checks + + FoX_DOM%FoX_checks = FoX_checks + end subroutine setFoX_checks + + + + +function getdocType(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(Node), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getdocType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getdocType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c => np%docExtras%docType + + end function getdocType + + + subroutine setDocType(arg, np, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setDocType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setDocType", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + arg%docExtras%docType => np +!NB special case in order to set ownerDocument + np%ownerDocument => arg + end subroutine setDocType + +function getdocumentElement(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(Node), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getdocumentElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getdocumentElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c => np%docExtras%documentElement + + end function getdocumentElement + + + subroutine setXds(arg, xds, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(xml_doc_state), pointer :: xds + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setXds", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setXds", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif +!NB special case in order to destroy_xml_doc_state etc + call destroy_xml_doc_state(arg%docExtras%xds) + deallocate(arg%docExtras%xds) + arg%docExtras%xds => xds + + end subroutine setXds + + function getImplementation(arg, ex)result(imp) + type(DOMException), intent(out), optional :: ex + type(Node), pointer, optional :: arg + type(DOMImplementation), pointer :: imp + + ! According to the testsuite, you get to call + ! getImplementation with no args. Dont know + ! where they get that from ... + if (present(arg)) then + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getImplementation", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getImplementation", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + imp => arg%docExtras%implementation + else + imp => FoX_DOM + endif + end function getImplementation + + + subroutine setDocumentElement(arg, np, ex) + type(DOMException), intent(out), optional :: ex + ! Only for use by FoX, not exported through FoX_DOM interface + type(Node), pointer :: arg + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setDocumentElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + +!NB special case due to additional error conditions: + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setDocumentElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (np%nodeType/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setDocumentElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.associated(np%ownerDocument, arg)) then + if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then + call throw_exception(WRONG_DOCUMENT_ERR, "setDocumentElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + arg%docExtras%documentElement => np + + end subroutine setDocumentElement + + ! Methods + + function createElement(arg, tagName, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: tagName + type(Node), pointer :: np + + type(xml_doc_state), pointer :: xds + type(element_t), pointer :: elem + type(attribute_t), pointer :: att + logical :: defaults_ + integer :: i + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(tagName, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "createElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + np => createNode(arg, ELEMENT_NODE, tagName, "") + allocate(np%elExtras) + np%elExtras%dom1 = .true. + np%elExtras%attributes%ownerElement => np + allocate(np%elExtras%namespaceURI(0)) + allocate(np%elExtras%prefix(0)) + allocate(np%elExtras%localname(0)) + allocate(np%elExtras%namespaceNodes%nodes(0)) + + np%elExtras%attributes%ownerElement => np + + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + ! We only add default attributes if we are *not* building the doc + xds => getXds(arg) + elem => get_element(xds%element_list, tagName) + if (associated(elem)) then + do i = 1, get_attlist_size(elem) + att => get_attribute_declaration(elem, i) + if (attribute_has_default(att)) then + ! Since this is a non-namespaced function, we create + ! a non-namespaced attribute ... + call setAttribute(np, str_vs(att%name), str_vs(att%default)) + endif + enddo + endif + else + np%inDocument = .true. + endif + + end function createElement + + function createEmptyElement(arg, tagName, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: tagName + type(Node), pointer :: np + +! NO CHECKS ! + + np => createNode(arg, ELEMENT_NODE, tagName, "") + allocate(np%elExtras) + np%elExtras%dom1 = .true. + np%elExtras%attributes%ownerElement => np + allocate(np%elExtras%namespaceURI(0)) + allocate(np%elExtras%prefix(0)) + allocate(np%elExtras%localname(0)) + allocate(np%elExtras%namespaceNodes%nodes(0)) + + np%elExtras%attributes%ownerElement => np + + if (getGCstate(arg)) then + call append(arg%docExtras%hangingnodes, np) + np%inDocument = .false. + else + np%inDocument = .true. + endif + end function createEmptyElement + + function createDocumentFragment(arg, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createDocumentFragment", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createDocumentFragment", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, DOCUMENT_FRAGMENT_NODE, "#document-fragment", "") + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + else + np%inDocument = .true. + endif + + end function createDocumentFragment + + function createTextNode(arg, data, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: data + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createTextNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createTextNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkChars(data, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then + call throw_exception(FoX_INVALID_CHARACTER, "createTextNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, TEXT_NODE, "#text", data) + np%textContentLength = len(data) + + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + else + np%inDocument = .true. + endif + + end function createTextNode + + function createComment(arg, data, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: data + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createComment", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createComment", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkChars(data, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then + call throw_exception(FoX_INVALID_CHARACTER, "createComment", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (index(data,"--")>0) then + if (getFoX_checks().or.FoX_INVALID_COMMENT<200) then + call throw_exception(FoX_INVALID_COMMENT, "createComment", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, COMMENT_NODE, "#comment", data) + np%textContentLength = len(data) + + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + else + np%inDocument = .true. + endif + + end function createComment + + function createCdataSection(arg, data, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: data + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createCdataSection", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createCdataSection", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkChars(data, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then + call throw_exception(FoX_INVALID_CHARACTER, "createCdataSection", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (index(data,"]]>")>0) then + if (getFoX_checks().or.FoX_INVALID_CDATA_SECTION<200) then + call throw_exception(FoX_INVALID_CDATA_SECTION, "createCdataSection", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, CDATA_SECTION_NODE, "#cdata-section", data) + np%textContentLength = len(data) + + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + else + np%inDocument = .true. + endif + + end function createCdataSection + + function createProcessingInstruction(arg, target, data, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: target + character(len=*), intent(in) :: data + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createProcessingInstruction", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createProcessingInstruction", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(target, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "createProcessingInstruction", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkChars(data, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then + call throw_exception(FoX_INVALID_CHARACTER, "createProcessingInstruction", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (index(data,"?>")>0) then + if (getFoX_checks().or.FoX_INVALID_PI_DATA<200) then + call throw_exception(FoX_INVALID_PI_DATA, "createProcessingInstruction", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, PROCESSING_INSTRUCTION_NODE, target, data) + np%textContentLength = len(data) + + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + else + np%inDocument = .true. + endif + + end function createProcessingInstruction + + function createAttribute(arg, name, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(name, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "createAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, ATTRIBUTE_NODE, name, "") + allocate(np%elExtras) + np%elExtras%dom1 = .true. + allocate(np%elExtras%namespaceURI(0)) + allocate(np%elExtras%prefix(0)) + allocate(np%elExtras%localname(0)) + + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + else + np%inDocument = .true. + endif + + end function createAttribute + + + recursive function createEntityReference(arg, name, ex)result(np) + type(DOMException), intent(out), optional :: ex + ! Needs to be recursive in case of entity-references within each other. + type(Node), pointer :: arg + character(len=*), intent(in) :: name + type(Node), pointer :: np + + type(Node), pointer :: ent, newNode + integer :: i + logical :: brokenNS + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createEntityReference", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createEntityReference", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(name, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "createEntityReference", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getXmlStandalone(arg).and..not.associated(getDocType(arg))) then + if (getFoX_checks().or.FoX_NO_SUCH_ENTITY<200) then + call throw_exception(FoX_NO_SUCH_ENTITY, "createEntityReference", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, ENTITY_REFERENCE_NODE, name, "") + if (getGCstate(arg)) then ! otherwise the parser will fill these nodes in itself + if (associated(getDocType(arg))) then + ent => getNamedItem(getEntities(getDocType(arg)), name) + if (associated(ent)) then + if (getIllFormed(ent)) then + if (getFoX_checks().or.FoX_INVALID_ENTITY<200) then + call throw_exception(FoX_INVALID_ENTITY, "createEntityReference", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + brokenNS = arg%docExtras%brokenNS + arg%docExtras%brokenNS = .true. ! We need to not worry about NS errors for a bit + do i = 0, getLength(getChildNodes(ent)) - 1 + newNode => appendChild(np, cloneNode(item(getChildNodes(ent), i), .true., ex)) + ! No namespace calcs here - wait for a namespace normalization + call setReadOnlyNode(newNode, .true., .true.) + enddo + arg%docExtras%brokenNS = brokenNS ! FIXME also for all new default attributes + elseif (getXmlStandalone(arg)) then + if (getFoX_checks().or.FoX_NO_SUCH_ENTITY<200) then + call throw_exception(FoX_NO_SUCH_ENTITY, "createEntityReference", ex) + if (present(ex)) then + if (inException(ex)) then + + if (associated(np)) deallocate(np) + return + endif + endif +endif + + endif + endif + endif + + call setReadOnlyNode(np, .true., .false.) + + if (getGCstate(arg)) then + np%inDocument = .false. + call append_nl(arg%docExtras%hangingNodes, np) + ! All child nodes were created outside the document by cloneNode above + else + np%inDocument = .true. + endif + + end function createEntityReference + + function createEmptyEntityReference(arg, name, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createEmptyEntityReference", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createEmptyEntityReference", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(name, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "createEmptyEntityReference", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, ENTITY_REFERENCE_NODE, name, "") + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + else + np%inDocument = .true. + endif + + end function createEmptyEntityReference + + function getElementsByTagName(doc, tagName, name, ex)result(list) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: doc + character(len=*), intent(in), optional :: tagName, name + type(NodeList), pointer :: list + + type(NodeListPtr), pointer :: nll(:), temp_nll(:) + type(Node), pointer :: arg, this, treeroot + logical :: doneChildren, doneAttributes, allElements + integer :: i, i_tree + + if (.not.associated(doc)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getElementsByTagName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (doc%nodeType==DOCUMENT_NODE) then + if (present(name).or..not.present(tagName)) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getElementsByTagName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + elseif (doc%nodeType==ELEMENT_NODE) then + if (present(name).or..not.present(tagName)) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getElementsByTagName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + else + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getElementsByTagName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (doc%nodeType==DOCUMENT_NODE) then + arg => getDocumentElement(doc) + else + arg => doc + endif + + allocate(list) + allocate(list%nodes(0)) + list%element => doc + if (present(name)) list%nodeName => vs_str_alloc(name) + if (present(tagName)) list%nodeName => vs_str_alloc(tagName) + + allElements = (str_vs(list%nodeName)=="*") + + if (doc%nodeType==DOCUMENT_NODE) then + nll => doc%docExtras%nodelists + elseif (doc%nodeType==ELEMENT_NODE) then + nll => doc%ownerDocument%docExtras%nodelists + endif + allocate(temp_nll(size(nll)+1)) + do i = 1, size(nll) + temp_nll(i)%this => nll(i)%this + enddo + temp_nll(i)%this => list + deallocate(nll) + if (doc%nodeType==DOCUMENT_NODE) then + doc%docExtras%nodelists => temp_nll + elseif (doc%nodeType==ELEMENT_NODE) then + doc%ownerDocument%docExtras%nodelists => temp_nll + endif + + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + if (this%nodeType==ELEMENT_NODE) then + if ((allElements .or. str_vs(this%nodeName)==tagName) & + .and..not.(getNodeType(doc)==ELEMENT_NODE.and.associated(this, arg))) & + call append(list, this) + doneAttributes = .true. + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + endif + endif + + enddo + + + + end function getElementsByTagName + + function getChildrenByTagName(doc, tagName, name, ex)result(list) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: doc + character(len=*), intent(in), optional :: tagName, name + type(NodeList), pointer :: list + + type(NodeListPtr), pointer :: nll(:), temp_nll(:) + type(Node), pointer :: arg, this, treeroot + logical :: doneChildren, doneAttributes, allElements + integer :: i, i_tree + + if (.not.associated(doc)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getElementsByTagName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (doc%nodeType==DOCUMENT_NODE) then + if (present(name).or..not.present(tagName)) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getElementsByTagName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + elseif (doc%nodeType==ELEMENT_NODE) then + if (present(name).or..not.present(tagName)) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getElementsByTagName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + else + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getElementsByTagName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (doc%nodeType==DOCUMENT_NODE) then + arg => getDocumentElement(doc) + else + arg => doc + endif + + allocate(list) + allocate(list%nodes(0)) + list%element => doc + if (present(name)) list%nodeName => vs_str_alloc(name) + if (present(tagName)) list%nodeName => vs_str_alloc(tagName) + + allElements = (str_vs(list%nodeName)=="*") + + if (doc%nodeType==DOCUMENT_NODE) then + nll => doc%docExtras%nodelists + elseif (doc%nodeType==ELEMENT_NODE) then + nll => doc%ownerDocument%docExtras%nodelists + endif + allocate(temp_nll(size(nll)+1)) + do i = 1, size(nll) + temp_nll(i)%this => nll(i)%this + enddo + temp_nll(i)%this => list + deallocate(nll) + if (doc%nodeType==DOCUMENT_NODE) then + doc%docExtras%nodelists => temp_nll + elseif (doc%nodeType==ELEMENT_NODE) then + doc%ownerDocument%docExtras%nodelists => temp_nll + endif + + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + if (this%nodeType==ELEMENT_NODE) then + if ((allElements .or. str_vs(this%nodeName)==tagName) & + .and..not.(getNodeType(doc)==ELEMENT_NODE.and.associated(this, arg))) & + call append(list, this) + doneAttributes = .true. + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this) .and. .not. associated(getParentNode(this), treeroot)) then + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + endif + endif + + enddo + + + + end function getChildrenByTagName + + function importNode(doc , arg, deep , ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: doc + type(Node), pointer :: arg + logical, intent(in) :: deep + type(Node), pointer :: np + + type(Node), pointer :: this, thatParent, new, treeroot + type(xml_doc_state), pointer :: xds + type(element_t), pointer :: elem + type(attribute_t), pointer :: att + logical :: doneAttributes, doneChildren, brokenNS + integer :: i_tree + + if (.not.associated(doc).or..not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "importNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(doc)/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "importNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)==DOCUMENT_NODE .or. & + getNodeType(arg)==DOCUMENT_TYPE_NODE) then + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "importNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + brokenNS = doc%docExtras%brokenNS + doc%docExtras%brokenNS = .true. ! We need to do stupid NS things + xds => getXds(doc) + thatParent => null() + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + + new => null() + select case (getNodeType(this, ex)) + case (ELEMENT_NODE) + if (.not.doneAttributes) then + ! We dont create an empty node - we insist on having all default + ! properties created. + if (getParameter(getDomConfig(doc, ex), "namespaces", ex)) then + new => createElementNS(doc, getNamespaceURI(this, ex), getTagName(this, ex), ex) + else + new => createElement(doc, getTagName(this, ex), ex) + endif + endif + case (ATTRIBUTE_NODE) + if (associated(this, arg).or.getSpecified(this, ex)) then + ! We are importing just this attribute node + ! or this was an explicitly specified attribute; either + ! way, we import it as is, and it remains specified. + if (getParameter(getDomConfig(doc), "namespaces")) then + new => createAttributeNS(doc, getNamespaceURI(this, ex), getName(this, ex), ex) + else + new => createAttribute(doc, getName(this), ex) + endif + call setSpecified(new, .true.) + else + ! This is an attribute being imported as part of a hierarchy, + ! but its only here by default. Is there a default attribute + ! of this name in the new document? + elem => get_element(xds%element_list, & + getTagName(getOwnerElement(this))) + att => get_attribute_declaration(elem, getName(this)) + if (attribute_has_default(att)) then + ! Create the new default: + if (getParameter(getDomConfig(doc, ex), "namespaces", ex)) then + ! We create a namespaced attribute. Of course, its + ! namespaceURI remains empty for the moment unless we know it ... + if (prefixOfQName(getName(this, ex))=="xml") then + new => createAttributeNS(doc, & + "http://www.w3.org/XML/1998/namespace", & + getName(this, ex), ex) + elseif (getName(this, ex)=="xmlns" & + .or. prefixOfQName(getName(this, ex))=="xmlns") then + new => createAttributeNS(doc, & + "http://www.w3.org/2000/xmlns/", & + getName(this, ex), ex) + else + ! Wait for namespace fixup ... + new => createAttributeNS(doc, "", & + getName(this, ex), ex) + endif + else + new => createAttribute(doc, getName(this, ex), ex) + endif + call setValue(new, str_vs(att%default), ex) + call setSpecified(new, .false.) + endif + ! In any case, we dont want to copy the children of this node. + doneChildren=.true. + endif + case (TEXT_NODE) + new => createTextNode(doc, getData(this, ex), ex) + case (CDATA_SECTION_NODE) + new => createCDataSection(doc, getData(this, ex), ex) + case (ENTITY_REFERENCE_NODE) + new => createEntityReference(doc, getNodeName(this, ex), ex) + ! This will automatically populate the entity reference if doc defines it, so no children needed + doneChildren = .true. + case (ENTITY_NODE) + new => createEntity(doc, getNodeName(this, ex), & + getPublicId(this, ex), getSystemId(this, ex), & + getNotationName(this, ex), ex) + case (PROCESSING_INSTRUCTION_NODE) + new => createProcessingInstruction(doc, & + getTarget(this, ex), getData(this, ex), ex) + case (COMMENT_NODE) + new => createComment(doc, getData(this, ex), ex) + case (DOCUMENT_NODE) + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "importNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + case (DOCUMENT_TYPE_NODE) + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "importNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + case (DOCUMENT_FRAGMENT_NODE) + new => createDocumentFragment(doc, ex) + case (NOTATION_NODE) + new => createNotation(doc, getNodeName(this, ex), & + getPublicId(this, ex), getSystemId(this, ex), ex) + end select + + if (.not.associated(thatParent)) then + thatParent => new + elseif (associated(new)) then + if (getNodeType(this, ex)==ATTRIBUTE_NODE) then + new => setAttributeNode(thatParent, new, ex) + else + new => appendChild(thatParent, new, ex) + endif + endif + + if (.not.deep) then + if (getNodeType(arg, ex)==ATTRIBUTE_NODE & + .or.getNodeType(arg, ex)==ELEMENT_NODE) then + continue + else + exit + endif + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + if (.not.associated(this, treeroot)) thatParent => getLastChild(thatParent) + this => item(getAttributes(this), 0) + else + if (.not.deep) exit + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + if (getNodeType(this)==ELEMENT_NODE.and..not.deep) exit + if (.not.associated(this, treeroot)) then + if (getNodeType(this)==ATTRIBUTE_NODE) then + thatParent => item(getAttributes(thatParent), i_tree) + else + thatParent => getLastChild(thatParent) + endif + endif + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + if (associated(getParentNode(thatParent))) thatParent => getParentNode(thatParent) + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + if (.not.associated(this, treeroot)) then + if (getNodeType(this)==ATTRIBUTE_NODE) then + thatParent => getOwnerElement(thatParent) + else + thatParent => getParentNode(thatParent) + endif + endif + endif + endif + + enddo + + + + np => thatParent + doc%docExtras%brokenNS = brokenNS +! call namespaceFixup(np) + + end function importNode + + function createElementNS(arg, namespaceURI, qualifiedName, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, qualifiedName + type(Node), pointer :: np + + type(xml_doc_state), pointer :: xds + type(element_t), pointer :: elem + type(attribute_t), pointer :: att + integer :: i + logical :: brokenNS + type(URI), pointer :: URIref + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createElementNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createElementNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(qualifiedName, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "createElementNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkQName(qualifiedName, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createElementNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (prefixOfQName(qualifiedName)/="" & + .and. namespaceURI=="".and..not.arg%docExtras%brokenNS) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createElementNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (namespaceURI=="http://www.w3.org/XML/1998/namespace" .neqv. & + prefixOfQName(qualifiedName)=="xml") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createElementNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (namespaceURI=="http://www.w3.org/2000/xmlns/") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createElementNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + URIref => parseURI(namespaceURI) + if (.not.associated(URIref)) then + if (getFoX_checks().or.FoX_INVALID_URI<200) then + call throw_exception(FoX_INVALID_URI, "createElementNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + call destroyURI(URIref) + + np => createNode(arg, ELEMENT_NODE, qualifiedName, "") + allocate(np%elExtras) + np%elExtras%namespaceURI => vs_str_alloc(namespaceURI) + np%elExtras%prefix => vs_str_alloc(prefixOfQName(qualifiedname)) + np%elExtras%localName => vs_str_alloc(localpartOfQName(qualifiedname)) + allocate(np%elExtras%namespaceNodes%nodes(0)) + + np%elExtras%attributes%ownerElement => np + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + ! We only add default attributes if we are *not* building the doc + xds => getXds(arg) + elem => get_element(xds%element_list, qualifiedName) + if (associated(elem)) then + do i = 1, get_attlist_size(elem) + att => get_attribute_declaration(elem, i) + if (attribute_has_default(att)) then + ! Since this is a namespaced function, we create a namespaced + ! attribute. Of course, its namespaceURI remains empty + ! for the moment unless we know it ... + if (prefixOfQName(str_vs(att%name))=="xml") then + call setAttributeNS(np, & + "http://www.w3.org/XML/1998/namespace", & + str_vs(att%name), str_vs(att%default), ex) + elseif (str_vs(att%name)=="xmlns" & + .or. prefixOfQName(str_vs(att%name))=="xmlns") then + call setAttributeNS(np, & + "http://www.w3.org/2000/xmlns/", & + str_vs(att%name), str_vs(att%default), ex) + else + ! Wait for namespace fixup ... + brokenNS = arg%docExtras%brokenNS + arg%docExtras%brokenNS = .true. + call setAttributeNS(np, "", str_vs(att%name), & + str_vs(att%default), ex) + arg%docExtras%brokenNS = brokenNS + endif + endif + enddo + endif + else + np%inDocument = .true. + endif + + end function createElementNS + + function createEmptyElementNS(arg, namespaceURI, qualifiedName, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, qualifiedName + type(Node), pointer :: np + +! NO CHECKS ! + + np => createNode(arg, ELEMENT_NODE, qualifiedName, "") + allocate(np%elExtras) + np%elExtras%namespaceURI => vs_str_alloc(namespaceURI) + np%elExtras%prefix => vs_str_alloc(prefixOfQName(qualifiedname)) + np%elExtras%localName => vs_str_alloc(localpartOfQName(qualifiedname)) + allocate(np%elExtras%namespaceNodes%nodes(0)) + + np%elExtras%attributes%ownerElement => np + + if (getGCstate(arg)) then + call append(arg%docExtras%hangingnodes, np) + np%inDocument = .false. + else + np%inDocument = .true. + endif + end function createEmptyElementNS + + function createAttributeNS(arg, namespaceURI, qualifiedname, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, qualifiedName + type(Node), pointer :: np + + type(URI), pointer :: URIref + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(qualifiedName, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "createAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkQName(qualifiedName, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (prefixOfQName(qualifiedName)/="" & + .and. namespaceURI=="".and..not.arg%docExtras%brokenNS) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (namespaceURI=="http://www.w3.org/XML/1998/namespace" .neqv. & + prefixOfQName(qualifiedName)=="xml") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (namespaceURI=="http://www.w3.org/2000/xmlns/" .neqv. & + (qualifiedName=="xmlns" .or. prefixOfQName(qualifiedName)=="xmlns")) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "createAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + URIref => parseURI(namespaceURI) + if (.not.associated(URIref)) then + if (getFoX_checks().or.FoX_INVALID_URI<200) then + call throw_exception(FoX_INVALID_URI, "createAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + call destroyURI(URIref) + + + np => createNode(arg, ATTRIBUTE_NODE, qualifiedName, "") + allocate(np%elExtras) + np%elExtras%namespaceURI => vs_str_alloc(namespaceURI) + np%elExtras%localname => vs_str_alloc(localPartofQName(qualifiedname)) + np%elExtras%prefix => vs_str_alloc(PrefixofQName(qualifiedname)) + + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + else + np%inDocument = .true. + endif + + end function createAttributeNS + + function getElementsByTagNameNS(doc, namespaceURI, localName, ex)result(list) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: doc + character(len=*), intent(in) :: namespaceURI, localName + type(NodeList), pointer :: list + + type(NodeListPtr), pointer :: nll(:), temp_nll(:) + type(Node), pointer :: this, arg, treeroot + logical :: doneChildren, doneAttributes, allLocalNames, allNameSpaces + integer :: i, i_tree + + if (.not.associated(doc)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getElementsByTagNameNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (doc%nodeType/=DOCUMENT_NODE.and.doc%nodeType/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getElementsByTagNameNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + allNamespaces = (namespaceURI=="*") + allLocalNames = (localName=="*") + + if (doc%nodeType==DOCUMENT_NODE) then + arg => getDocumentElement(doc) + else + arg => doc + endif + + allocate(list) + allocate(list%nodes(0)) + list%element => doc + list%localName => vs_str_alloc(localName) + list%namespaceURI => vs_str_alloc(namespaceURI) + + if (doc%nodeType==DOCUMENT_NODE) then + nll => doc%docExtras%nodelists + elseif (doc%nodeType==ELEMENT_NODE) then + nll => doc%ownerDocument%docExtras%nodelists + endif + allocate(temp_nll(size(nll)+1)) + do i = 1, size(nll) + temp_nll(i)%this => nll(i)%this + enddo + temp_nll(i)%this => list + deallocate(nll) + if (doc%nodeType==DOCUMENT_NODE) then + doc%docExtras%nodelists => temp_nll + elseif (doc%nodeType==ELEMENT_NODE) then + doc%ownerDocument%docExtras%nodelists => temp_nll + endif + + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + if (getNodeType(this)==ELEMENT_NODE) then + if (getNamespaceURI(this)/="") then + if ((allNameSpaces .or. getNameSpaceURI(this)==namespaceURI) & + .and. (allLocalNames .or. getLocalName(this)==localName) & + .and..not.(getNodeType(doc)==ELEMENT_NODE.and.associated(this, arg))) & + call append(list, this) + else + if ((allNameSpaces .or. namespaceURI=="") & + .and. (allLocalNames .or. getNodeName(this)==localName) & + .and..not.(getNodeType(doc)==ELEMENT_NODE.and.associated(this, arg))) & + call append(list, this) + endif + doneAttributes = .true. ! Never search attributes + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + endif + endif + + enddo + + + + end function getElementsByTagNameNS + + + function getElementById(arg, elementId, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: elementId + type(Node), pointer :: np + + type(Node), pointer :: this, treeroot + integer :: i_tree + logical :: doneChildren, doneAttributes + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getElementById", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getElementById", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => null() + treeroot => getDocumentElement(arg) + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + if (this%nodeType==ATTRIBUTE_NODE) then + if (getIsId(this).and.getValue(this)==elementId) then + np => getOwnerElement(this) + return + endif + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + endif + endif + + enddo + + + + end function getElementById + +function getxmlStandalone(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getxmlStandalone", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getxmlStandalone", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = np%docExtras%xds%standalone + + end function getxmlStandalone + +subroutine setxmlStandalone(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setxmlStandalone", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setxmlStandalone", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np%docExtras%xds%standalone = c + + end subroutine setxmlStandalone + +! FIXME additional check on setting - do we have any undefined entrefs present? + + function getXmlVersion(arg, ex)result(s) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=3) :: s + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getXmlVersion", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE & + .and.arg%nodeType/=ENTITY_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getXmlVersion", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getXmlVersionEnum(arg)==XML1_0) then + s = "1.0" + elseif (getXmlVersionEnum(arg)==XML1_1) then + s = "1.1" + else + s = "XXX" + endif + + end function getXmlVersion + + subroutine setXmlVersion(arg, s, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*) :: s + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setXmlVersion", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setXmlVersion", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (s=="1.0") then + arg%docExtras%xds%xml_version = XML1_0 + elseif (s=="1.1") then + arg%docExtras%xds%xml_version = XML1_1 + else + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "setXmlVersion", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + end subroutine setXmlVersion + + pure function getXmlEncoding_len(arg, p) result(n) + type(Node), pointer :: arg + logical, intent(in) :: p + integer :: n + + n = 0 + if (.not.p) return + if (arg%nodeType==DOCUMENT_NODE) & + n = size(arg%docExtras%xds%encoding) + end function getXmlEncoding_len + + function getXmlEncoding(arg, ex)result(s) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getXmlEncoding_len(arg, .true.)) :: s +#else + character(len=getXmlEncoding_len(arg, associated(arg))) :: s +#endif + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getXmlEncoding", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType==DOCUMENT_NODE) then + s = str_vs(arg%docExtras%xds%encoding) + elseif (arg%nodeType==ENTITY_NODE) then + s = "" !FIXME revisit when we have working external entities + else + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getXmlEncoding", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + end function getXmlEncoding + + pure function getInputEncoding_len(arg, p) result(n) + type(Node), pointer :: arg + logical, intent(in) :: p + integer :: n + + n = 0 + if (.not.p) return + if (arg%nodeType==DOCUMENT_NODE) & + n = size(arg%docExtras%xds%inputEncoding) + end function getInputEncoding_len + + function getInputEncoding(arg, ex)result(s) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getInputEncoding_len(arg, .true.)) :: s +#else + character(len=getInputEncoding_len(arg, associated(arg))) :: s +#endif + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getInputEncoding", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType==DOCUMENT_NODE) then + s = str_vs(arg%docExtras%xds%inputEncoding) + elseif (arg%nodeType==ENTITY_NODE) then + s = "" !FIXME revisit when we have working external entities + else + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getInputEncoding", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + end function getInputEncoding + + + pure function getdocumentURI_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + if (p .and. ( & + np%nodeType==DOCUMENT_NODE .or. & + .false.)) then + n = size(np%docExtras%xds%documentURI) + else + n = 0 + endif + end function getdocumentURI_len +function getdocumentURI(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getdocumentURI_len(np, .true.)) :: c +#else + character(len=getdocumentURI_len(np, associated(np))) :: c +#endif + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getdocumentURI", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getdocumentURI", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = str_vs(np%docExtras%xds%documentURI) + + end function getdocumentURI + +subroutine setdocumentURI(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + character(len=*) :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setdocumentURI", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setdocumentURI", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (associated(np%docExtras%xds%documentURI)) deallocate(np%docExtras%xds%documentURI) + np%docExtras%xds%documentURI => vs_str_alloc(c) + + end subroutine setdocumentURI + + +function getstrictErrorChecking(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getstrictErrorChecking", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getstrictErrorChecking", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = np%docExtras%strictErrorChecking + + end function getstrictErrorChecking + +subroutine setstrictErrorChecking(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setstrictErrorChecking", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setstrictErrorChecking", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np%docExtras%strictErrorChecking = c + + end subroutine setstrictErrorChecking + + + function adoptNode(doc , arg , ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: doc + type(Node), pointer :: arg + type(Node), pointer :: np + + type(Node), pointer :: this, thatParent, new, treeroot, parent, dead + type(xml_doc_state), pointer :: xds + type(element_t), pointer :: elem + type(attribute_t), pointer :: att + logical :: doneAttributes, doneChildren, brokenNS + integer :: i_tree + + if (.not.associated(doc).or..not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "adoptNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(doc)/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "adoptNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)==DOCUMENT_NODE .or. & + getNodeType(arg)==DOCUMENT_TYPE_NODE .or. & + getNodeType(arg)==NOTATION_NODE .or. & + getNodeType(arg)==ENTITY_NODE) then + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "adoptNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getReadonly(arg)) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "adoptNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + brokenNS = doc%docExtras%brokenNS + doc%docExtras%brokenNS = .true. ! We need to do stupid NS things + xds => getXds(doc) + + if (associated(getParentNode(arg))) then + np => removeChild(getParentNode(arg), arg) + else + np => arg + endif + + if (associated(arg, getOwnerDocument(arg))) return + + thatParent => null() + treeroot => np + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + + select case (getNodeType(this)) + case (ELEMENT_NODE) + if (.not.doneAttributes) call setOwnerDocument(this, doc) + case (ATTRIBUTE_NODE) + if (associated(this, arg).or.getSpecified(this)) then + ! We are importing just this attribute node + ! or this was an explicitly specified attribute; either + ! way, we import it as is, and it becomes/remains specified. + call setOwnerDocument(this, doc) + call setSpecified(this, .true.) + else + ! This is an attribute being imported as part of a hierarchy, + ! but its only here by default. Is there a default attribute + ! of this name in the new document? + elem => get_element(xds%element_list, & + getTagName(getOwnerElement(this))) + att => get_attribute_declaration(elem, getName(this)) + if (attribute_has_default(att)) then + ! Create the new default: + if (getParameter(getDomConfig(doc), "namespaces")) then + ! We create a namespaced attribute. Of course, its + ! namespaceURI remains empty for the moment unless we know it ... + if (prefixOfQName(getName(this))=="xml") then + new => createAttributeNS(np, & + "http://www.w3.org/XML/1998/namespace", & + getName(this)) + elseif (getName(this)=="xmlns" & + .or. prefixOfQName(getName(this))=="xmlns") then + new => createAttributeNS(np, & + "http://www.w3.org/2000/xmlns/", & + getName(this)) + else + ! Wait for namespace fixup ... + new => createAttributeNS(np, "", & + getName(this)) + endif + else + new => createAttribute(doc, getName(this)) + endif + call setValue(new, str_vs(att%default)) + call setSpecified(new, .false.) + ! In any case, we dont want to copy the children of this node. + doneChildren = .true. + dead => setAttributeNode(getOwnerElement(this), new) + this => new + call destroyAllNodesRecursively(dead) + endif + ! Otherwise no attribute here, so go back to previous node + dead => this + if (i_tree==0) then + this => getOwnerElement(this) + else + i_tree = i_tree - 1 + this => item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .true. + endif + call removeAttribute(getOwnerElement(dead), getNodeName(dead)) + endif + case (ENTITY_REFERENCE_NODE) + new => createEntityReference(doc, getNodeName(this)) + ! This will automatically populate the entity reference if doc defines it, so no children needed + parent => getParentNode(this) + if (associated(parent)) then + dead => replaceChild(parent, new, this) + this => new + call destroyAllNodesRecursively(dead) + endif + doneChildren = .true. + case (ENTITY_NODE) + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "adoptNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + case (DOCUMENT_NODE) + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "adoptNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + case (DOCUMENT_TYPE_NODE) + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "adoptNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + case (NOTATION_NODE) + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "adoptNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + case default + call setOwnerDocument(this, doc) + end select + + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + endif + endif + + enddo + + + + doc%docExtras%brokenNS = brokenNS +! call namespaceFixup(np) + + end function adoptNode + +function getdomConfig(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(DOMConfiguration), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getdomConfig", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getdomConfig", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c => np%docExtras%domConfig + + end function getdomConfig + +subroutine setdomConfig(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(DOMConfiguration), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setdomConfig", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setdomConfig", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np%docExtras%domConfig => c + + end subroutine setdomConfig + + + + function renameNode(arg, n, namespaceURI, qualifiedName, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: n + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: qualifiedName + type(Node), pointer :: np + + type(Node), pointer :: attNode + integer :: i + logical :: brokenNS + type(element_t), pointer :: elem + type(attribute_t), pointer :: att + type(xml_doc_state), pointer :: xds + type(URI), pointer :: URIref + + if (.not.associated(arg).or..not.associated(n)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "renameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(arg)/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "renameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.associated(getOwnerDocument(n), target=arg)) then + if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then + call throw_exception(WRONG_DOCUMENT_ERR, "renameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(qualifiedName, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "renameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkQName(qualifiedName, getXmlVersionEnum(arg))) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "renameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (prefixOfQName(qualifiedName)/="" & + .and. namespaceURI=="".and..not.arg%docExtras%brokenNS) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "renameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (namespaceURI=="http://www.w3.org/XML/1998/namespace" .neqv. & + prefixOfQName(qualifiedName)=="xml") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "renameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (namespaceURI=="http://www.w3.org/2000/xmlns/") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "renameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + URIref => parseURI(namespaceURI) + if (.not.associated(URIref)) then + if (getFoX_checks().or.FoX_INVALID_URI<200) then + call throw_exception(FoX_INVALID_URI, "renameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + call destroyURI(URIref) + +! FIXME what if this is called on a Level 1 node +! FIXME what if this is called on a read-only node +! FIXME what if this is called on an attribute whose specified=fals + select case(getNodeType(n)) + case (ELEMENT_NODE, ATTRIBUTE_NODE) + deallocate(n%nodeName) + n%nodeName => vs_str_alloc(qualifiedName) + deallocate(n%elExtras%namespaceURI) + n%elExtras%namespaceURI => vs_str_alloc(namespaceURI) + deallocate(n%elExtras%localName) + n%elExtras%localName => vs_str_alloc(localpartOfQName(qualifiedname)) + case default + if (getFoX_checks().or.NOT_SUPPORTED_ERR<200) then + call throw_exception(NOT_SUPPORTED_ERR, "renameNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + end select + + if (getNodeType(n)==ELEMENT_NODE) then + i = 0 + do while (i item(getAttributes(n), i) + if (.not.getSpecified(attNode)) then + attNode => removeAttributeNode(n, attNode) + call destroyNode(attNode) + else + i = i + 1 + endif + enddo + xds => getXds(arg) + elem => get_element(xds%element_list, qualifiedName) + if (associated(elem)) then + do i = 1, get_attlist_size(elem) + att => get_attribute_declaration(elem, i) + if (attribute_has_default(att)) then + ! Since this is a namespaced function, we create a namespaced + ! attribute. Of course, its namespaceURI remains empty + ! for the moment unless we know it ... + if (prefixOfQName(str_vs(att%name))=="xml") then + call setAttributeNS(np, & + "http://www.w3.org/XML/1998/namespace", & + str_vs(att%name), str_vs(att%default)) + elseif (str_vs(att%name)=="xmlns" & + .or. prefixOfQName(str_vs(att%name))=="xmlns") then + call setAttributeNS(np, & + "http://www.w3.org/2000/xmlns/", & + str_vs(att%name), str_vs(att%default)) + else + ! Wait for namespace fixup ... + brokenNS = arg%docExtras%brokenNS + arg%docExtras%brokenNS = .true. + call setAttributeNS(np, "", str_vs(att%name), & + str_vs(att%default)) + arg%docExtras%brokenNS = brokenNS + endif + endif + enddo + endif + endif + + np => n + + end function renameNode + + ! Internal function, not part of API + + function createNamespaceNode(arg, prefix, URI, specified, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: prefix + character(len=*), intent(in) :: URI + logical, intent(in) :: specified + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createNamespaceNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createNamespaceNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, XPATH_NAMESPACE_NODE, "#namespace", URI) + allocate(np%elExtras) + np%elExtras%prefix => vs_str_alloc(prefix) + np%elExtras%namespaceURI => vs_str_alloc(URI) + np%elExtras%specified = specified + + end function createNamespaceNode + + function createEntity(arg, name, publicId, systemId, notationName, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + character(len=*), intent(in) :: publicId + character(len=*), intent(in) :: systemId + character(len=*), intent(in) :: notationName + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createEntity", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createEntity", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, ENTITY_NODE, name, "") + allocate(np%dtdExtras) + np%dtdExtras%publicId => vs_str_alloc(publicId) + np%dtdExtras%systemId => vs_str_alloc(systemId) + np%dtdExtras%notationName => vs_str_alloc(notationName) + + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + else + np%inDocument = .true. + endif + + end function createEntity + + function createNotation(arg, name, publicId, systemId, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + character(len=*), intent(in) :: publicId + character(len=*), intent(in) :: systemId + type(Node), pointer :: np + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "createNotation", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "createNotation", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => createNode(arg, NOTATION_NODE, name, "") + allocate(np%dtdExtras) + np%dtdExtras%publicId => vs_str_alloc(publicId) + np%dtdExtras%systemId => vs_str_alloc(systemId) + + if (getGCstate(arg)) then + np%inDocument = .false. + call append(arg%docExtras%hangingnodes, np) + else + np%inDocument = .true. + endif + + end function createNotation + + function getXmlVersionEnum(arg, ex)result(n) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer :: n + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then + call throw_exception(FoX_INTERNAL_ERROR, "getXmlVersionEnum", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + n = arg%docExtras%xds%xml_version + + end function getXmlVersionEnum + + function getXds(arg, ex)result(xds) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(xml_doc_state), pointer :: xds + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then + call throw_exception(FoX_INTERNAL_ERROR, "getXds", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + xds => arg%docExtras%xds + + end function getXds + + +function getGCstate(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getGCstate", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getGCstate", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = np%docExtras%xds%building + + end function getGCstate + +subroutine setGCstate(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setGCstate", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setGCstate", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np%docExtras%xds%building = c + + end subroutine setGCstate + + +function getliveNodeLists(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getliveNodeLists", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getliveNodeLists", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = np%docExtras%liveNodeLists + + end function getliveNodeLists + +subroutine setliveNodeLists(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setliveNodeLists", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setliveNodeLists", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np%docExtras%liveNodeLists = c + + end subroutine setliveNodeLists + + + + +! function getName(docType) result(c) See m_dom_common + + function getEntities(arg, ex)result(nnp) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(NamedNodeMap), pointer :: nnp + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getEntities", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_TYPE_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getEntities", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + nnp => arg%dtdExtras%entities + end function getEntities + + function getNotations(arg, ex)result(nnp) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(NamedNodeMap), pointer :: nnp + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getNotations", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_TYPE_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getNotations", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + nnp => arg%dtdExtras%notations + end function getNotations + + +! function getPublicId(docType) result(c) See m_dom_common + + +! function getSystemId(docType) result(c) See m_dom_common + + pure function getInternalSubset_len(arg, p) result(n) + type(Node), pointer :: arg + logical, intent(in) :: p + integer :: n + + n = 0 + if (p) then + if (associated(arg%ownerDocument)) then + if (associated(arg%ownerDocument%docExtras%xds%intSubset)) then + n = size(arg%ownerDocument%docExtras%xds%intSubset) + endif + endif + endif + end function getInternalSubset_len + + function getInternalSubset(arg, ex)result(s) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getInternalSubset_len(arg, .true.)) :: s +#else + character(len=getInternalSubset_len(arg, associated(arg))) :: s +#endif + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getInternalSubset", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType/=DOCUMENT_TYPE_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getInternalSubset", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (len(s)>0) then + s = str_vs(arg%ownerDocument%docExtras%xds%intSubset) + else + s = "" + endif + end function getInternalSubset + + + + + pure function gettagName_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + if (p .and. ( & + np%nodeType==ELEMENT_NODE .or. & + .false.)) then + n = size(np%nodeName) + else + n = 0 + endif + end function gettagName_len +function gettagName(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=gettagName_len(np, .true.)) :: c +#else + character(len=gettagName_len(np, associated(np))) :: c +#endif + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "gettagName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ELEMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "gettagName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = str_vs(np%nodeName) + + end function gettagName + + + pure function getAttribute_len(arg, p, name) result(n) + type(Node), intent(in) :: arg + logical, intent(in) :: p + character(len=*), intent(in) :: name + integer :: n + + integer :: i + + n = 0 + if (.not.p) return + if (arg%nodeType/=ELEMENT_NODE) return + + do i = 1, arg%elExtras%attributes%length + if (str_vs(arg%elExtras%attributes%nodes(i)%this%nodeName)==name) then + n = getTextContent_len(arg%elExtras%attributes%nodes(i)%this, .true.) + exit + endif + enddo + + end function getAttribute_len + + function getAttribute(arg, name, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getAttribute_len(arg, .true., name)) :: c +#else + character(len=getAttribute_len(arg, associated(arg), name)) :: c +#endif + + integer :: i + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(arg) /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (len(c)>0) then + do i = 1, arg%elExtras%attributes%length + if (str_vs(arg%elExtras%attributes%nodes(i)%this%nodeName)==name) then + c = getTextContent(arg%elExtras%attributes%nodes(i)%this) + exit + endif + enddo + else + c = "" + endif + + end function getAttribute + + + subroutine setAttribute(arg, name, value, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + character(len=*), intent(in) :: value + + type(Node), pointer :: nn, dummy + logical :: quickFix + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodetype(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(name, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "setAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkChars(value, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then + call throw_exception(FoX_INVALID_CHARACTER, "setAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + quickFix = getGCstate(getOwnerDocument(arg)) & + .and. arg%inDocument + + if (quickFix) call setGCstate(getOwnerDocument(arg), .false.) + ! then the created attribute is going straight into the document, + ! so dont faff with hanging-node lists. + + nn => createAttribute(arg%ownerDocument, name) + call setValue(nn, value) + dummy => setNamedItem(getAttributes(arg), nn) + if (associated(dummy)) then + if (getGCstate(getOwnerDocument(arg)).and..not.dummy%inDocument) & + call putNodesInDocument(getOwnerDocument(arg), dummy) + ! ... so that dummy & children are removed from hangingNodes list. + call destroyAllNodesRecursively(dummy) + endif + + if (quickFix) call setGCstate(getOwnerDocument(arg), .true.) + + end subroutine setAttribute + + + subroutine removeAttribute(arg, name, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + type(DOMException) :: ex2 + type(Node), pointer :: dummy + integer :: e + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "removeAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodetype(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "removeAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "removeAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%inDocument) & + call setGCstate(getOwnerDocument(arg), .false.) + + dummy => removeNamedItem(getAttributes(arg), name, ex2) + ! removeNamedItem took care of any default attributes + if (inException(ex2)) then + e = getExceptionCode(ex2) + if (e/=NOT_FOUND_ERR) then + if (getFoX_checks().or.e<200) then + call throw_exception(e, "removeAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + else + if (.not.arg%inDocument) then + ! dummy was not in the doc, so was on hangingNode list. + ! To remove it from the list: + call putNodesInDocument(arg%ownerDocument, dummy) + endif + call destroyAllNodesRecursively(dummy) + endif + + if (arg%inDocument) & + call setGCstate(arg%ownerDocument, .true.) + + end subroutine removeAttribute + + + function getAttributeNode(arg, name, ex)result(attr) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + type(Node), pointer :: attr + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + attr => getNamedItem(getAttributes(arg), name) + + end function getAttributeNode + + + function setAttributeNode(arg, newattr, ex)result(attr) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: newattr + type(Node), pointer :: attr + type(Node), pointer :: dummy + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.associated(arg%ownerDocument, newattr%ownerDocument)) then + if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then + call throw_exception(WRONG_DOCUMENT_ERR, "setAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (associated(getOwnerElement(newattr), arg)) then + attr => newattr + return + ! Nothing to do, this attribute is already in this element + elseif (associated(getOwnerElement(newattr))) then + if (getFoX_checks().or.INUSE_ATTRIBUTE_ERR<200) then + call throw_exception(INUSE_ATTRIBUTE_ERR, "setAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + ! this checks if attribute exists already + ! It also does any adding/removing of hangingnodes + ! and sets ownerElement appropriately + dummy => setNamedItem(getAttributes(arg), newattr, ex) + attr => dummy + + end function setAttributeNode + + + function removeAttributeNode(arg, oldattr, ex)result(attr) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: oldattr + type(Node), pointer :: attr + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "removeAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "removeAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.associated(arg, getOwnerElement(oldattr))) then + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "removeAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + attr => removeNamedItem(getAttributes(arg), & + getNodeName(oldattr), ex) + + end function removeAttributeNode + + +! function getElementsByTagName - see m_dom_document + + + pure function getAttributesNS_len(arg, p, localname, namespaceURI) result(n) + type(Node), intent(in) :: arg + logical, intent(in) :: p + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: namespaceURI + integer :: n + + integer :: i + + n = 0 + if (.not.p) return + if (arg%nodeType/=ELEMENT_NODE) return + + do i = 1, arg%elExtras%attributes%length + if ((str_vs(arg%elExtras%attributes%nodes(i)%this%elExtras%localName)==localname & + .and. str_vs(arg%elExtras%attributes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) & + .or. (namespaceURI=="".and.str_vs(arg%elExtras%attributes%nodes(i)%this%nodeName)==localname)) then + n = getTextContent_len(arg%elExtras%attributes%nodes(i)%this, .true.) + exit + endif + enddo + + end function getAttributesNS_len + + function getAttributeNS(arg, namespaceURI, localName, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: localName +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getAttributesNS_len(arg, .true., localname, namespaceURI)) :: c +#else + character(len=getAttributesNS_len(arg, associated(arg), localname, namespaceURI)) :: c +#endif + + integer :: i + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (len(c)>0) then + do i = 1, arg%elExtras%attributes%length + if ((str_vs(arg%elExtras%attributes%nodes(i)%this%elExtras%localName)==localname & + .and. str_vs(arg%elExtras%attributes%nodes(i)%this%elExtras%namespaceURI)==namespaceURI) & + .or. (namespaceURI=="".and.str_vs(arg%elExtras%attributes%nodes(i)%this%nodeName)==localname)) then + c = getTextContent(arg%elExtras%attributes%nodes(i)%this) + exit + endif + enddo + else + c = "" + endif + + end function getAttributeNS + + + subroutine setAttributeNS(arg, namespaceURI, qualifiedname, value, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: qualifiedName + character(len=*), intent(in) :: value + + type(Node), pointer :: nn, dummy + logical :: quickfix + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.checkName(qualifiedname, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.INVALID_CHARACTER_ERR<200) then + call throw_exception(INVALID_CHARACTER_ERR, "setAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (.not.arg%ownerDocument%docExtras%brokenNS) then + if (.not.checkQName(qualifiedname, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "setAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (prefixOfQName(qualifiedName)/="" & + .and. namespaceURI=="") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "setAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (prefixOfQName(qualifiedName)=="xml" .neqv. & + namespaceURI=="http://www.w3.org/XML/1998/namespace") then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "setAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (namespaceURI=="http://www.w3.org/2000/xmlns/" .neqv. & + (qualifiedName=="xmlns" .or. prefixOfQName(qualifiedName)=="xmlns")) then + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "setAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + endif + +! FIXME what if namespace is undeclared? Throw an error *only* if FoX_errors is on, otherwise its taken care of by namespace fixup on serialization + + quickFix = getGCstate(getOwnerDocument(arg)) & + .and. arg%inDocument + + if (quickFix) call setGCstate(getOwnerDocument(arg), .false.) + ! then the created attribute is going straight into the document, + ! so dont faff with hanging-node lists. + + nn => createAttributeNS(arg%ownerDocument, namespaceURI, qualifiedname) + call setValue(nn, value) + dummy => setNamedItemNS(getAttributes(arg), nn) + + if (associated(dummy)) then + if (getGCstate(getOwnerDocument(arg)).and..not.dummy%inDocument) & + call putNodesInDocument(getOwnerDocument(arg), dummy) + ! ... so that dummy & children are removed from hangingNodes list. + call destroyAllNodesRecursively(dummy) + endif + + if (quickFix) call setGCstate(getOwnerDocument(arg), .true.) + + end subroutine setAttributeNS + + + subroutine removeAttributeNS(arg, namespaceURI, localName, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: localName + + type(DOMException) :: ex2 + type(Node), pointer :: dummy + integer :: e + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "removeAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "removeAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "removeAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%inDocument) & + call setGCstate(getOwnerDocument(arg), .false.) + ! So we dont add the removed nodes to the hanging node list + + dummy => removeNamedItemNS(getAttributes(arg), namespaceURI, localName, ex2) + ! removeNamedItemNS took care of any default attributes + if (inException(ex2)) then + e = getExceptionCode(ex2) + if (e/=NOT_FOUND_ERR) then + if (getFoX_checks().or.e<200) then + call throw_exception(e, "removeAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + else + if (.not.arg%inDocument) then + ! dummy was not in the doc, so was already on hangingNode list. + ! To remove it from the list: + call putNodesInDocument(arg%ownerDocument, dummy) + endif + call destroyAllNodesRecursively(dummy) + endif + + if (arg%inDocument) & + call setGCstate(arg%ownerDocument, .true.) + + end subroutine removeAttributeNS + + + function getAttributeNodeNS(arg, namespaceURI, localName, ex)result(attr) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: localName + type(Node), pointer :: attr + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getAttributeNodeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getAttributeNodeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + attr => null() ! as per specs, if not found + attr => getNamedItemNS(getAttributes(arg), namespaceURI, localname) + end function getAttributeNodeNS + + + function setAttributeNodeNS(arg, newattr, ex)result(attr) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: newattr + type(Node), pointer :: attr + type(Node), pointer :: dummy + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setAttributeNodeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setAttributeNodeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.associated(arg%ownerDocument, newattr%ownerDocument)) then + if (getFoX_checks().or.WRONG_DOCUMENT_ERR<200) then + call throw_exception(WRONG_DOCUMENT_ERR, "setAttributeNodeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setAttributeNodeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (associated(getOwnerElement(newattr), arg)) then + attr => newattr + return + ! Nothing to do, this attribute is already in this element + elseif (associated(getOwnerElement(newattr))) then + if (getFoX_checks().or.INUSE_ATTRIBUTE_ERR<200) then + call throw_exception(INUSE_ATTRIBUTE_ERR, "setAttributeNodeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + ! this checks if attribute exists already + ! It also does any adding/removing of hangingnodes + ! and sets ownerElement appropriately + dummy => setNamedItemNS(getAttributes(arg), newattr, ex) + attr => dummy + + end function setAttributeNodeNS + + + function removeAttributeNodeNS(arg, oldattr, ex)result(attr) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: oldattr + type(Node), pointer :: attr + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "removeAttributeNodeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "removeAttributeNodeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.associated(arg, getOwnerElement(oldattr))) then + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "removeAttributeNodeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + attr => removeNamedItemNS(getAttributes(arg), & + getNamespaceURI(oldattr), getLocalName(oldattr), ex) + + end function removeAttributeNodeNS + + +! function getElementsByTagNameNS - see m_dom_document + + + function hasAttribute(arg, name, ex)result(p) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + logical :: p + + integer :: i + type(Node), pointer :: attr + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "hasAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "hasAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + p = .false. + do i = 0, getLength(getAttributes(arg)) - 1 + attr => item(getAttributes(arg), i) + if (getNodeName(attr)==name) then + p = .true. + exit + endif + enddo + + end function hasAttribute + + + function hasAttributeNS(arg, namespaceURI, localName, ex)result(p) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: localName + logical :: p + + integer :: i + type(Node), pointer :: attr + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "hasAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (arg%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "hasAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + p = .false. + do i = 0, getLength(getAttributes(arg))-1 + attr => item(getAttributes(arg), i) + if (getNamespaceURI(attr)==namespaceURI & + .and. getLocalName(attr)==localName) then + p = .true. + exit + endif + enddo + + end function hasAttributeNS + + subroutine setIdAttribute(arg, name, isId, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + logical, intent(in) :: isId + + type(Node), pointer :: np + + if (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setIdAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => getAttributeNode(arg, name) + if (associated(np)) then + call setIsId(np, isId) + else + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "setIdAttribute", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + end subroutine setIdAttribute + + subroutine setIdAttributeNS(arg, namespaceURI, localname, isId, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: localName + logical, intent(in) :: isId + + type(Node), pointer :: np + + if (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setIdAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np => getAttributeNodeNS(arg, namespaceURI, localname) + if (associated(np)) then + call setIsId(np, isId) + else + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "setIdAttributeNS", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + end subroutine setIdAttributeNS + + subroutine setIdAttributeNode(arg, idAttr, isId, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + type(Node), pointer :: idAttr + logical, intent(in) :: isId + + if (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setIdAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (.not.associated(arg, getOwnerElement(idAttr))) then + if (getFoX_checks().or.NOT_FOUND_ERR<200) then + call throw_exception(NOT_FOUND_ERR, "setIdAttributeNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + call setIsId(idAttr, isId) + + end subroutine setIdAttributeNode + + + + ! function getName(attribute) result(c) See m_dom_common + +! NB All functions manipulating attributes play with the nodelist +! directly rather than through helper functions. +! This is so that getValue_length can be pure, and the nodeList +! can be explicitly kept up to dat. + +function getspecified(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getspecified", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ATTRIBUTE_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getspecified", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = np%elExtras%specified + + end function getspecified + + +subroutine setspecified(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setspecified", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ATTRIBUTE_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setspecified", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np%elExtras%specified = c + + end subroutine setspecified + + +function getisId_DOM(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getisId_DOM", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ATTRIBUTE_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getisId_DOM", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = np%elExtras%isId + + end function getisId_DOM + + +subroutine setisId_DOM(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setisId_DOM", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ATTRIBUTE_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setisId_DOM", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np%elExtras%isId = c + + end subroutine setisId_DOM + + +function getownerElement(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(Node), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getownerElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ATTRIBUTE_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getownerElement", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c => np%elExtras%ownerElement + + end function getownerElement + + + function getValue_DOM(arg, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getTextContent_len(arg, .true.)) :: c +#else + character(len=getTextContent_len(arg, associated(arg))) :: c +#endif + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getValue_DOM", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(arg)/=ATTRIBUTE_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getValue_DOM", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = getTextContent(arg, ex) + + end function getValue_DOM + + subroutine setValue(arg, value, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: value + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setValue", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(arg)/=ATTRIBUTE_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setValue", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + call setTextContent(arg, value, ex) + + end subroutine setValue + + + + pure function isCharData(nodeType) result(p) + integer, intent(in) :: nodeType + logical :: p + + p = (nodeType == TEXT_NODE .or. & + nodeType == COMMENT_NODE .or. & + nodeType == CDATA_SECTION_NODE) + end function isCharData + + + function getLength_characterdata(arg, ex)result(n) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer :: n + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getLength_characterdata", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.isCharData(arg%nodeType)) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getLength_characterdata", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + n = size(arg%nodeValue) + + end function getLength_characterdata + + + function subStringData(arg, offset, count, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer, intent(in) :: offset + integer, intent(in) :: count + character(len=count) :: c + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "subStringData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.isCharData(arg%nodeType)) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "subStringData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (offset<0.or.offset>size(arg%nodeValue).or.count<0) then + if (getFoX_checks().or.INDEX_SIZE_ERR<200) then + call throw_exception(INDEX_SIZE_ERR, "subStringData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (offset+count>size(arg%nodeValue)) then + c = str_vs(arg%nodeValue(offset+1:)) + else + c = str_vs(arg%nodeValue(offset+1:offset+count)) + endif + + end function subStringData + + + subroutine appendData(arg, data, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: data + + character, pointer :: tmp(:) + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "appendData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.isCharData(arg%nodeType)) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "appendData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "appendData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.checkChars(data, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then + call throw_exception(FoX_INVALID_CHARACTER, "appendData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + tmp => arg%nodeValue + arg%nodeValue => vs_str_alloc(str_vs(tmp)//data) + deallocate(tmp) + + ! We have to do these checks *after* appending data in case offending string + ! spans old & new data + if (arg%nodeType==COMMENT_NODE .and. index(str_vs(arg%nodeValue),"--")>0) then + if (getFoX_checks().or.FoX_INVALID_COMMENT<200) then + call throw_exception(FoX_INVALID_COMMENT, "appendData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%nodeType==CDATA_SECTION_NODE .and. index(str_vs(arg%nodeValue), "]]>")>0) then + if (getFoX_checks().or.FoX_INVALID_CDATA_SECTION<200) then + call throw_exception(FoX_INVALID_CDATA_SECTION, "appendData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + ! And propagate length upwards ... + if (getNodeType(arg)/=COMMENT_NODE) & + call updateTextContentLength(arg, len(data)) + + end subroutine appendData + + + subroutine insertData(arg, offset, data, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer, intent(in) :: offset + character(len=*), intent(in) :: data + + character, pointer :: tmp(:) + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "insertData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.isCharData(arg%nodeType)) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "insertData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "insertData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (offset<0.or.offset>size(arg%nodeValue)) then + if (getFoX_checks().or.INDEX_SIZE_ERR<200) then + call throw_exception(INDEX_SIZE_ERR, "insertData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.checkChars(data, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then + call throw_exception(FoX_INVALID_CHARACTER, "insertData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + tmp => arg%nodeValue + arg%nodeValue => vs_str_alloc(str_vs(tmp(:offset))//data//str_vs(tmp(offset+1:))) + deallocate(tmp) + + ! We have to do these checks *after* appending data in case offending string + ! spans old & new data + if (arg%nodeType==COMMENT_NODE .and. index(str_vs(arg%nodeValue),"--")>0) then + if (getFoX_checks().or.FoX_INVALID_COMMENT<200) then + call throw_exception(FoX_INVALID_COMMENT, "insertData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%nodeType==CDATA_SECTION_NODE .and. index(str_vs(arg%nodeValue), "]]>")>0) then + if (getFoX_checks().or.FoX_INVALID_CDATA_SECTION<200) then + call throw_exception(FoX_INVALID_CDATA_SECTION, "insertData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + ! And propagate length upwards ... + if (getNodeType(arg)/=COMMENT_NODE) & + call updateTextContentLength(arg, len(data)) + + end subroutine insertData + + + subroutine deleteData(arg, offset, count, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer, intent(in) :: offset + integer, intent(in) :: count + + character, pointer :: tmp(:) + integer :: n + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "deleteData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.isCharData(arg%nodeType)) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "deleteData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "deleteData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (offset<0.or.offset>size(arg%nodeValue).or.count<0) then + if (getFoX_checks().or.INDEX_SIZE_ERR<200) then + call throw_exception(INDEX_SIZE_ERR, "deleteData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (offset+count>size(arg%nodeValue)) then + n = size(arg%nodeValue)-offset + else + n = count + endif + + tmp => arg%nodeValue + arg%nodeValue => vs_str_alloc(str_vs(tmp(:offset))//str_vs(tmp(offset+count+1:))) + deallocate(tmp) + + ! And propagate length upwards ... + if (getNodeType(arg)/=COMMENT_NODE) & + call updateTextContentLength(arg, -n) + + end subroutine deleteData + + + subroutine replaceData(arg, offset, count, data, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer, intent(in) :: offset + integer, intent(in) :: count + character(len=*), intent(in) :: data + + character, pointer :: tmp(:) + integer :: n + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "replaceData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.isCharData(arg%nodeType)) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "replaceData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "replaceData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (offset<0.or.offset>size(arg%nodeValue).or.count<0) then + if (getFoX_checks().or.INDEX_SIZE_ERR<200) then + call throw_exception(INDEX_SIZE_ERR, "replaceData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.checkChars(data, getXmlVersionEnum(getOwnerDocument(arg)))) then + if (getFoX_checks().or.FoX_INVALID_CHARACTER<200) then + call throw_exception(FoX_INVALID_CHARACTER, "replaceData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (offset+count>size(arg%nodeValue)) then + n = len(data)-(size(arg%nodeValue)-offset) + else + n = len(data)-count + endif + + tmp => arg%nodeValue + if (offset+count <= size(arg%nodeValue)) then + arg%nodeValue => vs_str_alloc(str_vs(tmp(:offset))//data//str_vs(tmp(offset+count+1:))) + else + arg%nodeValue => vs_str_alloc(str_vs(tmp(:offset))//data) + endif + deallocate(tmp) + + ! We have to do these checks *after* appending data in case offending string + ! spans old & new data + if (arg%nodeType==COMMENT_NODE .and. index(str_vs(arg%nodeValue),"--")>0) then + if (getFoX_checks().or.FoX_INVALID_COMMENT<200) then + call throw_exception(FoX_INVALID_COMMENT, "replaceData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%nodeType==CDATA_SECTION_NODE .and. index(str_vs(arg%nodeValue), "]]>")>0) then + if (getFoX_checks().or.FoX_INVALID_CDATA_SECTION<200) then + call throw_exception(FoX_INVALID_CDATA_SECTION, "replaceData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + ! And propagate length upwards ... + if (getNodeType(arg)/=COMMENT_NODE) & + call updateTextContentLength(arg, n) + + end subroutine replaceData + + + + + pure function getnotationName_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + if (p .and. ( & + np%nodeType==ENTITY_NODE .or. & + .false.)) then + n = size(np%dtdExtras%notationName) + else + n = 0 + endif + end function getnotationName_len +function getnotationName(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getnotationName_len(np, .true.)) :: c +#else + character(len=getnotationName_len(np, associated(np))) :: c +#endif + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getnotationName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ENTITY_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getnotationName", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = str_vs(np%dtdExtras%notationName) + + end function getnotationName + + +!Internally-used getters/setters: + + function getillFormed(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getillFormed", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ENTITY_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getillFormed", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = np%dtdExtras%illFormed + + end function getillFormed + + subroutine setillFormed(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setillFormed", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ENTITY_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setillFormed", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + np%dtdExtras%illFormed = c + + end subroutine setillFormed + + + + pure function getstringValue_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + if (p .and. ( & + np%nodeType==ENTITY_NODE .or. & + .false.)) then + n = size(np%nodeValue) + else + n = 0 + endif + end function getstringValue_len +function getstringValue(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getstringValue_len(np, .true.)) :: c +#else + character(len=getstringValue_len(np, associated(np))) :: c +#endif + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getstringValue", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ENTITY_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getstringValue", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = str_vs(np%nodeValue) + + end function getstringValue + + subroutine setstringValue(np, c, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + character(len=*) :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setstringValue", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ENTITY_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setstringValue", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (associated(np%nodeValue)) deallocate(np%nodeValue) + np%nodeValue => vs_str_alloc(c) + + end subroutine setstringValue + + + + + + pure function getTarget_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + if (p .and. ( & + np%nodeType==PROCESSING_INSTRUCTION_NODE .or. & + .false.)) then + n = size(np%nodename) + else + n = 0 + endif + end function getTarget_len +function getTarget(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getTarget_len(np, .true.)) :: c +#else + character(len=getTarget_len(np, associated(np))) :: c +#endif + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getTarget", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=PROCESSING_INSTRUCTION_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getTarget", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = str_vs(np%nodename) + + end function getTarget + + + + + function splitText(arg, offset, ex)result(np) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer, intent(in) :: offset + + type(Node), pointer :: np + + character, pointer :: tmp(:) + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "splitText", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (.not.(arg%nodeType==TEXT_NODE.or.arg%nodeType==CDATA_SECTION_NODE)) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "splitText", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "splitText", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (offset<0 .or. offset>size(arg%nodeValue)) then + if (getFoX_checks().or.INDEX_SIZE_ERR<200) then + call throw_exception(INDEX_SIZE_ERR, "splitText", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + tmp => arg%nodeValue + if (arg%nodeType==TEXT_NODE) then + np => createTextNode(arg%ownerDocument, str_vs(tmp(offset+1:))) + elseif (arg%nodeType==CDATA_SECTION_NODE) then + np => createCdataSection(arg%ownerDocument, str_vs(tmp(offset+1:))) + endif + arg%nodeValue => vs_str_alloc(str_vs(tmp(:offset))) + deallocate(tmp) + if (associated(arg%parentNode)) then + if (associated(arg%nextSibling)) then + np => insertBefore(arg%parentNode, np, arg%nextSibling) + else + np => appendChild(arg%parentNode, np) + endif + endif + + end function splitText + +function getisElementContentWhitespace(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getisElementContentWhitespace", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=TEXT_NODE .and. & +getNodeType(np)/=CDATA_SECTION_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getisElementContentWhitespace", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = np%ignorableWhitespace + + end function getisElementContentWhitespace + + + subroutine setIsElementContentWhitespace(np, isElementContentWhitespace, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + logical :: isElementContentWhitespace + + integer :: n + + np%ignorableWhitespace = isElementContentWhitespace + + if (isElementContentWhitespace) then + n = -np%textContentLength + else + n = size(np%nodeValue) + endif + + call updateTextContentLength(np, n) + end subroutine setIsElementContentWhitespace + +! function getWholeText +! function replaceWholeText + + + + + pure function getdata_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + if (p .and. ( & + np%nodeType==TEXT_NODE .or. & + np%nodeType==COMMENT_NODE .or. & + np%nodeType==CDATA_SECTION_NODE .or. & + np%nodeType==PROCESSING_INSTRUCTION_NODE .or. & + .false.)) then + n = size(np%nodeValue) + else + n = 0 + endif + end function getdata_len +function getdata(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getdata_len(np, .true.)) :: c +#else + character(len=getdata_len(np, associated(np))) :: c +#endif + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getdata", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=TEXT_NODE .and. & +getNodeType(np)/=COMMENT_NODE .and. & +getNodeType(np)/=CDATA_SECTION_NODE .and. & +getNodeType(np)/=PROCESSING_INSTRUCTION_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getdata", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = str_vs(np%nodeValue) + + end function getdata + + + subroutine setData(arg, data, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*) :: data + + integer :: n + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "setData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + +!NB special case in order to check readonly correctly + if (arg%nodeType==TEXT_NODE .or. & + arg%nodeType==COMMENT_NODE .or. & + arg%nodeType==CDATA_SECTION_NODE .or. & + arg%nodeType==PROCESSING_INSTRUCTION_NODE) then + if (arg%readonly) then + if (getFoX_checks().or.NO_MODIFICATION_ALLOWED_ERR<200) then + call throw_exception(NO_MODIFICATION_ALLOWED_ERR, "setData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + else + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "setData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + select case (arg%nodeType) + case (CDATA_SECTION_NODE) + if (index(data,"]]>")>0) then + if (getFoX_checks().or.FoX_INVALID_CDATA_SECTION<200) then + call throw_exception(FoX_INVALID_CDATA_SECTION, "setData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (COMMENT_NODE) + if (index(data,"--")>0) then + if (getFoX_checks().or.FoX_INVALID_COMMENT<200) then + call throw_exception(FoX_INVALID_COMMENT, "setData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + case (PROCESSING_INSTRUCTION_NODE) + if (index(data,"?>")>0) then + if (getFoX_checks().or.FoX_INVALID_PI_DATA<200) then + call throw_exception(FoX_INVALID_PI_DATA, "setData", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + end select + + deallocate(arg%nodeValue) + arg%nodeValue => vs_str_alloc(data) + + if (arg%nodeType==TEXT_NODE .or. & + arg%nodeType==CDATA_SECTION_NODE) then + n = len(data) - arg%textContentLength + call updateTextContentLength(arg, n) + endif + + end subroutine setData + + + pure function getname_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + if (p .and. ( & + np%nodeType==DOCUMENT_TYPE_NODE .or. & + np%nodeType==ATTRIBUTE_NODE .or. & + .false.)) then + n = size(np%nodeName) + else + n = 0 + endif + end function getname_len +function getname(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getname_len(np, .true.)) :: c +#else + character(len=getname_len(np, associated(np))) :: c +#endif + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getname", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_TYPE_NODE .and. & +getNodeType(np)/=ATTRIBUTE_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getname", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = str_vs(np%nodeName) + + end function getname + + + + pure function getpublicId_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + if (p .and. ( & + np%nodeType==DOCUMENT_TYPE_NODE .or. & + np%nodeType==NOTATION_NODE .or. & + np%nodeType==ENTITY_NODE .or. & + .false.)) then + n = size(np%dtdExtras%publicId) + else + n = 0 + endif + end function getpublicId_len +function getpublicId(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getpublicId_len(np, .true.)) :: c +#else + character(len=getpublicId_len(np, associated(np))) :: c +#endif + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getpublicId", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_TYPE_NODE .and. & +getNodeType(np)/=NOTATION_NODE .and. & +getNodeType(np)/=ENTITY_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getpublicId", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = str_vs(np%dtdExtras%publicId) + + end function getpublicId + + + + pure function getsystemId_len(np, p) result(n) + type(Node), intent(in) :: np + logical, intent(in) :: p + integer :: n + + if (p .and. ( & + np%nodeType==DOCUMENT_TYPE_NODE .or. & + np%nodeType==NOTATION_NODE .or. & + np%nodeType==ENTITY_NODE .or. & + .false.)) then + n = size(np%dtdExtras%systemId) + else + n = 0 + endif + end function getsystemId_len +function getsystemId(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np +#ifdef RESTRICTED_ASSOCIATED_BUG + character(len=getsystemId_len(np, .true.)) :: c +#else + character(len=getsystemId_len(np, associated(np))) :: c +#endif + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getsystemId", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=DOCUMENT_TYPE_NODE .and. & +getNodeType(np)/=NOTATION_NODE .and. & +getNodeType(np)/=ENTITY_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getsystemId", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c = str_vs(np%dtdExtras%systemId) + + end function getsystemId + + + + + function getnamespaceNodes(np, ex)result(c) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + type(NodeList), pointer :: c + + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "getnamespaceNodes", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(np)/=ELEMENT_NODE .and. & + .true.) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "getnamespaceNodes", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + c => np%elExtras%namespaceNodes + + end function getnamespaceNodes + + + subroutine appendNSNode(np, prefix, namespaceURI, specified, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: np + character(len=*), intent(in) :: prefix + character(len=*), intent(in) :: namespaceURI + logical, intent(in) :: specified + + type(Node), pointer :: ns + type(NodeList), pointer :: nsnodes + integer :: i + logical :: quickFix + + if (.not.associated(np)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "appendNSNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (np%nodeType /= ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "appendNSNode", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + ! We never put namespace nodes in the hanging nodes + ! list since they can never be separated from their + ! parent element node, so will always be destroyed alongside it. + quickFix = getGCState(getOwnerDocument(np)) + call setGCState(getOwnerDocument(np), .false.) + nsnodes => getNamespaceNodes(np) + ! If we already have this prefix registered in the list, then remove it + do i = 0, getLength(nsNodes)-1 + ns => item(nsNodes, i) +! Intel 8.1 & 9.1 insist on separate variable here and just below + if (getPrefix(ns)==prefix) then + call setNamespaceURI(ns, namespaceURI) + exit + endif + enddo + if (i==getLength(nsNodes)) then + ns => createNamespaceNode(getOwnerDocument(np), & + prefix, namespaceURI, specified) + call append_nl(nsNodes, ns) + endif + call setGCState(getOwnerDocument(np), quickFix) + + end subroutine appendNSNode + + subroutine normalizeDocument(doc, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: doc + + type(Node), pointer :: this, treeroot, dummy, new, old, nsp + type(DOMConfiguration), pointer :: dc + logical :: doneAttributes, doneChildren + integer :: i_tree, i_children + + type(Node), pointer :: parent, attr + type(NamedNodeMap), pointer :: attrs + type(NodeList), pointer :: nsNodes, nsNodesParent + integer :: i, nsIndex + logical :: merged, ns + + if (.not.associated(doc)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "normalizeDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (getNodeType(doc)/=DOCUMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "normalizeDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + dc => getDomConfig(doc) + ns = getParameter(dc, "namespaces") + treeroot => doc + + call setGCstate(doc, .false.) + ! switch off the memory management, we are going + ! to destroy all nodes we remove from the tree + ! immediately. + + ! exception object is *not* passed through in any + ! of the DOM calls below. This is because all of + ! these should succeed - if they dont then there + ! is a problem so we need to terminate immediately + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + + if (.not.getReadonly(this)) then + select case (getNodeType(this)) + case (ELEMENT_NODE) + if (ns) then + + ! Clear all current namespace nodes: + nsnodes => getNamespaceNodes(this) + do i = 1, getLength(nsNodes) + call destroyNode(nsNodes%nodes(i)%this) + enddo + deallocate(nsNodes%nodes) + + parent => getParentNode(this) + do while (associated(parent)) + ! Go up (through perhaps multiple entref nodes) + if (getNodeType(parent)==ELEMENT_NODE) exit + parent => getParentNode(parent) + enddo + ! Inherit from parent (or not ...) + if (associated(parent)) then + nsNodesParent => getNamespaceNodes(parent) + allocate(nsNodes%nodes(getLength(nsNodesParent))) + nsNodes%length = getLength(nsNodesParent) + do i = 0, getLength(nsNodes) - 1 + ! separate variable for intel + nsp => item(nsNodesParent, i) + nsNodes%nodes(i+1)%this => & + createNamespaceNode(getOwnerDocument(this), & + getPrefix(nsp), getNamespaceURI(nsp), & + specified=.false.) + enddo + else + allocate(nsNodes%nodes(0)) + nsNodes%length = 0 + endif + + ! Now check for broken NS declarations, and add namespace + ! nodes for all non-broken declarations + attrs => getAttributes(this) + do i = 0, getLength(attrs)-1 + attr => item(attrs, i) + if ((getLocalName(attr)=="xmlns" & + .or.getPrefix(attr)=="xmlns") & + .and.getNamespaceURI(attr)/="http://www.w3.org/2000/xmlns/") then + ! This can only I think happen if we bugger about with setPrefix ... + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "normalizeDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (getNamespaceURI(attr)=="http://www.w3.org/2000/xmlns/") then + if (getLocalName(attr)=="xmlns") then + call appendNSNode(this, "", getValue(attr), specified=.true.) + else + call appendNSNode(this, getLocalName(attr), & + getValue(attr), specified=.true.) + endif + endif + enddo + + + if (getNamespaceURI(this)/="") then + ! Is the nsURI of this node bound to its prefix? + ! This will automatically do any necessary replacements ... + if (getPrefix(this)=="") then + if (.not.isDefaultNamespace(this, getNamespaceURI(this))) then + ! We are dealing with the default prefix + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns", getNamespaceURI(this)) + call appendNSNode(this, "", getNamespaceURI(this), specified=.true.) + endif + elseif (lookupNamespaceURI(this, getPrefix(this))/=getNamespaceURI(this)) then + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns:"//getPrefix(this), getNamespaceURI(this)) + call appendNSNode(this, getPrefix(this), getNamespaceURI(this), specified=.true.) + endif + else + ! No (or empty) namespace URI ... + if (getLocalName(this)=="") then + ! DOM level 1 node ... report error + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "normalizeDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + else + ! We must declare the elements prefix to have an empty nsURI + if (lookupNamespaceURI(this, getPrefix(this))/="") then + if (getPrefix(this)=="") then + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns", "") + else + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns:"//getPrefix(this), "") + endif + ! and add a namespace node for the empty nsURI + call appendNSNode(this, getPrefix(this), "", specified=.true.) + endif + endif + endif + + do i = 0, getLength(attrs)-1 + ! This loops over the number of attrs present initially, so any we + ! add within this loop will not get checked - but they will only + ! be namespace declarations about which we dont care anyway. + attr => item(attrs, i) + if (getNamespaceURI(attr)=="http://www.w3.org/2000/xmlns/") then + cycle ! We already worried about it above. + elseif (getNamespaceURI(attr)=="http://www.w3.org/XML/1998/namespace") then + cycle ! We dont have to declare these + elseif (getNamespaceURI(attr)/="") then + ! This is a namespaced attribute + if (getPrefix(attr)=="" & + .or. lookupNamespaceURI(this, getPrefix(attr))/=getNamespaceURI(attr)) then + ! It has an inappropriate prefix + if (lookupPrefix(this, getNamespaceURI(attr))/="") then + ! then an appropriate prefix exists, use it. + call setPrefix(attr, lookupPrefix(this, getNamespaceURI(attr))) + ! FIXME should be "most local" prefix. Make sure lookupPrefix does that. + else + ! No suitable prefix exists, declare one. + if (getPrefix(attr)/="") then + ! Then the current prefix is not in use, its just undeclared. + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns:"//getPrefix(attr), getNamespaceURI(attr)) + call appendNSNode(this, getPrefix(attr), getNamespaceURI(attr), specified=.true.) + else + ! This node has no prefix, but needs one. Make it up. + nsIndex = 1 + do while (lookupNamespaceURI(this, "NS"//nsIndex)/="") + ! FIXME this will exit if the namespace is undeclared *or* if it is declared to be empty. + nsIndex = nsIndex+1 + enddo + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns:NS"//nsIndex, getNamespaceURI(attr)) + ! and create namespace node + call appendNSNode(this, "NS"//nsIndex, getNamespaceURI(attr), specified=.true.) + call setPrefix(attr, "NS"//nsIndex) + endif + endif + endif + else + ! attribute has no namespace URI + if (getLocalName(this)=="") then + ! DOM level 1 node ... report error + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "normalizeDocument", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + ! otherwise no problem + endif + enddo + + endif + + case (ATTRIBUTE_NODE) + if (getParameter(dc, "entities")) then + ! we dont care about any attribute children, + ! we arent going to do anything + doneChildren = .true. + endif + + case (TEXT_NODE) + ! we may need to reset "this" later on ... + old => getPreviousSibling(this) + if (.not.associated(old)) old => getParentNode(this) + merged = .false. + if (getIsElementContentWhitespace(this) & + .and..not.getParameter(dc, "element-content-whitespace")) then + dummy => removeChild(getParentNode(this), this) + call destroy(dummy) + this => old + merged = .true. + endif + if (.not.merged) then + ! We didnt just remove this node. + ! Do we need to normalize? + dummy => getPreviousSibling(this) + if (associated(dummy)) then + if (getNodeType(dummy)==TEXT_NODE) then + call appendData(dummy, getData(this)) + parent => getParentNode(this) + dummy => removeChild(parent, this) + call destroy(dummy) + this => old + endif + endif + endif + + case (CDATA_SECTION_NODE) + if (.not.getParameter(dc, "cdata-sections")) then + ! we may need to reset "this" later on ... + old => getPreviousSibling(this) + if (.not.associated(old)) old => getParentNode(this) + merged = .false. + dummy => getPreviousSibling(this) + if (associated(dummy)) then + if (getNodeType(dummy)==TEXT_NODE) then + ! append the data to the previous node & chuck away this node + call appendData(dummy, getData(this)) + dummy => removeChild(getParentNode(this), this) + call destroy(dummy) + this => old + merged =.true. + endif + endif + if (.not.merged) then + ! we didnt merge it so just convert this to a text node + new => createTextNode(doc, getData(this)) + dummy => replaceChild(getParentNode(this), new, this) + call destroy(dummy) + this => new + endif + elseif (.not.getParameter(dc, "split-cdata-sections")) then + ! Actually, on re-reading DOM 3, this is a ridiculous + ! option. Ignoring for now. + endif + + case (ENTITY_REFERENCE_NODE) + if (.not.getParameter(dc, "entities")) then + if (associated(getFirstChild(this))) then + !If this node is not representing an unexpanded entity + ! we will need to reset "this" later on ... + old => getPreviousSibling(this) + if (.not.associated(old)) old => getParentNode(this) + ! take each child, and insert it immediately before the current node + do i_children = 0, getLength(getChildNodes(this))-1 + dummy => insertBefore(getParentNode(this), getFirstChild(this), this) + enddo + ! and finally remove the current node + dummy => removeChild(getParentNode(this), this) + call destroy(dummy) + ! and set the "this" pointer back so we go over these again + this => old + endif + endif + + case (COMMENT_NODE) + if (.not.getParameter(dc, "comments")) then + old => getPreviousSibling(this) + if (.not.associated(old)) old => getParentNode(this) + dummy => removeChild(getParentNode(this), this) + call destroy(dummy) + this => old + endif + + case (DOCUMENT_TYPE_NODE) + if (getParameter(dc, "canonical-form")) then + old => getPreviousSibling(this) + if (.not.associated(old)) old => getParentNode(this) + dummy => removeChild(getParentNode(this), this) + call destroy(this) + this => old + endif + + end select + endif + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + endif + endif + + enddo + + + + end subroutine normalizeDocument + + recursive subroutine namespaceFixup(this, deep, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: this + logical, intent(in) :: deep + + type(Node), pointer :: parent, child, attr, nsp + type(NamedNodeMap), pointer :: attrs + type(NodeList), pointer :: nsNodes, nsNodesParent + integer :: i, nsIndex + + if (getNodeType(this) /= ELEMENT_NODE & + .and. getNodeType(this) /= ENTITY_REFERENCE_NODE & + .and. getNodeType(this)/=DOCUMENT_FRAGMENT_NODE) then + return + endif + + if (this%nodeType==ELEMENT_NODE) then + + ! Clear all current namespace nodes: + nsnodes => getNamespaceNodes(this) + do i = 1, getLength(nsNodes) + call destroyNode(nsNodes%nodes(i)%this) + enddo + deallocate(nsNodes%nodes) + + parent => getParentNode(this) + do while (associated(parent)) + ! Go up (through perhaps multiple entref nodes) + if (getNodeType(parent)==ELEMENT_NODE) exit + parent => getParentNode(parent) + enddo + ! Inherit from parent (or not ...) + if (associated(parent)) then + nsNodesParent => getNamespaceNodes(parent) + allocate(nsNodes%nodes(getLength(nsNodesParent))) + nsNodes%length = getLength(nsNodesParent) + do i = 0, getLength(nsNodes) - 1 + ! separate variable for intel + nsp => item(nsNodesParent, i) + nsNodes%nodes(i+1)%this => & + createNamespaceNode(getOwnerDocument(this), & + getPrefix(nsp), getNamespaceURI(nsp), & + specified=.false.) + enddo + else + allocate(nsNodes%nodes(0)) + nsNodes%length = 0 + endif + + ! Now check for broken NS declarations, and add namespace + ! nodes for all non-broken declarations + attrs => getAttributes(this) + do i = 0, getLength(attrs)-1 + attr => item(attrs, i) + if ((getLocalName(attr)=="xmlns" & + .or.getPrefix(attr)=="xmlns") & + .and.getNamespaceURI(attr)/="http://www.w3.org/2000/xmlns/") then + ! This can only I think happen if we bugger about with setPrefix ... + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "namespaceFixup", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + if (getNamespaceURI(attr)=="http://www.w3.org/2000/xmlns/") then + if (getLocalName(attr)=="xmlns") then + call appendNSNode(this, "", getValue(attr), specified=.true.) + else + call appendNSNode(this, getLocalName(attr), & + getValue(attr), specified=.true.) + endif + endif + enddo + + + if (getNamespaceURI(this)/="") then + ! Is the nsURI of this node bound to its prefix? + ! This will automatically do any necessary replacements ... + if (getPrefix(this)=="") then + if (.not.isDefaultNamespace(this, getNamespaceURI(this))) then + ! We are dealing with the default prefix + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns", getNamespaceURI(this)) + call appendNSNode(this, "", getNamespaceURI(this), specified=.true.) + endif + elseif (lookupNamespaceURI(this, getPrefix(this))/=getNamespaceURI(this)) then + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns:"//getPrefix(this), getNamespaceURI(this)) + call appendNSNode(this, getPrefix(this), getNamespaceURI(this), specified=.true.) + endif + else + ! No (or empty) namespace URI ... + if (getLocalName(this)=="") then + ! DOM level 1 node ... report error + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "namespaceFixup", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + else + ! We must declare the elements prefix to have an empty nsURI + if (lookupNamespaceURI(this, getPrefix(this))/="") then + if (getPrefix(this)=="") then + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns", "") + else + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns:"//getPrefix(this), "") + endif + ! and add a namespace node for the empty nsURI + call appendNSNode(this, getPrefix(this), "", specified=.true.) + endif + endif + endif + + do i = 0, getLength(attrs)-1 + ! This loops over the number of attrs present initially, so any we + ! add within this loop will not get checked - but they will only + ! be namespace declarations about which we dont care anyway. + attr => item(attrs, i) + if (getNamespaceURI(attr)=="http://www.w3.org/2000/xmlns/") then + cycle ! We already worried about it above. + elseif (getNamespaceURI(attr)=="http://www.w3.org/XML/1998/namespace") then + cycle ! We dont have to declare these + elseif (getNamespaceURI(attr)/="") then + ! This is a namespaced attribute + if (getPrefix(attr)=="" & + .or. lookupNamespaceURI(this, getPrefix(attr))/=getNamespaceURI(attr)) then + ! It has an inappropriate prefix + if (lookupPrefix(this, getNamespaceURI(attr))/="") then + ! then an appropriate prefix exists, use it. + call setPrefix(attr, lookupPrefix(this, getNamespaceURI(attr))) + ! FIXME should be "most local" prefix. Make sure lookupPrefix does that. + else + ! No suitable prefix exists, declare one. + if (getPrefix(attr)/="") then + ! Then the current prefix is not in use, its just undeclared. + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns:"//getPrefix(attr), getNamespaceURI(attr)) + call appendNSNode(this, getPrefix(attr), getNamespaceURI(attr), specified=.true.) + else + ! This node has no prefix, but needs one. Make it up. + nsIndex = 1 + do while (lookupNamespaceURI(this, "NS"//nsIndex)/="") + ! FIXME this will exit if the namespace is undeclared *or* if it is declared to be empty. + nsIndex = nsIndex+1 + enddo + call setAttributeNS(this, "http://www.w3.org/2000/xmlns/", & + "xmlns:NS"//nsIndex, getNamespaceURI(attr)) + ! and create namespace node + call appendNSNode(this, "NS"//nsIndex, getNamespaceURI(attr), specified=.true.) + call setPrefix(attr, "NS"//nsIndex) + endif + endif + endif + else + ! attribute has no namespace URI + if (getLocalName(this)=="") then + ! DOM level 1 node ... report error + if (getFoX_checks().or.NAMESPACE_ERR<200) then + call throw_exception(NAMESPACE_ERR, "namespaceFixup", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + ! otherwise no problem + endif + enddo + + endif + + if (deep) then + ! And now call this on all appropriate children ... + child => getFirstChild(this) + do while (associated(child)) + call namespaceFixup(child, .true.) + child => getNextSibling(child) + enddo + endif + + end subroutine namespaceFixup + + +end module m_dom_dom diff --git a/src/xml/dom/m_dom_error.F90 b/src/xml/dom/m_dom_error.F90 new file mode 100644 index 000000000..c6fdae418 --- /dev/null +++ b/src/xml/dom/m_dom_error.F90 @@ -0,0 +1,211 @@ +module m_dom_error + + use fox_m_fsys_abort_flush, only: pxfabort + + use m_common_error, only: error_stack, add_error, in_error, destroy_error_stack + + implicit none + private + + type DOMException + private + type(error_stack) :: stack + end type DOMException + + integer, parameter, public :: INDEX_SIZE_ERR = 1 + integer, parameter, public :: DOMSTRING_SIZE_ERR = 2 + integer, parameter, public :: HIERARCHY_REQUEST_ERR = 3 + integer, parameter, public :: WRONG_DOCUMENT_ERR = 4 + integer, parameter, public :: INVALID_CHARACTER_ERR = 5 + integer, parameter, public :: NO_DATA_ALLOWED_ERR = 6 + integer, parameter, public :: NO_MODIFICATION_ALLOWED_ERR = 7 + integer, parameter, public :: NOT_FOUND_ERR = 8 + integer, parameter, public :: NOT_SUPPORTED_ERR = 9 + integer, parameter, public :: INUSE_ATTRIBUTE_ERR = 10 + integer, parameter, public :: INVALID_STATE_ERR = 11 + integer, parameter, public :: SYNTAX_ERR = 12 + integer, parameter, public :: INVALID_MODIFICATION_ERR = 13 + integer, parameter, public :: NAMESPACE_ERR = 14 + integer, parameter, public :: INVALID_ACCESS_ERR = 15 + integer, parameter, public :: VALIDATION_ERR = 16 + integer, parameter, public :: TYPE_MISMATCH_ERR = 17 + + integer, parameter, public :: INVALID_EXPRESSION_ERR = 51 + integer, parameter, public :: TYPE_ERR = 52 + + integer, parameter, public :: PARSE_ERR = 81 + integer, parameter, public :: SERIALIZE_ERR = 82 + + integer, parameter, public :: FoX_INVALID_NODE = 201 + integer, parameter, public :: FoX_INVALID_CHARACTER = 202 + integer, parameter, public :: FoX_NO_SUCH_ENTITY = 203 + integer, parameter, public :: FoX_INVALID_PI_DATA = 204 + integer, parameter, public :: FoX_INVALID_CDATA_SECTION = 205 + integer, parameter, public :: FoX_HIERARCHY_REQUEST_ERR = 206 + integer, parameter, public :: FoX_INVALID_PUBLIC_ID = 207 + integer, parameter, public :: FoX_INVALID_SYSTEM_ID = 208 + integer, parameter, public :: FoX_INVALID_COMMENT = 209 + integer, parameter, public :: FoX_NODE_IS_NULL = 210 + integer, parameter, public :: FoX_INVALID_ENTITY = 211 + integer, parameter, public :: FoX_INVALID_URI = 212 + integer, parameter, public :: FoX_IMPL_IS_NULL = 213 + integer, parameter, public :: FoX_MAP_IS_NULL = 214 + integer, parameter, public :: FoX_LIST_IS_NULL = 215 + + integer, parameter, public :: FoX_INTERNAL_ERROR = 999 + + + public :: DOMException + public :: getExceptionCode + public :: throw_exception + public :: inException + public :: dom_error + public :: internal_error + +contains + + pure function errorString(code) result(s) + integer, intent(in) :: code + character(len=27) :: s + + select case(code) + case(1) + s = "INDEX_SIZE_ERR" + case(2) + s = "DOMSTRING_SIZE_ERR" + case(3) + s = "HIERARCHY_REQUEST_ERR" + case(4) + s = "WRONG_DOCUMENT_ERR" + case(5) + s = "INVALID_CHARACTER_ERR" + case(6) + s = "NO_DATA_ALLOWED_ERR" + case(7) + s = "NO_MODIFICATION_ALLOWED_ERR" + case(8) + s = "NOT_FOUND_ERR" + case(9) + s = "NOT_SUPPORTED_ERR" + case(10) + s = "INUSE_ATTRIBUTE_ERR" + case(11) + s = "INVALID_STATE_ERR" + case(12) + s = "SYNTAX_ERR" + case(13) + s = "INVALID_MODIFICATION_ERR" + case(14) + s = "NAMESPACE_ERR" + case(15) + s = "INVALID_ACCESS_ERR" + case(16) + s = "VALIDATION_ERR" + case(18) + s = "TYPE_MISMATCH_ERR" + case(51) + s = "INVALID_EXPRESSION_ERR" + case(52) + s = "TYPE_ERR" + case(81) + s = "PARSE_ERR" + case(82) + s = "SERIALIZE_ERR" + case(201) + s = "FoX_INVALID_NODE" + case(202) + s = "FoX_INVALID_CHARACTER" + case(203) + s = "FoX_NO_SUCH_ENTITY" + case(204) + s = "FoX_INVALID_PI_DATA" + case(205) + s = "FoX_INVALID_CDATA_SECTION" + case(206) + s = "FoX_HIERARCHY_REQUEST_ERR" + case(207) + s = "FoX_INVALID_PUBLIC_ID" + case(208) + s = "FoX_INVALID_SYSTEM_ID" + case(209) + s = "FoX_INVALID_COMMENT" + case(210) + s = "FoX_NODE_IS_NULL" + case(211) + s = "FoX_INVALID_ENTITY" + case(212) + s = "FoX_NO_DOCTYPE" + case(213) + s = "FoX_IMPL_IS_NULL" + case(214) + s = "FoX_MAP_IS_NULL" + case(215) + s = "FoX_LIST_IS_NULL" + case default + s = "INTERNAL ERROR!!!!" + end select + + end function errorString + + function getExceptionCode(ex) result(n) + type(DOMException), intent(inout) :: ex + integer :: n + + if (in_error(ex%stack)) then + n = ex%stack%stack(size(ex%stack%stack))%error_code + call destroy_error_stack(ex%stack) + else + n = 0 + endif + end function getExceptionCode + + subroutine throw_exception(code, msg, ex) + integer, intent(in) :: code + character(len=*), intent(in) :: msg + type(DOMException), intent(inout), optional :: ex + + if (present(ex)) then + call add_error(ex%stack, msg, error_code=code) ! FIXME + else + write(0,'(a)') errorString(code) + write(0,'(i0,a)') code, " "//msg + call pxfabort() + endif + + end subroutine throw_exception + + + subroutine dom_error(name,code,msg) + character(len=*), intent(in) :: name, msg + integer, intent(in) :: code + + write(0,'(4a)') "Routine ", name, ":", msg + write(0,'(a)') errorString(code) + call pxfabort() + + end subroutine dom_error + + + subroutine destroyDOMException(ex) + type(DOMException), intent(inout) :: ex + + call destroy_error_stack(ex%stack) + end subroutine destroyDOMException + + + subroutine internal_error(name,msg) + character(len=*), intent(in) :: name, msg + + write(0,'(4a)') "Internal error in ", name, ":", msg + call pxfabort() + + end subroutine internal_error + + function inException(ex) result(p) + type(DOMException), intent(in) :: ex + logical :: p + + p = in_error(ex%stack) + end function inException + +end module m_dom_error diff --git a/src/xml/dom/m_dom_extras.F90 b/src/xml/dom/m_dom_extras.F90 new file mode 100644 index 000000000..790561746 --- /dev/null +++ b/src/xml/dom/m_dom_extras.F90 @@ -0,0 +1,2444 @@ +module m_dom_extras + + use fox_m_fsys_realtypes, only: sp, dp + use fox_m_fsys_parse_input, only: rts + + use m_dom_error, only: DOMException, inException, throw_exception, & + FoX_NODE_IS_NULL, FoX_INVALID_NODE + use m_dom_dom, only: Node, ELEMENT_NODE, & + getAttribute, getAttributeNS, getTextContent, getNodeType, getFoX_checks + + implicit none + private + + public :: extractDataContent + public :: extractDataAttribute + public :: extractDataAttributeNS + + interface extractDataContent + module procedure extractDataContentCmplxDpSca + module procedure extractDataContentCmplxDpArr + module procedure extractDataContentCmplxDpMat + module procedure extractDataContentCmplxSpSca + module procedure extractDataContentCmplxSpArr + module procedure extractDataContentCmplxSpMat + module procedure extractDataContentRealDpSca + module procedure extractDataContentRealDpArr + module procedure extractDataContentRealDpMat + module procedure extractDataContentRealSpSca + module procedure extractDataContentRealSpArr + module procedure extractDataContentRealSpMat + module procedure extractDataContentIntSca + module procedure extractDataContentIntArr + module procedure extractDataContentIntMat + module procedure extractDataContentLongSca + module procedure extractDataContentLgSca + module procedure extractDataContentLgArr + module procedure extractDataContentLgMat + module procedure extractDataContentChSca + module procedure extractDataContentChArr + module procedure extractDataContentChMat + + end interface extractDataContent + + interface extractDataAttribute + module procedure extractDataAttributeCmplxDpSca + module procedure extractDataAttributeCmplxDpArr + module procedure extractDataAttributeCmplxDpMat + module procedure extractDataAttributeCmplxSpSca + module procedure extractDataAttributeCmplxSpArr + module procedure extractDataAttributeCmplxSpMat + module procedure extractDataAttributeRealDpSca + module procedure extractDataAttributeRealDpArr + module procedure extractDataAttributeRealDpMat + module procedure extractDataAttributeRealSpSca + module procedure extractDataAttributeRealSpArr + module procedure extractDataAttributeRealSpMat + module procedure extractDataAttributeIntSca + module procedure extractDataAttributeIntArr + module procedure extractDataAttributeIntMat + module procedure extractDataAttributeLongSca + module procedure extractDataAttributeLgSca + module procedure extractDataAttributeLgArr + module procedure extractDataAttributeLgMat + module procedure extractDataAttributeChSca + module procedure extractDataAttributeChArr + module procedure extractDataAttributeChMat + + end interface extractDataAttribute + + interface extractDataAttributeNS + module procedure extractDataAttNSCmplxDpSca + module procedure extractDataAttNSCmplxDpArr + module procedure extractDataAttNSCmplxDpMat + module procedure extractDataAttNSCmplxSpSca + module procedure extractDataAttNSCmplxSpArr + module procedure extractDataAttNSCmplxSpMat + module procedure extractDataAttNSRealDpSca + module procedure extractDataAttNSRealDpArr + module procedure extractDataAttNSRealDpMat + module procedure extractDataAttNSRealSpSca + module procedure extractDataAttNSRealSpArr + module procedure extractDataAttNSRealSpMat + module procedure extractDataAttNSIntSca + module procedure extractDataAttNSIntArr + module procedure extractDataAttNSIntMat + module procedure extractDataAttNSLgSca + module procedure extractDataAttNSLgArr + module procedure extractDataAttNSLgMat + module procedure extractDataAttNSChSca + module procedure extractDataAttNSChArr + module procedure extractDataAttNSChMat + + end interface extractDataAttributeNS + +contains + +subroutine extractDataContentCmplxDpSca(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + complex(dp), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentCmplxDpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentCmplxDpSca + +subroutine extractDataContentCmplxSpSca(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + complex(sp), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentCmplxSpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentCmplxSpSca + +subroutine extractDataContentRealDpSca(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + real(dp), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentRealDpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentRealDpSca + +subroutine extractDataContentRealSpSca(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + real(sp), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentRealSpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentRealSpSca + +subroutine extractDataContentIntSca(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer, intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentIntSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentIntSca + +subroutine extractDataContentLongSca(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer(8), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentIntSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentLongSca + +subroutine extractDataContentLgSca(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + logical, intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentLgSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentLgSca + +subroutine extractDataContentChSca(arg, data, separator, csv, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(out) :: data + + logical, intent(in), optional :: csv + character, intent(in), optional :: separator + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentChSca", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + endif + if (present(ex)) then + call rts(getTextContent(arg, ex), data, separator, csv, num, iostat) + else + call rts(getTextContent(arg), data, separator, csv, num, iostat) + endif + + end subroutine extractDataContentChSca + + +subroutine extractDataContentCmplxDpArr(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + complex(dp), dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentCmplxDpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentCmplxDpArr + +subroutine extractDataContentCmplxSpArr(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + complex(sp), dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentCmplxSpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentCmplxSpArr + +subroutine extractDataContentRealDpArr(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + real(dp), dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentRealDpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentRealDpArr + +subroutine extractDataContentRealSpArr(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + real(sp), dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentRealSpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentRealSpArr + +subroutine extractDataContentIntArr(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer, dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentIntArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentIntArr + +subroutine extractDataContentLgArr(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + logical, dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentLgArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentLgArr + +subroutine extractDataContentChArr(arg, data, separator, csv, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), dimension(:), intent(out) :: data + + logical, intent(in), optional :: csv + character, intent(in), optional :: separator + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentChArr", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + endif + if (present(ex)) then + call rts(getTextContent(arg, ex), data, separator, csv, num, iostat) + else + call rts(getTextContent(arg), data, separator, csv, num, iostat) + endif + + end subroutine extractDataContentChArr + + +subroutine extractDataContentCmplxDpMat(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + complex(dp), dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentCmplxDpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentCmplxDpMat + +subroutine extractDataContentCmplxSpMat(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + complex(sp), dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentCmplxSpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentCmplxSpMat + +subroutine extractDataContentRealDpMat(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + real(dp), dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentRealDpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentRealDpMat + +subroutine extractDataContentRealSpMat(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + real(sp), dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentRealSpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentRealSpMat + +subroutine extractDataContentIntMat(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + integer, dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentIntMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentIntMat + +subroutine extractDataContentLgMat(arg, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + logical, dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentLgMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getTextContent(arg, ex), data, num, iostat) + else + call rts(getTextContent(arg), data, num, iostat) + endif + + end subroutine extractDataContentLgMat + +subroutine extractDataContentChMat(arg, data, separator, csv, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), dimension(:,:), intent(out) :: data + + logical, intent(in), optional :: csv + character, intent(in), optional :: separator + integer, intent(out), optional :: num, iostat + + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataContentChMat", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + endif + if (present(ex)) then + call rts(getTextContent(arg, ex), data, separator, csv, num, iostat) + else + call rts(getTextContent(arg), data, separator, csv, num, iostat) + endif + + end subroutine extractDataContentChMat + + +subroutine extractDataAttributeCmplxDpSca(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + complex(dp), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeCmplxDpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeCmplxDpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeCmplxDpSca + +subroutine extractDataAttributeCmplxSpSca(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + complex(sp), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeCmplxSpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeCmplxSpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeCmplxSpSca + +subroutine extractDataAttributeRealDpSca(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + real(dp), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeRealDpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeRealDpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeRealDpSca + +subroutine extractDataAttributeRealSpSca(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + real(sp), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeRealSpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeRealSpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeRealSpSca + +subroutine extractDataAttributeIntSca(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + integer, intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeIntSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeIntSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeIntSca + +subroutine extractDataAttributeLongSca(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + integer(8), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeIntSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeIntSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeLongSca + +subroutine extractDataAttributeLgSca(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + logical, intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeLgSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeLgSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeLgSca + +subroutine extractDataAttributeChSca(arg, name, data, separator, csv, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + logical, intent(in), optional :: csv + character, intent(in), optional :: separator + character(len=*), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeChSca", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeChSca", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, separator, csv, num, iostat) + else + call rts(getAttribute(arg, name), data, separator, csv, num, iostat) + endif + + + end subroutine extractDataAttributeChSca + + +subroutine extractDataAttributeCmplxDpArr(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + complex(dp), dimension(:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeCmplxDpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeCmplxDpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeCmplxDpArr + +subroutine extractDataAttributeCmplxSpArr(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + complex(sp), dimension(:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeCmplxSpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeCmplxSpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeCmplxSpArr + +subroutine extractDataAttributeRealDpArr(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + real(dp), dimension(:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeRealDpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeRealDpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeRealDpArr + +subroutine extractDataAttributeRealSpArr(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + real(sp), dimension(:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeRealSpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeRealSpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeRealSpArr + +subroutine extractDataAttributeIntArr(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + integer, dimension(:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeIntArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeIntArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeIntArr + +subroutine extractDataAttributeLgArr(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + logical, dimension(:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeLgArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeLgArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeLgArr + +subroutine extractDataAttributeChArr(arg, name, data, separator, csv, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + logical, intent(in), optional :: csv + character, intent(in), optional :: separator + character(len=*), dimension(:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeChArr", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeChArr", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, separator, csv, num, iostat) + else + call rts(getAttribute(arg, name), data, separator, csv, num, iostat) + endif + + + end subroutine extractDataAttributeChArr + + +subroutine extractDataAttributeCmplxDpMat(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + complex(dp), dimension(:,:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeCmplxDpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeCmplxDpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeCmplxDpMat + +subroutine extractDataAttributeCmplxSpMat(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + complex(sp), dimension(:,:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeCmplxSpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeCmplxSpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeCmplxSpMat + +subroutine extractDataAttributeRealDpMat(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + real(dp), dimension(:,:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeRealDpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeRealDpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeRealDpMat + +subroutine extractDataAttributeRealSpMat(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + real(sp), dimension(:,:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeRealSpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeRealSpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeRealSpMat + +subroutine extractDataAttributeIntMat(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + integer, dimension(:,:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeIntMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeIntMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeIntMat + +subroutine extractDataAttributeLgMat(arg, name, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + logical, dimension(:,:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeLgMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeLgMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, num, iostat) + else + call rts(getAttribute(arg, name), data, num, iostat) + endif + + + end subroutine extractDataAttributeLgMat + +subroutine extractDataAttributeChMat(arg, name, data, separator, csv, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: name + + logical, intent(in), optional :: csv + character, intent(in), optional :: separator + character(len=*), dimension(:,:), intent(out) :: data + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttributeChMat", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttributeChMat", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getAttribute(arg, name, ex), data, separator, csv, num, iostat) + else + call rts(getAttribute(arg, name), data, separator, csv, num, iostat) + endif + + + end subroutine extractDataAttributeChMat + + +subroutine extractDataAttNSCmplxDpSca(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + complex(dp), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSCmplxDpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSCmplxDpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSCmplxDpSca + +subroutine extractDataAttNSCmplxSpSca(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + complex(sp), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSCmplxSpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSCmplxSpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSCmplxSpSca + +subroutine extractDataAttNSRealDpSca(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + real(dp), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSRealDpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSRealDpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSRealDpSca + +subroutine extractDataAttNSRealSpSca(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + real(sp), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSRealSpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSRealSpSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSRealSpSca + +subroutine extractDataAttNSIntSca(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + integer, intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSIntSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSIntSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSIntSca + +subroutine extractDataAttNSLgSca(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + logical, intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSLgSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSLgSca", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSLgSca + +subroutine extractDataAttNSChSca(arg, namespaceURI, localName, data, separator, csv, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + character(len=*), intent(out) :: data + + logical, intent(in), optional :: csv + character, intent(in), optional :: separator + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSChSca", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSChSca", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, separator, csv, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, separator, csv, num, iostat) + endif + + + end subroutine extractDataAttNSChSca + + +subroutine extractDataAttNSCmplxDpArr(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + complex(dp), dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSCmplxDpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSCmplxDpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSCmplxDpArr + +subroutine extractDataAttNSCmplxSpArr(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + complex(sp), dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSCmplxSpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSCmplxSpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSCmplxSpArr + +subroutine extractDataAttNSRealDpArr(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + real(dp), dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSRealDpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSRealDpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSRealDpArr + +subroutine extractDataAttNSRealSpArr(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + real(sp), dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSRealSpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSRealSpArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSRealSpArr + +subroutine extractDataAttNSIntArr(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + integer, dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSIntArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSIntArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSIntArr + +subroutine extractDataAttNSLgArr(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + logical, dimension(:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSLgArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSLgArr", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSLgArr + +subroutine extractDataAttNSChArr(arg, namespaceURI, localName, data, separator, csv, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + character(len=*), dimension(:), intent(out) :: data + + logical, intent(in), optional :: csv + character, intent(in), optional :: separator + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSChArr", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSChArr", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, separator, csv, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, separator, csv, num, iostat) + endif + + + end subroutine extractDataAttNSChArr + + +subroutine extractDataAttNSCmplxDpMat(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + complex(dp), dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSCmplxDpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSCmplxDpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSCmplxDpMat + +subroutine extractDataAttNSCmplxSpMat(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + complex(sp), dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSCmplxSpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSCmplxSpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSCmplxSpMat + +subroutine extractDataAttNSRealDpMat(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + real(dp), dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSRealDpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSRealDpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSRealDpMat + +subroutine extractDataAttNSRealSpMat(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + real(sp), dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSRealSpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSRealSpMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSRealSpMat + +subroutine extractDataAttNSIntMat(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + integer, dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSIntMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSIntMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSIntMat + +subroutine extractDataAttNSLgMat(arg, namespaceURI, localName, data, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + logical, dimension(:,:), intent(out) :: data + + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSLgMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSLgMat", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, num, iostat) + endif + + + end subroutine extractDataAttNSLgMat + +subroutine extractDataAttNSChMat(arg, namespaceURI, localName, data, separator, csv, num, iostat, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: arg + character(len=*), intent(in) :: namespaceURI, localName + character(len=*), dimension(:,:), intent(out) :: data + + logical, intent(in), optional :: csv + character, intent(in), optional :: separator + integer, intent(out), optional :: num, iostat + if (.not.associated(arg)) then + if (getFoX_checks().or.FoX_NODE_IS_NULL<200) then + call throw_exception(FoX_NODE_IS_NULL, "extractDataAttNSChMat", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + elseif (getNodeType(arg)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "extractDataAttNSChMat", ex) + if (present(ex)) then + if (inException(ex)) then + data = "" + return + endif + endif +endif + + endif + + if (present(ex)) then + call rts(getAttributeNS(arg, namespaceURI, localName, ex), & + data, separator, csv, num, iostat) + else + call rts(getAttributeNS(arg, namespaceURI, localName), & + data, separator, csv, num, iostat) + endif + + + end subroutine extractDataAttNSChMat + + + +end module m_dom_extras diff --git a/src/xml/dom/m_dom_parse.F90 b/src/xml/dom/m_dom_parse.F90 new file mode 100644 index 000000000..72e683732 --- /dev/null +++ b/src/xml/dom/m_dom_parse.F90 @@ -0,0 +1,577 @@ +module m_dom_parse + + use fox_m_fsys_array_str, only: str_vs, vs_str_alloc + use fox_m_utils_uri, only: URI, parseURI, rebaseURI, expressURI, destroyURI + use m_common_attrs, only: hasKey, getValue, getIndex, getIsId, getBase, & + add_item_to_dict + use m_common_entities, only: entity_t, size, getEntityByIndex + use m_common_error, only: FoX_error, in_error + use m_common_struct, only: xml_doc_state + use FoX_common, only: dictionary_t, getLength + use FoX_common, only: getQName, getValue, getURI, isSpecified + use m_sax_parser, only: sax_parse + use FoX_sax, only: xml_t + use FoX_sax, only: open_xml_file, open_xml_string, close_xml_t + + ! Public interfaces + use m_dom_dom, only: DOMConfiguration, Node, NamedNodeMap, & + TEXT_NODE, & + getAttributes, getData, getDocType, getEntities, getImplementation, & + getLastChild, getNodeType, & + getNotations, getParameter, getParentNode, getXmlVersion, & + setAttribute, setAttributeNS, setData, setValue, & + appendChild, createAttribute, createAttributeNS, createCdataSection, & + createComment, createDocumentType, createElement, createElementNS, & + createEntityReference, createProcessingInstruction, createTextNode, & + getNamedItem, setAttributeNode, setAttributeNodeNS, setNamedItem, & + getFoX_checks + + ! Private interfaces + use m_dom_dom, only: copyDOMConfig, createEmptyDocument, setDocumentElement, & + createEmptyEntityReference, createEntity, createNotation, & + getReadOnly, getStringValue, getXds, destroy, destroyAllNodesRecursively, & + namespaceFixup, setDocType, setDomConfig, setGCstate, setIllFormed, & + setIsElementContentWhitespace, setIsId, setReadOnlyMap, setReadonlyNode, & + setSpecified, setXds, setStringValue + + use m_dom_error, only: DOMException, inException, throw_exception, & + getExceptionCode, PARSE_ERR + + implicit none + private + + public :: parsefile + public :: parsestring + + type(xml_t), target, save :: fxml + + type(Node), pointer, save :: mainDoc => null() + type(Node), pointer, save :: current => null() + + type(DOMConfiguration), pointer :: domConfig + + logical :: cdata + character, pointer :: error(:) => null() + character, pointer :: inEntity(:) => null() + +contains + + subroutine startElement_handler(nsURI, localname, name, attrs) + character(len=*), intent(in) :: nsURI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attrs + + type(URI), pointer :: URIref, URIbase, newURI + type(Node), pointer :: el, attr, dummy + character, pointer :: baseURI(:) + integer :: i + + if (getParameter(domConfig, "namespaces")) then + el => createElementNS(mainDoc, nsURI, name) + else + el => createElement(mainDoc, name) + endif + + if (getBase(attrs)/="") then + i = getIndex(attrs, "xml:base") + if (i>0) then + URIbase => parseURI(getBase(attrs)) + URIref => parseURI(getValue(attrs, i)) + newURI => rebaseURI(URIbase, URIref) + call destroyURI(URIbase) + call destroyURI(URIref) + baseURI => vs_str_alloc(expressURI(newURI)) + call destroyURI(newURI) + else + baseURI => vs_str_alloc(getBase(attrs)) + endif + if (getParameter(domConfig, "namespaces")) then + attr => createAttributeNS(mainDoc, & + "http://www.w3.org/XML/1998/namespace", "xml:base") + else + attr => createAttribute(mainDoc, "xml:base") + endif + call setValue(attr, str_vs(baseURI)) + deallocate(baseURI) + if (i>0) then + call setSpecified(attr, isSpecified(attrs, i)) + call setIsId(attr, getIsId(attrs, i)) + endif + if (getParameter(domConfig, "namespaces")) then + dummy => setAttributeNodeNS(el, attr) + else + dummy => setAttributeNode(el, attr) + endif + endif + + do i = 1, getLength(attrs) + if (getQName(attrs, i)=="xml:base") cycle + if (getParameter(domConfig, "namespaces")) then + attr => createAttributeNS(mainDoc, getURI(attrs, i), getQName(attrs, i)) + else + attr => createAttribute(mainDoc, getQName(attrs, i)) + endif + call setValue(attr, getValue(attrs, i)) + call setSpecified(attr, isSpecified(attrs, i)) + call setIsId(attr, getIsId(attrs, i)) + if (getParameter(domConfig, "namespaces")) then + dummy => setAttributeNodeNS(el, attr) + else + dummy => setAttributeNode(el, attr) + endif + if (associated(inEntity)) call setReadOnlyNode(attr, .true., .true.) + enddo + + if (associated(current, mainDoc)) then + current => appendChild(current,el) + call setDocumentElement(mainDoc, current) + else + current => appendChild(current,el) + endif + if (getParameter(domConfig, "namespaces")) & + call namespaceFixup(current, .false.) + + if (associated(inEntity)) & + call setReadOnlyMap(getAttributes(current), .true.) + + cdata = .false. + + end subroutine startElement_handler + + subroutine endElement_handler(URI, localName, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (associated(inEntity)) call setReadOnlyNode(current, .true., .false.) + + current => getParentNode(current) + end subroutine endElement_handler + + ! FIXME to pick up entity references within attribute values, we need + ! separate just_the_element, start_attribute, attribute_text etc. calls. + + subroutine characters_handler(chunk) + character(len=*), intent(in) :: chunk + + type(Node), pointer :: temp + logical :: readonly + + temp => getLastChild(current) + if (associated(temp)) then + if (.not.cdata.and.getNodeType(temp)==TEXT_NODE) then + readonly = getReadOnly(temp) ! Reset readonly status quickly + call setReadOnlyNode(temp, .false., .false.) + call setData(temp, getData(temp)//chunk) + call setReadOnlyNode(temp, readonly, .false.) + return + endif + endif + if (cdata) then + temp => createCdataSection(mainDoc, chunk) + temp => appendChild(current, temp) + else + temp => createTextNode(mainDoc, chunk) + temp => appendChild(current, temp) + endif + + if (associated(inEntity)) call setReadOnlyNode(temp, .true., .false.) + + end subroutine characters_handler + + subroutine ignorableWhitespace_handler(chunk) + character(len=*), intent(in) :: chunk + + type(Node), pointer :: temp + logical :: readonly + + if (getParameter(domConfig, "element-content-whitespace")) then + temp => getLastChild(current) + if (associated(temp)) then + if (getNodeType(temp)==TEXT_NODE) then + readonly = getReadOnly(temp) ! Reset readonly status quickly + call setReadOnlyNode(temp, .false., .false.) + call setData(temp, getData(temp)//chunk) + call setReadOnlyNode(temp, readonly, .false.) + call setIsElementContentWhitespace(temp, .true.) + return + endif + endif + temp => createTextNode(mainDoc, chunk) + temp => appendChild(current, temp) + call setIsElementContentWhitespace(temp, .true.) + if (associated(inEntity)) call setReadOnlyNode(temp, .true., .false.) + endif + + end subroutine ignorableWhitespace_handler + + subroutine comment_handler(comment) + character(len=*), intent(in) :: comment + + type(Node), pointer :: temp + + if (getParameter(domConfig, "comments")) then + temp => appendChild(current, createComment(mainDoc, comment)) + if (associated(inEntity)) call setReadOnlyNode(temp, .true., .false.) + endif + + end subroutine comment_handler + + subroutine processingInstruction_handler(target, data) + character(len=*), intent(in) :: target + character(len=*), intent(in) :: data + + type(Node), pointer :: temp + + temp => appendChild(current, & + createProcessingInstruction(mainDoc, target, data)) + + if (associated(inEntity)) call setReadOnlyNode(temp, .true., .false.) + end subroutine processingInstruction_handler + + subroutine startDocument_handler + mainDoc => createEmptyDocument() + current => mainDoc + call setGCstate(mainDoc, .false.) + call setDomConfig(mainDoc, domConfig) + end subroutine startDocument_handler + + subroutine endDocument_Handler + call setGCstate(mainDoc, .true.) + end subroutine endDocument_Handler + + subroutine startDTD_handler(name, publicId, systemId) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: publicId + character(len=*), intent(in) :: systemId + + type(Node), pointer :: np + + np => createDocumentType(getImplementation(mainDoc), name, publicId=publicId, systemId=systemId) + np => appendChild(mainDoc, np) + call setDocType(mainDoc, np) + + end subroutine startDTD_handler + + subroutine endDTD_handler + + type(Node), pointer :: np, oldcurrent + type(NamedNodeMap), pointer :: entities + type(xml_t) :: subsax + type(xml_doc_state), pointer :: xds + type(entity_t), pointer :: ent + integer :: i, ios + logical :: ok + + entities => getEntities(getDocType(mainDoc)) + xds => getXds(mainDoc) + + do i = 1, size(xds%entityList) + ent => getEntityByIndex(xds%entityList, i) + np => getNamedItem(entities, str_vs(ent%name)) + + ok = .false. + if (ent%external) then + if (size(ent%notation)==0) then + call open_xml_file(subsax, expressURI(ent%baseURI), iostat=ios) + if (ios/=0) then + call setIllFormed(np, .true.) + else + ok = .true. + endif + endif + else + call open_xml_string(subsax, getStringValue(np)) + ok = .true. + endif + if (ok) then + oldcurrent => current + current => np + ! Run the parser over value + ! We do this with all entities already declared. + call sax_parse(subsax%fx, subsax%fb, & + startElement_handler=startElement_handler, & + endElement_handler=endElement_handler, & + characters_handler=characters_handler, & + startCdata_handler=startCdata_handler, & + endCdata_handler=endCdata_handler, & + comment_handler=comment_handler, & + processingInstruction_handler=processingInstruction_handler, & + fatalError_handler=entityErrorHandler, & + startInCharData = .true., & + externalEntity = ent%external, & + xmlVersion = getXmlVersion(mainDoc), & + namespaces=getParameter(domConfig, "namespaces"), & + initial_entities = xds%entityList) + call close_xml_t(subsax) + + current => oldcurrent + endif + enddo + + if (associated(getDocType(mainDoc))) then + call setReadonlyMap(getEntities(getDocType(mainDoc)), .true.) + call setReadonlyMap(getNotations(getDocType(mainDoc)), .true.) + endif + + end subroutine endDTD_handler + + subroutine FoX_endDTD_handler(state) + type(xml_doc_state), pointer :: state + + call setXds(mainDoc, state) + + end subroutine FoX_endDTD_handler + + subroutine notationDecl_handler(name, publicId, systemId) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: publicId + character(len=*), intent(in) :: systemId + + type(Node), pointer :: np + + np => createNotation(mainDoc, name, publicId=publicId, systemId=systemId) + np => setNamedItem(getNotations(getDocType(mainDoc)), np) + ! The SAX parser will never give us duplicate entities, + ! so there is no need to check + + end subroutine notationDecl_handler + + subroutine startCdata_handler() + if (getParameter(domConfig, "cdata-sections")) cdata = .true. + end subroutine startCdata_handler + subroutine endCdata_handler() + cdata = .false. + end subroutine endCdata_handler + + subroutine internalEntityDecl_handler(name, value) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: value + + type(Node), pointer :: np + + if (name(1:1)=="%") return + ! Do nothing with parameter entities + + ! We only note that these exist here. + ! A second parsing stage is triggered at the end + ! of the DTD, in order to resolve entity references (which + ! need not be declared in order) + + np => createEntity(mainDoc, name, "", "", "") + call setStringValue(np, value) + np => setNamedItem(getEntities(getDocType(mainDoc)), np) + + end subroutine internalEntityDecl_handler + + subroutine normalErrorHandler(msg) + character(len=*), intent(in) :: msg + ! This is called if the main parsing routine fails + error => vs_str_alloc(msg) + end subroutine normalErrorHandler + + subroutine entityErrorHandler(msg) + character(len=*), intent(in) :: msg + + !This gets called if parsing of an entity failed. If so, + !then we need to destroy all nodes which were being generated as + !children of this entity, then mark the entity as ill-formed - but + !otherwise carry on parsing the document, and only throw an error + !if a reference is made to it. + + call destroyAllNodesRecursively(current, except=.true.) + call setIllFormed(current, .true.) + end subroutine entityErrorHandler + + subroutine externalEntityDecl_handler(name, publicId, systemId) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: publicId + character(len=*), intent(in) :: systemId + type(Node), pointer :: np + + if (name(1:1)=="%") return + ! Do nothing with parameter entities + + np => createEntity(mainDoc, name, & + publicId=publicId, systemId=systemId, notationName="") + np => setNamedItem(getEntities(getDocType(mainDoc)), np) + + end subroutine externalEntityDecl_handler + + subroutine unparsedEntityDecl_handler(name, publicId, systemId, notationName) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: publicId + character(len=*), intent(in) :: systemId + character(len=*), intent(in) :: notationName + type(Node), pointer :: np + + np => getNamedItem(getEntities(getDocType(mainDoc)), name) + if (.not.associated(np)) then + np => createEntity(mainDoc, name, publicId=publicId, systemId=systemId, notationName=notationName) + np => setNamedItem(getEntities(getDocType(mainDoc)), np) + endif + + end subroutine unparsedEntityDecl_handler + + subroutine startEntity_handler(name) + character(len=*), intent(in) :: name + + if (name(1:1)=="%") return + ! Do nothing with parameter entities + + if (getParameter(domConfig, "entities")) then + if (.not.associated(inEntity)) then + inEntity => vs_str_alloc(name) + endif + current => appendChild(current, createEmptyEntityReference(mainDoc, name)) + endif + end subroutine startEntity_handler + + subroutine endEntity_handler(name) + character(len=*), intent(in) :: name + + if (name(1:1)=="%") return + ! Do nothing with parameter entities + + if (getParameter(domConfig, "entities")) then + call setReadOnlyNode(current, .true., .false.) + if (str_vs(inEntity)==name) deallocate(inEntity) + current => getParentNode(current) + endif + + end subroutine endEntity_handler + + subroutine skippedEntity_handler(name) + character(len=*), intent(in) :: name + + type(Node), pointer :: temp + + if (name(1:1)=="%") return + ! Do nothing with parameter entities + + temp => appendChild(current, createEntityReference(mainDoc, name)) + if (associated(inEntity)) call setReadonlyNode(temp, .true., .false.) + end subroutine skippedEntity_handler + + + subroutine runParser(fxml, configuration, ex) + type(DOMException), intent(out), optional :: ex + type(xml_t), intent(inout) :: fxml + type(DOMConfiguration), pointer, optional :: configuration + + allocate(DOMConfig) + if (present(configuration)) call copyDOMConfig(DOMConfig, configuration) + +! We use internal sax_parse rather than public interface in order +! to use internal callbacks to get extra info. + call sax_parse(fx=fxml%fx, fb=fxml%fb,& + characters_handler=characters_handler, & + endDocument_handler=endDocument_handler, & + endElement_handler=endElement_handler, & + !endPrefixMapping_handler, & + ignorableWhitespace_handler=ignorableWhitespace_handler, & + processingInstruction_handler=processingInstruction_handler, & + ! setDocumentLocator + skippedEntity_handler=skippedEntity_handler, & + startDocument_handler=startDocument_handler, & + startElement_handler=startElement_handler, & + !startPrefixMapping_handler, & + notationDecl_handler=notationDecl_handler, & + unparsedEntityDecl_handler=unparsedEntityDecl_handler, & + !error_handler, & + fatalError_handler=normalErrorHandler, & + !warning_handler, & + !attributeDecl_handler, & + !elementDecl_handler, & + externalEntityDecl_handler=externalEntityDecl_handler, & + internalEntityDecl_handler=internalEntityDecl_handler, & + comment_handler=comment_handler, & + endCdata_handler=endCdata_handler, & + endDTD_handler=endDTD_handler, & + endEntity_handler=endEntity_handler, & + startCdata_handler=startCdata_handler, & + startDTD_handler=startDTD_handler, & + startEntity_handler=startEntity_handler, & + FoX_endDTD_handler=FoX_endDTD_handler, & + namespaces = getParameter(domConfig, "namespaces"), & + namespace_prefixes = .true., & + validate = getParameter(domConfig, "validate"), & ! FIXME what about validate-if-present ... + xmlns_uris = .true.) + + call close_xml_t(fxml) + + if (associated(error)) then + if (associated(inEntity)) deallocate(inEntity) + ! FIXME pass the value of the error through + ! when we let exceptions do that + deallocate(error) + call destroy(mainDoc) + if (getFoX_checks().or.PARSE_ERR<200) then + call throw_exception(PARSE_ERR, "runParser", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + end subroutine runParser + + + function parsefile(filename, configuration, iostat, ex) + type(DOMException), intent(out), optional :: ex + character(len=*), intent(in) :: filename + type(DOMConfiguration), pointer, optional :: configuration + integer, intent(out), optional :: iostat + type(Node), pointer :: parsefile + + type(DOMException) :: ex_ + integer :: iostat_ + + call open_xml_file(fxml, filename, iostat_) + if (present(iostat)) then + iostat = iostat_ + if (iostat/=0) return + elseif (in_error(fxml%fx%error_stack)) then + call FoX_error(str_vs(fxml%fx%error_stack%stack(1)%msg)) + elseif (iostat_/=0) then + call FoX_error("Cannot open file") + endif + + if (present(ex)) then + call runParser(fxml, configuration, ex) + elseif (present(iostat)) then + call runParser(fxml, configuration, ex_) + else + call runParser(fxml, configuration) + endif + + if (present(iostat).and.inException(ex_)) then + iostat = getExceptionCode(ex_) + endif + + parsefile => mainDoc + mainDoc => null() + + end function parsefile + + + function parsestring(string, configuration, ex) + type(DOMException), intent(out), optional :: ex + character(len=*), intent(in) :: string + type(DOMConfiguration), pointer, optional :: configuration + type(Node), pointer :: parsestring + + call open_xml_string(fxml, string) + + call runParser(fxml, configuration, ex) + + parsestring => mainDoc + mainDoc => null() + + end function parsestring + +end module m_dom_parse diff --git a/src/xml/dom/m_dom_utils.F90 b/src/xml/dom/m_dom_utils.F90 new file mode 100644 index 000000000..1234c48ad --- /dev/null +++ b/src/xml/dom/m_dom_utils.F90 @@ -0,0 +1,437 @@ +module m_dom_utils + + use fox_m_fsys_array_str, only: str_vs, vs_str + use fox_m_fsys_format, only: operator(//) + use m_common_attrs, only: getValue + use m_common_element, only: element_t, attribute_t, & + get_attlist_size, get_attribute_declaration, express_attribute_declaration + use m_common_struct, only: xml_doc_state + + ! Public interfaces + use m_dom_dom, only: DOMConfiguration, NamedNodeMap, Node, & + NodeList, & + ATTRIBUTE_NODE, CDATA_SECTION_NODE, COMMENT_NODE, DOCUMENT_NODE, & + DOCUMENT_TYPE_NODE, ELEMENT_NODE, ENTITY_REFERENCE_NODE, & + PROCESSING_INSTRUCTION_NODE, TEXT_NODE, & + getAttributes, getChildNodes, getData, getDomConfig, getEntities, & + getFirstChild, getFoX_checks, getLength, getLocalName, getName, & + getNamespaceURI, getNextSibling, getNodeName, getNodeType, getNotationName,& + getNotations, getOwnerDocument, getOwnerElement, getParameter, & + getParentNode, getPrefix, getPublicId, getSpecified, getSystemId, & + getTagName, getTarget, getXmlStandalone, getXmlVersion, getValue, & + haschildnodes, item, normalizeDocument + + ! Private interfaces + use m_dom_dom, only: getNamespaceNodes, getStringValue, getXds, namespaceFixup + + use m_dom_error, only: DOMException, inException, throw_exception, & + getExceptionCode, & + NAMESPACE_ERR, SERIALIZE_ERR, FoX_INTERNAL_ERROR, FoX_INVALID_NODE + + use FoX_wxml, only: xmlf_t, & + xml_AddAttribute, xml_AddCharacters, xml_AddComment, xml_AddElementToDTD, & + xml_AddEntityReference, xml_AddExternalEntity, xml_AddInternalEntity, & + xml_AddDOCTYPE, xml_AddNotation, xml_AddXMLDeclaration, xml_AddXMLPI, & + xml_EndElement, xml_Close, xml_DeclareNamespace, xml_NewElement, & + xml_OpenFile, xml_UndeclareNamespace, xml_AddAttlistToDTD + + implicit none + + public :: dumpTree + public :: serialize + + private + +contains + + subroutine dumpTree(startNode) + + type(Node), pointer :: startNode + + integer :: indent_level + + indent_level = 0 + + call dump2(startNode) + + contains + + recursive subroutine dump2(input) + type(Node), pointer :: input + type(Node), pointer :: temp, np + type(NamedNodeMap), pointer :: attrs + type(NodeList), pointer :: nsnodes + integer :: i + temp => input + do while(associated(temp)) + write(*,"(3a,i0)") repeat(" ", indent_level), & + getNodeName(temp), " of type ", & + getNodeType(temp) + if (getNodeType(temp)==ELEMENT_NODE) then + write(*,"(2a)") repeat(" ", indent_level), & + " ATTRIBUTES:" + attrs => getAttributes(temp) + do i = 0, getLength(attrs) - 1 + np => item(attrs, i) + write(*, "(2a)") repeat(" ", indent_level)//" ", & + getName(np) + enddo + write(*,"(2a)") repeat(" ", indent_level), & + " IN-SCOPE NAMESPACES:" + nsnodes => getNamespaceNodes(temp) + do i = 0, getLength(nsnodes) - 1 + np => item(nsnodes, i) + write(*,"(4a)") repeat(" ", indent_level)//" ", & + getPrefix(np), ':', & + getNamespaceURI(np) + enddo + endif + if (hasChildNodes(temp)) then + indent_level = indent_level + 3 + call dump2(getFirstChild(temp)) + indent_level = indent_level - 3 + endif + temp => getNextSibling(temp) + enddo + + end subroutine dump2 + + end subroutine dumpTree + + + subroutine serialize(startNode, name, ex) + type(DOMException), intent(out), optional :: ex + type(Node), pointer :: startNode + character(len=*), intent(in) :: name + + type(Node), pointer :: doc + type(xmlf_t) :: xf + integer :: iostat + logical :: xmlDecl + + if (getNodeType(startNode)/=DOCUMENT_NODE & + .and.getNodeType(startNode)/=ELEMENT_NODE) then + if (getFoX_checks().or.FoX_INVALID_NODE<200) then + call throw_exception(FoX_INVALID_NODE, "serialize", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + + if (getNodeType(startNode)==DOCUMENT_NODE) then + doc => startNode + if (getParameter(getDomConfig(doc), "canonical-form") & + .and.getXmlVersion(doc)=="1.1") then + if (getFoX_checks().or.SERIALIZE_ERR<200) then + call throw_exception(SERIALIZE_ERR, "serialize", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + call normalizeDocument(startNode, ex) + if (present(ex)) then + ! Only possible error should be namespace error ... + ! but we should avoid turning an error of 0 into + ! an internal error! + if (inException(ex)) then + if (getExceptionCode(ex)/=NAMESPACE_ERR) then + if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then + call throw_exception(FoX_INTERNAL_ERROR, "serialize", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + else + if (getFoX_checks().or.SERIALIZE_ERR<200) then + call throw_exception(SERIALIZE_ERR, "serialize", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + endif + endif + else + doc => getOwnerDocument(startNode) + ! We need to do this namespace fixup or serialization will fail. + ! it doesn't change the semantics of the docs, but other + ! normalization would, so we done here + ! But only normalize if this is not a DOM level 1 node. + if (getLocalName(startNode)/="" & + .and.getParameter(getDomConfig(doc), "namespaces")) & + call namespaceFixup(startNode, .true.) + endif + xmlDecl = getParameter(getDomConfig(doc), "xml-declaration") + + ! FIXME we shouldnt really normalize the Document here + ! (except for namespace Normalization) but rather just + ! pay attention to the DOMConfig values + + ! NOTE: We set pretty_print on the basis of the FoX specific + ! "invalid-pretty-print" config option. The DOM-L3-LS + ! option "format-pretty-print is always false and is + ! not settable by the user - this is because WXML + ! cannot preserve validity conditions that may be set + ! by a DTD. If WXML ever learns to do this we will need + ! to pass the value of "format-pretty-print" through. + call xml_OpenFile(name, xf, iostat=iostat, unit=-1, & + pretty_print=getParameter(getDomConfig(doc), "invalid-pretty-print"), & + canonical=getParameter(getDomConfig(doc), "canonical-form"), & + warning=.false., addDecl=.false.) + if (iostat/=0) then + if (getFoX_checks().or.SERIALIZE_ERR<200) then + call throw_exception(SERIALIZE_ERR, "serialize", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + + if (xmlDecl) then + if (getXmlStandalone(doc)) then + call xml_AddXMLDeclaration(xf, version=getXmlVersion(doc), standalone=.true.) + else + call xml_AddXMLDeclaration(xf, version=getXmlVersion(doc)) + endif + endif + + call iter_dmp_xml(xf, startNode, ex) + call xml_Close(xf) + + end subroutine serialize + + subroutine iter_dmp_xml(xf, arg, ex) + type(DOMException), intent(out), optional :: ex + type(xmlf_t), intent(inout) :: xf + + type(Node), pointer :: this, arg, treeroot + type(Node), pointer :: doc, attrchild, np + type(NamedNodeMap), pointer :: nnm + type(DOMConfiguration), pointer :: dc + type(xml_doc_state), pointer :: xds + type(element_t), pointer :: elem + type(attribute_t), pointer :: att_decl + integer :: i_tree, j, k + logical :: doneChildren, doneAttributes + character, pointer :: attrvalue(:), tmp(:) + + if (getNodeType(arg)==DOCUMENT_NODE) then + doc => arg + else + doc => getOwnerDocument(arg) + endif + dc => getDomConfig(doc) + xds => getXds(doc) + + treeroot => arg + + i_tree = 0 + doneChildren = .false. + doneAttributes = .false. + this => treeroot + do + if (.not.doneChildren.and..not.(getNodeType(this)==ELEMENT_NODE.and.doneAttributes)) then + select case(getNodeType(this)) + case (ELEMENT_NODE) + nnm => getAttributes(this) + do j = 0, getLength(nnm) - 1 + attrchild => item(nnm, j) + if (getLocalName(attrchild)=="xmlns") then + if (len(getValue(attrchild))==0) then + call xml_UndeclareNamespace(xf) + else + call xml_DeclareNamespace(xf, getValue(attrchild)) + endif + elseif (getPrefix(attrchild)=="xmlns") then + if (len(getValue(attrchild))==0) then + call xml_UndeclareNamespace(xf, getLocalName(attrchild)) + else + call xml_DeclareNamespace(xf, getValue(attrchild), & + getLocalName(attrchild)) + endif + endif + enddo + call xml_NewElement(xf, getTagName(this)) + case (ATTRIBUTE_NODE) + if ((.not.getParameter(dc, "discard-default-content") & + .or.getSpecified(this)) & + ! only output it if it is not a default, or we are outputting defaults + .and. (getPrefix(this)/="xmlns".and.getLocalName(this)/="xmlns")) then + ! and we dont output NS declarations here. + ! complex loop below is because we might have to worry about entrefs + ! being preserved in the attvalue. If we dont, we only go through the loop once anyway. + allocate(attrvalue(0)) + do j = 0, getLength(getChildNodes(this)) - 1 + attrchild => item(getChildNodes(this), j) + if (getNodeType(attrchild)==TEXT_NODE) then + tmp => attrvalue + allocate(attrvalue(size(tmp)+getLength(attrchild))) + attrvalue(:size(tmp)) = tmp + attrvalue(size(tmp)+1:) = vs_str(getData(attrChild)) + deallocate(tmp) + elseif (getNodeType(attrchild)==ENTITY_REFERENCE_NODE) then + tmp => attrvalue + allocate(attrvalue(size(tmp)+len(getNodeName(attrchild))+2)) + attrvalue(:size(tmp)) = tmp + attrvalue(size(tmp)+1:) = vs_str("&"//getData(attrChild)//";") + deallocate(tmp) + else + if (getFoX_checks().or.FoX_INTERNAL_ERROR<200) then + call throw_exception(FoX_INTERNAL_ERROR, "iter_dmp_xml", ex) + if (present(ex)) then + if (inException(ex)) then + return + endif + endif +endif + + endif + enddo + call xml_AddAttribute(xf, getName(this), str_vs(attrvalue)) + deallocate(attrvalue) + endif + doneChildren = .true. + case (TEXT_NODE) + call xml_AddCharacters(xf, getData(this)) + case (CDATA_SECTION_NODE) + if (getParameter(getDomConfig(doc), "canonical-form")) then + call xml_AddCharacters(xf, getData(this)) + else + call xml_AddCharacters(xf, getData(this), parsed = .false.) + endif + case (ENTITY_REFERENCE_NODE) + if (.not.getParameter(getDomConfig(doc), "canonical-form")) then + call xml_AddEntityReference(xf, getNodeName(this)) + doneChildren = .true. + endif + case (PROCESSING_INSTRUCTION_NODE) + call xml_AddXMLPI(xf, getTarget(this), getData(this)) + case (COMMENT_NODE) + if (.not.getParameter(getDomConfig(doc), "comments")) then + call xml_AddComment(xf, getData(this)) + endif + case (DOCUMENT_TYPE_NODE) + if (.not.getParameter(getDomConfig(doc), "canonical-form")) then + call xml_AddDOCTYPE(xf, getName(this)) + nnm => getNotations(this) + do j = 0, getLength(nnm)-1 + np => item(nnm, j) + if (getSystemId(np)=="") then + call xml_AddNotation(xf, getNodeName(np), public=getPublicId(np)) + elseif (getPublicId(np)=="") then + call xml_AddNotation(xf, getNodeName(np), system=getSystemId(np)) + else + call xml_AddNotation(xf, getNodeName(np), system=getSystemId(np), & + public=getPublicId(np)) + endif + enddo + nnm => getEntities(this) + do j = 0, getLength(nnm)-1 + np => item(nnm, j) + if (getSystemId(np)=="") then + call xml_AddInternalEntity(xf, getNodeName(np), getStringValue(np)) + elseif (getPublicId(np)=="".and.getNotationName(np)=="") then + call xml_AddExternalEntity(xf, getNodeName(np), system=getSystemId(np)) + elseif (getNotationName(np)=="") then + call xml_AddExternalEntity(xf, getNodeName(np), system=getSystemId(np), & + public=getPublicId(np)) + elseif (getPublicId(np)=="") then + call xml_AddExternalEntity(xf, getNodeName(np), system=getSystemId(np), & + notation=getNotationName(np)) + else + call xml_AddExternalEntity(xf, getNodeName(np), system=getSystemId(np), & + public=getPublicId(np), notation=getNotationName(np)) + endif + enddo + do j = 1, size(xds%element_list%list) + elem => xds%element_list%list(j) + if (associated(elem%model)) & + call xml_AddElementToDTD(xf, str_vs(elem%name), str_vs(elem%model)) + ! Because we may have some undeclared but referenced elements + do k = 1, get_attlist_size(elem) + att_decl => get_attribute_declaration(elem, k) + call xml_AddAttlistToDTD(xf, str_vs(elem%name), & + express_attribute_declaration(att_decl)) + enddo + enddo + endif + end select + + else + if (getNodeType(this)==ELEMENT_NODE.and..not.doneChildren) then + doneAttributes = .true. + else + + if (getNodeType(this)==ELEMENT_NODE) then + call xml_EndElement(xf, getTagName(this)) + endif + + endif + endif + + + if (.not.doneChildren) then + if (getNodeType(this)==ELEMENT_NODE.and..not.doneAttributes) then + if (getLength(getAttributes(this))>0) then + this => item(getAttributes(this), 0) + else + doneAttributes = .true. + endif + elseif (hasChildNodes(this)) then + this => getFirstChild(this) + doneChildren = .false. + doneAttributes = .false. + else + doneChildren = .true. + doneAttributes = .false. + endif + + else ! if doneChildren + + if (associated(this, treeroot)) exit + if (getNodeType(this)==ATTRIBUTE_NODE) then + if (i_tree item(getAttributes(getOwnerElement(this)), i_tree) + doneChildren = .false. + else + i_tree= 0 + this => getOwnerElement(this) + doneAttributes = .true. + doneChildren = .false. + endif + elseif (associated(getNextSibling(this))) then + + this => getNextSibling(this) + doneChildren = .false. + doneAttributes = .false. + else + this => getParentNode(this) + endif + endif + + enddo + + + + end subroutine iter_dmp_xml + +end module m_dom_utils diff --git a/src/xml/fsys/Makefile b/src/xml/fsys/Makefile new file mode 100644 index 000000000..6e80265b0 --- /dev/null +++ b/src/xml/fsys/Makefile @@ -0,0 +1,48 @@ +source = $(wildcard *.F90) +objects = $(source:.F90=.o) + +#=============================================================================== +# Compiler Options +#=============================================================================== + +# Ignore unusd variables + +ifeq ($(MACHINE),bluegene) + override F90 = xlf2003 +endif + +ifeq ($(F90),ifort) + override F90FLAGS += -warn nounused +endif + +#=============================================================================== +# Targets +#=============================================================================== + +all: $(objects) + mv *.mod ../include + mv *.o ../lib +clean: + @rm -f *.o *.mod +neat: + @rm -f *.o *.mod + +#=============================================================================== +# Rules +#=============================================================================== + +.SUFFIXES: .F90 .o + +.PHONY: clean neat + +%.o: %.F90 + $(F90) $(F90FLAGS) -I../include -c $< + +#=============================================================================== +# Dependencies +#=============================================================================== + +fox_m_fsys_format.o: fox_m_fsys_realtypes.o fox_m_fsys_abort_flush.o +fox_m_fsys_parse_input.o: fox_m_fsys_realtypes.o +fox_m_fsys_count_parse_input.o: fox_m_fsys_realtypes.o +fox_m_fsys_string_list.o: fox_m_fsys_array_str.o diff --git a/src/xml/fsys/fox_m_fsys_abort_flush.F90 b/src/xml/fsys/fox_m_fsys_abort_flush.F90 new file mode 100644 index 000000000..29af292fc --- /dev/null +++ b/src/xml/fsys/fox_m_fsys_abort_flush.F90 @@ -0,0 +1,124 @@ +module fox_m_fsys_abort_flush + + implicit none + + public :: pxfflush + public :: pxfabort + public :: pure_pxfabort + ! status values to write to stderr on termination + integer, public, parameter :: STDERR_SUCCESS_STATUS = 0 + integer, public, parameter :: STDERR_FAILURE_STATUS = 1 + + ! pxf.F90 - assortment of Fortran wrappers to various + ! unix-y system calls. + ! + ! Copyright Toby White, 2005 + + ! The name pxf is intended to be reminiscent of the POSIX + ! fortran interfaces defined by IEEE 1003.9-1992, although + ! in fact I don't think that either flush or abort were + ! covered by said standard. + + ! Of the preprocessor defines used here, only xlC is + ! automatically defined by the appropriate compiler. All + ! others must be defined by some other mechanism - I + ! recommend autoconf. + + + ! FLUSH: flushes buffered output on a given unit. Not guaranteed + ! to do anything at all (particularly under MPI when even FLUSHed + ! buffers may not make it to the host cpu after an abort. + ! + ! IMPLEMENTATION: in F2003, this is a native operation called by the + ! FLUSH statement. + ! In almost every compiler, there is a FLUSH intrinsic subroutine + ! available which takes one argument, the unit to be flushed. + ! (some will flush all open units when no argument is given - this + ! facility is not used here. + ! NAG complicates matters by having to USE a module to get at flush. + ! + ! If no FLUSH is available, the subroutine is a no-op. + + +CONTAINS + + subroutine pxfflush(unit) +#ifdef __NAG__ + use f90_unix_io, only : flush +#endif + integer, intent(in) :: unit + integer :: i + +#if defined(F2003) + flush(unit) +#elif defined(xlC) + call flush_(unit) +#elif defined (FC_HAVE_FLUSH) + call flush(unit) +#else + i= unit ! pacify compiler + continue +#endif + + end subroutine pxfflush + + ! ABORT: terminates program execution in such a way that a backtrace + ! is produced. (see abort() in the C Standard Library). No arguments. + ! + ! IMPLEMENTATION: In F2003, the C interoperability features mean that + ! the abort in stdlib.h is available to be linked against. + ! In several other compilers an ABORT intrinsic subroutine is available. + ! Again, NAG complicates matters by needing to USE a module. + ! + ! In the case where no native ABORT can be found, we emulate one + ! by dereferencing a null pointer. This has reliably produced coredumps + ! on every platform I've tried it with. Just in case it doesn't (it need + ! not even stop execution) a stop is given to force termination. + + subroutine pxfabort() +#ifdef __NAG__ + use f90_unix_proc, only : abort +#endif +#ifdef F2003 + interface + subroutine abort() bind(c) + end subroutine abort + end interface +#define FC_HAVE_ABORT +#endif +#ifndef FC_HAVE_ABORT + integer, pointer :: i +#endif + + call pxfflush(6) + +#ifdef FC_HAVE_ABORT +#ifdef FC_ABORT_UNDERSCORE + call abort_() +#elif defined(FC_ABORT_ARG) + call abort("") +#else + call abort() +#endif +#else + i=>null() + Print*,i +#endif + stop STDERR_FAILURE_STATUS + + end subroutine pxfabort + + ! For where we need a pxfabort that is pure, we have + ! this below. I am less sure of its working everywhe + ! also it must be used as a function not a subroutine + ! (otherwise it would be optimized away as side-effect + ! free + + pure function pure_pxfabort() result (crash) + integer :: crash + integer, pointer :: i + nullify(i) + crash = i + end function pure_pxfabort + +end module fox_m_fsys_abort_flush diff --git a/src/xml/fsys/fox_m_fsys_array_str.F90 b/src/xml/fsys/fox_m_fsys_array_str.F90 new file mode 100644 index 000000000..88d565256 --- /dev/null +++ b/src/xml/fsys/fox_m_fsys_array_str.F90 @@ -0,0 +1,94 @@ +module fox_m_fsys_array_str +#ifndef DUMMYLIB + + implicit none + private + + interface destroy + module procedure destroy_vs + end interface + + interface concat + module procedure vs_s_concat + end interface + + interface alloc + module procedure vs_str_alloc + end interface + + public :: str_vs + public :: vs_str + public :: vs_str_alloc + public :: vs_vs_alloc + + public :: concat + public :: alloc + + public :: destroy + +contains + + pure function str_vs(vs) result(s) + character, dimension(:), intent(in) :: vs + character(len=size(vs)) :: s + integer :: i + ! Note that we could use s = transfer(vs, s) + ! here and (in principle) this could be an O(1) + ! operation. However, this leakes memory on all + ! recent gfortrans and crashes on some versions of + ! PGF90. So the loop would need to be included with + ! an #ifdef PGF90. In any case, the looping version + ! seems to be quickers (probably due to the character + ! copying being vectorized in the loop). See: + ! http://gcc.gnu.org/bugzilla/show_bug.cgi?id=51175 + do i = 1, size(vs) + s(i:i) = vs(i) + enddo + end function str_vs + + + pure function vs_str(s) result(vs) + character(len=*), intent(in) :: s + character, dimension(len(s)) :: vs + + vs = transfer(s, vs) + end function vs_str + + pure function vs_str_alloc(s) result(vs) + character(len=*), intent(in) :: s + character, dimension(:), pointer :: vs + + allocate(vs(len(s))) + vs = vs_str(s) + end function vs_str_alloc + + pure function vs_vs_alloc(s) result(vs) + character, dimension(:), pointer :: s + character, dimension(:), pointer :: vs + + if (associated(s)) then + allocate(vs(size(s))) + vs = s + else + vs => null() + endif + end function vs_vs_alloc + + pure function vs_s_concat(vs, s) result(vs2) + character, dimension(:), intent(in) :: vs + character(len=*), intent(in) :: s + character, dimension(:), pointer :: vs2 + + allocate(vs2(size(vs)+len(s))) + vs2(:size(vs)) = vs + vs2(size(vs)+1:) = vs_str(s) + end function vs_s_concat + + subroutine destroy_vs(vs) + character, dimension(:), pointer :: vs + + deallocate(vs) + end subroutine destroy_vs + +#endif +end module fox_m_fsys_array_str diff --git a/src/xml/fsys/fox_m_fsys_count_parse_input.F90 b/src/xml/fsys/fox_m_fsys_count_parse_input.F90 new file mode 100644 index 000000000..b158d26fa --- /dev/null +++ b/src/xml/fsys/fox_m_fsys_count_parse_input.F90 @@ -0,0 +1,561 @@ +module fox_m_fsys_count_parse_input + + use fox_m_fsys_realtypes, only: sp, dp + + implicit none + private + + character(len=1), parameter :: SPACE = achar(32) + character(len=1), parameter :: NEWLINE = achar(10) + character(len=1), parameter :: CARRIAGE_RETURN = achar(13) + character(len=1), parameter :: TAB = achar(9) + character(len=*), parameter :: whitespace = & + SPACE//NEWLINE//CARRIAGE_RETURN//TAB + + interface countrts + module procedure countstring + module procedure countlogical + module procedure countinteger + module procedure countrealsp + module procedure countrealdp + module procedure countcomplexsp + module procedure countcomplexdp + end interface + + public :: countrts + +contains + + pure function countstring(s, datatype, separator, csv) result(num) + character(len=*), intent(in) :: s + character(len=*), intent(in) :: datatype + character, intent(in), optional :: separator + logical, intent(in), optional :: csv + integer :: num +#ifndef DUMMYLIB + logical :: bracketed + integer :: i, j, ij, k, s_i, err, ios, length + real :: r, c + + character(len=len(s)) :: s2 + logical :: csv_, eof + integer :: m + + csv_ = .false. + if (present(csv)) then + if (csv) csv_ = csv + endif + + s_i = 1 + err = 0 + eof = .false. + ij = 0 + loop: do + if (csv_) then + if (s_i>len(s)) then + ij = ij + 1 + exit loop + endif + k = verify(s(s_i:), achar(10)//achar(13)) + if (k==0) then + ij = ij + 1 + exit loop + elseif (s(s_i+k-1:s_i+k-1)=="""") then + ! we have a quote-delimited string; + s_i = s_i + k + s2 = "" + quote: do + k = index(s(s_i:), """") + if (k==0) then + err = 2 + exit loop + endif + k = s_i + k - 1 + s2(m:) = s(s_i:k) + m = m + (k-s_i+1) + k = k + 2 + if (k>len(s)) then + err = 2 + exit loop + endif + if (s(k:k)/="""") exit + s_i = k + 1 + if (s_i > len(s)) then + err = 2 + exit loop + endif + m = m + 1 + s2(m:m) = """" + enddo quote + k = scan(s(s_i:), whitespace) + if (k==0) then + err = 2 + exit loop + endif + else + s_i = s_i + k - 1 + k = scan(s(s_i:), achar(10)//achar(13)//",") + if (k==0) then + eof = .true. + k = len(s) + else + k = s_i + k - 2 + endif + if (index(s(s_i:k), """")/=0) then + err = 2 + exit loop + endif + endif + ij = ij + 1 + s_i = k + 2 + if (eof) exit loop + + else + if (present(separator)) then + k = index(s(s_i:), separator) + else + k = verify(s(s_i:), whitespace) + if (k==0) exit loop + s_i = s_i + k - 1 + k = scan(s(s_i:), whitespace) + endif + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + ij = ij + 1 + s_i = k + 2 + if (s_i>len(s)) exit loop + + endif + end do loop + + num = ij + if (err/=0) num=0 + +#else + num = 0 +#endif + end function countstring + + pure function countlogical(s, datatype) result(num) + character(len=*), intent(in) :: s + logical, intent(in) :: datatype + logical :: dummy_data + integer :: num +#ifndef DUMMYLIB + logical :: bracketed + integer :: i, j, ij, k, s_i, err, ios, length + real :: r, c + + + s_i = 1 + err = 0 + ij = 0 + length = 1 + loop: do + k = verify(s(s_i:), whitespace) + if (k==0) exit loop + s_i = s_i + k - 1 + if (s(s_i:s_i)==",") then + if (s_i+1>len(s)) then + err = 2 + exit loop + endif + k = verify(s(s_i+1:), whitespace) + s_i = s_i + k - 1 + endif + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + if (.not.((s(s_i:k)=="true".or.s(s_i:k)=="1").or. & + (s(s_i:k)=="false".or.s(s_i:k)=="0"))) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + num = ij + if (verify(s(s_i:), whitespace)/=0) num = 0 + if (err/=0) num=0 + + +#else + num = 0 +#endif + end function countlogical + + pure function countinteger(s, datatype) result(num) + character(len=*), intent(in) :: s + integer, intent(in) :: datatype + integer :: dummy_data + integer num +#ifndef DUMMYLIB + logical :: bracketed + integer :: i, j, ij, k, s_i, err, ios, length + real :: r, c + + s_i = 1 + err = 0 + ij = 0 + length = 1 + loop: do + k = verify(s(s_i:), whitespace) + if (k==0) exit loop + s_i = s_i + k - 1 + if (s(s_i:s_i)==",") then + if (s_i+1>len(s)) then + err = 2 + exit loop + endif + k = verify(s(s_i+1:), whitespace) + s_i = s_i + k - 1 + endif + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + read(s(s_i:k), *, iostat=ios) dummy_data + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + num = ij + if (verify(s(s_i:), whitespace)/=0) num = 0 + if (err/=0) num=0 + + +#else + num = 0 +#endif +end function countinteger + + pure function countrealsp(s, datatype) result(num) + character(len=*), intent(in) :: s + real(sp), intent(in) :: datatype + real(sp) :: dummy_data + integer :: num +#ifndef DUMMYLIB + logical :: bracketed + integer :: i, j, ij, k, s_i, err, ios, length + real :: r, c + + + s_i = 1 + err = 0 + ij = 0 + length = 1 + loop: do + k = verify(s(s_i:), whitespace) + if (k==0) exit loop + s_i = s_i + k - 1 + if (s(s_i:s_i)==",") then + if (s_i+1>len(s)) then + err = 2 + exit loop + endif + k = verify(s(s_i+1:), whitespace) + s_i = s_i + k - 1 + endif + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + read(s(s_i:k), *, iostat=ios) dummy_data + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + num = ij + if (verify(s(s_i:), whitespace)/=0) num = 0 + if (err/=0) num=0 + + +#else + num = 0 +#endif + end function countrealsp + + pure function countrealdp(s, datatype) result(num) + character(len=*), intent(in) :: s + real(dp), intent(in) :: datatype + real(dp) :: dummy_data + integer :: num +#ifndef DUMMYLIB + logical :: bracketed + integer :: i, j, ij, k, s_i, err, ios, length + real :: r, c + + + s_i = 1 + err = 0 + ij = 0 + length = 1 + loop: do + k = verify(s(s_i:), whitespace) + if (k==0) exit loop + s_i = s_i + k - 1 + if (s(s_i:s_i)==",") then + if (s_i+1>len(s)) then + err = 2 + exit loop + endif + k = verify(s(s_i+1:), whitespace) + s_i = s_i + k - 1 + endif + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + read(s(s_i:k), *, iostat=ios) dummy_data + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + num = ij + if (verify(s(s_i:), whitespace)/=0) num = 0 + if (err/=0) num=0 + + +#else + num = 0 +#endif + end function countrealdp + + pure function countcomplexsp(s, datatype) result(num) + character(len=*), intent(in) :: s + complex(sp), intent(in) :: datatype + complex(sp) :: dummy_data + integer :: num +#ifndef DUMMYLIB + logical :: bracketed + integer :: i, j, ij, k, s_i, err, ios, length + real :: r, c + + + s_i = 1 + err = 0 + ij = 0 + length = 1 + loop: do + bracketed = .false. + k = verify(s(s_i:), whitespace) + if (k==0) exit loop + s_i = s_i + k - 1 + select case (s(s_i:s_i)) + case ("(") + bracketed = .true. + k = verify(s(s_i:), whitespace) + if (k==0) then + err = 2 + exit loop + endif + s_i = s_i + k + case (",") + k = verify(s(s_i:), whitespace) + if (k==0) then + err = 2 + exit loop + endif + s_i = s_i + k - 1 + case ("+", "-", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9") + continue + case default + err = 2 + exit loop + end select + if (bracketed) then + k = index(s(s_i:), ")+i(") + else + k = scan(s(s_i:), whitespace//",") + endif + if (k==0) then + err = 2 + exit loop + endif + k = s_i + k - 2 + read(s(s_i:k), *, iostat=ios) r + if (ios/=0) then + err = 2 + exit loop + endif + if (bracketed) then + s_i = k + 5 + if (s_i>len(s)) then + err = 2 + exit loop + endif + else + s_i = k + 2 + endif + if (bracketed) then + k = index(s(s_i:), ")") + if (k==0) then + err = 2 + exit loop + endif + k = s_i + k - 2 + else + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + endif + read(s(s_i:k), *, iostat=ios) c + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + num = ij + if (verify(s(s_i:), whitespace)/=0) num = 0 + if (err/=0) num=0 + + +#else + num = 0 +#endif + end function countcomplexsp + + pure function countcomplexdp(s, datatype) result(num) + character(len=*), intent(in) :: s + complex(dp), intent(in) :: datatype + complex(dp) :: dummy_data + integer :: num +#ifndef DUMMYLIB + logical :: bracketed + integer :: i, j, ij, k, s_i, err, ios, length + real :: r, c + + + s_i = 1 + err = 0 + ij = 0 + length = 1 + loop: do + bracketed = .false. + k = verify(s(s_i:), whitespace) + if (k==0) exit loop + s_i = s_i + k - 1 + select case (s(s_i:s_i)) + case ("(") + bracketed = .true. + k = verify(s(s_i:), whitespace) + if (k==0) then + err = 2 + exit loop + endif + s_i = s_i + k + case (",") + k = verify(s(s_i:), whitespace) + if (k==0) then + err = 2 + exit loop + endif + s_i = s_i + k - 1 + case ("+", "-", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9") + continue + case default + err = 2 + exit loop + end select + if (bracketed) then + k = index(s(s_i:), ")+i(") + else + k = scan(s(s_i:), whitespace//",") + endif + if (k==0) then + err = 2 + exit loop + endif + k = s_i + k - 2 + read(s(s_i:k), *, iostat=ios) r + if (ios/=0) then + err = 2 + exit loop + endif + if (bracketed) then + s_i = k + 5 + if (s_i>len(s)) then + err = 2 + exit loop + endif + else + s_i = k + 2 + endif + if (bracketed) then + k = index(s(s_i:), ")") + if (k==0) then + err = 2 + exit loop + endif + k = s_i + k - 2 + else + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + endif + read(s(s_i:k), *, iostat=ios) c + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + num = ij + if (verify(s(s_i:), whitespace)/=0) num = 0 + if (err/=0) num=0 + + +#else + num = 0 +#endif + end function countcomplexdp + +end module fox_m_fsys_count_parse_input diff --git a/src/xml/fsys/fox_m_fsys_format.F90 b/src/xml/fsys/fox_m_fsys_format.F90 new file mode 100644 index 000000000..448f44ebd --- /dev/null +++ b/src/xml/fsys/fox_m_fsys_format.F90 @@ -0,0 +1,2250 @@ +module fox_m_fsys_format + +!Note that there are several oddities to this package, +!to get round assorted compiler bugs. + +!All the _matrix_ subroutines should be straight +!call-throughs to the relevant _array_ subroutine, +!but with flattened arrays. (this would allow easy +!generation of all functions up to 7 dimensions) +!but unfortunately that breaks PGI-6.1, and causes +!errors on Pathscale-2.4. + +!The Logical array/matrix functions should be able +!to COUNT their length inline in the specification +!expression, but Pathscale-2.4 gives an error on that. + + use fox_m_fsys_abort_flush, only: pxfflush + use fox_m_fsys_realtypes, only: sp, dp + + implicit none + private + +#ifndef DUMMYLIB + integer, parameter :: sig_sp = digits(1.0_sp)/4 + integer, parameter :: sig_dp = digits(1.0_dp)/4 ! Approximate precision worth outputting of each type. + + character(len=*), parameter :: digit = "0123456789:" + character(len=*), parameter :: hexdigit = "0123456789abcdefABCDEF" +#endif + + interface str +! This is for external use only: str should not be called within this +! file. +! All *_chk subroutines check that the fmt they are passed is valid. + module procedure str_string, str_string_array, str_string_matrix, & + str_integer, str_integer_array, str_integer_matrix, & + str_integer_fmt, str_integer_array_fmt, str_integer_matrix_fmt, & + str_logical, str_logical_array, str_logical_matrix, & + str_real_sp, str_real_sp_fmt_chk, & + str_real_sp_array, str_real_sp_array_fmt_chk, & + str_real_sp_matrix, str_real_sp_matrix_fmt_chk, & + str_real_dp, str_real_dp_fmt_chk, & + str_real_dp_array, str_real_dp_array_fmt_chk, & + str_real_dp_matrix, str_real_dp_matrix_fmt_chk, & + str_complex_sp, str_complex_sp_fmt_chk, & + str_complex_sp_array, str_complex_sp_array_fmt_chk, & + str_complex_sp_matrix, str_complex_sp_matrix_fmt_chk, & + str_complex_dp, str_complex_dp_fmt_chk, & + str_complex_dp_array, str_complex_dp_array_fmt_chk, & + str_complex_dp_matrix, str_complex_dp_matrix_fmt_chk + end interface str + +#ifndef DUMMYLIB + interface safestr +! This is for internal use only - no check is made on the validity of +! any fmt input. + module procedure str_string, str_string_array, str_string_matrix, & + str_integer, str_integer_array, str_integer_matrix, & + str_logical, str_logical_array, str_logical_matrix, & + str_real_sp, str_real_sp_fmt, & + str_real_sp_array, str_real_sp_array_fmt, & + str_real_sp_matrix, str_real_sp_matrix_fmt, & + str_real_dp, str_real_dp_fmt, & + str_real_dp_array, str_real_dp_array_fmt, & + str_real_dp_matrix, str_real_dp_matrix_fmt, & + str_complex_sp, str_complex_sp_fmt, & + str_complex_sp_array, str_complex_sp_array_fmt, & + str_complex_sp_matrix, str_complex_sp_matrix_fmt, & + str_complex_dp, str_complex_dp_fmt, & + str_complex_dp_array, str_complex_dp_array_fmt, & + str_complex_dp_matrix, str_complex_dp_matrix_fmt + end interface safestr + + interface len + module procedure str_integer_len, str_integer_array_len, str_integer_matrix_len, & + str_integer_fmt_len, str_integer_array_fmt_len, str_integer_matrix_fmt_len, & + str_logical_len, str_logical_array_len, str_logical_matrix_len, & + str_real_sp_len, str_real_sp_fmt_len, & + str_real_sp_array_len, str_real_sp_array_fmt_len, & + str_real_sp_matrix_len, str_real_sp_matrix_fmt_len, & + str_real_dp_len, str_real_dp_fmt_len, & + str_real_dp_array_len, str_real_dp_array_fmt_len, & + str_real_dp_matrix_len, str_real_dp_matrix_fmt_len, & + str_complex_sp_len, str_complex_sp_fmt_len, & + str_complex_sp_array_len, str_complex_sp_array_fmt_len, & + str_complex_sp_matrix_len, str_complex_sp_matrix_fmt_len, & + str_complex_dp_len, str_complex_dp_fmt_len, & + str_complex_dp_array_len, str_complex_dp_array_fmt_len, & + str_complex_dp_matrix_len, str_complex_dp_matrix_fmt_len + end interface +#endif + + interface operator(//) + module procedure concat_str_int, concat_int_str, & + concat_str_logical, concat_logical_str, & + concat_real_sp_str, concat_str_real_sp, & + concat_real_dp_str, concat_str_real_dp, & + concat_complex_sp_str, concat_str_complex_sp, & + concat_complex_dp_str, concat_str_complex_dp + end interface + + public :: str + public :: operator(//) + +#ifndef DUMMYLIB + public :: str_to_int_10 + public :: str_to_int_16 +#endif + +contains + +#ifndef DUMMYLIB + ! NB: The len generic module procedure is used in + ! many initialisation statments (to set the + ! length of the output string needed for the + ! converted number). As of the Fortran 2008 + ! spec every specific function belonging to + ! a generic used in this way must be defined + ! in the module before use. This is enforced + ! by at least version 7.4.4 of the Cray + ! Fortran compiler. Hence we put all the *_len + ! functions here at the top of the file. + pure function str_string_array_len(st) result(n) + character(len=*), dimension(:), intent(in) :: st + integer :: n + + integer :: k + + n = size(st) - 1 + do k = 1, size(st) + n = n + len(st(k)) + enddo + + end function str_string_array_len + + pure function str_string_matrix_len(st) result(n) + character(len=*), dimension(:, :), intent(in) :: st + integer :: n + + n = len(st) * size(st) + size(st) - 1 + end function str_string_matrix_len + + pure function str_integer_len(i) result(n) + integer, intent(in) :: i + integer :: n + + n = int(log10(real(max(abs(i),1)))) + 1 + dim(-i,0)/max(abs(i),1) + + end function str_integer_len + + pure function str_integer_base_len(i, b) result(n) + integer, intent(in) :: i, b + integer :: n + + n = int(log10(real(max(abs(i),1)))/log10(real(b))) & + + 1 + dim(-i,0)/max(abs(i),1) + + end function str_integer_base_len + + pure function str_integer_fmt_len(i, fmt) result(n) + integer, intent(in) :: i + character(len=*), intent(in) :: fmt + integer :: n + + select case (len(fmt)) + case(0) + n = 0 + case(1) + if (fmt=="x") then + n = int(log10(real(max(abs(i),1)))/log10(16.0)) + 1 + dim(-i,0)/max(abs(i),1) + elseif (fmt=="d") then + n = int(log10(real(max(abs(i),1)))) + 1 + dim(-i,0)/max(abs(i),1) + else + return + endif + case default + if (fmt(1:1)/='x'.and.fmt(1:1)/='d') then + n = 0 + elseif (verify(fmt(2:), digit)==0) then + n = str_to_int_10(fmt(2:)) + else + n = 0 + endif + end select + + end function str_integer_fmt_len + + pure function str_integer_array_len(ia) result(n) + integer, dimension(:), intent(in) :: ia + integer :: n + + integer :: j + + n = size(ia) - 1 + + do j = 1, size(ia) + n = n + len(ia(j)) + enddo + + end function str_integer_array_len + + pure function str_integer_array_fmt_len(ia, fmt) result(n) + integer, dimension(:), intent(in) :: ia + character(len=*), intent(in) :: fmt + integer :: n + + integer :: j + + n = size(ia) - 1 + + do j = 1, size(ia) + n = n + len(ia(j), fmt) + enddo + + end function str_integer_array_fmt_len + + pure function str_integer_matrix_len(ia) result(n) + integer, dimension(:,:), intent(in) :: ia + integer :: n + + integer :: j, k + + n = size(ia) - 1 + + do k = 1, size(ia, 2) + do j = 1, size(ia, 1) + n = n + len(ia(j, k)) + enddo + enddo + + end function str_integer_matrix_len + + pure function str_integer_matrix_fmt_len(ia, fmt) result(n) + integer, dimension(:,:), intent(in) :: ia + character(len=*), intent(in) :: fmt + integer :: n + + integer :: j, k + + n = size(ia) - 1 + + do k = 1, size(ia, 2) + do j = 1, size(ia, 1) + n = n + len(ia(j, k), fmt) + enddo + enddo + + end function str_integer_matrix_fmt_len + + pure function str_logical_len(l) result (n) + logical, intent(in) :: l + integer :: n + + if (l) then + n = 4 + else + n = 5 + endif + end function str_logical_len + + pure function str_logical_array_len(la) result(n) +! This function should be inlined in the declarations of +! str_logical_array below but PGI and pathscale don't like it. + logical, dimension(:), intent(in) :: la + integer :: n + n = 5*size(la) - 1 + count(.not.la) + end function str_logical_array_len + + pure function str_logical_matrix_len(la) result(n) +! This function should be inlined in the declarations of +! str_logical_matrix below but PGI and pathscale don't like it. + logical, dimension(:,:), intent(in) :: la + integer :: n + n = 5*size(la) - 1 + count(.not.la) + end function str_logical_matrix_len + + pure function str_real_sp_fmt_len(x, fmt) result(n) + real(sp), intent(in) :: x + character(len=*), intent(in) :: fmt + integer :: n + + integer :: dec, sig + integer :: e + + if (.not.checkFmt(fmt)) then + n = 0 + return + endif + + if (x == 0.0_sp) then + e = 1 + else + e = floor(log10(abs(x))) + endif + + if (x < 0.0_sp) then + n = 1 + else + n = 0 + endif + + if (len(fmt) == 0) then + sig = sig_sp + + n = n + sig + 2 + len(e) + ! for the decimal point and the e + + elseif (fmt(1:1) == "s") then + if (len(fmt) > 1) then + sig = str_to_int_10(fmt(2:)) + else + sig = sig_sp + endif + sig = max(sig, 1) + sig = min(sig, digits(1.0_sp)) + + if (sig > 1) n = n + 1 + ! for the decimal point + + n = n + sig + 1 + len(e) + + elseif (fmt(1:1) == "r") then + + if (len(fmt) > 1) then + dec = str_to_int_10(fmt(2:)) + else + dec = sig_sp - e - 1 + endif + dec = min(dec, digits(1.0_sp)-e) + dec = max(dec, 0) + + if (dec > 0) n = n + 1 + if (abs(x) >= 1.0_sp) n = n + 1 + + ! Need to know if there's an overflow .... + if (e+dec+1 > 0) then + if (index(real_sp_str(abs(x), e+dec+1), "!") == 1) & + e = e + 1 + endif + + n = n + abs(e) + dec + + endif + + end function str_real_sp_fmt_len + + pure function str_real_sp_len(x) result(n) + real(sp), intent(in) :: x + integer :: n + + n = len(x, "") + + end function str_real_sp_len + + pure function str_real_sp_array_len(xa) result(n) + real(sp), dimension(:), intent(in) :: xa + integer :: n + + integer :: k + + n = size(xa) - 1 + do k = 1, size(xa) + n = n + len(xa(k), "") + enddo + + end function str_real_sp_array_len + + pure function str_real_sp_array_fmt_len(xa, fmt) result(n) + real(sp), dimension(:), intent(in) :: xa + character(len=*), intent(in) :: fmt + integer :: n + + integer :: k + + n = size(xa) - 1 + do k = 1, size(xa) + n = n + len(xa(k), fmt) + enddo + + end function str_real_sp_array_fmt_len + + pure function str_real_sp_matrix_fmt_len(xa, fmt) result(n) + real(sp), dimension(:,:), intent(in) :: xa + character(len=*), intent(in) :: fmt + integer :: n + + integer :: j, k + + n = size(xa) - 1 + do k = 1, size(xa, 2) + do j = 1, size(xa, 1) + n = n + len(xa(j,k), fmt) + enddo + enddo + + end function str_real_sp_matrix_fmt_len + + pure function str_real_sp_matrix_len(xa) result(n) + real(sp), dimension(:,:), intent(in) :: xa + integer :: n + + n = len(xa, "") + end function str_real_sp_matrix_len + + pure function str_real_dp_fmt_len(x, fmt) result(n) + real(dp), intent(in) :: x + character(len=*), intent(in) :: fmt + integer :: n + + integer :: dec, sig + integer :: e + + if (.not.checkFmt(fmt)) then + n = 0 + return + endif + + if (x == 0.0_dp) then + e = 1 + else + e = floor(log10(abs(x))) + endif + + if (x < 0.0_dp) then + n = 1 + else + n = 0 + endif + + if (len(fmt) == 0) then + sig = sig_dp + + n = n + sig + 2 + len(e) + ! for the decimal point and the e + + elseif (fmt(1:1) == "s") then + if (len(fmt) > 1) then + sig = str_to_int_10(fmt(2:)) + else + sig = sig_dp + endif + sig = max(sig, 1) + sig = min(sig, digits(1.0_dp)) + + if (sig > 1) n = n + 1 + ! for the decimal point + + n = n + sig + 1 + len(e) + + elseif (fmt(1:1) == "r") then + + if (len(fmt) > 1) then + dec = str_to_int_10(fmt(2:)) + else + dec = sig_dp - e - 1 + endif + dec = min(dec, digits(1.0_dp)-e) + dec = max(dec, 0) + + if (dec > 0) n = n + 1 + if (abs(x) >= 1.0_dp) n = n + 1 + + ! Need to know if there's an overflow .... + if (e+dec+1 > 0) then + if (index(real_dp_str(abs(x), e+dec+1), "!") == 1) & + e = e + 1 + endif + + n = n + abs(e) + dec + + endif + + end function str_real_dp_fmt_len + + pure function str_real_dp_len(x) result(n) + real(dp), intent(in) :: x + integer :: n + + n = len(x, "") + + end function str_real_dp_len + + pure function str_real_dp_array_len(xa) result(n) + real(dp), dimension(:), intent(in) :: xa + integer :: n + + integer :: k + + n = size(xa) - 1 + do k = 1, size(xa) + n = n + len(xa(k), "") + enddo + + end function str_real_dp_array_len + + pure function str_real_dp_array_fmt_len(xa, fmt) result(n) + real(dp), dimension(:), intent(in) :: xa + character(len=*), intent(in) :: fmt + integer :: n + + integer :: k + + n = size(xa) - 1 + do k = 1, size(xa) + n = n + len(xa(k), fmt) + enddo + + end function str_real_dp_array_fmt_len + + pure function str_real_dp_matrix_fmt_len(xa, fmt) result(n) + real(dp), dimension(:,:), intent(in) :: xa + character(len=*), intent(in) :: fmt + integer :: n + + integer :: j, k + + n = size(xa) - 1 + do k = 1, size(xa, 2) + do j = 1, size(xa, 1) + n = n + len(xa(j,k), fmt) + enddo + enddo + + end function str_real_dp_matrix_fmt_len + + pure function str_real_dp_matrix_len(xa) result(n) + real(dp), dimension(:,:), intent(in) :: xa + integer :: n + + n = len(xa, "") + end function str_real_dp_matrix_len + + pure function str_complex_sp_fmt_len(c, fmt) result(n) + complex(sp), intent(in) :: c + character(len=*), intent(in) :: fmt + integer :: n + + real(sp) :: re, im + re = real(c) + im = aimag(c) + + n = len(re, fmt) + len(im, fmt) + 6 + end function str_complex_sp_fmt_len + + pure function str_complex_sp_len(c) result(n) + complex(sp), intent(in) :: c + integer :: n + + n = len(c, "") + end function str_complex_sp_len + + pure function str_complex_sp_array_fmt_len(ca, fmt) result(n) + complex(sp), dimension(:), intent(in) :: ca + character(len=*), intent(in) :: fmt + integer :: n + + integer :: i + + n = size(ca) - 1 + do i = 1, size(ca) + n = n + len(ca(i), fmt) + enddo + end function str_complex_sp_array_fmt_len + + pure function str_complex_sp_array_len(ca) result(n) + complex(sp), dimension(:), intent(in) :: ca + integer :: n + + n = len(ca, "") + end function str_complex_sp_array_len + + pure function str_complex_sp_matrix_fmt_len(ca, fmt) result(n) + complex(sp), dimension(:, :), intent(in) :: ca + character(len=*), intent(in) :: fmt + integer :: n + + integer :: i, j + + n = size(ca) - 1 + do i = 1, size(ca, 1) + do j = 1, size(ca, 2) + n = n + len(ca(i, j), fmt) + enddo + enddo + end function str_complex_sp_matrix_fmt_len + + pure function str_complex_sp_matrix_len(ca) result(n) + complex(sp), dimension(:, :), intent(in) :: ca + integer :: n + + n = len(ca, "") + end function str_complex_sp_matrix_len + + pure function str_complex_dp_fmt_len(c, fmt) result(n) + complex(dp), intent(in) :: c + character(len=*), intent(in) :: fmt + integer :: n + + real(dp) :: re, im + re = real(c) + im = aimag(c) + + n = len(re, fmt) + len(im, fmt) + 6 + end function str_complex_dp_fmt_len + + pure function str_complex_dp_len(c) result(n) + complex(dp), intent(in) :: c + integer :: n + + n = len(c, "") + end function str_complex_dp_len + + pure function str_complex_dp_array_fmt_len(ca, fmt) result(n) + complex(dp), dimension(:), intent(in) :: ca + character(len=*), intent(in) :: fmt + integer :: n + + integer :: i + + n = size(ca) - 1 + do i = 1, size(ca) + n = n + len(ca(i), fmt) + enddo + end function str_complex_dp_array_fmt_len + + pure function str_complex_dp_array_len(ca) result(n) + complex(dp), dimension(:), intent(in) :: ca + integer :: n + + n = len(ca, "") + end function str_complex_dp_array_len + + pure function str_complex_dp_matrix_fmt_len(ca, fmt) result(n) + complex(dp), dimension(:, :), intent(in) :: ca + character(len=*), intent(in) :: fmt + integer :: n + + integer :: i, j + + n = size(ca) - 1 + do i = 1, size(ca, 1) + do j = 1, size(ca, 2) + n = n + len(ca(i, j), fmt) + enddo + enddo + end function str_complex_dp_matrix_fmt_len + + pure function str_complex_dp_matrix_len(ca) result(n) + complex(dp), dimension(:, :), intent(in) :: ca + integer :: n + + n = len(ca, "") + end function str_complex_dp_matrix_len +#endif + +#ifndef DUMMYLIB + subroutine FoX_error(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 + + write(0,'(a)') 'ERROR(FoX)' + write(0,'(a)') msg + call pxfflush(0) + + stop + + end subroutine FoX_error + + + pure function str_to_int_10(str) result(n) + ! Takes a string containing digits, and returns + ! the integer representable by those digits. + ! Does not deal with negative numbers, and + ! presumes that the number is representable + ! in a default integer + ! Error is flagged by returning -1 + character(len=*), intent(in) :: str + integer :: n + + integer :: max_power, i, j + + if (verify(str, digit) > 0) then + n = -1 + return + endif + + max_power = len(str) - 1 + + n = 0 + do i = 0, max_power + j = max_power - i + 1 + n = n + (index(digit, str(j:j)) - 1) * 10**i + enddo + + end function str_to_int_10 + + pure function str_to_int_16(str) result(n) + ! Takes a string containing hexadecimal digits, and returns + ! the integer representable by those digits. + ! Does not deal with negative numbers, and + ! presumes that the number is representable + ! in a default integer + ! Error is flagged by returning -1 + character(len=*), intent(in) :: str + integer :: n + + character(len=len(str)) :: str_l + integer :: max_power, i, j + + if (verify(str, hexdigit) == 0) then + str_l = to_lower(str) + else + n = -1 + return + endif + + max_power = len(str) - 1 + + n = 0 + do i = 0, max_power + j = max_power - i + 1 + n = n + (index(hexdigit, str_l(j:j)) - 1) * 16**i + enddo + + contains + pure function to_lower(s) result(s2) + character(len=*), intent(in) :: s + character(len=len(s)) :: s2 + character(len=*), parameter :: hex = "abcdef" + integer :: j, k + do j = 1, len(s) + k = index('ABCDEF', s(j:j)) + if (k > 0) then + s2(j:j) = hex(k:k) + else + s2(j:j) = s(j:j) + endif + enddo + end function to_lower + + end function str_to_int_16 +#endif + + pure function str_string(st) result(s) + character(len=*), intent(in) :: st +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(st)) :: s + s = st +#endif + end function str_string + + pure function str_string_array(st, delimiter) result(s) + character(len=*), dimension(:), intent(in) :: st + character(len=1), intent(in), optional :: delimiter +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=str_string_array_len(st)) :: s + + integer :: k, n + character(len=1) :: d + + if (present(delimiter)) then + d = delimiter + else + d = " " + endif + + n = 1 + do k = 1, size(st) - 1 + s(n:n+len(st(k))) = st(k)//d + n = n + len(st(k)) + 1 + enddo + s(n:) = st(k) +#endif + end function str_string_array + + pure function str_string_matrix(st, delimiter) result(s) + character(len=*), dimension(:, :), intent(in) :: st + character(len=1), intent(in), optional :: delimiter +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=str_string_matrix_len(st)) :: s + + integer :: j, k, n + character(len=1) :: d + + if (present(delimiter)) then + d = delimiter + else + d = " " + endif + + s(1:len(st)) = st(1,1) + n = len(st) + 1 + do j = 2, size(st, 1) + s(n:n+len(st)) = d//st(j,1) + n = n + len(st) + 1 + enddo + do k = 2, size(st, 2) + do j = 1, size(st, 1) + s(n:n+len(st(j,k))) = d//st(j,k) + n = n + len(st) + 1 + enddo + enddo +#endif + end function str_string_matrix + + pure function str_integer(i) result(s) + integer, intent(in) :: i +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=str_integer_len(i)) :: s + + integer :: b, ii, j, k, n + + b = 10 + + if (i < 0) then + s(1:1) = "-" + n = 2 + else + n = 1 + endif + ii = abs(i) + do k = len(s) - n, 0, -1 + j = ii/(b**k) + ii = ii - j*(b**k) + s(n:n) = digit(j+1:j+1) + n = n + 1 + enddo +#endif + end function str_integer + + pure function str_integer_fmt(i, fmt) result(s) + integer, intent(in) :: i + character(len=*), intent(in):: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=str_integer_fmt_len(i, fmt)) :: s + + character :: f + integer :: b, ii, j, k, n, ls + + if (len(fmt)>0) then + if (fmt(1:1)=="d") then + f = 'd' + b = 10 + elseif (fmt(1:1)=="x") then + f = 'x' + b = 16 + else + ! Undefined outcome + s = "" + return + endif + else + ! Undefined outcome + s = "" + return + endif + + ls = str_integer_base_len(i, b) + n = len(s) - ls + 1 + + if (i < 0) then + if (n>0) s(:n) = "-"//repeat("0", n-1) + n = n + 1 + else + if (n>1) s(:n) = repeat("0", n) + endif + + ii = abs(i) + do k = 1, -n + 1 + j = ii/(b**k) + ii = ii - j*(b**k) + n = n + 1 + enddo + do k = len(s) - n, 0, -1 + j = ii/(b**k) + ii = ii - j*(b**k) + s(n:n) = hexdigit(j+1:j+1) + n = n + 1 + enddo +#endif + end function str_integer_fmt + + pure function str_integer_array(ia) result(s) + integer, dimension(:), intent(in) :: ia +#ifdef DUMMYLIB + character(len=1) :: s +#else + character(len=len(ia, "d")) :: s + + integer :: j, k, n + + n = 1 + do k = 1, size(ia) - 1 + j = len(ia(k)) + s(n:n+j) = str(ia(k))//" " + n = n + j + 1 + enddo + s(n:) = str(ia(k)) +#endif + end function str_integer_array + + + function str_integer_array_fmt(ia, fmt) result(s) + integer, dimension(:), intent(in) :: ia + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ia, fmt)) :: s + + integer :: j, k, n + + n = 1 + do k = 1, size(ia) - 1 + j = len(ia(k), fmt) + s(n:n+j) = str(ia(k), fmt)//" " + n = n + j + 1 + enddo + s(n:) = str(ia(k), fmt) +#endif + end function str_integer_array_fmt + + pure function str_integer_matrix(ia) result(s) + integer, dimension(:,:), intent(in) :: ia +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ia, "d")) :: s + + integer :: j, k, n + + s(:len(ia(1,1))) = str(ia(1,1)) + n = len(ia(1,1)) + 1 + do j = 2, size(ia, 1) + s(n:n+len(ia(j,1))) = " "//str(ia(j,1)) + n = n + len(ia(j,1)) + 1 + enddo + do k = 2, size(ia, 2) + do j = 1, size(ia, 1) + s(n:n+len(ia(j,k))) = " "//str(ia(j,k)) + n = n + len(ia(j,k)) + 1 + enddo + enddo +#endif + end function str_integer_matrix + + + pure function str_integer_matrix_fmt(ia, fmt) result(s) + integer, dimension(:,:), intent(in) :: ia + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ia, fmt)) :: s + + integer :: j, k, n + + s(:len(ia(1,1), fmt)) = str(ia(1,1), fmt) + n = len(ia(1,1), fmt) + 1 + do j = 2, size(ia, 1) + s(n:n+len(ia(j,1), fmt)) = " "//str(ia(j,1), fmt) + n = n + len(ia(j,1), fmt) + 1 + enddo + do k = 2, size(ia, 2) + do j = 1, size(ia, 1) + s(n:n+len(ia(j,k), fmt)) = " "//str(ia(j,k), fmt) + n = n + len(ia(j,k), fmt) + 1 + enddo + enddo +#endif + end function str_integer_matrix_fmt + + pure function str_logical(l) result(s) + logical, intent(in) :: l +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else +! Pathscale 2.5 gets it wrong if we use merge here +! character(len=merge(4,5,l)) :: s +! And g95 (sep2007) cant resolve the generic here + character(len=str_logical_len(l)) :: s + + if (l) then + s="true" + else + s="false" + endif +#endif + end function str_logical + + pure function str_logical_array(la) result(s) + logical, dimension(:), intent(in) :: la +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(la)) :: s + + integer :: k, n + + n = 1 + do k = 1, size(la) - 1 + if (la(k)) then + s(n:n+3) = "true" + n = n + 5 + else + s(n:n+4) = "false" + n = n + 6 + endif + s(n-1:n-1) = " " + enddo + if (la(k)) then + s(n:) = "true" + else + s(n:) = "false" + endif +#endif + end function str_logical_array + + pure function str_logical_matrix(la) result(s) + logical, dimension(:,:), intent(in) :: la +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(la)) :: s + + integer :: j, k, n + + if (la(1,1)) then + s(:4) = "true" + n = 5 + else + s(:5) = "false" + n = 6 + endif + do j = 2, size(la, 1) + s(n:n) = " " + if (la(j,1)) then + s(n+1:n+4) = "true" + n = n + 5 + else + s(n+1:n+5) = "false" + n = n + 6 + endif + enddo + do k = 2, size(la, 2) + do j = 1, size(la, 1) + s(n:n) = " " + if (la(j,k)) then + s(n+1:n+4) = "true" + n = n + 5 + else + s(n+1:n+5) = "false" + n = n + 6 + endif + enddo + enddo +#endif + end function str_logical_matrix + +#ifndef DUMMYLIB + ! In order to convert real numbers to strings, we need to + ! perform an internal write - but how long will the + ! resultant string be? We don't know & there is no way + ! to discover for an arbitrary format. Therefore, + ! (if we have the capability; f95 or better) + ! we assume it will be less than 100 characters, write + ! it to a string of that length, then remove leading & + ! trailing whitespace. (this means that if the specified + ! format includes whitespace, this will be lost.) + ! + ! If we are working with an F90-only compiler, then + ! we cannot do this trick - the output string will + ! always be 100 chars in length, though we will remove + ! leading whitespace. + + + ! The standard Fortran format functions do not give us + ! enough control, so we write our own real number formatting + ! routines here. For each real type, we optionally take a + ! format like so: + ! "r" which will produce output without an exponent, + ! and digits after the decimal point. + ! or + ! "s": which implies scientific notation, with an + ! exponent, with significant figures. + ! If the integer is absent, then the precision will be + ! half of the number of significant figures available + ! for that real type. + ! The absence of a format implies scientific notation, with + ! the default precision. + + ! These routines are fairly imperfect - they are inaccurate for + ! the lower-end bits of the number, since they work by simple + ! multiplications by 10. + ! Also they will probably be orders of magnitude slower than library IO. + ! Ideally they'd be rewritten to convert from teh native format by + ! bit-twidding. Not sure how to do that portably though. + + ! The format specification could be done more nicely - but unfortunately + ! not in F95 due to *stupid* restrictions on specification expressions. + + ! And I wouldn't have to invent my own format specification if Fortran + ! had a proper IO library anyway. + +!FIXME Signed zero is not handled correctly; don't quite understand why. +!FIXME too much duplication between sp & dp, we should m4. + + pure function real_sp_str(x, sig) result(s) + real(sp), intent(in) :: x + integer, intent(in) :: sig + character(len=sig) :: s + ! make a string of numbers sig long of x. + integer :: e, i, j, k, n + real(sp) :: x_ + + if (sig < 1) then + s ="" + return + endif + + if (x == 0.0_sp) then + e = 1 + else + e = floor(log10(abs(x))) + endif + x_ = abs(x) + ! Have to do this next in a loop rather than just exponentiating in + ! order to avoid under/over-flow. + do i = 1, abs(e) + ! Have to multiply by 10^-e rather than divide by 10^e + ! to avoid rounding errors. + x_ = x_ * (10.0_sp**(-abs(e)/e)) + enddo + n = 1 + do k = sig - 2, 0, -1 + ! This baroque way of taking int() ensures the optimizer + ! stores it in j without keeping a different value in cache. + j = iachar(digit(int(x_)+1:int(x_)+1)) - 48 + if (j==10) then + ! This can happen if, on the previous cycle, int(x_) in + ! the line above gave a result approx. 1.0 less than + ! expected. + ! In this case we want to quit the cycle & just get 999... to the end + s(n:) = repeat("9", sig - n + 1) + return + endif + s(n:n) = digit(j+1:j+1) + n = n + 1 + x_ = (x_ - j) * 10.0_sp + enddo + j = nint(x_) + if (j == 10) then + ! Now round ... + s(n:n) = "9" + ! Are they all 9's? + i = verify(s, "9", .true.) + if (i == 0) then + s(1:1) = "!" + ! overflow + return + endif + j = index(digit, s(i:i)) + s(i:i) = digit(j+1:j+1) + s(i+1:) = repeat("0", sig - i + 1) + else + s(n:n) = digit(j+1:j+1) + endif + + end function real_sp_str + +#endif + + function str_real_sp_fmt_chk(x, fmt) result(s) + real(sp), intent(in) :: x + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(x, fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(x, fmt) + else + call FoX_error("Invalid format: "//fmt) + endif +#endif + end function str_real_sp_fmt_chk + +#ifndef DUMMYLIB + pure function str_real_sp_fmt(x, fmt) result(s) + real(sp), intent(in) :: x + character(len=*), intent(in) :: fmt + character(len=len(x, fmt)) :: s + + integer :: sig, dec + integer :: e, n + character(len=len(x, fmt)) :: num !this will always be enough memory. + + if (x == 0.0_sp) then + e = 0 + else + e = floor(log10(abs(x))) + endif + + if (x < 0.0_sp) then + s(1:1) = "-" + n = 2 + else + n = 1 + endif + + if (len(fmt) == 0) then + + sig = sig_sp + + num = real_sp_str(abs(x), sig) + if (num(1:1) == "!") then + e = e + 1 + num = "1"//repeat("0",len(num)-1) + endif + + if (sig == 1) then + s(n:n) = num + n = n + 1 + else + s(n:n+1) = num(1:1)//"." + s(n+2:n+sig) = num(2:) + n = n + sig + 1 + endif + + s(n:n) = "e" + s(n+1:) = str(e) + + elseif (fmt(1:1) == "s") then + + if (len(fmt) > 1) then + sig = str_to_int_10(fmt(2:)) + else + sig = sig_sp + endif + sig = max(sig, 1) + sig = min(sig, digits(1.0_sp)) + + num = real_sp_str(abs(x), sig) + if (num(1:1) == "!") then + e = e + 1 + num = "1"//repeat("0",len(num)-1) + endif + + if (sig == 1) then + s(n:n) = num + n = n + 1 + else + s(n:n+1) = num(1:1)//"." + s(n+2:n+sig) = num(2:) + n = n + sig + 1 + endif + + s(n:n) = "e" + s(n+1:) = str(e) + + elseif (fmt(1:1) == "r") then + + if (len(fmt) > 1) then + dec = str_to_int_10(fmt(2:)) + else + dec = sig_sp - e - 1 + endif + dec = min(dec, digits(1.0_sp)-e-1) + dec = max(dec, 0) + + if (e+dec+1 > 0) then + num = real_sp_str(abs(x), e+dec+1) + else + num = "" + endif + if (num(1:1) == "!") then + e = e + 1 + num = "1"//repeat("0",len(num)-1) + endif + + if (abs(x) >= 1.0_sp) then + s(n:n+e) = num(:e+1) + n = n + e + 1 + if (dec > 0) then + s(n:n) = "." + n = n + 1 + s(n:) = num(e+2:) + endif + else + s(n:n) = "0" + if (dec > 0) then + s(n+1:n+1) = "." + n = n + 2 + if (dec < -e-1) then + s(n:) = repeat("0", dec) + else + s(n:n-e-2) = repeat("0", max(-e-1,0)) + n = n - min(e,-1) - 1 + if (n <= len(s)) then + s(n:) = num + endif + endif + endif + endif + + endif + + end function str_real_sp_fmt +#endif + + pure function str_real_sp(x) result(s) + real(sp), intent(in) :: x +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(x)) :: s + + s = safestr(x, "") +#endif + end function str_real_sp + + pure function str_real_sp_array(xa) result(s) + real(sp), dimension(:), intent(in) :: xa +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(xa)) :: s + + integer :: j, k, n + + n = 1 + do k = 1, size(xa) - 1 + j = len(xa(k), "") + s(n:n+j) = safestr(xa(k), "")//" " + n = n + j + 1 + enddo + s(n:) = safestr(xa(k), "") +#endif + end function str_real_sp_array + +#ifndef DUMMYLIB + pure function str_real_sp_array_fmt(xa, fmt) result(s) + real(sp), dimension(:), intent(in) :: xa + character(len=*), intent(in) :: fmt + character(len=len(xa, fmt)) :: s + + integer :: j, k, n + + n = 1 + do k = 1, size(xa) - 1 + j = len(xa(k), fmt) + s(n:n+j) = safestr(xa(k), fmt)//" " + n = n + j + 1 + enddo + s(n:) = safestr(xa(k), fmt) + + end function str_real_sp_array_fmt +#endif + + function str_real_sp_array_fmt_chk(xa, fmt) result(s) + real(sp), dimension(:), intent(in) :: xa + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(xa, fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(xa, fmt) + else + call FoX_error("Invalid format: "//fmt) + endif +#endif + end function str_real_sp_array_fmt_chk + +#ifndef DUMMYLIB + pure function str_real_sp_matrix_fmt(xa, fmt) result(s) + real(sp), dimension(:,:), intent(in) :: xa + character(len=*), intent(in) :: fmt + character(len=len(xa,fmt)) :: s + + integer :: i, j, k, n + + i = len(xa(1,1), fmt) + s(:i) = safestr(xa(1,1), fmt) + n = i + 1 + do j = 2, size(xa, 1) + i = len(xa(j,1), fmt) + s(n:n+i) = " "//safestr(xa(j,1), fmt) + n = n + i + 1 + enddo + do k = 2, size(xa, 2) + do j = 1, size(xa, 1) + i = len(xa(j,k), fmt) + s(n:n+i) = " "//safestr(xa(j,k), fmt) + n = n + i + 1 + enddo + enddo + + end function str_real_sp_matrix_fmt +#endif + + function str_real_sp_matrix_fmt_chk(xa, fmt) result(s) + real(sp), dimension(:,:), intent(in) :: xa + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(xa,fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(xa, fmt) + else + call FoX_error("Invalid format: "//fmt) + end if +#endif + end function str_real_sp_matrix_fmt_chk + + pure function str_real_sp_matrix(xa) result(s) + real(sp), dimension(:,:), intent(in) :: xa +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(xa)) :: s + + s = safestr(xa, "") +#endif + end function str_real_sp_matrix + +#ifndef DUMMYLIB + pure function real_dp_str(x, sig) result(s) + real(dp), intent(in) :: x + integer, intent(in) :: sig + character(len=sig) :: s + ! make a string of numbers sig long of x. + integer :: e, i, j, k, n + real(dp) :: x_ + + if (sig < 1) then + s ="" + return + endif + + if (x == 0.0_dp) then + e = 1 + else + e = floor(log10(abs(x))) + endif + x_ = abs(x) + ! Have to do this next in a loop rather than just exponentiating in + ! order to avoid under/over-flow. + do i = 1, abs(e) + ! Have to multiply by 10^-e rather than divide by 10^e + ! to avoid rounding errors. + x_ = x_ * (10.0_dp**(-abs(e)/e)) + enddo + n = 1 + do k = sig - 2, 0, -1 + ! This baroque way of taking int() ensures the optimizer definitely + ! stores it in j without keeping a different value in cache. + j = iachar(digit(int(x_)+1:int(x_)+1)) - 48 + if (j==10) then + ! This can happen if, on the previous cycle, int(x_) in + ! the line above gave a result almost exactly 1.0 less than + ! expected - but FP arithmetic is not consistent. + ! In this case we want to quit the cycle & just get 999... to the end + s(n:) = repeat("9", sig - n + 1) + return + endif + s(n:n) = digit(j+1:j+1) + n = n + 1 + x_ = (x_ - j) * 10.0_dp + enddo + j = nint(x_) + if (j == 10) then + ! Now round ... + s(n:n) = "9" + i = verify(s, "9", .true.) + if (i == 0) then + s(1:1) = "!" + !overflow + return + endif + j = index(digit, s(i:i)) + s(i:i) = digit(j+1:j+1) + s(i+1:) = repeat("0", sig - i + 1) + else + s(n:n) = digit(j+1:j+1) + endif + + end function real_dp_str + + +#endif + + function str_real_dp_fmt_chk(x, fmt) result(s) + real(dp), intent(in) :: x + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(x, fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(x, fmt) + else + call FoX_error("Invalid format: "//fmt) + endif +#endif + end function str_real_dp_fmt_chk + +#ifndef DUMMYLIB + pure function str_real_dp_fmt(x, fmt) result(s) + real(dp), intent(in) :: x + character(len=*), intent(in) :: fmt + character(len=len(x, fmt)) :: s + + integer :: sig, dec + integer :: e, n + character(len=len(x, fmt)) :: num !this will always be enough memory. + + if (x == 0.0_dp) then + e = 0 + else + e = floor(log10(abs(x))) + endif + + if (x < 0.0_dp) then + s(1:1) = "-" + n = 2 + else + n = 1 + endif + + if (len(fmt) == 0) then + + sig = sig_dp + + num = real_dp_str(abs(x), sig) + if (num(1:1) == "!") then + e = e + 1 + num = "1"//repeat("0",len(num)-1) + endif + + if (sig == 1) then + s(n:n) = num + n = n + 1 + else + s(n:n+1) = num(1:1)//"." + s(n+2:n+sig) = num(2:) + n = n + sig + 1 + endif + + s(n:n) = "e" + s(n+1:) = safestr(e) + + elseif (fmt(1:1) == "s") then + + if (len(fmt) > 1) then + sig = str_to_int_10(fmt(2:)) + else + sig = sig_dp + endif + sig = max(sig, 1) + sig = min(sig, digits(1.0_dp)) + + num = real_dp_str(abs(x), sig) + if (num(1:1) == "!") then + e = e + 1 + num = "1"//repeat("0",len(num)-1) + endif + + if (sig == 1) then + s(n:n) = num + n = n + 1 + else + s(n:n+1) = num(1:1)//"." + s(n+2:n+sig) = num(2:) + n = n + sig + 1 + endif + + s(n:n) = "e" + s(n+1:) = safestr(e) + + elseif (fmt(1:1) == "r") then + + if (len(fmt) > 1) then + dec = str_to_int_10(fmt(2:)) + else + dec = sig_dp - e - 1 + endif + dec = min(dec, digits(1.0_dp)-e-1) + dec = max(dec, 0) + + if (e+dec+1 > 0) then + num = real_dp_str(abs(x), e+dec+1) + else + num = "" + endif + if (num(1:1) == "!") then + e = e + 1 + num = "1"//repeat("0",len(num)-1) + endif + + if (abs(x) >= 1.0_dp) then + s(n:n+e) = num(:e+1) + n = n + e + 1 + if (dec > 0) then + s(n:n) = "." + n = n + 1 + s(n:) = num(e+2:) + endif + else + s(n:n) = "0" + if (dec > 0) then + s(n+1:n+1) = "." + n = n + 2 + if (dec < -e-1) then + s(n:) = repeat("0", dec) + else + s(n:n-e-2) = repeat("0", max(-e-1,0)) + n = n - min(e,-1) - 1 + if (n <= len(s)) then + s(n:) = num + endif + endif + endif + endif + + endif + + end function str_real_dp_fmt + +#endif + + pure function str_real_dp(x) result(s) + real(dp), intent(in) :: x +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(x)) :: s + + s = safestr(x, "") +#endif + end function str_real_dp + + pure function str_real_dp_array(xa) result(s) + real(dp), dimension(:), intent(in) :: xa +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(xa)) :: s + + integer :: j, k, n + + n = 1 + do k = 1, size(xa) - 1 + j = len(xa(k), "") + s(n:n+j) = safestr(xa(k), "")//" " + n = n + j + 1 + enddo + s(n:) = safestr(xa(k)) +#endif + end function str_real_dp_array + +#ifndef DUMMYLIB + pure function str_real_dp_array_fmt(xa, fmt) result(s) + real(dp), dimension(:), intent(in) :: xa + character(len=*), intent(in) :: fmt + character(len=len(xa, fmt)) :: s + + integer :: j, k, n + + n = 1 + do k = 1, size(xa) - 1 + j = len(xa(k), fmt) + s(n:n+j) = safestr(xa(k), fmt)//" " + n = n + j + 1 + enddo + s(n:) = safestr(xa(k), fmt) + + end function str_real_dp_array_fmt +#endif + + function str_real_dp_array_fmt_chk(xa, fmt) result(s) + real(dp), dimension(:), intent(in) :: xa + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(xa, fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(xa, fmt) + else + call FoX_error("Invalid format: "//fmt) + endif +#endif + end function str_real_dp_array_fmt_chk + +#ifndef DUMMYLIB + function str_real_dp_matrix_fmt(xa, fmt) result(s) + real(dp), dimension(:,:), intent(in) :: xa + character(len=*), intent(in) :: fmt + character(len=len(xa,fmt)) :: s + + integer :: i, j, k, n + + i = len(xa(1,1), fmt) + s(:i) = safestr(xa(1,1), fmt) + n = i + 1 + do j = 2, size(xa, 1) + i = len(xa(j,1), fmt) + s(n:n+i) = " "//safestr(xa(j,1), fmt) + n = n + i + 1 + enddo + do k = 2, size(xa, 2) + do j = 1, size(xa, 1) + i = len(xa(j,k), fmt) + s(n:n+i) = " "//safestr(xa(j,k), fmt) + n = n + i + 1 + enddo + enddo + + end function str_real_dp_matrix_fmt +#endif + + function str_real_dp_matrix_fmt_chk(xa, fmt) result(s) + real(dp), dimension(:,:), intent(in) :: xa + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(xa,fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(xa, fmt) + else + call FoX_error("Invalid format: "//fmt) + end if +#endif + end function str_real_dp_matrix_fmt_chk + + function str_real_dp_matrix(xa) result(s) + real(dp), dimension(:,:), intent(in) :: xa +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(xa)) :: s + + s = safestr(xa, "") +#endif + end function str_real_dp_matrix + +! For complex numbers, there's not really much prior art, so +! we use the easy solution: a+bi, where a & b are real numbers +! as output above. + + function str_complex_sp_fmt_chk(c, fmt) result(s) + complex(sp), intent(in) :: c + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(c, fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(c, fmt) + else + call FoX_error("Invalid format: "//fmt) + endif +#endif + end function str_complex_sp_fmt_chk + +#ifndef DUMMYLIB + pure function str_complex_sp_fmt(c, fmt) result(s) + complex(sp), intent(in) :: c + character(len=*), intent(in) :: fmt + character(len=len(c, fmt)) :: s + + real(sp) :: re, im + integer :: i + re = real(c) + im = aimag(c) + i = len(re, fmt) + s(:i+4) = "("//safestr(re, fmt)//")+i" + s(i+5:)="("//safestr(im,fmt)//")" + end function str_complex_sp_fmt +#endif + + pure function str_complex_sp(c) result(s) + complex(sp), intent(in) :: c +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(c, "")) :: s + + s = safestr(c, "") +#endif + end function str_complex_sp + +#ifndef DUMMYLIB + pure function str_complex_sp_array_fmt(ca, fmt) result(s) + complex(sp), dimension(:), intent(in) :: ca + character(len=*), intent(in) :: fmt + character(len=len(ca, fmt)) :: s + + integer :: i, n + + s(1:len(ca(1), fmt)) = safestr(ca(1), fmt) + n = len(ca(1), fmt)+1 + do i = 2, size(ca) + s(n:n+len(ca(i), fmt)) = " "//safestr(ca(i), fmt) + n = n + len(ca(i), fmt)+1 + enddo + end function str_complex_sp_array_fmt +#endif + + function str_complex_sp_array_fmt_chk(ca, fmt) result(s) + complex(sp), dimension(:), intent(in) :: ca + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ca, fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(ca, fmt) + else + call FoX_error("Invalid format: "//fmt) + endif +#endif + end function str_complex_sp_array_fmt_chk + + pure function str_complex_sp_array(ca) result(s) + complex(sp), dimension(:), intent(in) :: ca +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ca)) :: s + + s = safestr(ca, "") +#endif + end function str_complex_sp_array + +#ifndef DUMMYLIB + pure function str_complex_sp_matrix_fmt(ca, fmt) result(s) + complex(sp), dimension(:, :), intent(in) :: ca + character(len=*), intent(in) :: fmt + character(len=len(ca, fmt)) :: s + + integer :: i, j, k, n + + i = len(ca(1,1), fmt) + s(:i) = safestr(ca(1,1), fmt) + n = i + 1 + do j = 2, size(ca, 1) + i = len(ca(j,1), fmt) + s(n:n+i) = " "//safestr(ca(j,1), fmt) + n = n + i + 1 + enddo + do k = 2, size(ca, 2) + do j = 1, size(ca, 1) + i = len(ca(j,k), fmt) + s(n:n+i) = " "//safestr(ca(j,k), fmt) + n = n + i + 1 + enddo + enddo + + end function str_complex_sp_matrix_fmt +#endif + + function str_complex_sp_matrix_fmt_chk(ca, fmt) result(s) + complex(sp), dimension(:, :), intent(in) :: ca + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ca, fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(ca, fmt) + else + call FoX_error("Invalid format: "//fmt) + endif +#endif + end function str_complex_sp_matrix_fmt_chk + + pure function str_complex_sp_matrix(ca) result(s) + complex(sp), dimension(:, :), intent(in) :: ca +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ca)) :: s + + s = safestr(ca, "") +#endif + end function str_complex_sp_matrix + + function str_complex_dp_fmt_chk(c, fmt) result(s) + complex(dp), intent(in) :: c + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(c, fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(c, fmt) + else + call FoX_error("Invalid format: "//fmt) + endif +#endif + end function str_complex_dp_fmt_chk + +#ifndef DUMMYLIB + pure function str_complex_dp_fmt(c, fmt) result(s) + complex(dp), intent(in) :: c + character(len=*), intent(in) :: fmt + character(len=len(c, fmt)) :: s + + real(dp) :: re, im + integer :: i + re = real(c) + im = aimag(c) + i = len(re, fmt) + s(:i+4) = "("//safestr(re, fmt)//")+i" + s(i+5:)="("//safestr(im,fmt)//")" + end function str_complex_dp_fmt +#endif + + pure function str_complex_dp(c) result(s) + complex(dp), intent(in) :: c +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(c, "")) :: s + + s = safestr(c, "") +#endif + end function str_complex_dp + +#ifndef DUMMYLIB + pure function str_complex_dp_array_fmt(ca, fmt) result(s) + complex(dp), dimension(:), intent(in) :: ca + character(len=*), intent(in) :: fmt + character(len=len(ca, fmt)) :: s + + integer :: i, n + + s(1:len(ca(1), fmt)) = safestr(ca(1), fmt) + n = len(ca(1), fmt)+1 + do i = 2, size(ca) + s(n:n+len(ca(i), fmt)) = " "//safestr(ca(i), fmt) + n = n + len(ca(i), fmt)+1 + enddo + end function str_complex_dp_array_fmt +#endif + + function str_complex_dp_array_fmt_chk(ca, fmt) result(s) + complex(dp), dimension(:), intent(in) :: ca + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ca, fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(ca, fmt) + else + call FoX_error("Invalid format: "//fmt) + endif +#endif + end function str_complex_dp_array_fmt_chk + + pure function str_complex_dp_array(ca) result(s) + complex(dp), dimension(:), intent(in) :: ca +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ca)) :: s + + s = safestr(ca, "") +#endif + end function str_complex_dp_array + +#ifndef DUMMYLIB + pure function str_complex_dp_matrix_fmt(ca, fmt) result(s) + complex(dp), dimension(:, :), intent(in) :: ca + character(len=*), intent(in) :: fmt + character(len=len(ca, fmt)) :: s + + integer :: i, j, k, n + + i = len(ca(1,1), fmt) + s(:i) = safestr(ca(1,1), fmt) + n = i + 1 + do j = 2, size(ca, 1) + i = len(ca(j,1), fmt) + s(n:n+i) = " "//safestr(ca(j,1), fmt) + n = n + i + 1 + enddo + do k = 2, size(ca, 2) + do j = 1, size(ca, 1) + i = len(ca(j,k), fmt) + s(n:n+i) = " "//safestr(ca(j,k), fmt) + n = n + i + 1 + enddo + enddo + + end function str_complex_dp_matrix_fmt +#endif + + function str_complex_dp_matrix_fmt_chk(ca, fmt) result(s) + complex(dp), dimension(:, :), intent(in) :: ca + character(len=*), intent(in) :: fmt +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ca, fmt)) :: s + + if (checkFmt(fmt)) then + s = safestr(ca, fmt) + else + call FoX_error("Invalid format: "//fmt) + endif +#endif + end function str_complex_dp_matrix_fmt_chk + + pure function str_complex_dp_matrix(ca) result(s) + complex(dp), dimension(:, :), intent(in) :: ca +#ifdef DUMMYLIB + character(len=1) :: s + s = " " +#else + character(len=len(ca)) :: s + + s = safestr(ca, "") +#endif + end function str_complex_dp_matrix + +#ifndef DUMMYLIB + pure function checkFmt(fmt) result(good) + character(len=*), intent(in) :: fmt + logical :: good + + ! should be ([rs]\d*)? + + if (len(fmt) > 0) then + if (fmt(1:1) == "r" .or. fmt(1:1) == "s") then + if (len(fmt) > 1) then + good = (verify(fmt(2:), digit) == 0) + else + good = .true. + endif + else + good = .false. + endif + else + good = .true. + endif + end function checkFmt +#endif + + pure function concat_str_int(s1, s2) result(s3) + character(len=*), intent(in) :: s1 + integer, intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = s1//str(s2) +#endif + end function concat_str_int + pure function concat_int_str(s1, s2) result(s3) + integer, intent(in) :: s1 + character(len=*), intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = str(s1)//s2 +#endif + end function concat_int_str + + pure function concat_str_logical(s1, s2) result(s3) + character(len=*), intent(in) :: s1 + logical, intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = s1//str(s2) +#endif + end function concat_str_logical + pure function concat_logical_str(s1, s2) result(s3) + logical, intent(in) :: s1 + character(len=*), intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = str(s1)//s2 +#endif + end function concat_logical_str + + pure function concat_str_real_sp(s1, s2) result(s3) + character(len=*), intent(in) :: s1 + real(sp), intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = s1//str(s2) +#endif + end function concat_str_real_sp + pure function concat_real_sp_str(s1, s2) result(s3) + real(sp), intent(in) :: s1 + character(len=*), intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = str(s1)//s2 +#endif + end function concat_real_sp_str + + pure function concat_str_real_dp(s1, s2) result(s3) + character(len=*), intent(in) :: s1 + real(dp), intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = s1//str(s2) +#endif + end function concat_str_real_dp + pure function concat_real_dp_str(s1, s2) result(s3) + real(dp), intent(in) :: s1 + character(len=*), intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = str(s1)//s2 +#endif + end function concat_real_dp_str + + pure function concat_str_complex_sp(s1, s2) result(s3) + character(len=*), intent(in) :: s1 + complex(sp), intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = s1//str(s2) +#endif + end function concat_str_complex_sp + pure function concat_complex_sp_str(s1, s2) result(s3) + complex(sp), intent(in) :: s1 + character(len=*), intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = str(s1)//s2 +#endif + end function concat_complex_sp_str + + pure function concat_str_complex_dp(s1, s2) result(s3) + character(len=*), intent(in) :: s1 + complex(dp), intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = s1//str(s2) +#endif + end function concat_str_complex_dp + pure function concat_complex_dp_str(s1, s2) result(s3) + complex(dp), intent(in) :: s1 + character(len=*), intent(in) :: s2 +#ifdef DUMMYLIB + character(len=1) :: s3 + s3 = " " +#else + character(len=len(s1)+len(s2)) :: s3 + s3 = str(s1)//s2 +#endif + end function concat_complex_dp_str + +end module fox_m_fsys_format diff --git a/src/xml/fsys/fox_m_fsys_parse_input.F90 b/src/xml/fsys/fox_m_fsys_parse_input.F90 new file mode 100644 index 000000000..45551c1d6 --- /dev/null +++ b/src/xml/fsys/fox_m_fsys_parse_input.F90 @@ -0,0 +1,2281 @@ +module fox_m_fsys_parse_input + + use fox_m_fsys_realtypes, only: sp, dp + + implicit none + private + + character(len=1), parameter :: SPACE = achar(32) + character(len=1), parameter :: NEWLINE = achar(10) + character(len=1), parameter :: CARRIAGE_RETURN = achar(13) + character(len=1), parameter :: TAB = achar(9) + character(len=*), parameter :: whitespace = & + SPACE//NEWLINE//CARRIAGE_RETURN//TAB + + interface rts + module procedure scalartostring + module procedure scalartological + module procedure scalartointeger + module procedure scalartolong + module procedure scalartorealsp + module procedure scalartorealdp + module procedure scalartocomplexsp + module procedure scalartocomplexdp + module procedure arraytostring + module procedure arraytological + module procedure arraytointeger + module procedure arraytorealsp + module procedure arraytorealdp + module procedure arraytocomplexsp + module procedure arraytocomplexdp + module procedure matrixtostring + module procedure matrixtological + module procedure matrixtointeger + module procedure matrixtorealsp + module procedure matrixtorealdp + module procedure matrixtocomplexsp + module procedure matrixtocomplexdp + end interface + + public :: rts + +contains + + subroutine scalartostring(s, data, separator, csv, num, iostat) + character(len=*), intent(in) :: s + character(len=*), intent(out) :: data + character, intent(in), optional :: separator + logical, intent(in), optional :: csv + integer, intent(out), optional :: num, iostat +#ifndef DUMMYLIB + logical :: bracketed + integer :: i, j, ij, k, s_i, err, ios, length + real :: r, c + + character(len=len(s)) :: s2 + logical :: csv_, eof, sp + integer :: m + + csv_ = .false. + if (present(csv)) then + csv_ = csv + endif + + s_i = 1 + err = 0 + eof = .false. + data = "" + ij = 0 + length = 1 + loop: do + if (csv_) then + if (s_i>len(s)) then + data = "" + ij = ij + 1 + exit loop + endif + k = verify(s(s_i:), achar(10)//achar(13)) + if (k==0) then + data = "" + ij = ij + 1 + exit loop + elseif (s(s_i+k-1:s_i+k-1)=="""") then + ! we have a quote-delimited string; + s_i = s_i + k + s2 = "" + quote: do + k = index(s(s_i:), """") + if (k==0) then + err = 2 + exit loop + endif + k = s_i + k - 1 + s2(m:) = s(s_i:k) + m = m + (k-s_i+1) + k = k + 2 + if (k>len(s)) then + err = 2 + exit loop + endif + if (s(k:k)/="""") exit + s_i = k + 1 + if (s_i > len(s)) then + err = 2 + exit loop + endif + m = m + 1 + s2(m:m) = """" + enddo quote + data = s2 + k = scan(s(s_i:), whitespace) + if (k==0) then + err = 2 + exit loop + endif + else + s_i = s_i + k - 1 + k = scan(s(s_i:), achar(10)//achar(13)//",") + if (k==0) then + eof = .true. + k = len(s) + else + if (ij+1==length.and.s(s_i+k-1:s_i+k-1)==",") err = 1 + k = s_i + k - 2 + endif + data = s(s_i:k) + if (index(data, """")/=0) then + err = 2 + exit loop + endif + endif + ij = ij + 1 + s_i = k + 2 + if (eof) exit loop + + if (present(num)) num = ij + if (ijlen(s)) then + err = 2 + exit loop + endif + k = verify(s(s_i+1:), whitespace) + s_i = s_i + k - 1 + endif + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + if (s(s_i:k)=="true".or.s(s_i:k)=="1") then + data = .true. + elseif (s(s_i:k)=="false".or.s(s_i:k)=="0") then + data = .false. + else + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(s)) then + err = 2 + exit loop + endif + k = verify(s(s_i+1:), whitespace) + s_i = s_i + k - 1 + endif + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + read(s(s_i:k), *, iostat=ios) data + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(s)) then + err = 2 + exit loop + endif + k = verify(s(s_i+1:), whitespace) + s_i = s_i + k - 1 + endif + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + read(s(s_i:k), *, iostat=ios) data + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(s)) then + err = 2 + exit loop + endif + k = verify(s(s_i+1:), whitespace) + s_i = s_i + k - 1 + endif + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + read(s(s_i:k), *, iostat=ios) data + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(s)) then + err = 2 + exit loop + endif + k = verify(s(s_i+1:), whitespace) + s_i = s_i + k - 1 + endif + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + read(s(s_i:k), *, iostat=ios) data + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(s)) then + err = 2 + exit loop + endif + else + s_i = k + 2 + endif + if (bracketed) then + k = index(s(s_i:), ")") + if (k==0) then + err = 2 + exit loop + endif + k = s_i + k - 2 + else + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + endif + read(s(s_i:k), *, iostat=ios) c + if (ios/=0) then + err = 2 + exit loop + endif + data = cmplx(r, c) + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(s)) then + err = 2 + exit loop + endif + else + s_i = k + 2 + endif + if (bracketed) then + k = index(s(s_i:), ")") + if (k==0) then + err = 2 + exit loop + endif + k = s_i + k - 2 + else + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + endif + read(s(s_i:k), *, iostat=ios) c + if (ios/=0) then + err = 2 + exit loop + endif + data = cmplx(r, c) + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(s)) then + data(i) = "" + ij = ij + 1 + exit loop + endif + k = verify(s(s_i:), achar(10)//achar(13)) + if (k==0) then + data(i) = "" + ij = ij + 1 + exit loop + elseif (s(s_i+k-1:s_i+k-1)=="""") then + ! we have a quote-delimited string; + s_i = s_i + k + s2 = "" + quote: do + k = index(s(s_i:), """") + if (k==0) then + err = 2 + exit loop + endif + k = s_i + k - 1 + s2(m:) = s(s_i:k) + m = m + (k-s_i+1) + k = k + 2 + if (k>len(s)) then + err = 2 + exit loop + endif + if (s(k:k)/="""") exit + s_i = k + 1 + if (s_i > len(s)) then + err = 2 + exit loop + endif + m = m + 1 + s2(m:m) = """" + enddo quote + data(i) = s2 + k = scan(s(s_i:), whitespace) + if (k==0) then + err = 2 + exit loop + endif + else + s_i = s_i + k - 1 + k = scan(s(s_i:), achar(10)//achar(13)//",") + if (k==0) then + eof = .true. + k = len(s) + else + if (ij+1==length.and.s(s_i+k-1:s_i+k-1)==",") err = 1 + k = s_i + k - 2 + endif + data(i) = s(s_i:k) + if (index(data(i), """")/=0) then + err = 2 + exit loop + endif + endif + ij = ij + 1 + s_i = k + 2 + if (eof) exit loop + + else + if (present(separator)) then + k = index(s(s_i:), separator) + else + k = verify(s(s_i:), whitespace) + if (k==0) exit loop + s_i = s_i + k - 1 + k = scan(s(s_i:), whitespace) + endif + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + data(i) = s(s_i:k) + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + endif + end do loop + + if (present(num)) num = ij + if (ij=0) & + err = 1 + else + if (verify(s(s_i:), whitespace)/=0) & + err = 1 + endif + endif + + if (present(iostat)) then + iostat = err + else + select case (err) + case(-1) + write(0, *) "Error in arraytostring" + write(0, *) "Too few elements found" + stop + case(1) + write(0, *) "Error in arraytostring" + write(0, *) "Too many elements found" + stop + case(2) + write(0, *) "Error in arraytostring" + write(0, *) "Malformed input" + stop + end select + end if + +#else + data = "" +#endif + end subroutine arraytostring + + subroutine matrixtostring(s, data, separator, csv, num, iostat) + character(len=*) :: data(:,:) + character, intent(in), optional :: separator + logical, intent(in), optional :: csv + character(len=*), intent(in) :: s + integer, intent(out), optional :: num + integer, intent(out), optional :: iostat + +#ifndef DUMMYLIB + logical :: bracketed + integer :: i, j, ij, k, s_i, err, ios, length + real :: r, c + + character(len=len(s)) :: s2 + logical :: csv_, eof + integer :: m + + csv_ = .false. + if (present(csv)) then + if (csv) csv_ = csv + endif + + s_i = 1 + err = 0 + eof = .false. + data = "" + ij = 0 + length = size(data) + loop: do j = 1, size(data, 2) + do i = 1, size(data, 1) + if (csv_) then + if (s_i>len(s)) then + data(i, j) = "" + ij = ij + 1 + exit loop + endif + k = verify(s(s_i:), achar(10)//achar(13)) + if (k==0) then + data(i, j) = "" + ij = ij + 1 + exit loop + elseif (s(s_i+k-1:s_i+k-1)=="""") then + ! we have a quote-delimited string; + s_i = s_i + k + s2 = "" + quote: do + k = index(s(s_i:), """") + if (k==0) then + err = 2 + exit loop + endif + k = s_i + k - 1 + s2(m:) = s(s_i:k) + m = m + (k-s_i+1) + k = k + 2 + if (k>len(s)) then + err = 2 + exit loop + endif + if (s(k:k)/="""") exit + s_i = k + 1 + if (s_i > len(s)) then + err = 2 + exit loop + endif + m = m + 1 + s2(m:m) = """" + enddo quote + data(i, j) = s2 + k = scan(s(s_i:), whitespace) + if (k==0) then + err = 2 + exit loop + endif + else + s_i = s_i + k - 1 + k = scan(s(s_i:), achar(10)//achar(13)//",") + if (k==0) then + eof = .true. + k = len(s) + else + if (ij+1==length.and.s(s_i+k-1:s_i+k-1)==",") err = 1 + k = s_i + k - 2 + endif + data(i, j) = s(s_i:k) + if (index(data(i, j), """")/=0) then + err = 2 + exit loop + endif + endif + ij = ij + 1 + s_i = k + 2 + if (eof) exit loop + else + if (present(separator)) then + k = index(s(s_i:), separator) + else + k = verify(s(s_i:), whitespace) + if (k==0) exit loop + s_i = s_i + k - 1 + k = scan(s(s_i:), whitespace) + endif + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + data(i, j) = s(s_i:k) + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + endif + end do + end do loop + + if (present(num)) num = ij + if (ij=0) & + err = 1 + else + if (verify(s(s_i:), whitespace)/=0) & + err = 1 + endif + endif + + if (present(iostat)) then + iostat = err + else + select case (err) + case(-1) + write(0, *) "Error in matrixtostring" + write(0, *) "Too few elements found" + stop + case(1) + write(0, *) "Error in matrixtostring" + write(0, *) "Too many elements found" + stop + case(2) + write(0, *) "Error in matrixtostring" + write(0, *) "Malformed input" + stop + end select + end if + +#else + data = "" +#endif + end subroutine matrixtostring + + subroutine arraytological(s, data, num, iostat) + logical, intent(out) :: data(:) + character(len=*), intent(in) :: s + integer, intent(out), optional :: num + integer, intent(out), optional :: iostat + +#ifndef DUMMYLIB + logical :: bracketed + integer :: i, j, ij, k, s_i, err, ios, length + real :: r, c + + + s_i = 1 + err = 0 + data = .false. + ij = 0 + length = size(data) + loop: do i = 1, size(data) + k = verify(s(s_i:), whitespace) + if (k==0) exit loop + s_i = s_i + k - 1 + if (s(s_i:s_i)==",") then + if (s_i+1>len(s)) then + err = 2 + exit loop + endif + k = verify(s(s_i+1:), whitespace) + s_i = s_i + k - 1 + endif + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + if (s(s_i:k)=="true".or.s(s_i:k)=="1") then + data(i) = .true. + elseif (s(s_i:k)=="false".or.s(s_i:k)=="0") then + data(i) = .false. + else + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(s)) then + err = 2 + exit loop + endif + k = verify(s(s_i+1:), whitespace) + s_i = s_i + k - 1 + endif + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + if (s(s_i:k)=="true".or.s(s_i:k)=="1") then + data(i, j) = .true. + elseif (s(s_i:k)=="false".or.s(s_i:k)=="0") then + data(i, j) = .false. + else + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do + end do loop + + if (present(num)) num = ij + if (ijlen(s)) then + err = 2 + exit loop + endif + k = verify(s(s_i+1:), whitespace) + s_i = s_i + k - 1 + endif + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + read(s(s_i:k), *, iostat=ios) data(i) + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(s)) then + err = 2 + exit loop + endif + k = verify(s(s_i+1:), whitespace) + s_i = s_i + k - 1 + endif + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + read(s(s_i:k), *, iostat=ios) data(i, j) + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do + end do loop + + if (present(num)) num = ij + if (ijlen(s)) then + err = 2 + exit loop + endif + k = verify(s(s_i+1:), whitespace) + s_i = s_i + k - 1 + endif + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + read(s(s_i:k), *, iostat=ios) data(i) + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(s)) then + err = 2 + exit loop + endif + k = verify(s(s_i+1:), whitespace) + s_i = s_i + k - 1 + endif + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + read(s(s_i:k), *, iostat=ios) data(i, j) + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do + end do loop + + if (present(num)) num = ij + if (ijlen(s)) then + err = 2 + exit loop + endif + k = verify(s(s_i+1:), whitespace) + s_i = s_i + k - 1 + endif + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + read(s(s_i:k), *, iostat=ios) data(i) + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(s)) then + err = 2 + exit loop + endif + k = verify(s(s_i+1:), whitespace) + s_i = s_i + k - 1 + endif + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + read(s(s_i:k), *, iostat=ios) data(i, j) + if (ios/=0) then + err = 2 + exit loop + endif + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do + end do loop + + if (present(num)) num = ij + if (ijlen(s)) then + err = 2 + exit loop + endif + else + s_i = k + 2 + endif + if (bracketed) then + k = index(s(s_i:), ")") + if (k==0) then + err = 2 + exit loop + endif + k = s_i + k - 2 + else + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + endif + read(s(s_i:k), *, iostat=ios) c + if (ios/=0) then + err = 2 + exit loop + endif + data(i) = cmplx(r, c) + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(s)) then + err = 2 + exit loop + endif + else + s_i = k + 2 + endif + if (bracketed) then + k = index(s(s_i:), ")") + if (k==0) then + err = 2 + exit loop + endif + k = s_i + k - 2 + else + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + endif + read(s(s_i:k), *, iostat=ios) c + if (ios/=0) then + err = 2 + exit loop + endif + data(i, j) = cmplx(r, c) + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do + end do loop + + if (present(num)) num = ij + if (ijlen(s)) then + err = 2 + exit loop + endif + else + s_i = k + 2 + endif + if (bracketed) then + k = index(s(s_i:), ")") + if (k==0) then + err = 2 + exit loop + endif + k = s_i + k - 2 + else + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + endif + read(s(s_i:k), *, iostat=ios) c + if (ios/=0) then + err = 2 + exit loop + endif + data(i) = cmplx(r, c) + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do loop + + if (present(num)) num = ij + if (ijlen(s)) then + err = 2 + exit loop + endif + else + s_i = k + 2 + endif + if (bracketed) then + k = index(s(s_i:), ")") + if (k==0) then + err = 2 + exit loop + endif + k = s_i + k - 2 + else + k = scan(s(s_i:), whitespace//",") + if (k==0) then + k = len(s) + else + k = s_i + k - 2 + endif + endif + read(s(s_i:k), *, iostat=ios) c + if (ios/=0) then + err = 2 + exit loop + endif + data(i, j) = cmplx(r, c) + ij = ij + 1 + s_i = k + 2 + if (ijlen(s)) exit loop + + end do + end do loop + + if (present(num)) num = ij + if (ij0) then + s(i:i) = lowerAlphabet(n:n) + else + s(i:i) = s_in(i:i) + endif + enddo + + end function toLower + +#endif +end module fox_m_fsys_string diff --git a/src/xml/fsys/fox_m_fsys_string_list.F90 b/src/xml/fsys/fox_m_fsys_string_list.F90 new file mode 100644 index 000000000..ecf407483 --- /dev/null +++ b/src/xml/fsys/fox_m_fsys_string_list.F90 @@ -0,0 +1,191 @@ +module fox_m_fsys_string_list +#ifndef DUMMYLIB + + use fox_m_fsys_array_str, only: str_vs, vs_str_alloc + implicit none + private + + type string_t + character, pointer :: s(:) => null() + end type string_t + + type string_list + type(string_t), pointer :: list(:) => null() + end type string_list + + public :: string_t + public :: string_list + + public :: init_string_list + public :: destroy_string_list + public :: add_string + public :: remove_last_string + public :: get_last_string + public :: tokenize_to_string_list + public :: tokenize_and_add_strings + public :: registered_string + + interface destroy + module procedure destroy_string_list + end interface + + public :: destroy + +contains + + subroutine init_string_list(s_list) + type(string_list), intent(inout) :: s_list + + allocate(s_list%list(0)) + end subroutine init_string_list + + subroutine destroy_string_list(s_list) + type(string_list), intent(inout) :: s_list + + integer :: i + + if (associated(s_list%list)) then + do i = 1, ubound(s_list%list, 1) + deallocate(s_list%list(i)%s) + enddo + deallocate(s_list%list) + endif + end subroutine destroy_string_list + + subroutine add_string(s_list, s) + type(string_list), intent(inout) :: s_list + character(len=*), intent(in) :: s + + integer :: i + type(string_t), pointer :: temp(:) + + temp => s_list%list + allocate(s_list%list(size(temp)+1)) + do i = 1, size(temp) + s_list%list(i)%s => temp(i)%s + enddo + deallocate(temp) + s_list%list(i)%s => vs_str_alloc(s) + end subroutine add_string + + subroutine remove_last_string(s_list) + type(string_list), intent(inout) :: s_list + + integer :: i + type(string_t), pointer :: temp(:) + + temp => s_list%list + allocate(s_list%list(size(temp)-1)) + do i = 1, size(temp)-1 + s_list%list(i)%s => temp(i)%s + enddo + deallocate(temp) + + end subroutine remove_last_string + + function get_last_string(s_list) result(s) + type(string_list), intent(in) :: s_list + character(len=size(s_list%list(size(s_list%list))%s)) :: s + + s = str_vs(s_list%list(size(s_list%list))%s) + end function get_last_string + + function tokenize_to_string_list(s) result(s_list) + character(len=*), intent(in) :: s + type(string_list) :: s_list + + ! tokenize a whitespace-separated list of strings + ! and place results in a string list + + character(len=*), parameter :: & + WHITESPACE = achar(9)//achar(10)//achar(13)//achar(32) + integer :: i, j + + call init_string_list(s_list) + + i = verify(s, WHITESPACE) + if (i==0) return + j = scan(s(i:), WHITESPACE) + if (j==0) then + j = len(s) + else + j = i + j - 2 + endif + do + call add_string(s_list, s(i:j)) + i = j + 1 + j = verify(s(i:), WHITESPACE) + if (j==0) exit + i = i + j - 1 + j = scan(s(i:), WHITESPACE) + if (j==0) then + j = len(s) + else + j = i + j - 2 + endif + enddo + + end function tokenize_to_string_list + + function registered_string(s_list, s) result(p) + type(string_list), intent(in) :: s_list + character(len=*), intent(in) :: s + logical :: p + + integer :: i + + p = .false. + do i = 1, size(s_list%list) + if (str_vs(s_list%list(i)%s)//"x"==s//"x") then + p = .true. + exit + endif + enddo + end function registered_string + + subroutine tokenize_and_add_strings(s_list, s, uniquify) + type(string_list), intent(inout) :: s_list + character(len=*), intent(in) :: s + logical, intent(in), optional :: uniquify + + ! tokenize a whitespace-separated list of strings + ! and place results in the given string list + + character(len=*), parameter :: & + WHITESPACE = achar(9)//achar(10)//achar(13)//achar(32) + integer :: i, j + logical :: uniquify_ + + if (present(uniquify)) then + uniquify_ = uniquify + else + uniquify_ = .false. + endif + + i = verify(s, WHITESPACE) + if (i==0) return + j = scan(s(i:), WHITESPACE) + if (j==0) then + j = len(s) + else + j = i + j - 2 + endif + do + if (uniquify_.and..not.registered_string(s_list, s(i:j))) & + call add_string(s_list, s(i:j)) + i = j + 1 + j = verify(s(i:), WHITESPACE) + if (j==0) exit + i = i + j - 1 + j = scan(s(i:), WHITESPACE) + if (j==0) then + j = len(s) + else + j = i + j - 2 + endif + enddo + + end subroutine tokenize_and_add_strings + +#endif +end module fox_m_fsys_string_list diff --git a/src/xml/fsys/fox_m_fsys_varstr.F90 b/src/xml/fsys/fox_m_fsys_varstr.F90 new file mode 100644 index 000000000..52efa5fde --- /dev/null +++ b/src/xml/fsys/fox_m_fsys_varstr.F90 @@ -0,0 +1,254 @@ +module fox_m_fsys_varstr + implicit none + + private + + public :: varstr + public :: init_varstr + public :: destroy_varstr + public :: varstr_len + public :: is_varstr_empty + public :: set_varstr_empty + public :: is_varstr_null + public :: set_varstr_null + public :: vs_varstr_alloc + public :: move_varstr_vs + public :: move_varstr_varstr + public :: str_varstr + public :: append_varstr + public :: varstr_str + public :: varstr_vs + public :: equal_varstr_str + public :: equal_varstr_varstr + + ! Allocation step in which the data within varstr will be allocated + integer, parameter :: VARSTR_INIT_SIZE=1024 + integer, parameter :: VARSTR_ALLOC_SIZE=1024 + + ! Variable size string type. + ! It is used for token field, so that it can be grown + ! by one character at a time without incurring constant + ! penalty on allocating/deallocating vs data. + ! See functions and subroutines at the end of this module. + type varstr + private + character, dimension(:), pointer :: data + integer :: length + end type varstr + +contains + +! Initialise varstr type. The string is initialised as null (i.e. invalid) +subroutine init_varstr(vstr) + type(varstr), intent(inout) :: vstr + allocate(vstr%data(VARSTR_INIT_SIZE)) + vstr%length = -1 +end subroutine init_varstr + +! Clean up memory (leaves varstr null, and drops the data field) +subroutine destroy_varstr(vstr) + type(varstr), intent(inout) :: vstr + if (associated(vstr%data)) deallocate(vstr%data) + call set_varstr_null(vstr) +end subroutine destroy_varstr + +! Return real length of varstr +function varstr_len(vstr) result(l) + type(varstr), intent(in) :: vstr + integer :: l + if (vstr%length<0) print *, "WARNING: asking for length of null varstr" + l = vstr%length +end function varstr_len + + +! Make sure that varstr is at least size-n. +! The data will be kept (copied) if keep is true (default) +! This can be called on a null varstr, but should noty be called on +! one which was destroyed. +subroutine ensure_varstr_size(vstr,n,keep) + type(varstr), intent(inout) :: vstr + integer, intent(in) :: n + logical, optional, intent(in) :: keep + + character, pointer, dimension(:) :: new_data + integer :: new_size, old_size + logical :: keep_flag + + if (present(keep)) then + keep_flag = keep + else + keep_flag = .true. + end if + + old_size = size(vstr%data) + if (n <= old_size ) return + + new_size = old_size + ((n-old_size)/VARSTR_ALLOC_SIZE+1) * VARSTR_ALLOC_SIZE + allocate(new_data(new_size)) + + if (keep_flag) new_data(1:old_size) = vstr%data(1:old_size) + + deallocate( vstr%data ) + vstr%data => new_data +end subroutine ensure_varstr_size + +! Returns whether varstr is empty: "" +function is_varstr_empty(vstr) + type(varstr), intent(in) :: vstr + logical is_varstr_empty + is_varstr_empty = (vstr%length == 0) +end function is_varstr_empty + +! Set vstr to empty string +subroutine set_varstr_empty(vstr) + type(varstr), intent(inout) :: vstr + vstr%length = 0 +end subroutine set_varstr_empty + +! Returns whether varstr is null (i.e. invalid) +function is_varstr_null(vstr) + type(varstr), intent(in) :: vstr + logical is_varstr_null + is_varstr_null = (vstr%length < 0) +end function is_varstr_null + +! Set vstr to null +subroutine set_varstr_null(vstr) + type(varstr), intent(inout) :: vstr + vstr%length = -1 +end subroutine set_varstr_null + +! Convert varstr to newly allocated array of characters +function vs_varstr_alloc(vstr) result(vs) + type(varstr) :: vstr + character, dimension(:), pointer :: vs + + if (is_varstr_null(vstr)) then + print *, "WARNING: Converting null varstr to string... making it empty first" + call set_varstr_empty(vstr) + end if + + allocate(vs(vstr%length)) + vs = vstr%data(1:vstr%length) +end function vs_varstr_alloc + +! This call moves data from varstr to vs (i.e. vs is overwritten and vstr is made null) +subroutine move_varstr_vs(vstr,vs) + type(varstr), intent(inout) :: vstr + character, dimension(:), pointer, intent(inout) :: vs + + if (associated(vs)) deallocate(vs) + vs => vs_varstr_alloc(vstr) + call set_varstr_null(vstr) +end subroutine move_varstr_vs + +! This call moves data from varstr to varstr (src becomes null) +subroutine move_varstr_varstr(src,dst) + type(varstr), intent(inout) :: src + type(varstr), intent(inout) :: dst + character, dimension(:), pointer :: tmpdata + + tmpdata => dst%data + dst%data => src%data + src%data => tmpdata + dst%length = src%length + + call set_varstr_null(src) +end subroutine move_varstr_varstr + + +! Convert varstr to string type +function str_varstr(vstr) result(s) + type(varstr), intent(in) :: vstr + character(len=vstr%length) :: s + integer :: i + + if (is_varstr_null(vstr)) then + ! Can we really end-up here? Or will it blow on allocation with len=-1 ? + print *, "WARNING: Trying to convert null varstr to str... returning empty string" + s = "" + end if + + do i = 1, vstr%length + s(i:i) = vstr%data(i) + enddo +end function str_varstr + +! Append string to varstr +subroutine append_varstr(vstr,str) + type(varstr), intent(inout) :: vstr + character(len=*), intent(in) :: str + character, dimension(:), pointer :: tmp + integer :: i + + if (is_varstr_null(vstr)) then + print *, "WARNING: Trying to append to null varstr... making it empty first" + call set_varstr_empty(vstr) + end if + + call ensure_varstr_size(vstr,vstr%length+len(str)) + + ! Note: on a XML file with very large tokens, this loop + ! is consistently faster than equivalent 'transfer' intrinsic + do i=1,len(str) + vstr%data(vstr%length+i) = str(i:i) + end do + vstr%length = vstr%length + len(str) +end subroutine append_varstr + +! Convert string to varstr in place +subroutine varstr_str(vstr,str) + type(varstr), intent(inout) :: vstr + character(len=*), intent(in) :: str + integer :: i + + call ensure_varstr_size(vstr,len(str),.false.) + do i=1,len(str) + vstr%data(i) = str(i:i) + end do + vstr%length = len(str) +end subroutine varstr_str + +! Convert character array to varstr in place +subroutine varstr_vs(vstr,vs) + type(varstr), intent(inout) :: vstr + character, dimension(:), intent(in) :: vs + + call ensure_varstr_size(vstr,size(vs),.false.) + + vstr%length = size(vs) + vstr%data(1:size(vs)) = vs +end subroutine varstr_vs + +! Compare varstr to str (true if equal) +function equal_varstr_str(vstr,str) result(r) + type(varstr), intent(in) :: vstr + character(len=*) :: str + logical :: r + + integer :: i + + r = .false. + if ( len(str) /= varstr_len(vstr) ) return + do i=1,len(str) + if ( str(i:i) /= vstr%data(i) ) return + end do + r = .true. +end function equal_varstr_str + +! Compare varstr to varstr (true if equal) +function equal_varstr_varstr(vstr1,vstr2) result(r) + type(varstr), intent(in) :: vstr1, vstr2 + logical :: r + + integer :: i + + r = .false. + if ( varstr_len(vstr1) /= varstr_len(vstr2) ) return + do i=1,varstr_len(vstr1) + if ( vstr1%data(i) /= vstr2%data(i) ) return + end do + r = .true. +end function equal_varstr_varstr + +end module fox_m_fsys_varstr diff --git a/src/xml/fsys/m_ieee.F90 b/src/xml/fsys/m_ieee.F90 new file mode 100644 index 000000000..afec6f080 --- /dev/null +++ b/src/xml/fsys/m_ieee.F90 @@ -0,0 +1,17 @@ +module m_ieee + + implicit none + private + + public :: generate_nan + +contains + + function generate_nan() result(nan) + real :: nan + real :: zero + zero = 0.0 + nan = 0.0/zero + end function generate_nan + +end module m_ieee diff --git a/src/xml/sax/FoX_sax.F90 b/src/xml/sax/FoX_sax.F90 new file mode 100644 index 000000000..17dc2280e --- /dev/null +++ b/src/xml/sax/FoX_sax.F90 @@ -0,0 +1,34 @@ +module FoX_sax + + use FoX_common + use m_sax_operate + + implicit none + private + + public :: open_xml_file + public :: open_xml_string + public :: close_xml_t + public :: parse + public :: stop_parser + public :: SAX_OPEN_ERROR + + public :: xml_t + + public :: dictionary_t +!SAX functions + public :: getIndex + public :: getLength + public :: getLocalName + public :: getQName + public :: getURI + public :: getValue + public :: getType + public :: isSpecified + public :: isDeclared + public :: setSpecified + public :: setDeclared +!For convenience + public :: hasKey + +end module FoX_sax diff --git a/src/xml/sax/Makefile b/src/xml/sax/Makefile new file mode 100644 index 000000000..c0a134055 --- /dev/null +++ b/src/xml/sax/Makefile @@ -0,0 +1,50 @@ +source = $(wildcard *.F90) +objects = $(source:.F90=.o) + +#=============================================================================== +# Compiler Options +#=============================================================================== + +# Ignore unusd variables + +ifeq ($(MACHINE),bluegene) + override F90 = xlf2003 +endif + +ifeq ($(F90),ifort) + override F90FLAGS += -warn nounused +endif + +#=============================================================================== +# Targets +#=============================================================================== + +all: $(objects) + mv *.mod ../include + mv *.o ../lib +clean: + @rm -f *.o *.mod +neat: + @rm -f *.o *.mod + +#=============================================================================== +# Rules +#=============================================================================== + +.SUFFIXES: .F90 .o + +.PHONY: clean neat + +%.o: %.F90 + $(F90) $(F90FLAGS) -c -I../include $< + +#=============================================================================== +# Dependencies +#=============================================================================== + +FoX_sax.o: m_sax_operate.o +m_sax_operate.o: m_sax_parser.o m_sax_reader.o m_sax_types.o +m_sax_parser.o: m_sax_reader.o m_sax_tokenizer.o m_sax_types.o +m_sax_reader.o: m_sax_xml_source.o +m_sax_tokenizer.o: m_sax_reader.o m_sax_types.o +m_sax_types.o: m_sax_reader.o diff --git a/src/xml/sax/m_sax_operate.F90 b/src/xml/sax/m_sax_operate.F90 new file mode 100644 index 000000000..531618ad2 --- /dev/null +++ b/src/xml/sax/m_sax_operate.F90 @@ -0,0 +1,313 @@ +module m_sax_operate + +#ifndef DUMMYLIB + use m_common_error, only: FoX_error, in_error + use FoX_common, only : str_vs + + use m_sax_reader, only: open_file, close_file + use m_sax_parser, only: sax_parser_init, sax_parser_destroy, sax_parse + use m_sax_types, only: ST_STOP +#endif + use m_sax_types, only: xml_t + + implicit none + private + + integer, parameter :: SAX_OPEN_ERROR = 1001 + + public :: xml_t + public :: open_xml_file + public :: open_xml_string + public :: close_xml_t + public :: parse + public :: stop_parser + public :: SAX_OPEN_ERROR + +contains + + subroutine open_xml_file(xt, file, iostat, lun) + type(xml_t), intent(out) :: xt + character(len=*), intent(in) :: file + integer, intent(out), optional :: iostat + integer, intent(in), optional :: lun +#ifdef DUMMYLIB + if (present(iostat)) iostat = 0 +#else + integer :: i + + call open_file(xt%fb, file=trim(file), iostat=i, lun=lun, es=xt%fx%error_stack) + if (present(iostat)) then + if (in_error(xt%fx%error_stack)) i = SAX_OPEN_ERROR + iostat = i + if (i/=0) return + else + if (i/=0) & + call FoX_error("Error opening file in open_xml_file") + if (in_error(xt%fx%error_stack)) & + call FoX_error(str_vs(xt%fx%error_stack%stack(1)%msg)) + endif + + if (i==0) call sax_parser_init(xt%fx, xt%fb) +#endif + end subroutine open_xml_file + + subroutine open_xml_string(xt, string) + type(xml_t), intent(out) :: xt + character(len=*), intent(in) :: string +#ifndef DUMMYLIB + integer :: iostat + + call open_file(xt%fb, string=string, iostat=iostat, es=xt%fx%error_stack) + call sax_parser_init(xt%fx, xt%fb) +#endif + end subroutine open_xml_string + + subroutine close_xml_t(xt) + type(xml_t), intent(inout) :: xt +#ifndef DUMMYLIB + call close_file(xt%fb) + call sax_parser_destroy(xt%fx) +#endif + end subroutine close_xml_t + + + subroutine parse(xt, & + characters_handler, & + endDocument_handler, & + endElement_handler, & + endPrefixMapping_handler, & + ignorableWhitespace_handler, & + processingInstruction_handler, & + ! setDocumentLocator + skippedEntity_handler, & + startDocument_handler, & + startElement_handler, & + startPrefixMapping_handler, & + notationDecl_handler, & + unparsedEntityDecl_handler, & + error_handler, & + fatalError_handler, & + warning_handler, & + attributeDecl_handler, & + elementDecl_handler, & + externalEntityDecl_handler, & + internalEntityDecl_handler, & + comment_handler, & + endCdata_handler, & + endDTD_handler, & + endEntity_handler, & + startCdata_handler, & + startDTD_handler, & + startEntity_handler, & +! Features / properties + namespaces, & + namespace_prefixes, & + validate, & + xmlns_uris) + + type(xml_t), intent(inout) :: xt + optional :: characters_handler + optional :: endDocument_handler + optional :: endElement_handler + optional :: endPrefixMapping_handler + optional :: ignorableWhitespace_handler + optional :: processingInstruction_handler + optional :: skippedEntity_handler + optional :: startElement_handler + optional :: startDocument_handler + optional :: startPrefixMapping_handler + optional :: notationDecl_handler + optional :: unparsedEntityDecl_handler + optional :: error_handler + optional :: fatalError_handler + optional :: warning_handler + optional :: attributeDecl_handler + optional :: elementDecl_handler + optional :: externalEntityDecl_handler + optional :: internalEntityDecl_handler + optional :: comment_handler + optional :: endCdata_handler + optional :: endEntity_handler + optional :: endDTD_handler + optional :: startCdata_handler + optional :: startDTD_handler + optional :: startEntity_handler + + logical, intent(in), optional :: namespaces + logical, intent(in), optional :: namespace_prefixes + logical, intent(in), optional :: validate + logical, intent(in), optional :: xmlns_uris + + interface + + subroutine characters_handler(chunk) + character(len=*), intent(in) :: chunk + end subroutine characters_handler + + subroutine endDocument_handler() + end subroutine endDocument_handler + + subroutine endElement_handler(namespaceURI, localName, name) + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: localName + character(len=*), intent(in) :: name + end subroutine endElement_handler + + subroutine endPrefixMapping_handler(prefix) + character(len=*), intent(in) :: prefix + end subroutine endPrefixMapping_handler + + subroutine ignorableWhitespace_handler(chars) + character(len=*), intent(in) :: chars + end subroutine ignorableWhitespace_handler + + subroutine processingInstruction_handler(name, content) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: content + end subroutine processingInstruction_handler + + subroutine skippedEntity_handler(name) + character(len=*), intent(in) :: name + end subroutine skippedEntity_handler + + subroutine startDocument_handler() + end subroutine startDocument_handler + + subroutine startElement_handler(namespaceURI, localName, name, attributes) + use FoX_common + character(len=*), intent(in) :: namespaceUri + character(len=*), intent(in) :: localName + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + end subroutine startElement_handler + + subroutine startPrefixMapping_handler(namespaceURI, prefix) + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: prefix + end subroutine startPrefixMapping_handler + + subroutine notationDecl_handler(name, publicId, systemId) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: publicId + character(len=*), intent(in) :: systemId + end subroutine notationDecl_handler + + subroutine unparsedEntityDecl_handler(name, publicId, systemId, notation) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: publicId + character(len=*), intent(in) :: systemId + character(len=*), intent(in) :: notation + end subroutine unparsedEntityDecl_handler + + subroutine error_handler(msg) + character(len=*), intent(in) :: msg + end subroutine error_handler + + subroutine fatalError_handler(msg) + character(len=*), intent(in) :: msg + end subroutine fatalError_handler + + subroutine warning_handler(msg) + character(len=*), intent(in) :: msg + end subroutine warning_handler + + subroutine attributeDecl_handler(eName, aName, type, mode, value) + character(len=*), intent(in) :: eName + character(len=*), intent(in) :: aName + character(len=*), intent(in) :: type + character(len=*), intent(in), optional :: mode + character(len=*), intent(in), optional :: value + end subroutine attributeDecl_handler + + subroutine elementDecl_handler(name, model) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: model + end subroutine elementDecl_handler + + subroutine externalEntityDecl_handler(name, publicId, systemId) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: publicId + character(len=*), intent(in) :: systemId + end subroutine externalEntityDecl_handler + + subroutine internalEntityDecl_handler(name, value) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: value + end subroutine internalEntityDecl_handler + + subroutine comment_handler(comment) + character(len=*), intent(in) :: comment + end subroutine comment_handler + + subroutine endCdata_handler() + end subroutine endCdata_handler + + subroutine endDTD_handler() + end subroutine endDTD_handler + + subroutine endEntity_handler(name) + character(len=*), intent(in) :: name + end subroutine endEntity_handler + + subroutine startCdata_handler() + end subroutine startCdata_handler + + subroutine startDTD_handler(name, publicId, systemId) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: publicId + character(len=*), intent(in) :: systemId + end subroutine startDTD_handler + + subroutine startEntity_handler(name) + character(len=*), intent(in) :: name + end subroutine startEntity_handler + + end interface +#ifndef DUMMYLIB + ! FIXME check xt is initialized + + call sax_parse(xt%fx, xt%fb, & + characters_handler, & + endDocument_handler, & + endElement_handler, & + endPrefixMapping_handler, & + ignorableWhitespace_handler, & + processingInstruction_handler, & + ! setDocumentLocator + skippedEntity_handler, & + startDocument_handler, & + startElement_handler, & + startPrefixMapping_handler, & + notationDecl_handler, & + unparsedEntityDecl_handler, & + error_handler, & + fatalError_handler, & + warning_handler, & + attributeDecl_handler, & + elementDecl_handler, & + externalEntityDecl_handler, & + internalEntityDecl_handler, & + comment_handler, & + endCdata_handler, & + endDTD_handler, & + endEntity_handler, & + startCdata_handler, & + startDTD_handler, & + startEntity_handler, & + namespaces=namespaces, & + namespace_prefixes=namespace_prefixes, & + validate=validate, & + xmlns_uris=xmlns_uris) +#endif + end subroutine parse + + subroutine stop_parser(xt) + ! To be called from within a callback function; + ! this will stop the parser. + type(xml_t), intent(inout) :: xt +#ifndef DUMMYLIB + xt%fx%state = ST_STOP +#endif + end subroutine stop_parser + +end module m_sax_operate diff --git a/src/xml/sax/m_sax_parser.F90 b/src/xml/sax/m_sax_parser.F90 new file mode 100644 index 000000000..c2f2283fb --- /dev/null +++ b/src/xml/sax/m_sax_parser.F90 @@ -0,0 +1,3029 @@ +module m_sax_parser + +#ifndef DUMMYLIB + use fox_m_fsys_array_str, only: str_vs, vs_str_alloc, vs_vs_alloc + use fox_m_fsys_string_list, only: string_list, destroy_string_list, & + tokenize_to_string_list, registered_string, init_string_list, & + add_string, tokenize_and_add_strings, destroy + use fox_m_fsys_varstr + use m_common_attrs, only: init_dict, destroy_dict, reset_dict, & + add_item_to_dict, has_key, get_value, get_att_index_pointer, & + getLength, setIsId, setBase + use m_common_charset, only: XML1_0, XML1_1, XML_WHITESPACE + use m_common_element, only: element_t, existing_element, add_element, & + get_element, parse_dtd_element, parse_dtd_attlist, report_declarations, & + declared_element, attribute_t, att_value_normalize, & + get_attribute_declaration, & + ATT_CDATA, ATT_ID, ATT_IDREF, ATT_IDREFS, ATT_ENTITY, ATT_ENTITIES, & + ATT_NMTOKEN, ATT_NMTOKENS, ATT_NOTATION, ATT_ENUM, & + ATT_REQUIRED, ATT_IMPLIED, ATT_DEFAULT, ATT_FIXED + use m_common_elstack, only: push_elstack, pop_elstack, init_elstack, & + destroy_elstack, is_empty, len, get_top_elstack, checkContentModel, & + elementContent, emptyContent, checkContentModelToEnd + use m_common_entities, only: existing_entity, init_entity_list, & + destroy_entity_list, add_internal_entity, is_unparsed_entity, & + expand_entity, expand_char_entity, pop_entity_list, size, & + entity_t, getEntityByIndex, getEntityByName + use m_common_entity_expand, only: expand_entity_value_alloc + use m_common_error, only: FoX_error, add_error, & + init_error_stack, destroy_error_stack, in_error + use m_common_namecheck, only: checkName, checkPublicId, & + checkCharacterEntityReference, likeCharacterEntityReference, & + checkQName, checkNCName, checkPITarget, checkNmtoken, checkNmtokens, & + checkRepCharEntityReference, checkNames, checkNCNames + use m_common_namespaces, only: getnamespaceURI, invalidNS, & + checkNamespaces, checkEndNamespaces, namespaceDictionary, & + initNamespaceDictionary, destroyNamespaceDictionary + use m_common_notations, only: init_notation_list, destroy_notation_list, & + add_notation, notation_exists + use m_common_struct, only: init_xml_doc_state, & + destroy_xml_doc_state, register_internal_PE, register_external_PE, & + register_internal_GE, register_external_GE + + use FoX_utils, only: URI, parseURI, rebaseURI, copyURI, destroyURI, & + hasFragment, expressURI + + use m_sax_reader, only: file_buffer_t, pop_buffer_stack, open_new_string, & + open_new_file, parse_xml_declaration, parse_text_declaration, & + reading_main_file, reading_first_entity, add_error_position + use m_sax_tokenizer, only: sax_tokenize, normalize_attribute_text, & + expand_pe_text + use m_sax_types ! everything, really + + implicit none + private + + public :: getNSDict + + public :: sax_parser_init + public :: sax_parser_destroy + public :: sax_parse + +contains + + function getNSDict(fx) result(ns) + type(sax_parser_t), target :: fx + type(namespaceDictionary), pointer :: ns + + ns => fx%nsDict + end function getNSDict + + subroutine sax_parser_init(fx, fb) + type(sax_parser_t), intent(out) :: fx + type(file_buffer_t), intent(in) :: fb +#ifdef PGF90 + type(URI), pointer :: nullURI + + nullURI => null() +#endif + + call init_varstr(fx%token) + call init_varstr(fx%content) + call init_varstr(fx%name) + call init_varstr(fx%attname) + call init_varstr(fx%PublicId) + call init_varstr(fx%systemId) + call init_varstr(fx%Ndata) + call init_varstr(fx%root_element) + + call init_error_stack(fx%error_stack) + call init_elstack(fx%elstack) + call init_dict(fx%attributes) + + call initNamespaceDictionary(fx%nsdict) + call init_notation_list(fx%nlist) + ! FIXME do we copy correctly from fx%nlist to fx%xds%nlist? + allocate(fx%xds) + call init_xml_doc_state(fx%xds) + deallocate(fx%xds%inputEncoding) + fx%xds%inputEncoding => vs_str_alloc("us-ascii") + ! because it always is ... + if (fb%f(1)%lun>0) then + fx%xds%documentURI => vs_vs_alloc(fb%f(1)%filename) + else + fx%xds%documentURI => vs_str_alloc("") + endif + + fx%xds%standalone = fb%standalone + + call init_entity_list(fx%forbidden_ge_list) + call init_entity_list(fx%forbidden_pe_list) + call init_entity_list(fx%predefined_e_list) + +#ifdef PGF90 + call add_internal_entity(fx%predefined_e_list, 'amp', '&', nullURI, .false.) + call add_internal_entity(fx%predefined_e_list, 'lt', '<', nullURI, .false.) + call add_internal_entity(fx%predefined_e_list, 'gt', '>', nullURI, .false.) + call add_internal_entity(fx%predefined_e_list, 'apos', "'", nullURI, .false.) + call add_internal_entity(fx%predefined_e_list, 'quot', '"', nullURI, .false.) +#else + call add_internal_entity(fx%predefined_e_list, 'amp', '&', null(), .false.) + call add_internal_entity(fx%predefined_e_list, 'lt', '<', null(), .false.) + call add_internal_entity(fx%predefined_e_list, 'gt', '>', null(), .false.) + call add_internal_entity(fx%predefined_e_list, 'apos', "'", null(), .false.) + call add_internal_entity(fx%predefined_e_list, 'quot', '"', null(), .false.) +#endif + end subroutine sax_parser_init + + subroutine sax_parser_destroy(fx) + type(sax_parser_t), intent(inout) :: fx + + fx%context = CTXT_NULL + fx%state = ST_NULL + + call destroy_varstr(fx%token) + call destroy_varstr(fx%root_element) + + call destroy_error_stack(fx%error_stack) + call destroy_elstack(fx%elstack) + call destroy_dict(fx%attributes) + call destroyNamespaceDictionary(fx%nsdict) + call destroy_notation_list(fx%nlist) + if (.not.fx%xds_used) then + call destroy_xml_doc_state(fx%xds) + deallocate(fx%xds) + endif + + call destroy_entity_list(fx%forbidden_ge_list) + call destroy_entity_list(fx%forbidden_pe_list) + call destroy_entity_list(fx%predefined_e_list) + + call destroy_varstr(fx%token) + call destroy_varstr(fx%content) + call destroy_varstr(fx%name) + call destroy_varstr(fx%attname) + call destroy_varstr(fx%publicId) + call destroy_varstr(fx%systemId) + call destroy_varstr(fx%Ndata) + call destroy_varstr(fx%root_element) + + end subroutine sax_parser_destroy + + recursive subroutine sax_parse(fx, fb, & + ! org.xml.sax + ! SAX ContentHandler + characters_handler, & + endDocument_handler, & + endElement_handler, & + endPrefixMapping_handler, & + ignorableWhitespace_handler, & + processingInstruction_handler, & + ! setDocumentLocator + skippedEntity_handler, & + startDocument_handler, & + startElement_handler, & + startPrefixMapping_handler, & + ! SAX DTDHandler + notationDecl_handler, & + unparsedEntityDecl_handler, & + ! SAX ErrorHandler + error_handler, & + fatalError_handler, & + warning_handler, & + ! org.xml.sax.ext + ! SAX DeclHandler + attributeDecl_handler, & + elementDecl_handler, & + externalEntityDecl_handler, & + internalEntityDecl_handler, & + ! SAX LexicalHandler + comment_handler, & + endCdata_handler, & + endDTD_handler, & + endEntity_handler, & + startCdata_handler, & + startDTD_handler, & + startEntity_handler, & + namespaces, & + namespace_prefixes, & + xmlns_uris, & + validate, & + FoX_endDTD_handler, & + startInCharData, & + externalEntity, & + xmlVersion, & + initial_entities) + + type(sax_parser_t), intent(inout) :: fx + type(file_buffer_t), intent(inout) :: fb + optional :: characters_handler + optional :: endDocument_handler + optional :: endElement_handler + optional :: endPrefixMapping_handler + optional :: ignorableWhitespace_handler + optional :: processingInstruction_handler + optional :: skippedEntity_handler + optional :: startElement_handler + optional :: startDocument_handler + optional :: startPrefixMapping_handler + optional :: notationDecl_handler + optional :: unparsedEntityDecl_handler + optional :: error_handler + optional :: fatalError_handler + optional :: warning_handler + optional :: attributeDecl_handler + optional :: elementDecl_handler + optional :: externalEntityDecl_handler + optional :: internalEntityDecl_handler + optional :: comment_handler + optional :: endCdata_handler + optional :: endEntity_handler + optional :: endDTD_handler + optional :: FoX_endDTD_handler + optional :: startCdata_handler + optional :: startDTD_handler + optional :: startEntity_handler + + logical, intent(in), optional :: namespaces + logical, intent(in), optional :: namespace_prefixes + logical, intent(in), optional :: xmlns_uris + + logical, intent(in), optional :: validate + logical, intent(in), optional :: startInCharData + logical, intent(in), optional :: externalEntity + character(len=*), intent(in), optional :: xmlVersion + + type(entity_list), optional :: initial_entities +#ifdef PGF90 + type(URI), pointer :: nullURI +#endif + + interface + + subroutine characters_handler(chunk) + character(len=*), intent(in) :: chunk + end subroutine characters_handler + + subroutine endDocument_handler() + end subroutine endDocument_handler + + subroutine endElement_handler(namespaceURI, localName, name) + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: localName + character(len=*), intent(in) :: name + end subroutine endElement_handler + + subroutine endPrefixMapping_handler(prefix) + character(len=*), intent(in) :: prefix + end subroutine endPrefixMapping_handler + + subroutine ignorableWhitespace_handler(chars) + character(len=*), intent(in) :: chars + end subroutine ignorableWhitespace_handler + + subroutine processingInstruction_handler(name, content) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: content + end subroutine processingInstruction_handler + + subroutine skippedEntity_handler(name) + character(len=*), intent(in) :: name + end subroutine skippedEntity_handler + + subroutine startDocument_handler() + end subroutine startDocument_handler + + subroutine startElement_handler(namespaceURI, localName, name, attributes) + use FoX_common + character(len=*), intent(in) :: namespaceUri + character(len=*), intent(in) :: localName + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + end subroutine startElement_handler + + subroutine startPrefixMapping_handler(namespaceURI, prefix) + character(len=*), intent(in) :: namespaceURI + character(len=*), intent(in) :: prefix + end subroutine startPrefixMapping_handler + + subroutine notationDecl_handler(name, publicId, systemId) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: publicId + character(len=*), intent(in) :: systemId + end subroutine notationDecl_handler + + subroutine unparsedEntityDecl_handler(name, publicId, systemId, notation) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: publicId + character(len=*), intent(in) :: systemId + character(len=*), intent(in) :: notation + end subroutine unparsedEntityDecl_handler + + subroutine error_handler(msg) + character(len=*), intent(in) :: msg + end subroutine error_handler + + subroutine fatalError_handler(msg) + character(len=*), intent(in) :: msg + end subroutine fatalError_handler + + subroutine warning_handler(msg) + character(len=*), intent(in) :: msg + end subroutine warning_handler + + subroutine attributeDecl_handler(eName, aName, type, mode, value) + character(len=*), intent(in) :: eName + character(len=*), intent(in) :: aName + character(len=*), intent(in) :: type + character(len=*), intent(in), optional :: mode + character(len=*), intent(in), optional :: value + end subroutine attributeDecl_handler + + subroutine elementDecl_handler(name, model) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: model + end subroutine elementDecl_handler + + subroutine externalEntityDecl_handler(name, publicId, systemId) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: publicId + character(len=*), intent(in) :: systemId + end subroutine externalEntityDecl_handler + + subroutine internalEntityDecl_handler(name, value) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: value + end subroutine internalEntityDecl_handler + + subroutine comment_handler(comment) + character(len=*), intent(in) :: comment + end subroutine comment_handler + + subroutine endCdata_handler() + end subroutine endCdata_handler + + subroutine endDTD_handler() + end subroutine endDTD_handler + + subroutine FoX_endDTD_handler(state) + use m_common_struct, only: xml_doc_state + type(xml_doc_state), pointer :: state + end subroutine FoX_endDTD_handler + + subroutine endEntity_handler(name) + character(len=*), intent(in) :: name + end subroutine endEntity_handler + + subroutine startCdata_handler() + end subroutine startCdata_handler + + subroutine startDTD_handler(name, publicId, systemId) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: publicId + character(len=*), intent(in) :: systemId + end subroutine startDTD_handler + + subroutine startEntity_handler(name) + character(len=*), intent(in) :: name + end subroutine startEntity_handler + + end interface + + logical :: validCheck, startInCharData_, processDTD, pe, nameOK, eof + logical :: namespaces_, namespace_prefixes_, xmlns_uris_, externalEntity_ + integer :: i, iostat, temp_i, nextState, ignoreDepth, declSepValue + character, pointer :: tempString(:), tempString2(:) + character :: dummy + type(element_t), pointer :: elem + type(attribute_t), pointer :: attDecl + type(entity_t), pointer :: ent + type(URI), pointer :: extSubsetURI, URIref, newURI + integer, pointer :: wf_stack(:), temp_wf_stack(:), extEntStack(:) + logical :: inExtSubset + type(string_list) :: id_list, idref_list + +#ifdef PGF90 + nullURI => null() +#endif + tempString => null() + tempString2 => null() + elem => null() + attDecl => null() + + if (present(namespaces)) then + namespaces_ = namespaces + else + namespaces_ = .true. + endif + if (present(namespace_prefixes)) then + namespace_prefixes_ = namespace_prefixes + else + namespace_prefixes_ = .false. + endif + if (present(xmlns_uris)) then + xmlns_uris_ = xmlns_uris + else + xmlns_uris_ = .false. + endif + if (present(validate)) then + validCheck = validate + else + validCheck = .false. + endif + if (present(startInCharData)) then + startInCharData_ = startInCharData + else + startInCharData_ = .false. + endif + if (present(externalEntity)) then + externalEntity_ = externalEntity + else + externalEntity_ = .false. + endif + if (present(initial_entities)) then + do i = 1, size(initial_entities) + ent => getEntityByIndex(initial_entities, i) + if (ent%external) then + call register_external_GE(fx%xds, & + name=str_vs(ent%name), systemId=str_vs(ent%systemId), & + publicId=str_vs(ent%publicId), & + wfc=ent%wfc, baseURI=copyURI(ent%baseURI)) + else + call register_internal_GE(fx%xds, & + name=str_vs(ent%name), text=str_vs(ent%text), & + wfc=ent%wfc, baseURI=copyURI(ent%baseURI)) + endif + enddo + endif + + allocate(wf_stack(1)) + wf_stack(1) = 0 + allocate(extEntStack(0)) + fx%inIntSubset = .false. + extSubsetURI => null() + inExtSubset = .false. + declSepValue = 0 + processDTD = .true. + iostat = 0 + + if (startInCharData_) then + fx%context = CTXT_IN_CONTENT + fx%state = ST_CHAR_IN_CONTENT + fx%well_formed = .true. + if (externalEntity_) call parse_text_declaration(fb, fx%error_stack) + if (in_error(fx%error_stack)) goto 100 + if (present(xmlVersion)) then + if (xmlVersion=="1.0") then + fx%xds%xml_version = XML1_0 + elseif (xmlVersion=="1.1") then + fx%xds%xml_version = XML1_1 + endif + endif + elseif (reading_main_file(fb)) then + fx%context = CTXT_BEFORE_DTD + fx%state = ST_MISC + if (present(startDocument_handler)) then + call startDocument_handler() + if (fx%state==ST_STOP) goto 100 + endif + call parse_xml_declaration(fb, fx%xds%xml_version, fx%xds%encoding, fx%xds%standalone, fx%error_stack) + if (in_error(fx%error_stack)) goto 100 + call init_string_list(id_list) + call init_string_list(idref_list) + endif + + do + call sax_tokenize(fx, fb, eof) + if (in_error(fx%error_stack)) then + ! Any error, we want to quit sax_tokenizer + call add_error(fx%error_stack, 'Error getting token') + goto 100 + elseif (eof.and..not.reading_main_file(fb)) then + if (inExtSubset.and.reading_first_entity(fb)) then + if (wf_stack(1)>0) then + call add_error(fx%error_stack, & + "Unclosed conditional section or markup in external subset") + goto 100 + elseif (fx%state_dtd/=ST_DTD_SUBSET) then + call add_error(fx%error_stack, & + "Markup not terminated in external subset") + goto 100 + endif + call endDTDchecks + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + inExtSubset = .false. + fx%state = ST_MISC + fx%context = CTXT_BEFORE_CONTENT + elseif (fx%context==CTXT_IN_DTD) then + if (validCheck) then + if (wf_stack(1)/=0) then + call add_error(fx%error_stack, & + "Markup not terminated in parameter entity") + goto 100 + endif + endif + if (declSepValue==size(wf_stack)) then + if (wf_stack(1)/=0) then + call add_error(fx%error_stack, & + "Markup not terminated in parameter entity") + goto 100 + else + declSepValue = 0 + endif + endif + if (present(endEntity_handler)) then + call endEntity_handler('%'//pop_entity_list(fx%forbidden_pe_list)) + if (fx%state==ST_STOP) goto 100 + else + dummy = pop_entity_list(fx%forbidden_pe_list) + endif + if (fx%state_dtd==ST_DTD_ATTLIST_CONTENTS & + .or.fx%state_dtd==ST_DTD_ELEMENT_CONTENTS) then + ! stick the token back in contents ... + call move_varstr_varstr(fx%token,fx%content) + endif + if (reading_main_file(fb)) & + fx%inIntSubset = .true. + elseif (fx%context==CTXT_IN_CONTENT) then + if (fx%state==ST_TAG_IN_CONTENT) fx%state = ST_CHAR_IN_CONTENT + ! because CHAR_IN_CONTENT *always* leads to TAG_IN_CONTENT + ! *except* when it is the end of an entity expansion + if (present(endEntity_handler)) then + call endEntity_handler(pop_entity_list(fx%forbidden_ge_list)) + if (fx%state==ST_STOP) goto 100 + else + dummy = pop_entity_list(fx%forbidden_ge_list) + endif + if (fx%state/=ST_CHAR_IN_CONTENT.or.wf_stack(1)/=0) then + call add_error(fx%error_stack, 'Ill-formed entity') + goto 100 + endif + endif + temp_wf_stack => wf_stack + allocate(wf_stack(size(temp_wf_stack)-1)) + wf_stack = temp_wf_stack(2:) + ! If we are not doing validity checking, we might have + ! finished PE expansion with wf_stack(1) non-zero + wf_stack(1) = wf_stack(1) + temp_wf_stack(1) + deallocate(temp_wf_stack) + temp_wf_stack => extEntStack + allocate(extEntStack(size(temp_wf_stack)-1)) + extEntStack = temp_wf_stack(2:) + deallocate(temp_wf_stack) + call pop_buffer_stack(fb) + cycle + endif + if (fx%tokenType==TOK_NULL) then + call add_error(fx%error_stack, 'Internal error! No token found!') + goto 100 + endif + + nextState = ST_NULL + + select case (fx%state) + + case (ST_MISC) + !write(*,*) 'ST_MISC', str_varstr(fx%token) + select case (fx%tokenType) + case (TOK_PI_TAG) + wf_stack(1) = wf_stack(1) + 1 + nextState = ST_START_PI + case (TOK_BANG_TAG) + wf_stack(1) = wf_stack(1) + 1 + nextState = ST_BANG_TAG + case (TOK_OPEN_TAG) + wf_stack(1) = wf_stack(1) + 1 + nextState = ST_START_TAG + end select + + + case (ST_BANG_TAG) + !write(*,*) 'ST_BANG_TAG' + select case (fx%tokenType) + case (TOK_OPEN_SB) + nextState = ST_START_CDATA_DECLARATION + case (TOK_OPEN_COMMENT) + nextState = ST_START_COMMENT + case (TOK_NAME) + if (equal_varstr_str(fx%token,'DOCTYPE')) then + fx%context = CTXT_IN_DTD + nextState = ST_IN_DOCTYPE + endif + end select + + + case (ST_START_PI) + !write(*,*)'ST_START_PI' + select case (fx%tokenType) + case (TOK_NAME) + if (namespaces_) then + nameOk = checkNCName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (nameOk) then + if (equal_varstr_str(fx%token,'xml')) then + call add_error(fx%error_stack, "XML declaration must be at start of document") + goto 100 + elseif (checkPITarget(str_varstr(fx%token), fx%xds%xml_version)) then + nextState = ST_PI_CONTENTS + call move_varstr_varstr(fx%token,fx%name) + else + call add_error(fx%error_stack, "Invalid PI target name") + goto 100 + endif + endif + end select + + case (ST_PI_CONTENTS) + !write(*,*)'ST_PI_CONTENTS' + if (validCheck) then + if (emptyContent(fx%elstack)) then + call add_error(fx%error_stack, "Content inside empty element") + goto 100 + endif + endif + wf_stack(1) = wf_stack(1) - 1 + + select case(fx%tokenType) + case (TOK_CHAR) + if (present(processingInstruction_handler)) then + call processingInstruction_handler(str_varstr(fx%name), str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif + call set_varstr_null(fx%name) + nextState = ST_PI_END + case (TOK_PI_END) + if (present(processingInstruction_handler)) then + call processingInstruction_handler(str_varstr(fx%name), "") + if (fx%state==ST_STOP) goto 100 + endif + call set_varstr_null(fx%name) + if (fx%context==CTXT_IN_CONTENT) then + nextState = ST_CHAR_IN_CONTENT + else + nextState = ST_MISC + endif + end select + + case (ST_PI_END) + !write(*,*)'ST_PI_END' + select case(fx%tokenType) + case (TOK_PI_END) + if (fx%context==CTXT_IN_CONTENT) then + nextState = ST_CHAR_IN_CONTENT + else + nextState = ST_MISC + endif + end select + + case (ST_START_COMMENT) + !write(*,*)'ST_START_COMMENT' + select case (fx%tokenType) + case (TOK_CHAR) + call move_varstr_varstr(fx%token,fx%name) + nextState = ST_COMMENT_END + end select + + case (ST_COMMENT_END) + !write(*,*)'ST_COMMENT_END' + if (validCheck) then + if (emptyContent(fx%elstack)) then + call add_error(fx%error_stack, "Content inside empty element") + goto 100 + endif + endif + wf_stack(1) = wf_stack(1) - 1 + + select case (fx%tokenType) + case (TOK_COMMENT_END) + if (present(comment_handler)) then + call comment_handler(str_varstr(fx%name)) + if (fx%state==ST_STOP) goto 100 + endif + call set_varstr_null(fx%name) + if (fx%context==CTXT_IN_CONTENT) then + nextState = ST_CHAR_IN_CONTENT + else + nextState = ST_MISC + endif + end select + + case (ST_START_TAG) + !write(*,*)'ST_START_TAG', fx%context + select case (fx%tokenType) + case (TOK_NAME) + if (fx%context==CTXT_BEFORE_DTD & + .or. fx%context==CTXT_BEFORE_CONTENT & + .or. fx%context==CTXT_IN_CONTENT) then + if (namespaces_) then + nameOk = checkQName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, "Illegal element name") + goto 100 + endif + call move_varstr_varstr(fx%token,fx%name) + nextState = ST_IN_TAG + elseif (fx%context == CTXT_AFTER_CONTENT) then + call add_error(fx%error_stack, "Cannot open second root element") + goto 100 + elseif (fx%context == CTXT_IN_DTD) then + call add_error(fx%error_stack, "Cannot open root element before DTD is finished") + goto 100 + endif + end select + + case (ST_START_CDATA_DECLARATION) + !write(*,*) "ST_START_CDATA_DECLARATION" + select case (fx%tokenType) + case (TOK_NAME) + if (equal_varstr_str(fx%token,"CDATA")) then + if (fx%context/=CTXT_IN_CONTENT) then + call add_error(fx%error_stack, "CDATA section only allowed in text content.") + goto 100 + else + nextState = ST_FINISH_CDATA_DECLARATION + endif + else + call add_error(fx%error_stack, "Unknown keyword found in marked section declaration.") + endif + end select + + case (ST_FINISH_CDATA_DECLARATION) + !write(*,*) "ST_FINISH_CDATA_DECLARATION" + select case (fx%tokenType) + case (TOK_OPEN_SB) + nextState = ST_CDATA_CONTENTS + end select + + + case (ST_CDATA_CONTENTS) + !write(*,*)'ST_CDATA_CONTENTS' + select case (fx%tokenType) + case (TOK_CHAR) + call move_varstr_varstr(fx%token,fx%name) + nextState = ST_CDATA_END + end select + + case (ST_CDATA_END) + !write(*,*)'ST_CDATA_END' + if (validCheck) then + if (emptyContent(fx%elstack).or.elementContent(fx%elstack)) then + call add_error(fx%error_stack, "Content inside empty element") + goto 100 + endif + endif + wf_stack(1) = wf_stack(1) - 1 + + select case(fx%tokenType) + case (TOK_SECTION_END) + if (present(startCdata_handler)) then + call startCdata_handler + if (fx%state==ST_STOP) goto 100 + endif + if (.not.is_varstr_empty(fx%name)) then + if (present(characters_handler)) then + call characters_handler(str_varstr(fx%name)) + if (fx%state==ST_STOP) goto 100 + endif + endif + if (present(endCdata_handler)) then + call endCdata_handler + if (fx%state==ST_STOP) goto 100 + endif + call set_varstr_null(fx%name) + nextState = ST_CHAR_IN_CONTENT + end select + + case (ST_IN_TAG) + !write(*,*)'ST_IN_TAG' + select case (fx%tokenType) + case (TOK_END_TAG) + if (fx%context /= CTXT_IN_CONTENT) then + if (.not.is_varstr_null(fx%root_element)) then + if (validCheck) then + if (.not.equal_varstr_varstr(fx%name,fx%root_element)) then + call add_error(fx%error_stack, "Root element name does not match document name") + goto 100 + endif + endif + call set_varstr_null(fx%root_element) + elseif (validCheck) then + call add_error(fx%error_stack, "No DTD defined") + goto 100 + else + ! We havent had a DTD, so we havent handed xds + ! over to the DOM. + if (present(FoX_endDTD_handler)) then + fx%xds_used = .true. + call FoX_endDTD_handler(fx%xds) + endif + endif + fx%context = CTXT_IN_CONTENT + endif + call open_tag + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + call set_varstr_null(fx%name) + nextState = ST_CHAR_IN_CONTENT + + case (TOK_END_TAG_CLOSE) + if (fx%context==CTXT_IN_CONTENT) then + nextState = ST_CHAR_IN_CONTENT + else + ! only a single element in this doc + if (.not.is_varstr_null(fx%root_element)) then + if (validCheck) then + if (.not.equal_varstr_varstr(fx%name,fx%root_element)) then + call add_error(fx%error_stack, "Root element name does not match document name") + goto 100 + endif + endif + call set_varstr_null(fx%root_element) + elseif (validCheck) then + call add_error(fx%error_stack, "No DTD defined") + goto 100 + else + ! No DTD, so we havent handed over xds + if (present(FoX_endDTD_handler)) then + fx%xds_used = .true. + call FoX_endDTD_handler(fx%xds) + endif + endif + endif + call open_tag + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + call close_tag + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + call set_varstr_null(fx%name) + if (fx%context/=CTXT_IN_CONTENT) then + fx%well_formed = .true. + fx%context = CTXT_AFTER_CONTENT + nextState = ST_MISC + endif + + case (TOK_NAME) + if (namespaces_) then + nameOk = checkQName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, "Illegal attribute name") + goto 100 + endif + !Have we already had this dictionary item? + if (has_key(fx%attributes, str_varstr(fx%token))) then + call add_error(fx%error_stack, "Duplicate attribute name") + goto 100 + endif + call move_varstr_varstr(fx%token,fx%attname) + if (associated(elem)) then + attDecl => get_attribute_declaration(elem, str_varstr(fx%attname)) + else + attDecl => null() + endif + nextState = ST_ATT_NAME + end select + + case (ST_ATT_NAME) + !write(*,*)'ST_ATT_NAME' + select case (fx%tokenType) + case (TOK_EQUALS) + nextState = ST_ATT_EQUALS + end select + + case (ST_ATT_EQUALS) + !write(*,*)'ST_ATT_EQUALS' + ! token is pre-processed attribute value. + ! fx%name still contains attribute name + select case (fx%tokenType) + case (TOK_CHAR) + !First, expand all entities: + tempString2 => vs_varstr_alloc(fx%token) + tempString => normalize_attribute_text(fx, tempString2, fb) + call varstr_vs( fx%token, tempString ) + deallocate(tempString) + deallocate(tempString2) + tempString => null() + !If this attribute is not CDATA, we must process further; + if (associated(attDecl)) then + temp_i = attDecl%attType + else + temp_i = ATT_CDATA + endif + if (temp_i==ATT_CDATA) then + call add_item_to_dict(fx%attributes, str_varstr(fx%attname), & + str_varstr(fx%token), itype=ATT_CDATA, declared=associated(attDecl)) + else + if (validCheck) then + if (fx%xds%standalone.and..not.attDecl%internal & + .and.(str_varstr(fx%token)//"x"/=att_value_normalize(str_varstr(fx%token))//"x")) then + call add_error(fx%error_stack, & + "Externally-declared attribute value normalization results in changed value "// & + "in standalone document") + goto 100 + endif + endif + call add_item_to_dict(fx%attributes, str_varstr(fx%attname), & + att_value_normalize(str_varstr(fx%token)), itype=temp_i, & + declared=.true.) + endif + call set_varstr_null(fx%attname) + nextState = ST_IN_TAG + end select + + case (ST_CHAR_IN_CONTENT) + !write(*,*)'ST_CHAR_IN_CONTENT' + select case (fx%tokenType) + case (TOK_CHAR) + if (varstr_len(fx%token)>0) then + if (validCheck) then + if (elementContent(fx%elstack)) then + if (verify(str_varstr(fx%token), XML_WHITESPACE)==0) then + if (fx%xds%standalone.and..not.elem%internal) then + call add_error(fx%error_stack, & + "Externally-specified ignorable whitespace used in standalone document") + goto 100 + endif + if (present(ignorableWhitespace_handler)) then + call ignorableWhitespace_handler(str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif + else + call add_error(fx%error_stack, "Forbidden content inside elementc: "//get_top_elstack(fx%elstack)) + goto 100 + endif + elseif (emptyContent(fx%elstack)) then + call add_error(fx%error_stack, "Forbidden content inside element: "//get_top_elstack(fx%elstack)) + goto 100 + else + if (present(characters_handler)) then + call characters_handler(str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif + endif + else + if (present(characters_handler)) then + call characters_handler(str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif + endif + endif + nextState = ST_TAG_IN_CONTENT + end select + + case (ST_TAG_IN_CONTENT) + !write(*,*) 'ST_TAG_IN_CONTENT' + select case (fx%tokenType) + case (TOK_ENTITY) + nextState = ST_START_ENTITY + case (TOK_PI_TAG) + wf_stack(1) = wf_stack(1) + 1 + nextState = ST_START_PI + case (TOK_BANG_TAG) + wf_stack(1) = wf_stack(1) + 1 + nextState = ST_BANG_TAG + case (TOK_CLOSE_TAG) + nextState = ST_CLOSING_TAG + case (TOK_OPEN_TAG) + wf_stack(1) = wf_stack(1) + 1 + nextState = ST_START_TAG + end select + + case (ST_START_ENTITY) + !write(*,*) 'ST_START_ENTITY' + select case (fx%tokenType) + case (TOK_NAME) + if (validCheck) then + elem => get_element(fx%xds%element_list, get_top_elstack(fx%elstack)) + if (associated(elem)) then + if (elem%empty) then + call add_error(fx%error_stack, & + "Forbidden content inside element") + goto 100 + endif + else + call add_error(fx%error_stack, & + 'Encountered reference to undeclared entity') + endif + endif + ent => getEntityByName(fx%forbidden_ge_list, str_varstr(fx%token)) + if (associated(ent)) then + call add_error(fx%error_stack, 'Recursive entity reference') + goto 100 + endif + ent => getEntityByName(fx%predefined_e_list, str_varstr(fx%token)) + if (associated(ent)) then + if (present(startEntity_handler)) then + call startEntity_handler(str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif + if (validCheck) then + if (associated(elem)) then + if (.not.elem%mixed.and..not.elem%any) then + call add_error(fx%error_stack, & + "Forbidden content inside element") + goto 100 + endif + endif + endif + if (present(characters_handler)) then + call characters_handler(expand_entity(fx%predefined_e_list, str_varstr(fx%token))) + if (fx%state==ST_STOP) goto 100 + endif + if (present(endEntity_handler)) then + call endEntity_handler(str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif + elseif (likeCharacterEntityReference(str_varstr(fx%token))) then + if (checkRepCharEntityReference(str_varstr(fx%token), fx%xds%xml_version)) then + if (validCheck) then + if (associated(elem)) then + if (.not.elem%mixed.and..not.elem%any) then + call add_error(fx%error_stack, & + "Forbidden content inside element") + goto 100 + endif + endif + endif + if (present(characters_handler)) then + call characters_handler(expand_char_entity(str_varstr(fx%token))) + if (fx%state==ST_STOP) goto 100 + endif + elseif (checkCharacterEntityReference(str_varstr(fx%token), fx%xds%xml_version)) then + call add_error(fx%error_stack, "Unable to digest character entity reference in content, sorry.") + goto 100 + else + call add_error(fx%error_stack, "Illegal character reference") + goto 100 + endif + elseif (existing_entity(fx%xds%entityList, str_varstr(fx%token))) then + ent => getEntityByName(fx%xds%entityList, str_varstr(fx%token)) + if (ent%wfc.and.fx%xds%standalone) then + call add_error(fx%error_stack, & + 'Externally declared entity referenced in standalone document') + goto 100 + elseif (str_vs(ent%notation)/="") then + call add_error(fx%error_stack, & + 'Cannot reference unparsed entity in content') + goto 100 + elseif (ent%external) then + call open_new_file(fb, ent%baseURI, iostat) + if (iostat/=0) then + if (validCheck) then + call add_error(fx%error_stack, & + "Unable to retrieve external entity "//str_varstr(fx%token)) + goto 100 + endif + if (present(skippedEntity_handler)) then + call skippedEntity_handler(str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif + else + if (present(startEntity_handler)) then + call startEntity_handler(str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif +#ifdef PGF90 + call add_internal_entity(fx%forbidden_ge_list, str_varstr(fx%token), "", nullURI, .false.) +#else + call add_internal_entity(fx%forbidden_ge_list, str_varstr(fx%token), "", null(), .false.) +#endif + temp_wf_stack => wf_stack + allocate(wf_stack(size(temp_wf_stack)+1)) + wf_stack = (/0, temp_wf_stack/) + deallocate(temp_wf_stack) + temp_wf_stack => extEntStack + allocate(extEntStack(size(temp_wf_stack)+1)) + extEntStack = (/len(fx%elstack), temp_wf_stack/) + deallocate(temp_wf_stack) + call parse_text_declaration(fb, fx%error_stack) + if (in_error(fx%error_stack)) goto 100 + endif + else + if (validCheck.and.associated(elem)) then + if (elem%empty) then + call add_error(fx%error_stack, & + "Forbidden content inside element") + goto 100 + endif + endif + if (present(startEntity_handler)) then + call startEntity_handler(str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif +#ifdef PGF90 + call add_internal_entity(fx%forbidden_ge_list, str_varstr(fx%token), "", nullURI, .false.) +#else + call add_internal_entity(fx%forbidden_ge_list, str_varstr(fx%token), "", null(), .false.) +#endif + call open_new_string(fb, expand_entity(fx%xds%entityList, str_varstr(fx%token)), & + str_varstr(fx%token), baseURI=ent%baseURI) + temp_wf_stack => wf_stack + allocate(wf_stack(size(temp_wf_stack)+1)) + wf_stack = (/0, temp_wf_stack/) + deallocate(temp_wf_stack) + endif + else + ! Unknown entity check standalone etc + if (fx%skippedExternal.and..not.fx%xds%standalone) then + if (present(skippedEntity_handler)) then + call skippedEntity_handler(str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif + else + call add_error(fx%error_stack, & + 'Encountered reference to undeclared entity') + endif + endif + nextState = ST_CHAR_IN_CONTENT + end select + + case (ST_CLOSING_TAG) + !write(*,*)'ST_CLOSING_TAG' + select case (fx%tokenType) + case (TOK_NAME) + if (checkName(str_varstr(fx%token), fx%xds%xml_version)) then + call move_varstr_varstr(fx%token,fx%name) + nextState = ST_IN_CLOSING_TAG + else + call add_error(fx%error_stack, "Closing tag: expecting a Name") + goto 100 + end if + end select + + case (ST_IN_CLOSING_TAG) + !write(*,*)'ST_IN_CLOSING_TAG' + select case (fx%tokenType) + case (TOK_END_TAG) + call close_tag + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + call set_varstr_null(fx%name) + if (is_empty(fx%elstack)) then + if (startInCharData_) then + fx%well_formed = .true. + nextState = ST_CHAR_IN_CONTENT + else + !we're done + if (validCheck) then + call checkIdRefs + if (in_error(fx%error_stack)) goto 100 + endif + fx%well_formed = .true. + nextState = ST_MISC + fx%context = CTXT_AFTER_CONTENT + endif + else + nextState = ST_CHAR_IN_CONTENT + endif + end select + + case (ST_IN_DOCTYPE) + !write(*,*)'ST_IN_DOCTYPE' + select case (fx%tokenType) + case (TOK_NAME) + if (namespaces_) then + nameOk = checkQName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, "Invalid document name") + goto 100 + endif + call move_varstr_varstr(fx%token,fx%root_element) + nextState = ST_DOC_NAME + end select + + case (ST_DOC_NAME) + !write(*,*) 'ST_DOC_NAME ', str_varstr(fx%token) + select case (fx%tokenType) + case (TOK_NAME) + if (equal_varstr_str(fx%token,'SYSTEM')) then + nextState = ST_DOC_SYSTEM + elseif (equal_varstr_str(fx%token,'PUBLIC')) then + nextState = ST_DOC_PUBLIC + endif + case (TOK_OPEN_SB) + if (present(startDTD_handler)) then + call startDTD_handler(str_varstr(fx%root_element), "", "") + if (fx%state==ST_STOP) goto 100 + endif + wf_stack(1) = wf_stack(1) + 1 + nextState = ST_IN_SUBSET + fx%inIntSubset = .true. + case (TOK_END_TAG) + if (present(startDTD_handler)) then + call startDTD_handler(str_varstr(fx%root_element), "", "") + if (fx%state==ST_STOP) goto 100 + endif + wf_stack(1) = wf_stack(1) - 1 + call endDTDchecks + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + fx%context = CTXT_BEFORE_CONTENT + nextState = ST_MISC + case default + call add_error(fx%error_stack, "Unexpected token") + goto 100 + end select + + case (ST_DOC_PUBLIC) + !write(*,*) 'ST_DOC_PUBLIC' + select case (fx%tokenType) + case (TOK_CHAR) + if (checkPublicId(str_varstr(fx%token))) then + call move_varstr_varstr(fx%token,fx%publicId) + nextState = ST_DOC_SYSTEM + else + call add_error(fx%error_stack, "Invalid document public id") + goto 100 + endif + end select + + case (ST_DOC_SYSTEM) + !write(*,*) 'ST_DOC_SYSTEM' + select case (fx%tokenType) + case (TOK_CHAR) + call move_varstr_varstr(fx%token,fx%systemId) + nextState = ST_DOC_DECL + end select + + case (ST_DOC_DECL) + !write(*,*) 'ST_DOC_DECL' + select case (fx%tokenType) + case (TOK_OPEN_SB) + if (present(startDTD_handler)) then + if (.not.is_varstr_null(fx%publicId)) then + call startDTD_handler(str_varstr(fx%root_element), & + publicId=str_varstr(fx%publicId), systemId=str_varstr(fx%systemId)) + elseif (.not.is_varstr_null(fx%systemId)) then + call startDTD_handler(str_varstr(fx%root_element), & + publicId="", systemId=str_varstr(fx%systemId)) + else + call startDTD_handler(str_varstr(fx%root_element), "", "") + endif + if (fx%state==ST_STOP) goto 100 + endif + if (.not.is_varstr_null(fx%systemId)) then + extSubsetURI => parseURI(str_varstr(fx%systemId)) + call set_varstr_null(fx%systemId) + endif + call set_varstr_null(fx%publicId) + fx%inIntSubset = .true. + wf_stack(1) = wf_stack(1) + 1 + nextState = ST_IN_SUBSET + case (TOK_END_TAG) + if (present(startDTD_handler)) then + if (.not.is_varstr_null(fx%publicId)) then + call startDTD_handler(str_varstr(fx%root_element), publicId=str_varstr(fx%publicId), systemId=str_varstr(fx%systemId)) + call set_varstr_null(fx%publicId) + elseif (.not.is_varstr_null(fx%systemId)) then + call startDTD_handler(str_varstr(fx%root_element), publicId="", systemId=str_varstr(fx%systemId)) + else + call startDTD_handler(str_varstr(fx%root_element), "", "") + endif + if (fx%state==ST_STOP) goto 100 + endif + if (.not.is_varstr_null(fx%systemId)) then + extSubsetURI => parseURI(str_varstr(fx%systemId)) + if (.not.associated(extSubsetURI)) then + call add_error(fx%error_stack, "Invalid URI specified for DTD SYSTEM") + goto 100 + endif + call open_new_file(fb, extSubsetURI, iostat) + if (iostat==0) then + fx%inIntSubset=.false. + call parse_text_declaration(fb, fx%error_stack) + if (in_error(fx%error_stack)) goto 100 + temp_wf_stack => wf_stack + allocate(wf_stack(size(temp_wf_stack)+1)) + wf_stack = (/0, temp_wf_stack/) + deallocate(temp_wf_stack) + inExtSubset = .true. + nextState = ST_IN_SUBSET + else + if (validCheck) then + call add_error(fx%error_stack, & + "Unable to retrieve external subset "//str_varstr(fx%systemId)) + goto 100 + endif + call endDTDchecks + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + fx%context = CTXT_BEFORE_CONTENT + nextState = ST_MISC + endif + call destroyURI(extSubsetURI) + else + call endDTDchecks + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + fx%context = CTXT_BEFORE_CONTENT + nextState = ST_MISC + endif + call set_varstr_null(fx%systemId) + call set_varstr_null(fx%publicId) + case default + call add_error(fx%error_stack, "Unexpected token in DTD") + goto 100 + end select + + + case (ST_CLOSE_DOCTYPE) + !write(*,*) "ST_CLOSE_DOCTYPE" + select case (fx%tokenType) + case (TOK_END_TAG) + if (wf_stack(1)>1) then + call add_error(fx%error_stack, "Cannot end DTD while conditional section is still open") + goto 100 + endif + if (associated(extSubsetURI)) then + call open_new_file(fb, extSubsetURI, iostat) + call destroyURI(extSubsetURI) + if (iostat==0) then + fx%inIntSubset = .false. + call parse_text_declaration(fb, fx%error_stack) + if (in_error(fx%error_stack)) goto 100 + temp_wf_stack => wf_stack + allocate(wf_stack(size(temp_wf_stack)+1)) + wf_stack = (/0, temp_wf_stack/) + deallocate(temp_wf_stack) + inExtSubset = .true. + nextState = ST_IN_SUBSET + else + if (validCheck) then + call add_error(fx%error_stack, & + "Unable to retrieve external subset") + goto 100 + endif + call endDTDchecks + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + wf_stack(1) = wf_stack(1) - 1 + nextState = ST_MISC + fx%context = CTXT_BEFORE_CONTENT + endif + else + call endDTDchecks + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + wf_stack(1) = wf_stack(1) - 1 + nextState = ST_MISC + fx%context = CTXT_BEFORE_CONTENT + endif + end select + + case (ST_IN_SUBSET) + select case(fx%tokenType) + case (TOK_ENTITY) + nextState = ST_START_PE + case default + call parseDTD + if (in_error(fx%error_stack)) goto 100 + if (fx%state==ST_STOP) goto 100 + if (fx%state_dtd==ST_DTD_DONE) & + fx%state_dtd = ST_DTD_SUBSET + end select + + case (ST_START_PE) + !write(*,*) 'ST_START_PE' + select case (fx%tokenType) + case (TOK_NAME) + if (existing_entity(fx%forbidden_pe_list, str_varstr(fx%token))) then + call add_error(fx%error_stack, & + 'Recursive entity reference') + goto 100 + endif + ent => getEntityByName(fx%xds%PEList, str_varstr(fx%token)) + if (associated(ent)) then + if (ent%wfc.and.fx%xds%standalone) then + call add_error(fx%error_stack, & + "Externally declared entity used in standalone document") + goto 100 + elseif (ent%external) then + if (present(startEntity_handler)) then + call startEntity_handler('%'//str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif +#ifdef PGF90 + call add_internal_entity(fx%forbidden_pe_list, & + str_varstr(fx%token), "", nullURI, .false.) +#else + call add_internal_entity(fx%forbidden_pe_list, & + str_varstr(fx%token), "", null(), .false.) +#endif + call open_new_file(fb, ent%baseURI, iostat, pe=.true.) + if (iostat/=0) then + if (validCheck) then + call add_error(fx%error_stack, & + "Unable to retrieve external parameter entity "//str_varstr(fx%token)) + goto 100 + endif + if (present(skippedEntity_handler)) then + call skippedEntity_handler('%'//str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif + ! having skipped a PE, we must now not process + ! declarations any further (unless we are declared standalone) + ! (XML section 5.1) + fx%skippedExternal = .true. + processDTD = fx%xds%standalone + else + fx%inIntSubset = .false. + if (present(startEntity_handler)) then + call startEntity_handler('%'//str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif +#ifdef PGF90 + call add_internal_entity(fx%forbidden_pe_list, & + str_varstr(fx%token), "", nullURI, .false.) +#else + call add_internal_entity(fx%forbidden_pe_list, & + str_varstr(fx%token), "", null(), .false.) +#endif + call parse_text_declaration(fb, fx%error_stack) + if (in_error(fx%error_stack)) goto 100 + allocate(temp_wf_stack(size(wf_stack)+1)) + temp_wf_stack = (/0, wf_stack/) + deallocate(wf_stack) + wf_stack => temp_wf_stack + if (fx%state_dtd==ST_DTD_SUBSET) & + declSepValue = size(wf_stack) + endif + else + ! Expand the entity, + if (present(startEntity_handler)) then + call startEntity_handler('%'//str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif +#ifdef PGF90 + call add_internal_entity(fx%forbidden_pe_list, & + str_varstr(fx%token), "", nullURI, .false.) + call open_new_string(fb, & + expand_entity(fx%xds%PEList, str_varstr(fx%token)), str_varstr(fx%token), baseURI=nullURI, pe=.true.) +#else + call add_internal_entity(fx%forbidden_pe_list, & + str_varstr(fx%token), "", null(), .false.) + call open_new_string(fb, & + expand_entity(fx%xds%PEList, str_varstr(fx%token)), str_varstr(fx%token), baseURI=null(), pe=.true.) +#endif + ! NB because we are just expanding a string here, anything + ! evaluated as a result of this string is evaluated in the + ! context of the currently open file, so has a baseURI of + ! this file + allocate(temp_wf_stack(size(wf_stack)+1)) + temp_wf_stack = (/0, wf_stack/) + deallocate(wf_stack) + wf_stack => temp_wf_stack + if (fx%state_dtd==ST_DTD_SUBSET) & + declSepValue = size(wf_stack) + endif + ! and do nothing else, carry on ... + else + ! Have we previously skipped an external entity? + if (fx%skippedExternal.and..not.fx%xds%standalone) then + if (processDTD) then + if (present(skippedEntity_handler)) then + call skippedEntity_handler('%'//str_varstr(fx%token)) + if (fx%state==ST_STOP) goto 100 + endif + endif + else + ! If not, + call add_error(fx%error_stack, & + "Reference to undeclared parameter entity.") + goto 100 + endif + endif + nextState = ST_IN_SUBSET + + end select + + end select + + if (nextState/=ST_NULL) then + fx%state = nextState + else + call add_error(fx%error_stack, "Internal error in parser - no suitable token found.") + goto 100 + endif + + end do + +100 continue + if (in_error(fx%error_stack)) call add_error_position(fx%error_stack, fb) + if (associated(tempString)) deallocate(tempString) + if (associated(tempString2)) deallocate(tempString2) + if (associated(extSubsetURI)) call destroyURI(extSubsetURI) + call destroy_string_list(id_list) + call destroy_string_list(idref_list) + deallocate(wf_stack) + if (associated(extEntStack)) deallocate(extEntStack) + + if (fx%state==ST_STOP) return + if (.not.eof) then + ! We have encountered an error before the end of a file + if (.not.reading_main_file(fb)) then !we are parsing an entity + if (inExtSubset) then + call add_error(fx%error_stack, "Error encountered processing external subset.") + else + call add_error(fx%error_stack, "Error encountered processing entity.") + endif + call sax_error(fx, fatalError_handler) + else + call sax_error(fx, fatalError_handler) + endif + else + ! EOF of main file + if (startInChardata_) then + if (fx%well_formed) then + !Note: it used to be as follows: + !if (fx%state==ST_CHAR_IN_CONTENT.and.associated(fx%token%data)) then + !It is probably safe now not to check if token%data is allocated, as in case it is not, + !token%length should be -1... but if it crashes, you know the culprit. + if (fx%state==ST_CHAR_IN_CONTENT) then + if (varstr_len(fx%token)>0.and.present(characters_handler)) & + call characters_handler(str_varstr(fx%token)) + endif + else + if (present(fatalError_handler)) & + call fatalError_handler("Ill-formed XML fragment") + endif + elseif (fx%well_formed.and.fx%state==ST_MISC) then + if (present(endDocument_handler)) & + call endDocument_handler() + else + call add_error(fx%error_stack, "File is not well-formed") + call sax_error(fx, fatalError_handler) + endif + endif + + contains + + subroutine parseDTD + + integer :: nextDTDState +#ifdef PGF90 + type(element_t), pointer :: nullElement + + nullElement => null() +#endif + + nextDTDState = ST_DTD_NULL + + select case (fx%state_dtd) + + case (ST_DTD_SUBSET) + !write(*,*) "ST_DTD_SUBSET" + select case (fx%tokenType) + case (TOK_CLOSE_SB) + if (.not.reading_main_file(fb)) then + call add_error(fx%error_stack, "Cannot close DOCTYPE in external entity") + return + endif + wf_stack(1) = wf_stack(1) - 1 + fx%inIntSubset = .false. + nextState = ST_CLOSE_DOCTYPE + nextDTDState = ST_DTD_DONE + case (TOK_SECTION_END) + if (wf_stack(1)==0) then + call add_error(fx%error_stack, "Unbalanced conditional section in parameter entity") + return + endif + wf_stack(1) = wf_stack(1) - 2 + nextDTDState = ST_DTD_SUBSET + case (TOK_PI_TAG) + wf_stack(1) = wf_stack(1) + 1 + nextDTDState = ST_DTD_START_PI + case (TOK_BANG_TAG) + wf_stack(1) = wf_stack(1) + 1 + nextDTDState = ST_DTD_BANG_TAG + case default + call add_error(fx%error_stack, "Unexpected token in document subset") + return + end select + + + case (ST_DTD_BANG_TAG) + !write(*,*) 'ST_DTD_BANG_TAG' + select case (fx%tokenType) + case (TOK_OPEN_SB) + nextDTDState = ST_DTD_START_SECTION_DECL + case (TOK_OPEN_COMMENT) + nextDTDState = ST_DTD_START_COMMENT + case (TOK_NAME) + if (equal_varstr_str(fx%token,'ATTLIST')) then + nextDTDState = ST_DTD_ATTLIST + elseif (equal_varstr_str(fx%token,'ELEMENT')) then + nextDTDState = ST_DTD_ELEMENT + elseif (equal_varstr_str(fx%token,'ENTITY')) then + nextDTDState = ST_DTD_ENTITY + elseif (equal_varstr_str(fx%token,'NOTATION')) then + nextDTDState = ST_DTD_NOTATION + endif + end select + + case (ST_DTD_START_SECTION_DECL) + !write(*,*) "ST_DTD_START_SECTION_DECL" + select case (fx%tokenType) + case (TOK_NAME) + if (equal_varstr_str(fx%token,"IGNORE")) then + if (fx%context/=CTXT_IN_DTD.or.reading_main_file(fb)) then + call add_error(fx%error_stack, "IGNORE section only allowed in external subset.") + return + else + ignoreDepth = 0 + fx%context = CTXT_IGNORE + nextDTDState = ST_DTD_FINISH_SECTION_DECL + endif + elseif (equal_varstr_str(fx%token,"INCLUDE")) then + if (fx%context/=CTXT_IN_DTD.or.reading_main_file(fb)) then + call add_error(fx%error_stack, "INCLUDE section only allowed in external subset.") + return + else + nextDTDState = ST_DTD_FINISH_SECTION_DECL + endif + else + call add_error(fx%error_stack, "Unknown keyword found in marked section declaration.") + endif + end select + + + case (ST_DTD_FINISH_SECTION_DECL) + !write(*,*) "ST_FINISH_SECTION_DECL" + select case (fx%tokenType) + case (TOK_OPEN_SB) + wf_stack(1) = wf_stack(1) + 1 + if (fx%context==CTXT_IGNORE) then + nextDTDState = ST_DTD_IN_IGNORE_SECTION + ignoreDepth = ignoreDepth + 1 + else + nextDTDState = ST_DTD_SUBSET + endif + end select + + + case (ST_DTD_IN_IGNORE_SECTION) + !write(*,*) "ST_IN_IGNORE_SECTION" + select case (fx%tokenType) + case (TOK_SECTION_START) + wf_stack(1) = wf_stack(1) + 2 + ignoreDepth = ignoreDepth + 1 + nextDTDState = ST_DTD_IN_IGNORE_SECTION + case (TOK_SECTION_END) + wf_stack(1) = wf_stack(1) - 2 + ignoreDepth = ignoreDepth - 1 + if (ignoreDepth==0) then + fx%context = CTXT_IN_DTD + nextDTDState = ST_DTD_SUBSET + else + nextDTDState = ST_DTD_IN_IGNORE_SECTION + endif + end select + + case (ST_DTD_START_PI) + !write(*,*)'ST_DTD_START_PI' + select case (fx%tokenType) + case (TOK_NAME) + if (namespaces_) then + nameOk = checkNCName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (nameOk) then + if (equal_varstr_str(fx%token,'xml')) then + call add_error(fx%error_stack, "XML declaration must be at start of document") + return + elseif (checkPITarget(str_varstr(fx%token), fx%xds%xml_version)) then + nextDTDState = ST_DTD_PI_CONTENTS + call move_varstr_varstr(fx%token,fx%name) + else + call add_error(fx%error_stack, "Invalid PI target name") + return + endif + endif + end select + + case (ST_DTD_PI_CONTENTS) + !write(*,*)'ST_DTD_PI_CONTENTS' + if (validCheck) then + if (fx%context==CTXT_IN_DTD.and.wf_stack(1)==0) then + call add_error(fx%error_stack, & + "PI not balanced in parameter entity") + return + endif + if (len(fx%elstack)>0) then + elem => & + get_element(fx%xds%element_list, get_top_elstack(fx%elstack)) + if (associated(elem)) then + if (elem%empty) then + call add_error(fx%error_stack, "Content inside empty element") + endif + endif + endif + endif + wf_stack(1) = wf_stack(1) - 1 + + select case(fx%tokenType) + case (TOK_CHAR) + if (present(processingInstruction_handler)) then + call processingInstruction_handler(str_varstr(fx%name), str_varstr(fx%token)) + if (fx%state==ST_STOP) return + endif + call set_varstr_null(fx%name) + nextDTDState = ST_DTD_PI_END + case (TOK_PI_END) + if (present(processingInstruction_handler)) then + call processingInstruction_handler(str_varstr(fx%name), '') + if (fx%state==ST_STOP) return + endif + call set_varstr_null(fx%name) + nextDTDState = ST_DTD_SUBSET + end select + + case (ST_DTD_PI_END) + !write(*,*)'ST_DTD_PI_END' + select case(fx%tokenType) + case (TOK_PI_END) + nextDTDState = ST_DTD_SUBSET + end select + + case (ST_DTD_START_COMMENT) + !write(*,*)'ST_DTD_START_COMMENT' + select case (fx%tokenType) + case (TOK_CHAR) + call move_varstr_varstr(fx%token,fx%name) + nextDTDState = ST_DTD_COMMENT_END + end select + + case (ST_DTD_COMMENT_END) + !write(*,*)'ST_DTD_COMMENT_END' + if (validCheck) then + if (wf_stack(1)==0) then + call add_error(fx%error_stack, & + "Comment not balanced in entity") + return + endif + if (len(fx%elstack)>0) then + elem => & + get_element(fx%xds%element_list, get_top_elstack(fx%elstack)) + if (associated(elem)) then + if (elem%empty) then + call add_error(fx%error_stack, "Content inside empty element") + endif + endif + endif + endif + wf_stack(1) = wf_stack(1) - 1 + + select case (fx%tokenType) + case (TOK_COMMENT_END) + if (present(comment_handler)) then + call comment_handler(str_varstr(fx%name)) + if (fx%state==ST_STOP) return + endif + call set_varstr_null(fx%name) + nextDTDState = ST_DTD_SUBSET + end select + + case (ST_DTD_ATTLIST) + !write(*,*) 'ST_DTD_ATTLIST' + select case (fx%tokenType) + case (TOK_NAME) + if (namespaces_) then + nameOk = checkQName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, "Invalid element name for ATTLIST") + return + endif + if (existing_element(fx%xds%element_list, str_varstr(fx%token))) then + elem => get_element(fx%xds%element_list, str_varstr(fx%token)) + else + elem => add_element(fx%xds%element_list, str_varstr(fx%token)) + endif + nextDTDState = ST_DTD_ATTLIST_CONTENTS + end select + + case (ST_DTD_ATTLIST_CONTENTS) + !write(*,*) 'ST_DTD_ATTLIST_CONTENTS' + select case (fx%tokenType) + case (TOK_ENTITY) + !Weve found a PEref in the middle of the element contents + ! Leave DTD state as it is & expand the entity ... + nextState = ST_START_PE + case (TOK_DTD_CONTENTS) + if (processDTD) then + call parse_dtd_attlist(str_varstr(fx%token), fx%xds%xml_version, & + namespaces_, validCheck, fx%error_stack, elem, & + internal=reading_main_file(fb)) + else +#ifdef PGF90 + call parse_dtd_attlist(str_varstr(fx%token), fx%xds%xml_version, & + namespaces_, validCheck, fx%error_stack, nullElement, & + internal=reading_main_file(fb)) +#else + call parse_dtd_attlist(str_varstr(fx%token), fx%xds%xml_version, & + namespaces_, validCheck, fx%error_stack, null(), & + internal=reading_main_file(fb)) +#endif + endif + if (in_error(fx%error_stack)) return + ! Normalize attribute values in attlist + if (processDTD) then + do i = 1, size(elem%attlist%list) + if (associated(elem%attlist%list(i)%default)) then + tempString => elem%attlist%list(i)%default + elem%attlist%list(i)%default => & + normalize_attribute_text(fx, tempString, fb) + deallocate(tempString) + if (in_error(fx%error_stack)) return + endif + enddo + endif + nextDTDState = ST_DTD_ATTLIST_END + case (TOK_END_TAG) + if (validCheck) then + if (wf_stack(1)==0) then + call add_error(fx%error_stack, & + "ATTLIST not balanced in parameter entity") + return + endif + endif + wf_stack(1) = wf_stack(1) - 1 + if (processDTD) then + call parse_dtd_attlist("", fx%xds%xml_version, & + namespaces_, validCheck, fx%error_stack, elem, & + internal=reading_main_file(fb)) + else +#ifdef PGF90 + call parse_dtd_attlist("", fx%xds%xml_version, & + namespaces_, validCheck, fx%error_stack, nullElement, & + internal=reading_main_file(fb)) +#else + call parse_dtd_attlist("", fx%xds%xml_version, & + namespaces_, validCheck, fx%error_stack, null(), & + internal=reading_main_file(fb)) +#endif + endif + if (in_error(fx%error_stack)) return + if (processDTD) then + if (present(attributeDecl_handler)) then + call report_declarations(elem, attributeDecl_handler) + if (fx%state==ST_STOP) return + endif + endif + nextDTDState = ST_DTD_SUBSET + end select + + case (ST_DTD_ATTLIST_END) + !write(*,*) 'ST_DTD_ATTLIST_END' + select case (fx%tokenType) + case (TOK_END_TAG) + if (validCheck) then + if (wf_stack(1)==0) then + call add_error(fx%error_stack, & + "ATTLIST not balanced in parameter entity") + return + endif + endif + wf_stack(1) = wf_stack(1) - 1 + if (processDTD) then + if (present(attributeDecl_handler)) then + call report_declarations(elem, attributeDecl_handler) + if (fx%state==ST_STOP) return + endif + endif + nextDTDState = ST_DTD_SUBSET + end select + + case (ST_DTD_ELEMENT) + select case (fx%tokenType) + case (TOK_NAME) + if (namespaces_) then + nameOk = checkQName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, "Invalid name for ELEMENT") + return + endif + call move_varstr_varstr(fx%token,fx%name) + nextDTDState = ST_DTD_ELEMENT_CONTENTS + end select + + case (ST_DTD_ELEMENT_CONTENTS) + !write(*,*)'ST_DTD_ELEMENT_CONTENTS' + select case (fx%tokenType) + case (TOK_OPEN_PAR) + ! increment well_formedness + wf_stack(1) = wf_stack(1) + 1 + nextDTDState = ST_DTD_ELEMENT_CONTENTS + case (TOK_CLOSE_PAR) + ! increment well_formedness + wf_stack(1) = wf_stack(1) - 1 + nextDTDState = ST_DTD_ELEMENT_CONTENTS + case (TOK_ENTITY) + !Weve found a PEref in the middle of the element contents + ! Leave DTD state as it is & expand the entity ... + nextState = ST_START_PE + case (TOK_DTD_CONTENTS) + if (declared_element(fx%xds%element_list, str_varstr(fx%name))) then + if (validCheck) then + call add_error(fx%error_stack, "Duplicate Element declaration") + return + else + ! Ignore contents ... + elem => null() + endif + elseif (processDTD) then + if (existing_element(fx%xds%element_list, str_varstr(fx%name))) then + elem => get_element(fx%xds%element_list, str_varstr(fx%name)) + else + elem => add_element(fx%xds%element_list, str_varstr(fx%name)) + endif + else + elem => null() + endif + call parse_dtd_element(str_varstr(fx%token), fx%xds%xml_version, fx%error_stack, & + elem, reading_main_file(fb)) + if (in_error(fx%error_stack)) return + nextDTDState = ST_DTD_ELEMENT_END + end select + + case (ST_DTD_ELEMENT_END) + !write(*,*)'ST_DTD_ELEMENT_END' + select case (fx%tokenType) + case (TOK_END_TAG) + if (validCheck) then + if (wf_stack(1)==0) then + call add_error(fx%error_stack, & + "ELEMENT not balanced in parameter entity") + return + endif + endif + wf_stack(1) = wf_stack(1) - 1 + if (processDTD.and.associated(elem)) then + if (present(elementDecl_handler)) then + call elementDecl_handler(str_varstr(fx%name), str_vs(elem%model)) + if (fx%state==ST_STOP) return + endif + endif + call set_varstr_null(fx%name) + nextDTDState = ST_DTD_SUBSET + end select + + case (ST_DTD_ENTITY) + !write(*,*) 'ST_DTD_ENTITY' + select case (fx%tokenType) + case (TOK_NAME) + if (equal_varstr_str(fx%token,"%")) then + pe = .true. + ! this will be a PE + nextDTDState = ST_DTD_ENTITY_PE + else + pe = .false. + if (namespaces_) then + nameOk = checkNCName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, & + "Illegal name for general entity") + return + endif + call move_varstr_varstr(fx%token,fx%name) + nextDTDState = ST_DTD_ENTITY_ID + endif + end select + + case (ST_DTD_ENTITY_PE) + !write(*,*) 'ST_DTD_ENTITY_PE' + select case (fx%tokenType) + case (TOK_NAME) + if (namespaces_) then + nameOk = checkNCName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, & + "Illegal name for parameter entity") + return + endif + call move_varstr_varstr(fx%token,fx%name) + nextDTDState = ST_DTD_ENTITY_ID + end select + + case (ST_DTD_ENTITY_ID) + !write(*,*) 'ST_DTD_ENTITY_ID' + select case (fx%tokenType) + case (TOK_NAME) + if (equal_varstr_str(fx%token,"PUBLIC")) then + nextDTDState = ST_DTD_ENTITY_PUBLIC + elseif (equal_varstr_str(fx%token,"SYSTEM")) then + nextDTDState = ST_DTD_ENTITY_SYSTEM + else + call add_error(fx%error_stack, "Unexpected token in ENTITY") + return + endif + case (TOK_CHAR) + if (reading_main_file(fb)) then + tempString => vs_varstr_alloc(fx%token) + else + tempString2 => vs_varstr_alloc(fx%token) + tempString => expand_pe_text(fx, tempString2, fb) + deallocate(tempString2) + endif + tempString2 => expand_entity_value_alloc(tempString, fx%xds, fx%error_stack) + call varstr_vs( fx%attname, tempString2 ) + deallocate(tempString2) + if (reading_main_file(fb)) then + tempString => null() + else + deallocate(tempString) + endif + if (in_error(fx%error_stack)) return + nextDTDState = ST_DTD_ENTITY_END + case default + call add_error(fx%error_stack, "Unexpected token in ENTITY") + return + end select + + case (ST_DTD_ENTITY_PUBLIC) + !write(*,*) 'ST_DTD_ENTITY_PUBLIC' + select case (fx%tokenType) + case (TOK_CHAR) + if (checkPublicId(str_varstr(fx%token))) then + call move_varstr_varstr(fx%token,fx%publicId) + nextDTDState = ST_DTD_ENTITY_SYSTEM + else + call add_error(fx%error_stack, "Invalid PUBLIC id in ENTITY") + return + endif + case default + call add_error(fx%error_stack, "Unexpected token in ENTITY") + return + end select + + case (ST_DTD_ENTITY_SYSTEM) + !write(*,*) 'ST_DTD_ENTITY_SYSTEM' + select case (fx%tokenType) + case (TOK_CHAR) + call move_varstr_varstr(fx%token,fx%systemId) + nextDTDState = ST_DTD_ENTITY_NDATA + case default + call add_error(fx%error_stack, "Unexpected token in ENTITY") + return + end select + + case (ST_DTD_ENTITY_NDATA) + !write(*,*) 'ST_DTD_ENTITY_NDATA' + select case (fx%tokenType) + case (TOK_END_TAG) + if (validCheck) then + if (wf_stack(1)==0) then + call add_error(fx%error_stack, & + "ENTITY not balanced in parameter entity") + return + endif + endif + wf_stack(1) = wf_stack(1) - 1 + if (processDTD) then + call add_entity + if (in_error(fx%error_stack)) return + if (fx%state==ST_STOP) return + endif + call set_varstr_null(fx%name) + call set_varstr_null(fx%attname) + call set_varstr_null(fx%systemId) + call set_varstr_null(fx%publicId) + call set_varstr_null(fx%Ndata) + nextDTDState = ST_DTD_SUBSET + case (TOK_NAME) + if (equal_varstr_str(fx%token,'NDATA')) then + if (pe) then + call add_error(fx%error_stack, "Parameter entity cannot have NDATA declaration") + return + endif + nextDTDState = ST_DTD_ENTITY_NDATA_VALUE + else + call add_error(fx%error_stack, "Unexpected token in ENTITY") + return + endif + case default + call add_error(fx%error_stack, "Unexpected token in ENTITY") + return + end select + + case (ST_DTD_ENTITY_NDATA_VALUE) + !write(*,*) 'ST_DTD_ENTITY_NDATA_VALUE' + !check is a name and exists in notationlist + select case (fx%tokenType) + case (TOK_NAME) + if (namespaces_) then + nameOk = checkNCName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, "Invalid name for Notation") + return + endif + call move_varstr_varstr(fx%token,fx%Ndata) + nextDTDState = ST_DTD_ENTITY_END + case default + call add_error(fx%error_stack, "Unexpected token in ENTITY") + return + end select + + case (ST_DTD_ENTITY_END) + !write(*,*) 'ST_DTD_ENTITY_END' + select case (fx%tokenType) + case (TOK_END_TAG) + if (validCheck) then + if (wf_stack(1)==0) then + call add_error(fx%error_stack, & + "ENTITY not balanced in parameter entity") + return + endif + endif + wf_stack(1) = wf_stack(1) - 1 + if (processDTD) then + call add_entity + if (in_error(fx%error_stack)) return + if (fx%state==ST_STOP) return + endif + call set_varstr_null(fx%name) + call set_varstr_null(fx%attname) + call set_varstr_null(fx%systemId) + call set_varstr_null(fx%publicId) + call set_varstr_null(fx%Ndata) + nextDTDState = ST_DTD_SUBSET + case default + call add_error(fx%error_stack, "Unexpected token at end of ENTITY") + return + end select + + case (ST_DTD_NOTATION) + !write(*,*) 'ST_DTD_NOTATION' + select case (fx%tokenType) + case (TOK_NAME) + if (namespaces_) then + nameOk = checkNCName(str_varstr(fx%token), fx%xds%xml_version) + else + nameOk = checkName(str_varstr(fx%token), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, "Invalid name for Notation") + return + endif + call move_varstr_varstr(fx%token,fx%name) + nextDTDState = ST_DTD_NOTATION_ID + case default + call add_error(fx%error_stack, "Unexpected token in NOTATION") + return + end select + + case (ST_DTD_NOTATION_ID) + !write(*,*)'ST_DTD_NOTATION_ID' + select case (fx%tokenType) + case (TOK_NAME) + if (equal_varstr_str(fx%token,'SYSTEM')) then + nextDTDState = ST_DTD_NOTATION_SYSTEM + elseif (equal_varstr_str(fx%token,'PUBLIC')) then + nextDTDState = ST_DTD_NOTATION_PUBLIC + else + call add_error(fx%error_stack, "Unexpected token after NOTATION") + return + endif + case default + call add_error(fx%error_stack, "Unexpected token after NOTATION") + return + end select + + case (ST_DTD_NOTATION_SYSTEM) + !write(*,*)'ST_DTD_NOTATION_SYSTEM' + select case (fx%tokenType) + case (TOK_CHAR) + call move_varstr_varstr(fx%token,fx%systemId) + nextDTDState = ST_DTD_NOTATION_END + case default + call add_error(fx%error_stack, "Unexpected token in NOTATION") + return + end select + + case (ST_DTD_NOTATION_PUBLIC) + !write(*,*)'ST_DTD_NOTATION_PUBLIC' + select case (fx%tokenType) + case (TOK_CHAR) + if (checkPublicId(str_varstr(fx%token))) then + call move_varstr_varstr(fx%token,fx%publicId) + nextDTDState = ST_DTD_NOTATION_PUBLIC_2 + else + call add_error(fx%error_stack, "Invalid PUBLIC id in NOTATION") + return + endif + case default + call add_error(fx%error_stack, "Unexpected token in NOTATION") + return + end select + + case (ST_DTD_NOTATION_PUBLIC_2) + !write(*,*)'ST_DTD_NOTATION_PUBLIC_2' + select case (fx%tokenType) + case (TOK_END_TAG) + if (validCheck) then + if (wf_stack(1)==0) then + call add_error(fx%error_stack, & + "NOTATION not balanced in parameter entity") + return + endif + if (notation_exists(fx%nlist, str_varstr(fx%name))) then + call add_error(fx%error_stack, "Duplicate notation declaration") + return + endif + endif + wf_stack(1) = wf_stack(1) - 1 + if (processDTD) then + call add_notation(fx%nlist, str_varstr(fx%name), publicId=str_varstr(fx%publicId)) + if (present(notationDecl_handler)) then + call notationDecl_handler(str_varstr(fx%name), publicId=str_varstr(fx%publicId), systemId="") + if (fx%state==ST_STOP) return + endif + endif + call set_varstr_null(fx%name) + call set_varstr_null(fx%publicId) + nextDTDState = ST_DTD_SUBSET + case (TOK_CHAR) + call move_varstr_varstr(fx%token,fx%systemId) + nextDTDState = ST_DTD_NOTATION_END + end select + + case (ST_DTD_NOTATION_END) + !write(*,*)'ST_DTD_NOTATION_END' + select case (fx%tokenType) + case (TOK_END_TAG) + if (validCheck) then + if (wf_stack(1)==0) then + call add_error(fx%error_stack, & + "NOTATION not balanced in parameter entity") + return + endif + if (notation_exists(fx%nlist, str_varstr(fx%name))) then + call add_error(fx%error_stack, "Duplicate notation declaration") + return + endif + endif + wf_stack(1) = wf_stack(1) - 1 + if (processDTD) then + URIref => parseURI(str_varstr(fx%systemId)) + if (.not.associated(URIref)) then + call add_error(fx%error_stack, "Invalid SYSTEM literal") + return + endif + if (hasFragment(URIref)) then + call destroyURI(URIref) + call add_error(fx%error_stack, "SYSTEM literal may not contain fragment") + return + endif + ! We aren't ever going to do anything with this URI, + ! since we don't do NOTATIONs. + ! Throw it away again + call destroyURI(URIref) + if (.not.is_varstr_null(fx%publicId)) then + call add_notation(fx%nlist, str_varstr(fx%name), & + publicId=str_varstr(fx%publicId), systemId=str_varstr(fx%systemId)) + if (present(notationDecl_handler)) then + call notationDecl_handler(str_varstr(fx%name), & + publicId=str_varstr(fx%publicId), systemId=str_varstr(fx%systemId)) + if (fx%state==ST_STOP) return + endif + else + call add_notation(fx%nlist, str_varstr(fx%name), & + systemId=str_varstr(fx%systemId)) + if (present(notationDecl_handler)) then + call notationDecl_handler(str_varstr(fx%name), & + publicId="", systemId=str_varstr(fx%systemId)) + if (fx%state==ST_STOP) return + endif + endif + endif + call set_varstr_null(fx%publicId) + call set_varstr_null(fx%systemId) + call set_varstr_null(fx%name) + nextDTDState = ST_DTD_SUBSET + case default + call add_error(fx%error_stack, "Unexpected token in NOTATION") + return + end select + + end select + + if (nextDTDState==ST_DTD_NULL) then + call add_error(fx%error_stack, & + "Bad token found in DTD parsing") + else + fx%state_dtd = nextDTDState + endif + if (nextState==ST_NULL) & + nextState = ST_IN_SUBSET + + end subroutine parseDTD + + subroutine open_tag + elem => get_element(fx%xds%element_list, str_varstr(fx%name)) + if (associated(elem)) then + if (validCheck) then + call checkAttributes(elem, fx%attributes) + if (.not.checkContentModel(fx%elstack, str_varstr(fx%name))) then + call add_error(fx%error_stack, & + "Element '"//str_varstr(fx%name)//"' not permitted in this context") + return + endif + else + call getDefaultAttributes(elem, fx%attributes) + endif + else + if (validCheck) then + call add_error(fx%error_stack, & + "Trying to use an unrecognised element '"//str_varstr(fx%name)//"'") + return + endif + endif + ! Check for namespace changes + if (namespaces_) then + call checkNamespaces(fx%attributes, fx%nsDict, & + len(fx%elstack), fx%xds, namespace_prefixes_, xmlns_uris_, & + fx%error_stack, startInCharData_, & + startPrefixMapping_handler, endPrefixMapping_handler) + if (fx%state==ST_STOP) return + endif + if (in_error(fx%error_stack)) return + call checkXmlAttributes + if (in_error(fx%error_stack)) return + if (size(extEntStack)>0) then + if (len(fx%elstack)==extEntStack(1)) & + ! This is a top-level element in the current entity + call setBase(fx%attributes, expressURI(fb%f(1)%baseURI)) + endif + if (namespaces_.and.getURIofQName(fx,str_varstr(fx%name))==invalidNS) then + ! no namespace was found for the current element + if (.not.startInCharData_) then + ! but we ignore this if we are parsing an entity through DOM + call add_error(fx%error_stack, "No namespace found for current element '"//str_varstr(fx%name)//"'") + return + elseif (present(startElement_handler)) then + ! Record it as having an empty URI + call startElement_handler("", & + getlocalNameofQName(str_varstr(fx%name)), & + str_varstr(fx%name), fx%attributes) + if (fx%state==ST_STOP) return + endif + elseif (namespaces_) then + ! Normal state of affairs + if (present(startElement_handler)) then + call startElement_handler(getURIofQName(fx, str_varstr(fx%name)), & + getlocalNameofQName(str_varstr(fx%name)), & + str_varstr(fx%name), fx%attributes) + if (fx%state==ST_STOP) return + endif + else + ! Non-namespace aware processing + if (present(startElement_handler)) then + call startElement_handler("", "", & + str_varstr(fx%name), fx%attributes) + if (fx%state==ST_STOP) return + endif + endif + if (validCheck) then + call push_elstack(fx%elstack, str_varstr(fx%name), elem%cp) + else + call push_elstack(fx%elstack, str_varstr(fx%name)) + endif + call reset_dict(fx%attributes) + end subroutine open_tag + + subroutine close_tag + character :: dummy + wf_stack(1) = wf_stack(1) - 1 + if (wf_stack(1)<0) then + call add_error(fx%error_stack, & + 'Ill-formed entity') + return + endif + if (str_varstr(fx%name)/=get_top_elstack(fx%elstack)) then + call add_error(fx%error_stack, & + "Mismatching close tag: trying to close entity '"//get_top_elstack(fx%elstack) & + //"' with '"//str_varstr(fx%name)//"'") + return + endif + if (validCheck) then + if (.not.checkContentModelToEnd(fx%elstack)) then + call add_error(fx%error_stack, & + "Failed to fulfil content model for "//str_varstr(fx%name)) + return + endif + endif + dummy = pop_elstack(fx%elstack) + if (present(endElement_handler)) then + if (namespaces_.and.getURIofQName(fx,str_varstr(fx%name))==invalidNS) then + ! no namespace was found for the current element, we must be + ! closing inside a DOM entity. + ! Record it as having an empty URI + call endElement_handler("", & + getlocalNameofQName(str_varstr(fx%name)), & + str_varstr(fx%name)) + elseif (namespaces_) then + ! Normal state of affairs + call endElement_handler(getURIofQName(fx, str_varstr(fx%name)), & + getlocalnameofQName(str_varstr(fx%name)), & + str_varstr(fx%name)) + else + ! Non-namespace-aware processing: + call endElement_handler("", "", & + str_varstr(fx%name)) + endif + if (fx%state==ST_STOP) return + endif + if (namespaces_) then + call checkEndNamespaces(fx%nsDict, len(fx%elstack), & + endPrefixMapping_handler) + if (fx%state==ST_STOP) return + endif + end subroutine close_tag + + subroutine add_entity + !Parameter or General Entity? + logical :: wfc + wfc = fb%f(1)%pe.or.inExtSubset + if (pe) then + !Does entity with this name exist? + if (.not.existing_entity(fx%xds%PEList, str_varstr(fx%name))) then + ! Internal or external? + if (.not.is_varstr_null(fx%attname)) then ! it's internal + call register_internal_PE(fx%xds, & + name=str_varstr(fx%name), text=str_varstr(fx%attname), & + wfc=wfc, baseURI=copyURI(fb%f(1)%baseURI)) + ! FIXME need to expand value here before reporting ... + if (present(internalEntityDecl_handler)) then + call internalEntityDecl_handler('%'//str_varstr(fx%name), str_varstr(fx%attname)) + if (fx%state==ST_STOP) return + endif + else ! PE can't have Ndata declaration + URIref => parseURI(str_varstr(fx%systemId)) + if (.not.associated(URIref)) then + call add_error(fx%error_stack, "Invalid URI specified for SYSTEM") + elseif (hasFragment(URIref)) then + call add_error(fx%error_stack, "Fragment not permitted on SYSTEM URI") + call destroyURI(URIref) + else + newURI => rebaseURI(fb%f(1)%baseURI, URIref) + call destroyURI(URIref) + if (.not.is_varstr_null(fx%publicId)) then + call register_external_PE(fx%xds, name=str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), publicId=str_varstr(fx%publicId), & + wfc=wfc, baseURI=newURI) + if (present(externalEntityDecl_handler)) & + call externalEntityDecl_handler('%'//str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), publicId=str_varstr(fx%publicId)) + else + call register_external_PE(fx%xds, name=str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), & + wfc=wfc, baseURI=newURI) + if (present(externalEntityDecl_handler)) & + call externalEntityDecl_handler('%'//str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), publicId="") + endif + endif + endif + ! else we ignore it + endif + else !It's a general entity + if (.not.existing_entity(fx%xds%entityList, str_varstr(fx%name))) then + ! Internal or external? + if (.not.is_varstr_null(fx%attname)) then ! it's internal + call register_internal_GE(fx%xds, name=str_varstr(fx%name), & + text=str_varstr(fx%attname), & + wfc=wfc, baseURI=copyURI(fb%f(1)%baseURI)) + if (present(internalEntityDecl_handler)) then + call internalEntityDecl_handler(str_varstr(fx%name),& + str_varstr(fx%attname)) + if (fx%state==ST_STOP) return + endif + else + URIref => parseURI(str_varstr(fx%systemId)) + if (.not.associated(URIref)) then + call add_error(fx%error_stack, "Invalid URI specified for SYSTEM") + elseif (hasFragment(URIref)) then + call add_error(fx%error_stack, "Fragment not permitted on SYSTEM URI") + call destroyURI(URIref) + else + newURI => rebaseURI(fb%f(1)%baseURI, URIref) + call destroyURI(URIref) + if ((.not.is_varstr_null(fx%publicId)).and.(.not.is_varstr_null(fx%Ndata))) then + call register_external_GE(fx%xds, name=str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), publicId=str_varstr(fx%publicId), & + notation=str_varstr(fx%Ndata), & + wfc=wfc, baseURI=newURI) + if (present(unparsedEntityDecl_handler)) & + call unparsedEntityDecl_handler(str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), publicId=str_varstr(fx%publicId), & + notation=str_varstr(fx%Ndata)) + elseif (.not.is_varstr_null(fx%Ndata)) then + call register_external_GE(fx%xds, name=str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), notation=str_varstr(fx%Ndata), & + wfc=wfc, baseURI=newURI) + if (present(unparsedEntityDecl_handler)) & + call unparsedEntityDecl_handler(str_varstr(fx%name), publicId="", & + systemId=str_varstr(fx%systemId), notation=str_varstr(fx%Ndata)) + elseif (.not.is_varstr_null(fx%publicId)) then + call register_external_GE(fx%xds, name=str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), publicId=str_varstr(fx%publicId), & + wfc=wfc, baseURI=newURI) + if (present(externalEntityDecl_handler)) & + call externalEntityDecl_handler(str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), publicId=str_varstr(fx%publicId)) + else + call register_external_GE(fx%xds, name=str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), wfc=wfc, baseURI=newURI) + if (present(externalEntityDecl_handler)) & + call externalEntityDecl_handler(str_varstr(fx%name), & + systemId=str_varstr(fx%systemId), publicId="") + endif + endif + endif + endif + endif + end subroutine add_entity + + subroutine getDefaultAttributes(el, dict) + type(element_t), pointer :: el + type(dictionary_t), intent(inout) :: dict + + type(attribute_t), pointer :: att + integer :: i, ind + character, pointer :: attValue(:) + + do i = 1, size(el%attlist%list) + att => el%attlist%list(i) + call get_att_index_pointer(dict, str_vs(att%name), ind, attValue) + if (.not.associated(attValue)) then + if (att%attDefault==ATT_DEFAULT & + .or.att%attDefault==ATT_FIXED) then + call add_item_to_dict(dict, & + str_vs(att%name), str_vs(att%default), & + specified=.false., declared=.true.) + endif + endif + end do + end subroutine getDefaultAttributes + + subroutine checkAttributes(el, dict) + type(element_t), pointer :: el + type(dictionary_t), intent(inout) :: dict + + integer :: i, j + + type(attribute_t), pointer :: att + type(string_list) :: s_list + character, pointer :: attValue(:), s(:) + + integer :: ind + logical, allocatable :: attributesLeft(:) + allocate(attributesLeft(getLength(dict))) + attributesLeft = .true. + + do i = 1, size(el%attlist%list) + att => el%attlist%list(i) + call get_att_index_pointer(dict, str_vs(att%name), ind, attValue) + if (associated(attValue)) attributesLeft(ind) = .false. + select case(att%attDefault) + case (ATT_REQUIRED, ATT_IMPLIED, ATT_DEFAULT) + if (.not.associated(attValue)) then + if (att%attDefault==ATT_REQUIRED) then + ! Validity Constraint: Required Attribute + call add_error(fx%error_stack, & + "REQUIRED attribute "//str_vs(att%name)//" not present") + return + elseif (att%attDefault==ATT_DEFAULT) then + if (fx%xds%standalone.and..not.att%internal) then + ! VC: Standalone document declaration" + call add_error(fx%error_stack, & + "Externally-specifid default attribute used in non-standalone document") + return + else + call add_item_to_dict(dict, & + str_vs(att%name), str_vs(att%default), & + specified=.false., declared=.true.) + endif + endif + else + select case(att%attType) + case (ATT_ID) + ! VC: ID + if (namespaces_) then + nameOk = checkNCName(str_vs(attValue), fx%xds%xml_version) + else + nameOk = checkName(str_vs(attValue), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, & + "Attributes of type ID must have a value which is an XML Name") + return + endif + if (registered_string(id_list, str_vs(attValue))) then + call add_error(fx%error_stack, & + "Cannot declare the same ID twice") + return + endif + call add_string(id_list, str_vs(attValue)) + call setIsId(dict, ind, .true.) + ! We don't need to check for duplicate ID & xml:ids on the same + ! element - if we are validating we'd already have noticed, + ! if we're not, it's not possible + case (ATT_IDREF) + ! VC: IDREF + if (namespaces_) then + nameOk = checkNCName(str_vs(attValue), fx%xds%xml_version) + else + nameOk = checkName(str_vs(attValue), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, & + "Attributes of type IDREF must have a value which is an XML Name") + return + endif + ! FIXME in a namespaced document they must match QName + if (.not.registered_string(idref_list, str_vs(attValue))) & + call add_string(idref_list, str_vs(attValue)) + case (ATT_IDREFS) + ! VC: IDREF + if (namespaces_) then + nameOk = checkNCNames(str_vs(attValue), fx%xds%xml_version) + else + nameOk = checkNames(str_vs(attValue), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, & + "Attributes of type IDREFS must have a value which contains only XML Names") + return + endif + call tokenize_and_add_strings(idref_list, str_vs(attValue), .true.) + case (ATT_ENTITY) + ! VC: Entity Name + if (namespaces_) then + nameOk = checkNCName(str_vs(attValue), fx%xds%xml_version) + else + nameOk = checkName(str_vs(attValue), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, & + "Attributes of type ENTITY must have a value which is an XML Name") + return + endif + ent => getEntityByName(fx%xds%entityList, str_vs(attValue)) + if (associated(ent)) then + if (.not.is_unparsed_entity(ent)) then + ! Validity Constraint: Entity Name + call add_error(fx%error_stack, & + "Attribute "//str_vs(att%name) & + //" of element "//str_vs(el%name) & + //" declared as ENTITY refers to parsed entity") + return + endif + else + ! Validity Constraint: Entity Name + call add_error(fx%error_stack, & + "Attribute "//str_vs(att%name) & + //" of element "//str_vs(el%name) & + //" declared as ENTITY refers to non-existent entity") + return + endif + case (ATT_ENTITIES) + ! VC: Entity Name + if (namespaces_) then + nameOk = checkNCNames(str_vs(attValue), fx%xds%xml_version) + else + nameOk = checkNames(str_vs(attValue), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, & + "Attributes of type ENTITIES must have a value which contains only XML Names") + return + endif + s_list = tokenize_to_string_list(str_vs(attValue)) + do j = 1, size(s_list%list) + s => s_list%list(j)%s + ent => getEntityByName(fx%xds%entityList, str_vs(s)) + if (associated(ent)) then + if (.not.is_unparsed_entity(ent)) then + ! Validity Constraint: Entity Name + call add_error(fx%error_stack, & + "Attribute "//str_vs(att%name) & + //" of element "//str_vs(el%name) & + //" declared as ENTITIES refers to parsed entity "& + //str_vs(s)) + call destroy_string_list(s_list) + return + endif + else + ! Validity Constraint: Entity Name + call add_error(fx%error_stack, & + "Attribute "//str_vs(att%name) & + //" of element "//str_vs(el%name) & + //" declared as ENTITIES refers to non-existent entity "& + //str_vs(s)) + call destroy_string_list(s_list) + return + endif + enddo + call destroy_string_list(s_list) + case (ATT_NMTOKEN) + ! VC Name Token + if (.not.checkNmtoken(str_vs(attValue), fx%xds%xml_version)) then + call add_error(fx%error_stack, & + "Attributes of type NMTOKEN must have a value which is a NMTOKEN") + return + endif + case (ATT_NMTOKENS) + ! VC: Name Token + if (.not.checkNmtokens(str_vs(attValue), fx%xds%xml_version)) then + call add_error(fx%error_stack, & + "Attributes of type NMTOKENS must have a value which contain only NMTOKENs") + return + endif + case (ATT_NOTATION) + ! VC: Notation Attributes + if (namespaces_) then + nameOk = checkNCName(str_vs(attValue), fx%xds%xml_version) + else + nameOk = checkName(str_vs(attValue), fx%xds%xml_version) + endif + if (.not.nameOk) then + call add_error(fx%error_stack, & + "Attributes of type NOTATION must have a value which is an XML Name") + return + endif + if (.not.notation_exists(fx%nlist, str_vs(attValue))) then + ! Validity Constraint: Notation Attributes + call add_error(fx%error_stack, & + "Attribute "//str_vs(att%name) & + //" declared as NOTATION refers to non-existent notation "& + //str_vs(attValue)) + return + endif + if (att%attDefault==ATT_REQUIRED) then + if (.not.registered_string(att%enumerations, str_vs(attValue))) & + call add_error(fx%error_stack, & + "NOTATION attribute is not among declared values.") + endif + case (ATT_ENUM) + ! VC: Notation Attributes + if (.not.checkNmtoken(str_vs(attValue), fx%xds%xml_version)) then + call add_error(fx%error_stack, & + "Attributes of type ENUM must have a value which is an NMTOKEN") + return + endif + if (.not.registered_string(att%enumerations, str_vs(attValue))) then + ! Validity Constraint: Enumeration + call add_error(fx%error_stack, & + "Attribute "//str_vs(att%name) & + //" of element "//str_vs(el%name) & + //" declared as ENUM refers to undeclared enumeration "& + //str_vs(attValue)) + return + endif + end select + endif + case (ATT_FIXED) + if (associated(attValue)) then + if (str_vs(att%default)//"x"/=str_vs(attValue)//"x") then + ! Validity Constraint: Fixed Attribute Default + call add_error(fx%error_stack, & + "FIXED attribute has unexpected value." & + //" At Element='"//str_vs(el%name)//"' Attribute='"//str_vs(att%name)//"'" & + //" Expecting '"//str_vs(att%default)//"' Found '"//str_vs(attValue)//"'") + return + endif + else + if (fx%xds%standalone.and..not.att%internal) then + ! VC: Standalone document declaration" + call add_error(fx%error_stack, & + "Externally-specified default attribute used in non-standalone document") + return + else + call add_item_to_dict(dict, & + str_vs(att%name), str_vs(att%default), & + specified=.false., declared=.true.) + endif + endif + end select + enddo + + if (any(attributesLeft)) call add_error(fx%error_stack, "Undeclared attributes forbidden. Element '"//str_vs(el%name)//"'") + + end subroutine checkAttributes + + subroutine checkXMLAttributes + integer :: ind + character, pointer :: attValue(:) + ! These must all be done with the name of the attribute, + ! not the nsURI/localname pair, in case we are + ! processing for a non-namespace aware application + if (has_key(fx%attributes, 'xml:space')) then + if (get_value(fx%attributes, 'xml:space')/='default' & + .and. get_value(fx%attributes, 'xml:space')/='preserve') then + call add_error(fx%error_stack, 'Illegal value of xml:space attribute') + return + endif + endif + call get_att_index_pointer(fx%attributes, "xml:id", ind, attValue) + if (associated(attValue)) then + ! Per xml:id spec, NCName even in non-namespace aware document + if (.not.checkNCName(str_vs(attValue), fx%xds%xml_version)) then + call add_error(fx%error_stack, & + "xml:id attributes must have values which are NCNames") + return + elseif (registered_string(id_list, str_vs(attValue))) then + call add_error(fx%error_stack, & + "xml:id attributes must be unique within a document") + return + endif + call add_string(id_list, str_vs(attValue)) + call setIsId(fx%attributes, ind, .true.) + endif + if (has_key(fx%attributes, "xml:base")) then + URIref => parseURI(get_value(fx%attributes,"xml:base")) + if (.not.associated(URIref)) then + call add_error(fx%error_stack, & + "Invalid URI reference specified for xml:base attribute") + else + call destroyURI(URIref) + endif + endif + !if (has_key(fx%attributes, 'xml:lang')) then + ! We never care about this at the SAX level. + !endif + end subroutine checkXMLAttributes + + subroutine endDTDchecks + type(element_t), pointer :: el + type(attribute_t), pointer :: att + type(entity_t), pointer :: ent + type(string_list) :: s_list + character, pointer :: s(:) + integer :: i, j, k + + if (present(FoX_endDTD_handler)) then + fx%xds_used = .true. + call FoX_endDTD_handler(fx%xds) + endif + if (present(endDTD_handler)) then + call endDTD_handler() + if (fx%state==ST_STOP) return + endif + ! Check that all notations used have been declared: + if (validCheck) then + do i = 1, size(fx%xds%entityList) + ent => getEntityByIndex(fx%xds%entityList, i) + if (str_vs(ent%notation)/="" & + .and..not.notation_exists(fx%nlist, str_vs(ent%notation))) then + ! Validity Constraint: Notation Declared + call add_error(fx%error_stack, "Attempt to use undeclared notation") + exit + endif + enddo + validLoop: do i = 1, size(fx%xds%element_list%list) + el => fx%xds%element_list%list(i) + do j = 1, size(el%attlist%list) + att => el%attlist%list(j) + ! For NOTATION, need to check enumerated as well as default ... + if (att%attType==ATT_NOTATION) then + do k = 1, size(att%enumerations%list) + s => att%enumerations%list(k)%s + if (.not.notation_exists(fx%nlist, str_vs(s))) then + ! Validity Constraint: Notation Attributes + call add_error(fx%error_stack, & + "Enumerated NOTATION in "//str_vs(att%name) & + //" of element "//str_vs(el%name) & + //" refers to non-existent notation") + call destroy(s_list) + exit validLoop + endif + enddo + if (associated(att%default)) then + s_list = tokenize_to_string_list(str_vs(att%default)) + do k = 1, size(s_list%list) + s => s_list%list(k)%s + if (.not.notation_exists(fx%nlist, str_vs(s))) then + ! Validity Constraint: Notation Attributes + call add_error(fx%error_stack, & + "Attribute "//str_vs(att%name) & + //" of element "//str_vs(el%name) & + //" declared as NOTATION refers to non-existent notation") + call destroy(s_list) + exit validLoop + endif + enddo + call destroy(s_list) + endif + endif + enddo + enddo validLoop + endif + end subroutine endDTDchecks + + subroutine checkIdRefs + integer :: i + character, pointer :: s(:) + do i = 1, size(idRef_list%list) + s => idRef_list%list(i)%s + if (.not.registered_string(id_list, str_vs(s))) then + call add_error(fx%error_stack, & + "Reference to undeclared ID "//str_vs(s)) + return + endif + enddo + end subroutine checkIdRefs + end subroutine sax_parse + + + subroutine sax_error(fx, error_handler) + type(sax_parser_t), intent(inout) :: fx + optional :: error_handler + interface + subroutine error_handler(msg) + character(len=*), intent(in) :: msg + end subroutine error_handler + end interface + + character, dimension(:), pointer :: errmsg + + integer :: i, m, n, n_err + n = size(fx%error_stack%stack) + n_err = n + + do i = 1, n + n_err = n_err + size(fx%error_stack%stack(i)%msg) ! + spaces + size of entityref + enddo + allocate(errmsg(n_err)) + errmsg = '' + n = 1 + do i = 1, size(fx%error_stack%stack) + m = size(fx%error_stack%stack(i)%msg) + errmsg(n:n+m-1) = fx%error_stack%stack(i)%msg + errmsg(n+m:n+m) = " " + n = n + m + 1 + enddo + ! FIXME put location information in here + if (present(error_handler)) then + call error_handler(str_vs(errmsg)) + deallocate(errmsg) + if (fx%state==ST_STOP) return + else + call FoX_error(str_vs(errmsg)) + endif + + end subroutine sax_error + + pure function URIlength(fx, qname) result(l_u) + type(sax_parser_t), intent(in) :: fx + character(len=*), intent(in) :: qName + integer :: l_u + integer :: n + n = index(QName, ':') + if (n > 0) then + l_u = len(getnamespaceURI(fx%nsDict, QName(1:n-1))) + else + l_u = len(getnamespaceURI(fx%nsDict)) + endif + end function URIlength + + pure function getURIofQName(fx, qname) result(URI) + type(sax_parser_t), intent(in) :: fx + character(len=*), intent(in) :: qName + character(len=URIlength(fx, qname)) :: URI + + integer :: n + n = index(QName, ':') + if (n > 0) then + URI = getnamespaceURI(fx%nsDict, QName(1:n-1)) + else + URI = getnamespaceURI(fx%nsDict) + endif + + end function getURIofQName + + pure function getLocalNameofQName(qname) result(localName) + character(len=*), intent(in) :: qName + character(len=len(QName)-index(QName,':')) :: localName + + localName = QName(index(QName,':')+1:) + end function getLocalNameofQName +#endif + +end module m_sax_parser diff --git a/src/xml/sax/m_sax_reader.F90 b/src/xml/sax/m_sax_reader.F90 new file mode 100644 index 000000000..72fa6584e --- /dev/null +++ b/src/xml/sax/m_sax_reader.F90 @@ -0,0 +1,411 @@ +module m_sax_reader +#ifndef DUMMYLIB + + use fox_m_fsys_array_str, only: str_vs, vs_str_alloc, vs_vs_alloc + use fox_m_fsys_format, only: operator(//) + use m_common_charset, only: XML1_0 + use m_common_error, only: error_stack, FoX_error, in_error, add_error + use m_common_io, only: setup_io, get_unit, io_err + + use FoX_utils, only: URI, parseURI, copyURI, destroyURI, & + hasScheme, getScheme, getPath + + use m_sax_xml_source, only: xml_source_t, & + get_char_from_file, push_file_chars, parse_declaration + + implicit none + private + + type file_buffer_t + !FIXME private + type(xml_source_t), pointer :: f(:) => null() + logical :: standalone = .false. + integer :: xml_version = XML1_0 + end type file_buffer_t + + public :: file_buffer_t + public :: line + public :: column + public :: add_error_position + + public :: open_file + public :: close_file + + public :: open_new_file + + public :: push_chars + + public :: get_character + public :: get_all_characters + + public :: open_new_string + public :: pop_buffer_stack + + public :: parse_xml_declaration + public :: parse_text_declaration + + public :: reading_main_file + public :: reading_first_entity + +contains + + subroutine open_file(fb, iostat, file, lun, string, es) + type(file_buffer_t), intent(out) :: fb + character(len=*), intent(in), optional :: file + integer, intent(out) :: iostat + integer, intent(in), optional :: lun + character(len=*), intent(in), optional :: string + type(error_stack), intent(inout) :: es + + type(URI), pointer :: fileURI + + iostat = 0 + + call setup_io() + if (present(string)) then + if (present(file)) then + call FoX_error("Cannot specify both file and string input to open_xml") + elseif (present(lun)) then + call FoX_error("Cannot specify lun for string input to open_xml") + endif + fileURI => parseURI("") + call open_new_string(fb, string, "", baseURI=fileURI) + else + fileURI => parseURI(file) + if (.not.associated(fileURI)) then + call add_error(es, "Could not open file "//file//" - not a valid URI") + iostat=1 + return + endif + call open_new_file(fb, fileURI, iostat, lun) + endif + call destroyURI(fileURI) + + end subroutine open_file + + + subroutine open_new_file(fb, baseURI, iostat, lun, pe) + type(file_buffer_t), intent(inout) :: fb + integer, intent(out) :: iostat + type(URI), pointer :: baseURI + integer, intent(in), optional :: lun + logical, intent(in), optional :: pe + + integer :: i + type(xml_source_t) :: f + type(xml_source_t), pointer :: temp(:) + logical :: pe_ + + if (present(pe)) then + pe_ = pe + else + pe_ = .false. + endif + + if (hasScheme(baseURI)) then + if (getScheme(baseURI)/="file") then + iostat = io_err + return + endif + endif + + call open_actual_file(f, getPath(baseURI), iostat, lun) + if (iostat==0) then + if (.not.associated(fb%f)) allocate(fb%f(0)) + ! First file + + temp => fb%f + allocate(fb%f(size(temp)+1)) + do i = 1, size(temp) + fb%f(i+1)%lun = temp(i)%lun + fb%f(i+1)%xml_version = temp(i)%xml_version + fb%f(i+1)%encoding => temp(i)%encoding + fb%f(i+1)%filename => temp(i)%filename + fb%f(i+1)%line = temp(i)%line + fb%f(i+1)%col = temp(i)%col + fb%f(i+1)%startChar = temp(i)%startChar + fb%f(i+1)%next_chars => temp(i)%next_chars + fb%f(i+1)%input_string => temp(i)%input_string + fb%f(i+1)%baseURI => temp(i)%baseURI + fb%f(i+1)%pe = temp(i)%pe + enddo + deallocate(temp) + fb%f(1)%lun = f%lun + fb%f(1)%filename => f%filename + if (pe_) then + fb%f(1)%next_chars => vs_str_alloc(" ") + else + fb%f(1)%next_chars => vs_str_alloc("") + endif + fb%f(1)%pe = pe_ + fb%f(1)%baseURI => copyURI(baseURI) + endif + + end subroutine open_new_file + + subroutine open_actual_file(f, file, iostat, lun) + type(xml_source_t), intent(out) :: f + character(len=*), intent(in) :: file + integer, intent(out) :: iostat + integer, intent(in), optional :: lun + + if (present(lun)) then + f%lun = lun + else + call get_unit(f%lun, iostat) + if (iostat/=0) return + endif + open(unit=f%lun, file=file, form="formatted", status="old", & + action="read", position="rewind", iostat=iostat) + if (iostat/=0) return + f%filename => vs_str_alloc(file) + + end subroutine open_actual_file + + subroutine close_file(fb) + type(file_buffer_t), intent(inout) :: fb + + integer :: i + + do i = 1, size(fb%f) + call close_actual_file(fb%f(i)) + enddo + + if (associated(fb%f)) deallocate(fb%f) + + end subroutine close_file + + + subroutine close_actual_file(f) + type(xml_source_t), intent(inout) :: f + + deallocate(f%filename) + + if (f%lun>0) then + close(f%lun) + else + deallocate(f%input_string%s) + deallocate(f%input_string) + endif + + if (associated(f%encoding)) deallocate(f%encoding) + f%line = 0 + f%col = 0 + deallocate(f%next_chars) + call destroyURI(f%baseURI) + end subroutine close_actual_file + + + subroutine open_new_string(fb, string, name, baseURI, pe) + type(file_buffer_t), intent(inout) :: fb + character(len=*), intent(in) :: string + character(len=*), intent(in) :: name + type(URI), pointer :: baseURI + logical, intent(in), optional :: pe + + integer :: i + type(xml_source_t), pointer :: temp(:) + logical :: pe_ + + if (present(pe)) then + pe_ = pe + else + pe_ = .false. + endif + + if (.not.associated(fb%f)) allocate(fb%f(0)) + + temp => fb%f + allocate(fb%f(size(temp)+1)) + do i = 1, size(temp) + fb%f(i+1)%lun = temp(i)%lun + fb%f(i+1)%xml_version = temp(i)%xml_version + fb%f(i+1)%encoding => temp(i)%encoding + fb%f(i+1)%filename => temp(i)%filename + fb%f(i+1)%line = temp(i)%line + fb%f(i+1)%col = temp(i)%col + fb%f(i+1)%startChar = temp(i)%startChar + fb%f(i+1)%next_chars => temp(i)%next_chars + fb%f(i+1)%input_string => temp(i)%input_string + fb%f(i+1)%baseURI => temp(i)%baseURI + fb%f(i+1)%pe = temp(i)%pe + enddo + deallocate(temp) + + allocate(fb%f(1)%input_string) + fb%f(1)%filename => vs_str_alloc(name) + fb%f(1)%input_string%s => vs_str_alloc(string) + if (pe_) then + fb%f(1)%next_chars => vs_str_alloc(" ") + else + fb%f(1)%next_chars => vs_str_alloc("") + endif + fb%f(1)%pe = pe_ + if (associated(baseURI)) then + fb%f(1)%baseURI => copyURI(baseURI) + else + fb%f(1)%baseURI => copyURI(fb%f(2)%baseURI) + endif + + end subroutine open_new_string + + subroutine pop_buffer_stack(fb) + type(file_buffer_t), intent(inout) :: fb + + integer :: i + type(xml_source_t), pointer :: temp(:) + + call close_actual_file(fb%f(1)) + + temp => fb%f + allocate(fb%f(size(temp)-1)) + do i = 1, size(temp)-1 + fb%f(i)%lun = temp(i+1)%lun + fb%f(i)%xml_version = temp(i+1)%xml_version + fb%f(i)%encoding => temp(i+1)%encoding + fb%f(i)%filename => temp(i+1)%filename + fb%f(i)%line = temp(i+1)%line + fb%f(i)%col = temp(i+1)%col + fb%f(i)%startChar = temp(i+1)%startChar + fb%f(i)%next_chars => temp(i+1)%next_chars + fb%f(i)%input_string => temp(i+1)%input_string + fb%f(i)%baseURI => temp(i+1)%baseURI + fb%f(i)%pe = temp(i+1)%pe + enddo + deallocate(temp) + + end subroutine pop_buffer_stack + + + subroutine push_chars(fb, s) + type(file_buffer_t), intent(inout) :: fb + character(len=*), intent(in) :: s + + call push_file_chars(fb%f(1), s) + + end subroutine push_chars + + function get_character(fb, eof, es) result(string) + type(file_buffer_t), intent(inout) :: fb + logical, intent(out) :: eof + type(error_stack), intent(inout) :: es + character(len=1) :: string + + type(xml_source_t), pointer :: f + character, pointer :: temp(:) + + f => fb%f(1) + + if (size(f%next_chars)>0) then + eof = .false. + string = f%next_chars(1) + if (size(f%next_chars)>1) then + temp => vs_str_alloc(str_vs(f%next_chars(2:))) + else + temp => vs_str_alloc("") + endif + deallocate(f%next_chars) + f%next_chars => temp + else + string = get_char_from_file(f, fb%xml_version, eof, es) + endif + + end function get_character + + function get_all_characters(fb, es) result(s) + type(file_buffer_t), intent(inout) :: fb + type(error_stack), intent(inout) :: es + character, pointer :: s(:) + + logical :: eof + character :: c + character, pointer :: temp(:) + + eof = .false. + s => vs_str_alloc("") + do while (.not.eof) + c = get_character(fb, eof, es) + if (eof.or.in_error(es)) return + temp => vs_str_alloc(str_vs(s)//c) + deallocate(s) + s => temp + enddo + end function get_all_characters + + function line(fb) result(n) + type(file_buffer_t), intent(in) :: fb + integer :: n + + n = fb%f(1)%line + end function line + + function column(fb) result(n) + type(file_buffer_t), intent(in) :: fb + integer :: n + + n = fb%f(1)%col + end function column + + subroutine parse_xml_declaration(fb, xv, enc, sa, es) + type(file_buffer_t), intent(inout) :: fb + integer, intent(out) :: xv + character, pointer :: enc(:) + logical, intent(out) :: sa + type(error_stack), intent(inout) :: es + + logical :: eof + + call parse_declaration(fb%f(1), eof, es, sa) + if (eof.or.in_error(es)) then + call add_error(es, "Error parsing XML declaration") + else + fb%xml_version = fb%f(1)%xml_version + xv = fb%xml_version + enc => vs_vs_alloc(fb%f(1)%encoding) + endif + end subroutine parse_xml_declaration + + subroutine parse_text_declaration(fb, es) + type(file_buffer_t), intent(inout) :: fb + type(error_stack), intent(inout) :: es + + logical :: eof + integer :: xv + + xv = fb%f(size(fb%f))%xml_version + + call parse_declaration(fb%f(1), eof, es) + if (in_error(es)) then + call add_error(es, "Error parsing text declaration") + return + elseif (xv==XML1_0.and.fb%f(1)%xml_version/=XML1_0) then + call add_error(es, "XML 1.0 document cannot reference entities with higher version numbers") + return + endif + + end subroutine parse_text_declaration + + + function reading_main_file(fb) result(p) + type(file_buffer_t), intent(in) :: fb + logical :: p + + p = (size(fb%f)==1) + end function reading_main_file + + function reading_first_entity(fb) result(p) + type(file_buffer_t), intent(in) :: fb + logical :: p + + p = (size(fb%f)==2) + end function reading_first_entity + + subroutine add_error_position(stack, fb) + type(error_stack), intent(inout) :: stack + type(file_buffer_t), intent(in) :: fb + call add_error(stack,"(Possibly near line="//line(fb)//" col="//column(fb)//")") + end subroutine add_error_position + +#endif + +end module m_sax_reader diff --git a/src/xml/sax/m_sax_tokenizer.F90 b/src/xml/sax/m_sax_tokenizer.F90 new file mode 100644 index 000000000..59ea631d3 --- /dev/null +++ b/src/xml/sax/m_sax_tokenizer.F90 @@ -0,0 +1,1139 @@ +module m_sax_tokenizer + +#ifndef DUMMYLIB + use fox_m_fsys_array_str, only: vs_str, str_vs, vs_str_alloc + use fox_m_fsys_varstr + + use m_common_charset, only: XML_WHITESPACE, & + upperCase, isInitialNameChar + use m_common_error, only: add_error, in_error + use m_common_entities, only: entity_t, existing_entity, & + expand_entity_text, expand_char_entity, & + add_internal_entity, pop_entity_list, getEntityByName + use m_common_namecheck, only: checkName, checkCharacterEntityReference + + use m_sax_reader, only: file_buffer_t, open_new_file, pop_buffer_stack, & + push_chars, get_character, get_all_characters, & + parse_text_declaration, add_error_position + use m_sax_types ! everything, really +#ifdef PGF90 + use fox_m_utils_uri, only: URI +#endif + + implicit none + private + + public :: sax_tokenize + public :: normalize_attribute_text + public :: expand_pe_text + +contains + + subroutine sax_tokenize(fx, fb, eof) + type(sax_parser_t), intent(inout) :: fx + type(file_buffer_t), intent(inout) :: fb + logical, intent(out) :: eof + + character :: c, q + integer :: xv, phrase + logical :: firstChar, ws_discard + character, pointer :: tempString(:) + + xv = fx%xds%xml_version + + call set_varstr_empty(fx%token) + if (fx%nextTokenType/=TOK_NULL) then + eof = .false. + fx%tokenType = fx%nextTokenType + fx%nextTokenType = TOK_NULL + return + endif + fx%tokentype = TOK_NULL + + q = " " + phrase = 0 + firstChar = .true. + ws_discard = .false. + do + c = get_character(fb, eof, fx%error_stack) + if (eof) then + if (fx%state==ST_CHAR_IN_CONTENT) then + if (phrase==1) then + call append_varstr(fx%token,']') + elseif (phrase==2) then + call append_varstr(fx%token,']]') + endif + fx%tokenType = TOK_CHAR + endif + if (fx%tokenType/=TOK_NULL) then + ! make sure we pass back this token before eof'ing + eof = .false. + return + endif + endif + if (eof.or.in_error(fx%error_stack)) return + if (fx%inIntSubset) then + tempString => fx%xds%intSubset + fx%xds%intSubset => vs_str_alloc(str_vs(tempString)//c) + deallocate(tempString) + endif + + select case (fx%state) + case (ST_MISC) + if (firstChar) ws_discard = .true. + if (ws_discard) then + if (verify(c, XML_WHITESPACE)>0) then + if (c=="<") then + ws_discard = .false. + else + call add_error(fx%error_stack, "Unexpected character found outside content") + call add_error_position(fx%error_stack,fb) + endif + endif + else + if (c=="?") then + fx%tokenType = TOK_PI_TAG + elseif (c=="!") then + fx%tokenType = TOK_BANG_TAG + elseif (isInitialNameChar(c, xv)) then + call push_chars(fb, c) + fx%tokenType = TOK_OPEN_TAG + else + call add_error(fx%error_stack, "Unexpected character after <") + call add_error_position(fx%error_stack,fb) + endif + endif + + case (ST_BANG_TAG) + if (firstChar) then + if (c=="-") then + phrase = 1 + elseif (c=="[") then + fx%tokenType = TOK_OPEN_SB + elseif (verify(c,upperCase)==0) then + call varstr_str(fx%token,c) + else + call add_error(fx%error_stack, "Unexpected character after 0) then + call append_varstr(fx%token,c) + else + call push_chars(fb, c) + fx%tokenType = TOK_NAME + endif + + case (ST_START_PI) + ! grab until whitespace or ? + if (verify(c, XML_WHITESPACE//"?")>0) then + call append_varstr( fx%token, c ) + else + fx%tokenType = TOK_NAME + if (c=="?") call push_chars(fb, c) + endif + + case (ST_PI_CONTENTS) + if (firstChar) ws_discard = .true. + if (ws_discard) then + if (verify(c, XML_WHITESPACE)/=0) then + ws_discard = .false. + else + cycle + endif + endif + if (phrase==1) then + if (c==">") then + fx%tokenType = TOK_CHAR + fx%nextTokenType = TOK_PI_END + elseif (c=="?") then + ! The last ? didn't mean anything, but this one might. + call append_varstr( fx%token, '?' ) + else + phrase = 0 + call append_varstr( fx%token, '?' ) + call append_varstr( fx%token, c ) + endif + elseif (c=="?") then + phrase = 1 + else + call append_varstr( fx%token, c ) + endif + + case (ST_START_COMMENT) + select case(phrase) + case (0) + if (c=="-") then + phrase = 1 + else + call append_varstr( fx%token, c ) + endif + case (1) + if (c=="-") then + phrase = 2 + else + call append_varstr( fx%token, '-' ) + call append_varstr( fx%token, c ) + phrase = 0 + endif + case (2) + if (c==">") then + fx%tokenType = TOK_CHAR + fx%nextTokenType = TOK_COMMENT_END + exit + else + call add_error(fx%error_stack, & + "Expecting > after -- inside a comment.") + call add_error_position(fx%error_stack,fb) + endif + end select + + case (ST_START_TAG) + ! grab until whitespace or /, > + if (verify(c, XML_WHITESPACE//"/>")>0) then + call append_varstr( fx%token, c ) + else + fx%tokenType = TOK_NAME + if (c==">") then + fx%nextTokenType = TOK_END_TAG + else + call push_chars(fb, c) + endif + endif + + case (ST_START_CDATA_DECLARATION) + if (firstChar) then + if (verify(c, XML_WHITESPACE)==0) then + call add_error(fx%error_stack, & + "Whitespace not allowed around CDATA in section declaration") + call add_error_position(fx%error_stack,fb) + else + call varstr_str(fx%token, c) + ws_discard = .false. + endif + else + if (verify(c, XML_WHITESPACE)==0) then + call add_error(fx%error_stack, & + "Whitespace not allowed around CDATA in section declaration") + call add_error_position(fx%error_stack,fb) + elseif (c=="[") then + fx%tokenType = TOK_NAME + if (c=="[") fx%nextTokenType = TOK_OPEN_SB + else + call append_varstr( fx%token, c ) + endif + endif + + + case (ST_CDATA_CONTENTS) + select case(phrase) + case (0) + if (c=="]") then + phrase = 1 + else + call append_varstr( fx%token, c ) + endif + case (1) + if (c=="]") then + phrase = 2 + else + call append_varstr( fx%token, ']' ) + call append_varstr( fx%token, c ) + phrase = 0 + endif + case (2) + if (c==">") then + fx%tokenType = TOK_CHAR + fx%nextTokenType = TOK_SECTION_END + elseif (c=="]") then + call append_varstr( fx%token, ']' ) + else + call append_varstr( fx%token, ']]' ) + call append_varstr( fx%token, c ) + phrase = 0 + endif + end select + + case (ST_IN_TAG) + if (firstChar) then + if (verify(c,XML_WHITESPACE//"/>")>0) then + call add_error(fx%error_stack, & + "Whitespace required inside tag") + call add_error_position(fx%error_stack,fb) + exit + endif + ws_discard = .true. + endif + if (ws_discard) then + if (verify(c,XML_WHITESPACE)>0) then + if (c==">") then + fx%tokenType = TOK_END_TAG + elseif (c=="/") then + phrase = 1 + ws_discard = .false. + else + call varstr_str(fx%token,c) + ws_discard = .false. + endif + endif + else + if (phrase==1) then + if (c==">") then + fx%tokenType = TOK_END_TAG_CLOSE + else + call add_error(fx%error_stack, & + "Unexpected character after '/' ("//c//") in tag for element '"//str_varstr(fx%name)//"'") + call add_error_position(fx%error_stack,fb) + exit + endif + else + if (verify(c,XML_WHITESPACE//"=/>")==0) then + fx%tokenType = TOK_NAME + if (c=="=") then + fx%nextTokenType = TOK_EQUALS + elseif (c==">") then + fx%nextTokenType = TOK_END_TAG + else + call push_chars(fb, c) + endif + else + call append_varstr( fx%token, c ) + endif + endif + endif + + case (ST_ATT_NAME) + if (firstChar) ws_discard = .true. + if (ws_discard) then + if (verify(c,XML_WHITESPACE)>0) then + if (c=="=") then + fx%tokenType = TOK_EQUALS + else + call add_error(fx%error_stack, & + "Unexpected character in element tag, expected =") + call add_error_position(fx%error_stack,fb) + endif + endif + endif + + case (ST_ATT_EQUALS) + if (firstChar) ws_discard = .true. + if (ws_discard) then + if (verify(c,XML_WHITESPACE)>0) then + if (verify(c,"'""")==0) then + q = c + ws_discard = .false. + else + call add_error(fx%error_stack, "Expecting "" or '") + call add_error_position(fx%error_stack,fb) + endif + endif + else + if (c==q) then + fx%tokenType = TOK_CHAR + else + call append_varstr( fx%token, c ) + endif + endif + + case (ST_CHAR_IN_CONTENT) + if (c=="<".or.c=="&") then + if (phrase==1) then + call append_varstr( fx%token, ']' ) + elseif (phrase==2) then + call append_varstr( fx%token, ']]' ) + endif + fx%tokenType = TOK_CHAR + if (c=="<") then + call push_chars(fb, c) + elseif (c=="&") then + fx%nextTokenType = TOK_ENTITY + endif + elseif (c=="]") then + if (phrase==0) then + phrase = 1 + elseif (phrase==1) then + phrase = 2 + else + call append_varstr( fx%token, ']' ) + endif + elseif (c==">") then + if (phrase==1) then + phrase = 0 + call append_varstr( fx%token, ']>' ) + elseif (phrase==2) then + call add_error(fx%error_stack, "]]> forbidden in character context") + call add_error_position(fx%error_stack,fb) + else + call append_varstr( fx%token, '>' ) + endif + elseif (phrase==1) then + call append_varstr( fx%token, ']' ) + call append_varstr( fx%token, c ) + phrase = 0 + elseif (phrase==2) then + call append_varstr( fx%token, ']]' ) + call append_varstr( fx%token, c ) + phrase = 0 + else + call append_varstr( fx%token, c ) + endif + + case (ST_TAG_IN_CONTENT) + if (phrase==0) then + if (c=="<") then + phrase = 1 + ws_discard = .false. + elseif (c=="&") then + fx%tokenType = TOK_ENTITY + else + call add_error(fx%error_stack, "Unexpected character found in content") + call add_error_position(fx%error_stack,fb) + endif + elseif (phrase==1) then + if (c=="?") then + fx%tokenType = TOK_PI_TAG + elseif (c=="!") then + fx%tokenType = TOK_BANG_TAG + elseif (c=="/") then + fx%tokenType = TOK_CLOSE_TAG + elseif (isInitialNameChar(c, xv)) then + call push_chars(fb, c) + fx%tokenType = TOK_OPEN_TAG + else + call add_error(fx%error_stack, "Unexpected character after <") + call add_error_position(fx%error_stack,fb) + endif + endif + + case (ST_START_ENTITY) + if (verify(c,XML_WHITESPACE//";")>0) then + call append_varstr( fx%token, c ) + elseif (c==";") then + fx%tokenType = TOK_NAME + else + call add_error(fx%error_stack, "Entity reference must be terminated with a ;") + call add_error_position(fx%error_stack,fb) + endif + + case (ST_CLOSING_TAG) + if (verify(c,XML_WHITESPACE//">")>0) then + call append_varstr( fx%token, c ) + else + fx%tokenType = TOK_NAME + if (c==">") fx%nextTokenType = TOK_END_TAG + endif + + case (ST_IN_CLOSING_TAG) + if (verify(c, XML_WHITESPACE)>0) then + if (c==">") then + fx%tokenType = TOK_END_TAG + else + call add_error(fx%error_stack, "Unexpected character - expecting >") + call add_error_position(fx%error_stack,fb) + endif + endif + + case (ST_IN_DOCTYPE, ST_DOC_NAME, ST_DOC_SYSTEM, ST_DOC_PUBLIC, & + ST_DOC_DECL, ST_CLOSE_DOCTYPE) + if (firstChar) then + if (verify(c, XML_WHITESPACE)>0) then + if (c==">") then + fx%tokenType = TOK_END_TAG + elseif (c=="[") then + fx%tokenType = TOK_OPEN_SB + else + call add_error(fx%error_stack, & + "Missing whitespace in doctype delcaration.") + call add_error_position(fx%error_stack,fb) + endif + else + ws_discard = .true. + endif + endif + if (ws_discard) then + if (verify(c, XML_WHITESPACE)>0) then + if (verify(c, "'""")==0) then + q = c + call set_varstr_empty(fx%token) + ws_discard = .false. + elseif (c=="[") then + fx%tokenType = TOK_OPEN_SB + elseif (c==">") then + fx%tokenType = TOK_END_TAG + else + call varstr_str(fx%token, c) + ws_discard = .false. + endif + endif + else + if (q/=" ".and.c==q) then + fx%tokenType = TOK_CHAR + elseif (q==" ".and.verify(c, ">")==0.and.(fx%state==ST_IN_DOCTYPE)) then + fx%nextTokenType = TOK_END_TAG + fx%tokenType = TOK_NAME + elseif (q==" ".and.verify(c, XML_WHITESPACE)==0) then + call push_chars(fb, c) + fx%tokenType = TOK_NAME + else + call append_varstr( fx%token, c ) + endif + endif + + case (ST_IN_SUBSET) + call tokenizeDTD + + case (ST_START_PE) + if (verify(c,XML_WHITESPACE//";")>0) then + call append_varstr( fx%token, c ) + elseif (c==";") then + fx%tokenType = TOK_NAME + else + call add_error(fx%error_stack, "Entity reference must be terminated with a ;") + call add_error_position(fx%error_stack,fb) + endif + + end select + + firstChar = .false. + if (fx%tokenType/=TOK_NULL) exit + enddo + + contains + + subroutine tokenizeDTD + + if (c=="%") then + if (fx%state_dtd==ST_DTD_START_COMMENT & + .or.fx%state_dtd==ST_DTD_START_PI & + .or.fx%state_dtd==ST_DTD_PI_CONTENTS & + .or.fx%state_dtd==ST_DTD_ENTITY & + .or.fx%state_dtd==ST_DTD_NOTATION_SYSTEM & + .or.fx%state_dtd==ST_DTD_NOTATION_PUBLIC & + .or.fx%state_dtd==ST_DTD_NOTATION_PUBLIC_2 & + .or.fx%state_dtd==ST_DTD_ENTITY_PUBLIC & + .or.fx%state_dtd==ST_DTD_ENTITY_SYSTEM) then + ! % is perfectly legitimate + continue + elseif (fx%state_dtd==ST_DTD_SUBSET) then + if (.not.fx%spaceBeforeEntity) then + fx%spaceBeforeEntity = .true. + call push_chars(fb, c) + c = " " + else + fx%spaceBeforeEntity = .false. + fx%tokenType = TOK_ENTITY + return + endif + elseif (fx%state_dtd==ST_DTD_ATTLIST_CONTENTS & + .and. q/="") then + ! We are inside a ATTLIST attvalue, so apparent PErefs arent. + continue + elseif (fx%inIntSubset) then + call add_error(fx%error_stack, & + "Parameter entity reference not permitted inside markup for internal subset") + call add_error_position(fx%error_stack,fb) + return + elseif (fx%state_dtd==ST_DTD_ATTLIST_CONTENTS & + .or.fx%state_dtd==ST_DTD_ELEMENT_CONTENTS) then + if (is_varstr_null(fx%content)) then + ! content will not always be empty here; + ! if we have two PErefs bang next to each other. + call move_varstr_varstr(fx%token,fx%content) + endif + fx%tokenType = TOK_ENTITY + return + elseif (fx%state_dtd==ST_DTD_ENTITY_ID) then + ! % is ok if we are in the external subset + continue + else + if (.not.fx%spaceBeforeEntity) then + fx%spaceBeforeEntity = .true. + call push_chars(fb, c) + c = " " + else + fx%spaceBeforeEntity = .false. + fx%tokenType = TOK_ENTITY + return + endif + endif + endif + + select case(fx%state_dtd) + + case (ST_DTD_SUBSET) + if (firstChar) ws_discard = .true. + if (ws_discard) then + if (verify(c, XML_WHITESPACE)>0) then + if (c=="]") then + phrase = 1 + q = c + ws_discard = .false. + elseif (c=="<") then + phrase = 1 + q = c + ws_discard = .false. + else + call add_error(fx%error_stack, "Unexpected character found in document subset") + call add_error_position(fx%error_stack,fb) + endif + endif + elseif (phrase==1) then + if (q=="<") then + if (c=="?") then + fx%tokenType = TOK_PI_TAG + elseif (c=="!") then + fx%tokenType = TOK_BANG_TAG + else + call add_error(fx%error_stack, "Unexpected character, expecting ! or ?") + call add_error_position(fx%error_stack,fb) + endif + elseif (q=="]") then + if (c=="]") then + phrase = 2 + else + fx%tokenType = TOK_CLOSE_SB + call push_chars(fb, c) + if (fx%inIntSubset) then + tempString => fx%xds%intSubset + allocate(fx%xds%intSubset(size(tempString)-2)) + fx%xds%intSubset = tempString(:size(tempString)-2) + deallocate(tempString) + endif + endif + endif + elseif (phrase==2) then + if (c==">") then + fx%tokenType = TOK_SECTION_END + else + call add_error(fx%error_stack, "Unexpected character, expecting >") + call add_error_position(fx%error_stack,fb) + endif + endif + + + case (ST_DTD_BANG_TAG) + if (firstChar) then + if (c=="-") then + phrase = 1 + elseif (c=="[") then + fx%tokenType = TOK_OPEN_SB + elseif (verify(c,upperCase)==0) then + call varstr_str(fx%token,c) + else + call add_error(fx%error_stack, "Unexpected character after 0) then + call append_varstr( fx%token, c ) + else + call push_chars(fb, c) + fx%tokenType = TOK_NAME + endif + + + case (ST_DTD_START_SECTION_DECL) + if (firstChar) then + ws_discard = .true. + endif + if (ws_discard) then + if (verify(c, XML_WHITESPACE)/=0) then + call varstr_str(fx%token, c) + ws_discard = .false. + endif + else + if (verify(c, XML_WHITESPACE//"[")>0) then + call append_varstr( fx%token, c ) + else + fx%tokenType = TOK_NAME + if (c=="[") fx%nextTokenType = TOK_OPEN_SB + endif + endif + + case (ST_DTD_FINISH_SECTION_DECL) + if (verify(c, XML_WHITESPACE)>0) then + if (c/="[") then + call add_error(fx%error_stack, & + "Unexpected token found, expecting [") + call add_error_position(fx%error_stack,fb) + else + fx%tokenType = TOK_OPEN_SB + endif + endif + + case (ST_DTD_IN_IGNORE_SECTION) + select case(phrase) + case (0) + if (c=="<".or.c=="]") then + phrase = 1 + q = c + endif + case (1) + if ((q=="<".and.c=="!").or.(q=="]".and.c=="]")) then + phrase = 2 + else + phrase = 0 + endif + case (2) + if (q=="<".and.c=="[") then + fx%tokenType = TOK_SECTION_START + elseif (q=="]".and.c==">") then + fx%tokenType = TOK_SECTION_END + else + phrase = 0 + endif + end select + + + case (ST_DTD_START_PI) + ! grab until whitespace or ? + if (verify(c, XML_WHITESPACE//"?")>0) then + call append_varstr( fx%token, c ) + else + fx%tokenType = TOK_NAME + if (c=="?") call push_chars(fb, c) + endif + + case (ST_DTD_PI_CONTENTS) + if (firstChar) ws_discard = .true. + if (ws_discard) then + if (verify(c, XML_WHITESPACE)/=0) then + ws_discard = .false. + else + return + endif + endif + if (phrase==1) then + if (c==">") then + fx%tokenType = TOK_CHAR + fx%nextTokenType = TOK_PI_END + elseif (c=="?") then + ! The last ? didn't mean anything, but this one might. + call append_varstr( fx%token, '?' ) + else + phrase = 0 + call append_varstr( fx%token, '?' ) + call append_varstr( fx%token, c ) + endif + elseif (c=="?") then + phrase = 1 + else + call append_varstr( fx%token, c ) + endif + + case (ST_DTD_START_COMMENT) + select case(phrase) + case (0) + if (c=="-") then + phrase = 1 + else + call append_varstr( fx%token, c ) + endif + case (1) + if (c=="-") then + phrase = 2 + else + call append_varstr( fx%token, '-' ) + call append_varstr( fx%token, c ) + phrase = 0 + endif + case (2) + if (c==">") then + fx%tokenType = TOK_CHAR + call append_varstr( fx%token, c ) + fx%nextTokenType = TOK_COMMENT_END + else + call add_error(fx%error_stack, & + "Expecting > after -- inside a comment.") + call add_error_position(fx%error_stack,fb) + endif + end select + + case (ST_DTD_ATTLIST, ST_DTD_ELEMENT, ST_DTD_ENTITY, & + ST_DTD_ENTITY_PE, ST_DTD_NOTATION) + if (firstChar) ws_discard = .true. + if (ws_discard) then + if (verify(c,XML_WHITESPACE)>0) then + call varstr_str(fx%token, c) + ws_discard = .false. + endif + elseif (verify(c,XML_WHITESPACE//">")>0) then + call append_varstr( fx%token, c ) + else + if (c==">") then + fx%nextTokenType = TOK_END_TAG + else + call push_chars(fb, c) + endif + fx%tokenType = TOK_NAME + endif + + case (ST_DTD_ELEMENT_CONTENTS) + if (c==">") then + if (.not.is_varstr_null(fx%content)) then + call move_varstr_varstr(fx%content,fx%token) + endif + fx%tokenType = TOK_DTD_CONTENTS + fx%nextTokenType = TOK_END_TAG + else + if (.not.is_varstr_null(fx%content)) then + call move_varstr_varstr(fx%content,fx%token) + call append_varstr(fx%token, c) + else + call append_varstr(fx%token, c) + endif + if (c=="(") then + fx%tokenType = TOK_OPEN_PAR + call move_varstr_varstr(fx%token,fx%content) + elseif (c==")") then + fx%tokenType = TOK_CLOSE_PAR + call move_varstr_varstr(fx%token,fx%content) + endif + endif + + case (ST_DTD_ATTLIST_CONTENTS) + if (c==">") then + fx%tokenType = TOK_DTD_CONTENTS + fx%nextTokenType = TOK_END_TAG + elseif (.not.is_varstr_null(fx%content)) then + call move_varstr_varstr(fx%content,fx%token) + call append_varstr(fx%token, c) + else + call append_varstr( fx%token, c ) + endif + if (c=="'".or.c=="""") then + if (q==c) then + q = "" + else + q = c + endif + endif + + case (ST_DTD_ENTITY_ID, ST_DTD_ENTITY_PUBLIC, ST_DTD_ENTITY_SYSTEM, & + ST_DTD_ENTITY_NDATA, ST_DTD_ENTITY_END, ST_DTD_ENTITY_NDATA_VALUE, & + ST_DTD_NOTATION_ID, ST_DTD_NOTATION_SYSTEM, ST_DTD_NOTATION_PUBLIC, & + ST_DTD_NOTATION_PUBLIC_2, ST_DTD_NOTATION_END) + if (firstChar) then + if (verify(c, XML_WHITESPACE)>0) then + if (c==">") then + fx%tokenType = TOK_END_TAG + else + call add_error(fx%error_stack, "Missing whitespace in DTD.") + call add_error_position(fx%error_stack,fb) + endif + else + ws_discard = .true. + endif + elseif (ws_discard) then + if (verify(c, XML_WHITESPACE)>0) then + if (verify(c, "'""")==0) then + q = c + call set_varstr_empty(fx%token) + ws_discard = .false. + elseif (c==">") then + fx%tokenType = TOK_END_TAG + else + call varstr_str( fx%token, c ) + ws_discard = .false. + endif + endif + else + if (q/=" ".and.c==q) then + fx%tokenType = TOK_CHAR + elseif (q==" ".and.verify(c, XML_WHITESPACE//">")==0) then + fx%tokenType = TOK_NAME + if (c==">") then + fx%nextTokenType = TOK_END_TAG + else + call push_chars(fb, c) + endif + else + call append_varstr( fx%token, c ) + endif + endif + + end select + end subroutine tokenizeDTD + + end subroutine sax_tokenize + + + recursive function normalize_attribute_text(fx, s_in, fb) result(s_out) + type(sax_parser_t), intent(inout) :: fx + character, dimension(:), intent(in) :: s_in + type(file_buffer_t), intent(in) :: fb + character, dimension(:), pointer :: s_out + + character, dimension(:), pointer :: s_temp, s_temp2, s_ent, tempString + character :: dummy + integer :: i, i2, j + type(entity_t), pointer :: ent +#ifdef PGF90 + type(URI), pointer :: nullURI + nullURI => null() +#endif + + ! Condense all whitespace, only if we are validating, + ! Expand all & + ! Complain about < and & + + allocate(s_temp(size(s_in))) ! in the first instance + allocate(s_out(0)) ! in case we return early ... + s_ent => null() + tempString => null() + + i2 = 1 + i = 1 + do + if (i > size(s_in)) exit + ! Firstly, all whitespace must become 0x20 + if (verify(s_in(i),XML_WHITESPACE)==0) then + s_temp(i2) = " " + ! Then, < is always illegal + i = i + 1 + i2 = i2 + 1 + elseif (s_in(i)=='<') then + call add_error(fx%error_stack, "Illegal '<' found in attribute.") + call add_error_position(fx%error_stack,fb) + goto 100 + ! Then, expand < + elseif (s_in(i)=='&') then + j = index(str_vs(s_in(i+1:)), ';') + if (j==0) then + call add_error(fx%error_stack, "Illegal '&' found in attribute") + call add_error_position(fx%error_stack,fb) + goto 100 + elseif (j==1) then + call add_error(fx%error_stack, "No entity reference found") + call add_error_position(fx%error_stack,fb) + goto 100 + endif + allocate(tempString(j-1)) + tempString = s_in(i+1:i+j-1) + if (existing_entity(fx%predefined_e_list, str_vs(tempString))) then + ! Expand immediately + s_temp(i2) = expand_entity_text(fx%predefined_e_list, str_vs(tempString)) + i = i + j + 1 + i2 = i2 + 1 + elseif (checkCharacterEntityReference(str_vs(tempString), fx%xds%xml_version)) then + ! Expand all character entities + s_temp(i2) = expand_char_entity(str_vs(tempString)) + i = i + j + 1 + i2 = i2 + 1 ! fixme + elseif (checkName(str_vs(tempString), fx%xds%xml_version)) then + ent => getEntityByName(fx%forbidden_ge_list, str_vs(tempString)) + if (associated(ent)) then + call add_error(fx%error_stack, 'Recursive entity expansion') + call add_error_position(fx%error_stack,fb) + goto 100 + else + ent => getEntityByName(fx%xds%entityList, str_vs(tempString)) + endif + if (associated(ent)) then + if (ent%wfc.and.fx%xds%standalone) then + call add_error(fx%error_stack, 'Externally declared entity referenced in standalone document') + call add_error_position(fx%error_stack,fb) + goto 100 + endif + !is it the right sort of entity? + if (ent%external) then + call add_error(fx%error_stack, "External entity forbidden in attribute") + call add_error_position(fx%error_stack,fb) + goto 100 + endif +#ifdef PGF90 + call add_internal_entity(fx%forbidden_ge_list, str_vs(tempString), "", nullURI, .false.) +#else + call add_internal_entity(fx%forbidden_ge_list, str_vs(tempString), "", null(), .false.) +#endif + ! Recursively expand entity, checking for errors. + s_ent => normalize_attribute_text(fx, & + vs_str(expand_entity_text(fx%xds%entityList, str_vs(tempString))),fb) + dummy = pop_entity_list(fx%forbidden_ge_list) + if (in_error(fx%error_stack)) then + goto 100 + endif + allocate(s_temp2(size(s_temp)+size(s_ent)-j)) + s_temp2(:i2-1) = s_temp(:i2-1) + s_temp2(i2:i2+size(s_ent)-1) = s_ent + deallocate(s_temp) + s_temp => s_temp2 + nullify(s_temp2) + i = i + j + 1 + i2 = i2 + size(s_ent) + deallocate(s_ent) + else + s_temp(i2:i2+j) = s_in(i:i+j) + i = i + j + 1 + i2 = i2 + j + 1 + if (.not.fx%skippedExternal.or.fx%xds%standalone) then + call add_error(fx%error_stack, "Undeclared entity encountered in standalone document.") + call add_error_position(fx%error_stack,fb) + goto 100 + endif + endif + else + call add_error(fx%error_stack, "Illegal entity reference") + call add_error_position(fx%error_stack,fb) + goto 100 + endif + deallocate(tempString) + else + s_temp(i2) = s_in(i) + i = i + 1 + i2 = i2 + 1 + endif + enddo + + deallocate(s_out) + allocate(s_out(i2-1)) + s_out = s_temp(:i2-1) +100 deallocate(s_temp) + if (associated(s_ent)) deallocate(s_ent) + if (associated(tempString)) deallocate(tempString) + + end function normalize_attribute_text + + recursive function expand_pe_text(fx, s_in, fb) result(s_out) + type(sax_parser_t), intent(inout) :: fx + character, dimension(:), intent(in) :: s_in + type(file_buffer_t), intent(inout) :: fb + character, dimension(:), pointer :: s_out + + character, dimension(:), pointer :: s_temp, s_temp2, s_ent, tempString + character :: dummy + integer :: i, i2, j, iostat + type(entity_t), pointer :: ent +#ifdef PGF90 + type(URI), pointer :: nullURI + nullURI => null() +#endif + + ! Expand all %PE; + + allocate(s_temp(size(s_in))) ! in the first instance + allocate(s_out(0)) ! in case we return early ... + s_ent => null() + tempString => null() + s_temp2 => null() + + i2 = 1 + i = 1 + do while (i <= size(s_in)) + if (s_in(i)=='%') then + j = index(str_vs(s_in(i+1:)), ';') + if (j==0) then + call add_error(fx%error_stack, "Illegal '%' found in attribute") + call add_error_position(fx%error_stack,fb) + goto 100 + elseif (j==1) then + call add_error(fx%error_stack, "No entity reference found") + call add_error_position(fx%error_stack,fb) + goto 100 + endif + allocate(tempString(j-1)) + tempString = s_in(i+1:i+j-1) + if (checkName(str_vs(tempString), fx%xds%xml_version)) then + ent => getEntityByName(fx%forbidden_pe_list, str_vs(tempString)) + if (associated(ent)) then + call add_error(fx%error_stack, 'Recursive entity expansion') + call add_error_position(fx%error_stack,fb) + goto 100 + endif + ent => getEntityByName(fx%xds%peList, str_vs(tempString)) + if (associated(ent)) then + if (ent%wfc.and.fx%xds%standalone) then + call add_error(fx%error_stack, & + "Externally declared entity used in standalone document") + call add_error_position(fx%error_stack,fb) + goto 100 + elseif (str_vs(ent%notation)/="") then + call add_error(fx%error_stack, "Unparsed entity reference forbidden in entity value") + call add_error_position(fx%error_stack,fb) + goto 100 + endif +#ifdef PGF90 + call add_internal_entity(fx%forbidden_pe_list, str_vs(tempString), "", nullURI, .false.) +#else + call add_internal_entity(fx%forbidden_pe_list, str_vs(tempString), "", null(), .false.) +#endif + ! Recursively expand entity, checking for errors. + if (ent%external) then + call open_new_file(fb, ent%baseURI, iostat) + if (iostat/=0) then + call add_error(fx%error_stack, "Unable to access external parameter entity") + call add_error_position(fx%error_stack,fb) + goto 100 + endif + call parse_text_declaration(fb, fx%error_stack) + if (in_error(fx%error_stack)) goto 100 + s_temp2 => get_all_characters(fb, fx%error_stack) + call pop_buffer_stack(fb) + if (in_error(fx%error_stack)) goto 100 + s_ent => expand_pe_text(fx, s_temp2, fb) + deallocate(s_temp2) + else + s_ent => expand_pe_text(fx, & + vs_str(expand_entity_text(fx%xds%peList, str_vs(tempString))), fb) + endif + dummy = pop_entity_list(fx%forbidden_pe_list) + if (in_error(fx%error_stack)) then + goto 100 + endif + allocate(s_temp2(size(s_temp)+size(s_ent)-j)) + s_temp2(:i2-1) = s_temp(:i2-1) + s_temp2(i2:i2+size(s_ent)-1) = s_ent + deallocate(s_temp) + s_temp => s_temp2 + s_temp2 => null() + i = i + j + 1 + i2 = i2 + size(s_ent) + deallocate(s_ent) + else + s_temp(i2:i2+j) = s_in(i:i+j) + i = i + j + 1 + i2 = i2 + j + 1 + if (.not.fx%skippedExternal.or.fx%xds%standalone) then + call add_error(fx%error_stack, "Reference to undeclared parameter entity encountered in standalone document.") + call add_error_position(fx%error_stack,fb) + goto 100 + endif + endif + else + call add_error(fx%error_stack, "Illegal parameter entity reference") + call add_error_position(fx%error_stack,fb) + goto 100 + endif + deallocate(tempString) + else + s_temp(i2) = s_in(i) + i = i + 1 + i2 = i2 + 1 + endif + enddo + + deallocate(s_out) + allocate(s_out(i2-1)) + s_out = s_temp(:i2-1) +100 deallocate(s_temp) + if (associated(s_temp2)) deallocate(s_temp2) + if (associated(s_ent)) deallocate(s_ent) + if (associated(tempString)) deallocate(tempString) + + end function expand_pe_text +#endif + +end module m_sax_tokenizer diff --git a/src/xml/sax/m_sax_types.F90 b/src/xml/sax/m_sax_types.F90 new file mode 100644 index 000000000..eb123c781 --- /dev/null +++ b/src/xml/sax/m_sax_types.F90 @@ -0,0 +1,163 @@ +module m_sax_types + +#ifndef DUMMYLIB + use m_common_attrs, only: dictionary_t + use m_common_elstack, only: elstack_t + use m_common_entities, only: entity_list + use m_common_error, only: error_stack + use m_common_namespaces, only: namespacedictionary + use m_common_notations, only: notation_list + use m_common_struct, only: xml_doc_state + + use fox_m_fsys_varstr, only: varstr + + use m_sax_reader, only: file_buffer_t + + implicit none + + ! Context + + integer, parameter :: CTXT_NULL = -1 + integer, parameter :: CTXT_INIT = 0 + integer, parameter :: CTXT_BEFORE_DTD = 1 + integer, parameter :: CTXT_IN_DTD = 2 + integer, parameter :: CTXT_IGNORE = 3 + integer, parameter :: CTXT_BEFORE_CONTENT = 4 + integer, parameter :: CTXT_IN_CONTENT = 5 + integer, parameter :: CTXT_AFTER_CONTENT = 6 + + ! State + + integer, parameter :: ST_STOP = -1 + integer, parameter :: ST_NULL = 0 + integer, parameter :: ST_MISC = 1 + integer, parameter :: ST_BANG_TAG = 2 + integer, parameter :: ST_START_PI = 3 + integer, parameter :: ST_PI_CONTENTS = 4 + integer, parameter :: ST_PI_END = 5 + integer, parameter :: ST_START_COMMENT = 6 + integer, parameter :: ST_COMMENT_END = 7 + integer, parameter :: ST_START_TAG = 8 + integer, parameter :: ST_START_CDATA_DECLARATION = 9 + integer, parameter :: ST_FINISH_CDATA_DECLARATION = 10 + integer, parameter :: ST_IN_TAG = 11 + integer, parameter :: ST_ATT_NAME = 12 + integer, parameter :: ST_ATT_EQUALS = 13 + integer, parameter :: ST_CHAR_IN_CONTENT = 14 + integer, parameter :: ST_CLOSING_TAG = 15 + integer, parameter :: ST_CDATA_CONTENTS = 16 + integer, parameter :: ST_IN_CLOSING_TAG = 17 + integer, parameter :: ST_TAG_IN_CONTENT = 18 + integer, parameter :: ST_CDATA_END = 19 + integer, parameter :: ST_IN_DOCTYPE = 20 + integer, parameter :: ST_DOC_NAME = 21 + integer, parameter :: ST_DOC_SYSTEM = 22 + integer, parameter :: ST_DOC_PUBLIC = 23 + integer, parameter :: ST_DOC_DECL = 24 + integer, parameter :: ST_CLOSE_DOCTYPE = 25 + integer, parameter :: ST_START_ENTITY = 26 + integer, parameter :: ST_START_PE = 27 + integer, parameter :: ST_IN_SUBSET = 28 + +! DTD states + integer, parameter :: ST_DTD_NULL = 50 + integer, parameter :: ST_DTD_SUBSET = 51 + integer, parameter :: ST_DTD_START_SECTION_DECL = 52 + integer, parameter :: ST_DTD_FINISH_SECTION_DECL = 53 + integer, parameter :: ST_DTD_IN_IGNORE_SECTION = 54 + integer, parameter :: ST_DTD_BANG_TAG = 55 + integer, parameter :: ST_DTD_START_PI = 56 + integer, parameter :: ST_DTD_PI_CONTENTS = 57 + integer, parameter :: ST_DTD_PI_END = 58 + integer, parameter :: ST_DTD_COMMENT_END = 59 + integer, parameter :: ST_DTD_START_COMMENT = 60 + integer, parameter :: ST_DTD_ATTLIST = 61 + integer, parameter :: ST_DTD_ELEMENT = 62 + integer, parameter :: ST_DTD_ENTITY = 63 + integer, parameter :: ST_DTD_NOTATION = 64 + integer, parameter :: ST_DTD_NOTATION_ID = 65 + integer, parameter :: ST_DTD_NOTATION_SYSTEM = 66 + integer, parameter :: ST_DTD_NOTATION_PUBLIC = 67 + integer, parameter :: ST_DTD_NOTATION_PUBLIC_2 = 68 + integer, parameter :: ST_DTD_NOTATION_END = 69 + integer, parameter :: ST_DTD_ENTITY_PE = 70 + integer, parameter :: ST_DTD_ENTITY_ID = 71 + integer, parameter :: ST_DTD_ENTITY_PUBLIC = 72 + integer, parameter :: ST_DTD_ENTITY_SYSTEM = 73 + integer, parameter :: ST_DTD_ENTITY_NDATA = 74 + integer, parameter :: ST_DTD_ENTITY_NDATA_VALUE = 75 + integer, parameter :: ST_DTD_ENTITY_END = 76 + integer, parameter :: ST_DTD_ATTLIST_CONTENTS = 77 + integer, parameter :: ST_DTD_ATTLIST_END = 78 + integer, parameter :: ST_DTD_ELEMENT_CONTENTS = 79 + integer, parameter :: ST_DTD_ELEMENT_END = 80 + integer, parameter :: ST_DTD_DONE = 81 + +! token types + + integer, parameter :: TOK_NULL = 0 + integer, parameter :: TOK_PI_TAG = 1 ! + integer, parameter :: TOK_COMMENT_END = 10 ! --> + integer, parameter :: TOK_SECTION_START = 11 ! + integer, parameter :: TOK_END_TAG = 13 ! > + integer, parameter :: TOK_END_TAG_CLOSE = 14 ! /> + integer, parameter :: TOK_CLOSE_TAG = 15 ! null() + logical :: isUSASCII + character, pointer :: filename(:) => null() + type(URI), pointer :: baseURI => null() + integer :: line = 0 + integer :: col = 0 + integer :: startChar = 1 ! First character after XML decl + character, pointer :: next_chars(:) => null() ! pushback buffer + type(buffer_t), pointer :: input_string => null() + logical :: pe = .false. ! is this a parameter entity? + logical :: eof = .false.! need to keep track of this at the end of pes + end type xml_source_t + + public :: buffer_t + public :: xml_source_t + + public :: get_char_from_file + public :: push_file_chars + public :: parse_declaration + +contains + + + function get_char_from_file(f, xv, eof, es) result(string) + type(xml_source_t), intent(inout) :: f + integer, intent(in) :: xv + logical, intent(out) :: eof + type(error_stack), intent(inout) :: es + character(len=1) :: string + + integer :: iostat + logical :: pending + character :: c, c2 + + pending = .false. + eof = .false. + c = read_single_char(f, iostat) + if (iostat==io_eof) then + eof = .true. + return + elseif (iostat/=0) then + call add_error(es, "Error reading "//str_vs(f%filename)) + return + endif + if (.not.isLegalChar(c, f%isUSASCII, xv)) then + call add_error(es, "Illegal character found at " & + //str_vs(f%filename)//":"//f%line//":"//f%col) + return + endif + if (c==achar(13)) then + c = achar(10) + c2 = read_single_char(f, iostat) + if (iostat==io_eof) then + ! the file has just ended on a single CR. Report is as a LF. + ! Ignore the eof just now, it'll be picked up if we need to + ! perform another read. + eof = .false. + elseif (iostat/=0) then + call add_error(es, "Error reading "//str_vs(f%filename)) + return + elseif (c2/=achar(10)) then + ! then we keep c2, otherwise we'd just ignore it. + pending = .true. + endif + endif + string = c + + if (pending) then + ! we have one character left over, put in the pushback buffer + deallocate(f%next_chars) + allocate(f%next_chars(1)) + f%next_chars = c2 + endif + + if (c==achar(10)) then + f%line = f%line + 1 + f%col = 0 + else + f%col = f%col + 1 + endif + + end function get_char_from_file + + function read_single_char(f, iostat) result(c) + type(xml_source_t), intent(inout) :: f + integer, intent(out) :: iostat + character :: c + + if (f%eof) then + c = "" + iostat = io_eof + return + endif + if (f%lun==-1) then + if (f%input_string%pos>size(f%input_string%s)) then + c = "" + if (f%pe) then + iostat = 0 + else + iostat = io_eof + endif + f%eof = .true. + else + iostat = 0 + c = f%input_string%s(f%input_string%pos) + f%input_string%pos = f%input_string%pos + 1 + endif + else + read (unit=f%lun, iostat=iostat, advance="no", fmt="(a1)") c + if (iostat==io_eor) then + iostat = 0 +#ifdef FC_EOR_LF + c = achar(10) +#else + c = achar(13) +#endif + elseif (iostat==io_eof) then + if (f%pe) iostat = 0 + c = "" + f%eof = .true. + endif + endif + end function read_single_char + + subroutine rewind_source(f) + type(xml_source_t), intent(inout) :: f + + if (f%lun==-1) then + f%input_string%pos = 1 + else + rewind(f%lun) + endif + end subroutine rewind_source + + subroutine push_file_chars(f, s) + type(xml_source_t), intent(inout) :: f + character(len=*), intent(in) :: s + character, dimension(:), pointer :: nc + + nc => vs_str_alloc(s//str_vs(f%next_chars)) + deallocate(f%next_chars) + f%next_chars => nc + + end subroutine push_file_chars + + + subroutine parse_declaration(f, eof, es, standalone) + type(xml_source_t), intent(inout) :: f + logical, intent(out) :: eof + type(error_stack), intent(inout) :: es + logical, intent(out), optional :: standalone + + integer :: parse_state, xd_par + character :: c, q + character, pointer :: ch(:), ch2(:) + + integer, parameter :: XD_0 = 0 + integer, parameter :: XD_START = 1 + integer, parameter :: XD_TARGET = 2 + integer, parameter :: XD_MISC = 3 + integer, parameter :: XD_PA = 4 + integer, parameter :: XD_EQ = 5 + integer, parameter :: XD_QUOTE = 6 + integer, parameter :: XD_PV = 7 + integer, parameter :: XD_END = 8 + integer, parameter :: XD_SPACE = 9 + + integer, parameter :: xd_nothing = 0 + integer, parameter :: xd_version = 1 + integer, parameter :: xd_encoding = 2 + integer, parameter :: xd_standalone = 3 + + f%xml_version = XML1_0 + if (present(standalone)) standalone = .false. + + f%startChar = 1 + + parse_state = XD_0 + xd_par = xd_nothing + ch => null() + do + c = get_char_from_file(f, XML1_0, eof, es) + if (eof) then + call rewind_source(f) + exit + elseif (in_error(es)) then + goto 100 + endif + f%startChar = f%startChar + 1 + + select case (parse_state) + + case (XD_0) + if (c=="<") then + parse_state = XD_START + else + call rewind_source(f) + exit + endif + + case (XD_START) + if (c=="?") then + parse_state = XD_TARGET + ch => vs_str_alloc("") + else + call rewind_source(f) + exit + endif + + case (XD_TARGET) + if (isXML1_0_NameChar(c)) then + ch2 => vs_str_alloc(str_vs(ch)//c) + deallocate(ch) + ch => ch2 + elseif (verify(c, XML_WHITESPACE)==0 & + .and.str_vs(ch)=="xml") then + deallocate(ch) + parse_state = XD_MISC + else + call rewind_source(f) + deallocate(ch) + exit + endif + + case (XD_SPACE) + if (verify(c, XML_WHITESPACE)==0) then + parse_state = XD_MISC + elseif (c=="?") then + parse_state = XD_END + else + call add_error(es, & + "Missing space in XML declaration") + endif + + case (XD_MISC) + if (c=="?") then + parse_state = XD_END + elseif (isXML1_0_NameChar(c)) then + ch => vs_str_alloc(c) + parse_state = XD_PA + elseif (verify(c, XML_WHITESPACE)>0) then + call add_error(es, & + "Unexpected character in XML declaration") + endif + + case (XD_PA) + if (isXML1_0_NameChar(c)) then + ch2 => vs_str_alloc(str_vs(ch)//c) + deallocate(ch) + ch => ch2 + elseif (verify(c, XML_WHITESPACE//"=")==0) then + select case (str_vs(ch)) + + case ("version") + select case (xd_par) + case (xd_nothing) + xd_par = xd_version + case default + call add_error(es, & + "Cannot specify version twice in XML declaration") + end select + + case ("encoding") + select case (xd_par) + case (xd_nothing) + if (present(standalone)) then + call add_error(es, & + "Must specify version before encoding in XML declaration") + else + xd_par = xd_encoding + endif + case (xd_version) + xd_par = xd_encoding + case (xd_encoding) + call add_error(es, & + "Cannot specify encoding twice in XML declaration") + case (xd_standalone) + call add_error(es, & + "Cannot specify encoding after standalone in XML declaration") + end select + + case ("standalone") + if (.not.present(standalone)) & + call add_error(es, & + "Cannot specify standalone in text declaration") + select case (xd_par) + case (xd_nothing) + call add_error(es, & + "Must specify version before standalone in XML declaration") + case (xd_version, xd_encoding) + xd_par = xd_standalone + case (xd_standalone) + call add_error(es, & + "Cannot specify standalone twice in XML declaration") + end select + + case default + call add_error(es, & + "Unknown parameter "//str_vs(ch)//" in XML declaration, "//& + "expecting version, encoding or standalone") + + end select + + deallocate(ch) + if (c=="=") then + parse_state = XD_QUOTE + else + parse_state = XD_EQ + endif + else + call add_error(es, & + "Unexpected character found in XML declaration") + endif + + case (XD_EQ) + if (c=="=") then + parse_state = XD_QUOTE + elseif (verify(c, XML_WHITESPACE)>0) then + call add_error(es, & + "Unexpected character found in XML declaration; expecting ""=""") + endif + + case (XD_QUOTE) + if (verify(c, "'""")==0) then + q = c + parse_state = XD_PV + ch => vs_str_alloc("") + elseif (verify(c, XML_WHITESPACE)>0) then + call add_error(es, & + "Unexpected character found in XML declaration; expecting "" or '") + endif + + case (XD_PV) + if (c==q) then + select case (xd_par) + case (xd_version) + if (str_vs(ch)//"x"=="1.0x") then + f%xml_version = XML1_0 + deallocate(ch) + elseif (str_vs(ch)//"x"=="1.1x") then + f%xml_version = XML1_1 + deallocate(ch) + else + call add_error(es, & + "Unknown version number "//str_vs(ch)//" found in XML declaration; expecting 1.0 or 1.1") + endif + case (xd_encoding) + if (size(ch)==0) then + call add_error(es, & + "Empty value for encoding not allowed in XML declaration") + elseif (size(ch)==1.and.verify(ch(1), XML_INITIALENCODINGCHARS)>0) then + call add_error(es, & + "Invalid encoding found in XML declaration; illegal characters in encoding name") + elseif (size(ch)>1.and. & + (verify(ch(1), XML_INITIALENCODINGCHARS)>0 & + .or.verify(str_vs(ch(2:)), XML_ENCODINGCHARS)>0)) then + call add_error(es, & + "Invalid encoding found in XML declaration; illegal characters in encoding name") + elseif (.not.allowed_encoding(str_vs(ch))) then + call add_error(es, "Unknown character encoding in XML declaration") + else + f%encoding => ch + f%isUSASCII = isUSASCII(str_vs(ch)) + ch => null() + endif + case (xd_standalone) + if (str_vs(ch)//"x"=="yesx") then + standalone = .true. + deallocate(ch) + elseif (str_vs(ch)//"x"=="nox") then + standalone = .false. + deallocate(ch) + else + call add_error(es, & + "Invalid value for standalone found in XML declaration; expecting yes or no") + + endif + end select + parse_state = XD_SPACE + else + ch2 => vs_str_alloc(str_vs(ch)//c) + deallocate(ch) + ch => ch2 + endif + + case (XD_END) + if (c==">") then + exit + else + call add_error(es, & + "Unexpected character found in XML declaration; expecting >") + endif + + end select + + end do + + if (.not.associated(f%encoding)) then + if (present(standalone).or.parse_state/=XD_END) then + f%encoding => vs_str_alloc("utf-8") + else + call add_error(es, "Missing encoding in text declaration") + endif + endif + +100 if (associated(ch)) deallocate(ch) + ! if there is no XML declaraion, or if parsing caused an error, then + if (parse_state/=XD_END.or.in_error(es)) f%startChar = 1 + + end subroutine parse_declaration +#endif + +end module m_sax_xml_source diff --git a/src/xml/utils/FoX_utils.F90 b/src/xml/utils/FoX_utils.F90 new file mode 100644 index 000000000..560f91e59 --- /dev/null +++ b/src/xml/utils/FoX_utils.F90 @@ -0,0 +1,22 @@ +module FoX_utils + + use fox_m_utils_uuid + use fox_m_utils_uri + + implicit none + private + + public :: generate_uuid + + public :: URI + public :: parseURI + public :: rebaseURI + public :: copyURI + public :: destroyURI + public :: expressURI + public :: hasFragment + public :: hasScheme + public :: getScheme + public :: getPath + +end module FoX_utils diff --git a/src/xml-fortran/Makefile b/src/xml/utils/Makefile similarity index 69% rename from src/xml-fortran/Makefile rename to src/xml/utils/Makefile index 6bba7a148..449bd4d91 100644 --- a/src/xml-fortran/Makefile +++ b/src/xml/utils/Makefile @@ -1,12 +1,11 @@ -reader = xmlreader -source = $(wildcard *.f90) -objects = $(source:.f90=.o) +source = $(wildcard *.F90) +objects = $(source:.F90=.o) #=============================================================================== # Compiler Options #=============================================================================== -# Ignore unused variables +# Ignore unusd variables ifeq ($(MACHINE),bluegene) override F90 = xlf2003 @@ -20,11 +19,11 @@ endif # Targets #=============================================================================== -all: $(reader) -$(reader): $(objects) - $(F90) $(objects) $(LDFLAGS) -o $@ +all: $(objects) + mv *.mod ../include + mv *.o ../lib clean: - @rm -f *.o *.mod $(reader) + @rm -f *.o *.mod neat: @rm -f *.o *.mod @@ -32,16 +31,16 @@ neat: # Rules #=============================================================================== -.SUFFIXES: .f90 .o -.PHONY: all clean neat +.SUFFIXES: .F90 .o -%.o: %.f90 - $(F90) $(F90FLAGS) -c $< +.PHONY: clean neat + +%.o: %.F90 + $(F90) $(F90FLAGS) -c -I../include $< #=============================================================================== # Dependencies #=============================================================================== -read_xml_primitives.o: xmlparse.o -write_xml_primitives.o: xmlparse.o -xmlreader.o: xmlparse.o +FoX_utils.o: fox_m_utils_uuid.o fox_m_utils_uri.o +fox_m_utils_uuid.o: fox_m_utils_mtprng.o diff --git a/src/xml/utils/fox_m_utils_mtprng.F90 b/src/xml/utils/fox_m_utils_mtprng.F90 new file mode 100644 index 000000000..90a766d2b --- /dev/null +++ b/src/xml/utils/fox_m_utils_mtprng.F90 @@ -0,0 +1,360 @@ +module fox_m_utils_mtprng +#ifndef DUMMYLIB +!--------------------------------------------------------------------- +! From the Algorithmic Conjurings of Scott Robert Ladd comes... +!--------------------------------------------------------------------- +! +! mtprng.f90 (a Fortran 95 module) +! +! An implementation of the Mersenne Twister algorithm for generating +! psuedo-random sequences. +! +! History +! ------- +! 1.0.0 Initial release +! +! 1.1.0 6 February 2002 +! Updated to support algorithm revisions posted +! by Matsumoto and Nishimura on 26 January 2002 +! +! 1.5.0 12 December 2003 +! Added to hypatia project +! Minor style changes +! Tightened code +! Now state based; no static variables +! Removed mtprng_rand_real53 +! +! 2.0.0 4 January 2004 +! Corrected erroneous unsigned bit manipulations +! Doubled resolution by using 64-bit math +! Added mtprng_rand64 + +! Version for distribution with FoX +! Very small cosmetic changes to fit FoX naming scheme and +! avoid additional dependencies. +! Toby White , 2007 + +! +! ORIGINAL ALGORITHM COPYRIGHT +! ============================ +! Copyright (C) 1997,2002 Makoto Matsumoto and Takuji Nishimura. +! Any feedback is very welcome. For any question, comments, see +! http://www.math.keio.ac.jp/matumoto/emt.html or email +! matumoto@math.keio.ac.jp +!--------------------------------------------------------------------- +! +! COPYRIGHT NOTICE, DISCLAIMER, and LICENSE: +! +! This notice applies *only* to this specific expression of this +! algorithm, and does not imply ownership or invention of the +! implemented algorithm. +! +! If you modify this file, you may insert additional notices +! immediately following this sentence. +! +! Copyright 2001, 2002, 2004 Scott Robert Ladd. +! All rights reserved, except as noted herein. +! +! This computer program source file is supplied "AS IS". Scott Robert +! Ladd (hereinafter referred to as "Author") disclaims all warranties, +! expressed or implied, including, without limitation, the warranties +! of merchantability and of fitness for any purpose. The Author +! assumes no liability for direct, indirect, incidental, special, +! exemplary, or consequential damages, which may result from the use +! of this software, even if advised of the possibility of such damage. +! +! The Author hereby grants anyone permission to use, copy, modify, and +! distribute this source code, or portions hereof, for any purpose, +! without fee, subject to the following restrictions: +! +! 1. The origin of this source code must not be misrepresented. +! +! 2. Altered versions must be plainly marked as such and must not +! be misrepresented as being the original source. +! +! 3. This Copyright notice may not be removed or altered from any +! source or altered source distribution. +! +! The Author specifically permits (without fee) and encourages the use +! of this source code for entertainment, education, or decoration. If +! you use this source code in a product, acknowledgment is not required +! but would be appreciated. +! +! Acknowledgement: +! This license is based on the wonderful simple license that +! accompanies libpng. +! +!----------------------------------------------------------------------- +! +! For more information on this software package, please visit +! Scott's web site, Coyote Gulch Productions, at: +! +! http://www.coyotegulch.com +! +!----------------------------------------------------------------------- + + implicit none + + ! Kind types for 64-, 32-, 16-, and 8-bit signed integers + integer, parameter :: INT64 = selected_int_kind(18) + integer, parameter :: INT32 = selected_int_kind(9) + integer, parameter :: INT16 = selected_int_kind(4) + integer, parameter :: INT08 = selected_int_kind(2) + + ! Kind types for IEEE 754/IEC 60559 single- and double-precision reals + integer, parameter :: IEEE32 = selected_real_kind( 6, 37 ) + integer, parameter :: IEEE64 = selected_real_kind( 15, 307 ) + + !------------------------------------------------------------------------------ + ! Everything is private unless explicitly made public + private + + public :: mtprng_state, & + mtprng_init, mtprng_init_by_array, & + mtprng_rand64, mtprng_rand, mtprng_rand_range, & + mtprng_rand_real1, mtprng_rand_real2, mtprng_rand_real3 + + !------------------------------------------------------------------------------ + ! Constants + integer(INT32), parameter :: N = 624_INT32 + integer(INT32), parameter :: M = 397_INT32 + + !------------------------------------------------------------------------------ + ! types + type mtprng_state + integer(INT32) :: mti = -1 + integer(INT64), dimension(0:N-1) :: mt + end type + +contains + !-------------------------------------------------------------------------- + ! Initializes the generator with "seed" + subroutine mtprng_init(seed, state) + + ! arguments + integer(INT32), intent(in) :: seed + type(mtprng_state), intent(out) :: state + + ! working storage + integer :: i + + ! save seed + state%mt(0) = seed + + ! Set the seed using values suggested by Matsumoto & Nishimura, using + ! a generator by Knuth. See original source for details. + do i = 1, N - 1 + state%mt(i) = iand(4294967295_INT64,1812433253_INT64 * ieor(state%mt(i-1),ishft(state%mt(i-1),-30_INT64)) + i) + end do + + state%mti = N + + end subroutine mtprng_init + + !-------------------------------------------------------------------------- + ! Initialize with an array of seeds + subroutine mtprng_init_by_array(init_key, state) + + ! arguments + integer(INT32), dimension(:), intent(in) :: init_key + type(mtprng_state), intent(out) :: state + + ! working storage + integer :: key_length + integer :: i + integer :: j + integer :: k + + call mtprng_init(19650218_INT32,state) + + i = 1 + j = 0 + key_length = size(init_key) + + do k = max(N,key_length), 0, -1 + state%mt(i) = ieor(state%mt(i),(ieor(state%mt(i-1),ishft(state%mt(i-1),-30_INT64) * 1664525_INT64))) + init_key(j) + j + + i = i + 1 + j = j + 1 + + if (i >= N) then + state%mt(0) = state%mt(N-1) + i = 1 + end if + + if (j >= key_length) j = 0 + end do + + do k = N-1, 0, -1 + state%mt(i) = ieor(state%mt(i),(ieor(state%mt(i-1),ishft(state%mt(i-1),-30_INT64) * 1566083941_INT64))) - i + + i = i + 1 + + if (i>=N) then + state%mt(0) = state%mt(N-1) + i = 1 + end if + end do + + state%mt(0) = 1073741824_INT64 ! 0x40000000, assuring non-zero initial array + + end subroutine mtprng_init_by_array + + !-------------------------------------------------------------------------- + ! Obtain the next 32-bit integer in the psuedo-random sequence + function mtprng_rand64(state) result(r) + + ! arguments + type(mtprng_state), intent(inout) :: state + + !return type + integer(INT64) :: r + + ! internal constants + integer(INT64), dimension(0:1), parameter :: mag01 = (/ 0_INT64, -1727483681_INT64 /) + + ! Period parameters + integer(INT64), parameter :: UPPER_MASK = 2147483648_INT64 + integer(INT64), parameter :: LOWER_MASK = 2147483647_INT64 + + ! Tempering parameters + integer(INT64), parameter :: TEMPERING_B = -1658038656_INT64 + integer(INT64), parameter :: TEMPERING_C = -272236544_INT64 + + ! Note: variable names match those in original example + integer(INT32) :: kk + + ! Generate N words at a time + if (state%mti >= N) then + ! The value -1 acts as a flag saying that the seed has not been set. + if (state%mti == -1) call mtprng_init(4357_INT32,state) + + ! Fill the mt array + do kk = 0, N - M - 1 + r = ior(iand(state%mt(kk),UPPER_MASK),iand(state%mt(kk+1),LOWER_MASK)) + state%mt(kk) = ieor(ieor(state%mt(kk + M),ishft(r,-1_INT64)),mag01(iand(r,1_INT64))) + end do + + do kk = N - M, N - 2 + r = ior(iand(state%mt(kk),UPPER_MASK),iand(state%mt(kk+1),LOWER_MASK)) + state%mt(kk) = ieor(ieor(state%mt(kk + (M - N)),ishft(r,-1_INT64)),mag01(iand(r,1_INT64))) + end do + + r = ior(iand(state%mt(N-1),UPPER_MASK),iand(state%mt(0),LOWER_MASK)) + state%mt(N-1) = ieor(ieor(state%mt(M-1),ishft(r,-1)),mag01(iand(r,1_INT64))) + + ! Start using the array from first element + state%mti = 0 + end if + + ! Here is where we actually calculate the number with a series of + ! transformations + r = state%mt(state%mti) + state%mti = state%mti + 1 + + r = ieor(r,ishft(r,-11)) + r = iand(4294967295_INT64,ieor(r,iand(ishft(r, 7),TEMPERING_B))) + r = iand(4294967295_INT64,ieor(r,iand(ishft(r,15),TEMPERING_C))) + r = ieor(r,ishft(r,-18)) + + end function mtprng_rand64 + + !-------------------------------------------------------------------------- + ! Obtain the next 32-bit integer in the psuedo-random sequence + function mtprng_rand(state) result(r) + + ! arguments + type(mtprng_state), intent(inout) :: state + + !return type + integer(INT32) :: r + + ! working storage + integer(INT64) :: x + + ! done + x = mtprng_rand64(state) + + if (x > 2147483647_INT64) then + r = x - 4294967296_INT64 + else + r = x + end if + + end function mtprng_rand + + !--------------------------------------------------------------------------- + ! Obtain a psuedorandom integer in the range [lo,hi] + function mtprng_rand_range(state, lo, hi) result(r) + + ! arguments + type(mtprng_state), intent(inout) :: state + integer, intent(in) :: lo + integer, intent(in) :: hi + + ! return type + integer(INT32) :: r + + ! Use real value to caluclate range + r = lo + floor((hi - lo + 1.0_IEEE64) * mtprng_rand_real2(state)) + + end function mtprng_rand_range + + !-------------------------------------------------------------------------- + ! Obtain a psuedorandom real number in the range [0,1], i.e., a number + ! greater than or equal to 0 and less than or equal to 1. + function mtprng_rand_real1(state) result(r) + + ! arguments + type(mtprng_state), intent(inout) :: state + + ! return type + real(IEEE64) :: r + + ! Local constant; precalculated to avoid division below + real(IEEE64), parameter :: factor = 1.0_IEEE64 / 4294967295.0_IEEE64 + + ! compute + r = real(mtprng_rand64(state),IEEE64) * factor + + end function mtprng_rand_real1 + + !-------------------------------------------------------------------------- + ! Obtain a psuedorandom real number in the range [0,1), i.e., a number + ! greater than or equal to 0 and less than 1. + function mtprng_rand_real2(state) result(r) + + ! arguments + type(mtprng_state), intent(inout) :: state + + ! return type + real(IEEE64) :: r + + ! Local constant; precalculated to avoid division below + real(IEEE64), parameter :: factor = 1.0_IEEE64 / 4294967296.0_IEEE64 + + ! compute + r = real(mtprng_rand64(state),IEEE64) * factor + + end function mtprng_rand_real2 + + !-------------------------------------------------------------------------- + ! Obtain a psuedorandom real number in the range (0,1), i.e., a number + ! greater than 0 and less than 1. + function mtprng_rand_real3(state) result(r) + + ! arguments + type(mtprng_state), intent(inout) :: state + + ! return type + real(IEEE64) :: r + + ! Local constant; precalculated to avoid division below + real(IEEE64), parameter :: factor = 1.0_IEEE64 / 4294967296.0_IEEE64 + + r = (real(mtprng_rand64(state),IEEE64) + 0.5_IEEE64) * factor + + end function mtprng_rand_real3 + +#endif +end module fox_m_utils_mtprng diff --git a/src/xml/utils/fox_m_utils_uri.F90 b/src/xml/utils/fox_m_utils_uri.F90 new file mode 100644 index 000000000..a3f1d70ff --- /dev/null +++ b/src/xml/utils/fox_m_utils_uri.F90 @@ -0,0 +1,1033 @@ +module fox_m_utils_uri +#ifndef DUMMYLIB + + ! Manipulate URIs and URI references a la RFC 2396 + ! NB: ... + ! Forbidden (ASCII control) characters are not handled correctly + ! checking of reg names (not hosts) is done wrongly + ! checking of ipv6/X is untested + + use fox_m_fsys_array_str, only: str_vs, vs_str_alloc, vs_vs_alloc + use fox_m_fsys_format, only: str_to_int_10, str_to_int_16, str + use fox_m_fsys_string, only: toLower + + implicit none + private + + type path_segment + character, pointer :: s(:) => null() + end type path_segment +#endif + + type URI + private +#ifndef DUMMYLIB + character, pointer :: scheme(:) => null() + character, pointer :: authority(:) => null() + character, pointer :: userinfo(:) => null() + character, pointer :: host(:) => null() + integer :: port = -1 + character, pointer :: path(:) => null() + type(path_segment), pointer :: segments(:) => null() + character, pointer :: query(:) => null() + character, pointer :: fragment(:) => null() +#else + integer :: i +#endif + end type URI + +#ifndef DUMMYLIB + character(len=*), parameter :: lowalpha = "abcdefghijklmnopqrstuvwxyz" + character(len=*), parameter :: upalpha = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + character(len=*), parameter :: alpha = lowalpha//upalpha + character(len=*), parameter :: digit = "0123456789" + character(len=*), parameter :: hexdigit = "0123456789abcdefABCDEF" + character(len=*), parameter :: alphanum = alpha//digit + character(len=*), parameter :: unreserved = alphanum//"-._~" + character(len=*), parameter :: gen_delims = ":/?#[]@" + character(len=*), parameter :: sub_delims = "!$&'()*+,;=" + character(len=*), parameter :: reserved = gen_delims//sub_delims + character(len=*), parameter :: pchar = unreserved//":@&=+$," + character(len=*), parameter :: uric_no_slash = unreserved//";?:@&=+$," + character(len=*), parameter :: uric = unreserved//reserved + character(len=*), parameter :: unwise = "{}|\^[]`" +#endif + + public :: URI + public :: parseURI + public :: expressURI + public :: isAbsoluteURI + public :: rebaseURI + public :: copyURI + public :: destroyURI + + public :: hasScheme + public :: getScheme + public :: hasAuthority + public :: getAuthority + public :: hasUserinfo + public :: getUserinfo + public :: hasHost + public :: getHost + public :: hasPort + public :: getPort + public :: getPath + public :: hasQuery + public :: getQuery + public :: hasFragment + public :: getFragment + +#ifndef DUMMYLIB + public :: dumpURI +#endif + +contains + +#ifndef DUMMYLIB + function unEscape_alloc(s) result(c) + character(len=*), intent(in) :: s + character, pointer :: c(:) + + integer :: i, j, n + character(len(s)) :: t + + c => null() + + i = 1 + j = 0 + do while (i<=len(s)) + j = j + 1 + if (s(i:i)=="%") then + if (i+2>len(s)) return + if (verify(s(i+1:i+2), hexdigit)/=0) return + n = str_to_int_16(s(i+1:i+2)) + t(j:j) = achar(n) + i = i + 3 + else + t(j:j) = s(i:i) + i = i + 1 + endif + enddo + + c => vs_str_alloc(t(:j)) + end function unEscape_alloc + + function verifyWithPctEncoding(s, chars) result(p) + character(len=*), intent(in) :: s + character(len=*), intent(in) :: chars + logical :: p + + integer :: i + + p = .false. + i = 1 + do while (i<=len(s)) + if (s(i:i)=="%") then + if (i+2>len(s)) return + if (verify(s(i+1:i+2), hexdigit)>0) return + i = i + 3 + else + if (verify(s(i:i),chars)>0) return + i = i + 1 + endif + enddo + p = .true. + end function verifyWithPctEncoding + + pure function pctEncode_len(s, chars) result(n) + character(len=*), intent(in) :: s + character(len=*), intent(in) :: chars + integer :: n + + integer :: i + n = 0 + do i = 1, len(s) + n = n + 1 + if (verify(s(i:i), unwise)==0.or.verify(s(i:i), chars)>0) n = n + 2 + enddo + + end function pctEncode_len + + function pctEncode(s, chars) result(ps) + character(len=*), intent(in) :: s + character(len=*), intent(in) :: chars + character(len=pctEncode_len(s, chars)) :: ps + + integer :: i, n + + n = 1 + do i = 1, len(s) + if (verify(s(i:i), unwise)==0.or.verify(s(i:i), chars)>0) then + ps(n:n+2) = "%"//str(iachar(s(i:i)), "x2") + n = n + 3 + else + ps(n:n) = s(i:i) + n = n + 1 + endif + enddo + + end function pctEncode + + function checkOpaquePart(part) result(p) + character(len=*), intent(in) :: part + logical :: p + + if (len(part)>0) then + p = verify(part(1:1), uric_no_slash)==0 + if (p.and.len(part)>1) & + p = verify(part(1:1), uric)==0 + endif + end function checkOpaquePart + + + function checkScheme(scheme) result(p) + character(len=*), intent(in) :: scheme + logical :: p + + p = len(scheme)>0 + if (p) then + p = verify(scheme(1:1), lowalpha//upalpha)==0 + if (p.and.len(scheme)>1) then + p = verify(scheme(2:), alphanum//"+-.")==0 + endif + endif + end function checkScheme + + function checkIpvX(host) result(p) + character(len=*), intent(in) :: host + logical :: p + + integer :: i, n1, n2 + + p = (len(host)>5).and.(host(1:1)=="[".and.host(len(host):len(host))=="]") + + if (p) then + + ! Try IPvFuture: + p = (verify(host(2:2),"Vv")==0 & + .and.verify(host(3:3),hexdigit)==0 & + .and.host(4:4)=="." & + .and.verify(host(3:3),unreserved//sub_delims//":")==0) + + if (.not.p) then ! is it IPv6? + n1 = 0 + do i = 1, 4 + n2 = index(host(n1+1:), ":") + if (n2==0.or.n2>6) return + n2 = n2 + n1 + if (verify(host(n1+1:n2-1),hexdigit)>0) return + n1 = n2 + enddo + n2 = index(host(n1+1:), ":") + if (n2==0) then + ! this must be ipv4 format + do i = 1, 3 + n2 = index(host(n1+1:), ".") + if (n2==0) return + n2 = n2 + n1 + if (verify(host(n1+1:n2-1),digit)>0) return + if (str_to_int_10(host(n1+1:n2-1))>255) return + n1 = n2 + enddo + ! Now there must be 3 or less digits followed by ] + n2 = len(host)-1 + if (verify(host(n1+1:n2-1),digit)>0) return + if (str_to_int_10(host(n1+1:n2-1))>255) return + elseif (n2<6) then + n2 = n2 + n1 + if (verify(host(n1+1:n2-1),hexdigit)>0) return + ! Now there must be 4 or less digits followed by ] + n1 = n2 + n2 = len(host) + if (n2-n1>4) return + if (verify(host(n1+1:n2-1),hexdigit)>0) return + endif + p = .true. + endif + endif + end function checkIpvX + + function checkHost(host) result(p) + character(len=*), intent(in) :: host + logical :: p + + p = checkIpvX(host) + if (.not.p) & + p = verifyWithPctEncoding(host, unreserved//sub_delims) + + end function checkHost + + function checkAuthority(authority, userinfo, host, port) result(p) + character(len=*), intent(in) :: authority + character, pointer :: userinfo(:), host(:) + integer :: port + logical :: p + + integer :: i1, i2 + + p = .true. + if (len(authority)==0) return + + i1 = index(authority, "@") + if (i1>0) then + i2 = index(authority(i1+1:), ":") + else + i2 = index(authority, ":") + endif + if (i1==0) then + userinfo => null() + else + p = verifyWithPctEncoding(authority(:i1-1), unreserved//sub_delims//":") + if (p) userinfo => unEscape_alloc(authority(:i1-1)) + endif + if (i2==0) then + i2 = len(authority)+1 + else + i2 = i1 + i2 + p = p.and.verify(authority(i2+1:), digit)==0 + if (p) port = str_to_int_10(authority(i2+1:)) + endif + p = p.and.checkHost(authority(i1+1:i2-1)) + if (p) then + host => vs_str_alloc(authority(i1+1:i2-1)) + else + if (associated(userinfo)) deallocate(userinfo) + end if + + end function checkAuthority + + function checkPathSegment(segment) result(p) + character(len=*), intent(in) :: segment + logical :: p + + integer :: i1 + + i1 = index(segment, ";") + if (i1>0) then + p = verifyWithPctEncoding(segment(:i1-1), pchar) & + .and.verifyWithPctEncoding(segment(i1+1:), pchar) + else + p = verifyWithPctEncoding(segment, unreserved//pchar) + endif + end function checkPathSegment + + function checkNonOpaquePath(path, segments) result(p) + character(len=*), intent(in) :: path + type(path_segment), pointer :: segments(:) + logical :: p + + integer :: i, i1, i2 + type(path_segment), pointer :: temp(:) + + p = .true. + i1 = index(path, "/") + if (i1==1) then ! absolute path + allocate(segments(1)) + segments(1)%s => vs_str_alloc("/") + else + allocate(segments(0)) + i1 = 0 + endif + + do + i2 = index(path(i1+1:), "/") + if (i2==0) then + i2 = len(path) + else + i2 = i1 + i2 + endif + if (checkPathSegment(path(i1+1:i2-1))) then + allocate(temp(size(segments)+1)) + do i = 1, size(segments) + temp(i)%s => segments(i)%s + enddo + temp(i)%s => unEscape_alloc(path(i1+1:i2)) + deallocate(segments) + segments => temp + else + do i = 1, size(segments) + deallocate(segments(i)%s) + enddo + deallocate(segments) + p = .false. + return + endif + if (i2==len(path)) exit + i1 = i2 + end do + end function checkNonOpaquePath + + function checkPath(path, segments) result(p) + character(len=*), intent(in) :: path + type(path_segment), pointer :: segments(:) + logical :: p + + p = checkNonOpaquePath(path, segments) + if (.not.p) then + p = checkOpaquePart(path) + if (p) allocate(segments(0)) + endif + + end function checkPath + + function checkQuery(query) result(p) + character(len=*), intent(in) :: query + logical :: p + + p = verifyWithPctEncoding(query, uric) + end function checkQuery + + function checkFragment(fragment) result(p) + character(len=*), intent(in) :: fragment + logical :: p + + p = verifyWithPctEncoding(fragment, uric) + end function checkFragment +#endif + + function parseURI(inURIstring) result(u) + character(len=*), intent(in) :: inURIstring + type(URI), pointer :: u + character(len=len_trim(inURIstring)) :: URIstring +#ifndef DUMMYLIB + character, pointer, dimension(:) :: scheme, authority, & + userinfo, host, path, query, fragment + integer :: port + type(path_segment), pointer :: segments(:) + integer :: i1, i2, i3, i4 + logical :: p + +#endif + u => null() + URIstring = trim(inURIString) +#ifndef DUMMYLIB + + scheme => null() + authority => null() + userinfo => null() + host => null() + port = -1 + path => null() + segments => null() + query => null() + fragment => null() + + if (len(URIstring)>3) then + ! is this a M$ windoze absolute path ? eg of the form "C:/path_segments" + if ((scan(URIstring(1:1),alpha)>0).and.(URIstring(2:3)==':/') ) then + ! no point in attempting to decode as a uri, it contains only a windows path + scheme => vs_str_alloc("file") + path => unEscape_alloc(URIstring) + allocate(segments(1)) + segments(1)%s => vs_str_alloc("") + call produceResult + return + end if + end if + i1 = index(URIstring, ":") + if (i1>0) then + p = checkScheme(URIstring(:i1-1)) + if (p) then + scheme => vs_str_alloc(toLower(URIstring(:i1-1))) + else + i1 = 0 + endif + endif + ! if either i1==0 or the scheme doesn't validate, there is no scheme.. + if (len(URIstring)>=i1+3) then + if (URIstring(i1+1:i1+2)=="//") then + i2 = scan(URIstring(i1+3:), "/#?") + if (i2==0) then + i2 = len(URIstring) + 1 + else + i2 = i1 + i2 + 2 + endif + p = checkAuthority(URIstring(i1+3:i2-1), userinfo, host, port) + if (.not.p) then + call cleanUp + return + endif + authority => vs_str_alloc(URIstring(i1+3:i2-1)) + else + i2 = i1 + 1 + endif + else + i2 = i1 + 1 + endif + + if (i2>len(URIstring)) then + path => vs_str_alloc("") + allocate(segments(1)) + segments(1)%s => vs_str_alloc("") + call produceResult + return + endif + + i3 = scan(URIstring(i2:),"#?") + if (i3==0) then + i3 = len(URIstring) + 1 + else + i3 = i2 + i3 - 1 + endif + p = checkPath(URIstring(i2:i3-1), segments) + if (.not.p) then + call cleanUp + return + endif + if (len(URIstring(i2:i3-1))>3) then + ! is this a M$ windoze absolute path with a unix root ? eg of the form "/C:/path_segments" + if ( (URIstring(i2:i2)=='/').and.(scan(URIstring(i2+1:i2+1),alpha)>0).and.(URIstring(i2+2:i2+3)==':/') ) then + ! ignore the root slash (which would otherwise make sense on most systems) to yield a representation in windows canonical form + i2 = i2+1 + end if + end if + path => unEscape_alloc(URIstring(i2:i3-1)) + + if (i3>len(URIstring)) then + call produceResult + return + endif + + if (URIstring(i3:i3)=="?") then + i4 = index(URIstring(i3+1:), "#") + if (i4==0) then + i4 = len(URIstring) + 1 + else + i4 = i3 + i4 + endif + p = checkQuery(URIstring(i3+1:i4-1)) + if (.not.p) then + call cleanUp + return + endif + query => vs_str_alloc(URIstring(i3+1:i4-1)) + else + i4 = i3 + endif + + if (i4>len(URIstring)) then + call produceResult + return + endif + + p = checkFragment(URIstring(i4+1:)) + if (.not.p) then + call cleanUp + return + endif + fragment => vs_str_alloc(URIstring(i4+1:)) + call produceResult + + contains + subroutine cleanUp + integer :: i + if (associated(scheme)) deallocate(scheme) + if (associated(authority)) deallocate(authority) + if (associated(userinfo)) deallocate(userinfo) + if (associated(host)) deallocate(host) + if (associated(path)) deallocate(path) + if (associated(query)) deallocate(query) + if (associated(fragment)) deallocate(fragment) + if (associated(segments)) then + do i = 1, size(segments) + deallocate(segments(i)%s) + enddo + deallocate(segments) + endif + end subroutine cleanUp + subroutine produceResult + allocate(u) + u%scheme => scheme + u%authority => authority + u%userinfo => userinfo + u%host => host + u%port = port + u%path => path + u%query => query + u%fragment => fragment + u%segments => segments + end subroutine produceResult +#endif + end function parseURI + + function isAbsoluteURI(u) result(p) + type(URI), intent(in) :: u + logical :: p + +#ifdef DUMMYLIB + p = .false. +#else + p = associated(u%scheme).or.associated(u%authority) + if (.not.p.and.size(u%segments(1)%s)>0) then + p = u%segments(1)%s(1)=="/" + endif +#endif + end function isAbsoluteURI + + function rebaseURI(u1, u2) result(u3) + type(URI), pointer :: u1, u2 + type(URI), pointer :: u3 + + u3 => null() +#ifndef DUMMYLIB + + if (associated(u2%scheme).or.associated(u2%authority)) then + u3 => copyURI(u2) + return + endif + + allocate(u3) + if (associated(u1%scheme)) u3%scheme => vs_vs_alloc(u1%scheme) + if (associated(u1%authority)) u3%authority => vs_vs_alloc(u1%authority) + + u3%segments => appendPaths(u1%segments, u2%segments) + u3%path => expressSegments(u3%segments) + + if (associated(u2%query)) u3%query => vs_vs_alloc(u2%query) + if (associated(u2%fragment)) u3%fragment => vs_vs_alloc(u2%fragment) +#endif + end function rebaseURI + +#ifndef DUMMYLIB + function appendPaths(seg1, seg2) result(seg3) + type(path_segment), pointer :: seg1(:), seg2(:) + type(path_segment), pointer :: seg3(:) + + type(path_segment), pointer :: temp(:) + + integer :: i, n, n2 + + if (size(seg2(1)%s)==0) then + seg3 => normalizePath(seg1) + return + elseif (seg2(1)%s(1)=="/") then + seg3 => normalizePath(seg2) + return + endif + + n = size(seg1) + size(seg2) + i = size(seg1) + if (seg1(i)%s(size(seg1(i)%s))/="/") & + n = n - 1 + + allocate(temp(n)) + n2 = 1 + do i = 1, size(seg1) + if (i==size(seg1).and.seg1(i)%s(size(seg1(i)%s))/="/") exit ! it's a file + temp(n2)%s => vs_vs_alloc(seg1(i)%s) + n2 = n2 + 1 + enddo + + do i = 1, size(seg2) + temp(n2)%s => vs_vs_alloc(seg2(i)%s) + n2 = n2 + 1 + enddo + + seg3 => normalizePath(temp) + do i = 1, size(temp) + deallocate(temp(i)%s) + enddo + deallocate(temp) + + end function appendPaths + + function normalizepath(seg1) result(seg2) + type(path_segment), pointer :: seg1(:) + type(path_segment), pointer :: seg2(:) + + integer :: i, n, n2, parents + character, pointer :: tmp(:) + + + ! If the last of the input segments are + ! equal to '.' or '..', append a slash + ! so the rest of the subroutine works. + + if ((str_vs(seg1(size(seg1))%s) == '.').or. & + (str_vs(seg1(size(seg1))%s) == '..')) then + tmp => vs_vs_alloc(seg1(size(seg1))%s) + deallocate(seg1(size(seg1))%s) + seg1(size(seg1))%s => vs_str_alloc(str_vs(tmp)//"/") + deallocate(tmp) + endif + + n = 0 + parents = 0 + do i = 1, size(seg1) + if (str_vs(seg1(i)%s)//"x"=="./x") then + continue + elseif (str_vs(seg1(i)%s)//"x"=="../x") then + if (n>0) then + n = n - 1 + else + parents = parents + 1 + endif + else + n = n + 1 + endif + enddo + + n = n + parents + allocate(seg2(n)) + + n2 = parents + do i = 1, parents + seg2(i)%s => vs_str_alloc("../") + enddo + do i = 1, size(seg1) + if (str_vs(seg1(i)%s)//"x"=="./x") then + continue + elseif (str_vs(seg1(i)%s)//"x"=="../x") then + if (n2>parents) then + if (n2<=n) deallocate(seg2(n2)%s) + n2 = n2 - 1 + endif + else + n2 = n2 + 1 + if (n2>0.and.n2<=n) & + seg2(n2)%s => vs_vs_alloc(seg1(i)%s) + endif + enddo + + end function normalizepath + + function expressSegments(seg1) result(s) + type(path_segment), pointer :: seg1(:) + character, pointer :: s(:) + + integer :: i, n + + n = 0 + + do i = 1, size(seg1) + n = n + size(seg1(i)%s) + enddo + allocate(s(n)) + n = 1 + do i = 1, size(seg1) + s(n:n+size(seg1(i)%s)-1) = seg1(i)%s + n = n + size(seg1(i)%s) + enddo + end function expressSegments + + pure function expressURI_len(u) result(n) + type(URI), intent(in) :: u + integer :: n + + n = 0 + if (associated(u%scheme)) & + n = size(u%scheme) + 1 + if (associated(u%authority)) & + n = n + pctEncode_len(str_vs(u%authority), unreserved//sub_delims//"@:") + 2 + !FIXME - I suspect that ';' as the first character of a segment should be escaped + n = n + pctEncode_len(str_vs(u%path), pchar//";"//"/") + if (associated(u%query)) & + n = n + pctEncode_len(str_vs(u%query), uric) + 1 + if (associated(u%fragment)) & + n = n + pctEncode_len(str_vs(u%fragment), uric) + 1 + + end function expressURI_len + + function expressURI(u) result(URIstring) + type(URI), intent(in) :: u + character(len=expressURI_len(u)) :: URIstring + + integer :: i, j + URIstring="" + i = 1 + if (associated(u%scheme)) then + URIstring(:size(u%scheme)+1) = str_vs(u%scheme)//":" + i = i + size(u%scheme) + 1 + endif + if (associated(u%authority)) then + j = pctEncode_len(str_vs(u%authority), unreserved//sub_delims//"@:") + URIstring(i:i+j+1) = & + "//"//pctEncode(str_vs(u%authority), unreserved//sub_delims//"@:") + i = i + j + 2 + endif + if (size(u%path)>0) then + !FIXME - I suspect that ';' as the first character of a segment should be escaped + j = pctEncode_len(str_vs(u%path), pchar//";"//"/") + URIstring(i:i+j-1) = pctEncode(str_vs(u%path), pchar//";"//"/") + i = i + j + endif + if (associated(u%query)) then + j = pctEncode_len(str_vs(u%query), uric) + URIstring(i:i+j) = "?"//pctEncode(str_vs(u%query), uric) + i = i + j + 1 + endif + if (associated(u%fragment)) then + j = pctEncode_len(str_vs(u%fragment), uric) + URIstring(i:i+j) = "#"//pctEncode(str_vs(u%fragment), uric) + endif + + end function expressURI + + subroutine dumpURI(u) + type(URI), intent(in) :: u + integer :: i + if (associated(u%scheme)) then + write(*,*) "scheme: ", str_vs(u%scheme) + else + write(*,*) "scheme UNDEFINED" + endif + if (associated(u%authority)) then + write(*,*) "authority: ", str_vs(u%authority) + else + write(*,*) "authority UNDEFINED" + endif + if (associated(u%userinfo)) then + write(*,*) "userinfo: ", str_vs(u%userinfo) + else + write(*,*) "userinfo UNDEFINED" + endif + if (associated(u%host)) then + write(*,*) "host: ", str_vs(u%host) + else + write(*,*) "host UNDEFINED" + endif + if (u%port>0) then + write(*,*) "port: ", str(u%port) + else + write(*,*) "port UNDEFINED" + endif + if (associated(u%path)) then + write(*,*) "path: ", str_vs(u%path) + else + write(*,*) "path UNDEFINED" + endif + if (associated(u%segments)) then + do i = 1, size(u%segments) + write(*,*) " segment: ", str_vs(u%segments(i)%s) + enddo + endif + if (associated(u%query)) then + write(*,*) "query: ", str_vs(u%query) + else + write(*,*) "query UNDEFINED" + endif + if (associated(u%fragment)) then + write(*,*) "fragment: ", str_vs(u%fragment) + else + write(*,*) "fragment UNDEFINED" + endif + end subroutine dumpURI +#endif + + function copyURI(u1) result(u2) + type(URI), pointer :: u1 + type(URI), pointer :: u2 +#ifndef DUMMYLIB + integer :: i + + if (.not.associated(u1)) then +#endif + u2 => null() +#ifndef DUMMYLIB + return + endif + allocate(u2) + u2%scheme => vs_vs_alloc(u1%scheme) + u2%authority => vs_vs_alloc(u1%authority) + u2%userinfo => vs_vs_alloc(u1%userinfo) + u2%host => vs_vs_alloc(u1%host) + u2%port = u1%port + u2%path => vs_vs_alloc(u1%path) + allocate(u2%segments(size(u1%segments))) + do i = 1, size(u1%segments) + u2%segments(i)%s => vs_vs_alloc(u1%segments(i)%s) + enddo + u2%query => vs_vs_alloc(u1%query) + u2%fragment => vs_vs_alloc(u1%fragment) +#endif + end function copyURI + + + subroutine destroyURI(u) + type(URI), pointer :: u +#ifndef DUMMYLIB + integer :: i + if (associated(u%scheme)) deallocate(u%scheme) + if (associated(u%authority)) deallocate(u%authority) + if (associated(u%userinfo)) deallocate(u%userinfo) + if (associated(u%host)) deallocate(u%host) + if (associated(u%path)) deallocate(u%path) + if (associated(u%segments)) then + do i = 1, size(u%segments) + deallocate(u%segments(i)%s) + enddo + deallocate(u%segments) + endif + if (associated(u%query)) deallocate(u%query) + if (associated(u%fragment)) deallocate(u%fragment) + + deallocate(u) +#endif + end subroutine destroyURI + + function hasScheme(u) result(p) + type(URI), pointer :: u + logical :: p + + p = .false. +#ifndef DUMMYLIB + if (.not.associated(u)) return + p = associated(u%scheme) +#endif + end function hasScheme + + function getScheme(u) result(s) + type(URI), pointer :: u + +#ifndef DUMMYLIB + character(len=size(u%scheme)) :: s + s = str_vs(u%scheme) +#else + character(len=1) :: s + s = "" +#endif + end function getScheme + + function hasAuthority(u) result(p) + type(URI), pointer :: u + logical :: p + + p = .false. +#ifndef DUMMYLIB + if (.not.associated(u)) return + p = associated(u%authority) +#endif + end function hasAuthority + + function getAuthority(u) result(s) + type(URI), pointer :: u +#ifndef DUMMYLIB + character(len=size(u%authority)) :: s + s = str_vs(u%authority) +#else + character(len=1) :: s + s = "" +#endif + end function getAuthority + + function hasUserinfo(u) result(p) + type(URI), pointer :: u + logical :: p + + p = .false. +#ifndef DUMMYLIB + if (.not.associated(u)) return + p = associated(u%userinfo) +#endif + end function hasUserinfo + + function getUserinfo(u) result(s) + type(URI), pointer :: u +#ifndef DUMMYLIB + character(len=size(u%userinfo)) :: s + s = str_vs(u%userinfo) +#else + character(len=1) :: s + s = "" +#endif + end function getUserinfo + + function hasHost(u) result(p) + type(URI), pointer :: u + logical :: p + + p = .false. +#ifndef DUMMYLIB + if (.not.associated(u)) return + p = associated(u%host) +#endif + end function hasHost + + function getHost(u) result(s) + type(URI), pointer :: u +#ifndef DUMMYLIB + character(len=size(u%host)) :: s + s = str_vs(u%host) +#else + character(len=1) :: s + s = "" +#endif + end function getHost + + function hasPort(u) result(p) + type(URI), pointer :: u + logical :: p + + p = .false. +#ifndef DUMMYLIB + if (.not.associated(u)) return + p = u%port > 0 +#endif + end function hasPort + + function getPort(u) result(n) + type(URI), pointer :: u + integer :: n +#ifndef DUMMYLIB + n = u%port +#else + n = 0 +#endif + end function getPort + + function getPath(u) result(s) + type(URI), pointer :: u +#ifndef DUMMYLIB + character(len=size(u%path)) :: s + s = str_vs(u%path) +#else + character(len=1) :: s + s = "" +#endif + end function getPath + + function hasQuery(u) result(p) + type(URI), pointer :: u + logical :: p + + p = .false. +#ifndef DUMMYLIB + if (.not.associated(u)) return + p = associated(u%query) +#endif + end function hasQuery + + function getQuery(u) result(s) + type(URI), pointer :: u +#ifndef DUMMYLIB + character(len=size(u%query)) :: s + s = str_vs(u%query) +#else + character(len=1) :: s + s = "" +#endif + end function getQuery + + function hasFragment(u) result(p) + type(URI), pointer :: u + logical :: p + + p = .false. +#ifndef DUMMYLIB + if (.not.associated(u)) return + p = associated(u%fragment) +#endif + end function hasFragment + + function getFragment(u) result(s) + type(URI), pointer :: u +#ifndef DUMMYLIB + character(len=size(u%fragment)) :: s + s = str_vs(u%fragment) +#else + character(len=1) :: s + s = "" +#endif + end function getFragment + +end module fox_m_utils_uri diff --git a/src/xml/utils/fox_m_utils_uuid.F90 b/src/xml/utils/fox_m_utils_uuid.F90 new file mode 100644 index 000000000..fd9c272d9 --- /dev/null +++ b/src/xml/utils/fox_m_utils_uuid.F90 @@ -0,0 +1,247 @@ +module fox_m_utils_uuid + + !This generates UUIDs according to RFC 4122 + + ! Only types 1 (time-based) and 4 (pseudo-RNG-based) are implemented. + +#ifndef DUMMYLIB + use fox_m_utils_mtprng, only : mtprng_state, mtprng_init, mtprng_rand64 +#endif + + implicit none + private + +#ifndef DUMMYLIB + integer, parameter :: i4b = selected_int_kind(9) + integer, parameter :: i8b = selected_int_kind(18) + + character, parameter :: hexdigits(0:15) = & + (/'0','1','2','3','4','5','6','7','8','9','a','b','c','d','e','f'/) + + type(mtprng_state), save :: rng_state + logical, save :: initialized = .false. + integer, save :: values_save ! must be default for date_and_time + integer(kind=i4b), save :: hires_count = 0 + +! clock-seq holds a random number constant for the lifetime of the program +! using this module. That's the best we can do per S 4.1.5 + integer, save :: clock_seq = 0 + +#endif + + public :: generate_uuid + +contains + + function generate_uuid(version) result(uuid) + integer, intent(in), optional :: version + character(len=36) :: uuid + +#ifdef DUMMYLIB + uuid = "" +#else + integer(kind=i8b) :: timestamp, node + integer(kind=i4b) :: clock_sequence + + integer(kind=i4b) :: time_low, time_mid, time_hi_and_version + integer(kind=i4b) :: clk_seq_hi_res, clk_seq_low + + integer :: values(8) ! must be default for date_and_time + integer(kind=i4b) :: variant, v + + + if (.not.initialized) then + ! Use the current date and time to init mtprng + ! but this gives limited varaibility, so mix + ! the result up. Can we do better? In any + ! case, this gets passed through a quick + ! generator inside mtprng_init. + call date_and_time(values=values) + values(7) = values(7)*1000+values(5)*100+values(3)*10+values(1) + values(8) = values(2)*1000+values(4)*100+values(6)*10+values(8) + call mtprng_init(int(values(7)*10000+values(8), i4b), rng_state) + clock_seq = int(mtprng_rand64(rng_state), i4b) + initialized = .true. + endif + + variant = 1 + + if (present(version)) then + v = version + else + v = 4 + endif + + select case (v) + case (0) + ! Nil UUID - S 4.1.7 + uuid = repeat('0',8)//'-'//repeat('0',4)//'-'//repeat('0',4)// & + '-'//repeat('0',4)//'-'//repeat('0',12) + return + case(1) + call date_and_time(values=values) + ! In case of too-frequent requests, we will replace time_low + ! with the count below ... + if (all(values==values_save)) then + hires_count = hires_count + 1 + else + hires_count = 0 + endif + case(2-3) + !Unimplemented + uuid = '' + return + case(4) + continue + case(5) + !Unimplemented + uuid = '' + return + case default + !Unspecified + uuid = '' + return + end select + +!4.1.4 Timestamp + + select case(v) + case(1) + timestamp = get_utc_since_1582(values) + case(4) + timestamp = ior(mtprng_rand64(rng_state), ishft(mtprng_rand64(rng_state), 28)) + end select + +!4.1.5 Clock Sequence + ! 14 bits + select case(v) + case(1) + clock_sequence = clock_seq + case(4) + clock_sequence = int(mtprng_rand64(rng_state), i4b) + end select + +!4.1.6 Node + ! 48 bits + select case(v) + case(1) + node = ior(mtprng_rand64(rng_state), ishft(mtprng_rand64(rng_state), 16)) + ! No MAC address accessible - see section 4.5 !FIXME + case(4) + node = ior(mtprng_rand64(rng_state), ishft(mtprng_rand64(rng_state), 16)) + end select + + time_low = ibits(timestamp, 0, 32) + time_mid = ibits(timestamp, 32, 16) + if (hires_count==0) then + time_hi_and_version = ior(int(ibits(timestamp, 48, 12), i4b), ishft(v, 12)) + else + time_hi_and_version = ior(hires_count, ishft(v, 12)) + endif + + clk_seq_low = ibits(clock_sequence, 0, 8) + clk_seq_hi_res = ior(ibits(clock_sequence, 8, 6), ishft(variant, 6)) + + uuid = int32ToHexOctets(time_low, 4)//"-"// & + int32ToHexOctets(time_mid, 2)//"-"// & + int32ToHexOctets(time_hi_and_version, 2)//"-"// & + int32ToHexOctets(clk_seq_hi_res, 1)// & + int32ToHexOctets(clk_seq_low, 1)//"-"// & + int64ToHexOctets(node, 6) + + contains + + function int32ToHexOctets(b, n) result(s) + integer(i4b), intent(in) :: b + integer, intent(in) :: n ! number of octets to print + character(len=2*n) :: s + + integer :: i + + do i = 0, 2*n-1 + s(2*n-i:2*n-i) = hexdigits(ibits(b, i*4, 4)) + enddo + + end function int32ToHexOctets + function int64ToHexOctets(b, n) result(s) + integer(i8b), intent(in) :: b + integer, intent(in) :: n ! number of octets to print + character(len=2*n) :: s + + integer :: i + + do i = 0, 2*n-1 + s(2*n-i:2*n-i) = hexdigits(ibits(b, i*4, 4)) + enddo + + end function int64ToHexOctets + +#endif + end function generate_uuid + +#ifndef DUMMYLIB + function get_utc_since_1582(values) result(ns) + ! This subroutine is a little broken. It only works + ! for times after 1/1/2006 and takes no account + ! of any future leapseconds. It ought to serve regardless. + + ! It returns the number of 100-ns intervals since 1582-10-15-00-00-00 + + integer, dimension(8), intent(in) :: values + integer(kind=i8b) :: ns + + integer :: days + integer :: years + + integer, parameter :: days_in_normal_year(12) = & + (/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/) + + ns = 23_i8b * 1000_i8b * 1000_i8b * 10_i8b ! 23 leap seconds until 24:00:00 31/12/2005 + + ! A count of the 100-nanosecond intervals since the + ! beginning of the day. + ns = ns & + ! milliseconds + + int(values(8), i8b) * 10_i8b * 1000_i8b & + ! seconds + + int(values(7), i8b) * 10_i8b * 1000_i8b * 1000_i8b & + ! minutes (with timezone adjustment) + + int(values(6) + values(4), i8b) * 10_i8b * 1000_i8b * 1000_i8b * 60_i8b & + ! hours + + int(values(5), i8b) * 10_i8b * 1000_i8b * 1000_i8b * 60_i8b * 60_i8b + + ! Number of days this year: + days = sum(days_in_normal_year(:values(2)-1)) + days = days + values(3) - 1 !add days in current month + if (values(2)>2 .and. isLeapYear(values(1))) then + days = days + 1 + endif + !That's all the time since the turn of this year + + days = days + 78 ! From the start of 15th Oct to the end of 31st Dec in 1582 + !That's the additional time before the turn of the year 1583 + + days = days + 102 ! 102 leap years from 1584 to 2000 inclusive + ! That's all the intercalataed days until 2000 + + years = values(1) - 2000 - 1 ! years since 2000 - not including this year + + days = days + years/4 - years/100 + years/400 !Add extra leap days to this total: + ! That's all out intercalated days - remaining years are all 365 days long. + + years = years + 418 ! Add the years from 1583-2000 inclusive back on. + + ! Multiply by number of time units in one day & add to today's total. + ns = ns + 864000000000_i8b * (int(days,i8b) + 365_i8b * int(years,i8b)) + + contains + function isLeapYear(y) result(p) + integer, intent(in) :: y + logical :: p + p = (mod(y,4)==0 .and. .not.mod(y,100)==0 .or. mod(y,400)==0) + end function isLeapYear + + end function get_utc_since_1582 + +#endif +end module fox_m_utils_uuid diff --git a/src/xml/wxml/FoX_wxml.F90 b/src/xml/wxml/FoX_wxml.F90 new file mode 100644 index 000000000..cf4def0a7 --- /dev/null +++ b/src/xml/wxml/FoX_wxml.F90 @@ -0,0 +1,45 @@ +module FoX_wxml + + use m_wxml_core + use m_wxml_overloads + + implicit none + private + + public :: xmlf_t + public :: xml_OpenFile + public :: xml_Close + public :: xml_NewElement + public :: xml_EndElement + public :: xml_AddXMLDeclaration + public :: xml_AddXMLStylesheet + public :: xml_AddXMLPI + public :: xml_AddComment + public :: xml_AddEntityReference + + public :: xml_AddCharacters + public :: xml_AddNewline + public :: xml_AddAttribute + public :: xml_AddPseudoAttribute + + public :: xml_DeclareNamespace + public :: xml_UndeclareNamespace + + public :: xml_AddDOCTYPE + public :: xml_AddParameterEntity + public :: xml_AddInternalEntity + public :: xml_AddExternalEntity + public :: xml_AddNotation + public :: xml_AddElementToDTD + public :: xml_AddAttlistToDTD + public :: xml_AddPEreferenceToDTD + + public :: xmlf_GetPretty_print + public :: xmlf_SetPretty_print + public :: xmlf_GetExtendedData + public :: xmlf_SetExtendedData + + public :: xmlf_Name + public :: xmlf_OpenTag + +end module FoX_wxml diff --git a/src/templates/Makefile b/src/xml/wxml/Makefile similarity index 51% rename from src/templates/Makefile rename to src/xml/wxml/Makefile index 232ae9609..55dcc3d9c 100644 --- a/src/templates/Makefile +++ b/src/xml/wxml/Makefile @@ -1,15 +1,15 @@ -templates = $(wildcard *.xml) -objects = $(templates:.xml=.o) +source = $(wildcard *.F90) +objects = $(source:.F90=.o) #=============================================================================== # Compiler Options #=============================================================================== -# Add include for subdirectory +# Ignore unusd variables -override F90FLAGS += -I../xml-fortran - -# Ignore unused variables +ifeq ($(MACHINE),bluegene) + override F90 = xlf2003 +endif ifeq ($(F90),ifort) override F90FLAGS += -warn nounused @@ -20,19 +20,28 @@ endif #=============================================================================== all: $(objects) + mv *.mod ../include + mv *.o ../lib clean: - @rm -f *.o *.mod *.out *.f90 + @rm -f *.o *.mod +neat: + @rm -f *.o *.mod #=============================================================================== # Rules #=============================================================================== -.SUFFIXES: .f90 .o .xml -.PHONY: all clean -.PRECIOUS: %.f90 +.SUFFIXES: .F90 .o -%.f90: %.xml - ../xml-fortran/xmlreader $(basename $@) +.PHONY: clean neat -%.o: %.f90 - $(F90) $(F90FLAGS) -c $(basename $@).f90 +%.o: %.F90 + $(F90) $(F90FLAGS) -c -I../include $< + +#=============================================================================== +# Dependencies +#=============================================================================== + +FoX_wxml.o: m_wxml_core.o m_wxml_overloads.o +m_wxml_core.o: m_wxml_escape.o +m_wxml_overloads.o: m_wxml_core.o diff --git a/src/xml/wxml/m_wxml_core.F90 b/src/xml/wxml/m_wxml_core.F90 new file mode 100644 index 000000000..7e905c2ab --- /dev/null +++ b/src/xml/wxml/m_wxml_core.F90 @@ -0,0 +1,1877 @@ +module m_wxml_core + +#ifndef DUMMYLIB + use fox_m_fsys_abort_flush, only: pxfabort + use fox_m_fsys_array_str, only: vs_str, str_vs, vs_str_alloc + use fox_m_fsys_string, only: toLower + use fox_m_utils_uri, only: URI, parseURI, destroyURI + use m_common_attrs, only: dictionary_t, getLength, get_key, get_value, & + hasKey, add_item_to_dict, init_dict, reset_dict, destroy_dict, & + getWhitespaceHandling, sortAttrs + use m_common_buffer, only: buffer_t, len, add_to_buffer, reset_buffer, & + dump_buffer + use m_common_charset, only: XML1_0, XML1_1, checkChars + use m_common_element, only: parse_dtd_element, parse_dtd_attlist + use m_common_elstack, only: elstack_t, len, get_top_elstack, pop_elstack, & + is_empty, init_elstack, push_elstack, destroy_elstack + use m_common_entities, only: existing_entity, is_unparsed_entity + use m_common_error, only: FoX_warning_base, FoX_error_base, FoX_fatal_base, & + error_stack, in_error, FoX_get_fatal_errors, FoX_get_fatal_warnings + use m_common_io, only: get_unit + use m_common_namecheck, only: checkEncName, checkName, checkQName, & + checkCharacterEntityReference, checkPublicId, prefixOfQName, & + localpartofQName, checkPEDef, checkPseudoAttValue, checkAttValue, checkNCName, & + likeCharacterEntityReference, checkCharacterEntityReference + use m_common_namespaces, only: namespaceDictionary, getnamespaceURI, & + initnamespaceDictionary, addDefaultNS, destroyNamespaceDictionary, & + addPrefixedNS, isPrefixInForce, checkNamespacesWriting, checkEndNamespaces + use m_common_notations, only: add_notation, notation_exists + use m_common_struct, only: xml_doc_state, init_xml_doc_state, destroy_xml_doc_state, & + register_internal_PE, register_external_PE, register_internal_GE, register_external_GE + use m_wxml_escape, only: escape_string +#ifdef PGF90 + use m_common_element, only : element_t +#endif +#endif + + implicit none + private + +#ifndef DUMMYLIB + integer, parameter :: indent_inc = 2 + ! TOHW should we let this be set? + + !Output State Machines + ! status wrt root element: + integer, parameter :: WXML_STATE_1_JUST_OPENED = 0 + !File is just opened, nothing written to it yet. + integer, parameter :: WXML_STATE_1_BEFORE_ROOT = 1 + !File has been opened, something has been written, but no root element yet. + integer, parameter :: WXML_STATE_1_DURING_ROOT = 2 + !The root element has been opened but not closed + integer, parameter :: WXML_STATE_1_AFTER_ROOT = 3 + !The root element has been opened but not closed + + ! status wrt tags: + integer, parameter :: WXML_STATE_2_OUTSIDE_TAG = 0 + !We are not within a tag. + integer, parameter :: WXML_STATE_2_INSIDE_PI = 1 + !We are inside a Processing Instruction tag + integer, parameter :: WXML_STATE_2_INSIDE_ELEMENT = 2 + !We are inside an element tag. + integer, parameter :: WXML_STATE_2_IN_CHARDATA = 3 + !We are inside deliberately-constructed text. (this is only necessary for preserve_whitespace) + + ! status wrt DTD + integer, parameter :: WXML_STATE_3_BEFORE_DTD = 0 + ! No DTD has been encountered yet. + integer, parameter :: WXML_STATE_3_DURING_DTD = 1 + ! Halfway throught outputting a DTD + integer, parameter :: WXML_STATE_3_INSIDE_INTSUBSET = 2 + !We are inside the internal subset definition + integer, parameter :: WXML_STATE_3_AFTER_DTD = 3 + ! Finished outputting a DTD +#endif + + + type xmlf_t + private +#ifdef DUMMYLIB + integer :: i = 0 +#else + type(xml_doc_state) :: xds + integer :: lun = -1 + type(buffer_t) :: buffer + type(elstack_t) :: stack + type(dictionary_t) :: dict + integer :: state_1 = -1 + integer :: state_2 = -1 + integer :: state_3 = -1 + ! Holder for extra information for other writers. See + ! table with getter and setter below: + integer :: extended_data = 0 + logical :: minimize_overrun = .true. + logical :: pretty_print = .false. + logical :: canonical = .false. + integer :: indent = 0 + character, pointer :: name(:) + logical :: namespace = .true. + type(namespaceDictionary) :: nsDict +#endif + end type xmlf_t + + public :: xmlf_t + + public :: xml_OpenFile + public :: xml_NewElement + public :: xml_EndElement + public :: xml_Close + public :: xml_AddXMLDeclaration + public :: xml_AddXMLStylesheet + public :: xml_AddXMLPI + public :: xml_AddComment + public :: xml_AddCharacters + public :: xml_AddNewline + public :: xml_AddEntityReference + public :: xml_AddAttribute + public :: xml_AddPseudoAttribute + public :: xml_DeclareNamespace + public :: xml_UnDeclareNamespace + public :: xml_AddDOCTYPE + public :: xml_AddParameterEntity + public :: xml_AddInternalEntity + public :: xml_AddExternalEntity + public :: xml_AddNotation + public :: xml_AddElementToDTD + public :: xml_AddAttlistToDTD + public :: xml_AddPEreferenceToDTD + + public :: xmlf_Name + public :: xmlf_OpenTag + + public :: xmlf_SetPretty_print + public :: xmlf_GetPretty_print + public :: xmlf_SetExtendedData + public :: xmlf_GetExtendedData + + interface xml_AddCharacters + module procedure xml_AddCharacters_Ch + end interface + interface xml_AddAttribute + module procedure xml_AddAttribute_Ch + end interface + interface xml_AddPseudoAttribute + module procedure xml_AddPseudoAttribute_Ch + end interface + +#ifndef DUMMYLIB + !overload error handlers to allow file info + interface wxml_warning + module procedure wxml_warning_xf, FoX_warning_base + end interface + interface wxml_error + module procedure wxml_error_xf, FoX_error_base + end interface + interface wxml_fatal + module procedure wxml_fatal_xf, FoX_fatal_base + end interface + + ! Heuristic (approximate) target for justification of output + ! only gets used for outputting attributes + integer, parameter :: COLUMNS = 80 + + ! TOHW - This is the longest string that may be output without + ! a newline. The buffer must not be larger than this, but its size + ! can be tuned for performance. + !lowest value found so far is 4096, for NAG. We use 1024 just in case. + integer, parameter :: xml_recl = 1024 +#endif + +contains + + subroutine xml_OpenFile(filename, xf, unit, iostat, preserve_whitespace, & + pretty_print, minimize_overrun, canonical, replace, addDecl, warning, & + validate, namespace) + character(len=*), intent(in) :: filename + type(xmlf_t), intent(inout) :: xf + integer, intent(in), optional :: unit + integer, intent(out), optional :: iostat + logical, intent(in), optional :: preserve_whitespace + logical, intent(in), optional :: pretty_print + logical, intent(in), optional :: minimize_overrun + logical, intent(in), optional :: canonical + logical, intent(in), optional :: replace + logical, intent(in), optional :: addDecl + logical, intent(in), optional :: warning + logical, intent(in), optional :: validate + logical, intent(in), optional :: namespace + +#ifdef DUMMYLIB + if (present(iostat)) iostat = 0 +#else + logical :: repl, decl + integer :: iostat_ + + if (xf%lun /= -1) & + call wxml_fatal("Trying to reopen an already-open XML file") + + if (present(replace)) then + repl = replace + else + repl = .true. + endif + if (present(addDecl)) then + decl = addDecl + else + decl = .true. + endif + if (present(iostat)) iostat = 0 + + allocate(xf%name(0)) + + if (present(unit)) then + if (unit==-1) then + call get_unit(xf%lun,iostat_) + if (iostat_ /= 0) then + if (present(iostat)) iostat = iostat_ + return + endif + else + xf%lun = unit + endif + else + call get_unit(xf%lun,iostat_) + if (iostat_ /= 0) then + if (present(iostat)) iostat = iostat_ + return + endif + endif + + ! Use large I/O buffer in case the O.S./Compiler combination + ! has hard-limits by default (i.e., NAGWare f95's 1024 byte limit) + ! This is related to the maximum size of the buffer. + ! TOHW - This is the longest string that may be output without + ! a newline. The buffer must not be larger than this, but its size + ! can be tuned for performance. + + if (repl) then + ! NAG insists on unnecessary duplication of iostat etc here + if (present(iostat)) then + open(unit=xf%lun, file=filename, form="formatted", status="replace", & + action="write", recl=xml_recl, iostat=iostat) + else + open(unit=xf%lun, file=filename, form="formatted", status="replace", & + action="write", recl=xml_recl) + endif + else + if (present(iostat)) then + open(unit=xf%lun, file=filename, form="formatted", status="new", & + action="write", recl=xml_recl, iostat=iostat) + else + open(unit=xf%lun, file=filename, form="formatted", status="new", & + action="write", recl=xml_recl) + endif + endif + + call init_elstack(xf%stack) + + call init_dict(xf%dict) + !NB it can make no difference which XML version we are using + !until after we output the XML declaration. So we set it to + !1.0 for the moment & reset below. + ! Actually, this is done automatically in initializing xf%xds + call init_xml_doc_state(xf%xds) + xf%xds%documentURI => vs_str_alloc(filename) + + if (present(warning)) then + xf%xds%warning = warning + else + xf%xds%warning = .false. + endif + if (present(validate)) then + xf%xds%valid = validate + else + xf%xds%valid = .false. + endif + xf%state_1 = WXML_STATE_1_JUST_OPENED + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG + xf%state_3 = WXML_STATE_3_BEFORE_DTD + + if (present(pretty_print)) then + xf%pretty_print = pretty_print + else + xf%pretty_print = .true. + endif + if (present(minimize_overrun)) then + xf%minimize_overrun = minimize_overrun + else + xf%minimize_overrun = .false. + endif + if (present(preserve_whitespace)) then + xf%pretty_print = .not.preserve_whitespace + xf%minimize_overrun = preserve_whitespace + endif + if (present(canonical)) then + xf%canonical = canonical + else + xf%canonical = .false. + endif +! FIXME interplay of above options + + xf%indent = 0 + + if (decl) then + call xml_AddXMLDeclaration(xf,encoding='UTF-8') + ! which will reset the buffer itself + else + call reset_buffer(xf%buffer, xf%lun, xf%xds%xml_version) + endif + + if (present(namespace)) then + xf%namespace = namespace + else + xf%namespace = .true. + endif + if (xf%namespace) & + call initNamespaceDictionary(xf%nsDict) +#endif + end subroutine xml_OpenFile + + + subroutine xml_AddXMLDeclaration(xf, version, encoding, standalone) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in), optional :: version + character(len=*), intent(in), optional :: encoding + logical, intent(in), optional :: standalone + +#ifndef DUMMYLIB + call check_xf(xf) + ! Don't need to call checkChars on args, everything is checked + ! fully below anyway. + + if (xf%state_1 /= WXML_STATE_1_JUST_OPENED) & + call wxml_error("Tried to put XML declaration in wrong place") + + call reset_buffer(xf%buffer, xf%lun, xf%xds%xml_version) + + call xml_AddXMLPI(xf, "xml", xml=.true.) + if (present(version)) then + if (version =="1.0") then + xf%xds%xml_version = XML1_0 + call xml_AddPseudoAttribute(xf, "version", version) + elseif (version=="1.1") then + xf%xds%xml_version = XML1_1 + call xml_AddPseudoAttribute(xf, "version", version) + else + call wxml_error("Invalid XML version.") + endif + else + call xml_AddPseudoAttribute(xf, "version", "1.0") + xf%xds%xml_version = XML1_0 + endif + if (present(encoding)) then + if (.not.checkEncName(encoding)) & + call wxml_error("Invalid encoding name: "//encoding) + if (encoding /= 'UTF-8' .and. encoding /= 'utf-8') & + call wxml_warning(xf, "Non-default encoding specified: "//encoding) + call xml_AddPseudoAttribute(xf, "encoding", encoding) + endif + if (present(standalone)) then + xf%xds%standalone_declared = .true. + xf%xds%standalone = standalone + if (standalone) then + call xml_AddPseudoAttribute(xf, "standalone", "yes") + else + call xml_AddPseudoAttribute(xf, "standalone", "no") + endif + endif + call close_start_tag(xf) + ! We have to close explicitly here to ensure nothing gets tied + ! up in the XML declaration + xf%state_1 = WXML_STATE_1_BEFORE_ROOT +#endif + end subroutine xml_AddXMLDeclaration + + + subroutine xml_AddDOCTYPE(xf, name, system, public) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in), optional :: system, public + +#ifndef DUMMYLIB + type(URI), pointer :: URIref + + call check_xf(xf) + + if (xf%namespace) then + if (.not.checkQName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + endif + + if (present(system)) then + URIref => parseURI(system) + if (.not.associated(URIref)) call wxml_error("xml_AddDOCTYPE: Invalid SYSTEM URI") + call destroyURI(URIref) + endif + if (present(public)) then + if (.not.checkPublicId(public)) call wxml_error("xml_AddDOCTYPE: Invalid PUBLIC ID") + endif + + if (present(public).and..not.present(system)) & + call wxml_error('xml_AddDOCTYPE: PUBLIC supplied without SYSTEM for: '//name) + + ! By having an external ID we probably render this non-standalone (unless we've said that it is in the declaration) + if (present(system).and..not.xf%xds%standalone_declared) & + xf%xds%standalone=.false. + + call close_start_tag(xf) + + if (xf%state_1 /= WXML_STATE_1_BEFORE_ROOT) & + call wxml_error("Tried to put XML DOCTYPE in wrong place: "//name) + + if (xf%state_3 /= WXML_STATE_3_BEFORE_DTD) then + call wxml_error("Tried to output more than one DOCTYPE declaration: "//name) + else + xf%state_3 = WXML_STATE_3_DURING_DTD + endif + + call add_eol(xf) + call add_to_buffer(" null() +#endif + if (xf%namespace) then + if (.not.checkNCName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + endif + + if (present(PEDef)) then + if (.not.checkChars(PEDef,xf%xds%xml_version)) call wxml_error("xml_AddParameterEntity: Invalid character in PEDef") + endif + + if (present(system)) then + URIref => parseURI(system) + if (.not.associated(URIref)) call wxml_error("xml_AddParameterEntity: Invalid SYSTEM URI") + call destroyURI(URIref) + endif + if (present(public)) then + if (.not.checkPublicId(public)) call wxml_error("xml_AddParameterEntity: Invalid PUBLIC ID") + endif + + ! By adding a parameter entity (internal or external) we make this + ! a non-standalone document. + if (.not.xf%xds%standalone_declared) & + xf%xds%standalone = .false. + + if (xf%state_3 == WXML_STATE_3_DURING_DTD) then + call add_to_buffer(" [", xf%buffer, .false.) + xf%state_3 = WXML_STATE_3_INSIDE_INTSUBSET + endif + + if (xf%state_3 /= WXML_STATE_3_INSIDE_INTSUBSET) & + call wxml_fatal("Cannot define Parameter Entity here: "//name) + + if (xf%state_2 == WXML_STATE_2_INSIDE_PI) then + call close_start_tag(xf) + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG + endif + + if (present(PEdef)) then + if (present(system) .or. present(public)) & + call wxml_fatal("Parameter entity "//name//" cannot have both a PEdef and an External ID") + else + if (.not.present(system)) & + call wxml_fatal("Parameter entity "//name//" must have either a PEdef or an External ID") + endif + if (present(PEdef)) then + if (.not.checkPEDef(PEDef, xf%xds%xml_version)) & + call wxml_fatal("Parameter entity definition is invalid: "//PEDef) + if (xf%xds%standalone) then + if (.not.checkExistingRefs()) & + call wxml_error("Tried to reference unregistered parameter entity") + else + if (.not.checkExistingRefs()) & + call wxml_warning(xf, "Reference to unknown parameter entity") + endif +#ifdef PGF90 + call register_internal_PE(xf%xds, name=name, text=PEdef, baseURI=nullURIref, wfc=.false.) +#else + call register_internal_PE(xf%xds, name=name, text=PEdef, baseURI=null(), wfc=.false.) +#endif + + else +#ifdef PGF90 + call register_external_PE(xf%xds, name=name, systemId=system, & + publicId=public, baseURI=nullURIref, wfc=.false.) +#else + call register_external_PE(xf%xds, name=name, systemId=system, & + publicId=public, baseURI=null(), wfc=.false.) +#endif + endif + + call add_eol(xf) + + call add_to_buffer(" 0) then ! FIXME what if PEdef has both " and ' in it + call add_to_buffer(" '"//PEdef//"'", xf%buffer, .true.) + else + call add_to_buffer(" """//PEdef//"""", xf%buffer, .true.) + endif + call add_to_buffer(">", xf%buffer, .false.) + else + if (present(public)) then + call add_to_buffer(" PUBLIC", xf%buffer, .false.) + call add_to_buffer(" """//public//"""", xf%buffer, .true.) + else + call add_to_buffer(" SYSTEM", xf%buffer, .false.) + endif + if (scan(system, """")/=0) then + call add_to_buffer(" '"//system//"'", xf%buffer, .true.) + else + call add_to_buffer(" """//system//"""", xf%buffer, .true.) + endif + call add_to_buffer(">", xf%buffer) + endif + + contains + function checkExistingRefs() result(p) + logical :: p + + integer :: i1, i2 + + ! Here we assume we have syntactic well-formedness as + ! checked by checkPEDef. + + p = .false. + i1 = index(PEDef, '%') + i2 = 0 + do while (i1 > 0) + i1 = i2 + i1 + i2 = index(PEDef(i1+1:),';') + if (i2 == 0) return + i2 = i1 + i2 + if (.not.existing_entity(xf%xds%PEList, PEDef(i1+1:i2-1))) & + return + i1 = index(PEDef(i2+1:), '%') + enddo + p = .true. + + end function checkExistingRefs +#endif + end subroutine xml_AddParameterEntity + + + subroutine xml_AddInternalEntity(xf, name, value) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in) :: value + +#ifndef DUMMYLIB +#ifdef PGF90 + type(URI), pointer :: nullURI + nullURI => null() +#endif + call check_xf(xf) + + if (xf%namespace) then + if (.not.checkNCName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + endif + + if (.not.checkChars(value, xf%xds%xml_version)) call wxml_error("xml_AddInternalEntity: Invalid character in value") + + if (xf%state_3 == WXML_STATE_3_DURING_DTD) then + call add_to_buffer(" [", xf%buffer) + xf%state_3 = WXML_STATE_3_INSIDE_INTSUBSET + endif + + if (xf%state_3 /= WXML_STATE_3_INSIDE_INTSUBSET) & + call wxml_fatal("Cannot define Entity here: "//name) + + if (xf%state_2 == WXML_STATE_2_INSIDE_PI) then + call close_start_tag(xf) + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG + endif + + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("xml_AddInternalEntity: Invalid Name: "//name) +#ifdef PGF90 + call register_internal_GE(xf%xds, name=name, text=value, baseURI=nullURI, wfc=.false.) +#else + call register_internal_GE(xf%xds, name=name, text=value, baseURI=null(), wfc=.false.) +#endif + + call add_eol(xf) + + !FIXME - valid entity values? + call add_to_buffer(" 0) then + call add_to_buffer("'"//value//"'>", xf%buffer, .true.) + else + call add_to_buffer(""""//value//""">", xf%buffer, .true.) + endif +#endif + end subroutine xml_AddInternalEntity + + + subroutine xml_AddExternalEntity(xf, name, system, public, notation) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in) :: system + character(len=*), intent(in), optional :: public + character(len=*), intent(in), optional :: notation + +#ifndef DUMMYLIB + type(URI), pointer :: URIref +#ifdef PGF90 + type(URI), pointer :: nullURI + nullURI => null() +#endif + call check_xf(xf) + + if (xf%namespace) then + if (.not.checkNCName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + endif + URIref => parseURI(system) + if (.not.associated(URIref)) call wxml_error("xml_AddExternalEntity: Invalid SYSTEM URI") + call destroyURI(URIref) + if (present(public)) then + if (.not.checkPublicId(public)) call wxml_error("xml_AddExternalEntity: Invalid PUBLIC ID") + endif + if (present(notation)) then + if (xf%namespace) then + if (.not.checkNCName(notation, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + else + if (.not.checkName(notation, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + endif + endif + + if (xf%namespace) then + if (.not.checkNCName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + endif + + if (xf%state_3 == WXML_STATE_3_DURING_DTD) then + call add_to_buffer(" [", xf%buffer, .false.) + xf%state_3 = WXML_STATE_3_INSIDE_INTSUBSET + endif + + if (xf%state_3 /= WXML_STATE_3_INSIDE_INTSUBSET) & + call wxml_fatal("Cannot define Entity here: "//name) + + if (xf%state_2 == WXML_STATE_2_INSIDE_PI) then + call close_start_tag(xf) + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG + endif + + ! Notation only needs checked if not already registered - done above. +#ifdef PGF90 + call register_external_GE(xf%xds, name=name, & + systemID=system, publicId=public, notation=notation, & + baseURI=nullURI, wfc=.false.) +#else + call register_external_GE(xf%xds, name=name, & + systemID=system, publicId=public, notation=notation, & + baseURI=null(), wfc=.false.) +#endif + + call add_eol(xf) + + call add_to_buffer("", xf%buffer, .false.) +#endif + end subroutine xml_AddExternalEntity + + + subroutine xml_AddNotation(xf, name, system, public) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in), optional :: system + character(len=*), intent(in), optional :: public + +#ifndef DUMMYLIB + type(URI), pointer :: URIref + call check_xf(xf) + + if (xf%namespace) then + if (.not.checkNCName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Name in DTD "//name) + endif + if (present(system)) then + URIref => parseURI(system) + if (.not.associated(URIref)) call wxml_error("xml_AddNotation: Invalid SYSTEM URI") + call destroyURI(URIref) + endif + if (present(public)) then + if (.not.checkPublicId(public)) call wxml_error("xml_AddNotation: Invalid PUBLIC ID") + endif + + if (xf%state_3 == WXML_STATE_3_DURING_DTD) then + call add_to_buffer(" [", xf%buffer, .false.) + xf%state_3 = WXML_STATE_3_INSIDE_INTSUBSET + endif + + if (xf%state_3 /= WXML_STATE_3_INSIDE_INTSUBSET) & + call wxml_fatal("Cannot define Notation here: "//name) + + if (xf%state_2 == WXML_STATE_2_INSIDE_PI) then + call close_start_tag(xf) + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG + endif + + if (notation_exists(xf%xds%nList, name)) & + call wxml_error("Tried to create duplicate notation: "//name) + + call add_eol(xf) + + call add_notation(xf%xds%nList, name, system, public) + call add_to_buffer(" 0) then + call add_to_buffer(" '"//system//"'", xf%buffer, .true.) + else + call add_to_buffer(" """//system//"""", xf%buffer, .true.) + endif + endif + call add_to_buffer(">", xf%buffer, .false.) +#endif + end subroutine xml_AddNotation + + + subroutine xml_AddElementToDTD(xf, name, declaration) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in) :: declaration + +#ifndef DUMMYLIB + type(error_stack) :: stack +#ifdef PGF90 + type (element_t), pointer :: nullElement + + nullElement => null() +#endif + call check_xf(xf) + + if (.not.checkChars(declaration,xf%xds%xml_version)) call wxml_error("xml_AddElementToDTD: Invalid character in declaration") + + if (xf%namespace) then + if (.not.checkQName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Element Name in DTD "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Element Name in DTD "//name) + endif +#ifdef PGF90 + call parse_dtd_element(declaration, xf%xds%xml_version, stack, nullElement, .true.) +#else + call parse_dtd_element(declaration, xf%xds%xml_version, stack, null(), .true.) +#endif + if (in_error(stack)) call wxml_error(xf, "Invalid ELEMENT declaration") + + if (xf%state_3 == WXML_STATE_3_DURING_DTD) then + call add_to_buffer(" [", xf%buffer, .false.) + xf%state_3 = WXML_STATE_3_INSIDE_INTSUBSET + endif + + if (xf%state_3 /= WXML_STATE_3_INSIDE_INTSUBSET) & + call wxml_fatal("Cannot write to DTD here: xml_AddElementToDTD") + + if (xf%state_2 == WXML_STATE_2_INSIDE_PI) then + call close_start_tag(xf) + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG + endif + + call add_eol(xf) + call add_to_buffer("", xf%buffer, .false.) +#endif + end subroutine xml_AddElementToDTD + + + subroutine xml_AddAttlistToDTD(xf, name, declaration) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in) :: declaration + +#ifndef DUMMYLIB + type(error_stack) :: stack +#ifdef PGF90 + type (element_t), pointer :: nullElement + + nullElement => null() +#endif + call check_xf(xf) + + if (.not.checkChars(declaration,xf%xds%xml_version)) call wxml_error("xml_AddAttListToDTD: Invalid character in declaration") + + if (xf%namespace) then + if (.not.checkQName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Attribute Name in DTD "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Attribute Name in DTD "//name) + endif + +#ifdef PGF90 + call parse_dtd_attlist(declaration, xf%xds%xml_version, & + validCheck=.false., namespaces=xf%namespace, stack=stack, & + elem=nullElement, internal=.true.) +#else + call parse_dtd_attlist(declaration, xf%xds%xml_version, & + validCheck=.false., namespaces=xf%namespace, stack=stack, & + elem=null(), internal=.true.) +#endif + + if (in_error(stack)) call wxml_error(xf, "Invalid ATTLIST declaration") + + if (xf%state_3 == WXML_STATE_3_DURING_DTD) then + call add_to_buffer(" [", xf%buffer, .false.) + xf%state_3 = WXML_STATE_3_INSIDE_INTSUBSET + endif + + if (xf%state_3 /= WXML_STATE_3_INSIDE_INTSUBSET) & + call wxml_fatal("Cannot write to DTD here: xml_AddAttlistToDTD") + + if (xf%state_2 == WXML_STATE_2_INSIDE_PI) then + call close_start_tag(xf) + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG + endif + + call add_eol(xf) + call add_to_buffer("", xf%buffer, .false.) +#endif + end subroutine xml_AddAttlistToDTD + + + subroutine xml_AddPEReferenceToDTD(xf, name) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + +#ifndef DUMMYLIB + call check_xf(xf) + + if (xf%namespace) then + if (.not.checkNCName(name, xf%xds%xml_version)) & + call wxml_error("Invalid PE Name in DTD "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid PE Name in DTD "//name) + endif + + call wxml_warning(xf, "Adding PEReference to DTD. Cannot guarantee well-formedness") + if (.not.existing_entity(xf%xds%PEList, name)) then + if (.not.xf%xds%standalone) then + call wxml_warning(xf, "Tried to reference possibly unregistered parameter entity in DTD: "//name) + else + call wxml_error("Tried to reference unregistered parameter entity in DTD "//name) + endif + else + if (is_unparsed_entity(xf%xds%PEList, name)) & + call wxml_error("Tried to reference unparsed parameter entity in DTD "//name) + endif + + if (xf%state_3 == WXML_STATE_3_DURING_DTD) then + call add_to_buffer(" [", xf%buffer, .false.) + xf%state_3 = WXML_STATE_3_INSIDE_INTSUBSET + endif + + if (xf%state_3 /= WXML_STATE_3_INSIDE_INTSUBSET) & + call wxml_fatal("Cannot write to DTD here: xml_AddPEReferenceToDTD") + + if (xf%state_2 == WXML_STATE_2_INSIDE_PI) then + call close_start_tag(xf) + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG + endif + + call add_eol(xf) + call add_to_buffer("%"//name//";", xf%buffer, .false.) + +#endif + end subroutine xml_AddPEReferenceToDTD + + + subroutine xml_AddXMLStylesheet(xf, href, type, title, media, charset, alternate) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: href + character(len=*), intent(in) :: type + character(len=*), intent(in), optional :: title + character(len=*), intent(in), optional :: media + character(len=*), intent(in), optional :: charset + logical, intent(in), optional :: alternate + +#ifndef DUMMYLIB + call check_xf(xf) + ! Don't bother checking name - all pseudoatts get checked anyway. + + if (xf%state_1 /= WXML_STATE_1_JUST_OPENED & + .and. xf%state_1 /= WXML_STATE_1_BEFORE_ROOT) & + call wxml_error("Cannot add stylesheet here: "//href) + + call close_start_tag(xf) + + call xml_AddXMLPI(xf, 'xml-stylesheet', xml=.true.) + call xml_AddPseudoAttribute(xf, 'href', href) + call xml_AddPseudoAttribute(xf, 'type', type) + + if (present(title)) call xml_AddPseudoAttribute(xf, 'title', title) + if (present(media)) call xml_AddPseudoAttribute(xf, 'media', media) + if (present(charset)) call xml_AddPseudoAttribute(xf, 'charset', charset) + if (present(alternate)) then + if (alternate) then + call xml_AddPseudoAttribute(xf, 'alternate', 'yes') + else + call xml_AddPseudoAttribute(xf, 'alternate', 'no') + endif + endif + if (xf%state_1 == WXML_STATE_1_JUST_OPENED) & + xf%state_1 = WXML_STATE_1_BEFORE_ROOT + xf%state_2 = WXML_STATE_2_INSIDE_PI +#endif + end subroutine xml_AddXMLStylesheet + + + subroutine xml_AddXMLPI(xf, name, data, xml, ws_significant) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in), optional :: data + logical, intent(in), optional :: xml + logical, intent(in), optional :: ws_significant + + logical :: xml_ +#ifndef DUMMYLIB + call check_xf(xf) + + if (present(xml)) then + xml_ = xml + else + xml_ = .false. + endif + + if (xf%namespace) then + if (.not.checkNCName(name, xf%xds%xml_version)) & + call wxml_error("Invalid PI target "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid PI target "//name) + endif + if (.not.xml_) then + if (len(name)==3.and.(toLower(name)=="xml")) & + call wxml_error("Invalid PI target "//name) + endif + + if (present(data)) then + if (.not.checkChars(data,xf%xds%xml_version)) & + call wxml_error("xml_AddXMLPI: Invalid character in data") + endif + + select case (xf%state_1) + case (WXML_STATE_1_JUST_OPENED) + xf%state_1 = WXML_STATE_1_BEFORE_ROOT + case (WXML_STATE_1_DURING_ROOT) + call close_start_tag(xf) + if (xf%pretty_print) call add_eol(xf) + case default + call close_start_tag(xf) + call add_eol(xf) + end select + call add_to_buffer("0) then + if (index(data, '?>') > 0) & + call wxml_error(xf, "Tried to output invalid PI data "//data) + call add_to_buffer(' ', xf%buffer, .false.) + call add_to_buffer(data//'?>', xf%buffer, ws_significant) + ! state_2 is now OUTSIDE_TAG from close_start_tag + else + xf%state_2 = WXML_STATE_2_INSIDE_PI + call reset_dict(xf%dict) + endif + else + xf%state_2 = WXML_STATE_2_INSIDE_PI + call reset_dict(xf%dict) + endif +#endif + end subroutine xml_AddXMLPI + + + subroutine xml_AddComment(xf, comment, ws_significant) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: comment + logical, intent(in), optional :: ws_significant + +#ifndef DUMMYLIB + call check_xf(xf) + if (.not.checkChars(comment,xf%xds%xml_version)) call wxml_error("xml_AddComment: Invalid character in comment") + + select case (xf%state_1) + case (WXML_STATE_1_JUST_OPENED) + xf%state_1 = WXML_STATE_1_BEFORE_ROOT + case (WXML_STATE_1_DURING_ROOT) + call close_start_tag(xf) + if (xf%pretty_print.and.xf%state_2 == WXML_STATE_2_OUTSIDE_TAG) call add_eol(xf) + case default + call close_start_tag(xf) + call add_eol(xf) + end select + + if (index(comment,'--') > 0 .or. comment(len(comment):) == '-') & + call wxml_error("Tried to output invalid comment "//comment) + + call add_to_buffer("", xf%buffer, .false.) +#endif + end subroutine xml_AddComment + + + subroutine xml_NewElement(xf, name) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + +#ifndef DUMMYLIB + call check_xf(xf) + + if (xf%namespace) then + if (.not.checkQName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Element Name "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Element Name "//name) + endif + + select case (xf%state_1) + case (WXML_STATE_1_JUST_OPENED, WXML_STATE_1_BEFORE_ROOT) + if (xf%xds%valid) then + if (size(xf%name)==0) then + call wxml_error(xf, "No DTD specified for document") + elseif (str_vs(xf%name) /= name) then + call wxml_error(xf, "Root element name does not match DTD") + endif + endif + call close_start_tag(xf) + if (xf%state_3 /= WXML_STATE_3_BEFORE_DTD) then + select case (xf%state_3) + case (WXML_STATE_3_DURING_DTD) + call add_to_buffer('>', xf%buffer, .false.) + xf%state_3 = WXML_STATE_3_AFTER_DTD + case (WXML_STATE_3_INSIDE_INTSUBSET) + xf%state_3 = WXML_STATE_3_AFTER_DTD + call add_eol(xf) + call add_to_buffer(']>', xf%buffer, .false.) + end select + endif + call add_eol(xf) + case (WXML_STATE_1_DURING_ROOT) + call close_start_tag(xf) + if (xf%pretty_print) call add_eol(xf) + case (WXML_STATE_1_AFTER_ROOT) + call wxml_error(xf, "Two root elements: "//name) + end select + + if (xf%namespace) then + if (len(prefixOfQName(name)) > 0) then + if (.not.isPrefixInForce(xf%nsDict, prefixOfQName(name))) & + call wxml_error(xf, "Namespace prefix not registered: "//prefixOfQName(name)) + endif + endif + + call push_elstack(xf%stack, name) + call add_to_buffer("<"//name, xf%buffer, .false.) + xf%state_2 = WXML_STATE_2_INSIDE_ELEMENT + call reset_dict(xf%dict) + xf%indent = xf%indent + indent_inc + xf%state_1 = WXML_STATE_1_DURING_ROOT +#endif + end subroutine xml_NewElement + + + subroutine xml_AddCharacters_ch(xf, chars, parsed, ws_significant) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: chars + logical, intent(in), optional :: parsed + logical, intent(in), optional :: ws_significant + +#ifndef DUMMYLIB + logical :: pc + + call check_xf(xf) + if (.not.checkChars(chars, xf%xds%xml_version)) call wxml_error("xml_AddCharacters: Invalid character in chars") + + if (xf%state_1 /= WXML_STATE_1_DURING_ROOT) & + call wxml_fatal("Tried to add text section in wrong place: "//chars) + + if (present(parsed)) then + pc = parsed + else + pc = .true. + endif + + call close_start_tag(xf) + + if (pc) then + call add_to_buffer(escape_string(chars, xf%xds%xml_version), xf%buffer, ws_significant) + else + ! FIXME what if we try and output two separate character events? + ! need to keep track of this ... + if (index(chars,']]>') > 0) & + call wxml_fatal("Tried to output invalid CDATA: "//chars) + call add_to_buffer("", xf%buffer, ws_significant) + endif + + xf%state_2 = WXML_STATE_2_IN_CHARDATA +#endif + end subroutine xml_AddCharacters_Ch + + + subroutine xml_AddNewline(xf) + type(xmlf_t), intent(inout) :: xf + +#ifndef DUMMYLIB + call xml_AddCharacters(xf, "") ! To ensure we are in a text section + call add_eol(xf) +#endif + end subroutine xml_AddNewline + + + subroutine xml_AddEntityReference(xf, name) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + +#ifndef DUMMYLIB + call check_xf(xf) + + if (likeCharacterEntityReference(name)) then + if (.not.checkCharacterEntityReference(name, xf%xds%xml_version)) & + call wxml_error("Invalid Character Entity Reference "//name) + elseif (xf%namespace) then + if (.not.checkNCName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Entity Name "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Entity Name "//name) + endif + + call close_start_tag(xf) + + if (xf%state_2 /= WXML_STATE_2_OUTSIDE_TAG .and. & + xf%state_2 /= WXML_STATE_2_IN_CHARDATA) & + call wxml_fatal("Tried to add entity reference in wrong place: "//name) + + if (.not.checkCharacterEntityReference(name, xf%xds%xml_version)) then + !it's not just a unicode entity + call wxml_warning(xf, "Entity reference added - document may not be well-formed") + if (.not.existing_entity(xf%xds%entityList, name)) then + if (xf%xds%standalone) then + call wxml_error("Tried to reference unregistered entity") + else + call wxml_warning(xf, "Tried to reference unregistered entity") + endif + else + if (is_unparsed_entity(xf%xds%entityList, name)) & + call wxml_error("Tried to reference unparsed entity") + endif + endif + + call add_to_buffer('&'//name//';', xf%buffer, .false.) + xf%state_2 = WXML_STATE_2_IN_CHARDATA +#endif + end subroutine xml_AddEntityReference + + + subroutine xml_AddAttribute_Ch(xf, name, value, escape, type, ws_significant) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in) :: value + logical, intent(in), optional :: escape + character(len=*), intent(in), optional :: type + logical, intent(in), optional :: ws_significant + +#ifndef DUMMYLIB + logical :: esc + character, pointer :: type_(:) + + if (present(type)) then + if (type/='CDATA'.and.type/='ID'.and.type/='IDREF'.and.type/='IDREFS'.and.type/='NMTOKEN'.and.type/='NMTOKENS' & + .and.type/='ENTITY'.and.type/='ENTITIES'.and.type/='NOTATION') then + call wxml_fatal("Invalid type in xml_AddAttribute: "//type) + endif + type_ => vs_str_alloc(type) + else + ! We assume CDATA, but need to worry about whether the caller cares about whitespace ... + if (present(ws_significant)) then + if (ws_significant) then + type_ => vs_str_alloc('CDATA') + else + type_ => vs_str_alloc('CDANO') ! CDAta, whitespace Not significant + endif + else + type_ => vs_str_alloc('CDAMB') ! CDAta, whitespace MayBe significant + endif + endif + + call check_xf(xf) + + if (.not.checkChars(value, xf%xds%xml_version)) call wxml_error("xml_AddAttribute: Invalid character in value") + + if (xf%namespace) then + if (.not.checkQName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Attribute Name "//name) + else + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid Attribute Name "//name) + endif + + if (present(escape)) then + esc = escape + else + esc = .true. + endif + + if (name=="xml:space") then + ! The value can only be "default" or "preserve", by 2.10 + if (.not.esc) then + if (value/="default".and.value/="preserve") & + call wxml_fatal("Invalid value for xml:space attrbute") + endif + endif + + ! FIXME when escape is false we should still do full verification + ! where possible. + ! Currently - minimal check: only extra allowed is character entity references. + ! We check they exist, and are not unparsed. + ! Ideally we would fully expand all entity references (at least for + ! a standalone document where we can) and then + ! match the resultant production against [XML]-3.3.1. This is + ! initially too much work though, so we just check simple + ! syntactic constraint. + + if (.not.esc) then + if (.not.checkAttValue(value, xf%xds%xml_version)) & + call wxml_error(xf, "Invalid attribute value: "//value) + if (index(value, '&') > 0) then + ! There are entity references + ! They should exist (unless we are not standalone) and they must not be unparsed. + if (.not.checkExistingRefsInAttValue()) then + if (xf%xds%standalone) then + call wxml_error(xf, "outputting unknown entity. Cannot guarantee validity.") + else + call wxml_warning(xf, "Warning: outputting unknown entity. Cannot guarantee validity.") + endif + endif + if (.not.checkParsedRefsInAttValue()) & + call wxml_error(xf, "Warning: outputting unknown entity. Cannot guarantee validity.") + endif + endif + + if (xf%state_2 /= WXML_STATE_2_INSIDE_ELEMENT) & + call wxml_error(xf, "attributes outside element content: "//name) + + if (hasKey(xf%dict,name)) then + call wxml_error(xf, "duplicate att name: "//name) + elseif (xf%namespace) then + if (hasKey(xf%dict, & + getnamespaceURI(xf%nsDict,prefixOfQname(name)), localpartofQname(name))) then + call wxml_error(xf, "duplicate att after namespace processing: "//name) + endif + endif + + if (xf%namespace) then + if (len(prefixOfQName(name))>0) then + if (prefixOfQName(name)/="xml".and.prefixOfQName(name)/="xmlns") then + if (.not.isPrefixInForce(xf%nsDict, prefixOfQName(name))) & + call wxml_error(xf, "namespace prefix not registered: "//prefixOfQName(name)) + endif + if (esc) then + call add_item_to_dict(xf%dict, localpartofQname(name), escape_string(value, xf%xds%xml_version), prefixOfQName(name), & + getnamespaceURI(xf%nsDict,prefixOfQname(name)), type=str_vs(type_)) + else + call add_item_to_dict(xf%dict, localpartofQname(name), value, prefixOfQName(name), & + getnamespaceURI(xf%nsDict,prefixOfQName(name)), type=str_vs(type_)) + endif + else + if (esc) then + call add_item_to_dict(xf%dict, name, escape_string(value, xf%xds%xml_version), type=str_vs(type_)) + else + call add_item_to_dict(xf%dict, name, value, type=str_vs(type_)) + endif + endif + else + if (esc) then + call add_item_to_dict(xf%dict, name, escape_string(value, xf%xds%xml_version), type=str_vs(type_)) + else + call add_item_to_dict(xf%dict, name, value, type=str_vs(type_)) + endif + endif + + !FIXME need to deallocate this when we move to better error handling + deallocate(type_) + + contains + function checkExistingRefsInAttValue() result(p) + logical :: p + + integer :: i1, i2 + + ! Here we assume we have syntactic well-formedness as + ! checked by checkAttValue. + ! We also assume we do not have simply one entity as + ! the contents - that is checked by checkAttValueEntity + + p = .false. + i1 = index(value, '&') + i2 = 0 + do while (i1 > 0) + i1 = i2 + i1 + i2 = index(value(i1+1:),';') + if (i2 == 0) return + i2 = i1 + i2 + if (.not.existing_entity(xf%xds%entityList, value(i1+1:i2-1)) .and. & + .not.checkCharacterEntityReference(value(i1+1:i2-1), xf%xds%xml_version)) & + return + i1 = index(value(i2+1:), '&') + enddo + p = .true. + + end function checkExistingRefsInAttValue + + function checkParsedRefsInAttValue() result(p) + logical :: p + + integer :: i1, i2 + + ! Here we assume we have syntactic well-formedness as + ! checked by checkAttValue. + + p = .false. + i1 = index(value, '&') + i2 = 0 + do while (i1 > 0) + i1 = i1 + i2 + i2 = index(value(i1+1:),';') + if (i2 == 0) return + i2 = i1 + i2 + if (is_unparsed_entity(xf%xds%entityList, value(i1+1:i2-1))) & + return + i1 = index(value(i2+1:), '&') + enddo + p = .true. + + end function checkParsedRefsInAttValue +#endif + end subroutine xml_AddAttribute_Ch + + + subroutine xml_AddPseudoAttribute_Ch(xf, name, value, escape, ws_significant) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in) :: value + logical, intent(in), optional :: escape + logical, intent(in), optional :: ws_significant + +#ifndef DUMMYLIB + logical :: esc + character(len=5) :: type + + call check_xf(xf) + if (.not.checkChars(name, xf%xds%xml_version)) call wxml_error("xml_AddPseudoAttribute: Invalid character in name") + if (.not.checkChars(value, xf%xds%xml_version)) call wxml_error("xml_AddPseudoAttribute: Invalid character in value") + + if (present(escape)) then + esc = escape + else + esc = .true. + endif + if (present(ws_significant)) then + if (ws_significant) then + type='CDATA' + else + type='CDANO' ! CDAta, whitespace Not significant + endif + else + type='CDAMB' ! CDAta, whitespace MayBe significant + endif + + if (index(value, '?>') > 0) & + call wxml_error(xf, "Invalid pseudo-attribute value: "//value) + if (.not.esc) then + if (.not.checkPseudoAttValue(value, xf%xds%xml_version)) & + call wxml_error(xf, "Invalid pseudo-attribute value: "//value) + endif + + if (xf%state_2 /= WXML_STATE_2_INSIDE_PI) & + call wxml_error("PI pseudo-attribute outside PI: "//name) + + ! This is mostly ad-hoc, pseudo-attribute names are not defined anywhere. + if (.not.checkName(name, xf%xds%xml_version)) & + call wxml_error("Invalid pseudo-attribute name: "//name) + + if (hasKey(xf%dict,name)) & + call wxml_error(xf, "duplicate pseudo-attribute name: "//name) + + if (index(value, '?>') > 0) & + call wxml_error(xf, "Invalid pseudo-attribute data: "//value) + + if (esc) then + call add_item_to_dict(xf%dict, name, escape_string(value, xf%xds%xml_version), type=type) + else + call add_item_to_dict(xf%dict, name, value, type=type) + endif +#endif + end subroutine xml_AddPseudoAttribute_Ch + + + subroutine xml_EndElement(xf, name) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + + character :: dummy +#ifndef DUMMYLIB + call check_xf(xf) + ! No point in doing checkChars, name is compared to stack anyway. + + if (len(xf%stack) == 0) & + call wxml_fatal(xf,'Trying to close '//name//' but no tags are open.') + + if (get_top_elstack(xf%stack) /= name) & + call wxml_fatal(xf, 'Trying to close '//name//' but '//get_top_elstack(xf%stack)// & + ' is open. Either you have failed to open '//name//& + ' or you have failed to close '//get_top_elstack(xf%stack)//'.') + xf%indent = xf%indent - indent_inc + + if (xf%state_2==WXML_STATE_2_INSIDE_ELEMENT) then + if (xf%namespace) call checkNamespacesWriting(xf%dict, xf%nsDict, len(xf%stack)) + if (getLength(xf%dict) > 0) call write_attributes(xf) + if (xf%minimize_overrun) call add_eol(xf) + endif + if (xf%state_2==WXML_STATE_2_INSIDE_ELEMENT.and..not.xf%canonical) then + call add_to_buffer("/>", xf%buffer, .false.) + else + if (xf%state_2==WXML_STATE_2_INSIDE_ELEMENT) & + call add_to_buffer('>', xf%buffer, .false.) + if (xf%state_2==WXML_STATE_2_INSIDE_PI) & + call close_start_tag(xf) + if (xf%state_2==WXML_STATE_2_OUTSIDE_TAG.and.xf%pretty_print) & + call add_eol(xf) +! XLF does a weird thing here, and if pop_elstack is called as an +! argument to the add_to_buffer, it gets called twice. So we have to separate +! out get_top_... from pop_... + call add_to_buffer("", xf%buffer, .false.) + endif + dummy = pop_elstack(xf%stack) + + if (xf%namespace) call checkEndNamespaces(xf%nsDict, len(xf%stack)+1) + if (is_empty(xf%stack)) then + xf%state_1 = WXML_STATE_1_AFTER_ROOT + endif + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG +#endif + end subroutine xml_EndElement + + + subroutine xml_DeclareNamespace(xf, nsURI, prefix, xml) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: nsURI + character(len=*), intent(in), optional :: prefix + logical, intent(in), optional :: xml + +#ifndef DUMMYLIB + call check_xf(xf) + if (.not.xf%namespace) call wxml_error("Cannot declare a namespace in a non-namespaced document") + + !if (.not.checkNCName(nsURI, xf%xds%xml_version)) call wxml_error("xml_DeclareNamespace: Invalid nsURI") + if (present(prefix)) then + if (.not.checkNCName(prefix, xf%xds%xml_version)) call wxml_error("xml_DeclareNamespace: Invalid prefix") + endif + + if (xf%state_1 == WXML_STATE_1_AFTER_ROOT) & + call wxml_error(xf, "adding namespace outside element content") + + if (len(nsURI) == 0) then + if (present(prefix).and.xf%xds%xml_version==XML1_0) & + call wxml_error(xf, "prefixed namespace with empty URI forbidden in XML 1.0") + endif + + if (present(prefix)) then + call addPrefixedNS(xf%nsDict, prefix, nsURI, len(xf%stack)+1, xf%xds, xml) + else + call addDefaultNS(xf%nsDict, nsURI, len(xf%stack)+1) + endif +#endif + end subroutine xml_DeclareNamespace + + + subroutine xml_UndeclareNamespace(xf, prefix) + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in), optional :: prefix + +#ifndef DUMMYLIB + call check_xf(xf) + !No need to checkChars, prefix is checked against stack + if (.not.xf%namespace) call wxml_error("Cannot declare a namespace in a non-namespaced document") + + if (present(prefix).and.xf%xds%xml_version==XML1_0) & + call wxml_error("cannot undeclare prefixed namespaces in XML 1.0") + + if (xf%state_1 == WXML_STATE_1_AFTER_ROOT) & + call wxml_error(xf, "Undeclaring namespace outside element content") + + if (present(prefix)) then + call addPrefixedNS(xf%nsDict, prefix, "", len(xf%stack)+1, xf%xds) + else + call addDefaultNS(xf%nsDict, "", len(xf%stack)+1) + endif +#endif + end subroutine xml_UndeclareNamespace + + + subroutine xml_Close(xf, empty) + type(xmlf_t), intent(inout) :: xf + logical, optional :: empty + +#ifndef DUMMYLIB + logical :: empty_ + + if (present(empty)) then + empty_ = empty + else + empty_ = .false. + endif + + if (xf%lun == -1) & + call wxml_fatal('Tried to close XML file which is not open') + + if (xf%state_2 == WXML_STATE_2_INSIDE_PI) & + call close_start_tag(xf) + + if (xf%state_3 /= WXML_STATE_3_BEFORE_DTD & + .and. xf%state_3 /= WXML_STATE_3_AFTER_DTD) then + select case (xf%state_3) + case (WXML_STATE_3_DURING_DTD) + call add_to_buffer('>', xf%buffer, .false.) + case (WXML_STATE_3_INSIDE_INTSUBSET) + call add_eol(xf) + call add_to_buffer(']>', xf%buffer, .false.) + end select + xf%state_3 = WXML_STATE_3_AFTER_DTD + endif + + do while (xf%state_1 == WXML_STATE_1_DURING_ROOT) + call xml_EndElement(xf, get_top_elstack(xf%stack)) + enddo + + if (xf%state_1 /= WXML_STATE_1_AFTER_ROOT) then + if (empty_) then + call wxml_warning(xf, 'Invalid XML document produced: No root element') + else + call wxml_error(xf, 'Invalid XML document produced: No root element') + endif + endif + + call dump_buffer(xf%buffer) + close(unit=xf%lun) + xf%lun = -1 + + call destroy_dict(xf%dict) + call destroy_elstack(xf%stack) + + if (xf%namespace) & + call destroyNamespaceDictionary(xf%nsDict) + call destroy_xml_doc_state(xf%xds) + + deallocate(xf%name) +#endif + end subroutine xml_Close + + subroutine xmlf_SetPretty_print(xf, new_value) + type(xmlf_t), intent(inout) :: xf + logical, intent(in) :: new_value +#ifndef DUMMYLIB + xf%pretty_print = new_value +#endif + end subroutine xmlf_SetPretty_print + + pure function xmlf_GetPretty_print(xf) result(value) + logical :: value + type(xmlf_t), intent(in) :: xf +#ifdef DUMMYLIB + value = .false. +#else + value = xf%pretty_print +#endif + end function xmlf_GetPretty_print + +! xf%extended data is an integer so that writers +! can change there behaviour depending on some +! stored information. Currently only used for +! wcml 'validate' argument (which is intended to +! check some of the more troublesome aspects of +! the CML schema + subroutine xmlf_SetExtendedData(xf, new_value) + type(xmlf_t), intent(inout) :: xf + integer, intent(in) :: new_value +#ifndef DUMMYLIB + xf%extended_data = new_value +#endif + end subroutine xmlf_SetExtendedData + + pure function xmlf_GetExtendedData(xf) result(value) + integer :: value + type(xmlf_t), intent(in) :: xf +#ifdef DUMMYLIB + value = .false. +#else + value = xf%extended_data +#endif + end function xmlf_GetExtendedData + + pure function xmlf_name(xf) result(fn) + type (xmlf_t), intent(in) :: xf +#ifdef DUMMYLIB + character(len=1) :: fn + fn = " " +#else + character(len=size(xf%xds%documentURI)) :: fn + fn = str_vs(xf%xds%documentURI) +#endif + end function xmlf_name + +#ifndef DUMMYLIB + pure function xmlf_opentag_len(xf) result(n) + type (xmlf_t), intent(in) :: xf + integer :: n + + if (xf%lun == -1) then + n = 0 + elseif (is_empty(xf%stack)) then + n = 0 + else + n = len(get_top_elstack(xf%stack)) + endif + end function xmlf_opentag_len +#endif + + function xmlf_opentag(xf) result(fn) + type (xmlf_t), intent(in) :: xf +#ifdef DUMMYLIB + character(len=1) :: fn + fn = " " +#else + character(len=xmlf_opentag_len(xf)) :: fn + + if (xf%lun == -1) then + fn = '' + elseif (is_empty(xf%stack)) then + fn = '' + else + fn = get_top_elstack(xf%stack) + endif +#endif + end function xmlf_opentag + +#ifndef DUMMYLIB + + subroutine check_xf(xf) + type(xmlf_t), intent(inout) :: xf + if (xf%lun == -1) & + call wxml_fatal("Tried to manipulate an XML File which is not open") + + end subroutine check_xf + + + subroutine add_eol(xf) + type(xmlf_t), intent(inout) :: xf + + integer :: indent_level + + ! In case we still have a zero-length stack, we must make + ! sure indent_level is not less than zero. + if (xf%state_3 == WXML_STATE_3_INSIDE_INTSUBSET) then + indent_level = indent_inc + else + indent_level = xf%indent + endif + + !We must flush here (rather than just adding an eol character) + !since we don't know what the eol character is on this system. + !Flushing with a linefeed will get it automatically, though. + call dump_buffer(xf%buffer, lf=.true.) + call reset_buffer(xf%buffer, xf%lun, xf%xds%xml_version) + + if (xf%pretty_print) & + call add_to_buffer(repeat(' ',indent_level),xf%buffer, .false.) + + end subroutine add_eol + + + subroutine close_start_tag(xf) + type(xmlf_t), intent(inout) :: xf + + select case (xf%state_2) + case (WXML_STATE_2_INSIDE_ELEMENT) + if (xf%namespace) call checkNamespacesWriting(xf%dict, xf%nsDict, len(xf%stack)) + if (getLength(xf%dict) > 0) call write_attributes(xf) + if (xf%minimize_overrun) call add_eol(xf) + call add_to_buffer('>', xf%buffer, .false.) + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG + case (WXML_STATE_2_INSIDE_PI) + if (getLength(xf%dict) > 0) call write_attributes(xf) + call add_to_buffer('?>', xf%buffer, .false.) + if (xf%pretty_print.and.xf%state_3/=WXML_STATE_3_INSIDE_INTSUBSET) call add_eol(xf) + xf%state_2 = WXML_STATE_2_OUTSIDE_TAG + case (WXML_STATE_2_IN_CHARDATA) + continue + case (WXML_STATE_2_OUTSIDE_TAG) + continue + end select + + end subroutine close_start_tag + + + subroutine write_attributes(xf) + type(xmlf_t), intent(inout) :: xf + + integer :: i, j, size + + if (xf%state_2 /= WXML_STATE_2_INSIDE_PI .and. & + xf%state_2 /= WXML_STATE_2_INSIDE_ELEMENT) & + call wxml_fatal("Internal library error") + + if (xf%canonical) call sortAttrs(xf%dict) + + do i = 1, getLength(xf%dict) + size = len(get_key(xf%dict, i)) + len(get_value(xf%dict, i)) + 4 + if (xf%minimize_overrun.and.(len(xf%buffer) + size) > COLUMNS) then + call add_eol(xf) + else + call add_to_buffer(" ", xf%buffer, .false.) + endif + call add_to_buffer(get_key(xf%dict, i), xf%buffer, .false.) + call add_to_buffer("=", xf%buffer, .false.) + call add_to_buffer('"',xf%buffer, .false.) + j = getWhiteSpaceHandling(xf%dict, i) + if (j==0) then + call add_to_buffer(get_value(xf%dict, i), xf%buffer, .true.) + elseif (j==1) then + call add_to_buffer(get_value(xf%dict, i), xf%buffer) + else + call add_to_buffer(get_value(xf%dict, i), xf%buffer, .false.) + endif + call add_to_buffer('"', xf%buffer, .false.) + enddo + + end subroutine write_attributes + + subroutine wxml_warning_xf(xf, msg) + ! Emit warning, but carry on. + type(xmlf_t), intent(in) :: xf + character(len=*), intent(in) :: msg + + if (FoX_get_fatal_warnings()) then + write(6,'(a)') 'FoX warning made fatal' + call wxml_fatal_xf(xf, msg) + endif + + if (xf%xds%warning) then + write(6,'(a)') 'WARNING(wxml) in writing to file ', xmlf_name(xf) + write(6,'(a)') msg + endif + + end subroutine wxml_warning_xf + + + subroutine wxml_error_xf(xf, msg) + ! Emit error message, clean up file and stop. + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: msg + + if (FoX_get_fatal_errors()) then + write(6,'(a)') 'FoX error made fatal' + call wxml_fatal_xf(xf, msg) + endif + + write(6,'(a)') 'ERROR(wxml) in writing to file ', xmlf_name(xf) + write(6,'(a)') msg + + !call xml_Close(xf) + stop + + end subroutine wxml_error_xf + + + subroutine wxml_fatal_xf(xf, msg) + !Emit error message and abort with coredump. Does not try to + !close file, so should be used from anything xml_Close might + !itself call (to avoid infinite recursion!) + + type(xmlf_t), intent(in) :: xf + character(len=*), intent(in) :: msg + + write(6,'(a)') 'ERROR(wxml) in writing to file ', xmlf_name(xf) + write(6,'(a)') msg + + call pxfabort() + stop + + end subroutine wxml_fatal_xf + +#endif + +end module m_wxml_core diff --git a/src/xml/wxml/m_wxml_escape.F90 b/src/xml/wxml/m_wxml_escape.F90 new file mode 100644 index 000000000..99bfcdab0 --- /dev/null +++ b/src/xml/wxml/m_wxml_escape.F90 @@ -0,0 +1,140 @@ +module m_wxml_escape + +#ifndef DUMMYLIB + !Ensure all characters are safe to go out into XML file. + + use fox_m_fsys_format, only: str + use m_common_charset, only: XML1_0 + use m_common_error, only: FoX_error, FoX_warning + + implicit none + private + + integer, parameter :: AMP = iachar('&') + integer, parameter :: LT = iachar('<') + integer, parameter :: GT = iachar('>') + integer, parameter :: QUOT = iachar('"') + integer, parameter :: APOS = iachar("'") + + public :: escape_string + public :: escape_string_len + +contains + + pure function escape_string_len(s) result(c) + character(len=*), intent(in) :: s + integer :: c + + integer :: i + c = len(s) + do i = 1, len(s) + select case(iachar(s(i:i))) + case (AMP) + c = c + 4 + case (LT) + c = c + 3 + case (GT) + c = c + 3 + case (QUOT) + c = c + 5 + case (APOS) + c = c + 5 + case (1:8) + c = c + 3 + case (11:12) + c = c + 4 + case (14:31) + c = c + 4 + case (127:) + c = c + 5 + ! a char can never contain more than 8 bits = 256 characters, so + ! we never need more than 3 chars to represent the int. + end select + enddo + + end function escape_string_len + + + function escape_string(s, version) result (s2) + character(len=*), intent(in) :: s + integer, intent(in) :: version + character(len=escape_string_len(s)) :: s2 + + integer :: c, i, ic + + ! We have to do it this way (with achar etc) in case the native + ! platform encoding is not ASCII + + c = 1 + do i = 1, len(s) + ic = iachar(s(i:i)) + select case (ic) + case (0) + call FoX_error("Tried to output a NUL character") + case (1:8) + if (version==XML1_0) then + call FoX_error("Tried to output a character invalid under XML 1.0") + else + s2(c:c+3) = "&#"//str(ic)//";" + c = c + 4 + endif + case(9:10) + s2(c:c) = achar(ic) + c = c + 1 + case(11:12) + if (version==XML1_0) then + call FoX_error("Tried to output a character invalid under XML 1.0") + else + s2(c:c+5) = "&#"//str(ic)//";" + c = c + 5 + endif + case(13) + s2(c:c) = achar(13) + c = c + 1 + case (14:31) + if (version==XML1_0) then + call FoX_error("Tried to output a character invalid under XML 1.0") + else + s2(c:c+5) = "&#"//str(ic)//";" + c = c + 5 + endif + case (32:126) + select case (iachar(s(i:i))) + case (AMP) + s2(c:c+4) = "&" + c = c + 5 + case (LT) + s2(c:c+3) = "<" + c = c + 4 + case (GT) + s2(c:c+3) = ">" + c = c + 4 + case (QUOT) + s2(c:c+5) = """ + c = c + 6 + case (APOS) + s2(c:c+5) = "'" + c = c + 6 + case default + s2(c:c) = achar(ic) + c = c + 1 + end select + case (127) + s2(c:c+5) = "" + c = c + 6 + case default + !TOHW we should maybe just disallow this ... + call FoX_warning("emitting non-ASCII character. Platform-dependent result!") + s2(c:c+6) = "&#"//str(ic)//";" + c = c + 6 + ! a char can never contain more than 8 bits = 256 characters, so + ! we never need more than 3 chars to represent the int. + ! We have to encode it though, because UTF-8 x7F-x9F must be + ! encoded, and if they are in the native charset they'll be > 128 + end select + enddo + + end function escape_string + +#endif +end module m_wxml_escape diff --git a/src/xml/wxml/m_wxml_overloads.F90 b/src/xml/wxml/m_wxml_overloads.F90 new file mode 100644 index 000000000..5f6281dcb --- /dev/null +++ b/src/xml/wxml/m_wxml_overloads.F90 @@ -0,0 +1,1028 @@ +! This file is AUTOGENERATED!!!! +! Do not edit this file; edit m_wxml_overloads.m4 and regenerate. +! +! +module m_wxml_overloads + +#ifndef DUMMYLIB + use fox_m_fsys_format, only: str +#endif + use fox_m_fsys_realtypes, only: sp, dp + use m_wxml_core, only: xmlf_t + use m_wxml_core, only: xml_AddCharacters + use m_wxml_core, only: xml_AddAttribute + use m_wxml_core, only: xml_AddPseudoAttribute + + implicit none + private + + interface xml_AddCharacters + module procedure CharactersScalarCmplxDp + module procedure CharactersScalarCmplxSp + module procedure CharactersScalarRealDp + module procedure CharactersScalarRealSp + module procedure CharactersScalarInt + module procedure CharactersScalarLg + + module procedure CharactersArrayCmplxDp + module procedure CharactersArrayCmplxSp + module procedure CharactersArrayRealDp + module procedure CharactersArrayRealSp + module procedure CharactersArrayInt + module procedure CharactersArrayLg + module procedure CharactersArrayCh + module procedure CharactersMatrixCmplxDp + module procedure CharactersMatrixCmplxSp + module procedure CharactersMatrixRealDp + module procedure CharactersMatrixRealSp + module procedure CharactersMatrixInt + module procedure CharactersMatrixLg + module procedure CharactersMatrixCh + end interface + + interface xml_AddAttribute + module procedure AttributeScalarCmplxDp + module procedure AttributeScalarCmplxSp + module procedure AttributeScalarRealDp + module procedure AttributeScalarRealSp + module procedure AttributeScalarInt + module procedure AttributeScalarLg + + module procedure AttributeArrayCmplxDp + module procedure AttributeArrayCmplxSp + module procedure AttributeArrayRealDp + module procedure AttributeArrayRealSp + module procedure AttributeArrayInt + module procedure AttributeArrayLg + module procedure AttributeArrayCh + module procedure AttributeMatrixCmplxDp + module procedure AttributeMatrixCmplxSp + module procedure AttributeMatrixRealDp + module procedure AttributeMatrixRealSp + module procedure AttributeMatrixInt + module procedure AttributeMatrixLg + module procedure AttributeMatrixCh + end interface + + interface xml_AddPseudoAttribute + module procedure PseudoAttributeScalarCmplxDp + module procedure PseudoAttributeScalarCmplxSp + module procedure PseudoAttributeScalarRealDp + module procedure PseudoAttributeScalarRealSp + module procedure PseudoAttributeScalarInt + module procedure PseudoAttributeScalarLg + + module procedure PseudoAttributeArrayCmplxDp + module procedure PseudoAttributeArrayCmplxSp + module procedure PseudoAttributeArrayRealDp + module procedure PseudoAttributeArrayRealSp + module procedure PseudoAttributeArrayInt + module procedure PseudoAttributeArrayLg + module procedure PseudoAttributeArrayCh + module procedure PseudoAttributeMatrixCmplxDp + module procedure PseudoAttributeMatrixCmplxSp + module procedure PseudoAttributeMatrixRealDp + module procedure PseudoAttributeMatrixRealSp + module procedure PseudoAttributeMatrixInt + module procedure PseudoAttributeMatrixLg + module procedure PseudoAttributeMatrixCh + end interface + + public :: xml_AddCharacters + public :: xml_AddAttribute + public :: xml_AddPseudoAttribute + +contains + + subroutine CharactersScalarCmplxDp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + complex(dp), intent(in) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt)) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddCharacters(xf=xf, chars=str(chars, "")) + endif +#endif + end subroutine CharactersScalarCmplxDp + + + subroutine CharactersScalarCmplxSp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + complex(sp), intent(in) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt)) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddCharacters(xf=xf, chars=str(chars, "")) + endif +#endif + end subroutine CharactersScalarCmplxSp + + + subroutine CharactersScalarRealDp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + real(dp), intent(in) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt)) + else + call xml_AddCharacters(xf=xf, chars=str(chars)) + endif +#endif + end subroutine CharactersScalarRealDp + + + subroutine CharactersScalarRealSp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + real(sp), intent(in) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt)) + else + call xml_AddCharacters(xf=xf, chars=str(chars)) + endif +#endif + end subroutine CharactersScalarRealSp + + + subroutine CharactersScalarInt & + (xf, chars) + + type(xmlf_t), intent(inout) :: xf + integer, intent(in) :: chars + +#ifndef DUMMYLIB + call xml_AddCharacters(xf=xf, chars=str(chars)) +#endif + end subroutine CharactersScalarInt + + + subroutine CharactersScalarLg & + (xf, chars) + + type(xmlf_t), intent(inout) :: xf + logical, intent(in) :: chars + +#ifndef DUMMYLIB + call xml_AddCharacters(xf=xf, chars=str(chars)) +#endif + end subroutine CharactersScalarLg + + + + + subroutine CharactersArrayCmplxDp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + complex(dp), intent(in) , dimension(:) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddCharacters(xf=xf, chars=str(chars, ""), ws_significant=.false.) + endif +#endif + end subroutine CharactersArrayCmplxDp + + + subroutine CharactersArrayCmplxSp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + complex(sp), intent(in) , dimension(:) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddCharacters(xf=xf, chars=str(chars, ""), ws_significant=.false.) + endif +#endif + end subroutine CharactersArrayCmplxSp + + + subroutine CharactersArrayRealDp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + real(dp), intent(in) , dimension(:) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt), ws_significant=.false.) + else + call xml_AddCharacters(xf=xf, chars=str(chars), ws_significant=.false.) + endif +#endif + end subroutine CharactersArrayRealDp + + + subroutine CharactersArrayRealSp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + real(sp), intent(in) , dimension(:) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt), ws_significant=.false.) + else + call xml_AddCharacters(xf=xf, chars=str(chars), ws_significant=.false.) + endif +#endif + end subroutine CharactersArrayRealSp + + + subroutine CharactersArrayInt & + (xf, chars) + + type(xmlf_t), intent(inout) :: xf + integer, intent(in) , dimension(:) :: chars + +#ifndef DUMMYLIB + call xml_AddCharacters(xf=xf, chars=str(chars), ws_significant=.false.) +#endif + end subroutine CharactersArrayInt + + + subroutine CharactersArrayLg & + (xf, chars) + + type(xmlf_t), intent(inout) :: xf + logical, intent(in) , dimension(:) :: chars + +#ifndef DUMMYLIB + call xml_AddCharacters(xf=xf, chars=str(chars), ws_significant=.false.) +#endif + end subroutine CharactersArrayLg + + + subroutine CharactersArrayCh & + (xf, chars, delimiter) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) , dimension(:) :: chars + character(len=1), intent(in), optional :: delimiter + +#ifndef DUMMYLIB + call xml_AddCharacters(xf=xf, chars=str(chars, delimiter), ws_significant=.false.) +#endif + end subroutine CharactersArrayCh + + + subroutine CharactersMatrixCmplxDp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + complex(dp), intent(in) , dimension(:,:) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddCharacters(xf=xf, chars=str(chars, ""), ws_significant=.false.) + endif +#endif + end subroutine CharactersMatrixCmplxDp + + + subroutine CharactersMatrixCmplxSp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + complex(sp), intent(in) , dimension(:,:) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddCharacters(xf=xf, chars=str(chars, ""), ws_significant=.false.) + endif +#endif + end subroutine CharactersMatrixCmplxSp + + + subroutine CharactersMatrixRealDp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + real(dp), intent(in) , dimension(:,:) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt), ws_significant=.false.) + else + call xml_AddCharacters(xf=xf, chars=str(chars), ws_significant=.false.) + endif +#endif + end subroutine CharactersMatrixRealDp + + + subroutine CharactersMatrixRealSp & + (xf, chars, fmt) + + type(xmlf_t), intent(inout) :: xf + real(sp), intent(in) , dimension(:,:) :: chars + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddCharacters(xf=xf, chars=str(chars, fmt), ws_significant=.false.) + else + call xml_AddCharacters(xf=xf, chars=str(chars), ws_significant=.false.) + endif +#endif + end subroutine CharactersMatrixRealSp + + + subroutine CharactersMatrixInt & + (xf, chars) + + type(xmlf_t), intent(inout) :: xf + integer, intent(in) , dimension(:,:) :: chars + +#ifndef DUMMYLIB + call xml_AddCharacters(xf=xf, chars=str(chars), ws_significant=.false.) +#endif + end subroutine CharactersMatrixInt + + + subroutine CharactersMatrixLg & + (xf, chars) + + type(xmlf_t), intent(inout) :: xf + logical, intent(in) , dimension(:,:) :: chars + +#ifndef DUMMYLIB + call xml_AddCharacters(xf=xf, chars=str(chars), ws_significant=.false.) +#endif + end subroutine CharactersMatrixLg + + + subroutine CharactersMatrixCh & + (xf, chars, delimiter) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) , dimension(:,:) :: chars + character(len=1), intent(in), optional :: delimiter + +#ifndef DUMMYLIB + call xml_AddCharacters(xf=xf, chars=str(chars, delimiter), ws_significant=.false.) +#endif + end subroutine CharactersMatrixCh + + + + subroutine AttributeScalarCmplxDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(dp), intent(in) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt)) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddAttribute(xf=xf, name=name, value=str(value, "")) + endif +#endif + end subroutine AttributeScalarCmplxDp + + subroutine AttributeScalarCmplxSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(sp), intent(in) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt)) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddAttribute(xf=xf, name=name, value=str(value, "")) + endif +#endif + end subroutine AttributeScalarCmplxSp + + subroutine AttributeScalarRealDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(dp), intent(in) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt)) + else + call xml_AddAttribute(xf=xf, name=name, value=str(value)) + endif +#endif + end subroutine AttributeScalarRealDp + + subroutine AttributeScalarRealSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(sp), intent(in) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt)) + else + call xml_AddAttribute(xf=xf, name=name, value=str(value)) + endif +#endif + end subroutine AttributeScalarRealSp + + subroutine AttributeScalarInt & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + integer, intent(in) :: value + +#ifndef DUMMYLIB + call xml_AddAttribute(xf=xf, name=name, value=str(value)) +#endif + end subroutine AttributeScalarInt + + subroutine AttributeScalarLg & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + logical, intent(in) :: value + +#ifndef DUMMYLIB + call xml_AddAttribute(xf=xf, name=name, value=str(value)) +#endif + end subroutine AttributeScalarLg + + + subroutine AttributeArrayCmplxDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(dp), intent(in) , dimension(:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddAttribute(xf=xf, name=name, value=str(value, ""), ws_significant=.false.) + endif +#endif + end subroutine AttributeArrayCmplxDp + + subroutine AttributeArrayCmplxSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(sp), intent(in) , dimension(:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddAttribute(xf=xf, name=name, value=str(value, ""), ws_significant=.false.) + endif +#endif + end subroutine AttributeArrayCmplxSp + + subroutine AttributeArrayRealDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(dp), intent(in) , dimension(:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + call xml_AddAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) + endif +#endif + end subroutine AttributeArrayRealDp + + subroutine AttributeArrayRealSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(sp), intent(in) , dimension(:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + call xml_AddAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) + endif +#endif + end subroutine AttributeArrayRealSp + + subroutine AttributeArrayInt & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + integer, intent(in) , dimension(:) :: value + +#ifndef DUMMYLIB + call xml_AddAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) +#endif + end subroutine AttributeArrayInt + + subroutine AttributeArrayLg & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + logical, intent(in) , dimension(:) :: value + +#ifndef DUMMYLIB + call xml_AddAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) +#endif + end subroutine AttributeArrayLg + + subroutine AttributeArrayCh & + (xf, name, value, delimiter) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in) , dimension(:) :: value + character(len=1), intent(in), optional :: delimiter + +#ifndef DUMMYLIB + call xml_AddAttribute(xf=xf, name=name, value=str(value, delimiter), ws_significant=.false.) +#endif + end subroutine AttributeArrayCh + + subroutine AttributeMatrixCmplxDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(dp), intent(in) , dimension(:,:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddAttribute(xf=xf, name=name, value=str(value, ""), ws_significant=.false.) + endif +#endif + end subroutine AttributeMatrixCmplxDp + + subroutine AttributeMatrixCmplxSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(sp), intent(in) , dimension(:,:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddAttribute(xf=xf, name=name, value=str(value, ""), ws_significant=.false.) + endif +#endif + end subroutine AttributeMatrixCmplxSp + + subroutine AttributeMatrixRealDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(dp), intent(in) , dimension(:,:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + call xml_AddAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) + endif +#endif + end subroutine AttributeMatrixRealDp + + subroutine AttributeMatrixRealSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(sp), intent(in) , dimension(:,:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + call xml_AddAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) + endif +#endif + end subroutine AttributeMatrixRealSp + + subroutine AttributeMatrixInt & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + integer, intent(in) , dimension(:,:) :: value + +#ifndef DUMMYLIB + call xml_AddAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) +#endif + end subroutine AttributeMatrixInt + + subroutine AttributeMatrixLg & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + logical, intent(in) , dimension(:,:) :: value + +#ifndef DUMMYLIB + call xml_AddAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) +#endif + end subroutine AttributeMatrixLg + + subroutine AttributeMatrixCh & + (xf, name, value, delimiter) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in) , dimension(:,:) :: value + character(len=1), intent(in), optional :: delimiter + +#ifndef DUMMYLIB + call xml_AddAttribute(xf=xf, name=name, value=str(value, delimiter), ws_significant=.false.) +#endif + end subroutine AttributeMatrixCh + + + subroutine PseudoAttributeScalarCmplxDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(dp), intent(in) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt)) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, "")) + endif +#endif + end subroutine PseudoAttributeScalarCmplxDp + + subroutine PseudoAttributeScalarCmplxSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(sp), intent(in) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt)) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, "")) + endif +#endif + end subroutine PseudoAttributeScalarCmplxSp + + subroutine PseudoAttributeScalarRealDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(dp), intent(in) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt)) + else + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value)) + endif +#endif + end subroutine PseudoAttributeScalarRealDp + + subroutine PseudoAttributeScalarRealSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(sp), intent(in) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt)) + else + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value)) + endif +#endif + end subroutine PseudoAttributeScalarRealSp + + subroutine PseudoAttributeScalarInt & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + integer, intent(in) :: value + +#ifndef DUMMYLIB + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value)) +#endif + end subroutine PseudoAttributeScalarInt + + subroutine PseudoAttributeScalarLg & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + logical, intent(in) :: value + +#ifndef DUMMYLIB + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value)) +#endif + end subroutine PseudoAttributeScalarLg + + + subroutine PseudoAttributeArrayCmplxDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(dp), intent(in) , dimension(:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, ""), ws_significant=.false.) + endif +#endif + end subroutine PseudoAttributeArrayCmplxDp + + subroutine PseudoAttributeArrayCmplxSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(sp), intent(in) , dimension(:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, ""), ws_significant=.false.) + endif +#endif + end subroutine PseudoAttributeArrayCmplxSp + + subroutine PseudoAttributeArrayRealDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(dp), intent(in) , dimension(:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) + endif +#endif + end subroutine PseudoAttributeArrayRealDp + + subroutine PseudoAttributeArrayRealSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(sp), intent(in) , dimension(:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) + endif +#endif + end subroutine PseudoAttributeArrayRealSp + + subroutine PseudoAttributeArrayInt & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + integer, intent(in) , dimension(:) :: value + +#ifndef DUMMYLIB + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) +#endif + end subroutine PseudoAttributeArrayInt + + subroutine PseudoAttributeArrayLg & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + logical, intent(in) , dimension(:) :: value + +#ifndef DUMMYLIB + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) +#endif + end subroutine PseudoAttributeArrayLg + + subroutine PseudoAttributeArrayCh & + (xf, name, value, delimiter) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in) , dimension(:) :: value + character(len=1), intent(in), optional :: delimiter + +#ifndef DUMMYLIB + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, delimiter), ws_significant=.false.) +#endif + end subroutine PseudoAttributeArrayCh + + subroutine PseudoAttributeMatrixCmplxDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(dp), intent(in) , dimension(:,:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, ""), ws_significant=.false.) + endif +#endif + end subroutine PseudoAttributeMatrixCmplxDp + + subroutine PseudoAttributeMatrixCmplxSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + complex(sp), intent(in) , dimension(:,:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + ! Add empty optional fmt arg to str to avoid PGI bug: + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, ""), ws_significant=.false.) + endif +#endif + end subroutine PseudoAttributeMatrixCmplxSp + + subroutine PseudoAttributeMatrixRealDp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(dp), intent(in) , dimension(:,:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) + endif +#endif + end subroutine PseudoAttributeMatrixRealDp + + subroutine PseudoAttributeMatrixRealSp & + (xf, name, value, fmt) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + real(sp), intent(in) , dimension(:,:) :: value + character(len=*), intent(in), optional :: fmt + +#ifndef DUMMYLIB + if (present(fmt)) then + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, fmt), ws_significant=.false.) + else + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) + endif +#endif + end subroutine PseudoAttributeMatrixRealSp + + subroutine PseudoAttributeMatrixInt & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + integer, intent(in) , dimension(:,:) :: value + +#ifndef DUMMYLIB + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) +#endif + end subroutine PseudoAttributeMatrixInt + + subroutine PseudoAttributeMatrixLg & + (xf, name, value) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + logical, intent(in) , dimension(:,:) :: value + +#ifndef DUMMYLIB + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value), ws_significant=.false.) +#endif + end subroutine PseudoAttributeMatrixLg + + subroutine PseudoAttributeMatrixCh & + (xf, name, value, delimiter) + + type(xmlf_t), intent(inout) :: xf + character(len=*), intent(in) :: name + character(len=*), intent(in) , dimension(:,:) :: value + character(len=1), intent(in), optional :: delimiter + +#ifndef DUMMYLIB + call xml_AddPseudoAttribute(xf=xf, name=name, value=str(value, delimiter), ws_significant=.false.) +#endif + end subroutine PseudoAttributeMatrixCh + + +end module m_wxml_overloads diff --git a/src/xml_interface.F90 b/src/xml_interface.F90 new file mode 100644 index 000000000..870b4288b --- /dev/null +++ b/src/xml_interface.F90 @@ -0,0 +1,542 @@ +module xml_interface + + use constants, only: MAX_LINE_LEN + use error, only: fatal_error + use global, only: message + use fox_dom + + implicit none + private + public :: Node + public :: NodeList + public :: open_xmldoc + public :: close_xmldoc + public :: check_for_node + public :: get_node_ptr + public :: get_node_list + public :: get_list_size + public :: get_list_item + public :: get_node_value + public :: get_node_array + public :: get_arraysize_integer + public :: get_arraysize_double + public :: get_arraysize_string + + integer, parameter :: ATTR_NODE = 0 + integer, parameter :: ELEM_NODE = 1 + + interface get_node_value + module procedure get_node_value_integer + module procedure get_node_value_long + module procedure get_node_value_double + module procedure get_node_value_string + end interface get_node_value + + interface get_node_array + module procedure get_node_array_integer + module procedure get_node_array_double + module procedure get_node_array_string + end interface get_node_array + +contains + +!=============================================================================== +! OPEN_XMLDOC opens and parses an XML and returns a pointer to the document +!=============================================================================== + + subroutine open_xmldoc(ptr, filename) + + character(len=*) :: filename + type(Node), pointer :: ptr + + ptr => parseFile(trim(filename)) ! Pointer to the whole XML document + ptr => getDocumentElement(ptr) ! Grabs root element of XML document + + end subroutine open_xmldoc + +!=============================================================================== +! CLOSE_XMLDOC closes and destroys all memory associated with document +!=============================================================================== + + subroutine close_xmldoc(ptr) + + type(Node), pointer :: ptr + + ptr => getParentNode(ptr) ! Go from root element ptr to document ptr + call destroy(ptr) ! Deallocates all nodes recursively + + end subroutine close_xmldoc + +!=============================================================================== +! CHECK_FOR_NODE checks for an attribute or sub-element node with the given +! node name. This should only be used for checking a single occurance of a +! sub-element node. To check for sub-element nodes that repeat, use +! get_node_list and get_list_size. This is to minimize number of calls +! to getChildrenByTagName. +!=============================================================================== + + function check_for_node(ptr, node_name) result(found) + + character(len=*), intent(in) :: node_name + logical :: found + type(Node), pointer, intent(in) :: ptr + + type(Node), pointer :: temp_ptr + type(NodeList), pointer :: elem_list + + ! Default that we found it and attribute + found = .true. + + ! Get the attribute node + temp_ptr => getAttributeNode(ptr, trim(node_name)) + + ! Check if node exists + if (associated(temp_ptr)) return + + ! Check for a sub-element + elem_list => getChildrenByTagName(ptr, trim(node_name)) + + ! Get the length of the list + if (getLength(elem_list) == 0) then + found = .false. + return + end if + + end function check_for_node + +!=============================================================================== +! GET_NODE_PTR returns a Node pointer to an attribute or sub-element node. +! Note, this should only be used for sub-element nodes that occur only once. +! For repeated nodes, use get_node_list and then get_item_item. +!=============================================================================== + + subroutine get_node_ptr(in_ptr, node_name, out_ptr, found) + + character(len=*), intent(in) :: node_name + logical, intent(out), optional :: found + type(Node), pointer, intent(in) :: in_ptr + type(Node), pointer, intent(out) :: out_ptr + + logical :: found_ + type(NodeList), pointer :: elem_list => null() + + ! Set found to false + found_ = .false. + + ! Check for a sub-element + elem_list => getChildrenByTagName(in_ptr, trim(node_name)) + + ! Get the length of the list + if (getLength(elem_list) == 0) return + + ! Point to the new element + out_ptr => item(elem_list, 0) + found_ = .true. + + ! Check to output found + if (present(found)) found = found_ + + end subroutine get_node_ptr + +!=============================================================================== +! GET_NODE_LIST is used to get a pointer to a list of sub-element nodes +!=============================================================================== + + subroutine get_node_list(in_ptr, node_name, out_ptr) + + character(len=*), intent(in) :: node_name + type(Node), pointer, intent(in) :: in_ptr + type(NodeList), pointer, intent(out) :: out_ptr + + ! Check for a sub-element + out_ptr => getChildrenByTagName(in_ptr, trim(node_name)) + + end subroutine get_node_list + +!=============================================================================== +! GET_LIST_SIZE is used to get the number of elements from a node list +!=============================================================================== + + function get_list_size(in_ptr) result(n_size) + + integer :: n_size + type(NodeList), pointer, intent(in) :: in_ptr + + ! Get the size of the list + n_size = getLength(in_ptr) + + end function get_list_size + +!=============================================================================== +! GET_LIST_ITEM is used to select a specific item from a node list +!=============================================================================== + + subroutine get_list_item(in_ptr, idx, out_ptr) + + integer, intent(in) :: idx + type(NodeList), pointer, intent(in) :: in_ptr + type(Node), pointer, intent(out) :: out_ptr + + ! Check for a sub-element + out_ptr => item(in_ptr, idx - 1) + + end subroutine get_list_item + +!=============================================================================== +! GET_NODE_VALUE_INTEGER returns a integer value from an attribute or node +!=============================================================================== + + subroutine get_node_value_integer(ptr, node_name, result_int) + + character(len=*), intent(in) :: node_name + integer :: result_int + type(Node), pointer, intent(in) :: ptr + + integer :: node_type + logical :: found + type(Node), pointer :: temp_ptr + + ! Get pointer to the node + call get_node(ptr, node_name, temp_ptr, node_type, found) + + ! Leave if it was not found + if (.not. found) then + message = "Node " // node_name // " not part of Node " // & + getNodeName(ptr) // "." + call fatal_error() + end if + + ! Extract value + if (node_type == ATTR_NODE) then + call extractDataAttribute(ptr, node_name, result_int) + else + call extractDataContent(temp_ptr, result_int) + end if + + end subroutine get_node_value_integer + +!=============================================================================== +! GET_NODE_VALUE_LONG returns an 8-byte integer from attribute or node +!=============================================================================== + + subroutine get_node_value_long(ptr, node_name, result_long) + + character(len=*), intent(in) :: node_name + integer(8) :: result_long + type(Node), pointer, intent(in) :: ptr + + integer :: node_type + logical :: found + type(Node), pointer :: temp_ptr + + ! Get pointer to the node + call get_node(ptr, node_name, temp_ptr, node_type, found) + + ! Leave if it was not found + if (.not. found) then + message = "Node " // node_name // " not part of Node " // & + getNodeName(ptr) // "." + call fatal_error() + end if + + ! Extract value + if (node_type == ATTR_NODE) then + call extractDataAttribute(ptr, node_name, result_long) + else + call extractDataContent(temp_ptr, result_long) + end if + + end subroutine get_node_value_long + +!=============================================================================== +! GET_NODE_VALUE_DOUBLE returns a double precision real from attr. or node +!=============================================================================== + + subroutine get_node_value_double(ptr, node_name, result_double) + + character(len=*), intent(in) :: node_name + real(8) :: result_double + type(Node), pointer, intent(in) :: ptr + + integer :: node_type + logical :: found + type(Node), pointer :: temp_ptr + + ! Get pointer to the node + call get_node(ptr, node_name, temp_ptr, node_type, found) + + ! Leave if it was not found + if (.not. found) then + message = "Node " // node_name // " not part of Node " // & + getNodeName(ptr) // "." + call fatal_error() + end if + + ! Extract value + if (node_type == ATTR_NODE) then + call extractDataAttribute(ptr, node_name, result_double) + else + call extractDataContent(temp_ptr, result_double) + end if + + end subroutine get_node_value_double + +!=============================================================================== +! GET_NODE_ARRAY_INTEGER returns a 1-D array of integers +!=============================================================================== + + subroutine get_node_array_integer(ptr, node_name, result_int) + + character(len=*), intent(in) :: node_name + integer :: result_int(:) + type(Node), pointer, intent(in) :: ptr + + integer :: node_type + logical :: found + type(Node), pointer :: temp_ptr + + ! Get pointer to the node + call get_node(ptr, node_name, temp_ptr, node_type, found) + + ! Leave if it was not found + if (.not. found) then + message = "Node " // node_name // " not part of Node " // & + getNodeName(ptr) // "." + call fatal_error() + end if + + ! Extract value + if (node_type == ATTR_NODE) then + call extractDataAttribute(ptr, node_name, result_int) + else + call extractDataContent(temp_ptr, result_int) + end if + + end subroutine get_node_array_integer + +!=============================================================================== +! GET_NODE_ARRAY_DOUBLE returns a 1-D array of double precision reals +!=============================================================================== + + subroutine get_node_array_double(ptr, node_name, result_double) + + character(len=*), intent(in) :: node_name + real(8) :: result_double(:) + type(Node), pointer, intent(in) :: ptr + + integer :: node_type + logical :: found + type(Node), pointer :: temp_ptr + + ! Get pointer to the node + call get_node(ptr, node_name, temp_ptr, node_type, found) + + ! Leave if it was not found + if (.not. found) then + message = "Node " // node_name // " not part of Node " // & + getNodeName(ptr) // "." + call fatal_error() + end if + + ! Extract value + if (node_type == ATTR_NODE) then + call extractDataAttribute(ptr, node_name, result_double) + else + call extractDataContent(temp_ptr, result_double) + end if + + end subroutine get_node_array_double + +!=============================================================================== +! GET_NODE_ARRAY_STRING returns a 1-D array of strings +!=============================================================================== + + subroutine get_node_array_string(ptr, node_name, result_string) + + character(len=*), intent(in) :: node_name + character(len=*) :: result_string(:) + type(Node), pointer, intent(in) :: ptr + + integer :: node_type + logical :: found + type(Node), pointer :: temp_ptr + + ! Get pointer to the node + call get_node(ptr, node_name, temp_ptr, node_type, found) + + ! Leave if it was not found + if (.not. found) then + message = "Node " // node_name // " not part of Node " // & + getNodeName(ptr) // "." + call fatal_error() + end if + + ! Extract value + if (node_type == ATTR_NODE) then + call extractDataAttribute(ptr, node_name, result_string) + else + call extractDataContent(temp_ptr, result_string) + end if + + end subroutine get_node_array_string + +!=============================================================================== +! GET_NODE_VALUE_STRING returns a single string from attr. or node +!=============================================================================== + + subroutine get_node_value_string(ptr, node_name, result_str) + + character(len=*), intent(in) :: node_name + character(len=*) :: result_str + type(Node), pointer, intent(in) :: ptr + + integer :: node_type + logical :: found + type(Node), pointer :: temp_ptr + + ! Get pointer to the node + call get_node(ptr, node_name, temp_ptr, node_type, found) + + ! Leave if it was not found + if (.not. found) then + message = "Node " // node_name // " not part of Node " // & + getNodeName(ptr) // "." + call fatal_error() + end if + + ! Extract value + if (node_type == ATTR_NODE) then + call extractDataAttribute(ptr, node_name, result_str) + else + call extractDataContent(temp_ptr, result_str) + end if + + end subroutine get_node_value_string + +!=============================================================================== +! GET_NODE_ARRAYSIZE_INTEGER returns the size of the integer array +!=============================================================================== + + function get_arraysize_integer(ptr, node_name) result(n) + + character(len=*), intent(in) :: node_name + integer :: n + type(Node), pointer, intent(in) :: ptr + + integer :: node_type + logical :: found + type(Node), pointer :: temp_ptr + + ! Get pointer to the node + call get_node(ptr, node_name, temp_ptr, node_type, found) + + ! Leave if it was not found + if (.not. found) then + message = "Node " // node_name // " not part of Node " // & + getNodeName(ptr) // "." + call fatal_error() + end if + + ! Get the size + n = countrts(getTextContent(temp_ptr), 0) + + end function get_arraysize_integer + +!=============================================================================== +! GET_NODE_ARRAYSIZE_DOUBLE returns the size of double prec. real array +!=============================================================================== + + function get_arraysize_double(ptr, node_name) result(n) + + character(len=*), intent(in) :: node_name + integer :: n + type(Node), pointer, intent(in) :: ptr + + integer :: node_type + logical :: found + type(Node), pointer :: temp_ptr + + ! Get pointer to the node + call get_node(ptr, node_name, temp_ptr, node_type, found) + + ! Leave if it was not found + if (.not. found) then + message = "Node " // node_name // " not part of Node " // & + getNodeName(ptr) // "." + call fatal_error() + end if + + ! Get the size + n = countrts(getTextContent(temp_ptr), 0.0_8) + + end function get_arraysize_double + +!=============================================================================== +! GET_NODE_ARRAYSIZE_STRING returns the size of string array +!=============================================================================== + + function get_arraysize_string(ptr, node_name) result(n) + + character(len=*), intent(in) :: node_name + integer :: n + type(Node), pointer, intent(in) :: ptr + + integer :: node_type + logical :: found + type(Node), pointer :: temp_ptr + + ! Get pointer to the node + call get_node(ptr, node_name, temp_ptr, node_type, found) + + ! Leave if it was not found + if (.not. found) then + message = "Node " // node_name // " not part of Node " // & + getNodeName(ptr) // "." + call fatal_error() + end if + + ! Get the size + n = countrts(getTextContent(temp_ptr), 'a') + + end function get_arraysize_string + +!=============================================================================== +! GET_NODE private routine that gets a pointer to a specific node +!=============================================================================== + + subroutine get_node(in_ptr, node_name, out_ptr, node_type, found) + + character(len=*), intent(in) :: node_name + integer, intent(out) :: node_type + logical, intent(out) :: found + type(Node), pointer, intent(in) :: in_ptr + type(Node), pointer, intent(out) :: out_ptr + + type(NodeList), pointer :: elem_list + + ! Default that we found it and attribute + found = .true. + node_type = ATTR_NODE + + ! Get the attribute node + out_ptr => getAttributeNode(in_ptr, trim(node_name)) + + ! Check if node exists + if (associated(out_ptr)) return + + ! Check for a sub-element + elem_list => getChildrenByTagName(in_ptr, trim(node_name)) + + ! Get the length of the list + if (getLength(elem_list) == 0) then + found = .false. + return + end if + + ! Point to the new element + node_type = ELEM_NODE + out_ptr => item(elem_list, 0) + + end subroutine get_node + +end module xml_interface diff --git a/tests/cleanup b/tests/cleanup new file mode 100755 index 000000000..288c81025 --- /dev/null +++ b/tests/cleanup @@ -0,0 +1,10 @@ +#!/bin/bash + +# This simple script ensures that all binary +# output files have been deleted in all the +# folders. This can occur if a previous error +# occurred and the test suite was rerun without +# deleting left over binary files. This will +# cause an assertion error in some of the +# tests. +find . \( -name "*.binary" -o -name "*.h5" \) -exec rm -f {} \; diff --git a/tests/run_tests.py b/tests/run_tests.py index 49975c218..0669a99d0 100755 --- a/tests/run_tests.py +++ b/tests/run_tests.py @@ -117,6 +117,8 @@ if len(sys.argv) > 1: if j.rfind(suffix) != -1: if suffix == 'omp' and j == 'compile': continue + if j == 'compile': + continue tests__.append(j) else: tests__.append(i) # append specific test (e.g., mpi-debug) diff --git a/tests/test_natural_element/results_true.dat b/tests/test_natural_element/results_true.dat index 335f10c5a..9b2e933ab 100644 --- a/tests/test_natural_element/results_true.dat +++ b/tests/test_natural_element/results_true.dat @@ -1,2 +1,2 @@ k-combined: -1.012443E+00 2.162448E-02 +1.010190E+00 1.740589E-02 diff --git a/tests/test_output/settings.xml b/tests/test_output/settings.xml index 70116af72..fef5e2fcf 100644 --- a/tests/test_output/settings.xml +++ b/tests/test_output/settings.xml @@ -1,7 +1,7 @@ - summary cross_sections + 10 diff --git a/tests/test_salphabeta_multiple/geometry.xml b/tests/test_salphabeta_multiple/geometry.xml index 2d427d8cb..63f69f743 100644 --- a/tests/test_salphabeta_multiple/geometry.xml +++ b/tests/test_salphabeta_multiple/geometry.xml @@ -44,9 +44,11 @@ - + - + + + diff --git a/tests/test_salphabeta_multiple/materials.xml b/tests/test_salphabeta_multiple/materials.xml index 97ff56c05..6e975bde9 100644 --- a/tests/test_salphabeta_multiple/materials.xml +++ b/tests/test_salphabeta_multiple/materials.xml @@ -1,7 +1,8 @@ - + 70c @@ -111,4 +112,19 @@
+ + + + + + + + + + + + + + + diff --git a/tests/test_salphabeta_multiple/results_true.dat b/tests/test_salphabeta_multiple/results_true.dat index f26a309aa..3165faa41 100644 --- a/tests/test_salphabeta_multiple/results_true.dat +++ b/tests/test_salphabeta_multiple/results_true.dat @@ -1,2 +1,2 @@ k-combined: -1.013747E+00 3.067630E-02 +9.701793E-01 8.482149E-03 diff --git a/tests/test_source_file/geometry.xml b/tests/test_source_file/geometry.xml new file mode 100644 index 000000000..612e46132 --- /dev/null +++ b/tests/test_source_file/geometry.xml @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/tests/test_source_file/materials.xml b/tests/test_source_file/materials.xml new file mode 100644 index 000000000..1f85510e0 --- /dev/null +++ b/tests/test_source_file/materials.xml @@ -0,0 +1,9 @@ + + + + + + + + + diff --git a/tests/test_source_file/results.py b/tests/test_source_file/results.py new file mode 100644 index 000000000..8ff10971c --- /dev/null +++ b/tests/test_source_file/results.py @@ -0,0 +1,25 @@ +#!/usr/bin/env python + +import sys + +# import statepoint +sys.path.append('../../src/utils') +import statepoint + +# read in statepoint file +if len(sys.argv) > 1: + sp = statepoint.StatePoint(sys.argv[1]) +else: + sp = statepoint.StatePoint('statepoint.10.binary') +sp.read_results() + +# set up output string +outstr = '' + +# write out k-combined +outstr += 'k-combined:\n' +outstr += "{0:12.6E} {1:12.6E}\n".format(sp.k_combined[0], sp.k_combined[1]) + +# write results to file +with open('results_test.dat','w') as fh: + fh.write(outstr) diff --git a/tests/test_source_file/results_true.dat b/tests/test_source_file/results_true.dat new file mode 100644 index 000000000..ae37050f7 --- /dev/null +++ b/tests/test_source_file/results_true.dat @@ -0,0 +1,2 @@ +k-combined: +2.977307E-01 2.848670E-03 diff --git a/tests/test_source_file/settings.xml b/tests/test_source_file/settings.xml new file mode 100644 index 000000000..17d4ee2e2 --- /dev/null +++ b/tests/test_source_file/settings.xml @@ -0,0 +1,19 @@ + + + + + + + + 10 + 5 + 1000 + + + + + -4 -4 -4 4 4 4 + + + + diff --git a/tests/test_source_file/test_source_file.py b/tests/test_source_file/test_source_file.py new file mode 100644 index 000000000..85a33c031 --- /dev/null +++ b/tests/test_source_file/test_source_file.py @@ -0,0 +1,101 @@ +#!/usr/bin/env python + +import os +from subprocess import Popen, STDOUT, PIPE, call +import filecmp +from nose_mpi import NoseMPI +import glob + +pwd = os.path.dirname(__file__) + +settings1=""" + + + + + + + 10 + 5 + 1000 + + + + + -4 -4 -4 4 4 4 + + + + +""" + +settings2 = """ + + + + 10 + 5 + 1000 + + + + source.10.{0} + + + +""" + +def setup(): + os.putenv('PWD', pwd) + os.chdir(pwd) + +def test_run1(): + openmc_path = pwd + '/../../src/openmc' + if int(NoseMPI.mpi_np) > 0: + proc = Popen([NoseMPI.mpi_exec, '-np', NoseMPI.mpi_np, openmc_path], + stderr=STDOUT, stdout=PIPE) + else: + proc = Popen([openmc_path], stderr=STDOUT, stdout=PIPE) + print(proc.communicate()[0]) + returncode = proc.returncode + assert returncode == 0 + +def test_statepoint_exists(): + statepoint = glob.glob(pwd + '/statepoint.10.*') + assert len(statepoint) == 1 + assert statepoint[0].endswith('binary') or statepoint[0].endswith('h5') + source = glob.glob(pwd + '/source.10.*') + assert len(statepoint) == 1 + assert source[0].endswith('binary') or source[0].endswith('h5') + +def test_run2(): + openmc_path = pwd + '/../../src/openmc' + source = glob.glob(pwd + '/source.10.*') + with open('settings.xml','w') as fh: + fh.write(settings2.format(source[0].split('.')[2])) + if int(NoseMPI.mpi_np) > 0: + proc = Popen([NoseMPI.mpi_exec, '-np', NoseMPI.mpi_np, openmc_path], + stderr=STDOUT, stdout=PIPE) + else: + proc = Popen([openmc_path], stderr=STDOUT, stdout=PIPE) + print(proc.communicate()[0]) + returncode = proc.returncode + assert returncode == 0 + +def test_results(): + statepoint = glob.glob(pwd + '/statepoint.10.*') + call(['python', 'results.py', statepoint[0]]) + compare = filecmp.cmp('results_test.dat', 'results_true.dat') + if not compare: + os.rename('results_test.dat', 'results_error.dat') + assert compare + +def teardown(): + with open('settings.xml','w') as fh: + fh.write(settings1) + output = glob.glob(pwd + '/statepoint.10.*') + output += glob.glob(pwd + '/source.10.*') + output.append(pwd + '/results_test.dat') + for f in output: + if os.path.exists(f): + os.remove(f) diff --git a/tests/test_sourcepoint_batch/geometry.xml b/tests/test_sourcepoint_batch/geometry.xml new file mode 100644 index 000000000..612e46132 --- /dev/null +++ b/tests/test_sourcepoint_batch/geometry.xml @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/tests/test_sourcepoint_batch/materials.xml b/tests/test_sourcepoint_batch/materials.xml new file mode 100644 index 000000000..1f85510e0 --- /dev/null +++ b/tests/test_sourcepoint_batch/materials.xml @@ -0,0 +1,9 @@ + + + + + + + + + diff --git a/tests/test_sourcepoint_batch/results.py b/tests/test_sourcepoint_batch/results.py new file mode 100644 index 000000000..9b0f577eb --- /dev/null +++ b/tests/test_sourcepoint_batch/results.py @@ -0,0 +1,32 @@ +#!/usr/bin/env python + +import sys + +# import statepoint +sys.path.append('../../src/utils') +import statepoint + +# read in statepoint file +if len(sys.argv) > 1: + sp = statepoint.StatePoint(sys.argv[1]) +else: + sp = statepoint.StatePoint('statepoint.8.binary') +sp.read_results() +sp.read_source() + +# set up output string +outstr = '' + +# write out k-combined +outstr += 'k-combined:\n' +outstr += "{0:12.6E} {1:12.6E}\n".format(sp.k_combined[0], sp.k_combined[1]) + +# write out xyz +xyz = sp.source[0].xyz +for i in xyz: + outstr += "{0:12.6E} ".format(i) +outstr += "\n" + +# write results to file +with open('results_test.dat','w') as fh: + fh.write(outstr) diff --git a/tests/test_sourcepoint_batch/results_true.dat b/tests/test_sourcepoint_batch/results_true.dat new file mode 100644 index 000000000..748df0351 --- /dev/null +++ b/tests/test_sourcepoint_batch/results_true.dat @@ -0,0 +1,3 @@ +k-combined: +0.000000E+00 0.000000E+00 +-9.438655E-02 -4.436810E+00 -2.416825E+00 diff --git a/tests/test_sourcepoint_batch/settings.xml b/tests/test_sourcepoint_batch/settings.xml new file mode 100644 index 000000000..c816fe700 --- /dev/null +++ b/tests/test_sourcepoint_batch/settings.xml @@ -0,0 +1,19 @@ + + + + + + + + 10 + 5 + 1000 + + + + + -4 -4 -4 4 4 4 + + + + diff --git a/tests/test_sourcepoint_batch/test_sourcepoint_batch.py b/tests/test_sourcepoint_batch/test_sourcepoint_batch.py new file mode 100644 index 000000000..78d202e40 --- /dev/null +++ b/tests/test_sourcepoint_batch/test_sourcepoint_batch.py @@ -0,0 +1,44 @@ +#!/usr/bin/env python + +import os +from subprocess import Popen, STDOUT, PIPE, call +import filecmp +from nose_mpi import NoseMPI +import glob + +pwd = os.path.dirname(__file__) + +def setup(): + os.putenv('PWD', pwd) + os.chdir(pwd) + +def test_run(): + openmc_path = pwd + '/../../src/openmc' + if int(NoseMPI.mpi_np) > 0: + proc = Popen([NoseMPI.mpi_exec, '-np', NoseMPI.mpi_np, openmc_path], + stderr=STDOUT, stdout=PIPE) + else: + proc = Popen([openmc_path], stderr=STDOUT, stdout=PIPE) + print(proc.communicate()[0]) + returncode = proc.returncode + assert returncode == 0 + +def test_statepoint_exists(): + statepoint = glob.glob(pwd + '/statepoint.*') + assert len(statepoint) == 5 + assert statepoint[0].endswith('binary') or statepoint[0].endswith('h5') + +def test_results(): + statepoint = glob.glob(pwd + '/statepoint.8.*') + call(['python', 'results.py', statepoint[0]]) + compare = filecmp.cmp('results_test.dat', 'results_true.dat') + if not compare: + os.rename('results_test.dat', 'results_error.dat') + assert compare + +def teardown(): + output = glob.glob(pwd + '/statepoint.*') + output.append(pwd + '/results_test.dat') + for f in output: + if os.path.exists(f): + os.remove(f) diff --git a/tests/test_sourcepoint_interval/geometry.xml b/tests/test_sourcepoint_interval/geometry.xml new file mode 100644 index 000000000..612e46132 --- /dev/null +++ b/tests/test_sourcepoint_interval/geometry.xml @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/tests/test_sourcepoint_interval/materials.xml b/tests/test_sourcepoint_interval/materials.xml new file mode 100644 index 000000000..1f85510e0 --- /dev/null +++ b/tests/test_sourcepoint_interval/materials.xml @@ -0,0 +1,9 @@ + + + + + + + + + diff --git a/tests/test_sourcepoint_interval/results.py b/tests/test_sourcepoint_interval/results.py new file mode 100644 index 000000000..9b0f577eb --- /dev/null +++ b/tests/test_sourcepoint_interval/results.py @@ -0,0 +1,32 @@ +#!/usr/bin/env python + +import sys + +# import statepoint +sys.path.append('../../src/utils') +import statepoint + +# read in statepoint file +if len(sys.argv) > 1: + sp = statepoint.StatePoint(sys.argv[1]) +else: + sp = statepoint.StatePoint('statepoint.8.binary') +sp.read_results() +sp.read_source() + +# set up output string +outstr = '' + +# write out k-combined +outstr += 'k-combined:\n' +outstr += "{0:12.6E} {1:12.6E}\n".format(sp.k_combined[0], sp.k_combined[1]) + +# write out xyz +xyz = sp.source[0].xyz +for i in xyz: + outstr += "{0:12.6E} ".format(i) +outstr += "\n" + +# write results to file +with open('results_test.dat','w') as fh: + fh.write(outstr) diff --git a/tests/test_sourcepoint_interval/results_true.dat b/tests/test_sourcepoint_interval/results_true.dat new file mode 100644 index 000000000..748df0351 --- /dev/null +++ b/tests/test_sourcepoint_interval/results_true.dat @@ -0,0 +1,3 @@ +k-combined: +0.000000E+00 0.000000E+00 +-9.438655E-02 -4.436810E+00 -2.416825E+00 diff --git a/tests/test_sourcepoint_interval/settings.xml b/tests/test_sourcepoint_interval/settings.xml new file mode 100644 index 000000000..d0b8fa71d --- /dev/null +++ b/tests/test_sourcepoint_interval/settings.xml @@ -0,0 +1,19 @@ + + + + + + + + 10 + 5 + 1000 + + + + + -4 -4 -4 4 4 4 + + + + diff --git a/tests/test_sourcepoint_interval/test_sourcepoint_interval.py b/tests/test_sourcepoint_interval/test_sourcepoint_interval.py new file mode 100644 index 000000000..78d202e40 --- /dev/null +++ b/tests/test_sourcepoint_interval/test_sourcepoint_interval.py @@ -0,0 +1,44 @@ +#!/usr/bin/env python + +import os +from subprocess import Popen, STDOUT, PIPE, call +import filecmp +from nose_mpi import NoseMPI +import glob + +pwd = os.path.dirname(__file__) + +def setup(): + os.putenv('PWD', pwd) + os.chdir(pwd) + +def test_run(): + openmc_path = pwd + '/../../src/openmc' + if int(NoseMPI.mpi_np) > 0: + proc = Popen([NoseMPI.mpi_exec, '-np', NoseMPI.mpi_np, openmc_path], + stderr=STDOUT, stdout=PIPE) + else: + proc = Popen([openmc_path], stderr=STDOUT, stdout=PIPE) + print(proc.communicate()[0]) + returncode = proc.returncode + assert returncode == 0 + +def test_statepoint_exists(): + statepoint = glob.glob(pwd + '/statepoint.*') + assert len(statepoint) == 5 + assert statepoint[0].endswith('binary') or statepoint[0].endswith('h5') + +def test_results(): + statepoint = glob.glob(pwd + '/statepoint.8.*') + call(['python', 'results.py', statepoint[0]]) + compare = filecmp.cmp('results_test.dat', 'results_true.dat') + if not compare: + os.rename('results_test.dat', 'results_error.dat') + assert compare + +def teardown(): + output = glob.glob(pwd + '/statepoint.*') + output.append(pwd + '/results_test.dat') + for f in output: + if os.path.exists(f): + os.remove(f) diff --git a/tests/test_sourcepoint_latest/geometry.xml b/tests/test_sourcepoint_latest/geometry.xml new file mode 100644 index 000000000..612e46132 --- /dev/null +++ b/tests/test_sourcepoint_latest/geometry.xml @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/tests/test_sourcepoint_latest/materials.xml b/tests/test_sourcepoint_latest/materials.xml new file mode 100644 index 000000000..1f85510e0 --- /dev/null +++ b/tests/test_sourcepoint_latest/materials.xml @@ -0,0 +1,9 @@ + + + + + + + + + diff --git a/tests/test_sourcepoint_latest/results.py b/tests/test_sourcepoint_latest/results.py new file mode 100644 index 000000000..8ff10971c --- /dev/null +++ b/tests/test_sourcepoint_latest/results.py @@ -0,0 +1,25 @@ +#!/usr/bin/env python + +import sys + +# import statepoint +sys.path.append('../../src/utils') +import statepoint + +# read in statepoint file +if len(sys.argv) > 1: + sp = statepoint.StatePoint(sys.argv[1]) +else: + sp = statepoint.StatePoint('statepoint.10.binary') +sp.read_results() + +# set up output string +outstr = '' + +# write out k-combined +outstr += 'k-combined:\n' +outstr += "{0:12.6E} {1:12.6E}\n".format(sp.k_combined[0], sp.k_combined[1]) + +# write results to file +with open('results_test.dat','w') as fh: + fh.write(outstr) diff --git a/tests/test_sourcepoint_latest/results_true.dat b/tests/test_sourcepoint_latest/results_true.dat new file mode 100644 index 000000000..00a65f913 --- /dev/null +++ b/tests/test_sourcepoint_latest/results_true.dat @@ -0,0 +1,2 @@ +k-combined: +3.011353E-01 2.854556E-03 diff --git a/tests/test_sourcepoint_latest/settings.xml b/tests/test_sourcepoint_latest/settings.xml new file mode 100644 index 000000000..fa7f07dfa --- /dev/null +++ b/tests/test_sourcepoint_latest/settings.xml @@ -0,0 +1,18 @@ + + + + + + + 10 + 5 + 1000 + + + + + -4 -4 -4 4 4 4 + + + + diff --git a/tests/test_sourcepoint_latest/test_sourcepoint_latest.py b/tests/test_sourcepoint_latest/test_sourcepoint_latest.py new file mode 100644 index 000000000..d26533843 --- /dev/null +++ b/tests/test_sourcepoint_latest/test_sourcepoint_latest.py @@ -0,0 +1,48 @@ +#!/usr/bin/env python + +import os +from subprocess import Popen, STDOUT, PIPE, call +import filecmp +from nose_mpi import NoseMPI +import glob + +pwd = os.path.dirname(__file__) + +def setup(): + os.putenv('PWD', pwd) + os.chdir(pwd) + +def test_run(): + openmc_path = pwd + '/../../src/openmc' + if int(NoseMPI.mpi_np) > 0: + proc = Popen([NoseMPI.mpi_exec, '-np', NoseMPI.mpi_np, openmc_path], + stderr=STDOUT, stdout=PIPE) + else: + proc = Popen([openmc_path], stderr=STDOUT, stdout=PIPE) + print(proc.communicate()[0]) + returncode = proc.returncode + assert returncode == 0 + +def test_statepoint_exists(): + statepoint = glob.glob(pwd + '/statepoint.10.*') + assert len(statepoint) == 1 + assert statepoint[0].endswith('binary') or statepoint[0].endswith('h5') + source = glob.glob(pwd + '/source.*') + assert len(source) == 1 + assert source[0].endswith('binary') or source[0].endswith('h5') + +def test_results(): + statepoint = glob.glob(pwd + '/statepoint.10.*') + call(['python', 'results.py', statepoint[0]]) + compare = filecmp.cmp('results_test.dat', 'results_true.dat') + if not compare: + os.rename('results_test.dat', 'results_error.dat') + assert compare + +def teardown(): + output = glob.glob(pwd + '/statepoint.10.*') + output += glob.glob(pwd + '/source.*') + output.append(pwd + '/results_test.dat') + for f in output: + if os.path.exists(f): + os.remove(f) diff --git a/tests/test_sourcepoint_restart/geometry.xml b/tests/test_sourcepoint_restart/geometry.xml new file mode 100644 index 000000000..612e46132 --- /dev/null +++ b/tests/test_sourcepoint_restart/geometry.xml @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/tests/test_sourcepoint_restart/materials.xml b/tests/test_sourcepoint_restart/materials.xml new file mode 100644 index 000000000..1f85510e0 --- /dev/null +++ b/tests/test_sourcepoint_restart/materials.xml @@ -0,0 +1,9 @@ + + + + + + + + + diff --git a/tests/test_sourcepoint_restart/results.py b/tests/test_sourcepoint_restart/results.py new file mode 100644 index 000000000..f4c32a893 --- /dev/null +++ b/tests/test_sourcepoint_restart/results.py @@ -0,0 +1,44 @@ +#!/usr/bin/env python + +import sys +import numpy as np + +# import statepoint +sys.path.append('../../src/utils') +import statepoint + +# read in statepoint file +if len(sys.argv) > 1: + sp = statepoint.StatePoint(sys.argv[1]) +else: + sp = statepoint.StatePoint('statepoint.10.binary') +sp.read_results() + +# extract tally results and convert to vector +results1 = sp.tallies[0].results +shape1 = results1.shape +size1 = (np.product(shape1)) +results1 = np.reshape(results1, size1) +results2 = sp.tallies[1].results +shape2 = results2.shape +size2 = (np.product(shape2)) +results2 = np.reshape(results2, size2) + +# set up output string +outstr = '' + +# write out k-combined +outstr += 'k-combined:\n' +outstr += "{0:12.6E} {1:12.6E}\n".format(sp.k_combined[0], sp.k_combined[1]) + +# write out tally results +outstr += 'tally 1:\n' +for item in results1: + outstr += "{0:12.6E}\n".format(item) +outstr += 'tally 2:\n' +for item in results2: + outstr += "{0:12.6E}\n".format(item) + +# write results to file +with open('results_test.dat','w') as fh: + fh.write(outstr) diff --git a/tests/test_sourcepoint_restart/results_true.dat b/tests/test_sourcepoint_restart/results_true.dat new file mode 100644 index 000000000..ad94d7645 --- /dev/null +++ b/tests/test_sourcepoint_restart/results_true.dat @@ -0,0 +1,2412 @@ +k-combined: +3.011353E-01 2.854556E-03 +tally 1: +8.000000E-03 +1.600000E-05 +6.192275E-04 +1.370333E-06 +-8.662964E-04 +7.279501E-07 +-1.041312E-05 +3.860351E-07 +4.821963E-03 +5.791161E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +6.131510E-04 +1.880396E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.100000E-02 +3.300000E-05 +4.387087E-03 +7.410082E-06 +1.860042E-03 +2.867148E-06 +3.399756E-03 +5.784483E-06 +5.116596E-03 +6.752240E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +3.028119E-04 +9.169503E-08 +1.000000E-03 +1.000000E-06 +5.438971E-04 +2.958240E-07 +-5.626399E-05 +3.165637E-09 +-4.136011E-04 +1.710658E-07 +6.013419E-04 +3.616120E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +5.000000E-03 +1.300000E-05 +3.577754E-03 +6.496319E-06 +1.890975E-03 +1.788514E-06 +9.937593E-04 +4.944395E-07 +1.803302E-03 +1.626040E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.600000E-02 +6.600000E-05 +5.883798E-03 +1.472349E-05 +5.964243E-03 +1.758637E-05 +4.341846E-03 +6.731059E-06 +7.631087E-03 +1.536471E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +3.009839E-04 +9.059133E-08 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.300000E-02 +3.900000E-05 +1.678255E-03 +1.856663E-06 +3.802861E-03 +6.462034E-06 +-4.813541E-05 +2.987521E-06 +5.422032E-03 +6.871180E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +3.028119E-04 +9.169503E-08 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +5.000000E-03 +5.000000E-06 +1.710047E-03 +2.156886E-06 +7.353287E-04 +1.688467E-06 +1.623935E-03 +1.552163E-06 +2.439928E-03 +1.509909E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.000000E-03 +1.000000E-06 +1.789439E-04 +3.202091E-08 +-4.519686E-04 +2.042756E-07 +-2.540910E-04 +6.456222E-08 +6.243342E-04 +3.897931E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.400000E-02 +4.200000E-05 +4.680073E-03 +4.832992E-06 +9.241957E-04 +9.879528E-07 +2.560088E-03 +5.615638E-06 +7.279260E-03 +1.195027E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +5.992726E-04 +1.795675E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +9.000000E-03 +1.900000E-05 +4.178982E-03 +4.155519E-06 +3.346853E-03 +6.203486E-06 +1.267269E-03 +3.209807E-06 +3.940659E-03 +3.581639E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +3.028119E-04 +9.169503E-08 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +9.365012E-04 +8.770346E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +3.121671E-04 +9.744828E-08 +6.000000E-03 +1.200000E-05 +-2.469438E-05 +1.110126E-06 +6.006714E-04 +6.607712E-07 +1.988388E-03 +1.233934E-06 +3.924085E-03 +4.427425E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +6.243342E-04 +3.897931E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +3.009839E-04 +9.059133E-08 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +3.009839E-04 +9.059133E-08 +1.000000E-03 +1.000000E-06 +9.742209E-04 +9.491064E-07 +9.236596E-04 +8.531471E-07 +8.502670E-04 +7.229539E-07 +3.009839E-04 +9.059133E-08 +2.200000E-02 +1.140000E-04 +1.396444E-02 +4.152030E-05 +9.394828E-03 +1.953841E-05 +7.823718E-03 +1.254396E-05 +1.002065E-02 +2.139199E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +6.056238E-04 +3.667801E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +3.200000E-02 +2.140000E-04 +1.152532E-02 +2.810551E-05 +8.134203E-03 +1.622011E-05 +3.372833E-03 +2.907244E-06 +1.577229E-02 +5.159641E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +3.121671E-04 +9.744828E-08 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +9.365012E-04 +8.770346E-07 +2.000000E-03 +4.000000E-06 +4.929028E-04 +2.429532E-07 +-6.043220E-05 +3.652051E-09 +2.687444E-04 +7.222357E-08 +0.000000E+00 +0.000000E+00 +1.000000E-02 +2.400000E-05 +7.364203E-03 +1.356715E-05 +3.578025E-03 +3.952934E-06 +4.991388E-04 +8.277617E-07 +6.660384E-03 +1.078466E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.200000E-02 +4.800000E-05 +7.631639E-04 +2.262064E-06 +-3.448925E-04 +1.205043E-06 +-3.259600E-03 +4.482377E-06 +5.459930E-03 +8.074061E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +5.989596E-04 +1.793791E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +2.600000E-02 +1.820000E-04 +5.527216E-03 +9.741352E-06 +6.494815E-03 +1.331417E-05 +2.487729E-04 +9.009137E-06 +1.212394E-02 +3.763410E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +9.111267E-04 +2.768274E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +2.600000E-02 +1.400000E-04 +8.583494E-03 +1.976212E-05 +2.895567E-03 +1.210757E-05 +3.612948E-03 +7.374439E-06 +1.090179E-02 +2.581708E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +2.982887E-04 +8.897613E-08 +1.000000E-03 +1.000000E-06 +9.407668E-04 +8.850421E-07 +8.275632E-04 +6.848608E-07 +6.703954E-04 +4.494300E-07 +5.965773E-04 +3.559045E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +2.700000E-02 +1.750000E-04 +1.012358E-02 +2.467953E-05 +1.474435E-03 +4.801327E-06 +4.424179E-04 +1.661987E-06 +1.306491E-02 +3.990010E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.300000E-02 +3.900000E-05 +2.894580E-03 +7.413903E-06 +4.782406E-03 +8.519965E-06 +4.310430E-03 +7.496343E-06 +6.648334E-03 +9.824958E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +3.121671E-04 +9.744828E-08 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.800000E-02 +8.600000E-05 +8.003652E-04 +9.381590E-06 +3.457615E-03 +5.280629E-06 +-1.063124E-03 +2.234064E-06 +8.804401E-03 +1.982338E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.000000E-03 +1.000000E-06 +6.578244E-04 +4.327330E-07 +1.490994E-04 +2.223064E-08 +-2.750809E-04 +7.566948E-08 +6.243342E-04 +3.897931E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +2.000000E-02 +9.400000E-05 +4.167281E-04 +3.806472E-06 +3.031990E-03 +4.457402E-06 +-2.246079E-05 +6.478142E-07 +1.000360E-02 +2.105336E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +2.982887E-04 +8.897613E-08 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.900000E-02 +9.700000E-05 +6.458852E-03 +2.279404E-05 +3.627440E-03 +7.908704E-06 +3.946071E-03 +7.531590E-06 +8.885213E-03 +2.445611E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.200000E-02 +3.200000E-05 +5.376132E-03 +1.377498E-05 +3.290467E-03 +4.921168E-06 +1.422861E-03 +3.610761E-06 +4.838152E-03 +5.829692E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +6.016549E-04 +1.809943E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +6.056238E-04 +3.667801E-07 +1.000000E-03 +1.000000E-06 +3.227815E-04 +1.041879E-07 +-3.437182E-04 +1.181422E-07 +-4.000974E-04 +1.600779E-07 +0.000000E+00 +0.000000E+00 +2.700000E-02 +1.690000E-04 +1.259754E-02 +3.887684E-05 +3.514255E-03 +9.445635E-06 +1.359344E-03 +2.045441E-06 +1.362156E-02 +4.087828E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +9.156499E-04 +2.795463E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.805904E-03 +3.261288E-06 +2.000000E-03 +4.000000E-06 +1.904158E-03 +3.625820E-06 +1.722222E-03 +2.966050E-06 +1.472450E-03 +2.168109E-06 +0.000000E+00 +0.000000E+00 +3.900000E-02 +3.490000E-04 +1.656780E-02 +6.023774E-05 +1.361639E-02 +5.348538E-05 +9.429236E-03 +3.947382E-05 +1.761092E-02 +7.600968E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +3.028119E-04 +9.169503E-08 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +3.121671E-04 +9.744828E-08 +1.000000E-03 +1.000000E-06 +9.994298E-04 +9.988600E-07 +9.982900E-04 +9.965829E-07 +9.965814E-04 +9.931746E-07 +0.000000E+00 +0.000000E+00 +2.600000E-02 +1.600000E-04 +8.920548E-03 +2.629362E-05 +5.151221E-03 +8.876114E-06 +5.653525E-03 +1.067857E-05 +1.116368E-02 +2.969235E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.209415E-03 +5.437558E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +6.000000E-03 +1.800000E-05 +3.041714E-03 +1.129968E-05 +4.102928E-03 +6.714470E-06 +2.016161E-03 +6.122339E-06 +3.916134E-03 +9.516316E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +3.009839E-04 +9.059133E-08 +1.000000E-03 +1.000000E-06 +1.071043E-04 +1.147134E-08 +-4.827930E-04 +2.330891E-07 +-1.575849E-04 +2.483301E-08 +3.009839E-04 +9.059133E-08 +2.300000E-02 +1.150000E-04 +7.537245E-03 +2.829767E-05 +2.103092E-03 +9.662063E-06 +2.183497E-03 +3.744408E-06 +1.057909E-02 +2.415941E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +2.982887E-04 +8.897613E-08 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.209420E-03 +9.158466E-07 +1.000000E-03 +1.000000E-06 +9.276723E-04 +8.605758E-07 +7.908638E-04 +6.254655E-07 +6.043224E-04 +3.652056E-07 +3.009839E-04 +9.059133E-08 +2.500000E-02 +1.510000E-04 +1.154954E-02 +3.543399E-05 +4.217931E-03 +7.652974E-06 +1.816814E-03 +6.073065E-06 +9.720055E-03 +2.272026E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +3.121671E-04 +9.744828E-08 +1.000000E-03 +1.000000E-06 +-2.723974E-04 +7.420035E-08 +-3.886995E-04 +1.510873E-07 +3.580662E-04 +1.282114E-07 +3.121671E-04 +9.744828E-08 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +4.200000E-02 +3.560000E-04 +1.287791E-02 +4.221690E-05 +4.013355E-03 +1.949190E-05 +1.990533E-03 +9.786357E-06 +1.727222E-02 +6.016647E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +2.125620E-03 +1.382988E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +2.112371E-03 +2.274717E-06 +4.000000E-03 +8.000000E-06 +3.826961E-03 +7.325612E-06 +3.495526E-03 +6.132335E-06 +3.033406E-03 +4.680820E-06 +0.000000E+00 +0.000000E+00 +1.300000E-02 +4.300000E-05 +2.528669E-03 +1.367031E-05 +3.965235E-03 +4.071050E-06 +-4.149583E-04 +1.307826E-06 +7.258235E-03 +1.093717E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +9.114397E-04 +2.770157E-07 +2.000000E-03 +2.000000E-06 +-1.131644E-03 +6.424199E-07 +-3.637017E-05 +6.744918E-09 +7.827543E-04 +3.080768E-07 +9.271460E-04 +4.814882E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +2.000000E-02 +8.800000E-05 +5.382539E-03 +1.017579E-05 +2.414790E-03 +7.567027E-06 +3.961581E-03 +6.537588E-06 +9.680345E-03 +2.211393E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +9.159629E-04 +2.797346E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +2.200000E-02 +1.240000E-04 +7.269348E-03 +1.995179E-05 +2.992857E-03 +7.453704E-06 +4.698724E-03 +6.277902E-06 +1.253456E-02 +4.253483E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +3.121671E-04 +9.744828E-08 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +5.000000E-02 +5.100000E-04 +1.664620E-02 +7.437727E-05 +9.397450E-03 +4.322575E-05 +6.836310E-03 +1.231705E-05 +1.905990E-02 +7.550592E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +2.122996E-03 +1.372865E-06 +1.000000E-03 +1.000000E-06 +8.132758E-04 +6.614176E-07 +4.921264E-04 +2.421884E-07 +1.248736E-04 +1.559342E-08 +9.084356E-04 +8.252553E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +2.100000E-02 +9.500000E-05 +6.491403E-03 +1.250504E-05 +2.902964E-03 +5.648898E-06 +2.149247E-03 +2.668074E-06 +8.776336E-03 +1.780557E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +6.131510E-04 +1.880396E-07 +1.000000E-03 +1.000000E-06 +-6.320900E-04 +3.995377E-07 +9.930661E-05 +9.861803E-09 +3.167755E-04 +1.003467E-07 +1.239313E-03 +9.687296E-07 +1.000000E-03 +1.000000E-06 +9.677184E-04 +9.364790E-07 +9.047184E-04 +8.185155E-07 +8.140422E-04 +6.626647E-07 +0.000000E+00 +0.000000E+00 +3.000000E-02 +2.020000E-04 +7.960428E-03 +1.748184E-05 +1.857609E-03 +3.751885E-06 +3.621909E-03 +7.252984E-06 +1.365034E-02 +4.336505E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +2.900000E-02 +1.970000E-04 +5.726309E-03 +1.204288E-05 +-2.562602E-03 +8.796860E-06 +-5.408669E-04 +1.879390E-06 +1.269835E-02 +3.424162E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +9.226228E-04 +4.787693E-07 +1.000000E-03 +1.000000E-06 +-1.650338E-04 +2.723616E-08 +-4.591458E-04 +2.108148E-07 +2.363135E-04 +5.584407E-08 +2.982887E-04 +8.897613E-08 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +2.100000E-02 +1.070000E-04 +7.115739E-03 +1.595026E-05 +3.891656E-03 +4.927392E-06 +4.624860E-03 +6.824558E-06 +8.816934E-03 +1.684675E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +2.982887E-04 +8.897613E-08 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +9.029518E-04 +8.153220E-07 +1.000000E-03 +1.000000E-06 +9.531896E-04 +9.085703E-07 +8.628555E-04 +7.445196E-07 +7.353151E-04 +5.406883E-07 +0.000000E+00 +0.000000E+00 +8.000000E-03 +1.800000E-05 +1.619128E-03 +7.769465E-06 +2.613435E-03 +3.211760E-06 +1.405519E-03 +3.351048E-06 +4.513046E-03 +5.346316E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +3.009839E-04 +9.059133E-08 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +2.600000E-02 +1.760000E-04 +3.827326E-03 +1.821256E-05 +8.165880E-03 +1.737446E-05 +3.271322E-03 +1.161207E-05 +1.089998E-02 +2.472251E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.197919E-03 +7.175165E-07 +1.000000E-03 +1.000000E-06 +7.256235E-04 +5.265295E-07 +2.897942E-04 +8.398069E-08 +-1.332798E-04 +1.776351E-08 +3.028119E-04 +9.169503E-08 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.400000E-02 +5.800000E-05 +8.561790E-03 +2.265799E-05 +4.539886E-03 +5.757407E-06 +1.780257E-03 +1.445049E-06 +9.412238E-03 +1.952619E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +3.006709E-04 +9.040301E-08 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.900000E-02 +9.700000E-05 +1.187186E-02 +4.638870E-05 +5.669447E-03 +1.326414E-05 +2.818347E-03 +3.568113E-06 +6.363682E-03 +9.079681E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.198545E-03 +7.182698E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +6.013419E-04 +3.616120E-07 +1.000000E-03 +1.000000E-06 +9.751330E-04 +9.508843E-07 +9.263265E-04 +8.580808E-07 +8.553972E-04 +7.317044E-07 +0.000000E+00 +0.000000E+00 +1.000000E-02 +3.800000E-05 +5.100191E-03 +1.213804E-05 +2.526446E-03 +3.184717E-06 +1.120621E-03 +2.386039E-06 +4.520264E-03 +6.456267E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +9.062947E-04 +4.571831E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.700000E-02 +6.300000E-05 +3.401093E-03 +4.752976E-06 +-1.430942E-04 +2.289223E-06 +5.850560E-04 +2.116365E-06 +7.249747E-03 +1.181285E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +9.138219E-04 +2.784426E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.700000E-02 +9.900000E-05 +3.395904E-03 +1.353897E-05 +2.976877E-03 +2.251417E-06 +-1.066663E-04 +2.608803E-06 +7.331520E-03 +1.571258E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +5.989596E-04 +1.793791E-07 +2.000000E-03 +2.000000E-06 +7.367234E-04 +9.571208E-07 +4.356812E-04 +9.323439E-07 +1.039334E-03 +6.364636E-07 +1.505322E-03 +1.521066E-06 +1.000000E-03 +1.000000E-06 +9.879014E-04 +9.759491E-07 +9.639237E-04 +9.291489E-07 +9.285017E-04 +8.621153E-07 +0.000000E+00 +0.000000E+00 +1.900000E-02 +8.700000E-05 +2.777211E-03 +1.700824E-05 +4.035787E-03 +9.429368E-06 +2.980203E-05 +1.242805E-06 +1.000369E-02 +2.268829E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.900000E-02 +1.030000E-04 +7.734629E-03 +1.531457E-05 +5.093139E-03 +7.117666E-06 +5.058900E-03 +5.942325E-06 +7.269012E-03 +1.354949E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +3.009839E-04 +9.059133E-08 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +6.243342E-04 +3.897931E-07 +1.000000E-03 +1.000000E-06 +8.016563E-05 +6.426528E-09 +-4.903602E-04 +2.404531E-07 +-1.189605E-04 +1.415159E-08 +0.000000E+00 +0.000000E+00 +1.200000E-02 +4.600000E-05 +1.345552E-03 +1.661602E-06 +-1.840162E-03 +1.071811E-06 +6.885070E-04 +5.102453E-07 +5.789780E-03 +8.745856E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +8.000000E-03 +1.600000E-05 +6.633314E-03 +1.270264E-05 +4.628987E-03 +9.066793E-06 +2.905876E-03 +6.021797E-06 +4.223000E-03 +4.683691E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +6.013419E-04 +3.616120E-07 +1.000000E-03 +1.000000E-06 +4.295537E-04 +1.845164E-07 +-2.232254E-04 +4.982957E-08 +-4.461813E-04 +1.990778E-07 +1.207033E-03 +8.982334E-07 +2.000000E-03 +4.000000E-06 +1.368640E-03 +1.873175E-06 +5.907660E-04 +3.490045E-07 +1.853769E-04 +3.436459E-08 +0.000000E+00 +0.000000E+00 +6.000000E-03 +1.000000E-05 +3.102529E-03 +2.944216E-06 +3.553054E-03 +4.061545E-06 +2.423850E-03 +1.659791E-06 +2.405752E-03 +1.989485E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +5.965773E-04 +3.559045E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.200000E-02 +5.000000E-05 +7.180171E-03 +1.778928E-05 +2.622812E-03 +2.636835E-06 +1.108650E-03 +9.983372E-07 +6.665077E-03 +1.320251E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +3.028119E-04 +9.169503E-08 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +2.200000E-02 +1.300000E-04 +1.098015E-02 +3.419417E-05 +5.083853E-03 +6.677488E-06 +2.962020E-03 +3.751133E-06 +1.115370E-02 +3.284251E-05 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +2.982887E-04 +8.897613E-08 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +6.000000E-03 +1.000000E-05 +1.904880E-03 +1.700404E-06 +-5.545137E-04 +1.781015E-06 +-9.756510E-05 +6.625846E-07 +3.325684E-03 +2.829537E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +2.000000E-03 +2.000000E-06 +5.259036E-04 +2.147833E-07 +-6.778250E-04 +2.773263E-07 +-5.470874E-04 +2.096746E-07 +6.016549E-04 +1.809943E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +7.000000E-03 +1.700000E-05 +5.770569E-03 +1.116420E-05 +4.074122E-03 +5.715629E-06 +2.739484E-03 +2.864833E-06 +3.630946E-03 +2.739811E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +3.028119E-04 +9.169503E-08 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +1.000000E-02 +2.600000E-05 +3.940359E-03 +1.345990E-05 +4.066207E-03 +4.701591E-06 +2.653786E-03 +1.896780E-06 +3.626422E-03 +2.904169E-06 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +8.948660E-04 +8.007852E-07 +1.000000E-03 +1.000000E-06 +8.049124E-04 +6.478840E-07 +4.718259E-04 +2.226197E-07 +9.635598E-05 +9.284475E-09 +9.084356E-04 +8.252553E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +4.000000E-03 +4.000000E-06 +2.476562E-03 +1.946838E-06 +9.202571E-04 +1.346950E-06 +4.114154E-04 +1.017884E-06 +1.812898E-03 +9.066599E-07 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +0.000000E+00 +tally 2: +5.656024E-01 +6.399997E-02 +6.163195E-01 +7.599803E-02 +3.586752E+00 +2.573838E+00 +3.990119E+01 +3.185144E+02 diff --git a/tests/test_sourcepoint_restart/settings.xml b/tests/test_sourcepoint_restart/settings.xml new file mode 100644 index 000000000..4e9b12d24 --- /dev/null +++ b/tests/test_sourcepoint_restart/settings.xml @@ -0,0 +1,19 @@ + + + + + + + + 10 + 5 + 1000 + + + + + -4 -4 -4 4 4 4 + + + + diff --git a/tests/test_sourcepoint_restart/tallies.xml b/tests/test_sourcepoint_restart/tallies.xml new file mode 100644 index 000000000..1704f56e1 --- /dev/null +++ b/tests/test_sourcepoint_restart/tallies.xml @@ -0,0 +1,23 @@ + + + + + rectangular + 5 3 4 + -10. -5. 0. + 10. 4. 9. + + + + + + + scatter-P3 nu-fission + + + + + fission absorption total flux + + + \ No newline at end of file diff --git a/tests/test_sourcepoint_restart/test_sourcepoint_restart.py b/tests/test_sourcepoint_restart/test_sourcepoint_restart.py new file mode 100644 index 000000000..0eaf1198c --- /dev/null +++ b/tests/test_sourcepoint_restart/test_sourcepoint_restart.py @@ -0,0 +1,129 @@ +#!/usr/bin/env python + +import os +from subprocess import Popen, STDOUT, PIPE, call +import filecmp +from nose_mpi import NoseMPI +import glob + +pwd = os.path.dirname(__file__) + +def setup(): + os.putenv('PWD', pwd) + os.chdir(pwd) + +def test_run(): + openmc_path = pwd + '/../../src/openmc' + if int(NoseMPI.mpi_np) > 0: + proc = Popen([NoseMPI.mpi_exec, '-np', NoseMPI.mpi_np, openmc_path], + stderr=STDOUT, stdout=PIPE) + else: + proc = Popen([openmc_path], stderr=STDOUT, stdout=PIPE) + print(proc.communicate()[0]) + returncode = proc.returncode + assert returncode == 0 + +def test_created_statepoint(): + statepoint = glob.glob(pwd + '/statepoint.*') + assert len(statepoint) == 2 + assert statepoint[0].endswith('binary') or statepoint[0].endswith('h5') + sourcepoint = glob.glob(pwd + '/source.7.*') + assert len(sourcepoint) == 1 + assert sourcepoint[0].endswith('binary') or sourcepoint[0].endswith('h5') + +def test_results(): + statepoint = glob.glob(pwd + '/statepoint.10.*') + call(['python', 'results.py', statepoint[0]]) + compare = filecmp.cmp('results_test.dat', 'results_true.dat') + if not compare: + os.rename('results_test.dat', 'results_error.dat') + assert compare + os.remove(statepoint[0]) + +def test_restart_form1(): + statepoint = glob.glob(pwd + '/statepoint.7.*') + sourcepoint = glob.glob(pwd + '/source.7.*') + openmc_path = pwd + '/../../src/openmc' + if int(NoseMPI.mpi_np) > 0: + proc = Popen([NoseMPI.mpi_exec, '-np', NoseMPI.mpi_np, openmc_path, + '-r', statepoint[0], sourcepoint[0]], + stderr=STDOUT, stdout=PIPE) + else: + proc = Popen([openmc_path, '-r', statepoint[0], sourcepoint[0]], stderr=STDOUT, stdout=PIPE) + print(proc.communicate()[0]) + returncode = proc.returncode + assert returncode == 0 + +def test_created_statepoint_form1(): + statepoint = glob.glob(pwd + '/statepoint.10.*') + assert len(statepoint) == 1 + assert statepoint[0].endswith('binary') or statepoint[0].endswith('h5') + +def test_results_form1(): + statepoint = glob.glob(pwd + '/statepoint.10.*') + call(['python', 'results.py', statepoint[0]]) + compare = filecmp.cmp('results_test.dat', 'results_true.dat') + if not compare: + os.rename('results_test.dat', 'results_error.dat') + assert compare + os.remove(statepoint[0]) + +def test_restart_form2(): + statepoint = glob.glob(pwd + '/statepoint.7.*') + sourcepoint = glob.glob(pwd + '/source.7.*') + openmc_path = pwd + '/../../src/openmc' + if int(NoseMPI.mpi_np) > 0: + proc = Popen([NoseMPI.mpi_exec, '-np', NoseMPI.mpi_np, openmc_path, + '--restart', statepoint[0], sourcepoint[0]], + stderr=STDOUT, stdout=PIPE) + else: + proc = Popen([openmc_path, '--restart', statepoint[0], sourcepoint[0]], + stderr=STDOUT, stdout=PIPE) + print(proc.communicate()[0]) + returncode = proc.returncode + assert returncode == 0 + +def test_created_statepoint_form2(): + statepoint = glob.glob(pwd + '/statepoint.10.*') + assert len(statepoint) == 1 + assert statepoint[0].endswith('binary') or statepoint[0].endswith('h5') + +def test_results_form2(): + statepoint = glob.glob(pwd + '/statepoint.10.*') + call(['python', 'results.py', statepoint[0]]) + compare = filecmp.cmp('results_test.dat', 'results_true.dat') + if not compare: + os.rename('results_test.dat', 'results_error.dat') + assert compare + os.remove(statepoint[0]) + +def test_restart_serial(): + statepoint = glob.glob(pwd + '/statepoint.7.*') + sourcepoint = glob.glob(pwd + '/source.7.*') + openmc_path = pwd + '/../../src/openmc' + proc = Popen([openmc_path, '--restart', statepoint[0], sourcepoint[0]], + stderr=STDOUT, stdout=PIPE) + print(proc.communicate()[0]) + returncode = proc.returncode + assert returncode == 0 + +def test_created_statepoint_serial(): + statepoint = glob.glob(pwd + '/statepoint.10.*') + assert len(statepoint) == 1 + assert statepoint[0].endswith('binary') or statepoint[0].endswith('h5') + +def test_results_serial(): + statepoint = glob.glob(pwd + '/statepoint.10.*') + call(['python', 'results.py', statepoint[0]]) + compare = filecmp.cmp('results_test.dat', 'results_true.dat') + if not compare: + os.rename('results_test.dat', 'results_error.dat') + assert compare + +def teardown(): + output = glob.glob(pwd + '/statepoint.*') + output += glob.glob(pwd + '/source.*') + output.append(pwd + '/results_test.dat') + for f in output: + if os.path.exists(f): + os.remove(f) diff --git a/tests/test_statepoint_sourcesep/settings.xml b/tests/test_statepoint_sourcesep/settings.xml index 4f5b7691f..17d4ee2e2 100644 --- a/tests/test_statepoint_sourcesep/settings.xml +++ b/tests/test_statepoint_sourcesep/settings.xml @@ -1,7 +1,8 @@ - + + 10 diff --git a/tests/test_track_output/geometry.xml b/tests/test_track_output/geometry.xml new file mode 100644 index 000000000..f3566ab17 --- /dev/null +++ b/tests/test_track_output/geometry.xml @@ -0,0 +1,305 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -12.2682 -12.2682 + 1.63576 1.63576 + + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 1 2 2 2 1 2 2 2 2 2 + 2 2 2 3 2 2 2 2 2 2 2 3 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 1 2 2 1 2 2 2 1 2 2 1 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 1 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 1 2 2 1 2 2 2 1 2 2 1 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 3 2 2 2 2 2 2 2 3 2 2 2 + 2 2 2 2 2 1 2 2 2 1 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + + + + + + + -12.2682 -12.2682 + 1.63576 1.63576 + + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 1 2 2 2 1 2 2 2 2 2 + 2 2 2 1 2 2 2 2 2 2 2 1 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 1 2 2 1 2 2 2 1 2 2 1 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 1 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 1 2 2 1 2 2 2 1 2 2 1 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 3 2 2 2 2 2 2 2 3 2 2 2 + 2 2 2 2 2 1 2 2 2 1 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + + + + + + + + + + -12.2682 -12.2682 + 1.63576 1.63576 + + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 1 2 2 2 1 2 2 2 2 2 + 2 2 2 1 2 2 2 2 2 2 2 1 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 1 2 2 1 2 2 2 1 2 2 1 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 1 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 1 2 2 1 2 2 2 1 2 2 1 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 3 2 2 2 2 2 2 2 1 2 2 2 + 2 2 2 2 2 1 2 2 2 1 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + + + + + + + + + + + + -12.2682 -12.2682 + 1.63576 1.63576 + + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + + + + + + + -12.2682 -12.2682 + 1.63576 1.63576 + + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + + + + + + + + + + -12.2682 -12.2682 + 1.63576 1.63576 + + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 + 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 + 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 + + + + + + + + + + -12.2682 -12.2682 + 1.63576 1.63576 + + 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 + 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 + 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 + 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 + 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 + 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 + 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + + + + + + + + + + + -12.2682 -12.2682 + 1.63576 1.63576 + + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 + 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 + 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 + 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 + 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 + 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 + 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 + 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 + + + + + + + + + + -12.2682 -12.2682 + 1.63576 1.63576 + + 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 + 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 + 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 + 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 + 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 + 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 + 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 + 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 + 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 + 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 + 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 + 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 + + + + + + + + + + + + + + + + + + + -85.8774 -85.8774 + 24.5364 24.5364 + + 999 999 130 140 150 999 999 + 999 220 230 240 250 260 999 + 130 320 777 222 333 360 150 + 410 240 444 111 666 240 470 + 510 520 888 555 998 560 570 + 999 620 630 240 650 660 999 + 999 999 510 740 570 999 999 + + + + + + + + diff --git a/tests/test_track_output/materials.xml b/tests/test_track_output/materials.xml new file mode 100644 index 000000000..bbf880d96 --- /dev/null +++ b/tests/test_track_output/materials.xml @@ -0,0 +1,95 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/test_track_output/settings.xml b/tests/test_track_output/settings.xml new file mode 100644 index 000000000..ef74341db --- /dev/null +++ b/tests/test_track_output/settings.xml @@ -0,0 +1,30 @@ + + + + + + + + + + 2 + 0 + 100 + + + + + + + + + -1 -1 -1 1 1 1 + + + + + 1 1 1 + 1 1 2 + + + diff --git a/tests/test_track_output/test_track_output.py b/tests/test_track_output/test_track_output.py new file mode 100644 index 000000000..0e7674154 --- /dev/null +++ b/tests/test_track_output/test_track_output.py @@ -0,0 +1,65 @@ +#!/usr/bin/env python + +import os +from subprocess import Popen, STDOUT, PIPE, call +import filecmp +import glob + +from nose.plugins.skip import SkipTest + +from nose_mpi import NoseMPI + +pwd = os.path.dirname(__file__) + + +def setup(): + os.putenv('PWD', pwd) + os.chdir(pwd) + + +def test_run(): + openmc_path = pwd + '/../../src/openmc' + if int(NoseMPI.mpi_np) > 0: + proc = Popen([NoseMPI.mpi_exec, '-np', NoseMPI.mpi_np, openmc_path], + stderr=STDOUT, stdout=PIPE) + else: + proc = Popen([openmc_path], stderr=STDOUT, stdout=PIPE) + returncode = proc.wait() + print(proc.communicate()[0]) + assert returncode == 0 + + +def test_created_outputs(): + outputs = [glob.glob(''.join((pwd, '/track_1_1_1.*')))] + outputs.append(glob.glob(''.join((pwd, '/track_1_1_2.*')))) + for files in outputs: + assert len(files) == 1 + assert files[0].endswith('binary') or files[0].endswith('h5') + + +def test_outputs(): + # If vtk python module is not available, we can't run track.py so skip this + # test + try: + import vtk + except ImportError: + raise SkipTest + + call(['../../src/utils/track.py', '-o', 'poly'] + + glob.glob(''.join((pwd, '/track*')))) + poly = ''.join((pwd, '/poly.pvtp')) + assert os.path.isfile(poly) + metric = ''.join((pwd, '/true_poly.pvtp')) + compare = filecmp.cmp(poly, metric) + if not compare: + os.rename('poly.pvtp', 'error_poly.pvtp') + assert compare + + +def teardown(): + temp_files = glob.glob(''.join((pwd, '/statepoint*'))) + temp_files = temp_files + glob.glob(''.join((pwd, '/track*'))) + temp_files = temp_files + glob.glob(''.join((pwd, '/poly*'))) + for f in temp_files: + if os.path.exists(f): + os.remove(f) diff --git a/tests/test_track_output/true_poly.pvtp b/tests/test_track_output/true_poly.pvtp new file mode 100644 index 000000000..6ded87a0e --- /dev/null +++ b/tests/test_track_output/true_poly.pvtp @@ -0,0 +1,9 @@ + + + + + + + + + diff --git a/tests/test_void/results_true.dat b/tests/test_void/results_true.dat index a64938586..e569957b7 100644 --- a/tests/test_void/results_true.dat +++ b/tests/test_void/results_true.dat @@ -1,2 +1,2 @@ k-combined: -1.010313E+00 3.162080E-02 +1.006312E+00 3.000112E-02