├── .gitignore ├── CHANGES ├── LICENSE ├── README ├── TODO ├── doc ├── gettingstarted.pdf ├── using_xml_files.pdf ├── xml_again.pdf └── xmlparse.html ├── examples ├── array_of_words │ ├── Makefile │ ├── array_of_words.xml │ ├── example_words.xml │ └── tst_array_of_words.f90 ├── grid │ ├── Makefile │ ├── grid.xml │ ├── grid_example.xml │ └── tst_grid.f90 ├── menu │ ├── Makefile │ ├── menu.xml │ ├── menuitems.xml │ └── tst_menu.f90 ├── process │ ├── Makefile │ ├── simple.xml │ └── tst_process.f90 ├── readint │ ├── Makefile │ ├── readint.xml │ ├── readint_example.xml │ └── tst_readint.f90 └── writexml │ ├── Makefile │ └── writexml.f90 └── src ├── Makefile ├── read_from_buffer.inc ├── read_xml_array.inc ├── read_xml_primitives.f90 ├── read_xml_scalar.inc ├── read_xml_word.inc ├── test_read_prims.f90 ├── test_write_prims.f90 ├── tree_find.f90 ├── tree_struct.f90 ├── tst_prims.f90 ├── tstparse.f90 ├── tstparse.inp ├── write_xml_primitives.f90 ├── xmlparse.f90 ├── xmlreader.conf ├── xmlreader.f90 ├── xmlreader.inp ├── xmlreader_noprint.f90 └── xsdconvert.f90 /.gitignore: -------------------------------------------------------------------------------- 1 | # Compiler objects, modules, and executables 2 | examples/*.o 3 | examples/*.mod 4 | src/*.o 5 | src/*.mod 6 | src/libxmlparse.a 7 | src/xmlreader 8 | 9 | # Installed libraries 10 | lib/ 11 | 12 | # Emacs backups 13 | *~ 14 | -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | Changes wrt previous versions: 2 | ------------------------------ 3 | 4 | dd. 7 april 2008 5 | Corrected support for writing the data - the placeholder problem 6 | has been solved. 7 | This is now version 1.00 8 | 9 | dd. 27 december 2007 10 | Added support for writing the data to an XML file in 11 | xmlreader.f90 (the program now generates a routine write_xml_* as well 12 | that writes a file with the same structure as the routine read_xl_* 13 | reads). There is one problem left: if the definition contains 14 | "placeholders", the code is not written in the correct order. 15 | 16 | dd. 7 december 2007 17 | Added new predefined types, so that a specification like: 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | works as well (for all primitive types) 26 | 27 | Added the start of a program to convert XSD-files. 28 | 29 | dd. 25 june 2007 30 | Adjusted the xmlreader program to properly accept smaller arrays 31 | for fixed shape variables. 32 | 33 | dd. 19 june 2007 34 | Corrected a mistake with character variables with fixed shape. 35 | Allow larger arrays than according to shape 36 | 37 | dd. 17 june 2007 38 | Updated the documentation, prepared release of version 0.97 39 | 40 | dd. 12 june 2007 41 | Added support for arrays of fixed "shape" (see 42 | the menuitems example) 43 | 44 | Fixed a bug with handling the default values for variables 45 | (the code ended up in the wrong place) 46 | 47 | dd 10. june 2007 48 | Added routines to write basic data to an XML file. 49 | (Start of implementation of generating export routines 50 | in the xmlreader program) 51 | 52 | Corrected bug in xmlreader program (had to do with 53 | whitespace that interfered with the processing in the 54 | generated reader code) 55 | 56 | NOTE: Still need to check that this solves the 57 | problem entirely! 58 | 59 | Applied patch by Davide Cesari: array of strings and 60 | initialising pointer components. 61 | 62 | dd 26. february 2007 63 | Fixed a bug in the xmlreader program wrt reading 64 | attributes as data (self-contained elements were 65 | sometimes skipped - i.e. 66 | was not treated properly in all cases) 67 | 68 | dd 1. july 2006 69 | Corrected the initialisation of the array "entities" 70 | - the strings must all be the same length (not 71 | all compilers will complain about it though). 72 | 73 | And some corrections by Jacques Germishuizen for the 74 | examples. 75 | 76 | dd. 26 june 2006 77 | Fixed a few bugs pointed out by 78 | Jacques Germishuizen (rootname, double precision 79 | variables) 80 | 81 | dd. 16 june 2006 82 | Added a small configuration file to the 83 | xmlreader program - some global settings and 84 | a way to work around a limitation in some 85 | compilers. 86 | Also added a facility whereby attribute 87 | values are treated as data for a subelement: 88 | In the menu example (tst_menu.f90, menu.xml, 89 | menuitems.xml) the following fragments are 90 | equivalent: 91 | 92 | 93 | 94 | and 95 | 96 | 97 | item 98 | Open ... 99 | 100 | 101 | dd. 9 june 2006 102 | Corrected a severe misunderstanding about XML - 103 | the requirement that there is a root element 104 | This has now been built into the xmlreader 105 | program. 106 | Some refinements to xmlparse.f90 (extra check 107 | on elements) and added proper 108 | comments. 109 | 110 | dd. 5 june 2006 111 | Added two examples 112 | Added subroutine xml_process 113 | Updated the documentation 114 | Corrected bugs in xmlreader.f90 115 | 116 | dd. 30 may 2006 117 | Added TODO file to the project 118 | Added support for "strict" parsing of the 119 | XML file via the generated reader routine. 120 | 121 | dd. 28 may 2006 122 | Solved a problem with place holder tags 123 | (anything after the closing tag was 124 | ignored) 125 | 126 | dd. 17 may 2006 127 | Corrected a few glitches in xmlreader.f90 - 128 | The code generated for place holder tags 129 | was incorrect. 130 | 131 | Note: There is still a bug which appears 132 | in example tst_grid. With the tag "general" 133 | in place, the gridarray tags are not seen: 134 | 135 | 136 | 137 | Read a couple of integers and a derived type 138 | 139 | 1020 140 | 141 | 142 | 1 143 | 2 144 | 2 145 | 146 | 1122 147 | 1223 148 | 23 149 | 150 | Maybe an ordering/loop problem? 151 | 152 | dd. 7 february 2006 153 | Corrected a stupid mistake in xmlreader.f90 - 154 | the spurious error message is gone 155 | 156 | dd. 6 february 2006 157 | Added placeholders to the xmlreader utility. More 158 | thorough tests required: the generated source code is 159 | composed of several pieces, the ordering can be 160 | wrong when the XML file is ordered differently. 161 | 162 | Note: 163 | The generated code is not tested yet. It looks okay, 164 | but that is all. 165 | 166 | dd. 24 january 2006 167 | Extended the xmlreader utility with new features. 168 | (mostly support for default values) 169 | 170 | 171 | dd. 19 october 2005 172 | Added support for "entities" (like an ampersand) in 173 | character data. 174 | 175 | Expanded the capabilities of the xmlreader program 176 | with arrays of primitives and derived types. 177 | 178 | Updated the project documents at http://xml-fortran.sf.net 179 | 180 | 181 | dd. 3 october 2005 182 | Integrated a patch by cinonet with the file xmlparse.f90. 183 | 184 | Updated the documentation with information on the xmlreader 185 | program. 186 | 187 | New version of the test program (more flexible) for the 188 | parser. Not finished yet. 189 | 190 | New version of the xmlreader program - added support for 191 | derived types. 192 | 193 | 194 | dd. 29 september 2005 195 | Added two articles on the use of XML in Fortran that appeared in 196 | the Fortran Forum. 197 | 198 | Updated the project page - new information on available libraries among 199 | other things. 200 | 201 | Added new code: 202 | - tree_struct.f90 and tree_find.f90: 203 | Module for manipulating general tree structures 204 | 205 | - read_xml_prims.f90 and test_read_prims.f90 206 | Code to read (integer) data returned from xml_get. 207 | Will be part of a new approach to dealing with XML files 208 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Note: The official xml-fortran repository on sourceforge 2 | only lists the license as "BSD License". It 3 | is assumed that this refers to the 3-clause BSD license ("modified" or "new") 4 | that is shown below. 5 | 6 | ================================================================================ 7 | 8 | Copyright (c) 2011-2012 Paul K. Romano 9 | 10 | Copyright (c) 2008 Arjen Markus 11 | All rights reserved. 12 | 13 | Redistribution and use in source and binary forms, with or without modification, 14 | are permitted provided that the following conditions are met: 15 | 16 | * Redistributions of source code must retain the above copyright notice, 17 | this list of conditions and the following disclaimer. 18 | 19 | * Redistributions in binary form must reproduce the above copyright notice, 20 | this list of conditions and the following disclaimer in the documentation 21 | and/or other materials provided with the distribution. 22 | 23 | * Neither the name of the copyright holders nor the names of its 24 | contributors may be used to endorse or promote products derived from this 25 | software without specific prior written permission. 26 | 27 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 28 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 29 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 30 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, 31 | INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 32 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 33 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 34 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 35 | OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF 36 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 37 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Parser for XML-files in Fortran: 2 | -------------------------------- 3 | 4 | CONTENTS 5 | 6 | The directory structure is straightforward: 7 | 8 | README 9 | This file 10 | CHANGES 11 | Version and release information 12 | doc/ 13 | Contains the relevant documents describing how to use the parser module 14 | and the xmlreader utility that can generate the source of a module 15 | to read XML files with a particular structure. 16 | src/ 17 | Contains the sources and a simple makefile for creating the library 18 | and test programs. Also contains the source for the xmlreader 19 | utility that 20 | examples/ 21 | Contains example programs and input files 22 | lib/ 23 | After installation, contains the library and the module file, so 24 | that other programs can use it 25 | 26 | 27 | INSTALLATION 28 | 29 | This depends on the compiler you use and the platform, but the following 30 | steps are required: 31 | 32 | 1. Make the library and the module file via the makefile or something 33 | equivalent: 34 | 35 | > make 36 | 37 | 2. Copy the library and the module file to a place where the compiler 38 | will be able to find them. Within the limits of the simple makefile 39 | that is delivered here, this should do the trick: 40 | 41 | > make install 42 | 43 | Notes: 44 | Compilers vary in the naming convention for the module files. It is 45 | virtually impossible to support them all, so the makefile supports 46 | only a few of the possibilities. 47 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | TODO 2 | 3 | dd. 7 april 2008 4 | Most issues listed below have been solved. 5 | 6 | Major thing to do right now: finish the xsdconvert program 7 | 8 | 9 | dd. 12 june 2007 10 | - Document the shape= option 11 | 12 | dd. 5 march 2007 13 | Found a number of limitations to the parser generated via the 14 | xmlreader program: 15 | + Comments at the beginning (before the root element) are not 16 | recognised as such 17 | + There is no message about the tag that was found 18 | + No indication of the line number at which an error occurred 19 | - Defining optional elements is tricky: defaults are not enough, 20 | as there is no indication of what element was filled and 21 | defining defaults for derived types is awkward (especially 22 | if they contain derived types as fields) 23 | - There is no facility to create a proper deallocation routine or a 24 | print/write routine at the moment. 25 | + If the element contains both attributes and data, the data are 26 | lost 27 | 28 | Found one bug as well: 29 | - The placeholder facility causes incomplete reading routines. 30 | 31 | Solving these issues will require a new attribute and an update 32 | of the manual. 33 | 34 | (Issues with + have been solved) 35 | 36 | Hm, yet another problem: comment in the menu example. 37 | Solution: 38 | Handle the complete comment element in that case 39 | 40 | dd. 26 february 2007 41 | - A checking facility can easily be built using 42 | the xmlreader program. It would take the same 43 | input as the xmlreader program but check that 44 | all elements contain the proper subelements and 45 | attributes. 46 | 47 | dd. 1 july 2006 48 | - Add a better checking facility - balanced open-close 49 | elements. 50 | 51 | dd. 9 june 2006 52 | - Fix a bug regarding the well-formedness of 53 | Done 54 | - Fix an oversight in the xmlreader program: there _must_ be 55 | a root element 56 | Done 57 | - Fix a bug regarding the number of data lines _after_ a 58 | closing tag ... Or is that not a bug? 59 | 60 | dd. 5 june 2006 61 | Added this TODO file as an "official" list of things that are to done. 62 | 63 | The following functionality should be added: 64 | 65 | - In xmlreader: a facility for generating an appropriate writing 66 | routine. 67 | 68 | - In xmlreader: the options globaltype and version number 69 | and a small settings file to set certain parameters 70 | separately from the definition of the data structure 71 | (one parameter: to circumvent an apparent restriction of 72 | certain compilers vis-a-vis dynamic string length) 73 | 74 | - More (realistic) examples 75 | 76 | - A more flexible way of storing the character data: 77 | Allocated arrays and strings of arbitrary length. 78 | 79 | 80 | Limitations and bugs to be overcome: 81 | 82 | - In xmlreader: optional placeholder tags have not been 83 | implemented yet 84 | - Decided not to implement that feature. In retrospect 85 | I see little use for this. 86 | 87 | - Not all aspects of XML are yet supported (CDATA and process 88 | instructions for instance) 89 | 90 | - Writing XML files is not well-tested. Add an example 91 | for this. 92 | 93 | 94 | Things that probably will never be done: 95 | 96 | - XSLT, XPath and the like. 97 | -------------------------------------------------------------------------------- /doc/gettingstarted.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/paulromano/xml-fortran/ffe63a0591e86fc1c17a6cb673b56e633b15f906/doc/gettingstarted.pdf -------------------------------------------------------------------------------- /doc/xmlparse.html: -------------------------------------------------------------------------------- 1 | 2 | XMLPARSE - XML 3 | 4 | 6 | 8 | 9 | 10 |

XMLPARSE(n) 0.9 "XML"

11 |

NAME

12 |

13 |

XMLPARSE - Parser for XML files in Fortran 14 | 15 | 16 |

TABLE OF CONTENTS

17 |

    TABLE OF CONTENTS
18 |     SYNOPSIS
19 |     DESCRIPTION
20 |     PROCEDURES
21 |     MOTIVATION
22 |     PARAMETERS AND DERIVED TYPES
23 |     GENERATING A READING ROUTINE
24 |     EXAMPLES
25 |     LIMITATIONS
26 |     RELEASE NOTES
27 |     TO DO
28 |     KEYWORDS
29 |

SYNOPSIS

30 |

31 |
32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 |
subroutine xml_open( info, filename, mustread )
subroutine xml_close( info )
subroutine xml_options( info, ... )
subroutine xml_get( info, tag, endtag, attribs, no_attribs, data, no_data )
subroutine xml_put( info, tag, attribs, no_attribs, data, no_data, type )
logical function xml_ok( info )
logical function xml_error( info )
logical function xml_data_trunc( info )
integer function xml_find_attrib( attribs, no_attribs, name, value )
subroutine read_xml_file_xxx( filename, lurep, error )
subroutine xml_process( filename, attribs, data, startfunc, datafunc, endfunc, lurep, error )
43 |

DESCRIPTION

44 |

45 | The XML parser provided by this module has been written entirely in 46 | Fortran, making it possible to read and write XML files without the need 47 | to use mixed-language programming techniques. 48 |

49 | It should be noted that the implementation has a number of limitations 50 | (cf. the section Limitations). The module has the following features: 51 | 52 |

    53 |
  • 54 | Reading an XML-file (within certain limitations) in a stream-oriented 55 | manner. 56 | 57 |

    58 |
  • 59 | Writing an XML-file in a stream-oriented manner. 60 | 61 |

    62 |
  • 63 | Creating a reading routine that will fill a data structure. The data 64 | structure is described via an XML file and all necessary code to read 65 | files that conform to that structure is generated. 66 | 67 |
68 | 69 |

70 | The module has been implemented in standard Fortran 90. It is the 71 | intention to make it compilable by the F compiler as well, so that 72 | it can be used in conjunction to a wide set of Fortran compilers. 73 |

74 | (It should even be possible to convert the parsing routines to an 75 | equivalent library in FORTRAN 77, though with the availability of 76 | several free Fortran 95 compilers, there seems little need for that.) 77 | 78 |

PROCEDURES

79 |

80 | The module defines the following public routines and functions: 81 |

82 | 83 |
subroutine xml_open( info, filename, mustread )
84 | 85 | Open an XML-file and fill the structure info, so that it can be 86 | used to refer to the opened file. 87 |

88 | To check if all is well, (errors could be: the file can not be opened 89 | for some reason), the function xml_error() is available. 90 |

91 | Arguments: 92 |

93 |
94 | info - TYPE(XML_PARSE) structure used to identify the file 95 |

96 | filename - CHARACTER(LEN=*) name of the file to be opened 97 |

98 | mustread - LOGICAL whether to read the file or to write to it 99 |
100 |

101 | 102 |
subroutine xml_close( info )
103 | 104 | Close an opened XML-file. If the file was not opened, this routine has 105 | no effect. 106 |

107 | info - TYPE(XML_PARSE) structure used to identify the file 108 |

109 | 110 |

111 |
subroutine xml_options( info, ... )
112 | 113 | Set one or more options. These are all defined as optional arguments, so 114 | that the name=value convention can be used to select an option 115 | and to set its value. The first argument is fixed: 116 |

117 | info - TYPE(XML_PARSE) structure used to identify the file 118 |

119 | All other arguments are optional and include: 120 |

121 |

122 |
123 | ignore_whitespace - LOGICAL compress the array of strings (remove 124 | empty lines and remove leading blanks) for easier processing 125 |

126 | no_data_truncation - LOGICAL if data truncation occurs (too many 127 | lines of data or too many attributes, so that they can not all be stored 128 | in the arrays), this can be marked as an error or not. If the option is 129 | set to true, it is considered an error. 130 |

131 | report_lun - INTEGER LU-number of a file to which messages can be 132 | logged (use XML_STDOUT for output to screen) 133 |

134 | report_errors - LOGICAL write error messages to the report 135 |

136 | report_details - LOGICAL write detailed messages to the report, 137 | useful for debugging 138 |
139 |

140 | Note that these options are off by default. They should be set 141 | after the file has been opened. The reporting options can be set before 142 | an XML file has been opened, they hold globally (that is, they are in 143 | effect for all reading and writing, independent of the files). 144 |

145 | 146 |

147 |
subroutine xml_get( info, tag, endtag, attribs, no_attribs, data, no_data )
148 | 149 | Read the current tag in the file up to the next one or the end-of-file. 150 | Store the attributes in the given array and do the same for the 151 | character data that may be present after the tag. 152 |

153 |
154 | info - TYPE(XML_PARSE) structure used to identify the file 155 |

156 | tag - CHARACTER(LEN=*) string that will hold the tag's name 157 |

158 | endtag - LOGICAL indicates whether the current tag has ended or 159 | not 160 |

161 | attribs - CHARACTER(LEN=*), DIMENSION(:,:) array of strings that 162 | will hold the attributes given to the tag 163 |

164 | no_attribs - INTEGER number of attributes that were found 165 |

166 | data - CHARACTER(LEN=*), DIMENSION(:) array of strings that 167 | will hold the character data (one element per line) 168 |

169 | no_data - INTEGER number of lines of character data 170 |
171 | Note: 172 |

173 | If an error occurs or end-of-file is found, then use the functions 174 | xml_ok() and xml_error() to find out the conditions. 175 |

176 | 177 |

178 |
subroutine xml_put( info, tag, attribs, no_attribs, data, no_data, type )
179 | 180 | Write the information for the current tag to the file. This subroutine 181 | is the inverse, so to speak, of the subroutine xml_get that 182 | parses the XML input. 183 |

184 | For a description of the arguments, other than type: see above. 185 |

186 | type - CHARACTER(LEN=*) string having one the following values: 187 |

188 |
    189 |
  • 190 | 'open' - Write an opening tag with attributes and data (if there 191 | are any). Useful for creating a hierarchy of tags. 192 |

    193 |
  • 194 | 'close' - Write a closing tag 195 |

    196 |
  • 197 | 'elem' - Write the element data 198 |
199 |

200 | 201 |
logical function xml_ok( info )
202 | 203 | Returns whether the parser is still okay (no read errors or 204 | end-of-file). 205 |

206 | info - TYPE(XML_PARSE) structure used to identify the file 207 |

208 | 209 |

210 |
logical function xml_error( info )
211 | 212 | Returns whether the parser has encountered some error (see also the 213 | options). 214 |

215 | info - TYPE(XML_PARSE) structure used to identify the file 216 |

217 | 218 |

219 |
logical function xml_data_trunc( info )
220 | 221 | Returns whether the parser has had to truncate the data or the 222 | attributes. 223 |

224 | info - TYPE(XML_PARSE) structure used to identify the file 225 |

226 | 227 |

228 |
integer function xml_find_attrib( attribs, no_attribs, name, value )
229 | 230 | Convenience function that searches the list of attributes and returns 231 | the index of the sought attribute in the array or -1 if not present. 232 | In that case the argument value is not set, so that you can use 233 | this to supply a default. 234 |

235 |
236 | attribs - CHARACTER(LEN=*), DIMENSION(:,:) array of strings that 237 | hold the attributes 238 |

239 | no_attribs - INTEGER number of attributes that was found 240 |

241 | name - CHARACTER(LEN=*) name of the attribute to be found 242 |

243 | value - CHARACTER(LEN=*) actual or default value of the attribute 244 | upon return 245 |
246 | 247 |
subroutine read_xml_file_xxx( filename, lurep, error )
248 | 249 | Subroutine generated via the method described below to read an XML 250 | file of a particular structure. 251 |

252 |
253 | filename - CHARACTER(LEN=*) name of the XML file to read 254 |

255 | lurep - INTEGER LU-number to use for reporting errors (use 0 to 256 | write to the screen; optional) 257 |

258 | error - LOGICAL variable that indicates if an error occurred 259 | while reading (optional). 260 |
261 | 262 |
subroutine xml_process( filename, attribs, data, startfunc, datafunc, endfunc, lurep, error )
263 | 264 | Subroutine that reads the XML file and calls three user-defined 265 | subroutines to take care of the actual processing. This is a 266 | routine that implements the so-called SAX approach. 267 |

268 |
269 | filename - CHARACTER(LEN=*) name of the XML file to read 270 |

271 | attribs - CHARACTER(LEN=*), DIMENSION(:,:) work array to store the 272 | attributes 273 |

274 | data - CHARACTER(LEN=*), DIMENSION(:) work array to store the 275 | character data associated with a tag 276 |

277 | 278 | startfunc - Subroutine that is called to handle the start 279 | of a tag: 280 |

 
281 |     subroutine startfunc( tag, attribs, error )
282 |        character(len=*)                 :: tag
283 |        character(len=*), dimension(:,:) :: attribs
284 |        logical                          :: error
285 |

286 |

287 | If the argument error is set to true (because the tag was unexpected or 288 | something similar), the reading is interrupted and the routine returns. 289 | Only the fact that something was wrong is recorded. You need to use 290 | other means to convey more information if that is needed. 291 | 292 |

293 | datafunc - Subroutine that is called to handle the character data 294 | associated with a tag: 295 |

 
296 |     subroutine datafunc( tag, attribs, error )
297 |        character(len=*)               :: tag
298 |        character(len=*), dimension(:) :: data
299 |        logical                        :: error
300 |

301 |

302 | 303 | endfunc - Subroutine that is called to handle the end 304 | of a tag: 305 |

 
306 |     subroutine endfunc( tag, error )
307 |        character(len=*)               :: tag
308 |        logical                        :: error
309 |

310 |

311 | lurep - INTEGER LU-number to use for reporting errors (use 0 to 312 | write to the screen; optional) 313 |

314 | error - LOGICAL variable that indicates if an error occurred 315 | while reading (optional). 316 |
317 | 318 |
319 | 320 |

MOTIVATION

321 |

322 | The use of XML-files as a means to store data and more importantly to 323 | transfer data between very disparate applications and organisations has 324 | been growing these last few years. Standard implementations of libraries 325 | that deal with all features of XML or a significant part of them are 326 | available in many languages, but as far as we know there was no 327 | implementation in Fortran. 328 |

329 | One could of course use, say, the well-known Expat library by ... and 330 | provide a Fortran interface, but this is slightly awkward as it forces 331 | one to have a compatible C compiler. More importantly, this introduces 332 | platform-dependencies because the interfacing between Fortran and C 333 | depends strongly on the used compilers and this introduces a way of 334 | working that is alien to Fortran programmers: Expat requires the 335 | programmer to register a callback function, to be called when some 336 | "event" occurs while reading the file (a begin tag is found, character 337 | data are found and so on). 338 |

339 | The alternative is even more awkward: build a tree of tags and 340 | associated data and ask for these data. To a Fortran programmer, one of 341 | the first things they will want to do with an XML-file is to get all the 342 | information out - so a stream-oriented parsing method is more 343 | appropriate. 344 |

345 | Among the two predominant types of XML-parsing, SAX or stream-oriented 346 | parsing and DOM or object-oriented parsing, the stream-oriented approach 347 | is more suitable to the frame of mind of the average Fortran programmer. 348 | But instead of registering callbacks, this module uses the method known 349 | from, for instance, GNU's getopt() function: parse the data and return 350 | to the caller to have it process the information. The caller calls the 351 | function again and again, letting getopt() take care of the details. 352 |

353 | This is exactly the approach taken by the xmlparse module: 354 |

 
355 |     call xml_open(info, ... )
356 | 
357 |     do while ( xml_ok(info) )
358 |        call xml_get(info, ... ) ! Get the first/next tag
359 |        ... identify the tag (via xml_check_tag for instance)
360 |        ... process the information
361 |     enddo
362 | 
363 |     call xml_close(info)
364 | 
365 |     ... proceed with the rest of the program
366 |

367 | 368 |

369 | For convenience, the module does supply the routine xml_process 370 | that takes three user-defined subroutines to perform the actual 371 | processing. The file will be processed in its entirety. 372 | 373 |

PARAMETERS AND DERIVED TYPES

374 |

375 | The module defines several parameters and derived types for use by the 376 | programmer: 377 |

378 |
XML_BUFFER_LENGTH
379 | the length of the internal buffer, representing 380 | the maximum length of any individual line in an XML file and the maximum 381 | length for a tag including all its attributes. 382 | 383 |

384 |
XML_STDOUT
385 | a parameter to indicate the standard output (or *) as the file to 386 | write messages to. 387 | 388 |

389 |
type(XML_PARSE)
390 | the data structure that holds information about 391 | the XML file to be read or written. Its contents are partially 392 | accessible via functions such as XML_OK() and XML_ERROR(). 393 | Note: do not use its contents directly, as these may change in 394 | future. 395 | 396 |
397 | 398 |

GENERATING A READING ROUTINE

399 |

400 | Reading an XML file and making sure the data are structured the way 401 | they are supposed to, generally requires a lot of code. This can not be 402 | avoided: you will want to make sure everything you need is there and 403 | anything else is dealt with appropriately. 404 |

405 | There is a way out: by automatically generating the reading routine 406 | you can reduce the amount of manual coding to a minimum. This has two 407 | advantages: 408 |

    409 |
  • 410 | It is much less work to define the data and their place in an XML file 411 | than it is to encode the reading routine. 412 |

    413 |
  • 414 | It is much less error-prone, if the logic is generated for you and 415 | therefore you need much less testing. 416 |
417 | The idea is simple: 418 |

419 | In an XML-file you define the data structure and the way this data 420 | structure should appear in an input XML file for your program. 421 | The process is probably best explained via an example. 422 |

423 | Say, you want to read addresses (a classical example). Each address 424 | consists of the name of the person, street name and the number of 425 | the house, city (let us keep it simple). Of course we have multiple 426 | addresses, so they are stored in an array. Then via the 427 | xmlreader program you can generate a reading routine that 428 | deals with this type of information. 429 |

430 | The program takes an XML file as input and produces a Fortran 90 module 431 | that reads input files and stores the data in the designated variables. 432 | It also creates a writing routine to write the data to an XML file. 433 |

434 | In our case, we want a derived type to hold the various pieces 435 | that form a complete address and we want an array of that type: 436 |

 
437 | <typedef name="address_type">
438 |    <component name="person" type="character" length="40">
439 |    <component name="street" type="character" length="40">
440 |    <component name="number" type="integer">
441 |    <component name="city"   type="character" length="40">
442 | </typedef>
443 | <variable name="adress" dimension="1">
444 |

445 | 446 | This will produce the following derived type: 447 |

 
448 | type address_type
449 |    character(len=40) :: person
450 |    character(len=40) :: street
451 |    integer           :: number
452 |    character(len=40) :: city
453 | end type address_type
454 |

455 | and a variable "address": 456 |

 
457 | type(address_type), dimension(:), pointer :: address
458 |

459 | 460 | The reading routine will be able to read such XML files as the 461 | following: 462 |

 
463 | <address>
464 |    <person>John Doe</person>
465 |    <street>Wherever street</street>
466 |    <number>30</number>
467 |    <city>Erewhon</city>
468 | </address>
469 | <address>
470 |    ...
471 | </address>
472 | ...
473 |

474 | If in some address the number was forgotten, the reading routine will 475 | report this, as by default all variables and components in a derived 476 | type must be present. 477 | 478 |

479 | Here is a more detailed description of the XML files accepted by the 480 | xmlreader program: 481 |

    482 |
  • 483 | Use the comment tag to insert comments in the input file to 484 | reader (or the input to the resulting reading routines) 485 | 486 |

    487 |
  • 488 | The options tag can be used to influence the generated code: 489 |

    490 |
      491 |
    • 492 | The attribute "strict" determines whether unknown tags are 493 | regarded as an error (strict="yes") or not (strict="no", 494 | the default). 495 |

      496 |
    • 497 | The attribute "globaltype" is used to indicate that all variables should 498 | belong to a single derived type, whose name defaults to the name of the 499 | file. Use the "typename" attribute to set the name to a different value. 500 |
    501 | 502 |
  • 503 | If you want to group tags for several variables, but you do not 504 | want to introduce a special derived type, you can do so with the 505 | placeholder tag. Its effect is to require an additional 506 | tag - end tag surrounding the data. Any tags defined within the 507 | placeholder - end placeholder tags will have to be put in the 508 | corresponding tags in the input file for the resulting program. 509 |

     
    510 | <placeholder tag="grid">
511 |     <variable x ...>
512 |     <variable y ...>
513 | </placeholder>
514 |

    515 | 516 |

    517 |
  • 518 | variable tags correspond directly to module variables. 519 | They are used to declare these variables and to generate the code that will 520 | read them. 521 |

    522 | Variable tags can appear anywhere except within a type definition. 523 | Variables can be of a previously defined derived type or of a 524 | primitive type. 525 |

     
    526 | <variable name="x" type="integer" default="1" />
527 |

    528 | Variables can have a number of attributes: 529 |

    530 |
      531 |
    • 532 | Required attributes: 533 |

      534 |
      535 | name - the name of the variable in the actual program 536 |

      537 | type - the type of the variable 538 |

      539 | length - for character types only, the length of the string 540 |
      541 |

      542 | 543 |
    • 544 | Optional attributes: 545 |

      546 |
      547 | default - the default value to be used if information is missing 548 |

      549 | dimension - the number of dimensions (up to 3), gives rise to a 550 | pointer component 551 |

      552 | shape - the fixed size of an array, if this is present, the 553 | number of dimensions is taken from this attribute. 554 |

      555 | tag - the name of the tag that holds the data (default to 556 | the name of the variable) 557 |
      558 |

      559 | 560 |
    • 561 | Basic types for the variables include: 562 |

      563 |
      564 | integer - a single integer value 565 |

      566 | integer-array - a one-dimensional array of integer values (the 567 | values must appear between an opening and ending tag) 568 | real - a single-precision real value 569 |

      570 | real-array - a one-dimensional array of real values (the 571 | values must appear between an opening and ending tag) 572 |

      573 | double - a double-precision real value 574 |

      575 | double-array - a one-dimensional array of double-precision values 576 | (the values must appear between an opening and ending tag) 577 |

      578 | logical - a single logical value (represented as "T" or "F") 579 |

      580 | logical-array - a one-dimensional array of logical values 581 | (the values must appear between an opening and ending tag) 582 |

      583 | word - a character string as can be read via list-directed input 584 | (if it should contain spaces, surround it with single or double quotes) 585 |

      586 | word-array - a one-dimensional array of strings 587 | (the values must appear between an opening and ending tag) 588 |

      589 | line - a character string as can be read from a single line 590 | of text (via the '(A)' format) 591 |

      592 | line-array - a one-dimensional array of strings, read as 593 | individual lines between the opening and closing tag 594 |

      595 | character - a character string (synonym for "line") 596 |

      597 | character-array - a one-dimensional array of character strings, 598 | synonym for line-array 599 |
      600 |
    601 |

    602 | 603 |
  • 604 | Type definitions (typedef)allow the xmlreader program to 605 | define the derived types that you want to use in your reader. 606 |

    607 | The typedef tag may only contain component tags. They 608 | are synonym to variable tags with the same restrictions. 609 | 610 |
611 | 612 |

613 | Future versions may also include options for: 614 |

    615 |
  • 616 | Adding code to handle certain data in a particular way 617 |

    618 |
  • 619 | Version checking (so that an input file is explicitly identified 620 | as being of a particular version of the software) 621 |
622 | 623 |

EXAMPLES

624 |

625 | The directory "examples" contains some example programs. 626 |

    627 |
  • 628 | The tst_grid program demonstrates how to create a reader 629 | for an array of "grids", each consisting of two integers. 630 |

    631 |
  • 632 | The tst_menu program uses a more elaborate structure, 633 | a menubar with menus and each menu having an array of items. 634 | Items in a menu can have a submenu. This leads to an XML file with 635 | multiple hierarchical layers. 636 |

    637 |
  • 638 | The tst_process program uses the xml_process routine to 639 | read in an XML file (a "docbook" file) and turn it into an HTML file for 640 | viewing. 641 |
642 | 643 | 644 |

LIMITATIONS

645 |

646 | Basic limitations: 647 |

    648 |
  • 649 | The lines in the XML-file should not exceed 1000 characters. For tags 650 | that span more than one line, the limit holds for all the lines together 651 | (without leading or trailing blanks). 652 | 653 |

    654 |
  • 655 | There is no support for DTDs or namespaces, XSLT, XPath and 656 | other more advanced features around XML. 657 | 658 |

    659 |
  • 660 | There is currently no support for the object-oriented approach. It is up 661 | to the application to store the information that is needed, while the 662 | parsing is going on. 663 | 664 |

    665 |
  • 666 | No support (yet) for a single quote as delimiter 667 | 668 |

    669 |
  • 670 | No support (yet) for conversion of escape sequences (&gt. for instance) 671 | 672 |

    673 |
  • 674 | The parser may not handle malformed XML-files properly 675 | 676 |

    677 |
  • 678 | The parser does not (yet) handle different line-endings properly (that 679 | is: reading XML-files that were written under MS Windows in a UNIX or 680 | Linux environment) 681 | 682 |
683 | 684 |

RELEASE NOTES

685 |

686 | This document belongs to version 1.00 of the module. 687 |

688 | History: 689 |

690 | version 0.1: Proof of concept, august 2003 691 |

692 | A very preliminary version meant to show that it is indeed possible to 693 | read and write XML files using Fortran only. It was published on the 694 | comp.lang.fortran newsgroup and generated enough interest to encourage 695 | further development. 696 |

697 | version 0.2: First public release, august 2003 698 |

699 | After some additional testing with practical XML-files, a number of bugs 700 | were found and solved, several enhancements were made: 701 |

    702 |
  • 703 | Handling attributes (especially when tags span more than one line and 704 | correctly handling the case that too many attributes are present). 705 |

    706 |
  • 707 | Options for parsing and error handling added, as well as functions to 708 | check the status. 709 |

    710 |
  • 711 | Revision of the API, for more uniform names (prefix: xml_) 712 |

    713 |
  • 714 | Setting up the documentation (this document in particular) 715 |
716 |

717 | version 0.3: Improvements, september 2003 718 |

    719 |
  • 720 | Added the function xml_error() 721 |

    722 |
  • 723 | Implemented the report options 724 |

    725 |
  • 726 | Corrected a bug in xml_close (causing an infinite loop in the 727 | test program). 728 |

    729 |
  • 730 | Revised the test program to run through a number of test 731 | files. 732 |
733 |

734 | version 0.4: Corrected xml_put(), october 2003 735 |

    736 |
  • 737 | Adjusted the interface and implementation of the subroutine xml_put() 738 | It will now produce correct and reasonably looking XML files. 739 |

    740 |
  • 741 | Added a test program, tstwrite.f90, for this. 742 |
743 | 744 |

745 | version 0.9: Added new approach, october 2005 746 |

    747 |
  • 748 | Changes to the interface and implementation of the subroutine xml_put(), 749 | from a patch by cinonet. 750 |

    751 |
  • 752 | Added a program, xmlreader, to generate complete reading routines for 753 | particular XML files (cf. GENERATING A READING ROUTINE 754 |
755 | 756 |

757 | version 0.94: Gradually expanding the capabilities, june 2006 758 |

    759 |
  • 760 | Added a routine xml_process that enables you to use an 761 | event-based approach like in the famous Expat library. 762 |

    763 |
  • 764 | Added the option strict and the tag placeholder. 765 |

    766 |
  • 767 | Corrected a number of bugs associated with the xmlreader program 768 |
769 | 770 |

771 | version 0.97: Added the following capabilities to the 772 | xmlreader program since 0.94, june 2007 773 |

    774 |
  • 775 | Support for the shape option 776 |

    777 |
  • 778 | Defaults for both components of a derived type and for 779 | independent variables. 780 |

    781 |
  • 782 | The generated reading routine takes care of elements that have 783 | attributes and character data now. The character data is treated as if 784 | it were an attribute with the name "value" 785 |

    786 |
  • 787 | Several bugs corrected in the xmlreader program 788 |
789 | 790 |

791 | version 1.00: Added the following capabilities to the 792 | xmlreader program since 0.97, april 2008 793 |

    794 |
  • 795 | Write a writing routine to write the data to a XML file 796 |
797 | The project now also contains a first version of a program to convert an 798 | XSD file to a file accepted by the xmlreader program. This is called 799 | "xsdconvert". 800 | 801 |

TO DO

802 |

803 | The following items remain on the "to do" list: 804 |

    805 |
  • 806 | Adding checks for truncation of strings (attribute names/values too 807 | long, data lines too long; now only the number is checked). 808 |

    809 |
  • 810 | Documenting details about structures and parameters that may be of 811 | interest. 812 |
813 | 814 | 815 | 816 |

KEYWORDS

817 |

818 | Fortran, XML, parsing 819 | 820 | 821 | -------------------------------------------------------------------------------- /examples/array_of_words/Makefile: -------------------------------------------------------------------------------- 1 | program = tst_array_of_words 2 | template = array_of_words 3 | objects = $(program).o $(template).o ../../src/xmlparse.a 4 | 5 | #=============================================================================== 6 | # Compiler Options 7 | #=============================================================================== 8 | 9 | F90 = gfortran 10 | F90FLAGS = -g -fbacktrace -I../../src 11 | LDFLAGS = 12 | 13 | #=============================================================================== 14 | # Targets 15 | #=============================================================================== 16 | 17 | all: $(program) 18 | $(program): $(objects) 19 | $(F90) $(objects) -o $@ $(LDFLAGS) 20 | clean: 21 | @rm -f *.o *.mod *.out $(template).f90 $(program) 22 | neat: 23 | @rm -f *.o *.mod *.out $(template).f90 24 | 25 | #=============================================================================== 26 | # Rules 27 | #=============================================================================== 28 | 29 | .SUFFIXES: .f90 .o 30 | .PHONY: all clean neat 31 | 32 | #=============================================================================== 33 | # Dependencies 34 | #=============================================================================== 35 | 36 | $(program).o: $(template).o 37 | $(F90) -c $(F90FLAGS) $(program).f90 38 | 39 | $(template).o: $(template).xml 40 | ../../src/xmlreader $(template) 41 | $(F90) -c $(F90FLAGS) $(template).f90 42 | -------------------------------------------------------------------------------- /examples/array_of_words/array_of_words.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | -------------------------------------------------------------------------------- /examples/array_of_words/example_words.xml: -------------------------------------------------------------------------------- 1 | 2 | one 3 | two 4 | three 5 | four 6 | 1.0 7 | 2.0 8 | 3.0 9 | 4.0 10 | 5.0 11 | 12 | -------------------------------------------------------------------------------- /examples/array_of_words/tst_array_of_words.f90: -------------------------------------------------------------------------------- 1 | ! Test program for generated code: 2 | ! Test the option of one word or real per element 3 | ! 4 | program tst_array_of_words 5 | use xml_data_array_of_words 6 | implicit none 7 | 8 | call read_xml_file_array_of_words( 'example_words.xml' ) 9 | 10 | write(*,*) 'Words:' 11 | write(*,'(a)') word 12 | write(*,*) 'Reals:' 13 | write(*,'(f10.4)') real_value 14 | 15 | call write_xml_file_array_of_words( 'output_words.xml' ) 16 | end program 17 | -------------------------------------------------------------------------------- /examples/grid/Makefile: -------------------------------------------------------------------------------- 1 | program = tst_grid 2 | template = grid 3 | objects = $(program).o $(template).o ../../src/xmlparse.a 4 | 5 | #=============================================================================== 6 | # Compiler Options 7 | #=============================================================================== 8 | 9 | F90 = gfortran 10 | F90FLAGS = -g -fbacktrace -I../../src 11 | LDFLAGS = 12 | 13 | #=============================================================================== 14 | # Targets 15 | #=============================================================================== 16 | 17 | all: $(program) 18 | $(program): $(objects) 19 | $(F90) $(objects) -o $@ $(LDFLAGS) 20 | clean: 21 | @rm -f *.o *.mod *.out $(template).f90 $(program) 22 | neat: 23 | @rm -f *.o *.mod *.out $(template).f90 24 | 25 | #=============================================================================== 26 | # Rules 27 | #=============================================================================== 28 | 29 | .SUFFIXES: .f90 .o 30 | .PHONY: all clean neat 31 | 32 | #=============================================================================== 33 | # Dependencies 34 | #=============================================================================== 35 | 36 | $(program).o: $(template).o 37 | $(F90) -c $(F90FLAGS) $(program).f90 38 | 39 | $(template).o: $(template).xml 40 | ../../src/xmlreader $(template) 41 | $(F90) -c $(F90FLAGS) $(template).f90 42 | -------------------------------------------------------------------------------- /examples/grid/grid.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | This is an example of a template for the xmlreader program: 5 | The template defines (a part of) the data structure for the 6 | program that will use the generated reader routines. The 7 | xmlreader program can generate: 8 | - the Fortran code to read the XML file containing the 9 | actual data (this is put in a module) 10 | - an example of an acceptable XML file, so that you can check 11 | that all is as expected 12 | 13 | Use the "comment" tag to insert comments in this template. 14 | 15 | Additional comments: 16 | - Extend with version information 17 | - Options for treating unknown tags 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | The name of a variable can not be the same as that 34 | of a derived type. So, make sure there are two 35 | different names ... 36 | 37 | 38 | 39 | 40 | -------------------------------------------------------------------------------- /examples/grid/grid_example.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Read a couple of integers and a derived type 5 | 6 | 1020 7 | 8 | 9 | 1 10 | 2 11 | 2 12 | 13 | 1122 14 | 1223 15 | 23 16 | 17 | -------------------------------------------------------------------------------- /examples/grid/tst_grid.f90: -------------------------------------------------------------------------------- 1 | ! Test program for generated code 2 | ! 3 | program tst_grid 4 | use xml_data_grid 5 | call read_xml_file_grid( 'grid_example.xml' ) 6 | write(*,*) 'A,B,C:', a, b, c 7 | write(*,*) 'grid:', grid 8 | write(*,*) 'grid_array:', grid_array 9 | call write_xml_file_grid( 'out_grid.xml', 20 ) 10 | end program 11 | -------------------------------------------------------------------------------- /examples/menu/Makefile: -------------------------------------------------------------------------------- 1 | program = tst_menu 2 | template = menu 3 | objects = $(program).o $(template).o ../../src/xmlparse.a 4 | 5 | #=============================================================================== 6 | # Compiler Options 7 | #=============================================================================== 8 | 9 | F90 = gfortran 10 | F90FLAGS = -g -fbacktrace -I../../src 11 | LDFLAGS = 12 | 13 | #=============================================================================== 14 | # Targets 15 | #=============================================================================== 16 | 17 | all: $(program) 18 | $(program): $(objects) 19 | $(F90) $(objects) -o $@ $(LDFLAGS) 20 | clean: 21 | @rm -f *.o *.mod *.out $(template).f90 $(program) 22 | neat: 23 | @rm -f *.o *.mod *.out $(template).f90 24 | 25 | #=============================================================================== 26 | # Rules 27 | #=============================================================================== 28 | 29 | .SUFFIXES: .f90 .o 30 | .PHONY: all clean neat 31 | 32 | #=============================================================================== 33 | # Dependencies 34 | #=============================================================================== 35 | 36 | $(program).o: $(template).o 37 | $(F90) -c $(F90FLAGS) $(program).f90 38 | 39 | $(template).o: $(template).xml 40 | ../../src/xmlreader $(template) 41 | $(F90) -c $(F90FLAGS) $(template).f90 42 | -------------------------------------------------------------------------------- /examples/menu/menu.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | This file defines a fairly elaborate data structure: 5 | A menubar that contains menus. Each menu contains several 6 | items and an item can hold a submenu. Submenu only contain 7 | items. 8 | 9 | 10 | 11 | Hm, optional components of a derived type ... How to treat these? 12 | Simple: default="submenu_t('', '')", as the value will be 13 | written on the right-hand side of the assignment 14 | 15 | Note: 16 | When I added an array of items, I wanted to set the submenu 17 | default to: 18 | default="submenu_t('','',subitem_t('',''))" 19 | The resulting code made two compilers complain in a nasty 20 | way. Apparently you can not nest constructors this way. 21 | (And the subitem is a pointer to an array ... this 22 | will require a more subtle approach!) 23 | 24 | TODO: add a keyword "optional" 25 | 26 | To save the data: 27 | #typedef name="subitem_t"# 28 | #component name="type" type="line" length="20"##/component# 29 | #component name="name" type="line" length="20"##/component# 30 | #/typedef# 31 | In submenu: 32 | #component name="item" type="submenu_t" dimension="1"##/component# 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | Now the variables themselves ... just a single menubar 58 | 59 | 60 | 61 | 62 | 63 | 64 | -------------------------------------------------------------------------------- /examples/menu/menuitems.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | This is an example of a more elaborate XML file: 6 | It defines a menubar - nothing very realistic, mind you, 7 | but it shows that the xmlreader program can handle fairly 8 | complex structures 9 | 10 | General 11 | 1 2 3 12 | 4 5 6 13 |

14 | File 15 | 16 | 17 | separator 18 | --- 19 | 20 | 21 | This item stops the program 22 | 23 | 24 | 25 | Edit 26 | 27 | item 28 | Undo 29 | 30 | 31 | item 32 | Redo 33 | 34 | 35 | submenu 36 | Search 37 | 38 | Find ... 39 | 40 | 41 | 42 | 43 | 44 | -------------------------------------------------------------------------------- /examples/menu/tst_menu.f90: -------------------------------------------------------------------------------- 1 | ! Test program for generated code: 2 | ! A menubar with menus and submenus 3 | ! 4 | program tst_menu 5 | use xml_data_menu 6 | implicit none 7 | integer :: i, j, k 8 | 9 | call read_xml_file_menu( 'menuitems.xml' ) 10 | write(*,*) 'Just a value: ', just_a_value 11 | write(*,*) 'Menubar: ', menubar%name 12 | write(*,*) ' Number:', menubar%number 13 | write(*,*) ' (Shape:', shape(menubar%number), ')' 14 | write(*,*) ' Menus: ' 15 | do i = 1,size(menubar%menu) 16 | write(*,*) ' Menu: ', menubar%menu(i)%name 17 | write(*,*) ' Items: ' 18 | do j = 1,size(menubar%menu(i)%item) 19 | write(*,*) ' Item: ', menubar%menu(i)%item(j)%name,' - ', & 20 | menubar%menu(i)%item(j)%type 21 | write(*,*) ' Data:', menubar%menu(i)%item(j)%data 22 | if ( menubar%menu(i)%item(j)%type == 'submenu' ) then 23 | write(*,*) ' Submenu: ' 24 | ! 25 | ! Should be an array ... but there is a problem with defaults 26 | ! 27 | write(*,*) ' Item: ', menubar%menu(i)%item(j)%submenu%item 28 | 29 | ! do k = 1,size(item) 30 | ! write(*,*) ' Item: ', menubar%menu(i)%item(j)%submenu%item(k)%name & 31 | ! '- ', menubar%menu(i)%item(j)%submenu%item(k)%(name,type) 32 | ! enddo 33 | endif 34 | enddo 35 | enddo 36 | end program 37 | -------------------------------------------------------------------------------- /examples/process/Makefile: -------------------------------------------------------------------------------- 1 | program = tst_process 2 | objects = $(program).o ../../src/xmlparse.a 3 | 4 | #=============================================================================== 5 | # Compiler Options 6 | #=============================================================================== 7 | 8 | F90 = gfortran 9 | F90FLAGS = -g -fbacktrace -I../../src 10 | LDFLAGS = 11 | 12 | #=============================================================================== 13 | # Targets 14 | #=============================================================================== 15 | 16 | all: $(program) 17 | $(program): $(objects) 18 | $(F90) $(objects) -o $@ $(LDFLAGS) 19 | clean: 20 | @rm -f *.o *.mod *.html $(program) 21 | neat: 22 | @rm -f *.o *.mod *.html 23 | 24 | #=============================================================================== 25 | # Rules 26 | #=============================================================================== 27 | 28 | .SUFFIXES: .f90 .o 29 | .PHONY: all clean neat 30 | 31 | %.o: %.f90 32 | $(F90) -c $(F90FLAGS) $< 33 | -------------------------------------------------------------------------------- /examples/process/simple.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | Simple Use of PLplot 4 | 5 | 6 | Plotting a Simple Graph 7 | 8 | 9 | We shall first consider plotting simple graphs showing the dependence 10 | of one variable upon another. Such a graph may be composed of 11 | several elements: 12 | 13 | 14 | 15 | 16 | A box which defines the ranges of the variables, perhaps with 17 | axes and numeric labels along its edges. 18 | 19 | 20 | 21 | 22 | A set of points or lines within the box showing the functional 23 | dependence. 24 | 25 | 26 | 27 | 28 | A set of labels for the variables and a title for the graph. 29 | 30 | 31 | 32 | 33 | In order to draw such a graph, it is necessary to call at least four 34 | of the PLplot functions: 35 | 36 | 37 | 38 | 39 | 40 | &plinit;, to initialize PLplot. 41 | 42 | 43 | 44 | 45 | &plenv;, to define the range and scale of the 46 | graph, and draw labels, axes, etc. 47 | 48 | 49 | 50 | 51 | One or more calls to &plline; or &plpoin; to draw lines or points 52 | as needed. Other more complex routines include &plbin; and 53 | &plhist; to draw histograms, &plerrx; and &plerry; to draw 54 | error-bars. 55 | 56 | 57 | 58 | 59 | &plend;, to close the plot. 60 | 61 | 62 | 63 | 64 | 65 | More than one graph can be drawn on a single set of axes by making 66 | repeated calls to the routines listed in item 3 above. PLplot only 67 | needs to be initialized once unless plotting to multiple output 68 | devices. 69 | 70 | 71 | 72 | 73 | -------------------------------------------------------------------------------- /examples/process/tst_process.f90: -------------------------------------------------------------------------------- 1 | ! Test program for xml_process 2 | ! 3 | ! The program reads a small file in the docbook format 4 | ! (extracted from the PLplot project - http://plplot.sf.net) 5 | ! and writes it out as an HTML file 6 | ! 7 | ! Note: 8 | ! In this example we do not check the structure of the 9 | ! XML file. 10 | ! Of course the conversion is very, very simple. 11 | ! 12 | module convert_html 13 | character(len=20) :: section_type 14 | character(len=20), dimension(10) :: end_tag 15 | logical :: title 16 | integer :: level = 0 17 | contains 18 | 19 | subroutine startfunc( tag, attribs, error ) 20 | character(len=*) :: tag 21 | character(len=*), dimension(:,:) :: attribs 22 | logical :: error 23 | 24 | level = level + 1 25 | select case( tag ) 26 | case( 'chapter' ) 27 | section_type = '

' 28 | case( 'sect1' ) 29 | section_type = '

' 30 | case( 'title' ) 31 | title = .true. 32 | end_tag(level) = section_type(1:1) // '/' // section_type(2:) 33 | case( 'para') 34 | write( 20, * ) '

' 35 | end_tag(level) = '

' 36 | case( 'itemizedlist' ) 37 | write( 20, * ) '
    ' 38 | end_tag(level) = '
' 39 | case( 'orderedlist' ) 40 | write( 20, * ) '
    ' 41 | end_tag(level) = '
' 42 | case( 'listitem' ) 43 | write( 20, * ) '
  • ' 44 | end_tag(level) = '
    • ' 45 | end select 46 | end subroutine 47 | 48 | subroutine datafunc( tag, data, error ) 49 | character(len=*) :: tag 50 | character(len=*), dimension(:) :: data 51 | logical :: error 52 | 53 | integer :: i 54 | 55 | ! Nothing much to do ... 56 | 57 | if ( .not. title ) then 58 | if ( any( data .ne. ' ' ) ) then 59 | write(20,'(a)') ( data(i), i=1,size(data) ) 60 | endif 61 | else 62 | write(20,'(a)') section_type, ( data(i), i=1,size(data) ), end_tag(level) 63 | level = level - 1 64 | endif 65 | 66 | end subroutine 67 | 68 | subroutine endfunc( tag, error ) 69 | character(len=*) :: tag 70 | logical :: error 71 | 72 | integer :: i 73 | 74 | ! Nothing much to do ... 75 | if ( title ) then 76 | title = .false. 77 | else 78 | write(20,*) trim(end_tag(level)) 79 | level = level - 1 80 | endif 81 | 82 | end subroutine 83 | 84 | end module 85 | 86 | program tst_process 87 | use xmlparse 88 | use convert_html 89 | 90 | character(len=40), dimension(2,10) :: attribs 91 | character(len=80), dimension(100) :: data 92 | logical :: error 93 | 94 | open( 20, file = 'simple.html' ) 95 | write( 20 , * ) 'Example of converting XML to HTML' 96 | write( 20 , * ) '' 97 | 98 | call xml_process( 'simple.xml', attribs, data, startfunc, datafunc, endfunc, 0, error ) 99 | 100 | write( 20 , * ) '' 101 | 102 | end program 103 | -------------------------------------------------------------------------------- /examples/readint/Makefile: -------------------------------------------------------------------------------- 1 | program = tst_readint 2 | template = readint 3 | objects = $(program).o $(template).o ../../src/xmlparse.a 4 | 5 | #=============================================================================== 6 | # Compiler Options 7 | #=============================================================================== 8 | 9 | F90 = gfortran 10 | F90FLAGS = -g -fbacktrace -I../../src 11 | LDFLAGS = 12 | 13 | #=============================================================================== 14 | # Targets 15 | #=============================================================================== 16 | 17 | all: $(program) 18 | $(program): $(objects) 19 | $(F90) $(objects) -o $@ $(LDFLAGS) 20 | clean: 21 | @rm -f *.o *.mod *.out $(template).f90 $(program) 22 | neat: 23 | @rm -f *.o *.mod *.out $(template).f90 24 | 25 | #=============================================================================== 26 | # Rules 27 | #=============================================================================== 28 | 29 | .SUFFIXES: .f90 .o 30 | .PHONY: all clean neat 31 | 32 | #=============================================================================== 33 | # Dependencies 34 | #=============================================================================== 35 | 36 | $(program).o: $(template).o 37 | $(F90) -c $(F90FLAGS) $(program).f90 38 | 39 | $(template).o: $(template).xml 40 | ../../src/xmlreader $(template) 41 | $(F90) -c $(F90FLAGS) $(template).f90 42 | -------------------------------------------------------------------------------- /examples/readint/readint.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Read a couple of integers 6 | 7 | 8 | 9 | 10 | 11 | 12 | -------------------------------------------------------------------------------- /examples/readint/readint_example.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Read a couple of integers 5 | 6 | 10 7 | 23 8 | 9 | 10 | 1 2 3 4 5 6 11 | 12 | 13 | -------------------------------------------------------------------------------- /examples/readint/tst_readint.f90: -------------------------------------------------------------------------------- 1 | ! Test program for generated code 2 | ! 3 | program tst_readint 4 | use xml_data_readint 5 | call read_xml_file_readint( 'readint_example.xml' ) 6 | write(*,*) 'x,y,z:', x, y, z 7 | write(*,*) 'w:', w 8 | end program 9 | -------------------------------------------------------------------------------- /examples/writexml/Makefile: -------------------------------------------------------------------------------- 1 | program = writexml 2 | objects = $(program).o ../../src/xmlparse.a 3 | 4 | #=============================================================================== 5 | # Compiler Options 6 | #=============================================================================== 7 | 8 | F90 = gfortran 9 | F90FLAGS = -g -fbacktrace -I../../src 10 | LDFLAGS = 11 | 12 | #=============================================================================== 13 | # Targets 14 | #=============================================================================== 15 | 16 | all: $(program) 17 | $(program): $(objects) 18 | $(F90) $(objects) -o $@ $(LDFLAGS) 19 | clean: 20 | @rm -f *.o *.mod $(program) 21 | neat: 22 | @rm -f *.o *.mod 23 | 24 | #=============================================================================== 25 | # Rules 26 | #=============================================================================== 27 | 28 | .SUFFIXES: .f90 .o 29 | .PHONY: all clean neat 30 | 31 | %.o: %.f90 32 | $(F90) -c $(F90FLAGS) $< 33 | -------------------------------------------------------------------------------- /examples/writexml/writexml.f90: -------------------------------------------------------------------------------- 1 | ! writexml.f90 -- 2 | ! Example of writing a simple XML file 3 | ! 4 | ! Note: 5 | ! This example uses the fairly low-level routine xml_put. 6 | ! In the near future the xmlreader program should be able 7 | ! to produce a writer routine automatically in much the 8 | ! same way as it can produce a reader routine from the 9 | ! definition. 10 | ! 11 | program writexml 12 | use xmlparse 13 | 14 | implicit none 15 | type(xml_parse) :: info 16 | character(len=20) :: tag 17 | character(len=20), dimension(2,10) :: attribs 18 | character(len=50), dimension(10) :: data 19 | integer :: no_attribs 20 | integer :: no_data 21 | character(len=20) :: type 22 | 23 | ! 24 | ! Open the file for writing (.false.) 25 | ! 26 | call xml_open( info, "example.xml", .false. ) 27 | 28 | ! 29 | ! Write the root element (only the open tag) 30 | ! 31 | no_attribs = 0 32 | no_data = 0 33 | call xml_put( info, "examples", attribs, no_attribs, data, no_data, "open" ) 34 | 35 | ! 36 | ! Write a few elements: 37 | ! Each element is given with all information that is required, so we 38 | ! can write the opening and closing tags at once. 39 | ! 40 | no_attribs = 1 41 | attribs(1,1) = "name" 42 | attribs(2,1) = "tst_menu.f90" 43 | no_data = 2 44 | data(1) = "Define a menubar with nested menus" 45 | data(2) = "Shows how to deal with arrays" 46 | call xml_put( info, "example", attribs, no_attribs, data, no_data, "elem") 47 | ! 48 | no_attribs = 3 49 | attribs(1,1) = "name" 50 | attribs(2,1) = "tst_grid.f90" 51 | attribs(1,2) = "definition" 52 | attribs(2,2) = "grid.xml" 53 | attribs(1,3) = "input" 54 | attribs(2,3) = "grid_example.xml" 55 | no_data = 2 56 | data(1) = "Conglomerate of options, nothing really structured" 57 | data(2) = "- despite the name" 58 | call xml_put( info, "example", attribs, no_attribs, data, no_data, "elem") 59 | ! 60 | ! Close the root tag 61 | ! 62 | no_attribs = 0 63 | no_data = 0 64 | call xml_put( info, "examples", attribs, no_attribs, data, no_data, "close") 65 | ! 66 | ! Close the file 67 | ! 68 | call xml_close( info ) 69 | 70 | end program 71 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | # Naive makefile for the simple test program "tstparse" 2 | # 3 | # Coarse test for the XML-Fortran module 4 | # 5 | 6 | #=============================================================================== 7 | # User Options 8 | #=============================================================================== 9 | 10 | COMPILER = intel 11 | DEBUG = no 12 | 13 | #=============================================================================== 14 | # Compiler Options 15 | #=============================================================================== 16 | 17 | # Intel Fortran compiler options 18 | 19 | ifeq ($(COMPILER),intel) 20 | F90 = ifort 21 | F90FLAGS += -fpp -warn 22 | endif 23 | 24 | # GNU Fortran compiler options 25 | 26 | ifeq ($(COMPILER),gfortran) 27 | F90 = gfortran 28 | F90FLAGS += -cpp -Wall 29 | endif 30 | 31 | # Set compiler flags for debugging 32 | 33 | ifeq ($(DEBUG),yes) 34 | F90FLAGS += -g 35 | LDFLAGS += -g 36 | ifeq ($(COMPILER),intel) 37 | F90FLAGS += -traceback -ftrapuv -fp-stack-check -check all 38 | endif 39 | ifeq ($(COMPILER),gfortran) 40 | F90FLAGS += -pedantic -std=f2008 -fbacktrace -fbounds-check \ 41 | -ffpe-trap=invalid,zero,overflow,underflow 42 | endif 43 | endif 44 | 45 | #=============================================================================== 46 | # Targets 47 | #=============================================================================== 48 | 49 | all: xmlreader 50 | test: tstparse 51 | install: 52 | mkdir -p ../lib 53 | cp libxmlparse.a ../lib 54 | cp xmlparse.mod read_xml_primitives.mod write_xml_primitives.mod ../lib 55 | clean: 56 | @rm -f *.o *.mod *.a xmlreader tstparse 57 | neat: 58 | @rm -f *.o *.mod *.a 59 | 60 | #=============================================================================== 61 | # Rules 62 | #=============================================================================== 63 | 64 | .SUFFIXES: .f90 .o 65 | .PHONY: all clean neat 66 | 67 | %.o: %.f90 68 | $(F90) -c $(F90FLAGS) $< 69 | 70 | #=============================================================================== 71 | # Dependencies 72 | #=============================================================================== 73 | 74 | libxmlparse.a: xmlparse.o read_xml_primitives.o write_xml_primitives.o 75 | ar r libxmlparse.a xmlparse.o read_xml_primitives.o write_xml_primitives.o 76 | 77 | tstparse: tstparse.o libxmlparse.a 78 | $(F90) tstparse.o libxmlparse.a -o $@ 79 | 80 | xmlreader: xmlreader.o libxmlparse.a 81 | $(F90) xmlreader.o libxmlparse.a -o $@ 82 | 83 | tstparse.o: xmlparse.o 84 | xmlreader.o: xmlparse.o 85 | -------------------------------------------------------------------------------- /src/read_from_buffer.inc: -------------------------------------------------------------------------------- 1 | ! Part of XML-Fortran library: 2 | ! 3 | ! $Id: read_from_buffer.inc,v 1.2 2006/03/26 19:05:48 arjenmarkus Exp $ 4 | ! 5 | character(len=*), intent(in) :: buffer 6 | integer, intent(inout) :: ierror 7 | 8 | integer :: n 9 | integer :: i 10 | integer :: step 11 | integer :: ierr 12 | ! 13 | ! First allocate an array that is surely large enough 14 | ! Note: 15 | ! This is not completely failsafe: with list-directed 16 | ! input you can also use repeat counts (10000*1.0 for 17 | ! instance). 18 | ! 19 | allocate( work(len(buffer)/2+1) ) 20 | 21 | ! 22 | ! NOTE: 23 | ! This is not portable!! 24 | ! 25 | ! read( buffer, *, iostat = ierror ) (work(n), n=1,size(work)) 26 | ! 27 | ! So, use a different strategy: a binary search 28 | ! First: establish that we have at least one item to read 29 | ! Second: do the binary search 30 | ! 31 | ! read( buffer, *, iostat = ierr ) work(1) 32 | ! if ( ierr /= 0 ) then 33 | ! n = 0 34 | ! else 35 | n = 1 36 | do while ( n <= size(work) ) 37 | n = 2 * n 38 | enddo 39 | n = n / 2 40 | step = n / 2 41 | ! step = n / 2 42 | 43 | do while ( step > 0 ) 44 | read( buffer, *, iostat = ierr ) (work(i), i = 1,n) 45 | if ( ierr /= 0 ) then 46 | ierror = ierr ! Store the error code for later use 47 | n = n - step 48 | else 49 | n = n + step 50 | endif 51 | step = step / 2 52 | enddo 53 | ! endif 54 | 55 | ! 56 | ! Then allocate an array of the actual size needed 57 | ! and copy the data 58 | ! 59 | ! 60 | if ( associated( var ) ) then 61 | deallocate( var ) 62 | endif 63 | ! 64 | ! One complication: we may have one too many 65 | ! (consequence of the binary search) 66 | ! 67 | read( buffer, *, iostat = ierr ) (work(i), i = 1,n) 68 | if ( ierr < 0 ) then 69 | n = n - 1 70 | endif 71 | 72 | allocate( var(n) ) 73 | var(1:n) = work(1:n) 74 | deallocate( work ) 75 | 76 | if ( ierror .lt. 0 ) then 77 | ierror = 0 78 | endif 79 | 80 | -------------------------------------------------------------------------------- /src/read_xml_array.inc: -------------------------------------------------------------------------------- 1 | ! Part of XML-Fortran library: 2 | ! 3 | ! $Id: read_xml_array.inc,v 1.3 2007/02/26 20:33:38 arjenmarkus Exp $ 4 | ! 5 | type(XML_PARSE), intent(inout) :: info 6 | character(len=*), intent(in) :: tag 7 | logical, intent(inout) :: endtag 8 | character(len=*), dimension(:,:), intent(in) :: attribs 9 | integer, intent(in) :: noattribs 10 | character(len=*), dimension(:), intent(in) :: data 11 | integer, intent(in) :: nodata 12 | logical, intent(inout) :: has_var 13 | 14 | character(len=len(attribs(1,1))) :: buffer 15 | integer :: idx 16 | integer :: ierr 17 | 18 | ! 19 | ! The big trick: 20 | ! A string long enough to hold all data strings 21 | ! 22 | character(len=nodata*(len(data(1))+1)) :: bufferd 23 | integer :: start 24 | 25 | ! 26 | ! The value can be stored in an attribute values="..." or in 27 | ! the data 28 | ! 29 | has_var = .false. 30 | idx = xml_find_attrib( attribs, noattribs, 'values', buffer ) 31 | if ( idx .gt. 0 ) then 32 | call read_from_buffer( buffer, var, ierr ) 33 | if ( buffer .ne. ' ' ) then 34 | has_var = .true. 35 | endif 36 | else 37 | bufferd = ' ' 38 | start = 1 39 | do idx = 1,nodata 40 | if ( data(idx) .ne. ' ' ) then 41 | bufferd(start:) = data(idx) 42 | start = start + len(data(idx)) + 1 43 | endif 44 | enddo 45 | call read_from_buffer( bufferd, var, ierr ) 46 | if ( bufferd .ne. ' ' ) then 47 | has_var = .true. 48 | endif 49 | endif 50 | 51 | if ( ierr .ne. 0 ) then 52 | write(*,*) 'Error reading variable - tag = ', trim(tag) 53 | has_var = .false. 54 | endif 55 | -------------------------------------------------------------------------------- /src/read_xml_primitives.f90: -------------------------------------------------------------------------------- 1 | ! read_xml_prims.f90 - Read routines for primitive data 2 | ! 3 | ! $Id: read_xml_prims.f90,v 1.7 2007/12/07 10:38:41 arjenmarkus Exp $ 4 | ! 5 | ! Arjen Markus 6 | ! 7 | ! General information: 8 | ! This module is part of the XML-Fortran library. Its 9 | ! purpose is to help read individual items from an XML 10 | ! file into the variables that have been connected to 11 | ! the various tags. It is used by the code generated 12 | ! by the make_xml_reader program. 13 | ! 14 | ! Because the routines differ mostly by the type of the 15 | ! output variable, the body is included, to prevent 16 | ! too much repeated blocks of code with all the maintenance 17 | ! issues that causes. 18 | ! 19 | module read_xml_primitives 20 | use xmlparse 21 | implicit none 22 | 23 | private :: read_from_buffer 24 | private :: read_from_buffer_integers 25 | private :: read_from_buffer_reals 26 | private :: read_from_buffer_doubles 27 | private :: read_from_buffer_logicals 28 | private :: read_from_buffer_words 29 | 30 | interface read_from_buffer 31 | module procedure read_from_buffer_integers 32 | module procedure read_from_buffer_reals 33 | module procedure read_from_buffer_doubles 34 | module procedure read_from_buffer_logicals 35 | module procedure read_from_buffer_words 36 | end interface 37 | 38 | contains 39 | 40 | ! skip_until_endtag -- 41 | ! Routine to read the XML file until the end tag is encountered 42 | ! 43 | ! Arguments: 44 | ! info The XML file data structure 45 | ! tag The tag in question 46 | ! attribs Array of attributes and their values 47 | ! data Array of strings, representing the data 48 | ! error Has an error occurred? 49 | ! 50 | subroutine skip_until_endtag( info, tag, attribs, data, error ) 51 | type(XML_PARSE), intent(inout) :: info 52 | character(len=*), intent(in) :: tag 53 | character(len=*), dimension(:,:), intent(inout) :: attribs 54 | character(len=*), dimension(:), intent(inout) :: data 55 | logical, intent(out) :: error 56 | 57 | integer :: noattribs 58 | integer :: nodata 59 | integer :: ierr 60 | logical :: endtag 61 | character(len=len(tag)) :: newtag 62 | 63 | error = .true. 64 | do 65 | call xml_get( info, newtag, endtag, attribs, noattribs, & 66 | data, nodata ) 67 | if ( xml_error(info) ) then 68 | error = .true. 69 | exit 70 | endif 71 | if ( endtag .and. newtag == tag ) then 72 | exit 73 | endif 74 | enddo 75 | end subroutine skip_until_endtag 76 | 77 | ! read_xml_integer -- 78 | ! Routine to read a single integer from the parsed data 79 | ! 80 | ! Arguments: 81 | ! info XML parser structure 82 | ! tag The tag in question (error message only) 83 | ! endtag End tag found? (Dummy argument, actually) 84 | ! attribs Array of attributes and their values 85 | ! noattribs Number of attributes found 86 | ! data Array of strings, representing the data 87 | ! nodata Number of data strings 88 | ! var Variable to be filled 89 | ! has_var Has the variable been set? 90 | ! 91 | subroutine read_xml_integer( info, tag, endtag, attribs, noattribs, data, nodata, & 92 | var, has_var ) 93 | integer, intent(inout) :: var 94 | 95 | include 'read_xml_scalar.inc' 96 | 97 | end subroutine read_xml_integer 98 | 99 | ! read_xml_line -- 100 | ! Routine to read a single line of text from the parsed data 101 | ! 102 | ! Arguments: 103 | ! info XML parser structure 104 | ! tag The tag in question (error message only) 105 | ! endtag End tag found? (Dummy argument, actually) 106 | ! attribs Array of attributes and their values 107 | ! noattribs Number of attributes found 108 | ! data Array of strings, representing the data 109 | ! nodata Number of data strings 110 | ! var Variable to be filled 111 | ! has_var Has the variable been set? 112 | ! 113 | subroutine read_xml_line( info, tag, endtag, attribs, noattribs, data, nodata, & 114 | var, has_var ) 115 | type(XML_PARSE), intent(inout) :: info 116 | character(len=*), intent(in) :: tag 117 | logical, intent(inout) :: endtag 118 | character(len=*), dimension(:,:), intent(in) :: attribs 119 | integer, intent(in) :: noattribs 120 | character(len=*), dimension(:), intent(in) :: data 121 | integer, intent(in) :: nodata 122 | character(len=*), intent(inout) :: var 123 | logical, intent(inout) :: has_var 124 | 125 | character(len=len(attribs(1,1))) :: buffer 126 | integer :: idx 127 | integer :: ierr 128 | 129 | ! 130 | ! The value can be stored in an attribute value="..." or in 131 | ! the data 132 | ! 133 | has_var = .false. 134 | idx = xml_find_attrib( attribs, noattribs, 'value', buffer ) 135 | if ( idx > 0 ) then 136 | var = buffer 137 | has_var = .true. 138 | else 139 | do idx = 1,nodata 140 | if ( data(idx) /= ' ' ) then 141 | var = data(idx) 142 | has_var = .true. 143 | exit 144 | endif 145 | enddo 146 | endif 147 | end subroutine read_xml_line 148 | 149 | ! read_xml_real, ... -- 150 | ! See read_xml_integer for an explanation 151 | ! 152 | subroutine read_xml_real( info, tag, endtag, attribs, noattribs, data, nodata, & 153 | var, has_var ) 154 | real, intent(inout) :: var 155 | 156 | include 'read_xml_scalar.inc' 157 | 158 | end subroutine read_xml_real 159 | 160 | subroutine read_xml_double( info, tag, endtag, attribs, noattribs, data, nodata, & 161 | var, has_var ) 162 | real(kind=kind(1.0d00)), intent(inout) :: var 163 | 164 | include 'read_xml_scalar.inc' 165 | 166 | end subroutine read_xml_double 167 | 168 | subroutine read_xml_logical( info, tag, endtag, attribs, noattribs, data, nodata, & 169 | var, has_var ) 170 | logical, intent(inout) :: var 171 | 172 | include 'read_xml_scalar.inc' 173 | 174 | end subroutine read_xml_logical 175 | 176 | subroutine read_xml_word( info, tag, endtag, attribs, noattribs, data, nodata, & 177 | var, has_var ) 178 | character(len=*), intent(inout) :: var 179 | 180 | include 'read_xml_word.inc' 181 | 182 | end subroutine read_xml_word 183 | 184 | ! read_xml_integer_array -- 185 | ! Routine to read a one-dimensional integer array from the parsed 186 | ! ata 187 | ! 188 | ! Arguments: 189 | ! info XML parser structure 190 | ! tag The tag in question (error message only) 191 | ! endtag End tag found? (Dummy argument, actually) 192 | ! attribs Array of attributes and their values 193 | ! noattribs Number of attributes found 194 | ! data Array of strings, representing the data 195 | ! nodata Number of data strings 196 | ! var Variable to be filled 197 | ! has_var Has the variable been set? 198 | ! 199 | subroutine read_xml_integer_array( info, tag, endtag, attribs, noattribs, data, & 200 | nodata, var, has_var ) 201 | integer, dimension(:), pointer :: var 202 | 203 | include 'read_xml_array.inc' 204 | 205 | end subroutine read_xml_integer_array 206 | 207 | ! read_xml_line_array -- 208 | ! Routine to read an array of lines of text from the parsed data 209 | ! 210 | ! Arguments: 211 | ! info XML parser structure 212 | ! tag The tag in question (error message only) 213 | ! attribs Array of attributes and their values 214 | ! noattribs Number of attributes found 215 | ! data Array of strings, representing the data 216 | ! nodata Number of data strings 217 | ! var Variable to be filled 218 | ! has_var Has the variable been set? 219 | ! 220 | subroutine read_xml_line_array( info, tag, endtag, attribs, noattribs, data, & 221 | nodata, var, has_var ) 222 | type(XML_PARSE), intent(inout) :: info 223 | character(len=*), intent(in) :: tag 224 | logical, intent(inout) :: endtag 225 | character(len=*), dimension(:,:), intent(in) :: attribs 226 | integer, intent(in) :: noattribs 227 | character(len=*), dimension(:), intent(in) :: data 228 | integer, intent(in) :: nodata 229 | character(len=*), dimension(:), pointer :: var 230 | logical, intent(inout) :: has_var 231 | 232 | character(len=len(attribs(1,1))) :: buffer 233 | integer :: idx 234 | integer :: idxv 235 | integer :: ierr 236 | logical :: started 237 | 238 | ! 239 | ! The value can be stored in an attribute values="..." or in 240 | ! the data 241 | ! 242 | has_var = .false. 243 | idx = xml_find_attrib( attribs, noattribs, 'values', buffer ) 244 | if ( idx > 0 ) then 245 | allocate( var(1:1) ) 246 | var(1) = buffer 247 | if ( buffer /= ' ' ) then 248 | has_var = .true. 249 | endif 250 | else 251 | idxv = 0 252 | started = .false. 253 | do idx = 1,nodata 254 | if ( data(idx) /= ' ' .or. started ) then 255 | if ( .not. started ) then 256 | allocate( var(1:nodata-idx+1) ) 257 | started = .true. 258 | endif 259 | idxv = idxv + 1 260 | var(idxv) = data(idx) 261 | endif 262 | enddo 263 | if ( started ) then 264 | has_var = .true. 265 | endif 266 | endif 267 | end subroutine read_xml_line_array 268 | 269 | ! read_xml_real_array, ... -- 270 | ! See read_xml_integer_array for an explanation 271 | ! 272 | subroutine read_xml_real_array( info, tag, endtag, attribs, noattribs, data, & 273 | nodata, var, has_var ) 274 | real, dimension(:), pointer :: var 275 | 276 | include 'read_xml_array.inc' 277 | 278 | end subroutine read_xml_real_array 279 | 280 | subroutine read_xml_double_array( info, tag, endtag, attribs, noattribs, data, & 281 | nodata, var, has_var ) 282 | real(kind=kind(1.0d00)), dimension(:), pointer :: var 283 | 284 | include 'read_xml_array.inc' 285 | 286 | end subroutine read_xml_double_array 287 | 288 | subroutine read_xml_logical_array( info, tag, endtag, attribs, noattribs, data, & 289 | nodata, var, has_var ) 290 | logical, dimension(:), pointer :: var 291 | 292 | include 'read_xml_array.inc' 293 | 294 | end subroutine read_xml_logical_array 295 | 296 | subroutine read_xml_word_array( info, tag, endtag, attribs, noattribs, data, & 297 | nodata, var, has_var ) 298 | character(len=*), dimension(:), pointer :: var 299 | 300 | include 'read_xml_array.inc' 301 | 302 | end subroutine read_xml_word_array 303 | 304 | ! read_from_buffer_integers -- 305 | ! Routine to read all integers from a long string 306 | ! 307 | ! Arguments: 308 | ! buffer String containing the data 309 | ! var Variable to be filled 310 | ! ierror Error flag 311 | ! 312 | subroutine read_from_buffer_integers( buffer, var, ierror ) 313 | integer, dimension(:), pointer :: var 314 | integer, dimension(:), pointer :: work 315 | 316 | include 'read_from_buffer.inc' 317 | 318 | end subroutine read_from_buffer_integers 319 | 320 | ! read_xml_from_buffer_reals, ... - 321 | ! See read_xml_from_buffer_integers for an explanation 322 | ! 323 | subroutine read_from_buffer_reals( buffer, var, ierror ) 324 | real, dimension(:), pointer :: var 325 | real, dimension(:), pointer :: work 326 | 327 | include 'read_from_buffer.inc' 328 | 329 | end subroutine read_from_buffer_reals 330 | 331 | subroutine read_from_buffer_doubles( buffer, var, ierror ) 332 | real(kind=kind(1.0d00)), dimension(:), pointer :: var 333 | real(kind=kind(1.0d00)), dimension(:), pointer :: work 334 | 335 | include 'read_from_buffer.inc' 336 | 337 | end subroutine read_from_buffer_doubles 338 | 339 | subroutine read_from_buffer_logicals( buffer, var, ierror ) 340 | logical, dimension(:), pointer :: var 341 | logical, dimension(:), pointer :: work 342 | 343 | include 'read_from_buffer.inc' 344 | 345 | end subroutine read_from_buffer_logicals 346 | 347 | subroutine read_from_buffer_words( buffer, var, ierror ) 348 | character(len=*), dimension(:), pointer :: var 349 | character(len=len(var)), dimension(:), pointer :: work 350 | 351 | include 'read_from_buffer.inc' 352 | 353 | end subroutine read_from_buffer_words 354 | 355 | ! read_xml_word_1dim, ... - 356 | ! Read an array of "words" (or ...) but from different elements 357 | ! 358 | subroutine read_xml_integer_1dim( info, tag, endtag, attribs, noattribs, data, nodata, & 359 | var, has_var ) 360 | type(XML_PARSE), intent(inout) :: info 361 | character(len=*), intent(in) :: tag 362 | logical, intent(inout) :: endtag 363 | character(len=*), dimension(:,:), intent(in) :: attribs 364 | integer, intent(in) :: noattribs 365 | character(len=*), dimension(:), intent(in) :: data 366 | integer, intent(in) :: nodata 367 | integer, dimension(:), pointer :: var 368 | logical, intent(inout) :: has_var 369 | 370 | integer,dimension(:), pointer :: newvar 371 | character(len=len(attribs(1,1))) :: buffer 372 | integer :: newsize 373 | integer :: ierr 374 | 375 | newsize = size(var) + 1 376 | allocate( newvar(1:newsize) ) 377 | newvar(1:newsize-1) = var 378 | deallocate( var ) 379 | var => newvar 380 | 381 | call read_xml_integer( info, tag, endtag, attribs, noattribs, data, nodata, & 382 | var(newsize), has_var ) 383 | 384 | end subroutine read_xml_integer_1dim 385 | 386 | subroutine read_xml_real_1dim( info, tag, endtag, attribs, noattribs, data, nodata, & 387 | var, has_var ) 388 | type(XML_PARSE), intent(inout) :: info 389 | character(len=*), intent(in) :: tag 390 | logical, intent(inout) :: endtag 391 | character(len=*), dimension(:,:), intent(in) :: attribs 392 | integer, intent(in) :: noattribs 393 | character(len=*), dimension(:), intent(in) :: data 394 | integer, intent(in) :: nodata 395 | real, dimension(:), pointer :: var 396 | logical, intent(inout) :: has_var 397 | 398 | real, dimension(:), pointer :: newvar 399 | character(len=len(attribs(1,1))) :: buffer 400 | integer :: newsize 401 | integer :: ierr 402 | 403 | newsize = size(var) + 1 404 | allocate( newvar(1:newsize) ) 405 | newvar(1:newsize-1) = var 406 | deallocate( var ) 407 | var => newvar 408 | 409 | call read_xml_real( info, tag, endtag, attribs, noattribs, data, nodata, & 410 | var(newsize), has_var ) 411 | 412 | end subroutine read_xml_real_1dim 413 | 414 | subroutine read_xml_double_1dim( info, tag, endtag, attribs, noattribs, data, nodata, & 415 | var, has_var ) 416 | type(XML_PARSE), intent(inout) :: info 417 | character(len=*), intent(in) :: tag 418 | logical, intent(inout) :: endtag 419 | character(len=*), dimension(:,:), intent(in) :: attribs 420 | integer, intent(in) :: noattribs 421 | character(len=*), dimension(:), intent(in) :: data 422 | integer, intent(in) :: nodata 423 | real(kind=kind(1.0d00)), dimension(:), pointer:: var 424 | logical, intent(inout) :: has_var 425 | 426 | real(kind=kind(1.0d00)), dimension(:), pointer:: newvar 427 | character(len=len(attribs(1,1))) :: buffer 428 | integer :: newsize 429 | integer :: ierr 430 | 431 | newsize = size(var) + 1 432 | allocate( newvar(1:newsize) ) 433 | newvar(1:newsize-1) = var 434 | deallocate( var ) 435 | var => newvar 436 | 437 | call read_xml_double( info, tag, endtag, attribs, noattribs, data, nodata, & 438 | var(newsize), has_var ) 439 | 440 | end subroutine read_xml_double_1dim 441 | 442 | subroutine read_xml_logical_1dim( info, tag, endtag, attribs, noattribs, data, nodata, & 443 | var, has_var ) 444 | type(XML_PARSE), intent(inout) :: info 445 | character(len=*), intent(in) :: tag 446 | logical, intent(inout) :: endtag 447 | character(len=*), dimension(:,:), intent(in) :: attribs 448 | integer, intent(in) :: noattribs 449 | character(len=*), dimension(:), intent(in) :: data 450 | integer, intent(in) :: nodata 451 | logical, dimension(:), pointer :: var 452 | logical, intent(inout) :: has_var 453 | 454 | logical, dimension(:), pointer :: newvar 455 | character(len=len(attribs(1,1))) :: buffer 456 | integer :: newsize 457 | integer :: ierr 458 | 459 | newsize = size(var) + 1 460 | allocate( newvar(1:newsize) ) 461 | newvar(1:newsize-1) = var 462 | deallocate( var ) 463 | var => newvar 464 | 465 | call read_xml_logical( info, tag, endtag, attribs, noattribs, data, nodata, & 466 | var(newsize), has_var ) 467 | 468 | end subroutine read_xml_logical_1dim 469 | 470 | subroutine read_xml_word_1dim( info, tag, endtag, attribs, noattribs, data, nodata, & 471 | var, has_var ) 472 | type(XML_PARSE), intent(inout) :: info 473 | character(len=*), intent(in) :: tag 474 | logical, intent(inout) :: endtag 475 | character(len=*), dimension(:,:), intent(in) :: attribs 476 | integer, intent(in) :: noattribs 477 | character(len=*), dimension(:), intent(in) :: data 478 | integer, intent(in) :: nodata 479 | character(len=*), dimension(:), pointer :: var 480 | logical, intent(inout) :: has_var 481 | 482 | character(len=len(var)),dimension(:), pointer :: newvar 483 | character(len=len(attribs(1,1))) :: buffer 484 | integer :: newsize 485 | integer :: ierr 486 | 487 | newsize = size(var) + 1 488 | allocate( newvar(1:newsize) ) 489 | newvar(1:newsize-1) = var 490 | deallocate( var ) 491 | var => newvar 492 | 493 | call read_xml_word( info, tag, endtag, attribs, noattribs, data, nodata, & 494 | var(newsize), has_var ) 495 | 496 | end subroutine read_xml_word_1dim 497 | 498 | subroutine read_xml_line_1dim( info, tag, endtag, attribs, noattribs, data, nodata, & 499 | var, has_var ) 500 | type(XML_PARSE), intent(inout) :: info 501 | character(len=*), intent(in) :: tag 502 | logical, intent(inout) :: endtag 503 | character(len=*), dimension(:,:), intent(in) :: attribs 504 | integer, intent(in) :: noattribs 505 | character(len=*), dimension(:), intent(in) :: data 506 | integer, intent(in) :: nodata 507 | character(len=*), dimension(:), pointer :: var 508 | logical, intent(inout) :: has_var 509 | 510 | character(len=len(var)),dimension(:), pointer :: newvar 511 | character(len=len(attribs(1,1))) :: buffer 512 | integer :: newsize 513 | integer :: ierr 514 | 515 | newsize = size(var) + 1 516 | allocate( newvar(1:newsize) ) 517 | newvar(1:newsize-1) = var 518 | deallocate( var ) 519 | var => newvar 520 | 521 | call read_xml_line( info, tag, endtag, attribs, noattribs, data, nodata, & 522 | var(newsize), has_var ) 523 | 524 | end subroutine read_xml_line_1dim 525 | 526 | 527 | end module read_xml_primitives 528 | -------------------------------------------------------------------------------- /src/read_xml_scalar.inc: -------------------------------------------------------------------------------- 1 | ! Part of XML-Fortran library: 2 | ! 3 | ! $Id: read_xml_scalar.inc,v 1.3 2007/02/26 20:33:38 arjenmarkus Exp $ 4 | ! 5 | type(XML_PARSE), intent(inout) :: info 6 | character(len=*), intent(in) :: tag 7 | logical, intent(inout) :: endtag 8 | character(len=*), dimension(:,:), intent(in) :: attribs 9 | integer, intent(in) :: noattribs 10 | character(len=*), dimension(:), intent(in) :: data 11 | integer, intent(in) :: nodata 12 | logical, intent(inout) :: has_var 13 | 14 | character(len=len(attribs(1,1))) :: buffer 15 | integer :: idx 16 | integer :: ierr 17 | 18 | ! 19 | ! The value can be stored in an attribute value="..." or in 20 | ! the data 21 | ! 22 | has_var = .false. 23 | idx = xml_find_attrib( attribs, noattribs, 'value', buffer ) 24 | if ( idx .gt. 0 ) then 25 | read( buffer, *, iostat=ierr ) var 26 | has_var = .true. 27 | else 28 | do idx = 1,nodata 29 | if ( data(idx) .ne. ' ' ) then 30 | read( data(idx), *, iostat=ierr ) var 31 | has_var = .true. 32 | exit 33 | endif 34 | enddo 35 | endif 36 | 37 | if ( ierr .ne. 0 ) then 38 | write(*,*) 'Error reading variable - tag = ', trim(tag) 39 | has_var = .false. 40 | endif 41 | -------------------------------------------------------------------------------- /src/read_xml_word.inc: -------------------------------------------------------------------------------- 1 | ! Part of XML-Fortran library: 2 | ! 3 | type(XML_PARSE), intent(inout) :: info 4 | character(len=*), intent(in) :: tag 5 | logical, intent(inout) :: endtag 6 | character(len=*), dimension(:,:), intent(in) :: attribs 7 | integer, intent(in) :: noattribs 8 | character(len=*), dimension(:), intent(in) :: data 9 | integer, intent(in) :: nodata 10 | logical, intent(inout) :: has_var 11 | 12 | character(len=len(attribs(1,1))) :: buffer 13 | integer :: idx 14 | integer :: ierr 15 | 16 | ! 17 | ! The value can be stored in an attribute value="..." or in 18 | ! the data 19 | ! 20 | has_var = .false. 21 | idx = xml_find_attrib( attribs, noattribs, 'value', buffer ) 22 | if ( idx .gt. 0 ) then 23 | read( buffer, *, iostat=ierr ) var 24 | has_var = .true. 25 | else 26 | do idx = 1,nodata 27 | if ( data(idx) .ne. ' ' ) then 28 | read( data(idx), '(A)', iostat=ierr ) var 29 | has_var = .true. 30 | exit 31 | endif 32 | enddo 33 | endif 34 | 35 | if ( ierr .ne. 0 ) then 36 | write(*,*) 'Error reading variable - tag = ', trim(tag) 37 | has_var = .false. 38 | endif 39 | -------------------------------------------------------------------------------- /src/test_read_prims.f90: -------------------------------------------------------------------------------- 1 | ! test_read_prims.f90 - Test program for reading primitive data 2 | ! 3 | ! $Id: test_read_prims.f90,v 1.3 2006/03/26 19:05:48 arjenmarkus Exp $ 4 | ! 5 | ! Arjen Markus 6 | ! 7 | ! General information: 8 | ! This is a test program for the module read_xml_primitives, 9 | ! part of the XML-Fortran library. 10 | ! 11 | program test_read_prims 12 | use read_xml_primitives 13 | 14 | implicit none 15 | 16 | type(XML_PARSE) :: info 17 | character(len=40) :: tag 18 | character(len=40), dimension(2,10) :: attribs 19 | integer :: noattribs 20 | character(len=80), dimension(100) :: data 21 | integer :: nodata 22 | integer :: var 23 | integer, dimension(:), pointer :: array 24 | logical :: has_var 25 | 26 | ! 27 | ! Test cases regarding reading integers 28 | ! 29 | attribs(1,1) = 'value' 30 | attribs(2,1) = ' 1' 31 | noattribs = 1 32 | data(1) = ' 2' 33 | nodata = 1 34 | var = -1 35 | has_var = .false. 36 | 37 | tag = 'integer-test' 38 | 39 | var = -1 40 | noattribs = 1 41 | nodata = 1 42 | call read_xml_integer( info, tag, attribs, noattribs, data, nodata, & 43 | var, has_var ) 44 | if ( var .ne. 1 ) then 45 | write(*,*) 'Error 1: var should be 1, is', var 46 | endif 47 | if ( .not. has_var ) then 48 | write(*,*) 'Error 1a: has_var should be true' 49 | endif 50 | 51 | var = -1 52 | noattribs = 0 53 | nodata = 1 54 | call read_xml_integer( info, tag, attribs, noattribs, data, nodata, & 55 | var, has_var ) 56 | if ( var .ne. 2 ) then 57 | write(*,*) 'Error 2: var should be 2, is', var 58 | endif 59 | if ( .not. has_var ) then 60 | write(*,*) 'Error 2a: has_var should be true' 61 | endif 62 | 63 | var = -1 64 | noattribs = 0 65 | nodata = 0 66 | call read_xml_integer( info, tag, attribs, noattribs, data, nodata, & 67 | var, has_var ) 68 | if ( var .ne. -1 ) then 69 | write(*,*) 'Error 3: var should be -1, is', var 70 | endif 71 | if ( has_var ) then 72 | write(*,*) 'Error 3a: has_var should be FALSE' 73 | endif 74 | if ( has_var ) then 75 | write(*,*) 'Error 3a: has_var should be FALSE' 76 | endif 77 | 78 | var = -1 79 | noattribs = 0 80 | nodata = 3 81 | data(1) = ' ' 82 | data(2) = ' ' 83 | data(3) = ' 3' 84 | call read_xml_integer( info, tag, attribs, noattribs, data, nodata, & 85 | var, has_var ) 86 | if ( var .ne. 3 ) then 87 | write(*,*) 'Error 4: var should be 3, is', var 88 | endif 89 | if ( .not. has_var ) then 90 | write(*,*) 'Error 4a: has_var should be true' 91 | endif 92 | 93 | var = -1 94 | noattribs = 0 95 | nodata = 3 96 | data(1) = ' ' 97 | data(2) = ' ' 98 | data(3) = 'xxx' 99 | call read_xml_integer( info, tag, attribs, noattribs, data, nodata, & 100 | var, has_var ) 101 | if ( var .ne. -1 ) then 102 | write(*,*) 'Error 5: var should be -1, is', var 103 | endif 104 | if ( has_var ) then 105 | write(*,*) 'Error 5a: has_var should be FALSE' 106 | endif 107 | 108 | nullify( array ) 109 | noattribs = 1 110 | attribs(1,1) = 'values' 111 | attribs(2,1) = '1 2 3' 112 | nodata = 3 113 | data(1) = ' ' 114 | data(2) = ' ' 115 | data(3) = 'xxx' 116 | call read_xml_integer_array( info, tag, attribs, noattribs, data, & 117 | nodata, array, has_var ) 118 | if ( size(array) .ne. 3 ) then 119 | write(*,*) 'Error 6: array should be size 3, is', size(array) 120 | endif 121 | if ( any(array .ne. (/1,2,3/)) ) then 122 | write(*,*) 'Error 6: array should be 1,2,3, is', array 123 | endif 124 | if ( .not. has_var ) then 125 | write(*,*) 'Error 6a: has_var should be TRUE' 126 | endif 127 | 128 | noattribs = 1 129 | attribs(1,1) = 'xxxxxx' 130 | attribs(2,1) = '3 4 5' 131 | nodata = 3 132 | data(1) = '1 ' 133 | data(2) = '2 ' 134 | data(3) = '3 ' 135 | call read_xml_integer_array( info, tag, attribs, noattribs, data, & 136 | nodata, array, has_var ) 137 | if ( size(array) .ne. 3 ) then 138 | write(*,*) 'Error 7: array should be size 3, is', size(array) 139 | endif 140 | if ( any(array .ne. (/1,2,3/)) ) then 141 | write(*,*) 'Error 7: array should be 1,2,3, is', array 142 | endif 143 | if ( .not. has_var ) then 144 | write(*,*) 'Error 7a: has_var should be TRUE' 145 | endif 146 | 147 | noattribs = 0 148 | attribs(1,1) = 'values' 149 | attribs(2,1) = '1 2 3' 150 | nodata = 3 151 | data(1) = '1 2' 152 | data(2) = ' ' 153 | data(3) = '3 ' 154 | call read_xml_integer_array( info, tag, attribs, noattribs, data, & 155 | nodata, array, has_var ) 156 | if ( size(array) .ne. 3 ) then 157 | write(*,*) 'Error 8: array should be size 3, is', size(array) 158 | endif 159 | if ( any(array .ne. (/1,2,3/)) ) then 160 | write(*,*) 'Error 8: array should be 1,2,3, is', array 161 | endif 162 | if ( .not. has_var ) then 163 | write(*,*) 'Error 8a: has_var should be TRUE' 164 | endif 165 | 166 | noattribs = 1 167 | attribs(1,1) = 'values' 168 | attribs(2,1) = 'xxx' 169 | nodata = 3 170 | data(1) = '1 2' 171 | data(2) = ' ' 172 | data(3) = '3 ' 173 | call read_xml_integer_array( info, tag, attribs, noattribs, data, & 174 | nodata, array, has_var ) 175 | if ( has_var ) then 176 | write(*,*) 'Error 9a: has_var should be FALSE' 177 | endif 178 | 179 | end program 180 | -------------------------------------------------------------------------------- /src/test_write_prims.f90: -------------------------------------------------------------------------------- 1 | ! test_write_prims.f90 - Test program for writing primitive data 2 | ! 3 | ! $Id: test_write_prims.f90,v 1.1 2007/06/10 10:08:38 arjenmarkus Exp $ 4 | ! 5 | ! Arjen Markus 6 | ! 7 | ! General information: 8 | ! This is a test program for the module write_xml_primitives, 9 | ! part of the XML-Fortran library. 10 | ! 11 | program test_write_prims 12 | use write_xml_primitives 13 | 14 | implicit none 15 | 16 | type(XML_PARSE) :: info 17 | character(len=40) :: tag 18 | integer :: var 19 | integer, dimension(:), pointer :: array 20 | logical :: has_var 21 | 22 | info%lun = 10 23 | open( info%lun, file='test_write.xml' ) 24 | 25 | call write_to_xml_integer( info, 'integer', 4, -123456789 ) 26 | call write_to_xml_real( info, 'real', 3, -1.23456789 ) 27 | call write_to_xml_double( info, 'double', 3, -1.23456789d0 ) 28 | call write_to_xml_logical( info, 'logical', 3, .true. ) 29 | call write_to_xml_logical( info, 'logical', 4, .false. ) 30 | call write_to_xml_string( info, 'string', 4, 'Hm, some string' ) 31 | 32 | call write_to_xml_integer_array( info, 'integers', 4, & 33 | (/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12 /) ) 34 | call write_to_xml_real_array( info, 'reals', 4, & 35 | (/ 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0, 9.0, 10.0, 11.0, 12.0 /) ) 36 | call write_to_xml_double_array( info, 'doubles', 4, & 37 | (/ 1.0d0, 2.0d0, 3.0d0, 4.0d0, 5.0d0, 6.0d0, & 38 | 7.0d0, 8.0d0, 9.0d0, 10.0d0, 11.0d0, 12.0d0 /) ) 39 | call write_to_xml_logical_array( info, 'logicals', 4, & 40 | (/ .true., .true., .true., .false., .false., .false., & 41 | .true., .true., .true., .false., .false., .false. /) ) 42 | 43 | close( info%lun ) 44 | 45 | end program 46 | -------------------------------------------------------------------------------- /src/tree_find.f90: -------------------------------------------------------------------------------- 1 | ! tree_find.f90 -- 2 | ! Include file for tree_struct.f90: "advanced" search routines 3 | ! 4 | ! $Id: tree_find.f90,v 1.2 2006/03/26 19:05:48 arjenmarkus Exp $ 5 | ! 6 | ! General information: 7 | ! This file contains the following routines: 8 | ! - tree_next_segment: strip a segment from the search path 9 | ! - tree_append_handles: append to an array of nodes 10 | ! - tree_find_descendants: find all nodes with a given name and type 11 | ! - tree_find: find all nodes given by a path 12 | ! 13 | 14 | ! tree_next_segment -- 15 | ! Strip a segment from the search path 16 | ! 17 | ! Arguments: 18 | ! path Full path (or partially stripped) 19 | ! segment First segment in the path or nothing 20 | ! Result: 21 | ! The first segment (that is a non-empty string between /'s) is 22 | ! returned in the argument "segment", the path is updated 23 | ! For instance: 24 | ! //A/B/C ==> segment=A, new path=B/C 25 | ! 26 | subroutine tree_next_segment( path, segment ) 27 | character(len=*), intent(inout) :: path 28 | character(len=*), intent(out) :: segment 29 | 30 | integer :: idx 31 | ! 32 | ! Strip off any leading slashes first 33 | ! 34 | do while ( path(1:1) == '/' ) 35 | path(1:) = path(2:) 36 | enddo 37 | 38 | ! 39 | ! Find the next segment 40 | ! 41 | idx = index( path, '/' ) 42 | if ( idx > 0 ) then 43 | segment = path(1:idx-1) 44 | path(1:) = path(idx+1:) 45 | else 46 | if ( path == ' ' ) then 47 | segment = ' ' 48 | else 49 | segment = path 50 | path = ' ' 51 | endif 52 | endif 53 | end subroutine tree_next_segment 54 | 55 | ! tree_append_handles -- 56 | ! Append to an array of handles 57 | ! 58 | ! Arguments: 59 | ! all_handles Pointer to array holding all handles 60 | ! handles New array to be appended 61 | ! Result: 62 | ! A new array with all handles included 63 | ! 64 | subroutine tree_append_handles( all_handles, handles ) 65 | type(TREE_DATA_PTR), dimension(:), pointer :: all_handles 66 | type(TREE_DATA_PTR), dimension(:) :: handles 67 | 68 | type(TREE_DATA_PTR), dimension(:), pointer :: new_array 69 | 70 | integer :: total_size 71 | 72 | total_size = size(all_handles) + size(handles) 73 | allocate( new_array(1:total_size) ) 74 | 75 | new_array(1:size(all_handles)) = all_handles 76 | new_array(size(all_handles)+1:total_size) = handles 77 | 78 | deallocate( all_handles ) 79 | all_handles => new_array 80 | 81 | end subroutine tree_append_handles 82 | 83 | ! tree_find_descendants -- 84 | ! Find all nodes with a given name and type 85 | ! 86 | ! Arguments: 87 | ! tree The node in the tree to start the search 88 | ! name The name of the node (empty for all) 89 | ! type The type of the node (empty for all) 90 | ! all Descend the tree (.true.) or only look at children 91 | ! handles A returned array of handles to the nodes that 92 | ! were found 93 | ! Result: 94 | ! An array of node handles - each node is found on the specified 95 | ! path. The user should deallocate the array when done 96 | ! 97 | recursive subroutine tree_find_descendants_priv( & 98 | tree, name, type, all, handles ) 99 | type(TREE_DATA), pointer :: tree 100 | type(TREE_DATA_PTR), dimension(:), pointer :: handles 101 | character(len=*) :: name 102 | character(len=*) :: type 103 | logical :: all 104 | 105 | type(TREE_DATA_PTR), dimension(1:1) :: new_handle 106 | character(len=80) :: node_name 107 | character(len=80) :: node_type 108 | integer :: i 109 | 110 | if ( associated(tree%child_nodes) ) then 111 | do i = 1,size(tree%child_nodes) 112 | node_name = tree_get_name( tree%child_nodes(i)%node_ptr ) 113 | node_type = tree_get_datatype( tree%child_nodes(i)%node_ptr ) 114 | 115 | if ( (node_name .eq. name .or. name .eq. ' ') .and. & 116 | (node_type .eq. type .or. type .eq. ' ') ) then 117 | new_handle(1)%node_ptr => tree%child_nodes(i)%node_ptr 118 | call tree_append_handles( handles, new_handle ) 119 | else 120 | if ( all ) then 121 | call tree_find_descendants_priv( & 122 | tree%child_nodes(i)%node_ptr, & 123 | name, type, all, handles ) 124 | endif 125 | endif 126 | enddo 127 | endif 128 | 129 | end subroutine tree_find_descendants_priv 130 | 131 | ! tree_find_descendants -- 132 | ! Find all nodes with a given name and type 133 | ! 134 | ! Arguments: 135 | ! tree The node in the tree to start the search 136 | ! name The name of the node (empty for all) 137 | ! type The type of the node (empty for all) 138 | ! all Descend the tree (.true.) or only look at children 139 | ! handles A returned array of handles to the nodes that 140 | ! were found 141 | ! Result: 142 | ! An array of node handles - each node is found on the specified 143 | ! path. The user should deallocate the array when done 144 | ! 145 | subroutine tree_find_descendants( tree, name, type, all, handles ) 146 | type(TREE_DATA), pointer :: tree 147 | type(TREE_DATA_PTR), dimension(:), pointer :: handles 148 | character(len=*) :: name 149 | character(len=*) :: type 150 | logical :: all 151 | 152 | type(TREE_DATA_PTR), dimension(:), pointer :: new_handle 153 | character(len=80) :: node_name 154 | character(len=80) :: node_type 155 | 156 | allocate( handles(1:0) ) 157 | call tree_find_descendants_priv( tree, name, type, all, handles ) 158 | 159 | end subroutine tree_find_descendants 160 | 161 | ! tree_find -- 162 | ! Find all nodes given by a path 163 | ! 164 | ! Arguments: 165 | ! tree The node in the tree to start the search 166 | ! path The path (a string of names separated by /) 167 | ! handles A returned array of handles to the nodes that 168 | ! were found 169 | ! Result: 170 | ! An array of node handles - each node is found on the specified 171 | ! path. The user should deallocate the array when done 172 | ! 173 | subroutine tree_find( tree, path, handles ) 174 | type(TREE_DATA), pointer :: tree 175 | type(TREE_DATA_PTR), dimension(:), pointer :: handles 176 | character(len=*) :: path 177 | 178 | ! 179 | ! Local variables: use the string length of path! 180 | ! 181 | character(len=len(path)) :: path_stripped 182 | character(len=len(path)) :: segment 183 | 184 | type(TREE_DATA_PTR), dimension(:), pointer :: result_handles 185 | type(TREE_DATA_PTR), dimension(:), pointer :: new_handles 186 | 187 | logical :: all 188 | integer :: i 189 | 190 | ! 191 | ! For the first segment we will search the whole tree, 192 | ! after that we are only interested in direct children 193 | ! 194 | all = .true. 195 | path_stripped = path 196 | 197 | allocate( handles(1:1) ) 198 | handles(1)%node_ptr => tree 199 | 200 | do 201 | call tree_next_segment( path_stripped, segment ) 202 | 203 | if ( segment /= ' ' ) then 204 | allocate( result_handles(1:0) ) 205 | do i = 1,size(handles) 206 | call tree_find_descendants( handles(i)%node_ptr, segment, & 207 | "", all, new_handles ) 208 | call tree_append_handles( result_handles, new_handles ) 209 | deallocate( new_handles ) 210 | enddo 211 | all = .false. 212 | else 213 | exit 214 | endif 215 | deallocate( handles ) 216 | handles => result_handles 217 | enddo 218 | 219 | end subroutine tree_find 220 | -------------------------------------------------------------------------------- /src/tree_struct.f90: -------------------------------------------------------------------------------- 1 | ! tree_struct.f90 -- 2 | ! Module that implements a general tree structure in Fortran 90 3 | ! 4 | ! General information: 5 | ! The tree is stored via a derived type TREE_DATA. A tree can 6 | ! have an arbitrary number of nodes, each of which can again 7 | ! have an arbitrary number of subnodes and so on. 8 | ! The data type for a node is the same as for a tree - there 9 | ! is no difference, except that the routine tree_create() 10 | ! returns the initialised root of a new tree. 11 | ! A node (and the root as well) can have the following 12 | ! properties: 13 | ! - A name (at most 80 characters) 14 | ! - Arbitrary data 15 | ! - A string indicating the type of data 16 | ! - Zero, one or more subnodes 17 | ! The storage is fairly efficient (via the TRANSFER() function 18 | ! all data and strings are converted to arrays of default 19 | ! integers). A node does not "know" its parent though and 20 | ! there is no check on circularity. 21 | ! 22 | ! $Id: tree_struct.f90,v 1.2 2006/03/26 19:05:48 arjenmarkus Exp $ 23 | ! 24 | module TREE_DATA_TYPES 25 | type TREE_DATA 26 | character(len=1), dimension(:), pointer :: node_name 27 | character(len=1), dimension(:), pointer :: node_data 28 | character(len=1), dimension(:), pointer :: node_data_type 29 | type(TREE_DATA_PTR), dimension(:), pointer :: child_nodes 30 | end type 31 | 32 | type TREE_DATA_PTR 33 | type(TREE_DATA), pointer :: node_ptr 34 | end type 35 | end module 36 | 37 | module TREE_STRUCTURES 38 | use TREE_DATA_TYPES 39 | implicit none 40 | 41 | private 42 | ! 43 | ! A variable that indicates the type of all data 44 | ! 45 | character(len=1), dimension(1:1), public :: node_value 46 | 47 | ! 48 | ! Auxiliary variable 49 | ! 50 | integer, private :: traverse_level = 0 51 | 52 | ! 53 | ! Public routines, types and parameters 54 | ! 55 | public :: TREE_DATA, TREE_DATA_PTR 56 | public :: tree_create, tree_create_node, tree_get_node_by_name, & 57 | tree_get_data_ptr, tree_put_data, tree_get_name, & 58 | tree_get_datatype, tree_get_data_string, & 59 | tree_find, tree_find_descendants, & 60 | tree_traverse, tree_traverse_level 61 | 62 | ! 63 | ! For testing purposes - should actually be private 64 | ! 65 | public :: tree_next_segment, tree_append_handles 66 | 67 | contains 68 | 69 | ! tree_create -- 70 | ! Create a new tree 71 | ! 72 | ! Arguments: 73 | ! name Name of the new tree 74 | ! tree Pointer to the new tree 75 | ! Result: 76 | ! The argument tree points to a new, empty tree structure or is 77 | ! not associated 78 | ! 79 | subroutine tree_create( name, tree ) 80 | character(len=*), intent(in) :: name 81 | type(TREE_DATA), pointer :: tree 82 | 83 | integer :: error 84 | integer :: newsize 85 | 86 | allocate( tree, stat = error ) 87 | 88 | if ( error .ne. 0 ) then 89 | nullify( tree ) 90 | else 91 | newsize = size( transfer( name, node_value ) ) 92 | allocate( tree%node_name(1:newsize), stat = error ) 93 | if ( error .ne. 0 ) then 94 | deallocate( tree ) 95 | return 96 | else 97 | tree%node_name(1:newsize) = transfer( name, node_value ) 98 | nullify( tree%node_data ) 99 | nullify( tree%node_data_type ) 100 | nullify( tree%child_nodes ) 101 | endif 102 | endif 103 | end subroutine tree_create 104 | 105 | ! tree_create_node -- 106 | ! Create a new node to the given tree or node 107 | ! 108 | ! Arguments: 109 | ! tree The tree or node to which to append the new node 110 | ! name Name of the new node 111 | ! node Pointer to the new node 112 | ! Result: 113 | ! The argument node points to a new, empty node or is 114 | ! not associated 115 | ! 116 | subroutine tree_create_node( tree, name, node ) 117 | character(len=*), intent(in) :: name 118 | type(TREE_DATA), pointer :: tree 119 | type(TREE_DATA), pointer :: node 120 | 121 | type(TREE_DATA_PTR), dimension(:), pointer :: children 122 | 123 | integer :: error 124 | integer :: newsize 125 | 126 | ! 127 | ! Check for uniqueness -- no: do not do that! 128 | ! 129 | !call tree_get_node_by_name( tree, name, node ) 130 | !if ( associated( node ) ) then 131 | ! return 132 | !endif 133 | 134 | ! 135 | ! Create a new node, store it in the array of child nodes 136 | ! for this (sub)tree 137 | ! 138 | call tree_create( name, node ) 139 | 140 | if ( associated( node ) ) then 141 | newsize = 1 142 | if ( associated( tree%child_nodes ) ) then 143 | newsize = 1 + size( tree%child_nodes ) 144 | endif 145 | 146 | allocate( children(1:newsize), stat = error ) 147 | if ( error .ne. 0 ) then 148 | deallocate( node ) 149 | return 150 | else 151 | if ( newsize .gt. 1 ) then 152 | children(1:newsize-1) = tree%child_nodes 153 | deallocate( tree%child_nodes ) 154 | endif 155 | 156 | tree%child_nodes => children 157 | tree%child_nodes(newsize)%node_ptr => node 158 | endif 159 | endif 160 | end subroutine tree_create_node 161 | 162 | ! tree_get_name -- 163 | ! Return the name of the tree or node 164 | ! 165 | ! Arguments: 166 | ! tree The tree or node 167 | ! 168 | function tree_get_name( tree ) result( node_name ) 169 | type(TREE_DATA), pointer :: tree 170 | character(len=80) :: node_name 171 | 172 | integer :: length 173 | 174 | length = size( tree%node_name ) 175 | node_name = ' ' 176 | node_name(1:length) = transfer( tree%node_name, node_name ) 177 | end function tree_get_name 178 | 179 | ! tree_get_datatype -- 180 | ! Return the data type for the data stored in the tree or node 181 | ! 182 | ! Arguments: 183 | ! tree The tree or node 184 | ! 185 | function tree_get_datatype( tree ) result( data_type ) 186 | type(TREE_DATA), pointer :: tree 187 | character(len=40) :: data_type 188 | 189 | integer :: length 190 | 191 | data_type = '?' 192 | if ( associated( tree%node_data_type ) ) then 193 | length = size( tree%node_data_type ) 194 | data_type(1:length) = transfer( tree%node_data_type, data_type ) 195 | endif 196 | end function tree_get_datatype 197 | 198 | ! tree_get_node_by_name -- 199 | ! Return the child node by name 200 | ! 201 | ! Arguments: 202 | ! tree The tree or node to which to append the new node 203 | ! name Name of the node to find 204 | ! node Pointer to the node or "null" 205 | ! Result: 206 | ! The argument node points to a new, empty node or is 207 | ! not associated 208 | ! 209 | subroutine tree_get_node_by_name( tree, name, node ) 210 | character(len=*), intent(in) :: name 211 | type(TREE_DATA), pointer :: tree 212 | type(TREE_DATA), pointer :: node 213 | 214 | character(len=80) :: node_name 215 | 216 | integer :: i 217 | 218 | nullify( node ) 219 | 220 | if ( associated(tree%child_nodes) ) then 221 | do i = 1,size(tree%child_nodes) 222 | node_name = tree_get_name( tree%child_nodes(i)%node_ptr ) 223 | 224 | if ( node_name .eq. name ) then 225 | node => tree%child_nodes(i)%node_ptr 226 | exit 227 | endif 228 | enddo 229 | endif 230 | 231 | end subroutine tree_get_node_by_name 232 | 233 | ! tree_get_data_ptr -- 234 | ! Return a pointer to the tree/node's data 235 | ! 236 | ! Arguments: 237 | ! tree The tree or node from which to get the data 238 | ! data_ptr Pointer to the node/tree data 239 | ! data_type String indicating the type 240 | ! Result: 241 | ! The argument data_ptr points to the stored data or is 242 | ! not associated 243 | ! 244 | subroutine tree_get_data_ptr( tree, data_ptr, data_type ) 245 | type(TREE_DATA), pointer :: tree 246 | character(len=1), dimension(:), pointer :: data_ptr 247 | character(len=*) :: data_type 248 | 249 | nullify( data_ptr ) 250 | 251 | data_type = '?' 252 | if ( associated( tree%node_data) ) then 253 | data_ptr => tree%node_data 254 | data_type = tree_get_datatype( tree ) 255 | endif 256 | 257 | end subroutine tree_get_data_ptr 258 | 259 | ! tree_put_data -- 260 | ! Put (a copy of) the data in the tree/node 261 | ! 262 | ! Arguments: 263 | ! tree The tree or node with which to attach the data 264 | ! data Array of integers 265 | ! data_type Optional string indicating the type 266 | ! success True if all went well, false otherwise 267 | ! Result: 268 | ! The tree structure points to a copy of the data 269 | ! Note: 270 | ! A direct call to this routine will look something like: 271 | ! 272 | ! call tree_put_data( tree, transfer( some_data, node_value ) ) 273 | ! 274 | ! where node_value acts as the mold for transferring the data 275 | ! 276 | subroutine tree_put_data( tree, data, data_type, success ) 277 | type(TREE_DATA), pointer :: tree 278 | character(len=1), dimension(:) :: data 279 | character(len=*), optional :: data_type 280 | logical, intent(out), optional :: success 281 | 282 | integer :: error 283 | 284 | if ( associated(tree%node_data) ) then 285 | deallocate( tree%node_data ) 286 | endif 287 | 288 | if ( associated(tree%node_data_type) ) then 289 | deallocate( tree%node_data_type ) 290 | endif 291 | 292 | allocate( tree%node_data(1:size(data)), stat = error ) 293 | if ( error .eq. 0 ) then 294 | tree%node_data = data 295 | allocate( tree%node_data_type(1:len_trim(data_type)), & 296 | stat = error ) 297 | if ( error .eq. 0 ) then 298 | tree%node_data_type = transfer( data_type, tree%node_data_type ) 299 | endif 300 | endif 301 | 302 | if ( present( success ) ) then 303 | success = error .eq. 0 304 | endif 305 | 306 | end subroutine tree_put_data 307 | 308 | ! tree_traverse_level -- 309 | ! Convenience function: level of the node during traversal 310 | ! 311 | ! Arguments: 312 | ! None 313 | ! 314 | ! Note: 315 | ! Functions without arguments can be optimised away! 316 | ! I should turn this into a subroutine instead 317 | ! 318 | integer function tree_traverse_level( ) 319 | tree_traverse_level = traverse_level 320 | end function tree_traverse_level 321 | 322 | ! tree_traverse -- 323 | ! Traverse a tree and handle the nodes by a depth-first method 324 | ! 325 | ! Arguments: 326 | ! tree The tree or node to traverse 327 | ! handler Routine to handle each node 328 | ! data Arbitrary data to be passed to the handler 329 | ! stop Whether to continue or stop (if set true) 330 | ! Result: 331 | ! Each tree node is visited (unless the traversal is 332 | ! prematurely ended by setting "stop" to true) 333 | ! 334 | recursive subroutine tree_traverse( tree, handler, data, stop ) 335 | type(TREE_DATA), pointer :: tree 336 | character(len=1), dimension(:) :: data 337 | logical, intent(out) :: stop 338 | 339 | interface 340 | subroutine handler( node, data, stop ) 341 | use TREE_DATA_TYPES 342 | type(TREE_DATA), pointer :: node 343 | character(len=1), dimension(:) :: data 344 | logical, intent(inout) :: stop 345 | end subroutine handler 346 | end interface 347 | 348 | integer :: i 349 | 350 | stop = .false. 351 | if ( .not. associated( tree ) ) then 352 | return 353 | endif 354 | 355 | ! 356 | ! First call the handler for the current node/tree 357 | ! 358 | call handler( tree, data, stop ) 359 | if ( stop ) then 360 | return 361 | endif 362 | 363 | ! 364 | ! Then recurse through the child nodes (if any) 365 | ! 366 | if ( associated( tree%child_nodes) ) then 367 | do i = 1,size(tree%child_nodes) 368 | traverse_level = traverse_level + 1 369 | call tree_traverse( tree%child_nodes(i)%node_ptr, & 370 | handler, data, stop ) 371 | traverse_level = traverse_level - 1 372 | if ( stop ) then 373 | exit 374 | endif 375 | enddo 376 | endif 377 | 378 | end subroutine tree_traverse 379 | 380 | ! tree_get_data_string -- 381 | ! Return data as a simple string 382 | ! 383 | ! Arguments: 384 | ! tree The tree or node from which to get the data 385 | ! string String to be filled 386 | ! success Whether successful or not 387 | ! Result: 388 | ! The string is filled with the data stored in the node 389 | ! not associated. The routine is successful if: 390 | ! - there is data associated with the node/tree 391 | ! - the data type is "STRING" or "ATTRIBUTE" 392 | ! If the routine is not successful, the string is 393 | ! not changed. 394 | ! 395 | subroutine tree_get_data_string( tree, string, success ) 396 | type(TREE_DATA), pointer :: tree 397 | character(len=*), intent(inout) :: string 398 | logical, intent(out) :: success 399 | 400 | character(len=1), dimension(:), pointer :: data_ptr 401 | character(len=40) :: data_type 402 | integer :: length 403 | 404 | success = .false. 405 | if ( associated(tree) ) then 406 | call tree_get_data_ptr( tree, data_ptr, data_type ) 407 | 408 | if ( .not. associated(data_ptr) ) then 409 | return 410 | endif 411 | if ( data_type .ne. 'STRING' .and. data_type .ne. 'ATTRIBUTE' ) then 412 | return 413 | endif 414 | 415 | success = .true. 416 | length = size(data_ptr) 417 | string = ' ' 418 | string(1:length) = transfer(data_ptr,string) 419 | endif 420 | 421 | end subroutine tree_get_data_string 422 | 423 | include 'tree_find.f90' 424 | 425 | end module TREE_STRUCTURES 426 | 427 | 428 | ! =================================================================== 429 | ! Put it to the test 430 | ! 431 | program test_tree 432 | use TREE_STRUCTURES 433 | 434 | implicit none 435 | type(TREE_DATA), pointer :: tree 436 | type(TREE_DATA), pointer :: node1, node2, node3 437 | 438 | character(len=1), dimension(1) :: dummy 439 | character(len=1), dimension(:), pointer :: data_ptr 440 | character(len=40) :: node_name, node_type, stored_data, type 441 | character(len=40) :: string, name 442 | 443 | logical :: stop 444 | logical :: success 445 | 446 | character(len=80) :: path 447 | character(len=80) :: segment 448 | integer :: i, j 449 | type(TREE_DATA_PTR), dimension(:), pointer :: all_handles 450 | type(TREE_DATA_PTR), dimension(:), pointer :: handles 451 | integer :: status 452 | 453 | interface 454 | subroutine handler( tree, data, stop ) 455 | use TREE_STRUCTURES 456 | type(TREE_DATA), pointer :: tree 457 | character(len=1), dimension(:) :: data 458 | logical, intent(inout) :: stop 459 | end subroutine handler 460 | end interface 461 | 462 | ! 463 | ! TREE: 464 | ! NODE A (data: STORED A) 465 | ! NODE C (data: AC) 466 | ! NODE D (data: AD) 467 | ! NODE B (data: --) 468 | ! NODE C (data: BC1) 469 | ! NODE D (data: BCD1) 470 | ! NODE C (data: BC2) 471 | ! NODE C (data: BC3) 472 | ! NODE D (data: --) 473 | ! 474 | 475 | call tree_create( "TREE", tree ) 476 | 477 | call tree_create_node( tree, "NODE A", node1 ) 478 | call tree_put_data( node1, transfer("STORED A",node_value), "STRING" ) 479 | 480 | call tree_create_node( node1, "NODE C", node2 ) 481 | call tree_put_data( node2, transfer("AC",node_value), "STRING" ) 482 | call tree_create_node( node1, "NODE D", node2 ) 483 | call tree_put_data( node2, transfer("AD",node_value), "STRING" ) 484 | 485 | call tree_create_node( tree, "NODE B", node1 ) 486 | 487 | call tree_create_node( node1, "NODE C", node3 ) 488 | call tree_put_data( node3, transfer("BC1",node_value), "STRING" ) 489 | call tree_create_node( node1, "NODE C", node2 ) 490 | call tree_put_data( node2, transfer("BC2",node_value), "STRING" ) 491 | call tree_create_node( node1, "NODE C", node2 ) 492 | call tree_put_data( node2, transfer("BC3",node_value), "STRING" ) 493 | 494 | call tree_create_node( node3, "NODE D", node2 ) 495 | call tree_put_data( node2, transfer("BCD1",node_value), "STRING" ) 496 | 497 | call tree_create_node( tree, "NODE D", node1 ) 498 | 499 | call tree_get_node_by_name( tree, "NODE A", node1 ) 500 | call tree_get_data_ptr( node1, data_ptr, type ) 501 | stored_data = transfer( data_ptr, stored_data ) 502 | write(*,*) 'NODE A:', stored_data 503 | 504 | call tree_get_node_by_name( tree, "NODE B", node1 ) 505 | call tree_get_data_ptr( node1, data_ptr, type ) 506 | if ( associated( data_ptr ) ) then 507 | stored_data = transfer( data_ptr, stored_data ) 508 | write(*,*) 'NODE B:', stored_data 509 | else 510 | write(*,*) 'NODE B - no data' 511 | endif 512 | 513 | call tree_get_node_by_name( node1, "NODE C", node2 ) 514 | call tree_get_data_ptr( node2, data_ptr, type ) 515 | stored_data = transfer( data_ptr, stored_data ) 516 | write(*,*) 'NODE C:', stored_data 517 | 518 | write(*,*) ' ' 519 | write(*,*) 'Traverse the tree:' 520 | 521 | call tree_traverse( tree, handler, dummy, stop ) 522 | 523 | 524 | path = '//A/B/C///D' 525 | do while ( path /= ' ' ) 526 | call tree_next_segment( path, segment ) 527 | write(*,*) 'path: >',trim(path),'<' 528 | write(*,*) 'segment: >',trim(segment),'<' 529 | enddo 530 | 531 | ! 532 | ! allocate( all_handles(1:0), stat=status ) ! A zero-length array! 533 | ! 534 | ! write(*,*) 'Status: ', status 535 | ! allocate( handles(1:10) ) 536 | ! handles(1:10) = (/ (i, i=1,10) /) 537 | ! call tree_append_handles( all_handles, handles ) 538 | ! write(*,*) 'First step: ', all_handles 539 | ! call tree_append_handles( all_handles, handles ) 540 | ! write(*,*) 'Second step: ', all_handles 541 | 542 | ! 543 | ! 1. Find all nodes "A" - just one 544 | ! 2. Find all nodes "C" - four 545 | ! 3. Find all nodes "A/C" - just one 546 | ! 4. Find all nodes "B/C" - three 547 | ! 548 | do i = 1,4 549 | select case (i) 550 | case (1) 551 | path = "NODE A" 552 | case (2) 553 | path = "NODE C" 554 | case (3) 555 | path = "NODE A/NODE C" 556 | case (4) 557 | path = "NODE B/NODE C" 558 | end select 559 | call tree_find( tree, path, handles ) 560 | write(*,*) 'Path: ',trim(path) 561 | do j = 1,size(handles) 562 | name = tree_get_name( handles(j)%node_ptr ) 563 | call tree_get_data_string( handles(j)%node_ptr, string, success ) 564 | write(*,*) 'Name: ', name, ' - ',trim(string) 565 | enddo 566 | enddo 567 | 568 | end program 569 | 570 | subroutine handler( tree, data, stop ) 571 | use TREE_STRUCTURES 572 | type(TREE_DATA), pointer :: tree 573 | character(len=1), dimension(:) :: data 574 | logical, intent(inout) :: stop 575 | 576 | character(len=1), dimension(:),pointer :: data_ptr 577 | character(len=60) :: string 578 | character(len=20) :: type_string 579 | 580 | integer :: level 581 | integer :: i 582 | logical :: success 583 | 584 | level = tree_traverse_level() 585 | 586 | write(*,*) (' ', i=1,level), 'Node: ', trim(tree_get_name(tree)) 587 | call tree_get_data_ptr( tree, data_ptr, type_string ) 588 | 589 | string = '(no data)' 590 | 591 | call tree_get_data_string( tree, string, success ) 592 | write(*,*) (' ', i=1,level+1), trim(string), ' -- ', & 593 | trim(type_string), ' -- ', success 594 | 595 | end subroutine handler 596 | -------------------------------------------------------------------------------- /src/tst_prims.f90: -------------------------------------------------------------------------------- 1 | ! tst_prims.f90 - Test program for reading the primitive data 2 | ! 3 | ! $Id: tst_prims.f90,v 1.2 2006/03/26 19:05:48 arjenmarkus Exp $ 4 | ! 5 | ! Arjen Markus 6 | ! 7 | ! General information: 8 | ! This program tests the data reading routines in 9 | ! read_xml_prims.f90 10 | ! To avoid editing the private/public clauses in the 11 | ! module I have copied the code in here. 12 | ! 13 | program tst_prims 14 | 15 | character(len=20) :: buffer 16 | integer, dimension(:), pointer :: var 17 | integer :: ierror 18 | integer :: nofail 19 | 20 | ! 21 | ! Tests: correct numbers returned? 22 | ! 1. Empty string, size(var) = 0 23 | ! 2. One value, size(var) = 1 24 | ! 3. Four values, size(var) = 4 25 | ! 4. Five values, size(var) = 5 26 | ! 5. Invalid data, ierror /= 0 27 | ! 28 | nofail = 0 29 | var => null() 30 | 31 | buffer = ' ' 32 | call read_from_buffer_integers( buffer, var, ierror ) 33 | if ( size(var) /= 0 .or. ierror /= 0 ) then 34 | write(*,*) 'Test 1 failed - expected:' 35 | write(*,*) 'Size: ', 0, ' - got:', size(var) 36 | write(*,*) 'Error:', 0, ' - got:', ierror 37 | nofail = nofail+1 38 | endif 39 | 40 | buffer = ' 1 ' 41 | call read_from_buffer_integers( buffer, var, ierror ) 42 | if ( size(var) /= 1 .or. ierror /= 0 ) then 43 | write(*,*) 'Test 2 failed - expected:' 44 | write(*,*) 'Size: ', 2, ' - got:', size(var) 45 | write(*,*) 'Error:', 0, ' - got:', ierror 46 | write(*,*) 'Values:', var 47 | nofail = nofail+1 48 | endif 49 | 50 | buffer = ' 1 2 3 4 ' 51 | call read_from_buffer_integers( buffer, var, ierror ) 52 | if ( size(var) /= 4 .or. ierror /= 0 ) then 53 | write(*,*) 'Test 3 failed - expected:' 54 | write(*,*) 'Size: ', 4, ' - got:', size(var) 55 | write(*,*) 'Error:', 0, ' - got:', ierror 56 | write(*,*) 'Values:', var 57 | nofail = nofail+1 58 | endif 59 | 60 | buffer = ' 1 2 3 4 5 ' 61 | call read_from_buffer_integers( buffer, var, ierror ) 62 | if ( size(var) /= 5 .or. ierror /= 0 ) then 63 | write(*,*) 'Test 4 failed - expected:' 64 | write(*,*) 'Size: ', 5, ' - got:', size(var) 65 | write(*,*) 'Error:', 0, ' - got:', ierror 66 | write(*,*) 'Values:', var 67 | nofail = nofail+1 68 | endif 69 | 70 | buffer = ' 1 A 3 4 5 ' 71 | call read_from_buffer_integers( buffer, var, ierror ) 72 | if ( size(var) /= 1 .or. ierror == 0 ) then 73 | write(*,*) 'Test 5 failed - expected:' 74 | write(*,*) 'Size: ', 1, ' - got:', size(var) 75 | write(*,*) 'Error:', '/= 0', ' - got:', ierror 76 | write(*,*) 'Values:', var 77 | nofail = nofail+1 78 | endif 79 | 80 | if ( nofail == 0 ) then 81 | write(*,*) 'All tests succeeded' 82 | endif 83 | contains 84 | 85 | ! read_from_buffer_integers -- 86 | ! Routine to read all integers from a long string 87 | ! 88 | ! Arguments: 89 | ! buffer String containing the data 90 | ! var Variable to be filled 91 | ! ierror Error flag 92 | ! 93 | subroutine read_from_buffer_integers( buffer, var, ierror ) 94 | character(len=*), intent(in) :: buffer 95 | integer, dimension(:), pointer :: var 96 | integer, intent(inout) :: ierror 97 | 98 | integer, dimension(:), pointer :: work 99 | integer :: n 100 | integer :: i 101 | integer :: step 102 | integer :: ierr 103 | ! 104 | ! First allocate an array that is surely large enough 105 | ! Note: 106 | ! This is not completely failsafe: with list-directed 107 | ! input you can also use repeat counts (10000*1.0 for 108 | ! instance). 109 | ! 110 | allocate( work(len(buffer)/2+1) ) 111 | 112 | ! 113 | ! NOTE: 114 | ! This is not portable!! 115 | ! 116 | ! read( buffer, *, iostat = ierror ) (work(n), n=1,size(work)) 117 | ! 118 | ! So, use a different strategy: a binary search 119 | ! First: establish that we have at least one item to read 120 | ! Second: do the binary search 121 | ! 122 | n = 1 123 | do while ( n <= size(work) ) 124 | n = 2 * n 125 | enddo 126 | n = n / 2 127 | step = n / 2 128 | 129 | do while ( step > 0 ) 130 | read( buffer, *, iostat = ierr ) (work(i), i = 1,n) 131 | if ( ierr /= 0 ) then 132 | ierror = ierr ! Store the error code for later use 133 | n = n - step 134 | else 135 | n = n + step 136 | endif 137 | step = step / 2 138 | enddo 139 | 140 | ! 141 | ! Then allocate an array of the actual size needed 142 | ! and copy the data 143 | ! 144 | ! 145 | if ( associated( var ) ) then 146 | deallocate( var ) 147 | endif 148 | ! 149 | ! One complication: we may have one too many 150 | ! (consequence of the binary search) 151 | ! 152 | read( buffer, *, iostat = ierr ) (work(i), i = 1,n) 153 | if ( ierr < 0 ) then 154 | n = n - 1 155 | endif 156 | 157 | allocate( var(n) ) 158 | var(1:n) = work(1:n) 159 | deallocate( work ) 160 | 161 | if ( ierror .lt. 0 ) then 162 | ierror = 0 163 | endif 164 | end subroutine read_from_buffer_integers 165 | 166 | end program 167 | -------------------------------------------------------------------------------- /src/tstparse.f90: -------------------------------------------------------------------------------- 1 | ! Test program for the module "XMLPARSE" 2 | ! Read a set of sample XML-files and report the 3 | ! possible failure to the screen 4 | ! 5 | ! $Id: tstparse.f90,v 1.3 2006/03/26 19:05:48 arjenmarkus Exp $ 6 | ! 7 | ! Per test case read: 8 | ! - The title 9 | ! - The XML file to be 10 | ! - The expected parse data: 11 | ! - which tags and the attributes that belong to them 12 | ! - which data lines 13 | ! 14 | ! If the XML file was read but the actually reported data did 15 | ! not match the expected ones, then the title of the test 16 | ! case is printed on screen. 17 | ! 18 | ! So, a successful test does not produce output. 19 | ! 20 | ! The test cases are defined in a file "tstpars.inp" 21 | ! which has the following format: 22 | ! - Title line 23 | ! - A line which starts with "-----" 24 | ! - The contents of the XML file 25 | ! - Another line with "-----" 26 | ! - Lines with keywords (in order) that define what 27 | ! tags, attributes and data to expect: 28 | ! tag: string 29 | ! endtag: T/F 30 | ! attribute: A=B 31 | ! data: string 32 | ! - Another line with "-----" to separate it from the 33 | ! next case 34 | ! - Lines with "#" in the first column are considered 35 | ! comment and are therefore ignored 36 | ! 37 | program tstparse 38 | 39 | use xmlparse 40 | 41 | implicit none 42 | 43 | character(len=60) :: title 44 | character(len=80) :: string 45 | logical :: has_title 46 | integer :: ierr 47 | 48 | 49 | ! 50 | ! Start the loop 51 | ! 52 | open( 10, file = 'tstparse.inp', status = 'old' ) 53 | open( 20, file = 'tstparse.out' ) 54 | 55 | has_title = .false. 56 | 57 | do while ( ierr .eq. 0 ) 58 | read( 10, '(a)', iostat = ierr ) string 59 | ! 60 | ! End of file or some error condition 61 | ! 62 | if ( ierr .ne. 0 ) then 63 | exit 64 | endif 65 | ! 66 | ! Skip comments 67 | ! 68 | if ( string(1:1) .eq. '#' ) then 69 | cycle 70 | endif 71 | ! 72 | ! Store the title and start reading the XML data 73 | ! 74 | if ( .not. has_title ) then 75 | title = string 76 | has_title = .true. 77 | endif 78 | if ( has_title .and. string(1:5) .eq. '-----' ) then 79 | open( 30, file = 'tstparse.xml' ) 80 | do 81 | read( 10, '(a)', iostat = ierr ) string 82 | if ( ierr .ne. 0 ) then 83 | exit 84 | endif 85 | if ( string(1:5) .eq. '-----' ) then 86 | exit 87 | endif 88 | write( 30, '(a)' ) string 89 | enddo 90 | 91 | ! 92 | ! Now we are ready to read the XML file 93 | ! and analyse the report 94 | ! 95 | close( 30 ) 96 | call check_xml_file 97 | endif 98 | enddo 99 | 100 | contains 101 | 102 | subroutine check_xml_file 103 | logical :: mustread 104 | type(XML_PARSE) :: info 105 | 106 | character(len=80) :: tag 107 | logical :: endtag 108 | character(len=80), dimension(1:2,1:20) :: attribs 109 | integer :: no_attribs 110 | character(len=200), dimension(1:100) :: data 111 | integer :: no_data 112 | integer :: i 113 | 114 | call xml_open( info, 'tstparse.xml', .true. ) 115 | call xml_options( info, report_lun = 20, report_details = .true. ) 116 | 117 | do 118 | call xml_get( info, tag, endtag, attribs, no_attribs, data, no_data ) 119 | if ( xml_error(info) ) then 120 | write(*,*) 'Error ', title 121 | write(20,*) 'Error ', title 122 | endif 123 | 124 | write( 20,* ) tag, endtag 125 | do i = 1,no_attribs 126 | write( 20,'(i3,1x,3a)') & 127 | i, trim(attribs(1,i)), '=', trim(attribs(2,i)) 128 | enddo 129 | write( 20,'(i3,1x,3a)') (i, '>',trim(data(i)), '<', i=1,no_data) 130 | if ( .not. xml_ok(info) ) exit 131 | enddo 132 | 133 | do 134 | read(10,'(a)' ) string 135 | if ( string(1:5) .eq. '-----' ) then 136 | exit 137 | endif 138 | enddo 139 | 140 | call xml_close( info ) 141 | 142 | end subroutine check_xml_file 143 | end program tstparse 144 | -------------------------------------------------------------------------------- /src/tstparse.inp: -------------------------------------------------------------------------------- 1 | Check first tag: no attributes 2 | -------------------------------- 3 | 4 | Some data 5 | 6 | -------------------------------- 7 | tag: first-tag 8 | endtag: F 9 | data: 10 | data: Some data 11 | data: 12 | tag: first-tag 13 | endtag: T 14 | -------------------------------- 15 | Check tag with embedded / 16 | -------------------------------- 17 | 18 | Some data 19 | 20 | -------------------------------- 21 | tag: first-tag 22 | endtag: F 23 | attribute: value=m/s 24 | data: 25 | data: Some data 26 | data: 27 | tag: first-tag 28 | endtag: T 29 | -------------------------------- 30 | Multiple tags on one line 31 | -------------------------------- 32 | 33 | -------------------------------- 34 | tag: tag1 35 | endtag: T 36 | attribute: value=a 37 | data: 38 | tag: tag2 39 | endtag: T 40 | attribute: value=b 41 | -------------------------------- 42 | Data with "entities" 43 | -------------------------------- 44 | ampersand & 45 | greater than >lower than < 46 | 47 | -------------------------------- 48 | tag: tag1 49 | endtag: F 50 | data: ampersand & 51 | data: greater than >lower than < 52 | tag: tag1 53 | endtag: T 54 | -------------------------------- 55 | Data directly after tag - ERROR! 56 | -------------------------------- 57 | ampersand 58 | -------------------------------- 59 | tag: tag1 60 | endtag: F 61 | data: ampersand 62 | tag: tag1 63 | endtag: T 64 | -------------------------------- 65 | Comments containing an equal-sign 66 | -------------------------------- 67 | ampersand 68 | 70 | last tag 71 | -------------------------------- 72 | tag: tag1 73 | endtag: F 74 | data: ampersand 75 | tag: tag1 76 | endtag: T 77 | tag: !-- 78 | data: This = true 79 | endtag: F 80 | tag: -- 81 | endtag: T 82 | tag: tag2 83 | data: last tag 84 | endtag: F 85 | tag: tag2 86 | endtag: T 87 | -------------------------------- 88 | -------------------------------------------------------------------------------- /src/write_xml_primitives.f90: -------------------------------------------------------------------------------- 1 | ! write_xml_prims.f90 - Write routines for primitive data 2 | ! 3 | ! $Id: write_xml_prims.f90,v 1.2 2007/12/27 05:13:59 arjenmarkus Exp $ 4 | ! 5 | ! Arjen Markus 6 | ! 7 | ! General information: 8 | ! This module is part of the XML-Fortran library. Its 9 | ! purpose is to write individual items to an XML 10 | ! file using the right tag. It is used by the code generated 11 | ! by the make_xml_reader program. 12 | ! 13 | module write_xml_primitives 14 | use xmlparse 15 | implicit none 16 | 17 | ! interface write_to_xml 18 | ! module procedure write_to_xml_integers 19 | ! module procedure write_to_xml_reals 20 | ! module procedure write_to_xml_doubles 21 | ! module procedure write_to_xml_logicals 22 | ! module procedure write_to_xml_words 23 | ! end interface 24 | interface write_to_xml_word 25 | module procedure write_to_xml_string 26 | end interface 27 | interface write_to_xml_line 28 | module procedure write_to_xml_string 29 | end interface 30 | 31 | contains 32 | 33 | ! write_to_xml_integer -- 34 | ! Routine to write a single integer to the XML file 35 | ! 36 | ! Arguments: 37 | ! info XML parser structure 38 | ! tag The tag in question 39 | ! indent Number of spaces for indentation 40 | ! value Value to be written 41 | ! 42 | subroutine write_to_xml_integer( info, tag, indent, value ) 43 | type(XML_PARSE), intent(in) :: info 44 | character(len=*), intent(in) :: tag 45 | integer, intent(in) :: indent 46 | integer, intent(in) :: value 47 | 48 | character(len=100) :: indentation 49 | 50 | indentation = ' ' 51 | write( info%lun, '(4a,i0,3a)' ) indentation(1:min(indent,100)), & 52 | '<', trim(tag), '>', value, '' 53 | 54 | end subroutine write_to_xml_integer 55 | 56 | ! write_to_xml_integer_1dim -- 57 | ! Routine to write an array of integers to the XML file 58 | ! 59 | ! Arguments: 60 | ! info XML parser structure 61 | ! tag The tag in question 62 | ! indent Number of spaces for indentation 63 | ! values Values to be written 64 | ! 65 | subroutine write_to_xml_integer_1dim( info, tag, indent, values ) 66 | type(XML_PARSE), intent(in) :: info 67 | character(len=*), intent(in) :: tag 68 | integer, intent(in) :: indent 69 | integer, dimension(:), intent(in) :: values 70 | 71 | integer :: i 72 | 73 | do i = 1,size(values) 74 | call write_to_xml_integer( info, tag, indent, values(i) ) 75 | enddo 76 | 77 | end subroutine write_to_xml_integer_1dim 78 | 79 | ! write_to_xml_real -- 80 | ! Routine to write a single real value (single precision) to the XML file 81 | ! 82 | ! Arguments: 83 | ! info XML parser structure 84 | ! tag The tag in question 85 | ! indent Number of spaces for indentation 86 | ! value Value to be written 87 | ! 88 | subroutine write_to_xml_real( info, tag, indent, value ) 89 | type(XML_PARSE), intent(in) :: info 90 | character(len=*), intent(in) :: tag 91 | integer, intent(in) :: indent 92 | real, intent(in) :: value 93 | 94 | character(len=100) :: indentation 95 | character(len=12) :: buffer 96 | 97 | indentation = ' ' 98 | write( buffer, '(1pg12.4)' ) value 99 | write( info%lun, '(8a)' ) indentation(1:min(indent,100)), & 100 | '<', trim(tag), '>', trim(adjustl(buffer)), '' 101 | 102 | end subroutine write_to_xml_real 103 | 104 | ! write_to_xml_real_1dim -- 105 | ! Routine to write an array of reals to the XML file 106 | ! 107 | ! Arguments: 108 | ! info XML parser structure 109 | ! tag The tag in question 110 | ! indent Number of spaces for indentation 111 | ! values Values to be written 112 | ! 113 | subroutine write_to_xml_real_1dim( info, tag, indent, values ) 114 | type(XML_PARSE), intent(in) :: info 115 | character(len=*), intent(in) :: tag 116 | integer, intent(in) :: indent 117 | real, dimension(:), intent(in) :: values 118 | 119 | integer :: i 120 | 121 | do i = 1,size(values) 122 | call write_to_xml_real( info, tag, indent, values(i) ) 123 | enddo 124 | 125 | end subroutine write_to_xml_real_1dim 126 | 127 | ! write_to_xml_double -- 128 | ! Routine to write one real value (double precision) to the XML file 129 | ! 130 | ! Arguments: 131 | ! info XML parser structure 132 | ! tag The tag in question 133 | ! indent Number of spaces for indentation 134 | ! value Value to be written 135 | ! 136 | subroutine write_to_xml_double( info, tag, indent, value ) 137 | type(XML_PARSE), intent(in) :: info 138 | character(len=*), intent(in) :: tag 139 | integer, intent(in) :: indent 140 | real(kind=kind(1.0d0)), intent(in) :: value 141 | 142 | character(len=100) :: indentation 143 | character(len=16) :: buffer 144 | 145 | indentation = ' ' 146 | write( buffer, '(1pg16.7)' ) value 147 | write( info%lun, '(8a)' ) indentation(1:min(indent,100)), & 148 | '<', trim(tag), '>', trim(adjustl(buffer)), '' 149 | 150 | end subroutine write_to_xml_double 151 | 152 | ! write_to_xml_double_1dim -- 153 | ! Routine to write an array of double precision reals to the XML file 154 | ! 155 | ! Arguments: 156 | ! info XML parser structure 157 | ! tag The tag in question 158 | ! indent Number of spaces for indentation 159 | ! values Values to be written 160 | ! 161 | subroutine write_to_xml_double_1dim( info, tag, indent, values ) 162 | type(XML_PARSE), intent(in) :: info 163 | character(len=*), intent(in) :: tag 164 | integer, intent(in) :: indent 165 | real(kind=kind(1.0d00)), dimension(:), intent(in) :: values 166 | 167 | integer :: i 168 | 169 | do i = 1,size(values) 170 | call write_to_xml_double( info, tag, indent, values(i) ) 171 | enddo 172 | 173 | end subroutine write_to_xml_double_1dim 174 | 175 | ! write_to_xml_string -- 176 | ! Routine to write one string to the XML file 177 | ! 178 | ! Arguments: 179 | ! info XML parser structure 180 | ! tag The tag in question 181 | ! indent Number of spaces for indentation 182 | ! value Value to be written 183 | ! 184 | subroutine write_to_xml_string( info, tag, indent, value ) 185 | type(XML_PARSE), intent(in) :: info 186 | character(len=*), intent(in) :: tag 187 | integer, intent(in) :: indent 188 | character(len=*), intent(in) :: value 189 | 190 | character(len=100) :: indentation 191 | 192 | ! 193 | ! NOTE: No guards against <, >, & and " yet! 194 | ! NOTE: difference needed between words and lines? 195 | ! 196 | indentation = ' ' 197 | write( info%lun, '(8a)' ) indentation(1:min(indent,100)), & 198 | '<', trim(tag), '>', trim(value), '' 199 | 200 | end subroutine write_to_xml_string 201 | 202 | ! write_to_xml_word_1dim -- 203 | ! Routine to write an array of single words to the XML file 204 | ! 205 | ! Arguments: 206 | ! info XML parser structure 207 | ! tag The tag in question 208 | ! indent Number of spaces for indentation 209 | ! value Value to be written 210 | ! 211 | subroutine write_to_xml_word_1dim( info, tag, indent, values ) 212 | type(XML_PARSE), intent(in) :: info 213 | character(len=*), intent(in) :: tag 214 | integer, intent(in) :: indent 215 | character(len=*), dimension(:), intent(in) :: values 216 | 217 | integer :: i 218 | 219 | do i = 1,size(values) 220 | call write_to_xml_string( info, tag, indent, values(i) ) 221 | enddo 222 | end subroutine write_to_xml_word_1dim 223 | 224 | ! write_to_xml_string_1dim -- 225 | ! Routine to write an array of strings to the XML file 226 | ! 227 | ! Arguments: 228 | ! info XML parser structure 229 | ! tag The tag in question 230 | ! indent Number of spaces for indentation 231 | ! values Values to be written 232 | ! 233 | subroutine write_to_xml_string_1dim( info, tag, indent, values ) 234 | type(XML_PARSE), intent(in) :: info 235 | character(len=*), intent(in) :: tag 236 | integer, intent(in) :: indent 237 | character(len=*), dimension(:), intent(in) :: values 238 | 239 | integer :: i 240 | 241 | do i = 1,size(values) 242 | call write_to_xml_string( info, tag, indent, values(i) ) 243 | enddo 244 | 245 | end subroutine write_to_xml_string_1dim 246 | 247 | ! write_to_xml_logical -- 248 | ! Routine to write one logical to the XML file 249 | ! 250 | ! Arguments: 251 | ! info XML parser structure 252 | ! tag The tag in question 253 | ! indent Number of spaces for indentation 254 | ! value Value to be written 255 | ! 256 | subroutine write_to_xml_logical( info, tag, indent, value ) 257 | type(XML_PARSE), intent(in) :: info 258 | character(len=*), intent(in) :: tag 259 | integer, intent(in) :: indent 260 | logical, intent(in) :: value 261 | 262 | character(len=100) :: indentation 263 | 264 | indentation = ' ' 265 | if ( value ) then 266 | write( info%lun, '(8a)' ) indentation(1:min(indent,100)), & 267 | '<', trim(tag), '>true' 268 | else 269 | write( info%lun, '(8a)' ) indentation(1:min(indent,100)), & 270 | '<', trim(tag), '>false' 271 | endif 272 | 273 | end subroutine write_to_xml_logical 274 | 275 | ! write_to_xml_logical_1dim -- 276 | ! Routine to write an array of logicals to the XML file 277 | ! 278 | ! Arguments: 279 | ! info XML parser structure 280 | ! tag The tag in question 281 | ! indent Number of spaces for indentation 282 | ! values Values to be written 283 | ! 284 | subroutine write_to_xml_logical_1dim( info, tag, indent, values ) 285 | type(XML_PARSE), intent(in) :: info 286 | character(len=*), intent(in) :: tag 287 | integer, intent(in) :: indent 288 | logical, dimension(:), intent(in) :: values 289 | 290 | integer :: i 291 | 292 | do i = 1,size(values) 293 | call write_to_xml_logical( info, tag, indent, values(i) ) 294 | enddo 295 | 296 | end subroutine write_to_xml_logical_1dim 297 | 298 | ! write_to_xml_integer_array -- 299 | ! Routine to write an array of integers to the XML file 300 | ! 301 | ! Arguments: 302 | ! info XML parser structure 303 | ! tag The tag in question 304 | ! indent Number of spaces for indentation 305 | ! array Values to be written 306 | ! 307 | subroutine write_to_xml_integer_array( info, tag, indent, array ) 308 | type(XML_PARSE), intent(in) :: info 309 | character(len=*), intent(in) :: tag 310 | integer, intent(in) :: indent 311 | integer, dimension(:), intent(in) :: array 312 | 313 | character(len=100) :: indentation 314 | integer :: i, i2, j 315 | 316 | indentation = ' ' 317 | 318 | write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & 319 | '<', trim(tag), '>' 320 | do i = 1,size(array),10 321 | i2 = min( i + 9, size(array) ) 322 | write( info%lun, '(a,10i12)' ) indentation(1:min(indent+4,100)), & 323 | ( array(j) ,j = i,i2 ) 324 | enddo 325 | write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & 326 | '' 327 | 328 | end subroutine write_to_xml_integer_array 329 | 330 | ! write_to_xml_real_array -- 331 | ! Routine to write an array of single precision reals to the XML file 332 | ! 333 | ! Arguments: 334 | ! info XML parser structure 335 | ! tag The tag in question 336 | ! indent Number of spaces for indentation 337 | ! array Values to be written 338 | ! 339 | subroutine write_to_xml_real_array( info, tag, indent, array ) 340 | type(XML_PARSE), intent(in) :: info 341 | character(len=*), intent(in) :: tag 342 | integer, intent(in) :: indent 343 | real, dimension(:), intent(in) :: array 344 | 345 | character(len=100) :: indentation 346 | integer :: i, i2, j 347 | 348 | indentation = ' ' 349 | 350 | write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & 351 | '<', trim(tag), '>' 352 | do i = 1,size(array),10 353 | i2 = min( i + 9, size(array) ) 354 | write( info%lun, '(a,10g12.4)' ) indentation(1:min(indent+4,100)), & 355 | ( array(j) ,j = i,i2 ) 356 | enddo 357 | write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & 358 | '' 359 | 360 | end subroutine write_to_xml_real_array 361 | 362 | ! write_to_xml_double_array -- 363 | ! Routine to write an array of double precision reals to the XML file 364 | ! 365 | ! Arguments: 366 | ! info XML parser structure 367 | ! tag The tag in question 368 | ! indent Number of spaces for indentation 369 | ! array Values to be written 370 | ! 371 | subroutine write_to_xml_double_array( info, tag, indent, array ) 372 | type(XML_PARSE), intent(in) :: info 373 | character(len=*), intent(in) :: tag 374 | integer, intent(in) :: indent 375 | real(kind=kind(1.0d0)), dimension(:), intent(in) :: array 376 | 377 | character(len=100) :: indentation 378 | integer :: i, i2, j 379 | 380 | indentation = ' ' 381 | 382 | write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & 383 | '<', trim(tag), '>' 384 | do i = 1,size(array),5 385 | i2 = min( i + 4, size(array) ) 386 | write( info%lun, '(a,5g20.7)' ) indentation(1:min(indent+4,100)), & 387 | ( array(j) ,j = i,i2 ) 388 | enddo 389 | write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & 390 | '' 391 | 392 | end subroutine write_to_xml_double_array 393 | 394 | ! write_to_xml_logical_array -- 395 | ! Routine to write an array of logicals to the XML file 396 | ! 397 | ! Arguments: 398 | ! info XML parser structure 399 | ! tag The tag in question 400 | ! indent Number of spaces for indentation 401 | ! array Values to be written 402 | ! 403 | subroutine write_to_xml_logical_array( info, tag, indent, array ) 404 | type(XML_PARSE), intent(in) :: info 405 | character(len=*), intent(in) :: tag 406 | integer, intent(in) :: indent 407 | logical, dimension(:), intent(in) :: array 408 | 409 | character(len=100) :: indentation 410 | integer :: i, i2, j 411 | 412 | indentation = ' ' 413 | 414 | write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & 415 | '<', trim(tag), '>' 416 | do i = 1,size(array),10 417 | i2 = min( i + 9, size(array) ) 418 | write( info%lun, '(a,10a)' ) indentation(1:min(indent+4,100)), & 419 | ( merge('true ', 'false ', array(j)) ,j = i,i2 ) 420 | enddo 421 | write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & 422 | '' 423 | 424 | end subroutine write_to_xml_logical_array 425 | 426 | ! write_to_xml_word_array -- 427 | ! Routine to write an array of words to the XML file 428 | ! 429 | ! Arguments: 430 | ! info XML parser structure 431 | ! tag The tag in question 432 | ! indent Number of spaces for indentation 433 | ! array Values to be written 434 | ! 435 | subroutine write_to_xml_word_array( info, tag, indent, array ) 436 | type(XML_PARSE), intent(in) :: info 437 | character(len=*), intent(in) :: tag 438 | integer, intent(in) :: indent 439 | character(len=*), dimension(:), intent(in) :: array 440 | 441 | character(len=100) :: indentation 442 | integer :: i, i2, j 443 | 444 | indentation = ' ' 445 | 446 | write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & 447 | '<', trim(tag), '>' 448 | do i = 1,size(array),10 449 | i2 = min( i + 9, size(array) ) 450 | write( info%lun, '(a,20a)' ) indentation(1:min(indent+4,100)), & 451 | ( trim(array(j)) , ' ' ,j = i,i2 ) 452 | enddo 453 | write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & 454 | '' 455 | 456 | end subroutine write_to_xml_word_array 457 | 458 | ! write_to_xml_line_array -- 459 | ! Routine to write an array of lines to the XML file 460 | ! 461 | ! Arguments: 462 | ! info XML parser structure 463 | ! tag The tag in question 464 | ! indent Number of spaces for indentation 465 | ! array Values to be written 466 | ! 467 | subroutine write_to_xml_line_array( info, tag, indent, array ) 468 | type(XML_PARSE), intent(in) :: info 469 | character(len=*), intent(in) :: tag 470 | integer, intent(in) :: indent 471 | logical, dimension(:), intent(in) :: array 472 | 473 | character(len=100) :: indentation 474 | integer :: i 475 | 476 | indentation = ' ' 477 | 478 | write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & 479 | '<', trim(tag), '>' 480 | do i = 1,size(array) 481 | write( info%lun, '(a)' ) indentation(1:min(indent+4,100)), & 482 | array(i) 483 | enddo 484 | write( info%lun, '(4a)' ) indentation(1:min(indent,100)), & 485 | '' 486 | 487 | end subroutine write_to_xml_line_array 488 | 489 | end module write_xml_primitives 490 | -------------------------------------------------------------------------------- /src/xmlparse.f90: -------------------------------------------------------------------------------- 1 | !=============================================================================== 2 | ! XMLPARSE - Simple, limited XML parser in Fortran 3 | ! 4 | ! General information: 5 | ! The module reads XML files by: 6 | ! - Identifying the tag and all attributes and data belonging 7 | ! to the tag. 8 | ! - Returning to the calling subprogram to let it take care of 9 | ! the tag, attributes and data. 10 | ! - If the tag is actually an ending tag, then this is flagged 11 | ! too. 12 | ! - Handling all the data is left to the calling subprogram, 13 | ! the module merely facilitates in the parsing. 14 | ! 15 | ! Note: 16 | ! The module in its current version has a number of limitations: 17 | ! - It does not handle escape sequences (like >. to signify 18 | ! a ">" sign) 19 | ! - It does not handle tags with attributes that are spread 20 | ! over more than one line 21 | ! - The maximum length of a line is 1000 characters 22 | ! - It may report too many lines of data (empty lines) 23 | ! - No DOM support nor support for an object tree 24 | ! - It is probably not very robust in detecting malformed XML files 25 | ! 26 | ! Some questions: 27 | ! - What to do with leading blanks? 28 | ! 29 | ! Update - several ideas: 30 | ! - Introduce at least two options (via xml_options): 31 | ! - ignore_whitespace - remove leading blanks and leading and trailing 32 | ! empty lines from the PCDATA 33 | ! - no_data_truncation - consider truncation of data (more 34 | ! attributes or lines of character data than 35 | ! can be stored) a read error 36 | ! - Introduce convenience functions and subroutines: 37 | ! - xml_ok() - all is well, reading can continue 38 | ! - xml_data_trunc() - was there truncation of the data? 39 | ! - xml_find_attrib() - find an attribute by name 40 | ! 41 | ! Further ideas: 42 | ! - simple checking via a table: parent, tag, id, min, max 43 | !=============================================================================== 44 | 45 | module xmlparse 46 | 47 | implicit none 48 | 49 | integer, parameter :: XML_BUFFER_LENGTH = 10000 50 | 51 | !=============================================================================== 52 | ! XML_PARSE defines the data type that holds the parser information 53 | !=============================================================================== 54 | 55 | type XML_PARSE 56 | integer :: lun ! LU-number of the XML-file 57 | integer :: level ! Indentation level (output) 58 | integer :: lineno ! Line in file 59 | logical :: ignore_whitespace ! Ignore leading blanks etc. 60 | logical :: no_data_truncation ! Do not allow data truncation 61 | logical :: too_many_attribs ! More attributes than could be stored? 62 | logical :: too_many_data ! More lines of data than could be stored? 63 | logical :: eof ! End of file? 64 | logical :: error ! Invalid XML file or other error? 65 | character(len=XML_BUFFER_LENGTH) :: line ! Buffer 66 | end type XML_PARSE 67 | 68 | !=============================================================================== 69 | ! Global options 70 | !=============================================================================== 71 | 72 | integer, parameter :: XML_STDOUT = -1 73 | integer, private :: report_lun_ = XML_STDOUT 74 | logical, private :: report_errors_ = .false. 75 | logical, private :: report_details_ = .false. 76 | 77 | !=============================================================================== 78 | ! Global data (the ampersand must come first) 79 | !=============================================================================== 80 | 81 | character(len=10), dimension(2,3), save, private :: entities = & 82 | reshape( (/ '& ', '&', & 83 | '> ', '> ', & 84 | '< ', '< ' /), (/2,3/) ) 85 | 86 | !=============================================================================== 87 | ! Auxiliary routines - private 88 | !=============================================================================== 89 | 90 | private :: xml_compress_ 91 | private :: xml_put_open_tag_ 92 | private :: xml_put_element_ 93 | private :: xml_put_close_tag_ 94 | private :: xml_replace_entities_ 95 | private :: xml_remove_tabs_ 96 | 97 | !=============================================================================== 98 | ! Interfaces to reporting routines 99 | !=============================================================================== 100 | 101 | private :: xml_report_details_int_ 102 | private :: xml_report_details_string_ 103 | private :: xml_report_errors_int_ 104 | private :: xml_report_errors_string_ 105 | 106 | interface xml_report_details 107 | module procedure xml_report_details_int_ 108 | module procedure xml_report_details_string_ 109 | end interface 110 | interface xml_report_errors 111 | module procedure xml_report_errors_int_ 112 | module procedure xml_report_errors_string_ 113 | module procedure xml_report_errors_extern_ 114 | end interface 115 | 116 | contains 117 | 118 | !=============================================================================== 119 | ! XML_REPORT_DETAILS_INT_ -- 120 | ! Routine to write a text with an integer value 121 | ! Arguments: 122 | ! text Text to be written 123 | ! int Integer value to be added 124 | !=============================================================================== 125 | 126 | subroutine xml_report_details_int_( text, int ) 127 | character(len=*), intent(in) :: text 128 | integer, intent(in) :: int 129 | 130 | if ( report_details_ ) then 131 | if ( report_lun_ == XML_STDOUT ) then 132 | write(*,*) trim(text), int 133 | else 134 | write(report_lun_,*) trim(text), int 135 | endif 136 | endif 137 | end subroutine xml_report_details_int_ 138 | 139 | !=============================================================================== 140 | ! XML_REPORT_DETAILS_STRING_ -- 141 | ! Routine to write a text with a string value 142 | ! Arguments: 143 | ! text Text to be written 144 | ! string String to be added 145 | !=============================================================================== 146 | 147 | subroutine xml_report_details_string_( text, string ) 148 | character(len=*), intent(in) :: text 149 | character(len=*), intent(in) :: string 150 | 151 | if ( report_details_ ) then 152 | if ( report_lun_ == XML_STDOUT ) then 153 | write(*,*) trim(text), ' ', trim(string) 154 | else 155 | write(report_lun_,*) trim(text), ' ', trim(string) 156 | endif 157 | endif 158 | end subroutine xml_report_details_string_ 159 | 160 | !=============================================================================== 161 | ! XML_REPORT_ERRORS_INT_ -- 162 | ! Routine to write an error message text with an integer value 163 | ! Arguments: 164 | ! text Text to be written 165 | ! int Integer value to be added 166 | ! lineno Line number in the file 167 | !=============================================================================== 168 | 169 | subroutine xml_report_errors_int_( text, int, lineno ) 170 | character(len=*), intent(in) :: text 171 | integer, intent(in) :: int 172 | integer, optional, intent(in) :: lineno 173 | 174 | if ( report_errors_ .or. report_details_ ) then 175 | if ( report_lun_ == XML_STDOUT ) then 176 | write(*,*) trim(text), int 177 | if ( present(lineno) ) then 178 | write(*,*) ' At or near line', lineno 179 | endif 180 | else 181 | write(report_lun_,*) trim(text), int 182 | if ( present(lineno) ) then 183 | write(report_lun_,*) ' At or near line', lineno 184 | endif 185 | endif 186 | endif 187 | end subroutine xml_report_errors_int_ 188 | 189 | !=============================================================================== 190 | ! XML_REPORT_ERRORS_STRING_ -- 191 | ! Routine to write an error message text with a string value 192 | ! Arguments: 193 | ! text Text to be written 194 | ! string String to be added 195 | ! lineno Line number in the file 196 | !=============================================================================== 197 | 198 | subroutine xml_report_errors_string_( text, string, lineno ) 199 | character(len=*), intent(in) :: text 200 | character(len=*), intent(in) :: string 201 | integer, optional, intent(in) :: lineno 202 | 203 | if ( report_errors_ .or. report_details_ ) then 204 | if ( report_lun_ == XML_STDOUT ) then 205 | write(*,*) trim(text), ' ', trim(string) 206 | if ( present(lineno) ) then 207 | write(*,*) ' At or near line', lineno 208 | endif 209 | else 210 | write(report_lun_,*) trim(text), ' ', trim(string) 211 | if ( present(lineno) ) then 212 | write(report_lun_,*) ' At or near line', lineno 213 | endif 214 | endif 215 | endif 216 | end subroutine xml_report_errors_string_ 217 | 218 | !=============================================================================== 219 | ! XML_REPORT_ERRORS_EXTERN_ -- 220 | ! Routine to write an error message text with a string value 221 | ! Arguments: 222 | ! info Structure holding information on the XML-file 223 | ! text Text to be written 224 | ! Note: 225 | ! This routine is meant for use by routines outside 226 | ! this module 227 | !=============================================================================== 228 | 229 | subroutine xml_report_errors_extern_( info, text ) 230 | type(XML_PARSE), intent(in) :: info 231 | character(len=*), intent(in) :: text 232 | 233 | if ( report_errors_ .or. report_details_ ) then 234 | if ( report_lun_ == XML_STDOUT ) then 235 | write(*,*) trim(text), ' - at or near line', info%lineno 236 | else 237 | write(report_lun_,*) trim(text), ' - at or near line', info%lineno 238 | endif 239 | end if 240 | 241 | end subroutine xml_report_errors_extern_ 242 | 243 | !=============================================================================== 244 | ! XML_OPEN -- 245 | ! Routine to open an XML file for reading or writing 246 | ! Arguments: 247 | ! info Structure holding information on the XML-file 248 | ! fname Name of the file 249 | ! mustread The file will be read (.true.) or written (.false.) 250 | !=============================================================================== 251 | 252 | subroutine xml_open( info, fname, mustread ) 253 | character(len=*), intent(in) :: fname 254 | logical, intent(in) :: mustread 255 | type(XML_PARSE), intent(out) :: info 256 | 257 | integer :: i 258 | integer :: k 259 | integer :: kend 260 | integer :: ierr 261 | logical :: opend 262 | logical :: exists 263 | 264 | info%lun = 10 265 | info%ignore_whitespace = .false. 266 | info%no_data_truncation = .false. 267 | info%too_many_attribs = .false. 268 | info%too_many_data = .false. 269 | info%eof = .false. 270 | info%error = .false. 271 | info%level = -1 272 | info%lineno = 0 273 | 274 | do i = 10,99 275 | inquire( unit = i, opened = opend ) 276 | if ( .not. opend ) then 277 | info%lun = i 278 | inquire( file = fname, exist = exists ) 279 | if ( .not. exists .and. mustread ) then 280 | call xml_report_errors( 'XML_OPEN: file does not exist:', trim(fname)) 281 | info%lun = -1 282 | info%error = .true. 283 | else 284 | open( unit = info%lun, file = fname ) 285 | call xml_report_details( 'XML_OPEN: opened file ', trim(fname) ) 286 | call xml_report_details( 'at LU-number: ', info%lun ) 287 | endif 288 | exit 289 | endif 290 | enddo 291 | if ( .not. info%error .and. mustread ) then 292 | k = 1 293 | do while ( k >= 1 ) 294 | read( info%lun, '(a)', iostat = ierr ) info%line 295 | 296 | ! If we encounter a blank line, skip it and read the next line 297 | if (len_trim(info%line) == 0) cycle 298 | 299 | call xml_remove_tabs_(info%line) 300 | if ( ierr == 0 ) then 301 | info%line = adjustl( info%line ) 302 | k = index( info%line, ' appears on a single line! 305 | ! 306 | if ( k >= 1 ) then 307 | kend = index( info%line, '?>' ) 308 | if ( kend <= 0 ) then 309 | call xml_report_errors( 'XML_OPEN: error reading file with LU-number: ', info%lun ) 310 | call xml_report_errors( 'Line starting with ""', ' ' ) 311 | info%error = .true. 312 | exit 313 | endif 314 | endif 315 | else 316 | call xml_report_errors( 'XML_OPEN: error reading file with LU-number: ', info%lun ) 317 | call xml_report_errors( 'Possibly no line starting with "' 326 | endif 327 | end subroutine xml_open 328 | 329 | !=============================================================================== 330 | ! XML_CLOSE -- 331 | ! Routine to close an XML file 332 | ! Arguments: 333 | ! info Structure holding information on the XML-file 334 | !=============================================================================== 335 | 336 | subroutine xml_close( info ) 337 | type(XML_PARSE), intent(inout) :: info 338 | 339 | close( info%lun ) 340 | 341 | ! 342 | ! Only clean up the LU-number, so that the calling program 343 | ! can examine the last condition 344 | ! 345 | call xml_report_details( 'XML_CLOSE: Closing file with LU-number ', info%lun ) 346 | info%lun = -1 347 | end subroutine xml_close 348 | 349 | !=============================================================================== 350 | ! XML_GET -- 351 | ! Routine to get the next bit of information from an XML file 352 | ! Arguments: 353 | ! info Structure holding information on the XML-file 354 | ! tag Tag that was encountered 355 | ! endtag Whether the end of the element was encountered 356 | ! attribs List of attribute-value pairs 357 | ! no_attribs Number of pairs in the list 358 | ! data Lines of character data found 359 | ! no_data Number of lines of character data 360 | !=============================================================================== 361 | 362 | subroutine xml_get( info, tag, endtag, attribs, no_attribs, & 363 | data, no_data ) 364 | type(XML_PARSE), intent(inout) :: info 365 | character(len=*), intent(out) :: tag 366 | logical, intent(out) :: endtag 367 | character(len=*), intent(out), dimension(:,:) :: attribs 368 | integer, intent(out) :: no_attribs 369 | character(len=*), intent(out), dimension(:) :: data 370 | integer, intent(out) :: no_data 371 | 372 | integer :: kspace 373 | integer :: kend 374 | integer :: kcend 375 | integer :: keq 376 | integer :: kfirst 377 | integer :: ksecond 378 | integer :: idxat 379 | integer :: idxdat 380 | integer :: ierr 381 | logical :: close_bracket 382 | logical :: comment_tag 383 | character(len=XML_BUFFER_LENGTH) :: nextline 384 | 385 | ! 386 | ! Initialise the output 387 | ! 388 | endtag = .false. 389 | no_attribs = 0 390 | no_data = 0 391 | 392 | info%too_many_attribs = .false. 393 | info%too_many_data = .false. 394 | 395 | if ( info%lun < 0 ) then 396 | call xml_report_details( 'XML_GET on closed file ', ' ' ) 397 | return 398 | endif 399 | 400 | ! 401 | ! From the previous call or the call to xmlopen we have 402 | ! the line that we need to parse already in memory: 403 | ! 404 | ! 405 | comment_tag = .false. 406 | close_bracket = .false. 407 | kspace = index( info%line, ' ' ) 408 | kend = index( info%line, '>' ) 409 | kcend = index( info%line, '-->' ) 410 | do while ( kend <= 0 ) 411 | read( info%lun, '(a)', iostat = ierr ) nextline 412 | call xml_remove_tabs_(nextline) 413 | info%lineno = info%lineno + 1 414 | 415 | if ( ierr == 0 ) then 416 | info%line = trim(info%line) // ' ' // adjustl(nextline) 417 | else 418 | info%error = .true. 419 | call xml_report_errors( 'XML_GET - end of tag not found ', & 420 | '(buffer too small?)', info%lineno ) 421 | call xml_close( info ) 422 | return 423 | endif 424 | kend = index( info%line, '>' ) 425 | enddo 426 | if ( kend > kspace ) then 427 | kend = kspace 428 | else if (info%line(1:4) == '' ) then 439 | endtag = .true. 440 | tag = info%line(4:kend-1) 441 | else if ( info%line(1:2) == '' ) 464 | if ( keq > kend ) keq = 0 ! Guard against multiple tags 465 | ! with attributes on one line 466 | 467 | ! 468 | ! No attributes any more? 469 | ! 470 | if ( keq < 1 ) then 471 | kend = index( info%line, '/>' ) 472 | if ( kend >= 1 ) then 473 | kend = kend + 1 ! To go beyond the ">" character 474 | endtag = .true. 475 | else 476 | kend = index( info%line, '>' ) 477 | if ( kend < 1 ) then 478 | call xml_report_errors( 'XML_GET - wrong ending of tag ', & 479 | trim(info%line), info%lineno ) 480 | info%error = .true. ! Wrong ending of line! 481 | call xml_close( info ) 482 | return 483 | else 484 | close_bracket = .true. 485 | endif 486 | endif 487 | if ( kend >= 1 ) then 488 | info%line = adjustl( info%line(kend+1:) ) 489 | endif 490 | exit 491 | endif 492 | 493 | idxat = idxat + 1 494 | if ( idxat <= size(attribs,2) ) then 495 | no_attribs = idxat 496 | attribs(1,idxat) = adjustl(info%line(1:keq-1)) ! Use adjustl() to avoid 497 | ! multiple spaces, etc 498 | info%line = adjustl( info%line(keq+1:) ) 499 | 500 | ! 501 | ! We have almost found the start of the attribute's value 502 | ! 503 | kfirst = index( info%line, '"' ) 504 | if ( kfirst < 1 ) then 505 | call xml_report_errors( 'XML_GET - malformed attribute-value pair: ', & 506 | trim(info%line), info%lineno ) 507 | info%error = .true. ! Wrong form of attribute-value pair 508 | call xml_close( info ) 509 | return 510 | endif 511 | 512 | ksecond = index( info%line(kfirst+1:), '"' ) + kfirst 513 | if ( ksecond < 1 ) then 514 | call xml_report_errors( 'XML_GET - malformed attribute-value pair: ', & 515 | trim(info%line), info%lineno ) 516 | info%error = .true. ! Wrong form of attribute-value pair 517 | call xml_close( info ) 518 | return 519 | endif 520 | 521 | attribs(2,idxat) = info%line(kfirst+1:ksecond-1) 522 | info%line = adjustl( info%line(ksecond+1:) ) 523 | endif 524 | 525 | if ( idxat > size(attribs,2) ) then 526 | call xml_report_errors( 'XML_GET - more attributes than could be stored: ', & 527 | trim(info%line), info%lineno ) 528 | info%too_many_attribs = .true. 529 | info%line = ' ' 530 | exit 531 | endif 532 | enddo 533 | 534 | ! 535 | ! Now read the data associated with the current tag 536 | ! - all the way to the next "<" character 537 | ! 538 | ! To do: reduce the number of data lines - empty ones 539 | ! at the end should not count. 540 | ! 541 | do 542 | if ( comment_tag ) then 543 | kend = index( info%line, '-->' ) 544 | else 545 | kend = index( info%line, '<' ) 546 | endif 547 | idxdat = idxdat + 1 548 | if ( idxdat <= size(data) ) then 549 | no_data = idxdat 550 | if ( kend >= 1 ) then 551 | data(idxdat) = info%line(1:kend-1) 552 | info%line = info%line(kend:) 553 | else 554 | data(idxdat) = info%line 555 | endif 556 | else 557 | call xml_report_errors( 'XML_GET - more data lines than could be stored: ', & 558 | trim(info%line), info%lineno ) 559 | info%too_many_data = .true. 560 | exit 561 | endif 562 | 563 | ! 564 | ! No more data? Otherwise, read on 565 | ! 566 | if ( kend >= 1 ) then 567 | exit 568 | else 569 | read( info%lun, '(a)', iostat = ierr ) info%line 570 | call xml_remove_tabs_(info%line) 571 | info%lineno = info%lineno + 1 572 | 573 | if ( ierr < 0 ) then 574 | call xml_report_details( 'XML_GET - end of file found - LU-number: ', & 575 | info%lun ) 576 | info%eof = .true. 577 | elseif ( ierr > 0 ) then 578 | call xml_report_errors( 'XML_GET - error reading file with LU-number ', & 579 | info%lun, info%lineno ) 580 | info%error = .true. 581 | endif 582 | if ( ierr /= 0 ) then 583 | exit 584 | endif 585 | endif 586 | enddo 587 | 588 | ! 589 | ! Compress the data? 590 | ! 591 | if ( info%ignore_whitespace ) then 592 | call xml_compress_( data, no_data ) 593 | endif 594 | 595 | ! 596 | ! Replace the entities, if any 597 | ! 598 | call xml_replace_entities_( data, no_data ) 599 | 600 | call xml_report_details( 'XML_GET - number of attributes: ', no_attribs ) 601 | call xml_report_details( 'XML_GET - number of data lines: ', no_data ) 602 | 603 | end subroutine xml_get 604 | 605 | !=============================================================================== 606 | ! XML_PUT -- 607 | ! Routine to write a tag with the associated data to an XML file 608 | ! Arguments: 609 | ! info Structure holding information on the XML-file 610 | ! tag Tag that was encountered 611 | ! endtag Whether the end of the element was encountered 612 | ! attribs List of attribute-value pairs 613 | ! no_attribs Number of pairs in the list 614 | ! data Lines of character data found 615 | ! no_data Number of lines of character data 616 | ! type Type of action: 617 | ! open - just the opening tag with attributes 618 | ! elem - complete element 619 | ! close - just the closing tag 620 | !=============================================================================== 621 | 622 | subroutine xml_put(info, tag, attribs, no_attribs, & 623 | data, no_data, type) 624 | 625 | type(XML_PARSE), intent(inout) :: info 626 | character(len=*), intent(in) :: tag 627 | character(len=*), intent(in), dimension(:,:) :: attribs 628 | integer, intent(in) :: no_attribs 629 | character(len=*), intent(in), dimension(:) :: data 630 | integer, intent(in) :: no_data 631 | character(len=*) :: type 632 | 633 | select case(type) 634 | case('open') 635 | call xml_put_open_tag_(info, tag, attribs, no_attribs) 636 | case('elem') 637 | call xml_put_element_(info, tag, attribs, no_attribs, & 638 | data, no_data) 639 | case('close') 640 | call xml_put_close_tag_(info, tag) 641 | end select 642 | 643 | end subroutine xml_put 644 | 645 | !=============================================================================== 646 | ! XML_PUT_OPEN_TAG_ -- 647 | ! Routine to write the opening tag with the attributes 648 | ! Arguments: 649 | ! info Structure holding information on the XML-file 650 | ! tag Tag that was encountered 651 | ! endtag Whether the end of the element was encountered 652 | ! attribs List of attribute-value pairs 653 | ! no_attribs Number of pairs in the list 654 | ! data Lines of character data found 655 | ! no_data Number of lines of character data 656 | !=============================================================================== 657 | 658 | subroutine xml_put_open_tag_(info, tag, attribs, no_attribs) 659 | 660 | type(XML_PARSE), intent(inout) :: info 661 | character(len=*), intent(in) :: tag 662 | character(len=*), intent(in), dimension(:,:) :: attribs 663 | integer, intent(in) :: no_attribs 664 | 665 | integer :: i 666 | character(len=300), parameter :: indent = ' ' 667 | 668 | write( info%lun, '(3a)', advance = 'no' ) & 669 | indent(1:3*info%level), '<', adjustl(tag) 670 | do i=1,no_attribs 671 | if (attribs(2,i)/='') then 672 | write( info%lun, '(5a)', advance = 'no' ) & 673 | ' ',trim(attribs(1,i)),'="', trim(attribs(2,i)),'"' 674 | endif 675 | enddo 676 | write( info%lun, '(a)' ) '>' 677 | info%level = info%level + 1 678 | 679 | end subroutine xml_put_open_tag_ 680 | 681 | !=============================================================================== 682 | ! XML_PUT_ELEMENT_ -- 683 | ! Routine to write the complete element 684 | ! Arguments: 685 | ! info Structure holding information on the XML-file 686 | ! tag Tag that was encountered 687 | ! endtag Whether the end of the element was encountered 688 | ! attribs List of attribute-value pairs 689 | ! no_attribs Number of pairs in the list 690 | ! data Lines of character data found 691 | ! no_data Number of lines of character data 692 | !=============================================================================== 693 | 694 | subroutine xml_put_element_(info, tag, attribs, no_attribs, & 695 | data, no_data) 696 | 697 | type(XML_PARSE), intent(inout) :: info 698 | character(len=*), intent(in) :: tag 699 | character(len=*), intent(in), dimension(:,:) :: attribs 700 | integer, intent(in) :: no_attribs 701 | character(len=*), intent(in), dimension(:) :: data 702 | integer, intent(in) :: no_data 703 | 704 | logical :: logic 705 | character(len=1) :: aa 706 | integer :: i, ii 707 | 708 | character(len=300), parameter :: indent = ' ' 709 | 710 | if ( (no_attribs==0 .and. no_data==0) ) then 711 | return 712 | else 713 | logic = .true. 714 | do ii = 1,no_attribs 715 | logic = logic .and. (attribs(2,ii)=='') 716 | enddo 717 | do ii = 1,no_data 718 | logic = logic .and. (data(ii)=='') 719 | enddo 720 | if ( logic ) then 721 | return 722 | else 723 | write( info%lun, '(3a)', advance = 'no' ) & 724 | indent(1:3*info%level), '<', adjustl(tag) 725 | do i = 1,no_attribs 726 | if (attribs(2,i)/='') then 727 | write( info%lun, '(5a)', advance = 'no' ) & 728 | ' ',trim(attribs(1,i)),'="', trim(attribs(2,i)),'"' 729 | endif 730 | enddo 731 | if ( no_attribs>0 .and. no_data==0 ) then 732 | aa='a' 733 | elseif ( (no_attribs>0 .and. no_data>0) .or. & 734 | (no_attribs==0 .and. no_data>0) ) then 735 | aa='b' 736 | else 737 | write(*,*) no_attribs, no_data 738 | endif 739 | endif 740 | endif 741 | 742 | select case(aa) 743 | case('a') 744 | write( info%lun, '(a)' ) '/>' 745 | case('b') 746 | write( info%lun, '(a)',advance='no' ) '>' 747 | write( info%lun, '(2a)', advance='no') ( ' ', trim(data(i)), i=1,no_data ) 748 | write( info%lun, '(4a)' ) ' ','' 749 | end select 750 | 751 | end subroutine xml_put_element_ 752 | 753 | !=============================================================================== 754 | ! XML_PUT_CLOSE_TAG_ -- 755 | ! Routine to write the closing tag 756 | ! Arguments: 757 | ! info Structure holding information on the XML-file 758 | ! tag Tag that was encountered 759 | ! endtag Whether the end of the element was encountered 760 | ! attribs List of attribute-value pairs 761 | ! no_attribs Number of pairs in the list 762 | ! data Lines of character data found 763 | ! no_data Number of lines of character data 764 | !=============================================================================== 765 | 766 | subroutine xml_put_close_tag_(info, tag) 767 | 768 | type(XML_PARSE), intent(inout) :: info 769 | character(len=*), intent(in) :: tag 770 | 771 | character(len=300), parameter :: indent = ' ' 772 | 773 | info%level = info%level - 1 774 | write(info%lun, '(4a)') indent(1:3*info%level), '' 775 | 776 | end subroutine xml_put_close_tag_ 777 | 778 | !=============================================================================== 779 | ! XML_COMPRESS_ -- 780 | ! Routine to remove empty lines from the character data 781 | ! Arguments: 782 | ! data Lines of character data found 783 | ! no_data (Nett) number of lines of character data 784 | !=============================================================================== 785 | 786 | subroutine xml_compress_( data, no_data ) 787 | character(len=*), intent(inout), dimension(:) :: data 788 | integer, intent(inout) :: no_data 789 | 790 | integer :: i 791 | integer :: j 792 | logical :: empty 793 | 794 | j = 0 795 | empty = .true. 796 | do i = 1,no_data 797 | if ( len_trim(data(i)) /= 0 .or. .not. empty ) then 798 | j = j + 1 799 | data(j) = adjustl(data(i)) 800 | empty = .false. 801 | endif 802 | enddo 803 | 804 | no_data = j 805 | 806 | do i = no_data,1,-1 807 | if ( len_trim(data(i)) /= 0 ) then 808 | exit 809 | else 810 | no_data = no_data - 1 811 | endif 812 | enddo 813 | 814 | end subroutine xml_compress_ 815 | 816 | !=============================================================================== 817 | ! XML_REPLACE_ENTITIES_ -- 818 | ! Routine to replace entities such as > by their 819 | ! proper character representation 820 | ! Arguments: 821 | ! data Lines of character data found 822 | ! no_data (Nett) number of lines of character data 823 | !=============================================================================== 824 | 825 | subroutine xml_replace_entities_( data, no_data ) 826 | character(len=*), intent(inout), dimension(:) :: data 827 | integer, intent(inout) :: no_data 828 | 829 | integer :: i 830 | integer :: j 831 | integer :: j2 832 | integer :: k 833 | integer :: pos 834 | logical :: found 835 | 836 | do i = 1,no_data 837 | j = 1 838 | do 839 | do k = 1,size(entities,2) 840 | found = .false. 841 | pos = index( data(i)(j:), trim(entities(2,k)) ) 842 | if ( pos > 0 ) then 843 | found = .true. 844 | j = j + pos - 1 845 | j2 = j + len_trim(entities(2,k)) 846 | data(i)(j:) = trim(entities(1,k)) // data(i)(j2:) 847 | j = j2 848 | endif 849 | enddo 850 | if ( .not. found ) exit 851 | enddo 852 | enddo 853 | 854 | end subroutine xml_replace_entities_ 855 | 856 | !=============================================================================== 857 | ! XML_OPTIONS -- 858 | ! Routine to handle the parser options 859 | ! Arguments: 860 | ! info Structure holding information on the XML-file 861 | ! ignore_whitespace Ignore whitespace (leading blanks, empty lines) or not 862 | ! no_data_truncation Consider truncation of strings an error or not 863 | ! report_lun LU-number for reporting information 864 | ! report_errors Write messages about errors or not 865 | ! report_details Write messages about all kinds of actions or not 866 | !=============================================================================== 867 | 868 | subroutine xml_options( info, ignore_whitespace, no_data_truncation, & 869 | report_lun, report_errors, & 870 | report_details ) 871 | type(XML_PARSE), intent(inout) :: info 872 | logical, intent(in), optional :: ignore_whitespace 873 | logical, intent(in), optional :: no_data_truncation 874 | 875 | integer, intent(in), optional :: report_lun 876 | logical, intent(in), optional :: report_errors 877 | logical, intent(in), optional :: report_details 878 | 879 | if ( present(ignore_whitespace) ) then 880 | info%ignore_whitespace = ignore_whitespace 881 | endif 882 | if ( present(no_data_truncation) ) then 883 | info%no_data_truncation = no_data_truncation 884 | endif 885 | if ( present(report_lun) ) then 886 | report_lun_ = report_lun 887 | endif 888 | if ( present(report_errors) ) then 889 | report_errors_ = report_errors 890 | endif 891 | if ( present(report_details) ) then 892 | report_details_ = report_details 893 | endif 894 | end subroutine xml_options 895 | 896 | !=============================================================================== 897 | ! XML_OK -- 898 | ! Function that returns whether all was okay or not 899 | ! Arguments: 900 | ! info Structure holding information on the XML-file 901 | ! Returns: 902 | ! .true. if there was no error, .false. otherwise 903 | !=============================================================================== 904 | 905 | logical function xml_ok( info ) 906 | type(XML_PARSE), intent(in) :: info 907 | 908 | xml_ok = info%eof .or. info%error .or. & 909 | ( info%no_data_truncation .and. & 910 | ( info%too_many_attribs .or. info%too_many_data ) ) 911 | xml_ok = .not. xml_ok 912 | end function xml_ok 913 | 914 | !=============================================================================== 915 | ! XML_ERROR -- 916 | ! Function that returns whether there was an error 917 | ! Arguments: 918 | ! info Structure holding information on the XML-file 919 | ! Returns: 920 | ! .true. if there was an error, .false. if there was none 921 | !=============================================================================== 922 | 923 | logical function xml_error( info ) 924 | type(XML_PARSE), intent(in) :: info 925 | 926 | xml_error = info%error .or. & 927 | ( info%no_data_truncation .and. & 928 | ( info%too_many_attribs .or. info%too_many_data ) ) 929 | end function xml_error 930 | 931 | !=============================================================================== 932 | ! XML_DATA_TRUNC -- 933 | ! Function that returns whether data were truncated or not 934 | ! Arguments: 935 | ! info Structure holding information on the XML-file 936 | ! Returns: 937 | ! .true. if data were truncated, .false. otherwise 938 | !=============================================================================== 939 | 940 | logical function xml_data_trunc( info ) 941 | type(XML_PARSE), intent(in) :: info 942 | 943 | xml_data_trunc = info%too_many_attribs .or. info%too_many_data 944 | end function xml_data_trunc 945 | 946 | !=============================================================================== 947 | ! XML_FIND_ATTRIB 948 | !=============================================================================== 949 | 950 | integer function xml_find_attrib( attribs, no_attribs, name, value ) 951 | character(len=*), dimension(:,:) :: attribs 952 | integer :: no_attribs 953 | character(len=*) :: name 954 | character(len=*) :: value 955 | 956 | integer :: i 957 | 958 | xml_find_attrib = -1 959 | do i = 1,no_attribs 960 | if ( name == attribs(1,i) ) then 961 | value = attribs(2,i) 962 | xml_find_attrib = i 963 | exit 964 | endif 965 | enddo 966 | 967 | end function xml_find_attrib 968 | 969 | !=============================================================================== 970 | ! XML_PROCESS -- 971 | ! Routine to read the XML file as a whole and distribute processing 972 | ! the contents over three user-defined subroutines 973 | ! Arguments: 974 | ! filename Name of the file to process 975 | ! attribs Array for holding the attributes 976 | ! data Array for holding the character data 977 | ! startfunc Subroutine to handle the start of elements 978 | ! datafunc Subroutine to handle the character data 979 | ! endfunc Subroutine to handle the end of elements 980 | ! error Indicates if there was an error or not 981 | ! Note: 982 | ! The routine is declared recursive to allow inclusion of XML files 983 | ! (common with XSD schemas). This extends to the auxiliary routines. 984 | !=============================================================================== 985 | 986 | recursive & 987 | subroutine xml_process( filename, attribs, data, startfunc, datafunc, endfunc, lunrep, error ) 988 | character(len=*) :: filename 989 | character(len=*), dimension(:,:) :: attribs 990 | character(len=*), dimension(:) :: data 991 | integer :: lunrep 992 | logical :: error 993 | 994 | interface 995 | recursive subroutine startfunc( tag, attribs, error ) 996 | character(len=*) :: tag 997 | character(len=*), dimension(:,:) :: attribs 998 | logical :: error 999 | end subroutine 1000 | end interface 1001 | 1002 | interface 1003 | recursive subroutine datafunc( tag, data, error ) 1004 | character(len=*) :: tag 1005 | character(len=*), dimension(:) :: data 1006 | logical :: error 1007 | end subroutine 1008 | end interface 1009 | 1010 | interface 1011 | recursive subroutine endfunc( tag, error ) 1012 | character(len=*) :: tag 1013 | logical :: error 1014 | end subroutine 1015 | end interface 1016 | 1017 | type(XML_PARSE) :: info 1018 | character(len=80) :: tag 1019 | logical :: endtag 1020 | integer :: noattribs 1021 | integer :: nodata 1022 | 1023 | call xml_options( info, report_lun = lunrep, report_details = .false. ) 1024 | call xml_open( info, filename, .true. ) 1025 | 1026 | error = .false. 1027 | do 1028 | call xml_get( info, tag, endtag, attribs, noattribs, data, nodata ) 1029 | if ( .not. xml_ok(info) ) then 1030 | exit 1031 | endif 1032 | 1033 | if ( xml_error(info) ) then 1034 | write(lunrep,*) 'Error reading XML file!' 1035 | error = .true. 1036 | exit 1037 | endif 1038 | 1039 | if ( .not. endtag .or. noattribs /= 0 ) then 1040 | call startfunc( tag, attribs(:,1:noattribs), error ) 1041 | if ( error ) exit 1042 | 1043 | call datafunc( tag, data(1:nodata), error ) 1044 | if ( error ) exit 1045 | endif 1046 | 1047 | if ( endtag ) then 1048 | call endfunc( tag, error ) 1049 | if ( error ) exit 1050 | endif 1051 | enddo 1052 | call xml_close( info ) 1053 | end subroutine xml_process 1054 | 1055 | !=============================================================================== 1056 | ! XML_REMOVE_TABS_ -- 1057 | ! Routine to change any horizontal tab characters to spaces when reading a 1058 | ! new line of data 1059 | ! Arguments: 1060 | ! line Line of character data to modify 1061 | !=============================================================================== 1062 | 1063 | subroutine xml_remove_tabs_(line) 1064 | character(len=*), intent(inout) :: line 1065 | 1066 | integer :: i 1067 | 1068 | do i = 1, len_trim(line) 1069 | if (line(i:i) == achar(9)) then 1070 | line(i:i) = ' ' 1071 | end if 1072 | end do 1073 | 1074 | end subroutine xml_remove_tabs_ 1075 | 1076 | end module xmlparse 1077 | -------------------------------------------------------------------------------- /src/xmlreader.conf: -------------------------------------------------------------------------------- 1 | 2 | 3 | 12 | 13 | -------------------------------------------------------------------------------- /src/xmlreader.inp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/paulromano/xml-fortran/ffe63a0591e86fc1c17a6cb673b56e633b15f906/src/xmlreader.inp -------------------------------------------------------------------------------- /src/xsdconvert.f90: -------------------------------------------------------------------------------- 1 | ! xsdconvert.f90 -- 2 | ! Auxiliary program to convert an XSD file to a schema file 3 | ! as used by xmlreader 4 | ! 5 | module handle_elems 6 | use xmlparse 7 | 8 | implicit none 9 | 10 | integer :: lunout 11 | 12 | logical, dimension(0:10), save :: intype = .false. 13 | logical, save :: rootelement = .false. 14 | logical, dimension(0:10), save :: optional = .false. 15 | integer, save :: type_level = 0 16 | integer, save :: level = 0 17 | integer, save :: type_count = 0 18 | character(len=40), save :: rootname 19 | 20 | type complextype_definition 21 | character(len=40) :: type_name 22 | character(len=40), dimension(20) :: attrib_name 23 | character(len=40), dimension(20) :: attrib_type 24 | logical, dimension(20) :: attrib_use 25 | character(len=40), dimension(20) :: attrib_default 26 | logical, dimension(20) :: has_default 27 | integer :: number_attribs 28 | logical :: is_array 29 | end type complextype_definition 30 | 31 | type(complextype_definition), dimension(10), save :: type_def 32 | logical, dimension(10), save :: type_write 33 | 34 | contains 35 | 36 | ! start_elem -- 37 | ! Handle the start of the elements in the XSD file 38 | ! 39 | ! Arguments: 40 | ! tag Tag that was found 41 | ! attribs List of attributes and their values 42 | ! error Error parameter (output) 43 | ! 44 | ! Note: 45 | ! Required because CVF 6.6 gave a strange error message when 46 | ! trying to use start_elem directly. 47 | ! 48 | recursive subroutine start_elemx( tag, attribs, error ) 49 | 50 | character(len=*) :: tag 51 | character(len=*), dimension(:,:) :: attribs 52 | logical :: error 53 | 54 | call start_elem( tag, attribs, error ) 55 | end subroutine 56 | 57 | recursive subroutine start_elem( tag, attribs, error ) 58 | 59 | character(len=*) :: tag 60 | character(len=*), dimension(:,:) :: attribs 61 | logical :: error 62 | 63 | character(len=100), dimension(100) :: new_data 64 | character(len=100), dimension(2,100) :: new_attribs 65 | character(len=300) :: filename 66 | character(len=40) :: name 67 | character(len=40) :: type 68 | integer :: idx 69 | 70 | !! write( lunout, * ) '>>Tag: ', tag, ' - level:', type_level 71 | select case( tag ) 72 | case( 'schema', 'annotation', 'documentation', '!--' ) 73 | ! Ignore 74 | case( 'xs:schema', 'xs:annotation', 'xs:documentation' ) 75 | ! Ignore 76 | case( 'xs:include', 'include' ) 77 | idx = xml_find_attrib( attribs, size(attribs,2), 'schemaLocation', filename ) 78 | 79 | ! We now use the fact that all routines are recursive to 80 | ! implement the inclusion of other XSD schemas 81 | ! (For the "module variables" this makes no difference - 82 | ! they should be globally updated anyway 83 | 84 | call xml_process( filename, new_attribs, new_data, start_elemx, data_elem, & 85 | end_elem, 20, error ) 86 | 87 | case( 'xs:element', 'element' ) 88 | 89 | ! 90 | ! If this is the first time we encounter "element", it 91 | ! defines the rootname 92 | ! In all other cases, examine the rest of the information 93 | ! 94 | if ( .not. rootelement ) then 95 | rootelement = .true. 96 | idx = xml_find_attrib( attribs, size(attribs,2), 'name', name ) 97 | write( lunout, * ) '' 98 | else 99 | type_level = type_level + 1 100 | type_write(type_level) = .true. 101 | call convert_elem( attribs, .false., optional(level) ) 102 | endif 103 | 104 | case( 'xs:attribute', 'attribute' ) 105 | call convert_attrib( attribs, optional(level) ) 106 | 107 | case( 'xs:sequence', 'sequence' ) 108 | level = level + 1 109 | optional(level) = .false. 110 | 111 | case( 'xs:choice', 'choice' ) 112 | level = level + 1 113 | optional(level) = .true. 114 | 115 | case( 'xs:complexType', 'complexType' ) 116 | if ( size(attribs,2) > 0 ) then 117 | type_level = type_level + 1 118 | type_write(type_level) = .true. 119 | call convert_elem( attribs, .true., optional(level) ) 120 | endif 121 | 122 | case( 'xs:simpleType', 'simpleType' ) 123 | idx = xml_find_attrib( attribs, size(attribs,2), 'name', name ) 124 | write( lunout, * ) '' 125 | 126 | case( 'xs:restriction', 'restriction' ) 127 | idx = xml_find_attrib( attribs, size(attribs,2), 'base', name ) 128 | write( lunout, * ) ' ' 129 | 130 | case( 'xs:enumeration', 'enumeration' ) 131 | ! Ignore 132 | case default 133 | write( *, * ) 'Ignoring: ', tag 134 | end select 135 | 136 | end subroutine 137 | 138 | ! data_elem -- 139 | ! Handle the data belonging to the elements in the XSD file 140 | ! 141 | ! Arguments: 142 | ! tag Tag that was found 143 | ! data Array of data strings 144 | ! error Error parameter (output) 145 | ! 146 | recursive subroutine data_elem( tag, data, error ) 147 | 148 | character(len=*) :: tag 149 | character(len=*), dimension(:) :: data 150 | logical :: error 151 | 152 | ! Dummy in this case 153 | 154 | return 155 | 156 | end subroutine data_elem 157 | 158 | ! end_elem -- 159 | ! Handle the end of the elements in the XSD file 160 | ! 161 | ! Arguments: 162 | ! tag Tag that was found 163 | ! error Error parameter (output) 164 | ! 165 | ! Note: 166 | ! It is easier to write all the relevant information in this 167 | ! routine. The others simply gather the information. 168 | ! 169 | recursive subroutine end_elem( tag, error ) 170 | 171 | character(len=*) :: tag 172 | logical :: error 173 | 174 | !! write( lunout, * ) '>>Endtag: ', trim(tag), ' - level: ',type_level 175 | select case( tag ) 176 | case( 'xs:complexType', 'complexType' ) 177 | if ( type_level == 1 ) then 178 | if ( type_write(type_level) ) then 179 | call write_elem 180 | endif 181 | type_write(type_level) = .false. 182 | type_level = type_level - 1 183 | endif 184 | 185 | case( 'xs:simpleType', 'simpleType' ) 186 | write( lunout, * ) '' 187 | 188 | case( 'xs:sequence', 'sequence', 'xs:choice', 'choice' ) 189 | level = level - 1 190 | 191 | case( 'xs:element', 'element' ) 192 | if ( type_level > 0 ) then 193 | if ( type_write(type_level) ) then 194 | call write_elem 195 | endif 196 | type_write(type_level) = .false. 197 | type_level = type_level - 1 198 | endif 199 | 200 | end select 201 | 202 | return 203 | 204 | end subroutine end_elem 205 | 206 | ! convert_elem -- 207 | ! Convert the definition of an element 208 | ! 209 | ! Arguments: 210 | ! attrib Attributes making up the definition 211 | ! complextype Is the item a complexType or not 212 | ! optional Is the item optional or not? 213 | ! 214 | subroutine convert_elem( attribs, complextype, optional ) 215 | 216 | character(len=*), dimension(:,:) :: attribs 217 | logical :: complextype 218 | logical :: optional 219 | 220 | character(len=40) :: name 221 | character(len=40) :: type 222 | character(len=40) :: minoccurs 223 | character(len=40) :: maxoccurs 224 | integer :: idx 225 | integer :: att 226 | integer :: off 227 | 228 | type_def(type_level)%number_attribs = 0 229 | 230 | ! 231 | ! If the type is anonymous, we must construct a type name 232 | ! and there will be an extra element complexType inbetween 233 | ! 234 | idx = xml_find_attrib( attribs, size(attribs,2), 'name', name ) 235 | 236 | idx = xml_find_attrib( attribs, size(attribs,2), 'type', type ) 237 | 238 | off = 1 239 | if ( idx <= 0 .and. .not. complextype ) then 240 | type_count = type_count + 1 241 | write( type_def(type_level)%type_name, '(a,i0)' ) 'type', type_count 242 | else 243 | if ( complextype ) then 244 | type_def(type_level)%type_name = name 245 | else 246 | type_write(type_level) = .false. 247 | endif 248 | endif 249 | 250 | if ( .not. complextype ) then 251 | att = type_def(type_level-off)%number_attribs + 1 252 | type_def(type_level-off)%number_attribs = att 253 | type_def(type_level-off)%attrib_name(att) = name 254 | type_def(type_level-off)%attrib_type(att) = type_def(type_level)%type_name 255 | endif 256 | 257 | minoccurs = '1' 258 | maxoccurs = '1' 259 | idx = xml_find_attrib( attribs, size(attribs,2), 'minOccurs', minoccurs ) 260 | idx = xml_find_attrib( attribs, size(attribs,2), 'maxOccurs', maxoccurs ) 261 | 262 | ! 263 | ! TODO: fixed shape 264 | ! 265 | type_def(type_level)%is_array = minoccurs /= maxoccurs 266 | 267 | ! TODO: 268 | ! - optional parameters 269 | ! - array-type or not 270 | ! - map the type to the xmlreader/Fortran type 271 | 272 | return 273 | 274 | end subroutine convert_elem 275 | 276 | ! convert_attrib -- 277 | ! Convert the definition of an attribute 278 | ! 279 | ! Arguments: 280 | ! attrib Attributes making up the definition 281 | ! optional Is the item optional or not? 282 | ! 283 | subroutine convert_attrib( attribs, optional ) 284 | 285 | character(len=*), dimension(:,:) :: attribs 286 | logical :: optional 287 | 288 | character(len=40) :: name 289 | character(len=40) :: type 290 | character(len=40) :: use 291 | character(len=40) :: defvalue 292 | integer :: idx 293 | integer :: att 294 | 295 | idx = xml_find_attrib( attribs, size(attribs,2), 'name', name ) 296 | idx = xml_find_attrib( attribs, size(attribs,2), 'type', type ) 297 | 298 | if ( idx <= 0 ) then 299 | type = 'line' 300 | endif 301 | 302 | att = type_def(type_level)%number_attribs + 1 303 | type_def(type_level)%number_attribs = att 304 | 305 | type_def(type_level)%attrib_name(att) = name 306 | type_def(type_level)%attrib_type(att) = type 307 | 308 | use = 'required' 309 | defvalue = ' ' 310 | 311 | idx = xml_find_attrib( attribs, size(attribs,2), 'use' , use ) 312 | type_def(type_level)%attrib_use(att) = use == 'required' 313 | 314 | idx = xml_find_attrib( attribs, size(attribs,2), 'default' , defvalue ) 315 | type_def(type_level)%attrib_default(att) = defvalue 316 | type_def(type_level)%has_default(att) = idx > 0 317 | 318 | return 319 | 320 | end subroutine convert_attrib 321 | 322 | ! write_elem -- 323 | ! Write the definition of an element to the file 324 | ! 325 | ! Arguments: 326 | ! None 327 | ! 328 | subroutine write_elem 329 | 330 | character(len=40) :: type 331 | character(len=40) :: name 332 | integer :: i 333 | 334 | type = type_def(type_level)%type_name 335 | 336 | ! 337 | ! Write the element definition 338 | ! 339 | write( lunout, '(a)' ) '' 340 | 341 | if ( type_def(type_level)%number_attribs > 0 ) then 342 | do i = 1,type_def(type_level)%number_attribs 343 | name = type_def(type_level)%attrib_name(i) 344 | type = type_def(type_level)%attrib_type(i) 345 | 346 | write( lunout, '(a)', advance = 'no' ) ' ' 362 | enddo 363 | else 364 | ! 365 | ! No attributes given, so make it a string by default 366 | ! 367 | write( lunout, '(a)' ) ' ' 368 | endif 369 | 370 | write( lunout, '(a)' ) '' 371 | 372 | end subroutine write_elem 373 | 374 | end module handle_elems 375 | 376 | program xsdconvert 377 | 378 | use xmlparse 379 | use handle_elems 380 | 381 | character(len=80) :: filename 382 | logical :: error 383 | 384 | character(len=100), dimension(2,100) :: attribs 385 | character(len=100), dimension(100) :: data 386 | 387 | open( 10, file = 'xsdconvert.inp' ) 388 | read( 10, '(a)' ) filename 389 | open( 12, file = trim(filename) // '.xml' ) 390 | 391 | lunout = 20 392 | open( lunout, file = 'xsdconvert.out' ) 393 | write( lunout, * ) '' 394 | 395 | filename = trim(filename) // '.xsd' 396 | 397 | call xml_process( filename, attribs, data, start_elem, data_elem, & 398 | end_elem, 20, error ) 399 | 400 | end program 401 | --------------------------------------------------------------------------------