mirror of https://gitlab.com/QEF/q-e.git
Merge branch 'replace-fox' into 'develop'
Replace FoX in pseudolib See merge request QEF/q-e!958
This commit is contained in:
commit
87cc10ac81
|
@ -51,6 +51,7 @@ SUBROUTINE readpp ( input_dft, printout, ecutwfc_pp, ecutrho_pp )
|
|||
USE wrappers, ONLY: md5_from_file, f_remove
|
||||
USE read_upf_v1_module, ONLY: read_upf_v1
|
||||
USE upf_module, ONLY: read_upf_new
|
||||
!USE read_upf_new_module, ONLY: read_upf_new
|
||||
USE upf_auxtools, ONLY: upf_get_pp_format, upf_check_atwfc_norm
|
||||
USE emend_upf_module, ONLY: make_emended_upf_copy
|
||||
USE upf_to_internal, ONLY: add_upf_grid, set_upf_q
|
||||
|
|
|
@ -21,6 +21,7 @@ radial_grids.o \
|
|||
read_cpmd.o \
|
||||
read_fhi.o \
|
||||
read_ncpp.o \
|
||||
read_upf_new.o \
|
||||
read_upf_schema.o \
|
||||
read_upf_v1.o \
|
||||
read_upf_v2.o \
|
||||
|
@ -40,8 +41,10 @@ upf_parallel_include.o \
|
|||
upf_to_internal.o \
|
||||
uspp.o \
|
||||
write_upf.o \
|
||||
write_upf_new.o \
|
||||
write_upf_schema.o \
|
||||
write_upf_v2.o
|
||||
write_upf_v2.o \
|
||||
xmltools.o
|
||||
|
||||
TLDEPS=libfox
|
||||
|
||||
|
|
|
@ -23,6 +23,10 @@ read_ncpp.o : pseudo_types.o
|
|||
read_ncpp.o : upf_const.o
|
||||
read_ncpp.o : upf_kinds.o
|
||||
read_ncpp.o : upf_params.o
|
||||
read_upf_new.o : pseudo_types.o
|
||||
read_upf_new.o : upf_kinds.o
|
||||
read_upf_new.o : upf_utils.o
|
||||
read_upf_new.o : xmltools.o
|
||||
read_upf_schema.o : pseudo_types.o
|
||||
read_upf_schema.o : upf_kinds.o
|
||||
read_upf_schema.o : upf_utils.o
|
||||
|
@ -69,6 +73,7 @@ upfconv.o : upf.o
|
|||
upfconv.o : upf_const.o
|
||||
upfconv.o : upf_utils.o
|
||||
upfconv.o : write_upf.o
|
||||
upfconv.o : write_upf_new.o
|
||||
uspp.o : pseudo_types.o
|
||||
uspp.o : upf_const.o
|
||||
uspp.o : upf_invmat.o
|
||||
|
@ -84,8 +89,14 @@ virtual_v2.o : write_upf.o
|
|||
write_upf.o : pseudo_types.o
|
||||
write_upf.o : write_upf_schema.o
|
||||
write_upf.o : write_upf_v2.o
|
||||
write_upf_new.o : pseudo_types.o
|
||||
write_upf_new.o : upf_kinds.o
|
||||
write_upf_new.o : upf_utils.o
|
||||
write_upf_new.o : xmltools.o
|
||||
write_upf_schema.o : pseudo_types.o
|
||||
write_upf_schema.o : upf_kinds.o
|
||||
write_upf_v2.o : pseudo_types.o
|
||||
write_upf_v2.o : upf_kinds.o
|
||||
xmltools.o : upf_kinds.o
|
||||
write_upf_new.o : ../include/version.h
|
||||
write_upf_schema.o : ../include/version.h
|
||||
|
|
|
@ -0,0 +1,822 @@
|
|||
!
|
||||
! Copyright (C) 2020 Quantum ESPRESSO group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
MODULE read_upf_new_module
|
||||
!-----------------------------------------------------
|
||||
!! this module contains the simplified code for reading
|
||||
!! pseudopotential files in either UPF v.2 or xml
|
||||
!
|
||||
USE xmltools
|
||||
USE upf_kinds, ONLY: dp
|
||||
USE pseudo_types, ONLY: pseudo_upf, pseudo_config
|
||||
!
|
||||
LOGICAL :: v2
|
||||
!! true if UPF v.2 version, false if new UPF with xml schema
|
||||
INTEGER :: iun
|
||||
!! unit for reading data
|
||||
!
|
||||
PUBLIC
|
||||
!
|
||||
CONTAINS
|
||||
!
|
||||
!------------------------------------------------+
|
||||
SUBROUTINE read_upf_new (filename, upf, ierr) !
|
||||
!---------------------------------------------+
|
||||
!! Reads pseudopotential in UPF format (either v.2 or upf_schema).
|
||||
!! Derived-type variable *upf* store in output the data read from file.
|
||||
!! File *filename* is opened and closed inside the routine
|
||||
!
|
||||
IMPLICIT NONE
|
||||
CHARACTER(len=*), INTENT(IN) :: filename
|
||||
!! i/o filename
|
||||
TYPE(pseudo_upf),INTENT(OUT) :: upf
|
||||
!! the derived type storing the pseudo data
|
||||
INTEGER, INTENT(OUT) :: ierr
|
||||
!! ierr=0 : xml schema, ierr=-2: UPF v.2
|
||||
!! ierr=-81: error reading PP file
|
||||
!
|
||||
iun = xml_openfile ( filename )
|
||||
IF ( iun == -1 ) CALL upf_error('read_upf', 'cannot open file',1)
|
||||
print *, ' READ_UPF_NEW'
|
||||
call xmlr_opentag ( 'qe_pp:pseudo', IERR = ierr )
|
||||
if ( ierr == 0 ) then
|
||||
v2 =.false.
|
||||
else if ( ierr == -1 ) then
|
||||
rewind (iun)
|
||||
call xmlr_opentag ( 'UPF', IERR = ierr )
|
||||
if ( ierr == 0 ) then
|
||||
v2 =.true.
|
||||
ierr = -2
|
||||
CALL get_attr ( 'version', upf%nv )
|
||||
end if
|
||||
end if
|
||||
if ( ierr /= 0 .and. ierr /= -2 ) then
|
||||
ierr = -81
|
||||
return
|
||||
end if
|
||||
!
|
||||
! The header sections differ a lot between UPF v.2 and UPF with schema
|
||||
!
|
||||
IF ( v2 ) THEN
|
||||
CALL read_pp_header_v2 ( upf )
|
||||
ELSE
|
||||
CALL read_pp_header_schema ( upf )
|
||||
END IF
|
||||
! compatibility
|
||||
upf%is_gth = .false.
|
||||
upf%is_multiproj = .true.
|
||||
!
|
||||
! From here on the format of v2 and schema do not differ much:
|
||||
! the most frequent difference is capitalization of tags
|
||||
! (see function capitalize_if_v2)
|
||||
!
|
||||
CALL read_pp_mesh ( upf )
|
||||
!
|
||||
allocate ( upf%rho_atc(upf%mesh) )
|
||||
IF(upf%nlcc) then
|
||||
CALL xmlr_readtag( capitalize_if_v2('pp_nlcc'), &
|
||||
upf%rho_atc(:) )
|
||||
else
|
||||
upf%rho_atc(:) = 0.0_dp
|
||||
end if
|
||||
IF( .NOT. upf%tcoulombp) then
|
||||
allocate ( upf%vloc(upf%mesh) )
|
||||
CALL xmlr_readtag( capitalize_if_v2('pp_local'), &
|
||||
upf%vloc(:) )
|
||||
end if
|
||||
!
|
||||
CALL read_pp_semilocal ( upf )
|
||||
!
|
||||
CALL read_pp_nonlocal ( upf )
|
||||
!
|
||||
CALL read_pp_pswfc ( upf )
|
||||
!
|
||||
CALL read_pp_full_wfc ( upf )
|
||||
!
|
||||
allocate( upf%rho_at(1:upf%mesh) )
|
||||
CALL xmlr_readtag( capitalize_if_v2('pp_rhoatom'), &
|
||||
upf%rho_at(1:upf%mesh) )
|
||||
!
|
||||
CALL read_pp_spinorb ( upf )
|
||||
!
|
||||
CALL read_pp_paw ( upf )
|
||||
!
|
||||
CALL read_pp_gipaw ( upf )
|
||||
!
|
||||
! close initial tag, qe_pp:pseudo or UPF
|
||||
!
|
||||
CALL xmlr_closetag ( )
|
||||
!
|
||||
CALL xml_closefile ( )
|
||||
!
|
||||
END SUBROUTINE read_upf_new
|
||||
!
|
||||
FUNCTION capitalize_if_v2 ( strin ) RESULT ( strout )
|
||||
!
|
||||
! returns a capitalized string for UPF v.2, the same string otherwise
|
||||
! (UPF v.2 uses capitalized tags, UPF with schema use lowercase)
|
||||
!
|
||||
USE upf_utils, ONLY: capital
|
||||
IMPLICIT NONE
|
||||
CHARACTER(LEN=*) :: strin
|
||||
!
|
||||
INTEGER :: n
|
||||
CHARACTER(LEN=:), ALLOCATABLE :: strout
|
||||
!
|
||||
IF ( v2 ) THEN
|
||||
strout = ''
|
||||
DO n = 1,LEN_TRIM(strin)
|
||||
strout = strout // capital(strin(n:n))
|
||||
END DO
|
||||
ELSE
|
||||
strout = TRIM(strin)
|
||||
END IF
|
||||
!
|
||||
END FUNCTION capitalize_if_v2
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE read_pp_header_schema ( upf )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf), INTENT(INOUT) :: upf ! the pseudo data
|
||||
!
|
||||
CALL xmlr_opentag( capitalize_if_v2('pp_header') )
|
||||
!
|
||||
CALL xmlr_readtag( 'element', upf%psd )
|
||||
CALL xmlr_readtag( 'z_valence', upf%zp )
|
||||
CALL xmlr_readtag( 'type', upf%typ )
|
||||
CALL xmlr_readtag( 'functional', upf%dft )
|
||||
CALL xmlr_readtag( 'relativistic', upf%rel )
|
||||
CALL xmlr_readtag( 'is_ultrasoft', upf%tvanp )
|
||||
CALL xmlr_readtag( 'is_paw', upf%tpawp )
|
||||
CALL xmlr_readtag( 'is_coulomb', upf%tcoulombp )
|
||||
CALL xmlr_readtag( 'has_so', upf%has_so )
|
||||
CALL xmlr_readtag( 'has_wfc', upf%has_wfc )
|
||||
CALL xmlr_readtag( 'has_gipaw', upf%has_gipaw )
|
||||
CALL xmlr_readtag( 'paw_as_gipaw', upf%paw_as_gipaw)
|
||||
CALL xmlr_readtag( 'core_correction', upf%nlcc)
|
||||
CALL xmlr_readtag( 'total_psenergy', upf%etotps )
|
||||
CALL xmlr_readtag( 'wfc_cutoff', upf%ecutwfc )
|
||||
CALL xmlr_readtag( 'rho_cutoff', upf%ecutrho )
|
||||
CALL xmlr_readtag( 'l_max', upf%lmax )
|
||||
CALL xmlr_readtag( 'l_max_rho', upf%lmax_rho )
|
||||
CALL xmlr_readtag( 'l_local', upf%lloc )
|
||||
CALL xmlr_readtag( 'mesh_size', upf%mesh )
|
||||
CALL xmlr_readtag( 'number_of_wfc', upf%nwfc )
|
||||
CALL xmlr_readtag( 'number_of_proj', upf%nbeta )
|
||||
!
|
||||
CALL xmlr_closetag( )
|
||||
!
|
||||
END SUBROUTINE read_pp_header_schema
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE read_pp_header_v2 ( upf )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf), INTENT(INOUT) :: upf ! the pseudo data
|
||||
!
|
||||
CHARACTER(LEN=1) :: dummy
|
||||
!
|
||||
CALL xmlr_readtag ( capitalize_if_v2('pp_header'), dummy )
|
||||
CALL get_attr ('generated', upf%generated)
|
||||
CALL get_attr ('author', upf%author)
|
||||
CALL get_attr ('date', upf%date)
|
||||
CALL get_attr ('comment', upf%comment)
|
||||
CALL get_attr ('element', upf%psd)
|
||||
CALL get_attr ('pseudo_type', upf%typ)
|
||||
CALL get_attr ('relativistic', upf%rel)
|
||||
CALL get_attr ('is_ultrasoft', upf%tvanp)
|
||||
CALL get_attr ('is_paw', upf%tpawp)
|
||||
CALL get_attr ('is_coulomb', upf%tcoulombp)
|
||||
CALL get_attr ('has_so', upf%has_so)
|
||||
CALL get_attr ('has_wfc', upf%has_wfc)
|
||||
CALL get_attr ('has_gipaw', upf%has_gipaw)
|
||||
CALL get_attr ('paw_as_gipaw', upf%paw_as_gipaw)
|
||||
CALL get_attr ('core_correction', upf%nlcc)
|
||||
CALL get_attr ('functional', upf%dft)
|
||||
CALL get_attr ('z_valence', upf%zp)
|
||||
CALL get_attr ('total_psenergy', upf%etotps)
|
||||
CALL get_attr ('wfc_cutoff', upf%ecutwfc)
|
||||
CALL get_attr ('rho_cutoff', upf%ecutrho)
|
||||
CALL get_attr ('l_max', upf%lmax)
|
||||
CALL get_attr ('l_max_rho', upf%lmax_rho)
|
||||
CALL get_attr ('l_local', upf%lloc)
|
||||
CALL get_attr ('mesh_size', upf%mesh)
|
||||
CALL get_attr ('number_of_wfc', upf%nwfc)
|
||||
CALL get_attr ('number_of_proj', upf%nbeta )
|
||||
!
|
||||
END SUBROUTINE read_pp_header_v2
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE read_pp_mesh ( upf )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf),INTENT(INOUT) :: upf ! the pseudo data
|
||||
integer :: mesh
|
||||
!
|
||||
CALL xmlr_opentag( capitalize_if_v2('pp_mesh') )
|
||||
CALL get_attr ( 'mesh', mesh )
|
||||
if ( mesh /= upf%mesh ) call upf_error('read_pp_mesh','mismatch in mesh',mesh)
|
||||
CALL get_attr ( 'dx' , upf%dx )
|
||||
CALL get_attr ( 'xmin', upf%xmin )
|
||||
CALL get_attr ( 'rmax', upf%rmax )
|
||||
CALL get_attr ( 'zmesh', upf%zmesh )
|
||||
allocate ( upf%r(1:upf%mesh) )
|
||||
CALL xmlr_readtag( capitalize_if_v2('pp_r'), upf%r(1:upf%mesh) )
|
||||
allocate ( upf%rab(1:upf%mesh) )
|
||||
CALL xmlr_readtag( capitalize_if_v2('pp_rab'), upf%rab(1:upf%mesh) )
|
||||
!
|
||||
CALL xmlr_closetag( ) ! end pp_mesh
|
||||
!
|
||||
END SUBROUTINE read_pp_mesh
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE read_pp_semilocal ( upf )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf),INTENT(INOUT) :: upf ! the pseudo data
|
||||
!
|
||||
INTEGER :: nb, ind, l, j, ierr
|
||||
CHARACTER(LEN=8) :: tag
|
||||
real(dp), allocatable :: vnl(:)
|
||||
!
|
||||
IF ( upf%typ == "SL" ) THEN
|
||||
!
|
||||
IF ( upf%has_so ) then
|
||||
ALLOCATE(upf%vnl(upf%mesh,0:upf%lmax,2))
|
||||
else
|
||||
ALLOCATE(upf%vnl(upf%mesh,0:upf%lmax,1))
|
||||
end if
|
||||
allocate ( vnl(1:upf%mesh) )
|
||||
CALL xmlr_opentag( capitalize_if_v2('pp_semilocal') )
|
||||
!
|
||||
IF ( v2 ) THEN
|
||||
tag = 'PP_VNL.1'
|
||||
ELSE
|
||||
tag = 'vnl'
|
||||
END IF
|
||||
DO nb = 1,upf%nbeta
|
||||
CALL xmlr_readtag( tag, vnl, ierr )
|
||||
if ( ierr /= 0 ) then
|
||||
if ( v2 ) then
|
||||
go to 10
|
||||
else
|
||||
call upf_error('read_pp_semilocal','error reading SL PPs',1)
|
||||
end if
|
||||
end if
|
||||
CALL get_attr ( 'l', l)
|
||||
ind = 1
|
||||
IF ( upf%has_so ) then
|
||||
CALL get_attr ( 'j', j)
|
||||
IF ( l > 0 .AND. ABS(j-l-0.5_dp) < 0.001_dp ) ind = 2
|
||||
if ( v2 .and. ind == 2 ) &
|
||||
call upf_error('read_pp_semilocal','inconsistency in SL',1)
|
||||
END IF
|
||||
upf%vnl(:,l,ind) = vnl(:)
|
||||
END DO
|
||||
!
|
||||
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 SUBROUTINE read_pp_semilocal
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE read_pp_nonlocal ( upf )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf),INTENT(INOUT) :: upf ! the pseudo data
|
||||
!
|
||||
LOGICAL :: isnull
|
||||
INTEGER :: nb, ind, l, l_, ln, lm, mb, nmb
|
||||
CHARACTER(LEN=15) :: tag
|
||||
REAL(dp), ALLOCATABLE :: aux(:)
|
||||
!
|
||||
nb = upf%nbeta
|
||||
IF ( nb == 0 ) nb = 1
|
||||
ALLOCATE (upf%beta(upf%mesh,nb) )
|
||||
ALLOCATE (upf%els_beta(nb), &
|
||||
upf%lll(nb), &
|
||||
upf%kbeta(nb), &
|
||||
upf%rcut(nb), &
|
||||
upf%rcutus(nb), &
|
||||
upf%dion(nb,nb), &
|
||||
upf%qqq(nb,nb) )
|
||||
!
|
||||
IF (upf%has_so) ALLOCATE( upf%jjj(upf%nbeta))
|
||||
!
|
||||
IF ( upf%nbeta == 0 ) THEN
|
||||
upf%nqf = 0
|
||||
upf%nqlc= 0
|
||||
upf%kkbeta = 0
|
||||
upf%qqq_eps=-1.0_dp
|
||||
RETURN
|
||||
END IF
|
||||
!
|
||||
CALL xmlr_opentag( capitalize_if_v2('pp_nonlocal') )
|
||||
!
|
||||
DO nb = 1,upf%nbeta
|
||||
!
|
||||
IF ( v2 ) THEN
|
||||
tag = 'PP_BETA.'//i2c(nb)
|
||||
ELSE
|
||||
tag = 'pp_beta'
|
||||
END IF
|
||||
CALL xmlr_readtag( tag, upf%beta(1:upf%mesh,nb) )
|
||||
CALL get_attr('index', mb)
|
||||
IF ( nb /= mb ) CALL upf_error('read_pp_nonlocal','mismatch',nb)
|
||||
CALL get_attr('label', upf%els_beta(nb))
|
||||
CALL get_attr('angular_momentum', upf%lll(nb))
|
||||
IF ( .NOT. v2 .AND. upf%has_so ) &
|
||||
CALL get_attr('tot_ang_mom', upf%jjj(nb))
|
||||
CALL get_attr('cutoff_radius_index', upf%kbeta(nb))
|
||||
CALL get_attr('cutoff_radius', upf%rcut(nb))
|
||||
CALL get_attr('ultrasoft_cutoff_radius', upf%rcutus(nb))
|
||||
|
||||
END DO
|
||||
!
|
||||
! pp_dij (D_lm matrix)
|
||||
!
|
||||
CALL xmlr_opentag( capitalize_if_v2 ('pp_dij') )
|
||||
READ(iun,*) upf%dion(1:upf%nbeta,1:upf%nbeta)
|
||||
CALL xmlr_closetag( )
|
||||
!
|
||||
! pp_augmentation
|
||||
!
|
||||
IF (upf%tvanp .or. upf%tpawp) THEN
|
||||
CALL xmlr_opentag( capitalize_if_v2('pp_augmentation') )
|
||||
!
|
||||
IF ( v2 ) THEN
|
||||
CALL get_attr ( 'q_with_l', upf%q_with_l )
|
||||
CALL get_attr ( 'nqf', upf%nqf )
|
||||
CALL get_attr ( 'nqlc', upf%nqlc )
|
||||
IF (upf%tpawp) THEN
|
||||
CALL get_attr ( 'shape', upf%paw%augshape )
|
||||
CALL get_attr ( 'cutoff_r', upf%paw%raug )
|
||||
CALL get_attr ( 'cutoff_r_index', upf%paw%iraug )
|
||||
CALL get_attr ( 'augmentation_epsilon', upf%qqq_eps )
|
||||
CALL get_attr ( 'l_max_aug', upf%paw%lmax_aug )
|
||||
ENDIF
|
||||
ELSE
|
||||
CALL xmlr_readtag( 'q_with_l', upf%q_with_l )
|
||||
CALL xmlr_readtag( 'nqf', upf%nqf )
|
||||
CALL xmlr_readtag( 'nqlc', upf%nqlc )
|
||||
IF (upf%tpawp) THEN
|
||||
CALL xmlr_readtag( 'shape', upf%paw%augshape )
|
||||
CALL xmlr_readtag( 'cutoff_r', upf%paw%raug )
|
||||
CALL xmlr_readtag( 'cutoff_r_index', upf%paw%iraug )
|
||||
CALL xmlr_readtag( 'augmentation_epsilon', upf%qqq_eps )
|
||||
CALL xmlr_readtag( 'l_max_aug', upf%paw%lmax_aug )
|
||||
ENDIF
|
||||
ENDIF
|
||||
!
|
||||
CALL xmlr_opentag( capitalize_if_v2('pp_q') )
|
||||
READ(iun,*) upf%qqq(1:upf%nbeta,1:upf%nbeta)
|
||||
CALL xmlr_closetag( )
|
||||
!
|
||||
IF ( upf%tpawp ) THEN
|
||||
CALL xmlr_opentag( capitalize_if_v2('pp_multipoles') )
|
||||
ALLOCATE ( upf%paw%augmom(1:upf%nbeta,1:upf%nbeta,0:2*upf%lmax) )
|
||||
READ(iun,*) upf%paw%augmom(1:upf%nbeta,1:upf%nbeta,0:2*upf%lmax)
|
||||
CALL xmlr_closetag ()
|
||||
ENDIF
|
||||
!
|
||||
! read polinomial coefficients for Q_ij expansion at small radius
|
||||
!
|
||||
IF ( v2 .AND. upf%nqf > 0) THEN
|
||||
ALLOCATE ( upf%qfcoef(upf%nqf, upf%nqlc, upf%nbeta, upf%nbeta) )
|
||||
CALL xmlr_opentag('PP_QFCOEF')
|
||||
READ(iun,*) upf%qfcoef
|
||||
CALL xmlr_closetag ()
|
||||
ALLOCATE( upf%rinner( upf%nqlc ) )
|
||||
CALL xmlr_readtag('PP_RINNER',upf%rinner)
|
||||
ELSE IF ( upf%nqf == 0 ) THEN
|
||||
ALLOCATE( upf%rinner(1), upf%qfcoef(1,1,1,1) )
|
||||
upf%rinner = 0.0_dp; upf%qfcoef =0.0_dp
|
||||
ENDIF
|
||||
!
|
||||
! Read augmentation charge Q_ij
|
||||
!
|
||||
IF( upf%q_with_l ) THEN
|
||||
ALLOCATE( upf%qfuncl(upf%mesh,upf%nbeta*(upf%nbeta+1)/2,0:2*upf%lmax) )
|
||||
ELSE
|
||||
ALLOCATE ( upf%qfunc(upf%mesh,upf%nbeta*(upf%nbeta+1)/2) )
|
||||
END IF
|
||||
ALLOCATE ( aux(upf%mesh) )
|
||||
loop_on_nb: DO nb = 1,upf%nbeta
|
||||
ln = upf%lll(nb)
|
||||
loop_on_mb: DO mb = nb,upf%nbeta
|
||||
lm = upf%lll(mb)
|
||||
IF( upf%q_with_l ) THEN
|
||||
loop_on_l: DO l = abs(ln-lm),ln+lm,2 ! only even terms
|
||||
isnull = .FALSE.
|
||||
IF( upf%tpawp ) isnull = (abs(upf%paw%augmom(nb,mb,l)) < upf%qqq_eps)
|
||||
IF(isnull) CYCLE loop_on_l
|
||||
IF ( v2 ) THEN
|
||||
tag = 'PP_QIJL.'//i2c(nb)//'.'//i2c(mb)//'.'//i2c(l)
|
||||
ELSE
|
||||
tag = 'pp_qijl'
|
||||
END IF
|
||||
CALL xmlr_readtag( tag, aux )
|
||||
CALL get_attr ('composite_index', nmb)
|
||||
IF ( nmb /= mb*(mb-1)/2 + nb ) &
|
||||
CALL upf_error ('read_pp_nonlocal','mismatch',1)
|
||||
CALL get_attr ('angular_momentum', l_)
|
||||
IF ( l /= l_ ) CALL upf_error ('read_pp_nonlocal','mismatch',2)
|
||||
upf%qfuncl(:,nmb,l) = aux(:)
|
||||
IF (upf%tpawp) upf%qfuncl(upf%paw%iraug+1:,nmb,l) = 0._DP
|
||||
ENDDO loop_on_l
|
||||
ELSE
|
||||
isnull = .FALSE.
|
||||
IF ( upf%tpawp ) isnull = ( abs(upf%qqq(nb,mb)) < upf%qqq_eps )
|
||||
IF (isnull) CYCLE loop_on_mb
|
||||
IF ( v2 ) THEN
|
||||
tag = 'PP_QIJ.'//i2c(nb)//'.'//i2c(mb)
|
||||
ELSE
|
||||
tag = 'pp_qij'
|
||||
END IF
|
||||
CALL xmlr_readtag( tag, aux )
|
||||
CALL get_attr ('composite_index', nmb)
|
||||
IF ( nmb /= mb*(mb-1)/2 + nb ) &
|
||||
CALL upf_error ('read_pp_nonlocal','mismatch',3)
|
||||
upf%qfunc(:,nmb) = aux(:)
|
||||
!
|
||||
ENDIF
|
||||
ENDDO loop_on_mb
|
||||
ENDDO loop_on_nb
|
||||
!
|
||||
DEALLOCATE (aux)
|
||||
CALL xmlr_closetag( ) ! end pp_augmentation
|
||||
!
|
||||
END IF
|
||||
CALL xmlr_closetag( ) ! end pp_nonlocal
|
||||
!
|
||||
! Maximum radius of beta projector: outer radius to integrate
|
||||
upf%kkbeta = MAXVAL(upf%kbeta(1:upf%nbeta))
|
||||
! For PAW, augmentation charge may extend a bit further:
|
||||
IF(upf%tpawp) upf%kkbeta = MAX(upf%kkbeta, upf%paw%iraug)
|
||||
!
|
||||
END SUBROUTINE read_pp_nonlocal
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE read_pp_pswfc ( upf )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf),INTENT(INOUT) :: upf ! the pseudo data
|
||||
!
|
||||
INTEGER :: nw, ind, l
|
||||
CHARACTER(LEN=8) :: tag
|
||||
!
|
||||
allocate ( upf%chi(1:upf%mesh,upf%nwfc) )
|
||||
allocate ( upf%els(upf%nwfc), &
|
||||
upf%oc(upf%nwfc), &
|
||||
upf%lchi(upf%nwfc), &
|
||||
upf%nchi(upf%nwfc), &
|
||||
upf%rcut_chi(upf%nwfc), &
|
||||
upf%rcutus_chi(upf%nwfc), &
|
||||
upf%epseu(upf%nwfc) )
|
||||
IF ( upf%has_so ) THEN
|
||||
allocate ( upf%nn(upf%nwfc) )
|
||||
allocate ( upf%jchi(upf%nwfc) )
|
||||
END IF
|
||||
!
|
||||
CALL xmlr_opentag( capitalize_if_v2('pp_pswfc') )
|
||||
DO nw=1,upf%nwfc
|
||||
IF ( v2 ) THEN
|
||||
tag = 'PP_CHI.'//i2c(nw)
|
||||
ELSE
|
||||
tag = 'pp_chi'
|
||||
END IF
|
||||
CALL xmlr_readtag( tag, upf%chi(1:upf%mesh,nw) )
|
||||
call get_attr('index', ind)
|
||||
if ( ind /= nw ) &
|
||||
call upf_error('read_pp_pswfc','mismatch reading PSWFC', nw)
|
||||
call get_attr( 'label', upf%els(nw) )
|
||||
call get_attr( 'l', upf%lchi(nw) )
|
||||
IF ( .not. v2 .and. upf%has_so ) THEN
|
||||
call get_attr( 'nn', upf%nn(nw) )
|
||||
call get_attr( 'jchi', upf%jchi(nw) )
|
||||
END IF
|
||||
call get_attr( 'occupation', upf%oc(nw) )
|
||||
call get_attr( 'n', upf%nchi(nw) )
|
||||
call get_attr( 'pseudo_energy', upf%epseu(nw) )
|
||||
call get_attr( 'cutoff_radius', upf%rcut_chi(nw) )
|
||||
call get_attr( 'ultrasoft_cutoff_radius', upf%rcutus_chi(nw) )
|
||||
END DO
|
||||
CALL xmlr_closetag( ) ! end pp_pswfc
|
||||
!
|
||||
END SUBROUTINE read_pp_pswfc
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE read_pp_full_wfc ( upf )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf),INTENT(INOUT) :: upf ! the pseudo data
|
||||
!
|
||||
INTEGER :: nb, mb
|
||||
CHARACTER(LEN=15) :: tag
|
||||
!
|
||||
IF ( upf%has_wfc ) THEN
|
||||
!
|
||||
ALLOCATE (upf%aewfc(1:upf%mesh,upf%nbeta) )
|
||||
CALL xmlr_opentag( capitalize_if_v2('pp_full_wfc') )
|
||||
!
|
||||
DO nb = 1, upf%nbeta
|
||||
IF ( v2 ) THEN
|
||||
tag = 'PP_AEWFC.'//i2c(nb)
|
||||
ELSE
|
||||
tag = 'pp_aewfc'
|
||||
END IF
|
||||
CALL xmlr_readtag( tag, upf%aewfc(1:upf%mesh,nb) )
|
||||
CALL get_attr ('index',mb)
|
||||
IF ( nb /= mb ) CALL upf_error('read_pp_full_wfc','mismatch',1)
|
||||
END DO
|
||||
!
|
||||
IF ( upf%has_so .AND. upf%tpawp ) THEN
|
||||
ALLOCATE (upf%paw%aewfc_rel(1:upf%mesh,upf%nbeta) )
|
||||
DO nb = 1, upf%nbeta
|
||||
IF ( v2 ) THEN
|
||||
tag = 'PP_AEWFC_rel.'//i2c(nb)
|
||||
ELSE
|
||||
tag = 'pp_aewfc_rel'
|
||||
END IF
|
||||
CALL xmlr_readtag(tag, upf%paw%aewfc_rel(1:upf%mesh,nb) )
|
||||
CALL get_attr ('index',mb)
|
||||
IF ( nb /= mb ) CALL upf_error('read_pp_full_wfc','mismatch',2)
|
||||
END DO
|
||||
END IF
|
||||
!
|
||||
ALLOCATE (upf%pswfc(1:upf%mesh,upf%nbeta) )
|
||||
DO nb = 1, upf%nbeta
|
||||
IF ( v2 ) THEN
|
||||
tag = 'PP_PSWFC.'//i2c(nb)
|
||||
ELSE
|
||||
tag = 'pp_pswfc'
|
||||
END IF
|
||||
CALL xmlr_readtag(tag, upf%pswfc(1:upf%mesh,nb) )
|
||||
CALL get_attr ('index',mb)
|
||||
IF ( nb /= mb ) CALL upf_error('read_pp_full_wfc','mismatch',3)
|
||||
END DO
|
||||
!
|
||||
CALL xmlr_closetag( )
|
||||
!
|
||||
END IF
|
||||
!
|
||||
END SUBROUTINE read_pp_full_wfc
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE read_pp_spinorb ( upf )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf),INTENT(INOUT) :: upf ! the pseudo data
|
||||
INTEGER :: nw, nb
|
||||
CHARACTER(LEN=1) :: dummy
|
||||
!
|
||||
IF ( .NOT. v2 .OR. .NOT. upf%has_so ) RETURN
|
||||
!
|
||||
CALL xmlr_opentag( 'PP_SPIN_ORB' )
|
||||
DO nw = 1,upf%nwfc
|
||||
CALL xmlr_readtag( 'PP_RELWFC.'//i2c(nw), dummy )
|
||||
CALL get_attr( 'index' , nb )
|
||||
IF ( nb /= nw ) CALL upf_error('read_pp_spinorb','mismatch',1)
|
||||
CALL get_attr( 'els', upf%els(nw) )
|
||||
CALL get_attr( 'nn', upf%nn(nw) )
|
||||
CALL get_attr( 'lchi', upf%lchi(nw) )
|
||||
CALL get_attr( 'jchi', upf%jchi(nw) )
|
||||
CALL get_attr( 'oc', upf%oc(nw) )
|
||||
ENDDO
|
||||
!
|
||||
DO nb = 1,upf%nbeta
|
||||
CALL xmlr_readtag( 'PP_RELBETA.'//i2c(nb), dummy )
|
||||
CALL get_attr( 'index' , nw )
|
||||
IF ( nb /= nw ) CALL upf_error('read_pp_spinorb','mismatch',2)
|
||||
CALL get_attr( 'lll', upf%lll(nb) )
|
||||
CALL get_attr( 'jjj', upf%jjj(nb) )
|
||||
ENDDO
|
||||
CALL xmlr_closetag () ! end pp_spin_orb
|
||||
!
|
||||
END SUBROUTINE read_pp_spinorb
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE read_pp_paw ( upf )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf),INTENT(INOUT) :: upf ! the pseudo data
|
||||
INTEGER :: nb, mb
|
||||
!
|
||||
IF ( .NOT. upf%tpawp ) RETURN
|
||||
!
|
||||
CALL xmlr_opentag( capitalize_if_v2('pp_paw') )
|
||||
CALL get_attr ('paw_data_format', upf%paw_data_format)
|
||||
CALL get_attr ('core_energy', upf%paw%core_energy)
|
||||
! Full occupation (not only > 0 ones)
|
||||
ALLOCATE (upf%paw%oc(upf%nbeta) )
|
||||
ALLOCATE (upf%paw%ae_rho_atc(upf%mesh) )
|
||||
ALLOCATE (upf%paw%ae_vloc(upf%mesh) )
|
||||
CALL xmlr_readtag( capitalize_if_v2('pp_occupations'), &
|
||||
upf%paw%oc(1:upf%nbeta) )
|
||||
! All-electron core charge
|
||||
CALL xmlr_readtag( capitalize_if_v2('pp_ae_nlcc'), &
|
||||
upf%paw%ae_rho_atc(1:upf%mesh) )
|
||||
! All-electron local potential
|
||||
CALL xmlr_readtag( capitalize_if_v2('pp_ae_vloc'), &
|
||||
upf%paw%ae_vloc(1:upf%mesh) )
|
||||
CALL xmlr_closetag () ! end pp_paw
|
||||
!
|
||||
ALLOCATE(upf%paw%pfunc(upf%mesh, upf%nbeta,upf%nbeta) )
|
||||
upf%paw%pfunc(:,:,:) = 0._dp
|
||||
IF (upf%has_so) THEN
|
||||
ALLOCATE(upf%paw%pfunc_rel(upf%mesh, upf%nbeta,upf%nbeta) )
|
||||
upf%paw%pfunc_rel(:,:,:) = 0._dp
|
||||
ENDIF
|
||||
DO nb=1,upf%nbeta
|
||||
DO mb=1,nb
|
||||
upf%paw%pfunc (1:upf%mesh, nb, mb) = &
|
||||
upf%aewfc(1:upf%mesh, nb) * upf%aewfc(1:upf%mesh, mb)
|
||||
IF (upf%has_so) THEN
|
||||
upf%paw%pfunc_rel (1:upf%paw%iraug, nb, mb) = &
|
||||
upf%paw%aewfc_rel(1:upf%paw%iraug, nb) * &
|
||||
upf%paw%aewfc_rel(1:upf%paw%iraug, mb)
|
||||
!
|
||||
! The small component is added to pfunc. pfunc_rel is useful only
|
||||
! to add a small magnetic contribution
|
||||
!
|
||||
upf%paw%pfunc (1:upf%paw%iraug, nb, mb) = &
|
||||
upf%paw%pfunc (1:upf%paw%iraug, nb, mb) + &
|
||||
upf%paw%pfunc_rel (1:upf%paw%iraug, nb, mb)
|
||||
ENDIF
|
||||
upf%paw%pfunc(upf%paw%iraug+1:,nb,mb) = 0._dp
|
||||
!
|
||||
upf%paw%pfunc (1:upf%mesh, mb, nb) = upf%paw%pfunc (1:upf%mesh, nb, mb)
|
||||
IF (upf%has_so) upf%paw%pfunc_rel (1:upf%mesh, mb, nb) = &
|
||||
upf%paw%pfunc_rel (1:upf%mesh, nb, mb)
|
||||
ENDDO
|
||||
ENDDO
|
||||
!
|
||||
! Pseudo wavefunctions (not only the ones for oc > 0)
|
||||
! All-electron wavefunctions
|
||||
ALLOCATE(upf%paw%ptfunc(upf%mesh, upf%nbeta,upf%nbeta) )
|
||||
upf%paw%ptfunc(:,:,:) = 0._dp
|
||||
DO nb=1,upf%nbeta
|
||||
DO mb=1,upf%nbeta
|
||||
upf%paw%ptfunc (1:upf%mesh, nb, mb) = &
|
||||
upf%pswfc(1:upf%mesh, nb) * upf%pswfc(1:upf%mesh, mb)
|
||||
upf%paw%ptfunc(upf%paw%iraug+1:,nb,mb) = 0._dp
|
||||
!
|
||||
upf%paw%ptfunc (1:upf%mesh, mb, nb) = upf%paw%ptfunc (1:upf%mesh, nb, mb)
|
||||
ENDDO
|
||||
ENDDO
|
||||
!
|
||||
END SUBROUTINE read_pp_paw
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE read_pp_gipaw ( upf )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf),INTENT(INOUT) :: upf ! the pseudo data
|
||||
!
|
||||
INTEGER :: nb, mb
|
||||
CHARACTER(LEN=24) :: tag
|
||||
!
|
||||
IF (.NOT. upf%has_gipaw) RETURN
|
||||
!
|
||||
CALL xmlr_opentag( capitalize_if_v2('pp_gipaw') )
|
||||
CALL get_attr ('gipaw_data_format', upf%gipaw_data_format )
|
||||
IF ( v2 ) THEN
|
||||
CALL xmlr_opentag( 'PP_GIPAW_CORE_ORBITALS')
|
||||
CALL get_attr ('number_of_core_orbitals', upf%gipaw_ncore_orbitals)
|
||||
ELSE
|
||||
print *, 'FIXME! upf%gipaw_ncore_orbitals'
|
||||
END IF
|
||||
ALLOCATE ( upf%gipaw_core_orbital(upf%mesh,upf%gipaw_ncore_orbitals) )
|
||||
ALLOCATE ( upf%gipaw_core_orbital_n(upf%gipaw_ncore_orbitals) )
|
||||
ALLOCATE ( upf%gipaw_core_orbital_el(upf%gipaw_ncore_orbitals) )
|
||||
ALLOCATE ( upf%gipaw_core_orbital_l(upf%gipaw_ncore_orbitals) )
|
||||
DO nb = 1,upf%gipaw_ncore_orbitals
|
||||
IF ( v2 ) THEN
|
||||
tag = "PP_GIPAW_CORE_ORBITAL."//i2c(nb)
|
||||
ELSE
|
||||
tag = 'pp_gipaw_core_orbital'
|
||||
END IF
|
||||
CALL xmlr_readtag( tag, upf%gipaw_core_orbital(1:upf%mesh,nb) )
|
||||
CALL get_attr ('index', mb)
|
||||
IF ( nb /= mb ) CALL upf_error('read_pp_gipaw','mismatch',1)
|
||||
CALL get_attr ('label', upf%gipaw_core_orbital_el(nb) )
|
||||
CALL get_attr ('n', upf%gipaw_core_orbital_n(nb) )
|
||||
CALL get_attr ('l', upf%gipaw_core_orbital_l(nb) )
|
||||
END DO
|
||||
IF ( v2 ) CALL xmlr_closetag ( )
|
||||
!
|
||||
IF ( upf%paw_as_gipaw) THEN
|
||||
!
|
||||
! PAW as GIPAW case: all-electron and pseudo-orbitals not read here
|
||||
!
|
||||
upf%gipaw_wfs_nchannels = upf%nbeta
|
||||
ALLOCATE ( upf%gipaw_wfs_el(upf%gipaw_wfs_nchannels) )
|
||||
ALLOCATE ( upf%gipaw_wfs_ll(upf%gipaw_wfs_nchannels) )
|
||||
ALLOCATE ( upf%gipaw_wfs_rcut(upf%gipaw_wfs_nchannels) )
|
||||
ALLOCATE ( upf%gipaw_wfs_rcutus(upf%gipaw_wfs_nchannels) )
|
||||
ALLOCATE ( upf%gipaw_wfs_ae(upf%mesh,upf%gipaw_wfs_nchannels) )
|
||||
ALLOCATE ( upf%gipaw_wfs_ps(upf%mesh,upf%gipaw_wfs_nchannels) )
|
||||
DO nb = 1,upf%gipaw_wfs_nchannels
|
||||
upf%gipaw_wfs_el(nb) = upf%els_beta(nb)
|
||||
upf%gipaw_wfs_ll(nb) = upf%lll(nb)
|
||||
upf%gipaw_wfs_ae(:,nb) = upf%aewfc(:,nb)
|
||||
ENDDO
|
||||
DO nb = 1,upf%gipaw_wfs_nchannels
|
||||
upf%gipaw_wfs_ps(:,nb) = upf%pswfc(:,nb)
|
||||
ENDDO
|
||||
ALLOCATE ( upf%gipaw_vlocal_ae(upf%mesh) )
|
||||
ALLOCATE ( upf%gipaw_vlocal_ps(upf%mesh) )
|
||||
upf%gipaw_vlocal_ae(:)= upf%paw%ae_vloc(:)
|
||||
upf%gipaw_vlocal_ps(:)= upf%vloc(:)
|
||||
DO nb = 1,upf%gipaw_wfs_nchannels
|
||||
upf%gipaw_wfs_rcut(nb)=upf%rcut(nb)
|
||||
upf%gipaw_wfs_rcutus(nb)=upf%rcutus(nb)
|
||||
ENDDO
|
||||
!
|
||||
ELSE
|
||||
!
|
||||
! Read valence all-electron and pseudo orbitals
|
||||
!
|
||||
IF ( v2 ) THEN
|
||||
CALL xmlr_opentag( 'PP_GIPAW_ORBITALS' )
|
||||
CALL get_attr( 'number_of_valence_orbitals', &
|
||||
upf%gipaw_wfs_nchannels )
|
||||
ELSE
|
||||
print *, 'FIXME! upf%gipaw_wfs_nchannel'
|
||||
END IF
|
||||
ALLOCATE ( upf%gipaw_wfs_el(upf%gipaw_wfs_nchannels) )
|
||||
ALLOCATE ( upf%gipaw_wfs_ll(upf%gipaw_wfs_nchannels) )
|
||||
ALLOCATE ( upf%gipaw_wfs_rcut(upf%gipaw_wfs_nchannels) )
|
||||
ALLOCATE ( upf%gipaw_wfs_rcutus(upf%gipaw_wfs_nchannels) )
|
||||
ALLOCATE ( upf%gipaw_wfs_ae(upf%mesh,upf%gipaw_wfs_nchannels) )
|
||||
ALLOCATE ( upf%gipaw_wfs_ps(upf%mesh,upf%gipaw_wfs_nchannels) )
|
||||
ALLOCATE ( upf%gipaw_vlocal_ae(upf%mesh) )
|
||||
ALLOCATE ( upf%gipaw_vlocal_ps(upf%mesh) )
|
||||
DO nb = 1,upf%gipaw_wfs_nchannels
|
||||
IF ( v2 ) THEN
|
||||
tag = "PP_GIPAW_ORBITAL."//i2c(nb)
|
||||
ELSE
|
||||
tag = 'pp_gipaw_orbital'
|
||||
END IF
|
||||
CALL xmlr_opentag( tag )
|
||||
CALL get_attr ('index', mb)
|
||||
IF ( nb /= mb ) CALL upf_error('read_pp_gipaw','mismatch',2)
|
||||
CALL get_attr ('label', upf%gipaw_wfs_el(nb) )
|
||||
CALL get_attr ('l', upf%gipaw_wfs_ll(nb) )
|
||||
CALL get_attr ('cutoff_radius', upf%gipaw_wfs_rcut(nb) )
|
||||
CALL get_attr ('ultrasoft_cutoff_radius', upf%gipaw_wfs_rcutus(nb) )
|
||||
CALL xmlr_readtag( capitalize_if_v2('pp_gipaw_wfs_ae'), &
|
||||
upf%gipaw_wfs_ae(1:upf%mesh,nb) )
|
||||
CALL xmlr_readtag( capitalize_if_v2('pp_gipaw_wfs_ps'),&
|
||||
upf%gipaw_wfs_ps(1:upf%mesh,nb) )
|
||||
CALL xmlr_closetag ()
|
||||
END DO
|
||||
IF ( v2 ) CALL xmlr_closetag( )
|
||||
!
|
||||
! Read all-electron and pseudo local potentials
|
||||
!
|
||||
CALL xmlr_opentag( capitalize_if_v2('pp_gipaw_vlocal') )
|
||||
CALL xmlr_readtag( capitalize_if_v2('pp_gipaw_vlocal_ae'), &
|
||||
upf%gipaw_vlocal_ae(1:upf%mesh) )
|
||||
CALL xmlr_readtag( capitalize_if_v2('pp_gipaw_vlocal_ps'), &
|
||||
upf%gipaw_vlocal_ps(1:upf%mesh) )
|
||||
CALL xmlr_closetag ()
|
||||
END IF
|
||||
CALL xmlr_closetag () ! end pp_gipaw
|
||||
!
|
||||
END SUBROUTINE read_pp_gipaw
|
||||
!
|
||||
END MODULE read_upf_new_module
|
|
@ -27,6 +27,7 @@ SUBROUTINE read_ps ( filein, upf_in )
|
|||
! stripped-down version of readpp in Modules/read_pseudo.f90:
|
||||
! for serial execution only
|
||||
!
|
||||
!USE read_upf_new_module,ONLY: read_upf_new
|
||||
USE read_upf_v1_module, ONLY: read_upf_v1
|
||||
USE emend_upf_module, ONLY: make_emended_upf_copy
|
||||
USE pseudo_types, ONLY: pseudo_upf
|
||||
|
|
|
@ -28,7 +28,7 @@ PROGRAM upfconv
|
|||
USE pseudo_types, ONLY : pseudo_upf, deallocate_pseudo_upf
|
||||
USE casino_pp, ONLY : conv_upf2casino, write_casino_tab
|
||||
USE upf_module, ONLY : read_ps
|
||||
USE write_upf_module, ONLY : write_upf
|
||||
USE write_upf_new,ONLY : write_upf
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf) :: upf_in
|
||||
|
@ -222,12 +222,14 @@ SUBROUTINE conv_upf2xml( upf )
|
|||
ALLOCATE(upf%epseu(upf%nwfc))
|
||||
upf%epseu(:) = 0.0
|
||||
END IF
|
||||
IF ( upf%has_so) THEN
|
||||
upf%rel="full"
|
||||
ELSEIF ( upf%zmesh > 18 ) THEN
|
||||
upf%rel="scalar"
|
||||
ELSE
|
||||
upf%rel="no"
|
||||
IF ( TRIM(upf%rel) == '' ) THEN
|
||||
IF (upf%has_so) THEN
|
||||
upf%rel="full"
|
||||
ELSE IF ( upf%zmesh > 18 ) THEN
|
||||
upf%rel="scalar"
|
||||
ELSE
|
||||
upf%rel="no"
|
||||
ENDIF
|
||||
ENDIF
|
||||
!
|
||||
IF ( .not. upf%has_so) THEN
|
||||
|
|
|
@ -0,0 +1,885 @@
|
|||
!
|
||||
! Copyright (C) 2020 Quantum ESPRESSO group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
MODULE write_upf_new
|
||||
!-----------------------------------------------------
|
||||
!! this module contains the simplified code for writing
|
||||
!! pseudopotential files in either UPF v.2 or xml
|
||||
!
|
||||
USE xmltools
|
||||
USE upf_kinds, ONLY: dp
|
||||
USE pseudo_types, ONLY: pseudo_upf, pseudo_config
|
||||
!
|
||||
LOGICAL :: v2
|
||||
!! true if UPF v.2 version, false if new UPF with xml schema
|
||||
INTEGER :: iun
|
||||
!! unit for writing data
|
||||
PRIVATE
|
||||
PUBLIC :: write_upf
|
||||
!
|
||||
CONTAINS
|
||||
|
||||
SUBROUTINE write_upf ( filename, upf, schema, conf, u_input)
|
||||
!
|
||||
IMPLICIT NONE
|
||||
CHARACTER(LEN=*),INTENT(IN) :: filename
|
||||
!! name of the output file
|
||||
TYPE(pseudo_upf),INTENT(IN) :: upf
|
||||
!! pseudo_upf structure containing all the pseudo data
|
||||
CHARACTER(LEN=*),INTENT(IN), OPTIONAL :: schema
|
||||
!! optional, character flag which selects what schema will be used on writing
|
||||
TYPE(pseudo_config), OPTIONAL, INTENT(IN) :: conf
|
||||
!! optional, pseudo_conf data structure containing the atomic configuration used
|
||||
!! to generate the pseudo
|
||||
INTEGER,OPTIONAL :: u_input
|
||||
!! optional: unit of stdin for the generation program, used to write the
|
||||
!! generation input in the upf file
|
||||
!
|
||||
CHARACTER(LEN=5) :: schema_='qe_pp'
|
||||
CHARACTER(LEN=*), PARAMETER :: QE_PP_URI = &
|
||||
"http://www.quantum-espresso.org/ns/qes/qe_pp-1.0", &
|
||||
XSI = "http://www.w3.org/2001/XMLSchema-instance", &
|
||||
XSD_VERSION = "QE_PP-1.0"
|
||||
!
|
||||
WRITE(6,'("WRITE_UPF_NEW")')
|
||||
IF ( PRESENT(schema) ) schema_ = schema
|
||||
SELECT CASE (TRIM(schema_))
|
||||
CASE ('qe_pp', 'QE_PP')
|
||||
v2 = .false.
|
||||
CASE ('V2', 'v2' ,'upf', 'UPF')
|
||||
v2 = .true.
|
||||
END SELECT
|
||||
!
|
||||
iun = xml_openfile ( filename )
|
||||
IF ( iun == -1 ) CALL upf_error('write_upf', 'cannot open file',1)
|
||||
!
|
||||
! The starting line, header and info sections differ a lot
|
||||
! between UPF v.2 and UPF with schema so we call different routines
|
||||
!
|
||||
IF ( v2 ) THEN
|
||||
!
|
||||
CALL add_attr ('version', upf%nv )
|
||||
CALL xmlw_opentag ( 'UPF')
|
||||
!
|
||||
! pp_info
|
||||
!
|
||||
CALL write_pp_info_v2 ( upf, conf, u_input )
|
||||
!
|
||||
! pp_header
|
||||
!
|
||||
CALL write_pp_header_v2 ( upf )
|
||||
!
|
||||
ELSE
|
||||
!
|
||||
call add_attr( 'version','1.0')
|
||||
call add_attr( 'encoding','UTF-8')
|
||||
CALL xmlw_writetag ( 'xml', '?' )
|
||||
call add_attr( 'xsi:schemalocation', QE_PP_URI//' '//QE_PP_URI//'.xsd')
|
||||
call add_attr( 'xmlns:xsi',XSI)
|
||||
call add_attr( 'xmlns:qe_pp', QE_PP_URI)
|
||||
CALL xmlw_opentag ( 'qe_pp:pseudo' )
|
||||
CALL xmlw_writetag ( 'xsd_version', XSD_VERSION )
|
||||
!
|
||||
! pp_info
|
||||
!
|
||||
CALL write_pp_info_schema ( upf, conf, u_input )
|
||||
!
|
||||
! pp_header
|
||||
!
|
||||
CALL write_pp_header_schema ( upf )
|
||||
!
|
||||
END IF
|
||||
!
|
||||
! From here on the format of v2 and schema do not differ much:
|
||||
! the most frequent difference is capitalization of tags
|
||||
! (see function capitalize_if_v2)
|
||||
!
|
||||
CALL write_pp_mesh ( upf )
|
||||
!
|
||||
IF( upf%nlcc ) THEN
|
||||
CALL add_attr( 'size', upf%mesh )
|
||||
CALL xmlw_writetag(capitalize_if_v2('pp_nlcc'), upf%rho_atc(1:upf%mesh))
|
||||
END IF
|
||||
IF( .NOT. upf%tcoulombp ) THEN
|
||||
CALL add_attr( 'size', upf%mesh )
|
||||
CALL xmlw_writetag( capitalize_if_v2('pp_local'), upf%vloc(1:upf%mesh))
|
||||
END IF
|
||||
!
|
||||
CALL write_pp_semilocal ( upf )
|
||||
!
|
||||
CALL write_pp_nonlocal ( upf )
|
||||
!
|
||||
CALL write_pp_pswfc ( upf )
|
||||
!
|
||||
CALL write_pp_full_wfc ( upf )
|
||||
!
|
||||
CALL add_attr( 'size', upf%mesh )
|
||||
CALL xmlw_writetag( capitalize_if_v2('pp_rhoatom'), upf%rho_at(1:upf%mesh))
|
||||
!
|
||||
CALL write_pp_spinorb ( upf )
|
||||
!
|
||||
CALL write_pp_paw ( upf )
|
||||
!
|
||||
CALL write_pp_gipaw ( upf )
|
||||
!
|
||||
! close initial tag, qe_pp:pseudo or UPF
|
||||
!
|
||||
CALL xmlw_closetag ( )
|
||||
!
|
||||
CALL xml_closefile ( )
|
||||
!
|
||||
RETURN
|
||||
!
|
||||
END SUBROUTINE write_upf
|
||||
!
|
||||
FUNCTION capitalize_if_v2 ( strin ) RESULT ( strout )
|
||||
!
|
||||
! returns a capitalized string for UPF v.2, the same string otherwise
|
||||
! (UPF v.2 uses capitalized tags, UPF with schema use lowercase)
|
||||
!
|
||||
USE upf_utils, ONLY: capital
|
||||
IMPLICIT NONE
|
||||
CHARACTER(LEN=*) :: strin
|
||||
!
|
||||
INTEGER :: n
|
||||
CHARACTER(LEN=:), ALLOCATABLE :: strout
|
||||
!
|
||||
IF ( v2 ) THEN
|
||||
strout = ''
|
||||
DO n = 1,LEN_TRIM(strin)
|
||||
strout = strout // capital(strin(n:n))
|
||||
END DO
|
||||
ELSE
|
||||
strout = TRIM(strin)
|
||||
END IF
|
||||
!
|
||||
END FUNCTION capitalize_if_v2
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE write_pp_info_schema ( upf, conf, u_input )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data
|
||||
! optional: configuration used to generate the pseudopotential
|
||||
TYPE(pseudo_config), OPTIONAL, INTENT(IN) :: conf
|
||||
! optional: unit pointing to input file containing generation data
|
||||
INTEGER, OPTIONAL, INTENT(IN):: u_input
|
||||
!
|
||||
#include "version.h"
|
||||
INTEGER :: nw, nb
|
||||
!
|
||||
CALL xmlw_opentag ( 'pp_info' )
|
||||
CALL xmlw_writetag ( 'generated', xml_protect(upf%generated) )
|
||||
CALL add_attr( 'NAME', 'QE Atomic Code' )
|
||||
CALL add_attr( 'VERSION', version_number )
|
||||
CALL xmlw_writetag ( 'creator', xml_protect(upf%author) )
|
||||
CALL add_attr( 'DATE', upf%date )
|
||||
CALL xmlw_writetag ( 'created', '' )
|
||||
!
|
||||
IF ( PRESENT(u_input) ) CALL copy_input_data ( u_input )
|
||||
!
|
||||
CALL xmlw_writetag ( 'type', upf%typ )
|
||||
IF (TRIM(upf%rel)=='full' .OR. TRIM(upf%rel)=='scalar' ) THEN
|
||||
CALL xmlw_writetag ( 'relativistic_effects', upf%rel )
|
||||
ELSE
|
||||
CALL xmlw_writetag ( 'relativistic_effects', 'none' )
|
||||
ENDIF
|
||||
CALL xmlw_writetag ( 'element', upf%psd )
|
||||
CALL xmlw_writetag ( 'functional', upf%dft )
|
||||
CALL add_attr( 'ecutwfc', upf%ecutwfc )
|
||||
IF (upf%tpawp .OR. upf%tvanp ) THEN
|
||||
CALL add_attr( 'ecutrho', upf%ecutrho )
|
||||
CALL xmlw_writetag ( 'suggested_basis', '' )
|
||||
ELSE
|
||||
CALL xmlw_writetag ( 'suggested_basis', '' )
|
||||
END IF
|
||||
DO nw =1, upf%nwfc
|
||||
IF( upf%oc(nw) >= 0.0_dp) THEN
|
||||
CALL add_attr( 'nl', upf%els(nw) )
|
||||
CALL add_attr( 'pn', upf%nchi(nw) )
|
||||
CALL add_attr( 'l', upf%lchi(nw) )
|
||||
CALL xmlw_opentag ( "valence_orbital" )
|
||||
CALL xmlw_writetag ( "occupation", upf%oc(nw) )
|
||||
CALL xmlw_writetag ( "Rcut", upf%rcut_chi(nw) )
|
||||
IF (upf%rcutus_chi(nw) > 0.0_dp) &
|
||||
CALL xmlw_writetag ( "RcutUS", upf%rcutus_chi(nw) )
|
||||
CALL xmlw_writetag ( "Epseu", upf%epseu(nw) )
|
||||
CALL xmlw_closetag ( )
|
||||
END IF
|
||||
END DO
|
||||
IF( present(conf) ) THEN
|
||||
CALL xmlw_opentag ( "generation_configuration" )
|
||||
DO nb = 1,conf%nwfs
|
||||
WRITE(iun, '(4x,a2,2i3,f6.2,2f11.3,1f13.6)') &
|
||||
conf%els(nb), conf%nns(nb), &
|
||||
conf%lls(nb), conf%ocs(nb), conf%rcut(nb), &
|
||||
conf%rcutus(nb), conf%enls(nb)
|
||||
ENDDO
|
||||
WRITE(iun,'(4x,2a)') 'Pseudization used: ',TRIM(conf%pseud)
|
||||
CALL xmlw_closetag ( )
|
||||
ENDIF
|
||||
IF( TRIM(upf%comment) /= ' ') &
|
||||
WRITE(iun,'("<!--",a,"-->")') TRIM(upf%comment)
|
||||
CALL xmlw_closetag ( ) ! end pp_info
|
||||
!
|
||||
END SUBROUTINE write_pp_info_schema
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE write_pp_header_schema ( upf )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data
|
||||
!
|
||||
CALL xmlw_opentag ( 'pp_header')
|
||||
CALL xmlw_writetag( 'element', upf%psd )
|
||||
CALL xmlw_writetag( 'z_valence', upf%zp )
|
||||
CALL xmlw_writetag( 'type', upf%typ )
|
||||
CALL xmlw_writetag( 'functional', upf%dft )
|
||||
CALL xmlw_writetag( 'relativistic', upf%rel )
|
||||
CALL xmlw_writetag( 'is_ultrasoft', upf%tvanp )
|
||||
CALL xmlw_writetag( 'is_paw', upf%tpawp )
|
||||
CALL xmlw_writetag( 'is_coulomb', upf%tcoulombp )
|
||||
CALL xmlw_writetag( 'has_so', upf%has_so )
|
||||
CALL xmlw_writetag( 'has_wfc', upf%has_wfc )
|
||||
CALL xmlw_writetag( 'has_gipaw', upf%has_gipaw )
|
||||
CALL xmlw_writetag( 'paw_as_gipaw', upf%paw_as_gipaw)
|
||||
CALL xmlw_writetag( 'core_correction', upf%nlcc)
|
||||
CALL xmlw_writetag( 'total_psenergy', upf%etotps )
|
||||
CALL xmlw_writetag( 'wfc_cutoff', upf%ecutwfc )
|
||||
CALL xmlw_writetag( 'rho_cutoff', upf%ecutrho )
|
||||
CALL xmlw_writetag( 'l_max', upf%lmax )
|
||||
CALL xmlw_writetag( 'l_max_rho', upf%lmax_rho )
|
||||
CALL xmlw_writetag( 'l_local', upf%lloc )
|
||||
CALL xmlw_writetag( 'mesh_size', upf%mesh )
|
||||
CALL xmlw_writetag( 'number_of_wfc', upf%nwfc )
|
||||
CALL xmlw_writetag( 'number_of_proj', upf%nbeta )
|
||||
CALL xmlw_closetag( ) ! end pp_header
|
||||
!
|
||||
END SUBROUTINE write_pp_header_schema
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE write_pp_info_v2 ( upf, conf, u_input )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data
|
||||
! optional: configuration used to generate the pseudopotential
|
||||
TYPE(pseudo_config), OPTIONAL, INTENT(IN) :: conf
|
||||
! optional: unit pointing to input file containing generation data
|
||||
INTEGER, OPTIONAL, INTENT(IN):: u_input
|
||||
!
|
||||
INTEGER :: nw, nb
|
||||
CALL xmlw_opentag ( 'PP_INFO' )
|
||||
WRITE(iun,'(4x,a)') TRIM(upf%generated)
|
||||
WRITE(iun,'(4x,a)') 'Author: '//TRIM(upf%author)
|
||||
WRITE(iun,'(4x,a)') 'Generation date: '//TRIM(upf%date)
|
||||
WRITE(iun,'(4x,a)') 'Pseudopotential type: '//TRIM(upf%typ)
|
||||
WRITE(iun,'(4x,a)') 'Element: '//TRIM(upf%psd)
|
||||
WRITE(iun,'(4x,a)') 'Functional: '//TRIM(upf%dft)
|
||||
!
|
||||
! Cutoff Information
|
||||
WRITE(iun,'(4x,a,f5.0,a)') &
|
||||
'Suggested minimum cutoff for wavefunctions:',upf%ecutwfc,' Ry'
|
||||
WRITE(iun, '(4x,a,f5.0,a)') &
|
||||
'Suggested minimum cutoff for charge density:',upf%ecutrho,' Ry'
|
||||
! Write relativistic information
|
||||
IF (TRIM(upf%rel)=='full') THEN
|
||||
WRITE(iun, '(4x,a)') &
|
||||
"The Pseudo was generated with a Fully-Relativistic Calculation"
|
||||
ELSE IF (TRIM(upf%rel)=='scalar') THEN
|
||||
WRITE(iun, '(4x,a)') &
|
||||
"The Pseudo was generated with a Scalar-Relativistic Calculation"
|
||||
ELSE
|
||||
WRITE(iun, '(4x,a)') &
|
||||
"The Pseudo was generated with a Non-Relativistic Calculation"
|
||||
ENDIF
|
||||
!
|
||||
! Write local potential information
|
||||
IF (upf%lloc >= 0 ) THEN
|
||||
WRITE(iun, '(4x,a,i3,f9.4)') &
|
||||
"L component and cutoff radius for Local Potential:", upf%lloc, upf%rcloc
|
||||
ELSE IF (upf%lloc == -1 ) THEN
|
||||
WRITE(iun, '(4x,a,f9.4)') &
|
||||
"Local Potential by smoothing AE potential with Bessel fncs, cutoff radius:", upf%rcloc
|
||||
ELSE IF (upf%lloc == -2 ) THEN
|
||||
WRITE(iun, '(4x,a,f9.4)') &
|
||||
"Local Potential according to Troullier-Martins recipe, cutoff radius:", upf%rcloc
|
||||
ELSE
|
||||
WRITE(iun, '(4x,a,i3,f9.4)') &
|
||||
"Local Potential: unknown format, L component and cutoff radius:",upf%lloc, upf%rcloc
|
||||
ENDIF
|
||||
!
|
||||
IF (upf%has_so) WRITE(iun, '(4x,a,i3,f9.4)') &
|
||||
"Pseudopotential contains additional information for spin-orbit calculations."
|
||||
IF (upf%has_gipaw) WRITE(iun, '(4x,a,i3,f9.4)') &
|
||||
"Pseudopotential contains additional information for GIPAW reconstruction."
|
||||
!
|
||||
! Write valence orbitals information
|
||||
WRITE(iun, '(4x,a)') 'Valence configuration: '
|
||||
WRITE(iun, '(4x,a2,2a3,a6,2a11,1a13)') &
|
||||
"nl"," pn", "l", "occ", "Rcut", "Rcut US", "E pseu"
|
||||
DO nb = 1, upf%nwfc
|
||||
IF(upf%oc(nb) >= 0._dp) THEN
|
||||
WRITE(iun, '(4x,a2,2i3,f6.2,2f11.3,1f13.6)') &
|
||||
upf%els(nb), upf%nchi(nb), &
|
||||
upf%lchi(nb), upf%oc(nb), upf%rcut_chi(nb), &
|
||||
upf%rcutus_chi(nb), upf%epseu(nb)
|
||||
ENDIF
|
||||
END DO
|
||||
IF( present(conf) ) THEN
|
||||
WRITE(iun, '(4x,a)') 'Generation configuration:'
|
||||
DO nb = 1,conf%nwfs
|
||||
WRITE(iun, '(4x,a2,2i3,f6.2,2f11.3,1f13.6)') &
|
||||
conf%els(nb), conf%nns(nb), &
|
||||
conf%lls(nb), conf%ocs(nb), conf%rcut(nb), &
|
||||
conf%rcutus(nb), conf%enls(nb)
|
||||
ENDDO
|
||||
WRITE(iun,'(4x,2a)') 'Pseudization used: ',TRIM(conf%pseud)
|
||||
ELSE
|
||||
WRITE(iun, '(4x,a)') 'Generation configuration: not available.'
|
||||
ENDIF
|
||||
|
||||
IF(TRIM(upf%comment) /= ' ') WRITE(iun, '(4x,"Comment:",2x,a)') &
|
||||
xml_protect(TRIM(upf%comment))
|
||||
!
|
||||
IF ( PRESENT(u_input) ) CALL copy_input_data ( u_input )
|
||||
!
|
||||
! end PP_INFO
|
||||
!
|
||||
CALL xmlw_closetag ( )
|
||||
WRITE(iun, '(" <!-- END OF HUMAN READABLE SECTION -->")')
|
||||
!
|
||||
END SUBROUTINE write_pp_info_v2
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE write_pp_header_v2 ( upf )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data
|
||||
!
|
||||
call add_attr("generated", xml_protect(upf%generated) )
|
||||
call add_attr("author", xml_protect(upf%author) )
|
||||
call add_attr("date", upf%date )
|
||||
call add_attr("comment", xml_protect(upf%comment) )
|
||||
call add_attr("element", upf%psd )
|
||||
call add_attr("pseudo_type", upf%typ )
|
||||
call add_attr("relativistic", upf%rel )
|
||||
call add_attr("is_ultrasoft", upf%tvanp )
|
||||
call add_attr("is_paw", upf%tpawp )
|
||||
call add_attr("is_coulomb", upf%tcoulombp )
|
||||
call add_attr("has_so", upf%has_so )
|
||||
call add_attr("has_wfc", upf%has_wfc )
|
||||
call add_attr("has_gipaw", upf%has_gipaw )
|
||||
call add_attr("paw_as_gipaw", upf%paw_as_gipaw )
|
||||
call add_attr("core_correction", upf%nlcc )
|
||||
call add_attr("functional", upf%dft )
|
||||
call add_attr("z_valence", upf%zp )
|
||||
call add_attr("total_psenergy", upf%etotps )
|
||||
call add_attr("wfc_cutoff", upf%ecutwfc )
|
||||
call add_attr("rho_cutoff", upf%ecutrho )
|
||||
call add_attr("l_max", upf%lmax )
|
||||
call add_attr("l_max_rho", upf%lmax_rho )
|
||||
call add_attr("l_local", upf%lloc )
|
||||
call add_attr("mesh_size", upf%mesh )
|
||||
call add_attr("number_of_wfc", upf%nwfc )
|
||||
call add_attr("number_of_proj", upf%nbeta )
|
||||
!
|
||||
CALL xmlw_writetag ( "PP_HEADER", '')
|
||||
!
|
||||
END SUBROUTINE write_pp_header_v2
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE copy_input_data ( u_input )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
INTEGER, INTENT(IN) :: u_input
|
||||
CHARACTER(len=256) :: line
|
||||
LOGICAL :: opnd
|
||||
!
|
||||
! copy content of input file used in pseudopotential generation
|
||||
!
|
||||
INQUIRE (unit=u_input, opened=opnd)
|
||||
IF (opnd) THEN
|
||||
IF ( v2 ) THEN
|
||||
CALL xmlw_opentag ( 'PP_INPUTFILE' )
|
||||
ELSE
|
||||
CALL add_attr ('program', 'ld1.x' )
|
||||
CALL xmlw_opentag ( 'input' )
|
||||
END IF
|
||||
REWIND (unit=u_input)
|
||||
read_write_loop: DO
|
||||
READ (u_input, '(A)',end=20,err=25) line
|
||||
WRITE (iun, '(A)') xml_protect(line)
|
||||
CYCLE read_write_loop
|
||||
25 CALL upf_error('write_upf::write_inputfile', 'problem writing input data',-1)
|
||||
20 EXIT read_write_loop
|
||||
END DO read_write_loop
|
||||
ELSE
|
||||
CALL upf_error('write_upf::write_inputfile', 'input file not open',-1)
|
||||
END IF
|
||||
CALL xmlw_closetag ( ) ! 'input'
|
||||
!
|
||||
END SUBROUTINE copy_input_data
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE write_pp_mesh ( upf )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data
|
||||
!
|
||||
IF ( upf%dx > 0.d0) THEN
|
||||
CALL add_attr( 'mesh', upf%mesh )
|
||||
CALL add_attr( 'dx', upf%dx )
|
||||
CALL add_attr( 'xmin', upf%xmin )
|
||||
CALL add_attr( 'rmax', upf%rmax )
|
||||
CALL add_attr( 'zmesh', upf%zmesh )
|
||||
CALL xmlw_opentag( capitalize_if_v2('pp_mesh') )
|
||||
ELSE
|
||||
CALL xmlw_opentag( capitalize_if_v2('pp_mesh') )
|
||||
END IF
|
||||
CALL xmlw_writetag( capitalize_if_v2('pp_r'), upf%r(1:upf%mesh) )
|
||||
CALL xmlw_writetag( capitalize_if_v2('pp_rab'), upf%rab(1:upf%mesh) )
|
||||
!
|
||||
CALL xmlw_closetag( ) ! end pp_mesh
|
||||
!
|
||||
END SUBROUTINE write_pp_mesh
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE write_pp_semilocal ( upf )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data
|
||||
!
|
||||
INTEGER :: nb, ind, l
|
||||
CHARACTER(LEN=8) :: tag
|
||||
!
|
||||
IF ( upf%typ == "SL" ) THEN
|
||||
CALL xmlw_opentag( capitalize_if_v2('pp_semilocal') )
|
||||
!
|
||||
DO nb = 1,upf%nbeta
|
||||
l = upf%lll(nb)
|
||||
ind = 1
|
||||
IF ( upf%has_so ) THEN
|
||||
IF ( l > 0 .AND. ABS(upf%jjj(nb)-l-0.5_dp) < 0.001_dp ) ind = 2
|
||||
END IF
|
||||
IF ( v2 ) THEN
|
||||
tag = 'PP_VNL.'//i2c(ind)
|
||||
ELSE
|
||||
tag = 'vnl'
|
||||
END IF
|
||||
CALL add_attr( 'l', l )
|
||||
IF ( upf%has_so ) THEN
|
||||
CALL add_attr( 'j', upf%jjj(nb) )
|
||||
CALL xmlw_writetag( tag, upf%vnl(1:upf%mesh,l,ind) )
|
||||
ELSE
|
||||
CALL xmlw_writetag( tag, upf%vnl(1:upf%mesh,l,ind) )
|
||||
END IF
|
||||
END DO
|
||||
CALL xmlw_closetag( ) ! end pp_semilocal
|
||||
END IF
|
||||
!
|
||||
END SUBROUTINE write_pp_semilocal
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE write_pp_nonlocal ( upf )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data
|
||||
!
|
||||
LOGICAL :: isnull
|
||||
INTEGER :: nb, ind, l, ln, lm, mb, nmb
|
||||
CHARACTER(LEN=15) :: tag
|
||||
!
|
||||
CALL xmlw_opentag( capitalize_if_v2('pp_nonlocal') )
|
||||
!
|
||||
DO nb = 1,upf%nbeta
|
||||
!
|
||||
IF ( v2 ) THEN
|
||||
tag = 'PP_BETA.'//i2c(nb)
|
||||
ELSE
|
||||
tag = 'pp_beta'
|
||||
END IF
|
||||
call add_attr( 'index', nb )
|
||||
call add_attr( 'label', upf%els_beta(nb) )
|
||||
call add_attr( 'angular_momentum', upf%lll(nb) )
|
||||
call add_attr( 'cutoff_radius_index', upf%kbeta(nb) )
|
||||
call add_attr( 'cutoff_radius', upf%rcut(nb) )
|
||||
call add_attr( 'ultrasoft_cutoff_radius', upf%rcutus(nb) )
|
||||
IF ( .NOT. v2 .AND. upf%has_so ) THEN
|
||||
call add_attr( 'tot_ang_mom', upf%jjj(nb) )
|
||||
CALL xmlw_writetag( tag, upf%beta(1:upf%mesh,nb) )
|
||||
ELSE
|
||||
CALL xmlw_writetag( tag, upf%beta(1:upf%mesh,nb) )
|
||||
END IF
|
||||
END DO
|
||||
!
|
||||
! pp_dij (D_lm matrix)
|
||||
!
|
||||
call add_attr( 'columns', upf%nbeta )
|
||||
call add_attr( 'rows', upf%nbeta )
|
||||
CALL xmlw_opentag( capitalize_if_v2 ('pp_dij') )
|
||||
WRITE(iun,*) upf%dion(1:upf%nbeta,1:upf%nbeta)
|
||||
CALL xmlw_closetag( )
|
||||
!
|
||||
! pp_augmentation
|
||||
!
|
||||
IF (upf%tvanp .or. upf%tpawp) THEN
|
||||
IF ( v2 ) THEN
|
||||
call add_attr('q_with_l', upf%q_with_l )
|
||||
call add_attr('nqf', upf%nqf )
|
||||
call add_attr('nqlc', upf%nqlc )
|
||||
IF (upf%tpawp) THEN
|
||||
CALL add_attr( 'shape', upf%paw%augshape )
|
||||
CALL add_attr( 'cutoff_r', upf%paw%raug )
|
||||
CALL add_attr( 'cutoff_r_index', upf%paw%iraug )
|
||||
CALL add_attr( 'augmentation_epsilon', upf%qqq_eps )
|
||||
CALL add_attr( 'l_max_aug', upf%paw%lmax_aug )
|
||||
ENDIF
|
||||
END IF
|
||||
CALL xmlw_opentag( capitalize_if_v2('pp_augmentation') )
|
||||
!
|
||||
IF ( .NOT. v2 ) THEN
|
||||
CALL xmlw_writetag( 'q_with_l', upf%q_with_l )
|
||||
CALL xmlw_writetag( 'nqf', upf%nqf )
|
||||
CALL xmlw_writetag( 'nqlc', upf%nqlc )
|
||||
IF (upf%tpawp) THEN
|
||||
CALL xmlw_writetag( 'shape', upf%paw%augshape )
|
||||
CALL xmlw_writetag( 'cutoff_r', upf%paw%raug )
|
||||
CALL xmlw_writetag( 'cutoff_r_index', upf%paw%iraug )
|
||||
CALL xmlw_writetag( 'augmentation_epsilon', upf%qqq_eps )
|
||||
CALL xmlw_writetag( 'l_max_aug', upf%paw%lmax_aug )
|
||||
ENDIF
|
||||
END IF
|
||||
!
|
||||
nb = upf%nbeta*upf%nbeta
|
||||
call add_attr( 'size', nb )
|
||||
CALL xmlw_opentag( capitalize_if_v2('pp_q') )
|
||||
WRITE(iun,*) upf%qqq(1:upf%nbeta,1:upf%nbeta)
|
||||
CALL xmlw_closetag( )
|
||||
!
|
||||
IF ( upf%tpawp ) THEN
|
||||
WRITE(iun,"('<!--augmentation charge multipoles ( only for PAW) ',/,&
|
||||
& 'multipole array dims = (nbeta,nbeta,2*lmax+1)-->')")
|
||||
call add_attr( 'nbeta', upf%nbeta )
|
||||
call add_attr( 'lmax', upf%lmax )
|
||||
CALL xmlw_opentag( capitalize_if_v2('pp_multipoles') )
|
||||
WRITE(iun,*) upf%paw%augmom(1:upf%nbeta,1:upf%nbeta,0:2*upf%lmax)
|
||||
CALL xmlw_closetag ()
|
||||
ENDIF
|
||||
!
|
||||
END IF
|
||||
!
|
||||
! Write polinomial coefficients for Q_ij expansion at small radius
|
||||
IF ( v2 .AND. upf%nqf > 0) THEN
|
||||
WRITE(iun,"('<!--polinomial expansion of Q_ij at small radius-->')")
|
||||
CALL xmlw_opentag('PP_QFCOEF')
|
||||
WRITE(iun,*) upf%qfcoef
|
||||
CALL xmlw_closetag ()
|
||||
CALL xmlw_opentag('PP_RINNER')
|
||||
WRITE(iun,*) upf%rinner
|
||||
CALL xmlw_closetag ()
|
||||
ENDIF
|
||||
!
|
||||
IF ( upf%tpawp .or. upf%tvanp ) THEN
|
||||
!
|
||||
! Write augmentation charge Q_ij
|
||||
!
|
||||
loop_on_nb: DO nb = 1,upf%nbeta
|
||||
ln = upf%lll(nb)
|
||||
loop_on_mb: DO mb = nb,upf%nbeta
|
||||
lm = upf%lll(mb)
|
||||
nmb = mb * (mb-1) /2 + nb
|
||||
IF( upf%q_with_l ) THEN
|
||||
loop_on_l: DO l = abs(ln-lm),ln+lm,2 ! only even terms
|
||||
isnull = .FALSE.
|
||||
IF( upf%tpawp ) isnull = (abs(upf%paw%augmom(nb,mb,l)) < upf%qqq_eps)
|
||||
IF(isnull) CYCLE loop_on_l
|
||||
IF ( v2 ) THEN
|
||||
tag = 'PP_QIJL.'//i2c(nb)//'.'//i2c(mb)//'.'//i2c(l)
|
||||
ELSE
|
||||
tag = 'pp_qijl'
|
||||
END IF
|
||||
call add_attr( 'first_index', nb )
|
||||
call add_attr( 'second_index', mb )
|
||||
call add_attr( 'composite_index', nmb )
|
||||
call add_attr( 'angular_momentum', l )
|
||||
call add_attr( 'size', upf%mesh )
|
||||
CALL xmlw_writetag( tag, upf%qfuncl(1:upf%mesh,nmb,l) )
|
||||
ENDDO loop_on_l
|
||||
ELSE
|
||||
isnull = .FALSE.
|
||||
IF ( upf%tpawp ) isnull = ( abs(upf%qqq(nb,mb)) < upf%qqq_eps )
|
||||
IF (isnull) CYCLE loop_on_mb
|
||||
IF ( v2 ) THEN
|
||||
tag = 'PP_QIJ.'//i2c(nb)//'.'//i2c(mb)
|
||||
ELSE
|
||||
tag = 'pp_qij'
|
||||
END IF
|
||||
call add_attr( 'size', upf%mesh )
|
||||
call add_attr( 'first_index', nb )
|
||||
call add_attr( 'second_index', mb )
|
||||
call add_attr( 'composite_index', nmb )
|
||||
CALL xmlw_writetag( tag, upf%qfunc(1:upf%mesh,nmb) )
|
||||
!
|
||||
ENDIF
|
||||
ENDDO loop_on_mb
|
||||
ENDDO loop_on_nb
|
||||
!
|
||||
CALL xmlw_closetag( ) ! end pp_augmentation
|
||||
!
|
||||
END IF
|
||||
CALL xmlw_closetag( ) ! end pp_nonlocal
|
||||
!
|
||||
END SUBROUTINE write_pp_nonlocal
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE write_pp_pswfc ( upf )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data
|
||||
!
|
||||
INTEGER :: nw, ind, l
|
||||
CHARACTER(LEN=8) :: tag
|
||||
!
|
||||
CALL xmlw_opentag( capitalize_if_v2('pp_pswfc') )
|
||||
DO nw =1, upf%nwfc
|
||||
call add_attr( 'size', upf%mesh )
|
||||
call add_attr( 'index', nw )
|
||||
call add_attr( 'label', upf%els(nw) )
|
||||
call add_attr( 'l', upf%lchi(nw) )
|
||||
IF ( upf%has_so) THEN
|
||||
call add_attr( 'nn', upf%nn(nw) )
|
||||
call add_attr( 'jchi', upf%jchi(nw) )
|
||||
END IF
|
||||
call add_attr( 'occupation', upf%oc(nw) )
|
||||
IF ( upf%nchi(nw) > upf%lchi(nw) ) call add_attr( 'n', upf%nchi(nw) )
|
||||
IF ( upf%epseu(nw) > 0.0_dp ) &
|
||||
call add_attr( 'pseudo_energy',upf%epseu(nw) )
|
||||
IF ( upf%rcut_chi(nw) > 0.0_dp ) &
|
||||
call add_attr( 'cutoff_radius',upf%rcut_chi(nw) )
|
||||
IF ( upf%rcutus_chi(nw) > 0.0_dp ) &
|
||||
call add_attr( 'ultrasoft_cutoff_radius',upf%rcutus_chi(nw) )
|
||||
!
|
||||
IF ( v2 ) THEN
|
||||
tag = 'PP_CHI.'//i2c(nw)
|
||||
ELSE
|
||||
tag = 'pp_chi'
|
||||
END IF
|
||||
CALL xmlw_writetag( tag, upf%chi(1:upf%mesh,nw) )
|
||||
END DO
|
||||
CALL xmlw_closetag( ) ! end pp_pswfc
|
||||
!
|
||||
END SUBROUTINE write_pp_pswfc
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE write_pp_full_wfc ( upf )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data
|
||||
!
|
||||
INTEGER :: nb
|
||||
CHARACTER(LEN=15) :: tag
|
||||
!
|
||||
IF ( upf%has_wfc ) THEN
|
||||
!
|
||||
call add_attr( 'number_of_wfc', upf%nbeta )
|
||||
CALL xmlw_opentag( capitalize_if_v2('pp_full_wfc') )
|
||||
!
|
||||
DO nb = 1, upf%nbeta
|
||||
IF ( v2 ) THEN
|
||||
tag = 'PP_AEWFC.'//i2c(nb)
|
||||
ELSE
|
||||
tag = 'pp_aewfc'
|
||||
END IF
|
||||
call add_attr( 'index', nb )
|
||||
call add_attr( 'label', upf%els_beta(nb) )
|
||||
call add_attr( 'l', upf%lll(nb) )
|
||||
CALL xmlw_writetag( tag, upf%aewfc(1:upf%mesh,nb) )
|
||||
END DO
|
||||
!
|
||||
IF ( upf%has_so .AND. upf%tpawp ) THEN
|
||||
DO nb = 1, upf%nbeta
|
||||
IF ( v2 ) THEN
|
||||
tag = 'PP_AEWFC_rel.'//i2c(nb)
|
||||
ELSE
|
||||
tag = 'pp_aewfc_rel'
|
||||
END IF
|
||||
call add_attr( 'index', nb )
|
||||
call add_attr( 'label', upf%els_beta(nb) )
|
||||
call add_attr( 'l', upf%lll(nb) )
|
||||
CALL xmlw_writetag(tag, upf%paw%aewfc_rel(1:upf%mesh,nb) )
|
||||
END DO
|
||||
END IF
|
||||
!
|
||||
DO nb = 1, upf%nbeta
|
||||
IF ( v2 ) THEN
|
||||
tag = 'PP_PSWFC.'//i2c(nb)
|
||||
ELSE
|
||||
tag = 'pp_pswfc'
|
||||
END IF
|
||||
call add_attr( 'size', upf%mesh )
|
||||
call add_attr( 'index', nb )
|
||||
call add_attr( 'label', upf%els_beta(nb) )
|
||||
call add_attr( 'l', upf%lll(nb) )
|
||||
CALL xmlw_writetag( tag, upf%pswfc(1:upf%mesh,nb) )
|
||||
END DO
|
||||
!
|
||||
CALL xmlw_closetag( )
|
||||
!
|
||||
END IF
|
||||
!
|
||||
END SUBROUTINE write_pp_full_wfc
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE write_pp_spinorb ( upf )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data
|
||||
INTEGER :: nw, nb
|
||||
!
|
||||
IF ( .NOT. v2 .OR. .NOT. upf%has_so ) RETURN
|
||||
!
|
||||
CALL xmlw_opentag( 'PP_SPIN_ORB' )
|
||||
DO nw = 1,upf%nwfc
|
||||
CALL add_attr( 'index' , nw )
|
||||
CALL add_attr( 'els', upf%els(nw) )
|
||||
CALL add_attr( 'nn', upf%nn(nw) )
|
||||
CALL add_attr( 'lchi', upf%lchi(nw) )
|
||||
CALL add_attr( 'jchi', upf%jchi(nw) )
|
||||
CALL add_attr( 'oc', upf%oc(nw) )
|
||||
CALL xmlw_writetag( 'PP_RELWFC.'//i2c(nw), '' )
|
||||
ENDDO
|
||||
!
|
||||
DO nb = 1,upf%nbeta
|
||||
CALL add_attr( 'index' , nb )
|
||||
CALL add_attr( 'lll', upf%lll(nb) )
|
||||
CALL add_attr( 'jjj', upf%jjj(nb) )
|
||||
CALL xmlw_writetag( 'PP_RELBETA.'//i2c(nb), '' )
|
||||
ENDDO
|
||||
CALL xmlw_closetag () ! end pp_spin_orb
|
||||
!
|
||||
END SUBROUTINE write_pp_spinorb
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE write_pp_paw ( upf )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data
|
||||
!
|
||||
IF ( upf%tpawp ) THEN
|
||||
call add_attr( 'paw_data_format', upf%paw_data_format )
|
||||
call add_attr( 'core_energy', upf%paw%core_energy )
|
||||
CALL xmlw_opentag( capitalize_if_v2('pp_paw') )
|
||||
! Full occupation (not only > 0 ones)
|
||||
call add_attr( 'size', upf%nbeta )
|
||||
CALL xmlw_writetag( capitalize_if_v2('pp_occupations'), &
|
||||
upf%paw%oc(1:upf%nbeta) )
|
||||
! All-electron core charge
|
||||
call add_attr( 'size', upf%mesh )
|
||||
CALL xmlw_writetag( capitalize_if_v2('pp_ae_nlcc'), &
|
||||
upf%paw%ae_rho_atc(1:upf%mesh) )
|
||||
! All-electron local potential
|
||||
call add_attr( 'size', upf%mesh )
|
||||
CALL xmlw_writetag( capitalize_if_v2('pp_ae_vloc'), &
|
||||
upf%paw%ae_vloc(1:upf%mesh) )
|
||||
CALL xmlw_closetag () ! end pp_paw
|
||||
END IF
|
||||
!
|
||||
END SUBROUTINE write_pp_paw
|
||||
!--------------------------------------------------------
|
||||
SUBROUTINE write_pp_gipaw ( upf )
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
IMPLICIT NONE
|
||||
TYPE(pseudo_upf),INTENT(IN) :: upf ! the pseudo data
|
||||
!
|
||||
INTEGER :: nb
|
||||
CHARACTER(LEN=24) :: tag
|
||||
!
|
||||
IF (upf%has_gipaw) THEN
|
||||
call add_attr( 'gipaw_data_format', upf%gipaw_data_format )
|
||||
CALL xmlw_opentag( capitalize_if_v2('pp_gipaw') )
|
||||
IF ( v2 ) THEN
|
||||
call add_attr( 'number_of_core_orbitals', upf%gipaw_ncore_orbitals )
|
||||
CALL xmlw_opentag( 'PP_GIPAW_CORE_ORBITALS' )
|
||||
END IF
|
||||
DO nb = 1,upf%gipaw_ncore_orbitals
|
||||
IF ( v2 ) THEN
|
||||
tag = "PP_GIPAW_CORE_ORBITAL."//i2c(nb)
|
||||
ELSE
|
||||
tag = 'pp_gipaw_core_orbital'
|
||||
END IF
|
||||
call add_attr( 'size', upf%mesh )
|
||||
call add_attr( 'index', nb )
|
||||
call add_attr( 'label', upf%gipaw_core_orbital_el(nb) )
|
||||
call add_attr( 'n', upf%gipaw_core_orbital_n(nb) )
|
||||
call add_attr( 'l', upf%gipaw_core_orbital_l(nb) )
|
||||
CALL xmlw_writetag( tag, upf%gipaw_core_orbital(1:upf%mesh,nb) )
|
||||
END DO
|
||||
IF ( v2 ) CALL xmlw_closetag ( )
|
||||
!
|
||||
! Only core orbitals are written in the PAW as GIPAW case
|
||||
!
|
||||
IF ( .NOT. upf%paw_as_gipaw) THEN
|
||||
!
|
||||
! Write valence all-electron and pseudo orbitals
|
||||
!
|
||||
IF ( v2 ) THEN
|
||||
call add_attr( 'number_of_valence_orbitals', upf%gipaw_wfs_nchannels )
|
||||
CALL xmlw_opentag( 'PP_GIPAW_ORBITALS' )
|
||||
END IF
|
||||
DO nb = 1,upf%gipaw_wfs_nchannels
|
||||
IF ( v2 ) THEN
|
||||
tag = "PP_GIPAW_ORBITAL."//i2c(nb)
|
||||
ELSE
|
||||
tag = 'pp_gipaw_orbital'
|
||||
END IF
|
||||
call add_attr( 'index', nb )
|
||||
call add_attr( 'label', upf%gipaw_wfs_el(nb) )
|
||||
call add_attr( 'l', upf%gipaw_wfs_ll(nb) )
|
||||
call add_attr( 'cutoff_radius', upf%gipaw_wfs_rcut(nb) )
|
||||
call add_attr( 'ultrasoft_cutoff_radius', upf%gipaw_wfs_rcutus(nb) )
|
||||
CALL xmlw_opentag( tag)
|
||||
!
|
||||
call add_attr( 'size', upf%mesh )
|
||||
CALL xmlw_writetag( capitalize_if_v2('pp_gipaw_wfs_ae'), &
|
||||
upf%gipaw_wfs_ae(1:upf%mesh,nb) )
|
||||
call add_attr( 'size', upf%mesh )
|
||||
CALL xmlw_writetag( capitalize_if_v2('pp_gipaw_wfs_ps'),&
|
||||
upf%gipaw_wfs_ps(1:upf%mesh,nb) )
|
||||
CALL xmlw_closetag ()
|
||||
END DO
|
||||
IF ( v2 ) CALL xmlw_closetag( )
|
||||
!
|
||||
! Write all-electron and pseudo local potentials
|
||||
CALL xmlw_opentag( capitalize_if_v2('pp_gipaw_vlocal') )
|
||||
call add_attr( 'size', upf%mesh )
|
||||
CALL xmlw_writetag( capitalize_if_v2('pp_gipaw_vlocal_ae'), &
|
||||
upf%gipaw_vlocal_ae(1:upf%mesh) )
|
||||
call add_attr( 'size', upf%mesh )
|
||||
CALL xmlw_writetag( capitalize_if_v2('pp_gipaw_vlocal_ps'), &
|
||||
upf%gipaw_vlocal_ps(1:upf%mesh) )
|
||||
CALL xmlw_closetag ()
|
||||
END IF
|
||||
CALL xmlw_closetag () ! end pp_gipaw
|
||||
END IF
|
||||
!
|
||||
END SUBROUTINE write_pp_gipaw
|
||||
|
||||
END MODULE write_upf_new
|
||||
|
|
@ -0,0 +1,887 @@
|
|||
!
|
||||
! Copyright (C) 2020 Quantum ESPRESSO group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
MODULE xmltools
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
! Poor-man tools for reading and writing xml files
|
||||
! Limitations: too many to be listed in detail. Main ones:
|
||||
! * lines no more than 1024 characters long (see maxline parameter)
|
||||
! * no more than 9 levels of tags (see maxlevel parameter)
|
||||
! * length of tags no more than 80 characters (see maxlength parameter)
|
||||
! * can read tags only in the correct order
|
||||
! * no commas in attribute values
|
||||
!
|
||||
USE upf_kinds, ONLY : dp
|
||||
IMPLICIT NONE
|
||||
!
|
||||
! internal variables for reading and writing
|
||||
!
|
||||
INTEGER :: xmlunit
|
||||
INTEGER, PARAMETER :: maxline=1024
|
||||
character(len=maxline) :: line
|
||||
integer :: eot
|
||||
integer :: nattr
|
||||
CHARACTER(LEN=:), ALLOCATABLE :: attrlist
|
||||
!
|
||||
! variables used keep track of open tags
|
||||
!
|
||||
INTEGER :: nlevel = -1
|
||||
INTEGER, PARAMETER :: maxlength=80, maxlevel=9
|
||||
CHARACTER(LEN=maxlength), DIMENSION(0:maxlevel) :: open_tags
|
||||
!
|
||||
PRIVATE
|
||||
PUBLIC :: xml_openfile, xml_closefile
|
||||
PUBLIC :: add_attr
|
||||
PUBLIC :: xmlw_writetag, xmlw_opentag, xmlw_closetag
|
||||
PUBLIC :: xmlr_readtag, xmlr_opentag, xmlr_closetag
|
||||
PUBLIC :: get_attr
|
||||
PUBLIC :: xml_protect, i2c, l2c, r2c
|
||||
!
|
||||
INTERFACE xmlr_readtag
|
||||
MODULE PROCEDURE readtag_c, readtag_r, readtag_l, readtag_i, readtag_rv
|
||||
END INTERFACE xmlr_readtag
|
||||
!
|
||||
INTERFACE xmlw_writetag
|
||||
MODULE PROCEDURE writetag_c, writetag_r, writetag_l, writetag_i, writetag_rv
|
||||
END INTERFACE xmlw_writetag
|
||||
!
|
||||
INTERFACE get_attr
|
||||
MODULE PROCEDURE get_i_attr, get_l_attr, get_r_attr, get_c_attr
|
||||
END INTERFACE get_attr
|
||||
|
||||
INTERFACE add_attr
|
||||
MODULE PROCEDURE add_i_attr, add_l_attr, add_r_attr, add_c_attr
|
||||
END INTERFACE add_attr
|
||||
|
||||
CONTAINS
|
||||
|
||||
SUBROUTINE get_i_attr ( attrname, attrval_i )
|
||||
!
|
||||
IMPLICIT NONE
|
||||
CHARACTER(LEN=*), INTENT(IN) :: attrname
|
||||
INTEGER, INTENT(OUT) :: attrval_i
|
||||
!
|
||||
CHARACTER(LEN=80) :: attrval_c
|
||||
!
|
||||
CALL get_c_attr ( attrname, attrval_c )
|
||||
if ( len_trim(attrval_c) > 0 ) then
|
||||
READ (attrval_c,*) attrval_i
|
||||
else
|
||||
attrval_i = 0
|
||||
end if
|
||||
!
|
||||
END SUBROUTINE get_i_attr
|
||||
!
|
||||
SUBROUTINE get_l_attr ( attrname, attrval_l )
|
||||
!
|
||||
IMPLICIT NONE
|
||||
CHARACTER(LEN=*), INTENT(IN) :: attrname
|
||||
LOGICAL, INTENT(OUT) :: attrval_l
|
||||
!
|
||||
CHARACTER(LEN=80) :: attrval_c
|
||||
!
|
||||
CALL get_c_attr ( attrname, attrval_c )
|
||||
if ( len_trim(attrval_c) > 0 ) then
|
||||
READ (attrval_c,*) attrval_l
|
||||
else
|
||||
attrval_l = .false.
|
||||
end if
|
||||
!
|
||||
END SUBROUTINE get_l_attr
|
||||
!
|
||||
SUBROUTINE get_r_attr ( attrname, attrval_r )
|
||||
!
|
||||
IMPLICIT NONE
|
||||
CHARACTER(LEN=*), INTENT(IN) :: attrname
|
||||
REAL(dp), INTENT(OUT) :: attrval_r
|
||||
!
|
||||
CHARACTER(LEN=80) :: attrval_c
|
||||
!
|
||||
CALL get_c_attr ( attrname, attrval_c )
|
||||
if ( len_trim(attrval_c) > 0 ) then
|
||||
READ (attrval_c,*) attrval_r
|
||||
else
|
||||
attrval_r = 0.0_dp
|
||||
end if
|
||||
!
|
||||
END SUBROUTINE get_r_attr
|
||||
!
|
||||
SUBROUTINE get_c_attr ( attrname, attrval_c )
|
||||
!
|
||||
IMPLICIT NONE
|
||||
CHARACTER(LEN=*), INTENT(IN) :: attrname
|
||||
CHARACTER(LEN=*), INTENT(OUT) :: attrval_c
|
||||
!
|
||||
CHARACTER(LEN=1) :: quote
|
||||
INTEGER :: j0, j1
|
||||
LOGICAL :: found
|
||||
!
|
||||
! search for attribute name in attrlist: attr1="val1" attr2="val2" ...
|
||||
!
|
||||
attrval_c = ''
|
||||
if ( .not. allocated(attrlist) ) return
|
||||
if ( len_trim(attrlist) < 1 ) return
|
||||
!
|
||||
j0 = 1
|
||||
do while ( j0 < len_trim(attrlist) )
|
||||
! locate = and first quote
|
||||
j1 = index ( attrlist(j0:), '=' )
|
||||
quote = attrlist(j0+j1:j0+j1)
|
||||
! next line: something is not right
|
||||
if ( quote /= '"' .and. quote /= "'" ) return
|
||||
! check if attribute found: need exact match
|
||||
found = ( trim(attrname) == adjustl(trim(attrlist(j0:j0+j1-2))) )
|
||||
! locate next quote
|
||||
j0 = j0+j1+1
|
||||
j1 = index ( attrlist(j0:), quote )
|
||||
if ( found) then
|
||||
if ( j1 == 1 ) then
|
||||
! two quotes, one after the other ("")
|
||||
attrval_c = ' '
|
||||
else
|
||||
! get value between two quotes
|
||||
attrval_c = adjustl(trim(attrlist(j0:j0+j1-2)))
|
||||
end if
|
||||
return
|
||||
end if
|
||||
j0 = j0+j1
|
||||
end do
|
||||
!
|
||||
END SUBROUTINE get_c_attr
|
||||
!
|
||||
SUBROUTINE add_i_attr ( attrname, attrval_i )
|
||||
!
|
||||
IMPLICIT NONE
|
||||
CHARACTER(LEN=*), INTENT(IN) :: attrname
|
||||
INTEGER, INTENT(IN) :: attrval_i
|
||||
!
|
||||
CALL add_c_attr ( attrname, i2c(attrval_i) )
|
||||
!
|
||||
END SUBROUTINE add_i_attr
|
||||
!
|
||||
SUBROUTINE add_l_attr ( attrname, attrval_l )
|
||||
!
|
||||
IMPLICIT NONE
|
||||
CHARACTER(LEN=*), INTENT(IN) :: attrname
|
||||
LOGICAL, INTENT(IN) :: attrval_l
|
||||
!
|
||||
CALL add_c_attr ( attrname, l2c(attrval_l) )
|
||||
!
|
||||
END SUBROUTINE add_l_attr
|
||||
!
|
||||
SUBROUTINE add_r_attr ( attrname, attrval_r )
|
||||
!
|
||||
IMPLICIT NONE
|
||||
CHARACTER(LEN=*), INTENT(IN) :: attrname
|
||||
REAL(dp), INTENT(IN) :: attrval_r
|
||||
!
|
||||
CALL add_c_attr ( attrname, r2c(attrval_r) )
|
||||
!
|
||||
END SUBROUTINE add_r_attr
|
||||
!
|
||||
SUBROUTINE add_c_attr ( attrname, attrval_c )
|
||||
!
|
||||
IMPLICIT NONE
|
||||
CHARACTER(LEN=*), INTENT(IN) :: attrname, attrval_c
|
||||
!
|
||||
IF ( .NOT. ALLOCATED(attrlist) ) THEN
|
||||
attrlist = ' '//TRIM(attrname)//'="'//TRIM(attrval_c)//'"'
|
||||
ELSE
|
||||
attrlist = attrlist // ' ' // TRIM(attrname)//'="'//TRIM(attrval_c)//'"'
|
||||
END IF
|
||||
!
|
||||
END SUBROUTINE add_c_attr
|
||||
!
|
||||
FUNCTION xml_openfile ( filexml ) RESULT (iun)
|
||||
!
|
||||
! returns on output the opened unit number if opened successfully
|
||||
! returns -1 otherwise
|
||||
!
|
||||
CHARACTER(LEN=*), INTENT(in) :: filexml
|
||||
INTEGER :: iun, ios
|
||||
!
|
||||
OPEN ( NEWUNIT=iun, FILE=filexml, FORM='formatted', STATUS='unknown', &
|
||||
IOSTAT=ios)
|
||||
IF ( ios /= 0 ) iun = -1
|
||||
xmlunit = iun
|
||||
nlevel = 0
|
||||
open_tags(nlevel) = 'root'
|
||||
if ( allocated(attrlist) ) DEALLOCATE ( attrlist)
|
||||
!
|
||||
END FUNCTION xml_openfile
|
||||
!
|
||||
SUBROUTINE xml_closefile ( )
|
||||
!
|
||||
CLOSE ( UNIT=xmlunit, STATUS='keep' )
|
||||
xmlunit = -1
|
||||
IF ( nlevel > 0 ) THEN
|
||||
print '("severe error: file closed at level ",i1," with tag ",A," open")', &
|
||||
nlevel, trim(open_tags(nlevel))
|
||||
END IF
|
||||
nlevel = 0
|
||||
!
|
||||
END SUBROUTINE xml_closefile
|
||||
!
|
||||
SUBROUTINE xmlw_opentag (name, ierr )
|
||||
! On input:
|
||||
! name required, character: tag name
|
||||
! On output: the tag is left open, ready for addition of data -
|
||||
! the tag must be subsequently closed with close_xml_tag
|
||||
! If ierr is present, the following value is returned:
|
||||
! ierr = 0 normal execution
|
||||
! ierr = 1 cannot write to unit "xmlunit"
|
||||
! ierr = 2 tag name too long
|
||||
! ierr = 3 too many tag levels
|
||||
! ierr =10 wrong number of values for attributes
|
||||
! If absent, the above error messages are printed.
|
||||
!
|
||||
CHARACTER(LEN=*), INTENT(IN) :: name
|
||||
INTEGER, INTENT(OUT),OPTIONAL :: ierr
|
||||
!
|
||||
INTEGER :: ier_
|
||||
CHARACTER(LEN=1) :: tag_end='>'
|
||||
!
|
||||
ier_ = write_tag_and_attr (name)
|
||||
IF ( ier_ < 0 ) ier_ = 0
|
||||
! complete tag, leaving it open for further data
|
||||
WRITE (xmlunit, "(A1)", ERR=100) tag_end
|
||||
! exit here
|
||||
100 IF ( present(ierr) ) THEN
|
||||
ierr = ier_
|
||||
ELSE IF ( ier_ > 0 ) THEN
|
||||
print '("Fatal error ",i2," in xmlw_opentag!")', ier_
|
||||
END IF
|
||||
!
|
||||
END SUBROUTINE xmlw_opentag
|
||||
|
||||
SUBROUTINE writetag_c (name, cval, ierr )
|
||||
! On input, same as xmlw_opentag, plus:
|
||||
! cval character, value of the tag.
|
||||
! 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>
|
||||
! (su di una stessa riga)
|
||||
! On output, same as xmlw_opentag
|
||||
!
|
||||
CHARACTER(LEN=*), INTENT(IN) :: name
|
||||
CHARACTER(LEN=*), INTENT(IN) :: cval
|
||||
INTEGER, INTENT(OUT),OPTIONAL :: ierr
|
||||
!
|
||||
INTEGER :: ier_
|
||||
LOGICAL :: is_proc
|
||||
!
|
||||
is_proc = (LEN_TRIM(cval) == 1)
|
||||
IF ( is_proc ) is_proc = is_proc .AND. ( cval(1:1) == '?')
|
||||
IF (is_proc) THEN
|
||||
ier_ = write_tag_and_attr ( '?'//name )
|
||||
ELSE
|
||||
ier_ = write_tag_and_attr ( name )
|
||||
END IF
|
||||
IF ( ier_ > 0 ) GO TO 10
|
||||
!
|
||||
! all is well: write tag value if any, close otherwise
|
||||
!
|
||||
IF ( LEN_TRIM(cval) == 0 ) THEN
|
||||
! empty tag value: close here the tag
|
||||
CALL xmlw_closetag ( '' )
|
||||
ELSE IF ( is_proc ) THEN
|
||||
! close "process" tag (e.g. <?xml ... ?>
|
||||
CALL xmlw_closetag ( '?' )
|
||||
ELSE
|
||||
! write value (character)
|
||||
WRITE (xmlunit, "('>',A)", ADVANCE='no') trim(cval)
|
||||
! close here the tag
|
||||
CALL xmlw_closetag ( name )
|
||||
END IF
|
||||
! in case of exit error close the tag anyway
|
||||
10 IF ( ier_ /= 0 ) WRITE (xmlunit, "('>')", ERR=100)
|
||||
100 IF ( present(ierr) ) THEN
|
||||
ierr = ier_
|
||||
ELSE IF ( ier_ > 0 ) THEN
|
||||
print '("Fatal error ",i2," in xmlw_writetag!")', ier_
|
||||
stop
|
||||
END IF
|
||||
!
|
||||
END SUBROUTINE writetag_c
|
||||
!
|
||||
SUBROUTINE writetag_i (name, ival, ierr )
|
||||
!
|
||||
! As writetag_c, for integer value
|
||||
!
|
||||
CHARACTER(LEN=*), INTENT(IN) :: name
|
||||
INTEGER, INTENT(IN) :: ival
|
||||
INTEGER, INTENT(OUT),OPTIONAL :: ierr
|
||||
!
|
||||
CALL writetag_c (name, i2c(ival), ierr )
|
||||
!
|
||||
END SUBROUTINE writetag_i
|
||||
!
|
||||
SUBROUTINE writetag_l (name, lval, ierr )
|
||||
!
|
||||
! As writetag_c, for logical value
|
||||
!
|
||||
CHARACTER(LEN=*), INTENT(IN) :: name
|
||||
LOGICAL, INTENT(IN) :: lval
|
||||
INTEGER, INTENT(OUT),OPTIONAL :: ierr
|
||||
!
|
||||
CALL writetag_c (name, l2c(lval), ierr )
|
||||
!
|
||||
END SUBROUTINE writetag_l
|
||||
!
|
||||
SUBROUTINE writetag_r (name, rval, ierr )
|
||||
!
|
||||
! As writetag_c, for real value
|
||||
!
|
||||
CHARACTER(LEN=*), INTENT(IN) :: name
|
||||
REAL(dp), INTENT(IN) :: rval
|
||||
INTEGER, INTENT(OUT),OPTIONAL :: ierr
|
||||
!
|
||||
CALL writetag_c (name, r2c(rval), ierr )
|
||||
!
|
||||
END SUBROUTINE writetag_r
|
||||
!
|
||||
SUBROUTINE writetag_rv (name, rval, ierr )
|
||||
!
|
||||
! As writetag_c, for an array of real values
|
||||
!
|
||||
CHARACTER(LEN=*), INTENT(IN) :: name
|
||||
REAL(dp), INTENT(IN) :: rval(:)
|
||||
INTEGER, INTENT(OUT),OPTIONAL :: ierr
|
||||
!
|
||||
CALL xmlw_opentag (name, ierr )
|
||||
WRITE( xmlunit, *) rval
|
||||
CALL xmlw_closetag ( )
|
||||
!
|
||||
END SUBROUTINE writetag_rv
|
||||
|
||||
FUNCTION write_tag_and_attr (name) RESULT (ierr)
|
||||
!
|
||||
CHARACTER(LEN=*), INTENT(IN) :: name
|
||||
INTEGER :: ierr
|
||||
!
|
||||
LOGICAL :: have_list, have_vals
|
||||
INTEGER :: i, la, lv, n1a,n2a, n1v, n2v
|
||||
!
|
||||
IF ( LEN_TRIM(name) > maxlength ) THEN
|
||||
ierr = 2
|
||||
RETURN
|
||||
END IF
|
||||
!
|
||||
IF ( nlevel+1 > maxlevel ) THEN
|
||||
ierr = 3
|
||||
RETURN
|
||||
END IF
|
||||
nlevel = nlevel+1
|
||||
open_tags(nlevel) = TRIM(name)
|
||||
!
|
||||
! pretty (?) printing
|
||||
!
|
||||
ierr = 1
|
||||
DO i=2,nlevel
|
||||
WRITE (xmlunit, "(' ')", ADVANCE="no", ERR=10)
|
||||
END DO
|
||||
WRITE (xmlunit, "('<',A)", ADVANCE="no", ERR=10) trim(name)
|
||||
! print '("opened at level ",i1," tag ",A)', nlevel, trim(open_tags(nlevel))
|
||||
!
|
||||
! attributes (if present)
|
||||
!
|
||||
ierr = 10
|
||||
if ( allocated (attrlist) ) then
|
||||
WRITE (xmlunit, "(A)", ADVANCE='no', ERR=10) attrlist
|
||||
deallocate (attrlist)
|
||||
end if
|
||||
! normal exit here
|
||||
ierr = 0
|
||||
10 RETURN
|
||||
!
|
||||
END FUNCTION write_tag_and_attr
|
||||
!
|
||||
SUBROUTINE xmlw_closetag ( tag )
|
||||
! tag not present: close current open tag with </tag>
|
||||
! empty tag present: close current open tag with />
|
||||
! tag='?' present: close current open tag with ?>
|
||||
! otherwise,close specified tag with </tag>
|
||||
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: tag
|
||||
INTEGER :: i
|
||||
!
|
||||
IF ( nlevel < 0 ) &
|
||||
print '("severe error: closing tag that was never opened")'
|
||||
IF ( .NOT.PRESENT(tag) ) THEN
|
||||
DO i=2,nlevel
|
||||
WRITE (xmlunit, '(" ")', ADVANCE='NO')
|
||||
END DO
|
||||
WRITE (xmlunit, '("</",A,">")') trim(open_tags(nlevel))
|
||||
ELSE
|
||||
i = len_trim(tag)
|
||||
IF ( i == 0 ) THEN
|
||||
WRITE (xmlunit, '("/>")')
|
||||
ELSE IF ( i == 1 .AND. tag(1:1) == '?' ) THEN
|
||||
WRITE (xmlunit, '("?>")')
|
||||
ELSE
|
||||
WRITE (xmlunit, '("</",A,">")') trim(tag)
|
||||
END IF
|
||||
END IF
|
||||
!print '("closed at level ",i1," tag ",A)', nlevel, trim(open_tags(nlevel))
|
||||
nlevel = nlevel-1
|
||||
!
|
||||
END SUBROUTINE xmlw_closetag
|
||||
!
|
||||
!--------------------------------------------------------
|
||||
function xml_protect ( data_in ) result (data_out)
|
||||
!--------------------------------------------------------
|
||||
!
|
||||
! poor-man escaping of a string so that it conforms to xml standard:
|
||||
! replace & with @, < and > with *.
|
||||
! To prevent problems with attributes, double quotes " are replaced
|
||||
! with single quotes '. data_out is left-justified
|
||||
!
|
||||
character(len=*), intent(in) :: data_in
|
||||
character(len=:), allocatable :: data_out
|
||||
character(len=1) :: c
|
||||
integer:: n, i
|
||||
!
|
||||
n = len_trim(adjustl(data_in))
|
||||
! Alternative version with CDATA:
|
||||
! allocate(character(len=n+12):: data_out)
|
||||
! data_out = '<![CDATA['//trim(adjustl(data_in))//']]>'
|
||||
data_out = trim(adjustl(data_in))
|
||||
do i=1,n
|
||||
if ( data_out(i:i) == '&' ) data_out(i:i) = '@'
|
||||
if ( data_out(i:i) == '<' .or. data_out(i:i) == '>') data_out(i:i) = '*'
|
||||
if ( data_out(i:i) == '"' ) data_out(i:i) = "'"
|
||||
end do
|
||||
! a more complete version should escape & as &, < as <
|
||||
! (escaping > as > , " as "es; , ' as &apo; is not strictly needed)
|
||||
! BUT taking care not to escape & into &amp;
|
||||
|
||||
end function xml_protect
|
||||
|
||||
! Poor-man conversion utilities from integer, logical, real to character
|
||||
! To be used in conjunction with routines in module xmlw to write xml
|
||||
!
|
||||
function i2c (i) result (c)
|
||||
integer, intent(in) :: i
|
||||
character(len=:), allocatable :: c
|
||||
character(len=11) :: caux
|
||||
!
|
||||
write(caux,'(i11)') i
|
||||
c = trim(adjustl(caux))
|
||||
!
|
||||
end function i2c
|
||||
|
||||
function l2c (l) result (c)
|
||||
logical, intent(in) :: l
|
||||
character(len=:), allocatable :: c
|
||||
!
|
||||
if (l) then
|
||||
c='true'
|
||||
else
|
||||
c='false'
|
||||
endif
|
||||
!
|
||||
end function l2c
|
||||
|
||||
function r2c (f) result (c)
|
||||
real(dp), intent(in) :: f
|
||||
character(len=:), allocatable :: c
|
||||
character(len=30) :: caux
|
||||
!
|
||||
integer :: n, m, i
|
||||
! The format of real numbers can be vastly improved
|
||||
! this is just the simplest solution
|
||||
write(caux,*) f
|
||||
c = trim(adjustl(caux))
|
||||
!
|
||||
end function r2c
|
||||
!
|
||||
SUBROUTINE readtag_i (name, ival, ierr )
|
||||
!
|
||||
! As readtag_c, for integer value
|
||||
!
|
||||
CHARACTER(LEN=*), INTENT(IN) :: name
|
||||
INTEGER, INTENT(OUT) :: ival
|
||||
INTEGER, INTENT(OUT),OPTIONAL :: ierr
|
||||
CHARACTER(LEN=80) :: cval
|
||||
!
|
||||
CALL readtag_c (name, cval, ierr )
|
||||
if ( len_trim(cval) > 0 ) then
|
||||
READ (cval,*) ival
|
||||
else
|
||||
ival = 0
|
||||
end if
|
||||
!
|
||||
END SUBROUTINE readtag_i
|
||||
!
|
||||
SUBROUTINE readtag_l (name, lval, ierr )
|
||||
!
|
||||
! As readtag_c, for logical value
|
||||
!
|
||||
CHARACTER(LEN=*), INTENT(IN) :: name
|
||||
LOGICAL, INTENT(OUT) :: lval
|
||||
INTEGER, INTENT(OUT),OPTIONAL :: ierr
|
||||
CHARACTER(LEN=80) :: cval
|
||||
!
|
||||
CALL readtag_c (name, cval, ierr )
|
||||
if ( len_trim(cval) > 0 ) then
|
||||
READ (cval,*) lval
|
||||
else
|
||||
lval = .false.
|
||||
end if
|
||||
!
|
||||
END SUBROUTINE readtag_l
|
||||
!
|
||||
SUBROUTINE readtag_r (name, rval, ierr )
|
||||
!
|
||||
! As readtag_c, for real value
|
||||
!
|
||||
CHARACTER(LEN=*), INTENT(IN) :: name
|
||||
REAL(dp), INTENT(OUT) :: rval
|
||||
INTEGER, INTENT(OUT),OPTIONAL :: ierr
|
||||
CHARACTER(LEN=80) :: cval
|
||||
!
|
||||
CALL readtag_c (name, cval, ierr )
|
||||
if ( len_trim(cval) > 0 ) then
|
||||
READ (cval,*) rval
|
||||
else
|
||||
rval = 0.0_dp
|
||||
end if
|
||||
!
|
||||
END SUBROUTINE readtag_r
|
||||
!
|
||||
SUBROUTINE readtag_rv (name, rval, ierr)
|
||||
!
|
||||
! As readtag_c, for an array of real values
|
||||
!
|
||||
CHARACTER(LEN=*), INTENT(IN) :: name
|
||||
REAL(dp), INTENT(OUT) :: rval(:)
|
||||
INTEGER, INTENT(OUT),OPTIONAL :: ierr
|
||||
INTEGER :: ier_
|
||||
CHARACTER(LEN=80) :: cval
|
||||
!
|
||||
CALL xmlr_opentag (name, ier_)
|
||||
if ( ier_ == 0 ) then
|
||||
READ(xmlunit, *) rval
|
||||
CALL xmlr_closetag ( )
|
||||
else
|
||||
rval = 0.0_dp
|
||||
end if
|
||||
IF ( present (ierr) ) ierr = ier_
|
||||
!
|
||||
END SUBROUTINE readtag_rv
|
||||
!
|
||||
subroutine readtag_c ( tag, cval, ierr)
|
||||
!
|
||||
implicit none
|
||||
!
|
||||
character(len=*), intent(in) :: tag
|
||||
character(len=*), intent(out):: cval
|
||||
integer, intent(out), optional :: ierr
|
||||
! 0: tag found and read
|
||||
!-1: tag not found
|
||||
! 1: error parsing file
|
||||
! 2: error in arguments
|
||||
!
|
||||
integer :: i, j, lt
|
||||
character(len=1) :: endtag
|
||||
!
|
||||
call xmlr_opentag ( tag, ierr )
|
||||
!
|
||||
if ( eot > 0 ) then
|
||||
j = eot
|
||||
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'
|
||||
if ( present(ierr) ) ierr =-1
|
||||
else if ( eot < 0 ) then
|
||||
! print *, 'tag found, no value to read on line'
|
||||
cval = ''
|
||||
end if
|
||||
!
|
||||
end subroutine readtag_c
|
||||
!
|
||||
subroutine xmlr_opentag ( tag, ierr)
|
||||
!
|
||||
implicit none
|
||||
!
|
||||
character(len=*), intent(in) :: tag
|
||||
integer, intent(out), optional :: ierr
|
||||
! 0: tag found and read
|
||||
!-1: tag not found
|
||||
! 1: error parsing file
|
||||
! 2: line too long
|
||||
! 3: too many levels of tags
|
||||
!
|
||||
integer :: stat, ll, lt, i, j, j0
|
||||
! stat= 0: begin
|
||||
! stat=-1: in comment
|
||||
! stat=1 : tag found
|
||||
!
|
||||
character(len=1) :: quote
|
||||
!
|
||||
nattr=0
|
||||
if ( allocated(attrlist) ) deallocate (attrlist)
|
||||
!
|
||||
lt = len_trim(tag)
|
||||
stat=0
|
||||
eot =0
|
||||
do while (.true.)
|
||||
read(xmlunit,'(a)', end=10) line
|
||||
ll = len_trim(line)
|
||||
if ( ll == maxline ) then
|
||||
print *, 'line too long'
|
||||
if (present(ierr)) ierr = 2
|
||||
return
|
||||
end if
|
||||
! j is the current scan position
|
||||
j = 1
|
||||
! j0 is the start of attributes and values
|
||||
j0 = 1
|
||||
parse: do while ( j <= ll )
|
||||
!
|
||||
if ( stat ==-1 ) then
|
||||
!
|
||||
! scanning a comment
|
||||
i = index(line(j:),'-->')
|
||||
if ( i == 0 ) then
|
||||
! no end of comment found on this line
|
||||
exit parse
|
||||
else
|
||||
! end of comment found
|
||||
stat = 0
|
||||
j = j+i+3
|
||||
end if
|
||||
!
|
||||
else if ( stat == 0 ) then
|
||||
!
|
||||
! searching for tag
|
||||
!
|
||||
i = index( line(j:),'<'//trim(tag) )
|
||||
if ( i == 0 ) then
|
||||
! no tag found on this line
|
||||
exit parse
|
||||
else
|
||||
! tag found? check what follows our would-be tag
|
||||
j = j+i+lt
|
||||
if ( j > ll ) then
|
||||
print *, 'oops... opened tag not closed on same line'
|
||||
exit parse
|
||||
else if ( line(j:j) == ' ' .or. line(j:j) == '>') then
|
||||
! print *, '<tag found'
|
||||
stat = 1
|
||||
end if
|
||||
end if
|
||||
!
|
||||
else if ( stat == 1 ) then
|
||||
! tag found, search for attributes if any or end of tag
|
||||
if (line(j:j) == ' ' ) then
|
||||
! skip blanks: there is at least one if attributes are present
|
||||
j = j+1
|
||||
! save value of j into j0: beginning of an attribute
|
||||
j0= j
|
||||
else if ( line(j:j+1) == '/>' ) then
|
||||
! <tag ... /> found : return
|
||||
if (present(ierr)) ierr = 0
|
||||
! eot = -2: tag with no value found
|
||||
eot = -2
|
||||
!
|
||||
return
|
||||
!
|
||||
else if ( line(j:j) == '>' ) then
|
||||
! <tag ... > found
|
||||
if ( j+1 > ll ) then
|
||||
! eot = -1: tag found, line ends
|
||||
eot = -1
|
||||
else
|
||||
! eot points to the rest of the line
|
||||
eot = j+1
|
||||
end if
|
||||
if (present(ierr)) ierr = 0
|
||||
nlevel = nlevel+1
|
||||
IF ( nlevel > maxlevel ) THEN
|
||||
print *, ' too many levels'
|
||||
if (present(ierr)) ierr = 3
|
||||
else
|
||||
open_tags(nlevel) = trim(tag)
|
||||
!print '("opened at level ",i1," tag ",A)', &
|
||||
! nlevel, trim(open_tags(nlevel))
|
||||
end if
|
||||
!
|
||||
return
|
||||
!
|
||||
else if ( line(j:j) == '=' ) then
|
||||
! end of attribute located: save attribute (with final =)
|
||||
nattr=nattr+1
|
||||
! print *, 'attr=',line(j0:j-1)
|
||||
if ( nattr == 1 ) then
|
||||
attrlist = line(j0:j)
|
||||
else
|
||||
attrlist = attrlist//' '//line(j0:j)
|
||||
end if
|
||||
! continue searching for attribute value
|
||||
j = j+1
|
||||
else if ( line(j:j) == '"' .or. line(j:j) =="'" ) then
|
||||
! first occurrence of ' or " found, look for next
|
||||
quote = line(j:j)
|
||||
i = index(line(j+1:),quote)
|
||||
if ( i < 1 ) then
|
||||
! print *, 'Error: matching quote not found'
|
||||
go to 10
|
||||
else
|
||||
! save attribute value (with quotes) and continue scanning
|
||||
! print *, 'attrval=',line(j:j+i-2)
|
||||
attrlist = attrlist//line(j:j+i)
|
||||
j = j+i+1
|
||||
end if
|
||||
else
|
||||
! continue scanning until end of attribute
|
||||
j = j+1
|
||||
endif
|
||||
!
|
||||
end if
|
||||
end do parse
|
||||
!
|
||||
end do
|
||||
!
|
||||
10 if ( stat == 0 ) then
|
||||
if ( present(ierr) ) then
|
||||
ierr =-1
|
||||
else
|
||||
print *, 'end of file reached, tag '//trim(tag)//' not found'
|
||||
end if
|
||||
else
|
||||
print *, 'parsing error'
|
||||
if ( present(ierr) ) ierr = 1
|
||||
end if
|
||||
!
|
||||
end subroutine xmlr_opentag
|
||||
!
|
||||
subroutine xmlr_closetag ( tag, ierr)
|
||||
!
|
||||
implicit none
|
||||
!
|
||||
character(len=*), intent(in), optional :: tag
|
||||
integer, intent(out), optional :: ierr
|
||||
! 0: </tag> found
|
||||
! 1: </tag> not found
|
||||
! 2: error parsing file
|
||||
!
|
||||
integer :: stat, ll, lt, i, j
|
||||
! stat=-1: in comment
|
||||
! stat= 0: begin
|
||||
! stat= 1: end
|
||||
!
|
||||
IF ( nlevel < 0 ) &
|
||||
print '("severe error: closing tag that was never opened")'
|
||||
stat=0
|
||||
!write(6,'("closing at level ",i1," tag ",A,"...")',advance='no') &
|
||||
! nlevel,trim(open_tags(nlevel))
|
||||
do while (.true.)
|
||||
read(xmlunit,'(a)', end=10) line
|
||||
ll = len_trim(line)
|
||||
if ( ll == maxline ) then
|
||||
print *, 'line too long'
|
||||
if (present(ierr)) ierr = 1
|
||||
return
|
||||
end if
|
||||
! j is the current scan position
|
||||
j = 1
|
||||
parse: do while ( j <= ll )
|
||||
!
|
||||
if ( stat ==-1 ) then
|
||||
!
|
||||
! scanning a comment
|
||||
i = index(line(j:),'-->')
|
||||
if ( i == 0 ) then
|
||||
! no end of comment found on this line
|
||||
exit parse
|
||||
else
|
||||
! end of comment found
|
||||
stat = 0
|
||||
j = j+i+3
|
||||
end if
|
||||
!
|
||||
else if ( stat == 0 ) then
|
||||
!
|
||||
! searching for closing tag
|
||||
!
|
||||
IF ( .NOT.PRESENT(tag) ) THEN
|
||||
i = index( line(j:),'</'//trim(open_tags(nlevel)) )
|
||||
lt= len_trim(open_tags(nlevel))
|
||||
ELSE
|
||||
i = index( line(j:),'</'//trim(tag) )
|
||||
lt= len_trim(tag)
|
||||
END IF
|
||||
if ( i == 0 ) then
|
||||
! no tag found on this line
|
||||
exit parse
|
||||
else
|
||||
! tag found? check what follows our would-be tag
|
||||
j = j+i+1+lt
|
||||
if ( j > ll ) then
|
||||
print *, 'oops... opened tag not closed on same line'
|
||||
exit parse
|
||||
else if ( line(j:j) == ' ' .or. line(j:j) == '>') then
|
||||
! print *, '</tag found'
|
||||
stat = 1
|
||||
end if
|
||||
end if
|
||||
!
|
||||
else if ( stat == 1 ) then
|
||||
!
|
||||
! </tag found, search for end of tag
|
||||
!
|
||||
if (line(j:j) == ' ' ) then
|
||||
! skip blanks
|
||||
j = j+1
|
||||
else if ( line(j:j) == '>' ) then
|
||||
! </tag ... > found
|
||||
! print *, '</tag> found'
|
||||
if ( present(ierr) ) ierr = 0
|
||||
!print '("closed")'
|
||||
nlevel = nlevel - 1
|
||||
!
|
||||
return
|
||||
!
|
||||
endif
|
||||
!
|
||||
end if
|
||||
end do parse
|
||||
!
|
||||
end do
|
||||
!
|
||||
10 print *, 'end of file reached, closing tag not found'
|
||||
if ( present(ierr) ) ierr = 1
|
||||
!
|
||||
end subroutine xmlr_closetag
|
||||
|
||||
END MODULE xmltools
|
Loading…
Reference in New Issue