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
|
