mirror of https://gitlab.com/QEF/q-e.git
Improvements to xml toolkit:
- can read tags not in order, although only in some specific cases (luckily including those PP files that do have some tags not in the usual order) - writes complex variables as two reals, not in fortran free format: it makes reading data from other languages (e.g., python) easy
This commit is contained in:
parent
1767e45c90
commit
8a3e92febe
|
@ -87,7 +87,15 @@ CONTAINS
|
||||||
IF( .NOT. upf%tcoulombp) then
|
IF( .NOT. upf%tcoulombp) then
|
||||||
allocate ( upf%vloc(upf%mesh) )
|
allocate ( upf%vloc(upf%mesh) )
|
||||||
CALL xmlr_readtag( capitalize_if_v2('pp_local'), &
|
CALL xmlr_readtag( capitalize_if_v2('pp_local'), &
|
||||||
upf%vloc(:) )
|
upf%vloc(:), ierr )
|
||||||
|
!
|
||||||
|
! existing PP files may have pp_nlcc first, pp_local later,
|
||||||
|
! but also the other way round - check that everything was right
|
||||||
|
!
|
||||||
|
if ( ierr /= 0 ) then
|
||||||
|
ierr = -81
|
||||||
|
return
|
||||||
|
end if
|
||||||
end if
|
end if
|
||||||
!
|
!
|
||||||
CALL read_pp_semilocal ( upf )
|
CALL read_pp_semilocal ( upf )
|
||||||
|
@ -258,51 +266,32 @@ CONTAINS
|
||||||
allocate ( vnl(1:upf%mesh) )
|
allocate ( vnl(1:upf%mesh) )
|
||||||
CALL xmlr_opentag( capitalize_if_v2('pp_semilocal') )
|
CALL xmlr_opentag( capitalize_if_v2('pp_semilocal') )
|
||||||
!
|
!
|
||||||
IF ( v2 ) THEN
|
tag = 'vnl'
|
||||||
tag = 'PP_VNL.1'
|
|
||||||
ELSE
|
|
||||||
tag = 'vnl'
|
|
||||||
END IF
|
|
||||||
DO nb = 1,upf%nbeta
|
DO nb = 1,upf%nbeta
|
||||||
|
IF ( v2 ) THEN
|
||||||
|
! NOTA BENE: v2 format follows available PP files, written
|
||||||
|
! using original write_upf_v2; not FoX-based write_upf_v2
|
||||||
|
IF ( nb - 1 == upf%lloc ) CYCLE
|
||||||
|
tag = 'PP_VNL.'//i2c(nb-1)
|
||||||
|
END IF
|
||||||
CALL xmlr_readtag( tag, vnl, ierr )
|
CALL xmlr_readtag( tag, vnl, ierr )
|
||||||
if ( ierr /= 0 ) then
|
if ( ierr /= 0 ) &
|
||||||
if ( v2 ) then
|
call upf_error('read_pp_semilocal','error reading SL PPs',1)
|
||||||
go to 10
|
|
||||||
else
|
|
||||||
call upf_error('read_pp_semilocal','error reading SL PPs',1)
|
|
||||||
end if
|
|
||||||
end if
|
|
||||||
CALL get_attr ( 'l', l)
|
CALL get_attr ( 'l', l)
|
||||||
ind = 1
|
ind = 1
|
||||||
IF ( upf%has_so ) then
|
IF ( upf%has_so ) then
|
||||||
CALL get_attr ( 'j', j)
|
CALL get_attr ( 'j', j)
|
||||||
IF ( l > 0 .AND. ABS(j-l-0.5_dp) < 0.001_dp ) ind = 2
|
IF ( l > 0 .AND. ABS(j-l-0.5_dp) < 0.001_dp ) ind = 2
|
||||||
if ( v2 .and. ind == 2 ) &
|
! FIXME: what about spin-orbit case for v.2 upf?
|
||||||
call upf_error('read_pp_semilocal','inconsistency in SL',1)
|
if ( v2 ) &
|
||||||
|
call upf_error('read_pp_semilocal','check spin-orbit',1)
|
||||||
END IF
|
END IF
|
||||||
upf%vnl(:,l,ind) = vnl(:)
|
upf%vnl(:,l,ind) = vnl(:)
|
||||||
END DO
|
END DO
|
||||||
|
deallocate ( vnl )
|
||||||
!
|
!
|
||||||
CALL xmlr_closetag( ) ! end pp_semilocal
|
CALL xmlr_closetag( ) ! end pp_semilocal
|
||||||
!
|
!
|
||||||
10 IF ( v2 .and. upf%has_so ) then
|
|
||||||
rewind ( iun )
|
|
||||||
CALL xmlr_opentag( capitalize_if_v2('pp_semilocal') )
|
|
||||||
ind = 2
|
|
||||||
tag = 'PP_VNL.2'
|
|
||||||
DO nb = 1,upf%nbeta
|
|
||||||
CALL xmlr_readtag( tag, vnl, ierr )
|
|
||||||
if ( ierr /= 0 ) exit
|
|
||||||
CALL get_attr ( 'l', l)
|
|
||||||
CALL get_attr ( 'j', j)
|
|
||||||
IF ( .not. (l > 0 .AND. ABS(j-l-0.5_dp) < 0.001_dp) ) ind = 1
|
|
||||||
if ( v2 .and. ind == 1 ) &
|
|
||||||
call upf_error('read_pp_semilocal','inconsistency in SL',2)
|
|
||||||
upf%vnl(:,l,ind) = vnl(:)
|
|
||||||
END DO
|
|
||||||
CALL xmlr_closetag( ) ! end pp_semilocal
|
|
||||||
END IF
|
|
||||||
deallocate ( vnl )
|
|
||||||
END IF
|
END IF
|
||||||
!
|
!
|
||||||
END SUBROUTINE read_pp_semilocal
|
END SUBROUTINE read_pp_semilocal
|
||||||
|
@ -359,7 +348,7 @@ CONTAINS
|
||||||
CALL get_attr('cutoff_radius_index', upf%kbeta(nb))
|
CALL get_attr('cutoff_radius_index', upf%kbeta(nb))
|
||||||
CALL get_attr('cutoff_radius', upf%rcut(nb))
|
CALL get_attr('cutoff_radius', upf%rcut(nb))
|
||||||
CALL get_attr('ultrasoft_cutoff_radius', upf%rcutus(nb))
|
CALL get_attr('ultrasoft_cutoff_radius', upf%rcutus(nb))
|
||||||
|
!
|
||||||
END DO
|
END DO
|
||||||
!
|
!
|
||||||
! pp_dij (D_lm matrix)
|
! pp_dij (D_lm matrix)
|
||||||
|
@ -599,7 +588,7 @@ CONTAINS
|
||||||
!
|
!
|
||||||
IMPLICIT NONE
|
IMPLICIT NONE
|
||||||
TYPE(pseudo_upf),INTENT(INOUT) :: upf ! the pseudo data
|
TYPE(pseudo_upf),INTENT(INOUT) :: upf ! the pseudo data
|
||||||
INTEGER :: nw, nb
|
INTEGER :: nw, nb, ierr
|
||||||
CHARACTER(LEN=1) :: dummy
|
CHARACTER(LEN=1) :: dummy
|
||||||
!
|
!
|
||||||
IF ( .NOT. v2 .OR. .NOT. upf%has_so ) RETURN
|
IF ( .NOT. v2 .OR. .NOT. upf%has_so ) RETURN
|
||||||
|
@ -617,7 +606,15 @@ CONTAINS
|
||||||
ENDDO
|
ENDDO
|
||||||
!
|
!
|
||||||
DO nb = 1,upf%nbeta
|
DO nb = 1,upf%nbeta
|
||||||
CALL xmlr_readtag( 'PP_RELBETA.'//i2c(nb), dummy )
|
CALL xmlr_readtag( 'PP_RELBETA.'//i2c(nb), dummy, ierr )
|
||||||
|
!
|
||||||
|
! existing PP files may have pp_relbeta first, pp_relwfc later,
|
||||||
|
! but also the other way round - check that everything was right
|
||||||
|
!
|
||||||
|
if ( ierr /= 0 ) then
|
||||||
|
ierr = -81
|
||||||
|
return
|
||||||
|
end if
|
||||||
CALL get_attr( 'index' , nw )
|
CALL get_attr( 'index' , nw )
|
||||||
IF ( nb /= nw ) CALL upf_error('read_pp_spinorb','mismatch',2)
|
IF ( nb /= nw ) CALL upf_error('read_pp_spinorb','mismatch',2)
|
||||||
CALL get_attr( 'lll', upf%lll(nb) )
|
CALL get_attr( 'lll', upf%lll(nb) )
|
||||||
|
|
|
@ -16,23 +16,35 @@ MODULE xmltools
|
||||||
! * lines no more than 1024 characters long (see maxline parameter)
|
! * lines no more than 1024 characters long (see maxline parameter)
|
||||||
! * no more than 9 levels of tags (see maxlevel parameter)
|
! * no more than 9 levels of tags (see maxlevel parameter)
|
||||||
! * length of tags no more than 80 characters (see maxlength parameter)
|
! * length of tags no more than 80 characters (see maxlength parameter)
|
||||||
! Can read tags only in the correct order and in the following format:
|
! * can read tags only in the correct order. If a tag is not found, the
|
||||||
! * tags holding a single value should begin and end in the same line
|
! file is rewound. If "ierr" is present, a second attempt to find the
|
||||||
! * tags holding arrays of values should be opened in a single line,
|
! tag is done starting from the top of the file - may work if the searched
|
||||||
! then the array in free format, then a single line with closing tag
|
! tag is found only above the current position, and nowhere else
|
||||||
|
! * only single values (e.g. no vectors) in attributes
|
||||||
! * attributes should not contain commas or strange characters
|
! * attributes should not contain commas or strange characters
|
||||||
! Unpredictable results may follow otherwise.
|
|
||||||
!
|
!
|
||||||
USE upf_kinds, ONLY : dp
|
USE upf_kinds, ONLY : dp
|
||||||
IMPLICIT NONE
|
IMPLICIT NONE
|
||||||
!
|
!
|
||||||
|
#undef __debug
|
||||||
|
!! define __debug to print information on opened and closed tags
|
||||||
|
LOGICAL, PARAMETER :: one_line_tags=.true.
|
||||||
|
!! if true, write tags with one value in a single line:
|
||||||
|
!! <tag attr1="val1" ... >value</tag>
|
||||||
|
!! otherwise, as in iotk:
|
||||||
|
!! <tag attr1="val1" ... >
|
||||||
|
!! value
|
||||||
|
!! </tag>
|
||||||
|
!! Only for single values; arrays are always written as in iotk
|
||||||
|
!
|
||||||
! internal variables for reading and writing
|
! internal variables for reading and writing
|
||||||
!
|
!
|
||||||
INTEGER :: xmlunit
|
INTEGER :: xmlunit
|
||||||
INTEGER, PARAMETER :: maxline=1024
|
INTEGER, PARAMETER :: maxline=1024
|
||||||
character(len=maxline) :: line
|
CHARACTER(LEN=maxline) :: line
|
||||||
integer :: eot
|
INTEGER :: eot
|
||||||
integer :: nattr
|
! eot points to the end of tag in line just scanned
|
||||||
|
INTEGER :: nattr
|
||||||
CHARACTER(LEN=:), ALLOCATABLE :: attrlist
|
CHARACTER(LEN=:), ALLOCATABLE :: attrlist
|
||||||
!
|
!
|
||||||
! variables used keep track of open tags
|
! variables used keep track of open tags
|
||||||
|
@ -55,12 +67,18 @@ MODULE xmltools
|
||||||
!
|
!
|
||||||
INTERFACE xmlr_readtag
|
INTERFACE xmlr_readtag
|
||||||
MODULE PROCEDURE readtag_c, readtag_r, readtag_l, readtag_i, &
|
MODULE PROCEDURE readtag_c, readtag_r, readtag_l, readtag_i, &
|
||||||
readtag_rv, readtag_rm, readtag_rt, readtag_zv, readtag_zm
|
readtag_iv, readtag_rv, readtag_rm, readtag_rt, &
|
||||||
|
readtag_zv, readtag_zm
|
||||||
END INTERFACE xmlr_readtag
|
END INTERFACE xmlr_readtag
|
||||||
!
|
!
|
||||||
|
! IMPORTANT NOTICE: complex numbers, z=a+ib, are written as two reals:
|
||||||
|
! "a b", not in fortran free format as "(a,b)". Reason:
|
||||||
|
! make the file readable by non-fortran tools, e.g. python
|
||||||
|
!
|
||||||
INTERFACE xmlw_writetag
|
INTERFACE xmlw_writetag
|
||||||
MODULE PROCEDURE writetag_c, writetag_r, writetag_l, writetag_i, &
|
MODULE PROCEDURE writetag_c, writetag_r, writetag_l, writetag_i, &
|
||||||
writetag_rv, writetag_rm, writetag_rt, writetag_zv, writetag_zm
|
writetag_iv, writetag_rv, writetag_rm, writetag_rt, &
|
||||||
|
writetag_zv, writetag_zm
|
||||||
END INTERFACE xmlw_writetag
|
END INTERFACE xmlw_writetag
|
||||||
!
|
!
|
||||||
INTERFACE get_attr
|
INTERFACE get_attr
|
||||||
|
@ -224,18 +242,22 @@ CONTAINS
|
||||||
xmlunit = iun
|
xmlunit = iun
|
||||||
nlevel = 0
|
nlevel = 0
|
||||||
open_tags(nlevel) = 'root'
|
open_tags(nlevel) = 'root'
|
||||||
if ( allocated(attrlist) ) DEALLOCATE ( attrlist)
|
if ( allocated(attrlist) ) DEALLOCATE ( attrlist)
|
||||||
|
#if defined ( __debug )
|
||||||
|
print "('file ',a,' opened with unit ',i5)",trim(filexml),iun
|
||||||
|
#endif
|
||||||
!
|
!
|
||||||
END FUNCTION xml_openfile
|
END FUNCTION xml_openfile
|
||||||
!
|
!
|
||||||
SUBROUTINE xml_closefile ( )
|
SUBROUTINE xml_closefile ( )
|
||||||
!
|
!
|
||||||
CLOSE ( UNIT=xmlunit, STATUS='keep' )
|
CLOSE ( UNIT=xmlunit, STATUS='keep' )
|
||||||
|
#if defined ( __debug )
|
||||||
|
print "('unit ',i5,': file closed')", xmlunit
|
||||||
|
#endif
|
||||||
xmlunit = -1
|
xmlunit = -1
|
||||||
IF ( nlevel > 0 ) THEN
|
IF (nlevel > 0) print '("warning: file closed at level ",i1,&
|
||||||
print '("severe error: file closed at level ",i1," with tag ",A," open")', &
|
& " with tag ",A," open")', nlevel, trim(open_tags(nlevel))
|
||||||
nlevel, trim(open_tags(nlevel))
|
|
||||||
END IF
|
|
||||||
nlevel = 0
|
nlevel = 0
|
||||||
!
|
!
|
||||||
END SUBROUTINE xml_closefile
|
END SUBROUTINE xml_closefile
|
||||||
|
@ -278,7 +300,7 @@ CONTAINS
|
||||||
! If cval=' ' write <name attr1="val1" attr2="val2" ... />
|
! If cval=' ' write <name attr1="val1" attr2="val2" ... />
|
||||||
! If cval='?' write <?name attr1="val1" attr2="val2" ...?>
|
! If cval='?' write <?name attr1="val1" attr2="val2" ...?>
|
||||||
! otherwise, write <name attr1="val1" attr2="val2" ...>cval</name>
|
! otherwise, write <name attr1="val1" attr2="val2" ...>cval</name>
|
||||||
! (su di una stessa riga)
|
! (on a same line if one_line_tags=.true.)
|
||||||
! On output, same as xmlw_opentag
|
! On output, same as xmlw_opentag
|
||||||
!
|
!
|
||||||
CHARACTER(LEN=*), INTENT(IN) :: name
|
CHARACTER(LEN=*), INTENT(IN) :: name
|
||||||
|
@ -307,7 +329,11 @@ CONTAINS
|
||||||
CALL xmlw_closetag ( '?' )
|
CALL xmlw_closetag ( '?' )
|
||||||
ELSE
|
ELSE
|
||||||
! write value (character)
|
! write value (character)
|
||||||
WRITE (xmlunit, "('>',A)", ADVANCE='no') trim(cval)
|
IF (one_line_tags) THEN
|
||||||
|
WRITE (xmlunit, "('>',A)", ADVANCE='no') trim(cval)
|
||||||
|
ELSE
|
||||||
|
WRITE (xmlunit, "('>',/,A)") trim(cval)
|
||||||
|
ENDIF
|
||||||
! close here the tag
|
! close here the tag
|
||||||
CALL xmlw_closetag ( name )
|
CALL xmlw_closetag ( name )
|
||||||
END IF
|
END IF
|
||||||
|
@ -317,7 +343,6 @@ CONTAINS
|
||||||
ierr = ier_
|
ierr = ier_
|
||||||
ELSE IF ( ier_ > 0 ) THEN
|
ELSE IF ( ier_ > 0 ) THEN
|
||||||
print '("Fatal error ",i2," in xmlw_writetag!")', ier_
|
print '("Fatal error ",i2," in xmlw_writetag!")', ier_
|
||||||
stop
|
|
||||||
END IF
|
END IF
|
||||||
!
|
!
|
||||||
END SUBROUTINE writetag_c
|
END SUBROUTINE writetag_c
|
||||||
|
@ -334,6 +359,20 @@ CONTAINS
|
||||||
!
|
!
|
||||||
END SUBROUTINE writetag_i
|
END SUBROUTINE writetag_i
|
||||||
!
|
!
|
||||||
|
SUBROUTINE writetag_iv (name, ivec, ierr )
|
||||||
|
!
|
||||||
|
! As writetag_c, for integer value
|
||||||
|
!
|
||||||
|
CHARACTER(LEN=*), INTENT(IN) :: name
|
||||||
|
INTEGER, INTENT(IN) :: ivec(:)
|
||||||
|
INTEGER, INTENT(OUT),OPTIONAL :: ierr
|
||||||
|
!
|
||||||
|
CALL xmlw_opentag (name, ierr )
|
||||||
|
WRITE( xmlunit, *) ivec
|
||||||
|
CALL xmlw_closetag ( )
|
||||||
|
!
|
||||||
|
END SUBROUTINE writetag_iv
|
||||||
|
!
|
||||||
SUBROUTINE writetag_l (name, lval, ierr )
|
SUBROUTINE writetag_l (name, lval, ierr )
|
||||||
!
|
!
|
||||||
! As writetag_c, for logical value
|
! As writetag_c, for logical value
|
||||||
|
@ -404,26 +443,50 @@ CONTAINS
|
||||||
!
|
!
|
||||||
! As writetag_c, for a vector of complex values
|
! As writetag_c, for a vector of complex values
|
||||||
!
|
!
|
||||||
|
USE iso_c_binding
|
||||||
CHARACTER(LEN=*), INTENT(IN) :: name
|
CHARACTER(LEN=*), INTENT(IN) :: name
|
||||||
COMPLEX(dp), INTENT(IN) :: zvec(:)
|
COMPLEX(dp), INTENT(IN), TARGET:: zvec(:)
|
||||||
INTEGER, INTENT(OUT),OPTIONAL :: ierr
|
INTEGER, INTENT(OUT), OPTIONAL :: ierr
|
||||||
!
|
!
|
||||||
|
! Casts a real pointer (rvec) to a complex array (zvec) via C pointer (!)
|
||||||
|
! in order to write complexes as two reals. Some compilers require that
|
||||||
|
! the argument of c_loc (zvec) is a pointer or has the "target" attribute
|
||||||
|
!
|
||||||
|
TYPE (c_ptr) :: cp
|
||||||
|
REAL(dp), POINTER :: rvec(:)
|
||||||
|
INTEGER :: n, ndim
|
||||||
|
!
|
||||||
|
NULLIFY (rvec)
|
||||||
|
cp = c_loc(zvec)
|
||||||
|
CALL c_f_pointer (cp, rvec, shape(zvec)*[2])
|
||||||
CALL xmlw_opentag (name, ierr )
|
CALL xmlw_opentag (name, ierr )
|
||||||
WRITE( xmlunit, *) zvec
|
ndim = SIZE (zvec)
|
||||||
|
DO n=1,2*ndim,2
|
||||||
|
WRITE( xmlunit, *) rvec(n), rvec(n+1)
|
||||||
|
END DO
|
||||||
CALL xmlw_closetag ( )
|
CALL xmlw_closetag ( )
|
||||||
!
|
!
|
||||||
END SUBROUTINE writetag_zv
|
END SUBROUTINE writetag_zv
|
||||||
!
|
!
|
||||||
SUBROUTINE writetag_zm (name, zmat, ierr )
|
SUBROUTINE writetag_zm (name, zmat, ierr )
|
||||||
!
|
!
|
||||||
! As writetag_c, for a matrix of complex values
|
! As writetag_c for a matrix of complex values - see comments in writetag_zv
|
||||||
!
|
!
|
||||||
|
USE iso_c_binding
|
||||||
CHARACTER(LEN=*), INTENT(IN) :: name
|
CHARACTER(LEN=*), INTENT(IN) :: name
|
||||||
COMPLEX(dp), INTENT(IN) :: zmat(:,:)
|
COMPLEX(dp), INTENT(IN), TARGET:: zmat(:,:)
|
||||||
INTEGER, INTENT(OUT),OPTIONAL :: ierr
|
INTEGER, INTENT(OUT), OPTIONAL :: ierr
|
||||||
|
!
|
||||||
|
TYPE (c_ptr) :: cp
|
||||||
|
REAL(dp), POINTER :: rmat(:,:)
|
||||||
|
INTEGER :: n, nvec
|
||||||
|
!
|
||||||
|
NULLIFY (rmat)
|
||||||
|
cp = c_loc(zmat)
|
||||||
|
CALL c_f_pointer (cp, rmat, shape(zmat)*[2,1])
|
||||||
!
|
!
|
||||||
CALL xmlw_opentag (name, ierr )
|
CALL xmlw_opentag (name, ierr )
|
||||||
WRITE( xmlunit, *) zmat
|
WRITE( xmlunit, *) rmat
|
||||||
CALL xmlw_closetag ( )
|
CALL xmlw_closetag ( )
|
||||||
!
|
!
|
||||||
END SUBROUTINE writetag_zm
|
END SUBROUTINE writetag_zm
|
||||||
|
@ -455,7 +518,9 @@ CONTAINS
|
||||||
WRITE (xmlunit, "(' ')", ADVANCE="no", ERR=10)
|
WRITE (xmlunit, "(' ')", ADVANCE="no", ERR=10)
|
||||||
END DO
|
END DO
|
||||||
WRITE (xmlunit, "('<',A)", ADVANCE="no", ERR=10) trim(name)
|
WRITE (xmlunit, "('<',A)", ADVANCE="no", ERR=10) trim(name)
|
||||||
! print '("opened at level ",i1," tag ",A)', nlevel, trim(open_tags(nlevel))
|
#if defined ( __debug )
|
||||||
|
print '("opened (write) level-",i1," tag ",A)', nlevel, trim(open_tags(nlevel))
|
||||||
|
#endif
|
||||||
!
|
!
|
||||||
! attributes (if present)
|
! attributes (if present)
|
||||||
!
|
!
|
||||||
|
@ -478,24 +543,35 @@ CONTAINS
|
||||||
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: tag
|
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: tag
|
||||||
INTEGER :: i
|
INTEGER :: i
|
||||||
!
|
!
|
||||||
IF ( nlevel < 0 ) &
|
IF ( nlevel < 0 ) print "('severe error: closing tag that was never opened')"
|
||||||
print '("severe error: closing tag that was never opened")'
|
|
||||||
IF ( .NOT.PRESENT(tag) ) THEN
|
IF ( .NOT.PRESENT(tag) ) THEN
|
||||||
DO i=2,nlevel
|
DO i=2,nlevel
|
||||||
WRITE (xmlunit, '(" ")', ADVANCE='NO')
|
WRITE (xmlunit, '(" ")', ADVANCE='NO')
|
||||||
END DO
|
END DO
|
||||||
WRITE (xmlunit, '("</",A,">")') trim(open_tags(nlevel))
|
WRITE (xmlunit, '("</",A,">")') trim(open_tags(nlevel))
|
||||||
|
#if defined ( __debug )
|
||||||
|
print '("closed (write) level-",i1," tag ",A)', nlevel, trim(open_tags(nlevel))
|
||||||
|
#endif
|
||||||
ELSE
|
ELSE
|
||||||
i = len_trim(tag)
|
i = len_trim(tag)
|
||||||
IF ( i == 0 ) THEN
|
IF ( i == 0 ) THEN
|
||||||
WRITE (xmlunit, '("/>")')
|
WRITE (xmlunit, '("/>")')
|
||||||
|
#if defined ( __debug )
|
||||||
|
print '("closed (write) level-",i1," tag ",A)', &
|
||||||
|
nlevel, trim(open_tags(nlevel))
|
||||||
|
#endif
|
||||||
ELSE IF ( i == 1 .AND. tag(1:1) == '?' ) THEN
|
ELSE IF ( i == 1 .AND. tag(1:1) == '?' ) THEN
|
||||||
WRITE (xmlunit, '("?>")')
|
WRITE (xmlunit, '("?>")')
|
||||||
|
#if defined ( __debug )
|
||||||
|
print '("closed (write) level-",i1," tag ",A)', nlevel, tag
|
||||||
|
#endif
|
||||||
ELSE
|
ELSE
|
||||||
WRITE (xmlunit, '("</",A,">")') trim(tag)
|
WRITE (xmlunit, '("</",A,">")') trim(tag)
|
||||||
|
#if defined ( __debug )
|
||||||
|
print '("closed (write) level-",i1," tag ",A)', nlevel, tag
|
||||||
|
#endif
|
||||||
END IF
|
END IF
|
||||||
END IF
|
END IF
|
||||||
!print '("closed at level ",i1," tag ",A)', nlevel, trim(open_tags(nlevel))
|
|
||||||
nlevel = nlevel-1
|
nlevel = nlevel-1
|
||||||
!
|
!
|
||||||
END SUBROUTINE xmlw_closetag
|
END SUBROUTINE xmlw_closetag
|
||||||
|
@ -586,6 +662,26 @@ CONTAINS
|
||||||
!
|
!
|
||||||
END SUBROUTINE readtag_i
|
END SUBROUTINE readtag_i
|
||||||
!
|
!
|
||||||
|
SUBROUTINE readtag_iv (name, ivec, ierr)
|
||||||
|
!
|
||||||
|
! As readtag_c, for a vector of integer values
|
||||||
|
!
|
||||||
|
CHARACTER(LEN=*), INTENT(IN) :: name
|
||||||
|
INTEGER, INTENT(OUT) :: ivec(:)
|
||||||
|
INTEGER, INTENT(OUT),OPTIONAL :: ierr
|
||||||
|
INTEGER :: ier_
|
||||||
|
!
|
||||||
|
CALL xmlr_opentag (name, ier_)
|
||||||
|
if ( ier_ == 0 ) then
|
||||||
|
READ(xmlunit, *) ivec
|
||||||
|
CALL xmlr_closetag ( )
|
||||||
|
else
|
||||||
|
ivec = 0.0_dp
|
||||||
|
end if
|
||||||
|
IF ( present (ierr) ) ierr = ier_
|
||||||
|
!
|
||||||
|
END SUBROUTINE readtag_iv
|
||||||
|
!
|
||||||
SUBROUTINE readtag_l (name, lval, ierr )
|
SUBROUTINE readtag_l (name, lval, ierr )
|
||||||
!
|
!
|
||||||
! As readtag_c, for logical value
|
! As readtag_c, for logical value
|
||||||
|
@ -684,16 +780,23 @@ CONTAINS
|
||||||
!
|
!
|
||||||
SUBROUTINE readtag_zv (name, zvec, ierr)
|
SUBROUTINE readtag_zv (name, zvec, ierr)
|
||||||
!
|
!
|
||||||
! As readtag_c, for a vector of complex values
|
! As readtag_c, for a vector of complex values - see comments in writetag_zv
|
||||||
!
|
!
|
||||||
|
USE iso_c_binding
|
||||||
CHARACTER(LEN=*), INTENT(IN) :: name
|
CHARACTER(LEN=*), INTENT(IN) :: name
|
||||||
COMPLEX(dp), INTENT(OUT) :: zvec(:)
|
COMPLEX(dp), INTENT(OUT), target :: zvec(:)
|
||||||
INTEGER, INTENT(OUT),OPTIONAL :: ierr
|
INTEGER, INTENT(OUT),OPTIONAL :: ierr
|
||||||
|
!
|
||||||
|
TYPE (c_ptr) :: cp
|
||||||
|
REAL(dp), POINTER :: rvec(:)
|
||||||
INTEGER :: ier_
|
INTEGER :: ier_
|
||||||
!
|
!
|
||||||
CALL xmlr_opentag (name, ier_)
|
CALL xmlr_opentag (name, ier_)
|
||||||
if ( ier_ == 0 ) then
|
if ( ier_ == 0 ) then
|
||||||
READ(xmlunit, *) zvec
|
NULLIFY (rvec)
|
||||||
|
cp = c_loc(zvec)
|
||||||
|
CALL c_f_pointer ( cp, rvec, shape(zvec)*[2])
|
||||||
|
READ( xmlunit, *) rvec
|
||||||
CALL xmlr_closetag ( )
|
CALL xmlr_closetag ( )
|
||||||
else
|
else
|
||||||
zvec = 0.0_dp
|
zvec = 0.0_dp
|
||||||
|
@ -704,16 +807,22 @@ CONTAINS
|
||||||
!
|
!
|
||||||
SUBROUTINE readtag_zm (name, zmat, ierr)
|
SUBROUTINE readtag_zm (name, zmat, ierr)
|
||||||
!
|
!
|
||||||
! As readtag_c, for a matrix of complex values
|
! As readtag_c, for a matrix of complex values - see comments in writetag_zv
|
||||||
!
|
!
|
||||||
|
USE iso_c_binding
|
||||||
CHARACTER(LEN=*), INTENT(IN) :: name
|
CHARACTER(LEN=*), INTENT(IN) :: name
|
||||||
COMPLEX(dp), INTENT(OUT) :: zmat(:,:)
|
COMPLEX(dp), INTENT(OUT), target :: zmat(:,:)
|
||||||
INTEGER, INTENT(OUT),OPTIONAL :: ierr
|
INTEGER, INTENT(OUT),OPTIONAL :: ierr
|
||||||
|
TYPE (c_ptr) :: cp
|
||||||
|
REAL(dp), POINTER :: rmat(:,:)
|
||||||
INTEGER :: ier_
|
INTEGER :: ier_
|
||||||
!
|
!
|
||||||
CALL xmlr_opentag (name, ier_)
|
CALL xmlr_opentag (name, ier_)
|
||||||
if ( ier_ == 0 ) then
|
if ( ier_ == 0 ) then
|
||||||
READ(xmlunit, *) zmat
|
NULLIFY (rmat)
|
||||||
|
cp = c_loc(zmat)
|
||||||
|
CALL c_f_pointer (cp, rmat, shape(zmat)*[2,1])
|
||||||
|
READ(xmlunit, *) rmat
|
||||||
CALL xmlr_closetag ( )
|
CALL xmlr_closetag ( )
|
||||||
else
|
else
|
||||||
zmat = 0.0_dp
|
zmat = 0.0_dp
|
||||||
|
@ -734,44 +843,64 @@ CONTAINS
|
||||||
! 1: error parsing file
|
! 1: error parsing file
|
||||||
! 2: error in arguments
|
! 2: error in arguments
|
||||||
!
|
!
|
||||||
integer :: i, j, lt
|
integer :: i, j, lt, ll
|
||||||
character(len=1) :: endtag
|
character(len=1) :: endtag
|
||||||
!
|
!
|
||||||
call xmlr_opentag ( tag, ierr )
|
call xmlr_opentag ( tag, ierr )
|
||||||
!
|
!
|
||||||
if ( eot > 0 ) then
|
cval = ''
|
||||||
j = eot
|
if ( eot < 0 ) then
|
||||||
lt = len_trim(tag)
|
|
||||||
! beginning of val at line(j:j): search for end tag
|
|
||||||
i = index ( line(j:), '</'//trim(tag) )
|
|
||||||
if ( i < 1 ) then
|
|
||||||
! </tag> not found on this line
|
|
||||||
! print *, 'tag </',trim(tag),'> not found'
|
|
||||||
ierr = 1
|
|
||||||
return
|
|
||||||
else
|
|
||||||
! maybe found end tag?
|
|
||||||
endtag = adjustl( line(j+i+1+lt:) )
|
|
||||||
if ( endtag /= '>' ) then
|
|
||||||
! print *, 'tag ',trim(tag),' not correctly closed'
|
|
||||||
if (present(ierr)) ierr = 1
|
|
||||||
else
|
|
||||||
! <tag ....>val</tag> found, exit
|
|
||||||
cval = adjustl(trim(line(j:j+i-2)))
|
|
||||||
! print *, 'value=',cval
|
|
||||||
end if
|
|
||||||
! print '("closed at level ",i1," tag ",A)', nlevel, trim(open_tags(nlevel))
|
|
||||||
nlevel = nlevel -1
|
|
||||||
!
|
|
||||||
return
|
|
||||||
!
|
|
||||||
endif
|
|
||||||
else if ( eot == 0 ) then
|
|
||||||
! print *, 'end of file reached, tag not found'
|
! print *, 'end of file reached, tag not found'
|
||||||
if ( present(ierr) ) ierr =-1
|
if ( present(ierr) ) ierr =-1
|
||||||
else if ( eot < 0 ) then
|
return
|
||||||
|
else if ( eot == 0 ) then
|
||||||
! print *, 'tag found, no value to read on line'
|
! print *, 'tag found, no value to read on line'
|
||||||
cval = ''
|
return
|
||||||
|
else
|
||||||
|
! scan current line if there is something after the end of tag
|
||||||
|
! (variable "eot"); read a new line otherwise
|
||||||
|
do while(.true.)
|
||||||
|
if ( eot > len_trim(line) ) then
|
||||||
|
read(xmlunit,'(a)', end=10) line
|
||||||
|
j = 1
|
||||||
|
else
|
||||||
|
j = eot
|
||||||
|
end if
|
||||||
|
! beginning of val at line(j:j): search for end tag
|
||||||
|
i = index ( line(j:), '</'//trim(tag) )
|
||||||
|
if ( i < 1 ) then
|
||||||
|
! </tag> not found on this line: read value and continue
|
||||||
|
cval = trim(cval) // adjustl(trim(line(j:)))
|
||||||
|
else
|
||||||
|
! possible end tag found
|
||||||
|
lt = len_trim(tag)
|
||||||
|
endtag = adjustl( line(j+i+1+lt:) )
|
||||||
|
if ( endtag /= '>' ) then
|
||||||
|
! print *, 'tag ',trim(tag),' not correctly closed'
|
||||||
|
if (present(ierr)) ierr = 1
|
||||||
|
else
|
||||||
|
! end of tag found, read value (if any) and exit
|
||||||
|
if ( i > 1 ) cval = trim(cval) // adjustl(trim(line(j:j+i-2)))
|
||||||
|
! print *, 'value=',cval
|
||||||
|
end if
|
||||||
|
#if defined ( __debug )
|
||||||
|
print '("closed (read) level-",i1," tag ",A)', &
|
||||||
|
nlevel, trim(open_tags(nlevel))
|
||||||
|
#endif
|
||||||
|
nlevel = nlevel -1
|
||||||
|
!
|
||||||
|
return
|
||||||
|
!
|
||||||
|
endif
|
||||||
|
!
|
||||||
|
end do
|
||||||
|
!
|
||||||
|
end if
|
||||||
|
! print *, 'tag </',trim(tag),'> not found'
|
||||||
|
10 if ( present(ierr) ) then
|
||||||
|
ierr = 1
|
||||||
|
else
|
||||||
|
print *, 'end of file reached, tag </'//trim(tag)//'> not found'
|
||||||
end if
|
end if
|
||||||
!
|
!
|
||||||
end subroutine readtag_c
|
end subroutine readtag_c
|
||||||
|
@ -788,7 +917,7 @@ CONTAINS
|
||||||
! 2: line too long
|
! 2: line too long
|
||||||
! 3: too many levels of tags
|
! 3: too many levels of tags
|
||||||
!
|
!
|
||||||
integer :: stat, ll, lt, i, j, j0
|
integer :: stat, ntry, ll, lt, i, j, j0
|
||||||
! stat= 0: begin
|
! stat= 0: begin
|
||||||
! stat=-1: in comment
|
! stat=-1: in comment
|
||||||
! stat=1 : tag found
|
! stat=1 : tag found
|
||||||
|
@ -796,16 +925,18 @@ CONTAINS
|
||||||
character(len=1) :: quote
|
character(len=1) :: quote
|
||||||
!
|
!
|
||||||
nattr=0
|
nattr=0
|
||||||
|
ntry =0
|
||||||
if ( allocated(attrlist) ) deallocate (attrlist)
|
if ( allocated(attrlist) ) deallocate (attrlist)
|
||||||
!
|
|
||||||
lt = len_trim(tag)
|
lt = len_trim(tag)
|
||||||
|
!
|
||||||
|
1 ntry = ntry+1
|
||||||
stat=0
|
stat=0
|
||||||
eot =0
|
eot =-1
|
||||||
do while (.true.)
|
do while (.true.)
|
||||||
read(xmlunit,'(a)', end=10) line
|
read(xmlunit,'(a)', end=10) line
|
||||||
ll = len_trim(line)
|
ll = len_trim(line)
|
||||||
if ( ll == maxline ) then
|
if ( ll == maxline ) then
|
||||||
print *, 'line too long'
|
print *, 'severe error: line too long'
|
||||||
if (present(ierr)) ierr = 2
|
if (present(ierr)) ierr = 2
|
||||||
return
|
return
|
||||||
end if
|
end if
|
||||||
|
@ -840,11 +971,12 @@ CONTAINS
|
||||||
! tag found? check what follows our would-be tag
|
! tag found? check what follows our would-be tag
|
||||||
j = j+i+lt
|
j = j+i+lt
|
||||||
if ( j > ll ) then
|
if ( j > ll ) then
|
||||||
print *, 'oops... opened tag not closed on same line'
|
stat = 1
|
||||||
|
! <tag continues in next line
|
||||||
exit parse
|
exit parse
|
||||||
else if ( line(j:j) == ' ' .or. line(j:j) == '>' &
|
else if ( line(j:j) == ' ' .or. line(j:j) == '>' &
|
||||||
.or. line(j:j+1)=='/>') then
|
.or. line(j:j+1)=='/>') then
|
||||||
! print *, '<tag found'
|
! <tag or <tag> or <tag/> found
|
||||||
stat = 1
|
stat = 1
|
||||||
end if
|
end if
|
||||||
end if
|
end if
|
||||||
|
@ -859,29 +991,26 @@ CONTAINS
|
||||||
else if ( line(j:j+1) == '/>' ) then
|
else if ( line(j:j+1) == '/>' ) then
|
||||||
! <tag ... /> found : return
|
! <tag ... /> found : return
|
||||||
if (present(ierr)) ierr = 0
|
if (present(ierr)) ierr = 0
|
||||||
! eot = -2: tag with no value found
|
! eot = 0: tag with no value found
|
||||||
eot = -2
|
eot = 0
|
||||||
!
|
!
|
||||||
return
|
return
|
||||||
!
|
!
|
||||||
else if ( line(j:j) == '>' ) then
|
else if ( line(j:j) == '>' ) then
|
||||||
! <tag ... > found
|
! <tag ... > found
|
||||||
if ( j+1 > ll ) then
|
! eot points to the rest of the line
|
||||||
! eot = -1: tag found, line ends
|
eot = j+1
|
||||||
eot = -1
|
|
||||||
else
|
|
||||||
! eot points to the rest of the line
|
|
||||||
eot = j+1
|
|
||||||
end if
|
|
||||||
if (present(ierr)) ierr = 0
|
if (present(ierr)) ierr = 0
|
||||||
nlevel = nlevel+1
|
nlevel = nlevel+1
|
||||||
IF ( nlevel > maxlevel ) THEN
|
IF ( nlevel > maxlevel ) THEN
|
||||||
print *, ' too many levels'
|
print *, ' severe error: too many levels'
|
||||||
if (present(ierr)) ierr = 3
|
if (present(ierr)) ierr = 3
|
||||||
else
|
else
|
||||||
open_tags(nlevel) = trim(tag)
|
open_tags(nlevel) = trim(tag)
|
||||||
!print '("opened at level ",i1," tag ",A)', &
|
#if defined ( __debug )
|
||||||
! nlevel, trim(open_tags(nlevel))
|
print '("opened (read) level-",i1," tag ",A)',&
|
||||||
|
nlevel, trim(open_tags(nlevel))
|
||||||
|
#endif
|
||||||
end if
|
end if
|
||||||
!
|
!
|
||||||
return
|
return
|
||||||
|
@ -923,11 +1052,16 @@ CONTAINS
|
||||||
10 if ( stat == 0 ) then
|
10 if ( stat == 0 ) then
|
||||||
if ( present(ierr) ) then
|
if ( present(ierr) ) then
|
||||||
ierr =-1
|
ierr =-1
|
||||||
|
! quick-and-dirty pseudo-fix to deal with tags not found:
|
||||||
|
! rewind and try again - will work if the desired tag is
|
||||||
|
! found above the current position (and nowhere else)
|
||||||
|
rewind(xmlunit)
|
||||||
|
if ( ntry == 1 ) go to 1
|
||||||
else
|
else
|
||||||
print *, 'end of file reached, tag '//trim(tag)//' not found'
|
print *, 'end of file reached, tag '//trim(tag)//' not found'
|
||||||
end if
|
end if
|
||||||
else
|
else
|
||||||
print *, 'parsing error'
|
print *, 'severe parsing error'
|
||||||
if ( present(ierr) ) ierr = 1
|
if ( present(ierr) ) ierr = 1
|
||||||
end if
|
end if
|
||||||
!
|
!
|
||||||
|
@ -948,16 +1082,22 @@ CONTAINS
|
||||||
! stat= 0: begin
|
! stat= 0: begin
|
||||||
! stat= 1: end
|
! stat= 1: end
|
||||||
!
|
!
|
||||||
IF ( nlevel < 0 ) &
|
if ( nlevel < 0 ) &
|
||||||
print '("severe error: closing tag that was never opened")'
|
print '("severe error: closing tag that was never opened")'
|
||||||
stat=0
|
stat=0
|
||||||
!write(6,'("closing at level ",i1," tag ",A,"...")',advance='no') &
|
#if defined ( __debug )
|
||||||
! nlevel,trim(open_tags(nlevel))
|
if ( .not. present(tag) ) then
|
||||||
|
print '("closed (read) level-",i1," tag ",A)', &
|
||||||
|
nlevel, trim(open_tags(nlevel))
|
||||||
|
else
|
||||||
|
print '("closed (read) level-",i1," tag ",A)', nlevel, tag
|
||||||
|
end if
|
||||||
|
#endif
|
||||||
do while (.true.)
|
do while (.true.)
|
||||||
read(xmlunit,'(a)', end=10) line
|
read(xmlunit,'(a)', end=10) line
|
||||||
ll = len_trim(line)
|
ll = len_trim(line)
|
||||||
if ( ll == maxline ) then
|
if ( ll == maxline ) then
|
||||||
print *, 'line too long'
|
print *, 'Fatal error: line too long'
|
||||||
if (present(ierr)) ierr = 1
|
if (present(ierr)) ierr = 1
|
||||||
return
|
return
|
||||||
end if
|
end if
|
||||||
|
@ -996,10 +1136,11 @@ CONTAINS
|
||||||
! tag found? check what follows our would-be tag
|
! tag found? check what follows our would-be tag
|
||||||
j = j+i+1+lt
|
j = j+i+1+lt
|
||||||
if ( j > ll ) then
|
if ( j > ll ) then
|
||||||
print *, 'oops... opened tag not closed on same line'
|
stat = 1
|
||||||
|
! </tag continues in next line
|
||||||
exit parse
|
exit parse
|
||||||
else if ( line(j:j) == ' ' .or. line(j:j) == '>') then
|
else if ( line(j:j) == ' ' .or. line(j:j) == '>') then
|
||||||
! print *, '</tag found'
|
! </tag or </tag> found
|
||||||
stat = 1
|
stat = 1
|
||||||
end if
|
end if
|
||||||
end if
|
end if
|
||||||
|
|
Loading…
Reference in New Issue