Branch data Line data Source code
1 : : !
2 : : ! Copyright (C) 2020-2021 Quantum ESPRESSO group
3 : : ! This file is distributed under the terms of the
4 : : ! GNU General Public License. See the file `License'
5 : : ! in the root directory of the present distribution,
6 : : ! or http://www.gnu.org/copyleft/gpl.txt .
7 : : !
8 : : !--------------------------------------------------------
9 : :
10 : : #if defined HAVE_CONFIG_H
11 : : #include "config.h"
12 : : #endif
13 : :
14 : : #include "abi_common.h"
15 : :
16 : : MODULE xmltools
17 : : !--------------------------------------------------------
18 : : !
19 : : ! Poor-man set of tools for reading and writing xml files
20 : : ! Similar to iotk but much simpler - Paolo Giannozzi, June 2020
21 : : ! Limitations: too many to be listed in detail. Main ones:
22 : : ! * works on a single opened file at the time. Exception:
23 : : ! while a file is opened, one can open, R/W, close another file,
24 : : ! but it is not possible to operate on both files at the same time
25 : : ! * lines no more than 1024 characters long (see maxline parameter)
26 : : ! * no more than 9 levels of tags (see maxlevel parameter)
27 : : ! * length of tags no more than 80 characters (see maxlength parameter)
28 : : ! * can read tags only in the correct order. If a tag is not found, the
29 : : ! file is rewound. If "ierr" is present, a second attempt to find the
30 : : ! tag is done starting from the top of the file - may work if the searched
31 : : ! tag is found only above the current position, and nowhere else
32 : : ! * only single values (e.g. no vectors) in attributes
33 : : ! * attributes should not contain commas or strange characters
34 : : ! * xml comments (<!-- ... -->) or <![CDATA[ ... ]]> cannot be mixed
35 : : ! with numerical fields
36 : : !
37 : : !USE upf_kinds, ONLY : dp
38 : : use defs_basis
39 : : IMPLICIT NONE
40 : : !
41 : : #undef __debug
42 : : !! define __debug to print information on opened and closed tags
43 : : LOGICAL, PARAMETER :: one_line_tags=.true.
44 : : !! if true, write tags with one value in a single line:
45 : : !! <tag attr1="val1" ... >value</tag>
46 : : !! otherwise, as in iotk:
47 : : !! <tag attr1="val1" ... >
48 : : !! value
49 : : !! </tag>
50 : : !! Only for single values; arrays are always written as in iotk
51 : : !
52 : : ! internal variables for reading and writing
53 : : !
54 : : INTEGER :: xmlunit
55 : : INTEGER, PARAMETER :: maxline=1024
56 : : CHARACTER(LEN=maxline) :: line
57 : : INTEGER :: xmlsave = -1, nopen = 0
58 : : INTEGER :: eot
59 : : ! eot points to the end of tag in line just scanned
60 : : INTEGER :: nattr
61 : : CHARACTER(LEN=:), ALLOCATABLE :: attrlist
62 : : !
63 : : ! variables used to keep track of open tags
64 : : !
65 : : INTEGER :: nlevel = -1
66 : : INTEGER, PARAMETER :: maxlength=80, maxlevel=9
67 : : CHARACTER(LEN=maxlength), DIMENSION(0:maxlevel) :: open_tags
68 : : !
69 : : PRIVATE
70 : : ! general subroutines
71 : : PUBLIC :: xml_open_file, xml_closefile
72 : : ! subroutines for writing
73 : : PUBLIC :: add_attr
74 : : PUBLIC :: xmlw_writetag, xmlw_opentag, xmlw_closetag
75 : : ! subroutines for reading
76 : : PUBLIC :: xmlr_readtag, xmlr_opentag, xmlr_closetag
77 : : PUBLIC :: get_attr
78 : : ! utility functions
79 : : PUBLIC :: xml_protect, i2c, l2c, r2c
80 : : !
81 : : ! Error codes returned by xmlr_opentag / xml_readtag:
82 : : ! -1 tag with no value (e.g. <tag attr="val"/>) found (no error)
83 : : ! 0 tag found and read (no error)
84 : : ! 1 tag not found
85 : : ! 2 error parsing file
86 : : ! 3 line too long
87 : : ! 4 too many levels of tags
88 : : !
89 : : ! Error codes returned by xmlw_opentag / xml_writetag:
90 : : ! 0 tag open and/or written (no error)
91 : : ! 1 cannot write to unit "xmlunit"
92 : : ! 2 tag name too long
93 : : ! 3 wrong number of values for attributes
94 : : ! 4 too many levels of tag
95 : : !
96 : : INTERFACE xmlr_readtag
97 : : MODULE PROCEDURE readtag_c, readtag_r, readtag_l, readtag_i, &
98 : : readtag_iv, readtag_rv, readtag_rm, readtag_rt, &
99 : : readtag_zv, readtag_zm, readtag_zt
100 : : END INTERFACE xmlr_readtag
101 : : !
102 : : ! IMPORTANT NOTICE: complex numbers, z=a+ib, are written as two reals:
103 : : ! "a b", not in fortran free format as "(a,b)". Reason:
104 : : ! make the file readable by non-fortran tools, e.g. python
105 : : !
106 : : INTERFACE xmlw_writetag
107 : : MODULE PROCEDURE writetag_c, writetag_r, writetag_l, writetag_i, &
108 : : writetag_iv, writetag_rv, writetag_rm, writetag_rt, &
109 : : writetag_zv, writetag_zm, writetag_zt
110 : : END INTERFACE xmlw_writetag
111 : : !
112 : : INTERFACE get_attr
113 : : MODULE PROCEDURE get_i_attr, get_l_attr, get_r_attr, get_c_attr
114 : : END INTERFACE get_attr
115 : :
116 : : INTERFACE add_attr
117 : : MODULE PROCEDURE add_i_attr, add_l_attr, add_r_attr, add_c_attr
118 : : END INTERFACE add_attr
119 : :
120 : : CONTAINS
121 : :
122 : 805 : SUBROUTINE get_i_attr ( attrname, attrval_i )
123 : : !
124 : : ! returns attrval_i=0 if not found or not readable
125 : : !
126 : : !IMPLICIT NONE
127 : : CHARACTER(LEN=*), INTENT(IN) :: attrname
128 : : INTEGER, INTENT(OUT) :: attrval_i
129 : : !
130 : : CHARACTER(LEN=80) :: attrval_c
131 : : !
132 : 805 : CALL get_c_attr ( attrname, attrval_c )
133 [ + + ]: 805 : if ( len_trim(attrval_c) > 0 ) then
134 [ + - ]: 719 : READ (attrval_c,*, err=1) attrval_i
135 : 719 : return
136 : : 1 print '("Error reading attribute ",a,": expected integer, found ",a)', &
137 : 0 : trim(attrname), trim(attrval_c)
138 : : end if
139 : 86 : attrval_i = 0
140 : : !
141 : : END SUBROUTINE get_i_attr
142 : : !
143 : 144 : SUBROUTINE get_l_attr ( attrname, attrval_l )
144 : : !
145 : : ! returns attrval_l=.false. if not found or not readable
146 : : !
147 : : !IMPLICIT NONE
148 : : CHARACTER(LEN=*), INTENT(IN) :: attrname
149 : : LOGICAL, INTENT(OUT) :: attrval_l
150 : : !
151 : : CHARACTER(LEN=80) :: attrval_c
152 : : !
153 : 144 : CALL get_c_attr ( attrname, attrval_c )
154 [ + + ]: 144 : if ( len_trim(attrval_c) > 0 ) then
155 [ + - ]: 114 : READ (attrval_c,*, err=1) attrval_l
156 : 114 : return
157 : : 1 print '("Error reading attribute ",a,": expected logical, found ",a)', &
158 : 0 : trim(attrname), trim(attrval_c)
159 : : end if
160 : 30 : attrval_l = .false.
161 : : !
162 : : END SUBROUTINE get_l_attr
163 : : !
164 : 668 : SUBROUTINE get_r_attr ( attrname, attrval_r )
165 : : !
166 : : ! returns attrval_r=0 if not found or not readable
167 : : !
168 : : !IMPLICIT NONE
169 : : CHARACTER(LEN=*), INTENT(IN) :: attrname
170 : : REAL(dp), INTENT(OUT) :: attrval_r
171 : : !
172 : : CHARACTER(LEN=80) :: attrval_c
173 : : !
174 : 668 : CALL get_c_attr ( attrname, attrval_c )
175 [ + + ]: 668 : if ( len_trim(attrval_c) > 0 ) then
176 [ + - ]: 363 : READ (attrval_c,*, err=1) attrval_r
177 : 363 : return
178 : : 1 print '("Error reading attribute ",a,": expected real, found ",a)', &
179 : 0 : trim(attrname), trim(attrval_c)
180 : : end if
181 : 305 : attrval_r = 0.0_dp
182 : : !
183 : : END SUBROUTINE get_r_attr
184 : : !
185 : 1932 : SUBROUTINE get_c_attr ( attrname, attrval_c )
186 : : !
187 : : ! returns attrval_c='' if not found
188 : : !
189 : : !IMPLICIT NONE
190 : : CHARACTER(LEN=*), INTENT(IN) :: attrname
191 : : CHARACTER(LEN=*), INTENT(OUT) :: attrval_c
192 : : !
193 : : CHARACTER(LEN=1) :: quote
194 : : INTEGER :: j0, j1
195 : : LOGICAL :: found
196 : : !
197 : : ! search for attribute name in attrlist: attr1="val1" attr2="val2" ...
198 : : !
199 : 1932 : attrval_c = ''
200 [ + + ]: 3326 : if ( .not. allocated(attrlist) ) return
201 [ + - ]: 1852 : if ( len_trim(attrlist) < 1 ) return
202 : : !
203 : : j0 = 1
204 [ + + ]: 14098 : do while ( j0 < len_trim(attrlist) )
205 : : ! locate = and first quote
206 : 13640 : j1 = index ( attrlist(j0:), '=' )
207 : 13640 : quote = attrlist(j0+j1:j0+j1)
208 : : ! next line: something is not right
209 [ + - ]: 13640 : if ( quote /= '"' .and. quote /= "'" ) return
210 : : ! check if attribute found: need exact match
211 [ + - ]: 13640 : found = ( trim(attrname) == adjustl(trim(attrlist(j0:j0+j1-2))) )
212 : : ! locate next quote
213 : 13640 : j0 = j0+j1+1
214 : 13640 : j1 = index ( attrlist(j0:), quote )
215 [ + + ]: 13640 : if ( found) then
216 [ + + ]: 1394 : if ( j1 == 1 ) then
217 : : ! two quotes, one after the other ("")
218 [ + - ]: 16 : attrval_c = ' '
219 : : else
220 : : ! get value between two quotes
221 [ + - + + : 1378 : attrval_c = adjustl(trim(attrlist(j0:j0+j1-2)))
+ - ]
222 : : end if
223 : 1394 : return
224 : : end if
225 : 12246 : j0 = j0+j1
226 : : end do
227 : : !
228 [ + - ]: 1932 : END SUBROUTINE get_c_attr
229 : : !
230 : 0 : SUBROUTINE add_i_attr ( attrname, attrval_i )
231 : : !
232 : : !IMPLICIT NONE
233 : : CHARACTER(LEN=*), INTENT(IN) :: attrname
234 : : INTEGER, INTENT(IN) :: attrval_i
235 : : !
236 : 0 : CALL add_c_attr ( attrname, i2c(attrval_i) )
237 : : !
238 : 0 : END SUBROUTINE add_i_attr
239 : : !
240 : 0 : SUBROUTINE add_l_attr ( attrname, attrval_l )
241 : : !
242 : : !IMPLICIT NONE
243 : : CHARACTER(LEN=*), INTENT(IN) :: attrname
244 : : LOGICAL, INTENT(IN) :: attrval_l
245 : : !
246 : 0 : CALL add_c_attr ( attrname, l2c(attrval_l) )
247 : : !
248 : 0 : END SUBROUTINE add_l_attr
249 : : !
250 : 0 : SUBROUTINE add_r_attr ( attrname, attrval_r )
251 : : !
252 : : !IMPLICIT NONE
253 : : CHARACTER(LEN=*), INTENT(IN) :: attrname
254 : : REAL(dp), INTENT(IN) :: attrval_r
255 : : !
256 : 0 : CALL add_c_attr ( attrname, r2c(attrval_r) )
257 : : !
258 : 0 : END SUBROUTINE add_r_attr
259 : : !
260 : 0 : SUBROUTINE add_c_attr ( attrname, attrval_c )
261 : : !
262 : : !IMPLICIT NONE
263 : : CHARACTER(LEN=*), INTENT(IN) :: attrname, attrval_c
264 : : !
265 [ # # ]: 0 : IF ( .NOT. ALLOCATED(attrlist) ) THEN
266 [ # # # # ]: 0 : attrlist = ' '//TRIM(attrname)//'="'//TRIM(attrval_c)//'"'
267 : : ELSE
268 [ # # # # : 0 : attrlist = attrlist // ' ' // TRIM(attrname)//'="'//TRIM(attrval_c)//'"'
# # # # #
# ]
269 : : END IF
270 : : !
271 : 0 : END SUBROUTINE add_c_attr
272 : : !
273 : 16 : FUNCTION xml_open_file ( filexml ) RESULT (iun)
274 : : !
275 : : ! returns on output the opened unit number if opened successfully
276 : : ! returns -1 otherwise
277 : : !
278 : : CHARACTER(LEN=*), INTENT(in) :: filexml
279 : : INTEGER :: iun, ios
280 : : !
281 [ - + ]: 16 : IF ( nopen > 1 ) THEN
282 : : print "('cannot open file ',a,': two xml files already opened')",&
283 : 0 : trim(filexml)
284 : : iun = -1
285 : 0 : RETURN
286 : : END IF
287 : : OPEN ( NEWUNIT=iun, FILE=filexml, FORM='formatted', STATUS='unknown', &
288 : 16 : IOSTAT=ios)
289 [ - + ]: 16 : IF ( ios /= 0 ) iun = -1
290 : 16 : nopen = nopen + 1
291 [ - + ]: 16 : IF ( nopen > 1 ) xmlsave = xmlunit
292 : 16 : xmlunit = iun
293 : 16 : nlevel = 0
294 : 16 : open_tags(nlevel) = 'root'
295 [ + + ]: 16 : if ( allocated(attrlist) ) DEALLOCATE ( attrlist)
296 : : #if defined ( __debug )
297 : : print "('file ',a,' opened with unit ',i5)",trim(filexml),iun
298 : : #endif
299 : : !
300 : 16 : END FUNCTION xml_open_file
301 : : !
302 : 16 : SUBROUTINE xml_closefile ( )
303 : : !
304 : 16 : CLOSE ( UNIT=xmlunit, STATUS='keep' )
305 : : #if defined ( __debug )
306 : : print "('unit ',i5,': file closed')", xmlunit
307 : : #endif
308 : 16 : xmlunit = xmlsave
309 : 16 : nopen = nopen - 1
310 : 16 : xmlsave = -1
311 [ - + ]: 16 : IF (nlevel > 0) print '("warning: file closed at level ",i1,&
312 [ # # ]: 0 : & " with tag ",A," open")', nlevel, trim(open_tags(nlevel))
313 : 16 : nlevel = 0
314 : : !
315 : 16 : END SUBROUTINE xml_closefile
316 : : !
317 : 0 : SUBROUTINE xmlw_opentag (name, ierr )
318 : : ! On input:
319 : : ! name required, character: tag name
320 : : ! On output: the tag is left open, ready for addition of data -
321 : : ! the tag must be subsequently closed with close_xml_tag
322 : : ! If ierr is present, the error code set in write_tag_and_attr is returned
323 : : ! If ierr is absent, the above error code is reprinted on output
324 : : !
325 : : CHARACTER(LEN=*), INTENT(IN) :: name
326 : : INTEGER, INTENT(OUT),OPTIONAL :: ierr
327 : : !
328 : : INTEGER :: ier_
329 : : CHARACTER(LEN=1) :: tag_end='>'
330 : : !
331 : 0 : ier_ = write_tag_and_attr (name)
332 : : IF ( ier_ < 0 ) ier_ = 0
333 : : ! complete tag, leaving it open for further data
334 [ # # ]: 0 : WRITE (xmlunit, "(A1)", ERR=100) tag_end
335 : : ! exit here
336 [ # # ]: 0 : 100 IF ( present(ierr) ) THEN
337 : 0 : ierr = ier_
338 [ # # ]: 0 : ELSE IF ( ier_ > 0 ) THEN
339 : 0 : print '("Fatal error ",i2," in xmlw_opentag!")', ier_
340 : : END IF
341 : : !
342 : 0 : END SUBROUTINE xmlw_opentag
343 : :
344 : 0 : SUBROUTINE writetag_c (name, cval, ierr )
345 : : ! On input, same as xmlw_opentag, plus:
346 : : ! cval character, value of the tag.
347 : : ! If cval=' ' write <name attr1="val1" attr2="val2" ... />
348 : : ! If cval='?' write <?name attr1="val1" attr2="val2" ...?>
349 : : ! otherwise, write <name attr1="val1" attr2="val2" ...>cval</name>
350 : : ! (on a same line if one_line_tags=.true.)
351 : : ! On output, same as xmlw_opentag
352 : : !
353 : : CHARACTER(LEN=*), INTENT(IN) :: name
354 : : CHARACTER(LEN=*), INTENT(IN) :: cval
355 : : INTEGER, INTENT(OUT),OPTIONAL :: ierr
356 : : !
357 : : INTEGER :: ier_
358 : : LOGICAL :: is_proc
359 : : !
360 : 0 : is_proc = (LEN_TRIM(cval) == 1)
361 [ # # # # ]: 0 : IF ( is_proc ) is_proc = is_proc .AND. ( cval(1:1) == '?')
362 : : IF (is_proc) THEN
363 : 0 : ier_ = write_tag_and_attr ( '?'//name )
364 : : ELSE
365 : 0 : ier_ = write_tag_and_attr ( name )
366 : : END IF
367 [ # # ]: 0 : IF ( ier_ > 0 ) GO TO 10
368 : : !
369 : : ! all is well: write tag value if any, close otherwise
370 : : !
371 [ # # ]: 0 : IF ( LEN_TRIM(cval) == 0 ) THEN
372 : : ! empty tag value: close here the tag
373 : 0 : CALL xmlw_closetag ( '' )
374 [ # # ]: 0 : ELSE IF ( is_proc ) THEN
375 : : ! close "process" tag (e.g. <?xml ... ?>
376 : 0 : CALL xmlw_closetag ( '?' )
377 : : ELSE
378 : : ! write value (character)
379 : : IF (one_line_tags) THEN
380 : 0 : WRITE (xmlunit, "('>',A)", ADVANCE='no') trim(cval)
381 : : ELSE
382 : : WRITE (xmlunit, "('>',/,A)") trim(cval)
383 : : ENDIF
384 : : ! close here the tag
385 : 0 : CALL xmlw_closetag ( name )
386 : : END IF
387 : : ! in case of exit error close the tag anyway
388 [ # # # # ]: 0 : 10 IF ( ier_ /= 0 ) WRITE (xmlunit, "('>')", ERR=100)
389 [ # # ]: 0 : 100 IF ( present(ierr) ) THEN
390 : 0 : ierr = ier_
391 [ # # ]: 0 : ELSE IF ( ier_ > 0 ) THEN
392 : 0 : print '("Fatal error ",i2," in xmlw_writetag!")', ier_
393 : : END IF
394 : : !
395 : 0 : END SUBROUTINE writetag_c
396 : : !
397 : 0 : SUBROUTINE writetag_i (name, ival, ierr )
398 : : !
399 : : ! As writetag_c, for integer value
400 : : !
401 : : CHARACTER(LEN=*), INTENT(IN) :: name
402 : : INTEGER, INTENT(IN) :: ival
403 : : INTEGER, INTENT(OUT),OPTIONAL :: ierr
404 : : !
405 : 0 : CALL writetag_c (name, i2c(ival), ierr )
406 : : !
407 : 0 : END SUBROUTINE writetag_i
408 : : !
409 [ # # ]: 0 : SUBROUTINE writetag_iv (name, ivec, ierr )
410 : : !
411 : : ! As writetag_c, for integer value
412 : : !
413 : : CHARACTER(LEN=*), INTENT(IN) :: name
414 : : INTEGER, INTENT(IN) :: ivec(:)
415 : : INTEGER, INTENT(OUT),OPTIONAL :: ierr
416 : : !
417 : 0 : CALL xmlw_opentag (name, ierr )
418 : 0 : WRITE( xmlunit, '(4I18)') ivec
419 : 0 : CALL xmlw_closetag ( )
420 : : !
421 : 0 : END SUBROUTINE writetag_iv
422 : : !
423 : 0 : SUBROUTINE writetag_l (name, lval, ierr )
424 : : !
425 : : ! As writetag_c, for logical value
426 : : !
427 : : CHARACTER(LEN=*), INTENT(IN) :: name
428 : : LOGICAL, INTENT(IN) :: lval
429 : : INTEGER, INTENT(OUT),OPTIONAL :: ierr
430 : : !
431 : 0 : CALL writetag_c (name, l2c(lval), ierr )
432 : : !
433 : 0 : END SUBROUTINE writetag_l
434 : : !
435 : 0 : SUBROUTINE writetag_r (name, rval, ierr )
436 : : !
437 : : ! As writetag_c, for real value
438 : : !
439 : : CHARACTER(LEN=*), INTENT(IN) :: name
440 : : REAL(dp), INTENT(IN) :: rval
441 : : INTEGER, INTENT(OUT),OPTIONAL :: ierr
442 : : !
443 : 0 : CALL writetag_c (name, r2c(rval), ierr )
444 : : !
445 : 0 : END SUBROUTINE writetag_r
446 : : !
447 [ # # ]: 0 : SUBROUTINE writetag_rv (name, rvec, ierr )
448 : : !
449 : : ! As writetag_c, for a vector of real values
450 : : !
451 : : CHARACTER(LEN=*), INTENT(IN) :: name
452 : : REAL(dp), INTENT(IN) :: rvec(:)
453 : : INTEGER, INTENT(OUT),OPTIONAL :: ierr
454 : : !
455 : 0 : CALL xmlw_opentag (name, ierr )
456 : 0 : WRITE( xmlunit, '(3es24.15)') rvec
457 : 0 : CALL xmlw_closetag ( )
458 : : !
459 : 0 : END SUBROUTINE writetag_rv
460 : : !
461 [ # # ]: 0 : SUBROUTINE writetag_rm (name, rmat, ierr )
462 : : !
463 : : ! As writetag_c, for a matrix of real values
464 : : !
465 : : CHARACTER(LEN=*), INTENT(IN) :: name
466 : : REAL(dp), INTENT(IN) :: rmat(:,:)
467 : : INTEGER, INTENT(OUT),OPTIONAL :: ierr
468 : : !
469 : 0 : CALL xmlw_opentag (name, ierr )
470 : 0 : WRITE( xmlunit, '(3es24.15)') rmat
471 : 0 : CALL xmlw_closetag ( )
472 : : !
473 : 0 : END SUBROUTINE writetag_rm
474 : : !
475 [ # # ]: 0 : SUBROUTINE writetag_rt (name, rtens, ierr )
476 : : !
477 : : ! As writetag_c, for a 3-dim tensor of real values
478 : : !
479 : : CHARACTER(LEN=*), INTENT(IN) :: name
480 : : REAL(dp), INTENT(IN) :: rtens(:,:,:)
481 : : INTEGER, INTENT(OUT),OPTIONAL :: ierr
482 : : !
483 : 0 : CALL xmlw_opentag (name, ierr )
484 : 0 : WRITE( xmlunit, '(3es24.15)') rtens
485 : 0 : CALL xmlw_closetag ( )
486 : : !
487 : 0 : END SUBROUTINE writetag_rt
488 : : !
489 : 0 : SUBROUTINE writetag_zv (name, zvec, ierr )
490 : : !
491 : : ! As writetag_c, for a vector of complex values
492 : : !
493 : : use, intrinsic :: iso_c_binding
494 : : CHARACTER(LEN=*), INTENT(IN) :: name
495 : : COMPLEX(dp), INTENT(IN), TARGET:: zvec(:)
496 : : INTEGER, INTENT(OUT), OPTIONAL :: ierr
497 : : !
498 : : ! Casts a real pointer (rvec) to a complex array (zvec) via C pointer (!)
499 : : ! in order to write complexes as two reals. Some compilers require that
500 : : ! the argument of c_loc (zvec) is a pointer or has the "target" attribute
501 : : !
502 : : TYPE (c_ptr) :: cp
503 : 0 : REAL(dp), POINTER :: rvec(:)
504 : : INTEGER :: n, ndim
505 : : !
506 : 0 : NULLIFY (rvec)
507 : 0 : cp = c_loc(zvec)
508 [ # # ]: 0 : CALL c_f_pointer (cp, rvec, shape(zvec)*[2])
509 : 0 : CALL xmlw_opentag (name, ierr )
510 : 0 : ndim = SIZE (zvec)
511 [ # # # # ]: 0 : DO n=1,2*ndim,2
512 : 0 : WRITE( xmlunit, *) rvec(n), rvec(n+1)
513 : : END DO
514 : 0 : CALL xmlw_closetag ( )
515 : : !
516 : 0 : END SUBROUTINE writetag_zv
517 : : !
518 : 0 : SUBROUTINE writetag_zm (name, zmat, ierr )
519 : : !
520 : : ! As writetag_c for a matrix of complex values - see comments in writetag_zv
521 : : !
522 : : use, intrinsic :: iso_c_binding
523 : : CHARACTER(LEN=*), INTENT(IN) :: name
524 : : COMPLEX(dp), INTENT(IN), TARGET:: zmat(:,:)
525 : : INTEGER, INTENT(OUT), OPTIONAL :: ierr
526 : : !
527 : : TYPE (c_ptr) :: cp
528 : 0 : REAL(dp), POINTER :: rmat(:,:)
529 : : !
530 : 0 : NULLIFY (rmat)
531 : 0 : cp = c_loc(zmat)
532 [ # # ]: 0 : CALL c_f_pointer (cp, rmat, shape(zmat)*[2,1])
533 : : !
534 : 0 : CALL xmlw_opentag (name, ierr )
535 [ # # # # ]: 0 : WRITE( xmlunit, '(2es24.15)') rmat
536 : 0 : CALL xmlw_closetag ( )
537 : : !
538 : 0 : END SUBROUTINE writetag_zm
539 : : !
540 : 0 : SUBROUTINE writetag_zt (name, ztens, ierr )
541 : : !
542 : : ! As writetag_c for a matrix of complex values - see comments in writetag_zv
543 : : !
544 : : use, intrinsic :: iso_c_binding
545 : : CHARACTER(LEN=*), INTENT(IN) :: name
546 : : COMPLEX(dp), INTENT(IN), TARGET:: ztens(:,:,:)
547 : : INTEGER, INTENT(OUT), OPTIONAL :: ierr
548 : : !
549 : : TYPE (c_ptr) :: cp
550 : 0 : REAL(dp), POINTER :: rtens(:,:,:)
551 : : !
552 : 0 : NULLIFY (rtens)
553 : 0 : cp = c_loc(ztens)
554 [ # # ]: 0 : CALL c_f_pointer (cp, rtens, shape(ztens)*[2,1,1])
555 : : !
556 : 0 : CALL xmlw_opentag (name, ierr )
557 [ # # # # : 0 : WRITE( xmlunit, '(2es24.15)') rtens
# # ]
558 : 0 : CALL xmlw_closetag ( )
559 : : !
560 : 0 : END SUBROUTINE writetag_zt
561 : : !
562 : 0 : FUNCTION write_tag_and_attr (name) RESULT (ierr)
563 : : !
564 : : CHARACTER(LEN=*), INTENT(IN) :: name
565 : : INTEGER :: ierr
566 : : ! See list of error codes in the header of this file
567 : : !
568 : : !LOGICAL :: have_list, have_vals
569 : : INTEGER :: i !, la, lv, n1a,n2a, n1v, n2v
570 : : !
571 : 0 : IF ( LEN_TRIM(name) > maxlength ) THEN
572 : 0 : ierr = 2
573 : : RETURN
574 : : END IF
575 : : !
576 [ # # ]: 0 : IF ( nlevel+1 > maxlevel ) THEN
577 : 0 : ierr = 4
578 : : RETURN
579 : : END IF
580 : 0 : nlevel = nlevel+1
581 [ # # ]: 0 : open_tags(nlevel) = TRIM(name)
582 : : !
583 : : ! pretty (?) printing
584 : : !
585 : 0 : ierr = 1
586 [ # # ]: 0 : DO i=2,nlevel
587 [ # # ]: 0 : WRITE (xmlunit, "(' ')", ADVANCE="no", ERR=10)
588 : : END DO
589 [ # # ]: 0 : WRITE (xmlunit, "('<',A)", ADVANCE="no", ERR=10) trim(name)
590 : : #if defined ( __debug )
591 : : print '("opened (write) level-",i1," tag ",A)', nlevel, trim(open_tags(nlevel))
592 : : #endif
593 : : !
594 : : ! attributes (if present)
595 : : !
596 : 0 : ierr = 3
597 [ # # ]: 0 : if ( allocated (attrlist) ) then
598 [ # # ]: 0 : WRITE (xmlunit, "(A)", ADVANCE='no', ERR=10) attrlist
599 [ # # ]: 0 : deallocate (attrlist)
600 : : end if
601 : : ! normal exit here
602 : : ierr = 0
603 : : 10 RETURN
604 : : !
605 [ # # ]: 0 : END FUNCTION write_tag_and_attr
606 : : !
607 : 0 : SUBROUTINE xmlw_closetag ( tag )
608 : : ! tag not present: close current open tag with </tag>
609 : : ! empty tag present: close current open tag with />
610 : : ! tag='?' present: close current open tag with ?>
611 : : ! otherwise,close specified tag with </tag>
612 : : CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: tag
613 : : INTEGER :: i
614 : : !
615 [ # # ]: 0 : IF ( nlevel < 0 ) THEN
616 : 0 : print "('xmlw_closetag: severe error, closing tag that was never opened')"
617 : 0 : RETURN
618 : : END IF
619 [ # # ]: 0 : IF ( .NOT.PRESENT(tag) ) THEN
620 [ # # ]: 0 : DO i=2,nlevel
621 : 0 : WRITE (xmlunit, '(" ")', ADVANCE='NO')
622 : : END DO
623 [ # # ]: 0 : WRITE (xmlunit, '("</",A,">")') trim(open_tags(nlevel))
624 : : #if defined ( __debug )
625 : : print '("closed (write) level-",i1," tag ",A)', nlevel, trim(open_tags(nlevel))
626 : : #endif
627 : : ELSE
628 : 0 : i = len_trim(tag)
629 [ # # ]: 0 : IF ( i == 0 ) THEN
630 : 0 : WRITE (xmlunit, '("/>")')
631 : : #if defined ( __debug )
632 : : print '("closed (write) level-",i1," tag ",A)', &
633 : : nlevel, trim(open_tags(nlevel))
634 : : #endif
635 [ # # # # ]: 0 : ELSE IF ( i == 1 .AND. tag(1:1) == '?' ) THEN
636 : 0 : WRITE (xmlunit, '("?>")')
637 : : #if defined ( __debug )
638 : : print '("closed (write) level-",i1," tag ",A)', nlevel, tag
639 : : #endif
640 : : ELSE
641 : 0 : WRITE (xmlunit, '("</",A,">")') trim(tag)
642 : : #if defined ( __debug )
643 : : print '("closed (write) level-",i1," tag ",A)', nlevel, tag
644 : : #endif
645 : : END IF
646 : : END IF
647 : 0 : nlevel = nlevel-1
648 : : !
649 : : END SUBROUTINE xmlw_closetag
650 : : !
651 : : !--------------------------------------------------------
652 : 0 : function xml_protect ( data_in ) result (data_out)
653 : : !--------------------------------------------------------
654 : : !
655 : : ! poor-man escaping of a string so that it conforms to xml standard:
656 : : ! replace & with @, < and > with *.
657 : : ! To prevent problems with attributes, double quotes " are replaced
658 : : ! with single quotes '. data_out is left-justified
659 : : !
660 : : character(len=*), intent(in) :: data_in
661 : : character(len=:), allocatable :: data_out
662 : : !character(len=1) :: c
663 : : integer:: n, i
664 : : !
665 : 0 : n = len_trim(adjustl(data_in))
666 : : ! Alternative version with CDATA:
667 : : ! allocate(character(len=n+12):: data_out)
668 : : ! data_out = '<![CDATA['//trim(adjustl(data_in))//']]>'
669 [ # # # # : 0 : data_out = trim(adjustl(data_in))
# # # # ]
670 [ # # ]: 0 : do i=1,n
671 [ # # ]: 0 : if ( data_out(i:i) == '&' ) data_out(i:i) = '@'
672 [ # # # # ]: 0 : if ( data_out(i:i) == '<' .or. data_out(i:i) == '>') data_out(i:i) = '*'
673 [ # # ]: 0 : if ( data_out(i:i) == '"' ) data_out(i:i) = "'"
674 : : end do
675 : : ! a more complete version should escape & as &, < as <
676 : : ! (escaping > as > , " as "es; , ' as &apo; is not strictly needed)
677 : : ! BUT taking care not to escape & into &amp;
678 : :
679 : 0 : end function xml_protect
680 : :
681 : : ! Poor-man conversion utilities from integer, logical, real to character
682 : : ! To be used in conjunction with routines in module xmlw to write xml
683 : : !
684 : 261 : function i2c (i) result (c)
685 : : integer, intent(in) :: i
686 : : character(len=:), allocatable :: c
687 : : character(len=11) :: caux
688 : : !
689 : 261 : write(caux,'(i11)') i
690 [ + - - - : 261 : c = trim(adjustl(caux))
+ - + - ]
691 : : !
692 : 261 : end function i2c
693 : :
694 : 0 : function l2c (l) result (c)
695 : : logical, intent(in) :: l
696 : : character(len=:), allocatable :: c
697 : : !
698 [ # # ]: 0 : if (l) then
699 : 0 : c='true'
700 : : else
701 : 0 : c='false'
702 : : endif
703 : : !
704 : 0 : end function l2c
705 : :
706 : 0 : function r2c (f) result (c)
707 : : real(dp), intent(in) :: f
708 : : character(len=:), allocatable :: c
709 : : character(len=30) :: caux
710 : : !
711 : : !integer :: n, m, i
712 : : ! The format of real numbers can be vastly improved
713 : : ! this is just the simplest solution
714 : 0 : write(caux,*) f
715 [ # # # # : 0 : c = trim(adjustl(caux))
# # # # ]
716 : : !
717 : 0 : end function r2c
718 : : !
719 : 0 : SUBROUTINE readtag_i (name, ival, ierr )
720 : : !
721 : : ! As readtag_c, for integer value
722 : : !
723 : : CHARACTER(LEN=*), INTENT(IN) :: name
724 : : INTEGER, INTENT(OUT) :: ival
725 : : INTEGER, INTENT(OUT),OPTIONAL :: ierr
726 : : CHARACTER(LEN=80) :: cval
727 : : !
728 : 0 : CALL readtag_c (name, cval, ierr )
729 [ # # ]: 0 : if ( len_trim(cval) > 0 ) then
730 : 0 : READ (cval,*) ival
731 : : else
732 : 0 : ival = 0
733 : : end if
734 : : !
735 : 0 : END SUBROUTINE readtag_i
736 : : !
737 [ # # ]: 0 : SUBROUTINE readtag_iv (name, ivec, ierr)
738 : : !
739 : : ! As readtag_c, for a vector of integer values
740 : : !
741 : : CHARACTER(LEN=*), INTENT(IN) :: name
742 : : INTEGER, INTENT(OUT) :: ivec(:)
743 : : INTEGER, INTENT(OUT),OPTIONAL :: ierr
744 : : INTEGER :: ier_
745 : : !
746 : 0 : CALL xmlr_opentag (name, ier_)
747 [ # # ]: 0 : if ( ier_ == 0 ) then
748 : 0 : READ(xmlunit, *) ivec
749 : 0 : CALL xmlr_closetag ( )
750 : : else
751 [ # # ]: 0 : ivec = 0.0_dp
752 : : end if
753 [ # # ]: 0 : IF ( present (ierr) ) ierr = ier_
754 : : !
755 : 0 : END SUBROUTINE readtag_iv
756 : : !
757 : 0 : SUBROUTINE readtag_l (name, lval, ierr )
758 : : !
759 : : ! As readtag_c, for logical value
760 : : !
761 : : CHARACTER(LEN=*), INTENT(IN) :: name
762 : : LOGICAL, INTENT(OUT) :: lval
763 : : INTEGER, INTENT(OUT),OPTIONAL :: ierr
764 : : CHARACTER(LEN=80) :: cval
765 : : !
766 : 0 : CALL readtag_c (name, cval, ierr )
767 [ # # ]: 0 : if ( len_trim(cval) > 0 ) then
768 : 0 : READ (cval,*) lval
769 : : else
770 : 0 : lval = .false.
771 : : end if
772 : : !
773 : 0 : END SUBROUTINE readtag_l
774 : : !
775 : 0 : SUBROUTINE readtag_r (name, rval, ierr )
776 : : !
777 : : ! As readtag_c, for real value
778 : : !
779 : : CHARACTER(LEN=*), INTENT(IN) :: name
780 : : REAL(dp), INTENT(OUT) :: rval
781 : : INTEGER, INTENT(OUT),OPTIONAL :: ierr
782 : : CHARACTER(LEN=80) :: cval
783 : : !
784 : 0 : CALL readtag_c (name, cval, ierr )
785 [ # # ]: 0 : if ( len_trim(cval) > 0 ) then
786 : 0 : READ (cval,*) rval
787 : : else
788 : 0 : rval = 0.0_dp
789 : : end if
790 : : !
791 : 0 : END SUBROUTINE readtag_r
792 : : !
793 [ - + ]: 283 : SUBROUTINE readtag_rv (name, rvec, ierr)
794 : : !
795 : : ! As readtag_c, for a vector of real values
796 : : !
797 : : CHARACTER(LEN=*), INTENT(IN) :: name
798 : : REAL(dp), INTENT(OUT) :: rvec(:)
799 : : INTEGER, INTENT(OUT),OPTIONAL :: ierr
800 : : INTEGER :: ier_
801 : : !
802 : 283 : CALL xmlr_opentag (name, ier_)
803 [ + + ]: 283 : if ( ier_ == 0 ) then
804 : 259 : READ(xmlunit, *) rvec
805 : 259 : CALL xmlr_closetag ( )
806 : : else
807 [ + + ]: 34404 : rvec = 0.0_dp
808 : : end if
809 [ + + ]: 283 : IF ( present (ierr) ) ierr = ier_
810 : : !
811 : 283 : END SUBROUTINE readtag_rv
812 : : !
813 [ - + ]: 16 : SUBROUTINE readtag_rm (name, rmat, ierr)
814 : : !
815 : : ! As readtag_c, for a matrix of real values
816 : : !
817 : : CHARACTER(LEN=*), INTENT(IN) :: name
818 : : REAL(dp), INTENT(OUT) :: rmat(:,:)
819 : : INTEGER, INTENT(OUT),OPTIONAL :: ierr
820 : : INTEGER :: ier_
821 : : !
822 : 16 : CALL xmlr_opentag (name, ier_)
823 [ - + ]: 16 : if ( ier_ == 0 ) then
824 : 16 : READ(xmlunit, *) rmat
825 : 16 : CALL xmlr_closetag ( )
826 : : else
827 [ # # # # ]: 0 : rmat = 0.0_dp
828 : : end if
829 [ - + ]: 16 : IF ( present (ierr) ) ierr = ier_
830 : : !
831 : 16 : END SUBROUTINE readtag_rm
832 : : !
833 [ # # ]: 0 : SUBROUTINE readtag_rt (name, rtens, ierr)
834 : : !
835 : : ! As readtag_c, for a 3-dim tensor of real values
836 : : !
837 : : CHARACTER(LEN=*), INTENT(IN) :: name
838 : : REAL(dp), INTENT(OUT) :: rtens(:,:,:)
839 : : INTEGER, INTENT(OUT),OPTIONAL :: ierr
840 : : INTEGER :: ier_
841 : : !
842 : 0 : CALL xmlr_opentag (name, ier_)
843 [ # # ]: 0 : if ( ier_ == 0 ) then
844 : 0 : READ(xmlunit, *) rtens
845 : 0 : CALL xmlr_closetag ( )
846 : : else
847 [ # # # # : 0 : rtens = 0.0_dp
# # ]
848 : : end if
849 [ # # ]: 0 : IF ( present (ierr) ) ierr = ier_
850 : : !
851 : 0 : END SUBROUTINE readtag_rt
852 : : !
853 [ # # ]: 0 : SUBROUTINE readtag_zv (name, zvec, ierr)
854 : : !
855 : : ! As readtag_c, for a vector of complex values - see comments in writetag_zv
856 : : !
857 : : use, intrinsic :: iso_c_binding
858 : : CHARACTER(LEN=*), INTENT(IN) :: name
859 : : COMPLEX(dp), INTENT(OUT), target :: zvec(:)
860 : : INTEGER, INTENT(OUT),OPTIONAL :: ierr
861 : : !
862 : : TYPE (c_ptr) :: cp
863 : 0 : REAL(dp), POINTER :: rvec(:)
864 : : INTEGER :: ier_
865 : : !
866 : 0 : CALL xmlr_opentag (name, ier_)
867 [ # # ]: 0 : if ( ier_ == 0 ) then
868 : 0 : NULLIFY (rvec)
869 : 0 : cp = c_loc(zvec)
870 [ # # ]: 0 : CALL c_f_pointer ( cp, rvec, shape(zvec)*[2])
871 [ # # ]: 0 : READ( xmlunit, *) rvec
872 : 0 : CALL xmlr_closetag ( )
873 : : else
874 [ # # ]: 0 : zvec = 0.0_dp
875 : : end if
876 [ # # ]: 0 : IF ( present (ierr) ) ierr = ier_
877 : : !
878 : 0 : END SUBROUTINE readtag_zv
879 : : !
880 [ # # ]: 0 : SUBROUTINE readtag_zm (name, zmat, ierr)
881 : : !
882 : : ! As readtag_c, for a matrix of complex values - see comments in writetag_zv
883 : : !
884 : : use, intrinsic :: iso_c_binding
885 : : CHARACTER(LEN=*), INTENT(IN) :: name
886 : : COMPLEX(dp), INTENT(OUT), target :: zmat(:,:)
887 : : INTEGER, INTENT(OUT),OPTIONAL :: ierr
888 : : TYPE (c_ptr) :: cp
889 : 0 : REAL(dp), POINTER :: rmat(:,:)
890 : : INTEGER :: ier_
891 : : !
892 : 0 : CALL xmlr_opentag (name, ier_)
893 [ # # ]: 0 : if ( ier_ == 0 ) then
894 : 0 : NULLIFY (rmat)
895 : 0 : cp = c_loc(zmat)
896 [ # # ]: 0 : CALL c_f_pointer (cp, rmat, shape(zmat)*[2,1])
897 [ # # # # ]: 0 : READ(xmlunit, *) rmat
898 : 0 : CALL xmlr_closetag ( )
899 : : else
900 [ # # # # ]: 0 : zmat = 0.0_dp
901 : : end if
902 [ # # ]: 0 : IF ( present (ierr) ) ierr = ier_
903 : : !
904 : 0 : END SUBROUTINE readtag_zm
905 : : !
906 [ # # ]: 0 : SUBROUTINE readtag_zt (name, ztens, ierr)
907 : : !
908 : : ! As readtag_c, for a matrix of complex values - see comments in writetag_zv
909 : : !
910 : : use, intrinsic :: iso_c_binding
911 : : CHARACTER(LEN=*), INTENT(IN) :: name
912 : : COMPLEX(dp), INTENT(OUT), target :: ztens(:,:,:)
913 : : INTEGER, INTENT(OUT),OPTIONAL :: ierr
914 : : TYPE (c_ptr) :: cp
915 : 0 : REAL(dp), POINTER :: rtens(:,:,:)
916 : : INTEGER :: ier_
917 : : !
918 : 0 : CALL xmlr_opentag (name, ier_)
919 [ # # ]: 0 : if ( ier_ == 0 ) then
920 : 0 : NULLIFY (rtens)
921 : 0 : cp = c_loc(ztens)
922 [ # # ]: 0 : CALL c_f_pointer (cp, rtens, shape(ztens)*[2,1,1])
923 [ # # # # : 0 : READ(xmlunit, *) rtens
# # ]
924 : 0 : CALL xmlr_closetag ( )
925 : : else
926 [ # # # # : 0 : ztens = 0.0_dp
# # ]
927 : : end if
928 [ # # ]: 0 : IF ( present (ierr) ) ierr = ier_
929 : : !
930 : 0 : END SUBROUTINE readtag_zt
931 : : !
932 : 106 : subroutine readtag_c ( tag, cval, ierr)
933 : : !
934 : : !implicit none
935 : : !
936 : : character(len=*), intent(in) :: tag
937 : : character(len=*), intent(out):: cval
938 : : integer, intent(out), optional :: ierr
939 : : !
940 : : integer :: i, j, lt !, ll
941 : : character(len=1) :: endtag
942 : : !
943 : 106 : call xmlr_opentag ( tag, ierr )
944 : : !
945 [ + - ]: 106 : cval = ''
946 [ - + ]: 106 : if ( eot < 0 ) then
947 [ # # ]: 0 : if ( .not. present(ierr) ) then
948 : 0 : write(std_out,*) 'end of file reached, tag not found'
949 : : else
950 : 0 : ierr = 1
951 : : end if
952 : 106 : return
953 [ - + ]: 106 : else if ( eot == 0 ) then
954 : : ! print *, 'tag found, no value to read on line'
955 : : return
956 : : else
957 : : ! scan current line if there is something after the end of tag
958 : : ! (variable "eot"); read a new line otherwise
959 : 0 : do while(.true.)
960 [ # # ]: 0 : if ( eot > len_trim(line) ) then
961 [ # # ]: 0 : read(xmlunit,'(a)', end=10) line
962 : 0 : j = 1
963 : : else
964 : : j = eot
965 : : end if
966 : : ! beginning of val at line(j:j): search for end tag
967 : 0 : i = index ( line(j:), '</'//trim(tag) )
968 [ # # ]: 0 : if ( i < 1 ) then
969 : : ! </tag> not found on this line: read value and continue
970 [ # # # # : 0 : cval = trim(cval) // adjustl(trim(line(j:)))
# # ]
971 : : else
972 : : ! possible end tag found
973 : 0 : lt = len_trim(tag)
974 [ # # ]: 0 : endtag = adjustl( line(j+i+1+lt:) )
975 [ # # ]: 0 : if ( endtag /= '>' ) then
976 [ # # ]: 0 : if ( .not.present(ierr)) then
977 : 0 : write(std_out,*) 'tag ',trim(tag),' not correctly closed'
978 : : else
979 : 0 : ierr = 2
980 : : endif
981 : : else
982 : : ! end of tag found, read value (if any) and exit
983 [ # # # # : 0 : if ( i > 1 ) cval = trim(cval) // adjustl(trim(line(j:j+i-2)))
# # # # ]
984 : : ! print *, 'value=',cval
985 : : end if
986 : : #if defined ( __debug )
987 : : print '("closed (read) level-",i1," tag ",A)', &
988 : : nlevel, trim(open_tags(nlevel))
989 : : #endif
990 : 0 : nlevel = nlevel -1
991 : : !
992 : 0 : return
993 : : !
994 : : endif
995 : : !
996 : : end do
997 : : !
998 : : end if
999 : : ! print *, 'tag </',trim(tag),'> not found'
1000 [ # # ]: 0 : 10 if ( present(ierr) ) then
1001 : 0 : ierr = 1
1002 : : else
1003 : 0 : write(std_out,*) 'end of file reached, tag </'//trim(tag)//'> not found'
1004 : : end if
1005 : : !
1006 : 106 : end subroutine readtag_c
1007 : : !
1008 : 491 : subroutine xmlr_opentag ( tag, ierr)
1009 : : !
1010 : : !implicit none
1011 : : !
1012 : : character(len=*), intent(in) :: tag
1013 : : integer, intent(out), optional :: ierr
1014 : : ! See list of error codes in the header of this file
1015 : : integer :: stat, ntry, ll, lt, i, j, j0
1016 : : ! stat=-1: in comment (not actually used)
1017 : : ! stat= 0: begin
1018 : : ! stat= 1: tag found
1019 : : !
1020 : : character(len=1) :: quote
1021 : : !
1022 : 491 : nattr=0
1023 : 491 : ntry =0
1024 : 387 : if ( allocated(attrlist) ) deallocate (attrlist)
1025 : 491 : lt = len_trim(tag)
1026 : : !
1027 : 557 : 1 ntry = ntry+1
1028 : 557 : stat=0
1029 : 557 : eot =-1
1030 : : do while (.true.)
1031 [ + + ]: 619182 : read(xmlunit,'(a)', end=10) line
1032 : 619076 : ll = len_trim(line)
1033 [ - + ]: 619076 : if ( ll == maxline ) then
1034 : 0 : write(std_out,*)'xmlr_opentag: severe error, line too long'
1035 [ # # ]: 0 : if (present(ierr)) ierr = 3
1036 : 451 : return
1037 : : end if
1038 : : ! j is the current scan position
1039 : : j = 1
1040 : : ! j0 is the start of attributes and values
1041 : : j0 = 1
1042 [ + + ]: 644225 : parse: do while ( j <= ll )
1043 : : !
1044 : : ! following case is never set and unnecessary:
1045 : : !if ( stat ==-1 ) then
1046 : : ! ! scanning a comment
1047 : : ! i = index(line(j:),'-->')
1048 : : ! if ( i == 0 ) then
1049 : : ! ! no end of comment found on this line
1050 : : ! exit parse
1051 : : ! else
1052 : : ! ! end of comment found
1053 : : ! stat = 0
1054 : : ! j = j+i+3
1055 : : ! end if
1056 : : !else if ( stat == 0 ) then
1057 [ + + ]: 1260757 : if ( stat == 0 ) then
1058 : : !
1059 : : ! searching for tag
1060 : : !
1061 : 616983 : i = index( line(j:),'<'//trim(tag) )
1062 [ + + ]: 616983 : if ( i == 0 ) then
1063 : : ! no tag found on this line
1064 : : exit parse
1065 : : else
1066 : : ! tag found? check what follows our would-be tag
1067 : 451 : j = j+i+lt
1068 [ + + ]: 451 : if ( j > ll ) then
1069 : : stat = 1
1070 : : ! <tag continues in next line
1071 : : exit parse
1072 : : else if ( line(j:j) == ' ' .or. line(j:j) == '>' &
1073 [ + + - + : 264 : .or. line(j:j+1)=='/>') then
- - ]
1074 : : ! <tag or <tag> or <tag/> found
1075 : 264 : stat = 1
1076 : : end if
1077 : : end if
1078 : : !
1079 : : else if ( stat == 1 ) then
1080 : : ! tag found, search for attributes if any or end of tag
1081 [ + + ]: 25336 : if (line(j:j) == ' ' ) then
1082 : : ! skip blanks: there is at least one if attributes are present
1083 : 3577 : j = j+1
1084 : : ! save value of j into j0: beginning of an attribute
1085 : 3577 : j0= j
1086 [ + + ]: 21759 : else if ( line(j:j+1) == '/>' ) then
1087 : : ! <tag ... /> found : return
1088 [ + + ]: 106 : if (present(ierr)) ierr =-1
1089 : : ! eot = 0: tag with no value found
1090 : 106 : eot = 0
1091 : : !
1092 : 106 : return
1093 : : !
1094 [ + + ]: 21653 : else if ( line(j:j) == '>' ) then
1095 : : ! <tag ... > found
1096 : : ! eot points to the rest of the line
1097 : 345 : eot = j+1
1098 [ + + ]: 345 : if (present(ierr)) ierr = 0
1099 : 345 : nlevel = nlevel+1
1100 [ - + ]: 345 : IF ( nlevel > maxlevel ) THEN
1101 : 0 : write(std_out,*) 'xmlr_opentag: severe error, too many levels'
1102 [ # # ]: 0 : if (present(ierr)) ierr = 4
1103 : : else
1104 [ + - ]: 345 : open_tags(nlevel) = trim(tag)
1105 : : #if defined ( __debug )
1106 : : print '("opened (read) level-",i1," tag ",A)',&
1107 : : nlevel, trim(open_tags(nlevel))
1108 : : #endif
1109 : : end if
1110 : : !
1111 : 345 : return
1112 : : !
1113 [ + + ]: 21308 : else if ( line(j:j) == '=' ) then
1114 : : ! end of attribute located: save attribute (with final =)
1115 : 2249 : nattr=nattr+1
1116 : : ! print *, 'attr=',line(j0:j-1)
1117 [ + + ]: 2249 : if ( nattr == 1 ) then
1118 [ + - - - : 397 : attrlist = line(j0:j)
- + ]
1119 : : else
1120 [ + - - + : 1852 : attrlist = attrlist//' '//line(j0:j)
+ - + - -
+ ]
1121 : : end if
1122 : : ! continue searching for attribute value
1123 : : j = j+1
1124 [ + + + - ]: 19059 : else if ( line(j:j) == '"' .or. line(j:j) =="'" ) then
1125 : : ! first occurrence of ' or " found, look for next
1126 : 2249 : quote = line(j:j)
1127 : 2249 : i = index(line(j+1:),quote)
1128 [ + - ]: 2249 : if ( i < 1 ) then
1129 : : ! print *, 'Error: matching quote not found'
1130 : : go to 10
1131 : : else
1132 : : ! save attribute value (with quotes) and continue scanning
1133 : : ! print *, 'attrval=',line(j:j+i-2)
1134 [ + - - + : 2249 : attrlist = attrlist//line(j:j+i)
+ - + - +
- ]
1135 : 2249 : j = j+i+1
1136 : : end if
1137 : : else
1138 : : ! continue scanning until end of attribute
1139 : : j = j+1
1140 : : endif
1141 : : !
1142 : : end if
1143 : : end do parse
1144 : : !
1145 : : end do
1146 : : !
1147 [ + - ]: 106 : 10 if ( stat == 0 ) then
1148 [ + - ]: 106 : if ( present(ierr) ) then
1149 : 106 : ierr = 1
1150 : : ! quick-and-dirty pseudo-fix to deal with tags not found:
1151 : : ! rewind and try again - will work if the desired tag is
1152 : : ! found above the current position (and nowhere else)
1153 : 106 : rewind(xmlunit)
1154 [ + + ]: 106 : if ( ntry == 1 ) go to 1
1155 : : else
1156 : 0 : write(std_out,*) 'end of file reached, tag '//trim(tag)//' not found'
1157 : : end if
1158 : : else
1159 : 0 : write(std_out,*) 'xmlr_opentag: severe parsing error'
1160 [ # # ]: 0 : if ( present(ierr) ) ierr = 2
1161 : : end if
1162 : : !
1163 [ + + ]: 491 : end subroutine xmlr_opentag
1164 : : !
1165 : 345 : subroutine xmlr_closetag ( tag, ierr)
1166 : : !
1167 : : !implicit none
1168 : : !
1169 : : character(len=*), intent(in), optional :: tag
1170 : : integer, intent(out), optional :: ierr
1171 : : ! 0: </tag> found
1172 : : ! 1: </tag> not found
1173 : : ! 2: error parsing file
1174 : : !
1175 : : integer :: stat, ll, lt, i, j
1176 : : ! stat=-1: in comment (not actually used)
1177 : : ! stat= 0: begin
1178 : : ! stat= 1: end
1179 : : !
1180 [ - + ]: 345 : if ( nlevel < 0 ) &
1181 : 0 : print '("xmlr_closetag: severe error, closing tag that was never opened")'
1182 : : stat=0
1183 : : #if defined ( __debug )
1184 : : if ( .not. present(tag) ) then
1185 : : print '("closed (read) level-",i1," tag ",A)', &
1186 : : nlevel, trim(open_tags(nlevel))
1187 : : else
1188 : : print '("closed (read) level-",i1," tag ",A)', nlevel, tag
1189 : : end if
1190 : : #endif
1191 : : do while (.true.)
1192 [ + - ]: 24336 : read(xmlunit,'(a)', end=10) line
1193 : 24336 : ll = len_trim(line)
1194 [ - + ]: 24336 : if ( ll == maxline ) then
1195 : 0 : write(std_out,*) 'Fatal error: line too long'
1196 [ # # ]: 0 : if (present(ierr)) ierr = 2
1197 : 0 : return
1198 : : end if
1199 : : ! j is the current scan position
1200 : : j = 1
1201 [ + + ]: 24681 : parse: do while ( j <= ll )
1202 : : !
1203 : : ! following case is never set and unnecessary:
1204 : : !if ( stat ==-1 ) then
1205 : : ! scanning a comment
1206 : : ! i = index(line(j:),'-->')
1207 : : ! if ( i == 0 ) then
1208 : : ! no end of comment found on this line
1209 : : ! exit parse
1210 : : ! else
1211 : : ! end of comment found
1212 : : ! stat = 0
1213 : : ! j = j+i+3
1214 : : ! end if
1215 : : !else if ( stat == 0 ) then
1216 [ + + ]: 48648 : if ( stat == 0 ) then
1217 : : !
1218 : : ! searching for closing tag
1219 : : !
1220 [ + - ]: 24312 : IF ( .NOT.PRESENT(tag) ) THEN
1221 [ + - ]: 24312 : i = index( line(j:),'</'//trim(open_tags(nlevel)) )
1222 : 24312 : lt= len_trim(open_tags(nlevel))
1223 : : ELSE
1224 : 0 : i = index( line(j:),'</'//trim(tag) )
1225 : 0 : lt= len_trim(tag)
1226 : : END IF
1227 [ + + ]: 24312 : if ( i == 0 ) then
1228 : : ! no tag found on this line
1229 : : exit parse
1230 : : else
1231 : : ! tag found? check what follows our would-be tag
1232 : 345 : j = j+i+1+lt
1233 [ - + ]: 345 : if ( j > ll ) then
1234 : : stat = 1
1235 : : ! </tag continues in next line
1236 : : exit parse
1237 [ + - - + ]: 345 : else if ( line(j:j) == ' ' .or. line(j:j) == '>') then
1238 : : ! </tag or </tag> found
1239 : 345 : stat = 1
1240 : : end if
1241 : : end if
1242 : : !
1243 : : else if ( stat == 1 ) then
1244 : : !
1245 : : ! </tag found, search for end of tag
1246 : : !
1247 [ - + ]: 345 : if (line(j:j) == ' ' ) then
1248 : : ! skip blanks
1249 : 0 : j = j+1
1250 [ - + ]: 345 : else if ( line(j:j) == '>' ) then
1251 : : ! </tag ... > found
1252 : : ! print *, '</tag> found'
1253 [ - + ]: 345 : if ( present(ierr) ) ierr = 0
1254 : : !print '("closed")'
1255 : 345 : nlevel = nlevel - 1
1256 : : !
1257 : 345 : return
1258 : : !
1259 : : endif
1260 : : !
1261 : : end if
1262 : : end do parse
1263 : : !
1264 : : end do
1265 : : !
1266 : 0 : 10 write(std_out,*) 'end of file reached, closing tag not found'
1267 [ # # ]: 0 : if ( present(ierr) ) ierr = 1
1268 : : !
1269 : : end subroutine xmlr_closetag
1270 : :
1271 : 4101 : END MODULE xmltools
|
