Index: vendors/XMLF90/current/LICENSE
===================================================================
--- vendors/XMLF90/current/LICENSE	(revision 1899)
+++ vendors/XMLF90/current/LICENSE	(revision 1899)
@@ -0,0 +1,35 @@
+Copyright (c) 2003, 2004, Alberto Garcia (SAX, XPATH, WXML, Overall design)
+(c) 2003, 2004, Jon Wakelin, Alberto Garcia (DOM subsystem)
+(c) 2003, 2004, Jon Wakelin (CML writing subsystem)
+STRINGS module contributed by Mart Reentmeester. (See strings/m_strings.f90)
+
+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.
+
Index: vendors/XMLF90/current/arch/arch-IA64_PLATINE.fcm
===================================================================
--- vendors/XMLF90/current/arch/arch-IA64_PLATINE.fcm	(revision 1899)
+++ vendors/XMLF90/current/arch/arch-IA64_PLATINE.fcm	(revision 1899)
@@ -0,0 +1,15 @@
+%COMPILER            mpif90
+%LINKER              mpif90
+%AR                  ar
+%MAKE                gmake
+%FPP_FLAGS           -P -traditional 
+%FPP_DEF             
+%BASE_FFLAGS         -i4 -r8 -automatic -align all -I/opt/mpi/current/include
+%PROD_FFLAGS         -O3
+%DEV_FFLAGS          -O3 -traceback
+%DEBUG_FFLAGS        -g -traceback
+%MPI_FFLAGS
+%OMP_FFLAGS          -openmp
+%BASE_LD             -i4 -r8 -automatic
+%MPI_LD
+%OMP_LD              -openmp
Index: vendors/XMLF90/current/arch/arch-IA64_PLATINE.path
===================================================================
--- vendors/XMLF90/current/arch/arch-IA64_PLATINE.path	(revision 1899)
+++ vendors/XMLF90/current/arch/arch-IA64_PLATINE.path	(revision 1899)
@@ -0,0 +1,1 @@
+
Index: vendors/XMLF90/current/arch/arch-PW6_VARGAS.fcm
===================================================================
--- vendors/XMLF90/current/arch/arch-PW6_VARGAS.fcm	(revision 1899)
+++ vendors/XMLF90/current/arch/arch-PW6_VARGAS.fcm	(revision 1899)
@@ -0,0 +1,15 @@
+%COMPILER            xlf_r
+%LINKER              xlf_r
+%AR                  ar
+%MAKE                gmake
+%FPP_FLAGS           -P -traditional 
+%FPP_DEF             
+%BASE_FFLAGS         
+%PROD_FFLAGS         -O3
+%DEV_FFLAGS          -O2 -qfullpath -qinitauto=7FBFFFFF -qfloat=nans -qflttrap=overflow:zerodivide:invalid:enable -qsigtrap
+%DEBUG_FFLAGS        -g -qfullpath -qnooptimize -qinitauto=7FBFFFFF  -qfloat=nans -qflttrap=overflow:zerodivide:invalid:enable -qsigtrap 
+%MPI_FFLAGS
+%OMP_FFLAGS          
+%BASE_LD             
+%MPI_LD
+%OMP_LD              
Index: vendors/XMLF90/current/arch/arch-SX8_BRODIE.fcm
===================================================================
--- vendors/XMLF90/current/arch/arch-SX8_BRODIE.fcm	(revision 1899)
+++ vendors/XMLF90/current/arch/arch-SX8_BRODIE.fcm	(revision 1899)
@@ -0,0 +1,15 @@
+%COMPILER            sxmpif90
+%LINKER              sxmpif90
+%AR                  sxar
+%MAKE                make
+%FPP_FLAGS           -P -traditional 
+%FPP_DEF             NC_DOUBLE
+%BASE_FFLAGS         -P stack -Wf,-pvctl res=whole -R5 -float0 -size_t64 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume"
+%PROD_FFLAGS         -C vopt
+%DEV_FFLAGS          -C vsafe -gv -Wf,-init stack=nan,-init heap=nan
+%DEBUG_FFLAGS        -C debug -eC -Wf,-init stack=nan,-init heap=nan
+%MPI_FFLAGS
+%OMP_FFLAGS          -P openmp 
+%BASE_LD             
+%MPI_LD
+%OMP_LD              -P openmp
Index: vendors/XMLF90/current/arch/arch-SX8_MERCURE.fcm
===================================================================
--- vendors/XMLF90/current/arch/arch-SX8_MERCURE.fcm	(revision 1899)
+++ vendors/XMLF90/current/arch/arch-SX8_MERCURE.fcm	(revision 1899)
@@ -0,0 +1,15 @@
+%COMPILER            sxmpif90
+%LINKER              sxmpif90
+%AR                  sxar
+%MAKE                make
+%FPP_FLAGS           -P -traditional 
+%FPP_DEF             NC_DOUBLE
+%BASE_FFLAGS         -P stack -Wf,-pvctl res=whole -R5 -float0 -size_t64 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume"
+%PROD_FFLAGS         -C vopt
+%DEV_FFLAGS          -C vsafe -gv -Wf,-init stack=nan,-init heap=nan
+%DEBUG_FFLAGS        -C debug -eC -Wf,-init stack=nan,-init heap=nan
+%MPI_FFLAGS
+%OMP_FFLAGS          -P openmp 
+%BASE_LD             -size_t64
+%MPI_LD
+%OMP_LD              -P openmp
Index: vendors/XMLF90/current/arch/arch-SX9_MERCURE.fcm
===================================================================
--- vendors/XMLF90/current/arch/arch-SX9_MERCURE.fcm	(revision 1899)
+++ vendors/XMLF90/current/arch/arch-SX9_MERCURE.fcm	(revision 1899)
@@ -0,0 +1,15 @@
+%COMPILER            sxmpif90
+%LINKER              sxmpif90
+%AR                  sxar
+%MAKE                make
+%FPP_FLAGS           -P -traditional 
+%FPP_DEF             NC_DOUBLE
+%BASE_FFLAGS         -P stack -Wf,-pvctl res=whole -R5 -float0 -size_t64 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume"
+%PROD_FFLAGS         -C vopt
+%DEV_FFLAGS          -C vsafe -gv -Wf,-init stack=nan,-init heap=nan
+%DEBUG_FFLAGS        -C debug -eC -Wf,-init stack=nan,-init heap=nan
+%MPI_FFLAGS
+%OMP_FFLAGS          -P openmp 
+%BASE_LD             -size_t64
+%MPI_LD
+%OMP_LD              -P openmp
Index: vendors/XMLF90/current/arch/arch-X64_TITANE.fcm
===================================================================
--- vendors/XMLF90/current/arch/arch-X64_TITANE.fcm	(revision 1899)
+++ vendors/XMLF90/current/arch/arch-X64_TITANE.fcm	(revision 1899)
@@ -0,0 +1,15 @@
+%COMPILER            mpif90
+%LINKER              mpif90
+%AR                  ar
+%MAKE                gmake
+%FPP_FLAGS           -P -traditional 
+%FPP_DEF             
+%BASE_FFLAGS         -i4 -r8 -automatic -align all
+%PROD_FFLAGS         -O3
+%DEV_FFLAGS          -O3 -traceback
+%DEBUG_FFLAGS        -g -traceback
+%MPI_FFLAGS
+%OMP_FFLAGS          -openmp
+%BASE_LD             -i4 -r8 -automatic
+%MPI_LD
+%OMP_LD              -openmp
Index: vendors/XMLF90/current/bld.cfg
===================================================================
--- vendors/XMLF90/current/bld.cfg	(revision 1899)
+++ vendors/XMLF90/current/bld.cfg	(revision 1899)
@@ -0,0 +1,34 @@
+# ----------------------- FCM extract configuration file -----------------------
+cfg::type                           bld
+cfg::version                        1.0
+
+
+# ------------------------------------------------------------------------------
+# Build information
+# ------------------------------------------------------------------------------
+
+inc arch.fcm
+inc config.fcm
+
+dir::root   $PWD
+
+search_src           1
+bld::lib            xmlf90
+bld::target libxmlf90.a
+
+bld::tool::fc        %COMPILER
+bld::tool::ld        %LINKER
+bld::tool::ar        %AR
+bld::tool::make      %MAKE
+bld::tool::fflags    %FFLAGS
+bld::tool::ldflags   %BASE_LD
+
+# Pre-process code before analysing dependencies
+bld::pp              1
+
+
+# Don't generate interface files
+bld::tool::geninterface none
+
+# Allow ".inc" as an extension for CPP include files
+bld::outfile_ext::mod .mod
Index: vendors/XMLF90/current/configure
===================================================================
--- vendors/XMLF90/current/configure	(revision 1899)
+++ vendors/XMLF90/current/configure	(revision 1899)
@@ -0,0 +1,106 @@
+#!/bin/csh
+set verbose echo
+set has_arch_opt           = FALSE 
+set has_compile_opt        = FALSE
+set default_compile_flags = "%PROD_FFLAGS"
+
+top:
+if ($#argv > 0) then
+    switch ($1)
+
+    case -h
+
+########################################################################
+# Manuel en ligne
+########################################################################
+more <<eod
+
+
+configure_ioserver [Options] 
+
+bla, bla, bla
+eod
+exit
+
+########################################################################
+# Lecture des differentes options
+########################################################################
+                   
+    case -a
+    case -arch
+        set has_arch_opt = TRUE
+        set arch="$2" ; shift ; shift ; goto top
+
+    case -prod
+        set has_compile_opt = TRUE
+        set compile_flags="%PROD_FFLAGS"
+        shift ; goto top
+
+    case -dev
+        set has_compile_opt = TRUE
+        set compile_flags="%DEV_FFLAGS"
+        shift ; goto top
+
+    case -debug
+        set has_compile_opt = TRUE
+        set compile_flags="%DEBUG_FFLAGS"
+        shift ; goto top
+
+    default
+        echo "unknown option "$1" , exiting..."
+        exit 
+   endsw
+endif
+
+
+#define architecture files
+if ( $has_arch_opt == TRUE) then
+  if ( -e arch/arch-${arch}.fcm ) then
+    rm -f arch.fcm
+    ln -s arch/arch-${arch}.fcm arch.fcm
+  else
+    echo "architecture file : << arch/arch-${arch}.fcm >> is missing, exiting...."
+    exit
+  endif
+  
+  if ( -e arch/arch-${arch}.path ) then
+    rm -f arch.path
+    ln -s arch/arch-${arch}.path arch.path
+  else
+    echo "architecture file : << arch/arch-${arch}.path >> is missing, exiting...."
+    exit
+  endif
+else
+  echo "Warning : architecture not specified, taking default file <<arch.fcm>> and <<arch.path>>" 
+  if ( ! -e arch.fcm ) then
+    echo "architecture file : << arch.fcm >> is missing, exiting...."
+    exit
+  endif
+
+  if ( ! -e arch.fcm ) then
+    echo "architecture file : << arch.path >> is missing, exiting...."
+    exit
+  endif
+endif
+  
+# set compiler flags
+set FFLAGS="%BASE_FFLAGS"
+set LD_FFLAGS="%BASE_LD"
+set CPP_KEY="%FPP_DEF"
+
+# set compiler flags for optimisation
+if ( $has_compile_opt == FALSE ) then
+  set compile_flags=$default_compile_flags
+endif
+set FFLAGS=${FFLAGS}" "$compile_flags
+
+
+source ./arch.path
+
+# build config file
+set config_fcm="config.fcm"
+rm -f $config_fcm
+
+echo "%FFLAGS        $FFLAGS"                           >  $config_fcm 
+echo "%CPP_KEY       $CPP_KEY"                          >> $config_fcm
+echo "%LD_FFLAGS     $LD_FFLAGS"                        >> $config_fcm
Index: vendors/XMLF90/current/src/cml/flib_cml.f90
===================================================================
--- vendors/XMLF90/current/src/cml/flib_cml.f90	(revision 1899)
+++ vendors/XMLF90/current/src/cml/flib_cml.f90	(revision 1899)
@@ -0,0 +1,7 @@
+module flib_cml
+  use m_stmw
+  use m_cmlw
+ 
+  public
+
+end module flib_cml
Index: vendors/XMLF90/current/src/cml/m_cmlw.f90
===================================================================
--- vendors/XMLF90/current/src/cml/m_cmlw.f90	(revision 1899)
+++ vendors/XMLF90/current/src/cml/m_cmlw.f90	(revision 1899)
@@ -0,0 +1,1846 @@
+module m_cmlw
+
+  use flib_wxml
+  use m_stmw
+
+  private
+
+  integer, private, parameter ::  sp = selected_real_kind(6,30)
+  integer, private, parameter ::  dp = selected_real_kind(14,100)
+
+
+! CMLUnits
+  character(len=40), parameter :: U_ANGSTR = 'units:angstrom'
+  character(len=40), parameter :: U_PMETER = 'units:pm'
+  character(len=40), parameter :: U_DEGREE = 'units:degree'
+  character(len=40), parameter :: U_RADIAN = 'units:radian'
+  character(len=40), parameter :: U_INVCM  = 'units:cm-1'
+  character(len=40), parameter :: U_KCALMO = 'units:kcal-mole'
+  character(len=40), parameter :: U_EVOLT  = 'units:ev'
+  character(len=40), parameter :: U_SECOND = 'units:second'
+  character(len=40), parameter :: U_VOLT   = 'units:volt'
+
+! CMLCore
+  PUBLIC :: cmlAddCoordinates
+  PUBLIC :: cmlAddCrystal
+  PUBLIC :: cmlAddAngle
+  PUBLIC :: cmlAddLength
+  PUBLIC :: cmlAddEigenvalue
+  PUBLIC :: cmlAddProperty
+  PUBLIC :: cmlAddPropertyList
+  PUBLIC :: cmlAddMolecule
+  PUBLIC :: cmlAddMetadata
+
+! CMLComp
+  PUBLIC :: cmlAddLattice
+  PUBLIC :: cmlAddLatticeVector
+  PUBLIC :: cmlAddParameter
+
+! CMLCore
+  INTERFACE cmlAddCoordinates
+     MODULE PROCEDURE cmlAddCoordinatesSP, cmlAddCoordinatesDP
+  END INTERFACE
+
+  INTERFACE cmlAddCrystal
+     MODULE PROCEDURE cmlAddCrystalSP, cmlAddCrystalDP
+  END INTERFACE
+
+  INTERFACE cmlAddAngle
+     MODULE PROCEDURE cmlAddAngleSP, cmlAddAngleDP
+  END INTERFACE
+
+  INTERFACE cmlAddLength
+     MODULE PROCEDURE cmlAddLengthSP, cmlAddLengthDP
+  END INTERFACE
+
+  INTERFACE cmlAddEigenvalue
+     MODULE PROCEDURE cmlAddEigenvalueSP, cmlAddEigenvalueDP
+  END INTERFACE
+
+  INTERFACE cmlAddMolecule
+     MODULE PROCEDURE cmlAddMoleculeSP, cmlAddMoleculeDP, cmlAddMolecule3SP, &
+                      cmlAddMolecule3DP
+  END INTERFACE
+
+! CMLComa
+  INTERFACE cmlAddLattice
+     MODULE PROCEDURE cmlAddLatticeSP, cmlAddLatticeDP
+  END INTERFACE
+
+  INTERFACE cmlAddLatticeVector
+     MODULE PROCEDURE cmlAddLatticeVectorSP, cmlAddLatticeVectorDP
+  END INTERFACE
+
+  INTERFACE cmlAddProperty
+     MODULE PROCEDURE &
+          cmlAddPropScalarDP, cmlAddPropScalarSP, cmlAddPropScalarI, & 
+          cmlAddPropMatrixDP, cmlAddPropMatrixSP, cmlAddPropMatrixI, &
+          cmlAddPropArrayDP,  cmlAddPropArraySP,  cmlAddPropArrayI
+  END INTERFACE
+
+  INTERFACE cmlAddParameter
+     MODULE PROCEDURE &
+        cmlAddParameterCH, cmlAddParameterI, &
+        cmlAddParameterSP, cmlAddParameterDP, &
+        cmlAddParameterLG
+  END INTERFACE
+
+
+CONTAINS
+
+  ! =================================================
+  ! convenience CML routines
+  ! =================================================
+  
+  ! -------------------------------------------------
+  ! writes a propertyList start Tag to xml channel
+  ! -------------------------------------------------
+  
+  SUBROUTINE cmlAddPropertyList(xf, id, title, conv, dictref, ref, role)
+
+    implicit none
+    type(xmlf_t) :: xf
+    character(len=*), intent(in), optional :: id
+    character(len=*), intent(in), optional :: title
+    character(len=*), intent(in), optional :: conv
+    character(len=*), intent(in), optional :: dictref
+    character(len=*), intent(in), optional :: ref
+    character(len=*), intent(in), optional :: role
+    
+    call xml_NewElement(xf, 'propertyList')
+    if (present(id)) call xml_AddAttribute(xf, 'id', id)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(conv)) call xml_AddAttribute(xf, 'convention', conv)
+    if (present(ref)) call xml_AddAttribute(xf, 'ref', ref)
+    if (present(role)) call xml_AddAttribute(xf, 'role', role)
+    
+  END SUBROUTINE cmlAddPropertyList
+  
+  
+  ! -------------------------------------------------
+  ! 1. writes a DP property to xml channel
+  ! -------------------------------------------------
+  
+  SUBROUTINE cmlAddPropScalarDP(xf, property, id, title, conv, dictref, ref, units, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=dp), intent(in)               :: property
+    character(len=*), intent(in), optional :: id
+    character(len=*), intent(in), optional :: title
+    character(len=*), intent(in), optional :: dictref
+    character(len=*), intent(in), optional :: conv
+    character(len=*), intent(in), optional :: ref
+    character(len=*), intent(in), optional :: fmt
+    character(len=*), intent(in), optional :: units
+
+    call xml_NewElement(xf, 'property')
+    if (present(id))      call xml_AddAttribute(xf, 'id', id)
+    if (present(title))   call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(conv))    call xml_AddAttribute(xf, 'convention', conv)
+    if (present(ref))    call xml_AddAttribute(xf, 'ref', ref)
+    call stmAddScalar(xf=xf, value=property, units=units, fmt=fmt)
+    call xml_EndElement(xf, 'property')
+
+  END SUBROUTINE cmlAddPropScalarDP
+
+  ! -------------------------------------------------
+  ! 2. writes a Scalar SP property to xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE cmlAddPropScalarSP(xf, property, id, title, conv, dictref, ref, units, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=sp), intent(in) :: property
+    character(len=*), intent(in), optional :: id
+    character(len=*), intent(in), optional :: title
+    character(len=*), intent(in), optional :: dictref
+    character(len=*), intent(in), optional :: conv
+    character(len=*), intent(in), optional :: ref
+    character(len=*), intent(in), optional :: fmt
+    character(len=*), intent(in), optional :: units
+
+    call xml_NewElement(xf, 'property')
+    if (present(id)) call xml_AddAttribute(xf, 'id', id)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(conv)) call xml_AddAttribute(xf, 'convention', conv)
+    if (present(ref)) call xml_AddAttribute(xf, 'ref', ref)
+    call stmAddScalar(xf=xf, value=property, units=units, fmt=fmt)
+    call xml_EndElement(xf, 'property')
+  END SUBROUTINE cmlAddPropScalarSP
+  
+  ! -------------------------------------------------
+  ! 3. writes a Scalar integer property to xml channel
+  ! -------------------------------------------------
+  
+  SUBROUTINE cmlAddPropScalarI(xf, property, id, title, conv, dictref, ref, units)
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in) :: property
+    character(len=*), intent(in), optional :: id
+    character(len=*), intent(in), optional :: title
+    character(len=*), intent(in), optional :: dictref
+    character(len=*), intent(in), optional :: conv
+    character(len=*), intent(in), optional :: ref
+    character(len=*), intent(in), optional :: units
+
+    call xml_NewElement(xf, 'property')
+    if (present(id)) call xml_AddAttribute(xf, 'id', id)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(conv)) call xml_AddAttribute(xf, 'convention', conv)
+    if (present(ref)) call xml_AddAttribute(xf, 'ref', ref)
+    call stmAddScalar(xf=xf, value=property, units=units)
+    call xml_EndElement(xf, 'property')
+  END SUBROUTINE cmlAddPropScalarI
+
+  ! -------------------------------------------------
+  ! 4. writes an Float matrix property to xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE cmlAddPropMatrixDP(xf, property, nrows, ncols, dim, id, title, conv, dictref, ref, units, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in)      :: nrows
+    integer, intent(in)      :: ncols
+    integer, intent(in)      :: dim
+    real(kind=dp), intent(in) :: property(nrows,ncols)
+    character(len=*), intent(in), optional :: id
+    character(len=*), intent(in), optional :: title
+    character(len=*), intent(in), optional :: dictref
+    character(len=*), intent(in), optional :: conv
+    character(len=*), intent(in), optional :: ref
+    character(len=*), intent(in), optional :: fmt
+    character(len=*), intent(in), optional :: units
+
+    call xml_NewElement(xf, 'property')
+    if (present(id)) call xml_AddAttribute(xf, 'id', id)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(conv)) call xml_AddAttribute(xf, 'convention', conv)
+    if (present(ref)) call xml_AddAttribute(xf, 'ref', ref)
+    call stmAddMatrix(xf=xf, matrix=property, dim=dim, ncols=ncols, nrows=nrows, units=units, fmt=fmt)
+    call xml_EndElement(xf, 'property')
+  END SUBROUTINE cmlAddPropMatrixDP
+
+  ! -------------------------------------------------
+  ! 5. writes an SP Float matrix property to xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE cmlAddPropMatrixSP(xf, property, nrows, ncols, dim, id, title, conv, dictref, ref, units, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in)      :: nrows
+    integer, intent(in)      :: ncols
+    integer, intent(in)      :: dim
+    real(kind=sp), intent(in) :: property(nrows,ncols)
+    character(len=*), intent(in), optional :: id
+    character(len=*), intent(in), optional :: title
+    character(len=*), intent(in), optional :: dictref
+    character(len=*), intent(in), optional :: conv
+    character(len=*), intent(in), optional :: ref
+    character(len=*), intent(in), optional :: fmt
+    character(len=*), intent(in), optional :: units
+
+    call xml_NewElement(xf, 'property')
+    if (present(id)) call xml_AddAttribute(xf, 'id', id)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(conv)) call xml_AddAttribute(xf, 'convention', conv)
+    if (present(ref)) call xml_AddAttribute(xf, 'ref', ref)
+    call stmAddMatrix(xf=xf,matrix=property, dim=dim, ncols=ncols, nrows=nrows, units=units, fmt=fmt)
+    call xml_EndElement(xf, 'property')
+  END SUBROUTINE cmlAddPropMatrixSP
+
+
+  ! -------------------------------------------------
+  ! 6. writes an Integer matrix property to xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE cmlAddPropMatrixI(xf, property, nrows, ncols, dim, id, title, conv, dictref, ref, units, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+
+    integer, intent(in)                    :: nrows
+    integer, intent(in)                    :: ncols
+    integer, intent(in), optional          :: dim
+    integer, intent(in)                    :: property(nrows,ncols)
+    character(len=*), intent(in), optional :: id
+    character(len=*), intent(in), optional :: title
+    character(len=*), intent(in), optional :: dictref
+    character(len=*), intent(in), optional :: conv
+    character(len=*), intent(in), optional :: ref
+    character(len=*), intent(in), optional :: fmt
+    character(len=*), intent(in), optional :: units
+
+    call xml_NewElement(xf, 'property')
+    if (present(id)) call xml_AddAttribute(xf, 'id', id)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(conv)) call xml_AddAttribute(xf, 'convention', conv)
+    if (present(conv)) call xml_AddAttribute(xf, 'ref', ref)
+    call stmAddMatrix(xf=xf, matrix=property, dim=dim, ncols=ncols, nrows=nrows, units=units)
+    call xml_EndElement(xf, 'property')
+  END SUBROUTINE cmlAddPropMatrixI
+
+
+  ! -------------------------------------------------
+  ! 7. writes an Array DP property to xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE cmlAddPropArrayDP(xf, property, nvalue, id, title, conv, dictref, ref, units, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=dp), intent(in)               :: property(*)
+    integer, intent(in)                    :: nvalue
+    character(len=*), intent(in), optional :: id
+    character(len=*), intent(in), optional :: title
+    character(len=*), intent(in), optional :: dictref
+    character(len=*), intent(in), optional :: conv
+    character(len=*), intent(in), optional :: ref
+    character(len=*), intent(in), optional :: fmt
+    character(len=*), intent(in), optional :: units
+
+    call xml_NewElement(xf, 'property')
+    if (present(id)) call xml_AddAttribute(xf, 'id', id)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(conv)) call xml_AddAttribute(xf, 'convention', conv)
+    if (present(ref)) call xml_AddAttribute(xf, 'ref', ref)
+    call stmAddArray(xf=xf, array=property, nvalue=nvalue, units=units, fmt=fmt)
+    call xml_EndElement(xf, 'property')
+  END SUBROUTINE cmlAddPropArrayDP
+
+  ! -------------------------------------------------
+  ! 8. writes an Array SP property to xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE cmlAddPropArraySP(xf, property, nvalue, id, title, conv, dictref, ref, units, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=sp), intent(in)               :: property(*)
+    integer, intent(in)                    :: nvalue
+    character(len=*), intent(in), optional :: id
+    character(len=*), intent(in), optional :: title
+    character(len=*), intent(in), optional :: dictref
+    character(len=*), intent(in), optional :: conv
+    character(len=*), intent(in), optional :: ref
+    character(len=*), intent(in), optional :: fmt
+    character(len=*), intent(in), optional :: units
+
+    call xml_NewElement(xf, 'property')
+    if (present(id)) call xml_AddAttribute(xf, 'id', id)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(conv)) call xml_AddAttribute(xf, 'convention', conv)
+    if (present(ref)) call xml_AddAttribute(xf, 'ref', ref)
+    call stmAddArray(xf=xf, array=property, nvalue=nvalue, units=units, fmt=fmt)
+    call xml_EndElement(xf, 'property')
+  END SUBROUTINE cmlAddPropArraySP
+
+  ! -------------------------------------------------
+  ! 9. writes an Array integer property to xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE cmlAddPropArrayI(xf, property, nvalue, id, title, conv, dictref, ref, units)
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in)                    :: property(*)
+    integer, intent(in)                    :: nvalue
+    character(len=*), intent(in), optional :: id
+    character(len=*), intent(in), optional :: title
+    character(len=*), intent(in), optional :: dictref
+    character(len=*), intent(in), optional :: conv
+    character(len=*), intent(in), optional :: ref
+    character(len=*), intent(in), optional :: units
+
+    call xml_NewElement(xf, 'property')
+    if (present(id)) call xml_AddAttribute(xf, 'id', id)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(conv)) call xml_AddAttribute(xf, 'convention', conv)
+    if (present(ref)) call xml_AddAttribute(xf, 'ref', ref)
+    call stmAddArray(xf, array=property, nvalue=nvalue, units=units)
+    call xml_EndElement(xf, 'property')
+  END SUBROUTINE cmlAddPropArrayI
+
+  !------------------------------------------------------------
+  ! END OF PROPERTIES 
+  !------------------------------------------------------------
+
+
+  ! -------------------------------------------------
+  ! 1. writes complete DP molecule to xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE cmlAddMoleculeDP(xf, natoms, elements, coords, style, id, title, dictref, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in)                    :: natoms             ! number of atoms
+    real(kind=dp), intent(in)               :: coords(3, natoms)  ! atomic coordinates
+    character(len=*), intent(in)           :: elements(natoms)   ! chemical element types
+    character(len=*), intent(in), optional :: id                 ! id
+    character(len=*), intent(in), optional :: title              ! the title
+    character(len=*), intent(in), optional :: dictref            ! the dictionary reference
+    character(len=*), intent(in), optional :: fmt                ! format for coords
+    character(len=*), intent(in), optional :: style              ! type of coordinates 
+
+    ! 'x3' for Cartesians, 
+    ! 'xFrac' for fractionals
+    ! default => cartesians
+
+    ! Internal Variables
+    character(len=6) :: id1, id0
+    character(len=10):: formt, stylei
+    integer          :: i
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+    if (present(style)) then
+       stylei = style
+    else
+       stylei = 'x3'
+    endif
+
+    call stmAddStartTag(xf, 'molecule', id, title, dictref)
+    call xml_NewElement(xf, 'atomArray')
+    do i = 1, natoms
+       write(id0, '(i4)') i
+       id0 = adjustl(id0)
+       id1 = 'a'
+       id1(2:) = id0
+       call cmlAddAtom(xf=xf, elem=elements(i), id=id1)
+       if (stylei .eq. 'x3') then
+          call CMLATX39DP(xf, coords(1, i), coords(2, i), coords(3, i), formt)
+       elseif (stylei .eq. 'xFrac') then
+          call CMLATXF9DP(xf, coords(1, i), coords(2, i), coords(3, i), formt)
+       elseif (stylei .eq. 'xyz3') then
+          call CMLATXYZ39DP(xf, coords(1, i), coords (2, i), coords(3, i), formt)
+       elseif (stylei .eq. 'xyzFrac') then
+          call CMLATXYZFRACT9DP(xf, coords(1, i), coords(2, i), coords(3, i), formt)
+       endif
+       call xml_EndElement(xf, 'atom')
+    enddo
+
+    call xml_EndElement(xf, 'atomArray')
+    call xml_EndElement(xf, 'molecule')
+    
+  END SUBROUTINE cmlAddMoleculeDP
+
+  
+  ! -------------------------------------------------
+  ! 2. writes complete SP molecule to xml channel
+  ! -------------------------------------------------
+  
+  SUBROUTINE cmlAddMoleculeSP(xf, natoms, elements, coords, style, id, title, dictref, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in)                    :: natoms          ! number of atoms
+    character(len=*), intent(in)           :: elements(*)     ! chemical element types
+    real(kind=sp), intent(in)               :: coords(3, *)    ! atomic coordinates
+    character(len=*), intent(in), optional :: id              ! id
+    character(len=*), intent(in), optional :: title           ! the title
+    character(len=*), intent(in), optional :: dictref         ! the dictionary reference
+    character(len=*), intent(in), optional :: fmt             ! format for coords
+    character(len=*), intent(in), optional :: style           ! type of coordinates ('x3'for Cartesians, 'xFrac' 
+    ! for fractionals; ' ' = default => cartesians)
+    ! Flush on entry and exit
+    character(len=6) :: id1, id0
+    integer          :: i
+    character(len=10):: formt, stylei
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+    if (present(style)) then
+       stylei = style
+    else
+       stylei = 'x3'
+    endif
+
+    call stmAddStartTag(xf, 'molecule', id, title, dictref)
+    call xml_NewElement(xf, 'atomArray')
+    do i = 1, natoms
+       write(id0, '(i4)') i
+       id0 = adjustl(id0)
+       id1 = 'a'
+       id1(2:) = id0
+       call cmlAddAtom(xf=xf, elem=elements(i), id=id1)
+       if (stylei .eq. 'x3') then
+          call CMLATX39SP(xf, coords(1, i), coords(2, i), coords(3, i), formt)
+       elseif (stylei .eq. 'xFrac') then
+          call CMLATXF9SP(xf, coords(1, i), coords(2, i), coords(3, i), formt)
+       elseif (stylei .eq. 'xyz3') then
+          call CMLATXYZ39SP(xf, coords(1, i), coords(2, i), coords(3, i), formt)
+       elseif (stylei .eq. 'xyzFrac') then
+          call CMLATXYZFRACT9SP(xf, coords(1, i), coords(2, i), coords(3, i), formt)
+       endif
+       call xml_EndElement(xf, 'atom')
+    enddo
+
+    call xml_EndElement(xf, 'atomArray')
+    call xml_EndElement(xf, 'molecule')
+    
+    
+  END SUBROUTINE cmlAddMoleculeSP
+  
+  
+  ! -------------------------------------------------
+  ! 1. writes complete DP molecule to xml channel (No. 2)
+  ! -------------------------------------------------
+  
+  SUBROUTINE cmlAddMolecule3DP(xf, natoms, elements, x, y, z, style, id, title, dictref, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in)                    :: natoms          ! number of atoms
+    real(kind=dp), intent(in)               :: x(*)
+    real(kind=dp), intent(in)               :: y(*)
+    real(kind=dp), intent(in)               :: z(*)
+    character(len=*), intent(in)           :: elements(*)     ! chemical element types
+    character(len=*), intent(in), optional :: id              ! id
+    character(len=*), intent(in), optional :: title           ! the title
+    character(len=*), intent(in), optional :: dictref         ! the dictionary reference
+    character(len=*), intent(in), optional :: fmt             ! format for coords
+    character(len=*), intent(in), optional :: style           ! type of coordinates ('x3'for Cartesians, 'xFrac' 
+    ! for fractionals; ' ' = default => cartesians)
+    character(len=6)  :: id1, id0
+    integer           :: i, l
+    character(len=10) :: formt, stylei
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+    if (present(style)) then
+       stylei = trim(style)
+    else
+       stylei = 'x3'
+    endif
+
+    call stmAddStartTag(xf=xf, name='molecule', id=id, title=title, dictref=dictref)
+    call xml_NewElement(xf, 'atomArray')
+
+    do i = 1, natoms
+       write(id0, '(i4)') i
+       id0 = adjustl(id0)
+       id1 = 'a'
+       id1(2:) = id0
+       call cmlAddAtom(xf=xf, elem=elements(i), id=id1)
+       if (trim(stylei) .eq. 'x3') then
+          call CMLATX39DP(xf, x(i), y(i), z(i), formt)
+       elseif (stylei .eq. 'xFrac') then
+          call CMLATXF9DP(xf, x(i), y(i), z(i), formt)
+       elseif (stylei .eq. 'xyz3') then
+          call CMLATXYZ39DP(xf, x(i), y(i), z(i), formt)
+       elseif (stylei .eq. 'xyzFrac') then
+          call CMLATXYZFRACT9DP(xf, x(i), y(i), z(i), formt)
+       endif
+       call xml_EndElement(xf, 'atom')
+    enddo
+
+    call xml_EndElement(xf, 'atomArray')
+    call xml_EndElement(xf, 'molecule')
+    
+  END SUBROUTINE cmlAddMolecule3DP
+  
+  
+  ! -------------------------------------------------
+  ! 2. writes complete SP molecule to xml channel (No. 2)
+  ! -------------------------------------------------
+  
+  SUBROUTINE cmlAddMolecule3SP(xf, natoms, elements, x, y, z, style, id, title, dictref, fmt)
+
+
+    implicit none
+    type(xmlf_t) :: xf
+    ! 10 Arguments
+    integer, intent(in)                    :: natoms          ! number of atoms
+    real(kind=sp), intent(in)               :: x(*)
+    real(kind=sp), intent(in)               :: y(*)
+    real(kind=sp), intent(in)               :: z(*)
+    character(len=*), intent(in)           :: elements(*)      ! chemical element types
+    character(len=*), intent(in), optional :: id               ! id
+    character(len=*), intent(in), optional :: title            ! the title
+    character(len=*), intent(in), optional :: dictref          ! the dictionary reference
+    character(len=*), intent(in), optional :: fmt              ! format for coords
+    character(len=*), intent(in), optional :: style            ! type of coordinates ('x3' for Cartesians, 'xFrac' 
+    ! for fractionals; ' ' = default => cartesians)
+    ! Internal variables
+    character(len=6)  :: id1, id0
+    integer           :: i, l
+    character(len=10) :: formt, stylei
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+    if (present(style)) then
+       stylei = style
+    else
+       stylei = 'x3'
+    endif
+
+    call xml_NewElement(xf, 'molecule')
+    call xml_AddAttribute(xf, 'id', id)
+    call xml_AddAttribute(xf, 'title', title)
+    call xml_AddAttribute(xf, 'dictref', dictref)
+    call xml_NewElement(xf, 'atomArray')
+    do i = 1, natoms
+       write(id0, '(i4)') i
+       id0 = adjustl(id0)
+       id1 = 'a'
+       id1(2:) = id0
+       call cmlAddAtom(xf=xf, elem=elements(i), id=id1)
+       if (stylei .eq. 'x3') then
+          call CMLATX39SP(xf, x(i), y(i), z(i), formt)
+       else if (stylei .eq. 'xFrac') then
+          call CMLATXF9SP(xf, x(i), y(i), z(i), formt)
+       else if (stylei .eq. 'xyz3') then
+          call CMLATXYZ39SP(xf, x(i), y(i), z(i), formt)
+       else if (stylei .eq. 'xyzFrac') then
+          call CMLATXYZFRACT9SP(xf, x(i), y(i), z(i), formt)
+       endif
+           call xml_EndElement(xf, 'atom')
+    enddo
+
+    call xml_EndElement(xf, 'atomArray')
+    call xml_EndElement(xf, 'molecule')
+
+  END SUBROUTINE cmlAddMolecule3SP
+  
+  ! -------------------------------------------------
+  ! writes an <atom> start tag
+  ! -------------------------------------------------
+  
+  SUBROUTINE cmlAddAtom(xf, elem, id, charge, hCount, occupancy, fmt)
+
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in), optional           :: charge     ! formalCharge
+    integer, intent(in), optional           :: hCount     ! hydrogenCount
+    real(kind=sp), intent(in), optional      :: occupancy  ! hydrogenCount
+    character(len=*), intent(in), optional  :: elem       ! chemical element name
+    character(len=*), intent(in), optional  :: id         ! atom id
+    character(len=*), intent(in), optional  :: fmt        ! format
+
+    ! internal Variable
+    character(len=10):: formt
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+
+    call xml_NewElement(xf, 'atom')
+    if (present(elem))      call xml_AddAttribute(xf, 'elementType', elem)
+    if (present(id))        call xml_AddAttribute(xf, 'id', id)
+    if (present(charge))    call xml_AddAttribute(xf, 'formalCharge', str(charge))
+    if (present(hCount))    call xml_AddAttribute(xf, 'hydrogenCount', str(hCount))
+    if (present(occupancy)) call xml_AddAttribute(xf, 'occupancy', str(occupancy,formt))
+
+  END SUBROUTINE cmlAddAtom
+  
+  
+  ! -------------------------------------------------
+  ! 1. append SP coordinates to atom tag
+  ! -------------------------------------------------
+  
+  SUBROUTINE cmlAddCoordinatesSP(xf, x, y, z, style, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=sp), intent(in)               :: x, y
+    real(kind=sp), intent(in), optional     :: z
+    character(len=*), intent(in), optional :: style
+    character(len=*), intent(in), optional :: fmt
+
+    ! Internal variable
+    character(len=10):: formt
+    character(len=10):: stylei
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+    if (present(style)) then
+       stylei = style
+    else
+       stylei = 'x3'
+    endif
+
+    if (present(z) .and. stylei .eq. 'x3') then
+       call CMLATX39SP(xf, x, y, z, formt)
+    else if (present(z) .and. stylei .eq. 'xFrac') then
+       call CMLATXF9SP(xf, x, y, z, formt)
+    else if (present(z) .and. stylei .eq. 'xyz3') then
+       call CMLATXYZ39SP(xf, x, y, z, formt)
+    else if (present(z) .and. stylei .eq. 'xyzFrac') then
+       call CMLATXYZFRACT9SP(xf, x, y, z, formt)
+    elseif (.not. present(z) .and. stylei .eq. 'xy2') then
+       call CMLATXY9SP(xf, x, y, formt)           
+    endif
+
+  END SUBROUTINE cmlAddCoordinatesSP
+
+  ! -------------------------------------------------
+  ! 2. append DP coordinates to atom tag
+  ! -------------------------------------------------
+
+  SUBROUTINE cmlAddCoordinatesDP(xf, x, y, z, style, fmt)
+    implicit none
+    type(xmlf_t) :: xf 
+    real(kind=dp), intent(in)               :: x, y
+    real(kind=dp), intent(in), optional     :: z
+    character(len=*), intent(in), optional :: style
+    character(len=*), intent(in), optional :: fmt
+    
+    ! Internal variable
+    character(len=10):: formt
+    character(len=10):: stylei
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+    if (present(style)) then
+       stylei = style
+    else
+       stylei = 'x3'
+    endif
+    
+    if (present(z) .and. stylei .eq. 'x3') then
+       call CMLATX39DP(xf, x, y, z, formt)
+    else if (present(z) .and. stylei .eq. 'xFrac') then
+       call CMLATXF9DP(xf, x, y, z, formt)
+    else if (present(z) .and. stylei .eq. 'xyz3') then
+       call CMLATXYZ39DP(xf, x, y, z, formt)
+    else if (present(z) .and. stylei .eq. 'xyzFrac') then
+       call CMLATXYZFRACT9DP(xf, x, y, z, formt)
+    else if (.not. present(z) .and. stylei .eq. 'xy2') then
+       call CMLATXY9DP(xf, x, y, formt)           
+    endif
+    
+  END SUBROUTINE cmlAddCoordinatesDP
+
+  
+  ! -------------------------------------------------
+  ! 1. writes a DP <length> element to output channel
+  ! -------------------------------------------------
+  
+  SUBROUTINE cmlAddLengthDP(xf, length, id, atomRef1, atomRef2, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=dp), intent(in)     :: length     ! length
+    character(len=*), intent(in) :: id         ! length id
+    character(len=*), intent(in) :: atomRef1   ! ref to first atom
+    character(len=*), intent(in) :: atomRef2   ! ref to second atom
+    character(len=*), intent(in) :: fmt        ! format
+
+    optional         :: fmt
+    character(len=10):: formt
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+
+    ! Flush on entry and exit
+    call CMLLEN9DP(xf, id, atomRef1, atomRef2, length, formt)
+  END SUBROUTINE cmlAddLengthDP
+
+  ! -------------------------------------------------
+  ! 2. writes a SP <length> element to output channel
+  ! -------------------------------------------------
+  
+  SUBROUTINE cmlAddLengthSP(xf, length, id, atomRef1, atomRef2, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=sp), intent(in)     :: length     ! the length
+    character(len=*), intent(in) :: id         ! length id
+    character(len=*), intent(in) :: atomRef1   ! ref to first atom
+    character(len=*), intent(in) :: atomRef2   ! ref to second atom
+    character(len=*), intent(in) :: fmt        ! format
+
+    optional         :: fmt
+    character(len=10):: formt
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+
+    ! Flush on entry and exit
+    call CMLLEN9SP(xf, id, atomRef1, atomRef2, length, formt)
+  END SUBROUTINE cmlAddLengthSP
+
+
+  ! -------------------------------------------------
+  ! 1. writes an DP <angle> element to output channel
+  ! -------------------------------------------------
+
+  SUBROUTINE cmlAddAngleDP(xf, angle, id, atomRef1, atomRef2, atomRef3, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=dp), intent(in)     :: angle        ! the angle
+    character(len=*), intent(in) :: id           ! angle id
+    character(len=*), intent(in) :: atomRef1     ! ref to first atom
+    character(len=*), intent(in) :: atomRef2     ! ref to second atom
+    character(len=*), intent(in) :: atomRef3     ! ref to third atom
+    character(len=*), intent(in) :: fmt          ! format
+
+    optional         :: fmt
+    character(len=10):: formt
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+
+    ! Flush on entry and exit
+    call CMLANG9DP(xf, id, atomRef1, atomRef2, atomRef3, angle, formt)
+  END SUBROUTINE cmlAddAngleDP
+
+  ! -------------------------------------------------
+  ! 2. writes an SP <angle> element to output channel
+  ! -------------------------------------------------
+
+  SUBROUTINE cmlAddAngleSP(xf, angle, id, atomRef1, atomRef2, atomRef3, fmt)
+
+
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=sp), intent(in)     :: angle        ! the angle
+    character(len=*), intent(in) :: id           ! angle id
+    character(len=*), intent(in) :: atomRef1     ! ref to first atom
+    character(len=*), intent(in) :: atomRef2     ! ref to second atom
+    character(len=*), intent(in) :: atomRef3     ! ref to third atom
+    character(len=*), intent(in) :: fmt          ! format
+
+    optional         :: fmt
+    character(len=10):: formt
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+
+    ! Flush on entry and exit
+    call CMLANG9SP(xf, id, atomRef1, atomRef2, atomRef3, angle, formt)
+  END SUBROUTINE cmlAddAngleSP
+
+
+  ! -------------------------------------------------
+  ! 1. creates and writes a DP <torsion> element
+  ! -------------------------------------------------
+
+  SUBROUTINE cmlAddTorsionDP(xf, torsion, id, atomRef1, atomRef2, atomRef3, atomRef4, fmt)
+
+
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=dp), intent(in)     :: torsion         ! the torsion
+    character(len=*), intent(in) :: id              ! torsion id
+    character(len=*), intent(in) :: atomRef1        ! ref to first atom
+    character(len=*), intent(in) :: atomRef2        ! ref to second atom
+    character(len=*), intent(in) :: atomRef3        ! ref to third atom
+    character(len=*), intent(in) :: atomRef4        ! ref to fourth atom
+    character(len=*), intent(in) :: fmt             ! format
+
+    optional         :: fmt
+    character(len=10):: formt
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+
+    ! Flush on entry and exit
+    call CMLTOR9DP(xf, id, atomRef1, atomRef2, atomRef3, atomRef4, torsion, formt)
+  END SUBROUTINE cmlAddTorsionDP
+  
+  ! -------------------------------------------------
+  ! 2. creates and writes a SP <torsion> element
+  ! -------------------------------------------------
+  
+  SUBROUTINE cmlAddTorsionSP(xf, torsion, id, atomRef1, atomRef2, atomRef3, atomRef4, fmt)
+
+
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=sp), intent(in)     :: torsion         ! the torsion
+    character(len=*), intent(in) :: id              ! torsion id
+    character(len=*), intent(in) :: atomRef1        ! ref to first atom
+    character(len=*), intent(in) :: atomRef2        ! ref to second atom
+    character(len=*), intent(in) :: atomRef3        ! ref to third atom
+    character(len=*), intent(in) :: atomRef4        ! ref to fourth atom
+    character(len=*), intent(in) :: fmt             ! format
+
+    optional         :: fmt
+    character(len=10):: formt
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+
+    ! Flush on entry and exit
+    call CMLTOR9SP(xf, id, atomRef1, atomRef2, atomRef3, atomRef4, torsion, formt)
+  END SUBROUTINE cmlAddTorsionSP
+
+
+  ! -------------------------------------------------
+  ! 1. creates and writes an SP Lattice element
+  ! -------------------------------------------------
+
+  SUBROUTINE cmlAddLatticeSP(xf, cell, units, title, id, dictref, conv, lattType, spaceType, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=sp), intent(in)               :: cell(3,3)
+    character(len=*), intent(in), optional :: units       
+    character(len=*), intent(in), optional :: id           ! id
+    character(len=*), intent(in), optional :: title        ! title
+    character(len=*), intent(in), optional :: dictref      ! dictref
+    character(len=*), intent(in), optional :: conv         ! format
+    character(len=*), intent(in), optional :: lattType     ! 
+    character(len=*), intent(in), optional :: spaceType    !
+    character(len=*), intent(in), optional :: fmt         
+
+    ! Internal Variables
+    integer           :: i
+    character(len=10) :: formt
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'   
+    endif
+
+    call xml_NewElement(xf, 'lattice')
+    if (present(id)) call xml_AddAttribute(xf, 'id', id)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(conv)) call xml_AddAttribute(xf, 'convention', conv)
+    if (present(lattType)) call xml_AddAttribute(xf, 'latticeType', lattType)
+    if (present(spaceType)) call xml_AddAttribute(xf, 'spaceType', spaceType)
+
+    do i = 1,3
+       call xml_NewElement(xf, 'latticeVector')
+       if (present(units)) call xml_AddAttribute(xf, 'units', units)
+       call xml_AddAttribute(xf, 'dictRef', 'cml:latticeVector')
+       call xml_AddPcdata(xf, str(cell(1,i), formt))
+       call xml_AddPcdata(xf, str(cell(2,i), formt))
+       call xml_AddPcdata(xf, str(cell(3,i), formt))
+    call xml_EndElement(xf, 'latticeVector')
+    enddo
+    call xml_EndElement(xf, 'lattice')
+
+  END SUBROUTINE cmlAddLatticeSP
+
+
+  ! -------------------------------------------------
+  ! 2. creates and writes DP Lattice element
+  ! -------------------------------------------------
+
+  SUBROUTINE cmlAddLatticeDP(xf, cell, units, title, id, dictref, conv, lattType, spaceType, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=dp), intent(in)               :: cell(3,3)
+    character(len=*), intent(in), optional :: units       
+    character(len=*), intent(in), optional :: id           ! id
+    character(len=*), intent(in), optional :: title        ! title
+    character(len=*), intent(in), optional :: dictref      ! dictref
+    character(len=*), intent(in), optional :: conv         ! format
+    character(len=*), intent(in), optional :: lattType     ! 
+    character(len=*), intent(in), optional :: spaceType    !
+    character(len=*), intent(in), optional :: fmt         
+
+    ! Internal Variables
+    integer           :: i
+    character(len=10) :: formt
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'   
+    endif
+
+    call xml_NewElement(xf, 'lattice')
+    if (present(id)) call xml_AddAttribute(xf, 'id', id)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(conv)) call xml_AddAttribute(xf, 'convention', conv)
+    if (present(lattType)) call xml_AddAttribute(xf, 'latticeType', lattType)
+    if (present(spaceType)) call xml_AddAttribute(xf, 'spaceType', spaceType)
+
+    do i = 1,3
+       call xml_NewElement(xf, 'latticeVector')
+       if (present(units)) call xml_AddAttribute(xf, 'units', units)
+       call xml_AddAttribute(xf, 'dictRef', 'cml:latticeVector')
+       call xml_AddPcdata(xf, str(cell(1,i), formt))
+       call xml_AddPcdata(xf, str(cell(2,i), formt))
+       call xml_AddPcdata(xf, str(cell(3,i), formt))
+       call xml_EndElement(xf, 'latticeVector')
+    enddo
+    
+    call xml_EndElement(xf, 'lattice')
+
+  END SUBROUTINE cmlAddLatticeDP
+
+
+  ! -------------------------------------------------
+  ! 1. creates a DP Lattice Vector element
+  ! -------------------------------------------------
+  
+  SUBROUTINE cmlAddLatticeVectorDP(xf, vector, title, id, dictref, conv, units, periodic, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=dp), intent(in) :: vector(3)
+    character(len=*), intent(in), optional :: title        
+    character(len=*), intent(in), optional :: id           
+    character(len=*), intent(in), optional :: dictref     
+    character(len=*), intent(in), optional :: conv        
+    character(len=*), intent(in), optional :: units       
+    character(len=*), intent(in), optional :: periodic    
+    character(len=*), intent(in), optional :: fmt         
+
+    ! Deal with optional things
+    ! that have defaults
+    character(len=10) :: formt
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'   
+    endif
+
+    call xml_NewElement(xf, 'latticeVector')
+    if (present(id)) call xml_AddAttribute(xf, 'id', id)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(conv)) call xml_AddAttribute(xf, 'convention', conv)
+    if (present(units)) call xml_AddAttribute(xf, 'units', units)
+    if (present(periodic)) call xml_AddAttribute(xf, 'periodic', periodic)
+    call xml_AddPcdata(xf, str(vector(1), formt))
+    call xml_AddPcdata(xf, str(vector(2), formt))
+    call xml_AddPcdata(xf, str(vector(3), formt))
+    call xml_EndElement(xf, 'latticeVector')
+
+  END SUBROUTINE cmlAddLatticeVectorDP
+
+
+  ! -------------------------------------------------
+  ! 2. creates a SP Lattice Vector element
+  ! -------------------------------------------------
+
+  SUBROUTINE cmlAddLatticeVectorSP(xf, vector, title, id, dictref, conv, units, periodic, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=sp), intent(in) :: vector(3)
+    character(len=*), intent(in), optional :: title        
+    character(len=*), intent(in), optional :: id           
+    character(len=*), intent(in), optional :: dictref     
+    character(len=*), intent(in), optional :: conv        
+    character(len=*), intent(in), optional :: units       ! should this be optional
+    character(len=*), intent(in), optional :: periodic    
+    character(len=*), intent(in), optional :: fmt         
+
+    ! Deal with optional things
+    ! that have defaults
+    character(len=10) :: formt
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'   
+    endif
+
+    call xml_NewElement(xf, 'latticeVector')
+    if (present(id)) call xml_AddAttribute(xf, 'id', id)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(conv)) call xml_AddAttribute(xf, 'convention', conv)
+    if (present(units)) call xml_AddAttribute(xf, 'units', units)
+    if (present(units)) call xml_AddAttribute(xf, 'periodic', periodic)
+    call xml_AddPcdata(xf, str(vector(1), formt))
+    call xml_AddPcdata(xf, str(vector(2), formt))
+    call xml_AddPcdata(xf, str(vector(3), formt))
+    call xml_EndElement(xf, 'latticeVector')
+
+  END SUBROUTINE cmlAddLatticeVectorSP
+
+  ! -------------------------------------------------
+  ! 1. creates and writes a DP <cell> element
+  ! -------------------------------------------------
+
+  SUBROUTINE cmlAddCrystalDP(xf, a, b, c, alpha, beta, gamma, id, title, dictref, lenunits, angunits, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=dp), intent(in)               :: a, b, c      ! cell parameters
+    real(kind=dp), intent(in)               :: alpha        ! alpha cell parameter
+    real(kind=dp), intent(in)               :: beta         ! beta cell parameter
+    real(kind=dp), intent(in)               :: gamma        ! gamma cell parameter
+    character(len=*), intent(in), optional :: id           ! id
+    character(len=*), intent(in), optional :: title        ! title
+    character(len=*), intent(in), optional :: dictref      ! dictref
+    character(len=*), intent(in), optional :: lenunits     ! units for length (default = angstrom)
+    character(len=*), intent(in), optional :: angunits     ! units for angles (default = degree)
+    character(len=*), intent(in), optional :: fmt          ! format
+
+    ! Flush on entry and exit
+    character(len=30) ::  lunits, aunits
+    character(len=10) :: formt
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+    if (present(lenunits)) then
+       lunits = lenunits
+    else
+       lunits = 'units:angstrom'
+    endif
+    if (present(angunits)) then
+       aunits = angunits
+    else
+       aunits = 'units:degree'
+    endif
+
+    call stmAddStartTag(xf=xf, name='crystal', id=id, title=title, dictref=dictref)
+    call stmAddScalar(xf=xf, value=a, title='a', dictref='cml:a', units=lunits, fmt=formt)
+    call stmAddScalar(xf=xf, value=b, title='b', dictref='cml:b', units=lunits, fmt=formt)
+    call stmAddScalar(xf=xf, value=c, title='c', dictref='cml:c', units=lunits, fmt=formt)
+    call stmAddScalar(xf=xf, value=alpha, title='alpha', dictref='cml:alpha', units=aunits, fmt=formt)
+    call stmAddScalar(xf=xf, value=beta,  title='beta',  dictref='cml:beta',  units=aunits, fmt=formt)
+    call stmAddScalar(xf=xf, value=gamma, title='gamma', dictref='cml:gamma', units=aunits, fmt=formt)
+    call xml_EndElement(xf, 'crystal')
+
+  END SUBROUTINE cmlAddCrystalDP
+
+  ! -------------------------------------------------
+  ! 2. creates and writes a SP <cell> element
+  ! -------------------------------------------------
+
+  SUBROUTINE cmlAddCrystalSP(xf, a, b, c, alpha, beta, gamma, id, title, dictref, lenunits, angunits, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=sp), intent(in)     :: a, b, c      ! cell parameters
+    real(kind=sp), intent(in)     :: alpha        ! alpha cell parameter
+    real(kind=sp), intent(in)     :: beta         ! beta cell parameter
+    real(kind=sp), intent(in)     :: gamma        ! gamma cell parameter
+    character(len=*), intent(in), optional :: id           ! id
+    character(len=*), intent(in), optional :: title        ! title
+    character(len=*), intent(in), optional :: dictref      ! dictref
+    character(len=*), intent(in), optional :: lenunits     ! units for length (' ' = angstrom)
+    character(len=*), intent(in), optional :: angunits     ! units for angles (' ' = degree)
+    character(len=*), intent(in), optional :: fmt          ! format
+
+    ! Flush on entry and exit
+    character(len=30) :: lunits, aunits
+    character(len=10) :: formt
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+    if (present(lenunits)) then
+       lunits = lenunits
+    else
+       lunits = U_ANGSTR
+    endif
+    if (present(angunits)) then
+       aunits = angunits
+    else
+       aunits = U_DEGREE
+    endif
+
+    call stmAddStartTag(xf, 'crystal', id, title, dictref)
+    call stmAddScalar(xf, a, ' ', 'a', 'cml:a', lunits, formt)
+    call stmAddScalar(xf, b, ' ', 'b', 'cml:b', lunits, formt)
+    call stmAddScalar(xf, c, ' ', 'c', 'cml:c', lunits, formt)
+    call stmAddScalar(xf, alpha, ' ', 'alpha', 'cml:alpha', aunits, formt)
+    call stmAddScalar(xf, beta, ' ', 'beta', 'cml:beta', aunits, formt)
+    call stmAddScalar(xf, gamma, ' ', 'gamma', 'cml:gamma', aunits, formt)
+    call xml_EndElement(xf, 'crystal')
+
+  END SUBROUTINE cmlAddCrystalSP
+  
+  
+  ! -------------------------------------------------
+  ! 1. creates and writes an DP <eigen> element
+  ! -------------------------------------------------
+  
+  SUBROUTINE cmlAddEigenvalueDP(xf, n, dim, eigvec, eigval, id, title, dictref, fmt)
+
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in)          :: n              ! number of elements
+    integer, intent(in)          :: dim            ! dimension of matrix
+    real(kind=dp), intent(in)     :: eigvec(dim, *) ! eigenvectors
+    real(kind=dp), intent(in)     :: eigval(*)      ! eigenvalues
+    character(len=*), intent(in), optional :: id             ! id
+    character(len=*), intent(in), optional :: title          ! title
+    character(len=*), intent(in), optional :: dictref        ! dictionary reference
+    character(len=*), intent(in), optional :: fmt            ! format
+    character(len=10):: formt
+    integer ::  i, j
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+
+    ! Flush on entry and exit
+    call xml_NewElement(xf, 'eigen')
+    if (present(id))      call xml_AddAttribute(xf, 'id', id)
+    if (present(title))   call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(dictref)) call xml_AddAttribute(xf, 'title', title)
+    call stmAddArray(xf=xf, nvalue=n, array=eigval, title='eigenvalues', dictref=dictRef, fmt=fmt)
+    call stmAddMatrix(xf=xf, ncols=n, nrows=n, dim=dim, matrix=eigvec, title='eigenvectors', fmt=fmt)
+    call xml_EndElement(xf, 'eigen')
+
+  END SUBROUTINE cmlAddEigenvalueDP
+
+
+
+  ! -------------------------------------------------
+  ! 2. creates and writes an SP <eigen> element
+  ! -------------------------------------------------
+  
+  SUBROUTINE cmlAddEigenvalueSP(xf, n, dim, eigvec, eigval, id, title, dictref, fmt)
+
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in)          :: n              ! number of elements
+    integer, intent(in)          :: dim            ! dimension of matrix
+    real(kind=sp), intent(in)     :: eigvec(dim, *) ! eigenvectors
+    real(kind=sp), intent(in)     :: eigval(*)      ! eigenvalues
+    character(len=*), intent(in), optional :: id             ! id
+    character(len=*), intent(in), optional :: title          ! title
+    character(len=*), intent(in), optional :: dictref        ! dictionary reference
+    character(len=*), intent(in), optional :: fmt            ! format
+    character(len=10):: formt
+    integer ::  i, j
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+
+    ! Flush on entry and exit
+    call xml_NewElement(xf, 'eigen')
+    if (present(id))      call xml_AddAttribute(xf, 'id', id)
+    if (present(title))   call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(dictref)) call xml_AddAttribute(xf, 'title', title)
+    call stmAddArray(xf=xf, nvalue=n, array=eigval, title='eigenvalues', dictref=dictRef, fmt=fmt)
+    call stmAddMatrix(xf=xf, ncols=n, nrows=n, dim=dim, matrix=eigvec, title='eigenvectors', fmt=fmt)
+    call xml_EndElement(xf, 'eigen')
+
+  END SUBROUTINE cmlAddEigenvalueSP
+
+
+  SUBROUTINE cmlAddMetadata(xf, name, content, conv)
+    
+    implicit none
+    type(xmlf_t) :: xf
+    character(len=*) :: name
+    character(len=*) :: content
+    character(len=*), optional :: conv
+    
+    call xml_NewElement(xf, 'metadata')
+    call xml_AddAttribute(xf, 'name', name)
+    call xml_AddAttribute(xf, 'content', content)
+    if (present(conv)) call xml_AddAttribute(xf, 'convention', conv)
+    call xml_EndElement(xf, 'metadata')
+
+  END SUBROUTINE cmlAddMetadata
+
+
+  ! -------------------------------------------------
+  ! 1. creates and writes an Char <parameter> element
+  ! -------------------------------------------------
+
+
+  SUBROUTINE cmlAddParameterCh(xf, value, ref, id, title, conv, &
+       cons, units, name, role)
+
+    implicit none
+    type(xmlf_t) :: xf
+    character(len=*) :: value 
+    character(len=*), optional :: ref 
+    character(len=*), optional :: title
+    character(len=*), optional :: id
+    character(len=*), optional :: conv
+    character(len=*), optional :: cons
+    character(len=*), optional :: units
+    character(len=*), optional :: name
+    character(len=*), optional :: role
+
+    call xml_NewElement(xf, 'parameter')
+    if (present(ref)) call xml_AddAttribute(xf, 'ref', ref)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(id)) call xml_AddAttribute(xf, 'id', id)
+    if (present(conv)) call xml_AddAttribute(xf, 'convention', conv)
+    if (present(cons)) call xml_AddAttribute(xf, 'constraint', cons)
+    if (present(name)) call xml_AddAttribute(xf, 'name', name)
+    if (present(role)) call xml_AddAttribute(xf, 'role', role)
+    if (present(units)) then
+       call xml_NewElement(xf, 'scalar')
+       call xml_AddAttribute(xf, 'units', units)
+       call xml_AddPcdata(xf, value)
+       call xml_EndElement(xf, 'scalar')
+    else
+       call xml_AddAttribute(xf, 'value', value)
+    endif
+    call xml_EndElement(xf, 'parameter')
+
+  END SUBROUTINE CMLADDPARAMETERCH
+
+
+  ! -------------------------------------------------
+  ! 2. creates and writes an SP <parameter> element
+  ! -------------------------------------------------
+
+
+  SUBROUTINE cmlAddParameterSP(xf, value, ref, title, id, conv, &
+       cons, units, name, role, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=sp) :: value 
+    character(len=*), optional :: ref 
+    character(len=*), optional :: title
+    character(len=*), optional :: id
+    character(len=*), optional :: conv
+    character(len=*), optional :: cons
+    character(len=*), optional :: units
+    character(len=*), optional :: name
+    character(len=*), optional :: role
+    character(len=*), optional :: fmt    
+
+    character(len=10) :: formt
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+
+    call xml_NewElement(xf, 'parameter')
+    if (present(ref)) call xml_AddAttribute(xf, 'ref', ref)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(id)) call xml_AddAttribute(xf, 'id', id)
+    if (present(conv)) call xml_AddAttribute(xf, 'convention', conv)
+    if (present(cons)) call xml_AddAttribute(xf, 'constraint', cons)
+    if (present(name)) call xml_AddAttribute(xf, 'name', name)
+    if (present(role)) call xml_AddAttribute(xf, 'role', role)
+    if (present(units)) then
+       call xml_NewElement(xf, 'scalar')
+       call xml_AddAttribute(xf, 'units', units)
+       call xml_AddPcdata(xf, str(value))
+       call xml_EndElement(xf, 'scalar')
+    else
+       call xml_AddAttribute(xf, 'value', str(value,formt))
+    endif
+    call xml_EndElement(xf, 'parameter')
+
+  END SUBROUTINE CMLADDPARAMETERSP
+
+
+  ! -------------------------------------------------
+  ! 3. creates and writes an DP <parameter> element
+  ! -------------------------------------------------
+
+
+  SUBROUTINE cmlAddParameterDP(xf, value, ref, title, id, conv, &
+       cons, units, name, role, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=dp) :: value 
+    character(len=*), optional :: ref 
+    character(len=*), optional :: title
+    character(len=*), optional :: id
+    character(len=*), optional :: conv
+    character(len=*), optional :: cons
+    character(len=*), optional :: units
+    character(len=*), optional :: name
+    character(len=*), optional :: role
+    character(len=*), optional :: fmt    
+
+    character(len=10) :: formt
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+
+    call xml_NewElement(xf, 'parameter')
+    if (present(ref)) call xml_AddAttribute(xf, 'ref', ref)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(id)) call xml_AddAttribute(xf, 'id', id)
+    if (present(conv)) call xml_AddAttribute(xf, 'convention', conv)
+    if (present(cons)) call xml_AddAttribute(xf, 'constraint', cons)
+    if (present(name)) call xml_AddAttribute(xf, 'name', name)
+    if (present(role)) call xml_AddAttribute(xf, 'role', role)
+    if (present(units)) then
+       call xml_NewElement(xf, 'scalar')
+       call xml_AddAttribute(xf, 'units', units)
+       call xml_AddPcdata(xf, str(value))
+       call xml_EndElement(xf, 'scalar')
+    else
+       call xml_AddAttribute(xf, 'value', str(value))
+    endif
+    call xml_EndElement(xf, 'parameter')
+
+  END SUBROUTINE CMLADDPARAMETERDP
+
+
+  ! -------------------------------------------------
+  ! 4. creates and writes an Integer <parameter> element
+  ! -------------------------------------------------
+
+
+  SUBROUTINE cmlAddParameterI(xf, value, ref, id, title, conv, &
+       cons, units, name, role)
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer :: value 
+    character(len=*), optional :: ref 
+    character(len=*), optional :: title
+    character(len=*), optional :: id
+    character(len=*), optional :: conv
+    character(len=*), optional :: cons
+    character(len=*), optional :: units
+    character(len=*), optional :: name
+    character(len=*), optional :: role
+
+    call xml_NewElement(xf, 'parameter')
+    if (present(ref)) call xml_AddAttribute(xf, 'ref', ref)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(id)) call xml_AddAttribute(xf, 'id', id)
+    if (present(conv)) call xml_AddAttribute(xf, 'convention', conv)
+    if (present(cons)) call xml_AddAttribute(xf, 'constraint', cons)
+    if (present(name)) call xml_AddAttribute(xf, 'name', name)
+    if (present(role)) call xml_AddAttribute(xf, 'role', role)
+    if (present(units)) then
+       call xml_NewElement(xf, 'scalar')
+       call xml_AddAttribute(xf, 'units', units)
+       call xml_AddPcdata(xf, str(value))
+       call xml_EndElement(xf, 'scalar')
+    else
+       call xml_AddAttribute(xf, 'value', str(value))
+    endif
+    call xml_EndElement(xf, 'parameter')
+
+  END SUBROUTINE CMLADDPARAMETERI
+
+  SUBROUTINE cmlAddParameterLG(xf, value, ref, id, title, conv, &
+       cons, units, name, role)
+
+    implicit none
+    type(xmlf_t) :: xf
+    logical      :: value 
+    character(len=*), optional :: ref 
+    character(len=*), optional :: title
+    character(len=*), optional :: id
+    character(len=*), optional :: conv
+    character(len=*), optional :: cons
+    character(len=*), optional :: units
+    character(len=*), optional :: name
+    character(len=*), optional :: role
+
+    call xml_NewElement(xf, 'parameter')
+    if (present(ref)) call xml_AddAttribute(xf, 'ref', ref)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(id)) call xml_AddAttribute(xf, 'id', id)
+    if (present(conv)) call xml_AddAttribute(xf, 'convention', conv)
+    if (present(cons)) call xml_AddAttribute(xf, 'constraint', cons)
+    if (present(name)) call xml_AddAttribute(xf, 'name', name)
+    if (present(role)) call xml_AddAttribute(xf, 'role', role)
+    if (present(units)) then
+       call xml_NewElement(xf, 'scalar')
+       call xml_AddAttribute(xf, 'units', units)
+       call xml_AddPcdata(xf, str(value))
+       call xml_EndElement(xf, 'scalar')
+    else
+       call xml_AddAttribute(xf, 'value', str(value))
+    endif
+    call xml_EndElement(xf, 'parameter')
+
+  END SUBROUTINE CMLADDPARAMETERLG
+
+
+
+! =================================================
+! basic CML routines
+! =================================================
+
+  
+  ! -------------------------------------------------
+  ! 1. adds DP xyz3 to start tag
+  ! -------------------------------------------------
+  
+  SUBROUTINE CMLATXYZ39DP(xf, x3, y3, z3, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=dp)      :: x3, y3, z3 ! coordinates
+    character(len=*)  :: fmt        ! format (default '(f8.3)')
+    character(len=45) :: x, y, z
+
+    write(x,fmt) x3
+    write(y,fmt) y3
+    write(z,fmt) z3
+
+    call xml_AddAttribute(xf, 'xyz3', trim(x)//' '//trim(adjustl(y))//' '//trim(adjustl(z)) )
+
+  END SUBROUTINE CMLATXYZ39DP
+
+
+  ! -------------------------------------------------
+  ! 2. adds SP xyz3 to start tag
+  ! -------------------------------------------------
+
+  SUBROUTINE CMLATXYZ39SP(xf, x3, y3, z3, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=sp)      :: x3, y3, z3 ! coordinates
+    character(len=*)  :: fmt        ! format (default '(f8.3)')
+
+    character(len=45) :: x, y, z
+
+    write(x,fmt) x3
+    write(y,fmt) y3
+    write(z,fmt) z3
+
+    call xml_AddAttribute(xf, 'xyz3', trim(x)//' '//trim(adjustl(y))//' '//trim(adjustl(z)) )
+
+  END SUBROUTINE CMLATXYZ39SP
+  
+  ! -------------------------------------------------
+  ! 1. adds DP xyzFrac to start tag
+  ! -------------------------------------------------
+  
+  SUBROUTINE CMLATXYZFRACT9DP(xf, x3, y3, z3, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=dp)      :: x3, y3, z3 ! coordinates
+    character(len=*)  :: fmt        ! format (default '(f8.3)')
+
+    character(len=45) :: x, y, z
+
+    write(x,fmt) x3
+    write(y,fmt) y3
+    write(z,fmt) z3
+
+    call xml_AddAttribute(xf, 'xyzFrac', trim(x)//' '//trim(adjustl(y))//' '//trim(adjustl(z)) )
+
+  END SUBROUTINE CMLATXYZFRACT9DP
+
+  ! -------------------------------------------------
+  ! 2. adds SP xyzFrac to start tag
+  ! -------------------------------------------------
+
+  SUBROUTINE CMLATXYZFRACT9SP(xf, x3, y3, z3, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=sp), intent(in)     :: x3, y3, z3 ! coordinates
+    character(len=*), intent(in) :: fmt        ! format (default '(f8.3)')
+
+    character(len=45) :: x, y, z
+
+    write(x,fmt) x3
+    write(y,fmt) y3
+    write(z,fmt) z3
+
+    call xml_AddAttribute(xf, 'xyzFrac', trim(x)//' '//trim(y)//' '//trim(z))
+
+  END SUBROUTINE CMLATXYZFRACT9SP
+
+
+  ! -------------------------------------------------
+  ! 1. adds DP x3, y3, z3 to start tag
+  ! -------------------------------------------------
+
+  SUBROUTINE CMLATX39DP(xf, x3, y3, z3, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=dp), intent(in)     :: x3, y3, z3 ! coordinates
+    character(len=*), intent(in) :: fmt        ! format (default '(f8.3)')
+
+    call xml_AddAttribute(xf, 'x3', str(x3, fmt))
+    call xml_AddAttribute(xf, 'y3', str(y3, fmt))
+    call xml_AddAttribute(xf, 'z3', str(z3, fmt))
+
+  END SUBROUTINE CMLATX39DP
+
+  ! -------------------------------------------------
+  ! 2. adds SP x3, y3, z3 to start tag
+  ! -------------------------------------------------
+
+  SUBROUTINE CMLATX39SP(xf, x3, y3, z3, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=sp), intent(in)     :: x3, y3, z3 ! coordinates
+    character(len=*), intent(in) :: fmt        ! format (default '(f8.3)')
+
+    call xml_AddAttribute(xf, 'x3', str(x3, fmt))
+    call xml_AddAttribute(xf, 'y3', str(y3, fmt))
+    call xml_AddAttribute(xf, 'z3', str(z3, fmt))
+
+  END SUBROUTINE CMLATX39SP
+
+
+  ! -------------------------------------------------
+  ! 1. adds DP xFract, yFract, zFract to start tag
+  ! -------------------------------------------------
+
+  SUBROUTINE CMLATXF9DP(xf, xFract, yFract, zFract, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=dp), intent(in)     :: xFract, yFract, zFract ! coordinates
+    character(len=*), intent(in) :: fmt                    ! format (default '(f8.3)')
+
+    call xml_AddAttribute(xf, 'xFract', str(xFract, fmt))
+    call xml_AddAttribute(xf, 'yFract', str(yFract, fmt))
+    call xml_AddAttribute(xf, 'zFract', str(zFract, fmt))
+
+  END SUBROUTINE CMLATXF9DP
+  
+  ! -------------------------------------------------
+  ! 2. adds SP xfrac, yFractractrac, zFractrac to start tag
+  ! -------------------------------------------------
+  
+  SUBROUTINE CMLATXF9SP(xf, xFract, yFract, zFract, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=sp)     :: xFract, yFract, zFract   ! fractional coordinates
+    character(len=*) :: fmt                      ! format (default '(f8.3)')
+
+    call xml_AddAttribute(xf, 'xFract', str(xFract, fmt))
+    call xml_AddAttribute(xf, 'yFract', str(yFract, fmt))
+    call xml_AddAttribute(xf, 'zFract', str(zFract, fmt))
+
+  END SUBROUTINE CMLATXF9SP
+
+
+  ! -------------------------------------------------
+  ! 1. adds DP x2, y2 to start tag
+  ! -------------------------------------------------
+
+  SUBROUTINE CMLATXY9DP(xf, x2, y2, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=dp)     :: x2, y2   ! coordinates
+    character(len=*) :: fmt      ! format (default f8.3)
+
+    call xml_AddAttribute(xf, 'x2', str(x2, fmt))
+    call xml_AddAttribute(xf, 'y2', str(y2, fmt))
+    call xml_AddPcdata(xf, '>')                   !!! AG****
+
+  END SUBROUTINE CMLATXY9DP
+
+  ! -------------------------------------------------
+  ! 2. adds SP x2, y2 to start tag
+  ! -------------------------------------------------
+
+  SUBROUTINE CMLATXY9SP(xf, x2, y2, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=sp)     :: x2, y2   ! coordinates
+    character(len=*) :: fmt      ! format (default f8.3)
+
+    call xml_AddAttribute(xf, 'x2', str(x2, fmt))
+    call xml_AddAttribute(xf, 'y2', str(y2, fmt))
+    call xml_AddPcdata(xf, '>')                      !!AG***
+
+  END SUBROUTINE CMLATXY9SP
+
+
+  ! -------------------------------------------------
+  ! 1. creates a DP <length> element
+  ! -------------------------------------------------
+
+  SUBROUTINE CMLLEN9DP(xf, id, atomRef1, atomRef2, length, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    character(len=*) :: id           ! length id
+    character(len=*) :: atomRef1     ! ref to first atom
+    character(len=*) :: atomRef2     ! ref to second atom
+    real(kind=dp)     :: length       ! the length
+    character(len=*) :: fmt          ! format
+    character(len=20) :: temp
+
+    temp = atomRef1//' '//adjustl(atomRef2)
+
+    call xml_NewElement(xf, 'length')
+    call xml_AddAttribute(xf, 'id', id)
+    call xml_AddAttribute(xf, 'atomRefs2', temp)
+    call xml_AddPcdata(xf, str(length, fmt))
+    call xml_EndElement(xf, 'length')
+
+  END SUBROUTINE CMLLEN9DP
+  
+  ! -------------------------------------------------
+  ! 2. creates a SP <length> element
+  ! -------------------------------------------------
+  
+  SUBROUTINE CMLLEN9SP(xf, id, atomRef1, atomRef2, length, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    character(len=*) :: id           ! length id
+    character(len=*) :: atomRef1     ! ref to first atom
+    character(len=*) :: atomRef2     ! ref to second atom
+    real(kind=sp)     :: length       ! the length
+    character(len=*) :: fmt          ! format
+    character(len=20) :: temp
+
+    temp = atomRef1//' '//adjustl(atomRef2)
+
+    call xml_NewElement(xf, 'length')
+    call xml_AddAttribute(xf, 'id', id)
+    call xml_AddAttribute(xf, 'atomRefs2', temp)
+    call xml_AddPcdata(xf, str(length, fmt))
+    call xml_EndElement(xf, 'length')
+
+  END SUBROUTINE CMLLEN9SP
+
+
+  ! -------------------------------------------------
+  ! 1. creates a DP <angle> element
+  ! -------------------------------------------------
+
+  SUBROUTINE CMLANG9DP(xf, id, atomRef1, atomRef2, atomRef3, angle, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    character(len=*) :: id              ! angle id
+    character(len=*) :: atomRef1        ! ref to first atom
+    character(len=*) :: atomRef2        ! ref to second atom
+    character(len=*) :: atomRef3        ! ref to third atom
+    real(kind=dp)     :: angle           ! the angle
+    character(len=*) :: fmt             ! format
+    character(len=20) :: temp
+
+    temp = atomRef1//' '//adjustl(atomRef2)//' '//adjustl(atomRef3)
+
+    call xml_NewElement(xf, 'angle')
+    call xml_AddAttribute(xf, 'id', id)
+    call xml_AddAttribute(xf, 'atomRefs3', temp)
+    call xml_AddPcdata(xf, str(angle, fmt))
+    call xml_EndElement(xf, 'angle')
+
+  END SUBROUTINE CMLANG9DP
+
+  ! -------------------------------------------------
+  ! 2. creates a SP <angle> element
+  ! -------------------------------------------------
+
+  SUBROUTINE CMLANG9SP(xf, id, atomRef1, atomRef2, atomRef3, angle, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    character(len=*) :: id              ! angle id
+    character(len=*) :: atomRef1        ! ref to first atom
+    character(len=*) :: atomRef2        ! ref to second atom
+    character(len=*) :: atomRef3        ! ref to third atom
+    real(kind=sp)     :: angle           ! the angle
+    character(len=*) :: fmt             ! format
+    character(len=20) :: temp
+
+    temp = atomRef1//' '//adjustl(atomRef2)//' '//adjustl(atomRef3)
+
+    call xml_NewElement(xf, 'angle')
+    call xml_AddAttribute(xf, 'id', id)
+    call xml_AddAttribute(xf, 'atomRefs3', temp)
+    call xml_AddPcdata(xf, str(angle, fmt))
+    call xml_EndElement(xf, 'angle')
+
+  END SUBROUTINE CMLANG9SP
+
+
+  ! -------------------------------------------------
+  ! 1. creates a DP <torsion> element
+  ! -------------------------------------------------
+  
+  SUBROUTINE CMLTOR9DP(xf, id, atomRef1, atomRef2, atomRef3, atomRef4, torsion, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    character(len=*) :: id              ! torsion id
+    character(len=*) :: atomRef1        ! ref to first atom
+    character(len=*) :: atomRef2        ! ref to second atom
+    character(len=*) :: atomRef3        ! ref to third atom
+    character(len=*) :: atomRef4        ! ref to fourth atom
+    real(kind=dp)     :: torsion         ! the torsion
+    character(len=*) :: fmt             ! format
+    character(len=20) :: temp
+
+    temp = atomRef1//' '//adjustl(atomRef2)//' '//adjustl(atomRef3)//' '//adjustl(atomRef4)
+
+    call xml_NewElement(xf, 'torsion')
+    call xml_AddAttribute(xf, 'id', id)
+    call xml_AddAttribute(xf, 'atomRefs4', temp)
+    call xml_AddPcdata(xf, str(torsion, fmt))
+    call xml_EndElement(xf, 'torsion')
+
+  END SUBROUTINE CMLTOR9DP
+
+  ! -------------------------------------------------
+  ! 2. creates a SP <torsion> element
+  ! -------------------------------------------------
+
+  SUBROUTINE CMLTOR9SP(xf, id, atomRef1, atomRef2, atomRef3, atomRef4, torsion, fmt)
+    implicit none
+    type(xmlf_t) :: xf
+    character(len=*) :: id              ! torsion id
+    character(len=*) :: atomRef1        ! ref to first atom
+    character(len=*) :: atomRef2        ! ref to second atom
+    character(len=*) :: atomRef3        ! ref to third atom
+    character(len=*) :: atomRef4        ! ref to fourth atom
+    real(kind=sp)     :: torsion         ! the torsion
+    character(len=*) :: fmt             ! format
+    character(len=20) :: temp
+
+    temp = atomRef1//' '//adjustl(atomRef2)//' '//adjustl(atomRef3)//' '//adjustl(atomRef4)
+
+    call xml_NewElement(xf, 'torsion')
+    call xml_AddAttribute(xf, 'id', id)
+    call xml_AddAttribute(xf, 'atomRefs4', temp)
+    call xml_AddPcdata(xf, str(torsion, fmt))
+    call xml_EndElement(xf, 'torsion')
+
+  END SUBROUTINE CMLTOR9SP
+
+end module m_cmlw
Index: vendors/XMLF90/current/src/cml/m_stmw.f90
===================================================================
--- vendors/XMLF90/current/src/cml/m_stmw.f90	(revision 1899)
+++ vendors/XMLF90/current/src/cml/m_stmw.f90	(revision 1899)
@@ -0,0 +1,875 @@
+module m_stmw
+
+  use flib_wxml
+
+  private
+
+  integer, private, parameter ::  sp = selected_real_kind(6,30)
+  integer, private, parameter ::  dp = selected_real_kind(14,100)
+
+!  TYPE(xmlf_t), save,  :: xf
+
+  PUBLIC :: stmAddScalar
+  PUBLIC :: stmAddArray
+  PUBLIC :: stmAddMatrix
+  PUBLIC :: stmAddTriangle
+  PUBLIC :: stmAddStartTag
+
+  INTERFACE stmAddScalar
+     MODULE PROCEDURE stmAddString, stmAddInteger, stmAddFloatSP, stmAddFloatDP
+  END INTERFACE
+
+  INTERFACE stmAddArray
+     MODULE PROCEDURE stmAddFloatArraySP, stmAddFloatArrayDP, stmAddStringArray, &
+                      stmAddIntegerArray
+  END INTERFACE
+
+  INTERFACE stmAddMatrix
+     MODULE PROCEDURE stmAddFloatMatrixSP, stmAddFloatMatrixDP, stmAddIntegerMatrix
+  END INTERFACE
+
+  INTERFACE stmAddTriangle
+     MODULE PROCEDURE stmAddTriangleSP, stmAddTriangleDP
+  END INTERFACE
+
+ 
+CONTAINS
+  
+  
+  ! =================================================
+  ! STMML convenience routines
+  ! =================================================
+  
+  ! -------------------------------------------------
+  ! create STMML start tag in xml channel
+  ! -------------------------------------------------
+  
+  SUBROUTINE stmAddStartTag(xf, name, id, title, dictref, dataType, &
+       convention, errorValue, errorBasis, min, max, units)
+
+    implicit none
+    type(xmlf_t) :: xf
+    character(len=*), intent(in) :: name                   ! the element name
+    character(len=*), intent(in), optional :: id           ! the element id; if whitespace, is omitted
+    character(len=*), intent(in), optional :: title        ! the title; if whitespace, is omitted
+    character(len=*), intent(in), optional :: dictref      ! the dictionary reference; if whitespace, is omitted
+    character(len=*), intent(in), optional :: dataType  
+    character(len=*), intent(in), optional :: convention
+    character(len=*), intent(in), optional :: errorValue
+    character(len=*), intent(in), optional :: errorBasis
+    character(len=*), intent(in), optional :: min
+    character(len=*), intent(in), optional :: max
+    character(len=*), intent(in), optional :: units
+
+!    call XMLCHKN9(name)
+    call xml_NewElement(xf, name)
+    if (present(id))         call xml_AddAttribute(xf, 'id', id)
+    if (present(title))      call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref))    call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(dataType))   call xml_AddAttribute(xf, 'dataType', dataType)
+    if (present(convention)) call xml_AddAttribute(xf, 'convention', convention)
+    if (present(errorValue)) call xml_AddAttribute(xf, 'errorValue', errorValue)
+    if (present(errorBasis)) call xml_AddAttribute(xf, 'errorBasis', errorBasis)
+    if (present(min))        call xml_AddAttribute(xf, 'min', min)
+    if (present(max))        call xml_AddAttribute(xf, 'max', max)
+    if (present(units))      call xml_AddAttribute(xf, 'units', units)
+
+  END SUBROUTINE stmAddStartTag
+
+
+  ! -------------------------------------------------
+  ! outputs STMML scalar in xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE stmAddString(xf, value, id, title, dictref, dataType, &
+       convention, errorValue, errorBasis, min, max, units)
+
+    implicit none
+    type(xmlf_t) :: xf
+    character(len=*), intent(in)           :: value         ! the value to be output
+    character(len=*), intent(in), optional :: id            ! the id
+    character(len=*), intent(in), optional :: title         ! the title
+    character(len=*), intent(in), optional :: dictref       ! the dictionary reference
+    character(len=*), intent(in), optional :: dataType  
+    character(len=*), intent(in), optional :: convention
+    character(len=*), intent(in), optional :: errorValue
+    character(len=*), intent(in), optional :: errorBasis
+    character(len=*), intent(in), optional :: min
+    character(len=*), intent(in), optional :: max
+    character(len=*), intent(in), optional :: units
+
+    ! Internal variables
+    character(len=20) :: temp
+
+!    if (XMLCHKS9(value)) then
+    call xml_AddPcdata(xf, ' '//value)
+
+    call xml_NewElement(xf, 'scalar')
+    if (present(id))         call xml_AddAttribute(xf, 'id', id)
+    if (present(title))      call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref))    call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(dataType))   call xml_AddAttribute(xf, 'dataType', dataType)
+    if (present(convention)) call xml_AddAttribute(xf, 'convention', convention)
+    if (present(errorValue)) call xml_AddAttribute(xf, 'errorValue', errorValue)
+    if (present(errorBasis)) call xml_AddAttribute(xf, 'errorBasis', errorBasis)
+    if (present(min))        call xml_AddAttribute(xf, 'min', min)
+    if (present(max))        call xml_AddAttribute(xf, 'max', max)
+    if (present(units))      call xml_AddAttribute(xf, 'units', units)
+    call xml_EndElement(xf, 'scalar')
+
+  END SUBROUTINE stmAddString
+
+
+  ! -------------------------------------------------
+  ! outputs STMML integer in xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE stmAddInteger(xf, value, id, title, dictref, dataType, &
+       convention, errorValue, errorBasis, min, max, units)
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in) :: value                           ! the value to be output
+    character(len=*), intent(in), optional :: id           ! the id
+    character(len=*), intent(in), optional :: title        ! the title
+    character(len=*), intent(in), optional :: dictref      ! the dictionary reference
+    character(len=*), intent(in), optional :: dataType  
+    character(len=*), intent(in), optional :: convention
+    character(len=*), intent(in), optional :: errorValue
+    character(len=*), intent(in), optional :: errorBasis
+    character(len=*), intent(in), optional :: min
+    character(len=*), intent(in), optional :: max
+    character(len=*), intent(in), optional :: units        ! units (default = none)
+
+
+    ! Flush on entry and exit
+    call xml_NewElement(xf, 'scalar')
+    if (present(id))         call xml_AddAttribute(xf, 'id', id)
+    if (present(title))      call xml_AddAttribute(xf, 'dictRef', title)
+    if (present(dictref))    call xml_AddAttribute(xf, 'title', dictref)
+    if (present(dataType))   call xml_AddAttribute(xf, 'dataType', dataType)
+    if (present(convention)) call xml_AddAttribute(xf, 'convention', convention)
+    if (present(errorValue)) call xml_AddAttribute(xf, 'errorValue', errorValue)
+    if (present(errorBasis)) call xml_AddAttribute(xf, 'errorBasis', errorBasis)
+    if (present(min))        call xml_AddAttribute(xf, 'min', min)
+    if (present(max))        call xml_AddAttribute(xf, 'max', max)
+    if (present(units))      call xml_AddAttribute(xf, 'units', units)
+    call xml_AddPcdata(xf, str(value))
+    call xml_EndElement(xf, 'scalar')
+
+  END SUBROUTINE stmAddInteger
+
+
+  ! -------------------------------------------------
+  ! 1. create an STMML <scalar> DP float in xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE stmAddFloatDP(xf, value, id, title, dictref, dataType, &
+       convention, errorValue, errorBasis, min, max, units, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=dp), intent(in)               :: value        ! the value to be output
+    character(len=*), intent(in), optional :: id           ! id
+    character(len=*), intent(in), optional :: title        ! the title
+    character(len=*), intent(in), optional :: dictref      ! the dictionary reference
+    character(len=*), intent(in), optional :: dataType  
+    character(len=*), intent(in), optional :: convention
+    character(len=*), intent(in), optional :: errorValue
+    character(len=*), intent(in), optional :: errorBasis
+    character(len=*), intent(in), optional :: min
+    character(len=*), intent(in), optional :: max
+    character(len=*), intent(in), optional :: units        ! units
+    character(len=*), intent(in), optional :: fmt          ! the format (default 'f10.4')
+
+    ! Internal Vaiable
+    character(len=10) :: formt
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f10.4)'
+    endif
+
+
+    ! Flushes on entry and exit
+    call xml_NewElement(xf, 'scalar')
+    if (present(id))         call xml_AddAttribute(xf, 'id', id)
+    if (present(title))      call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref))    call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(dataType))   call xml_AddAttribute(xf, 'dataType', dataType)
+    if (present(convention)) call xml_AddAttribute(xf, 'convention', convention)
+    if (present(errorValue)) call xml_AddAttribute(xf, 'errorValue', errorValue)
+    if (present(errorBasis)) call xml_AddAttribute(xf, 'errorBasis', errorBasis)
+    if (present(min))        call xml_AddAttribute(xf, 'min', min)
+    if (present(max))        call xml_AddAttribute(xf, 'max', max)
+    if (present(units))      call xml_AddAttribute(xf, 'units', units)
+
+    call xml_AddPcdata(xf, str(value))
+    call xml_EndElement(xf, 'scalar')
+
+  END SUBROUTINE stmAddFloatDP
+
+  ! -------------------------------------------------
+  ! 2. create an STMML <scalar> SP float in xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE stmAddFloatSP(xf, value, id, title, dictref, dataType, &
+       convention, errorValue, errorBasis, min, max, units, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    real(kind=sp), intent(in)               :: value        ! the value to be output
+    character(len=*), intent(in), optional :: id           ! id
+    character(len=*), intent(in), optional :: title        ! the title
+    character(len=*), intent(in), optional :: dictref      ! the dictionary reference
+    character(len=*), intent(in), optional :: units        ! units (' ' = none)
+    character(len=*), intent(in), optional :: dataType  
+    character(len=*), intent(in), optional :: convention
+    character(len=*), intent(in), optional :: errorValue
+    character(len=*), intent(in), optional :: errorBasis
+    character(len=*), intent(in), optional :: min
+    character(len=*), intent(in), optional :: max
+    character(len=*), intent(in), optional :: fmt          ! the format (default 'f10.4')
+
+    ! Internal Variable
+    character(len=10) :: formt
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f10.4)'
+    endif
+
+    ! Flushes on entry and exit
+    call xml_NewElement(xf, 'scalar')
+    if (present(id))         call xml_AddAttribute(xf, 'id', id)
+    if (present(title))      call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(dictref))    call xml_AddAttribute(xf, 'title', title)
+    if (present(dataType))   call xml_AddAttribute(xf, 'dataType', dataType)
+    if (present(convention)) call xml_AddAttribute(xf, 'convention', convention)
+    if (present(errorValue)) call xml_AddAttribute(xf, 'errorValue', errorValue)
+    if (present(errorBasis)) call xml_AddAttribute(xf, 'errorBasis', errorBasis)
+    if (present(min))        call xml_AddAttribute(xf, 'min', min)
+    if (present(max))        call xml_AddAttribute(xf, 'max', max)
+    if (present(units))      call xml_AddAttribute(xf, 'units', units)
+    call xml_AddPcdata(xf, str(value))
+    call xml_EndElement(xf, 'scalar')
+
+  END SUBROUTINE stmAddFloatSP
+
+
+  ! -------------------------------------------------
+  ! outputs string array to xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE stmAddStringArray(xf, nvalue, array, id, title, dictref, type, delim, ref)
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in)                    :: nvalue        ! number of values to be output
+    character(len=*), intent(in)           :: array(*)      ! the values to be output
+    character(len=*), intent(in), optional :: id            ! the id
+    character(len=*), intent(in), optional :: title         ! the title
+    character(len=*), intent(in), optional :: dictref       ! the dictionary reference
+    character(len=*), intent(in), optional :: type          ! the dataType
+    character(len=*), intent(in), optional :: delim         ! delimiter
+    character(len=*), intent(in), optional :: ref           ! delimiter
+
+    ! splits data into lines whenever it overflows workspace/linelength
+    ! Flush on entry and exit
+    character(len=1) :: delim1
+    integer          :: i
+
+
+    if (present(delim)) then
+       delim1 = delim
+    else
+       delim1 = ' '
+    endif
+
+    call xml_NewElement(xf, 'array')
+    if (present(id))      call xml_AddAttribute(xf, 'id', id)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(title))   call xml_AddAttribute(xf, 'title', title)
+    if (present(type))    call xml_AddAttribute(xf, 'type', type)
+    if (present(ref))     call xml_AddAttribute(xf, 'ref', ref)
+    call xml_AddAttribute(xf, 'delimiter', delim1)
+    call xml_AddAttribute(xf, 'size', str(nvalue))
+
+    call xml_AddPcdata(xf, array(1))
+    do i = 2, nvalue
+       if (delim1 .eq. ' ') then
+          call xml_AddPcdata(xf, ' '//array(i))
+       else
+          call xml_AddPcdata(xf, delim1//array(i))
+       endif
+    enddo
+    call xml_EndElement(xf, 'array')
+
+  END SUBROUTINE stmAddStringArray
+
+
+  ! -------------------------------------------------
+  ! outputs integer array to xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE stmAddIntegerArray(xf, nvalue, array, id, title, dictref, ref, units)
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in)                    :: nvalue        ! the number of values to be output
+    integer, intent(in)                    :: array(*)      ! the values to be output
+    character(len=*), intent(in), optional :: id            ! the id
+    character(len=*), intent(in), optional :: title         ! the title
+    character(len=*), intent(in), optional :: dictref       ! the dictionary reference
+    character(len=*), intent(in), optional :: units         ! scienitific units (default ' ')
+    character(len=*), intent(in), optional :: ref           ! scienitific units (default ' ')
+
+    ! splits data into lines wherever it overflows the workspace
+    integer          :: i
+
+    ! Flush on entry and exit
+
+    call xml_NewElement(xf, 'array')
+    if (present(id))      call xml_AddAttribute(xf, 'id', id)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(title))   call xml_AddAttribute(xf, 'title', title)
+    if (present(units))   call xml_AddAttribute(xf, 'units', units)
+    if (present(ref))     call xml_AddAttribute(xf, 'ref', ref)
+    call xml_AddAttribute(xf, 'size', str(nvalue))
+
+
+    call xml_AddPcdata(xf, str(array(1)))
+    do i = 2, nvalue
+       call xml_AddPcdata(xf, str(array(i)))
+    enddo
+    call xml_EndElement(xf, 'array')
+    
+  END SUBROUTINE stmAddIntegerArray
+
+
+  ! -------------------------------------------------
+  ! 1. outputs DP float array to xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE stmAddFloatArrayDP(xf, nvalue, array, id, title, dictref, units, ref, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in)                    :: nvalue        ! number of values to be output
+    real(kind=dp), intent(in)               :: array(*)       ! the values to be output
+    character(len=*), intent(in), optional :: id            ! the id
+    character(len=*), intent(in), optional :: title         ! the title
+    character(len=*), intent(in), optional :: dictref       ! the dictionary reference
+    character(len=*), intent(in), optional :: units         ! scienitific units (default ' ')
+    character(len=*), intent(in), optional :: ref           ! 
+    character(len=*), intent(in), optional :: fmt           ! the output format
+
+    ! Internal Variable
+    character(len=10) :: formt
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+
+    ! splits data into lines whenever it overflows workspace/linelength
+    ! Flush on entry and exit
+
+    call xml_NewElement(xf, 'array')
+    if (present(id))      call xml_AddAttribute(xf, 'id', id)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(title))   call xml_AddAttribute(xf, 'title', title)
+    if (present(units))   call xml_AddAttribute(xf, 'units', units)
+    if (present(ref))     call xml_AddAttribute(xf, 'ref', ref)
+    call xml_AddAttribute(xf, 'size', str(nvalue))
+    call STMARCF9DP(xf, nvalue, array, fmt)
+    call xml_EndElement(xf, 'array')
+
+  END SUBROUTINE stmAddFloatArrayDP
+
+  ! -------------------------------------------------
+  ! 2. outputs SP float array to xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE stmAddFloatArraySP(xf, nvalue, array, id, title, dictref, units, ref, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in)                    :: nvalue        ! number of values to be output
+    real(kind=sp), intent(in)               :: array(*)       ! the values to be output
+    character(len=*), intent(in), optional :: id            ! the id
+    character(len=*), intent(in), optional :: title         ! the title
+    character(len=*), intent(in), optional :: dictref       ! the dictionary reference
+    character(len=*), intent(in), optional :: units         ! scienitific units (default ' ')
+    character(len=*), intent(in), optional :: fmt           ! the output format
+    character(len=*), intent(in), optional :: ref           ! the output format
+
+    ! Internal Variable
+    character(len=10) :: formt
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+
+    ! splits data into lines whenever it overflows workspace/linelength
+    ! Flush on entry and exit
+
+    call xml_NewElement(xf, 'array')
+    if (present(id))      call xml_AddAttribute(xf, 'id', id)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(title))   call xml_AddAttribute(xf, 'title', title)
+    if (present(units))   call xml_AddAttribute(xf, 'units', units)
+    if (present(ref))     call xml_AddAttribute(xf, 'ref', ref)
+    call xml_AddAttribute(xf, 'size', str(nvalue))
+    call STMARCF9SP(xf, nvalue, array, fmt)
+    call xml_EndElement(xf, 'array')
+
+  END SUBROUTINE stmAddFloatArraySP
+
+
+  ! -------------------------------------------------
+  ! outputs integer matrix to xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE stmAddIntegerMatrix(xf, nrows, ncols, dim, matrix, id, title, dictref, units)
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in)                    :: nrows         ! the number of rows to be output
+    integer, intent(in)                    :: ncols         ! the number of rows to be output
+    integer, intent(in)                    :: dim           ! the range of the fastest index
+    integer, intent(in)                    :: matrix(nrows,ncols) ! the values to be output
+    character(len=*), intent(in), optional :: id            ! the id
+    character(len=*), intent(in), optional :: title         ! the title
+    character(len=*), intent(in), optional :: dictref       ! the dictionary reference
+    character(len=*), intent(in), optional :: units         ! scienitific units (default ' ')
+
+    ! splits data into lines wherever it overflows the workspace
+    ! Flush on entry and exit
+    integer ::  i, j
+
+
+
+    call xml_NewElement(xf, 'matrix')
+    if (present(id))      call xml_AddAttribute(xf, 'id', id)
+    if (present(dictref))   call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(units))   call xml_AddAttribute(xf, 'units', units)
+    call xml_AddAttribute(xf, 'cols', str(ncols))
+    call xml_AddAttribute(xf, 'rows', str(nrows))
+
+!
+!   Try addArray...
+!
+    do i = 1, ncols
+       do j = 1, nrows
+          call xml_AddPcdata(xf, str(matrix(j, i)))
+       enddo
+    enddo
+    call xml_EndElement(xf, 'matrix')
+
+  END SUBROUTINE stmAddIntegerMatrix
+
+
+  ! -------------------------------------------------
+  ! 1. outputs DP float matrix to xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE stmAddFloatMatrixDP(xf, ncols, nrows, dim, matrix, id, title, dictref, units, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in)                    :: ncols                ! the number of cols to be output
+    integer, intent(in)                    :: nrows                ! the number of rows to be output
+    integer, intent(in)                    :: dim                  ! the range of the fastest index
+    real(kind=dp), intent(in)               :: matrix(ncols,nrows)  ! the values to be output
+    character(len=*), intent(in), optional :: id                   ! the id
+    character(len=*), intent(in), optional :: title                ! the title
+    character(len=*), intent(in), optional :: dictref              ! the dictionary reference
+    character(len=*), intent(in), optional :: units                ! scienitific units (default ' ')
+    character(len=*), intent(in), optional :: fmt                  ! format
+
+    ! internal variable
+    character(len=10) :: formt
+    integer ::  i, j
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+
+    ! splits data into lines wherever it overflows the workspace
+    ! Flush on entry and exit      
+    !-------------
+    call xml_NewElement(xf, 'matrix')
+    if (present(id))      call xml_AddAttribute(xf, 'id', id)
+    if (present(title))   call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(units))   call xml_AddAttribute(xf, 'units', units)
+    call xml_AddAttribute(xf, 'cols', str(ncols))
+    call xml_AddAttribute(xf, 'rows', str(nrows))
+    !-------------
+    do i = 1, nrows
+       do j = 1, ncols
+          !              write(*,*) ">>> 1", i, j
+          call xml_AddPcdata(xf, str(matrix(j, i)))
+       enddo
+    enddo
+    call xml_EndElement(xf, 'matrix')
+
+  END SUBROUTINE stmAddFloatMatrixDP
+
+  ! -------------------------------------------------
+  ! 2. outputs SP float matrix to xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE stmAddFloatMatrixSP(xf, ncols, nrows, dim, matrix, id, title, dictref, units, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in)                    :: ncols               ! the number of cols to be output
+    integer, intent(in)                    :: nrows               ! the number of rows to be output
+    integer, intent(in)                    :: dim                 ! the range of the fastest index
+    real(kind=sp), intent(in)               :: matrix(ncols,nrows) ! the values to be output
+    character(len=*), intent(in), optional :: id                  ! the id
+    character(len=*), intent(in), optional :: title               ! the title
+    character(len=*), intent(in), optional :: dictref             ! the dictionary reference
+    character(len=*), intent(in), optional :: units               ! scienitific units (default ' ')
+    character(len=*), intent(in), optional :: fmt                 ! format
+
+    ! internal variable
+    character(len=10) :: formt
+    integer ::  i, j
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+
+    ! splits data into lines wherever it overflows the workspace
+    ! Flush on entry and exit      
+    !
+    call xml_NewElement(xf, 'matrix')
+    if (present(id))      call xml_AddAttribute(xf, 'id', id)
+    if (present(title))   call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(units))   call xml_AddAttribute(xf, 'units', units)
+    call xml_AddAttribute(xf, 'cols', str(ncols))
+    call xml_AddAttribute(xf, 'rows', str(nrows))
+    do i = 1, nrows
+       do j = 1, ncols
+          call xml_AddPcdata(xf, str(matrix(j, i)))
+       enddo
+    enddo
+    call xml_EndElement(xf, 'matrix')
+
+  END SUBROUTINE stmAddFloatMatrixSP
+
+
+  ! -------------------------------------------------
+  ! 1. outputs DP lower triangle array to xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE stmAddTriangleDP(xf, nvalue, array, id, title, dictref, units, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in)                    :: nvalue         ! number of values to be output
+    real(kind=dp), intent(in)               :: array(*)        ! the values to be output
+    character(len=*), intent(in), optional :: id             ! the id
+    character(len=*), intent(in), optional :: title          ! the title
+    character(len=*), intent(in), optional :: dictref        ! the dictionary reference
+    character(len=*), intent(in), optional :: units          ! units (' ' = none)
+    character(len=*), intent(in), optional :: fmt            ! the output format
+
+    ! splits data into lines whenever it overflows workspace/linelength
+    ! Flush on entry and exit
+    integer           :: size
+    character(len=10) :: formt
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+
+    size = (nvalue*(nvalue+1))/2
+    call xml_NewElement(xf, 'array')
+    call xml_AddAttribute(xf, 'size', str(size))
+    call xml_AddAttribute(xf, 'rows', str(nvalue))
+    if (present(id))      call xml_AddAttribute(xf, 'id', id)
+    if (present(title))   call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(units))   call xml_AddAttribute(xf, 'units', units)
+    call STMARCF9DP(xf, size, array, formt)
+    call xml_EndElement(xf, 'matrix')
+
+  END SUBROUTINE stmAddTriangleDP
+
+  ! -------------------------------------------------
+  ! 2. outputs SP lower triangle array to xml channel
+  ! -------------------------------------------------
+
+  SUBROUTINE stmAddTriangleSP(xf, nvalue, array, id, title, dictref, units, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in)                    :: nvalue         ! number of values to be output
+    real(kind=sp), intent(in)               :: array(*)        ! the values to be output
+    character(len=*), intent(in), optional :: id             ! the id
+    character(len=*), intent(in), optional :: title          ! the title
+    character(len=*), intent(in), optional :: dictref        ! the dictionary reference
+    character(len=*), intent(in), optional :: units          ! units (' ' = none)
+    character(len=*), intent(in), optional :: fmt            ! the output format
+
+    ! splits data into lines whenever it overflows workspace/linelength
+    ! Flush on entry and exit
+    integer           :: size
+    character(len=10) :: formt
+
+    if (present(fmt)) then
+       formt = fmt
+    else
+       formt = '(f8.3)'
+    endif
+
+    size = (nvalue*(nvalue+1))/2
+    call xml_NewElement(xf, 'array')
+    call xml_AddAttribute(xf, 'size', str(size))
+    call xml_AddAttribute(xf, 'rows', str(nvalue))
+    if (present(id))      call xml_AddAttribute(xf, 'id', id)
+    if (present(title))   call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(units))   call xml_AddAttribute(xf, 'units', units)
+    call STMARCF9SP(xf, size, array, formt)
+    call xml_EndElement(xf, 'matrix')
+
+  END SUBROUTINE stmAddTriangleSP
+
+
+  ! -------------------------------------------------
+  ! outputs fatal error message
+  ! -------------------------------------------------
+
+  SUBROUTINE stmErrorMessage(xf, msg, id, title, dictref)
+
+    implicit none
+    type(xmlf_t) :: xf
+    character(len=*), intent(in)           :: msg            ! the message
+    character(len=*), intent(in), optional :: id             ! the id
+    character(len=*), intent(in), optional :: title          ! the title
+    character(len=*), intent(in), optional :: dictref        ! the dictionary reference
+
+    call xml_NewElement(xf, 'message')
+    call xml_AddAttribute(xf, 'severity', 'fatal')
+    if (present(id)) call xml_AddAttribute(xf, 'id', id)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    call xml_AddPcdata(xf, msg)
+    call xml_EndElement(xf, 'message')
+
+  END SUBROUTINE stmErrorMessage
+
+
+  ! -------------------------------------------------
+  ! outputs informational message
+  ! -------------------------------------------------
+
+  SUBROUTINE stmInfoMessage(xf, msg, id, title, dictref)
+
+    implicit none
+    type(xmlf_t) :: xf
+    character(len=*), intent(in)           :: msg            ! the message
+    character(len=*), intent(in), optional :: id             ! the id
+    character(len=*), intent(in), optional :: title          ! the title
+    character(len=*), intent(in), optional :: dictref        ! the dictionary reference
+
+    call xml_NewElement(xf, 'message')
+    call xml_AddAttribute(xf, 'severity', 'warning')
+    if (present(id))      call xml_AddAttribute(xf, 'id', id)
+    if (present(title))   call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    call xml_AddPcdata(xf, msg)
+    call xml_EndElement(xf, 'message')
+
+  END SUBROUTINE stmInfoMessage
+
+
+  ! -------------------------------------------------
+  ! outputs warning message
+  ! -------------------------------------------------
+
+  SUBROUTINE stmWarningMessage(xf, msg, id, title, dictref)
+
+    implicit none
+    type(xmlf_t) :: xf
+    character(len=*), intent(in)           :: msg            ! the message
+    character(len=*), intent(in), optional :: id             ! the id
+    character(len=*), intent(in), optional :: title          ! the title
+    character(len=*), intent(in), optional :: dictref        ! the dictionary reference
+
+    call xml_NewElement(xf, 'message')
+    call xml_AddAttribute(xf, 'severity', 'info')
+    if (present(id)) call xml_AddAttribute(xf, 'id', id)
+    if (present(title)) call xml_AddAttribute(xf, 'title', title)
+    if (present(dictref)) call xml_AddAttribute(xf, 'dictRef', dictref)
+    call xml_AddPcdata(xf, msg)
+    call xml_EndElement(xf, 'message')
+
+  END SUBROUTINE stmWarningMessage
+
+
+
+  ! =================================================
+  ! basic STMML routines
+  ! =================================================
+
+
+  ! -------------------------------------------------
+  ! creates STMML <scalar> string
+  ! -------------------------------------------------
+
+  SUBROUTINE STMSCAS9(xf, value, id, title, dictref, type)
+
+    implicit none
+    type(xmlf_t) :: xf
+    character(len=*), intent(in) :: value                 ! the value to be output
+    character(len=*), intent(in), optional :: id          ! the id
+    character(len=*), intent(in), optional :: title       ! the title
+    character(len=*), intent(in), optional :: dictref     ! the dictionary reference
+    character(len=*), intent(in), optional :: type        ! the data type (default 'xsd:string')
+
+    ! Internal variables
+    character(len=20) :: temp
+
+    call xml_NewElement(xf, 'scalar')
+    if (present(id))      call xml_AddAttribute(xf, 'id', id)
+    if (present(title))   call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(dictref)) call xml_AddAttribute(xf, 'title', title)
+    if (present(type))    call xml_AddAttribute(xf, 'dataType', type)
+
+!    if (XMLCHKS9(value)) then
+    call xml_AddPcdata(xf, value)
+    call xml_EndElement(xf, 'scalar')
+
+  END SUBROUTINE STMSCAS9
+
+
+
+  ! -------------------------------------------------
+  ! output start tag for an STMML array
+  ! -------------------------------------------------
+
+  SUBROUTINE STMARST9(xf, nvalue, id, title, dictref, typunt, tuval, delim)
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in)                    :: nvalue      ! the number of values to be output
+    character(len=*), intent(in), optional :: id          ! the id
+    character(len=*), intent(in), optional :: title       ! the title
+    character(len=*), intent(in), optional :: dictref     ! the dictionary reference
+    character(len=*), intent(in), optional :: typunt      ! 'type' (for strings) or 'unit' (for numeric)
+    character(len=*), intent(in), optional :: tuval       ! data type (default 'xsd:string') or units (' ' = none)
+    character(len=*), intent(in), optional :: delim       ! the delimiter (default ' ')
+
+    ! Internal Variables
+    character(len=1) :: delim1
+
+    if (present(delim)) then
+       delim1 = delim
+    else
+       delim1 = ' '
+    endif
+
+    call xml_NewElement(xf, 'array')
+    if (present(id))      call xml_AddAttribute(xf, 'id', id)
+    if (present(title))   call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(dictref)) call xml_AddAttribute(xf, 'title', title)
+    if (present(tuval))   call xml_AddAttribute(xf, 'type', tuval)
+    call xml_AddAttribute(xf, 'delimiter', delim1)
+    call xml_AddAttribute(xf, 'size', str(nvalue))
+    call xml_EndElement(xf, 'array')
+
+  END SUBROUTINE STMARST9
+
+
+
+  ! -------------------------------------------------
+  ! 2. outputs SP float array to channel
+  ! -------------------------------------------------
+
+  SUBROUTINE STMARF9SP(xf, nvalue, arrf, id, title, dictref, units, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in)                    :: nvalue      ! the number of values to be output
+    real(kind=sp), intent(in)               :: arrf(*)     ! the values to be output
+    character(len=*), intent(in), optional :: id          ! the id
+    character(len=*), intent(in), optional :: title       ! the title
+    character(len=*), intent(in), optional :: dictref     ! the dictionary reference
+    character(len=*), intent(in), optional :: units       ! units (' ' = none)
+    character(len=*)                       :: fmt         ! the output format
+
+    call xml_NewElement(xf, 'scalar')
+    if (present(id))      call xml_AddAttribute(xf, 'id', id)
+    if (present(title))   call xml_AddAttribute(xf, 'dictRef', dictref)
+    if (present(dictref)) call xml_AddAttribute(xf, 'title', title)
+    if (present(units))   call xml_AddAttribute(xf, 'units', units)
+    call xml_AddAttribute(xf, 'size', str(nvalue))
+    call STMARCF9SP(xf, nvalue, arrf, fmt)
+    call xml_NewElement(xf, 'scalar')
+
+  END SUBROUTINE STMARF9SP
+
+
+  ! -------------------------------------------------
+  ! 1. outputs content of DP float array to channel
+  ! -------------------------------------------------
+
+  SUBROUTINE STMARCF9DP(xf, nvalue, arrf, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer, intent(in)          :: nvalue     ! the number of values to be output
+    real(kind=dp), intent(in)     :: arrf(*)    ! the values to be output
+    character(len=*), intent(in) :: fmt        ! the output format
+
+    ! splits data into lines whenever it overflows workspace/linelength
+    integer :: i
+
+    call xml_AddPcdata(xf, str(arrf(1)))
+    do i = 2, nvalue
+       call xml_AddPcdata(xf, str(arrf(i)))
+    enddo
+  END SUBROUTINE STMARCF9DP
+
+
+  ! -------------------------------------------------
+  ! 2. outputs content of SP float array to channel
+  ! -------------------------------------------------
+
+  SUBROUTINE STMARCF9SP(xf, nvalue, arrf, fmt)
+
+    implicit none
+    type(xmlf_t) :: xf
+    integer          :: nvalue     ! the number of values to be output
+    real(kind=sp)     :: arrf(*)    ! the values to be output
+    character(len=*) :: fmt        ! the output format
+
+    ! splits data into lines whenever it overflows workspace/linelength
+    integer :: i
+
+    call xml_AddPcdata(xf, str(arrf(1)))
+    do i = 2, nvalue
+       call xml_AddPcdata(xf, str(arrf(i)))
+    enddo
+  END SUBROUTINE STMARCF9SP
+
+end module m_stmw
Index: vendors/XMLF90/current/src/dom/flib_dom.f90
===================================================================
--- vendors/XMLF90/current/src/dom/flib_dom.f90	(revision 1899)
+++ vendors/XMLF90/current/src/dom/flib_dom.f90	(revision 1899)
@@ -0,0 +1,17 @@
+module flib_dom
+
+  use m_dom_types
+  use m_dom_namednodemap
+  use m_dom_nodelist
+  use m_dom_attribute
+  use m_dom_document
+  use m_dom_node
+  use m_dom_element
+  use m_dom_parse
+  use m_dom_utils
+
+  use m_strings
+
+  public
+
+end module flib_dom
Index: vendors/XMLF90/current/src/dom/m_dom_attribute.f90
===================================================================
--- vendors/XMLF90/current/src/dom/m_dom_attribute.f90	(revision 1899)
+++ vendors/XMLF90/current/src/dom/m_dom_attribute.f90	(revision 1899)
@@ -0,0 +1,86 @@
+module m_dom_attribute
+
+use m_dom_types
+use m_dom_node
+use m_strings
+
+private
+  !-------------------------------------------------------  
+  ! METHODS FOR ATTRIBUTE NODES
+  !------------------------------------------------------- 
+
+  public :: getName
+  public :: getValue
+  public :: setValue
+
+CONTAINS
+
+  function getName(attribute)
+
+    type(fnode), intent(in) :: attribute
+    type(string)            :: getName
+
+    if (attribute % nodeType == ATTRIBUTE_NODE) then
+       getName = attribute%nodeName
+    else
+       getName = ''
+    endif
+
+  end function getName
+
+  !-----------------------------------------------------------
+
+  function getValue(attribute)
+
+    type(fnode), intent(in) :: attribute
+    type(string)            :: getValue
+
+    if (attribute % nodeType == ATTRIBUTE_NODE) then
+       getValue = attribute%nodeValue
+    else
+       getValue = ''
+    endif
+
+  end function getValue
+
+  !-----------------------------------------------------------
+
+  subroutine setValue(attribute, value)
+
+    character(len=*), intent(in) :: value
+    type(fnode), pointer  :: attribute
+
+    if (attribute % nodeType == ATTRIBUTE_NODE) then
+       call setNodeValue(attribute,value)
+    endif
+
+  end subroutine setValue
+
+  !-----------------------------------------------------------
+
+
+!!! NB Is this a good idea?
+!!! NB pure functions have no side effects
+
+  pure function attr_name_len(attribute)
+    type(fnode), intent(in) :: attribute
+    integer :: attr_name_len
+    if (attribute % nodeType == ATTRIBUTE_NODE) then
+       attr_name_len = len_trim(attribute % nodeName)
+    else
+       attr_name_len = 0
+    end if
+  end function attr_name_len
+  
+  pure function attr_val_len(attribute)   
+    type(fnode), intent(in) :: attribute
+    integer :: attr_val_len
+    if (attribute % nodeType == ATTRIBUTE_NODE) then
+       attr_val_len = len_trim(attribute % nodeValue)
+    else
+       attr_val_len = 0
+    end if
+  end function attr_val_len
+
+
+end module m_dom_attribute
Index: vendors/XMLF90/current/src/dom/m_dom_debug.f90
===================================================================
--- vendors/XMLF90/current/src/dom/m_dom_debug.f90	(revision 1899)
+++ vendors/XMLF90/current/src/dom/m_dom_debug.f90	(revision 1899)
@@ -0,0 +1,5 @@
+module m_dom_debug
+
+  logical, save, public :: dom_debug = .false.
+
+end module m_dom_debug
Index: vendors/XMLF90/current/src/dom/m_dom_document.f90
===================================================================
--- vendors/XMLF90/current/src/dom/m_dom_document.f90	(revision 1899)
+++ vendors/XMLF90/current/src/dom/m_dom_document.f90	(revision 1899)
@@ -0,0 +1,113 @@
+module m_dom_document
+
+use m_dom_types
+use m_strings
+
+private
+
+  !-------------------------------------------------------  
+  ! METHODS FOR DOCUMENT NODES
+  !-------------------------------------------------------   
+  public :: createDocumentNode
+  public :: createDocumentFragment
+  public :: createTextNode
+  public :: createAttribute
+  public :: createElement
+  public :: createComment
+  public :: createCdataSection
+
+CONTAINS
+
+  !-----------------------------------------------------------
+  ! METHODS FOR DOCUMENT NODES
+  !-----------------------------------------------------------
+
+  function createDocumentNode()
+
+    type(fnode), pointer :: createDocumentNode
+    
+    createDocumentNode => createNode()
+    createDocumentNode % nodeType = DOCUMENT_NODE
+    createDocumentNode % nodeName = "#document"
+    
+  end function createDocumentNode
+!-------------------------------------------------------------------
+  function createDocumentFragment()
+
+    type(fnode), pointer :: createDocumentFragment
+    
+    createDocumentFragment => createNode()
+    createDocumentFragment % nodeType = DOCUMENT_FRAGMENT_NODE
+    createDocumentFragment % nodeName = "#document-fragment"
+    
+  end function createDocumentFragment
+!-------------------------------------------------------------------
+  function createTextNode(data)
+
+    character(len=*), intent(in) :: data
+    type(fnode), pointer :: createTextNode
+    
+    createTextNode => createNode()
+    createTextNode % nodeType = TEXT_NODE
+    createTextNode % nodeName = "#text"
+    createTextNode % nodeValue = data  ! NB need to split this string 
+                                       ! across several nodes 
+    
+  end function createTextNode
+
+  !-----------------------------------------------------------
+
+  function createAttribute(name)
+    
+    character(len=*), intent(in) :: name
+    type(fnode), pointer :: createAttribute
+  
+    createAttribute => createNode()
+    createAttribute % nodeName = name
+    createAttribute % nodeType = ATTRIBUTE_NODE
+  
+  end function createAttribute
+
+  !-----------------------------------------------------------
+
+  function createElement(tagName)
+    
+    character(len=*), intent(in) :: tagName
+    type(fnode), pointer :: createElement
+  
+    createElement => createNode()
+    createElement % nodeName = tagName
+    createElement % nodeType = ELEMENT_NODE
+  
+  end function createElement
+
+  !-----------------------------------------------------------
+
+  function createComment(data)
+    
+    character(len=*), intent(in) :: data
+    type(fnode), pointer :: createComment
+  
+    createComment => createNode()
+    createComment % nodeName = "#comment"
+    createComment % nodeValue = data
+    createComment % nodeType = COMMENT_NODE
+  
+  end function createComment
+
+  !-----------------------------------------------------------
+
+  function createCdataSection(data)
+    
+    character(len=*), intent(in) :: data
+    type(fnode), pointer :: createCdataSection
+  
+    createCdataSection => createNode()
+    createCdataSection % nodeName = "#cdata-section"
+    createCdataSection % nodeValue = data
+    createCdataSection % nodeType = CDATA_SECTION_NODE
+  
+  end function createCdataSection
+
+  
+end module m_dom_document
Index: vendors/XMLF90/current/src/dom/m_dom_element.f90
===================================================================
--- vendors/XMLF90/current/src/dom/m_dom_element.f90	(revision 1899)
+++ vendors/XMLF90/current/src/dom/m_dom_element.f90	(revision 1899)
@@ -0,0 +1,242 @@
+module m_dom_element
+
+use m_dom_types
+use m_dom_namednodemap
+use m_dom_nodelist
+use m_dom_attribute
+use m_dom_document
+use m_dom_debug
+use m_dom_node
+use m_strings
+
+private
+
+  !-------------------------------------------------------   
+  ! METHODS FOR ELEMENT NODES
+  !-------------------------------------------------------   
+  public :: getTagName
+  public :: getElementsByTagName
+  public :: getAttribute
+  public :: getAttributeNode
+  public :: setAttribute
+  public :: setAttributeNode
+  public :: removeAttribute
+  public :: normalize       !--- combines adjacent text nodes ---!
+
+CONTAINS
+
+  !-----------------------------------------------------------
+  !  METHODS FOR ELEMENT NODES
+  !-----------------------------------------------------------
+  function getTagName(element)
+
+    type(fnode), intent(in) :: element   
+    type(string)            :: getTagName
+
+    if (element % nodeType == ELEMENT_NODE) then
+       getTagName = element % nodeName 
+    else
+       getTagName = ''
+    endif
+
+  end function getTagName
+
+  !-----------------------------------------------------------
+  function getElementsByTagName(element, tag) result(nodelist)
+    type(fnode), pointer         :: element
+    character(len=*), intent(in) :: tag
+    type(fnodeList), pointer     :: nodelist 
+
+    type(fnode), pointer        :: np
+
+    nodelist => null()
+
+    np => element
+    if (dom_debug) print *, "Going into search for tag: ", trim(tag)
+    call search(np)
+
+    CONTAINS
+
+    recursive subroutine search(np)
+    type(fnode), pointer        :: np
+
+    type(string)                :: name
+
+    !
+    ! Could replace the calls to helper methods by direct lookups of node 
+    ! components to make it faster.
+    ! 
+    do
+       if (.not. associated(np)) exit
+       select case(np%nodeType)
+
+          case(DOCUMENT_NODE) 
+             ! special case ... search its children 
+             if (hasChildNodes(np)) call search(getFirstChild(np))
+             ! will exit for lack of siblings
+          case(ELEMENT_NODE)
+
+             name = getNodeName(np)
+             if (dom_debug) print *, "exploring node: ", char(name)
+             if ((tag == "*") .or. (tag == name)) then
+                call append(nodelist,np)
+                if (dom_debug) print *, "found match ", nodelist%length
+             endif
+             if (hasChildNodes(np)) call search(getFirstChild(np))
+
+          case default
+             
+             ! do nothing
+
+        end select
+
+        if (associated(np,element)) exit  ! no siblings of element...
+        np => getNextSibling(np)
+
+     enddo
+    
+    end subroutine search
+
+  end function getElementsByTagName
+
+  !-----------------------------------------------------------
+
+  function getAttribute(element, name)
+    
+    type(fnode), intent(in) :: element
+    character(len=*), intent(in) :: name
+    type(string)                 :: getAttribute
+
+    type(fnode), pointer :: nn
+
+    getAttribute = ""  ! as per specs, if not found
+    if (element % nodeType /= ELEMENT_NODE) RETURN
+    nn => getNamedItem(element%attributes,name)
+    if (.not. associated(nn)) RETURN
+    
+    getAttribute = nn%nodeValue
+
+        
+  end function getAttribute
+
+  !-----------------------------------------------------------
+
+  function getAttributeNode(element, name)
+    
+    type(fnode), intent(in) :: element
+    type(fnode), pointer    :: getAttributeNode
+    character(len=*), intent(in) :: name
+
+    getAttributeNode => null()     ! as per specs, if not found
+    if (element % nodeType /= ELEMENT_NODE) RETURN
+    getAttributeNode => getNamedItem(element%attributes,name)
+
+  end function getAttributeNode
+  
+  !-----------------------------------------------------------
+
+  subroutine setAttributeNode(element, newattr)
+    type(fnode), pointer :: element
+    type(fnode), pointer :: newattr
+
+    type(fnode), pointer :: dummy
+
+    if (element % nodeType /= ELEMENT_NODE) then
+       if (dom_debug) print *, "not an element node in setAttributeNode..."
+       RETURN
+    endif
+
+    dummy => setNamedItem(element%attributes,newattr)
+     
+  end subroutine setAttributeNode
+
+!-------------------------------------------------------------------
+  subroutine setAttribute(element, name, value)
+    type(fnode), pointer :: element
+    character(len=*), intent(in) :: name
+    character(len=*), intent(in) :: value
+
+    type(fnode), pointer      :: newattr
+
+    newattr => createAttribute(name)
+    call setValue(newattr,value)
+    call setAttributeNode(element,newattr)
+
+  end subroutine setAttribute
+
+  !-----------------------------------------------------------
+
+  subroutine removeAttribute(element, name)
+    type(fnode), pointer :: element
+    character(len=*), intent(in) :: name
+
+    type(fnode), pointer :: dummy
+
+    if (element % nodeType /= ELEMENT_NODE) RETURN
+    if (.not. associated(element%attributes)) RETURN
+
+    dummy => removeNamedItem(element%attributes,name)
+     
+  end subroutine removeAttribute
+
+  !-----------------------------------------------------------
+  recursive subroutine normalize(element)
+    type(fnode), pointer         :: element
+
+    type(fnode), pointer        :: np, ghost
+    logical                     :: first
+
+    type(fnode), pointer        :: head
+
+    first = .true.  ! next Text node will be first
+
+    if (dom_debug) print *, "Normalizing: ", trim(element%nodeName)
+    np => element%firstChild
+    ! 
+    do
+       if (.not. associated(np)) exit
+       select case(np%nodeType)
+
+          case(TEXT_NODE) 
+             if (first) then
+                if (dom_debug) print *, "normalize: found first in chain"
+                head => np
+                first = .false.
+                np => getNextSibling(np)
+             else                    ! a contiguous text node
+                if (dom_debug) print *, "normalize: found second in chain"
+                head%nodeValue = head%nodeValue // np%nodeValue
+                head%nextSibling => np%nextSibling
+                if (associated(np,np%parentNode%lastChild)) then
+                   np%parentNode%lastChild => head
+                   head%nextSibling => null()
+                else
+                   np%nextSibling%previousSibling => head
+                endif
+                ghost => np
+                np => getNextSibling(np)
+                call destroyNode(ghost)
+             endif
+
+          case(ELEMENT_NODE)
+
+             first = .true.
+             if (dom_debug) print *, "element sibling: ", trim(np%nodeName)
+             if (hasChildNodes(np)) call normalize(np)
+             np => getNextSibling(np)
+
+          case default
+             
+             ! do nothing, just mark that we break the chain of text nodes
+             if (dom_debug) print *, "other sibling: ", trim(np%nodeName)
+             first = .true.
+             np => getNextSibling(np)
+
+        end select
+
+     enddo
+
+    end subroutine normalize
+
+
+end module m_dom_element
Index: vendors/XMLF90/current/src/dom/m_dom_error.f90
===================================================================
--- vendors/XMLF90/current/src/dom/m_dom_error.f90	(revision 1899)
+++ vendors/XMLF90/current/src/dom/m_dom_error.f90	(revision 1899)
@@ -0,0 +1,35 @@
+module m_dom_error
+
+  !-------------------------------------------------------
+  ! EXCEPTION CODES
+  !-------------------------------------------------------
+  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
+
+CONTAINS
+
+  subroutine dom_error(name,code,msg)
+    character(len=*), intent(in) :: name, msg
+    integer, intent(in)          :: code
+
+    print *, "***ERROR***"
+    print *, "Routine ", trim(name), ":", trim(msg)
+    print *, 1.0 / sin(3.141592654)
+  end subroutine dom_error
+
+end module m_dom_error
Index: vendors/XMLF90/current/src/dom/m_dom_namednodemap.f90
===================================================================
--- vendors/XMLF90/current/src/dom/m_dom_namednodemap.f90	(revision 1899)
+++ vendors/XMLF90/current/src/dom/m_dom_namednodemap.f90	(revision 1899)
@@ -0,0 +1,203 @@
+module m_dom_namednodemap
+!
+! This is basically a dictionary module, but written with the
+! DOM node structure in mind.
+!
+use m_dom_types
+use m_strings
+
+private
+  !-------------------------------------------------------  
+  ! METHODS FOR NAMEDNODEMAPS
+  !-------------------------------------------------------   
+  public :: getNamedItem
+  public :: setNamedItem
+  public :: removeNamedItem
+
+  public :: item
+  public :: getLength
+  public :: append
+
+  interface append
+     module procedure append_nnm
+  end interface
+
+  interface item
+     module procedure item_nnm
+  end interface 
+
+  interface getLength
+     module procedure getLength_nnm
+  end interface
+
+CONTAINS
+
+  function item_nnm(namedNodeMap, i)
+    
+    integer, intent(in)             :: i
+    type(fnamedNodeMap), pointer    :: namedNodeMap
+    type(fnode), pointer            :: item_nnm
+    
+    type(fnamedNode), pointer :: nnp
+
+    integer :: n
+
+    item_nnm => null()            ! In case there is no such item
+    if (.not. associated(namedNodeMap)) RETURN
+
+    nnp => namedNodeMap%head
+    n = -1
+    do 
+       if (.not. associated(nnp))  exit
+       n = n + 1
+       if (n == i) then
+          item_nnm => nnp%node
+          exit
+       endif
+       nnp => nnp%next
+    enddo
+
+  end function item_nnm
+
+  !----------------------------------------------------------- 
+  
+  function getLength_nnm(namedNodeMap)
+  
+    type(fnamedNodeMap), pointer :: namedNodeMap
+    integer :: getLength_nnm
+
+    getLength_nnm = 0
+    if (.not. associated(namedNodeMap)) return
+
+    getLength_nnm = namedNodeMap % length    
+    
+  end function getLength_nnm
+
+  !----------------------------------------------------------- 
+
+
+  subroutine append_nnm(nodeMap,node)
+    type(fnamednodeMap), pointer :: nodeMap
+    type(fnode), pointer :: node
+
+    if (.not. associated(nodeMap)) then
+       allocate(nodeMap)
+       nodeMap%length = 1
+       allocate(nodeMap%head)
+       nodeMap%head%name = node%nodeName
+       nodeMap%head%node => node
+       nodeMap%tail => nodeMap%head
+    else
+       allocate(nodeMap%tail%next)
+       nodeMap%tail%next%node => node
+       nodeMap%tail%next%name =  node%nodeName
+       nodeMap%tail => nodeMap%tail%next
+       nodeMap%length = nodeMap%length + 1
+    endif
+
+  end subroutine append_nnm
+
+  !----------------------------------------------------------- 
+
+  function getNamedItem(namedNodeMap, name)
+    
+    type(fnamedNodeMap), pointer    :: namedNodeMap
+    character(len=*), intent(in)    :: name
+    type(fnode), pointer            :: getNamedItem
+
+    type(fnamedNode), pointer :: nnp
+
+    getNamedItem => null()
+    if (.not. associated(namedNodeMap)) return 
+
+    nnp => namedNodeMap%head
+    do while (associated(nnp)) 
+       if (nnp%name == name) then
+          getNamedItem => nnp%node
+          exit                 ! one or zero nodes with a given name
+       endif
+       nnp => nnp%next
+    enddo
+
+  end function getNamedItem
+
+  
+  function setNamedItem(namedNodeMap, node)
+
+!!AG: Do we need to clone the node ?
+    
+    type(fnamedNodeMap), pointer    :: namedNodeMap
+    type(fnode), pointer            :: node
+    type(fnode), pointer            :: setNamedItem
+
+    type(fnamedNode), pointer :: nnp
+
+    if (.not. associated(namedNodeMap)) then
+
+       call append(namedNodeMap,node)
+       setNamedItem => node
+      
+    else
+
+       nnp => namedNodeMap%head
+       do while (associated(nnp)) 
+          if (nnp%name == node%nodeName) then
+             setNamedItem => nnp%node
+             nnp%node => node
+             setNamedItem => node
+             return
+          endif
+          nnp => nnp%next
+       enddo
+
+       !   If not found, insert it at the end of the linked list
+
+       call append(namedNodeMap,node)
+       setNamedItem => node
+    endif
+
+  end function setNamedItem
+
+!------------------------------------------------------------
+   function removeNamedItem(namedNodeMap, name)
+    
+    type(fnamedNodeMap), pointer   :: namedNodeMap
+    character(len=*), intent(in)   :: name
+    type(fnode), pointer           :: removeNamedItem
+
+    type(fnamedNode), pointer :: nnp, previous
+
+    removeNamedItem => null()
+    if (.not. associated(namedNodeMap)) return  
+
+    previous => null()
+    nnp => namedNodeMap%head
+    do while (associated(nnp)) 
+       if (nnp%name == name) then
+          removeNamedItem => nnp%node
+          if (associated(nnp,namedNodeMap%head)) then
+             ! we remove the first fnamedNode in the chain...
+             namedNodeMap%head => nnp%next
+          else if (.not. associated(nnp%next)) then
+             ! we remove the last fnamedNode in the chain
+             previous%next => null()
+             namedNodeMap%tail => previous
+          else
+             ! we remove a link in the middle of the chain
+             previous%next => nnp%next
+          endif
+          namedNodeMap%length =  namedNodeMap%length - 1
+          call unstring(nnp%name)
+          deallocate(nnp)
+          EXIT                 ! one or zero nodes with a given name
+       endif
+       previous => nnp
+       nnp => nnp%next
+    enddo
+
+  end function removeNamedItem
+
+
+
+end module m_dom_namednodemap
+
Index: vendors/XMLF90/current/src/dom/m_dom_node.f90
===================================================================
--- vendors/XMLF90/current/src/dom/m_dom_node.f90	(revision 1899)
+++ vendors/XMLF90/current/src/dom/m_dom_node.f90	(revision 1899)
@@ -0,0 +1,560 @@
+module m_dom_node
+
+use m_dom_types
+use m_dom_nodelist
+use m_dom_namednodemap
+use m_dom_debug
+use m_dom_error
+
+use m_strings
+
+private
+
+  !-------------------------------------------------------   
+  ! METHODS FOR NODES
+  !-------------------------------------------------------   
+
+  public :: getNodeName
+  public :: getNodevalue	
+  public :: getNodeType
+  public :: hasChildNodes
+  public :: hasAttributes
+  public :: getParentNode
+  public :: getFirstChild
+  public :: getLastChild
+  public :: getNextSibling
+  public :: getPreviousSibling
+  public :: getOwnerDocument
+  public :: getAttributes
+  public :: getChildNodes
+  public :: setNodeValue
+  public :: appendChild
+  public :: removeChild
+  public :: replaceChild
+  public :: cloneNode  
+  public :: isSameNode
+  public :: insertBefore
+
+  private :: name_len, value_len
+
+CONTAINS
+
+  pure function name_len(node)
+    type(fnode), pointer :: node
+    integer :: name_len
+
+    name_len = len_trim(node % nodeName)
+
+  end function name_len
+
+  pure function value_len(node)
+    type(fnode), pointer :: node
+    integer :: value_len
+
+    value_len = len_trim(node % nodeValue)
+
+  end function value_len
+
+  !-----------------------------------------------------------
+  !  METHODS FOR NODES
+  !-----------------------------------------------------------
+  function getNodeName(node)
+
+    type(fnode), pointer :: node
+!    character(len=len_trim(node%nodeName)) :: getNodeName
+    type(string)  :: getNodeName
+    if (.not. associated(node))  &
+               call dom_error("getNodeName",0,"Node not allocated")
+    getNodeName = node % nodeName
+
+  end function getNodeName
+
+  !-----------------------------------------------------------
+
+  function getNodeValue(node)
+
+    type(fnode), pointer :: node
+!    character(len=len_trim(node%nodeValue)) :: getNodeValue
+    type(string)  :: getNodeValue
+
+    if (.not. associated(node))  &
+               call dom_error("getNodeValue",0,"Node not allocated")
+    getNodeValue = node % nodeValue
+
+  end function getNodeValue
+
+  !-----------------------------------------------------------
+
+  function getNodeType(node)
+
+    type(fnode), pointer :: node
+    integer :: getNodeType
+
+    if (.not. associated(node)) call dom_error("getNodeType",0,"Node not allocated")
+    getNodeType = node % nodeType
+
+  end function getNodeTYpe
+
+  !-----------------------------------------------------------
+
+  function hasChildNodes(node)
+
+    type(fnode), pointer :: node
+    logical :: hasChildNodes
+
+    if (.not. associated(node)) call dom_error("hasChildNodes",0,"Node not allocated")
+    hasChildNodes = associated(node % firstChild)
+
+  end function hasChildNodes
+
+  !-----------------------------------------------------------
+
+  function hasAttributes(node)
+
+    type(fnode), pointer    :: node
+    logical                 :: hasAttributes
+
+    hasAttributes = .false.
+    if (.not. associated(node)) call dom_error("hasAttributes",0,"Node not allocated")
+    if (node % nodeType /= ELEMENT_NODE) RETURN
+    if ( getLength(node%attributes) > 0) hasAttributes = .true.
+
+  end function hasAttributes
+
+  !-----------------------------------------------------------
+
+  function getParentNode(node)
+
+    type(fnode), pointer    :: node
+    type(fnode), pointer    :: getParentNode
+
+    if (.not. associated(node)) call dom_error("getParentNode",0,"Node not allocated")
+    getParentNode => node % parentNode
+    
+  end function getParentNode
+  
+  !-----------------------------------------------------------
+
+  function getFirstChild(node)
+
+    type(fnode), pointer    :: node
+    type(fnode), pointer    :: getFirstChild
+
+    if (.not. associated(node)) call dom_error("getFirstChild",0,"Node not allocated")
+    getFirstChild => node % firstChild
+
+  end function getFirstChild
+
+  !-----------------------------------------------------------
+
+  function getLastChild(node)
+
+    type(fnode), pointer :: node
+    type(fnode), pointer    :: getLastChild
+
+    if (.not. associated(node)) call dom_error("getLastChild",0,"Node not allocated")
+    getLastChild => node % lastChild
+
+  end function getLastChild
+
+  !-----------------------------------------------------------
+
+  function getNextSibling(node)
+
+    type(fnode), pointer :: node
+    type(fnode), pointer    :: getNextSibling
+
+    if (.not. associated(node)) call dom_error("getNextSibling",0,"Node not allocated")
+    getNextSibling => node % nextSibling
+
+  end function getNextSibling
+
+  !-----------------------------------------------------------
+
+  function getPreviousSibling(node)
+
+    type(fnode), pointer     :: node
+    type(fnode), pointer    :: getPreviousSibling
+
+    if (.not. associated(node)) call dom_error("getPreviousSibling",0,"Node not allocated")
+    getPreviousSibling => node % previousSibling
+
+  end function getPreviousSibling
+
+  !-----------------------------------------------------------
+
+  function getOwnerDocument(node)
+
+    type(fnode), pointer    :: node
+    type(fnode), pointer    :: getOwnerDocument
+
+    if (.not. associated(node)) call dom_error("getOwnerDocument",0,"Node not allocated")
+    getOwnerDocument => node % ownerDocument
+
+  end function getOwnerDocument
+
+  !----------------------------------------------------------- 
+
+  function getChildNodes(node) result(nodelist)
+    
+    type(fnode), pointer        :: node
+    type(fnodeList), pointer    :: nodelist      !!! NB nodeList
+
+    type(fnode), pointer        :: np
+
+    if (.not. associated(node)) call dom_error("getChildNodes",0,"Node not allocated")
+    nodelist => null()
+    np => node%firstChild
+    do 
+       if (.not. associated(np)) exit
+       call append(nodelist,np)
+       np => np%nextSibling
+    enddo
+
+  end function getChildNodes
+
+  !----------------------------------------------------------- 
+
+  function getAttributes(node)
+
+    type(fnode), pointer         :: node
+    type(fnamedNodeMap), pointer :: getAttributes       !!! NB namedNodeMap
+    
+    if (.not. associated(node))  &
+               call dom_error("getAttributes",0,"Node not allocated")
+    getAttributes => node % attributes
+
+  end function getAttributes
+
+  !----------------------------------------------------------- 
+
+  subroutine setNodeValue(node, value)
+
+    type(fnode), pointer :: node
+    character(len=*), intent(in) :: value
+    
+    if (.not. associated(node))  &
+               call dom_error("setNodeValue",0,"Node not allocated")
+
+    select case(node % nodeType)
+
+    case(ATTRIBUTE_NODE)
+       node % nodeValue = trim(value)    !!AG: use just value ??
+
+    case(COMMENT_NODE)
+       node % nodeValue = value
+
+    case(TEXT_NODE)
+       node % nodeValue = value
+
+    case(PROCESSING_INSTRUCTION_NODE)
+       node % nodeValue = value
+
+    case(CDATA_SECTION_NODE)
+       node % nodeValue = value
+
+    end select
+
+  end subroutine setNodeValue
+
+  !-----------------------------------------------------------
+  
+  function appendChild(node, newChild)
+    type(fnode), pointer :: node
+    type(fnode), pointer :: newChild
+    type(fnode), pointer :: appendChild
+    
+    if (.not. associated(node))  & 
+               call dom_error("appendChild",0,"Node not allocated")
+
+    if ((node%nodeType /= ELEMENT_NODE) .and. &
+        (node%nodeType /= DOCUMENT_NODE)) &
+    call dom_error("appendChild",HIERARCHY_REQUEST_ERR, &
+           "this node cannot have children")
+
+    if (.not.(associated(node % firstChild))) then
+       node % firstChild => newChild
+    else 
+       newChild % previousSibling   => node % lastChild
+       node % lastChild % nextSibling => newChild 
+    endif
+
+    node % lastChild               => newChild
+    newChild % parentNode          => node
+    newChild % ownerDocument       => node % ownerDocument
+    node%nc  = node%nc + 1
+
+    appendChild => newChild
+
+  end function appendChild
+
+  !-----------------------------------------------------------
+  
+  function removeChild(node, oldChild)
+
+    type(fnode), pointer :: removeChild
+    type(fnode), pointer :: node
+    type(fnode), pointer :: oldChild
+    type(fnode), pointer :: np
+    
+    if (.not. associated(node)) call dom_error("removeChild",0,"Node not allocated")
+    np => node % firstChild
+
+    do while (associated(np))
+       if (associated(np, oldChild)) then   ! Two argument form 
+                                              !  of associated()
+          if (associated(np,node%firstChild)) then
+             node%firstChild => np%nextSibling
+             if (associated(np % nextSibling)) then
+                np%nextSibling % previousSibling => null()
+             else
+                node%lastChild => null()    ! there was just 1 node
+             endif
+          else if (associated(np,node%lastChild)) then
+             ! one-node-only case covered above
+             node%lastChild => np%previousSibling
+             np%previousSibling%nextSibling => null()
+          else
+             np % previousSibling % nextSibling => np % nextSibling
+             np % nextSibling % previousSibling => np % previousSibling
+          endif
+          node%nc = node%nc -1
+          np % previousSibling => null()    ! Are these necessary?
+          np % nextSibling => null()
+          np % parentNode => null()
+          removeChild => oldChild
+          RETURN
+       endif
+       np => np % nextSibling
+    enddo
+
+    call dom_error("removeChild",NOT_FOUND_ERR,"oldChild not found")
+
+  end function removeChild
+
+ !-----------------------------------------------------------
+  
+  function replaceChild(node, newChild, oldChild)
+
+    type(fnode), pointer :: replaceChild
+    type(fnode), pointer :: node
+    type(fnode), pointer :: newChild
+    type(fnode), pointer :: oldChild
+
+    type(fnode), pointer :: np
+    
+    if (.not. associated(node)) call dom_error("replaceChild",0,"Node not allocated")
+    if ((node%nodeType /= ELEMENT_NODE) .and. &
+        (node%nodeType /= DOCUMENT_NODE)) &
+    call dom_error("replaceChild",HIERARCHY_REQUEST_ERR, &
+           "this node cannot have children")
+
+    np => node % firstChild
+
+    do while (associated(np))    
+       if (associated(np, oldChild)) then
+          if (associated(np,node%firstChild)) then
+             node%firstChild => newChild
+             if (associated(np % nextSibling)) then
+                oldChild%nextSibling % previousSibling => newChild
+             else
+                node%lastChild => newChild    ! there was just 1 node
+             endif
+          else if (associated(np,node%lastChild)) then
+             ! one-node-only case covered above
+             node%lastChild => newChild
+             oldChild%previousSibling%nextSibling => newChild
+          else
+             oldChild % previousSibling % nextSibling => newChild
+             oldChild % nextSibling % previousSibling => newChild
+          endif
+
+          newChild % parentNode      => oldChild % parentNode
+          newChild % nextSibling     => oldChild % nextSibling
+          newChild % previousSibling => oldChild % previousSibling
+          replaceChild => oldChild
+          RETURN
+       endif
+       np => np % nextSibling
+    enddo
+
+    call dom_error("replaceChild",NOT_FOUND_ERR,"oldChild not found")
+
+  end function replaceChild
+
+  !-----------------------------------------------------------
+
+  function cloneNode(node, deep)             
+    type(fnode), pointer :: cloneNode
+    type(fnode), pointer :: node
+
+    logical, optional :: deep
+    logical           :: do_children
+
+    type(fnode), pointer :: original
+    type(fnode), pointer :: parent_clone
+    
+    if (.not. associated(node)) call dom_error("cloneNode",0,"Node not allocated")
+
+    do_children = .false.
+    if (present(deep)) then
+       do_children = deep
+    endif
+    
+    original => node             ! Keep node
+    cloneNode => null()
+    parent_clone => null()
+    call recursive_clone(original, cloneNode)
+    cloneNode%parentNode => null()     ! as per specs   , superfÃluous
+ 
+  Contains
+
+    recursive subroutine recursive_clone(original, cloneNode)
+      type(fnode), pointer :: original        ! node to clone
+      type(fnode), pointer :: cloneNode       ! new node
+
+      type(fnode), pointer :: np, clone
+      type(fnode), pointer :: previous_clone, attr, newattr
+      type(string)         :: name
+      logical :: first_sibling
+      integer :: i
+
+      np => original
+      previous_clone => null()
+      first_sibling = .true.
+      do 
+
+         ! Keep going across siblings
+         ! (2nd and lower levels only)
+
+         if (.not.(associated(np))) EXIT
+
+
+         !----------------------------------------------------!
+         clone => createNode()
+         if (first_sibling) then
+            cloneNode => clone       ! Rest of siblings are chained
+                                     ! automatically, but must not
+                                     ! be aliases of cloneNode !!
+            first_sibling = .false.
+         endif
+         clone % nodeName    = np % nodeName
+         name = np%nodeName
+         if (dom_debug) print *, "Cloning ", char(name)
+         clone % nodeValue   = np % nodeValue
+         clone % nodeType    = np % nodeType
+         clone % ownerDocument => np % ownerDocument
+         clone % parentNode  => parent_clone
+         !
+         ! always deep copy attributes, as per specs
+         ! Note that this will not work for "deep" attributes, with
+         ! hanging entity nodes, etc
+         if (associated(np % attributes)) then
+            do i = 0, getLength(np%attributes) - 1
+               attr => item(np%attributes,i)
+               newattr => createNode()
+               newattr%nodeName = getNodeName(attr)
+               newattr%nodeValue = getNodeValue(attr)
+               newattr%nodeType = ATTRIBUTE_NODE
+               call append(clone%attributes, newattr)
+            enddo
+         endif
+
+         ! Deal with first sibling
+         if (associated(previous_clone)) then
+            if (dom_debug) print *, "linking to previous sibling"
+            previous_clone%nextSibling => clone
+            clone%previousSibling => previous_clone
+         else
+            if (dom_debug) print *, "marking as first child of parent"
+            if (associated(parent_clone))  &
+                           parent_clone%firstChild => clone
+         endif
+
+         ! Deal with last sibling
+         if (.not. associated(np%nextSibling)) then
+            if (dom_debug) print *, "this is the last sibling"
+            if (associated(parent_clone)) then
+               if (dom_debug) print *, "marking as last child of parent"
+               parent_clone%lastChild => clone
+            endif
+         endif
+            
+         if (do_children .and. associated(np%firstChild)) then
+            parent_clone => clone
+            if (dom_debug) print *, ".... going for its children"
+            call recursive_clone(np%firstChild,clone%firstChild)
+            parent_clone => clone%parentNode
+         endif
+
+         if (associated(np,node)) then
+            if (dom_debug) print *, "No more siblings of ", char(name)
+            EXIT  ! no siblings of master node
+         endif
+         np => np % nextSibling
+         previous_clone => clone
+
+      enddo 
+
+    end subroutine recursive_clone
+
+  end function cloneNode
+
+  !-----------------------------------------------------------
+
+  function isSameNode(node1, node2)    ! DOM 3.0
+    type(fnode), pointer :: node1
+    type(fnode), pointer :: node2
+    logical :: isSameNode
+
+    isSameNode = associated(node1, node2)
+
+  end function isSameNode
+
+  !-----------------------------------------------------------
+
+  function insertBefore(node, newChild, refChild)
+    type(fnode), pointer :: insertBefore
+    type(fnode), pointer :: node
+    type(fnode), pointer :: newChild
+    type(fnode), pointer :: refChild
+    type(fnode), pointer :: np
+
+    if (.not. associated(node)) call dom_error("insertBefore",0,"Node not allocated")
+    if ((node%nodeType /= ELEMENT_NODE) .and. &
+        (node%nodeType /= DOCUMENT_NODE)) &
+    call dom_error("insertBefore",HIERARCHY_REQUEST_ERR, &
+           "cannot insert node here")
+
+    if (.not.associated(refChild)) then
+       insertBefore => appendChild(node, newChild)
+       RETURN
+    endif
+
+    np => node % firstChild
+    do while (associated(np))
+       if (associated(np, refChild)) then
+          if (associated(np,node%firstChild)) then
+             node%firstChild => newChild
+          else
+             refChild%previousSibling%nextSibling => newChild
+          endif
+
+          refChild % previousSibling => newChild
+          newChild % nextSibling => refChild
+          newChild % parentNode => node
+          newChild % ownerDocument => refChild % ownerDocument
+          insertBefore => newChild
+          RETURN
+       endif
+       np => np % nextSibling
+    enddo
+
+    call dom_error("insertBefore",NOT_FOUND_ERR,"refChild not found")
+
+  end function insertBefore
+
+!----------------------------------------------------------------------
+
+end module m_dom_node
+
Index: vendors/XMLF90/current/src/dom/m_dom_nodelist.f90
===================================================================
--- vendors/XMLF90/current/src/dom/m_dom_nodelist.f90	(revision 1899)
+++ vendors/XMLF90/current/src/dom/m_dom_nodelist.f90	(revision 1899)
@@ -0,0 +1,89 @@
+module m_dom_nodelist
+
+use m_dom_types
+
+private
+
+public :: item
+public :: getLength
+public :: append
+
+interface append
+   module procedure append_nl
+end interface
+
+interface item
+   module procedure item_nl
+end interface
+
+interface getLength
+   module procedure getLength_nl
+end interface
+
+CONTAINS
+
+  !-----------------------------------------------------------
+  ! METHODS FOR NODELISTS
+  !-----------------------------------------------------------
+  function item_nl(nodeList, i)
+    
+    integer, intent(in)             :: i
+    type(fnodeList), pointer        :: nodeList
+    type(fnode), pointer            :: item_nl
+    
+    type(flistNode), pointer :: lp
+    integer :: n
+
+    item_nl => null()            ! In case there is no such item
+    if (.not. associated(nodeList)) RETURN
+
+    lp => nodeList%head
+    n = -1
+    do 
+       if (.not. associated(lp))  exit
+       n = n + 1
+       if (n == i) then
+          item_nl => lp%node
+          exit
+       endif
+       lp => lp%next
+    enddo
+
+  end function item_nl
+
+  !----------------------------------------------------------- 
+
+  function getLength_nl(nodeList)
+    
+    type(fnodeList), pointer :: nodeList
+    integer                  :: getLength_nl
+
+    if (.not. associated(nodeList)) then
+       getLength_nl = 0
+    else
+       getLength_nl = nodeList % length
+    endif
+
+  end function getLength_nl
+
+  subroutine append_nl(nodeList,node)
+    type(fnodeList), pointer :: nodeList
+    type(fnode), pointer :: node
+
+    if (.not. associated(nodeList)) then
+       allocate(nodeList)
+       nodelist%length = 1
+       allocate(nodelist%head)
+       nodelist%head%node => node
+       nodelist%tail => nodelist%head
+    else
+       allocate(nodelist%tail%next)
+       nodelist%tail%next%node => node
+       nodelist%tail => nodelist%tail%next
+       nodelist%length = nodelist%length + 1
+    endif
+
+  end subroutine append_nl
+
+end module m_dom_nodelist
+
Index: vendors/XMLF90/current/src/dom/m_dom_parse.f90
===================================================================
--- vendors/XMLF90/current/src/dom/m_dom_parse.f90	(revision 1899)
+++ vendors/XMLF90/current/src/dom/m_dom_parse.f90	(revision 1899)
@@ -0,0 +1,152 @@
+module m_dom_parse
+
+  use m_dom_types
+  use m_dom_element
+  use m_dom_document
+  use m_dom_node
+!  use m_dom_namednodemap
+  use m_dom_debug
+
+  use flib_sax
+
+  implicit none
+  
+  private
+
+  public :: parsefile
+
+  type(fnode), pointer, private, save  :: main
+  type(fnode), pointer, private, save  :: current
+
+
+CONTAINS
+
+  subroutine begin_element_handler(name,attrs)
+
+    character(len=*),   intent(in) :: name
+    type(dictionary_t), intent(in) :: attrs
+   
+    type(fnode), pointer :: temp
+    character(len=400)   :: attr_name, attr_value
+    integer              :: status
+    integer              :: i
+
+    if (dom_debug) print *, "Adding node for element: ", name
+
+    temp => createElement(name)
+    current => appendChild(current,temp)
+!
+!   Add attributes
+!
+    do i = 1, len(attrs)
+       call get_name(attrs, i, attr_name, status)
+       call get_value(attrs, attr_name, attr_value, status)
+       if (dom_debug) print *, "Adding attribute: ", &
+                       trim(attr_name), ":",trim(attr_value)
+       call setAttribute(current,attr_name,attr_value)
+    enddo
+
+  end subroutine begin_element_handler
+
+!---------------------------------------------------------
+
+  subroutine end_element_handler(name)
+    character(len=*), intent(in)     :: name
+
+!!AG for IBM    type(fnode), pointer :: np
+
+    if (dom_debug) print *, "End of element: ", name
+!!AG for IBM    np => getParentNode(current)
+!!AG for IBM    current => np
+    current => getParentNode(current)
+  end subroutine end_element_handler
+
+!---------------------------------------------------------
+
+  subroutine pcdata_chunk_handler(chunk)
+    character(len=*), intent(in) :: chunk
+
+    type(fnode), pointer :: temp, dummy
+    
+    if (dom_debug) print *, "Got PCDATA: |", chunk, "|"
+
+    temp => createTextNode(chunk)
+    dummy => appendChild(current,temp)
+
+  end subroutine pcdata_chunk_handler
+
+!---------------------------------------------------------
+
+  subroutine comment_handler(comment)
+    character(len=*), intent(in) :: comment
+
+    type(fnode), pointer :: temp, dummy
+
+    if (dom_debug) print *, "Got COMMENT: |", comment, "|"
+
+    temp => createComment(comment)
+    dummy => appendChild(current,temp)
+
+  end subroutine comment_handler
+!---------------------------------------------------------
+  subroutine cdata_section_handler(chunk)
+    character(len=*), intent(in) :: chunk
+
+    type(fnode), pointer :: temp, dummy
+    
+    if (dom_debug) print *, "Got CDATA_SECTION: |", chunk, "|"
+
+    temp => createCdataSection(chunk)
+    dummy => appendChild(current,temp)
+
+  end subroutine cdata_section_handler
+
+!***************************************************
+!   PUBLIC PROCEDURES
+!***************************************************
+
+
+  function parsefile(filename, verbose, sax_verbose)
+
+    character(len=*), intent(in) :: filename
+    logical, intent(in), optional :: verbose
+    logical, intent(in), optional :: sax_verbose
+
+    type(fnode), pointer :: parsefile
+
+    logical :: sax_debug = .false.
+
+    type(xml_t) :: fxml
+    integer :: iostat
+
+    if (present(verbose)) then
+       dom_debug = verbose
+    endif
+
+    if (present(sax_verbose)) then
+       sax_debug = sax_verbose
+    endif
+    
+    call open_xmlfile(filename, fxml, iostat)
+
+    PRINT *,'filename : ',filename
+    if (iostat /= 0) then
+       stop "Cannot open file."
+    endif
+
+    main => createDocumentNode()
+    current => main
+
+    call xml_parse(fxml,  &
+           begin_element_handler, end_element_handler, pcdata_chunk_handler, &
+           comment_handler, cdata_section_handler=cdata_section_handler, &
+           verbose = sax_debug)    
+    call close_xmlfile(fxml)
+
+    parsefile => main
+    if (dom_debug) print *, "Number of allocated nodes: ", getNumberofAllocatedNodes()
+
+  end function parsefile
+
+
+END MODULE m_dom_parse
Index: vendors/XMLF90/current/src/dom/m_dom_types.f90
===================================================================
--- vendors/XMLF90/current/src/dom/m_dom_types.f90	(revision 1899)
+++ vendors/XMLF90/current/src/dom/m_dom_types.f90	(revision 1899)
@@ -0,0 +1,195 @@
+Module m_dom_types
+
+  use m_strings
+
+  implicit none
+
+  private
+
+  !-------------------------------------------------------   
+  ! A GENERIC NODE
+  !-------------------------------------------------------   
+  type, public :: fnode
+     type(string)         :: nodeName    
+     type(string)         :: nodeValue   
+!!!     character(len=200)    :: nodeName  = ""
+!!!     character(len=200)    :: nodeValue = ""
+     integer              :: nc              = 0 
+     integer              :: nodeType        = 0
+     type(fnode), pointer :: parentNode      => null()
+     type(fnodeList), pointer :: childNodes  => null()  ! New
+     type(fnode), pointer :: firstChild      => null()
+     type(fnode), pointer :: lastChild       => null()
+     type(fnode), pointer :: previousSibling => null()
+     type(fnode), pointer :: nextSibling     => null()
+     type(fnode), pointer :: ownerDocument   => null()
+     type(fnamedNodeMap), pointer :: attributes => null()
+  end type fnode
+
+  !-----------------------------------------------------------
+  !  ONE WAY TO IMPLEMENT A NAMEDNODEMAP  (dictionary)
+  !-----------------------------------------------------------
+
+  ! Linked list of name/node pairs, with overall length variable
+
+  type, public :: fnamedNode
+     type(string)                   :: name
+!!!     character(len=100)            :: name
+     type(fnode), pointer          :: node => null()
+     type(fnamedNode), pointer     :: next => null()
+  end type fnamedNode
+
+  type, public :: fnamedNodeMap
+     integer :: length = 0
+     type(fnamedNode), pointer  :: head => null()
+     type(fnamedNode), pointer  :: tail => null()
+  end type fnamedNodeMap
+
+  !-----------------------------------------------------------
+  !  ONE WAY TO IMPLEMENT A NODELIST 
+  !-----------------------------------------------------------
+
+  type, public :: flistNode
+     type(fnode), pointer          :: node => null()
+     type(flistNode), pointer      :: next => null()
+  end type flistNode
+
+  type, public :: fnodeList
+     integer                      :: length = 0
+     type(flistNode), pointer     :: head => null()
+     type(flistNode), pointer     :: tail => null()
+  end type fnodeList
+
+!========================================================================
+  integer, save, private          :: allocated_nodes = 0
+!========================================================================
+
+  !-------------------------------------------------------   
+  ! NODETYPES
+  !-------------------------------------------------------   
+  integer, parameter, public :: ELEMENT_NODE                = 1
+  integer, parameter, public :: ATTRIBUTE_NODE              = 2
+  integer, parameter, public :: TEXT_NODE                   = 3
+  integer, parameter, public :: CDATA_SECTION_NODE          = 4
+  integer, parameter, public :: ENTITY_REFERENCE_NODE       = 5
+  integer, parameter, public :: ENTITY_NODE                 = 6
+  integer, parameter, public :: PROCESSING_INSTRUCTION_NODE = 7
+  integer, parameter, public :: COMMENT_NODE                = 8
+  integer, parameter, public :: DOCUMENT_NODE               = 9
+  integer, parameter, public :: DOCUMENT_TYPE_NODE          = 10
+  integer, parameter, public :: DOCUMENT_FRAGMENT_NODE      = 11
+  integer, parameter, public :: NOTATION_NODE               = 12
+
+  public :: node_class
+  public :: createNode
+  public :: destroyNode
+  public :: destroyNamedNodeMap
+  public :: destroyNodeList
+  public :: getNumberofAllocatedNodes
+
+CONTAINS
+
+  function getNumberofAllocatedNodes() result(n)
+    integer   :: n
+
+    n = allocated_nodes
+  end function getNumberofAllocatedNodes
+
+!--------------------------------------------------------------
+  function createNode() result(node)
+    type(fnode), pointer  :: node
+
+    allocate(node)
+    allocated_nodes = allocated_nodes + 1
+
+  end function createNode
+!--------------------------------------------------------------
+
+  function node_class(nodetype) result(class)
+    integer, intent(in) :: nodetype
+    character(len=10)  ::     class
+
+    select case(nodetype)
+    case(ELEMENT_NODE)
+       class = "element"
+    case(ATTRIBUTE_NODE)
+       class = "attribute"
+    case(TEXT_NODE)
+       class = "text"
+    case(COMMENT_NODE)
+       class = "comment"
+    case(DOCUMENT_NODE)
+       class = "document"
+    end select
+  end function node_class
+
+  subroutine destroyNamedNodeMap(nodemap)
+    type(fnamedNodeMap), pointer :: nodemap
+
+    type(fnamednode), pointer  :: nnp
+    type(fnode), pointer       :: ghost
+    
+    if (.not. associated(nodemap)) return
+    nnp => nodemap%head
+    do while (associated(nnp))
+       call unstring(nnp%name)
+       ghost => nnp%node
+       nnp => nnp%next
+       call destroyNode(ghost)      ! We might not want to really destroy
+    enddo
+  end subroutine destroyNamedNodeMap
+
+  subroutine destroyNodeList(nodelist)
+    type(fnodeList), pointer :: nodelist
+
+    type(flistnode), pointer   :: p
+    type(fnode), pointer       :: ghost
+    
+    if (.not. associated(nodelist)) return
+    p => nodelist%head
+    do while (associated(p))
+       ghost => p%node
+       p => p%next
+       call destroyNode(ghost)      ! We might not want to really destroy
+    enddo
+  end subroutine destroyNodeList
+
+  recursive subroutine destroyNode(node)
+    type(fnode), pointer  :: node
+    
+    type(fnode), pointer  :: np, ghost
+    
+    np => node
+    do while (associated(np))
+       if (associated(np%firstChild)) then
+          call destroyNode(np%firstChild)
+       endif
+       if (associated(np%attributes)) call destroyNamedNodeMap(np%attributes)
+       call unstring(np%nodeName)
+       call unstring(np%nodeValue)
+       if (associated(np%previousSibling)) & 
+                np%previousSibling%nextSibling => np%nextSibling
+       if (associated(np%nextSibling)) & 
+                np%nextSibling%previousSibling => np%previousSibling
+       if (associated(np%parentNode)) then
+          if (associated(np%parentNode%firstChild,np)) &
+               np%parentNode%firstChild => null()
+          if (associated(np%parentNode%lastChild,np)) &
+               np%parentNode%lastChild => null()
+       endif
+       if (associated(np,node)) then    
+          deallocate(np)
+          allocated_nodes = allocated_nodes - 1
+          EXIT                           ! do not destroy siblings
+       else
+          ghost => np
+          np => np%nextSibling
+          deallocate(ghost)
+          allocated_nodes = allocated_nodes - 1
+       endif
+    enddo
+    node => null()     ! superfluous ?
+  end subroutine destroyNode
+
+end module m_dom_types
+
Index: vendors/XMLF90/current/src/dom/m_dom_utils.f90
===================================================================
--- vendors/XMLF90/current/src/dom/m_dom_utils.f90	(revision 1899)
+++ vendors/XMLF90/current/src/dom/m_dom_utils.f90	(revision 1899)
@@ -0,0 +1,131 @@
+module m_dom_utils
+
+  use m_dom_types
+  use m_dom_element
+  use m_dom_document
+  use m_dom_node
+  use m_dom_namednodemap
+  use m_dom_debug
+  use m_strings
+
+  use flib_wxml
+
+  public :: dumpTree
+  public :: xmlize
+
+  private
+
+CONTAINS
+
+  subroutine dumpTree(startNode)
+
+    type(fnode), pointer :: startNode   
+
+    character(len=50) :: indent = " "
+    integer           :: indent_level
+    type(string)      :: s
+
+    indent_level = 0
+
+    call dump2(startNode)
+
+  contains
+
+    recursive subroutine dump2(input)
+      type(fnode), pointer :: input
+      type(fnode), pointer :: temp     
+      temp => input
+      do while(associated(temp))
+         s = getNodeName(temp)
+         write(*,'(3a,i3)') indent(1:indent_level), &
+                        char(s), " of type ", &
+                        getNodeType(temp)
+         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 xmlize(startNode,fname)
+
+    type(fnode), pointer :: startNode   
+    character(len=*), intent(in) :: fname
+
+    type(xmlf_t)  :: xf
+    type(string)  :: s, sv, sn       ! to avoid memory leaks
+
+    call xml_OpenFile(fname,xf)
+    call dump_xml(startNode)
+    call xml_Close(xf)
+
+  contains
+
+    recursive subroutine dump_xml(input)
+      type(fnode), pointer         :: input
+!
+!     Just this node and its descendants, no siblings. 
+!     Of course, the document node has only children...
+!
+      type(fnode), pointer         :: node, attr
+      type(fnamedNodeMap), pointer :: attr_map
+      integer  ::  i
+
+      node => input
+      do
+         if (.not. associated(node)) exit
+         select case (getNodeType(node))
+
+          case (DOCUMENT_NODE)
+
+             call xml_AddXMLDeclaration(xf)
+             if (hasChildNodes(node)) call dump_xml(getFirstChild(node))
+
+          case (ELEMENT_NODE)
+
+             s = getNodeName(node)
+             call xml_NewElement(xf,char(s))
+             attr_map => getAttributes(node)
+             do i = 0, getLength(attr_map) - 1
+                attr => item(attr_map,i)
+                sn = getNodeName(attr)
+                sv = getNodeValue(attr)
+                call xml_AddAttribute(xf, char(sn),char(sv))
+             enddo
+             if (hasChildNodes(node)) call dump_xml(getFirstChild(node))
+             s = getNodeName(node)
+             call xml_EndElement(xf,char(s))
+
+          case (TEXT_NODE)
+             
+             s = getNodeValue(node)
+             call xml_AddPcdata(xf,char(s))
+
+          case (CDATA_SECTION_NODE)
+             
+             s = getNodeValue(node)
+             call xml_AddCdataSection(xf,char(s))
+
+          case (COMMENT_NODE)
+             
+             s = getNodeValue(node)
+             call xml_AddComment(xf,char(s))
+
+        end select
+        if (associated(node,StartNode)) exit  ! In case we request the 
+                                              ! dumping of a single element,
+                                              ! do not do siblings
+        node => getNextSibling(node)
+     enddo
+
+    end subroutine dump_xml
+
+  end subroutine xmlize
+
+end module m_dom_utils
Index: vendors/XMLF90/current/src/sax/CHANGES
===================================================================
--- vendors/XMLF90/current/src/sax/CHANGES	(revision 1899)
+++ vendors/XMLF90/current/src/sax/CHANGES	(revision 1899)
@@ -0,0 +1,28 @@
+April 28, 2004
+
+* New optional argument "record_size" in open_xmlfile. The default record 
+length is 65536, but for overly long lines it might be necessary to specify
+a larger size.
+
+* Wrote "init_" routines to avoid undefined status for the components
+of the buffer, dictionary, and elstack derived types (Fortran90 restriction). 
+They are called just once at the beginning of execution.
+
+The "reset_" routines just zero out the counters in the derived
+types. This leads to substantial savings in overhead.
+
+* Avoided when possible the allocation of temporaries (mostly strings) by
+the compilers. This was particularly acute in the "action" records. The
+typical idiom:
+
+	action =trim("Reading character in name: " // c)
+
+forced the allocation of a temporary.  The number of compiler allocations
+(at least with NAG) has dropped down to just those needed in the processing
+of entities.
+
+* Put the explicit module dependencies in the makefile.
+
+* Increased the standard size of the buffers and dictionaries.
+***** The program now stops when those sizes are not enough.
+
Index: vendors/XMLF90/current/src/sax/Developer.Guide
===================================================================
--- vendors/XMLF90/current/src/sax/Developer.Guide	(revision 1899)
+++ vendors/XMLF90/current/src/sax/Developer.Guide	(revision 1899)
@@ -0,0 +1,61 @@
+Developer Notes:
+
+The parser is built on several levels:
+
+1. The closest to the user.
+
+   Modules:  m_xml_parser: The main module
+             m_error     : Basic error handling
+
+2. An intermediate layer.
+
+   Modules: m_fsm  (A finite-state machine to parse the input)
+
+3. A layer defining basic data structures and file interfaces:
+
+   Modules: m_reader:  File interface and character handling as per XML specs.
+	    m_buffer:  Basic homemade "variable length string", with some
+                       limitations (size, of course), but avoiding the
+                       use of dynamic structures for now.
+	    m_dictionary: Simple, not dynamic.
+            m_charset: A simple hashing method for sets of characters.
+	    m_elstack: Simple stack to check well-formedness.
+	    m_entities: Entity replacement utilities.
+
+4. Something which does not really belong in the parser but which
+   is useful to massage the data extracted from the file:
+
+	m_converters: Routines to turn pcdata chunks into numerical arrays
+
+
+There are obviously a number of hardwired limitations, which should be
+removed in a later version:
+
+* Buffer size in buffer_t definition. This is not as serious as it
+  looks. Only long unbroken pcdata sections and overly long attribute
+  names or values will be affected. Long SGML declarations and comments
+  might be truncated, but they are not relevant anyway.
+
+* Maximum number of attributes in an element tag (set in m_dictionary)
+
+While the parser does not use any variable-length strings (to keep it
+compatible with existing Fortran90 compilers) or dynamical data
+structures for attribute dictionaries, etc, such improvements could be
+incorporated almost as drop-in replacements for existing sub-modules.
+
+
+The coding style is that of the F subset of Fortran90. I strongly
+believe that it makes for better coding and fewer errors.
+Go to http://www.fortran.com/imagine1/ and get a feel for it. You can
+download free implementations for Linux and Windows, or get an
+inexpensive CD+Book combination to help support the project. Of course,
+F *is* Fortran, so you can always compile it with a Fortran compiler.
+
+
+
+
+
+
+
+
+
Index: vendors/XMLF90/current/src/sax/TODO
===================================================================
--- vendors/XMLF90/current/src/sax/TODO	(revision 1899)
+++ vendors/XMLF90/current/src/sax/TODO	(revision 1899)
@@ -0,0 +1,7 @@
+Things to do:
+
+* Make buffer pseudo-dynamical to avoid limitations.
+* Insert code to deal with XML declarations (really processing instructions)
+  which are not of the form
+  
+ <?name  pseudo_att_name="pseudo_att_value" .... ?>
Index: vendors/XMLF90/current/src/sax/flib_sax.f90
===================================================================
--- vendors/XMLF90/current/src/sax/flib_sax.f90	(revision 1899)
+++ vendors/XMLF90/current/src/sax/flib_sax.f90	(revision 1899)
@@ -0,0 +1,19 @@
+module flib_sax
+
+!
+! Stub module to gather all the functionality needed by the user
+! 
+! In future m_dictionary and m_converters could be exported by
+! other parts of a more general fortran library.
+!
+! m_xml_error is necessary in order to use a custom error handler.
+!
+use m_dictionary
+use m_xml_parser
+use m_converters
+use m_xml_error
+
+public
+
+end module flib_sax
+
Index: vendors/XMLF90/current/src/sax/m_buffer.f90
===================================================================
--- vendors/XMLF90/current/src/sax/m_buffer.f90	(revision 1899)
+++ vendors/XMLF90/current/src/sax/m_buffer.f90	(revision 1899)
@@ -0,0 +1,200 @@
+module m_buffer
+
+!
+! 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".
+! There is code in m_fsm to avoid buffer overflows
+! caused by pcdata with whitespace.
+!
+! In a forthcoming implementation it could be made dynamical...
+!
+integer, parameter, public   :: MAX_BUFF_SIZE  = 10000
+integer, parameter, private  :: BUFF_SIZE_WARNING  = 900
+
+!
+
+type, public  :: buffer_t
+private
+      integer                       :: size
+      character(len=MAX_BUFF_SIZE)  :: str
+end type buffer_t
+
+public :: add_to_buffer
+public :: print_buffer, str, len       !! , char
+public :: operator (.equal.)
+public :: buffer_nearly_full, reset_buffer, init_buffer
+public :: buffer_to_character
+
+
+!----------------------------------------------------------------
+interface add_to_buffer
+      module procedure add_str_to_buffer
+end interface
+private :: add_char_to_buffer, add_str_to_buffer
+
+interface operator (.equal.)
+      module procedure compare_buffers, compare_buffer_str, &
+             compare_str_buffer
+end interface
+private :: compare_buffers, compare_buffer_str, compare_str_buffer
+
+interface str
+      module procedure buffer_to_str
+end interface
+interface char                 ! Experimental
+      module procedure buffer_to_str
+end interface
+private :: buffer_to_str
+
+interface len
+   module procedure buffer_length
+end interface
+private :: buffer_length
+
+CONTAINS
+!==================================================================
+
+!----------------------------------------------------------------
+function compare_buffers(a,b) result(equal)     ! .equal. generic
+type(buffer_t), intent(in)  :: a
+type(buffer_t), intent(in)  :: b
+logical                     :: equal
+
+equal = ((a%size == b%size) .and. (a%str(1:a%size) == b%str(1:b%size)))
+
+end function compare_buffers
+
+!----------------------------------------------------------------
+function compare_buffer_str(buffer,str) result(equal) ! .equal. generic
+type(buffer_t), intent(in)   :: buffer
+character(len=*), intent(in) :: str
+logical                      :: equal
+
+equal = (buffer%str(1:buffer%size) == trim(str))
+
+end function compare_buffer_str
+
+!----------------------------------------------------------------
+function compare_str_buffer(str,buffer) result(equal) ! .equal. generic
+character(len=*), intent(in) :: str
+type(buffer_t), intent(in)   :: buffer
+logical                     :: equal
+
+equal = (buffer%str(1:buffer%size) == trim(str))
+
+end function compare_str_buffer
+
+!----------------------------------------------------------------
+subroutine add_char_to_buffer(c,buffer)
+character(len=1), intent(in)   :: c
+type(buffer_t), intent(inout)  :: buffer
+
+integer   :: n
+buffer%size = buffer%size + 1
+n = buffer%size
+
+if (n> MAX_BUFF_SIZE) then
+!!  RETURN
+!
+!  It will only affect long comments and sgml declarations
+   STOP "sax 1 Buffer overflow: long unbroken string of pcdata or attribute value..."
+endif
+
+buffer%str(n:n) = c
+end subroutine add_char_to_buffer
+
+!----------------------------------------------------------------
+subroutine add_str_to_buffer(s,buffer)
+character(len=*), intent(in)   :: s
+type(buffer_t), intent(inout)  :: buffer
+
+integer   :: n, len_s, last_pos
+
+len_s = len(s)
+last_pos = buffer%size
+buffer%size = buffer%size + len_s
+n = buffer%size
+
+if (n> MAX_BUFF_SIZE) then
+!!  RETURN
+!
+!  It will only affect long comments and sgml declarations
+  STOP "sax 2 Buffer overflow: long unbroken string of pcdata or attribute value..."
+endif
+
+buffer%str(last_pos+1:n) = s
+end subroutine add_str_to_buffer
+
+!----------------------------------------------------------------
+subroutine init_buffer(buffer)
+type(buffer_t), intent(inout)  :: buffer
+
+buffer%size = 0
+buffer%str=""               ! To avoid "undefined" status
+
+end subroutine init_buffer
+!----------------------------------------------------------------
+subroutine reset_buffer(buffer)
+type(buffer_t), intent(inout)  :: buffer
+  buffer%size = 0
+end subroutine reset_buffer
+!----------------------------------------------------------------
+subroutine print_buffer(buffer)
+type(buffer_t), intent(in)  :: buffer
+
+integer :: i
+
+do i = 1, buffer%size
+      write(unit=6,fmt="(a1)",advance="no") buffer%str(i:i)
+enddo
+
+end subroutine print_buffer
+!----------------------------------------------------------------
+! This is better... but could it lead to memory leaks?
+!
+function buffer_to_str(buffer) result(str)
+type(buffer_t), intent(in)          :: buffer
+character(len=buffer%size)          :: str
+
+str = buffer%str(1:buffer%size)
+end function buffer_to_str
+
+!----------------------------------------------------------------
+!
+subroutine buffer_to_character(buffer,str)
+type(buffer_t), intent(in)          :: buffer
+character(len=*), intent(out)       :: str
+
+str = buffer%str(1:buffer%size)
+end subroutine buffer_to_character
+
+!----------------------------------------------------------------
+function buffer_nearly_full(buffer) result(warn)
+type(buffer_t), intent(in)          :: buffer
+logical                             :: warn
+
+warn = buffer%size > BUFF_SIZE_WARNING
+
+end function buffer_nearly_full
+
+!----------------------------------------------------------------
+function buffer_length(buffer) result(length)
+type(buffer_t), intent(in)          :: buffer
+integer                             :: length
+
+length = buffer%size 
+
+end function buffer_length
+
+
+end module m_buffer
+
+
+
+
+
+
+
Index: vendors/XMLF90/current/src/sax/m_charset.f90
===================================================================
--- vendors/XMLF90/current/src/sax/m_charset.f90	(revision 1899)
+++ vendors/XMLF90/current/src/sax/m_charset.f90	(revision 1899)
@@ -0,0 +1,203 @@
+module m_charset
+!
+! One-byte only, sorry
+!
+private
+
+integer, parameter, private  :: small_int = selected_int_kind(1)
+
+!--------------------------------------------------------------------------
+type, public :: charset_t
+! private
+      integer(kind=small_int), dimension(0:255) :: mask
+end type charset_t
+
+
+public  :: operator(.in.), operator(+)
+public  :: assignment(=)
+public  :: print_charset, reset_charset
+
+interface operator(.in.)
+      module procedure belongs
+end interface
+private :: belongs
+
+interface assignment(=)
+      module procedure set_string_to_charset, set_codes_to_charset
+end interface
+private ::  set_string_to_charset, set_codes_to_charset
+
+interface operator(+)
+      module procedure add_string_to_charset, &
+                       add_code_to_charset, add_codes_to_charset
+end interface
+private :: add_string_to_charset, add_code_to_charset, add_codes_to_charset
+
+!--------------------------------------------------------------------------
+
+character(len=*), parameter, private :: &
+            lowercase = "abcdefghijklmnopqrstuvwxyz",  & 
+            uppercase = "ABCDEFGHIJKLMNOPQRSTUVWXYZ", &
+            digits    = "0123456789"
+
+integer, parameter, public   :: SPACE           = 32
+integer, parameter, public   :: NEWLINE         = 10
+integer, parameter, public   :: CARRIAGE_RETURN = 13
+integer, parameter, public   :: TAB             =  9
+
+type(charset_t), public    :: initial_name_chars
+type(charset_t), public    :: name_chars
+type(charset_t), public    :: whitespace
+type(charset_t), public    :: valid_chars
+type(charset_t), public    :: uppercase_chars
+
+public  :: setup_xml_charsets
+
+
+CONTAINS !==========================================================
+
+!--------------------------------------------------------------
+function belongs(c,charset)  result(res)
+character(len=1), intent(in)  :: c
+type(charset_t), intent(in)   :: charset
+logical                       :: res
+
+integer  :: code
+
+code = ichar(c)
+res = (charset%mask(code) == 1)
+
+end function belongs
+
+!--------------------------------------------------------------
+
+function add_string_to_charset(charset,str)  result (sum)
+type(charset_t), intent(in)      :: charset
+character(len=*), intent(in)     :: str
+type(charset_t)                  :: sum
+
+integer :: length, code, i
+
+sum%mask = charset%mask
+
+length = len_trim(str)
+do i = 1, length
+      code = ichar(str(i:i))
+      sum%mask(code) = 1
+enddo
+end function add_string_to_charset
+
+!--------------------------------------------------------------
+
+function add_code_to_charset(charset,code) result(sum)
+type(charset_t), intent(in)      :: charset
+integer, intent(in)              :: code
+type(charset_t)                  :: sum
+
+if ((code > 255) .or. (code < 0)) return
+sum%mask = charset%mask
+sum%mask(code) = 1
+
+end function add_code_to_charset
+
+!--------------------------------------------------------------
+function add_codes_to_charset(charset,codes) result(sum)
+type(charset_t), intent(in)        :: charset
+integer, dimension(:), intent(in)  :: codes
+type(charset_t)                    :: sum
+
+integer  :: i
+
+sum%mask = charset%mask
+do i = 1, size(codes)
+      if ((codes(i) > 255) .or. (codes(i) < 0)) cycle
+      sum%mask(codes(i)) = 1
+enddo
+end function add_codes_to_charset
+
+!--------------------------------------------------------------
+
+subroutine set_string_to_charset(charset,str)      
+type(charset_t), intent(out)   :: charset
+character(len=*), intent(in)   :: str
+
+
+integer :: length, code, i
+
+charset%mask = 0
+
+length = len_trim(str)
+do i = 1, length
+      code = ichar(str(i:i))
+      charset%mask(code) = 1
+enddo
+
+end subroutine set_string_to_charset
+
+!--------------------------------------------------------------
+
+subroutine set_codes_to_charset(charset,codes)      
+type(charset_t), intent(out)   :: charset
+integer, dimension(:), intent(in)  :: codes
+
+integer :: i
+
+charset%mask = 0
+
+do i = 1, size(codes)
+      charset%mask(codes(i)) = 1
+enddo
+
+end subroutine set_codes_to_charset
+
+
+!--------------------------------------------------------------
+subroutine print_charset(charset)      
+type(charset_t), intent(in)   :: charset
+
+integer :: i
+
+do i = 0, 255
+      if (charset%mask(i) == 1) print *, "Code: ", i
+enddo
+end subroutine print_charset
+
+!--------------------------------------------------------------
+
+subroutine reset_charset(charset)      
+type(charset_t), intent(inout)   :: charset
+
+integer :: i
+
+do i = 0, 255
+      charset%mask(i) = 0
+enddo
+end subroutine reset_charset
+
+!--------------------------------------------------------------
+
+!--------------------------------------------------------
+subroutine setup_xml_charsets()
+
+integer :: i
+
+uppercase_chars = uppercase
+initial_name_chars = (lowercase  // uppercase //  "_:" )
+name_chars = initial_name_chars + ( digits // ".-")
+whitespace = (/ SPACE, NEWLINE, TAB, CARRIAGE_RETURN /)
+
+valid_chars = whitespace + (/ (i, i=33,255) /)
+
+end subroutine setup_xml_charsets
+!--------------------------------------------------------
+
+end module m_charset
+
+
+
+
+
+
+
+
+
Index: vendors/XMLF90/current/src/sax/m_converters.f90
===================================================================
--- vendors/XMLF90/current/src/sax/m_converters.f90	(revision 1899)
+++ vendors/XMLF90/current/src/sax/m_converters.f90	(revision 1899)
@@ -0,0 +1,180 @@
+module m_converters
+
+use m_debug
+
+private
+!
+! Takes a string and turns it into useful data structures,
+! such as numerical arrays.
+!
+! NOTE: The string must contain *homogeneous* data, i.e.: all real numbers,
+! all integers, etc.
+!
+public :: build_data_array
+
+interface build_data_array
+      module procedure build_data_array_real_sp,  &
+                       build_data_array_real_dp,  &
+                       build_data_array_integer
+end interface
+private :: build_data_array_real_sp
+private :: build_data_array_real_dp
+private :: build_data_array_integer
+
+private :: token_analysis, is_separator, is_CR_or_LF
+
+CONTAINS
+
+!---------------------------------------------------------------
+subroutine build_data_array_real_dp(str,x,n)
+integer, parameter  :: dp = selected_real_kind(14)
+!
+character(len=*), intent(in)                ::  str
+real(kind=dp), dimension(:), intent(inout)  ::    x
+integer, intent(inout)                      ::    n
+
+integer                            :: ntokens, status, last_pos
+character(len=len(str))  :: s
+
+s = str
+call token_analysis(s,ntokens,last_pos)
+if (debug) print *, "ntokens, last_pos ", ntokens, last_pos
+if (debug) print *, s
+if ((n + ntokens) > size(x)) STOP "data array full"
+read(unit=s(1:last_pos),fmt=*,iostat=status) x(n+1:n+ntokens)
+if (status /= 0) STOP "real conversion error"
+n = n + ntokens
+
+end subroutine build_data_array_real_dp
+!---------------------------------------------------------------
+
+subroutine build_data_array_real_sp(str,x,n)
+integer, parameter  :: sp = selected_real_kind(6)
+!
+character(len=*), intent(in)                :: str
+real(kind=sp), dimension(:), intent(inout)  ::    x
+integer, intent(inout)                      ::    n
+
+integer                            :: ntokens, status, last_pos
+character(len=len(str))  :: s
+
+s = str
+call token_analysis(s,ntokens,last_pos)
+if (debug) print *, "ntokens, last_pos ", ntokens, last_pos
+if (debug) print *, s
+if ((n + ntokens) > size(x)) STOP "data array full"
+read(unit=s(1:last_pos),fmt=*,iostat=status) x(n+1:n+ntokens)
+if (status /= 0) STOP "real conversion error"
+n = n + ntokens
+
+end subroutine build_data_array_real_sp
+
+!---------------------------------------------------------------
+subroutine build_data_array_integer(str,x,n)
+integer, parameter  :: sp = selected_real_kind(14)
+!
+character(len=*), intent(in)                :: str
+integer, dimension(:), intent(inout)        ::    x
+integer, intent(inout)                      ::    n
+
+integer                            :: ntokens, status, last_pos
+character(len=len(str))  :: s
+
+s = str
+call token_analysis(s,ntokens,last_pos)
+if (debug) print *, "ntokens, last_pos ", ntokens, last_pos
+if (debug) print *, s
+if ((n + ntokens) > size(x)) STOP "data array full"
+read(unit=s(1:last_pos),fmt=*,iostat=status) x(n+1:n+ntokens)
+if (status /= 0) STOP "integer conversion error"
+n = n + ntokens
+
+end subroutine build_data_array_integer
+
+
+!==================================================================
+
+function is_separator(c) result(sep)
+character(len=1), intent(in)          :: c
+logical                               :: sep
+
+ sep = ((c == char(32)) .or. (c == char(10))             &
+         .or. (c == char(9)) .or. (c == char(13)))
+
+end function is_separator
+!----------------------------------------------------------------
+function is_CR_or_LF(c) result(res)
+character(len=1), intent(in)          :: c
+logical                               :: res
+
+ res = ((c == char(10)) .or. (c == char(13)))
+
+end function is_CR_or_LF
+
+!==================================================================
+
+subroutine token_analysis(str,ntokens,last_pos)
+!
+character(len=*), intent(inout)          :: str
+integer, intent(out)                     :: ntokens, last_pos
+!
+!
+! Checks the contents of a string and finds the number of tokens it contains
+! The standard separator is generalized whitespace (space, tab, CR, or LF)
+! It also returns the last useful position in the string (excluding
+! separator characters which are not blanks, and thus not caught by the
+! (len_)trim fortran intrinsic). This is necessary to perform list-directed
+! I/O in the string as an internal file.
+! 
+! Also, replace on the fly CR and LF by blanks. This is necessary if
+! str spans more than one record. In that case, internal reads only 
+! look at the first record. 
+! -- ** Compiler limits on size of internal record??
+!
+integer           :: i, str_length
+logical           :: in_token
+character(len=1)  :: c
+
+in_token = .false.
+ntokens = 0
+last_pos = 0
+
+str_length = len_trim(str)
+!print *, "string length: ", str_length
+
+do i = 1, str_length
+      c = str(i:i)
+
+      if (in_token) then
+         if (is_separator(c)) then
+            in_token = .false.
+            if (is_CR_or_LF(c)) str(i:i) = " "
+         else
+            last_pos = i
+         endif
+
+      else   ! not in token
+         
+         if (is_separator(c)) then
+            if (is_CR_or_LF(c)) str(i:i) = " "
+            ! do nothing
+         else
+            in_token = .true.
+            last_pos = i
+            ntokens = ntokens + 1
+         endif
+      endif
+enddo
+!print *, "ntokens, last_pos: ", ntokens, last_pos
+
+end subroutine token_analysis
+
+
+end module m_converters
+
+
+
+
+
+
+
Index: vendors/XMLF90/current/src/sax/m_debug.f90
===================================================================
--- vendors/XMLF90/current/src/sax/m_debug.f90	(revision 1899)
+++ vendors/XMLF90/current/src/sax/m_debug.f90	(revision 1899)
@@ -0,0 +1,5 @@
+module m_debug
+
+logical, public, save   :: debug = .false.
+
+end module m_debug
Index: vendors/XMLF90/current/src/sax/m_dictionary.f90
===================================================================
--- vendors/XMLF90/current/src/sax/m_dictionary.f90	(revision 1899)
+++ vendors/XMLF90/current/src/sax/m_dictionary.f90	(revision 1899)
@@ -0,0 +1,183 @@
+module m_dictionary
+
+use m_buffer
+private
+!
+! A very rough implementation for now
+! It uses fixed-length buffers for key/value pairs,
+! and the maximum number of dictionary items is hardwired.
+
+integer, parameter, private    :: MAX_ITEMS = 64
+type, public :: dictionary_t
+private
+      integer                               :: number_of_items
+      type(buffer_t), dimension(MAX_ITEMS)  :: key
+      type(buffer_t), dimension(MAX_ITEMS)  :: value
+end type dictionary_t
+
+!
+! Building procedures
+!
+public  :: add_key_to_dict, add_value_to_dict, init_dict, reset_dict
+
+!
+! Query and extraction procedures
+!
+public  :: len
+interface len
+   module procedure number_of_entries
+end interface
+public  :: number_of_entries
+public  :: get_key
+public  :: get_value
+public  :: has_key
+public  :: print_dict
+!
+public  :: get_name
+
+interface get_name
+   module procedure get_key
+end interface
+
+interface get_value
+   module procedure sax_get_value
+end interface
+private :: sax_get_value
+
+CONTAINS
+
+!------------------------------------------------------
+function number_of_entries(dict) result(n)
+type(dictionary_t), intent(in)   :: dict
+integer                          :: n
+
+n = dict%number_of_items
+
+end function number_of_entries
+
+!------------------------------------------------------
+function has_key(dict,key) result(found)
+type(dictionary_t), intent(in)   :: dict
+character(len=*), intent(in)     :: key
+logical                          :: found
+
+integer  :: n, i
+found = .false.
+n = dict%number_of_items
+do  i = 1, n
+      if (dict%key(i) .EQUAL. key) then
+         found = .true.
+         exit
+      endif
+enddo
+end function has_key
+
+!------------------------------------------------------
+subroutine sax_get_value(dict,key,value,status)
+type(dictionary_t), intent(in)            :: dict
+character(len=*), intent(in)              :: key
+character(len=*), intent(out)             :: value
+integer, intent(out)                      :: status
+!
+integer  :: n, i
+
+status = -1
+n = dict%number_of_items
+do  i = 1, n
+      if (dict%key(i) .EQUAL. key) then
+         value = str(dict%value(i))
+         status = 0
+         RETURN
+      endif
+enddo
+
+end subroutine sax_get_value
+
+!------------------------------------------------------
+subroutine get_key(dict,i,key,status)
+!
+! Get the i'th key
+!
+type(dictionary_t), intent(in)            :: dict
+integer, intent(in)                       :: i
+character(len=*), intent(out)             :: key
+integer, intent(out)                      :: status
+
+if (i <= dict%number_of_items) then
+      key = str(dict%key(i))
+      status = 0
+else
+      key = ""
+      status = -1
+endif
+
+end subroutine get_key
+
+!------------------------------------------------------
+subroutine add_key_to_dict(key,dict)
+type(buffer_t), intent(in)          :: key
+type(dictionary_t), intent(inout)   :: dict
+
+integer  :: n
+
+n = dict%number_of_items
+if (n == MAX_ITEMS) then
+      write(unit=0,fmt=*) "Dictionary capacity exceeded ! size= ", max_items
+      RETURN
+endif
+
+n = n + 1
+dict%key(n) = key
+dict%number_of_items = n
+
+end subroutine add_key_to_dict
+
+!------------------------------------------------------
+! Assumes we build the dictionary in an orderly fashion,
+! so one adds first the key and then immediately afterwards the value.
+!
+subroutine add_value_to_dict(value,dict)
+type(buffer_t), intent(in)          :: value
+type(dictionary_t), intent(inout)   :: dict
+
+integer  :: n
+
+n = dict%number_of_items
+dict%value(n) = value
+
+end subroutine add_value_to_dict
+
+!------------------------------------------------------
+subroutine init_dict(dict)
+type(dictionary_t), intent(inout)   :: dict
+
+integer  :: i
+
+dict%number_of_items = 0
+do i=1, MAX_ITEMS                      ! To avoid "undefined" status
+   call init_buffer(dict%key(i))       ! (Fortran90 restriction)
+   call init_buffer(dict%value(i))
+enddo
+end subroutine init_dict
+!------------------------------------------------------
+subroutine reset_dict(dict)
+type(dictionary_t), intent(inout)   :: dict
+
+dict%number_of_items = 0
+
+end subroutine reset_dict
+
+!------------------------------------------------------
+subroutine print_dict(dict)
+type(dictionary_t), intent(in)   :: dict
+
+integer  :: i
+
+do i = 1, dict%number_of_items
+      print *, trim(str(dict%key(i))), " = ", trim(str(dict%value(i)))
+enddo
+
+end subroutine print_dict
+
+
+end module m_dictionary
Index: vendors/XMLF90/current/src/sax/m_elstack.f90
===================================================================
--- vendors/XMLF90/current/src/sax/m_elstack.f90	(revision 1899)
+++ vendors/XMLF90/current/src/sax/m_elstack.f90	(revision 1899)
@@ -0,0 +1,153 @@
+module m_elstack
+
+use m_buffer
+
+private
+
+!
+! Simple stack to keep track of which elements have appeared so far
+!
+integer, parameter, private            :: STACK_SIZE = 40
+
+type, public :: elstack_t
+private
+      integer                                :: n_items
+      type(buffer_t), dimension(STACK_SIZE)  :: data
+end type elstack_t
+
+public  :: push_elstack, pop_elstack, reset_elstack, print_elstack
+public  :: init_elstack
+public  :: get_top_elstack, is_empty, get_elstack_signature
+
+interface is_empty
+      module procedure is_empty_elstack
+end interface
+private :: is_empty_elstack
+
+CONTAINS
+
+!-----------------------------------------------------------------
+subroutine init_elstack(elstack)
+type(elstack_t), intent(inout)  :: elstack
+
+integer :: i
+
+elstack%n_items = 0
+do i = 1, STACK_SIZE                   ! to avoid "undefined status"
+      call init_buffer(elstack%data(i))
+enddo
+end subroutine init_elstack
+
+!-----------------------------------------------------------------
+subroutine reset_elstack(elstack)
+type(elstack_t), intent(inout)  :: elstack
+
+integer :: i
+
+elstack%n_items = 0
+do i = 1, STACK_SIZE                  
+      call reset_buffer(elstack%data(i))
+enddo
+end subroutine reset_elstack
+
+!-----------------------------------------------------------------
+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
+
+!-----------------------------------------------------------------
+subroutine push_elstack(item,elstack)
+type(buffer_t), intent(in)      :: item
+type(elstack_t), intent(inout)  :: elstack
+
+integer   :: n
+
+n = elstack%n_items
+if (n == STACK_SIZE) then
+      stop "*Element stack full"
+endif
+n = n + 1
+elstack%data(n) = item
+elstack%n_items = n
+
+end subroutine push_elstack
+
+!-----------------------------------------------------------------
+subroutine pop_elstack(elstack,item)
+type(elstack_t), intent(inout)     :: elstack
+type(buffer_t), intent(out)        :: item
+
+!
+! We assume the elstack is not empty... (the user has called is_empty first)
+!
+integer   :: n
+
+n = elstack%n_items
+if (n == 0) then
+      stop "*********Element stack empty"
+endif
+item = elstack%data(n)
+elstack%n_items = n - 1
+
+end subroutine pop_elstack
+
+!-----------------------------------------------------------------
+subroutine get_top_elstack(elstack,item)
+!
+! Get the top element of the stack, *without popping it*.
+!
+type(elstack_t), intent(in)        :: elstack
+type(buffer_t), intent(out)        :: item
+
+!
+! We assume the elstack is not empty... (the user has called is_empty first)
+!
+integer   :: n
+
+n = elstack%n_items
+if (n == 0) then
+      stop "*********Element stack empty"
+endif
+item = elstack%data(n)
+
+end subroutine get_top_elstack
+
+!-----------------------------------------------------------------
+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=*) str(elstack%data(i))
+enddo
+
+end subroutine print_elstack
+
+!-------------------------------------------------------------
+subroutine get_elstack_signature(elstack,string)
+type(elstack_t), intent(in)   :: elstack
+character(len=*), intent(out) :: string
+integer   :: i, length, j
+
+string = ""
+j = 0
+do i = 1, elstack%n_items
+   length = len(elstack%data(i))
+   string(j+1:j+1) = "/"
+   j = j+1
+   string(j+1:j+length) = str(elstack%data(i))
+   j = j + length
+enddo
+
+end subroutine get_elstack_signature
+
+end module m_elstack
+
+
+
+
+
Index: vendors/XMLF90/current/src/sax/m_entities.f90
===================================================================
--- vendors/XMLF90/current/src/sax/m_entities.f90	(revision 1899)
+++ vendors/XMLF90/current/src/sax/m_entities.f90	(revision 1899)
@@ -0,0 +1,134 @@
+module m_entities
+!
+! Entity management
+!
+! It deals with: 
+!    1. The five standard entities (gt,lt,amp,apos,quot)
+!    2. Character entities  (but only within the range of the char intrinsic)
+!
+use m_buffer
+private
+
+integer, parameter, private      :: MAX_REPLACEMENT_SIZE = 200
+!
+type, private :: entity_t
+ character(len=40)                     :: code
+ character(len=MAX_REPLACEMENT_SIZE)   :: replacement
+end type entity_t
+
+integer, parameter, private                          ::  N_ENTITIES  = 5
+
+type(entity_t), private, dimension(N_ENTITIES), save :: predefined_ent =  &
+      (/                  &
+      entity_t("gt",">"), &
+      entity_t("lt","<"),  &
+      entity_t("amp","&"),  &
+      entity_t("apos","'"),  &
+      entity_t("quot","""")  &
+      /)
+      
+public :: code_to_str , entity_filter
+
+CONTAINS
+
+subroutine code_to_str(code,str,status)
+character(len=*), intent(in)  :: code
+character(len=*), intent(out) :: str
+integer, intent(out)          :: status         
+integer :: i
+
+integer   :: number, ll
+character(len=4)  :: fmtstr
+
+status = -1
+do i = 1, N_ENTITIES
+      if (code == predefined_ent(i)%code) then
+         str = predefined_ent(i)%replacement
+         status = 0
+         return
+      endif
+enddo
+!
+! Replace character references  (but only within the range of the
+! char intrinsic !!)
+!
+if (code(1:1) == "#") then
+   if (code(2:2) == "x") then       ! hex character reference
+      ll = len_trim(code(3:))
+      write(unit=fmtstr,fmt="(a2,i1,a1)") "(Z", ll,")"
+      read(unit=code(3:),fmt=fmtstr) number
+      str = char(number)
+      status = 0
+      return
+   else                             ! decimal character reference
+      read(unit=code(2:),fmt=*) number
+      str = char(number)
+      status = 0
+      return
+   endif
+endif
+
+end subroutine code_to_str
+
+!----------------------------------------------------------------
+!
+! Replaces entity references in buf1 and creates a new buffer buf2.
+!
+subroutine entity_filter(buf1,buf2,status,message)
+type(buffer_t), intent(in)    :: buf1
+type(buffer_t), intent(out)   :: buf2
+integer, intent(out)          :: status
+character(len=*), intent(out) :: message
+!
+! Replaces entity references by their value
+!
+integer :: i, k, len1
+character(len=MAX_BUFF_SIZE)           :: s1
+character(len=1)                       :: c
+character(len=MAX_REPLACEMENT_SIZE)    :: repl
+
+call buffer_to_character(buf1,s1)        !! Avoid allocation of temporary
+len1 = len(buf1)
+
+i = 1
+status = 0
+
+call reset_buffer(buf2)
+
+do
+   if (i > len1) exit
+   c = s1(i:i)
+   if (c == "&") then
+      if (i+1 > len1) then
+         status = -i
+         message=  " Unmatched & in entity reference"
+         return
+      endif
+      k = index(s1(i+1:),";")
+      if (k == 0) then
+         status = -i
+         message=  " Unmatched & in entity reference"
+         return
+      endif
+      call code_to_str(s1(i+1:i+k-1),repl,status)
+      if (status /= 0) then
+         status =  i     ! Could let it continue
+         message= "Ignored unknown entity: &" // s1(i+1:i+k-1) // ";"
+      else
+         call add_to_buffer(trim(repl),buf2)
+      endif
+      i = i + k + 1
+   else
+     call add_to_buffer(c,buf2)
+     i = i + 1
+   endif
+enddo
+
+end subroutine entity_filter
+
+end module m_entities
+
+
+
+
+
Index: vendors/XMLF90/current/src/sax/m_fsm.f90
===================================================================
--- vendors/XMLF90/current/src/sax/m_fsm.f90	(revision 1899)
+++ vendors/XMLF90/current/src/sax/m_fsm.f90	(revision 1899)
@@ -0,0 +1,745 @@
+module m_fsm
+!
+use m_buffer
+use m_dictionary
+use m_charset
+use m_entities
+use m_elstack
+
+private
+
+type, public :: fsm_t
+      !
+      ! Contains information about the "finite state machine"
+      ! Some of the components (marked *) could at this point be made into
+      ! saved module variables.
+      ! 
+      !
+      integer              :: state
+      integer              :: context
+      integer              :: nbrackets             !*
+      integer              :: nlts                  !*
+      character(len=1)     :: quote_char            !*
+      type(buffer_t)       :: buffer                !*
+      type(buffer_t)       :: element_name
+      type(dictionary_t)   :: attributes
+      type(buffer_t)       :: pcdata
+      type(elstack_t)      :: element_stack
+      logical              :: root_element_seen
+      type(buffer_t)       :: root_element_name
+      character(len=150)   :: action
+      logical              :: debug
+end type fsm_t
+
+public :: init_fsm, reset_fsm, evolve_fsm
+
+!
+! State parameters
+!
+integer, parameter, public   ::  ERROR = -1
+integer, parameter, public   ::  INIT = 1         
+integer, parameter, private  ::  START_TAG_MARKER = 2
+integer, parameter, private  ::  END_TAG_MARKER = 3
+integer, parameter, private  ::  IN_NAME = 4
+integer, parameter, private  ::  WHITESPACE_IN_TAG = 5
+integer, parameter, private  ::  IN_PCDATA = 6
+integer, parameter, private  ::  SINGLETAG_MARKER = 7
+integer, parameter, private  ::  CLOSINGTAG_MARKER = 8
+integer, parameter, private  ::  IN_COMMENT = 9
+integer, parameter, private  ::  IN_ATT_NAME = 10
+integer, parameter, private  ::  IN_ATT_VALUE = 11
+integer, parameter, private  ::  EQUAL = 12
+integer, parameter, private  ::  SPACE_AFTER_EQUAL = 13
+integer, parameter, private  ::  SPACE_BEFORE_EQUAL = 14
+integer, parameter, private  ::  START_QUOTE = 15
+integer, parameter, private  ::  END_QUOTE = 16
+integer, parameter, private  ::  BANG = 17
+integer, parameter, private  ::  BANG_HYPHEN = 18
+integer, parameter, private  ::  ONE_HYPHEN = 19
+integer, parameter, private  ::  TWO_HYPHEN = 20
+integer, parameter, private  ::  QUESTION_MARK = 21
+integer, parameter, private  ::  START_XML_DECLARATION = 22
+integer, parameter, private  ::  IN_SGML_DECLARATION = 23
+integer, parameter, private  ::  IN_CDATA_SECTION = 24
+integer, parameter, private  ::  ONE_BRACKET = 25
+integer, parameter, private  ::  TWO_BRACKET = 26
+integer, parameter, private  ::  CDATA_PREAMBLE = 27
+integer, parameter, private  ::  IN_PCDATA_AT_EOL = 30
+!
+! Context parameters
+!
+integer, parameter, public   ::  OPENING_TAG  = 100
+integer, parameter, public   ::  CLOSING_TAG  = 110
+integer, parameter, public   ::  SINGLE_TAG   = 120
+integer, parameter, public   ::  COMMENT_TAG  = 130
+integer, parameter, public   ::  XML_DECLARATION_TAG  = 140
+integer, parameter, public   ::  SGML_DECLARATION_TAG  = 150
+integer, parameter, public   ::  CDATA_SECTION_TAG  = 160
+integer, parameter, public   ::  NULL_CONTEXT          = 200
+!
+! Signal parameters
+!
+integer, parameter, public   ::  QUIET             = 1000
+integer, parameter, public   ::  END_OF_TAG        = 1100
+integer, parameter, public   ::  CHUNK_OF_PCDATA   = 1200
+integer, parameter, public   ::  EXCEPTION         = 1500
+
+CONTAINS
+
+!------------------------------------------------------------
+! Initialize once and for all the derived types (Fortran90 restriction)
+!
+subroutine init_fsm(fx) 
+type(fsm_t), intent(inout)   :: fx
+
+ fx%state = INIT
+ call setup_xml_charsets()
+ fx%context = NULL_CONTEXT
+ call init_elstack(fx%element_stack)
+ fx%root_element_seen = .false.
+ fx%debug = .false.
+ fx%action = ""
+ call init_buffer(fx%buffer)
+ call init_buffer(fx%element_name)
+ call init_buffer(fx%pcdata)
+ call init_buffer(fx%root_element_name)
+ call init_dict(fx%attributes)
+end subroutine init_fsm
+!------------------------------------------------------------
+subroutine reset_fsm(fx) 
+type(fsm_t), intent(inout)   :: fx
+
+ fx%state = INIT
+ call setup_xml_charsets()
+ fx%context = NULL_CONTEXT
+ call reset_elstack(fx%element_stack)
+ fx%action = ""
+ fx%root_element_seen = .false.
+ call reset_buffer(fx%buffer)
+ call reset_buffer(fx%element_name)
+ call reset_buffer(fx%pcdata)
+ call reset_buffer(fx%root_element_name)
+ call reset_dict(fx%attributes)
+end subroutine reset_fsm
+
+!------------------------------------------------------------
+subroutine evolve_fsm(fx,c,signal)
+!
+! Finite-state machine evolution rules for XML parsing.
+!
+type(fsm_t), intent(inout)      :: fx    ! Internal state
+character(len=1), intent(in)    :: c
+integer, intent(out)            :: signal
+
+!
+! Reset signal
+!
+signal = QUIET
+!
+
+if (.not. (c .in. valid_chars)) then
+!
+!      Let it pass (in case the underlying encoding is UTF-8)
+!      But this chars in a name will cause havoc
+!
+!      signal = EXCEPTION
+!      fx%state = ERROR
+!      fx%action = trim("Not a valid character in simple encoding: "//c)
+!      RETURN
+endif
+
+select case(fx%state)
+
+ case (INIT)
+      if (c == "<") then
+         fx%state = START_TAG_MARKER
+         if (fx%debug) fx%action = ("Starting tag")
+      else if (c == ">") then
+         fx%state = ERROR
+         fx%action = ("Ending tag without being in one!")
+      else
+         if (fx%debug) fx%action = ("Reading garbage chars")
+      endif
+
+ case (START_TAG_MARKER)
+      if (c == ">") then
+         fx%state = ERROR
+         fx%action = ("Tag empty!")
+      else if (c == "<") then
+         fx%state = ERROR
+         fx%action = ("Double opening of tag!!")
+      else if (c == "/") then
+         fx%state = CLOSINGTAG_MARKER
+         if (fx%debug) fx%action = ("Starting endtag: ")
+         fx%context = CLOSING_TAG
+      else if (c == "?") then
+         fx%state = START_XML_DECLARATION
+         if (fx%debug) fx%action = ("Starting XML declaration ")
+         fx%context = XML_DECLARATION_TAG
+      else if (c == "!") then
+         fx%state = BANG
+         if (fx%debug) fx%action = ("Saw ! -- comment or SGML declaration expected...")
+      else if (c .in. whitespace) then
+         fx%state = ERROR
+         fx%action = ("Cannot have whitespace after <")
+      else if (c .in. initial_name_chars) then
+         fx%context = OPENING_TAG
+         fx%state = IN_NAME
+         call add_to_buffer(c,fx%buffer)
+         if (fx%debug) fx%action = ("Starting to read name in tag")
+      else 
+         fx%state = ERROR
+         fx%action = ("Illegal initial character for name")
+      endif
+
+
+ case (BANG)
+      if (c == "-") then
+         fx%state = BANG_HYPHEN
+         if (fx%debug) fx%action = ("Almost ready to start comment ")
+      else if (c .in. uppercase_chars) then
+         fx%state = IN_SGML_DECLARATION
+         fx%nlts = 0
+         fx%nbrackets = 0
+         if (fx%debug) fx%action = ("SGML declaration ")
+         fx%context = SGML_DECLARATION_TAG
+         call add_to_buffer(c,fx%buffer)
+      else if (c == "[") then
+         fx%state = CDATA_PREAMBLE
+         if (fx%debug) fx%action = ("Declaration with [ ")
+         fx%context = CDATA_SECTION_TAG
+      else
+         fx%state = ERROR
+         fx%action = ("Wrong character after ! ")
+      endif
+
+ case (CDATA_PREAMBLE)
+      ! We assume a CDATA[ is forthcoming, we do not check
+      if (c == "[") then
+         fx%state = IN_CDATA_SECTION
+         if (fx%debug) fx%action = ("About to start reading CDATA contents")
+      else if (c == "]") then
+         fx%state = ERROR
+         fx%action = ("Unexpected ] in CDATA preamble")
+      else
+         if (fx%debug) fx%action = ("Reading CDATA preamble")
+      endif
+
+ case (IN_CDATA_SECTION)
+      if (c == "]") then
+         fx%state = ONE_BRACKET
+         if (fx%debug) fx%action = ("Saw a ] in CDATA section")
+      else
+         call add_to_buffer(c,fx%buffer)
+         if (fx%debug) fx%action = ("Reading contents of CDATA section")
+      endif
+
+ case (ONE_BRACKET)
+      if (c == "]") then
+         fx%state = TWO_BRACKET
+         if (fx%debug) fx%action = ("Maybe finish a CDATA section")
+      else
+         fx%state = IN_CDATA_SECTION
+         call add_to_buffer("]",fx%buffer)
+         if (fx%debug) fx%action = ("Continue reading contents of CDATA section")
+      endif
+
+ case (TWO_BRACKET)
+      if (c == ">") then
+         fx%state = END_TAG_MARKER
+         signal = END_OF_TAG
+         if (fx%debug) fx%action = ("End of CDATA section")
+         fx%pcdata = fx%buffer    ! Not quite the same behavior
+                                  ! as pcdata... (not filtered)
+         call reset_buffer(fx%buffer)
+      else
+         fx%state = IN_CDATA_SECTION
+         call add_to_buffer("]",fx%buffer)
+         if (fx%debug) fx%action = ("Continue reading contents of CDATA section")
+      endif
+
+ case (IN_SGML_DECLARATION)
+      if (c == "<") then
+         fx%nlts = fx%nlts + 1
+         call add_to_buffer("<",fx%buffer)
+         fx%action = "Read an intermediate < in SGML declaration"
+      else if (c == "[") then
+         fx%nbrackets = fx%nbrackets + 1
+         call add_to_buffer("[",fx%buffer)
+         fx%action = "Read a [ in SGML declaration"
+      else if (c == "]") then
+         fx%nbrackets = fx%nbrackets - 1
+         call add_to_buffer("]",fx%buffer)
+         fx%action = "Read a ] in SGML declaration"
+      else if (c == ">") then
+         if (fx%nlts == 0) then
+            if (fx%nbrackets == 0) then
+               fx%state = END_TAG_MARKER
+               signal  = END_OF_TAG
+               if (fx%debug) fx%action = ("Ending SGML declaration tag")
+               fx%pcdata = fx%buffer       ! Same behavior as pcdata
+               call reset_buffer(fx%buffer)
+            else
+               fx%state = ERROR
+               fx%action = ("Unmatched ] in SGML declaration")
+            endif
+         else
+            fx%nlts = fx%nlts -1
+            call add_to_buffer(">",fx%buffer)
+            fx%action = "Read an intermediate > in SGML declaration"
+         endif
+      else
+         if (fx%debug) fx%action = ("Keep reading SGML declaration")
+         call add_to_buffer(c,fx%buffer)
+      endif
+
+ case (BANG_HYPHEN)
+      if (c == "-") then
+         fx%state = IN_COMMENT
+         fx%context = COMMENT_TAG
+         if (fx%debug) fx%action = ("In comment ")
+      else
+         fx%state = ERROR
+         fx%action = ("Wrong character after <!- ")
+      endif
+
+ case (START_XML_DECLARATION)
+      if (c .in. initial_name_chars) then
+         fx%state = IN_NAME
+         call add_to_buffer(c,fx%buffer)
+         if (fx%debug) fx%action = ("Starting to read name in XML declaration")
+      else
+         fx%state = ERROR
+         fx%action = "Wrong character after ? in start of XML declaration"
+      endif
+
+ case (CLOSINGTAG_MARKER)
+      if (c == ">") then
+         fx%state = ERROR
+         fx%action = ("Closing tag empty!")
+      else if (c == "<") then
+         fx%state = ERROR
+         fx%action = ("Double opening of closing tag!!")
+      else if (c == "/") then
+         fx%state = ERROR
+         fx%action = ("Syntax error (<//)")
+      else if (c .in. whitespace) then
+         fx%state = ERROR
+         fx%action = ("Cannot have whitespace after </")
+      else if (c .in. initial_name_chars) then
+         fx%state = IN_NAME
+         if (fx%debug) fx%action = ("Starting to read name inside endtag")
+         call add_to_buffer(c,fx%buffer)
+      else 
+         fx%state = ERROR
+         fx%action = ("Illegal initial character for name")
+      endif
+
+ case (IN_NAME)
+      if (c == "<") then
+         fx%state = ERROR
+         fx%action = ("Starting tag within tag")
+      else if (c == ">") then
+         fx%state = END_TAG_MARKER
+         signal  = END_OF_TAG
+         if (fx%debug) fx%action = ("Ending tag")
+!         call set_element_name(fx%buffer,fx%element)
+         fx%element_name = fx%buffer
+         call reset_buffer(fx%buffer)
+         call reset_dict(fx%attributes)
+      else if (c == "/") then
+         if (fx%context /= OPENING_TAG) then
+            fx%state = ERROR
+            fx%action = ("Single tag did not open as start tag")
+         else 
+            fx%state = SINGLETAG_MARKER
+            fx%context = SINGLE_TAG
+            if (fx%debug) fx%action = ("Almost ending single tag")
+!            call set_element_name(fx%buffer,fx%element)
+            fx%element_name = fx%buffer
+            call reset_buffer(fx%buffer)
+            call reset_dict(fx%attributes)
+         endif
+      else if (c .in. whitespace) then
+         fx%state = WHITESPACE_IN_TAG
+         if (fx%debug) fx%action = ("Ending name chars")
+!            call set_element_name(fx%buffer,fx%element)
+         fx%element_name = fx%buffer
+         call reset_buffer(fx%buffer)
+         call reset_dict(fx%attributes)
+      else if (c .in. name_chars) then
+         if (fx%debug) fx%action = ("Reading name chars in tag")
+         call add_to_buffer(c,fx%buffer)
+      else
+         fx%state = ERROR
+         fx%action = ("Illegal character for name")
+      endif
+
+ case (IN_ATT_NAME)
+      if (c == "<") then
+         fx%state = ERROR
+         fx%action = ("Starting tag within tag")
+      else if (c == ">") then
+         fx%state = ERROR
+         fx%action = ("Ending tag in the middle of an attribute")
+      else if (c == "/") then
+         fx%state = ERROR
+         fx%action = ("Ending tag in the middle of an attribute")
+      else if (c .in. whitespace) then
+         fx%state = SPACE_BEFORE_EQUAL  
+         if (fx%debug) fx%action = ("Whitespace after attr. name (specs?)")
+         call add_key_to_dict(fx%buffer,fx%attributes)
+         call reset_buffer(fx%buffer)
+      else if ( c == "=" ) then
+         fx%state = EQUAL
+         if (fx%debug) fx%action = ("End of attr. name")
+         call add_key_to_dict(fx%buffer,fx%attributes)
+         call reset_buffer(fx%buffer)
+      else if (c .in. name_chars) then
+         if (fx%debug) fx%action = ("Reading attribute name chars")
+         call add_to_buffer(c,fx%buffer)
+      else
+         fx%state = ERROR
+         fx%action = ("Illegal character for attribute name")
+      endif
+
+ case (EQUAL)
+      if ( (c == """") .or. (c == "'") ) then
+         fx%state = START_QUOTE
+         if (fx%debug) fx%action = ("Found beginning quote")
+         fx%quote_char = c
+      else if (c .in. whitespace) then
+         fx%state = SPACE_AFTER_EQUAL
+         if (fx%debug) fx%action = ("Whitespace after equal sign...")
+      else
+         fx%state = ERROR
+         fx%action = ("Must use quotes for attribute values")
+      endif
+
+ case (SPACE_BEFORE_EQUAL)
+      if ( c == "=" ) then
+         fx%state = EQUAL
+         if (fx%debug) fx%action = ("Equal sign")
+      else if (c .in. whitespace) then
+         if (fx%debug) fx%action = ("More whitespace before equal sign...")
+      else
+         fx%state = ERROR
+         fx%action = ("Must use equal sign for attribute values")
+      endif
+
+ case (SPACE_AFTER_EQUAL)
+      if ( c == "=" ) then
+         fx%state = ERROR
+         fx%action = ("Duplicate Equal sign")
+      else if (c .in. whitespace) then
+         if (fx%debug) fx%action = ("More whitespace after equal sign...")
+      else  if ( (c == """") .or. (c == "'") ) then
+         fx%state = START_QUOTE
+         fx%quote_char = c
+         if (fx%debug) fx%action = ("Found beginning quote")
+      else
+         fx%state = ERROR
+         fx%action = ("Must use quotes for attribute values")
+      endif
+
+ case (START_QUOTE)
+      if (c == fx%quote_char) then
+         fx%state = END_QUOTE
+         if (fx%debug) fx%action = ("Emtpy attribute value...")
+         call add_value_to_dict(fx%buffer,fx%attributes)
+         call reset_buffer(fx%buffer)
+      else if (c == "<") then
+         fx%state = ERROR
+         fx%action = ("Attribute value cannot contain <")
+      else   ! actually allowed chars in att values... Specs: No "<"        
+         fx%state = IN_ATT_VALUE
+         if (fx%debug) fx%action = ("Starting to read attribute value")
+         call add_to_buffer(c,fx%buffer)
+      endif
+
+ case (IN_ATT_VALUE)
+      if (c == fx%quote_char) then
+         fx%state = END_QUOTE
+         if (fx%debug) fx%action = ("End of attribute value")
+         call add_value_to_dict(fx%buffer,fx%attributes)
+         call reset_buffer(fx%buffer)
+      else if (c == "<") then
+         fx%state = ERROR
+         fx%action = ("Attribute value cannot contain <")
+      else if ( (c == char(10)) ) then
+         fx%state = ERROR
+!
+!        Aparently other whitespace is allowed...
+!
+         fx%action = ("No newline allowed in attr. value (specs?)")
+      else        ! all other chars allowed in attr value
+         if (fx%debug) fx%action = ("Reading attribute value chars")
+         call add_to_buffer(c,fx%buffer)
+      endif
+
+ case (END_QUOTE)
+      if ((c == """") .or. (c == "'")) then
+         fx%state = ERROR
+         fx%action = ("Duplicate end quote")
+      else if (c .in. whitespace) then
+         fx%state = WHITESPACE_IN_TAG
+         if (fx%debug) fx%action = ("Space in between attributes or to end of tag")
+      else if (c == "<") then
+         fx%state = ERROR
+         fx%action = ("Starting tag within tag")
+      else if (c == ">") then
+         if (fx%context == XML_DECLARATION_TAG) then
+            fx%state = ERROR
+            fx%action = "End of XML declaration without ?"
+         else
+            fx%state = END_TAG_MARKER
+            signal  = END_OF_TAG
+            if (fx%debug) fx%action = ("Ending tag after some attributes")
+         endif
+      else if (c == "/") then
+         if (fx%context /= OPENING_TAG) then
+            fx%state = ERROR
+            fx%action = ("Single tag did not open as start tag")
+         else 
+            fx%state = SINGLETAG_MARKER
+            fx%context = SINGLE_TAG
+            if (fx%debug) fx%action = ("Almost ending single tag after some attributes")
+         endif
+      else if (c == "?") then
+         if (fx%context /= XML_DECLARATION_TAG) then
+            fx%state = ERROR
+            fx%action = "Wrong lone ? in tag"
+         else
+            fx%state = QUESTION_MARK
+            if (fx%debug) fx%action = ("About to end XML declaration")
+         endif
+      else   
+         fx%state = ERROR
+         fx%action = ("Must have some whitespace after att. value")
+      endif
+
+
+ case (WHITESPACE_IN_TAG)
+      if ( c .in. whitespace) then
+         if (fx%debug) fx%action = ("Reading whitespace in tag")
+      else if (c == "<") then
+         fx%state = ERROR
+         fx%action = ("Starting tag within tag")
+      else if (c == ">") then
+         if (fx%context == XML_DECLARATION_TAG) then
+            fx%state = ERROR
+            fx%action = "End of XML declaration without ?"
+         else
+            fx%state = END_TAG_MARKER
+            signal  = END_OF_TAG
+            if (fx%debug) fx%action = ("End whitespace in tag")
+         endif
+      else if (c == "/") then
+         if (fx%context /= OPENING_TAG) then
+            fx%state = ERROR
+            fx%action = ("Single tag did not open as start tag")
+         else 
+            fx%state = SINGLETAG_MARKER
+            fx%context = SINGLE_TAG
+            if (fx%debug) fx%action = ("End whitespace in single tag")
+         endif
+      else if (c .in. initial_name_chars) then
+         fx%state = IN_ATT_NAME
+         if (fx%debug) fx%action = ("Starting Attribute name in tag")
+         call add_to_buffer(c,fx%buffer)
+      else if (c == "?") then
+         if (fx%context /= XML_DECLARATION_TAG) then
+            fx%state = ERROR
+            fx%action = "Wrong lone ? in tag"
+         else
+            fx%state = QUESTION_MARK
+            if (fx%debug) fx%action = ("About to end XML declaration after whitespace")
+         endif
+      else
+         fx%state = ERROR
+         fx%action = ("Illegal initial character for attribute")
+      endif
+
+ case (QUESTION_MARK)
+      if (c == ">") then
+         fx%state = END_TAG_MARKER
+         signal  = END_OF_TAG
+         if (fx%debug) fx%action = ("End of XML declaration tag")
+      else
+         fx%state = ERROR
+         fx%action = "No > after ? in XML declaration tag"
+      endif
+
+ case (IN_COMMENT)
+      !
+      ! End of comment is  "-->", and  ">" can appear inside comments
+      !
+      if (c == "-") then
+         fx%state = ONE_HYPHEN
+         if (fx%debug) fx%action = ("Saw - in Comment")
+      else
+         if (fx%debug) fx%action = ("Reading comment")
+         call add_to_buffer(c,fx%buffer)
+      endif
+
+ case (ONE_HYPHEN)
+      if (c == "-") then
+         fx%state = TWO_HYPHEN
+         if (fx%debug) fx%action = ("About to end comment")
+      else
+         fx%state = IN_COMMENT
+         if (fx%debug) fx%action = ("Keep reading comment after -: ")
+         call add_to_buffer("-",fx%buffer)
+         call add_to_buffer(c,fx%buffer)
+      endif
+
+ case (TWO_HYPHEN)
+      if (c == ">") then
+         fx%state = END_TAG_MARKER
+         signal  = END_OF_TAG
+         if (fx%debug) fx%action = ("End of Comment")
+         fx%pcdata = fx%buffer                  ! Same behavior as pcdata
+         call reset_buffer(fx%buffer)
+      else
+         fx%state = ERROR
+         fx%action = ("Cannot have -- in comment")
+      endif
+
+ case (SINGLETAG_MARKER)
+
+      if (c == ">") then
+         fx%state = END_TAG_MARKER
+         signal  = END_OF_TAG
+         if (fx%debug) fx%action = ("Ending tag")
+         ! We have to call begin_element AND end_element
+      else 
+         fx%state = ERROR
+         fx%action = ("Wrong ending of single tag")
+      endif
+
+ case (IN_PCDATA)
+      if (c == "<") then
+         fx%state = START_TAG_MARKER
+         signal = CHUNK_OF_PCDATA
+         if (fx%debug) fx%action = ("End of pcdata -- Starting tag")
+         fx%pcdata = fx%buffer
+         call reset_buffer(fx%buffer)
+      else if (c == ">") then
+         fx%state = ERROR
+         fx%action = ("Ending tag without starting it!")
+      else if  (c == char(10)) then
+         fx%state = IN_PCDATA_AT_EOL
+         signal = CHUNK_OF_PCDATA
+         if (fx%debug) fx%action = ("Resetting PCDATA buffer at newline")
+         call add_to_buffer(c,fx%buffer)
+         fx%pcdata = fx%buffer
+         call reset_buffer(fx%buffer)
+      else
+         call add_to_buffer(c,fx%buffer)
+         if (fx%debug) fx%action = ("Reading chars outside tags")
+         !
+         ! Check whether we are close to the end of the buffer. 
+         ! If so, make a chunk and reset the buffer
+         if (c .in. whitespace) then
+            if (buffer_nearly_full(fx%buffer)) then
+               signal = CHUNK_OF_PCDATA
+               if (fx%debug) fx%action = ("Resetting almost full PCDATA buffer")
+               fx%pcdata = fx%buffer
+               call reset_buffer(fx%buffer)
+            endif
+         endif
+      endif
+
+ case (IN_PCDATA_AT_EOL)
+      !
+      ! Avoid triggering an extra pcdata event
+      !
+      if (c == "<") then
+         fx%state = START_TAG_MARKER
+         if (fx%debug) fx%action = ("No more pcdata after eol-- Starting tag")
+      else if (c == ">") then
+         fx%state = ERROR
+         fx%action = ("Ending tag without starting it!")
+      else if  (c == char(10)) then
+         fx%state = IN_PCDATA_AT_EOL
+         signal = CHUNK_OF_PCDATA
+         if (fx%debug) fx%action = ("Resetting PCDATA buffer at repeated newline")
+         call add_to_buffer(c,fx%buffer)
+         fx%pcdata = fx%buffer
+         call reset_buffer(fx%buffer)
+      else
+         fx%state = IN_PCDATA
+         call add_to_buffer(c,fx%buffer)
+         if (fx%debug) fx%action = ("Reading chars outside tags")
+         !
+         ! Check whether we are close to the end of the buffer. 
+         ! If so, make a chunk and reset the buffer
+         if (c .in. whitespace) then
+            if (buffer_nearly_full(fx%buffer)) then
+               signal = CHUNK_OF_PCDATA
+               if (fx%debug) fx%action = ("Resetting almost full PCDATA buffer")
+               fx%pcdata = fx%buffer
+               call reset_buffer(fx%buffer)
+            endif
+         endif
+      endif
+
+
+
+ case (END_TAG_MARKER)
+!
+      if (c == "<") then
+         fx%state = START_TAG_MARKER
+         if (fx%debug) fx%action = ("Starting tag")
+      else if (c == ">") then
+         fx%state = ERROR
+         fx%action = ("Double ending of tag!")
+!
+!     We should make this whitespace in general (maybe not?
+!     how about indentation in text chunks?)
+!     See specs.
+!
+      else if (c == char(10)) then
+        ! Ignoring LF after end of tag is probably non standard...
+
+         if (fx%debug) &
+            fx%action = ("---------Discarding newline after end of tag")
+
+        !!!  New code for full compliance
+        ! fx%state = IN_PCDATA_AT_EOL
+        ! call add_to_buffer(c,fx%buffer)
+        ! if (fx%debug) &
+        !    fx%action = ("Found LF after end of tag. Emitting PCDATA event")
+        ! signal = CHUNK_OF_PCDATA
+        ! fx%pcdata = fx%buffer
+        ! call reset_buffer(fx%buffer)
+      else
+         fx%state = IN_PCDATA
+         call add_to_buffer(c,fx%buffer)
+         if (fx%debug) fx%action = ("End of Tag. Starting to read PCDATA")
+      endif
+
+ case (ERROR)
+
+      stop "Cannot continue after parsing errors!"
+
+ end select
+
+if (fx%state == ERROR) signal  = EXCEPTION
+
+end subroutine evolve_fsm
+
+end module m_fsm
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: vendors/XMLF90/current/src/sax/m_io.f90
===================================================================
--- vendors/XMLF90/current/src/sax/m_io.f90	(revision 1899)
+++ vendors/XMLF90/current/src/sax/m_io.f90	(revision 1899)
@@ -0,0 +1,94 @@
+module m_io
+
+!
+! Basic  I/O tools
+!
+integer, public, save            :: io_eor, io_eof
+
+public  :: get_unit, setup_io
+private :: find_eor_eof
+
+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)
+!
+integer, intent(out)           :: io_eor
+integer, intent(out)           :: io_eof
+
+integer           :: lun, iostat
+character(len=1)  :: c
+
+call get_unit(lun,iostat)
+
+if (iostat /= 0) stop "Out of unit numbers"
+
+open(unit=lun,status="scratch",form="formatted", &
+     action="readwrite",position="rewind",iostat=iostat)
+if (iostat /= 0)   stop "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
+
+!!!!!!!!print *, "IO_EOR, IO_EOF: ", io_eor, io_eof
+
+close(unit=lun,status="delete")
+
+end subroutine find_eor_eof
+
+! ----------------------------------------------------------------------
+end module m_io
+
+
+
+
+
+
+
+
+
Index: vendors/XMLF90/current/src/sax/m_reader.f90
===================================================================
--- vendors/XMLF90/current/src/sax/m_reader.f90	(revision 1899)
+++ vendors/XMLF90/current/src/sax/m_reader.f90	(revision 1899)
@@ -0,0 +1,298 @@
+module m_reader
+
+use m_io
+
+private
+
+integer, parameter, public              :: BUFFER_NOT_CONNECTED = -2048
+integer, private, parameter             :: MAXLENGTH = 1024
+
+type, public :: file_buffer_t
+private
+      logical                           :: connected
+      logical                           :: eof
+      integer                           :: lun
+      character(len=50)                 :: filename
+      integer                           :: counter
+      character(len=MAXLENGTH)          :: buffer
+      integer                           :: line
+      integer                           :: col
+      integer                           :: pos 
+      integer                           :: nchars
+      logical                           :: debug
+end type file_buffer_t
+
+public  :: get_character, sync_file
+public  :: line, column, nchars_processed
+public  :: open_file, close_file_buffer, rewind_file, mark_eof_file
+public  :: eof_file
+
+private :: fill_buffer
+
+CONTAINS
+
+!-----------------------------------------
+!
+subroutine open_file(fname,fb,iostat,record_size,verbose)
+character(len=*), intent(in)      :: fname
+type(file_buffer_t), intent(out)  :: fb
+integer, intent(out)              :: iostat
+integer, intent(in), optional     :: record_size
+logical, intent(in), optional     :: verbose
+
+iostat = 0
+
+call setup_io()
+
+fb%connected = .false.
+
+call get_unit(fb%lun,iostat)
+if (iostat /= 0) then
+   if (fb%debug) print *, "Cannot get unit"
+   return
+endif
+
+if (present(verbose)) then
+   fb%debug = verbose
+else
+   fb%debug = .false.
+endif
+
+if (present(record_size)) then
+   open(unit=fb%lun,file=fname,form="formatted",status="old", &
+        action="read",position="rewind",recl=record_size,iostat=iostat)
+else
+   open(unit=fb%lun,file=fname,form="formatted",status="old", &
+        action="read",position="rewind",recl=65536,iostat=iostat)
+endif
+if (iostat /= 0) then
+   if (fb%debug) print *, "Cannot open file ", trim(fname), " iostat: ", iostat
+   return
+endif
+
+fb%connected = .true.
+fb%counter = 0
+fb%eof = .false.
+fb%line = 1
+fb%col = 0
+fb%filename = fname
+fb%pos = 0
+fb%nchars = 0
+fb%buffer = ""
+
+end subroutine open_file
+
+!-------------------------------------------------
+subroutine rewind_file(fb)
+type(file_buffer_t), intent(inout)  :: fb
+
+fb%eof = .false.
+fb%counter = 0
+fb%line = 1
+fb%col = 0
+fb%pos = 0
+fb%nchars = 0
+fb%buffer = ""
+
+rewind(unit=fb%lun)
+
+end subroutine rewind_file
+!-----------------------------------------
+subroutine mark_eof_file(fb)
+type(file_buffer_t), intent(inout)  :: fb
+
+fb%eof = .true.
+
+end subroutine mark_eof_file
+
+!-----------------------------------------
+subroutine close_file_buffer(fb)
+type(file_buffer_t), intent(inout)  :: fb
+
+if (fb%connected) then
+    close(unit=fb%lun)
+    fb%connected = .false.
+endif
+
+end subroutine close_file_buffer
+
+!-------------------------------------------------
+function eof_file(fb) result (res)
+type(file_buffer_t), intent(in)  :: fb
+logical                          :: res
+
+res = fb%eof
+
+end function eof_file
+!-----------------------------------------
+!-----------------------------------------
+! New version, able to cope with arbitrarily long lines 
+! (still need to specify a big enough record_size if necessary)
+!
+subroutine fill_buffer(fb,iostat)
+type(file_buffer_t), intent(inout)  :: fb
+integer, intent(out)  :: iostat
+! 
+!
+character(len=41)  :: str       ! 40 seems like a good compromise?
+                                ! (1 extra for added newline, see below)
+integer            :: len
+!
+read(unit=fb%lun,iostat=iostat,advance="no",size=len,fmt="(a40)") str
+
+if (iostat == io_eof) then
+   
+   ! End of file
+   if (fb%debug) print *, "End of file."
+   return
+
+else if (iostat > 0) then
+
+   ! Hard i/o error
+   if (fb%debug) print *, "Hard i/o error. iostat:", iostat
+   RETURN
+
+else
+!
+ if (fb%debug) then
+   print *, "Buffer: len, iostat", len, iostat
+   print *, trim(str)
+ endif
+
+   fb%pos = 0
+
+   if (iostat == 0) then
+
+      !  Normal read, with more stuff left on the line
+      !
+      fb%buffer = str(1:len) 
+      fb%nchars = len
+
+   else         ! (end of record)
+      !
+      !  End of record. We mark it with an LF, whatever it is the native marker.
+      !
+!!      fb%buffer = str(1:len) // char(10)
+      fb%buffer = str(1:len)             !! Avoid allocation of string
+      len = len + 1                      !! by compiler
+      fb%buffer(len:len) = char(10)   
+      fb%nchars = len
+      iostat = 0
+   endif
+
+endif
+
+end subroutine fill_buffer
+
+!---------------------------------------------------------------
+subroutine get_character(fb,c,iostat)
+character(len=1), intent(out) :: c
+type(file_buffer_t), intent(inout)  :: fb
+integer, intent(out)          :: iostat
+
+character(len=1)   :: c_next
+
+if (.not. fb%connected) then
+      iostat = BUFFER_NOT_CONNECTED
+      return
+endif
+
+if (fb%pos >= fb%nchars) then
+      call fill_buffer(fb,iostat)
+      if (iostat /= 0) return
+endif
+fb%pos = fb%pos + 1
+c = fb%buffer(fb%pos:fb%pos)
+fb%counter = fb%counter + 1              ! Raw counter
+fb%col = fb%col + 1
+!
+! Deal with end-of-line handling on the processor...
+!
+if (c == char(10)) then
+   ! Our own marker for end of line
+   fb%line = fb%line + 1
+   fb%col = 0
+endif
+if (c == char(13)) then
+   c_next = fb%buffer(fb%pos+1:fb%pos+1)
+   if (c_next == char(10)) then
+      !
+      ! Found CRLF. We replace it by LF, as per specs.
+      c = c_next
+      fb%pos = fb%pos + 1
+      if (fb%debug) print *, "-/-> Removed CR before LF in get_character"
+   else
+      ! Replace single CR by LF
+      c = char(10)
+      if (fb%debug) print *, "-/-> Changed CR to LF in get_character -- line++"
+      !
+   endif
+   ! In both cases we increase the line counter and reset the column
+   !
+   fb%line = fb%line + 1
+   fb%col = 0
+endif
+
+iostat = 0
+
+end subroutine get_character
+
+!----------------------------------------------------
+!----------------------------------------------------
+! Error Location functions
+!
+function line(fb) result (ll)
+type(file_buffer_t), intent(in)  :: fb
+integer                          :: ll
+
+ll = fb%line
+end function line
+
+!----------------------------------------------------
+function column(fb) result (col)
+type(file_buffer_t), intent(in)  :: fb
+integer                          :: col
+
+col = fb%col
+end function column
+!----------------------------------------------------
+!----------------------------------------------------
+function nchars_processed(fb) result (nc)
+type(file_buffer_t), intent(in)  :: fb
+integer                          :: nc
+
+nc = fb%counter
+end function nchars_processed
+!----------------------------------------------------
+
+subroutine sync_file(fb,iostat)
+type(file_buffer_t), intent(inout)  :: fb
+integer, intent(out)                :: iostat
+!
+! Repositions the file so that it matches with
+! the stored file_buffer information
+!
+integer          :: target_counter
+character(len=1) :: c
+
+target_counter = fb%counter
+call rewind_file(fb)
+iostat = 0
+do
+   if (fb%counter == target_counter) exit
+   call get_character(fb,c,iostat)
+   if (iostat /= 0) return
+enddo
+
+end subroutine sync_file
+
+end module m_reader
+
+
+
+
+
+
+
+
+
Index: vendors/XMLF90/current/src/sax/m_xml_error.f90
===================================================================
--- vendors/XMLF90/current/src/sax/m_xml_error.f90	(revision 1899)
+++ vendors/XMLF90/current/src/sax/m_xml_error.f90	(revision 1899)
@@ -0,0 +1,84 @@
+module m_xml_error
+!
+! Error handling
+!
+use m_elstack
+private
+
+type, public  :: xml_error_t
+      character(len=100)  :: message
+      integer             :: line
+      integer             :: column
+      type(elstack_t)     :: stack
+      integer             :: severity
+end type xml_error_t
+
+integer, public             ::  xml_stderr = 0    ! Unit for error info
+integer, public, parameter  ::  SEVERE_ERROR_CODE=0, WARNING_CODE=1
+
+public  :: build_error_info, default_error_handler
+public  :: set_xml_stderr
+
+CONTAINS
+
+!-------------------------------------------------------------------------
+subroutine build_error_info(error_info,message,line,column,stack,severity)
+type(xml_error_t), intent(out)        :: error_info
+integer, intent(in)                   :: line, column
+character(len=*), intent(in)          :: message
+type(elstack_t), intent(in)           :: stack
+integer, intent(in)                   :: severity
+
+error_info%message = message
+error_info%line = line
+error_info%column = column
+error_info%stack = stack
+error_info%severity = severity
+
+end subroutine build_error_info
+
+!--------------------------------------------------
+
+subroutine default_error_handler(error_info)
+type(xml_error_t), intent(in)            :: error_info
+!
+! Default error handling
+!
+if (error_info%severity == SEVERE_ERROR_CODE)  then
+   write(unit=xml_stderr,fmt="(a)") "*** XML parsing Error:"
+else if (error_info%severity == WARNING_CODE)  then
+   write(unit=xml_stderr,fmt="(a)") "*** XML parsing Warning:"
+endif
+write(unit=xml_stderr,fmt="(a)") trim(error_info%message)
+write(unit=xml_stderr,fmt="(a,i8,a,i4)") "Line: ", &
+                                         error_info%line, &
+                                         " Column: ", &
+                                         error_info%column
+write(unit=xml_stderr,fmt="(a)") "Element traceback:"
+call print_elstack(error_info%stack,unit=xml_stderr)
+!
+!   If there is a severe error the program should stop...
+!
+if (error_info%severity == SEVERE_ERROR_CODE)  then
+      STOP
+else if (error_info%severity == WARNING_CODE)  then
+   write(unit=xml_stderr,fmt="(a)") "*** Continuing after Warning..."
+endif
+
+end subroutine default_error_handler
+
+!-------------------------------------------------------------------------
+subroutine set_xml_stderr(unit)
+integer, intent(in)  :: unit
+
+xml_stderr  = unit
+
+end subroutine set_xml_stderr
+
+end module m_xml_error
+
+
+
+
+
+
Index: vendors/XMLF90/current/src/sax/m_xml_parser.f90
===================================================================
--- vendors/XMLF90/current/src/sax/m_xml_parser.f90	(revision 1899)
+++ vendors/XMLF90/current/src/sax/m_xml_parser.f90	(revision 1899)
@@ -0,0 +1,506 @@
+module m_xml_parser
+
+!
+! Basic module to parse XML in the SAX spirit.
+!
+
+use m_buffer
+use m_reader
+use m_fsm
+use m_dictionary
+use m_debug
+use m_xml_error
+use m_elstack          ! For element nesting checks
+use m_entities
+!
+private
+
+!
+!  XML file handle
+!
+type, public :: xml_t
+private
+      type(file_buffer_t)  :: fb
+      type(fsm_t)          :: fx
+      character(len=200)   :: path_mark
+end type xml_t
+
+!
+public :: xml_parse
+public :: open_xmlfile, close_xmlfile
+public :: endfile_xmlfile, rewind_xmlfile
+public :: eof_xmlfile, sync_xmlfile
+public :: xml_char_count
+public :: xml_path, xml_mark_path, xml_get_path_mark
+public :: xml_name, xml_attributes
+
+CONTAINS  !=============================================================
+
+subroutine open_xmlfile(fname,fxml,iostat,record_size)
+character(len=*), intent(in)      :: fname
+integer, intent(out)              :: iostat
+type(xml_t), intent(out)          :: fxml
+integer, intent(in), optional     :: record_size
+
+call open_file(fname,fxml%fb,iostat,record_size)
+call init_fsm(fxml%fx)
+fxml%path_mark = ""
+
+end subroutine open_xmlfile
+!-------------------------------------------------------------------------
+
+subroutine rewind_xmlfile(fxml)
+type(xml_t), intent(inout) :: fxml
+
+call rewind_file(fxml%fb)
+call reset_fsm(fxml%fx)
+fxml%path_mark = ""
+
+end subroutine rewind_xmlfile
+
+!-----------------------------------------
+subroutine endfile_xmlfile(fxml)
+type(xml_t), intent(inout) :: fxml
+
+call mark_eof_file(fxml%fb) 
+
+end subroutine endfile_xmlfile
+
+!-----------------------------------------
+subroutine close_xmlfile(fxml)
+type(xml_t), intent(inout) :: fxml
+
+call close_file_buffer(fxml%fb)
+call reset_fsm(fxml%fx)         ! just in case
+fxml%path_mark = ""             ! ""
+
+end subroutine close_xmlfile
+
+!-----------------------------------------
+subroutine sync_xmlfile(fxml,iostat)
+type(xml_t), intent(inout) :: fxml
+integer, intent(out)       :: iostat
+
+call sync_file(fxml%fb,iostat)
+! Do not reset fx: that's the whole point of synching.
+
+end subroutine sync_xmlfile
+
+!----------------------------------------------------
+function eof_xmlfile(fxml) result (res)
+type(xml_t), intent(in)          :: fxml
+logical                          :: res
+
+res = eof_file(fxml%fb)
+
+end function eof_xmlfile
+!
+!----------------------------------------------------
+!----------------------------------------------------
+function xml_char_count(fxml) result (nc)
+type(xml_t), intent(in)          :: fxml
+integer                          :: nc
+
+nc = nchars_processed(fxml%fb)
+
+end function xml_char_count
+!
+!----------------------------------------------------
+!
+
+subroutine xml_parse(fxml, begin_element_handler,    &
+                           end_element_handler,      &
+                           pcdata_chunk_handler,     &
+                           comment_handler,          &
+                           xml_declaration_handler,  &
+                           cdata_section_handler,     &
+                           sgml_declaration_handler, &
+                           error_handler,            &
+                           signal_handler,            &
+                           verbose,                  &
+                           empty_element_handler)
+
+type(xml_t), intent(inout), target  :: fxml
+
+optional                            :: begin_element_handler
+optional                            :: end_element_handler
+optional                            :: pcdata_chunk_handler
+optional                            :: comment_handler
+optional                            :: xml_declaration_handler
+optional                            :: sgml_declaration_handler
+optional                            :: cdata_section_handler
+optional                            :: error_handler
+optional                            :: signal_handler
+logical, intent(in), optional       :: verbose
+optional                            :: empty_element_handler
+
+interface
+   subroutine begin_element_handler(name,attributes)
+   use m_dictionary
+   character(len=*), intent(in)     :: name
+   type(dictionary_t), intent(in)   :: attributes
+   end subroutine begin_element_handler
+
+   subroutine end_element_handler(name)
+   character(len=*), intent(in)     :: name
+   end subroutine end_element_handler
+
+   subroutine pcdata_chunk_handler(chunk)
+   character(len=*), intent(in) :: chunk
+   end subroutine pcdata_chunk_handler
+
+   subroutine comment_handler(comment)
+   character(len=*), intent(in) :: comment
+   end subroutine comment_handler
+
+   subroutine xml_declaration_handler(name,attributes)
+   use m_dictionary
+   character(len=*), intent(in)     :: name
+   type(dictionary_t), intent(in)   :: attributes
+   end subroutine xml_declaration_handler
+
+   subroutine sgml_declaration_handler(sgml_declaration)
+   character(len=*), intent(in) :: sgml_declaration
+   end subroutine sgml_declaration_handler
+
+   subroutine cdata_section_handler(cdata)
+   character(len=*), intent(in) :: cdata
+   end subroutine cdata_section_handler
+
+   subroutine error_handler(error_info)
+   use m_xml_error
+   type(xml_error_t), intent(in)            :: error_info
+   end subroutine error_handler
+
+   subroutine signal_handler(code)
+   logical, intent(out) :: code
+   end subroutine signal_handler
+
+   subroutine empty_element_handler(name,attributes)
+   use m_dictionary
+   character(len=*), intent(in)     :: name
+   type(dictionary_t), intent(in)   :: attributes
+   end subroutine empty_element_handler
+
+end interface
+
+character(len=1)     :: c
+integer              :: iostat, status
+
+character(len=150)   :: message
+integer              :: signal
+
+type(buffer_t)       :: translated_pcdata
+type(buffer_t)       :: name, oldname, dummy
+
+logical              :: have_begin_handler, have_end_handler, &
+                        have_pcdata_handler, have_comment_handler, &
+                        have_xml_declaration_handler, &
+                        have_sgml_declaration_handler, &
+                        have_cdata_section_handler, have_empty_handler, &
+                        have_error_handler, have_signal_handler
+
+logical              :: pause_signal
+
+type(xml_error_t)            :: error_info
+type(file_buffer_t), pointer :: fb
+type(fsm_t), pointer         :: fx
+
+have_begin_handler = present(begin_element_handler)
+have_end_handler = present(end_element_handler)
+have_pcdata_handler = present(pcdata_chunk_handler)
+have_comment_handler = present(comment_handler)
+have_xml_declaration_handler = present(xml_declaration_handler)
+have_sgml_declaration_handler = present(sgml_declaration_handler)
+have_cdata_section_handler = present(cdata_section_handler)
+have_error_handler = present(error_handler)
+have_signal_handler = present(signal_handler)
+have_empty_handler = present(empty_element_handler)
+
+fb => fxml%fb
+fx => fxml%fx
+if (present(verbose)) then
+   debug = verbose                 ! For m_converters
+   fx%debug = verbose              ! job-specific flag
+endif
+
+if (fx%debug) print *, " Entering xml_parse..."
+
+!---------------------------------------------------------------------
+do
+      call get_character(fb,c,iostat)
+
+      if (iostat /= 0) then          ! End of file...
+         if (.not. is_empty(fx%element_stack)) then
+            call build_error_info(error_info, &
+                 "Early end of file.", &
+                 line(fb),column(fb),fx%element_stack,SEVERE_ERROR_CODE)
+            if (have_error_handler) then
+               call error_handler(error_info)
+            else
+               call default_error_handler(error_info)
+            endif
+         endif
+         call endfile_xmlfile(fxml)  ! Mark it as eof
+         EXIT
+      endif
+
+      call evolve_fsm(fx,c,signal)
+
+      if (fx%debug) print *, c, " ::: ", trim(fx%action)
+
+      if (signal == END_OF_TAG) then
+         !
+         ! We decide whether we have ended an opening tag or a closing tag
+         !
+         if (fx%context == OPENING_TAG) then
+            name = fx%element_name
+
+            if (fx%debug) print *, "We have found an opening tag"
+            if (fx%root_element_seen) then
+               if (name .equal. fx%root_element_name) then
+                  call build_error_info(error_info, &
+                  "Duplicate root element: " // str(name), &
+                  line(fb),column(fb),fx%element_stack,SEVERE_ERROR_CODE)
+                  if (have_error_handler) then
+                     call error_handler(error_info)
+                  else
+                     call default_error_handler(error_info)
+                  endif
+               endif
+               if (is_empty(fx%element_stack)) then
+                  call build_error_info(error_info, &
+                  "Opening tag beyond root context: " // str(name), &
+                  line(fb),column(fb),fx%element_stack,SEVERE_ERROR_CODE)
+                  if (have_error_handler) then
+                     call error_handler(error_info)
+                  else
+                     call default_error_handler(error_info)
+                  endif
+               endif
+            else
+               fx%root_element_name = name
+               fx%root_element_seen = .true.
+            endif
+            call push_elstack(name,fx%element_stack)
+            if (have_begin_handler) &
+                call begin_element_handler(str(name),fx%attributes)
+
+         else if (fx%context == CLOSING_TAG) then
+            name = fx%element_name
+         
+            if (fx%debug) print *, "We have found a closing tag"
+            if (is_empty(fx%element_stack)) then
+               call build_error_info(error_info, &
+                  "Nesting error: End tag: " // str(name) //  &
+                  " does not match -- too many end tags", &
+                  line(fb),column(fb),fx%element_stack,SEVERE_ERROR_CODE)
+               if (have_error_handler) then
+                  call error_handler(error_info)
+               else
+                  call default_error_handler(error_info)
+               endif
+            else
+               call get_top_elstack(fx%element_stack,oldname)
+               if (oldname .equal. name) then
+                  call pop_elstack(fx%element_stack,oldname)
+                  if (have_end_handler) call end_element_handler(str(name))
+!!                  call pop_elstack(fx%element_stack,oldname)
+               else
+                  call build_error_info(error_info, &
+                       "Nesting error: End tag: " // str(name) //  &
+                       ". Expecting end of : " // str(oldname), &
+                       line(fb),column(fb),fx%element_stack,SEVERE_ERROR_CODE)
+                  if (have_error_handler) then
+                     call error_handler(error_info)
+                  else
+                     call default_error_handler(error_info)
+                  endif
+               endif
+            endif
+         else if (fx%context == SINGLE_TAG) then
+            name = fx%element_name
+
+            if (fx%debug) print *, "We have found a single (empty) tag: ", &
+                                char(name)
+            !
+            ! Push name on to stack to reveal true xpath
+            !
+            call push_elstack(name,fx%element_stack)
+            if (have_empty_handler) then
+               if (fx%debug) print *, "--> calling empty_element_handler."
+               call empty_element_handler(str(name),fx%attributes)
+               call pop_elstack(fx%element_stack,dummy)
+            else
+               if (have_begin_handler) then
+                  if (fx%debug) print *, "--> calling begin_element_handler..."
+                  call begin_element_handler(str(name),fx%attributes)
+               endif
+               call pop_elstack(fx%element_stack,dummy)
+               if (have_end_handler) then
+                  if (fx%debug) print *, "--> ... and end_element_handler."
+                  call end_element_handler(str(name))
+               endif
+            endif
+!!            call pop_elstack(fx%element_stack,dummy)
+
+         else if (fx%context == CDATA_SECTION_TAG) then
+
+            if (fx%debug) print *, "We found a CDATA section"
+            if (is_empty(fx%element_stack)) then
+               if (fx%debug) print *, &
+                   "... Warning: CDATA section outside element context"
+            else
+               if (have_cdata_section_handler) then
+                  call cdata_section_handler(str(fx%pcdata))
+               else
+                  if (have_pcdata_handler) &
+                   call pcdata_chunk_handler(str(fx%pcdata))
+               endif
+            endif
+
+         else if (fx%context == COMMENT_TAG) then
+
+            if (fx%debug) print *, "We found a comment tag"
+            if (have_comment_handler)  &
+                 call comment_handler(str(fx%pcdata))
+
+         else if (fx%context == SGML_DECLARATION_TAG) then
+
+            if (fx%debug) print *, "We found an sgml declaration"
+            if (have_sgml_declaration_handler)  &
+                      call sgml_declaration_handler(str(fx%pcdata))
+
+         else if (fx%context == XML_DECLARATION_TAG) then
+
+            if (fx%debug) print *, "We found an XML declaration"
+            name = fx%element_name
+            if (have_xml_declaration_handler)  &
+                      call xml_declaration_handler(str(name),fx%attributes)
+
+         else
+
+            ! do nothing
+
+         endif
+
+      else if (signal == CHUNK_OF_PCDATA) then
+
+         if (fx%debug) print *, "We found a chunk of PCDATA"
+         if (is_empty(fx%element_stack)) then
+            if (fx%debug) print *, "... Warning: PCDATA outside element context"
+               ! Just a warning
+               call build_error_info(error_info, &
+                  "PCDATA outside of element context", &
+                  line(fb),column(fb),fx%element_stack,WARNING_CODE)
+               if (have_error_handler) then
+                  call error_handler(error_info)
+               else
+                  call default_error_handler(error_info)
+               endif
+         else
+            !
+            ! Replace entities by their value
+            !
+            call entity_filter(fx%pcdata,translated_pcdata,status,message)
+            if (status < 0) then
+               call build_error_info(error_info, message, &
+                  line(fb),-status,fx%element_stack,SEVERE_ERROR_CODE)
+               if (have_error_handler) then
+                  call error_handler(error_info)
+               else
+                  call default_error_handler(error_info)
+               endif
+            else if (status > 0) then
+               ! Just a warning
+               call build_error_info(error_info, message, &
+                  line(fb),status,fx%element_stack,WARNING_CODE)
+               if (have_error_handler) then
+                  call error_handler(error_info)
+               else
+                  call default_error_handler(error_info)
+               endif
+            else
+               if (have_pcdata_handler) &
+                   call pcdata_chunk_handler(str(translated_pcdata))
+            endif
+         endif
+
+      else if (signal == EXCEPTION) then
+         call build_error_info(error_info, fx%action, &
+                  line(fb),column(fb),fx%element_stack,SEVERE_ERROR_CODE)
+         if (have_error_handler) then
+            call error_handler(error_info)
+         else
+            call default_error_handler(error_info)
+         endif
+      else
+         ! QUIET, do nothing
+      endif
+      if (signal /= QUIET) then
+         if (have_signal_handler) then
+            call signal_handler(pause_signal)
+            if (pause_signal) exit
+         endif
+      endif
+
+enddo
+
+end subroutine xml_parse
+
+!-----------------------------------------
+subroutine xml_path(fxml,path)
+type(xml_t), intent(in) :: fxml
+character(len=*), intent(out)  :: path
+
+call get_elstack_signature(fxml%fx%element_stack,path)
+
+end subroutine xml_path
+
+!-----------------------------------------
+subroutine xml_mark_path(fxml,path)
+!
+! Marks the current path
+!
+type(xml_t), intent(inout) :: fxml
+character(len=*), intent(out)  :: path
+
+call get_elstack_signature(fxml%fx%element_stack,fxml%path_mark)
+path = fxml%path_mark
+
+end subroutine xml_mark_path
+
+!-----------------------------------------
+subroutine xml_get_path_mark(fxml,path)
+!
+! Returns the currently markd path (or an empty string if there are no marks)
+!
+type(xml_t), intent(in)        :: fxml
+character(len=*), intent(out)  :: path
+
+path = fxml%path_mark
+
+end subroutine xml_get_path_mark
+
+!-----------------------------------------
+subroutine xml_name(fxml,name)
+type(xml_t), intent(in) :: fxml
+character(len=*), intent(out)  :: name
+
+name = char(fxml%fx%element_name)
+
+end subroutine xml_name
+!-----------------------------------------
+subroutine xml_attributes(fxml,attributes)
+type(xml_t), intent(in) :: fxml
+type(dictionary_t), intent(out)  :: attributes
+
+attributes = fxml%fx%attributes
+
+end subroutine xml_attributes
+
+end module m_xml_parser
+
+
+
+
Index: vendors/XMLF90/current/src/strings/m_strings.f90
===================================================================
--- vendors/XMLF90/current/src/strings/m_strings.f90	(revision 1899)
+++ vendors/XMLF90/current/src/strings/m_strings.f90	(revision 1899)
@@ -0,0 +1,6323 @@
+!*******************************************************************************
+! module STRINGS
+! Mart Rentmeester, Mart.Rentmeester@sci.kun.nl
+! http://nn-online.sci.kun.nl/fortran
+! Version 1.0
+!*******************************************************************************
+
+      module m_strings
+
+      private
+
+      type string
+          private
+          integer                 :: len = 0
+          integer                 :: size = 0
+
+          character, pointer      :: chars(:) => null()
+
+      end type string
+
+      character, parameter :: blank = ' '
+
+!     GENERIC PROCEDURE INTERFACE DEFINITIONS
+
+!---- LEN interface
+      interface len
+          module procedure len_s
+      end interface
+
+!---- Conversion (to CHAR) procedure interfaces
+      interface char
+          module procedure s_to_c, &! string to character
+                           s_to_slc       ! string to specified length character
+      end interface
+
+!---- ASSIGNMENT interfaces
+      interface assignment(=)
+          module procedure assign_s_to_s, &! string = string
+                           assign_s_to_c, &! character = string
+                           assign_c_to_s        ! string = character
+      end interface
+
+!---- // operator interfaces
+      interface operator(//)
+          module procedure s_concat_s, &! string // string
+                           s_concat_c, &! string // character
+                           c_concat_s     ! character // string
+      end interface
+
+!---- INSERT_IN_STRING interface
+      interface insert_in_string
+          module procedure insert_in_string_c, insert_in_string_s
+      end interface
+
+!---- PREPEND_TO_STRING interface
+      interface prepend_to_string
+          module procedure prepend_to_string_c, prepend_to_string_s
+      end interface
+
+!---- APPEND_TO_STRING interface
+      interface append_to_string
+          module procedure append_to_string_c, append_to_string_s
+      end interface
+
+!---- REPLACE_IN_STRING interface
+      interface replace_in_string
+          module procedure replace_in_string_sc_s,   replace_in_string_ss_s,   &
+                           replace_in_string_sc_sf,  replace_in_string_ss_sf,  &
+                           replace_in_string_scc,    replace_in_string_ssc,    &
+                           replace_in_string_scs,    replace_in_string_sss,    &
+                           replace_in_string_scc_f,  replace_in_string_ssc_f,  &
+                           replace_in_string_scs_f,  replace_in_string_sss_f
+      end interface
+
+
+!---- REPEAT interface
+      interface repeat
+          module procedure repeat_s
+      end interface
+
+!---- ==  .eq. comparison operator interfaces
+      interface operator(==)
+          module procedure s_eq_s, &! string == string
+                           s_eq_c, &! string == character
+                           c_eq_s         ! character == string
+      end interface
+
+!---- /=  .ne. comparison operator interfaces
+      interface operator(/=)
+          module procedure s_ne_s, &! string /= string
+                           s_ne_c, &! string /= character
+                           c_ne_s         ! character /= string
+      end interface
+
+!---- <  .lt. comparison operator interfaces
+      interface operator(<)
+          module procedure s_lt_s, &! string < string
+                           s_lt_c, &! string < character
+                           c_lt_s         ! character < string
+      end interface
+
+!---- <=  .le. comparison operator interfaces
+      interface operator(<=)
+          module procedure s_le_s, &! string <= string
+                           s_le_c, &! string <= character
+                           c_le_s         ! character <= string
+      end interface
+
+!---- >=  .ge. comparison operator interfaces
+      interface operator(>=)
+          module procedure s_ge_s, &! string >= string
+                           s_ge_c, &! string >= character
+                           c_ge_s         ! character >= string
+      end interface
+
+!---- >  .gt. comparison operator interfaces
+      interface operator(>)
+          module procedure s_gt_s, &! string > string
+                           s_gt_c, &! string > character
+                           c_gt_s         ! character > string
+      end interface
+
+!---- .aeq. comparison operator interfaces
+      interface operator(.aeq.)
+          module procedure a_eq_a, &! array == array
+                           a_eq_c, &! array == character
+                           c_eq_a         ! character == array
+      end interface
+
+!---- .ane. comparison operator interfaces
+      interface operator(.ane.)
+          module procedure a_ne_a, &! array /= array
+                           a_ne_c, &! array /= character
+                           c_ne_a         ! character /= array
+      end interface
+
+!---- .alt. comparison operator interfaces
+      interface operator(.alt.)
+          module procedure a_lt_a, &! array < array
+                           a_lt_c, &! array < character
+                           c_lt_a         ! character < array
+      end interface
+
+!---- .ale. comparison operator interfaces
+      interface operator(.ale.)
+          module procedure a_le_a, &! array <= array
+                           a_le_c, &! array <= character
+                           c_le_a         ! character <= array
+      end interface
+
+!---- .age. comparison operator interfaces
+      interface operator(.age.)
+          module procedure a_ge_a, &! array >= array
+                           a_ge_c, &! array >= character
+                           c_ge_a         ! character >= array
+      end interface
+
+!---- .agt. comparison operator interfaces
+      interface operator(.agt.)
+          module procedure a_gt_a, &! array > array
+                           a_gt_c, &! array > character
+                           c_gt_a         ! character > array
+      end interface
+
+!---- LLT comparison function interfaces
+      interface llt
+          module procedure s_llt_s, &! llt(string,string)
+                           s_llt_c, &! llt(string,character)
+                           c_llt_s        ! llt(character,string)
+      end interface
+
+!---- LLE comparison function interfaces
+      interface lle
+          module procedure s_lle_s, &! lle(string,string)
+                           s_lle_c, &! lle(string,character)
+                           c_lle_s        ! lle(character,string)
+      end interface
+
+!---- LGE comparison function interfaces
+      interface lge
+          module procedure s_lge_s, &! lge(string,string)
+                           s_lge_c, &! lge(string,character)
+                           c_lge_s        ! lge(character,string)
+      end interface
+
+!---- LGT comparison function interfaces
+      interface lgt
+          module procedure s_lgt_s, &! lgt(string,string)
+                           s_lgt_c, &! lgt(string,character)
+                           c_lgt_s        ! lgt(character,string)
+      end interface
+
+!---- ALLT comparison function interfaces
+      interface allt
+          module procedure a_allt_a, &! allt(array,array)
+                           a_allt_c, &! allt(array,character)
+                           c_allt_a        ! allt(character,array)
+      end interface
+
+!---- ALLE comparison function interfaces
+      interface alle
+          module procedure a_alle_a, &! alle(array,array)
+                           a_alle_c, &! alle(array,character)
+                           c_alle_a        ! alle(character,array)
+      end interface
+
+!---- ALGE comparison function interfaces
+      interface alge
+          module procedure a_alge_a, &! alge(array,array)
+                           a_alge_c, &! alge(array,character)
+                           c_alge_a        ! alge(character,array)
+      end interface
+
+!---- ALGT comparison function interfaces
+      interface algt
+          module procedure a_algt_a, &! algt(array,array)
+                           a_algt_c, &! algt(array,character)
+                           c_algt_a        ! algt(character,array)
+      end interface
+
+!---- INDEX procedure
+      interface index
+          module procedure index_ss, index_sc, index_cs
+      end interface
+
+!---- AINDEX procedure
+      interface aindex
+          module procedure aindex_aa, aindex_ac, aindex_ca
+      end interface
+
+!---- SCAN procedure
+      interface scan
+          module procedure scan_ss, scan_sc, scan_cs
+      end interface
+
+!---- ASCAN procedure
+      interface ascan
+          module procedure ascan_aa, ascan_ac, ascan_ca
+      end interface
+
+!---- VERIFY procedure
+      interface verify
+          module procedure verify_ss, verify_sc, verify_cs
+      end interface
+
+!---- AVERIFY procedure
+      interface averify
+          module procedure averify_aa, averify_ac, averify_ca
+      end interface
+
+!---- TRIM interface
+      interface len_trim
+          module procedure len_trim_s
+      end interface
+
+!---- LEN_TRIM interface
+      interface trim
+          module procedure trim_s
+      end interface
+
+!---- IACHAR interface
+      interface iachar
+          module procedure iachar_s
+      end interface
+
+!---- ICHAR interface
+      interface ichar
+          module procedure ichar_s
+      end interface
+
+!---- ADJUSTL interface
+      interface adjustl
+          module procedure adjustl_s
+      end interface
+
+!---- ADJUSTR interface
+      interface adjustr
+          module procedure adjustr_s
+      end interface
+
+!---- LEN_STRIP interface
+      interface len_strip
+          module procedure len_strip_c, len_strip_s
+      end interface
+
+!---- STRIP interface
+      interface strip
+          module procedure strip_c, strip_s
+      end interface
+
+!---- UPPERCASE interface
+      interface uppercase
+          module procedure uppercase_s, uppercase_c
+      end interface
+
+!---- TO_UPPERCASE interface
+      interface to_uppercase
+          module procedure to_uppercase_s, to_uppercase_c
+      end interface
+
+!---- LOWERCASE interface
+      interface lowercase
+          module procedure lowercase_s, lowercase_c
+      end interface
+
+!---- TO_LOWERCASE interface
+      interface to_lowercase
+          module procedure to_lowercase_s, to_lowercase_c
+      end interface
+
+!---- EXTRACT interface
+      interface extract
+          module procedure extract_s, extract_c
+      end interface
+
+!---- SUBSTRING interface
+      interface substring
+          module procedure extract_s, extract_c
+      end interface
+
+!---- REMOVE interface
+      interface remove
+          module procedure remove_s, remove_c
+      end interface
+
+!---- INSERT interface
+      interface insert
+          module procedure insert_ss, insert_cs, insert_sc, insert_cc
+      end interface
+
+!---- REPLACE interface
+      interface replace
+          module procedure replace_cc_s,   replace_cs_s,   &
+                           replace_sc_s,   replace_ss_s,   &
+                           replace_cc_sf,  replace_cs_sf,  &
+                           replace_sc_sf,  replace_ss_sf,  &
+                           replace_ccc,    replace_csc,    &
+                           replace_ccs,    replace_css,    &
+                           replace_scc,    replace_ssc,    &
+                           replace_scs,    replace_sss,    &
+                           replace_ccc_f,  replace_csc_f,  &
+                           replace_ccs_f,  replace_css_f,  &
+                           replace_scc_f,  replace_ssc_f,  &
+                           replace_scs_f,  replace_sss_f
+      end interface
+
+!---- SORT interface
+      interface sort
+          module procedure sort_c, sort_s
+      end interface
+
+!---- LSORT interface
+      interface lsort
+          module procedure lsort_c, lsort_s
+      end interface
+
+!---- RANK interface
+      interface rank
+          module procedure rank_c, rank_s
+      end interface
+
+!---- LRANK interface
+      interface lrank
+          module procedure lrank_c, lrank_s
+      end interface
+
+
+
+!---- Publically accessible entities
+      public :: string
+      public :: assignment(=),unstring
+      public :: insert,replace,remove,extract,substring
+      public :: repeat,index,scan,verify
+      public :: operator(//)
+      public :: operator(==),operator(/=)
+      public :: operator(<),operator(<=)
+      public :: operator(>),operator(>=)
+      public :: llt,lle,lge,lgt
+      public :: char,len,len_trim,trim,iachar,ichar,adjustl,adjustr
+      public :: lowercase,to_lowercase,uppercase,to_uppercase
+      public :: strip,len_strip
+      public :: sort,rank,lsort,lrank
+
+      public :: resize_string,string_size,swap_strings
+      public :: trim_string,strip_string
+      public :: adjustl_string,adjustr_string
+      public :: insert_in_string,remove_from_string
+      public :: prepend_to_string,append_to_string
+      public :: replace_in_string
+
+
+
+
+      contains
+
+!*******************************************************************************
+!     LEN
+!*******************************************************************************
+
+      elemental function len_s(s)
+
+      implicit none
+      type(string), intent(in)  :: s
+      integer                   :: len_s
+
+
+      len_s = s%len
+
+      end function len_s
+
+!*******************************************************************************
+!     STRING_SIZE
+!*******************************************************************************
+
+      elemental function string_size(s)
+
+      implicit none
+      type(string), intent(in)  :: s
+      integer                   :: string_size
+
+
+      string_size = s%size
+
+      end function string_size
+
+!*******************************************************************************
+!     CHAR
+!*******************************************************************************
+!     Returns the characters of string as an automatically sized character
+
+      pure function s_to_c(s)
+
+      implicit none
+      type(string),intent(in)   :: s
+      character(len(s))         :: s_to_c
+
+
+      s_to_c = transfer(s%chars(1:len(s)),s_to_c)
+
+      end function s_to_c
+
+!*******************************************************************************
+!     Returns the character of fixed length, length, containing the characters
+!     of string either padded with blanks or truncated on the right to fit
+
+      pure function s_to_slc(s,length)
+
+      implicit none
+      type(string),intent(in)  :: s
+      integer, intent(in)      :: length
+      character(length)        :: s_to_slc
+      integer                  :: i,lc
+
+
+      lc = min(len(s),length)
+      s_to_slc(1:lc) = transfer(s%chars(1:lc),s_to_slc)
+
+!     Result longer than string: padding needed
+      if (lc < length) s_to_slc(lc+1:length) = blank
+
+      end function s_to_slc
+
+!*******************************************************************************
+! Assign a string value to a string variable overriding default assignement.
+! Reallocates string variable to size of string value and copies characters.
+
+      elemental subroutine assign_s_to_s(var,expr)
+
+      implicit none
+      type(string), intent(out)  :: var
+      type(string), intent(in)   :: expr
+
+
+
+      if (associated(var%chars,expr%chars)) then
+!         Identity assignment: nothing to be done
+          continue
+      else
+          if (associated(var%chars)) deallocate(var%chars)
+
+          var%size = expr%size
+          var%len = expr%len
+!AG
+          if (associated(expr%chars)) then
+             allocate(var%chars(1:var%size))
+             var%chars(1:var%len) = expr%chars(1:var%len)
+          endif
+      endif
+
+
+      end subroutine assign_s_to_s
+
+!*******************************************************************************
+! Assign a string value to a character variable.
+! If the string is longer than the character truncate the string on the right.
+! If the string is shorter the character is blank padded on the right.
+
+      elemental subroutine assign_s_to_c(var,expr)
+
+      implicit none
+      character(*), intent(out)  :: var
+      type(string), intent(in)   :: expr
+      integer                    :: i,lc,ls
+
+
+      lc = len(var);
+      ls = min(len(expr),lc)
+
+      var(1:ls) = transfer(expr%chars(1:ls),var(1:ls))
+
+      do i=ls+1,lc
+          var(i:i) = blank
+      enddo
+
+      end subroutine assign_s_to_c
+
+!*******************************************************************************
+!     Assign a character value to a string variable.
+!     Disassociates the string variable from its current value, allocates new
+!     space to hold the characters and copies them from the character value
+!     into this space.
+
+      elemental subroutine assign_c_to_s(var,expr)
+
+      implicit none
+      type(string), intent(out)  :: var
+      character(*), intent(in)   :: expr
+      integer                    :: i,lc
+
+
+
+      if (associated(var%chars)) deallocate(var%chars)
+
+
+      lc = len(expr)
+      var%len = lc
+      var%size = lc
+      allocate(var%chars(1:lc))
+!!AG: NAG compiler uses temporaries here:
+      var%chars(:) = (/ (expr(i:i), i=1,lc) /)
+
+      endsubroutine assign_c_to_s
+
+!*******************************************************************************
+!     RESIZE_STRING procedure
+!*******************************************************************************
+
+!*** return code
+!*** n < 0  --> deallocate?
+
+!     pure subroutine resize_string(s,newsize,status)
+      pure subroutine resize_string(s,newsize)
+
+      implicit none
+      type(string), intent(inout)     :: s
+      integer, intent(in)             :: newsize
+!     integer, intent(out), optional  :: status
+
+      character, pointer              :: c(:)
+
+      integer                         :: i
+
+
+      if (newsize <= 0) return
+
+
+      if (associated(s%chars)) then
+
+          i = min(newsize,s%len)
+          allocate(c(i))
+          c(:) = s%chars(1:i)
+          deallocate(s%chars)
+
+          s%chars => c
+
+          s%len = i
+          s%size = newsize
+      else
+          s%size = newsize
+          s%len = 0
+          allocate(s%chars(s%size))
+      endif
+
+      end subroutine resize_string
+
+!*******************************************************************************
+!     SWAP_STRINGS
+!*******************************************************************************
+      subroutine swap_strings(s1,s2)
+
+
+      implicit none
+      type(string), intent(inout)  :: s1,s2
+      integer                      :: l,s
+      character, pointer           :: c(:)
+
+
+      l = s1%len
+      s = s1%size
+      c => s1%chars
+      s1%len = s2%len
+      s1%size = s2%size
+      s1%chars => s2%chars
+      s2%len = l
+      s2%size = s
+      s2%chars => c
+
+      end subroutine swap_strings
+
+!*******************************************************************************
+!     TRIM_STRINGSIZE
+!*******************************************************************************
+
+      subroutine trim_stringsize(s)
+
+      implicit none
+      type(string), intent(inout)  :: s
+
+
+      call resize_string(s,len(s))
+
+      end subroutine trim_stringsize
+
+!*******************************************************************************
+!     TRIM_STRING
+!*******************************************************************************
+
+      subroutine trim_string(s)
+
+      implicit none
+      type(string), intent(inout)  :: s
+
+
+      s%len = len_trim(s)
+
+      end subroutine trim_string
+
+!*******************************************************************************
+!    STRIP
+!*******************************************************************************
+
+     pure subroutine strip_string(s)
+
+     implicit none
+     type(string), intent(inout)  :: s
+     integer                      :: i,i1,i2
+
+
+     do i1=1,len(s)
+         if (s%chars(i1) /= blank) exit
+     enddo
+     do i2=len(s),1,-1
+         if (s%chars(i2) /= blank) exit
+     enddo
+     do i=i1,i2
+         s%chars(i-i1+1) = s%chars(i)
+     enddo
+     s%len = i2 - i1 + 1
+
+     end subroutine strip_string
+
+!*******************************************************************************
+!     ADJUSTL_STRING
+!*******************************************************************************
+! Returns as a character variable the string adjusted to the left,
+! removing leading blanks and inserting trailing blanks.
+
+      pure subroutine adjustl_string(s)
+
+      implicit none
+      type(string), intent(inout)  :: s
+      integer                      :: i,j
+
+
+      do i=1,len(s)
+          if (s%chars(i) /= blank) exit
+      enddo
+      do j=i,len(s)
+          s%chars(j-i:j-i) = s%chars(j)
+      enddo
+      s%chars(j+1:) = blank
+
+      end subroutine adjustl_string
+
+!*******************************************************************************
+!     ADJUSTR_STRING
+!*******************************************************************************
+! Returns as a character variable the string adjusted to the right,
+! removing trailing blanks and inserting leading blanks.
+
+      pure subroutine adjustr_string(s)
+
+      implicit none
+      type(string), intent(inout)  :: s
+      integer                      :: i,j,l,lt
+
+
+      l = len(s)
+      lt = len_trim(s)
+
+      i = l - lt
+
+      do j=1,lt
+          s%chars(j+i:j+i) = s%chars(j)
+      enddo
+      s%chars(1:i) = blank
+
+
+      end subroutine adjustr_string
+
+!*******************************************************************************
+!     PREPEND_TO_STRING
+!*******************************************************************************
+
+      pure subroutine prepend_to_string_s(s1,s2)
+
+      implicit none
+      type(string), intent(inout)  :: s1
+      type(string), intent(in)     :: s2
+      integer                      :: i,ls1,ls2
+
+      character, pointer           :: ss(:)
+
+
+      ls1 = len(s1)
+      ls2 = len(s2)
+      if (ls2 == 0) return
+      if (ls1+ls2 > string_size(s1)) then
+          allocate(ss(ls1+ls2))
+          do i=1,ls2
+              ss(i) = s2%chars(i)
+          enddo
+          do i=1,ls1
+              ss(ls2+i) = s1%chars(i)
+          enddo
+          deallocate(s1%chars)
+
+          s1%chars => ss
+
+          s1%len = ls1 + ls2
+          s1%size = s1%len
+      else
+          do i=ls1,1,-1
+              s1%chars(ls2+i) = s1%chars(i)
+          enddo
+          do i=1,ls2
+              s1%chars(i) = s2%chars(i)
+          enddo
+          s1%len = ls1 + ls2
+      endif
+
+      end subroutine prepend_to_string_s
+
+!*******************************************************************************
+
+      pure subroutine prepend_to_string_c(s,c)
+
+      implicit none
+      type(string), intent(inout)  :: s
+      character(*), intent(in)     :: c
+      integer                      :: i,ls,lc
+
+      character, pointer           :: ss(:)
+
+
+
+      ls = len(s)
+      lc = len(c)
+      if (lc == 0) return
+      if (ls+lc > string_size(s)) then
+          allocate(ss(ls+lc))
+          do i=1,lc
+              ss(i) = c(i:i)
+          enddo
+          do i=1,ls
+              ss(lc+i) = s%chars(i)
+          enddo
+          deallocate(s%chars)
+
+          s%chars => ss
+
+          s%len = ls + lc
+          s%size = s%len
+      else
+          do i=ls,1,-1
+              s%chars(lc+i) = s%chars(i)
+          enddo
+          do i=1,lc
+              s%chars(i) = c(i:i)
+          enddo
+          s%len = ls + lc
+      endif
+
+      end subroutine prepend_to_string_c
+
+!*******************************************************************************
+!     APPEND_TO_STRING
+!*******************************************************************************
+
+      pure subroutine append_to_string_s(s1,s2)
+
+      implicit none
+      type(string), intent(inout)  :: s1
+      type(string), intent(in)     :: s2
+      integer                      :: i,ls1,ls2
+
+      character, pointer           :: ss(:)
+
+
+      ls1 = len(s1)
+      ls2 = len(s2)
+      if (ls2 == 0) return
+      if (ls1+ls2 > string_size(s1)) then
+          allocate(ss(ls1+ls2))
+          do i=1,ls1
+              ss(i) = s1%chars(i)
+          enddo
+          do i=ls1+1,ls1+ls2
+              ss(i) = s2%chars(i-ls1)
+          enddo
+          deallocate(s1%chars)
+
+          s1%chars => ss
+
+          s1%len = ls1 + ls2
+          s1%size = s1%len
+      else
+          do i=ls1+1,ls1+ls2
+              s1%chars(i) = s2%chars(i-ls1)
+          enddo
+          s1%len = ls1 + ls2
+      endif
+
+      end subroutine append_to_string_s
+
+!*******************************************************************************
+
+      pure subroutine append_to_string_c(s,c)
+
+      implicit none
+      type(string), intent(inout)  :: s
+      character(*), intent(in)     :: c
+      integer                      :: i,ls,lc
+
+      character, pointer           :: ss(:)
+
+
+
+      ls = len(s)
+      lc = len(c)
+      if (lc == 0) return
+      if (ls+lc > string_size(s)) then
+          allocate(ss(ls+lc))
+          do i=1,ls
+              ss(i) = s%chars(i)
+          enddo
+          do i=ls+1,ls+lc
+              ss(i) = c(i-ls:i-ls)
+          enddo
+          deallocate(s%chars)
+
+          s%chars => ss
+
+          s%len = ls + lc
+          s%size = s%len
+      else
+          do i=ls+1,ls+lc
+              s%chars(i) = c(i-ls:i-ls)
+          enddo
+          s%len = ls + lc
+      endif
+
+      end subroutine append_to_string_c
+
+!*******************************************************************************
+!     INSERT_IN_STRING
+!*******************************************************************************
+
+      pure subroutine insert_in_string_s(s1,start,s2)
+
+      implicit none
+      type(string), intent(inout)  :: s1
+      type(string), intent(in)     :: s2
+      integer, intent(in)          :: start
+      integer                      :: i,ip,is,ls1,ls2
+
+      character, pointer           :: ss(:)
+
+
+      ls1 = len(s1)
+      ls2 = len(s2)
+      if (ls2 == 0) return
+      if (ls1+ls2 > string_size(s1)) then
+          allocate(ss(ls1+ls2))
+          is = max(start,1)
+          ip = min(ls1+1,is)
+          do i=1,ip-1
+              ss(i) = s1%chars(i)
+          enddo
+          do i=ip,ip+ls2-1
+              ss(i) = s2%chars(i-ip+1)
+          enddo
+          do i=ip+ls2,ls1+ls2
+              ss(i) = s1%chars(i-ls2)
+          enddo
+          deallocate(s1%chars)
+
+          s1%chars => ss
+
+          s1%len = ls1 + ls2
+          s1%size = s1%len
+      else
+          is = max(start,1)
+          ip = min(ls1+1,is)
+          do i=ls1+ls2,ip+ls2,-1
+              s1%chars(i) = s1%chars(i-ls2)
+          enddo
+          do i=ip,ip+ls2-1
+              s1%chars(i) = s2%chars(i-ip+1)
+          enddo
+          s1%len = ls1 + ls2
+      endif
+
+      end subroutine insert_in_string_s
+
+!*******************************************************************************
+
+      pure subroutine insert_in_string_c(s,start,c)
+
+      implicit none
+      type(string), intent(inout)  :: s
+      character(*), intent(in)     :: c
+      integer, intent(in)          :: start
+      integer                      :: i,ip,is,ls,lc
+
+      character, pointer           :: ss(:)
+
+
+
+      ls = len(s)
+      lc = len(c)
+      if (lc == 0) return
+      if (ls+lc > string_size(s)) then
+          allocate(ss(ls+lc))
+          is = max(start,1)
+          ip = min(ls+1,is)
+          do i=1,ip-1
+              ss(i) = s%chars(i)
+          enddo
+          do i=ip,ip+lc-1
+              ss(i) = c(i-ip+1:i-ip+1)
+          enddo
+          do i=ip+lc,ls+lc
+              ss(i) = s%chars(i-lc)
+          enddo
+          deallocate(s%chars)
+
+          s%chars => ss
+
+          s%len = ls + lc
+          s%size = s%len
+      else
+          is = max(start,1)
+          ip = min(ls+1,is)
+          do i=ls+lc,ip+lc,-1
+              s%chars(i) = s%chars(i-lc)
+          enddo
+          do i=ip,ip+lc-1
+              s%chars(i) = c(i-ip+1:i-ip+1)
+          enddo
+          s%len = ls + lc
+      endif
+
+      end subroutine insert_in_string_c
+
+!*******************************************************************************
+!     REPLACE_IN_STRING
+!*******************************************************************************
+!     pure subroutine replace_in_string_ss_s(s,start,ss)
+!
+!     implicit none
+!     type(string), intent(inout)  :: s
+!     type(string), intent(in)     :: ss
+!     integer, intent(in)          :: start
+!
+!
+!     call replace_in_string_sc_s(s,start,char(ss))
+!
+!     end subroutine replace_in_string_ss_s
+!*******************************************************************************
+
+!*******************************************************************************
+
+      pure subroutine replace_in_string_ss_s(s,start,ss)
+
+      implicit none
+      type(string), intent(inout)  :: s
+      type(string), intent(in)     :: ss
+      integer, intent(in)          :: start
+      integer                      :: i,ip,is,lr,lss,ls
+      character, pointer           :: rs(:)
+      logical                      :: new
+
+
+      lr = lr_ss_s(s,start,ss)
+      lss = len(ss)
+      ls = len(s)
+      is = max(start,1)
+      ip = min(ls+1,is)
+
+      new = lr > string_size(s)
+
+      if (new) then
+          allocate(rs(lr))
+      else
+          rs => s%chars
+      endif
+
+      do i=lr,ip+lss,-1
+          rs(i) = s%chars(i)
+      enddo
+      do i=lss,1,-1
+          rs(ip-1+i) = ss%chars(i)
+      enddo
+      if (new) then
+          do i=1,ip-1
+              rs(i) = s%chars(i)
+          enddo
+      endif
+
+      if (new) then
+          deallocate(s%chars)
+          s%chars => rs
+          s%size = lr
+      else
+          nullify(rs)
+      endif
+      s%len = lr
+
+      end subroutine replace_in_string_ss_s
+
+!*******************************************************************************
+!     pure subroutine replace_in_string_ss_sf(s,start,finish,ss)
+!
+!     implicit none
+!     type(string), intent(inout)  :: s
+!     type(string), intent(in)     :: ss
+!     integer, intent(in)          :: start,finish
+!
+!
+!     call replace_in_string_sc_sf(s,start,finish,char(ss))
+!
+!     end subroutine replace_in_string_ss_sf
+!*******************************************************************************
+
+!*******************************************************************************
+
+      pure subroutine replace_in_string_ss_sf(s,start,finish,ss)
+
+      implicit none
+      type(string), intent(inout)  :: s
+      type(string), intent(in)     :: ss
+      integer, intent(in)          :: start,finish
+      integer                      :: i,if,ip,is,lr,ls,lss
+      character, pointer           :: rs(:)
+      logical                      :: new
+
+
+      lr = lr_ss_sf(s,start,finish,ss)
+      lss = len(ss)
+      ls = len(s)
+      is = max(start,1)
+      ip = min(ls+1,is)
+      if = max(ip-1,min(finish,ls))
+
+      new = lr > string_size(s)
+
+      if (new) then
+          allocate(rs(lr))
+      else
+          rs => s%chars
+      endif
+
+      do i=1,lr-ip-lss+1
+          rs(i+ip+lss-1) = s%chars(if+i)
+      enddo
+      do i=lss,1,-1
+          rs(i+ip-1) = ss%chars(i)
+      enddo
+      if (new) then
+          do i=1,ip-1
+              rs(i) = s%chars(i)
+          enddo
+      endif
+
+      if (new) then
+          deallocate(s%chars)
+          s%chars => rs
+          s%size = lr
+      else
+          nullify(rs)
+      endif
+      s%len = lr
+
+      end subroutine replace_in_string_ss_sf
+
+!*******************************************************************************
+
+!*******************************************************************************
+
+      pure subroutine replace_in_string_sc_s(s,start,c)
+
+      implicit none
+      type(string), intent(inout)  :: s
+      character(*), intent(in)     :: c
+      integer, intent(in)          :: start
+      integer                      :: i,ip,is,lc,lr,ls
+      character, pointer           :: rs(:)
+      logical                      :: new
+
+
+      lr = lr_sc_s(s,start,c)
+      lc = len(c)
+      ls = len(s)
+      is = max(start,1)
+      ip = min(ls+1,is)
+
+      new = lr > string_size(s)
+
+      if (new) then
+          allocate(rs(lr))
+      else
+          rs => s%chars
+      endif
+
+      do i=lr,ip+lc,-1
+          rs(i) = s%chars(i)
+      enddo
+      do i=lc,1,-1
+          rs(ip-1+i) = c(i:i)
+      enddo
+      if (new) then
+          do i=1,ip-1
+              rs(i) = s%chars(i)
+          enddo
+      endif
+
+      if (new) then
+          deallocate(s%chars)
+          s%chars => rs
+          s%size = lr
+      else
+          nullify(rs)
+      endif
+      s%len = lr
+
+      end subroutine replace_in_string_sc_s
+
+!*******************************************************************************
+
+!*******************************************************************************
+
+      pure subroutine replace_in_string_sc_sf(s,start,finish,c)
+
+      implicit none
+      type(string), intent(inout)  :: s
+      character(*), intent(in)     :: c
+      integer, intent(in)          :: start,finish
+      integer                      :: i,if,ip,is,lc,lr,ls
+      character, pointer           :: rs(:)
+      logical                      :: new
+
+
+      lr = lr_sc_sf(s,start,finish,c)
+      lc = len(c)
+      ls = len(s)
+      is = max(start,1)
+      ip = min(ls+1,is)
+      if = max(ip-1,min(finish,ls))
+
+      new = lr > string_size(s)
+
+      if (new) then
+          allocate(rs(lr))
+      else
+          rs => s%chars
+      endif
+
+      do i=1,lr-ip-lc+1
+          rs(i+ip+lc-1) = s%chars(if+i)
+      enddo
+      do i=lc,1,-1
+          rs(i+ip-1) = c(i:i)
+      enddo
+      if (new) then
+          do i=1,ip-1
+              rs(i) = s%chars(i)
+          enddo
+      endif
+
+      if (new) then
+          deallocate(s%chars)
+          s%chars => rs
+          s%size = lr
+      else
+          nullify(rs)
+      endif
+      s%len = lr
+
+      end subroutine replace_in_string_sc_sf
+
+!*******************************************************************************
+!*******************************************************************************
+!*******************************************************************************
+
+      pure subroutine replace_in_string_scc(s,target,ss)
+
+      implicit none
+      type(string), intent(inout)  :: s
+      character(*), intent(in)     :: target,ss
+
+
+      call x_replace_in_string_scc(s,target,ss,'first')
+
+
+      end subroutine replace_in_string_scc
+
+!*******************************************************************************
+
+      pure subroutine replace_in_string_scc_f(s,target,ss,action)
+
+      implicit none
+      type(string), intent(inout)  :: s
+      character(*), intent(in)     :: target,ss,action
+
+
+      call x_replace_in_string_scc(s,target,ss,action)
+
+      end subroutine replace_in_string_scc_f
+
+!*******************************************************************************
+
+      pure subroutine x_replace_in_string_scc(s,target,ss,action)
+
+      implicit none
+      type(string), intent(inout)  :: s
+      character(*), intent(in)     :: target,ss,action
+      logical                      :: every,back
+      integer                      :: lr,ls,lt,lss
+      integer                      :: i,i1,i2,k1,k2,m1,m2
+
+      character, pointer           :: rs(:)
+
+
+
+      lr = lr_scc(s,target,ss,action)
+      ls = len(s)
+      lt = len(target)
+      lss = len(ss)
+
+      if (lt == 0) then
+          if (ls == 0) then
+              do i=1,lss
+                  s%chars(i) = ss(i:i)
+              enddo
+              s%len = lss
+          endif
+          return
+      endif
+
+      select case(uppercase(action))
+      case('FIRST')
+          back = .false.
+          every = .false.
+      case('LAST')
+          back = .true.
+          every = .false.
+      case('ALL')
+          back = .false.
+          every = .true.
+      case default
+          back = .false.
+          every = .false.
+      end select
+
+      allocate(rs(lr))
+
+      if (back) then
+!         Backwards search
+
+!         k2 points to the absolute position one before the target in string
+          k2 = ls
+          m2 = lr
+          do
+!             find the next occurrence of target
+              i1 = aindex(s%chars(:k2),target,back)
+              if (i1 == 0) then
+!                 fill up to the end
+                  rs(:m2) = s%chars(:k2)
+                  exit
+              endif
+!             i1 points to the absolute position of the first
+!             letter of target in string
+!             i2 points to the absolute position of the last
+!             letter of target in string
+              i2 = i1 + lt - 1
+
+!             copy the unaffected text string chunk after it
+!             k1 points to the absolute position one after target in string
+              k1 = i2 + 1
+              m1 = m2 + k1 - k2
+              rs(m1:m2) = s%chars(k1:k2)
+              m2 = m1 - 1
+              m1 = m2 - lss + 1
+!             copy the replacement substring for target
+              do i=1,lss
+                  rs(m1+i-1) = ss(i:i)
+              enddo
+
+!             k2 points to the absolute position one before the target in string
+              k2 = i1 - 1
+              m2 = m1 - 1
+              if (.not.every) then
+                  rs(:m2) = s%chars(:k2)
+                  exit
+              endif
+          enddo
+      else
+!         Forward search
+
+!         k1 points to the absolute position one after target in string
+          k1 = 1
+          m1 = 1
+          do
+!             find the next occurrence of target
+              i1 = aindex(s%chars(k1:),target)
+              if (i1 == 0) then
+!                 fill up to the end
+                  rs(m1:lr) = s%chars(k1:ls)
+                  exit
+              endif
+!             i1 points to the absolute position of the first
+!             letter of target in string
+              i1 = k1 + (i1 - 1)
+!             i2 points to the absolute position of the last
+!             letter of target in string
+              i2 = i1 + lt - 1
+
+!             copy the unaffected text string chunk before it
+!             k2 points to the absolute position one before the target in string
+              k2 = i1 - 1
+              m2 = m1 + k2 - k1
+              rs(m1:m2) = s%chars(k1:k2)
+              m1 = m2 + 1
+              m2 = m1 + lss - 1
+!             copy the replacement substring for target
+              do i=1,lss
+                  rs(m1+i-1) = ss(i:i)
+              enddo
+
+!             k1 points to the absolute position one after target in string
+              k1 = i2 + 1
+              m1 = m2 + 1
+              if (.not.every) then
+                  rs(m1:lr) = s%chars(k1:ls)
+                  exit
+              endif
+          enddo
+      endif
+
+
+      if (associated(s%chars)) deallocate(s%chars)
+      s%chars => rs
+
+      s%len = lr
+      s%size = size(s%chars)
+
+      end subroutine x_replace_in_string_scc
+
+!*******************************************************************************
+
+      pure subroutine replace_in_string_ssc(s,target,ss)
+
+      implicit none
+      type(string), intent(inout)  :: s
+      type(string), intent(in)     :: target
+      character(*), intent(in)     :: ss
+
+
+      call x_replace_in_string_scc(s,char(target),ss,'first')
+
+      end subroutine replace_in_string_ssc
+
+!*******************************************************************************
+
+      pure subroutine replace_in_string_ssc_f(s,target,ss,action)
+
+      implicit none
+      type(string), intent(inout)  :: s
+      type(string), intent(in)     :: target
+      character(*), intent(in)     :: ss,action
+
+
+      call x_replace_in_string_scc(s,char(target),ss,action)
+
+      end subroutine replace_in_string_ssc_f
+
+!*******************************************************************************
+
+      pure subroutine replace_in_string_scs(s,target,ss)
+
+      implicit none
+      type(string), intent(inout)  :: s
+      type(string), intent(in)     :: ss
+      character(*), intent(in)     :: target
+
+
+      call x_replace_in_string_scc(s,target,char(ss),'first')
+
+      end subroutine replace_in_string_scs
+
+!*******************************************************************************
+
+      pure subroutine replace_in_string_scs_f(s,target,ss,action)
+
+      implicit none
+      type(string), intent(inout)  :: s
+      type(string), intent(in)     :: ss
+      character(*), intent(in)     :: target,action
+
+
+      call x_replace_in_string_scc(s,target,char(ss),action)
+
+      end subroutine replace_in_string_scs_f
+
+!*******************************************************************************
+
+      pure subroutine replace_in_string_sss(s,target,ss)
+
+      implicit none
+      type(string), intent(inout)  :: s
+      type(string), intent(in)     :: ss,target
+
+
+      call x_replace_in_string_scc(s,char(target),char(ss),'first')
+
+      end subroutine replace_in_string_sss
+
+!*******************************************************************************
+
+      pure subroutine replace_in_string_sss_f(s,target,ss,action)
+
+      implicit none
+      type(string), intent(inout)  :: s
+      type(string), intent(in)     :: ss,target
+      character(*), intent(in)     :: action
+
+
+      call x_replace_in_string_scc(s,char(target),char(ss),action)
+
+      end subroutine replace_in_string_sss_f
+
+!*******************************************************************************
+!     REMOVE_FROM_STRING
+!*******************************************************************************
+
+      pure subroutine remove_from_string(s,start,finish)
+
+      implicit none
+      type(string), intent(inout)                      :: s
+      integer, intent(in)                              :: start,finish
+      integer                                          :: i,if,is,le,ls
+
+
+      is = max(1,start)
+      ls = len(s)
+      if = min(ls,finish)
+      if (if < is) return
+
+      le = if - is + 1            ! = len_extract
+      do i=if+1,ls
+          s%chars(i-le) = s%chars(i)
+      enddo
+      s%len = s%len - le
+
+      end subroutine remove_from_string
+
+!*******************************************************************************
+!     UNSTRING procedure
+!*******************************************************************************
+!     Deallocate the chars in the string to avoid leaking of memory
+!     Use this in functions and subroutines on locally declared variables
+!     of type string after their use. (I.e. garbage collecting).
+
+      elemental subroutine unstring(s)
+
+      implicit none
+      type(string), intent(inout)  :: s
+
+
+
+      if (associated(s%chars)) deallocate(s%chars)
+      nullify(s%chars)
+
+      s%size = 0
+      s%len = 0
+
+      end subroutine unstring
+
+!*******************************************************************************
+!     //
+!*******************************************************************************
+!     string // string
+
+      pure function s_concat_s(s1,s2)
+
+      implicit none
+      type(string), intent(in)    :: s1,s2
+      character(len(s1)+len(s2))  :: s_concat_s
+      integer                     :: l1,l2
+
+
+      l1 = len(s1)
+      l2 = len(s2)
+      s_concat_s(1:l1) = s1
+      s_concat_s(1+l1:l1+l2) = s2
+
+      end function s_concat_s
+
+!*******************************************************************************
+!     string // character
+
+      pure function s_concat_c(s,c)
+
+      implicit none
+      type(string), intent(in)  :: s
+      character(*), intent(in)  :: c
+      character(len(s)+len(c))  :: s_concat_c
+      integer                   :: ls,lc
+
+
+      ls = len(s)
+      lc = len(c)
+      s_concat_c(1:ls) = s
+      s_concat_c(1+ls:ls+lc) = c
+
+      end function s_concat_c
+
+!*******************************************************************************
+!     character // string
+
+      pure function c_concat_s(c,s)
+
+      implicit none
+      character(*), intent(in)  :: c
+      type(string), intent(in)  :: s
+      character(len(s)+len(c))  :: c_concat_s
+      integer                   :: lc,ls
+
+
+      lc = len(c)
+      ls = len(s)
+      c_concat_s(1:lc) = c
+      c_concat_s(1+lc:lc+ls) = s
+
+      end function c_concat_s
+
+!*******************************************************************************
+!     REPEAT
+!*******************************************************************************
+
+      function repeat_s(s,ncopies)
+
+      implicit none
+      type(string), intent(in)   :: s
+      integer, intent(in)        :: ncopies
+      character(ncopies*len(s))  :: repeat_s
+
+
+      if (ncopies < 0) stop 'Negative ncopies requested in REPEAT'
+      repeat_s = repeat(char(s),ncopies)
+
+      end function repeat_s
+
+!*******************************************************************************
+!     LEN_TRIM
+!*******************************************************************************
+
+      elemental function len_trim_s(s)
+
+      implicit none
+      type(string), intent(in)  :: s
+      integer                   :: len_trim_s
+
+      if (len(s) == 0) then
+        len_trim_s = 0
+        return
+      endif
+      do len_trim_s = len(s),1,-1
+          if (s%chars(len_trim_s) /= blank) return
+      end do
+
+      end function len_trim_s
+
+!*******************************************************************************
+!     TRIM
+!*******************************************************************************
+
+      pure function trim_s(s)
+
+      implicit none
+      type(string), intent(in)  :: s
+      character(len_trim(s))    :: trim_s
+      integer                   :: i
+
+
+      do i=1,len(trim_s)
+          trim_s(i:i) = s%chars(i)
+      enddo
+
+      end function trim_s
+
+!*******************************************************************************
+!     IACHAR
+!*******************************************************************************
+! Returns the position of the character string in the ISO 646 collating
+! sequence. String must be of length one, otherwise result is as for
+! intrinsic iachar.
+
+      elemental function iachar_s(s)
+
+      implicit none
+      type(string), intent(in) :: s
+      integer                  :: iachar_s
+
+
+      iachar_s = iachar(char(s))
+
+      end function iachar_s
+
+!*******************************************************************************
+!     ICHAR
+!*******************************************************************************
+! Returns the position of character from string in the processor collating
+! sequence. String must be of length one, otherwise it will behave as the
+! intrinsic ichar with the equivalent character string.
+
+      elemental function ichar_s(s)
+
+      implicit none
+      type(string), intent(in) ::  s
+      integer                  ::  ichar_s
+
+
+      ichar_s = ichar(char(s))
+
+      end function ichar_s
+
+!*******************************************************************************
+!     ADJUSTL
+!*******************************************************************************
+! Returns as a character variable the string adjusted to the left,
+! removing leading blanks and inserting trailing blanks.
+
+      pure function adjustl_s(s)
+
+      implicit none
+      type(string), intent(in)  :: s
+      character(len(s))         :: adjustl_s
+
+
+      adjustl_s = adjustl(char(s))
+
+      end function adjustl_s
+
+!*******************************************************************************
+!     ADJUSTR
+!*******************************************************************************
+! Returns as a character variable the string adjusted to the right,
+! removing trailing blanks and inserting leading blanks.
+
+      pure function adjustr_s(s)
+
+      implicit none
+      type(string), intent(in)  :: s
+      character(len(s))         :: adjustr_s
+
+
+      adjustr_s = adjustr(char(s))
+
+      end function adjustr_s
+
+!*******************************************************************************
+!    LEN_STRIP
+!*******************************************************************************
+
+     elemental function len_strip_s(s)
+
+     implicit none
+     type(string), intent(in) :: s
+     integer                  :: len_strip_s
+     integer                  :: i1,i2
+
+
+     do i1=1,len(s)
+         if (s%chars(i1) /= blank) exit
+     enddo
+     do i2=len(s),1,-1
+         if (s%chars(i2) /= blank) exit
+     enddo
+     len_strip_s = max(0,i2-i1+1)
+
+     end function len_strip_s
+
+!*******************************************************************************
+!    STRIP
+!*******************************************************************************
+
+     pure function strip_s(s)
+
+     implicit none
+     type(string), intent(in)  :: s
+     character(len_strip(s))   :: strip_s
+     integer                   :: i,j
+
+
+     do i=1,len(s)
+         if (s%chars(i) /= blank) exit
+     enddo
+     do j=1,len(strip_s)
+         strip_s(j:j) = s%chars(i+j-1)
+     enddo
+
+     end function strip_s
+
+!*******************************************************************************
+
+     elemental function len_strip_c(c)
+
+     implicit none
+     character(*), intent(in) :: c
+     integer                  :: len_strip_c
+     integer                  :: i1,i2
+
+
+     do i1=1,len(c)
+         if (c(i1:i1) /= blank) exit
+     enddo
+     i2 = len_trim(c)
+     len_strip_c = max(0,i2-i1+1)
+
+     end function len_strip_c
+
+!*******************************************************************************
+
+     pure function strip_c(c)
+
+     implicit none
+     character(*), intent(in)  :: c
+     character(len_strip(c))   :: strip_c
+     integer                   :: i
+
+
+     do i=1,len(c)
+         if (c(i:i) /= blank) exit
+     enddo
+     strip_c(1:) = c(i:)
+
+     end function strip_c
+
+!*******************************************************************************
+!     EXTRACT
+!*******************************************************************************
+      elemental FUNCTION len_extract_s(s,start,finish)
+
+      implicit none
+      type(string), intent(in)  :: s
+      integer, intent(in)       :: start,finish
+      integer                   :: len_extract_s
+      integer                   :: is,if
+
+
+      is = max(1,start)
+      if = min(len(s),finish)
+      if (if < is) then
+          len_extract_s = 0
+      else
+          len_extract_s = max(0,if-is) + 1
+      endif
+
+      end function len_extract_s
+
+!*****************************************************
+      pure function extract_s(s,start,finish)
+
+      implicit none
+      type(string), intent(in)                  :: s
+      integer, intent(in)                       :: start,finish
+      character(len_extract_s(s,start,finish))  :: extract_s
+      integer                                   :: i,is,if
+
+
+      is = max(1,start)
+      if = min(len(s),finish)
+      if (if < is) then
+          extract_s = ''
+      else
+          do i=1,max(0,if-is+1)
+              extract_s(i:i) = s%chars(is+i-1)
+          enddo
+      endif
+
+      end function extract_s
+
+!*******************************************************************************
+
+!      elemental FUNCTION len_extract_s(s,start,finish)
+
+!      implicit none
+!      type(string), intent(in)  :: s
+!      integer, intent(in)       :: start,finish
+!      integer                   :: len_extract_s
+!      integer                   :: is,if
+
+
+!      is = max(1,start)
+!      if = min(len(s),finish)
+!      if (if < is) then
+!          len_extract_s = 0
+!      else
+!          len_extract_s = max(0,if-is) + 1
+!      endif
+
+!      end function len_extract_s
+
+!*******************************************************************************
+
+      elemental function len_extract_c(c,start,finish)
+
+      implicit none
+      character(*), intent(in)  :: c
+      integer, intent(in)       :: start,finish
+      integer                   :: len_extract_c
+      integer                   :: is,if
+
+
+      is = max(1,start)
+      if = min(len(c),finish)
+      if (if < is) then
+          len_extract_c = 0
+      else
+          len_extract_c = max(0,if-is) + 1
+      endif
+
+      end function len_extract_c
+
+!*******************************************************************************
+
+      pure function extract_c(c,start,finish)
+
+      implicit none
+      character(*), intent(in)                  :: c
+      integer, intent(in)                       :: start,finish
+      character(len_extract_c(c,start,finish))  :: extract_c
+      integer                                   :: is,if
+
+
+      is = max(1,start)
+      if = min(len(c),finish)
+      if (if < is) then
+          extract_c = ''
+      else
+          extract_c(1:if-is+1) = c(is:if)
+      endif
+
+      end function extract_c
+
+!*******************************************************************************
+
+!      elemental function len_extract_c(c,start,finish)
+
+!      implicit none
+!      character(*), intent(in)  :: c
+!      integer, intent(in)       :: start,finish
+!      integer                   :: len_extract_c
+!      integer                   :: is,if
+
+
+!      is = max(1,start)
+!      if = min(len(c),finish)
+!      if (if < is) then
+!          len_extract_c = 0
+!      else
+!          len_extract_c = max(0,if-is) + 1
+!      endif
+
+!      end function len_extract_c
+
+!*******************************************************************************
+!     INSERT
+!*******************************************************************************
+
+      pure function insert_ss(s1,start,s2)
+
+      implicit none
+      type(string), intent(in)    :: s1,s2
+      integer, intent(in)         :: start
+      character(len(s1)+len(s2))  :: insert_ss
+      integer                     :: i,ip,is,ls1,ls2
+
+
+      ls1 = len(s1)
+      ls2 = len(s2)
+      is = max(start,1)
+      ip = min(ls1+1,is)
+      do i=1,ip-1
+          insert_ss(i:i) = s1%chars(i)
+      enddo
+      do i=ip,ip+ls2-1
+          insert_ss(i:i) = s2%chars(i-ip+1)
+      enddo
+      do i=ip+ls2,ls1+ls2
+          insert_ss(i:i) = s1%chars(i-ls2)
+      enddo
+
+      end function insert_ss
+
+!*******************************************************************************
+
+      pure function insert_sc(s1,start,c2)
+
+      implicit none
+      type(string), intent(in)    :: s1
+      character(*), intent(in)    :: c2
+      integer, intent(in)         :: start
+      character(len(s1)+len(c2))  :: insert_sc
+      integer                     :: i,ip,is,ls1,ls2
+
+
+      ls1 = len(s1)
+      ls2 = len(c2)
+      is = max(start,1)
+      ip = min(ls1+1,is)
+      do i=1,ip-1
+          insert_sc(i:i) = s1%chars(i)
+      enddo
+      insert_sc(ip:ip+ls2-1) = c2
+      do i=ip+ls2,ls1+ls2
+          insert_sc(i:i) = s1%chars(i-ls2)
+      enddo
+
+      end function insert_sc
+
+!*******************************************************************************
+
+      pure function insert_cs(c1,start,s2)
+
+      implicit none
+      character(*), intent(in)    :: c1
+      type(string), intent(in)    :: s2
+      integer, intent(in)         :: start
+      character(len(c1)+len(s2))  :: insert_cs
+      integer                     :: i,ip,is,ls1,ls2
+
+
+      ls1 = len(c1)
+      ls2 = len(s2)
+      is = max(start,1)
+      ip = min(ls1+1,is)
+      insert_cs(1:ip-1) = c1(1:ip-1)
+      do i=ip,ip+ls2-1
+          insert_cs(i:i) = s2%chars(i-ip+1)
+      enddo
+      insert_cs(ip+ls2:ls1+ls2) = c1(ip:ls1)
+
+      end function insert_cs
+
+!*******************************************************************************
+
+      pure function insert_cc(c1,start,c2)
+
+      implicit none
+      character(*), intent(in)    :: c1,c2
+      integer, intent(in)         :: start
+      character(len(c1)+len(c2))  :: insert_cc
+      integer                     :: ip,is,ls1,ls2
+
+
+      ls1 = len(c1)
+      ls2 = len(c2)
+      is = max(start,1)
+      ip = min(ls1+1,is)
+      insert_cc(1:ip-1) = c1(1:ip-1)
+      insert_cc(ip:ip+ls2-1) = c2
+      insert_cc(ip+ls2:ls1+ls2) = c1(ip:ls1)
+
+      end function insert_cc
+
+!*******************************************************************************
+!     REMOVE
+!*******************************************************************************
+
+      pure function remove_c(c,start,finish)
+
+      implicit none
+      character(*), intent(in)                         :: c
+      integer, intent(in)                              :: start,finish
+      character(len(c)-len_extract_c(c,start,finish))  :: remove_c
+      integer                                          :: if,is,ls
+
+
+      is = max(1,start)
+      ls = len(c)
+      if = min(ls,finish)
+      if (if < is) then
+          remove_c = c
+      else
+          remove_c = c(1:is-1) // c(if+1:)
+      endif
+
+      end function remove_c
+
+!*******************************************************************************
+
+      pure function remove_s(s,start,finish)
+
+      implicit none
+      type(string), intent(in)                         :: s
+      integer, intent(in)                              :: start,finish
+      character(len(s)-len_extract_s(s,start,finish))  :: remove_s
+      integer                                          :: i,if,is,le,ls
+
+
+      is = max(1,start)
+      ls = len(s)
+      if = min(ls,finish)
+      if (if < is) then
+           remove_s = s
+      else
+          le = if - is + 1
+          do i=1,is-1
+              remove_s(i:i) = s%chars(i)
+          enddo
+          do i=if+1,ls
+              remove_s(i-le:i-le) = s%chars(i)
+          enddo
+      endif
+
+      end function remove_s
+
+!*******************************************************************************
+!     REPLACE
+!*******************************************************************************
+
+      pure function lr_cc_s(s,start,ss) result(l)
+
+      implicit none
+      character(*), intent(in)  :: s,ss
+      integer, intent(in)       :: start
+      integer                   :: l
+      integer                   :: ip,is,ls,lss
+
+
+      l = max(len(s),min(len(s)+1,max(start,1)+len(ss)-1))
+
+      end function lr_cc_s
+
+!*******************************************************************************
+!  Calculate the result string by the following actions:
+!  Insert the characters from substring SS into string STR beginning
+!  at position START replacing the following LEN(SUBSTRING) characters of
+!  the string and enlarging string if necessary. If START is greater than
+!  LEN(STRING) substring is simply appended to string by concatenation.
+!  If START is less than 1, substring replaces characters in string
+!  starting at 1
+
+      function replace_cc_s(s,start,ss) result(r)
+
+      implicit none
+      character(*), intent(in)        :: s,ss
+      integer, intent(in)             :: start
+      character(lr_cc_s(s,start,ss))  :: r
+      integer                         :: ip,is,l,lss,ls
+
+
+      lss = len(ss)
+      ls = len(s)
+      is = max(start,1)
+      ip = min(ls+1,is)
+      l = len(r)
+
+      r(1:ip-1) = s(1:ip-1)
+      r(ip:ip+lss-1) = ss
+      r(ip+lss:l) = s(ip+lss:ls)
+
+      end function replace_cc_s
+
+!*******************************************************************************
+
+      pure function lr_cc_sf(s,start,finish,ss) result(l)
+
+      implicit none
+      character(*), intent(in)  :: s,ss
+      integer, intent(in)       :: start,finish
+      integer                   :: l
+      integer                   :: if,ip,is,ls,lss
+
+
+      lss = len(ss)
+      ls = len(s)
+      is = max(start,1)
+      ip = min(ls+1,is)
+      if = max(ip-1,min(finish,ls))
+      l = lss + ls - if+ip-1
+
+      end function lr_cc_sf
+
+!*******************************************************************************
+!  Calculates the result string by the following actions:
+!  Insert the substring SS into string STR beginning at position
+!  START replacing the following FINISH-START+1 characters of the string
+!  and enlarging or shrinking the string if necessary.
+!  If start is greater than LEN(STRING) substring is simply appended to
+!  string by concatenation. If START is less than 1, START = 1 is used.
+!  If FINISH is greater than LEN(STRING), FINISH = LEN(STRING) is used.
+!  If FINISH is less than START, substring is inserted before START.
+
+      function replace_cc_sf(s,start,finish,ss) result(r)
+
+      implicit none
+      character(*), intent(in)                :: s,ss
+      integer, intent(in)                     :: start,finish
+      character(lr_cc_sf(s,start,finish,ss))  :: r
+      integer                                 :: i,if,ip,is,l,ls,lss
+
+
+      lss = len(ss)
+      ls = len(s)
+      is = max(start,1)
+      ip = min(ls+1,is)
+      if = max(ip-1,min(finish,ls))
+      l = len(r)
+
+      r(1:ip-1) = s(1:ip-1)
+      do i=1,lss
+          r(i+ip-1:i+ip-1) = ss(i:i)
+      enddo
+      do i=1,l-ip-lss+1
+          r(i+ip+lss-1:i+ip+lss-1) = s(if+i:if+i)
+      enddo
+
+      end function replace_cc_sf
+
+!*******************************************************************************
+
+      pure function lr_cs_s(s,start,ss) result(l)
+
+      implicit none
+      character(*), intent(in)  :: s
+      type(string), intent(in)  :: ss
+      integer, intent(in)       :: start
+      integer                   :: l
+      integer                   :: ip,is,ls,lss
+
+
+      l = max(len(s),min(len(s)+1,max(start,1)+len(ss)-1))
+
+      end function lr_cs_s
+
+!*******************************************************************************
+!  Calculate the result string by the following actions:
+!  Insert the characters from substring SS into string STR beginning
+!  at position START replacing the following LEN(SUBSTRING) characters of
+!  the string and enlarging string if necessary. If START is greater than
+!  LEN(STRING) substring is simply appended to string by concatenation.
+!  If START is less than 1, substring replaces characters in string
+!  starting at 1
+
+      function replace_cs_s(s,start,ss) result(r)
+
+      implicit none
+      character(*), intent(in)        :: s
+      type(string), intent(in)        :: ss
+      integer, intent(in)             :: start
+      character(lr_cs_s(s,start,ss))  :: r
+      integer                         :: i,ip,is,l,lss,ls
+
+
+      lss = len(ss)
+      ls = len(s)
+      is = max(start,1)
+      ip = min(ls+1,is)
+      l = len(r)
+
+      r(1:ip-1) = s(1:ip-1)
+      r(ip:ip+lss-1) = transfer(ss%chars(1:lss),r(1:lss))
+      r(ip+lss:l) = s(ip+lss:ls)
+
+      end function replace_cs_s
+
+!*******************************************************************************
+
+      pure function lr_cs_sf(s,start,finish,ss) result(l)
+
+      implicit none
+      character(*), intent(in)  :: s
+      type(string), intent(in)  :: ss
+      integer, intent(in)       :: start,finish
+      integer                   :: l
+      integer                   :: if,ip,is,ls,lss
+
+
+      lss = len(ss)
+      ls = len(s)
+      is = max(start,1)
+      ip = min(ls+1,is)
+      if = max(ip-1,min(finish,ls))
+      l = lss + ls - if+ip-1
+
+      end function lr_cs_sf
+
+!*******************************************************************************
+!  Calculates the result string by the following actions:
+!  Insert the substring SS into string STR beginning at position
+!  START replacing the following FINISH-START+1 characters of the string
+!  and enlarging or shrinking the string if necessary.
+!  If start is greater than LEN(STRING) substring is simply appended to
+!  string by concatenation. If START is less than 1, START = 1 is used.
+!  If FINISH is greater than LEN(STRING), FINISH = LEN(STRING) is used.
+!  If FINISH is less than START, substring is inserted before START.
+
+      function replace_cs_sf(s,start,finish,ss) result(r)
+
+      implicit none
+      character(*), intent(in)                :: s
+      type(string), intent(in)                :: ss
+      integer, intent(in)                     :: start,finish
+      character(lr_cs_sf(s,start,finish,ss))  :: r
+      integer                                 :: i,if,ip,is,l,ls,lss
+
+
+      lss = len(ss)
+      ls = len(s)
+      is = max(start,1)
+      ip = min(ls+1,is)
+      if = max(ip-1,min(finish,ls))
+      l = len(r)
+
+      r(1:ip-1) = s(1:ip-1)
+
+      r(i+ip:i+ip+lss-1) = transfer(ss%chars(1:lss),r(1:lss))
+
+      do i=1,lss
+          r(i+ip-1:i+ip-1) = ss%chars(i)
+      enddo
+
+      do i=1,l-ip-lss+1
+          r(i+ip+lss-1:i+ip+lss-1) = s(if+i:if+i)
+      enddo
+
+      end function replace_cs_sf
+
+!*******************************************************************************
+
+      pure function lr_sc_s(s,start,ss) result(l)
+
+      implicit none
+      type(string), intent(in)  :: s
+      character(*), intent(in)  :: ss
+      integer, intent(in)       :: start
+      integer                   :: l
+      integer                   :: ip,is,ls,lss
+
+
+      l = max(len(s),min(len(s)+1,max(start,1)+len(ss)-1))
+
+      end function lr_sc_s
+
+!*******************************************************************************
+!  Calculate the result string by the following actions:
+!  Insert the characters from substring SS into string STR beginning
+!  at position START replacing the following LEN(SUBSTRING) characters of
+!  the string and enlarging string if necessary. If START is greater than
+!  LEN(STRING) substring is simply appended to string by concatenation.
+!  If START is less than 1, substring replaces characters in string
+!  starting at 1
+
+      function replace_sc_s(s,start,ss) result(r)
+
+      implicit none
+      type(string), intent(in)        :: s
+      character(*), intent(in)        :: ss
+      integer, intent(in)             :: start
+      character(lr_sc_s(s,start,ss))  :: r
+      integer                         :: i,ip,is,l,lss,ls
+
+
+      lss = len(ss)
+      ls = len(s)
+      is = max(start,1)
+      ip = min(ls+1,is)
+      l = len(r)
+
+      do i=1,ip-1
+          r(i:i) = s%chars(i)
+      enddo
+
+      do i=1,lss
+          r(i+ip-1:i+ip-1) = ss(i:i)
+      enddo
+
+      do i=ip+lss,l
+          r(i:i) = s%chars(i)
+      enddo
+
+      end function replace_sc_s
+
+!*******************************************************************************
+
+      pure function lr_sc_sf(s,start,finish,ss) result(l)
+
+      implicit none
+      type(string), intent(in)  :: s
+      character(*), intent(in)  :: ss
+      integer, intent(in)       :: start,finish
+      integer                   :: l
+      integer                   :: if,ip,is,ls,lss
+
+
+      lss = len(ss)
+      ls = len(s)
+      is = max(start,1)
+      ip = min(ls+1,is)
+      if = max(ip-1,min(finish,ls))
+      l = lss + ls - if+ip-1
+
+      end function lr_sc_sf
+
+!*******************************************************************************
+!  Calculates the result string by the following actions:
+!  Insert the substring SS into string STR beginning at position
+!  START replacing the following FINISH-START+1 characters of the string
+!  and enlarging or shrinking the string if necessary.
+!  If start is greater than LEN(STRING) substring is simply appended to
+!  string by concatenation. If START is less than 1, START = 1 is used.
+!  If FINISH is greater than LEN(STRING), FINISH = LEN(STRING) is used.
+!  If FINISH is less than START, substring is inserted before START.
+
+      function replace_sc_sf(s,start,finish,ss) result(r)
+
+      implicit none
+      type(string), intent(in)                :: s
+      character(*), intent(in)                :: ss
+      integer, intent(in)                     :: start,finish
+      character(lr_sc_sf(s,start,finish,ss))  :: r
+      integer                                 :: i,if,ip,is,l,ls,lss
+
+
+      lss = len(ss)
+      ls = len(s)
+      is = max(start,1)
+      ip = min(ls+1,is)
+      if = max(ip-1,min(finish,ls))
+      l = len(r)
+
+      do i=1,ip-1
+          r(i:i) = s%chars(i)
+      enddo
+
+      r(ip:ip+lss-1) = ss
+
+      do i=1,l-ip-lss+1
+          r(i+ip+lss-1:i+ip+lss-1) = s%chars(if+i)
+      enddo
+
+      end function replace_sc_sf
+
+!*******************************************************************************
+
+      pure function lr_ss_s(s,start,ss) result(l)
+
+      implicit none
+      type(string), intent(in)  :: s,ss
+      integer, intent(in)       :: start
+      integer                   :: l
+      integer                   :: ip,is,ls,lss
+
+
+      l = max(len(s),min(len(s)+1,max(start,1)+len(ss)-1))
+
+      end function lr_ss_s
+
+!*******************************************************************************
+!  Calculate the result string by the following actions:
+!  Insert the characters from substring SS into string STR beginning
+!  at position START replacing the following LEN(SUBSTRING) characters of
+!  the string and enlarging string if necessary. If START is greater than
+!  LEN(STRING) substring is simply appended to string by concatenation.
+!  If START is less than 1, substring replaces characters in string
+!  starting at 1
+
+      function replace_ss_s(s,start,ss) result(r)
+
+      implicit none
+      type(string), intent(in)        :: s,ss
+      integer, intent(in)             :: start
+      character(lr_ss_s(s,start,ss))  :: r
+      integer                         :: i,ip,is,l,lss,ls
+
+
+      lss = len(ss)
+      ls = len(s)
+      is = max(start,1)
+      ip = min(ls+1,is)
+      l = len(r)
+
+      do i=1,ip-1
+          r(i:i) = s%chars(i)
+      enddo
+
+      do i=1,lss
+          r(ip-1+i:ip-1+i) = ss%chars(i)
+      enddo
+
+      do i=ip+lss,l
+          r(i:i) = s%chars(i)
+      enddo
+
+      end function replace_ss_s
+
+!*******************************************************************************
+
+      pure function lr_ss_sf(s,start,finish,ss) result(l)
+
+      implicit none
+      type(string), intent(in)  :: s,ss
+      integer, intent(in)       :: start,finish
+      integer                   :: l
+      integer                   :: if,ip,is,ls,lss
+
+
+      lss = len(ss)
+      ls = len(s)
+      is = max(start,1)
+      ip = min(ls+1,is)
+      if = max(ip-1,min(finish,ls))
+      l = lss + ls - if+ip-1
+
+      end function lr_ss_sf
+
+!*******************************************************************************
+!  Calculates the result string by the following actions:
+!  Insert the substring SS into string STR beginning at position
+!  START replacing the following FINISH-START+1 characters of the string
+!  and enlarging or shrinking the string if necessary.
+!  If start is greater than LEN(STRING) substring is simply appended to
+!  string by concatenation. If START is less than 1, START = 1 is used.
+!  If FINISH is greater than LEN(STRING), FINISH = LEN(STRING) is used.
+!  If FINISH is less than START, substring is inserted before START.
+
+      function replace_ss_sf(s,start,finish,ss) result(r)
+
+      implicit none
+      type(string), intent(in)                :: s,ss
+      integer, intent(in)                     :: start,finish
+      character(lr_ss_sf(s,start,finish,ss))  :: r
+      integer                                 :: i,if,ip,is,l,ls,lss
+
+
+      lss = len(ss)
+      ls = len(s)
+      is = max(start,1)
+      ip = min(ls+1,is)
+      if = max(ip-1,min(finish,ls))
+      l = len(r)
+
+      do i=1,ip-1
+          r(i:i) = s%chars(i)
+      enddo
+
+      do i=1,lss
+          r(i+ip-1:i+ip-1) = ss%chars(i)
+      enddo
+
+      do i=1,l-ip-lss+1
+          r(i+ip+lss-1:i+ip+lss-1) = s%chars(if+i)
+      enddo
+
+      end function replace_ss_sf
+
+!*******************************************************************************
+
+      pure function lr_ccc(s,target,ss,action) result(l)
+
+      implicit none
+      character(*), intent(in)       :: s,target,ss,action
+      integer                        :: l
+      logical                        :: every,back
+      integer                        :: ls,lt,lss,ipos,nr
+
+
+      ls = len(s)
+      lt = len(target)
+      lss = len(ss)
+
+      if (lt == 0) then
+          if (ls == 0) then
+              l = lss
+          else
+              l = ls
+          endif
+          return
+      endif
+
+      if (lt == lss) then
+          l = ls
+          return
+      endif
+
+      select case(uppercase(action))
+      case('FIRST')
+          back = .false.
+          every = .false.
+      case('LAST')
+          back = .true.
+          every = .false.
+      case('ALL')
+          back = .false.
+          every = .true.
+      case default
+          back = .false.
+          every = .false.
+      end select
+
+      nr = 0
+      if (back) then
+          ipos = ls
+          do while (ipos > 0)
+              ipos = index(s(:ipos),target,back)
+              if (ipos == 0) exit
+              nr = nr + 1
+              if (.not. every) exit
+              ipos = ipos - 1
+          enddo
+      else
+          ipos = 1
+          do while (ipos <= ls-lt+1)
+              l = index(s(ipos:),target)
+              if (l == 0) exit
+              nr = nr + 1
+              if (.not. every) exit
+              ipos = ipos + l + 1
+              ipos = ipos + 1
+          enddo
+      endif
+      l = ls + nr*(lss-lt)
+
+      end function lr_ccc
+
+!*******************************************************************************
+
+      function replace_ccc(s,target,ss) result(r)
+
+      implicit none
+      character(*), intent(in)                :: s,target,ss
+      character(lr_ccc(s,target,ss,'first'))  :: r
+
+
+      call x_replace_ccc(s,target,ss,'first',r)
+
+      end function replace_ccc
+
+!*******************************************************************************
+
+      function replace_ccc_f(s,target,ss,action) result(r)
+
+      implicit none
+      character(*), intent(in)               :: s,target,ss,action
+      character(lr_ccc(s,target,ss,action))  :: r
+
+
+      call x_replace_ccc(s,target,ss,action,r)
+
+      end function replace_ccc_f
+
+!*******************************************************************************
+!  Calculate the result string by the following actions:
+!  Search for occurences of TARGET in string S, and replaces these with
+!  substring SS.  If BACK present with value true search is backward otherwise
+!  search is done forward.  If EVERY present with value true all accurences
+!  of TARGET in S are replaced, otherwise only the first found is
+!  replaced.  If TARGET is not found the result is the same as S.
+
+      subroutine x_replace_ccc(s,target,ss,action,r)
+
+      implicit none
+      character(*), intent(in)               :: s,target,ss,action
+      character(*), intent(inout)            :: r
+      logical                                :: every,back
+      integer                                :: lr,ls,lt,lss
+      integer                                :: i1,i2,k1,k2,m1,m2
+
+
+      lr = len(r)
+      ls = len(s)
+      lt = len(target)
+      lss = len(ss)
+
+      if (lt == 0) then
+          if (ls == 0) then
+              r = ss
+          else
+              r = s
+          endif
+          return
+      endif
+
+      select case(uppercase(action))
+      case('FIRST')
+          back = .false.
+          every = .false.
+      case('LAST')
+          back = .true.
+          every = .false.
+      case('ALL')
+          back = .false.
+          every = .true.
+      case default
+          back = .false.
+          every = .false.
+      end select
+
+      if (back) then
+          k2 = ls
+          m2 = lr
+          do
+              i1 = index(s(:k2),target,back)
+              if (i1 == 0) then
+                  r(:m2) = s(:k2)
+                  return
+              endif
+              i2 = i1 + lt - 1
+              k1 = i2 + 1
+              m1 = m2 + k1 - k2
+              r(m1:m2) = s(k1:k2)
+              m2 = m1 - 1
+              m1 = m2 - lss + 1
+              r(m1:m2) = ss
+              k2 = i1 - 1
+              m2 = m1 - 1
+              if (.not. every) then
+                  r(:m2) = s(:k2)
+                  return
+              endif
+          enddo
+      else
+          k1 = 1
+          m1 = 1
+          do
+              i1 = index(s(k1:),target)
+              if (i1 == 0) then
+                  r(m1:) = s(k1:)
+                  return
+              endif
+              i1 = k1 + (i1 - 1)
+              i2 = i1 + lt - 1
+              k2 = i1 - 1
+              m2 = m1 + k2 - k1
+              r(m1:m2) = s(k1:k2)
+              m1 = m2 + 1
+              m2 = m1 + lss - 1
+              r(m1:m2) = ss
+              k1 = i2 + 1
+              m1 = m2 + 1
+              if (.not. every) then
+                  r(m1:) = s(k1:)
+                  return
+              endif
+          enddo
+      endif
+
+      end subroutine x_replace_ccc
+
+!*******************************************************************************
+
+      function replace_csc(s,target,ss) result(r)
+
+      implicit none
+      character(*), intent(in)                      :: s,ss
+      type(string), intent(in)                      :: target
+      character(lr_ccc(s,char(target),ss,'first'))  :: r
+
+
+      call x_replace_ccc(s,char(target),ss,'first',r)
+
+      end function replace_csc
+
+!*******************************************************************************
+
+      function replace_csc_f(s,target,ss,action) result(r)
+
+      implicit none
+      character(*), intent(in)                     :: s,ss,action
+      type(string), intent(in)                     :: target
+      character(lr_ccc(s,char(target),ss,action))  :: r
+
+
+      call x_replace_ccc(s,char(target),ss,action,r)
+
+      end function replace_csc_f
+
+!*******************************************************************************
+!*******************************************************************************
+
+      function replace_ccs(s,target,ss) result(r)
+
+      implicit none
+      character(*), intent(in)                      :: s,target
+      type(string), intent(in)                      :: ss
+      character(lr_ccc(s,target,char(ss),'first'))  :: r
+
+
+      call x_replace_ccc(s,target,char(ss),'first',r)
+
+      end function replace_ccs
+
+!*******************************************************************************
+
+      function replace_ccs_f(s,target,ss,action) result(r)
+
+      implicit none
+      character(*), intent(in)                     :: s,target,action
+      type(string), intent(in)                     :: ss
+      character(lr_ccc(s,target,char(ss),action))  :: r
+
+
+      call x_replace_ccc(s,target,char(ss),action,r)
+
+      end function replace_ccs_f
+
+!*******************************************************************************
+!*******************************************************************************
+
+      function replace_css(s,target,ss) result(r)
+
+      implicit none
+      character(*), intent(in)                            :: s
+      type(string), intent(in)                            :: ss,target
+      character(lr_ccc(s,char(target),char(ss),'first'))  :: r
+
+
+      call x_replace_ccc(s,char(target),char(ss),'first',r)
+
+      end function replace_css
+
+!*******************************************************************************
+
+      function replace_css_f(s,target,ss,action) result(r)
+
+      implicit none
+      character(*), intent(in)                           :: s,action
+      type(string), intent(in)                           :: ss,target
+      character(lr_ccc(s,char(target),char(ss),action))  :: r
+
+
+      call x_replace_ccc(s,char(target),char(ss),action,r)
+
+      end function replace_css_f
+
+!*******************************************************************************
+!*******************************************************************************
+      pure function lr_scc(s,target,ss,action) result(l)
+
+      implicit none
+      type(string), intent(in)       :: s
+      character(*), intent(in)       :: target,ss,action
+      integer                        :: l
+      logical                        :: every,back
+      integer                        :: ls,lt,lss,ipos,nr
+
+
+      ls = len(s)
+      lt = len(target)
+      lss = len(ss)
+
+      if (lt == 0) then
+          if (ls == 0) then
+              l = lss
+          else
+              l = ls
+          endif
+          return
+      endif
+      if (lt == lss) then
+          l = ls
+          return
+      endif
+
+      select case(uppercase(action))
+      case('FIRST')
+          back = .false.
+          every = .false.
+      case('LAST')
+          back = .true.
+          every = .false.
+      case('ALL')
+          back = .false.
+          every = .true.
+      case default
+          back = .false.
+          every = .false.
+      end select
+
+      nr = 0
+      if (back) then
+          ipos = ls
+          do while (ipos > 0)
+              ipos = aindex(s%chars(:ipos),target,back)
+              if (ipos == 0) exit
+              nr = nr + 1
+              if (.not. every) exit
+              ipos = ipos - 1
+          enddo
+
+      else
+          ipos = 1
+          do while (ipos <= ls-lt+1)
+              l = aindex(s%chars(ipos:),target)
+              if (l == 0) exit
+              nr = nr + 1
+              if (.not. every) exit
+              ipos = ipos + l + 1
+          enddo
+      endif
+      l = ls + nr*(lss-lt)
+
+      end function lr_scc
+
+!*******************************************************************************
+
+      function replace_scc(s,target,ss) result(r)
+
+      implicit none
+      type(string), intent(in)                :: s
+      character(*), intent(in)                :: target,ss
+      character(lr_scc(s,target,ss,'first'))  :: r
+
+
+      call x_replace_scc(s,target,ss,'first',r)
+
+
+      end function replace_scc
+
+!*******************************************************************************
+
+      function replace_scc_f(s,target,ss,action) result(r)
+
+      implicit none
+      type(string), intent(in)               :: s
+      character(*), intent(in)               :: target,ss,action
+      character(lr_scc(s,target,ss,action))  :: r
+
+
+      call x_replace_scc(s,target,ss,action,r)
+
+      end function replace_scc_f
+
+!*******************************************************************************
+!  Calculate the result string by the following actions:
+!  Search for occurences of TARGET in string S, and replaces these with
+!  substring SS.  If BACK present with value true search is backward otherwise
+!  search is done forward.  If EVERY present with value true all accurences
+!  of TARGET in S are replaced, otherwise only the first found is
+!  replaced.  If TARGET is not found the result is the same as S.
+
+      subroutine x_replace_scc(s,target,ss,action,r)
+
+      implicit none
+      type(string), intent(in)               :: s
+      character(*), intent(in)               :: target,ss,action
+      character(*), intent(inout)            :: r
+      logical                                :: every,back
+      integer                                :: lr,ls,lt,lss
+      integer                                :: i1,i2,k1,k2,m1,m2
+
+
+      lr = len(r)
+      ls = len(s)
+      lt = len(target)
+      lss = len(ss)
+
+      if (lt == 0) then
+          if (ls == 0) then
+              r = ss
+          else
+              r = s
+          endif
+          return
+      endif
+
+      select case(uppercase(action))
+      case('FIRST')
+          back = .false.
+          every = .false.
+      case('LAST')
+          back = .true.
+          every = .false.
+      case('ALL')
+          back = .false.
+          every = .true.
+      case default
+          back = .false.
+          every = .false.
+      end select
+
+      if (back) then
+          k2 = ls
+          m2 = lr
+          do
+              i1 = aindex(s%chars(:k2),target,back)
+              if (i1 == 0) then
+                  r(:m2) = transfer(s%chars(:k2),r(:m2))
+                  return
+              endif
+              i2 = i1 + lt - 1
+              k1 = i2 + 1
+              m1 = m2 + k1 - k2
+              r(m1:m2) = transfer(s%chars(k1:k2),r(m1:m2))
+              m2 = m1 - 1
+              m1 = m2 - lss + 1
+              r(m1:m2) = ss
+              k2 = i1 - 1
+              m2 = m1 - 1
+              if (.not.every) then
+                  r(:m2) = transfer(s%chars(:k2),r(:m2))
+                  return
+              endif
+          enddo
+      else
+          k1 = 1
+          m1 = 1
+          do
+              i1 = aindex(s%chars(k1:),target)
+              if (i1 == 0) then
+                  r(m1:) = transfer(s%chars(k1:),r(m1:))
+                  return
+              endif
+              i1 = k1 + (i1 - 1)
+              i2 = i1 + lt - 1
+              k2 = i1 - 1
+              m2 = m1 + k2 - k1
+              r(m1:m2) = transfer(s%chars(k1:k2),r(m1:m2))
+              m1 = m2 + 1
+              m2 = m1 + lss - 1
+              r(m1:m2) = ss
+              k1 = i2 + 1
+              m1 = m2 + 1
+              if (.not.every) then
+                  r(m1:) = transfer(s%chars(k1:),r(m1:))
+                  return
+              endif
+          enddo
+      endif
+
+      end subroutine x_replace_scc
+
+!*******************************************************************************
+
+      function replace_ssc(s,target,ss) result(r)
+
+      implicit none
+      type(string), intent(in)                      :: s,target
+      character(*), intent(in)                      :: ss
+      character(lr_scc(s,char(target),ss,'first'))  :: r
+
+
+      call x_replace_scc(s,char(target),ss,'first',r)
+
+
+      end function replace_ssc
+
+!*******************************************************************************
+
+      function replace_ssc_f(s,target,ss,action) result(r)
+
+      implicit none
+      type(string), intent(in)                     :: s,target
+      character(*), intent(in)                     :: ss,action
+      character(lr_scc(s,char(target),ss,action))  :: r
+
+
+      call x_replace_scc(s,char(target),ss,action,r)
+
+      end function replace_ssc_f
+
+!*******************************************************************************
+
+      function replace_scs(s,target,ss) result(r)
+
+      implicit none
+      type(string), intent(in)                      :: s,ss
+      character(*), intent(in)                      :: target
+      character(lr_scc(s,target,char(ss),'first'))  :: r
+
+
+      call x_replace_scc(s,target,char(ss),'first',r)
+
+      end function replace_scs
+
+!*******************************************************************************
+
+      function replace_scs_f(s,target,ss,action) result(r)
+
+      implicit none
+      type(string), intent(in)                     :: s,ss
+      character(*), intent(in)                     :: target,action
+      character(lr_scc(s,target,char(ss),action))  :: r
+
+
+      call x_replace_scc(s,target,char(ss),action,r)
+
+      end function replace_scs_f
+
+!*******************************************************************************
+
+      function replace_sss(s,target,ss) result(r)
+
+      implicit none
+      type(string), intent(in)                            :: s,ss,target
+      character(lr_scc(s,char(target),char(ss),'first'))  :: r
+
+
+      call x_replace_scc(s,char(target),char(ss),'first',r)
+
+      end function replace_sss
+
+!*******************************************************************************
+
+      function replace_sss_f(s,target,ss,action) result(r)
+
+      implicit none
+      type(string), intent(in)                           :: s,ss,target
+      character(*), intent(in)                           :: action
+      character(lr_scc(s,char(target),char(ss),action))  :: r
+
+
+      call x_replace_scc(s,char(target),char(ss),action,r)
+
+      end function replace_sss_f
+
+!*******************************************************************************
+!     SORT, LSORT
+!*******************************************************************************
+!*******************************************************************************
+! Sorts A into ascending order, from A(1) to A(N).
+! Reference: Richard C. Singleton, Algorithm 347, SORT.
+! Comm. ACM 3, 321 (March 1969).
+! Algorithm is Copyright 1969 Association of Computing Machinery,
+!*******************************************************************************
+
+      subroutine sort_c(a)
+
+      implicit none
+      character(*), intent(inout)  :: a(:)
+      character(len(a))            :: t,s
+      integer                      :: p,i,j,k,l,m
+      integer                      :: is(0:63)
+
+
+      m = 0
+      i = 1
+      j = size(a)
+
+    5 continue
+      if (i >= j) goto 70
+
+   10 continue
+      p = (i + j)/2
+      t = a(p)
+      if (a(i) > t) then
+          a(p) = a(i)
+          a(i) = t
+          t = a(p)
+      endif
+      if (a(j) < t) then
+          a(p) = a(j)
+          a(j) = t
+          t = a(p)
+          if (a(i) > t) then
+              a(p) = a(i)
+              a(i) = t
+              t = a(p)
+          endif
+      endif
+
+      k = i
+      l = j
+      do
+          do
+              l = l - 1
+              if (a(l) <= t) exit
+          enddo
+          s = a(l)
+          do
+              k = k + 1
+              if (a(k) >= t) exit
+          enddo
+          if (k > l) exit
+          a(l) = a(k)
+          a(k) = s
+      enddo
+
+      if (l-i > j-k) then
+          is(m) = i
+          m = m + 1
+          is(m) = l
+          m = m + 1
+          i = k
+      else
+          is(m) = k
+          m = m + 1
+          is(m) = j
+          m = m + 1
+          j = l
+      endif
+      goto 80
+
+   70 continue
+      if (m == 0) return
+      m = m - 1
+      j = is(m)
+      m = m - 1
+      i = is(m)
+
+   80 continue
+      if (j-i >= 11) goto 10
+      if (i == 1) goto 5
+      i = i - 1
+
+      do
+          i = i + 1
+          if (i == j) goto 70
+          t = a(i+1)
+          if (a(i) <= t) cycle
+          k = i
+          do
+              a(k+1) = a(k)
+              k = k - 1
+              if (t >= a(k)) exit
+          enddo
+          a(k+1) = t
+      enddo
+
+      end subroutine sort_c
+
+!*******************************************************************************
+! Sorts A into ascending order, from A(1) to A(N).
+! Reference: Richard C. Singleton, Algorithm 347, SORT.
+! Comm. ACM 3, 321 (March 1969).
+! Algorithm is Copyright 1969 Association of Computing Machinery,
+!*******************************************************************************
+
+      subroutine sort_s(a)
+
+      implicit none
+      type(string), intent(inout)  :: a(:)
+      type(string)                 :: s,t
+      integer                      :: p,i,j,k,l,m
+      integer                      :: is(0:63)
+
+
+      m = 0
+      i = 1
+      j = size(a)
+
+    5 continue
+      if (i >= j) goto 70
+
+   10 continue
+      p = (i + j)/2
+      call pstring(t,a(p))
+      if (a(i) > t) then
+          call pstring(a(p),a(i))
+          call pstring(a(i),t)
+          call pstring(t,a(p))
+      endif
+      if (a(j) < t) then
+          call pstring(a(p),a(j))
+          call pstring(a(j),t)
+          call pstring(t,a(p))
+          if (a(i) > t) then
+              call pstring(a(p),a(i))
+              call pstring(a(i),t)
+              call pstring(t,a(p))
+          endif
+      endif
+
+      k = i
+      l = j
+      do
+          do
+              l = l - 1
+              if (a(l) <= t) exit
+          enddo
+          call pstring(s,a(l))
+          do
+              k = k + 1
+              if (a(k) >= t) exit
+          enddo
+          if (k > l) exit
+          call pstring(a(l),a(k))
+          call pstring(a(k),s)
+      enddo
+
+      if (l-i > j-k) then
+          is(m) = i
+          m = m + 1
+          is(m) = l
+          m = m + 1
+          i = k
+      else
+          is(m) = k
+          m = m + 1
+          is(m) = j
+          m = m + 1
+          j = l
+      endif
+      goto 80
+
+   70 continue
+      if (m == 0) return
+      m = m - 1
+      j = is(m)
+      m = m - 1
+      i = is(m)
+
+   80 continue
+      if (j-i >= 11) goto 10
+      if (i == 1) goto 5
+      i = i - 1
+
+      do
+          i = i + 1
+          if (i == j) goto 70
+          call pstring(t,a(i+1))
+          if (a(i) <= t) cycle
+          k = i
+          do
+              call pstring(a(k+1),a(k))
+              k = k - 1
+              if (t >= a(k)) exit
+          enddo
+          call pstring(a(k+1),t)
+      enddo
+
+      contains
+
+!-------------------------------------------------------------------------------
+      subroutine pstring(p,t)
+
+      implicit none
+      type(string), intent(inout)  :: p
+      type(string), intent(in)     :: t
+
+
+      p%len = t%len
+      p%size = t%size
+      p%chars => t%chars
+
+
+      end subroutine pstring
+!-------------------------------------------------------------------------------
+
+      end subroutine sort_s
+
+!*******************************************************************************
+! Sorts A into ascending order, from A(1) to A(N).
+! Reference: Richard C. Singleton, Algorithm 347, SORT.
+! Comm. ACM 3, 321 (March 1969).
+! Algorithm is Copyright 1969 Association of Computing Machinery,
+! reproduced with permission.
+!*******************************************************************************
+
+      subroutine lsort_c(a)
+
+      implicit none
+      character(*), intent(inout)  :: a(:)
+      character(len(a))            :: t,s
+      integer                      :: p,i,j,k,l,m
+      integer                      :: is(0:63)
+
+
+      m = 0
+      i = 1
+      j = size(a)
+
+    5 continue
+      if (i >= j) goto 70
+
+   10 continue
+      p = (i + j)/2
+      t = a(p)
+      if (lgt(a(i),t)) then
+          a(p) = a(i)
+          a(i) = t
+          t = a(p)
+      endif
+      if (llt(a(j),t)) then
+          a(p) = a(j)
+          a(j) = t
+          t = a(p)
+          if (lgt(a(i),t)) then
+              a(p) = a(i)
+              a(i) = t
+              t = a(p)
+          endif
+      endif
+
+      k = i
+      l = j
+      do
+          do
+              l = l - 1
+              if (lle(a(l),t)) exit
+          enddo
+          s = a(l)
+          do
+              k = k + 1
+              if (lge(a(k),t)) exit
+          enddo
+          if (k > l) exit
+          a(l) = a(k)
+          a(k) = s
+      enddo
+
+      if (l-i > j-k) then
+          is(m) = i
+          m = m + 1
+          is(m) = l
+          m = m + 1
+          i = k
+      else
+          is(m) = k
+          m = m + 1
+          is(m) = j
+          m = m + 1
+          j = l
+      endif
+      goto 80
+
+   70 continue
+      if (m == 0) return
+      m = m - 1
+      j = is(m)
+      m = m - 1
+      i = is(m)
+
+   80 continue
+      if (j-i >= 11) goto 10
+      if (i == 1) goto 5
+      i = i - 1
+
+      do
+          i = i + 1
+          if (i == j) goto 70
+          t = a(i+1)
+          if (lle(a(i),t)) cycle
+          k = i
+          do
+              a(k+1) = a(k)
+              k = k - 1
+              if (lge(t,a(k))) exit
+          enddo
+          a(k+1) = t
+      enddo
+
+      end subroutine lsort_c
+
+!*******************************************************************************
+! Sorts A into ascending order, from A(1) to A(N).
+! Reference: Richard C. Singleton, Algorithm 347, SORT.
+! Comm. ACM 3, 321 (March 1969).
+! Algorithm is Copyright 1969 Association of Computing Machinery,
+!*******************************************************************************
+
+      subroutine lsort_s(a)
+
+      implicit none
+      type(string), intent(inout)  :: a(:)
+      type(string)                 :: s,t
+      integer                      :: p,i,j,k,l,m
+      integer                      :: is(0:63)
+
+
+      m = 0
+      i = 1
+      j = size(a)
+
+    5 continue
+      if (i >= j) goto 70
+
+   10 continue
+      p = (i + j)/2
+      call pstring(t,a(p))
+      if (lgt(a(i),t)) then
+          call pstring(a(p),a(i))
+          call pstring(a(i),t)
+          call pstring(t,a(p))
+      endif
+      if (llt(a(j),t)) then
+          call pstring(a(p),a(j))
+          call pstring(a(j),t)
+          call pstring(t,a(p))
+          if (lgt(a(i),t)) then
+              call pstring(a(p),a(i))
+              call pstring(a(i),t)
+              call pstring(t,a(p))
+          endif
+      endif
+
+      k = i
+      l = j
+      do
+          do
+              l = l - 1
+              if (lle(a(l),t)) exit
+          enddo
+          call pstring(s,a(l))
+          do
+              k = k + 1
+              if (lge(a(k),t)) exit
+          enddo
+          if (k > l) exit
+          call pstring(a(l),a(k))
+          call pstring(a(k),s)
+      enddo
+
+      if (l-i > j-k) then
+          is(m) = i
+          m = m + 1
+          is(m) = l
+          m = m + 1
+          i = k
+      else
+          is(m) = k
+          m = m + 1
+          is(m) = j
+          m = m + 1
+          j = l
+      endif
+      goto 80
+
+   70 continue
+      if (m == 0) return
+      m = m - 1
+      j = is(m)
+      m = m - 1
+      i = is(m)
+
+   80 continue
+      if (j-i >= 11) goto 10
+      if (i == 1) goto 5
+      i = i - 1
+
+      do
+          i = i + 1
+          if (i == j) goto 70
+          call pstring(t,a(i+1))
+          if (lle(a(i),t)) cycle
+          k = i
+          do
+              call pstring(a(k+1),a(k))
+              k = k - 1
+              if (lge(t,a(k))) exit
+          enddo
+          call pstring(a(k+1),t)
+      enddo
+
+      contains
+
+!-------------------------------------------------------------------------------
+      subroutine pstring(p,t)
+
+      implicit none
+      type(string), intent(inout)  :: p
+      type(string), intent(in)     :: t
+
+
+      p%len = t%len
+      p%size = t%size
+      p%chars => t%chars
+
+
+      end subroutine pstring
+!-------------------------------------------------------------------------------
+
+      end subroutine lsort_s
+
+!*******************************************************************************
+!     RANK, LRANK
+!*******************************************************************************
+!*******************************************************************************
+! Sorts A into ascending order, from A(1) to A(N).
+! Reference: Richard C. Singleton, Algorithm 347, SORT.
+! Comm. ACM 3, 321 (March 1969).
+! Algorithm is Copyright 1969 Association of Computing Machinery,
+! reproduced with permission.
+!*******************************************************************************
+
+      subroutine rank_c(a,r)
+
+      implicit none
+      character(*), intent(in)  :: a(:)
+      integer, intent(out)      :: r(size(a))
+      character(len(a))         :: t
+      integer                   :: i,j,k,l,m,n,p,rs,rt
+      integer                   :: is(0:63)
+
+
+      n = size(a)
+      r(:) = (/ (i, i=1,n) /)
+      m = 0
+      i = 1
+      j = n
+
+    5 continue
+      if (i >= j) goto 70
+
+   10 continue
+      p = (j+i)/2
+      rt = r(p)
+      t = a(rt)
+      if (a(r(i)) > t) then
+          r(p) = r(i)
+          r(i) = rt
+          rt = r(p)
+          t = a(rt)
+      endif
+      if (a(r(j)) < t) then
+          r(p) = r(j)
+          r(j) = rt
+          rt = r(p)
+          t = a(rt)
+          if (a(r(i)) > t) then
+              r(p) = r(i)
+              r(i) = rt
+              rt = r(p)
+              t = a(rt)
+          endif
+      endif
+
+      k = i
+      l = j
+      do
+          do
+              l = l - 1
+              if (a(r(l)) <= t) exit
+          enddo
+          rs = r(l)
+          do
+              k = k + 1
+              if (a(r(k)) >= t) exit
+          enddo
+          if (k > l) exit
+          r(l) = r(k)
+          r(k) = rs
+      enddo
+
+      if (l-i > j-k) then
+          is(m) = i
+          m = m + 1
+          is(m) = l
+          m = m + 1
+          i = k
+      else
+          is(m) = k
+          m = m + 1
+          is(m) = j
+          m = m + 1
+          j = l
+      endif
+      goto 80
+
+   70 continue
+      if (m == 0) return
+      m = m - 1
+      j = is(m)
+      m = m - 1
+      i = is(m)
+
+   80 continue
+      if (j-i >= 11) goto 10
+      if (i == 1) goto 5
+      i = i - 1
+
+      do
+          i = i + 1
+          if (i == j) goto 70
+          rt = r(i+1)
+          t = a(rt)
+          if (a(r(i)) <= t) cycle
+          k = i
+          do
+              r(k+1) = r(k)
+              k = k - 1
+              if (t >= a(r(k))) exit
+          enddo
+          r(k+1) = rt
+      enddo
+
+      end subroutine rank_c
+
+!*******************************************************************************
+! Sorts A into ascending order, from A(1) to A(N).
+! Reference: Richard C. Singleton, Algorithm 347, SORT.
+! Comm. ACM 3, 321 (March 1969).
+! Algorithm is Copyright 1969 Association of Computing Machinery,
+!*******************************************************************************
+
+      subroutine rank_s(a,r)
+
+      implicit none
+      type(string), intent(in)  :: a(:)
+      integer, intent(out)      :: r(size(a))
+      type(string)              :: t
+      integer                   :: i,j,k,l,m,n,p,rs,rt
+      integer                   :: is(0:63)
+
+
+      n = size(a)
+      r(:) = (/ (i, i=1,n) /)
+      m = 0
+      i = 1
+      j = n
+
+    5 continue
+      if (i >= j) goto 70
+
+   10 continue
+      p = (j+i)/2
+      rt = r(p)
+      call pstring(t,a(rt))
+      if (a(r(i)) > t) then
+          r(p) = r(i)
+          r(i) = rt
+          rt = r(p)
+          call pstring(t,a(rt))
+      endif
+      if (a(r(j)) < t) then
+          r(p) = r(j)
+          r(j) = rt
+          rt = r(p)
+          call pstring(t,a(rt))
+          if (a(r(i)) > t) then
+              r(p) = r(i)
+              r(i) = rt
+              rt = r(p)
+              call pstring(t,a(rt))
+          endif
+      endif
+
+      k = i
+      l = j
+      do
+          do
+              l = l - 1
+              if (a(r(l)) <= t) exit
+          enddo
+          rs = r(l)
+          do
+              k = k + 1
+              if (a(r(k)) >= t) exit
+          enddo
+          if (k > l) exit
+          r(l) = r(k)
+          r(k) = rs
+      enddo
+
+      if (l-i > j-k) then
+          is(m) = i
+          m = m + 1
+          is(m) = l
+          m = m + 1
+          i = k
+      else
+          is(m) = k
+          m = m + 1
+          is(m) = j
+          m = m + 1
+          j = l
+      endif
+      goto 80
+
+   70 continue
+      if (m == 0) return
+      m = m - 1
+      j = is(m)
+      m = m - 1
+      i = is(m)
+
+   80 continue
+      if (j-i >= 11) goto 10
+      if (i == 1) goto 5
+      i = i - 1
+
+      do
+          i = i + 1
+          if (i == j) goto 70
+          rt = r(i+1)
+          call pstring(t,a(rt))
+          if (a(r(i)) <= t) cycle
+          k = i
+          do
+              r(k+1) = r(k)
+              k = k - 1
+              if (t >= a(r(k))) exit
+          enddo
+          r(k+1) = rt
+      enddo
+
+      contains
+
+!-------------------------------------------------------------------------------
+      subroutine pstring(p,t)
+
+      implicit none
+      type(string), intent(inout)  :: p
+      type(string), intent(in)     :: t
+
+
+      p%len = t%len
+      p%size = t%size
+      p%chars => t%chars
+
+
+      end subroutine pstring
+!-------------------------------------------------------------------------------
+
+      end subroutine rank_s
+
+!*******************************************************************************
+! Sorts A into ascending order, from A(1) to A(N).
+! Reference: Richard C. Singleton, Algorithm 347, SORT.
+! Comm. ACM 3, 321 (March 1969).
+! Algorithm is Copyright 1969 Association of Computing Machinery,
+!*******************************************************************************
+
+      subroutine lrank_c(a,r)
+
+      implicit none
+      character(*), intent(in)  :: a(:)
+      integer, intent(out)      :: r(size(a))
+      character(len(a))         :: t
+      integer                   :: i,j,k,l,m,n,p,rs,rt
+      integer                   :: is(0:63)
+
+
+      n = size(a)
+      r(:) = (/ (i, i=1,n) /)
+      m = 0
+      i = 1
+      j = n
+
+    5 continue
+      if (i >= j) goto 70
+
+   10 continue
+      p = (j+i)/2
+      rt = r(p)
+      t = a(rt)
+      if (lgt(a(r(i)),t)) then
+          r(p) = r(i)
+          r(i) = rt
+          rt = r(p)
+          t = a(rt)
+      endif
+      if (llt(a(r(j)),t)) then
+          r(p) = r(j)
+          r(j) = rt
+          rt = r(p)
+          t = a(rt)
+          if (llt(a(r(i)),t)) then
+              r(p) = r(i)
+              r(i) = rt
+              rt = r(p)
+              t = a(rt)
+          endif
+      endif
+
+      k = i
+      l = j
+      do
+          do
+              l = l - 1
+              if (lle(a(r(l)),t)) exit
+          enddo
+          rs = r(l)
+          do
+              k = k + 1
+              if (lge(a(r(k)),t)) exit
+          enddo
+          if (k > l) exit
+          r(l) = r(k)
+          r(k) = rs
+      enddo
+
+      if (l-i > j-k) then
+          is(m) = i
+          m = m + 1
+          is(m) = l
+          m = m + 1
+          i = k
+      else
+          is(m) = k
+          m = m + 1
+          is(m) = j
+          m = m + 1
+          j = l
+      endif
+      goto 80
+
+   70 continue
+      if (m == 0) return
+      m = m - 1
+      j = is(m)
+      m = m - 1
+      i = is(m)
+
+   80 continue
+      if (j-i >= 11) goto 10
+      if (i == 1) goto 5
+      i = i - 1
+
+      do
+          i = i + 1
+          if (i == j) goto 70
+          rt = r(i+1)
+          t = a(rt)
+          if (lle(a(r(i)),t)) cycle
+          k = i
+          do
+              r(k+1) = r(k)
+              k = k - 1
+              if (lge(t,a(r(k)))) exit
+          enddo
+          r(k+1) = rt
+      enddo
+
+      end subroutine lrank_c
+
+!*******************************************************************************
+! Sorts A into ascending order, from A(1) to A(N).
+! Reference: Richard C. Singleton, Algorithm 347, SORT.
+! Comm. ACM 3, 321 (March 1969).
+! Algorithm is Copyright 1969 Association of Computing Machinery,
+!*******************************************************************************
+
+      subroutine lrank_s(a,r)
+
+      implicit none
+      type(string), intent(in)  :: a(:)
+      integer, intent(out)      :: r(size(a))
+      type(string)              :: t
+      integer                   :: i,j,k,l,m,n,p,rs,rt
+      integer                   :: is(0:63)
+
+
+      n = size(a)
+      r(:) = (/ (i, i=1,n) /)
+      m = 0
+      i = 1
+      j = n
+
+    5 continue
+      if (i >= j) goto 70
+
+   10 continue
+      p = (j+i)/2
+      rt = r(p)
+      call pstring(t,a(rt))
+      if (lgt(a(r(i)),t)) then
+          r(p) = r(i)
+          r(i) = rt
+          rt = r(p)
+          call pstring(t,a(rt))
+      endif
+      if (llt(a(r(j)),t)) then
+          r(p) = r(j)
+          r(j) = rt
+          rt = r(p)
+          call pstring(t,a(rt))
+          if (lgt(a(r(i)),t)) then
+              r(p) = r(i)
+              r(i) = rt
+              rt = r(p)
+              call pstring(t,a(rt))
+          endif
+      endif
+
+      k = i
+      l = j
+      do
+          do
+              l = l - 1
+              if (lle(a(r(l)),t)) exit
+          enddo
+          rs = r(l)
+          do
+              k = k + 1
+              if (lge(a(r(k)),t)) exit
+          enddo
+          if (k > l) exit
+          r(l) = r(k)
+          r(k) = rs
+      enddo
+
+      if (l-i > j-k) then
+          is(m) = i
+          m = m + 1
+          is(m) = l
+          m = m + 1
+          i = k
+      else
+          is(m) = k
+          m = m + 1
+          is(m) = j
+          m = m + 1
+          j = l
+      endif
+      goto 80
+
+   70 continue
+      if (m == 0) return
+      m = m - 1
+      j = is(m)
+      m = m - 1
+      i = is(m)
+
+   80 continue
+      if (j-i >= 11) goto 10
+      if (i == 1) goto 5
+      i = i - 1
+
+      do
+          i = i + 1
+          if (i == j) goto 70
+          rt = r(i+1)
+          call pstring(t,a(rt))
+          if (lle(a(r(i)),t)) cycle
+          k = i
+          do
+              r(k+1) = r(k)
+              k = k - 1
+              if (lge(t,a(r(k)))) exit
+          enddo
+          r(k+1) = rt
+      enddo
+
+      contains
+
+!-------------------------------------------------------------------------------
+      subroutine pstring(p,t)
+
+      implicit none
+      type(string), intent(inout)  :: p
+      type(string), intent(in)     :: t
+
+
+      p%len = t%len
+      p%size = t%size
+      p%chars => t%chars
+
+
+      end subroutine pstring
+!-------------------------------------------------------------------------------
+
+      end subroutine lrank_s
+
+!*******************************************************************************
+!     COMPARE, LCOMPARE, ACOMPARE, ALCOMPARE
+!*******************************************************************************
+!*******************************************************************************
+
+      elemental function compare_ss(s1,s2) result(css)
+
+      implicit none
+      type(string), intent(in)  :: s1,s2
+      character(2)              :: css
+      integer                   :: i,l1,l2
+
+
+      l1 = len(s1)
+      l2 = len(s2)
+      do i=1,min(l1,l2)
+          if (s1%chars(i) < s2%chars(i)) then
+              css = 'LT'
+              return
+          elseif (s1%chars(i) > s2%chars(i)) then
+              css = 'GT'
+              return
+          endif
+      enddo
+      if (l1 < l2) then
+          do i=l1+1,l2
+              if (blank < s2%chars(i)) then
+                  css = 'LT'
+                  return
+              elseif (blank > s2%chars(i)) then
+                  css = 'GT'
+                  return
+              endif
+          enddo
+      elseif (l1 > l2) then
+          do i=l2+1,l1
+              if (s1%chars(i) < blank) then
+                  css = 'LT'
+                  return
+              elseif (s1%chars(i) > blank) then
+                  css = 'GT'
+                  return
+              endif
+          enddo
+      endif
+      css = 'EQ'
+
+      end function compare_ss
+
+!*******************************************************************************
+
+      elemental function compare_cs(c,s) result(css)
+
+      implicit none
+      character(*), intent(in)  :: c
+      type(string), intent(in)  :: s
+      character(2)              :: css
+      integer                   :: i,lc,ls
+
+
+      lc = len(c)
+      ls = len(s)
+      do i=1,min(lc,ls)
+          if (c(i:i) < s%chars(i)) then
+              css = 'LT'
+              return
+          elseif (c(i:i) > s%chars(i)) then
+              css = 'GT'
+              return
+          endif
+      enddo
+      if (lc < ls) then
+          do i=lc+1,ls
+              if (blank < s%chars(i)) then
+                  css = 'LT'
+                  return
+              elseif (blank > s%chars(i)) then
+                  css = 'GT'
+                  return
+              endif
+          enddo
+      elseif (lc > ls) then
+          do i=ls+1,lc
+              if (c(i:i) < blank) then
+                  css = 'LT'
+                  return
+              elseif (c(i:i) > blank) then
+                  css = 'GT'
+                  return
+              endif
+          enddo
+      endif
+      css = 'EQ'
+
+      end function compare_cs
+
+!*******************************************************************************
+!     ==
+!*******************************************************************************
+! string == string
+
+      elemental function s_eq_s(s1,s2)
+
+      implicit none
+      type(string), intent(in)  :: s1,s2
+      logical                   :: s_eq_s
+      integer                   :: l1,l2
+
+
+      l1 = len(s1)
+      l2 = len(s2)
+      if (l1 > l2) then
+          s_eq_s = all(s1%chars(1:l2) == s2%chars) .and.  &
+                   all(s1%chars(l2+1:l1) == blank)
+      elseif (l1 < l2) then
+          s_eq_s = all(s1%chars == s2%chars(1:l1)) .and.  &
+                   all(blank == s2%chars(l1+1:l2))
+      else
+          s_eq_s = all(s1%chars == s2%chars)
+      endif
+
+      end function s_eq_s
+
+!*******************************************************************************
+! string == character
+
+      elemental function s_eq_c(s,c)
+
+      implicit none
+      type(string), intent(in)  :: s
+      character(*), intent(in)  :: c
+      logical                   :: s_eq_c
+      integer                   :: i,ls,lc
+
+
+      ls = len(s)
+      lc = len(c)
+      do i=1,min(ls,lc)
+          if (s%chars(i) /= c(i:i)) then
+              s_eq_c = .false.
+              return
+          endif
+      enddo
+      if ((ls > lc) .and. any(s%chars(lc+1:ls) /= blank)) then
+          s_eq_c = .false.
+      elseif ((ls < lc) .and. (blank /= c(ls+1:lc))) then
+          s_eq_c = .false.
+      else
+          s_eq_c = .true.
+      endif
+
+      end function s_eq_c
+
+!*******************************************************************************
+! character == string
+
+      elemental function c_eq_s(c,s)
+
+      implicit none
+      character(*), intent(in)  :: c
+      type(string), intent(in)  :: s
+      logical                   :: c_eq_s
+      integer                   :: i,lc,ls
+
+
+      lc = len(c)
+      ls = len(s)
+      do i=1,min(lc,ls)
+          if (c(i:i) /= s%chars(i)) then
+              c_eq_s = .false.
+              return
+          endif
+      enddo
+      if ((lc > ls) .and. (c(ls+1:lc) /= blank)) then
+          c_eq_s = .false.
+      elseif ((lc < ls) .and. any(blank /= s%chars(lc+1:ls) ) )then
+          c_eq_s = .false.
+      else
+          c_eq_s = .true.
+      endif
+
+      end function c_eq_s
+
+!*******************************************************************************
+!     /=
+!*******************************************************************************
+! string /= string
+
+      elemental function s_ne_s(s1,s2)
+
+      implicit none
+      type(string), intent(in)  :: s1,s2
+      logical                   :: s_ne_s
+      integer                   :: l1,l2
+
+
+      l1 = len(s1)
+      l2 = len(s2)
+      if (l1 > l2) then
+          s_ne_s = any(s1%chars(1:l2) /= s2%chars) .or.  &
+                   any(s1%chars(l2+1:l1) /= blank)
+      elseif (l1 < l2) then
+          s_ne_s = any(s1%chars /= s2%chars(1:l1)) .or. &
+                   any(blank /= s2%chars(l1+1:l2))
+      else
+          s_ne_s = any(s1%chars /= s2%chars)
+      endif
+
+      end function s_ne_s
+
+!*******************************************************************************
+! string /= character
+
+      elemental function s_ne_c(s,c)
+
+      implicit none
+      type(string), intent(in)  :: s
+      character(*), intent(in)  :: c
+      logical                   :: s_ne_c
+      integer                   :: i,ls,lc
+
+
+      ls = len(s)
+      lc = len(c)
+      do i=1,min(ls,lc)
+          if (s%chars(i) /= c(i:i) )then
+              s_ne_c = .true.
+              return
+          endif
+      enddo
+      if ((ls > lc) .and. any(s%chars(ls+1:lc) /= blank)) then
+          s_ne_c = .true.
+      elseif ((ls < lc) .and. blank /= c(ls+1:lc)) then
+          s_ne_c = .true.
+      else
+          s_ne_c = .false.
+      endif
+
+      end function s_ne_c
+
+!*******************************************************************************
+! character /= string
+
+      elemental function c_ne_s(c,s)
+
+      implicit none
+      character(*), intent(in)  :: c
+      type(string), intent(in)  :: s
+      logical                   :: c_ne_s
+      integer                   :: i,lc,ls
+
+
+      lc = len(c)
+      ls = len(s)
+      do i=1,min(lc,ls)
+          if (c(i:i) /= s%chars(i)) then
+              c_ne_s = .true.
+              return
+          endif
+      enddo
+      if ((lc > ls) .and. c(ls+1:lc) /= blank) then
+          c_ne_s = .true.
+      elseif ((lc < ls) .and. any(blank /= s%chars(lc+1:ls))) then
+          c_ne_s = .true.
+      else
+          c_ne_s = .false.
+      endif
+
+      end function c_ne_s
+
+!*******************************************************************************
+!     < operators
+!*******************************************************************************
+! string < string
+
+      elemental function s_lt_s(s1,s2)
+
+      implicit none
+      type(string), intent(in)  :: s1,s2
+      logical                   :: s_lt_s
+
+
+      s_lt_s = compare_ss(s1,s2) == 'LT'
+
+      end function s_lt_s
+
+!*******************************************************************************
+! string < character
+
+      elemental function s_lt_c(s,c)
+
+      implicit none
+      type(string), intent(in)  :: s
+      character(*), intent(in)  :: c
+      logical                   :: s_lt_c
+
+
+      s_lt_c = compare_cs(c,s) == 'GT'
+
+      end function s_lt_c
+
+!*******************************************************************************
+! character < string
+
+      elemental function c_lt_s(c,s)
+
+      implicit none
+      character(*), intent(in)  :: c
+      type(string), intent(in)  :: s
+      logical                   :: c_lt_s
+
+
+      c_lt_s = compare_cs(c,s) == 'LT'
+
+      end function c_lt_s
+
+!*******************************************************************************
+!     <=  operators
+!*******************************************************************************
+! string <= string
+
+      elemental function s_le_s(s1,s2)
+
+      implicit none
+      type(string), intent(in)  :: s1,s2
+      logical                   :: s_le_s
+
+
+      s_le_s = compare_ss(s1,s2) /= 'GT'
+
+      end function s_le_s
+
+!*******************************************************************************
+! string <= character
+
+      elemental function s_le_c(s,c)
+
+      implicit none
+      type(string), intent(in)  :: s
+      character(*), intent(in)  :: c
+      logical                   :: s_le_c
+
+
+      s_le_c = compare_cs(c,s) /= 'LT'
+
+      end function s_le_c
+
+!*******************************************************************************
+! character <= string
+
+      elemental function c_le_s(c,s)
+
+      implicit none
+      character(*), intent(in)  :: c
+      type(string), intent(in)  :: s
+      logical                   :: c_le_s
+
+
+      c_le_s = compare_cs(c,s) /= 'GT'
+
+      end function c_le_s
+
+!*******************************************************************************
+!     >=  operators
+!*******************************************************************************
+! string >= string
+
+      elemental function s_ge_s(s1,s2)
+
+      implicit none
+      type(string), intent(in) :: s1,s2
+      logical                  :: s_ge_s
+
+
+      s_ge_s = compare_ss(s1,s2) /= 'LT'
+
+      end function s_ge_s
+
+!*******************************************************************************
+! string >= character
+
+      elemental function s_ge_c(s,c)
+
+      implicit none
+      type(string), intent(in)  :: s
+      character(*), intent(in)  :: c
+      logical                   :: s_ge_c
+
+
+      s_ge_c = compare_cs(c,s) /= 'GT'
+
+      end function s_ge_c
+
+!*******************************************************************************
+! character >= string
+
+      elemental function c_ge_s(c,s)
+
+      implicit none
+      character(*), intent(in)  :: c
+      type(string), intent(in)  :: s
+      logical                   :: c_ge_s
+
+
+      c_ge_s = compare_cs(c,s) /= 'LT'
+
+      end function c_ge_s
+
+!*******************************************************************************
+!     >  operators
+!*******************************************************************************
+! string > string
+
+      elemental function s_gt_s(s1,s2)
+
+      implicit none
+      type(string), intent(in) :: s1,s2
+      logical                  :: s_gt_s
+
+
+      s_gt_s = compare_ss(s1,s2) == 'GT'
+
+      end function s_gt_s
+
+!*******************************************************************************
+! string > character
+
+      elemental function s_gt_c(s,c)
+
+      implicit none
+      type(string), intent(in)  :: s
+      character(*), intent(in)  :: c
+      logical                   :: s_gt_c
+
+
+      s_gt_c = compare_cs(c,s) == 'LT'
+
+      end function s_gt_c
+
+!*******************************************************************************
+! character > string
+
+      elemental function c_gt_s(c,s)
+
+      implicit none
+      character(*), intent(in)  :: c
+      type(string), intent(in)  :: s
+      logical                   :: c_gt_s
+
+
+      c_gt_s = compare_cs(c,s) == 'GT'
+
+      end function c_gt_s
+
+!*******************************************************************************
+
+      elemental function lcompare_ss(s1,s2) result(css)
+
+      implicit none
+      type(string), intent(in)  :: s1,s2
+      character(2)              :: css
+      integer                   :: i,l1,l2
+
+
+      l1 = len(s1)
+      l2 = len(s2)
+      do i=1,min(l1,l2)
+          if (llt(s1%chars(i),s2%chars(i))) then
+              css = 'LT'
+              return
+          elseif (lgt(s1%chars(i),s2%chars(i))) then
+              css = 'GT'
+              return
+          endif
+      enddo
+      if (l1 < l2) then
+          do i=l1+1,l2
+              if (llt(blank,s2%chars(i))) then
+                  css = 'LT'
+                  return
+              elseif (lgt(blank,s2%chars(i))) then
+                  css = 'GT'
+                  return
+              endif
+          enddo
+      elseif (l1 > l2) then
+          do i=l2+1,l1
+              if (llt(s1%chars(i),blank)) then
+                  css = 'LT'
+                  return
+              elseif (lgt(s1%chars(i),blank)) then
+                  css = 'GT'
+                  return
+              endif
+          enddo
+      endif
+      css = 'EQ'
+
+      end function lcompare_ss
+
+!*******************************************************************************
+
+      elemental function lcompare_cs(c,s) result(css)
+
+      implicit none
+      character(*), intent(in)  :: c
+      type(string), intent(in)  :: s
+      character(2)              :: css
+      integer                   :: i,lc,ls
+
+
+      lc = len(c)
+      ls = len(s)
+      do i=1,min(lc,ls)
+          if (llt(c(i:i),s%chars(i))) then
+              css = 'LT'
+              return
+          elseif (lgt(c(i:i),s%chars(i))) then
+              css = 'GT'
+              return
+          endif
+      enddo
+      if (lc < ls) then
+          do i=lc+1,ls
+              if (llt(blank,s%chars(i))) then
+                  css = 'LT'
+                  return
+              elseif (lgt(blank,s%chars(i))) then
+                  css = 'GT'
+                  return
+              endif
+          enddo
+      elseif (lc > ls) then
+          do i=ls+1,lc
+              if (llt(c(i:i),blank)) then
+                  css = 'LT'
+                  return
+              elseif (lgt(c(i:i),blank)) then
+                  css = 'GT'
+                  return
+              endif
+          enddo
+      endif
+      css = 'EQ'
+
+      end function lcompare_cs
+
+!*******************************************************************************
+!     LLT function
+!*******************************************************************************
+!     llt(string,string)
+
+      elemental function s_llt_s(s1,s2)
+
+      implicit none
+      type(string), intent(in)  :: s1,s2
+      logical                   :: s_llt_s
+
+      s_llt_s = (lcompare_ss(s1,s2) == 'LT')
+
+      end function s_llt_s
+
+!*******************************************************************************
+!     llt(string,character)
+
+      elemental function s_llt_c(s1,c2)
+
+      implicit none
+      type(string), intent(in)  :: s1
+      character(*), intent(in)  :: c2
+      logical                   :: s_llt_c
+
+      s_llt_c = (lcompare_cs(c2,s1) == 'GT')
+
+      end function s_llt_c
+
+!*******************************************************************************
+!     llt(character,string)
+
+      elemental function c_llt_s(c1,s2)
+
+      implicit none
+      type(string), intent(in)  :: s2
+      character(*), intent(in)  :: c1
+      logical                   :: c_llt_s
+
+      c_llt_s = (lcompare_cs(c1,s2) == 'LT')
+
+      end function c_llt_s
+
+!*******************************************************************************
+!     LGT function
+!*******************************************************************************
+!     lgt(string,string)
+
+      elemental function s_lgt_s(s1,s2)
+
+      implicit none
+      type(string), intent(in)  :: s1,s2
+      logical                   :: s_lgt_s
+
+      s_lgt_s = (lcompare_ss(s1,s2) == 'GT')
+
+      end function s_lgt_s
+
+!*******************************************************************************
+!     lgt(string,character)
+
+      elemental function s_lgt_c(s1,c2)
+
+      implicit none
+      type(string), intent(in)  :: s1
+      character(*), intent(in)  :: c2
+      logical                   :: s_lgt_c
+
+      s_lgt_c = (lcompare_cs(c2,s1) == 'LT')
+
+      end function s_lgt_c
+
+!*******************************************************************************
+!     lgt(character,string)
+
+      elemental function c_lgt_s(c1,s2)
+
+      implicit none
+      type(string), intent(in)  :: s2
+      character(*), intent(in)  :: c1
+      logical                   :: c_lgt_s
+
+      c_lgt_s = (lcompare_cs(c1,s2) == 'GT')
+
+      end function c_lgt_s
+
+!*******************************************************************************
+!     LGE function
+!*******************************************************************************
+!     lge(string,string)
+
+      elemental function s_lge_s(s1,s2)
+
+      implicit none
+      type(string), intent(in)  :: s1,s2
+      logical                   :: s_lge_s
+
+      s_lge_s = (lcompare_ss(s1,s2) /= 'LT')
+
+      end function s_lge_s
+
+!*******************************************************************************
+!     lge(string,character)
+
+      elemental function s_lge_c(s1,c2)
+
+      implicit none
+      type(string), intent(in)  :: s1
+      character(*), intent(in)  :: c2
+      logical                   :: s_lge_c
+
+      s_lge_c = (lcompare_cs(c2,s1) /= 'GT')
+
+      end function s_lge_c
+
+!*******************************************************************************
+!     lge(character,string)
+
+      elemental function c_lge_s(c1,s2)
+
+      implicit none
+      type(string), intent(in)  :: s2
+      character(*), intent(in)  :: c1
+      logical                   :: c_lge_s
+
+      c_lge_s = (lcompare_cs(c1,s2) /= 'LT')
+
+      end function c_lge_s
+
+!*******************************************************************************
+!     LLE function
+!*******************************************************************************
+!     lle(string,string)
+
+      elemental function s_lle_s(s1,s2)
+
+      implicit none
+      type(string), intent(in)  :: s1,s2
+      logical                   :: s_lle_s
+
+      s_lle_s = (lcompare_ss(s1,s2) /= 'GT')
+
+      end function s_lle_s
+
+!*******************************************************************************
+!     lle(string,character)
+
+      elemental function s_lle_c(s1,c2)
+
+      implicit none
+      type(string), intent(in)  :: s1
+      character(*), intent(in)  :: c2
+      logical                   :: s_lle_c
+
+      s_lle_c = (lcompare_cs(c2,s1) /= 'LT')
+
+      end function s_lle_c
+
+!*******************************************************************************
+!     lle(character,string)
+
+      elemental function c_lle_s(c1,s2)
+
+      implicit none
+      type(string), intent(in)  :: s2
+      character(*), intent(in)  :: c1
+      logical                   :: c_lle_s
+
+      c_lle_s = (lcompare_cs(c1,s2) /= 'GT')
+
+      end function c_lle_s
+
+!*******************************************************************************
+
+      pure function acompare_aa(a1,a2) result(caa)
+
+      implicit none
+      character, intent(in)  :: a1(:),a2(:)
+      character(2)           :: caa
+      integer                :: i,l1,l2
+
+
+      l1 = size(a1)
+      l2 = size(a2)
+      do i=1,min(l1,l2)
+          if (a1(i) < a2(i)) then
+              caa = 'LT'
+              return
+          elseif (a1(i) > a2(i)) then
+              caa = 'GT'
+              return
+          endif
+      enddo
+      if (l1 < l2) then
+          do i=l1+1,l2
+              if (blank < a2(i)) then
+                  caa = 'LT'
+                  return
+              elseif (blank > a2(i)) then
+                  caa = 'GT'
+                  return
+              endif
+          enddo
+      elseif (l1 > l2) then
+          do i=l2+1,l1
+              if (a1(i) < blank) then
+                  caa = 'LT'
+                  return
+              elseif (a1(i) > blank) then
+                  caa = 'GT'
+                  return
+              endif
+          enddo
+      endif
+      caa = 'EQ'
+
+      end function acompare_aa
+
+!*******************************************************************************
+
+      pure function acompare_ca(c,a) result(cca)
+
+      implicit none
+      character(*), intent(in)  :: c
+      character, intent(in)     :: a(:)
+      character(2)              :: cca
+      integer                   :: i,lc,la
+
+
+      lc = len(c)
+      la = size(a)
+      do i=1,min(lc,la)
+          if (c(i:i) < a(i)) then
+              cca = 'LT'
+              return
+          elseif (c(i:i) > a(i)) then
+              cca = 'GT'
+              return
+          endif
+      enddo
+      if (lc < la) then
+          do i=lc+1,la
+              if (blank < a(i)) then
+                  cca = 'LT'
+                  return
+              elseif (blank > a(i)) then
+                  cca = 'GT'
+                  return
+              endif
+          enddo
+      elseif (lc > la) then
+          do i=la+1,lc
+              if (c(i:i) < blank) then
+                  cca = 'LT'
+                  return
+              elseif (c(i:i) > blank) then
+                  cca = 'GT'
+                  return
+              endif
+          enddo
+      endif
+      cca = 'EQ'
+
+      end function acompare_ca
+
+!*******************************************************************************
+!     ==
+!*******************************************************************************
+! array == array
+
+      pure function a_eq_a(a1,a2)
+
+      implicit none
+      character, intent(in)  :: a1(:),a2(:)
+      logical                :: a_eq_a
+      integer                :: l1,l2
+
+
+      l1 = size(a1)
+      l2 = size(a2)
+      if (l1 > l2) then
+          a_eq_a = all(a1(1:l2) == a2) .and.  &
+                   all(a1(l2+1:l1) == blank)
+      elseif (l1 < l2) then
+          a_eq_a = all(a1 == a2(1:l1)) .and.  &
+                   all(blank == a2(l1+1:l2))
+      else
+          a_eq_a = all(a1 == a2)
+      endif
+
+      end function a_eq_a
+
+!*******************************************************************************
+! array == character
+
+      pure function a_eq_c(a,c)
+
+      implicit none
+      character, intent(in)     :: a(:)
+      character(*), intent(in)  :: c
+      logical                   :: a_eq_c
+      integer                   :: i,la,lc
+
+
+      la = len(a)
+      lc = len(c)
+      do i=1,min(la,lc)
+          if (a(i) /= c(i:i)) then
+              a_eq_c = .false.
+              return
+          endif
+      enddo
+      if ((la > lc) .and. any(a(lc+1:la) /= blank)) then
+          a_eq_c = .false.
+      elseif ((la < lc) .and. (blank /= c(la+1:lc))) then
+          a_eq_c = .false.
+      else
+          a_eq_c = .true.
+      endif
+
+      end function a_eq_c
+
+!*******************************************************************************
+! character == array
+
+      pure function c_eq_a(c,a)
+
+      implicit none
+      character(*), intent(in)  :: c
+      character, intent(in)     :: a(:)
+      logical                   :: c_eq_a
+
+
+      c_eq_a = a_eq_c(a,c)
+
+      end function c_eq_a
+
+!*******************************************************************************
+!     /=
+!*******************************************************************************
+! array /= array
+
+      pure function a_ne_a(a1,a2)
+
+      implicit none
+      character, intent(in)  :: a1(:),a2(:)
+      logical                :: a_ne_a
+      integer                :: l1,l2
+
+
+      l1 = size(a1)
+      l2 = size(a2)
+      if (l1 > l2) then
+          a_ne_a = any(a1(1:l2) /= a2) .or.  &
+                   any(a1(l2+1:l1) /= blank)
+      elseif (l1 < l2) then
+          a_ne_a = any(a1 /= a2(1:l1)) .or. &
+                   any(blank /= a2(l1+1:l2))
+      else
+          a_ne_a = any(a1 /= a2)
+      endif
+
+      end function a_ne_a
+
+!*******************************************************************************
+! array /= character
+
+      pure function a_ne_c(a,c)
+
+      implicit none
+      character, intent(in)     :: a(:)
+      character(*), intent(in)  :: c
+      logical                   :: a_ne_c
+      integer                   :: i,la,lc
+
+
+      la = size(a)
+      lc = len(c)
+      do i=1,min(la,lc)
+          if (a(i) /= c(i:i) )then
+              a_ne_c = .true.
+              return
+          endif
+      enddo
+      if ((la > lc) .and. any(a(la+1:lc) /= blank)) then
+          a_ne_c = .true.
+      elseif ((la < lc) .and. blank /= c(la+1:lc)) then
+          a_ne_c = .true.
+      else
+          a_ne_c = .false.
+      endif
+
+      end function a_ne_c
+
+!*******************************************************************************
+! character /= array
+
+      pure function c_ne_a(c,a)
+
+      implicit none
+      character(*), intent(in)  :: c
+      character, intent(in)     :: a(:)
+      logical                   :: c_ne_a
+
+
+      c_ne_a = acompare_ca(c,a) /= 'EQ'
+
+      end function c_ne_a
+
+!*******************************************************************************
+!     < operators
+!*******************************************************************************
+! array < array
+
+      pure function a_lt_a(a1,a2)
+
+      implicit none
+      character, intent(in)  :: a1(:),a2(:)
+      logical                :: a_lt_a
+
+
+      a_lt_a = acompare_aa(a1,a2) == 'LT'
+
+      end function a_lt_a
+
+!*******************************************************************************
+! array < character
+
+      pure function a_lt_c(a,c)
+
+      implicit none
+      character, intent(in)     :: a(:)
+      character(*), intent(in)  :: c
+      logical                   :: a_lt_c
+
+
+      a_lt_c = acompare_ca(c,a) == 'GT'
+
+      end function a_lt_c
+
+!*******************************************************************************
+! character < array
+
+      pure function c_lt_a(c,a)
+
+      implicit none
+      character(*), intent(in)  :: c
+      character, intent(in)     :: a(:)
+      logical                   :: c_lt_a
+
+
+      c_lt_a = acompare_ca(c,a) == 'LT'
+
+      end function c_lt_a
+
+!*******************************************************************************
+!     <=  operators
+!*******************************************************************************
+! array <= array
+
+      pure function a_le_a(a1,a2)
+
+      implicit none
+      character, intent(in)  :: a1(:),a2(:)
+      logical                :: a_le_a
+
+
+      a_le_a = acompare_aa(a1,a2) /= 'GT'
+
+      end function a_le_a
+
+!*******************************************************************************
+! array <= character
+
+      pure function a_le_c(a,c)
+
+      implicit none
+      character, intent(in)     :: a(:)
+      character(*), intent(in)  :: c
+      logical                   :: a_le_c
+
+
+      a_le_c = acompare_ca(c,a) /= 'LT'
+
+      end function a_le_c
+
+!*******************************************************************************
+! character <= array
+
+      pure function c_le_a(c,a)
+
+      implicit none
+      character(*), intent(in)  :: c
+      character, intent(in)     :: a(:)
+      logical                   :: c_le_a
+
+
+      c_le_a = acompare_ca(c,a) /= 'GT'
+
+      end function c_le_a
+
+!*******************************************************************************
+!     >=  operators
+!*******************************************************************************
+! array >= array
+
+      pure function a_ge_a(a1,a2)
+
+      implicit none
+      character, intent(in)  :: a1(:),a2(:)
+      logical                :: a_ge_a
+
+
+      a_ge_a = acompare_aa(a1,a2) /= 'LT'
+
+      end function a_ge_a
+
+!*******************************************************************************
+! array >= character
+
+      pure function a_ge_c(a,c)
+
+      implicit none
+      character, intent(in)     :: a(:)
+      character(*), intent(in)  :: c
+      logical                   :: a_ge_c
+
+
+      a_ge_c = acompare_ca(c,a) /= 'GT'
+
+      end function a_ge_c
+
+!*******************************************************************************
+! character >= array
+
+      pure function c_ge_a(c,a)
+
+      implicit none
+      character(*), intent(in)  :: c
+      character, intent(in)     :: a(:)
+      logical                   :: c_ge_a
+
+
+      c_ge_a = acompare_ca(c,a) /= 'LT'
+
+      end function c_ge_a
+
+!*******************************************************************************
+!     >  operators
+!*******************************************************************************
+! array > array
+
+      pure function a_gt_a(a1,a2)
+
+      implicit none
+      character, intent(in)  :: a1(:),a2(:)
+      logical                :: a_gt_a
+
+
+      a_gt_a = acompare_aa(a1,a2) == 'GT'
+
+      end function a_gt_a
+
+!*******************************************************************************
+! array > character
+
+      pure function a_gt_c(a,c)
+
+      implicit none
+      character, intent(in)     :: a(:)
+      character(*), intent(in)  :: c
+      logical                   :: a_gt_c
+
+
+      a_gt_c = acompare_ca(c,a) == 'LT'
+
+      end function a_gt_c
+
+!*******************************************************************************
+! character > array
+
+      pure function c_gt_a(c,a)
+
+      implicit none
+      character(*), intent(in)  :: c
+      character, intent(in)     :: a(:)
+      logical                   :: c_gt_a
+
+
+      c_gt_a = acompare_ca(c,a) == 'GT'
+
+      end function c_gt_a
+
+!*******************************************************************************
+
+      pure function alcompare_aa(a1,a2) result(caa)
+
+      implicit none
+      character, intent(in)  :: a1(:),a2(:)
+      character(2)           :: caa
+      integer                :: i,l1,l2
+
+
+      l1 = size(a1)
+      l2 = size(a2)
+      do i=1,min(l1,l2)
+          if (llt(a1(i),a2(i))) then
+              caa = 'LT'
+              return
+          elseif (lgt(a1(i),a2(i))) then
+              caa = 'GT'
+              return
+          endif
+      enddo
+      if (l1 < l2) then
+          do i=l1+1,l2
+              if (llt(blank,a2(i))) then
+                  caa = 'LT'
+                  return
+              elseif (lgt(blank,a2(i))) then
+                  caa = 'GT'
+                  return
+              endif
+          enddo
+      elseif (l1 > l2) then
+          do i=l2+1,l1
+              if (llt(a1(i),blank)) then
+                  caa = 'LT'
+                  return
+              elseif (lgt(a1(i),blank)) then
+                  caa = 'GT'
+                  return
+              endif
+          enddo
+      endif
+      caa = 'EQ'
+
+      end function alcompare_aa
+
+!*******************************************************************************
+
+      pure function alcompare_ca(c,a) result(cca)
+
+      implicit none
+      character(*), intent(in)  :: c
+      character, intent(in)     :: a(:)
+      character(2)              :: cca
+      integer                   :: i,lc,la
+
+
+      lc = len(c)
+      la = size(a)
+      do i=1,min(lc,la)
+          if (llt(c(i:i),a(i))) then
+              cca = 'LT'
+              return
+          elseif (lgt(c(i:i),a(i))) then
+              cca = 'GT'
+              return
+          endif
+      enddo
+      if (lc < la) then
+          do i=lc+1,la
+              if (llt(blank,a(i))) then
+                  cca = 'LT'
+                  return
+              elseif (lgt(blank,a(i))) then
+                  cca = 'GT'
+                  return
+              endif
+          enddo
+      elseif (lc > la) then
+          do i=la+1,lc
+              if (llt(c(i:i),blank)) then
+                  cca = 'LT'
+                  return
+              elseif (lgt(c(i:i),blank)) then
+                  cca = 'GT'
+                  return
+              endif
+          enddo
+      endif
+      cca = 'EQ'
+
+      end function alcompare_ca
+
+!*******************************************************************************
+!     LLT operators
+!*******************************************************************************
+! array < array
+
+      pure function a_allt_a(a1,a2)
+
+      implicit none
+      character, intent(in)  :: a1(:),a2(:)
+      logical                :: a_allt_a
+
+
+      a_allt_a = alcompare_aa(a1,a2) == 'LT'
+
+      end function a_allt_a
+
+!*******************************************************************************
+! array < character
+
+      pure function a_allt_c(a1,c2)
+
+      implicit none
+      character, intent(in)     :: a1(:)
+      character(*), intent(in)  :: c2
+      logical                   :: a_allt_c
+
+
+      a_allt_c = alcompare_ca(c2,a1) == 'GT'
+
+      end function a_allt_c
+
+!*******************************************************************************
+! character < array
+
+      pure function c_allt_a(c1,a2)
+
+      implicit none
+      character(*), intent(in)  :: c1
+      character, intent(in)     :: a2(:)
+      logical                   :: c_allt_a
+
+
+      c_allt_a = alcompare_ca(c1,a2) == 'LT'
+
+      end function c_allt_a
+
+!*******************************************************************************
+!     LLE  operators
+!*******************************************************************************
+! array <= array
+
+      pure function a_alle_a(a1,a2)
+
+      implicit none
+      character, intent(in)  :: a1(:),a2(:)
+      logical                :: a_alle_a
+
+
+      a_alle_a = alcompare_aa(a1,a2) /= 'GT'
+
+      end function a_alle_a
+
+!*******************************************************************************
+! array <= character
+
+      pure function a_alle_c(a1,c2)
+
+      implicit none
+      character, intent(in)     :: a1(:)
+      character(*), intent(in)  :: c2
+      logical                   :: a_alle_c
+
+
+      a_alle_c = alcompare_ca(c2,a1) /= 'LT'
+
+      end function a_alle_c
+
+!*******************************************************************************
+! character <= array
+
+      pure function c_alle_a(c1,a2)
+
+      implicit none
+      character(*), intent(in)  :: c1
+      character, intent(in)     :: a2(:)
+      logical                   :: c_alle_a
+
+
+      c_alle_a = alcompare_ca(c1,a2) /= 'GT'
+
+      end function c_alle_a
+
+!*******************************************************************************
+!     LGE  operators
+!*******************************************************************************
+! array >= array
+
+      pure function a_alge_a(a1,a2)
+
+      implicit none
+      character, intent(in)  :: a1(:),a2(:)
+      logical                :: a_alge_a
+
+
+      a_alge_a = alcompare_aa(a1,a2) /= 'LT'
+
+      end function a_alge_a
+
+!*******************************************************************************
+! array >= character
+
+      pure function a_alge_c(a1,c2)
+
+      implicit none
+      character, intent(in)     :: a1(:)
+      character(*), intent(in)  :: c2
+      logical                   :: a_alge_c
+
+
+      a_alge_c = alcompare_ca(c2,a1) /= 'GT'
+
+      end function a_alge_c
+
+!*******************************************************************************
+! character >= array
+
+      pure function c_alge_a(c1,a2)
+
+      implicit none
+      character(*), intent(in)  :: c1
+      character, intent(in)     :: a2(:)
+      logical                   :: c_alge_a
+
+
+      c_alge_a = alcompare_ca(c1,a2) /= 'LT'
+
+      end function c_alge_a
+
+!*******************************************************************************
+!     LGT  operators
+!*******************************************************************************
+! array > array
+
+      pure function a_algt_a(a1,a2)
+
+      implicit none
+      character, intent(in)  :: a1(:),a2(:)
+      logical                :: a_algt_a
+
+
+      a_algt_a = alcompare_aa(a1,a2) == 'GT'
+
+      end function a_algt_a
+
+!*******************************************************************************
+! array > character
+
+      pure function a_algt_c(a1,c2)
+
+      implicit none
+      character, intent(in)     :: a1(:)
+      character(*), intent(in)  :: c2
+      logical                   :: a_algt_c
+
+
+      a_algt_c = alcompare_ca(c2,a1) == 'LT'
+
+      end function a_algt_c
+
+!*******************************************************************************
+! character > array
+
+      pure function c_algt_a(c1,a2)
+
+      implicit none
+      character(*), intent(in)  :: c1
+      character, intent(in)     :: a2(:)
+      logical                   :: c_algt_a
+
+
+      c_algt_a = alcompare_ca(c1,a2) == 'GT'
+
+      end function c_algt_a
+
+!*******************************************************************************
+!     INDEX
+!*******************************************************************************
+
+      elemental function index_ss(s,sub,back)
+
+      implicit none
+      type(string), intent(in)       :: s,sub
+      logical, intent(in), optional  :: back
+      integer                        :: index_ss
+      logical                        :: dir_switch
+      integer                        :: ls,lsub
+
+
+      if (present(back)) then
+          dir_switch = back
+      else
+          dir_switch = .false.
+      endif
+
+      ls = len(s)
+      lsub = len(sub)
+      index_ss = aindex(s%chars(:ls),sub%chars(:lsub),dir_switch)
+
+      end function index_ss
+
+!*******************************************************************************
+
+      elemental function index_sc(s,sub,back)
+
+      implicit none
+      type(string), intent(in)       :: s
+      character(*), intent(in)       :: sub
+      logical, intent(in), optional  :: back
+      integer                        :: index_sc
+      logical                        :: dir_switch
+      integer                        :: ls
+
+
+      if (present(back)) then
+          dir_switch = back
+      else
+          dir_switch = .false.
+      endif
+
+      ls = len(s)
+      index_sc = aindex(s%chars(:ls),sub,dir_switch)
+
+      end function index_sc
+
+!*******************************************************************************
+
+      elemental function index_cs(s,sub,back)
+
+      implicit none
+      character(*), intent(in)       :: s
+      type(string), intent(in)       :: sub
+      logical, intent(in), optional  :: back
+      integer                        :: index_cs
+      logical                        :: dir_switch
+
+
+      if (present(back)) then
+          dir_switch = back
+      else
+          dir_switch = .false.
+      endif
+
+      index_cs = index(s,char(sub),dir_switch)
+
+      end function index_cs
+
+!*******************************************************************************
+!     AINDEX
+!*******************************************************************************
+
+      pure function aindex_aa(s,sub,back) result(index_aa)
+
+      implicit none
+      character, intent(in)          :: s(:),sub(:)
+      logical, intent(in), optional  :: back
+      integer                        :: index_aa
+      logical                        :: dir_switch
+      integer                        :: i,ls,lss
+
+
+      if (present(back)) then
+          dir_switch = back
+      else
+          dir_switch = .false.
+      endif
+
+      ls = size(s)
+      lss = size(sub)
+
+      if (lss == 0) then
+          if (dir_switch) then
+              index_aa = ls + 1
+          else
+              index_aa = 1
+          endif
+          return
+      endif
+
+      if (dir_switch) then
+!         backwards search
+          do i=ls-lss+1,1,-1
+              if (all(s(i:i+lss-1) == sub(1:lss))) then
+                  index_aa = i
+                  return
+              endif
+          enddo
+          index_aa = 0
+      else
+!         forward search
+          do i=1,ls-lss+1
+              if (all(s(i:i+lss-1) == sub(1:lss))) then
+                  index_aa = i
+                  return
+              endif
+          enddo
+          index_aa = 0
+      endif
+
+      end function aindex_aa
+
+!*******************************************************************************
+
+      pure function aindex_ac(s,sub,back) result(index_ac)
+
+      implicit none
+      character, intent(in)          :: s(:)
+      character(*), intent(in)       :: sub
+      logical, intent(in), optional  :: back
+      integer                        :: index_ac
+      logical                        :: dir_switch,matched
+      integer                        :: i,j,ls,lss
+
+
+      if (present(back)) then
+          dir_switch = back
+      else
+          dir_switch = .false.
+      endif
+
+      ls = size(s)
+      lss = len(sub)
+
+      if (lss == 0) then
+          if (dir_switch) then
+              index_ac = ls + 1
+          else
+              index_ac = 1
+          endif
+          return
+      endif
+
+      if (dir_switch) then
+          index_ac = 0
+          do i=ls-lss+1,1,-1
+              matched = all(s(i:i+lss-1) == (/ (sub(j:j), j=1,lss) /))
+              if (matched) then
+                  index_ac = i
+                  return
+              endif
+          enddo
+      else
+          index_ac = 0
+          do i=1,ls-lss+1
+              matched = all(s(i:i+lss-1) == (/ (sub(j:j), j=1,lss) /))
+              if (matched) then
+                  index_ac = i
+                  return
+              endif
+          enddo
+      endif
+
+      end function aindex_ac
+
+!*******************************************************************************
+
+      pure function aindex_ca(s,sub,back) result(index_ca)
+
+      implicit none
+      character(*), intent(in)       :: s
+      character, intent(in)          :: sub(:)
+      logical, intent(in), optional  :: back
+      integer                        :: index_ca
+      logical                        :: dir_switch,matched
+      integer                        :: i,j,ls,lss
+
+
+      if (present(back)) then
+          dir_switch = back
+      else
+          dir_switch = .false.
+      endif
+
+      ls = len(s)
+      lss = size(sub)
+
+      if (lss == 0) then
+          if (dir_switch) then
+              index_ca = ls + 1
+          else
+              index_ca = 1
+          endif
+          return
+      endif
+
+      if (dir_switch) then
+          do i=ls-lss+1,1,-1
+              matched = .true.
+              do j=1,lss
+                  if (s(i+j-1:i+j-1) /= sub(j)) then
+                      matched = .false.
+                      exit
+                  endif
+              enddo
+              if (matched) then
+                  index_ca = i
+                  return
+              endif
+          enddo
+          index_ca = 0
+      else
+          do i=1,ls-lss+1
+              matched = .true.
+              do j=1,lss
+                  if (s(i+j-1:i+j-1) /= sub(j)) then
+                      matched = .false.
+                      exit
+                  endif
+              enddo
+              if (matched) then
+                  index_ca = i
+                  return
+              endif
+          enddo
+          index_ca = 0
+      endif
+
+      end function aindex_ca
+
+!*******************************************************************************
+!     SCAN
+!*******************************************************************************
+
+      elemental function scan_ss(s,set,back)
+
+      implicit none
+      type(string), intent(in)       :: s,set
+      logical, intent(in), optional  :: back
+      integer                        :: scan_ss
+      logical                        :: dir_switch
+      integer                        :: ls,lset
+
+
+      if (present(back)) then
+          dir_switch = back
+      else
+          dir_switch = .false.
+      endif
+
+      ls = len(s)
+      lset = len(set)
+      scan_ss = ascan_aa(s%chars(1:ls),set%chars(1:lset),dir_switch)
+
+      end function scan_ss
+
+!*******************************************************************************
+
+      elemental function scan_sc(s,set,back)
+
+      implicit none
+      type(string), intent(in)       :: s
+      character(*), intent(in)       :: set
+      logical, intent(in), optional  :: back
+      integer                        :: scan_sc
+      logical                        :: dir_switch
+      integer                        :: ls
+
+
+      if (present(back)) then
+          dir_switch = back
+      else
+          dir_switch = .false.
+      endif
+
+      ls = len(s)
+      scan_sc = ascan_ac(s%chars(1:ls),set,dir_switch)
+
+      end function scan_sc
+
+!*******************************************************************************
+
+      elemental function scan_cs(s,set,back)
+
+      implicit none
+      character(*), intent(in)       :: s
+      type(string), intent(in)       :: set
+      logical, intent(in), optional  :: back
+      integer                        :: scan_cs
+      logical                        :: dir_switch
+      integer                        :: lset
+
+
+      if (present(back)) then
+          dir_switch = back
+      else
+          dir_switch = .false.
+      endif
+
+      lset = len(set)
+      scan_cs = ascan_ca(s,set%chars(1:lset),dir_switch)
+
+      end function scan_cs
+!*******************************************************************************
+!     ASCAN
+!*******************************************************************************
+
+      pure function ascan_aa(s,set,back)
+
+      implicit none
+      character, intent(in)          :: s(:),set(:)
+      logical, intent(in), optional  :: back
+      integer                        :: ascan_aa
+      logical                        :: dir_switch
+      integer                        :: i,ls,lset
+
+
+      if (present(back)) then
+          dir_switch = back
+      else
+          dir_switch = .false.
+      endif
+
+      ls = size(s)
+      lset = size(set)
+      if (dir_switch) then
+!         backwards search
+          do i=ls,1,-1
+              if (any(set(1:lset) == s(i))) then
+                  ascan_aa = i
+                  return
+              endif
+          enddo
+          ascan_aa = 0
+      else
+!         forward search
+          do i=1,ls
+              if (any(set(1:lset) == s(i))) then
+                  ascan_aa = i
+                  return
+              endif
+          enddo
+          ascan_aa = 0
+      endif
+
+      end function ascan_aa
+
+!*******************************************************************************
+
+      pure function ascan_ac(s,set,back)
+
+      implicit none
+      character, intent(in)          :: s(:)
+      character(*), intent(in)       :: set
+      logical, intent(in), optional  :: back
+      integer                        :: ascan_ac
+      logical                        :: dir_switch,matched
+      integer                        :: i,j,ls,lset
+
+
+      if (present(back)) then
+          dir_switch = back
+      else
+          dir_switch = .false.
+      endif
+
+      ls = size(s)
+      lset = len(set)
+      if (dir_switch) then
+!         backwards search
+          do i=ls,1,-1
+              matched = .false.
+              do j=1,lset
+                  if (s(i) == set(j:j)) then
+                      matched = .true.
+                      exit
+                  endif
+              enddo
+              if (matched) then
+                  ascan_ac = i
+                  return
+              endif
+          enddo
+          ascan_ac = 0
+      else
+!         forward search
+          do i=1,ls
+              matched = .false.
+              do j=1,lset
+                  if (s(i) == set(j:j)) then
+                      matched = .true.
+                      exit
+                  endif
+              enddo
+              if (matched) then
+                  ascan_ac = i
+                  return
+              endif
+          enddo
+          ascan_ac = 0
+      endif
+
+      end function ascan_ac
+
+!*******************************************************************************
+
+      pure function ascan_ca(s,set,back)
+
+      implicit none
+      character(*), intent(in)       :: s
+      character, intent(in)          :: set(:)
+      logical, intent(in), optional  :: back
+      integer                        :: ascan_ca
+      logical                        :: dir_switch,matched
+      integer                        :: i,j,ls,lset
+
+
+      if (present(back)) then
+          dir_switch = back
+      else
+          dir_switch = .false.
+      endif
+
+      ls = len(s)
+      lset = size(set)
+      if (dir_switch) then
+!         backwards search
+          do i=ls,1,-1
+              matched = .false.
+              do j=1,lset
+                  if (s(i:i) == set(j)) then
+                      matched = .true.
+                      exit
+                  endif
+              enddo
+              if (matched) then
+                  ascan_ca = i
+                  return
+              endif
+          enddo
+          ascan_ca = 0
+      else
+!         forward search
+          do i=1,ls
+              matched = .false.
+              do j=1,lset
+                  if (s(i:i) == set(j)) then
+                      matched = .true.
+                      exit
+                  endif
+              enddo
+              if (matched) then
+                  ascan_ca = i
+                  return
+              endif
+          enddo
+          ascan_ca = 0
+      endif
+
+      end function ascan_ca
+
+!*******************************************************************************
+!     VERIFY
+!*******************************************************************************
+
+      elemental function verify_ss(s,set,back)
+
+      implicit none
+      type(string), intent(in)       :: s,set
+      logical, intent(in), optional  :: back
+      integer                        :: verify_ss
+      logical                        :: dir_switch
+      integer                        :: ls,lset
+
+
+      if (present(back)) then
+          dir_switch = back
+      else
+          dir_switch = .false.
+      endif
+
+      ls = len(s)
+      lset = len(set)
+      verify_ss = averify_aa(s%chars(1:ls),set%chars(1:lset),dir_switch)
+
+      end function verify_ss
+
+!*******************************************************************************
+
+      elemental function verify_sc(s,set,back)
+
+      implicit none
+      type(string), intent(in)       :: s
+      character(*), intent(in)       :: set
+      logical, intent(in), optional  :: back
+      integer                        :: verify_sc
+      logical                        :: dir_switch
+      integer                        :: ls
+
+
+      if (present(back)) then
+          dir_switch = back
+      else
+          dir_switch = .false.
+      endif
+
+      ls = len(s)
+      verify_sc = averify_ac(s%chars(1:ls),set,dir_switch)
+
+      end function verify_sc
+
+!*******************************************************************************
+
+      elemental function verify_cs(s,set,back)
+
+      implicit none
+      character(*), intent(in)       :: s
+      type(string), intent(in)       :: set
+      logical, intent(in), optional  :: back
+      integer                        :: verify_cs
+      logical                        :: dir_switch
+      integer                        :: lset
+
+
+      if (present(back)) then
+          dir_switch = back
+      else
+          dir_switch = .false.
+      endif
+
+      lset = len(set)
+      verify_cs = averify_ca(s,set%chars(1:lset),dir_switch)
+
+      end function verify_cs
+
+!*******************************************************************************
+!     AVERIFY
+!*******************************************************************************
+
+      pure function averify_aa(s,set,back)
+
+      implicit none
+      character, intent(in)          :: s(:),set(:)
+      logical, intent(in), optional  :: back
+      integer                        :: averify_aa
+      logical                        :: dir_switch
+      integer                        :: i,ls,lset
+
+
+      if (present(back)) then
+          dir_switch = back
+      else
+          dir_switch = .false.
+      endif
+
+      ls = size(s)
+      lset = size(set)
+      if (dir_switch) then
+!         backwards search
+          do i=ls,1,-1
+              if (.not.(any(set(1:lset) == s(i)))) then
+                  averify_aa = i
+                  return
+              endif
+          enddo
+          averify_aa = 0
+      else
+!         forward search
+          do i=1,ls
+              if (.not.(any(set(1:lset) == s(i)))) then
+                  averify_aa = i
+                  return
+              endif
+          enddo
+          averify_aa = 0
+      endif
+
+      end function averify_aa
+
+!*******************************************************************************
+
+      pure function averify_ac(s,set,back)
+
+      implicit none
+      character, intent(in)          :: s(:)
+      character(*), intent(in)       :: set
+      logical, intent(in), optional  :: back
+      integer                        :: averify_ac
+      logical                        :: dir_switch
+      integer                        :: i,j,ls,lset
+
+
+      if (present(back)) then
+          dir_switch = back
+      else
+          dir_switch = .false.
+      endif
+
+      ls = size(s)
+      lset = len(set)
+      if (dir_switch) then
+!         backwards search
+b:        do i=ls,1,-1
+              do j=1,lset
+                  if (s(i) == set(j:j)) cycle b
+              enddo
+              averify_ac = i
+              return
+          enddo b
+          averify_ac = 0
+      else
+!         forward search
+f:        do i=1,ls
+              do j=1,lset
+                  if (s(i) == set(j:j)) cycle f
+              enddo
+              averify_ac = i
+              return
+          enddo f
+          averify_ac = 0
+      endif
+
+      end function averify_ac
+
+!*******************************************************************************
+
+      pure function averify_ca(s,set,back)
+
+      implicit none
+      character(*), intent(in)       :: s
+      character, intent(in)          :: set(:)
+      logical, intent(in), optional  :: back
+      integer                        :: averify_ca
+      logical                        :: dir_switch
+      integer                        :: i,j,ls,lset
+
+
+      if (present(back)) then
+          dir_switch = back
+      else
+          dir_switch = .false.
+      endif
+
+      ls = len(s)
+      lset = size(set)
+      if (dir_switch) then
+!         backwards search
+b:        do i=ls,1,-1
+              do j=1,lset
+                  if (s(i:i) == set(j)) cycle b
+              enddo
+              averify_ca = i
+              return
+          enddo b
+          averify_ca = 0
+      else
+!         forward search
+f:        do i=1,ls
+              do j=1,lset
+                  if (s(i:i) == set(j)) cycle f
+              enddo
+              averify_ca = i
+              return
+          enddo f
+          averify_ca = 0
+      endif
+
+      end function averify_ca
+
+!*******************************************************************************
+!     UPPERCASE
+!*******************************************************************************
+
+      pure function uppercase_s(s,begin,end)
+
+      implicit none
+      type(string), intent(in)       :: s
+      integer, intent(in), optional  :: begin,end
+      character(len(s))              :: uppercase_s
+      integer                        :: i,i1,i2,j
+
+
+      i1 = 1
+      if (present(begin)) i1 = max(i1,begin)
+      i2 = len(s)
+      if (present(end)) i2 = min(i2,end)
+
+      do i=1,i1-1
+          uppercase_s(i:i) = s%chars(i)
+      enddo
+      do i=i1,i2
+          j = iachar(s%chars(i))
+          select case(j)
+          case(97:122)
+              uppercase_s(i:i) = achar(j-32)
+          case default
+              uppercase_s(1:i) = s%chars(i)
+          end select
+      enddo
+      do i=i2+1,len(s)
+          uppercase_s(i:i) = s%chars(i)
+      enddo
+
+      end function uppercase_s
+
+!*******************************************************************************
+
+      pure function uppercase_c(c,begin,end)
+
+      implicit none
+      character(*), intent(in)       :: c
+      integer, intent(in), optional  :: begin,end
+      character(len(c))              :: uppercase_c
+      integer                        :: i,i1,i2,j
+
+
+      i1 = 1
+      if (present(begin)) i1 = max(i1,begin)
+      i2 = len(c)
+      if (present(end)) i2 = min(i2,end)
+
+      uppercase_c(:i1-1) = c(:i1-1)
+      do i=i1,i2
+          j = iachar(c(i:i))
+          select case(j)
+          case(97:122)
+              uppercase_c(i:i) = achar(j-32)
+          case default
+              uppercase_c(i:i) = c(i:i)
+          end select
+      enddo
+      uppercase_c(i2+1:) = c(i2+1:)
+
+      end function uppercase_c
+
+!*******************************************************************************
+
+      elemental subroutine to_uppercase_s(s,begin,end)
+
+      implicit none
+      type(string), intent(inout)    :: s
+      integer, intent(in), optional  :: begin,end
+      integer                        :: i,i1,i2,j
+
+
+      i1 = 1
+      if (present(begin)) i1 = max(i1,begin)
+      i2 = len(s)
+      if (present(end)) i2 = min(i2,end)
+
+      do i=i1,i2
+          j = iachar(s%chars(i))
+          select case(j)
+          case(97:122)
+              s%chars(i) = achar(j-32)
+          case default
+              continue
+          end select
+      enddo
+
+      end subroutine to_uppercase_s
+
+!*******************************************************************************
+
+      elemental subroutine to_uppercase_c(c,begin,end)
+
+      implicit none
+      character(*), intent(inout)    :: c
+      integer, intent(in), optional  :: begin,end
+      integer                        :: i,i1,i2,j
+
+
+      i1 = 1
+      if (present(begin)) i1 = max(i1,begin)
+      i2 = len(c)
+      if (present(end)) i2 = min(i2,end)
+
+      do i=i1,i2
+          j = iachar(c(i:i))
+          select case(j)
+          case(97:122)
+              c(i:i) = achar(j-32)
+          case default
+              continue
+          end select
+      enddo
+
+      end subroutine to_uppercase_c
+
+!*******************************************************************************
+!     LOWERCASE
+!*******************************************************************************
+
+      pure function lowercase_s(s,begin,end)
+
+      implicit none
+      type(string), intent(in)       :: s
+      integer, intent(in), optional  :: begin,end
+      character(len(s))              :: lowercase_s
+      integer                        :: i,i1,i2,j
+
+
+      i1 = 1
+      if (present(begin)) i1 = max(i1,begin)
+      i2 = len(s)
+      if (present(end)) i2 = min(i2,end)
+
+      do i=1,i1-1
+          lowercase_s(i:i) = s%chars(i)
+      enddo
+      do i=i1,i2
+          j = iachar(s%chars(i))
+          select case(j)
+          case(65:90)
+              lowercase_s(i:i) = achar(j+32)
+          case default
+              lowercase_s(i:i) = s%chars(i)
+          end select
+      enddo
+      do i=i2+1,len(s)
+          lowercase_s(i:i) = s%chars(i)
+      enddo
+
+      end function lowercase_s
+
+!*******************************************************************************
+
+      pure function lowercase_c(c,begin,end)
+
+      implicit none
+      character(*), intent(in)       :: c
+      integer, intent(in), optional  :: begin,end
+      character(len(c))              :: lowercase_c
+      integer                        :: i,i1,i2,j
+
+
+      i1 = 1
+      if (present(begin)) i1 = max(i1,begin)
+      i2 = len(c)
+      if (present(end)) i2 = min(i2,end)
+
+      lowercase_c(:i1-1) = c(:i1-1)
+      do i=i1,i2
+          j = iachar(c(i:i))
+          select case(j)
+          case(65:90)
+              lowercase_c(i:i) = achar(j+32)
+          case default
+              lowercase_c(i:i) = c(i:i)
+          end select
+      enddo
+      lowercase_c(i2+1:) = c(i2+1:)
+
+      end function lowercase_c
+
+!*******************************************************************************
+
+      elemental subroutine to_lowercase_s(s,begin,end)
+
+      implicit none
+      type(string), intent(inout)    :: s
+      integer, intent(in), optional  :: begin,end
+      integer                        :: i,i1,i2,j
+
+
+      i1 = 1
+      if (present(begin)) i1 = max(i1,begin)
+      i2 = len(s)
+      if (present(end)) i2 = min(i2,end)
+
+      do i=i1,i2
+          j = iachar(s%chars(i))
+          select case(j)
+          case(65:90)
+              s%chars(i) = achar(j+32)
+          case default
+              continue
+          end select
+      enddo
+
+      end subroutine to_lowercase_s
+
+!*******************************************************************************
+
+      elemental subroutine to_lowercase_c(c,begin,end)
+
+      implicit none
+      character(*), intent(inout)    :: c
+      integer, intent(in), optional  :: begin,end
+      integer                        :: i,i1,i2,j
+
+
+      i1 = 1
+      if (present(begin)) i1 = max(i1,begin)
+      i2 = len(c)
+      if (present(end)) i2 = min(i2,end)
+
+      do i=i1,i2
+          j = iachar(c(i:i))
+          select case(j)
+          case(65:90)
+              c(i:i) = achar(j+32)
+          case default
+              continue
+          end select
+      enddo
+
+      end subroutine to_lowercase_c
+
+!*******************************************************************************
+
+!*******************************************************************************
+
+      end module m_strings
Index: vendors/XMLF90/current/src/wxml/flib_wxml.f90
===================================================================
--- vendors/XMLF90/current/src/wxml/flib_wxml.f90	(revision 1899)
+++ vendors/XMLF90/current/src/wxml/flib_wxml.f90	(revision 1899)
@@ -0,0 +1,11 @@
+module flib_wxml
+
+!use m_wxml_buffer
+!use m_wxml_dictionary
+!use m_wxml_elstack
+use m_wxml_text
+use m_wxml_core
+
+public
+
+end module flib_wxml
Index: vendors/XMLF90/current/src/wxml/m_wxml_buffer.f90
===================================================================
--- vendors/XMLF90/current/src/wxml/m_wxml_buffer.f90	(revision 1899)
+++ vendors/XMLF90/current/src/wxml/m_wxml_buffer.f90	(revision 1899)
@@ -0,0 +1,176 @@
+module m_wxml_buffer
+
+!
+! 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".
+! There is code in the parser module  m_fsm to avoid buffer overflows
+! caused by pcdata values.
+!
+! This module is re-used from the parser package.
+! Most of the routines are superfluous at this point.
+!
+! In a forthcoming implementation it could be made dynamical...
+!
+integer, parameter, public   :: MAX_BUFF_SIZE  = 2000
+integer, parameter, private  :: BUFF_SIZE_WARNING  = 1750
+!
+type, public  :: buffer_t
+private
+      integer                       :: size
+      character(len=MAX_BUFF_SIZE)  :: str
+end type buffer_t
+
+public :: add_to_buffer
+public :: print_buffer, str, char, len
+public :: operator (.equal.)
+public :: buffer_nearly_full, reset_buffer
+
+
+!----------------------------------------------------------------
+interface add_to_buffer
+      module procedure add_str_to_buffer
+end interface
+private :: add_char_to_buffer, add_str_to_buffer
+
+interface operator (.equal.)
+      module procedure compare_buffers, compare_buffer_str, &
+             compare_str_buffer
+end interface
+private :: compare_buffers, compare_buffer_str, compare_str_buffer
+
+interface str
+      module procedure buffer_to_str
+end interface
+interface char                 ! Experimental
+      module procedure buffer_to_str
+end interface
+private :: buffer_to_str
+
+interface len
+   module procedure buffer_length
+end interface
+private :: buffer_length
+
+CONTAINS
+!==================================================================
+
+!----------------------------------------------------------------
+function compare_buffers(a,b) result(equal)     ! .equal. generic
+type(buffer_t), intent(in)  :: a
+type(buffer_t), intent(in)  :: b
+logical                     :: equal
+
+equal = ((a%size == b%size) .and. (a%str(1:a%size) == b%str(1:b%size)))
+
+end function compare_buffers
+
+!----------------------------------------------------------------
+function compare_buffer_str(buffer,str) result(equal) ! .equal. generic
+type(buffer_t), intent(in)   :: buffer
+character(len=*), intent(in) :: str
+logical                      :: equal
+
+equal = (buffer%str(1:buffer%size) == trim(str))
+
+end function compare_buffer_str
+
+!----------------------------------------------------------------
+function compare_str_buffer(str,buffer) result(equal) ! .equal. generic
+character(len=*), intent(in) :: str
+type(buffer_t), intent(in)   :: buffer
+logical                     :: equal
+
+equal = (buffer%str(1:buffer%size) == trim(str))
+
+end function compare_str_buffer
+
+!----------------------------------------------------------------
+subroutine add_char_to_buffer(c,buffer)
+character(len=1), intent(in)   :: c
+type(buffer_t), intent(inout)  :: buffer
+
+integer   :: n
+buffer%size = buffer%size + 1
+n = buffer%size
+
+if (n> MAX_BUFF_SIZE) then
+  stop "wxml Buffer overflow: long unbroken string of pcdata or attribute value..."
+!  RETURN
+!
+endif
+
+buffer%str(n:n) = c
+end subroutine add_char_to_buffer
+
+!----------------------------------------------------------------
+subroutine add_str_to_buffer(s,buffer)
+character(len=*), intent(in)   :: s
+type(buffer_t), intent(inout)  :: buffer
+
+integer   :: n, len_s, last_pos
+
+len_s = len(s)
+last_pos = buffer%size
+buffer%size = buffer%size + len_s
+n = buffer%size
+
+if (n> MAX_BUFF_SIZE) then
+  stop "wxml Buffer overflow: long unbroken string of pcdata or attribute value..."
+!  RETURN
+endif
+
+buffer%str(last_pos+1:n) = s
+end subroutine add_str_to_buffer
+
+!----------------------------------------------------------------
+subroutine reset_buffer(buffer)
+type(buffer_t), intent(inout)  :: buffer
+
+buffer%size = 0
+
+end subroutine reset_buffer
+
+!----------------------------------------------------------------
+subroutine print_buffer(buffer)
+type(buffer_t), intent(in)  :: buffer
+
+integer :: i
+
+do i = 1, buffer%size
+      write(unit=6,fmt="(a1)",advance="no") buffer%str(i:i)
+enddo
+
+end subroutine print_buffer
+!----------------------------------------------------------------
+! This is better... but could it lead to memory leaks?
+!
+function buffer_to_str(buffer) result(str)
+type(buffer_t), intent(in)          :: buffer
+character(len=buffer%size)          :: str
+
+str = buffer%str(1:buffer%size)
+end function buffer_to_str
+
+!----------------------------------------------------------------
+function buffer_nearly_full(buffer) result(warn)
+type(buffer_t), intent(in)          :: buffer
+logical                             :: warn
+
+warn = buffer%size > BUFF_SIZE_WARNING
+
+end function buffer_nearly_full
+
+!----------------------------------------------------------------
+function buffer_length(buffer) result(length)
+type(buffer_t), intent(in)          :: buffer
+integer                             :: length
+
+length = buffer%size 
+
+end function buffer_length
+
+
+end module m_wxml_buffer
Index: vendors/XMLF90/current/src/wxml/m_wxml_core.f90
===================================================================
--- vendors/XMLF90/current/src/wxml/m_wxml_core.f90	(revision 1899)
+++ vendors/XMLF90/current/src/wxml/m_wxml_core.f90	(revision 1899)
@@ -0,0 +1,380 @@
+module m_wxml_core
+
+use m_wxml_buffer
+use m_wxml_elstack
+use m_wxml_dictionary
+
+logical, private, save  :: pcdata_advance_line_default = .false.
+logical, private, save  :: pcdata_advance_space_default = .false.
+
+integer, private, parameter ::  sp = selected_real_kind(6,30)
+integer, private, parameter ::  dp = selected_real_kind(14,100)
+
+private
+
+type, public :: xmlf_t
+   integer            :: lun
+   type(buffer_t)     :: buffer
+   type(elstack_t)    :: stack
+   type(wxml_dictionary_t) :: dict
+   logical            :: start_tag_closed
+   logical            :: root_element_output
+   logical            :: indenting_requested
+end type xmlf_t
+
+public :: xml_OpenFile, xml_NewElement, xml_EndElement, xml_Close
+public :: xml_AddPcdata, xml_AddAttribute, xml_AddXMLDeclaration
+public :: xml_AddComment, xml_AddCdataSection
+
+public :: xml_AddArray
+interface xml_AddArray
+   module procedure  xml_AddArray_integer,  &
+                xml_AddArray_real_dp, xml_AddArray_real_sp
+end interface
+private :: xml_AddArray_integer,  xml_AddArray_real_dp, xml_AddArray_real_sp
+
+private :: get_unit
+private :: add_eol
+private :: write_attributes
+
+
+integer, private, parameter  :: COLUMNS = 80
+
+CONTAINS
+
+!-------------------------------------------------------------------
+subroutine xml_OpenFile(filename, xf, indent)
+character(len=*), intent(in)  :: filename
+type(xmlf_t), intent(inout)   :: xf
+logical, intent(in), optional :: indent
+
+integer :: iostat
+
+call get_unit(xf%lun,iostat)
+if (iostat /= 0) stop "cannot open file"
+open(unit=xf%lun, file=filename, form="formatted", status="replace", &
+     action="write", position="rewind") ! , recl=65536)
+
+call reset_elstack(xf%stack)
+call reset_dict(xf%dict)
+call reset_buffer(xf%buffer)
+
+xf%start_tag_closed = .true.
+xf%root_element_output = .false.
+
+xf%indenting_requested = .false.
+if (present(indent)) then
+   xf%indenting_requested = indent
+endif
+end subroutine xml_OpenFile
+
+!-------------------------------------------------------------------
+subroutine xml_AddXMLDeclaration(xf,encoding)
+type(xmlf_t), intent(inout)   :: xf
+character(len=*), intent(in), optional :: encoding
+
+if (present(encoding)) then
+   call add_to_buffer("<?xml version=""1.0"" encoding=""" &
+                     // trim(encoding) // """ ?>", xf%buffer)
+else
+   call add_to_buffer("<?xml version=""1.0"" ?>", xf%buffer)
+endif
+end subroutine xml_AddXMLDeclaration
+
+!-------------------------------------------------------------------
+subroutine xml_AddComment(xf,comment)
+type(xmlf_t), intent(inout)   :: xf
+character(len=*), intent(in)  :: comment
+
+call close_start_tag(xf,">")
+call add_eol(xf)
+call add_to_buffer("<!--", xf%buffer)
+call add_to_buffer(comment, xf%buffer)
+call add_to_buffer("-->", xf%buffer)
+end subroutine xml_AddComment
+
+!-------------------------------------------------------------------
+subroutine xml_AddCdataSection(xf,cdata)
+type(xmlf_t), intent(inout)   :: xf
+character(len=*), intent(in)  :: cdata
+
+call close_start_tag(xf,">")
+call add_to_buffer("<![CDATA[", xf%buffer)
+call add_to_buffer(cdata, xf%buffer)
+call add_to_buffer("]]>", xf%buffer)
+end subroutine xml_AddCdataSection
+
+!-------------------------------------------------------------------
+subroutine xml_NewElement(xf,name)
+type(xmlf_t), intent(inout)   :: xf
+character(len=*), intent(in)  :: name
+
+if (is_empty(xf%stack)) then
+   if (xf%root_element_output) stop "two root elements"
+   xf%root_element_output = .true.
+endif
+
+call close_start_tag(xf,">")
+call push_elstack(name,xf%stack)
+call add_eol(xf)
+call add_to_buffer("<" // trim(name),xf%buffer)
+xf%start_tag_closed = .false.
+call reset_dict(xf%dict)
+
+end subroutine xml_NewElement
+!-------------------------------------------------------------------
+subroutine xml_AddPcdata(xf,pcdata,space,line_feed)
+type(xmlf_t), intent(inout)   :: xf
+character(len=*), intent(in)  :: pcdata
+logical, intent(in), optional  :: space
+logical, intent(in), optional  :: line_feed
+
+logical :: advance_line , advance_space
+integer :: n, i, jmax
+integer, parameter   :: chunk_size = 128
+
+advance_line = pcdata_advance_line_default 
+if (present(line_feed)) then
+   advance_line = line_feed
+endif
+
+advance_space = pcdata_advance_space_default 
+if (present(space)) then
+   advance_space = space
+endif
+
+if (is_empty(xf%stack)) then
+   stop "pcdata outside element content"
+endif
+
+call close_start_tag(xf,">")
+
+if (advance_line) then
+   call add_eol(xf)
+   advance_space = .false.
+else
+   if (xf%indenting_requested) then
+      if ((len(xf%buffer) + len_trim(pcdata) + 1) > COLUMNS ) then
+         call add_eol(xf)
+         advance_space = .false.
+      endif
+   endif
+endif
+if (advance_space) call add_to_buffer(" ",xf%buffer)
+if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.false.)
+!
+! We bypass the buffer for the bulk of the dump
+!
+n = len(pcdata)
+!print *, "writing pcdata of length: ", n
+i = 1
+do
+   jmax = min(i+chunk_size-1,n)
+!   print *, "writing chunk: ", i, jmax
+   write(unit=xf%lun,fmt="(a)",advance="no") pcdata(i:jmax)
+   if (jmax == n) exit
+   i = jmax + 1
+enddo
+end subroutine xml_AddPcdata
+
+!-------------------------------------------------------------------
+subroutine xml_AddAttribute(xf,name,value)
+type(xmlf_t), intent(inout)   :: xf
+character(len=*), intent(in)  :: name
+character(len=*), intent(in)  :: value
+
+if (is_empty(xf%stack)) then
+   stop "attributes outside element content"
+endif
+
+if (xf%start_tag_closed)  then
+   stop "attributes outside start tag"
+endif
+if (has_key(xf%dict,name)) then
+   stop "duplicate att name"
+endif
+
+call add_key_to_dict(trim(name),xf%dict)
+call add_value_to_dict(trim(value),xf%dict)
+
+end subroutine xml_AddAttribute
+
+!-----------------------------------------------------------
+subroutine xml_EndElement(xf,name)
+type(xmlf_t), intent(inout)   :: xf
+character(len=*), intent(in)  :: name
+
+character(len=100)  :: current
+
+if (is_empty(xf%stack)) then
+   stop "Out of elements to close"
+endif
+
+call get_top_elstack(xf%stack,current)
+if (current /= name) then
+   print *, "current, name: ", trim(current), " ", trim(name)
+   stop
+endif
+if (.not. xf%start_tag_closed)  then                ! Empty element
+   if (len(xf%dict) > 0) call write_attributes(xf)
+   call add_to_buffer(" />",xf%buffer)
+   xf%start_tag_closed = .true.
+else
+   call add_eol(xf)
+   call add_to_buffer("</" // trim(name) // ">", xf%buffer)
+endif
+call pop_elstack(xf%stack,current)
+
+end subroutine xml_EndElement
+
+!----------------------------------------------------------------
+
+subroutine xml_Close(xf)
+type(xmlf_t), intent(in)   :: xf
+
+write(unit=xf%lun,fmt="(a)") char(xf%buffer)
+close(unit=xf%lun)
+
+end subroutine xml_Close
+
+!==================================================================
+!-------------------------------------------------------------------
+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 add_eol(xf)
+type(xmlf_t), intent(inout)   :: xf
+
+integer :: indent_level
+character(len=100), parameter  ::  blanks =  ""
+
+indent_level = len(xf%stack) - 1
+write(unit=xf%lun,fmt="(a)") char(xf%buffer)
+call reset_buffer(xf%buffer)
+
+if (xf%indenting_requested) &
+   call add_to_buffer(blanks(1:indent_level),xf%buffer)
+
+end subroutine add_eol
+!------------------------------------------------------------
+subroutine dump_buffer(xf,lf)
+type(xmlf_t), intent(inout)   :: xf
+logical, intent(in), optional :: lf
+
+if (present(lf)) then
+   if (lf) then
+      write(unit=xf%lun,fmt="(a)",advance="yes") char(xf%buffer)
+   else
+      write(unit=xf%lun,fmt="(a)",advance="no") char(xf%buffer)
+   endif
+else
+   write(unit=xf%lun,fmt="(a)",advance="no") char(xf%buffer)
+endif
+call reset_buffer(xf%buffer)
+
+end subroutine dump_buffer
+
+!------------------------------------------------------------
+subroutine close_start_tag(xf,s)
+type(xmlf_t), intent(inout)   :: xf
+character(len=*), intent(in)  :: s
+
+if (.not. xf%start_tag_closed)  then
+   if (len(xf%dict) > 0)  call write_attributes(xf)
+   call add_to_buffer(s, xf%buffer)
+   xf%start_tag_closed = .true.
+endif
+
+end subroutine close_start_tag
+
+!-------------------------------------------------------------
+subroutine write_attributes(xf)
+type(xmlf_t), intent(inout)   :: xf
+
+integer  :: i, status, size
+character(len=100)  :: key, value
+
+do i = 1, len(xf%dict)
+   call get_key(xf%dict,i,key,status)
+   call get_value(xf%dict,key,value,status)
+   key = adjustl(key)
+   value = adjustl(value)
+   size = len_trim(key) + len_trim(value) + 4
+   if ((len(xf%buffer) + size) > COLUMNS) call add_eol(xf)
+   call add_to_buffer(" ", xf%buffer)
+   call add_to_buffer(trim(key), xf%buffer)
+   call add_to_buffer("=", xf%buffer)
+   call add_to_buffer("""",xf%buffer)
+   call add_to_buffer(trim(value), xf%buffer)
+   call add_to_buffer("""", xf%buffer)
+enddo
+
+end subroutine write_attributes
+
+!---------------------------------------------------------------
+    subroutine xml_AddArray_integer(xf,a,format)
+      type(xmlf_t), intent(inout)         :: xf
+      integer, intent(in), dimension(:)   :: a
+      character(len=*), intent(in), optional  :: format
+
+      call close_start_tag(xf,">")
+      if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.true.)
+      if (present(format)) then
+         write(xf%lun,format) a
+      else
+         write(xf%lun,"(6(i12))") a
+      endif
+    end subroutine xml_AddArray_integer
+
+!-------------------------------------------------------------------
+    subroutine xml_AddArray_real_dp(xf,a,format)
+      type(xmlf_t), intent(inout)         :: xf
+      real(kind=dp), intent(in), dimension(:)   :: a
+      character(len=*), intent(in), optional  :: format
+
+      call close_start_tag(xf,">")
+      if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.true.)
+      if (present(format)) then
+         write(xf%lun,format) a
+      else
+         write(xf%lun,"(4(es20.12))") a
+      endif
+    end subroutine xml_AddArray_real_dp
+
+!------------------------------------------------------------------
+    subroutine xml_AddArray_real_sp(xf,a,format)
+      type(xmlf_t), intent(inout)         :: xf
+      real(kind=sp), intent(in), dimension(:)   :: a
+      character(len=*), intent(in), optional  :: format
+
+      call close_start_tag(xf,">")
+      if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.true.)
+      if (present(format)) then
+         write(xf%lun,format) a
+      else
+         write(xf%lun,"(4(es20.12))") a
+      endif
+    end subroutine xml_AddArray_real_sp
+
+end module m_wxml_core
+
Index: vendors/XMLF90/current/src/wxml/m_wxml_dictionary.f90
===================================================================
--- vendors/XMLF90/current/src/wxml/m_wxml_dictionary.f90	(revision 1899)
+++ vendors/XMLF90/current/src/wxml/m_wxml_dictionary.f90	(revision 1899)
@@ -0,0 +1,162 @@
+module m_wxml_dictionary
+
+private
+!
+! A very rough implementation for now
+! It uses fixed-length buffers for key/value pairs,
+! and the maximum number of dictionary items is hardwired.
+
+integer, parameter, private    :: MAX_ITEMS = 30
+type, public :: wxml_dictionary_t
+private
+      integer                               :: number_of_items ! = 0
+      character(len=100), dimension(MAX_ITEMS)  :: key
+      character(len=100), dimension(MAX_ITEMS)  :: value
+end type wxml_dictionary_t
+
+!
+! Building procedures
+!
+public  :: add_key_to_dict, add_value_to_dict, reset_dict
+
+!
+! Query and extraction procedures
+!
+public  :: len
+interface len
+   module procedure number_of_entries
+end interface
+public  :: number_of_entries
+public  :: get_key
+public  :: get_value
+public  :: has_key
+public  :: print_dict
+!
+interface get_value
+   module procedure wxml_get_value
+end interface
+
+CONTAINS
+
+!------------------------------------------------------
+function number_of_entries(dict) result(n)
+type(wxml_dictionary_t), intent(in)   :: dict
+integer                          :: n
+
+n = dict%number_of_items
+
+end function number_of_entries
+
+!------------------------------------------------------
+function has_key(dict,key) result(found)
+type(wxml_dictionary_t), intent(in)   :: dict
+character(len=*), intent(in)     :: key
+logical                          :: found
+
+integer  :: n, i
+found = .false.
+n = dict%number_of_items
+do  i = 1, n
+      if (dict%key(i) == key) then
+         found = .true.
+         exit
+      endif
+enddo
+end function has_key
+
+!------------------------------------------------------
+subroutine wxml_get_value(dict,key,value,status)
+type(wxml_dictionary_t), intent(in)            :: dict
+character(len=*), intent(in)              :: key
+character(len=*), intent(out)             :: value
+integer, intent(out)                      :: status
+!
+integer  :: n, i
+
+status = -1
+n = dict%number_of_items
+do  i = 1, n
+      if (dict%key(i) == key) then
+         value = dict%value(i)
+         status = 0
+         RETURN
+      endif
+enddo
+
+end subroutine wxml_get_value
+
+!------------------------------------------------------
+subroutine get_key(dict,i,key,status)
+!
+! Get the i'th key
+!
+type(wxml_dictionary_t), intent(in)            :: dict
+integer, intent(in)                       :: i
+character(len=*), intent(out)             :: key
+integer, intent(out)                      :: status
+
+if (i <= dict%number_of_items) then
+      key = dict%key(i)
+      status = 0
+else
+      key = ""
+      status = -1
+endif
+
+end subroutine get_key
+
+!------------------------------------------------------
+subroutine add_key_to_dict(key,dict)
+character(len=*), intent(in)          :: key
+type(wxml_dictionary_t), intent(inout)   :: dict
+
+integer  :: n
+
+n = dict%number_of_items
+if (n == MAX_ITEMS) then
+      write(unit=0,fmt=*) "Dictionary capacity exceeded !"
+      RETURN
+endif
+
+n = n + 1
+dict%key(n) = key
+dict%number_of_items = n
+
+end subroutine add_key_to_dict
+
+!------------------------------------------------------
+! Assumes we build the dictionary in an orderly fashion,
+! so one adds first the key and then immediately afterwards the value.
+!
+subroutine add_value_to_dict(value,dict)
+character(len=*), intent(in)          :: value
+type(wxml_dictionary_t), intent(inout)   :: dict
+
+integer  :: n
+
+n = dict%number_of_items
+dict%value(n) = value
+
+end subroutine add_value_to_dict
+
+!------------------------------------------------------
+subroutine reset_dict(dict)
+type(wxml_dictionary_t), intent(inout)   :: dict
+
+dict%number_of_items = 0
+
+end subroutine reset_dict
+
+!------------------------------------------------------
+subroutine print_dict(dict)
+type(wxml_dictionary_t), intent(in)   :: dict
+
+integer  :: i
+
+do i = 1, dict%number_of_items
+      print *, trim(dict%key(i)), " = ", trim(dict%value(i))
+enddo
+
+end subroutine print_dict
+
+end module m_wxml_dictionary
Index: vendors/XMLF90/current/src/wxml/m_wxml_elstack.f90
===================================================================
--- vendors/XMLF90/current/src/wxml/m_wxml_elstack.f90	(revision 1899)
+++ vendors/XMLF90/current/src/wxml/m_wxml_elstack.f90	(revision 1899)
@@ -0,0 +1,143 @@
+module m_wxml_elstack
+
+private
+
+!
+! Simple stack to keep track of which elements have appeared so far
+!
+integer, parameter, private            :: STACK_SIZE = 20
+
+type, public :: elstack_t
+private
+      integer                                    :: n_items
+      character(len=100), dimension(STACK_SIZE)  :: data
+end type elstack_t
+
+public  :: push_elstack, pop_elstack, reset_elstack, print_elstack
+public  :: get_top_elstack, is_empty, get_elstack_signature
+public  :: len
+
+interface len
+   module procedure number_of_items
+end interface
+private :: number_of_items
+
+interface is_empty
+      module procedure is_empty_elstack
+end interface
+private :: is_empty_elstack
+
+CONTAINS
+
+!-----------------------------------------------------------------
+subroutine reset_elstack(elstack)
+type(elstack_t), intent(inout)  :: elstack
+
+elstack%n_items = 0
+
+end subroutine reset_elstack
+
+!-----------------------------------------------------------------
+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(item,elstack)
+character(len=*), intent(in)      :: item
+type(elstack_t), intent(inout)  :: elstack
+
+integer   :: n
+
+n = elstack%n_items
+if (n == STACK_SIZE) then
+      stop "*Element stack full"
+endif
+n = n + 1
+elstack%data(n) = item
+elstack%n_items = n
+
+end subroutine push_elstack
+
+!-----------------------------------------------------------------
+subroutine pop_elstack(elstack,item)
+type(elstack_t), intent(inout)     :: elstack
+character(len=*), intent(out)        :: item
+
+!
+! We assume the elstack is not empty... (the user has called is_empty first)
+!
+integer   :: n
+
+n = elstack%n_items
+if (n == 0) then
+      stop "*********Element stack empty"
+endif
+item = elstack%data(n)
+elstack%n_items = n - 1
+
+end subroutine pop_elstack
+
+!-----------------------------------------------------------------
+subroutine get_top_elstack(elstack,item)
+!
+! Get the top element of the stack, *without popping it*.
+!
+type(elstack_t), intent(in)        :: elstack
+character(len=*), intent(out)        :: item
+
+!
+! We assume the elstack is not empty... (the user has called is_empty first)
+!
+integer   :: n
+
+n = elstack%n_items
+if (n == 0) then
+      stop "*********Element stack empty"
+endif
+item = elstack%data(n)
+
+end subroutine get_top_elstack
+
+!-----------------------------------------------------------------
+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=*) trim(elstack%data(i))
+enddo
+
+end subroutine print_elstack
+
+!-------------------------------------------------------------
+subroutine get_elstack_signature(elstack,string)
+type(elstack_t), intent(in)   :: elstack
+character(len=*), intent(out) :: string
+integer   :: i, length, j
+
+string = ""
+j = 0
+do i = 1, elstack%n_items
+   length = len_trim(elstack%data(i))
+   string(j+1:j+1) = "/"
+   j = j+1
+   string(j+1:j+length) = trim(elstack%data(i))
+   j = j + length
+enddo
+
+end subroutine get_elstack_signature
+
+end module m_wxml_elstack
Index: vendors/XMLF90/current/src/wxml/m_wxml_text.f90
===================================================================
--- vendors/XMLF90/current/src/wxml/m_wxml_text.f90	(revision 1899)
+++ vendors/XMLF90/current/src/wxml/m_wxml_text.f90	(revision 1899)
@@ -0,0 +1,73 @@
+module m_wxml_text
+!
+integer, private, parameter ::  sp = selected_real_kind(6,30)
+integer, private, parameter ::  dp = selected_real_kind(14,100)
+!
+! TODO : Add optional format parameter
+!
+private
+
+public :: str
+
+interface str
+   module procedure  str_integer,  str_real_dp, str_real_sp, &
+                     str_logical
+end interface
+private :: str_integer,  str_real_dp, str_real_sp, str_logical
+
+CONTAINS
+
+      function str_integer(int,format) result(s)
+      integer, intent(in)   :: int
+      character(len=*), intent(in), optional  :: format
+      character(len=100)    :: s
+
+      if (present(format)) then
+         write(s,format) int
+      else
+         write(s,"(i25)") int
+      endif
+      s = adjustl(s)
+      end function str_integer
+
+      function str_logical(log,format) result(s)
+      logical, intent(in)   :: log
+      character(len=*), intent(in), optional  :: format
+      character(len=100)    :: s
+
+      if (present(format)) then
+         write(s,format) log
+      else
+         write(s,"(l1)") log
+      endif
+      s = adjustl(s)
+      end function str_logical
+
+      function str_real_dp(x,format) result(s)
+      real(kind=dp), intent(in)   :: x
+      character(len=*), intent(in), optional  :: format
+      character(len=100)    :: s
+
+      if (present(format)) then
+         write(s,format) x
+      else
+         write(s,"(g22.12)") x
+      endif
+      s = adjustl(s)
+      end function str_real_dp
+
+      function str_real_sp(x,format) result(s)
+      real(kind=sp), intent(in)   :: x
+      character(len=*), intent(in), optional  :: format
+      character(len=100)    :: s
+
+      if (present(format)) then
+         write(s,format) x
+      else
+         write(s,"(g22.12)") x
+      endif
+      s = adjustl(s)
+      end function str_real_sp
+
+
+end module m_wxml_text
Index: vendors/XMLF90/current/src/xpath/Ba.xml
===================================================================
--- vendors/XMLF90/current/src/xpath/Ba.xml	(revision 1899)
+++ vendors/XMLF90/current/src/xpath/Ba.xml	(revision 1899)
@@ -0,0 +1,34 @@
+<?xml version="1.0"?>
+<atom version="0.1">
+
+  <job type="pseudopotential-generation">
+
+  <!-- Note that this configuration is ionic (+2) -->
+  <title>pg Ba with 5s as semicore, 5p in valence -- soft Vf </title>
+  <symbol>Ba</symbol>
+  <pseudo flavor="tm2" core-corrections="no" />
+  <calculation relativistic="yes" spin-polarized="no" xc="ca" />
+  <configuration ncore="9" nvalence="4" >
+     <shell n="5" l="0" occupation="2.00" rc="1.75" />
+     <shell n="5" l="1" occupation="6.00" rc="2.00" />
+     <shell n="5" l="2" occupation="0.00" rc="2.50" />
+     <shell n="4" l="3" occupation="0.00" rc="2.50" />
+  </configuration>
+  <analysis logder="3.0" />
+
+  </job>
+  <job type="pseudopotential-test">
+
+  <!-- Note that this configuration is ionic (+2) -->
+  <title>test Ba </title>
+  <symbol>Ba</symbol>
+  <calculation relativistic="yes" spin-polarized="no" xc="ca" />
+  <configuration ncore="9" nvalence="4" >
+     <shell n="5" l="0" occupation="2.00"  />
+     <shell n="5" l="1" occupation="5.00"  />
+     <shell n="5" l="2" occupation="1.00"  />
+     <shell n="4" l="3" occupation="0.00"  />
+  </configuration>
+
+  </job>
+</atom>
Index: vendors/XMLF90/current/src/xpath/Developer.Guide
===================================================================
--- vendors/XMLF90/current/src/xpath/Developer.Guide	(revision 1899)
+++ vendors/XMLF90/current/src/xpath/Developer.Guide	(revision 1899)
@@ -0,0 +1,63 @@
+Developer Notes for the XPATH-lite API
+
+This API is built on top of the more fundamental SAX one. The basic
+idea is to have a set of programable handlers that communicate among
+themselves and with the parser via module variables.
+
+A new pseudo-handler, "signal_handler", has been added to the optional
+argument list of xml_parse(). In the current implementation it just
+checks whether a stop signal has been raised by the user side of the
+program (for example, after a "begin tag" event, or after going out
+of the scope of a parent element).
+
+Since the SAX parser is stream-oriented, and XPATH searches can be
+done in any order, there are new routines to rewind the XML file and
+to synchronize the physical file reader with a previously saved point
+in the XML tree. 
+
+These tools, and the rather sophisticated path-matching routine
+provided (which allows for wildcards and the "//" construction) would
+be enough for standard use, as implemented in the routine
+"get_node". However, there is also the possibility of performing
+searches constrained to a given ancestor element ("context" searches)
+so that blocks of logically related information can be processed
+together. A context is implicitly created by a call to
+"mark_node". Contexts can be saved and "synched" to, allowing for
+repeated constrained searches (calls with relative paths). Contexts
+can even be passed to subroutines to package the parsing of common
+elements once and for all. (See for example Examples/xpath/pseudo.f90).
+This feature is nevertheless in need of a more rigorous specification:
+
+* What should be the behavior if a "mark_node" is followed by a
+  call to "get_node" with an absolute path?
+* Should there always be an "automatic rewind" to the beginning of the
+  context before any successive calls to "get_node"?
+
+
+LIMITATIONS
+
+The pcdata buffer provided by the user as a character variable could
+overflow.  Note that the parser itself uses a string of length
+MAX_PCDATA_SIZE (currently 65536) as a buffer to hold PCDATA. A
+warning is issued if there is not enough space (in the user or in the
+system buffer) to hold the data.
+
+Support for converting PCDATA characters to numerical arrays "on the
+fly" is planned for a forthcoming version.
+
+
+The coding style is that of the F subset of Fortran90. I strongly
+believe that it makes for better coding and fewer errors.
+Go to http://www.fortran.com/imagine1/ and get a feel for it. You can
+download free implementations for Linux and Windows, or get an
+inexpensive CD+Book combination to help support the project. Of course,
+F *is* Fortran, so you can always compile it with a Fortran compiler.
+
+
+
+
+
+
+
+
+
Index: vendors/XMLF90/current/src/xpath/flib_xpath.f90
===================================================================
--- vendors/XMLF90/current/src/xpath/flib_xpath.f90	(revision 1899)
+++ vendors/XMLF90/current/src/xpath/flib_xpath.f90	(revision 1899)
@@ -0,0 +1,12 @@
+module flib_xpath
+
+!
+! Stub module to gather all the XML functionality needed by the user
+! 
+use flib_sax
+use m_path
+
+public
+
+end module flib_xpath
+
Index: vendors/XMLF90/current/src/xpath/m_path.f90
===================================================================
--- vendors/XMLF90/current/src/xpath/m_path.f90	(revision 1899)
+++ vendors/XMLF90/current/src/xpath/m_path.f90	(revision 1899)
@@ -0,0 +1,617 @@
+module m_path
+!
+! XPATH-like API for XML Parsing
+! Copyright Alberto Garcia <wdpgaara@lg.ehu.es>, August 2003
+!
+use flib_sax
+
+private
+!
+public :: get_node, mark_node, enable_debug, disable_debug
+
+private :: match, process_node, get_path
+private :: begin_element, end_element, pcdata_handler, empty_element
+private :: pause_parsing
+
+!
+integer, private, save :: global_status
+integer, public, parameter :: END_OF_FILE = -1
+integer, public, parameter :: END_OF_ANCESTOR_ELEMENT = -2
+integer, public, parameter :: PCDATA_OVERFLOW = 7
+
+logical, private, save :: debug_xpath = .false.
+logical, private, save :: debug_sax = .false.
+character(len=500), private, save :: path_required
+character(len=100), private, save :: target_path ! *** Hard limit
+
+
+logical, private, save :: in_target_element = .false.
+logical, private, save :: in_pcdata_level = .false.
+
+logical, private, save :: stop_parsing = .false.
+!
+! This global variable determines whether we stop after
+! getting the initial element tag, or after digesting the full node.
+!
+logical, private, save :: full_node = .true.
+
+logical, private, save :: relative_path = .false.
+logical, private, save :: looking_for_current_element
+
+logical, private, save :: attributes_requested
+type(dictionary_t), private, save, pointer :: attributes_recovered
+
+integer, parameter, private :: MAX_PCDATA_SIZE = 65536
+logical, private, save :: pcdata_requested
+character(len=MAX_PCDATA_SIZE), private, &
+                                save :: pcdata_recovered !*** Hard
+integer, private, save :: len_pcdata
+integer, private, save :: max_len_pcdata
+
+type(xml_t), pointer, save, private :: xp
+
+CONTAINS !===========================================================
+
+!----------------------------------------------------
+! Debugging control
+!
+subroutine enable_debug(sax)
+logical, intent(in), optional :: sax
+  debug_xpath = .true.
+  debug_sax = .false.
+  if (present(sax)) then
+     debug_sax = sax
+  endif
+end subroutine enable_debug
+
+subroutine disable_debug()
+  debug_xpath = .false.
+end subroutine disable_debug
+
+!----------------------------------------------------
+! Main routines
+!---------------------------------------------------------------------
+subroutine mark_node(fxml,path,att_name,att_value,attributes,status)
+!
+! Performs a search of a given element (by path, and/or presence of
+! a given attribute and/or value of that attribute), returning optionally
+! the element's attribute dictionary, and leaving the file handle fxml'
+! ready to process the rest of the element's contents (child elements'
+! and/or pcdata).
+!
+! Side effects: it sets "ancestor_path" to the element's path'
+!
+! If the argument "path" is present and evaluates to a relative path (a
+! string not beginning with "/"), the search is interrupted after the end
+! of the "ancestor_element" set by a previous call to "mark_node".
+! If not earlier, the search ends at the end of the file.
+!
+! The status argument, if present, will hold a return value,
+! which will be:
+!
+! 0 on success,
+! negative in case of end-of-file or end-of-ancestor-element, or
+! positive in case of a malfunction
+!
+type(xml_t), intent(inout), target :: fxml
+character(len=*), intent(in), optional :: path
+character(len=*), intent(in), optional :: att_name
+character(len=*), intent(in), optional :: att_value
+type(dictionary_t), intent(out), optional :: attributes
+integer, intent(out), optional :: status
+
+
+character(len=200) :: ancestor_path ! local variable
+
+     full_node = .false.
+     call process_node(fxml, &
+                       path,att_name,att_value, &
+                       attributes, &
+                       status=status)
+     if (status == 0) then
+        call xml_mark_path(fxml,ancestor_path)
+        if (debug_xpath) print *, "Setting ancestor_path to: ", trim(ancestor_path)
+     endif
+
+end subroutine mark_node
+
+!--------------------------------------------------------------------
+subroutine get_node(fxml,path,att_name,att_value,attributes,pcdata,status)
+!
+! Performs a search of a given element (by path, and/or presence of
+! a given attribute and/or value of that attribute), returning optionally
+! the element's attribute dictionary and any PCDATA characters contained'
+! in the element's scope (but not child elements). It leaves the file handle'
+! physically and logically positioned:
+!
+! after the end of the element's start tag if 'pcdata' is not present'
+! after the end of the element's end tag if 'pcdata' is present'
+!
+! If the argument "path" is present and evaluates to a relative path (a
+! string not beginning with "/"), the search is interrupted after the end
+! of the "ancestor_element" set by a previous call to "mark_node".
+! If not earlier, the search ends at the end of the file.
+!
+! The status argument, if present, will hold a return value,
+! which will be:
+!
+! 0 on success,
+! negative in case of end-of-file or end-of-ancestor-element, or
+! positive in case of a malfunction (such as the overflow of the
+! user's pcdata buffer).'
+!
+type(xml_t), intent(inout), target :: fxml
+character(len=*), intent(in), optional :: path
+character(len=*), intent(in), optional :: att_name
+character(len=*), intent(in), optional :: att_value
+type(dictionary_t), intent(out), optional :: attributes
+character(len=*), intent(out), optional, target :: pcdata
+integer, intent(out), optional :: status
+
+     full_node = present(pcdata)
+     call process_node(fxml, &
+                       path,att_name,att_value, &
+                       attributes,pcdata, &
+                       status=status)
+
+end subroutine get_node
+!
+!--------------------------------------------------------------------
+! Workhorse routines follow
+!--------------------------------------------------------------------
+subroutine process_node(fxml,path,att_name,att_value, &
+                        attributes,pcdata,&
+                        status)
+type(xml_t), intent(inout), target :: fxml
+character(len=*), intent(in), optional :: path
+character(len=*), intent(in), optional :: att_name
+character(len=*), intent(in), optional :: att_value
+type(dictionary_t), intent(out), optional :: attributes
+character(len=*), intent(out), optional, target :: pcdata
+integer, intent(out), optional :: status
+
+logical :: path_present, att_name_present, att_value_present
+logical :: attributes_present
+
+character(len=3) :: any_path = "//*"
+character(len=200) :: local_path, ancestor_path ! *** Hard limit
+character(len=500) :: value ! *** Hard limit
+integer :: local_status
+
+type(dictionary_t) :: local_attributes
+
+global_status = 0 ! reset
+
+path_present = present(path)
+attributes_present = present(attributes)
+att_name_present = present(att_name)
+att_value_present = present(att_value)
+
+relative_path = .false.
+
+if (path_present) then
+   if (debug_xpath) print *, "SEARCHING for: ", trim(path)
+   if (path(1:1) /= "/") then
+      !
+      ! Relative path search
+      !
+      call xml_path(fxml,local_path)
+      call xml_get_path_mark(fxml,ancestor_path)
+      if (ancestor_path == "") then
+        if (debug_xpath) print *, "Relative search with null ancestor..."
+      endif
+      relative_path = .true.
+      if (debug_xpath) print *, "Relative search. ANCESTOR ELEMENT: ", &
+                             trim(ancestor_path)
+      !
+      ! Convert to absolute path
+      local_path = trim(local_path) // "/" // trim(path)
+      if (debug_xpath) print *, "Converting ", trim(path), &
+               " to absolute path: ", trim(local_path)
+   else
+      local_path = path
+   endif
+else
+   local_path = any_path
+endif
+
+looking_for_current_element = (path == ".")
+!
+! Use local_attributes, since it is in principle possible that
+! the user does not need to get back the attribute list.
+!
+do ! Loop until we satisfy the constraints
+
+   if (debug_xpath) print *, "--> Calling get_path ..."
+   call get_path(fxml,local_path,local_attributes,pcdata,local_status)
+   if (debug_xpath) print *, "-->Status after get_path: ", local_status
+   if (local_status /= 0) EXIT
+
+   if (debug_xpath) print *, "FOUND path matching: ", trim(local_path)
+
+   if (att_name_present) then
+      if (debug_xpath) print *, "Checking ", trim(att_name), " among ", &
+                          number_of_entries(local_attributes), " entries:"
+      if (debug_xpath) call print_dict(local_attributes)
+
+      if (has_key(local_attributes,att_name)) then
+
+         if (att_value_present) then
+            call get_value(local_attributes,att_name,value,local_status)
+            if (local_status /= 0) then
+               if (debug_xpath) print *, "Failed to get value of att: ", &
+                                    trim(att_name)
+               EXIT
+            endif
+
+            if (att_value == value) then
+               local_status = 0
+               if (debug_xpath) print *, "Got correct att name and value "
+               EXIT
+            else
+               if (debug_xpath) print *, "att value: ", trim(value), &
+                                   " does not match"
+               cycle ! We keep searching
+            endif
+         else ! Found att_name, and no value required
+            local_status = 0
+            if (debug_xpath) print *, "Got correct att name"
+            EXIT
+         endif
+      else ! Did not find that attribute name
+         if (debug_xpath) print *, "Att name not present"
+         cycle ! keep searching
+      endif
+   else ! Found path, and no att info required
+      local_status = 0
+      if (debug_xpath) print *, "Found correct path. No other reqs."
+      EXIT
+   endif
+
+enddo
+
+if (present(status)) then
+   status = local_status
+   if (debug_xpath) print *, "--Returning status: ", status
+endif
+
+if (attributes_present) then
+   attributes = local_attributes
+endif
+
+end subroutine process_node
+
+!--------------------------------------------------------------------
+subroutine get_path(fxml,path,attributes,pcdata,status)
+type(xml_t), intent(inout), target :: fxml
+character(len=*), intent(in) :: path
+type(dictionary_t), intent(out), optional, target :: attributes
+character(len=*), intent(out), optional, target :: pcdata
+integer, intent(out), optional :: status
+
+logical :: status_present
+
+xp => fxml
+
+path_required = path
+status_present = present(status)
+pcdata_requested = (present(pcdata))
+
+attributes_requested = (present(attributes))
+if (attributes_requested) then
+      call reset_dict(attributes)
+      attributes_recovered => attributes
+endif
+
+if (pcdata_requested) then
+!
+! Make sure we do not overstep the bounds of the supplied argument
+!
+   max_len_pcdata = min(len(pcdata),MAX_PCDATA_SIZE)
+   len_pcdata = 0
+   pcdata_recovered(1:max_len_pcdata) = ""
+   if (debug_xpath) print *, "Max length of pcdata store: ", max_len_pcdata
+endif
+
+if (looking_for_current_element) then
+   if (debug_xpath) print *, "Returning info about current element"
+
+   ! We are now in the desired element, and we have the name and
+   ! attribute list saved in xp.
+   !
+   if (attributes_requested) call xml_attributes(xp,attributes_recovered)
+   !
+   if (pcdata_requested) then
+   !
+   ! Set things up so that we can get the pcdata
+   !
+      call xml_path(xp,target_path)
+      in_target_element = .true.
+      in_pcdata_level = .true.
+   else
+      if (status_present) status = 0
+      RETURN ! We are done
+   endif
+else
+   target_path = ""
+   in_target_element = .false.
+   in_pcdata_level = .false.
+endif
+
+stop_parsing = .false.
+
+call xml_parse(fxml, &
+               begin_element_handler = begin_element , &
+               end_element_handler = end_element, &
+               pcdata_chunk_handler = pcdata_handler, &
+               verbose = debug_sax, signal_handler=pause_parsing, &
+               empty_element_handler = empty_element)
+
+if (eof_xmlfile(fxml)) then
+   global_status = END_OF_FILE
+   if (debug_xpath) print *, "Found end of file"
+   if (pcdata_requested) pcdata = ""
+else if (global_status == END_OF_ANCESTOR_ELEMENT) then
+   if (debug_xpath) print *, "Found end of ancestor element"
+   if (pcdata_requested) pcdata = ""
+else
+   if (debug_xpath) print *, "Parser found candidate element"
+   if (pcdata_requested) then
+      pcdata = pcdata_recovered(1:len_pcdata)
+      if (debug_xpath) print *, "PCDATA recovered: ", pcdata_recovered(1:len_pcdata)
+   endif
+endif
+if (global_status > 0) then
+   if (debug_xpath) print *, "Something went slightly wrong. Status > 0"
+endif
+!
+if (present(status)) status = global_status
+
+
+end subroutine get_path
+
+!==================================================================
+subroutine begin_element(name,attributes)
+character(len=*), intent(in) :: name
+type(dictionary_t), intent(in) :: attributes
+
+character(len=1000) :: path ! *** Hard limit
+
+call xml_path(xp,path)
+if (debug_xpath) print *, " begin_element ::: PATH: " , trim(path)
+if (debug_xpath) print *, "path: ", trim(path), " req: ", trim(path_required)
+if (match(path,path_required)) then
+      if (debug_xpath) print *, " Match path: " , trim(path)
+      in_target_element = .true.
+      target_path = path
+      in_pcdata_level = .true.
+      if (debug_xpath) print *, "In element name: " , name
+      if (attributes_requested) attributes_recovered = attributes
+      ! stop parsing
+      if (debug_xpath) print *, "full_node: ", full_node
+      if (.not. full_node) then
+         if (debug_xpath) print *, "Stopping parsing after initial tag"
+         stop_parsing = .true.
+      endif
+else
+   !
+   ! If we are at the pcdata level and we enter another element,
+   ! we must not read pcdata
+   !
+   if (in_pcdata_level) in_pcdata_level = .false.
+endif
+
+end subroutine begin_element
+!------------------------------------------------------------
+subroutine end_element(name)
+character(len=*), intent(in) :: name
+
+character(len=300) :: path ! *** Hard limit
+character(len=300) :: left_path ! *** Hard limit
+character(len=300) :: ancestor_path ! *** Hard limit
+!
+
+call xml_path(xp,path) ! path *after* leaving element
+left_path = trim(path) // "/" // trim(name)
+
+if (in_target_element) then
+   if (path == target_path) then
+      !
+      ! We are back to pcdata level after visiting child elements
+      !
+      in_pcdata_level = .true.
+
+   else if (left_path == target_path) then
+
+      ! We stop the parsing at the end of the element
+      !
+      if (debug_xpath) print *, "Exiting target element: ", trim(target_path)
+      in_target_element = .false.
+      in_pcdata_level = .false.
+      if (debug_xpath) print *, "Stopping parsing after end of target element"
+      stop_parsing = .true.
+   endif
+
+else if (relative_path) then
+   !
+   ! Check in case we go out of ancestor element
+   !
+   call xml_get_path_mark(xp,ancestor_path)
+   if (match(left_path,ancestor_path)) then
+      !
+      ! We are leaving the ancestor element
+      !
+      if (debug_xpath) print *, "Relative search. End of element: ", name
+      if (debug_xpath) print *, "Leaving Path: ", trim(left_path)
+      if (debug_xpath) print *, "Ancestor Path: ", trim(ancestor_path)
+      if (debug_xpath) print *, "Stopping parsing after end of ancestor element"
+
+      stop_parsing = .true.
+      global_status = END_OF_ANCESTOR_ELEMENT
+   endif
+endif
+
+end subroutine end_element
+
+!------------------------------------------------------------
+subroutine empty_element(name,attributes)
+character(len=*), intent(in) :: name
+type(dictionary_t), intent(in) :: attributes
+
+character(len=300) :: path ! *** Hard limit
+
+call xml_path(xp,path)
+if (debug_xpath) print *, " empty_element ::: PATH: " , trim(path)
+if (debug_xpath) print *, "path: ", trim(path), " req: ", trim(path_required)
+if (match(path,path_required)) then
+      if (debug_xpath) print *, " Match path: " , trim(path)
+      if (debug_xpath) print *, "In (empty) element name: " , name
+      if (attributes_requested) attributes_recovered = attributes
+      ! stop parsing
+      stop_parsing = .true.
+      if (debug_xpath) print *, "Stopping parsing after empty tag"
+      if (debug_xpath) print *, "full_node: ", full_node
+      if (full_node) then
+         if (debug_xpath) print *, "*Warning: full_node requested, empty tag found"
+      endif
+endif
+!
+! There is no logic for ancestor element handling, as by definition
+! an emtpy element cannot have children.
+!
+end subroutine empty_element
+
+!-----------------------------------------------------------
+subroutine pcdata_handler(chunk)
+character(len=*), intent(in) :: chunk
+
+integer :: len_chunk
+
+if (in_pcdata_level) then
+   !
+   ! Build pcdata_recovered chunk by chunk, until it overflows
+   !
+   if (pcdata_requested) then
+      if (debug_xpath) print *, "Found chunk of pcdata: ", chunk
+      len_chunk = len(chunk)
+      if ((len_pcdata + len_chunk) > max_len_pcdata) then
+         !
+         if (debug_xpath) print *, "***Pcdata Overflow "
+         global_status = PCDATA_OVERFLOW
+         stop_parsing = .true.
+         return
+      endif
+      pcdata_recovered(len_pcdata+1:len_pcdata+len_chunk) = chunk
+      len_pcdata = len_pcdata + len_chunk
+   endif
+endif
+
+end subroutine pcdata_handler
+!--------------------------------------------------------------------
+
+subroutine pause_parsing(res)
+logical, intent(out) :: res
+
+res = stop_parsing
+
+end subroutine pause_parsing
+!--------------------------------------------------------------------
+
+recursive function match(p,ptarget) result(res_match)
+character(len=*), intent(in) :: p
+character(len=*), intent(in) :: ptarget
+logical :: res_match
+
+!
+! Checks whether a given XML path matches the target path ptarget
+! Only absolute paths are considered.
+!
+! Examples of target paths:
+!
+! /pseudo/vps/radfunc [1]
+! //radfunc/data
+! //data
+! //*/vps/data
+! //job//data      
+! //*
+!
+integer :: len_target, len_path, pos_target, pos_path
+character(len=100) :: anchor_leaf ! *** Hard limit
+
+res_match = .false.
+
+if (trim(p) == trim(ptarget)) then
+   res_match = .true.
+   return
+
+else if (ptarget == "/") then
+   ! We process // in the middle below
+
+   res_match = .true.
+   return
+
+else ! We get the extreme elements
+
+   len_target = len_trim(ptarget)
+   len_path = len_trim(p)
+   pos_target = index(ptarget,"/",back=.true.)
+   pos_path = index(p,"/",back=.true.)
+
+   if (pos_target == len_target) then ! // in the middle...
+      ! Get leaf further up
+      search_anchor : do
+         pos_target = index(ptarget(1:len_target-1),"/",back=.true.)
+         if (pos_target == 1) then ! Target begins by /.// 
+            res_match = .true.
+            return
+         endif
+         anchor_leaf = ptarget(pos_target:len_target-1)
+         if (anchor_leaf == "/.") then ! keep searching
+            len_target = pos_target
+            cycle search_anchor
+         else
+            exit search_anchor
+         endif
+      enddo search_anchor
+
+      ! Note that the anchor includes the leading /
+      ! Now we search for that anchor in the candidate path
+      !
+      pos_path = index(p(1:len_path),trim(anchor_leaf),back=.true.)
+      if (pos_path /= 0) then
+
+         ! Found anchor. Continue further up.
+         !
+         res_match = match(p(1:pos_path-1),ptarget(1:pos_target-1))
+      endif
+
+   else if (ptarget(pos_target+1:len_target) == ".") then
+
+      ! A dot is a dummy. Continue further up in target path.
+      !
+      res_match = match(p(1:len_path),ptarget(1:pos_target-1))
+
+   else if (ptarget(pos_target+1:len_target) == "*") then
+
+      if (len_path == pos_path) then
+         RETURN ! empty path element
+      endif
+
+      ! A star matches any non-empty leaf. Continue further up.
+      !
+      res_match = match(p(1:pos_path-1),ptarget(1:pos_target-1))
+
+   else if (p(pos_path+1:len_path) == &
+             ptarget(pos_target+1:len_target)) then
+
+      ! Leafs are equal. Continue further up.
+      !
+      res_match = match(p(1:pos_path-1),ptarget(1:pos_target-1))
+
+   endif
+
+endif
+
+end function match
+
+end module m_path
Index: vendors/XMLF90/current/src/xpath/m_path_orig.f90
===================================================================
--- vendors/XMLF90/current/src/xpath/m_path_orig.f90	(revision 1899)
+++ vendors/XMLF90/current/src/xpath/m_path_orig.f90	(revision 1899)
@@ -0,0 +1,629 @@
+module m_path
+!
+! XPATH-like API for XML Parsing
+! Copyright Alberto Garcia <wdpgaara@lg.ehu.es>, August 2003
+!
+use flib_sax
+
+private
+!
+public :: get_node, mark_node, enable_debug, disable_debug
+
+private :: match, process_node, get_path
+private :: begin_element, end_element, pcdata_handler, empty_element
+private :: pause_parsing
+
+!
+integer, private, save                   :: global_status
+integer, public, parameter               :: END_OF_FILE  = -1
+integer, public, parameter               :: END_OF_ANCESTOR_ELEMENT = -2
+integer, public, parameter               :: PCDATA_OVERFLOW = 7
+
+logical, private, save                   :: debug_xpath = .false.
+logical, private, save                   :: debug_sax = .false.
+character(len=500), private, save        :: path_required
+character(len=100), private, save        :: target_path      ! *** Hard limit
+
+
+logical, private, save                   :: in_target_element = .false.
+logical, private, save                   :: in_pcdata_level = .false.
+
+logical, private, save                   :: stop_parsing = .false.
+!
+! This global variable determines whether we stop after
+! getting the initial element tag, or after digesting the full node.
+!
+logical, private, save                   :: full_node = .true.
+
+logical, private, save                   :: relative_path = .false.
+logical, private, save                   :: looking_for_current_element
+                             
+logical, private, save                        :: attributes_requested
+type(dictionary_t), private, save, pointer    :: attributes_recovered
+
+integer, parameter, private                   :: MAX_PCDATA_SIZE = 65536
+logical, private, save                        :: pcdata_requested 
+character(len=MAX_PCDATA_SIZE), private, &
+                                save          :: pcdata_recovered !*** Hard 
+integer, private, save                        :: len_pcdata
+integer, private, save                        :: max_len_pcdata
+
+type(xml_t), pointer, save, private           :: xp
+
+CONTAINS !===========================================================
+
+!----------------------------------------------------
+! Debugging control
+!
+subroutine enable_debug(sax)
+logical, intent(in), optional  :: sax
+  debug_xpath = .true.
+  debug_sax = .false.
+  if (present(sax)) then
+     debug_sax = sax
+  endif
+end subroutine enable_debug
+
+subroutine disable_debug()
+  debug_xpath = .false.
+end subroutine disable_debug
+
+!----------------------------------------------------
+! Main routines
+!---------------------------------------------------------------------
+subroutine mark_node(fxml,path,att_name,att_value,attributes,status)
+!
+! Performs a search of a given element (by path, and/or presence of
+! a given attribute and/or value of that attribute), returning optionally
+! the element's attribute dictionary, and leaving the file handle fxml
+! ready to process the rest of the element's contents (child elements
+! and/or pcdata).
+!
+! Side effects: it sets "ancestor_path" to the element's path
+!
+! If the argument "path" is present and evaluates to a relative path (a
+! string not beginning with "/"), the search is interrupted after the end
+! of the "ancestor_element" set by a previous call to "mark_node".
+! If not earlier, the search ends at the end of the file.
+!
+! The status argument, if present, will hold a return value, 
+! which will be:
+!
+!   0 on success,
+!   negative in case of end-of-file or end-of-ancestor-element, or 
+!   positive in case of a malfunction 
+!
+type(xml_t), intent(inout), target           :: fxml
+character(len=*), intent(in), optional       :: path
+character(len=*), intent(in), optional       :: att_name
+character(len=*), intent(in), optional       :: att_value
+type(dictionary_t), intent(out), optional    :: attributes
+integer, intent(out), optional               :: status
+
+
+character(len=200)         :: ancestor_path           ! local variable
+
+     full_node = .false.
+     call process_node(fxml,                    &
+                       path,att_name,att_value, &
+                       attributes,              &
+                       status=status)
+     if (status == 0) then
+        call xml_mark_path(fxml,ancestor_path)
+        if (debug_xpath) print *, "Setting ancestor_path to: ", trim(ancestor_path)
+     endif
+
+end subroutine mark_node
+
+!--------------------------------------------------------------------
+subroutine get_node(fxml,path,att_name,att_value,attributes,pcdata,status)
+!
+! Performs a search of a given element (by path, and/or presence of
+! a given attribute and/or value of that attribute), returning optionally
+! the element's attribute dictionary and any PCDATA characters contained
+! in the element's scope (but not child elements). It leaves the file handle
+! physically and logically positioned:
+!
+!     after the end of the element's start tag if 'pcdata' is not present
+!     after the end of the element's end tag if 'pcdata' is present
+!
+! If the argument "path" is present and evaluates to a relative path (a
+! string not beginning with "/"), the search is interrupted after the end
+! of the "ancestor_element" set by a previous call to "mark_node".
+! If not earlier, the search ends at the end of the file.
+!
+! The status argument, if present, will hold a return value, 
+! which will be:
+!
+!   0 on success,
+!   negative in case of end-of-file or end-of-ancestor-element, or 
+!   positive in case of a malfunction (such as the overflow of the 
+!   user's pcdata buffer).
+!
+type(xml_t), intent(inout), target           :: fxml
+character(len=*), intent(in), optional       :: path
+character(len=*), intent(in), optional       :: att_name
+character(len=*), intent(in), optional       :: att_value
+type(dictionary_t), intent(out), optional    :: attributes
+character(len=*), intent(out), optional, target      :: pcdata
+integer, intent(out), optional               :: status
+
+     full_node = present(pcdata)
+     call process_node(fxml,                    &
+                       path,att_name,att_value, &
+                       attributes,pcdata,       &
+                       status=status)
+
+end subroutine get_node
+!
+!--------------------------------------------------------------------
+! Workhorse routines follow
+!--------------------------------------------------------------------
+subroutine process_node(fxml,path,att_name,att_value, &
+                        attributes,pcdata,&
+                        status)
+type(xml_t), intent(inout), target           :: fxml
+character(len=*), intent(in), optional       :: path
+character(len=*), intent(in), optional       :: att_name
+character(len=*), intent(in), optional       :: att_value
+type(dictionary_t), intent(out), optional    :: attributes
+character(len=*), intent(out), optional, target      :: pcdata
+integer, intent(out), optional               :: status
+
+logical :: path_present, att_name_present, att_value_present
+logical :: attributes_present
+
+character(len=3)   :: any_path  = "//*"
+character(len=200) :: local_path, ancestor_path      ! *** Hard limit
+character(len=500) :: value                          ! *** Hard limit
+integer            :: local_status
+
+type(dictionary_t) :: local_attributes
+
+global_status = 0           ! reset
+
+path_present = present(path)
+attributes_present = present(attributes)
+att_name_present = present(att_name)
+att_value_present = present(att_value)
+
+relative_path = .false.
+
+if (path_present) then
+   if (debug_xpath) print *, "SEARCHING for: ", trim(path)
+   if (path(1:1) /= "/") then
+      !
+      ! Relative path search
+      !
+      call xml_path(fxml,local_path)
+      call xml_get_path_mark(fxml,ancestor_path)
+      if (ancestor_path == "") then
+        if (debug_xpath) print *, "Relative search with null ancestor..."
+      endif
+      relative_path = .true.    
+      if (debug_xpath) print *, "Relative search. ANCESTOR ELEMENT: ", &
+                             trim(ancestor_path)
+      !
+      ! Convert to absolute path
+      local_path = trim(local_path) // "/" // trim(path)
+      if (debug_xpath) print *, "Converting ", trim(path), &
+               " to absolute path: ", trim(local_path)
+   else
+      local_path = path
+   endif
+else
+   local_path = any_path
+endif
+
+looking_for_current_element = (path == ".")
+!
+! Use local_attributes, since it is in principle possible that
+! the user does not need to get back the attribute list.
+!
+do ! Loop until we satisfy the constraints 
+   
+   if (debug_xpath) print *, "--> Calling get_path ..."
+   call get_path(fxml,local_path,local_attributes,pcdata,local_status)
+   if (debug_xpath) print *, "-->Status after get_path: ", local_status
+   if (local_status /= 0)  EXIT
+
+   if (debug_xpath) print *, "FOUND path matching: ", trim(local_path)
+
+   if (att_name_present) then
+      if (debug_xpath) print *, "Checking ", trim(att_name), " among ", &
+                          number_of_entries(local_attributes), " entries:"
+      if (debug_xpath) call print_dict(local_attributes)
+
+      if (has_key(local_attributes,att_name)) then
+
+         if (att_value_present) then
+            call get_value(local_attributes,att_name,value,local_status)
+            if (local_status /= 0) then
+               if (debug_xpath) print *, "Failed to get value of att: ", &
+                                    trim(att_name)
+               EXIT
+            endif
+
+            if (att_value == value)  then
+               local_status = 0
+               if (debug_xpath) print *, "Got correct att name and value "
+               EXIT
+            else
+               if (debug_xpath) print *, "att value: ", trim(value), &
+                                   " does not match"
+               cycle        ! We keep searching
+            endif
+         else           ! Found att_name, and no value required
+            local_status = 0
+            if (debug_xpath) print *, "Got correct att name"
+            EXIT
+         endif
+      else              ! Did not find that attribute name
+         if (debug_xpath) print *, "Att name not present"
+         cycle          ! keep searching
+      endif
+   else                 ! Found path, and no att info required
+      local_status = 0
+      if (debug_xpath) print *, "Found correct path. No other reqs."
+      EXIT
+   endif
+   
+enddo
+
+if (present(status)) then
+   status = local_status
+   if (debug_xpath) print *, "--Returning status: ", status
+endif
+
+if (attributes_present) then
+   attributes = local_attributes
+endif
+
+end subroutine process_node
+
+!--------------------------------------------------------------------
+subroutine get_path(fxml,path,attributes,pcdata,status)
+type(xml_t), intent(inout), target           :: fxml
+character(len=*), intent(in)                 :: path
+type(dictionary_t), intent(out), optional, target    :: attributes
+character(len=*), intent(out), optional, target      :: pcdata
+integer, intent(out), optional                       :: status  
+
+logical            :: status_present
+
+xp => fxml
+
+path_required = path
+status_present = present(status)
+pcdata_requested = (present(pcdata))
+
+attributes_requested = (present(attributes))
+if (attributes_requested) then
+      call reset_dict(attributes)
+      attributes_recovered => attributes
+endif
+
+if (pcdata_requested) then
+!
+!  Make sure we do not overstep the bounds of the supplied argument
+!
+   max_len_pcdata = min(len(pcdata),MAX_PCDATA_SIZE)
+   len_pcdata = 0
+   pcdata_recovered(1:max_len_pcdata) = ""
+   if (debug_xpath) print *, "Max length of pcdata store: ", max_len_pcdata
+endif
+
+if (looking_for_current_element) then
+   if (debug_xpath) print *, "Returning info about current element"
+
+   ! We are now in the desired element, and we have the name and
+   ! attribute list saved in xp.
+   !
+   if (attributes_requested) call xml_attributes(xp,attributes_recovered)
+   !
+   if (pcdata_requested) then
+   !
+   ! Set things up so that we can get the pcdata
+   !
+      call xml_path(xp,target_path)
+      in_target_element = .true.
+      in_pcdata_level = .true.
+   else
+      if (status_present) status = 0
+      RETURN              ! We are done
+   endif
+else
+   target_path = ""
+   in_target_element = .false.
+   in_pcdata_level = .false.
+endif
+
+stop_parsing = .false.
+
+call xml_parse(fxml,  &
+               begin_element_handler = begin_element , &
+               end_element_handler = end_element,  &
+               pcdata_chunk_handler = pcdata_handler, &
+               verbose = debug_sax, signal_handler=pause_parsing, &
+               empty_element_handler = empty_element)
+
+if (eof_xmlfile(fxml)) then
+   global_status = END_OF_FILE
+   if (debug_xpath) print *, "Found end of file"
+   if (pcdata_requested) pcdata = ""
+else if (global_status == END_OF_ANCESTOR_ELEMENT) then
+   if (debug_xpath) print *, "Found end of ancestor element"
+   if (pcdata_requested) pcdata = ""
+else
+   if (debug_xpath) print *, "Parser found candidate element"
+   if (pcdata_requested) then
+      pcdata = pcdata_recovered(1:len_pcdata)
+      if (debug_xpath) print *, "PCDATA recovered: ", pcdata_recovered(1:len_pcdata)
+   endif
+endif
+if (global_status > 0) then
+   if (debug_xpath) print *, "Something went slightly wrong. Status > 0"
+endif
+!
+if (present(status)) status = global_status  
+
+
+end subroutine get_path
+
+!==================================================================
+subroutine begin_element(name,attributes)
+character(len=*), intent(in)   :: name
+type(dictionary_t), intent(in) :: attributes
+
+character(len=1000)   :: path              ! *** Hard limit
+
+call xml_path(xp,path)
+if (debug_xpath) print *, " begin_element ::: PATH: " ,  trim(path)
+if (debug_xpath) print *, "path: ", trim(path), " req: ", trim(path_required)
+if (match(path,path_required)) then
+      if (debug_xpath) print *, " Match path: " ,  trim(path)
+      in_target_element = .true.
+      target_path = path
+      in_pcdata_level = .true.
+      if (debug_xpath) print *, "In element name: " , name
+      if (attributes_requested) attributes_recovered = attributes
+      ! stop parsing
+      if (debug_xpath) print *, "full_node: ", full_node
+      if (.not. full_node)  then
+         if (debug_xpath) print *, "Stopping parsing after initial tag"
+         stop_parsing = .true.
+      endif
+else 
+   !
+   ! If we are at the pcdata level and we enter another element, 
+   ! we must not read pcdata
+   !
+   if (in_pcdata_level)   in_pcdata_level = .false.
+endif
+
+end subroutine begin_element
+!------------------------------------------------------------
+subroutine end_element(name)
+character(len=*), intent(in)   :: name
+
+character(len=300)   :: path             ! *** Hard limit
+character(len=300)   :: left_path        ! *** Hard limit
+character(len=300)   :: ancestor_path    ! *** Hard limit
+!
+
+call xml_path(xp,path)   ! path *after* leaving element
+left_path = trim(path) // "/" // trim(name)
+
+if (in_target_element) then
+   if (path == target_path) then
+      ! 
+      ! We are back to pcdata level after visiting child elements
+      !
+      in_pcdata_level = .true.
+
+   else  if (left_path == target_path) then
+
+      ! We stop the parsing at the end of the element
+      !
+      if (debug_xpath) print *, "Exiting target element: ", trim(target_path)
+      in_target_element = .false.
+      in_pcdata_level = .false.
+      if (debug_xpath) print *, "Stopping parsing after end of target element"
+      stop_parsing = .true.
+   endif
+   
+else if (relative_path) then
+   !
+   ! Check in case we go out of ancestor element
+   !
+   call xml_get_path_mark(xp,ancestor_path)
+   if (match(left_path,ancestor_path)) then
+      !
+      ! We are leaving the ancestor element
+      !
+      if (debug_xpath) print *, "Relative search. End of element: ", name
+      if (debug_xpath) print *, "Leaving Path: ", trim(left_path)
+      if (debug_xpath) print *, "Ancestor Path: ", trim(ancestor_path)
+      if (debug_xpath) print *, "Stopping parsing after end of ancestor element"
+    
+      stop_parsing = .true.
+      global_status = END_OF_ANCESTOR_ELEMENT
+   endif
+endif
+  
+end subroutine end_element
+
+!------------------------------------------------------------
+subroutine empty_element(name,attributes)
+character(len=*), intent(in)   :: name
+type(dictionary_t), intent(in) :: attributes
+
+character(len=300)   :: path              ! *** Hard limit
+
+call xml_path(xp,path)
+if (debug_xpath) print *, " empty_element ::: PATH: " ,  trim(path)
+if (debug_xpath) print *, "path: ", trim(path), " req: ", trim(path_required)
+if (match(path,path_required)) then
+      if (debug_xpath) print *, " Match path: " ,  trim(path)
+      if (debug_xpath) print *, "In (empty) element name: " , name
+      if (attributes_requested) attributes_recovered = attributes
+      ! stop parsing
+      stop_parsing = .true.
+      if (debug_xpath) print *, "Stopping parsing after empty tag"
+      if (debug_xpath) print *, "full_node: ", full_node
+      if (full_node)  then
+         if (debug_xpath) print *, "*Warning: full_node requested, empty tag found"
+      endif
+endif
+!
+! There is no logic for ancestor element handling, as by definition
+! an emtpy element cannot have children.
+!
+end subroutine empty_element
+
+!-----------------------------------------------------------
+subroutine pcdata_handler(chunk)
+character(len=*), intent(in)   :: chunk
+
+integer  :: len_chunk
+
+if (in_pcdata_level) then
+   ! 
+   ! Build pcdata_recovered chunk by chunk, until it overflows
+   !
+   if (pcdata_requested) then
+      if (debug_xpath) print *, "Found chunk of pcdata: ", chunk
+      len_chunk = len(chunk)
+      if ((len_pcdata + len_chunk) > max_len_pcdata) then
+         !
+         if (debug_xpath) print *, "***Pcdata Overflow "
+         global_status = PCDATA_OVERFLOW
+         stop_parsing = .true.
+         return
+      endif
+      pcdata_recovered(len_pcdata+1:len_pcdata+len_chunk) = chunk
+      len_pcdata = len_pcdata + len_chunk
+   endif
+endif
+
+end subroutine pcdata_handler
+!--------------------------------------------------------------------
+
+subroutine pause_parsing(res)
+logical, intent(out)  :: res
+
+res =  stop_parsing
+
+end subroutine pause_parsing
+!--------------------------------------------------------------------
+
+recursive function match(p,ptarget) result(res_match)
+character(len=*), intent(in)  :: p
+character(len=*), intent(in)  :: ptarget
+logical                       :: res_match
+
+!
+! Checks whether a given XML path matches the target path ptarget
+! Only absolute paths are considered.
+!
+! Examples of target paths:
+!
+!           /pseudo/vps/radfunc      [1]
+!           //radfunc/data
+!           //data
+!           //*/vps/data
+!           //job//data      
+!           //*
+!
+integer  :: len_target, len_path, pos_target, pos_path
+character(len=100)   :: anchor_leaf                     ! *** Hard limit
+
+res_match = .false.       
+
+if (trim(p) == trim(ptarget)) then
+   res_match = .true.
+   return
+
+else if (ptarget == "/") then
+   ! We  process // in the middle below
+
+   res_match = .true.
+   return
+
+else              ! We get the extreme elements
+
+   len_target = len_trim(ptarget)
+   len_path = len_trim(p)
+   pos_target = index(ptarget,"/",back=.true.)
+   pos_path = index(p,"/",back=.true.)
+
+   if (pos_target == len_target) then   ! // in the middle...
+      ! Get leaf further up
+      search_anchor : do 
+         pos_target = index(ptarget(1:len_target-1),"/",back=.true.)
+         if (pos_target == 1) then  ! Target begins by /.// 
+            res_match = .true.
+            return
+         endif
+         anchor_leaf = ptarget(pos_target:len_target-1)
+         if (anchor_leaf == "/.") then  ! keep searching
+            len_target = pos_target 
+            cycle search_anchor
+         else
+            exit search_anchor
+         endif
+      enddo search_anchor
+
+      ! Note that the anchor includes the leading /
+      ! Now we search for that anchor in the candidate path
+      !
+      pos_path = index(p(1:len_path),trim(anchor_leaf),back=.true.)
+      if (pos_path /= 0) then
+
+         ! Found anchor. Continue further up.
+         !
+         res_match = match(p(1:pos_path-1),ptarget(1:pos_target-1))
+      endif
+
+   else if  (ptarget(pos_target+1:len_target) == ".") then
+
+      ! A dot is a dummy. Continue further up in target path.
+      !
+      res_match = match(p(1:len_path),ptarget(1:pos_target-1))
+
+   else if  (ptarget(pos_target+1:len_target) == "*") then
+
+      if (len_path == pos_path) then
+         RETURN   ! empty path element
+      endif
+
+      ! A star matches any non-empty leaf. Continue further up.
+      !
+      res_match = match(p(1:pos_path-1),ptarget(1:pos_target-1))
+
+   else  if (p(pos_path+1:len_path) ==  &
+             ptarget(pos_target+1:len_target)) then 
+
+      ! Leafs are equal. Continue further up.
+      !
+      res_match = match(p(1:pos_path-1),ptarget(1:pos_target-1))
+
+   endif
+
+endif
+
+end function match
+
+end module m_path
+
+
+
+
+
+
+
+
+
+
+
+
Index: vendors/XMLF90/current/src/xpath/match_tester.f90
===================================================================
--- vendors/XMLF90/current/src/xpath/match_tester.f90	(revision 1899)
+++ vendors/XMLF90/current/src/xpath/match_tester.f90	(revision 1899)
@@ -0,0 +1,148 @@
+program m
+
+character(len=100) :: p, t
+logical            :: result
+
+do
+   write(unit=*,fmt="(a)",advance="no")  "Target path: "
+   read(unit=*,fmt="(a)") t
+   write(unit=*,fmt="(a)",advance="no")  "Path: "
+   read(unit=*,fmt="(a)") p
+
+   result = match(p,t)
+   print *, "Result: ", result
+
+enddo
+
+
+CONTAINS
+
+recursive function match(p,ptarget) result(res_match)
+character(len=*), intent(in)  :: p
+character(len=*), intent(in)  :: ptarget
+logical                       :: res_match
+
+!
+! Checks whether a given XML path matches the target path ptarget
+! Only absolute paths are considered.
+!
+! Examples of target paths:
+!
+!           /pseudo/vps/radfunc      [1]
+!           //radfunc/data
+!           //data
+!           //*/vps/data
+!           //job//data      
+!           //*
+!
+integer  :: len_target, len_path, pos_target, pos_path
+character(len=100)   :: anchor_leaf
+
+res_match = .false.       
+
+ print *, ":testing: "
+ print *, "          ", trim(p)
+ print *, " against: ", trim(ptarget)
+ print *, "-----------------------------------------"
+
+if (trim(p) == trim(ptarget)) then
+   res_match = .true.
+   print *, "outright equality"
+   return
+
+else if (ptarget == "/") then
+   ! We  process // in the middle below
+
+   res_match = .true.
+   print *, "target begins by //"
+   return
+
+else              ! We get the extreme elements
+
+   len_target = len_trim(ptarget)
+   len_path = len_trim(p)
+   pos_target = index(ptarget,"/",back=.true.)
+   pos_path = index(p,"/",back=.true.)
+
+   print *, " Path leaf: ", p(pos_path+1:len_path) 
+   print *, " Target leaf: ", ptarget(pos_target+1:len_target)
+
+   if (pos_target == len_target) then   ! // in the middle...
+      ! Get leaf further up
+      search_anchor : do 
+         print *, "looking for anchor in: ", ptarget(1:len_target-1)
+         print *, "press enter"
+         read *
+         pos_target = index(ptarget(1:len_target-1),"/",back=.true.)
+         print *, "pos_target in anchor search: ", pos_target
+         if (pos_target == 1) then  ! Target begins by /.// 
+            res_match = .true.
+            print *, "reached initial /.// in target"
+            return
+         endif
+         anchor_leaf = ptarget(pos_target:len_target-1)
+         print *, " Anchor leaf: ", trim(anchor_leaf)
+         if (anchor_leaf == "/.") then  ! keep searching
+            len_target = pos_target 
+            cycle search_anchor
+         else
+            exit search_anchor
+         endif
+      enddo search_anchor
+
+      ! Note that the anchor includes the leading /
+      ! Now we search for that anchor in the candidate path
+      !
+      print *, " Searching anchor in : ", trim(p(1:len_path))
+      pos_path = index(p(1:len_path),trim(anchor_leaf),back=.true.)
+      if (pos_path /= 0) then
+
+         ! Found anchor. Continue further up.
+         !
+         res_match = match(p(1:pos_path-1),ptarget(1:pos_target-1))
+      endif
+
+   else if  (ptarget(pos_target+1:len_target) == ".") then
+
+      ! A dot is a dummy. Continue further up.
+      !
+      res_match = match(p(1:len_path),ptarget(1:pos_target-1))
+
+   else if  (ptarget(pos_target+1:len_target) == "*") then
+
+      if (len_path == pos_path) then
+         print *, "empty element. len_path, pos_path: ", len_path, pos_path
+         RETURN   ! empty path element
+      endif
+
+      ! A star matches any non-empty leaf. Continue further up.
+      !
+      res_match = match(p(1:pos_path-1),ptarget(1:pos_target-1))
+
+   else  if (p(pos_path+1:len_path) ==  &
+             ptarget(pos_target+1:len_target)) then 
+
+      ! Leafs are equal. Continue further up.
+      !
+      res_match = match(p(1:pos_path-1),ptarget(1:pos_target-1))
+
+   endif
+
+endif
+
+end function match
+
+end program m
+
+
+
+
+
+
+
+
+
+
+
+
+
