diff --git a/src/DEPENDENCIES b/src/DEPENDENCIES index f50be249cc..2a0bd27635 100644 --- a/src/DEPENDENCIES +++ b/src/DEPENDENCIES @@ -84,10 +84,10 @@ input_xml.o: mesh_header.o input_xml.o: output.o input_xml.o: string.o input_xml.o: tally_header.o -input_xml.o: xml_geometry.o -input_xml.o: xml_materials.o -input_xml.o: xml_settings.o -input_xml.o: xml_tallies.o +input_xml.o: xml-fortran/templates/geometry_t.o +input_xml.o: xml-fortran/templates/materials_t.o +input_xml.o: xml-fortran/templates/settings_t.o +input_xml.o: xml-fortran/templates/tallies_t.o interpolation.o: constants.o interpolation.o: error.o diff --git a/src/Makefile b/src/Makefile index 91cd5b68cd..57b8758dfb 100644 --- a/src/Makefile +++ b/src/Makefile @@ -1,5 +1,10 @@ program = openmc +templates = $(wildcard xml-fortran/templates/*.o) +xml_fort = xml-fortran/xmlparse.o \ + xml-fortran/read_xml_primitives.o \ + xml-fortran/write_xml_primitives.o + #=============================================================================== # Object Files #=============================================================================== @@ -26,16 +31,16 @@ USE_COARRAY = no ifeq ($(COMPILER),intel) F90 = ifort - F90FLAGS = -I../lib/intel -fpp -warn - LDFLAGS = -L../lib/intel -lxmlparse + F90FLAGS = -Ixml-fortran -Ixml-fortran/templates -fpp -warn + LDFLAGS = endif # GNU Fortran compiler options ifeq ($(COMPILER),gfortran) F90 = gfortran - F90FLAGS = -I../lib/gfortran -cpp -Wall - LDFLAGS = -L../lib/gfortran -lxmlparse + F90FLAGS = -cpp -Wall + LDFLAGS = endif # Set compiler flags for debugging @@ -93,9 +98,12 @@ endif # Targets #=============================================================================== -all: $(program) +all: xml-fortran $(program) +xml-fortran: + cd xml-fortran; make + cd xml-fortran/templates; make $(program): $(objects) - $(F90) $(objects) -o $@ $(LDFLAGS) + $(F90) $(objects) $(templates) $(xml_fort) -o $@ $(LDFLAGS) clean: @rm -f *.o *.mod $(program) neat: @@ -106,7 +114,7 @@ neat: #=============================================================================== .SUFFIXES: .f90 .o -.PHONY: all clean neat +.PHONY: all clean neat xml-fortran %.o: %.f90 $(F90) $(F90FLAGS) -c $< diff --git a/src/OBJECTS b/src/OBJECTS index 4d43bafd8c..536508d01e 100644 --- a/src/OBJECTS +++ b/src/OBJECTS @@ -32,8 +32,4 @@ source_header.o \ string.o \ tally.o \ tally_header.o \ -timing.o \ -xml_geometry.o \ -xml_materials.o \ -xml_settings.o \ -xml_tallies.o \ No newline at end of file +timing.o \ No newline at end of file diff --git a/src/xml-fortran/Makefile b/src/xml-fortran/Makefile new file mode 100644 index 0000000000..8be256b20c --- /dev/null +++ b/src/xml-fortran/Makefile @@ -0,0 +1,72 @@ +reader = xmlreader +xml_fortran_source = $(wildcard *.f90) +xml_fortran_objects = $(xml_fortran_source:.f90=.o) + +#=============================================================================== +# User Options +#=============================================================================== + +COMPILER = intel +DEBUG = no + +#=============================================================================== +# Compiler Options +#=============================================================================== + +# Intel Fortran compiler options + +ifeq ($(COMPILER),intel) + F90 = ifort + F90FLAGS += -fpp +endif + +# GNU Fortran compiler options + +ifeq ($(COMPILER),gfortran) + F90 = gfortran + F90FLAGS += -cpp -Wall +endif + +# Set compiler flags for debugging + +ifeq ($(DEBUG),yes) + F90FLAGS += -g + LDFLAGS += -g + ifeq ($(COMPILER),intel) + F90FLAGS += -traceback -ftrapuv -fp-stack-check -check all + endif + ifeq ($(COMPILER),gfortran) + F90FLAGS += -pedantic -std=f2008 -fbacktrace -fbounds-check \ + -ffpe-trap=invalid,zero,overflow,underflow + endif +endif + +#=============================================================================== +# Targets +#=============================================================================== + +all: $(reader) +$(reader): $(xml_fortran_objects) + $(F90) $(xml_fortran_objects) -o $@ $(LDFLAGS) +clean: + @rm -f *.o *.mod $(reader) +neat: + @rm -f *.o *.mod + +#=============================================================================== +# Rules +#=============================================================================== + +.SUFFIXES: .f90 .o +.PHONY: all clean neat + +%.o: %.f90 + $(F90) $(F90FLAGS) -c $< + +#=============================================================================== +# Dependencies +#=============================================================================== + +read_xml_primitives.o: xmlparse.o +write_xml_primitives.o: xmlparse.o +xmlreader.o: xmlparse.o diff --git a/src/xml-fortran/read_from_buffer.inc b/src/xml-fortran/read_from_buffer.inc new file mode 100644 index 0000000000..0cb6ee9590 --- /dev/null +++ b/src/xml-fortran/read_from_buffer.inc @@ -0,0 +1,79 @@ +! Part of XML-Fortran library: +! +! $Id: read_from_buffer.inc,v 1.2 2006/03/26 19:05:48 arjenmarkus Exp $ +! + character(len=*), intent(in) :: buffer + integer, intent(inout) :: ierror + + integer :: n + integer :: i + integer :: step + integer :: ierr + ! + ! First allocate an array that is surely large enough + ! Note: + ! This is not completely failsafe: with list-directed + ! input you can also use repeat counts (10000*1.0 for + ! instance). + ! + allocate( work(len(buffer)/2+1) ) + + ! + ! NOTE: + ! This is not portable!! + ! + ! read( buffer, *, iostat = ierror ) (work(n), n=1,size(work)) + ! + ! So, use a different strategy: a binary search + ! First: establish that we have at least one item to read + ! Second: do the binary search + ! +! read( buffer, *, iostat = ierr ) work(1) +! if ( ierr /= 0 ) then +! n = 0 +! else + n = 1 + do while ( n <= size(work) ) + n = 2 * n + enddo + n = n / 2 + step = n / 2 +! step = n / 2 + + do while ( step > 0 ) + read( buffer, *, iostat = ierr ) (work(i), i = 1,n) + if ( ierr /= 0 ) then + ierror = ierr ! Store the error code for later use + n = n - step + else + n = n + step + endif + step = step / 2 + enddo +! endif + + ! + ! Then allocate an array of the actual size needed + ! and copy the data + ! + ! + if ( associated( var ) ) then + deallocate( var ) + endif + ! + ! One complication: we may have one too many + ! (consequence of the binary search) + ! + read( buffer, *, iostat = ierr ) (work(i), i = 1,n) + if ( ierr < 0 ) then + n = n - 1 + endif + + allocate( var(n) ) + var(1:n) = work(1:n) + deallocate( work ) + + if ( ierror .lt. 0 ) then + ierror = 0 + endif + diff --git a/src/xml-fortran/read_xml_array.inc b/src/xml-fortran/read_xml_array.inc new file mode 100644 index 0000000000..a88086e740 --- /dev/null +++ b/src/xml-fortran/read_xml_array.inc @@ -0,0 +1,54 @@ +! Part of XML-Fortran library: +! +! $Id: read_xml_array.inc,v 1.3 2007/02/26 20:33:38 arjenmarkus Exp $ +! + type(XML_PARSE), intent(inout) :: info + character(len=*), intent(in) :: tag + logical, intent(inout) :: endtag + character(len=*), dimension(:,:), intent(in) :: attribs + integer, intent(in) :: noattribs + character(len=*), dimension(:), intent(in) :: data + integer, intent(in) :: nodata + logical, intent(inout) :: has_var + + character(len=len(attribs(1,1))) :: buffer + integer :: idx + integer :: ierr + + ! + ! The big trick: + ! A string long enough to hold all data strings + ! + character(len=nodata*(len(data(1))+1)) :: bufferd + integer :: start + + ! + ! The value can be stored in an attribute values="..." or in + ! the data + ! + has_var = .false. + idx = xml_find_attrib( attribs, noattribs, 'values', buffer ) + if ( idx .gt. 0 ) then + call read_from_buffer( buffer, var, ierr ) + if ( buffer .ne. ' ' ) then + has_var = .true. + endif + else + bufferd = ' ' + start = 1 + do idx = 1,nodata + if ( data(idx) .ne. ' ' ) then + bufferd(start:) = data(idx) + start = start + len(data(idx)) + 1 + endif + enddo + call read_from_buffer( bufferd, var, ierr ) + if ( bufferd .ne. ' ' ) then + has_var = .true. + endif + endif + + if ( ierr .ne. 0 ) then + write(*,*) 'Error reading variable - tag = ', trim(tag) + has_var = .false. + endif diff --git a/src/xml-fortran/read_xml_primitives.f90 b/src/xml-fortran/read_xml_primitives.f90 new file mode 100644 index 0000000000..1fb63d57b8 --- /dev/null +++ b/src/xml-fortran/read_xml_primitives.f90 @@ -0,0 +1,527 @@ +! read_xml_prims.f90 - Read routines for primitive data +! +! $Id: read_xml_prims.f90,v 1.7 2007/12/07 10:38:41 arjenmarkus Exp $ +! +! Arjen Markus +! +! General information: +! This module is part of the XML-Fortran library. Its +! purpose is to help read individual items from an XML +! file into the variables that have been connected to +! the various tags. It is used by the code generated +! by the make_xml_reader program. +! +! Because the routines differ mostly by the type of the +! output variable, the body is included, to prevent +! too much repeated blocks of code with all the maintenance +! issues that causes. +! +module read_xml_primitives + use xmlparse + implicit none + + private :: read_from_buffer + private :: read_from_buffer_integers + private :: read_from_buffer_reals + private :: read_from_buffer_doubles + private :: read_from_buffer_logicals + private :: read_from_buffer_words + + interface read_from_buffer + module procedure read_from_buffer_integers + module procedure read_from_buffer_reals + module procedure read_from_buffer_doubles + module procedure read_from_buffer_logicals + module procedure read_from_buffer_words + end interface + +contains + +! skip_until_endtag -- +! Routine to read the XML file until the end tag is encountered +! +! Arguments: +! info The XML file data structure +! tag The tag in question +! attribs Array of attributes and their values +! data Array of strings, representing the data +! error Has an error occurred? +! +subroutine skip_until_endtag( info, tag, attribs, data, error ) + type(XML_PARSE), intent(inout) :: info + character(len=*), intent(in) :: tag + character(len=*), dimension(:,:), intent(inout) :: attribs + character(len=*), dimension(:), intent(inout) :: data + logical, intent(out) :: error + + integer :: noattribs + integer :: nodata + integer :: ierr + logical :: endtag + character(len=len(tag)) :: newtag + + error = .true. + do + call xml_get( info, newtag, endtag, attribs, noattribs, & + data, nodata ) + if ( xml_error(info) ) then + error = .true. + exit + endif + if ( endtag .and. newtag == tag ) then + exit + endif + enddo +end subroutine skip_until_endtag + +! read_xml_integer -- +! Routine to read a single integer from the parsed data +! +! Arguments: +! info XML parser structure +! tag The tag in question (error message only) +! endtag End tag found? (Dummy argument, actually) +! attribs Array of attributes and their values +! noattribs Number of attributes found +! data Array of strings, representing the data +! nodata Number of data strings +! var Variable to be filled +! has_var Has the variable been set? +! +subroutine read_xml_integer( info, tag, endtag, attribs, noattribs, data, nodata, & + var, has_var ) + integer, intent(inout) :: var + + include 'read_xml_scalar.inc' + +end subroutine read_xml_integer + +! read_xml_line -- +! Routine to read a single line of text from the parsed data +! +! Arguments: +! info XML parser structure +! tag The tag in question (error message only) +! endtag End tag found? (Dummy argument, actually) +! attribs Array of attributes and their values +! noattribs Number of attributes found +! data Array of strings, representing the data +! nodata Number of data strings +! var Variable to be filled +! has_var Has the variable been set? +! +subroutine read_xml_line( info, tag, endtag, attribs, noattribs, data, nodata, & + var, has_var ) + type(XML_PARSE), intent(inout) :: info + character(len=*), intent(in) :: tag + logical, intent(inout) :: endtag + character(len=*), dimension(:,:), intent(in) :: attribs + integer, intent(in) :: noattribs + character(len=*), dimension(:), intent(in) :: data + integer, intent(in) :: nodata + character(len=*), intent(inout) :: var + logical, intent(inout) :: has_var + + character(len=len(attribs(1,1))) :: buffer + integer :: idx + integer :: ierr + + ! + ! The value can be stored in an attribute value="..." or in + ! the data + ! + has_var = .false. + idx = xml_find_attrib( attribs, noattribs, 'value', buffer ) + if ( idx > 0 ) then + var = buffer + has_var = .true. + else + do idx = 1,nodata + if ( data(idx) /= ' ' ) then + var = data(idx) + has_var = .true. + exit + endif + enddo + endif +end subroutine read_xml_line + +! read_xml_real, ... -- +! See read_xml_integer for an explanation +! +subroutine read_xml_real( info, tag, endtag, attribs, noattribs, data, nodata, & + var, has_var ) + real, intent(inout) :: var + + include 'read_xml_scalar.inc' + +end subroutine read_xml_real + +subroutine read_xml_double( info, tag, endtag, attribs, noattribs, data, nodata, & + var, has_var ) + real(kind=kind(1.0d00)), intent(inout) :: var + + include 'read_xml_scalar.inc' + +end subroutine read_xml_double + +subroutine read_xml_logical( info, tag, endtag, attribs, noattribs, data, nodata, & + var, has_var ) + logical, intent(inout) :: var + + include 'read_xml_scalar.inc' + +end subroutine read_xml_logical + +subroutine read_xml_word( info, tag, endtag, attribs, noattribs, data, nodata, & + var, has_var ) + character(len=*), intent(inout) :: var + + include 'read_xml_word.inc' + +end subroutine read_xml_word + +! read_xml_integer_array -- +! Routine to read a one-dimensional integer array from the parsed +! ata +! +! Arguments: +! info XML parser structure +! tag The tag in question (error message only) +! endtag End tag found? (Dummy argument, actually) +! attribs Array of attributes and their values +! noattribs Number of attributes found +! data Array of strings, representing the data +! nodata Number of data strings +! var Variable to be filled +! has_var Has the variable been set? +! +subroutine read_xml_integer_array( info, tag, endtag, attribs, noattribs, data, & + nodata, var, has_var ) + integer, dimension(:), pointer :: var + + include 'read_xml_array.inc' + +end subroutine read_xml_integer_array + +! read_xml_line_array -- +! Routine to read an array of lines of text from the parsed data +! +! Arguments: +! info XML parser structure +! tag The tag in question (error message only) +! attribs Array of attributes and their values +! noattribs Number of attributes found +! data Array of strings, representing the data +! nodata Number of data strings +! var Variable to be filled +! has_var Has the variable been set? +! +subroutine read_xml_line_array( info, tag, endtag, attribs, noattribs, data, & + nodata, var, has_var ) + type(XML_PARSE), intent(inout) :: info + character(len=*), intent(in) :: tag + logical, intent(inout) :: endtag + character(len=*), dimension(:,:), intent(in) :: attribs + integer, intent(in) :: noattribs + character(len=*), dimension(:), intent(in) :: data + integer, intent(in) :: nodata + character(len=*), dimension(:), pointer :: var + logical, intent(inout) :: has_var + + character(len=len(attribs(1,1))) :: buffer + integer :: idx + integer :: idxv + integer :: ierr + logical :: started + + ! + ! The value can be stored in an attribute values="..." or in + ! the data + ! + has_var = .false. + idx = xml_find_attrib( attribs, noattribs, 'values', buffer ) + if ( idx > 0 ) then + allocate( var(1:1) ) + var(1) = buffer + if ( buffer /= ' ' ) then + has_var = .true. + endif + else + idxv = 0 + started = .false. + do idx = 1,nodata + if ( data(idx) /= ' ' .or. started ) then + if ( .not. started ) then + allocate( var(1:nodata-idx+1) ) + started = .true. + endif + idxv = idxv + 1 + var(idxv) = data(idx) + endif + enddo + if ( started ) then + has_var = .true. + endif + endif +end subroutine read_xml_line_array + +! read_xml_real_array, ... -- +! See read_xml_integer_array for an explanation +! +subroutine read_xml_real_array( info, tag, endtag, attribs, noattribs, data, & + nodata, var, has_var ) + real, dimension(:), pointer :: var + + include 'read_xml_array.inc' + +end subroutine read_xml_real_array + +subroutine read_xml_double_array( info, tag, endtag, attribs, noattribs, data, & + nodata, var, has_var ) + real(kind=kind(1.0d00)), dimension(:), pointer :: var + + include 'read_xml_array.inc' + +end subroutine read_xml_double_array + +subroutine read_xml_logical_array( info, tag, endtag, attribs, noattribs, data, & + nodata, var, has_var ) + logical, dimension(:), pointer :: var + + include 'read_xml_array.inc' + +end subroutine read_xml_logical_array + +subroutine read_xml_word_array( info, tag, endtag, attribs, noattribs, data, & + nodata, var, has_var ) + character(len=*), dimension(:), pointer :: var + + include 'read_xml_array.inc' + +end subroutine read_xml_word_array + +! read_from_buffer_integers -- +! Routine to read all integers from a long string +! +! Arguments: +! buffer String containing the data +! var Variable to be filled +! ierror Error flag +! +subroutine read_from_buffer_integers( buffer, var, ierror ) + integer, dimension(:), pointer :: var + integer, dimension(:), pointer :: work + + include 'read_from_buffer.inc' + +end subroutine read_from_buffer_integers + +! read_xml_from_buffer_reals, ... - +! See read_xml_from_buffer_integers for an explanation +! +subroutine read_from_buffer_reals( buffer, var, ierror ) + real, dimension(:), pointer :: var + real, dimension(:), pointer :: work + + include 'read_from_buffer.inc' + +end subroutine read_from_buffer_reals + +subroutine read_from_buffer_doubles( buffer, var, ierror ) + real(kind=kind(1.0d00)), dimension(:), pointer :: var + real(kind=kind(1.0d00)), dimension(:), pointer :: work + + include 'read_from_buffer.inc' + +end subroutine read_from_buffer_doubles + +subroutine read_from_buffer_logicals( buffer, var, ierror ) + logical, dimension(:), pointer :: var + logical, dimension(:), pointer :: work + + include 'read_from_buffer.inc' + +end subroutine read_from_buffer_logicals + +subroutine read_from_buffer_words( buffer, var, ierror ) + character(len=*), dimension(:), pointer :: var + character(len=len(var)), dimension(:), pointer :: work + + include 'read_from_buffer.inc' + +end subroutine read_from_buffer_words + +! read_xml_word_1dim, ... - +! Read an array of "words" (or ...) but from different elements +! +subroutine read_xml_integer_1dim( info, tag, endtag, attribs, noattribs, data, nodata, & + var, has_var ) + type(XML_PARSE), intent(inout) :: info + character(len=*), intent(in) :: tag + logical, intent(inout) :: endtag + character(len=*), dimension(:,:), intent(in) :: attribs + integer, intent(in) :: noattribs + character(len=*), dimension(:), intent(in) :: data + integer, intent(in) :: nodata + integer, dimension(:), pointer :: var + logical, intent(inout) :: has_var + + integer,dimension(:), pointer :: newvar + character(len=len(attribs(1,1))) :: buffer + integer :: newsize + integer :: ierr + + newsize = size(var) + 1 + allocate( newvar(1:newsize) ) + newvar(1:newsize-1) = var + deallocate( var ) + var => newvar + + call read_xml_integer( info, tag, endtag, attribs, noattribs, data, nodata, & + var(newsize), has_var ) + +end subroutine read_xml_integer_1dim + +subroutine read_xml_real_1dim( info, tag, endtag, attribs, noattribs, data, nodata, & + var, has_var ) + type(XML_PARSE), intent(inout) :: info + character(len=*), intent(in) :: tag + logical, intent(inout) :: endtag + character(len=*), dimension(:,:), intent(in) :: attribs + integer, intent(in) :: noattribs + character(len=*), dimension(:), intent(in) :: data + integer, intent(in) :: nodata + real, dimension(:), pointer :: var + logical, intent(inout) :: has_var + + real, dimension(:), pointer :: newvar + character(len=len(attribs(1,1))) :: buffer + integer :: newsize + integer :: ierr + + newsize = size(var) + 1 + allocate( newvar(1:newsize) ) + newvar(1:newsize-1) = var + deallocate( var ) + var => newvar + + call read_xml_real( info, tag, endtag, attribs, noattribs, data, nodata, & + var(newsize), has_var ) + +end subroutine read_xml_real_1dim + +subroutine read_xml_double_1dim( info, tag, endtag, attribs, noattribs, data, nodata, & + var, has_var ) + type(XML_PARSE), intent(inout) :: info + character(len=*), intent(in) :: tag + logical, intent(inout) :: endtag + character(len=*), dimension(:,:), intent(in) :: attribs + integer, intent(in) :: noattribs + character(len=*), dimension(:), intent(in) :: data + integer, intent(in) :: nodata + real(kind=kind(1.0d00)), dimension(:), pointer:: var + logical, intent(inout) :: has_var + + real(kind=kind(1.0d00)), dimension(:), pointer:: newvar + character(len=len(attribs(1,1))) :: buffer + integer :: newsize + integer :: ierr + + newsize = size(var) + 1 + allocate( newvar(1:newsize) ) + newvar(1:newsize-1) = var + deallocate( var ) + var => newvar + + call read_xml_double( info, tag, endtag, attribs, noattribs, data, nodata, & + var(newsize), has_var ) + +end subroutine read_xml_double_1dim + +subroutine read_xml_logical_1dim( info, tag, endtag, attribs, noattribs, data, nodata, & + var, has_var ) + type(XML_PARSE), intent(inout) :: info + character(len=*), intent(in) :: tag + logical, intent(inout) :: endtag + character(len=*), dimension(:,:), intent(in) :: attribs + integer, intent(in) :: noattribs + character(len=*), dimension(:), intent(in) :: data + integer, intent(in) :: nodata + logical, dimension(:), pointer :: var + logical, intent(inout) :: has_var + + logical, dimension(:), pointer :: newvar + character(len=len(attribs(1,1))) :: buffer + integer :: newsize + integer :: ierr + + newsize = size(var) + 1 + allocate( newvar(1:newsize) ) + newvar(1:newsize-1) = var + deallocate( var ) + var => newvar + + call read_xml_logical( info, tag, endtag, attribs, noattribs, data, nodata, & + var(newsize), has_var ) + +end subroutine read_xml_logical_1dim + +subroutine read_xml_word_1dim( info, tag, endtag, attribs, noattribs, data, nodata, & + var, has_var ) + type(XML_PARSE), intent(inout) :: info + character(len=*), intent(in) :: tag + logical, intent(inout) :: endtag + character(len=*), dimension(:,:), intent(in) :: attribs + integer, intent(in) :: noattribs + character(len=*), dimension(:), intent(in) :: data + integer, intent(in) :: nodata + character(len=*), dimension(:), pointer :: var + logical, intent(inout) :: has_var + + character(len=len(var)),dimension(:), pointer :: newvar + character(len=len(attribs(1,1))) :: buffer + integer :: newsize + integer :: ierr + + newsize = size(var) + 1 + allocate( newvar(1:newsize) ) + newvar(1:newsize-1) = var + deallocate( var ) + var => newvar + + call read_xml_word( info, tag, endtag, attribs, noattribs, data, nodata, & + var(newsize), has_var ) + +end subroutine read_xml_word_1dim + +subroutine read_xml_line_1dim( info, tag, endtag, attribs, noattribs, data, nodata, & + var, has_var ) + type(XML_PARSE), intent(inout) :: info + character(len=*), intent(in) :: tag + logical, intent(inout) :: endtag + character(len=*), dimension(:,:), intent(in) :: attribs + integer, intent(in) :: noattribs + character(len=*), dimension(:), intent(in) :: data + integer, intent(in) :: nodata + character(len=*), dimension(:), pointer :: var + logical, intent(inout) :: has_var + + character(len=len(var)),dimension(:), pointer :: newvar + character(len=len(attribs(1,1))) :: buffer + integer :: newsize + integer :: ierr + + newsize = size(var) + 1 + allocate( newvar(1:newsize) ) + newvar(1:newsize-1) = var + deallocate( var ) + var => newvar + + call read_xml_line( info, tag, endtag, attribs, noattribs, data, nodata, & + var(newsize), has_var ) + +end subroutine read_xml_line_1dim + + +end module read_xml_primitives diff --git a/src/xml-fortran/read_xml_scalar.inc b/src/xml-fortran/read_xml_scalar.inc new file mode 100644 index 0000000000..b28ba3c7a0 --- /dev/null +++ b/src/xml-fortran/read_xml_scalar.inc @@ -0,0 +1,40 @@ +! Part of XML-Fortran library: +! +! $Id: read_xml_scalar.inc,v 1.3 2007/02/26 20:33:38 arjenmarkus Exp $ +! + type(XML_PARSE), intent(inout) :: info + character(len=*), intent(in) :: tag + logical, intent(inout) :: endtag + character(len=*), dimension(:,:), intent(in) :: attribs + integer, intent(in) :: noattribs + character(len=*), dimension(:), intent(in) :: data + integer, intent(in) :: nodata + logical, intent(inout) :: has_var + + character(len=len(attribs(1,1))) :: buffer + integer :: idx + integer :: ierr + + ! + ! The value can be stored in an attribute value="..." or in + ! the data + ! + has_var = .false. + idx = xml_find_attrib( attribs, noattribs, 'value', buffer ) + if ( idx .gt. 0 ) then + read( buffer, *, iostat=ierr ) var + has_var = .true. + else + do idx = 1,nodata + if ( data(idx) .ne. ' ' ) then + read( data(idx), *, iostat=ierr ) var + has_var = .true. + exit + endif + enddo + endif + + if ( ierr .ne. 0 ) then + write(*,*) 'Error reading variable - tag = ', trim(tag) + has_var = .false. + endif diff --git a/src/xml-fortran/read_xml_word.inc b/src/xml-fortran/read_xml_word.inc new file mode 100644 index 0000000000..4c1848dcff --- /dev/null +++ b/src/xml-fortran/read_xml_word.inc @@ -0,0 +1,38 @@ +! Part of XML-Fortran library: +! + type(XML_PARSE), intent(inout) :: info + character(len=*), intent(in) :: tag + logical, intent(inout) :: endtag + character(len=*), dimension(:,:), intent(in) :: attribs + integer, intent(in) :: noattribs + character(len=*), dimension(:), intent(in) :: data + integer, intent(in) :: nodata + logical, intent(inout) :: has_var + + character(len=len(attribs(1,1))) :: buffer + integer :: idx + integer :: ierr + + ! + ! The value can be stored in an attribute value="..." or in + ! the data + ! + has_var = .false. + idx = xml_find_attrib( attribs, noattribs, 'value', buffer ) + if ( idx .gt. 0 ) then + read( buffer, *, iostat=ierr ) var + has_var = .true. + else + do idx = 1,nodata + if ( data(idx) .ne. ' ' ) then + read( data(idx), '(A)', iostat=ierr ) var + has_var = .true. + exit + endif + enddo + endif + + if ( ierr .ne. 0 ) then + write(*,*) 'Error reading variable - tag = ', trim(tag) + has_var = .false. + endif diff --git a/src/xml-fortran/templates/Makefile b/src/xml-fortran/templates/Makefile new file mode 100644 index 0000000000..1563c15ad5 --- /dev/null +++ b/src/xml-fortran/templates/Makefile @@ -0,0 +1,69 @@ +templates = $(wildcard *.xml) +objects = $(templates:.xml=.o) + +#=============================================================================== +# User Options +#=============================================================================== + +COMPILER = intel +DEBUG = no + +#=============================================================================== +# Compiler Options +#=============================================================================== + +# Set compiler defaults + +F90 = gfortran +F90FLAGS = -I.. +LDFLAGS = + +# Intel Fortran compiler options + +ifeq ($(COMPILER),intel) + F90 = ifort + F90FLAGS += -fpp +endif + +# GNU Fortran compiler options + +ifeq ($(COMPILER),gfortran) + F90 = gfortran + F90FLAGS += -cpp -Wall +endif + +# Set compiler flags for debugging + +ifeq ($(DEBUG),yes) + F90FLAGS += -g + LDFLAGS += -g + ifeq ($(COMPILER),intel) + F90FLAGS += -traceback -ftrapuv -fp-stack-check -check all + endif + ifeq ($(COMPILER),gfortran) + F90FLAGS += -pedantic -std=f2008 -fbacktrace -fbounds-check \ + -ffpe-trap=invalid,zero,overflow,underflow + endif +endif + +#=============================================================================== +# Targets +#=============================================================================== + +all: $(objects) +clean: + @rm -f *.o *.mod *.out *.f90 + +#=============================================================================== +# Rules +#=============================================================================== + +.SUFFIXES: .f90 .o .xml +.PHONY: all clean +.PRECIOUS: %.f90 + +%.f90: %.xml + ../xmlreader $(basename $@) + +%.o: %.f90 + $(F90) $(F90FLAGS) -c $(basename $@).f90 diff --git a/src/xml-fortran/templates/geometry_t.xml b/src/xml-fortran/templates/geometry_t.xml new file mode 100644 index 0000000000..2752cb7cee --- /dev/null +++ b/src/xml-fortran/templates/geometry_t.xml @@ -0,0 +1,36 @@ + + diff --git a/src/xml-fortran/templates/materials_t.xml b/src/xml-fortran/templates/materials_t.xml new file mode 100644 index 0000000000..ac232dc3b4 --- /dev/null +++ b/src/xml-fortran/templates/materials_t.xml @@ -0,0 +1,42 @@ + + diff --git a/src/xml-fortran/templates/settings_t.xml b/src/xml-fortran/templates/settings_t.xml new file mode 100644 index 0000000000..a61892b15d --- /dev/null +++ b/src/xml-fortran/templates/settings_t.xml @@ -0,0 +1,33 @@ + + diff --git a/src/xml-fortran/templates/tallies_t.xml b/src/xml-fortran/templates/tallies_t.xml new file mode 100644 index 0000000000..695ef8f6a8 --- /dev/null +++ b/src/xml-fortran/templates/tallies_t.xml @@ -0,0 +1,36 @@ + + diff --git a/src/xml-fortran/write_xml_primitives.f90 b/src/xml-fortran/write_xml_primitives.f90 new file mode 100644 index 0000000000..94609593af --- /dev/null +++ b/src/xml-fortran/write_xml_primitives.f90 @@ -0,0 +1,489 @@ +! write_xml_prims.f90 - Write routines for primitive data +! +! $Id: write_xml_prims.f90,v 1.2 2007/12/27 05:13:59 arjenmarkus Exp $ +! +! Arjen Markus +! +! General information: +! This module is part of the XML-Fortran library. Its +! purpose is to write individual items to an XML +! file using the right tag. It is used by the code generated +! by the make_xml_reader program. +! +module write_xml_primitives + use xmlparse + implicit none + +! interface write_to_xml +! module procedure write_to_xml_integers +! module procedure write_to_xml_reals +! module procedure write_to_xml_doubles +! module procedure write_to_xml_logicals +! module procedure write_to_xml_words +! end interface + interface write_to_xml_word + module procedure write_to_xml_string + end interface + interface write_to_xml_line + module procedure write_to_xml_string + end interface + +contains + +! write_to_xml_integer -- +! Routine to write a single integer to the XML file +! +! Arguments: +! info XML parser structure +! tag The tag in question +! indent Number of spaces for indentation +! value Value to be written +! +subroutine write_to_xml_integer( info, tag, indent, value ) + type(XML_PARSE), intent(in) :: info + character(len=*), intent(in) :: tag + integer, intent(in) :: indent + integer, intent(in) :: value + + character(len=100) :: indentation + + indentation = ' ' + write( info%lun, '(4a,i0,3a)' ) indentation(1:min(indent,100)), & + '<', trim(tag), '>', value, '' + +end subroutine write_to_xml_integer + +! write_to_xml_integer_1dim -- +! Routine to write an array of integers to the XML file +! +! Arguments: +! info XML parser structure +! tag The tag in question +! indent Number of spaces for indentation +! values Values to be written +! +subroutine write_to_xml_integer_1dim( info, tag, indent, values ) + type(XML_PARSE), intent(in) :: info + character(len=*), intent(in) :: tag + integer, intent(in) :: indent + integer, dimension(:), intent(in) :: values + + integer :: i + + do i = 1,size(values) + call write_to_xml_integer( info, tag, indent, values(i) ) + enddo + +end subroutine write_to_xml_integer_1dim + +! write_to_xml_real -- +! Routine to write a single real value (single precision) to the XML file +! +! Arguments: +! info XML parser structure +! tag The tag in question +! indent Number of spaces for indentation +! value Value to be written +! +subroutine write_to_xml_real( info, tag, indent, value ) + type(XML_PARSE), intent(in) :: info + character(len=*), intent(in) :: tag + integer, intent(in) :: indent + real, intent(in) :: value + + character(len=100) :: indentation + character(len=12) :: buffer + + indentation = ' ' + write( buffer, '(1pg12.4)' ) value + write( info%lun, '(8a)' ) indentation(1:min(indent,100)), & + '<', trim(tag), '>', trim(adjustl(buffer)), '' + +end subroutine write_to_xml_real + +! write_to_xml_real_1dim -- +! Routine to write an array of reals to the XML file +! +! Arguments: +! info XML parser structure +! tag The tag in question +! indent Number of spaces for indentation +! values Values to be written +! +subroutine write_to_xml_real_1dim( info, tag, indent, values ) + type(XML_PARSE), intent(in) :: info + character(len=*), intent(in) :: tag + integer, intent(in) :: indent + real, dimension(:), intent(in) :: values + + integer :: i + + do i = 1,size(values) + call write_to_xml_real( info, tag, indent, values(i) ) + enddo + +end subroutine write_to_xml_real_1dim + +! write_to_xml_double -- +! Routine to write one real value (double precision) to the XML file +! +! Arguments: +! info XML parser structure +! tag The tag in question +! indent Number of spaces for indentation +! value Value to be written +! +subroutine write_to_xml_double( info, tag, indent, value ) + type(XML_PARSE), intent(in) :: info + character(len=*), intent(in) :: tag + integer, intent(in) :: indent + real(kind=kind(1.0d0)), intent(in) :: value + + character(len=100) :: indentation + character(len=16) :: buffer + + indentation = ' ' + write( buffer, '(1pg16.7)' ) value + write( info%lun, '(8a)' ) indentation(1:min(indent,100)), & + '<', trim(tag), '>', trim(adjustl(buffer)), '' + +end subroutine write_to_xml_double + +! write_to_xml_double_1dim -- +! Routine to write an array of double precision reals to the XML file +! +! Arguments: +! info XML parser structure +! tag The tag in question +! indent Number of spaces for indentation +! values Values to be written +! +subroutine write_to_xml_double_1dim( info, tag, indent, values ) + type(XML_PARSE), intent(in) :: info + character(len=*), intent(in) :: tag + integer, intent(in) :: indent + real(kind=kind(1.0d00)), dimension(:), intent(in) :: values + + integer :: i + + do i = 1,size(values) + call write_to_xml_double( info, tag, indent, values(i) ) + enddo + +end subroutine write_to_xml_double_1dim + +! write_to_xml_string -- +! Routine to write one string to the XML file +! +! Arguments: +! info XML parser structure +! tag The tag in question +! indent Number of spaces for indentation +! value Value to be written +! +subroutine write_to_xml_string( info, tag, indent, value ) + type(XML_PARSE), intent(in) :: info + character(len=*), intent(in) :: tag + integer, intent(in) :: indent + character(len=*), intent(in) :: value + + character(len=100) :: indentation + + ! + ! NOTE: No guards against <, >, & and " yet! + ! NOTE: difference needed between words and lines? + ! + indentation = ' ' + write( info%lun, '(8a)' ) indentation(1:min(indent,100)), & + '<', trim(tag), '>', trim(value), '' + +end subroutine write_to_xml_string + +! write_to_xml_word_1dim -- +! Routine to write an array of single words to the XML file +! +! Arguments: +! info XML parser structure +! tag The tag in question +! indent Number of spaces for indentation +! value Value to be written +! +subroutine write_to_xml_word_1dim( info, tag, indent, values ) + type(XML_PARSE), intent(in) :: info + character(len=*), intent(in) :: tag + integer, intent(in) :: indent + character(len=*), dimension(:), intent(in) :: values + + integer :: i + + do i = 1,size(values) + call write_to_xml_string( info, tag, indent, values(i) ) + enddo +end subroutine write_to_xml_word_1dim + +! write_to_xml_string_1dim -- +! Routine to write an array of strings to the XML file +! +! Arguments: +! info XML parser structure +! tag The tag in question +! indent Number of spaces for indentation +! values Values to be written +! +subroutine write_to_xml_string_1dim( info, tag, indent, values ) + type(XML_PARSE), intent(in) :: info + character(len=*), intent(in) :: tag + integer, intent(in) :: indent + character(len=*), dimension(:), intent(in) :: values + + integer :: i + + do i = 1,size(values) + call write_to_xml_string( info, tag, indent, values(i) ) + enddo + +end subroutine write_to_xml_string_1dim + +! write_to_xml_logical -- +! Routine to write one logical to the XML file +! +! Arguments: +! info XML parser structure +! tag The tag in question +! indent Number of spaces for indentation +! value Value to be written +! +subroutine write_to_xml_logical( info, tag, indent, value ) + type(XML_PARSE), intent(in) :: info + character(len=*), intent(in) :: tag + integer, intent(in) :: indent + logical, intent(in) :: value + + character(len=100) :: indentation + + indentation = ' ' + if ( value ) then + write( info%lun, '(8a)' ) indentation(1:min(indent,100)), & + '<', trim(tag), '>true' + else + write( info%lun, '(8a)' ) indentation(1:min(indent,100)), & + '<', trim(tag), '>false' + endif + +end subroutine write_to_xml_logical + +! write_to_xml_logical_1dim -- +! Routine to write an array of logicals to the XML file +! +! Arguments: +! info XML parser structure +! tag The tag in question +! indent Number of spaces for indentation +! values Values to be written +! +subroutine write_to_xml_logical_1dim( info, tag, indent, values ) + type(XML_PARSE), intent(in) :: info + character(len=*), intent(in) :: tag + integer, intent(in) :: indent + logical, dimension(:), intent(in) :: values + + integer :: i + + do i = 1,size(values) + call write_to_xml_logical( info, tag, indent, values(i) ) + enddo + +end subroutine write_to_xml_logical_1dim + +! write_to_xml_integer_array -- +! Routine to write an array of integers to the XML file +! +! Arguments: +! info XML parser structure +! tag The tag in question +! indent Number of spaces for indentation +! array Values to be written +! +subroutine write_to_xml_integer_array( info, tag, indent, array ) + type(XML_PARSE), intent(in) :: info + character(len=*), intent(in) :: tag + integer, intent(in) :: indent + integer, dimension(:), intent(in) :: array + + character(len=100) :: indentation + integer :: i, i2, j + + indentation = ' ' + + write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & + '<', trim(tag), '>' + do i = 1,size(array),10 + i2 = min( i + 9, size(array) ) + write( info%lun, '(a,10i12)' ) indentation(1:min(indent+4,100)), & + ( array(j) ,j = i,i2 ) + enddo + write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & + '' + +end subroutine write_to_xml_integer_array + +! write_to_xml_real_array -- +! Routine to write an array of single precision reals to the XML file +! +! Arguments: +! info XML parser structure +! tag The tag in question +! indent Number of spaces for indentation +! array Values to be written +! +subroutine write_to_xml_real_array( info, tag, indent, array ) + type(XML_PARSE), intent(in) :: info + character(len=*), intent(in) :: tag + integer, intent(in) :: indent + real, dimension(:), intent(in) :: array + + character(len=100) :: indentation + integer :: i, i2, j + + indentation = ' ' + + write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & + '<', trim(tag), '>' + do i = 1,size(array),10 + i2 = min( i + 9, size(array) ) + write( info%lun, '(a,10g12.4)' ) indentation(1:min(indent+4,100)), & + ( array(j) ,j = i,i2 ) + enddo + write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & + '' + +end subroutine write_to_xml_real_array + +! write_to_xml_double_array -- +! Routine to write an array of double precision reals to the XML file +! +! Arguments: +! info XML parser structure +! tag The tag in question +! indent Number of spaces for indentation +! array Values to be written +! +subroutine write_to_xml_double_array( info, tag, indent, array ) + type(XML_PARSE), intent(in) :: info + character(len=*), intent(in) :: tag + integer, intent(in) :: indent + real(kind=kind(1.0d0)), dimension(:), intent(in) :: array + + character(len=100) :: indentation + integer :: i, i2, j + + indentation = ' ' + + write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & + '<', trim(tag), '>' + do i = 1,size(array),5 + i2 = min( i + 4, size(array) ) + write( info%lun, '(a,5g20.7)' ) indentation(1:min(indent+4,100)), & + ( array(j) ,j = i,i2 ) + enddo + write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & + '' + +end subroutine write_to_xml_double_array + +! write_to_xml_logical_array -- +! Routine to write an array of logicals to the XML file +! +! Arguments: +! info XML parser structure +! tag The tag in question +! indent Number of spaces for indentation +! array Values to be written +! +subroutine write_to_xml_logical_array( info, tag, indent, array ) + type(XML_PARSE), intent(in) :: info + character(len=*), intent(in) :: tag + integer, intent(in) :: indent + logical, dimension(:), intent(in) :: array + + character(len=100) :: indentation + integer :: i, i2, j + + indentation = ' ' + + write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & + '<', trim(tag), '>' + do i = 1,size(array),10 + i2 = min( i + 9, size(array) ) + write( info%lun, '(a,10a)' ) indentation(1:min(indent+4,100)), & + ( merge('true ', 'false ', array(j)) ,j = i,i2 ) + enddo + write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & + '' + +end subroutine write_to_xml_logical_array + +! write_to_xml_word_array -- +! Routine to write an array of words to the XML file +! +! Arguments: +! info XML parser structure +! tag The tag in question +! indent Number of spaces for indentation +! array Values to be written +! +subroutine write_to_xml_word_array( info, tag, indent, array ) + type(XML_PARSE), intent(in) :: info + character(len=*), intent(in) :: tag + integer, intent(in) :: indent + character(len=*), dimension(:), intent(in) :: array + + character(len=100) :: indentation + integer :: i, i2, j + + indentation = ' ' + + write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & + '<', trim(tag), '>' + do i = 1,size(array),10 + i2 = min( i + 9, size(array) ) + write( info%lun, '(a,20a)' ) indentation(1:min(indent+4,100)), & + ( trim(array(j)) , ' ' ,j = i,i2 ) + enddo + write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & + '' + +end subroutine write_to_xml_word_array + +! write_to_xml_line_array -- +! Routine to write an array of lines to the XML file +! +! Arguments: +! info XML parser structure +! tag The tag in question +! indent Number of spaces for indentation +! array Values to be written +! +subroutine write_to_xml_line_array( info, tag, indent, array ) + type(XML_PARSE), intent(in) :: info + character(len=*), intent(in) :: tag + integer, intent(in) :: indent + logical, dimension(:), intent(in) :: array + + character(len=100) :: indentation + integer :: i, i2, j + + indentation = ' ' + + write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & + '<', trim(tag), '>' + do i = 1,size(array) + write( info%lun, '(a)' ) indentation(1:min(indent+4,100)), & + array(i) + enddo + write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & + '' + +end subroutine write_to_xml_line_array + +end module write_xml_primitives diff --git a/src/xml-fortran/xmlparse.f90 b/src/xml-fortran/xmlparse.f90 new file mode 100644 index 0000000000..b54b2c41ec --- /dev/null +++ b/src/xml-fortran/xmlparse.f90 @@ -0,0 +1,1068 @@ +!=============================================================================== +! XMLPARSE - Simple, limited XML parser in Fortran +! +! General information: +! The module reads XML files by: +! - Identifying the tag and all attributes and data belonging +! to the tag. +! - Returning to the calling subprogram to let it take care of +! the tag, attributes and data. +! - If the tag is actually an ending tag, then this is flagged +! too. +! - Handling all the data is left to the calling subprogram, +! the module merely facilitates in the parsing. +! +! Note: +! The module in its current version has a number of limitations: +! - It does not handle escape sequences (like >. to signify +! a ">" sign) +! - It does not handle tags with attributes that are spread +! over more than one line +! - The maximum length of a line is 1000 characters +! - It may report too many lines of data (empty lines) +! - No DOM support nor support for an object tree +! - It is probably not very robust in detecting malformed XML files +! +! Some questions: +! - What to do with leading blanks? +! +! Update - several ideas: +! - Introduce at least two options (via xml_options): +! - ignore_whitespace - remove leading blanks and leading and trailing +! empty lines from the PCDATA +! - no_data_truncation - consider truncation of data (more +! attributes or lines of character data than +! can be stored) a read error +! - Introduce convenience functions and subroutines: +! - xml_ok() - all is well, reading can continue +! - xml_data_trunc() - was there truncation of the data? +! - xml_find_attrib() - find an attribute by name +! +! Further ideas: +! - simple checking via a table: parent, tag, id, min, max +!=============================================================================== + +module xmlparse + + implicit none + + integer, parameter :: XML_BUFFER_LENGTH = 1000 + +!=============================================================================== +! XML_PARSE defines the data type that holds the parser information +!=============================================================================== + + type XML_PARSE + integer :: lun ! LU-number of the XML-file + integer :: level ! Indentation level (output) + integer :: lineno ! Line in file + logical :: ignore_whitespace ! Ignore leading blanks etc. + logical :: no_data_truncation ! Do not allow data truncation + logical :: too_many_attribs ! More attributes than could be stored? + logical :: too_many_data ! More lines of data than could be stored? + logical :: eof ! End of file? + logical :: error ! Invalid XML file or other error? + character(len=XML_BUFFER_LENGTH) :: line ! Buffer + end type XML_PARSE + +!=============================================================================== +! Global options +!=============================================================================== + + integer, parameter :: XML_STDOUT = -1 + integer, private :: report_lun_ = XML_STDOUT + logical, private :: report_errors_ = .false. + logical, private :: report_details_ = .false. + +!=============================================================================== +! Global data (the ampersand must come first) +!=============================================================================== + + character(len=10), dimension(2,3), save, private :: entities = & + reshape( (/ '& ', '&', & + '> ', '> ', & + '< ', '< ' /), (/2,3/) ) + +!=============================================================================== +! Auxiliary routines - private +!=============================================================================== + + private :: xml_compress_ + private :: xml_put_open_tag_ + private :: xml_put_element_ + private :: xml_put_close_tag_ + private :: xml_replace_entities_ + private :: xml_remove_tabs_ + +!=============================================================================== +! Interfaces to reporting routines +!=============================================================================== + + private :: xml_report_details_int_ + private :: xml_report_details_string_ + private :: xml_report_errors_int_ + private :: xml_report_errors_string_ + + interface xml_report_details + module procedure xml_report_details_int_ + module procedure xml_report_details_string_ + end interface + interface xml_report_errors + module procedure xml_report_errors_int_ + module procedure xml_report_errors_string_ + module procedure xml_report_errors_extern_ + end interface + +contains + +!=============================================================================== +! XML_REPORT_DETAILS_INT_ -- +! Routine to write a text with an integer value +! Arguments: +! text Text to be written +! int Integer value to be added +!=============================================================================== + +subroutine xml_report_details_int_( text, int ) + character(len=*), intent(in) :: text + integer, intent(in) :: int + + if ( report_details_ ) then + if ( report_lun_ == XML_STDOUT ) then + write(*,*) trim(text), int + else + write(report_lun_,*) trim(text), int + endif + endif +end subroutine xml_report_details_int_ + +!=============================================================================== +! XML_REPORT_DETAILS_STRING_ -- +! Routine to write a text with a string value +! Arguments: +! text Text to be written +! string String to be added +!=============================================================================== + +subroutine xml_report_details_string_( text, string ) + character(len=*), intent(in) :: text + character(len=*), intent(in) :: string + + if ( report_details_ ) then + if ( report_lun_ == XML_STDOUT ) then + write(*,*) trim(text), ' ', trim(string) + else + write(report_lun_,*) trim(text), ' ', trim(string) + endif + endif +end subroutine xml_report_details_string_ + +!=============================================================================== +! XML_REPORT_ERRORS_INT_ -- +! Routine to write an error message text with an integer value +! Arguments: +! text Text to be written +! int Integer value to be added +! lineno Line number in the file +!=============================================================================== + +subroutine xml_report_errors_int_( text, int, lineno ) + character(len=*), intent(in) :: text + integer, intent(in) :: int + integer, optional, intent(in) :: lineno + + if ( report_errors_ .or. report_details_ ) then + if ( report_lun_ == XML_STDOUT ) then + write(*,*) trim(text), int + if ( present(lineno) ) then + write(*,*) ' At or near line', lineno + endif + else + write(report_lun_,*) trim(text), int + if ( present(lineno) ) then + write(report_lun_,*) ' At or near line', lineno + endif + endif + endif +end subroutine xml_report_errors_int_ + +!=============================================================================== +! XML_REPORT_ERRORS_STRING_ -- +! Routine to write an error message text with a string value +! Arguments: +! text Text to be written +! string String to be added +! lineno Line number in the file +!=============================================================================== + +subroutine xml_report_errors_string_( text, string, lineno ) + character(len=*), intent(in) :: text + character(len=*), intent(in) :: string + integer, optional, intent(in) :: lineno + + if ( report_errors_ .or. report_details_ ) then + if ( report_lun_ == XML_STDOUT ) then + write(*,*) trim(text), ' ', trim(string) + if ( present(lineno) ) then + write(*,*) ' At or near line', lineno + endif + else + write(report_lun_,*) trim(text), ' ', trim(string) + if ( present(lineno) ) then + write(report_lun_,*) ' At or near line', lineno + endif + endif + endif +end subroutine xml_report_errors_string_ + +!=============================================================================== +! XML_REPORT_ERRORS_EXTERN_ -- +! Routine to write an error message text with a string value +! Arguments: +! info Structure holding information on the XML-file +! text Text to be written +! Note: +! This routine is meant for use by routines outside +! this module +!=============================================================================== + +subroutine xml_report_errors_extern_( info, text ) + type(XML_PARSE), intent(in) :: info + character(len=*), intent(in) :: text + + if ( report_errors_ .or. report_details_ ) then + if ( report_lun_ == XML_STDOUT ) then + write(*,*) trim(text), ' - at or near line', info%lineno + else + write(report_lun_,*) trim(text), ' - at or near line', info%lineno + endif + end if + +end subroutine xml_report_errors_extern_ + +!=============================================================================== +! XML_OPEN -- +! Routine to open an XML file for reading or writing +! Arguments: +! info Structure holding information on the XML-file +! fname Name of the file +! mustread The file will be read (.true.) or written (.false.) +!=============================================================================== + +subroutine xml_open( info, fname, mustread ) + character(len=*), intent(in) :: fname + logical, intent(in) :: mustread + type(XML_PARSE), intent(out) :: info + + integer :: i + integer :: k + integer :: kend + integer :: ierr + logical :: opend + logical :: exists + + info%lun = 10 + info%ignore_whitespace = .false. + info%no_data_truncation = .false. + info%too_many_attribs = .false. + info%too_many_data = .false. + info%eof = .false. + info%error = .false. + info%level = -1 + info%lineno = 0 + + do i = 10,99 + inquire( unit = i, opened = opend ) + if ( .not. opend ) then + info%lun = i + inquire( file = fname, exist = exists ) + if ( .not. exists .and. mustread ) then + call xml_report_errors( 'XML_OPEN: file does not exist:', trim(fname)) + info%lun = -1 + info%error = .true. + else + open( unit = info%lun, file = fname ) + call xml_report_details( 'XML_OPEN: opened file ', trim(fname) ) + call xml_report_details( 'at LU-number: ', info%lun ) + endif + exit + endif + enddo + if ( .not. info%error .and. mustread ) then + k = 1 + do while ( k >= 1 ) + read( info%lun, '(a)', iostat = ierr ) info%line + call xml_remove_tabs_(info%line) + if ( ierr == 0 ) then + info%line = adjustl( info%line ) + k = index( info%line, ' appears on a single line! + ! + if ( k >= 1 ) then + kend = index( info%line, '?>' ) + if ( kend <= 0 ) then + call xml_report_errors( 'XML_OPEN: error reading file with LU-number: ', info%lun ) + call xml_report_errors( 'Line starting with ""', ' ' ) + info%error = .true. + exit + endif + endif + else + call xml_report_errors( 'XML_OPEN: error reading file with LU-number: ', info%lun ) + call xml_report_errors( 'Possibly no line starting with "' + endif +end subroutine xml_open + +!=============================================================================== +! XML_CLOSE -- +! Routine to close an XML file +! Arguments: +! info Structure holding information on the XML-file +!=============================================================================== + +subroutine xml_close( info ) + type(XML_PARSE), intent(inout) :: info + + close( info%lun ) + + ! + ! Only clean up the LU-number, so that the calling program + ! can examine the last condition + ! + call xml_report_details( 'XML_CLOSE: Closing file with LU-number ', info%lun ) + info%lun = -1 +end subroutine xml_close + +!=============================================================================== +! XML_GET -- +! Routine to get the next bit of information from an XML file +! Arguments: +! info Structure holding information on the XML-file +! tag Tag that was encountered +! endtag Whether the end of the element was encountered +! attribs List of attribute-value pairs +! no_attribs Number of pairs in the list +! data Lines of character data found +! no_data Number of lines of character data +!=============================================================================== + +subroutine xml_get( info, tag, endtag, attribs, no_attribs, & + data, no_data ) + type(XML_PARSE), intent(inout) :: info + character(len=*), intent(out) :: tag + logical, intent(out) :: endtag + character(len=*), intent(out), dimension(:,:) :: attribs + integer, intent(out) :: no_attribs + character(len=*), intent(out), dimension(:) :: data + integer, intent(out) :: no_data + + integer :: kspace + integer :: kend + integer :: keq + integer :: kfirst + integer :: ksecond + integer :: idxat + integer :: idxdat + integer :: ierr + logical :: close_bracket + logical :: comment_tag + character(len=XML_BUFFER_LENGTH) :: nextline + + ! + ! Initialise the output + ! + endtag = .false. + no_attribs = 0 + no_data = 0 + + info%too_many_attribs = .false. + info%too_many_data = .false. + + if ( info%lun < 0 ) then + call xml_report_details( 'XML_GET on closed file ', ' ' ) + return + endif + + ! + ! From the previous call or the call to xmlopen we have + ! the line that we need to parse already in memory: + ! + ! + comment_tag = .false. + close_bracket = .false. + kspace = index( info%line, ' ' ) + kend = index( info%line, '>' ) + do while ( kend <= 0 ) + read( info%lun, '(a)', iostat = ierr ) nextline + call xml_remove_tabs_(nextline) + info%lineno = info%lineno + 1 + + if ( ierr == 0 ) then + info%line = trim(info%line) // ' ' // adjustl(nextline) + else + info%error = .true. + call xml_report_errors( 'XML_GET - end of tag not found ', & + '(buffer too small?)', info%lineno ) + call xml_close( info ) + return + endif + kend = index( info%line, '>' ) + enddo + if ( kend > kspace ) then + kend = kspace + else + close_bracket = .true. + endif + + ! + ! Check for the end of an ordianry tag and of + ! a comment tag + ! + if ( info%line(1:3) == '-->' ) then + endtag = .true. + tag = info%line(4:kend-1) + else if ( info%line(1:2) == '' ) + if ( keq > kend ) keq = 0 ! Guard against multiple tags + ! with attributes on one line + + ! + ! No attributes any more? + ! + if ( keq < 1 ) then + kend = index( info%line, '/>' ) + if ( kend >= 1 ) then + kend = kend + 1 ! To go beyond the ">" character + endtag = .true. + else + kend = index( info%line, '>' ) + if ( kend < 1 ) then + call xml_report_errors( 'XML_GET - wrong ending of tag ', & + trim(info%line), info%lineno ) + info%error = .true. ! Wrong ending of line! + call xml_close( info ) + return + else + close_bracket = .true. + endif + endif + if ( kend >= 1 ) then + info%line = adjustl( info%line(kend+1:) ) + endif + exit + endif + + idxat = idxat + 1 + if ( idxat <= size(attribs,2) ) then + no_attribs = idxat + attribs(1,idxat) = adjustl(info%line(1:keq-1)) ! Use adjustl() to avoid + ! multiple spaces, etc + info%line = adjustl( info%line(keq+1:) ) + + ! + ! We have almost found the start of the attribute's value + ! + kfirst = index( info%line, '"' ) + if ( kfirst < 1 ) then + call xml_report_errors( 'XML_GET - malformed attribute-value pair: ', & + trim(info%line), info%lineno ) + info%error = .true. ! Wrong form of attribute-value pair + call xml_close( info ) + return + endif + + ksecond = index( info%line(kfirst+1:), '"' ) + kfirst + if ( ksecond < 1 ) then + call xml_report_errors( 'XML_GET - malformed attribute-value pair: ', & + trim(info%line), info%lineno ) + info%error = .true. ! Wrong form of attribute-value pair + call xml_close( info ) + return + endif + + attribs(2,idxat) = info%line(kfirst+1:ksecond-1) + info%line = adjustl( info%line(ksecond+1:) ) + endif + + if ( idxat > size(attribs,2) ) then + call xml_report_errors( 'XML_GET - more attributes than could be stored: ', & + trim(info%line), info%lineno ) + info%too_many_attribs = .true. + info%line = ' ' + exit + endif + enddo + + ! + ! Now read the data associated with the current tag + ! - all the way to the next "<" character + ! + ! To do: reduce the number of data lines - empty ones + ! at the end should not count. + ! + do + if ( comment_tag ) then + kend = index( info%line, '-->' ) + else + kend = index( info%line, '<' ) + endif + idxdat = idxdat + 1 + if ( idxdat <= size(data) ) then + no_data = idxdat + if ( kend >= 1 ) then + data(idxdat) = info%line(1:kend-1) + info%line = info%line(kend:) + else + data(idxdat) = info%line + endif + else + call xml_report_errors( 'XML_GET - more data lines than could be stored: ', & + trim(info%line), info%lineno ) + info%too_many_data = .true. + exit + endif + + ! + ! No more data? Otherwise, read on + ! + if ( kend >= 1 ) then + exit + else + read( info%lun, '(a)', iostat = ierr ) info%line + call xml_remove_tabs_(info%line) + info%lineno = info%lineno + 1 + + if ( ierr < 0 ) then + call xml_report_details( 'XML_GET - end of file found - LU-number: ', & + info%lun ) + info%eof = .true. + elseif ( ierr > 0 ) then + call xml_report_errors( 'XML_GET - error reading file with LU-number ', & + info%lun, info%lineno ) + info%error = .true. + endif + if ( ierr /= 0 ) then + exit + endif + endif + enddo + + ! + ! Compress the data? + ! + if ( info%ignore_whitespace ) then + call xml_compress_( data, no_data ) + endif + + ! + ! Replace the entities, if any + ! + call xml_replace_entities_( data, no_data ) + + call xml_report_details( 'XML_GET - number of attributes: ', no_attribs ) + call xml_report_details( 'XML_GET - number of data lines: ', no_data ) + +end subroutine xml_get + +!=============================================================================== +! XML_PUT -- +! Routine to write a tag with the associated data to an XML file +! Arguments: +! info Structure holding information on the XML-file +! tag Tag that was encountered +! endtag Whether the end of the element was encountered +! attribs List of attribute-value pairs +! no_attribs Number of pairs in the list +! data Lines of character data found +! no_data Number of lines of character data +! type Type of action: +! open - just the opening tag with attributes +! elem - complete element +! close - just the closing tag +!=============================================================================== + +subroutine xml_put(info, tag, attribs, no_attribs, & + data, no_data, type) + + type(XML_PARSE), intent(inout) :: info + character(len=*), intent(in) :: tag + character(len=*), intent(in), dimension(:,:) :: attribs + integer, intent(in) :: no_attribs + character(len=*), intent(in), dimension(:) :: data + integer, intent(in) :: no_data + character(len=*) :: type + + select case(type) + case('open') + call xml_put_open_tag_(info, tag, attribs, no_attribs) + case('elem') + call xml_put_element_(info, tag, attribs, no_attribs, & + data, no_data) + case('close') + call xml_put_close_tag_(info, tag) + end select + +end subroutine xml_put + +!=============================================================================== +! XML_PUT_OPEN_TAG_ -- +! Routine to write the opening tag with the attributes +! Arguments: +! info Structure holding information on the XML-file +! tag Tag that was encountered +! endtag Whether the end of the element was encountered +! attribs List of attribute-value pairs +! no_attribs Number of pairs in the list +! data Lines of character data found +! no_data Number of lines of character data +!=============================================================================== + +subroutine xml_put_open_tag_(info, tag, attribs, no_attribs) + + type(XML_PARSE), intent(inout) :: info + character(len=*), intent(in) :: tag + character(len=*), intent(in), dimension(:,:) :: attribs + integer, intent(in) :: no_attribs + + integer :: i + character(len=300), parameter :: indent = ' ' + + write( info%lun, '(3a)', advance = 'no' ) & + indent(1:3*info%level), '<', adjustl(tag) + do i=1,no_attribs + if (attribs(2,i)/='') then + write( info%lun, '(5a)', advance = 'no' ) & + ' ',trim(attribs(1,i)),'="', trim(attribs(2,i)),'"' + endif + enddo + write( info%lun, '(a)' ) '>' + info%level = info%level + 1 + +end subroutine xml_put_open_tag_ + +!=============================================================================== +! XML_PUT_ELEMENT_ -- +! Routine to write the complete element +! Arguments: +! info Structure holding information on the XML-file +! tag Tag that was encountered +! endtag Whether the end of the element was encountered +! attribs List of attribute-value pairs +! no_attribs Number of pairs in the list +! data Lines of character data found +! no_data Number of lines of character data +!=============================================================================== + +subroutine xml_put_element_(info, tag, attribs, no_attribs, & + data, no_data) + + type(XML_PARSE), intent(inout) :: info + character(len=*), intent(in) :: tag + character(len=*), intent(in), dimension(:,:) :: attribs + integer, intent(in) :: no_attribs + character(len=*), intent(in), dimension(:) :: data + integer, intent(in) :: no_data + + logical :: logic + character(len=1) :: aa + integer :: i, ii + + character(len=300), parameter :: indent = ' ' + + if ( (no_attribs==0 .and. no_data==0) ) then + return + else + logic = .true. + do ii = 1,no_attribs + logic = logic .and. (attribs(2,ii)=='') + enddo + do ii = 1,no_data + logic = logic .and. (data(ii)=='') + enddo + if ( logic ) then + return + else + write( info%lun, '(3a)', advance = 'no' ) & + indent(1:3*info%level), '<', adjustl(tag) + do i = 1,no_attribs + if (attribs(2,i)/='') then + write( info%lun, '(5a)', advance = 'no' ) & + ' ',trim(attribs(1,i)),'="', trim(attribs(2,i)),'"' + endif + enddo + if ( no_attribs>0 .and. no_data==0 ) then + aa='a' + elseif ( (no_attribs>0 .and. no_data>0) .or. & + (no_attribs==0 .and. no_data>0) ) then + aa='b' + else + write(*,*) no_attribs, no_data + endif + endif + endif + + select case(aa) + case('a') + write( info%lun, '(a)' ) '/>' + case('b') + write( info%lun, '(a)',advance='no' ) '>' + write( info%lun, '(2a)', advance='no') ( ' ', trim(data(i)), i=1,no_data ) + write( info%lun, '(4a)' ) ' ','' + end select + +end subroutine xml_put_element_ + +!=============================================================================== +! XML_PUT_CLOSE_TAG_ -- +! Routine to write the closing tag +! Arguments: +! info Structure holding information on the XML-file +! tag Tag that was encountered +! endtag Whether the end of the element was encountered +! attribs List of attribute-value pairs +! no_attribs Number of pairs in the list +! data Lines of character data found +! no_data Number of lines of character data +!=============================================================================== + +subroutine xml_put_close_tag_(info, tag) + + type(XML_PARSE), intent(inout) :: info + character(len=*), intent(in) :: tag + + character(len=300), parameter :: indent = ' ' + + info%level = info%level - 1 + write(info%lun, '(4a)') indent(1:3*info%level), '' + +end subroutine xml_put_close_tag_ + +!=============================================================================== +! XML_COMPRESS_ -- +! Routine to remove empty lines from the character data +! Arguments: +! data Lines of character data found +! no_data (Nett) number of lines of character data +!=============================================================================== + +subroutine xml_compress_( data, no_data ) + character(len=*), intent(inout), dimension(:) :: data + integer, intent(inout) :: no_data + + integer :: i + integer :: j + logical :: empty + + j = 0 + empty = .true. + do i = 1,no_data + if ( len_trim(data(i)) /= 0 .or. .not. empty ) then + j = j + 1 + data(j) = adjustl(data(i)) + empty = .false. + endif + enddo + + no_data = j + + do i = no_data,1,-1 + if ( len_trim(data(i)) /= 0 ) then + exit + else + no_data = no_data - 1 + endif + enddo + +end subroutine xml_compress_ + +!=============================================================================== +! XML_REPLACE_ENTITIES_ -- +! Routine to replace entities such as > by their +! proper character representation +! Arguments: +! data Lines of character data found +! no_data (Nett) number of lines of character data +!=============================================================================== + +subroutine xml_replace_entities_( data, no_data ) + character(len=*), intent(inout), dimension(:) :: data + integer, intent(inout) :: no_data + + integer :: i + integer :: j + integer :: j2 + integer :: k + integer :: pos + logical :: found + + do i = 1,no_data + j = 1 + do + do k = 1,size(entities,2) + found = .false. + pos = index( data(i)(j:), trim(entities(2,k)) ) + if ( pos > 0 ) then + found = .true. + j = j + pos - 1 + j2 = j + len_trim(entities(2,k)) + data(i)(j:) = trim(entities(1,k)) // data(i)(j2:) + j = j2 + endif + enddo + if ( .not. found ) exit + enddo + enddo + +end subroutine xml_replace_entities_ + +!=============================================================================== +! XML_OPTIONS -- +! Routine to handle the parser options +! Arguments: +! info Structure holding information on the XML-file +! ignore_whitespace Ignore whitespace (leading blanks, empty lines) or not +! no_data_truncation Consider truncation of strings an error or not +! report_lun LU-number for reporting information +! report_errors Write messages about errors or not +! report_details Write messages about all kinds of actions or not +!=============================================================================== + +subroutine xml_options( info, ignore_whitespace, no_data_truncation, & + report_lun, report_errors, & + report_details ) + type(XML_PARSE), intent(inout) :: info + logical, intent(in), optional :: ignore_whitespace + logical, intent(in), optional :: no_data_truncation + + integer, intent(in), optional :: report_lun + logical, intent(in), optional :: report_errors + logical, intent(in), optional :: report_details + + if ( present(ignore_whitespace) ) then + info%ignore_whitespace = ignore_whitespace + endif + if ( present(no_data_truncation) ) then + info%no_data_truncation = no_data_truncation + endif + if ( present(report_lun) ) then + report_lun_ = report_lun + endif + if ( present(report_errors) ) then + report_errors_ = report_errors + endif + if ( present(report_details) ) then + report_details_ = report_details + endif +end subroutine xml_options + +!=============================================================================== +! XML_OK -- +! Function that returns whether all was okay or not +! Arguments: +! info Structure holding information on the XML-file +! Returns: +! .true. if there was no error, .false. otherwise +!=============================================================================== + +logical function xml_ok( info ) + type(XML_PARSE), intent(in) :: info + + xml_ok = info%eof .or. info%error .or. & + ( info%no_data_truncation .and. & + ( info%too_many_attribs .or. info%too_many_data ) ) + xml_ok = .not. xml_ok +end function xml_ok + +!=============================================================================== +! XML_ERROR -- +! Function that returns whether there was an error +! Arguments: +! info Structure holding information on the XML-file +! Returns: +! .true. if there was an error, .false. if there was none +!=============================================================================== + +logical function xml_error( info ) + type(XML_PARSE), intent(in) :: info + + xml_error = info%error .or. & + ( info%no_data_truncation .and. & + ( info%too_many_attribs .or. info%too_many_data ) ) +end function xml_error + +!=============================================================================== +! XML_DATA_TRUNC -- +! Function that returns whether data were truncated or not +! Arguments: +! info Structure holding information on the XML-file +! Returns: +! .true. if data were truncated, .false. otherwise +!=============================================================================== + +logical function xml_data_trunc( info ) + type(XML_PARSE), intent(in) :: info + + xml_data_trunc = info%too_many_attribs .or. info%too_many_data +end function xml_data_trunc + +!=============================================================================== +! XML_FIND_ATTRIB +!=============================================================================== + +integer function xml_find_attrib( attribs, no_attribs, name, value ) + character(len=*), dimension(:,:) :: attribs + integer :: no_attribs + character(len=*) :: name + character(len=*) :: value + + integer :: i + + xml_find_attrib = -1 + do i = 1,no_attribs + if ( name == attribs(1,i) ) then + value = attribs(2,i) + xml_find_attrib = i + exit + endif + enddo + +end function xml_find_attrib + +!=============================================================================== +! XML_PROCESS -- +! Routine to read the XML file as a whole and distribute processing +! the contents over three user-defined subroutines +! Arguments: +! filename Name of the file to process +! attribs Array for holding the attributes +! data Array for holding the character data +! startfunc Subroutine to handle the start of elements +! datafunc Subroutine to handle the character data +! endfunc Subroutine to handle the end of elements +! error Indicates if there was an error or not +! Note: +! The routine is declared recursive to allow inclusion of XML files +! (common with XSD schemas). This extends to the auxiliary routines. +!=============================================================================== + +recursive & +subroutine xml_process( filename, attribs, data, startfunc, datafunc, endfunc, lunrep, error ) + character(len=*) :: filename + character(len=*), dimension(:,:) :: attribs + character(len=*), dimension(:) :: data + integer :: lunrep + logical :: error + + interface + recursive subroutine startfunc( tag, attribs, error ) + character(len=*) :: tag + character(len=*), dimension(:,:) :: attribs + logical :: error + end subroutine + end interface + + interface + recursive subroutine datafunc( tag, data, error ) + character(len=*) :: tag + character(len=*), dimension(:) :: data + logical :: error + end subroutine + end interface + + interface + recursive subroutine endfunc( tag, error ) + character(len=*) :: tag + logical :: error + end subroutine + end interface + + type(XML_PARSE) :: info + character(len=80) :: tag + logical :: endtag + integer :: noattribs + integer :: nodata + + call xml_options( info, report_lun = lunrep, report_details = .false. ) + call xml_open( info, filename, .true. ) + + error = .false. + do + call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) + if ( .not. xml_ok(info) ) then + exit + endif + + if ( xml_error(info) ) then + write(lunrep,*) 'Error reading XML file!' + error = .true. + exit + endif + + if ( .not. endtag .or. noattribs /= 0 ) then + call startfunc( tag, attribs(:,1:noattribs), error ) + if ( error ) exit + + call datafunc( tag, data(1:nodata), error ) + if ( error ) exit + endif + + if ( endtag ) then + call endfunc( tag, error ) + if ( error ) exit + endif + enddo + call xml_close( info ) +end subroutine xml_process + +!=============================================================================== +! XML_REMOVE_TABS_ -- +! Routine to change any horizontal tab characters to spaces when reading a +! new line of data +! Arguments: +! line Line of character data to modify +!=============================================================================== + +subroutine xml_remove_tabs_(line) + character(len=*), intent(inout) :: line + + integer :: i + + do i = 1, len_trim(line) + if (line(i:i) == achar(9)) then + line(i:i) = ' ' + end if + end do + +end subroutine xml_remove_tabs_ + +end module xmlparse diff --git a/src/xml-fortran/xmlreader.f90 b/src/xml-fortran/xmlreader.f90 new file mode 100644 index 0000000000..c53b1ae71f --- /dev/null +++ b/src/xml-fortran/xmlreader.f90 @@ -0,0 +1,1239 @@ +!=============================================================================== +! XMLREADER: +! Read an XML-file that contains a template for the data and the XML files +! that will be used in a program and generate a module with reading routines. +! +! TODO: +! - Private routines! +! - Error for unknown data types +! - Length for character items +!=============================================================================== + +program xmlreader + use XMLPARSE + implicit none + + character(len=60) :: fname + type(XML_PARSE) :: info + + character(len=80) :: tag + character(len=80) :: starttag + logical :: endtag + character(len=80), dimension(1:2,1:20) :: attribs + integer :: noattribs + character(len=200), dimension(1:100) :: data + integer :: nodata + integer :: i + integer :: j + integer, parameter :: notmps = 6 ! Number of temporary files needed! + integer :: ludef + integer :: ludeflt + integer :: luinit + integer :: lusubs + integer :: luprolog + integer :: lustart + integer :: luloop + integer :: luend + integer :: lumain + integer :: luwrite + integer :: luwritp + integer :: luwrv + integer :: argc + logical :: prolog_written + logical :: comp + logical :: error + logical :: begin_loop = .true. + logical :: begin_main_loop = .true. + logical :: begin_component = .false. + logical :: strict + logical :: global_type + logical :: dyn_strings + + character(len=32) :: root_name + character(len=32) :: global_name + character(len=32) :: typename + character(len=32), dimension(1:20) :: placeholder + integer :: no_placeholders + + character(len=50) :: declare + character(len=50), dimension(:,:), pointer :: types + character(len=50), dimension(:,:), pointer :: new_types + + ! TODO: arrays of integers etc, in addition to integer-arrays - see: word + integer, parameter :: notypes_predefined = 27 + character(len=50), dimension(1:4,1:notypes_predefined) :: predefined_types + integer :: notypes = notypes_predefined + data ((predefined_types(i,j) , i=1,4), j=1,notypes_predefined ) / & +'logical' ,' logical' , 'read_xml_logical', 'write_to_xml_logical', & +'logical-1dim' ,' logical, dimension(:), pointer' , 'read_xml_logical_1dim', 'write_to_xml_logical_1dim', & +'logical-array' ,' logical, dimension(:), pointer' , 'read_xml_logical_array', 'write_to_xml_logical_array', & +'logical-shape' ,' logical, dimension(SHAPE)' , 'read_xml_logical_array', 'write_to_xml_logical_array', & +'integer' ,' integer' , 'read_xml_integer', 'write_to_xml_integer', & +'integer-1dim' ,' integer, dimension(:), pointer' , 'read_xml_integer_1dim', 'write_to_xml_integer_1dim', & +'integer-array' ,' integer, dimension(:), pointer' , 'read_xml_integer_array', 'write_to_xml_integer_array', & +'integer-shape' ,' integer, dimension(SHAPE)' , 'read_xml_integer_array', 'write_to_xml_integer_array', & +'real' ,' real' , 'read_xml_real' , 'write_to_xml_real' , & +'real-1dim' ,' real, dimension(:), pointer' , 'read_xml_real_1dim', 'write_to_xml_real_1dim', & +'real-array' ,' real, dimension(:), pointer' , 'read_xml_real_array', 'write_to_xml_real_array', & +'real-shape' ,' real, dimension(SHAPE)' , 'read_xml_real_array', 'write_to_xml_real_array', & +'double' ,' real(kind=kind(1.0d0))' , 'read_xml_double', 'write_to_xml_double', & +'double-1dim' ,' real(kind=kind(1.0d0)), dimension(:), pointer' , & + 'read_xml_double_1dim', 'write_to_xml_double_1dim', & +'double-array' ,' real(kind=kind(1.0d0)), dimension(:), pointer' , & + 'read_xml_double_array', 'write_to_xml_double_array', & +'double-shape' ,' real(kind=kind(1.0d0)), dimension(SHAPE)' , & + 'read_xml_double_array', 'write_to_xml_double_array', & +'word' ,' character(len=?)' , 'read_xml_word', 'write_to_xml_word', & +'word-1dim' ,' character(len=?), dimension(:), pointer' , 'read_xml_word_1dim', 'write_to_xml_word_1dim', & +'word-array' ,' character(len=?), dimension(:), pointer' , 'read_xml_word_array', 'write_to_xml_word_array', & +'word-shape' ,' character(len=?), dimension(SHAPE)' , 'read_xml_word_array', 'write_to_xml_word_array', & +'line' ,' character(len=?)' , 'read_xml_line', 'write_to_xml_line', & +'line-1dim' ,' character(len=?), dimension(:), pointer' , 'read_xml_line_1dim', 'write_to_xml_line_1dim', & +'line-array' ,' character(len=?), dimension(:), pointer' , 'read_xml_line_array', 'write_to_xml_line_array', & +'line-shape' ,' character(len=?), dimension(SHAPE)' , 'read_xml_line_array', 'write_to_xml_line_array', & +'character' ,' character(len=?)' , 'read_xml_line', 'write_to_xml_line', & +'character-array',' character(len=?), dimension(:), pointer' , 'read_xml_line_array', 'write_to_xml_line_array', & +'character-shape',' character(len=?), dimension(SHAPE)' , 'read_xml_line_array', 'write_to_xml_line_array' / + + allocate( types(1:4,1:notypes) ) + types = predefined_types(:,1:notypes) + + ! + ! Read the global options file, if present + ! + strict = .false. + global_type = .false. + dyn_strings = .true. + call get_global_options( attribs, noattribs, strict, global_type, global_name, & + root_name, dyn_strings ) + + ! + ! Open the input file and read the name of the template. + ! Load the template into a tree and then generate it all + ! in stages + ! + argc = COMMAND_ARGUMENT_COUNT() + if (argc > 0) then + call GET_COMMAND_ARGUMENT(1, fname) + else + open(UNIT=10, FILE='xmlreader.inp') + read(UNIT=10, FMT='(a)') fname + close(UNIT=10) + end if + + open( 20, file = 'xmlreader.out' ) + call xml_options( info, report_lun = 20, report_details = .true. ) + + prolog_written = .false. + ! + ! Set the defaults + ! + global_type = .false. + global_name = fname + root_name = fname + + ludef = 21 + lusubs = 22 + luinit = 23 + luwritp = 24 + luwrv = luwritp + open( ludef, file = trim(fname)//'.f90' ) + open( lusubs, status = 'scratch' ) + open( luinit, status = 'scratch' ) + open( luwritp, status = 'scratch' ) + call open_tmp_files( 31 ) + + lumain = luloop + + ! Read the template file and act as we go along: + ! - write the declarations + ! - write the main reading routine + ! - write the individual reading routines + ! - the root element is needed because of the definition of XML files, + ! but we ignore it. + ! + call xml_open( info, trim(fname)//'.xml', .true. ) + + error = .false. + comp = .false. + no_placeholders = 0 + + call xml_get( info, starttag, endtag, attribs, noattribs, data, nodata ) + + do + call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) + write(20,*) 'tag: ',tag + write(20,*) 'attribs: ',noattribs + if ( noattribs > 0 ) then + write(20,'(4a)') ( ' ', trim(attribs(1,i)), ' = ', trim(attribs(2,i)), i=1,noattribs ) + endif + write(20,*) 'data: ',nodata + if ( nodata > 0 ) then + write(20,'(3a)') ( ' >', trim(data(i)), '<', i=1,nodata ) + endif + if ( xml_error(info) ) then + write(*,*) 'Error reading template file!' + !stop + exit + endif + + ! + ! When encountering the endtag, then close the + ! current definition + ! + if ( endtag .and. noattribs == 0 ) then + select case ( tag ) + case ( 'typedef' ) + call close_typedef( begin_component ) + case ( 'placeholder' ) + !if ( comp ) then + ! call close_placeholder + !endif + !comp = .false. + call close_placeholder + luwrv = luwritp + case default + ! + ! Have we found the end of the definition? + ! + if ( tag == starttag ) then + exit + endif + end select + + if ( xml_ok(info) ) then + cycle + else + exit + endif + + endif + + ! + ! Opening tags: dispatch on the actual tag + ! + select case( tag ) + case( 'options' ) + call set_options( attribs, noattribs, strict, global_type, & + global_name, root_name, dyn_strings ) + if ( .not. prolog_written ) then + prolog_written = .true. + call write_prolog + else + write(20,*) 'Options element should be the first child of the root element',& + 'Otherwise it has no effect!' + endif + + if ( strict ) then + write( lumain, '(a)' ) ' strict_ = .true.' + else + write( lumain, '(a)' ) ' strict_ = .false.' + endif + + case( 'comment', '!--' ) + ! Do nothing + + case( 'placeholder' ) + if ( .not. prolog_written ) then + prolog_written = .true. + call write_prolog + endif + if ( begin_loop .or. begin_main_loop ) then + begin_main_loop = .false. + call add_begin_loop( .true., .false. ) + endif + call add_placeholder(dyn_strings) + begin_component = .false. + luwrv = luwrite + + case( 'typedef' ) + if ( .not. prolog_written ) then + prolog_written = .true. + call write_prolog + endif + call add_typedef(dyn_strings) + + case( 'variable' ) + if ( .not. prolog_written ) then + prolog_written = .true. + call write_prolog + endif + if ( begin_loop .or. begin_main_loop ) then + begin_main_loop = .false. + call add_begin_loop( .true., begin_component ) + endif + call add_variable( component=comp ) + + case( 'component' ) + ! + ! Components of derived types are treated in much the + ! same way as ordinary variables - with one syntactic + ! difference + ! + if ( .not. prolog_written ) then + prolog_written = .true. + call write_prolog + endif + if ( begin_loop ) then + call add_begin_loop( .true., .true. ) + endif + call add_variable( component=.true. ) + begin_component = .true. + + case default + write(20,*) 'Unknown tag: ',trim(tag) + write(20,*) '-- terminating the program!' + stop + end select + end do + + ! + ! Now finish it all + ! + write( luend, '(a)' ) & + & ' if ( present(errout) ) errout = error', & + & 'end subroutine', & + & ' ' + write( luwritp, '(a)' ) & + & ' write(info%lun,''(a)'') ''''', & + & ' call xml_close(info)', & + & 'end subroutine', & + & ' ' + + call append_files( luprolog ) + call merge_files + + write( ludef, '(/,a)' ) & + & 'end subroutine', & + & 'end module' + + if ( error ) then + write(*,*) 'Errors found in the definition - please check!' + endif + stop +contains + +!=============================================================================== +! GET_GLOBAL_OPTIONS -- +! Routine to get the global options from the configuration file +! Arguments: +! strict Option to make the parser check for unknown tags +! global_type Option to generate an overall derived type +! global_name Name of that overall derived type (if requested) +! root_name Name of the root element of the XML file +! dyn_strings Whether to use dynamic strings or not +!=============================================================================== + +subroutine get_global_options( attribs, noattribs, strict, global_type, global_name, & + root_name, dyn_strings ) + character(len=*), dimension(:,:), intent(inout) :: attribs + integer, intent(inout) :: noattribs + logical, intent(inout) :: strict + logical, intent(inout) :: global_type + character(len=*), intent(inout) :: global_name + character(len=*), intent(inout) :: root_name + logical, intent(inout) :: dyn_strings + + character(len=20) :: tag + character(len=20), dimension(1) :: data + integer :: nodata + logical :: exists + logical :: endtag + type(XML_PARSE) :: info + + inquire( file = 'xmlreader.conf', exist = exists ) + if ( exists ) then + call xml_open( info, 'xmlreader.conf', .true. ) + do while ( xml_ok(info) ) + call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) + if ( tag == 'xmlreader' ) then + call set_options( attribs, noattribs, strict, global_type, & + global_name, root_name, dyn_strings ) + endif + enddo + call xml_close( info ) + endif +end subroutine get_global_options + +!=============================================================================== +! SET_OPTIONS -- +! Routine to set the options that influence the parser +! Arguments: +! attribs List of attributes +! noattribs Number of attributes +! strict Option to make the parser check for unknown tags +! global_type Option to generate an overall derived type +! global_name Name of that overall derived type (if requested) +! root_name Name of the root element of the XML file +! dyn_strings Whether to use dynamic strings or not +!=============================================================================== + +subroutine set_options( attribs, noattribs, strict, global_type, global_name, root_name, dyn_strings ) + character(len=*), dimension(:,:), intent(in) :: attribs + integer, intent(in) :: noattribs + logical, intent(inout) :: strict + logical, intent(inout) :: global_type + character(len=*), intent(inout) :: global_name + character(len=*), intent(inout) :: root_name + logical, intent(inout) :: dyn_strings + + integer :: i + + do i = 1,noattribs + select case (attribs(1,i)) + case ('strict') + if ( attribs(2,i) == 'yes' ) then + strict = .true. + else + strict = .false. + endif + case ('globaltype') + if ( attribs(2,i) == 'yes' ) then + global_type = .true. + else + global_type = .false. + endif + case ('globalname') + global_name = attribs(2,i) + case ('rootname') + root_name = attribs(2,i) + case ('dynamicstrings') + if ( attribs(2,i) == 'yes' ) then + dyn_strings = .true. + else + dyn_strings = .false. + endif + case default + write(20,*) 'Unknown option: ',trim(attribs(1,i)), ' - ignored' + end select + enddo +end subroutine set_options + +!=============================================================================== +! OPEN_TMP_FILES -- +! Routine to open the temporary files +! Arguments: +! lufirst First LU-number to use +!=============================================================================== + +subroutine open_tmp_files( lufirst ) + integer, intent(in) :: lufirst + + luprolog = lufirst + lustart = lufirst + 1 + luloop = lufirst + 2 + luend = lufirst + 3 + ludeflt = lufirst + 4 + luwrite = lufirst + 5 + open( luprolog, status = 'scratch' ) + open( lustart, status = 'scratch' ) + open( luloop, status = 'scratch' ) + open( luend, status = 'scratch' ) + open( ludeflt, status = 'scratch' ) + open( luwrite, status = 'scratch' ) +end subroutine open_tmp_files + +!=============================================================================== +! CLOSE_TMP_FILES -- +! Routine to close the temporary files +! Arguments: +! None +!=============================================================================== + +subroutine close_tmp_files + close( luprolog ) + close( lustart ) + close( luloop ) + close( luend ) + close( ludeflt ) + close( luwrite ) + + luprolog = luprolog - notmps + lustart = lustart - notmps + luloop = luloop - notmps + luend = luend - notmps + ludeflt = ludeflt - notmps + luwrite = luwrite - notmps +end subroutine close_tmp_files + +!=============================================================================== +! APPEND_TMP_FILES -- +! Routine to append the contents of the temporary files +! Arguments: +! lufirst First LU-number to use +!=============================================================================== + +subroutine append_files( lufirst ) + integer, intent(in) :: lufirst + + integer :: lu + integer :: io + character(len=120) :: line + + ! + ! If we have not written a subroutine yet, then + ! now is the time to close the overall initialisation + ! routine + ! -- no longer needed + ! + !if ( .not. contains ) then + ! write( lusubs, '(a,/)' ) 'end subroutine' + ! contains = .true. + !endif + + ! + ! Copy the contents of the scratch files + ! + do lu = lufirst,lufirst+notmps-1 + rewind( lu ) + do + read( lu, '(a)', iostat=io ) line + if ( io /= 0 ) exit + write( lusubs, '(a)' ) trim(line) + enddo + rewind( lu ) + enddo +end subroutine append_files + +!=============================================================================== +! MERGE_FILES -- +! Routine to merge all temporary files into the definite file +! Arguments: +! None +!=============================================================================== + +subroutine merge_files + + integer :: io + character(len=120) :: line + + ! + ! Copy the contents of the "subroutines" file + ! + rewind( lusubs ) + do + read( lusubs, '(a)', iostat=io ) line + if ( io /= 0 ) exit + write( ludef, '(a)' ) trim(line) + enddo + + ! + ! Copy the contents of the "write xml file subroutine" file + ! + rewind( luwritp ) + do + read( luwritp, '(a)', iostat=io ) line + if ( io /= 0 ) exit + write( ludef, '(a)' ) trim(line) + enddo + + ! + ! Copy the contents of the "initialisation subroutine" file + ! + rewind( luinit ) + do + read( luinit, '(a)', iostat=io ) line + if ( io /= 0 ) exit + write( ludef, '(a)' ) trim(line) + enddo +end subroutine merge_files + +!=============================================================================== +! WRITE_PROLOG -- +! Routine to write the beginning of the module +! Arguments: +! None +!=============================================================================== + +subroutine write_prolog + write( ludef, '(a)' ) & + & 'module xml_data_' // trim(fname), & + & ' use READ_XML_PRIMITIVES', & + & ' use WRITE_XML_PRIMITIVES', & + & ' use XMLPARSE', & + & ' implicit none', & + & ' integer, private :: lurep_', & + & ' logical, private :: strict_' + + write( luprolog, '(a)' ) & + & 'subroutine read_xml_file_'//trim(fname)//'(fname, lurep, errout)' , & + & ' character(len=*), intent(in) :: fname' , & + & ' integer, intent(in), optional :: lurep' , & + & ' logical, intent(out), optional :: errout' , & + & ' ' , & + & ' type(XML_PARSE) :: info' , & + & ' logical :: error' , & + & ' character(len=80) :: tag' , & + & ' character(len=80) :: starttag' , & + & ' logical :: endtag' , & + & ' character(len=80), dimension(1:2,1:20) :: attribs' , & + & ' integer :: noattribs' , & + & ' character(len=200), dimension(1:100) :: data' , & + & ' integer :: nodata' + + write( lusubs, '(a)' ) & + & 'contains' + write( luinit, '(a)' ) & + & 'subroutine init_xml_file_'//trim(fname) + + write( luwritp, '(a)' ) & + & 'subroutine write_xml_file_'//trim(fname)//'(fname, lurep)' , & + & ' character(len=*), intent(in) :: fname' , & + & ' integer, intent(in), optional :: lurep' , & + & ' ' , & + & ' type(XML_PARSE) :: info' , & + & ' integer :: indent = 0', & + & ' ' , & + & ' call xml_open( info, fname, .false. )' , & + & ' call xml_options( info, report_errors=.true.)' , & + & ' if ( present(lurep) ) then' , & + & ' call xml_options( info, report_errors=.true.)' , & + & ' endif' , & + & ' write(info%lun,''(a)'') &' , & + & ' ''<' // trim(root_name) // '>''' + + write( lumain, '(a)' ) & + & ' ', & + & ' call init_xml_file_'//trim(fname), & + & ' call xml_open( info, fname, .true. )', & + & ' call xml_options( info, report_errors=.false., ignore_whitespace=.true.)', & + & ' lurep_ = 0', & + & ' if ( present(lurep) ) then', & + & ' lurep_ = lurep', & + & ' call xml_options( info, report_lun=lurep )', & + & ' endif', & + & ' do', & + & ' call xml_get( info, starttag, endtag, attribs, noattribs, &', & + & ' data, nodata)', & + & ' if ( starttag /= ''!--'' ) exit', & + & ' enddo', & + & ' if ( starttag /= "' // trim(root_name) // '" ) then', & + & ' call xml_report_errors( info, &', & + & ' ''XML-file should have root element "' // trim(root_name) // '"'')', & + & ' error = .true.', & + & ' call xml_close(info)', & + & ' return', & + & ' endif' + + call add_end_loop +end subroutine write_prolog + +!=============================================================================== +! ADD_BEGIN_LOOP -- +! Routine to write the start of the reading loop +! Arguments: +! checktag Whether code for checking the tag is required +! component Whether this is an ordinary variable or a component +! in a derived type +!=============================================================================== + +subroutine add_begin_loop( checktag, component ) + logical :: checktag + logical :: component + + if ( component ) then + write( luloop, '(a)' ) & + & ' call init_xml_type_'//trim(typename)//'(dvar)', & + & ' has_dvar = .true.' + endif + + begin_loop = .false. + + if ( component ) then + write( luloop, '(a)' ) & + & ' error = .false.' ,& + & ' att_ = 0' ,& + & ' noatt_ = noattribs+1' ,& + & ' endtag_org = endtag' ,& + & ' do', & + & ' if ( nodata /= 0 ) then' ,& + & ' noattribs = 0' ,& + & ' tag = starttag' ,& + & ' elseif ( att_ < noatt_ .and. noatt_ > 1 ) then' ,& + & ' att_ = att_ + 1' ,& + & ' if ( att_ <= noatt_-1 ) then' ,& + & ' tag = attribs(1,att_)' ,& + & ' data(1) = attribs(2,att_)' ,& + & ' noattribs = 0' ,& + & ' nodata = 1' ,& + & ' endtag = .false.' ,& + & ' else' ,& + & ' tag = starttag' ,& + & ' noattribs = 0' ,& + & ' nodata = 0' ,& + & ' endtag = .true.' ,& + & ' cycle' ,& + & ' endif' ,& + & ' else', & + & ' if ( endtag_org ) then', & + & ' return', & + & ' else', & + & ' call xml_get( info, tag, endtag, attribs, noattribs, data, nodata )' ,& + & ' if ( xml_error(info) ) then' ,& + & ' write(lurep_,*) ''Error reading input file!''',& + & ' error = .true.' ,& + & ' return' ,& + & ' endif' ,& + & ' endif' ,& + & ' endif' + else + write( luloop, '(a)' ) & + & ' error = .false.' ,& + & ' do', & + & ' call xml_get( info, tag, endtag, attribs, noattribs, data, nodata )' ,& + & ' if ( xml_error(info) ) then' ,& + & ' write(lurep_,*) ''Error reading input file!''' ,& + & ' error = .true.' ,& + & ' return' ,& + & ' endif' + endif + if ( checktag ) then + write( luloop, '(a)' ) & + & ' if ( endtag .and. tag == starttag ) then' ,& + & ' exit' ,& + & ' endif' + endif + write( luloop, '(a)' ) & + & ' if ( endtag .and. noattribs == 0 ) then' ,& + & ' if ( xml_ok(info) ) then' ,& + & ' cycle' ,& + & ' else' ,& + & ' exit' ,& + & ' endif' ,& + & ' endif' ,& + & ' select case( tag )' +end subroutine add_begin_loop + +!=============================================================================== +! ADD_END_LOOP -- +! Routine to write the end of the reading loop +! Arguments: +! None +!=============================================================================== + +subroutine add_end_loop + + write( luend, '(a)' ) & + & ' case (''comment'', ''!--'')' ,& + & ' ! Simply ignore', & + & ' case default' ,& + & ' if ( strict_ ) then', & + & ' error = .true.', & + & ' call xml_report_errors( info, &', & + & ' ''Unknown or wrongly placed tag: '' // trim(tag))',& + & ' endif' + + write( luend, '(a)' ) & + & ' end select' ,& + & ' nodata = 0' ,& + & ' if ( .not. xml_ok(info) ) exit' , & + & ' end do' +end subroutine add_end_loop + +!=============================================================================== +! ADD_VARIABLE -- +! Routine to write the definition of variables or components of +! derived types +! Arguments: +! component Whether this is an ordinary variable or a component +! in a derived type +!=============================================================================== + +subroutine add_variable( component ) + logical :: component + + integer :: idx1 + integer :: idx2 + integer :: idx3 + integer :: idx4 + integer :: idx5 + integer :: idx6 + integer :: idx7 + integer :: k + integer :: vdim + + character(len=32) :: varname + character(len=40) :: varcomp + character(len=40) :: varshape + character(len=100) :: vardefault + character(len=32) :: vartype + character(len=32) :: vartag + character(len=10) :: dim + character(len=10) :: strlength + character(len=32) :: initptr + + idx1 = xml_find_attrib( attribs, noattribs, 'name', varname ) + idx2 = xml_find_attrib( attribs, noattribs, 'type', vartype ) + strlength = "--" + idx5 = xml_find_attrib( attribs, noattribs, 'length', strlength ) + if ( idx1 <= 0 ) then + write( 20, * ) 'Variable/component found which has no name' + error = .true. + endif + if ( idx2 <= 0 ) then + write( 20, * ) 'Variable/component found which has no type - ',trim(varname) + error = .true. + else + dim = '--' + idx7 = xml_find_attrib( attribs, noattribs, 'dimension', dim ) + idx6 = xml_find_attrib( attribs, noattribs, 'shape', varshape ) + if ( idx7 >= 1 ) then + if ( dim == '1' ) then + idx3 = xml_find_attrib( types, notypes, vartype, declare ) + if ( idx3 > notypes_predefined ) then + vartype = trim(vartype) // '-array' + else + vartype = trim(vartype) // '-1dim' + endif + else + error = .true. + write(20,*) 'Dimension not supported: ',dim + endif + endif + if ( idx6 >= 1 ) then + vartype = trim(vartype) // '-shape' + vdim = 1 + if ( index(varshape, ',') > 0 ) then + vdim = 2 + endif + endif + + idx3 = xml_find_attrib( types, notypes, vartype, declare ) + if ( idx3 <= 0 ) then + write( 20, * ) & + 'Variable/component with unknown type - ',trim(varname) + error = .true. + endif + endif + + idx4 = xml_find_attrib( attribs, noattribs, 'default', vardefault ) + + if ( component ) then + varcomp = 'dvar%'//varname + else + varcomp = varname + endif + + idx1 = xml_find_attrib( attribs, noattribs, 'tag', vartag ) + if ( idx1 < 1 ) then + vartag = varname + endif + + if ( .not. error ) then + if ( index( declare, "pointer" ) > 0 ) then + initptr = " => null()" + else + initptr = "" + endif + + k = index( declare, 'SHAPE' ) + if ( k > 0 ) then + declare = declare(1:k-1) // trim(varshape) // declare(k+5:) + endif + + if ( index( declare, "?" ) <= 0 ) then + write( ludef, '(4a)' ) declare, ' :: ', trim(varname), trim(initptr) + else + if ( strlength == "--" ) then + strlength = "1" ! Hm, error is better? + endif + idx5 = index( declare, "?" ) + write( ludef, '(6a)' ) declare(1:idx5-1), trim(strlength), declare(idx5+1:), & + ' :: ', trim(varname), trim(initptr) + endif + + if ( idx6 > 0 ) then + k = index( types(2,idx3-1), '?' ) + if ( k <= 0 ) then + write( luprolog, '(3a)' ) types(2,idx3-1), ' :: ', 'p_'//trim(varname) + else + write( luprolog, '(6a)' ) types(2,idx3-1)(1:k-1), trim(strlength), & + types(2,idx3-1)(k+1:), ' :: ', 'p_'//trim(varname) + endif + endif + write( luprolog, '(3a)' ) types(2,1), ' :: ', 'has_'//trim(varname) + write( lustart, '(3a)' ) ' has_', varname, ' = .false.' + if ( dim /= '--' ) then + write( lustart, '(3a)' ) ' allocate(' // trim(varcomp), '(0))' + endif + write( luloop, '(a)' ) ' case('''//trim(vartag)//''')' + + if ( idx6 <= 0 ) then + write( luloop, '(a)' ) & + &' call '//trim(types(3,idx3))//'( &', & + &' info, tag, endtag, attribs, noattribs, data, nodata, &',& + &' ' // trim(varcomp) // ', has_'//trim(varname) // ' )' + else + write( luloop, '(a)' ) & + &' call '//trim(types(3,idx3))//'( &', & + &' info, tag, endtag, attribs, noattribs, data, nodata, &',& + &' p_' // trim(varname) // ', has_'//trim(varname) // ' )',& + &' if ( has_'//trim(varname) // ') then' + if ( vdim == 1 ) then + write( luloop, '(a)' ) & + &' if ( size('//trim(varcomp)//') <= size(p_'//trim(varname)//') ) then', & + &' '//trim(varcomp) // ' = p_'//trim(varname)//'(1:size('//trim(varcomp)//'))', & + &' else', & + &' '//trim(varcomp) // '(1:size(p_'//trim(varname)//')) = p_'//trim(varname), & + &' endif' + else + write( luloop, '(a)' ) & + &' if ( size(p_'//trim(varname)//') >= size('//trim(varcomp)//') ) then',& + &' '//trim(varcomp)//' = reshape(p_'//trim(varname)//', shape('//trim(varcomp)//'))',& + &' else',& + &' has_'//trim(varname)//' = .false.',& + &' call xml_report_errors(info, ''Incorrect number of values for '//trim(varname)//''')', & + &' endif' + endif + write( luloop, '(a)' ) & + &' deallocate( p_'//trim(varname)//' )', & + &' endif' + endif + if ( idx4 <= 0 ) then + write( luend, '(a)' ) & + &' if ( .not. has_'//trim(varname)//' ) then' + + if ( component ) then + write( luend, '(a)' ) & + &' has_dvar = .false.' + else + write( luend, '(a)' ) & + &' error = .true.' + endif + + write( luend, '(a)' ) & + &' call xml_report_errors(info, ''Missing data on '//trim(varname)//''')', & + &' endif' + else + ! + ! Note: the attribute value is supposed to have the quotes, if that + ! is relevant for the variable's type + ! + if ( component ) then + write( ludeflt, '(4a)' ) & + &' dvar%', trim(varname), ' = ', attribs(2,idx4) + else + write( luinit, '(4a)' ) & + &' ', trim(varname), ' = ', attribs(2,idx4) + endif + endif + ! + ! Write the component/variable + ! + if ( component ) then + write( luwrite, '(4a)' ) & + &' call '//trim(types(4,idx3))//'(', & + &' info, '''//trim(vartag)//''', indent+3, dvar%', trim(varname), ')' + else + write( luwrv, '(4a)' ) & + &' call '//trim(types(4,idx3))//'(', & + &' info, '''//trim(vartag)//''', indent+3, ', trim(varname), ')' + endif + endif + +end subroutine add_variable + +!=============================================================================== +! ADD_TYPEDEF -- +! Routine to write the definition and other code for a derived type +! Arguments: +! dyn_strings Whether dynamic string lengths are allowed +!=============================================================================== + +subroutine add_typedef( dyn_strings ) + logical, intent(in) :: dyn_strings + + integer :: idx1 + integer :: idx2 + + character(len=32) :: typetag + + idx1 = xml_find_attrib( attribs, noattribs, 'name', typename ) + if ( idx1 <= 0 ) then + write( 20, * ) 'Type definition found which has no name' + error = .true. + endif + + ! + ! We need a new set of temporary files + ! + call open_tmp_files( luprolog+notmps ) + + idx2 = xml_find_attrib( attribs, noattribs, 'tag', typetag ) + if ( idx1 < 1 ) then + typetag = typename + endif + + if ( .not. error ) then + write( ludef, '(/,2a)' ) 'type ',trim(typename) + write( luprolog, '(a)' ) & + & 'subroutine read_xml_type_'//trim(typename)//'_array( &' ,& + & ' info, tag, endtag, attribs, noattribs, data, nodata, &',& + & ' dvar, has_dvar )' ,& + & ' type(XML_PARSE) :: info' ,& + & ' character(len=*), intent(inout) :: tag ',& + & ' logical, intent(inout) :: endtag ',& + & ' character(len=*), dimension(:,:), intent(inout) :: attribs',& + & ' integer, intent(inout) :: noattribs',& + & ' character(len=*), dimension(:), intent(inout) :: data ',& + & ' integer, intent(inout) :: nodata ',& + & ' type('//trim(typename)//'), dimension(:), pointer :: dvar ',& + & ' logical, intent(inout) :: has_dvar ',& + & ' ' ,& + & ' integer :: newsize ',& + & ' type('//trim(typename)//'), dimension(:), pointer :: newvar',& + & ' ' ,& + & ' newsize = size(dvar) + 1' ,& + & ' allocate( newvar(1:newsize) )' ,& + & ' newvar(1:newsize-1) = dvar' ,& + & ' deallocate( dvar )' ,& + & ' dvar => newvar' ,& + & ' ' ,& + & ' call read_xml_type_'//trim(typename)// & + & '( info, tag, endtag, attribs, noattribs, data, nodata, &',& + & ' dvar(newsize), has_dvar )' ,& + & 'end subroutine read_xml_type_'//trim(typename)//'_array' ,& + & ' ' + + write( luwrite, '(a)' ) & + & 'subroutine write_xml_type_'//trim(typename)//'_array( &' ,& + & ' info, tag, indent, dvar )' ,& + & ' type(XML_PARSE) :: info' ,& + & ' character(len=*), intent(in) :: tag' ,& + & ' integer :: indent',& + & ' type('//trim(typename)//'), dimension(:) :: dvar' ,& + & ' integer :: i' ,& + & ' do i = 1,size(dvar)' ,& + & ' call write_xml_type_'//trim(typename)// & + & '( info, tag, indent, dvar(i) )' ,& + & ' enddo' ,& + & 'end subroutine write_xml_type_'//trim(typename)//'_array' ,& + & ' ', & + & 'subroutine write_xml_type_'//trim(typename)//'( &' ,& + & ' info, tag, indent, dvar )' ,& + & ' type(XML_PARSE) :: info' ,& + & ' character(len=*), intent(in) :: tag' ,& + & ' integer :: indent',& + & ' type('//trim(typename)//') :: dvar' ,& + & ' character(len=100) :: indentation' ,& + & ' indentation = '' ''' ,& + & ' write(info%lun, ''(4a)'' ) indentation(1:min(indent,100)),&',& + & ' ''<'',trim(tag), ''>''' + + write( luprolog, '(a)' ) & + & 'subroutine read_xml_type_'//trim(typename)//& + & '( info, starttag, endtag, attribs, noattribs, data, nodata, &' ,& + & ' dvar, has_dvar )' ,& + & ' type(XML_PARSE) :: info' ,& + & ' character(len=*), intent(in) :: starttag',& + & ' logical, intent(inout) :: endtag ',& + & ' character(len=*), dimension(:,:), intent(inout) :: attribs',& + & ' integer, intent(inout) :: noattribs',& + & ' character(len=*), dimension(:), intent(inout) :: data ',& + & ' integer, intent(inout) :: nodata ',& + & ' type('//trim(typename)//'), intent(inout) :: dvar' ,& + & ' logical, intent(inout) :: has_dvar ',& + & ' ' ,& + & ' integer :: att_ ',& + & ' integer :: noatt_ ',& + & ' logical :: error ',& + & ' logical :: endtag_org' + if ( dyn_strings ) then + write( luprolog, '(a)' ) & + & ' character(len=len(starttag)) :: tag ' + else + write( luprolog, '(a)' ) & + & ' character(len=80) :: tag ' + endif + + ! + ! Note: this may require a more sophisticated approach + ! when the components of the type are also pointers ... + ! + write( ludeflt, '(a)' ) & + & 'subroutine init_xml_type_'//trim(typename)//'_array( dvar ) ',& + & ' type('//trim(typename)//'), dimension(:), pointer :: dvar ',& + & ' if ( associated( dvar ) ) then' ,& + & ' deallocate( dvar )' ,& + & ' endif' ,& + & ' allocate( dvar(0) )' ,& + & 'end subroutine init_xml_type_'//trim(typename)//'_array' ,& + & 'subroutine init_xml_type_'//trim(typename)//'(dvar)' ,& + & ' type('//trim(typename)//') :: dvar ' + + begin_loop = .true. + + call add_end_loop + + ! + ! Add the names of the two new types to the list + ! + allocate( new_types(1:4,1:notypes+3) ) + new_types(:,1:notypes) = types + deallocate( types ) + types => new_types + + types(1,notypes+1) = typename + types(2,notypes+1) = ' type('//trim(typename)//')' + types(3,notypes+1) = 'read_xml_type_'//trim(typename) + types(4,notypes+1) = 'write_xml_type_'//trim(typename) + + types(1,notypes+2) = trim(typename) // '-array' + types(2,notypes+2) = ' type('//trim(typename)//'), dimension(:), pointer' + types(3,notypes+2) = 'read_xml_type_'//trim(typename)//'_array' + types(4,notypes+2) = 'write_xml_type_'//trim(typename)//'_array' + + types(1,notypes+3) = trim(typename) // '-shape' + types(2,notypes+3) = ' type('//trim(typename)//'), dimension(SHAPE)' + types(3,notypes+3) = 'read_xml_type_'//trim(typename)//'_array' + types(4,notypes+3) = 'write_xml_type_'//trim(typename)//'_array' + + notypes = notypes + 3 + + endif +end subroutine add_typedef + +!=============================================================================== +! CLOSE_TYPEDEF -- +! Routine to write the last code fragments for a derived type +! Arguments: +! component Turn off the "component" parameter +!=============================================================================== + +subroutine close_typedef( component ) + logical, intent(out) :: component + + component = .false. + write( ludef, '(a)' ) 'end type '//trim(typename) + write( luend, '(a)' ) & + & 'end subroutine read_xml_type_'//trim(typename) + write( ludeflt, '(a)' ) & + & 'end subroutine init_xml_type_'//trim(typename) + write( luwrite, '(a)' ) & + & ' write(info%lun,''(4a)'') indentation(1:min(indent,100)), &' ,& + & ' ''''', & + & 'end subroutine write_xml_type_'//trim(typename) ,& + & ' ' + call append_files( luprolog ) + call close_tmp_files + +end subroutine close_typedef + +!=============================================================================== +! ADD_PLACEHOLDER -- +! Routine to write the starting code fragments for a placeholder tag +! Arguments: +! dyn_strings Whether dynamic string lengths are allowed +!=============================================================================== + +subroutine add_placeholder( dyn_strings ) + logical, intent(in) :: dyn_strings + + integer :: idx1 + integer :: idx2 + + character(len=32) :: tag + character(len=20) :: optional + + idx1 = xml_find_attrib( attribs, noattribs, 'tag', tag ) + if ( idx1 <= 0 ) then + write( 20, * ) 'Placeholder definition found which has no tag name' + error = .true. + endif + + optional = 'no' + idx2 = xml_find_attrib( attribs, noattribs, 'optional', optional ) + + if ( optional == 'yes' ) then + if ( begin_loop ) then + call add_begin_loop( .false., .false. ) + endif + write( luloop, '(a)' ) & + ' case('''//trim(tag)//''')',& + ' ! Simply ignore the tag' + else + no_placeholders = no_placeholders + 1 + placeholder(no_placeholders) = tag + + write( luloop, '(a)' ) & + ' case('''//trim(tag)//''')',& + &' call read_xml_place_'//trim(tag)//'( info, &', & + &' tag, attribs, noattribs, data, nodata )' + comp = .false. + + ! + ! We need a new set of temporary files + ! + call open_tmp_files( luprolog+notmps ) + + ! + ! Write the first part of the routine + ! NOTE: + ! Will require an extra argument when collecting all variables + ! in one derived type + ! + write( luprolog, '(a)' ) & + & 'subroutine read_xml_place_'//trim(tag)//& + & '( info, starttag, attribs, noattribs, data, nodata )' ,& + & ' type(XML_PARSE) :: info' ,& + & ' character(len=*), intent(in) :: starttag',& + & ' character(len=*), dimension(:,:), intent(inout) :: attribs',& + & ' integer, intent(inout) :: noattribs',& + & ' character(len=*), dimension(:), intent(inout) :: data ',& + & ' integer, intent(inout) :: nodata ',& + & ' ' ,& + & ' logical :: error ',& + & ' logical :: endtag ' + if ( dyn_strings ) then + write( luprolog, '(a)' ) & + & ' character(len=len(starttag)) :: tag ' + else + write( luprolog, '(a)' ) & + & ' character(len=80) :: tag ' + endif + + begin_loop = .true. + + call add_end_loop + + write(luwrite,'(a)') & + &'subroutine write_xml_place_'//trim(tag)//'( &' ,& + &' info, indent )' ,& + &' type(XML_PARSE) :: info' ,& + &' integer :: indent',& + &' character(len=100) :: indentation' ,& + &' indentation = '' ''' ,& + &' write(info%lun, ''(4a)'' ) indentation(1:min(indent,100)),&',& + &' ''<'// trim(tag) // '>''' + write(luwritp,'(a)') & + &' call write_xml_place_'//trim(tag)//'( info, indent+3 )' + + endif +end subroutine add_placeholder + +!=============================================================================== +! CLOSE_PLACEHOLDER -- +! Routine to write the last code fragments for a placeholder +! Arguments: +! None +!=============================================================================== + +subroutine close_placeholder + + write( luend, '(a)' ) & + & 'end subroutine read_xml_place_'//trim(placeholder(no_placeholders)) + + write( luwrite, '(a)' ) & + & ' write(info%lun,''(4a)'') indentation(1:min(indent,100)), &' ,& + & ' ''''' ,& + & 'end subroutine write_xml_place_'//trim(placeholder(no_placeholders)) ,& + & ' ' + + call append_files( luprolog ) + call close_tmp_files + + no_placeholders = no_placeholders - 1 + +end subroutine close_placeholder + +end program diff --git a/src/xml_geometry.f90 b/src/xml_geometry.f90 deleted file mode 100644 index 97b5dd5055..0000000000 --- a/src/xml_geometry.f90 +++ /dev/null @@ -1,737 +0,0 @@ -module xml_data_geometry_t - use READ_XML_PRIMITIVES - use WRITE_XML_PRIMITIVES - use XMLPARSE - implicit none - integer, private :: lurep_ - logical, private :: strict_ - -type cell_xml - integer :: uid - integer :: universe - integer :: material - integer :: fill - integer, dimension(:), pointer :: surfaces => null() -end type cell_xml - -type surface_xml - integer :: uid - character(len=15) :: type - real(kind=kind(1.0d0)), dimension(:), pointer :: coeffs => null() - character(len=12) :: boundary -end type surface_xml - -type lattice_xml - integer :: uid - character(len=12) :: type - integer, dimension(:), pointer :: dimension => null() - real(kind=kind(1.0d0)), dimension(:), pointer :: origin => null() - real(kind=kind(1.0d0)), dimension(:), pointer :: width => null() - integer, dimension(:), pointer :: universes => null() -end type lattice_xml - type(cell_xml), dimension(:), pointer :: cell_ => null() - type(surface_xml), dimension(:), pointer :: surface_ => null() - type(lattice_xml), dimension(:), pointer :: lattice_ => null() -contains -subroutine read_xml_type_cell_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(inout) :: tag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(cell_xml), dimension(:), pointer :: dvar - logical, intent(inout) :: has_dvar - - integer :: newsize - type(cell_xml), dimension(:), pointer :: newvar - - newsize = size(dvar) + 1 - allocate( newvar(1:newsize) ) - newvar(1:newsize-1) = dvar - deallocate( dvar ) - dvar => newvar - - call read_xml_type_cell_xml( info, tag, endtag, attribs, noattribs, data, nodata, & - dvar(newsize), has_dvar ) -end subroutine read_xml_type_cell_xml_array - -subroutine read_xml_type_cell_xml( info, starttag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: starttag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(cell_xml), intent(inout) :: dvar - logical, intent(inout) :: has_dvar - - integer :: att_ - integer :: noatt_ - logical :: error - logical :: endtag_org - character(len=len(starttag)) :: tag - logical :: has_uid - logical :: has_universe - logical :: has_material - logical :: has_fill - logical :: has_surfaces - has_uid = .false. - has_universe = .false. - has_material = .false. - has_fill = .false. - has_surfaces = .false. - call init_xml_type_cell_xml(dvar) - has_dvar = .true. - error = .false. - att_ = 0 - noatt_ = noattribs+1 - endtag_org = endtag - do - if ( nodata /= 0 ) then - noattribs = 0 - tag = starttag - elseif ( att_ < noatt_ .and. noatt_ > 1 ) then - att_ = att_ + 1 - if ( att_ <= noatt_-1 ) then - tag = attribs(1,att_) - data(1) = attribs(2,att_) - noattribs = 0 - nodata = 1 - endtag = .false. - else - tag = starttag - noattribs = 0 - nodata = 0 - endtag = .true. - cycle - endif - else - if ( endtag_org ) then - return - else - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( xml_error(info) ) then - write(lurep_,*) 'Error reading input file!' - error = .true. - return - endif - endif - endif - if ( endtag .and. tag == starttag ) then - exit - endif - if ( endtag .and. noattribs == 0 ) then - if ( xml_ok(info) ) then - cycle - else - exit - endif - endif - select case( tag ) - case('uid') - call read_xml_integer( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%uid, has_uid ) - case('universe') - call read_xml_integer( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%universe, has_universe ) - case('material') - call read_xml_integer( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%material, has_material ) - case('fill') - call read_xml_integer( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%fill, has_fill ) - case('surfaces') - call read_xml_integer_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%surfaces, has_surfaces ) - case ('comment', '!--') - ! Simply ignore - case default - if ( strict_ ) then - error = .true. - call xml_report_errors( info, & - 'Unknown or wrongly placed tag: ' // trim(tag)) - endif - end select - nodata = 0 - if ( .not. xml_ok(info) ) exit - end do - if ( .not. has_uid ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on uid') - endif - if ( .not. has_surfaces ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on surfaces') - endif -end subroutine read_xml_type_cell_xml -subroutine init_xml_type_cell_xml_array( dvar ) - type(cell_xml), dimension(:), pointer :: dvar - if ( associated( dvar ) ) then - deallocate( dvar ) - endif - allocate( dvar(0) ) -end subroutine init_xml_type_cell_xml_array -subroutine init_xml_type_cell_xml(dvar) - type(cell_xml) :: dvar - dvar%universe = 0 - dvar%material = 0 - dvar%fill = 0 -end subroutine init_xml_type_cell_xml -subroutine write_xml_type_cell_xml_array( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(cell_xml), dimension(:) :: dvar - integer :: i - do i = 1,size(dvar) - call write_xml_type_cell_xml( info, tag, indent, dvar(i) ) - enddo -end subroutine write_xml_type_cell_xml_array - -subroutine write_xml_type_cell_xml( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(cell_xml) :: dvar - character(len=100) :: indentation - indentation = ' ' - write(info%lun, '(4a)' ) indentation(1:min(indent,100)),& - '<',trim(tag), '>' - call write_to_xml_integer( info, 'uid', indent+3, dvar%uid) - call write_to_xml_integer( info, 'universe', indent+3, dvar%universe) - call write_to_xml_integer( info, 'material', indent+3, dvar%material) - call write_to_xml_integer( info, 'fill', indent+3, dvar%fill) - call write_to_xml_integer_array( info, 'surfaces', indent+3, dvar%surfaces) - write(info%lun,'(4a)') indentation(1:min(indent,100)), & - '' -end subroutine write_xml_type_cell_xml - -subroutine read_xml_type_surface_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(inout) :: tag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(surface_xml), dimension(:), pointer :: dvar - logical, intent(inout) :: has_dvar - - integer :: newsize - type(surface_xml), dimension(:), pointer :: newvar - - newsize = size(dvar) + 1 - allocate( newvar(1:newsize) ) - newvar(1:newsize-1) = dvar - deallocate( dvar ) - dvar => newvar - - call read_xml_type_surface_xml( info, tag, endtag, attribs, noattribs, data, nodata, & - dvar(newsize), has_dvar ) -end subroutine read_xml_type_surface_xml_array - -subroutine read_xml_type_surface_xml( info, starttag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: starttag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(surface_xml), intent(inout) :: dvar - logical, intent(inout) :: has_dvar - - integer :: att_ - integer :: noatt_ - logical :: error - logical :: endtag_org - character(len=len(starttag)) :: tag - logical :: has_uid - logical :: has_type - logical :: has_coeffs - logical :: has_boundary - has_uid = .false. - has_type = .false. - has_coeffs = .false. - has_boundary = .false. - call init_xml_type_surface_xml(dvar) - has_dvar = .true. - error = .false. - att_ = 0 - noatt_ = noattribs+1 - endtag_org = endtag - do - if ( nodata /= 0 ) then - noattribs = 0 - tag = starttag - elseif ( att_ < noatt_ .and. noatt_ > 1 ) then - att_ = att_ + 1 - if ( att_ <= noatt_-1 ) then - tag = attribs(1,att_) - data(1) = attribs(2,att_) - noattribs = 0 - nodata = 1 - endtag = .false. - else - tag = starttag - noattribs = 0 - nodata = 0 - endtag = .true. - cycle - endif - else - if ( endtag_org ) then - return - else - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( xml_error(info) ) then - write(lurep_,*) 'Error reading input file!' - error = .true. - return - endif - endif - endif - if ( endtag .and. tag == starttag ) then - exit - endif - if ( endtag .and. noattribs == 0 ) then - if ( xml_ok(info) ) then - cycle - else - exit - endif - endif - select case( tag ) - case('uid') - call read_xml_integer( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%uid, has_uid ) - case('type') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%type, has_type ) - case('coeffs') - call read_xml_double_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%coeffs, has_coeffs ) - case('boundary') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%boundary, has_boundary ) - case ('comment', '!--') - ! Simply ignore - case default - if ( strict_ ) then - error = .true. - call xml_report_errors( info, & - 'Unknown or wrongly placed tag: ' // trim(tag)) - endif - end select - nodata = 0 - if ( .not. xml_ok(info) ) exit - end do - if ( .not. has_uid ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on uid') - endif - if ( .not. has_type ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on type') - endif - if ( .not. has_coeffs ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on coeffs') - endif -end subroutine read_xml_type_surface_xml -subroutine init_xml_type_surface_xml_array( dvar ) - type(surface_xml), dimension(:), pointer :: dvar - if ( associated( dvar ) ) then - deallocate( dvar ) - endif - allocate( dvar(0) ) -end subroutine init_xml_type_surface_xml_array -subroutine init_xml_type_surface_xml(dvar) - type(surface_xml) :: dvar - dvar%boundary = 'transmit' -end subroutine init_xml_type_surface_xml -subroutine write_xml_type_surface_xml_array( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(surface_xml), dimension(:) :: dvar - integer :: i - do i = 1,size(dvar) - call write_xml_type_surface_xml( info, tag, indent, dvar(i) ) - enddo -end subroutine write_xml_type_surface_xml_array - -subroutine write_xml_type_surface_xml( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(surface_xml) :: dvar - character(len=100) :: indentation - indentation = ' ' - write(info%lun, '(4a)' ) indentation(1:min(indent,100)),& - '<',trim(tag), '>' - call write_to_xml_integer( info, 'uid', indent+3, dvar%uid) - call write_to_xml_word( info, 'type', indent+3, dvar%type) - call write_to_xml_double_array( info, 'coeffs', indent+3, dvar%coeffs) - call write_to_xml_word( info, 'boundary', indent+3, dvar%boundary) - write(info%lun,'(4a)') indentation(1:min(indent,100)), & - '' -end subroutine write_xml_type_surface_xml - -subroutine read_xml_type_lattice_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(inout) :: tag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(lattice_xml), dimension(:), pointer :: dvar - logical, intent(inout) :: has_dvar - - integer :: newsize - type(lattice_xml), dimension(:), pointer :: newvar - - newsize = size(dvar) + 1 - allocate( newvar(1:newsize) ) - newvar(1:newsize-1) = dvar - deallocate( dvar ) - dvar => newvar - - call read_xml_type_lattice_xml( info, tag, endtag, attribs, noattribs, data, nodata, & - dvar(newsize), has_dvar ) -end subroutine read_xml_type_lattice_xml_array - -subroutine read_xml_type_lattice_xml( info, starttag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: starttag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(lattice_xml), intent(inout) :: dvar - logical, intent(inout) :: has_dvar - - integer :: att_ - integer :: noatt_ - logical :: error - logical :: endtag_org - character(len=len(starttag)) :: tag - logical :: has_uid - logical :: has_type - logical :: has_dimension - logical :: has_origin - logical :: has_width - logical :: has_universes - has_uid = .false. - has_type = .false. - has_dimension = .false. - has_origin = .false. - has_width = .false. - has_universes = .false. - call init_xml_type_lattice_xml(dvar) - has_dvar = .true. - error = .false. - att_ = 0 - noatt_ = noattribs+1 - endtag_org = endtag - do - if ( nodata /= 0 ) then - noattribs = 0 - tag = starttag - elseif ( att_ < noatt_ .and. noatt_ > 1 ) then - att_ = att_ + 1 - if ( att_ <= noatt_-1 ) then - tag = attribs(1,att_) - data(1) = attribs(2,att_) - noattribs = 0 - nodata = 1 - endtag = .false. - else - tag = starttag - noattribs = 0 - nodata = 0 - endtag = .true. - cycle - endif - else - if ( endtag_org ) then - return - else - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( xml_error(info) ) then - write(lurep_,*) 'Error reading input file!' - error = .true. - return - endif - endif - endif - if ( endtag .and. tag == starttag ) then - exit - endif - if ( endtag .and. noattribs == 0 ) then - if ( xml_ok(info) ) then - cycle - else - exit - endif - endif - select case( tag ) - case('uid') - call read_xml_integer( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%uid, has_uid ) - case('type') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%type, has_type ) - case('dimension') - call read_xml_integer_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%dimension, has_dimension ) - case('origin') - call read_xml_double_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%origin, has_origin ) - case('width') - call read_xml_double_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%width, has_width ) - case('universes') - call read_xml_integer_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%universes, has_universes ) - case ('comment', '!--') - ! Simply ignore - case default - if ( strict_ ) then - error = .true. - call xml_report_errors( info, & - 'Unknown or wrongly placed tag: ' // trim(tag)) - endif - end select - nodata = 0 - if ( .not. xml_ok(info) ) exit - end do - if ( .not. has_uid ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on uid') - endif - if ( .not. has_type ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on type') - endif - if ( .not. has_dimension ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on dimension') - endif - if ( .not. has_origin ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on origin') - endif - if ( .not. has_width ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on width') - endif - if ( .not. has_universes ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on universes') - endif -end subroutine read_xml_type_lattice_xml -subroutine init_xml_type_lattice_xml_array( dvar ) - type(lattice_xml), dimension(:), pointer :: dvar - if ( associated( dvar ) ) then - deallocate( dvar ) - endif - allocate( dvar(0) ) -end subroutine init_xml_type_lattice_xml_array -subroutine init_xml_type_lattice_xml(dvar) - type(lattice_xml) :: dvar -end subroutine init_xml_type_lattice_xml -subroutine write_xml_type_lattice_xml_array( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(lattice_xml), dimension(:) :: dvar - integer :: i - do i = 1,size(dvar) - call write_xml_type_lattice_xml( info, tag, indent, dvar(i) ) - enddo -end subroutine write_xml_type_lattice_xml_array - -subroutine write_xml_type_lattice_xml( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(lattice_xml) :: dvar - character(len=100) :: indentation - indentation = ' ' - write(info%lun, '(4a)' ) indentation(1:min(indent,100)),& - '<',trim(tag), '>' - call write_to_xml_integer( info, 'uid', indent+3, dvar%uid) - call write_to_xml_word( info, 'type', indent+3, dvar%type) - call write_to_xml_integer_array( info, 'dimension', indent+3, dvar%dimension) - call write_to_xml_double_array( info, 'origin', indent+3, dvar%origin) - call write_to_xml_double_array( info, 'width', indent+3, dvar%width) - call write_to_xml_integer_array( info, 'universes', indent+3, dvar%universes) - write(info%lun,'(4a)') indentation(1:min(indent,100)), & - '' -end subroutine write_xml_type_lattice_xml - -subroutine read_xml_file_geometry_t(fname, lurep, errout) - character(len=*), intent(in) :: fname - integer, intent(in), optional :: lurep - logical, intent(out), optional :: errout - - type(XML_PARSE) :: info - logical :: error - character(len=80) :: tag - character(len=80) :: starttag - logical :: endtag - character(len=80), dimension(1:2,1:20) :: attribs - integer :: noattribs - character(len=200), dimension(1:100) :: data - integer :: nodata - logical :: has_cell_ - logical :: has_surface_ - logical :: has_lattice_ - has_cell_ = .false. - allocate(cell_(0)) - has_surface_ = .false. - allocate(surface_(0)) - has_lattice_ = .false. - allocate(lattice_(0)) - - call init_xml_file_geometry_t - call xml_open( info, fname, .true. ) - call xml_options( info, report_errors=.false., ignore_whitespace=.true.) - lurep_ = 0 - if ( present(lurep) ) then - lurep_ = lurep - call xml_options( info, report_lun=lurep ) - endif - do - call xml_get( info, starttag, endtag, attribs, noattribs, & - data, nodata) - if ( starttag /= '!--' ) exit - enddo - if ( starttag /= "geometry" ) then - call xml_report_errors( info, & - 'XML-file should have root element "geometry"') - error = .true. - call xml_close(info) - return - endif - strict_ = .false. - error = .false. - do - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( xml_error(info) ) then - write(lurep_,*) 'Error reading input file!' - error = .true. - return - endif - if ( endtag .and. tag == starttag ) then - exit - endif - if ( endtag .and. noattribs == 0 ) then - if ( xml_ok(info) ) then - cycle - else - exit - endif - endif - select case( tag ) - case('cell') - call read_xml_type_cell_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - cell_, has_cell_ ) - case('surface') - call read_xml_type_surface_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - surface_, has_surface_ ) - case('lattice') - call read_xml_type_lattice_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - lattice_, has_lattice_ ) - case ('comment', '!--') - ! Simply ignore - case default - if ( strict_ ) then - error = .true. - call xml_report_errors( info, & - 'Unknown or wrongly placed tag: ' // trim(tag)) - endif - end select - nodata = 0 - if ( .not. xml_ok(info) ) exit - end do - if ( .not. has_cell_ ) then - error = .true. - call xml_report_errors(info, 'Missing data on cell_') - endif - if ( .not. has_surface_ ) then - error = .true. - call xml_report_errors(info, 'Missing data on surface_') - endif - if ( .not. has_lattice_ ) then - error = .true. - call xml_report_errors(info, 'Missing data on lattice_') - endif - if ( present(errout) ) errout = error -end subroutine - -subroutine write_xml_file_geometry_t(fname, lurep) - character(len=*), intent(in) :: fname - integer, intent(in), optional :: lurep - - type(XML_PARSE) :: info - integer :: indent = 0 - - call xml_open( info, fname, .false. ) - call xml_options( info, report_errors=.true.) - if ( present(lurep) ) then - call xml_options( info, report_errors=.true.) - endif - write(info%lun,'(a)') & - '' - call write_xml_type_cell_xml_array( info, 'cell', indent+3, cell_) - call write_xml_type_surface_xml_array( info, 'surface', indent+3, surface_) - call write_xml_type_lattice_xml_array( info, 'lattice', indent+3, lattice_) - write(info%lun,'(a)') '' - call xml_close(info) -end subroutine - -subroutine init_xml_file_geometry_t - -end subroutine - -end module diff --git a/src/xml_materials.f90 b/src/xml_materials.f90 deleted file mode 100644 index d747f3941b..0000000000 --- a/src/xml_materials.f90 +++ /dev/null @@ -1,822 +0,0 @@ -module xml_data_materials_t - use READ_XML_PRIMITIVES - use WRITE_XML_PRIMITIVES - use XMLPARSE - implicit none - integer, private :: lurep_ - logical, private :: strict_ - -type density_xml - real(kind=kind(1.0d0)) :: value - character(len=10) :: units -end type density_xml - -type nuclide_xml - character(len=10) :: name - character(len=3) :: xs - real(kind=kind(1.0d0)) :: ao - real(kind=kind(1.0d0)) :: wo -end type nuclide_xml - -type sab_xml - character(len=10) :: name - character(len=3) :: xs -end type sab_xml - -type material_xml - integer :: uid - type(density_xml) :: density - type(nuclide_xml), dimension(:), pointer :: nuclides => null() - type(sab_xml) :: sab -end type material_xml - type(material_xml), dimension(:), pointer :: material_ => null() -contains -subroutine read_xml_type_density_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(inout) :: tag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(density_xml), dimension(:), pointer :: dvar - logical, intent(inout) :: has_dvar - - integer :: newsize - type(density_xml), dimension(:), pointer :: newvar - - newsize = size(dvar) + 1 - allocate( newvar(1:newsize) ) - newvar(1:newsize-1) = dvar - deallocate( dvar ) - dvar => newvar - - call read_xml_type_density_xml( info, tag, endtag, attribs, noattribs, data, nodata, & - dvar(newsize), has_dvar ) -end subroutine read_xml_type_density_xml_array - -subroutine read_xml_type_density_xml( info, starttag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: starttag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(density_xml), intent(inout) :: dvar - logical, intent(inout) :: has_dvar - - integer :: att_ - integer :: noatt_ - logical :: error - logical :: endtag_org - character(len=len(starttag)) :: tag - logical :: has_value - logical :: has_units - has_value = .false. - has_units = .false. - call init_xml_type_density_xml(dvar) - has_dvar = .true. - error = .false. - att_ = 0 - noatt_ = noattribs+1 - endtag_org = endtag - do - if ( nodata /= 0 ) then - noattribs = 0 - tag = starttag - elseif ( att_ < noatt_ .and. noatt_ > 1 ) then - att_ = att_ + 1 - if ( att_ <= noatt_-1 ) then - tag = attribs(1,att_) - data(1) = attribs(2,att_) - noattribs = 0 - nodata = 1 - endtag = .false. - else - tag = starttag - noattribs = 0 - nodata = 0 - endtag = .true. - cycle - endif - else - if ( endtag_org ) then - return - else - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( xml_error(info) ) then - write(lurep_,*) 'Error reading input file!' - error = .true. - return - endif - endif - endif - if ( endtag .and. tag == starttag ) then - exit - endif - if ( endtag .and. noattribs == 0 ) then - if ( xml_ok(info) ) then - cycle - else - exit - endif - endif - select case( tag ) - case('value') - call read_xml_double( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%value, has_value ) - case('units') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%units, has_units ) - case ('comment', '!--') - ! Simply ignore - case default - if ( strict_ ) then - error = .true. - call xml_report_errors( info, & - 'Unknown or wrongly placed tag: ' // trim(tag)) - endif - end select - nodata = 0 - if ( .not. xml_ok(info) ) exit - end do - if ( .not. has_value ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on value') - endif -end subroutine read_xml_type_density_xml -subroutine init_xml_type_density_xml_array( dvar ) - type(density_xml), dimension(:), pointer :: dvar - if ( associated( dvar ) ) then - deallocate( dvar ) - endif - allocate( dvar(0) ) -end subroutine init_xml_type_density_xml_array -subroutine init_xml_type_density_xml(dvar) - type(density_xml) :: dvar - dvar%units = 'atom/b-cm' -end subroutine init_xml_type_density_xml -subroutine write_xml_type_density_xml_array( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(density_xml), dimension(:) :: dvar - integer :: i - do i = 1,size(dvar) - call write_xml_type_density_xml( info, tag, indent, dvar(i) ) - enddo -end subroutine write_xml_type_density_xml_array - -subroutine write_xml_type_density_xml( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(density_xml) :: dvar - character(len=100) :: indentation - indentation = ' ' - write(info%lun, '(4a)' ) indentation(1:min(indent,100)),& - '<',trim(tag), '>' - call write_to_xml_double( info, 'value', indent+3, dvar%value) - call write_to_xml_word( info, 'units', indent+3, dvar%units) - write(info%lun,'(4a)') indentation(1:min(indent,100)), & - '' -end subroutine write_xml_type_density_xml - -subroutine read_xml_type_nuclide_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(inout) :: tag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(nuclide_xml), dimension(:), pointer :: dvar - logical, intent(inout) :: has_dvar - - integer :: newsize - type(nuclide_xml), dimension(:), pointer :: newvar - - newsize = size(dvar) + 1 - allocate( newvar(1:newsize) ) - newvar(1:newsize-1) = dvar - deallocate( dvar ) - dvar => newvar - - call read_xml_type_nuclide_xml( info, tag, endtag, attribs, noattribs, data, nodata, & - dvar(newsize), has_dvar ) -end subroutine read_xml_type_nuclide_xml_array - -subroutine read_xml_type_nuclide_xml( info, starttag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: starttag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(nuclide_xml), intent(inout) :: dvar - logical, intent(inout) :: has_dvar - - integer :: att_ - integer :: noatt_ - logical :: error - logical :: endtag_org - character(len=len(starttag)) :: tag - logical :: has_name - logical :: has_xs - logical :: has_ao - logical :: has_wo - has_name = .false. - has_xs = .false. - has_ao = .false. - has_wo = .false. - call init_xml_type_nuclide_xml(dvar) - has_dvar = .true. - error = .false. - att_ = 0 - noatt_ = noattribs+1 - endtag_org = endtag - do - if ( nodata /= 0 ) then - noattribs = 0 - tag = starttag - elseif ( att_ < noatt_ .and. noatt_ > 1 ) then - att_ = att_ + 1 - if ( att_ <= noatt_-1 ) then - tag = attribs(1,att_) - data(1) = attribs(2,att_) - noattribs = 0 - nodata = 1 - endtag = .false. - else - tag = starttag - noattribs = 0 - nodata = 0 - endtag = .true. - cycle - endif - else - if ( endtag_org ) then - return - else - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( xml_error(info) ) then - write(lurep_,*) 'Error reading input file!' - error = .true. - return - endif - endif - endif - if ( endtag .and. tag == starttag ) then - exit - endif - if ( endtag .and. noattribs == 0 ) then - if ( xml_ok(info) ) then - cycle - else - exit - endif - endif - select case( tag ) - case('name') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%name, has_name ) - case('xs') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%xs, has_xs ) - case('ao') - call read_xml_double( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%ao, has_ao ) - case('wo') - call read_xml_double( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%wo, has_wo ) - case ('comment', '!--') - ! Simply ignore - case default - if ( strict_ ) then - error = .true. - call xml_report_errors( info, & - 'Unknown or wrongly placed tag: ' // trim(tag)) - endif - end select - nodata = 0 - if ( .not. xml_ok(info) ) exit - end do - if ( .not. has_name ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on name') - endif - if ( .not. has_xs ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on xs') - endif -end subroutine read_xml_type_nuclide_xml -subroutine init_xml_type_nuclide_xml_array( dvar ) - type(nuclide_xml), dimension(:), pointer :: dvar - if ( associated( dvar ) ) then - deallocate( dvar ) - endif - allocate( dvar(0) ) -end subroutine init_xml_type_nuclide_xml_array -subroutine init_xml_type_nuclide_xml(dvar) - type(nuclide_xml) :: dvar - dvar%ao = 0.0 - dvar%wo = 0.0 -end subroutine init_xml_type_nuclide_xml -subroutine write_xml_type_nuclide_xml_array( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(nuclide_xml), dimension(:) :: dvar - integer :: i - do i = 1,size(dvar) - call write_xml_type_nuclide_xml( info, tag, indent, dvar(i) ) - enddo -end subroutine write_xml_type_nuclide_xml_array - -subroutine write_xml_type_nuclide_xml( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(nuclide_xml) :: dvar - character(len=100) :: indentation - indentation = ' ' - write(info%lun, '(4a)' ) indentation(1:min(indent,100)),& - '<',trim(tag), '>' - call write_to_xml_word( info, 'name', indent+3, dvar%name) - call write_to_xml_word( info, 'xs', indent+3, dvar%xs) - call write_to_xml_double( info, 'ao', indent+3, dvar%ao) - call write_to_xml_double( info, 'wo', indent+3, dvar%wo) - write(info%lun,'(4a)') indentation(1:min(indent,100)), & - '' -end subroutine write_xml_type_nuclide_xml - -subroutine read_xml_type_sab_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(inout) :: tag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(sab_xml), dimension(:), pointer :: dvar - logical, intent(inout) :: has_dvar - - integer :: newsize - type(sab_xml), dimension(:), pointer :: newvar - - newsize = size(dvar) + 1 - allocate( newvar(1:newsize) ) - newvar(1:newsize-1) = dvar - deallocate( dvar ) - dvar => newvar - - call read_xml_type_sab_xml( info, tag, endtag, attribs, noattribs, data, nodata, & - dvar(newsize), has_dvar ) -end subroutine read_xml_type_sab_xml_array - -subroutine read_xml_type_sab_xml( info, starttag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: starttag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(sab_xml), intent(inout) :: dvar - logical, intent(inout) :: has_dvar - - integer :: att_ - integer :: noatt_ - logical :: error - logical :: endtag_org - character(len=len(starttag)) :: tag - logical :: has_name - logical :: has_xs - has_name = .false. - has_xs = .false. - call init_xml_type_sab_xml(dvar) - has_dvar = .true. - error = .false. - att_ = 0 - noatt_ = noattribs+1 - endtag_org = endtag - do - if ( nodata /= 0 ) then - noattribs = 0 - tag = starttag - elseif ( att_ < noatt_ .and. noatt_ > 1 ) then - att_ = att_ + 1 - if ( att_ <= noatt_-1 ) then - tag = attribs(1,att_) - data(1) = attribs(2,att_) - noattribs = 0 - nodata = 1 - endtag = .false. - else - tag = starttag - noattribs = 0 - nodata = 0 - endtag = .true. - cycle - endif - else - if ( endtag_org ) then - return - else - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( xml_error(info) ) then - write(lurep_,*) 'Error reading input file!' - error = .true. - return - endif - endif - endif - if ( endtag .and. tag == starttag ) then - exit - endif - if ( endtag .and. noattribs == 0 ) then - if ( xml_ok(info) ) then - cycle - else - exit - endif - endif - select case( tag ) - case('name') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%name, has_name ) - case('xs') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%xs, has_xs ) - case ('comment', '!--') - ! Simply ignore - case default - if ( strict_ ) then - error = .true. - call xml_report_errors( info, & - 'Unknown or wrongly placed tag: ' // trim(tag)) - endif - end select - nodata = 0 - if ( .not. xml_ok(info) ) exit - end do - if ( .not. has_name ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on name') - endif - if ( .not. has_xs ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on xs') - endif -end subroutine read_xml_type_sab_xml -subroutine init_xml_type_sab_xml_array( dvar ) - type(sab_xml), dimension(:), pointer :: dvar - if ( associated( dvar ) ) then - deallocate( dvar ) - endif - allocate( dvar(0) ) -end subroutine init_xml_type_sab_xml_array -subroutine init_xml_type_sab_xml(dvar) - type(sab_xml) :: dvar -end subroutine init_xml_type_sab_xml -subroutine write_xml_type_sab_xml_array( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(sab_xml), dimension(:) :: dvar - integer :: i - do i = 1,size(dvar) - call write_xml_type_sab_xml( info, tag, indent, dvar(i) ) - enddo -end subroutine write_xml_type_sab_xml_array - -subroutine write_xml_type_sab_xml( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(sab_xml) :: dvar - character(len=100) :: indentation - indentation = ' ' - write(info%lun, '(4a)' ) indentation(1:min(indent,100)),& - '<',trim(tag), '>' - call write_to_xml_word( info, 'name', indent+3, dvar%name) - call write_to_xml_word( info, 'xs', indent+3, dvar%xs) - write(info%lun,'(4a)') indentation(1:min(indent,100)), & - '' -end subroutine write_xml_type_sab_xml - -subroutine read_xml_type_material_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(inout) :: tag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(material_xml), dimension(:), pointer :: dvar - logical, intent(inout) :: has_dvar - - integer :: newsize - type(material_xml), dimension(:), pointer :: newvar - - newsize = size(dvar) + 1 - allocate( newvar(1:newsize) ) - newvar(1:newsize-1) = dvar - deallocate( dvar ) - dvar => newvar - - call read_xml_type_material_xml( info, tag, endtag, attribs, noattribs, data, nodata, & - dvar(newsize), has_dvar ) -end subroutine read_xml_type_material_xml_array - -subroutine read_xml_type_material_xml( info, starttag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: starttag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(material_xml), intent(inout) :: dvar - logical, intent(inout) :: has_dvar - - integer :: att_ - integer :: noatt_ - logical :: error - logical :: endtag_org - character(len=len(starttag)) :: tag - logical :: has_uid - logical :: has_density - logical :: has_nuclides - logical :: has_sab - has_uid = .false. - has_density = .false. - has_nuclides = .false. - allocate(dvar%nuclides(0)) - has_sab = .false. - call init_xml_type_material_xml(dvar) - has_dvar = .true. - error = .false. - att_ = 0 - noatt_ = noattribs+1 - endtag_org = endtag - do - if ( nodata /= 0 ) then - noattribs = 0 - tag = starttag - elseif ( att_ < noatt_ .and. noatt_ > 1 ) then - att_ = att_ + 1 - if ( att_ <= noatt_-1 ) then - tag = attribs(1,att_) - data(1) = attribs(2,att_) - noattribs = 0 - nodata = 1 - endtag = .false. - else - tag = starttag - noattribs = 0 - nodata = 0 - endtag = .true. - cycle - endif - else - if ( endtag_org ) then - return - else - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( xml_error(info) ) then - write(lurep_,*) 'Error reading input file!' - error = .true. - return - endif - endif - endif - if ( endtag .and. tag == starttag ) then - exit - endif - if ( endtag .and. noattribs == 0 ) then - if ( xml_ok(info) ) then - cycle - else - exit - endif - endif - select case( tag ) - case('uid') - call read_xml_integer( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%uid, has_uid ) - case('density') - call read_xml_type_density_xml( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%density, has_density ) - case('nuclide') - call read_xml_type_nuclide_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%nuclides, has_nuclides ) - case('sab') - call read_xml_type_sab_xml( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%sab, has_sab ) - case ('comment', '!--') - ! Simply ignore - case default - if ( strict_ ) then - error = .true. - call xml_report_errors( info, & - 'Unknown or wrongly placed tag: ' // trim(tag)) - endif - end select - nodata = 0 - if ( .not. xml_ok(info) ) exit - end do - if ( .not. has_uid ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on uid') - endif - if ( .not. has_density ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on density') - endif - if ( .not. has_nuclides ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on nuclides') - endif - if ( .not. has_sab ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on sab') - endif -end subroutine read_xml_type_material_xml -subroutine init_xml_type_material_xml_array( dvar ) - type(material_xml), dimension(:), pointer :: dvar - if ( associated( dvar ) ) then - deallocate( dvar ) - endif - allocate( dvar(0) ) -end subroutine init_xml_type_material_xml_array -subroutine init_xml_type_material_xml(dvar) - type(material_xml) :: dvar -end subroutine init_xml_type_material_xml -subroutine write_xml_type_material_xml_array( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(material_xml), dimension(:) :: dvar - integer :: i - do i = 1,size(dvar) - call write_xml_type_material_xml( info, tag, indent, dvar(i) ) - enddo -end subroutine write_xml_type_material_xml_array - -subroutine write_xml_type_material_xml( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(material_xml) :: dvar - character(len=100) :: indentation - indentation = ' ' - write(info%lun, '(4a)' ) indentation(1:min(indent,100)),& - '<',trim(tag), '>' - call write_to_xml_integer( info, 'uid', indent+3, dvar%uid) - call write_xml_type_density_xml( info, 'density', indent+3, dvar%density) - call write_xml_type_nuclide_xml_array( info, 'nuclide', indent+3, dvar%nuclides) - call write_xml_type_sab_xml( info, 'sab', indent+3, dvar%sab) - write(info%lun,'(4a)') indentation(1:min(indent,100)), & - '' -end subroutine write_xml_type_material_xml - -subroutine read_xml_file_materials_t(fname, lurep, errout) - character(len=*), intent(in) :: fname - integer, intent(in), optional :: lurep - logical, intent(out), optional :: errout - - type(XML_PARSE) :: info - logical :: error - character(len=80) :: tag - character(len=80) :: starttag - logical :: endtag - character(len=80), dimension(1:2,1:20) :: attribs - integer :: noattribs - character(len=200), dimension(1:100) :: data - integer :: nodata - logical :: has_material_ - has_material_ = .false. - allocate(material_(0)) - - call init_xml_file_materials_t - call xml_open( info, fname, .true. ) - call xml_options( info, report_errors=.false., ignore_whitespace=.true.) - lurep_ = 0 - if ( present(lurep) ) then - lurep_ = lurep - call xml_options( info, report_lun=lurep ) - endif - do - call xml_get( info, starttag, endtag, attribs, noattribs, & - data, nodata) - if ( starttag /= '!--' ) exit - enddo - if ( starttag /= "materials" ) then - call xml_report_errors( info, & - 'XML-file should have root element "materials"') - error = .true. - call xml_close(info) - return - endif - strict_ = .false. - error = .false. - do - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( xml_error(info) ) then - write(lurep_,*) 'Error reading input file!' - error = .true. - return - endif - if ( endtag .and. tag == starttag ) then - exit - endif - if ( endtag .and. noattribs == 0 ) then - if ( xml_ok(info) ) then - cycle - else - exit - endif - endif - select case( tag ) - case('material') - call read_xml_type_material_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - material_, has_material_ ) - case ('comment', '!--') - ! Simply ignore - case default - if ( strict_ ) then - error = .true. - call xml_report_errors( info, & - 'Unknown or wrongly placed tag: ' // trim(tag)) - endif - end select - nodata = 0 - if ( .not. xml_ok(info) ) exit - end do - if ( .not. has_material_ ) then - error = .true. - call xml_report_errors(info, 'Missing data on material_') - endif - if ( present(errout) ) errout = error -end subroutine - -subroutine write_xml_file_materials_t(fname, lurep) - character(len=*), intent(in) :: fname - integer, intent(in), optional :: lurep - - type(XML_PARSE) :: info - integer :: indent = 0 - - call xml_open( info, fname, .false. ) - call xml_options( info, report_errors=.true.) - if ( present(lurep) ) then - call xml_options( info, report_errors=.true.) - endif - write(info%lun,'(a)') & - '' - call write_xml_type_material_xml_array( info, 'material', indent+3, material_) - write(info%lun,'(a)') '' - call xml_close(info) -end subroutine - -subroutine init_xml_file_materials_t - -end subroutine - -end module diff --git a/src/xml_settings.f90 b/src/xml_settings.f90 deleted file mode 100644 index 89a831f143..0000000000 --- a/src/xml_settings.f90 +++ /dev/null @@ -1,836 +0,0 @@ -module xml_data_settings_t - use READ_XML_PRIMITIVES - use WRITE_XML_PRIMITIVES - use XMLPARSE - implicit none - integer, private :: lurep_ - logical, private :: strict_ - -type xslibrary_xml - character(len=250) :: path -end type xslibrary_xml - -type criticality_xml - integer :: cycles - integer :: inactive - integer :: particles -end type criticality_xml - -type source_xml - character(len=10) :: type - real(kind=kind(1.0d0)), dimension(:), pointer :: coeffs => null() -end type source_xml - -type cutoff_xml - real(kind=kind(1.0d0)) :: weight - real(kind=kind(1.0d0)) :: weight_avg -end type cutoff_xml - type(xslibrary_xml) :: xslibrary - type(criticality_xml) :: criticality - integer :: verbosity_ - type(source_xml) :: source_ - character(len=3), dimension(:), pointer :: survival_ => null() - type(cutoff_xml) :: cutoff_ -contains -subroutine read_xml_type_xslibrary_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(inout) :: tag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(xslibrary_xml), dimension(:), pointer :: dvar - logical, intent(inout) :: has_dvar - - integer :: newsize - type(xslibrary_xml), dimension(:), pointer :: newvar - - newsize = size(dvar) + 1 - allocate( newvar(1:newsize) ) - newvar(1:newsize-1) = dvar - deallocate( dvar ) - dvar => newvar - - call read_xml_type_xslibrary_xml( info, tag, endtag, attribs, noattribs, data, nodata, & - dvar(newsize), has_dvar ) -end subroutine read_xml_type_xslibrary_xml_array - -subroutine read_xml_type_xslibrary_xml( info, starttag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: starttag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(xslibrary_xml), intent(inout) :: dvar - logical, intent(inout) :: has_dvar - - integer :: att_ - integer :: noatt_ - logical :: error - logical :: endtag_org - character(len=len(starttag)) :: tag - logical :: has_path - has_path = .false. - call init_xml_type_xslibrary_xml(dvar) - has_dvar = .true. - error = .false. - att_ = 0 - noatt_ = noattribs+1 - endtag_org = endtag - do - if ( nodata /= 0 ) then - noattribs = 0 - tag = starttag - elseif ( att_ < noatt_ .and. noatt_ > 1 ) then - att_ = att_ + 1 - if ( att_ <= noatt_-1 ) then - tag = attribs(1,att_) - data(1) = attribs(2,att_) - noattribs = 0 - nodata = 1 - endtag = .false. - else - tag = starttag - noattribs = 0 - nodata = 0 - endtag = .true. - cycle - endif - else - if ( endtag_org ) then - return - else - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( xml_error(info) ) then - write(lurep_,*) 'Error reading input file!' - error = .true. - return - endif - endif - endif - if ( endtag .and. tag == starttag ) then - exit - endif - if ( endtag .and. noattribs == 0 ) then - if ( xml_ok(info) ) then - cycle - else - exit - endif - endif - select case( tag ) - case('path') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%path, has_path ) - case ('comment', '!--') - ! Simply ignore - case default - if ( strict_ ) then - error = .true. - call xml_report_errors( info, & - 'Unknown or wrongly placed tag: ' // trim(tag)) - endif - end select - nodata = 0 - if ( .not. xml_ok(info) ) exit - end do - if ( .not. has_path ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on path') - endif -end subroutine read_xml_type_xslibrary_xml -subroutine init_xml_type_xslibrary_xml_array( dvar ) - type(xslibrary_xml), dimension(:), pointer :: dvar - if ( associated( dvar ) ) then - deallocate( dvar ) - endif - allocate( dvar(0) ) -end subroutine init_xml_type_xslibrary_xml_array -subroutine init_xml_type_xslibrary_xml(dvar) - type(xslibrary_xml) :: dvar -end subroutine init_xml_type_xslibrary_xml -subroutine write_xml_type_xslibrary_xml_array( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(xslibrary_xml), dimension(:) :: dvar - integer :: i - do i = 1,size(dvar) - call write_xml_type_xslibrary_xml( info, tag, indent, dvar(i) ) - enddo -end subroutine write_xml_type_xslibrary_xml_array - -subroutine write_xml_type_xslibrary_xml( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(xslibrary_xml) :: dvar - character(len=100) :: indentation - indentation = ' ' - write(info%lun, '(4a)' ) indentation(1:min(indent,100)),& - '<',trim(tag), '>' - call write_to_xml_word( info, 'path', indent+3, dvar%path) - write(info%lun,'(4a)') indentation(1:min(indent,100)), & - '' -end subroutine write_xml_type_xslibrary_xml - -subroutine read_xml_type_criticality_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(inout) :: tag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(criticality_xml), dimension(:), pointer :: dvar - logical, intent(inout) :: has_dvar - - integer :: newsize - type(criticality_xml), dimension(:), pointer :: newvar - - newsize = size(dvar) + 1 - allocate( newvar(1:newsize) ) - newvar(1:newsize-1) = dvar - deallocate( dvar ) - dvar => newvar - - call read_xml_type_criticality_xml( info, tag, endtag, attribs, noattribs, data, nodata, & - dvar(newsize), has_dvar ) -end subroutine read_xml_type_criticality_xml_array - -subroutine read_xml_type_criticality_xml( info, starttag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: starttag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(criticality_xml), intent(inout) :: dvar - logical, intent(inout) :: has_dvar - - integer :: att_ - integer :: noatt_ - logical :: error - logical :: endtag_org - character(len=len(starttag)) :: tag - logical :: has_cycles - logical :: has_inactive - logical :: has_particles - has_cycles = .false. - has_inactive = .false. - has_particles = .false. - call init_xml_type_criticality_xml(dvar) - has_dvar = .true. - error = .false. - att_ = 0 - noatt_ = noattribs+1 - endtag_org = endtag - do - if ( nodata /= 0 ) then - noattribs = 0 - tag = starttag - elseif ( att_ < noatt_ .and. noatt_ > 1 ) then - att_ = att_ + 1 - if ( att_ <= noatt_-1 ) then - tag = attribs(1,att_) - data(1) = attribs(2,att_) - noattribs = 0 - nodata = 1 - endtag = .false. - else - tag = starttag - noattribs = 0 - nodata = 0 - endtag = .true. - cycle - endif - else - if ( endtag_org ) then - return - else - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( xml_error(info) ) then - write(lurep_,*) 'Error reading input file!' - error = .true. - return - endif - endif - endif - if ( endtag .and. tag == starttag ) then - exit - endif - if ( endtag .and. noattribs == 0 ) then - if ( xml_ok(info) ) then - cycle - else - exit - endif - endif - select case( tag ) - case('cycles') - call read_xml_integer( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%cycles, has_cycles ) - case('inactive') - call read_xml_integer( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%inactive, has_inactive ) - case('particles') - call read_xml_integer( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%particles, has_particles ) - case ('comment', '!--') - ! Simply ignore - case default - if ( strict_ ) then - error = .true. - call xml_report_errors( info, & - 'Unknown or wrongly placed tag: ' // trim(tag)) - endif - end select - nodata = 0 - if ( .not. xml_ok(info) ) exit - end do - if ( .not. has_cycles ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on cycles') - endif - if ( .not. has_inactive ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on inactive') - endif - if ( .not. has_particles ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on particles') - endif -end subroutine read_xml_type_criticality_xml -subroutine init_xml_type_criticality_xml_array( dvar ) - type(criticality_xml), dimension(:), pointer :: dvar - if ( associated( dvar ) ) then - deallocate( dvar ) - endif - allocate( dvar(0) ) -end subroutine init_xml_type_criticality_xml_array -subroutine init_xml_type_criticality_xml(dvar) - type(criticality_xml) :: dvar -end subroutine init_xml_type_criticality_xml -subroutine write_xml_type_criticality_xml_array( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(criticality_xml), dimension(:) :: dvar - integer :: i - do i = 1,size(dvar) - call write_xml_type_criticality_xml( info, tag, indent, dvar(i) ) - enddo -end subroutine write_xml_type_criticality_xml_array - -subroutine write_xml_type_criticality_xml( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(criticality_xml) :: dvar - character(len=100) :: indentation - indentation = ' ' - write(info%lun, '(4a)' ) indentation(1:min(indent,100)),& - '<',trim(tag), '>' - call write_to_xml_integer( info, 'cycles', indent+3, dvar%cycles) - call write_to_xml_integer( info, 'inactive', indent+3, dvar%inactive) - call write_to_xml_integer( info, 'particles', indent+3, dvar%particles) - write(info%lun,'(4a)') indentation(1:min(indent,100)), & - '' -end subroutine write_xml_type_criticality_xml - -subroutine read_xml_type_source_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(inout) :: tag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(source_xml), dimension(:), pointer :: dvar - logical, intent(inout) :: has_dvar - - integer :: newsize - type(source_xml), dimension(:), pointer :: newvar - - newsize = size(dvar) + 1 - allocate( newvar(1:newsize) ) - newvar(1:newsize-1) = dvar - deallocate( dvar ) - dvar => newvar - - call read_xml_type_source_xml( info, tag, endtag, attribs, noattribs, data, nodata, & - dvar(newsize), has_dvar ) -end subroutine read_xml_type_source_xml_array - -subroutine read_xml_type_source_xml( info, starttag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: starttag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(source_xml), intent(inout) :: dvar - logical, intent(inout) :: has_dvar - - integer :: att_ - integer :: noatt_ - logical :: error - logical :: endtag_org - character(len=len(starttag)) :: tag - logical :: has_type - logical :: has_coeffs - has_type = .false. - has_coeffs = .false. - call init_xml_type_source_xml(dvar) - has_dvar = .true. - error = .false. - att_ = 0 - noatt_ = noattribs+1 - endtag_org = endtag - do - if ( nodata /= 0 ) then - noattribs = 0 - tag = starttag - elseif ( att_ < noatt_ .and. noatt_ > 1 ) then - att_ = att_ + 1 - if ( att_ <= noatt_-1 ) then - tag = attribs(1,att_) - data(1) = attribs(2,att_) - noattribs = 0 - nodata = 1 - endtag = .false. - else - tag = starttag - noattribs = 0 - nodata = 0 - endtag = .true. - cycle - endif - else - if ( endtag_org ) then - return - else - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( xml_error(info) ) then - write(lurep_,*) 'Error reading input file!' - error = .true. - return - endif - endif - endif - if ( endtag .and. tag == starttag ) then - exit - endif - if ( endtag .and. noattribs == 0 ) then - if ( xml_ok(info) ) then - cycle - else - exit - endif - endif - select case( tag ) - case('type') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%type, has_type ) - case('coeffs') - call read_xml_double_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%coeffs, has_coeffs ) - case ('comment', '!--') - ! Simply ignore - case default - if ( strict_ ) then - error = .true. - call xml_report_errors( info, & - 'Unknown or wrongly placed tag: ' // trim(tag)) - endif - end select - nodata = 0 - if ( .not. xml_ok(info) ) exit - end do - if ( .not. has_type ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on type') - endif - if ( .not. has_coeffs ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on coeffs') - endif -end subroutine read_xml_type_source_xml -subroutine init_xml_type_source_xml_array( dvar ) - type(source_xml), dimension(:), pointer :: dvar - if ( associated( dvar ) ) then - deallocate( dvar ) - endif - allocate( dvar(0) ) -end subroutine init_xml_type_source_xml_array -subroutine init_xml_type_source_xml(dvar) - type(source_xml) :: dvar -end subroutine init_xml_type_source_xml -subroutine write_xml_type_source_xml_array( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(source_xml), dimension(:) :: dvar - integer :: i - do i = 1,size(dvar) - call write_xml_type_source_xml( info, tag, indent, dvar(i) ) - enddo -end subroutine write_xml_type_source_xml_array - -subroutine write_xml_type_source_xml( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(source_xml) :: dvar - character(len=100) :: indentation - indentation = ' ' - write(info%lun, '(4a)' ) indentation(1:min(indent,100)),& - '<',trim(tag), '>' - call write_to_xml_word( info, 'type', indent+3, dvar%type) - call write_to_xml_double_array( info, 'coeffs', indent+3, dvar%coeffs) - write(info%lun,'(4a)') indentation(1:min(indent,100)), & - '' -end subroutine write_xml_type_source_xml - -subroutine read_xml_type_cutoff_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(inout) :: tag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(cutoff_xml), dimension(:), pointer :: dvar - logical, intent(inout) :: has_dvar - - integer :: newsize - type(cutoff_xml), dimension(:), pointer :: newvar - - newsize = size(dvar) + 1 - allocate( newvar(1:newsize) ) - newvar(1:newsize-1) = dvar - deallocate( dvar ) - dvar => newvar - - call read_xml_type_cutoff_xml( info, tag, endtag, attribs, noattribs, data, nodata, & - dvar(newsize), has_dvar ) -end subroutine read_xml_type_cutoff_xml_array - -subroutine read_xml_type_cutoff_xml( info, starttag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: starttag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(cutoff_xml), intent(inout) :: dvar - logical, intent(inout) :: has_dvar - - integer :: att_ - integer :: noatt_ - logical :: error - logical :: endtag_org - character(len=len(starttag)) :: tag - logical :: has_weight - logical :: has_weight_avg - has_weight = .false. - has_weight_avg = .false. - call init_xml_type_cutoff_xml(dvar) - has_dvar = .true. - error = .false. - att_ = 0 - noatt_ = noattribs+1 - endtag_org = endtag - do - if ( nodata /= 0 ) then - noattribs = 0 - tag = starttag - elseif ( att_ < noatt_ .and. noatt_ > 1 ) then - att_ = att_ + 1 - if ( att_ <= noatt_-1 ) then - tag = attribs(1,att_) - data(1) = attribs(2,att_) - noattribs = 0 - nodata = 1 - endtag = .false. - else - tag = starttag - noattribs = 0 - nodata = 0 - endtag = .true. - cycle - endif - else - if ( endtag_org ) then - return - else - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( xml_error(info) ) then - write(lurep_,*) 'Error reading input file!' - error = .true. - return - endif - endif - endif - if ( endtag .and. tag == starttag ) then - exit - endif - if ( endtag .and. noattribs == 0 ) then - if ( xml_ok(info) ) then - cycle - else - exit - endif - endif - select case( tag ) - case('weight') - call read_xml_double( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%weight, has_weight ) - case('weight_avg') - call read_xml_double( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%weight_avg, has_weight_avg ) - case ('comment', '!--') - ! Simply ignore - case default - if ( strict_ ) then - error = .true. - call xml_report_errors( info, & - 'Unknown or wrongly placed tag: ' // trim(tag)) - endif - end select - nodata = 0 - if ( .not. xml_ok(info) ) exit - end do -end subroutine read_xml_type_cutoff_xml -subroutine init_xml_type_cutoff_xml_array( dvar ) - type(cutoff_xml), dimension(:), pointer :: dvar - if ( associated( dvar ) ) then - deallocate( dvar ) - endif - allocate( dvar(0) ) -end subroutine init_xml_type_cutoff_xml_array -subroutine init_xml_type_cutoff_xml(dvar) - type(cutoff_xml) :: dvar - dvar%weight = 0.25 - dvar%weight_avg = 1.0 -end subroutine init_xml_type_cutoff_xml -subroutine write_xml_type_cutoff_xml_array( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(cutoff_xml), dimension(:) :: dvar - integer :: i - do i = 1,size(dvar) - call write_xml_type_cutoff_xml( info, tag, indent, dvar(i) ) - enddo -end subroutine write_xml_type_cutoff_xml_array - -subroutine write_xml_type_cutoff_xml( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(cutoff_xml) :: dvar - character(len=100) :: indentation - indentation = ' ' - write(info%lun, '(4a)' ) indentation(1:min(indent,100)),& - '<',trim(tag), '>' - call write_to_xml_double( info, 'weight', indent+3, dvar%weight) - call write_to_xml_double( info, 'weight_avg', indent+3, dvar%weight_avg) - write(info%lun,'(4a)') indentation(1:min(indent,100)), & - '' -end subroutine write_xml_type_cutoff_xml - -subroutine read_xml_file_settings_t(fname, lurep, errout) - character(len=*), intent(in) :: fname - integer, intent(in), optional :: lurep - logical, intent(out), optional :: errout - - type(XML_PARSE) :: info - logical :: error - character(len=80) :: tag - character(len=80) :: starttag - logical :: endtag - character(len=80), dimension(1:2,1:20) :: attribs - integer :: noattribs - character(len=200), dimension(1:100) :: data - integer :: nodata - logical :: has_xslibrary - logical :: has_criticality - logical :: has_verbosity_ - logical :: has_source_ - logical :: has_survival_ - logical :: has_cutoff_ - has_xslibrary = .false. - has_criticality = .false. - has_verbosity_ = .false. - has_source_ = .false. - has_survival_ = .false. - allocate(survival_(0)) - has_cutoff_ = .false. - - call init_xml_file_settings_t - call xml_open( info, fname, .true. ) - call xml_options( info, report_errors=.false., ignore_whitespace=.true.) - lurep_ = 0 - if ( present(lurep) ) then - lurep_ = lurep - call xml_options( info, report_lun=lurep ) - endif - do - call xml_get( info, starttag, endtag, attribs, noattribs, & - data, nodata) - if ( starttag /= '!--' ) exit - enddo - if ( starttag /= "settings" ) then - call xml_report_errors( info, & - 'XML-file should have root element "settings"') - error = .true. - call xml_close(info) - return - endif - strict_ = .false. - error = .false. - do - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( xml_error(info) ) then - write(lurep_,*) 'Error reading input file!' - error = .true. - return - endif - if ( endtag .and. tag == starttag ) then - exit - endif - if ( endtag .and. noattribs == 0 ) then - if ( xml_ok(info) ) then - cycle - else - exit - endif - endif - select case( tag ) - case('xslibrary') - call read_xml_type_xslibrary_xml( & - info, tag, endtag, attribs, noattribs, data, nodata, & - xslibrary, has_xslibrary ) - case('criticality') - call read_xml_type_criticality_xml( & - info, tag, endtag, attribs, noattribs, data, nodata, & - criticality, has_criticality ) - case('verbosity') - call read_xml_integer( & - info, tag, endtag, attribs, noattribs, data, nodata, & - verbosity_, has_verbosity_ ) - case('source') - call read_xml_type_source_xml( & - info, tag, endtag, attribs, noattribs, data, nodata, & - source_, has_source_ ) - case('survival_biasing') - call read_xml_word_1dim( & - info, tag, endtag, attribs, noattribs, data, nodata, & - survival_, has_survival_ ) - case('cutoff') - call read_xml_type_cutoff_xml( & - info, tag, endtag, attribs, noattribs, data, nodata, & - cutoff_, has_cutoff_ ) - case ('comment', '!--') - ! Simply ignore - case default - if ( strict_ ) then - error = .true. - call xml_report_errors( info, & - 'Unknown or wrongly placed tag: ' // trim(tag)) - endif - end select - nodata = 0 - if ( .not. xml_ok(info) ) exit - end do - if ( .not. has_xslibrary ) then - error = .true. - call xml_report_errors(info, 'Missing data on xslibrary') - endif - if ( .not. has_criticality ) then - error = .true. - call xml_report_errors(info, 'Missing data on criticality') - endif - if ( .not. has_verbosity_ ) then - error = .true. - call xml_report_errors(info, 'Missing data on verbosity_') - endif - if ( .not. has_source_ ) then - error = .true. - call xml_report_errors(info, 'Missing data on source_') - endif - if ( .not. has_survival_ ) then - error = .true. - call xml_report_errors(info, 'Missing data on survival_') - endif - if ( .not. has_cutoff_ ) then - error = .true. - call xml_report_errors(info, 'Missing data on cutoff_') - endif - if ( present(errout) ) errout = error -end subroutine - -subroutine write_xml_file_settings_t(fname, lurep) - character(len=*), intent(in) :: fname - integer, intent(in), optional :: lurep - - type(XML_PARSE) :: info - integer :: indent = 0 - - call xml_open( info, fname, .false. ) - call xml_options( info, report_errors=.true.) - if ( present(lurep) ) then - call xml_options( info, report_errors=.true.) - endif - write(info%lun,'(a)') & - '' - call write_xml_type_xslibrary_xml( info, 'xslibrary', indent+3, xslibrary) - call write_xml_type_criticality_xml( info, 'criticality', indent+3, criticality) - call write_to_xml_integer( info, 'verbosity', indent+3, verbosity_) - call write_xml_type_source_xml( info, 'source', indent+3, source_) - call write_to_xml_word_1dim( info, 'survival_biasing', indent+3, survival_) - call write_xml_type_cutoff_xml( info, 'cutoff', indent+3, cutoff_) - write(info%lun,'(a)') '' - call xml_close(info) -end subroutine - -subroutine init_xml_file_settings_t - -end subroutine - -end module diff --git a/src/xml_tallies.f90 b/src/xml_tallies.f90 deleted file mode 100644 index 58fa59106e..0000000000 --- a/src/xml_tallies.f90 +++ /dev/null @@ -1,739 +0,0 @@ -module xml_data_tallies_t - use READ_XML_PRIMITIVES - use WRITE_XML_PRIMITIVES - use XMLPARSE - implicit none - integer, private :: lurep_ - logical, private :: strict_ - -type mesh_xml - integer :: id - character(len=12) :: type - integer, dimension(:), pointer :: dimension => null() - real(kind=kind(1.0d0)), dimension(:), pointer :: origin => null() - real(kind=kind(1.0d0)), dimension(:), pointer :: width => null() -end type mesh_xml - -type filter_xml - character(len=250) :: cell - character(len=250) :: surface - character(len=250) :: universe - character(len=250) :: material - integer :: mesh - character(len=250) :: cellborn - character(len=250) :: energy - character(len=250) :: energyout -end type filter_xml - -type tally_xml - integer :: id - type(filter_xml) :: filters - character(len=250) :: macros - character(len=250) :: reactions - character(len=250) :: nuclides -end type tally_xml - type(mesh_xml), dimension(:), pointer :: mesh_ => null() - type(tally_xml), dimension(:), pointer :: tally_ => null() -contains -subroutine read_xml_type_mesh_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(inout) :: tag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(mesh_xml), dimension(:), pointer :: dvar - logical, intent(inout) :: has_dvar - - integer :: newsize - type(mesh_xml), dimension(:), pointer :: newvar - - newsize = size(dvar) + 1 - allocate( newvar(1:newsize) ) - newvar(1:newsize-1) = dvar - deallocate( dvar ) - dvar => newvar - - call read_xml_type_mesh_xml( info, tag, endtag, attribs, noattribs, data, nodata, & - dvar(newsize), has_dvar ) -end subroutine read_xml_type_mesh_xml_array - -subroutine read_xml_type_mesh_xml( info, starttag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: starttag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(mesh_xml), intent(inout) :: dvar - logical, intent(inout) :: has_dvar - - integer :: att_ - integer :: noatt_ - logical :: error - logical :: endtag_org - character(len=len(starttag)) :: tag - logical :: has_id - logical :: has_type - logical :: has_dimension - logical :: has_origin - logical :: has_width - has_id = .false. - has_type = .false. - has_dimension = .false. - has_origin = .false. - has_width = .false. - call init_xml_type_mesh_xml(dvar) - has_dvar = .true. - error = .false. - att_ = 0 - noatt_ = noattribs+1 - endtag_org = endtag - do - if ( nodata /= 0 ) then - noattribs = 0 - tag = starttag - elseif ( att_ < noatt_ .and. noatt_ > 1 ) then - att_ = att_ + 1 - if ( att_ <= noatt_-1 ) then - tag = attribs(1,att_) - data(1) = attribs(2,att_) - noattribs = 0 - nodata = 1 - endtag = .false. - else - tag = starttag - noattribs = 0 - nodata = 0 - endtag = .true. - cycle - endif - else - if ( endtag_org ) then - return - else - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( xml_error(info) ) then - write(lurep_,*) 'Error reading input file!' - error = .true. - return - endif - endif - endif - if ( endtag .and. tag == starttag ) then - exit - endif - if ( endtag .and. noattribs == 0 ) then - if ( xml_ok(info) ) then - cycle - else - exit - endif - endif - select case( tag ) - case('id') - call read_xml_integer( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%id, has_id ) - case('type') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%type, has_type ) - case('dimension') - call read_xml_integer_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%dimension, has_dimension ) - case('origin') - call read_xml_double_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%origin, has_origin ) - case('width') - call read_xml_double_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%width, has_width ) - case ('comment', '!--') - ! Simply ignore - case default - if ( strict_ ) then - error = .true. - call xml_report_errors( info, & - 'Unknown or wrongly placed tag: ' // trim(tag)) - endif - end select - nodata = 0 - if ( .not. xml_ok(info) ) exit - end do - if ( .not. has_id ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on id') - endif - if ( .not. has_type ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on type') - endif - if ( .not. has_dimension ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on dimension') - endif - if ( .not. has_origin ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on origin') - endif - if ( .not. has_width ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on width') - endif -end subroutine read_xml_type_mesh_xml -subroutine init_xml_type_mesh_xml_array( dvar ) - type(mesh_xml), dimension(:), pointer :: dvar - if ( associated( dvar ) ) then - deallocate( dvar ) - endif - allocate( dvar(0) ) -end subroutine init_xml_type_mesh_xml_array -subroutine init_xml_type_mesh_xml(dvar) - type(mesh_xml) :: dvar -end subroutine init_xml_type_mesh_xml -subroutine write_xml_type_mesh_xml_array( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(mesh_xml), dimension(:) :: dvar - integer :: i - do i = 1,size(dvar) - call write_xml_type_mesh_xml( info, tag, indent, dvar(i) ) - enddo -end subroutine write_xml_type_mesh_xml_array - -subroutine write_xml_type_mesh_xml( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(mesh_xml) :: dvar - character(len=100) :: indentation - indentation = ' ' - write(info%lun, '(4a)' ) indentation(1:min(indent,100)),& - '<',trim(tag), '>' - call write_to_xml_integer( info, 'id', indent+3, dvar%id) - call write_to_xml_word( info, 'type', indent+3, dvar%type) - call write_to_xml_integer_array( info, 'dimension', indent+3, dvar%dimension) - call write_to_xml_double_array( info, 'origin', indent+3, dvar%origin) - call write_to_xml_double_array( info, 'width', indent+3, dvar%width) - write(info%lun,'(4a)') indentation(1:min(indent,100)), & - '' -end subroutine write_xml_type_mesh_xml - -subroutine read_xml_type_filter_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(inout) :: tag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(filter_xml), dimension(:), pointer :: dvar - logical, intent(inout) :: has_dvar - - integer :: newsize - type(filter_xml), dimension(:), pointer :: newvar - - newsize = size(dvar) + 1 - allocate( newvar(1:newsize) ) - newvar(1:newsize-1) = dvar - deallocate( dvar ) - dvar => newvar - - call read_xml_type_filter_xml( info, tag, endtag, attribs, noattribs, data, nodata, & - dvar(newsize), has_dvar ) -end subroutine read_xml_type_filter_xml_array - -subroutine read_xml_type_filter_xml( info, starttag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: starttag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(filter_xml), intent(inout) :: dvar - logical, intent(inout) :: has_dvar - - integer :: att_ - integer :: noatt_ - logical :: error - logical :: endtag_org - character(len=len(starttag)) :: tag - logical :: has_cell - logical :: has_surface - logical :: has_universe - logical :: has_material - logical :: has_mesh - logical :: has_cellborn - logical :: has_energy - logical :: has_energyout - has_cell = .false. - has_surface = .false. - has_universe = .false. - has_material = .false. - has_mesh = .false. - has_cellborn = .false. - has_energy = .false. - has_energyout = .false. - call init_xml_type_filter_xml(dvar) - has_dvar = .true. - error = .false. - att_ = 0 - noatt_ = noattribs+1 - endtag_org = endtag - do - if ( nodata /= 0 ) then - noattribs = 0 - tag = starttag - elseif ( att_ < noatt_ .and. noatt_ > 1 ) then - att_ = att_ + 1 - if ( att_ <= noatt_-1 ) then - tag = attribs(1,att_) - data(1) = attribs(2,att_) - noattribs = 0 - nodata = 1 - endtag = .false. - else - tag = starttag - noattribs = 0 - nodata = 0 - endtag = .true. - cycle - endif - else - if ( endtag_org ) then - return - else - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( xml_error(info) ) then - write(lurep_,*) 'Error reading input file!' - error = .true. - return - endif - endif - endif - if ( endtag .and. tag == starttag ) then - exit - endif - if ( endtag .and. noattribs == 0 ) then - if ( xml_ok(info) ) then - cycle - else - exit - endif - endif - select case( tag ) - case('cell') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%cell, has_cell ) - case('surface') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%surface, has_surface ) - case('universe') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%universe, has_universe ) - case('material') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%material, has_material ) - case('mesh') - call read_xml_integer( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%mesh, has_mesh ) - case('cellborn') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%cellborn, has_cellborn ) - case('energy') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%energy, has_energy ) - case('energyout') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%energyout, has_energyout ) - case ('comment', '!--') - ! Simply ignore - case default - if ( strict_ ) then - error = .true. - call xml_report_errors( info, & - 'Unknown or wrongly placed tag: ' // trim(tag)) - endif - end select - nodata = 0 - if ( .not. xml_ok(info) ) exit - end do -end subroutine read_xml_type_filter_xml -subroutine init_xml_type_filter_xml_array( dvar ) - type(filter_xml), dimension(:), pointer :: dvar - if ( associated( dvar ) ) then - deallocate( dvar ) - endif - allocate( dvar(0) ) -end subroutine init_xml_type_filter_xml_array -subroutine init_xml_type_filter_xml(dvar) - type(filter_xml) :: dvar - dvar%cell = '' - dvar%surface = '' - dvar%universe = '' - dvar%material = '' - dvar%mesh = 0 - dvar%cellborn = '' - dvar%energy = '' - dvar%energyout = '' -end subroutine init_xml_type_filter_xml -subroutine write_xml_type_filter_xml_array( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(filter_xml), dimension(:) :: dvar - integer :: i - do i = 1,size(dvar) - call write_xml_type_filter_xml( info, tag, indent, dvar(i) ) - enddo -end subroutine write_xml_type_filter_xml_array - -subroutine write_xml_type_filter_xml( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(filter_xml) :: dvar - character(len=100) :: indentation - indentation = ' ' - write(info%lun, '(4a)' ) indentation(1:min(indent,100)),& - '<',trim(tag), '>' - call write_to_xml_word( info, 'cell', indent+3, dvar%cell) - call write_to_xml_word( info, 'surface', indent+3, dvar%surface) - call write_to_xml_word( info, 'universe', indent+3, dvar%universe) - call write_to_xml_word( info, 'material', indent+3, dvar%material) - call write_to_xml_integer( info, 'mesh', indent+3, dvar%mesh) - call write_to_xml_word( info, 'cellborn', indent+3, dvar%cellborn) - call write_to_xml_word( info, 'energy', indent+3, dvar%energy) - call write_to_xml_word( info, 'energyout', indent+3, dvar%energyout) - write(info%lun,'(4a)') indentation(1:min(indent,100)), & - '' -end subroutine write_xml_type_filter_xml - -subroutine read_xml_type_tally_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(inout) :: tag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(tally_xml), dimension(:), pointer :: dvar - logical, intent(inout) :: has_dvar - - integer :: newsize - type(tally_xml), dimension(:), pointer :: newvar - - newsize = size(dvar) + 1 - allocate( newvar(1:newsize) ) - newvar(1:newsize-1) = dvar - deallocate( dvar ) - dvar => newvar - - call read_xml_type_tally_xml( info, tag, endtag, attribs, noattribs, data, nodata, & - dvar(newsize), has_dvar ) -end subroutine read_xml_type_tally_xml_array - -subroutine read_xml_type_tally_xml( info, starttag, endtag, attribs, noattribs, data, nodata, & - dvar, has_dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: starttag - logical, intent(inout) :: endtag - character(len=*), dimension(:,:), intent(inout) :: attribs - integer, intent(inout) :: noattribs - character(len=*), dimension(:), intent(inout) :: data - integer, intent(inout) :: nodata - type(tally_xml), intent(inout) :: dvar - logical, intent(inout) :: has_dvar - - integer :: att_ - integer :: noatt_ - logical :: error - logical :: endtag_org - character(len=len(starttag)) :: tag - logical :: has_id - logical :: has_filters - logical :: has_macros - logical :: has_reactions - logical :: has_nuclides - has_id = .false. - has_filters = .false. - has_macros = .false. - has_reactions = .false. - has_nuclides = .false. - call init_xml_type_tally_xml(dvar) - has_dvar = .true. - error = .false. - att_ = 0 - noatt_ = noattribs+1 - endtag_org = endtag - do - if ( nodata /= 0 ) then - noattribs = 0 - tag = starttag - elseif ( att_ < noatt_ .and. noatt_ > 1 ) then - att_ = att_ + 1 - if ( att_ <= noatt_-1 ) then - tag = attribs(1,att_) - data(1) = attribs(2,att_) - noattribs = 0 - nodata = 1 - endtag = .false. - else - tag = starttag - noattribs = 0 - nodata = 0 - endtag = .true. - cycle - endif - else - if ( endtag_org ) then - return - else - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( xml_error(info) ) then - write(lurep_,*) 'Error reading input file!' - error = .true. - return - endif - endif - endif - if ( endtag .and. tag == starttag ) then - exit - endif - if ( endtag .and. noattribs == 0 ) then - if ( xml_ok(info) ) then - cycle - else - exit - endif - endif - select case( tag ) - case('id') - call read_xml_integer( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%id, has_id ) - case('filters') - call read_xml_type_filter_xml( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%filters, has_filters ) - case('macros') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%macros, has_macros ) - case('reactions') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%reactions, has_reactions ) - case('nuclides') - call read_xml_word( & - info, tag, endtag, attribs, noattribs, data, nodata, & - dvar%nuclides, has_nuclides ) - case ('comment', '!--') - ! Simply ignore - case default - if ( strict_ ) then - error = .true. - call xml_report_errors( info, & - 'Unknown or wrongly placed tag: ' // trim(tag)) - endif - end select - nodata = 0 - if ( .not. xml_ok(info) ) exit - end do - if ( .not. has_id ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on id') - endif - if ( .not. has_filters ) then - has_dvar = .false. - call xml_report_errors(info, 'Missing data on filters') - endif -end subroutine read_xml_type_tally_xml -subroutine init_xml_type_tally_xml_array( dvar ) - type(tally_xml), dimension(:), pointer :: dvar - if ( associated( dvar ) ) then - deallocate( dvar ) - endif - allocate( dvar(0) ) -end subroutine init_xml_type_tally_xml_array -subroutine init_xml_type_tally_xml(dvar) - type(tally_xml) :: dvar - dvar%macros = '' - dvar%reactions = '' - dvar%nuclides = '' -end subroutine init_xml_type_tally_xml -subroutine write_xml_type_tally_xml_array( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(tally_xml), dimension(:) :: dvar - integer :: i - do i = 1,size(dvar) - call write_xml_type_tally_xml( info, tag, indent, dvar(i) ) - enddo -end subroutine write_xml_type_tally_xml_array - -subroutine write_xml_type_tally_xml( & - info, tag, indent, dvar ) - type(XML_PARSE) :: info - character(len=*), intent(in) :: tag - integer :: indent - type(tally_xml) :: dvar - character(len=100) :: indentation - indentation = ' ' - write(info%lun, '(4a)' ) indentation(1:min(indent,100)),& - '<',trim(tag), '>' - call write_to_xml_integer( info, 'id', indent+3, dvar%id) - call write_xml_type_filter_xml( info, 'filters', indent+3, dvar%filters) - call write_to_xml_word( info, 'macros', indent+3, dvar%macros) - call write_to_xml_word( info, 'reactions', indent+3, dvar%reactions) - call write_to_xml_word( info, 'nuclides', indent+3, dvar%nuclides) - write(info%lun,'(4a)') indentation(1:min(indent,100)), & - '' -end subroutine write_xml_type_tally_xml - -subroutine read_xml_file_tallies_t(fname, lurep, errout) - character(len=*), intent(in) :: fname - integer, intent(in), optional :: lurep - logical, intent(out), optional :: errout - - type(XML_PARSE) :: info - logical :: error - character(len=80) :: tag - character(len=80) :: starttag - logical :: endtag - character(len=80), dimension(1:2,1:20) :: attribs - integer :: noattribs - character(len=200), dimension(1:100) :: data - integer :: nodata - logical :: has_mesh_ - logical :: has_tally_ - has_mesh_ = .false. - allocate(mesh_(0)) - has_tally_ = .false. - allocate(tally_(0)) - - call init_xml_file_tallies_t - call xml_open( info, fname, .true. ) - call xml_options( info, report_errors=.false., ignore_whitespace=.true.) - lurep_ = 0 - if ( present(lurep) ) then - lurep_ = lurep - call xml_options( info, report_lun=lurep ) - endif - do - call xml_get( info, starttag, endtag, attribs, noattribs, & - data, nodata) - if ( starttag /= '!--' ) exit - enddo - if ( starttag /= "tallies" ) then - call xml_report_errors( info, & - 'XML-file should have root element "tallies"') - error = .true. - call xml_close(info) - return - endif - strict_ = .false. - error = .false. - do - call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) - if ( xml_error(info) ) then - write(lurep_,*) 'Error reading input file!' - error = .true. - return - endif - if ( endtag .and. tag == starttag ) then - exit - endif - if ( endtag .and. noattribs == 0 ) then - if ( xml_ok(info) ) then - cycle - else - exit - endif - endif - select case( tag ) - case('mesh') - call read_xml_type_mesh_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - mesh_, has_mesh_ ) - case('tally') - call read_xml_type_tally_xml_array( & - info, tag, endtag, attribs, noattribs, data, nodata, & - tally_, has_tally_ ) - case ('comment', '!--') - ! Simply ignore - case default - if ( strict_ ) then - error = .true. - call xml_report_errors( info, & - 'Unknown or wrongly placed tag: ' // trim(tag)) - endif - end select - nodata = 0 - if ( .not. xml_ok(info) ) exit - end do - if ( .not. has_mesh_ ) then - error = .true. - call xml_report_errors(info, 'Missing data on mesh_') - endif - if ( .not. has_tally_ ) then - error = .true. - call xml_report_errors(info, 'Missing data on tally_') - endif - if ( present(errout) ) errout = error -end subroutine - -subroutine write_xml_file_tallies_t(fname, lurep) - character(len=*), intent(in) :: fname - integer, intent(in), optional :: lurep - - type(XML_PARSE) :: info - integer :: indent = 0 - - call xml_open( info, fname, .false. ) - call xml_options( info, report_errors=.true.) - if ( present(lurep) ) then - call xml_options( info, report_errors=.true.) - endif - write(info%lun,'(a)') & - '' - call write_xml_type_mesh_xml_array( info, 'mesh', indent+3, mesh_) - call write_xml_type_tally_xml_array( info, 'tally', indent+3, tally_) - write(info%lun,'(a)') '' - call xml_close(info) -end subroutine - -subroutine init_xml_file_tallies_t - -end subroutine - -end module