scnc
/
quantum-espresso
mirror of https://gitlab.com/QEF/q-e.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Source "normalization" using Norbert's script dev-tools/src-normal. 

Changes should not affect functionalities (please verify!)


git-svn-id: http://qeforge.qe-forge.org/svn/q-e/trunk/espresso@6825 c92efa57-630b-4861-b058-cf58834340f0
This commit is contained in:
giannozz 2010-06-11 09:00:04 +00:00
parent 687bd89938
commit 13e61c2110
15 changed files with 2378 additions and 2378 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
upftools/any2upf.f90
View File

@ -7,72 +7,72 @@
! !
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
program mypp2upf PROGRAM mypp2upf
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
! Convert a pseudopotential written in a user-supplied format ! Convert a pseudopotential written in a user-supplied format
! to unified pseudopotential format - sample program ! to unified pseudopotential format - sample program
! !
implicit none IMPLICIT NONE
character(len=256) filein, fileout CHARACTER(len=256) filein, fileout
! !
! !
call get_file ( filein ) CALL get_file ( filein )
open (unit = 1, file = filein, status = 'old', form = 'formatted') OPEN (unit = 1, file = filein, status = 'old', form = 'formatted')
call read_mypp(1) CALL read_mypp(1)
close (1) CLOSE (1)
! convert variables read from user-supplied format into those needed ! convert variables read from user-supplied format into those needed
! by the upf format - add missing quantities ! by the upf format - add missing quantities
call convert_mypp CALL convert_mypp
fileout=trim(filein)//'.UPF' fileout=trim(filein)//'.UPF'
print '(''Output PP file in UPF format : '',a)', fileout PRINT '(''Output PP file in UPF format : '',a)', fileout
open(unit=2,file=fileout,status='unknown',form='formatted') OPEN(unit=2,file=fileout,status='unknown',form='formatted')
call write_upf(2) CALL write_upf(2)
close (unit=2) CLOSE (unit=2)
stop STOP
20 write (6,'("mypp2upf: error reading pseudopotential file name")') 20 WRITE (6,'("mypp2upf: error reading pseudopotential file name")')
stop STOP
end program mypp2upf END PROGRAM mypp2upf
module mypp MODULE mypp
! !
! All variables read from user-supplied file format ! All variables read from user-supplied file format
! Must have distinct names from variables in the "upf" module ! Must have distinct names from variables in the "upf" module
! !
end module mypp END MODULE mypp
! !
! ---------------------------------------------------------- ! ----------------------------------------------------------
subroutine read_mypp(iunps) SUBROUTINE read_mypp(iunps)
! ----------------------------------------------------------
!
use mypp
implicit none
integer :: iunps
!
! ----------------------------------------------------------
write (6,'(a)') 'Pseudopotential successfully read'
! ---------------------------------------------------------- ! ----------------------------------------------------------
! !
return USE mypp
100 write (6,'("read_mypp: error reading pseudopotential file")') IMPLICIT NONE
stop INTEGER :: iunps
end subroutine read_mypp !
! ----------------------------------------------------------
WRITE (6,'(a)') 'Pseudopotential successfully read'
! ----------------------------------------------------------
!
RETURN
100 WRITE (6,'("read_mypp: error reading pseudopotential file")')
STOP
END SUBROUTINE read_mypp
! ---------------------------------------------------------- ! ----------------------------------------------------------
subroutine convert_mypp SUBROUTINE convert_mypp
! ---------------------------------------------------------- ! ----------------------------------------------------------
! !
use mypp USE mypp
use upf USE upf
implicit none IMPLICIT NONE
! ---------------------------------------------------------- ! ----------------------------------------------------------
write (6,'(a)') 'Pseudopotential successfully converted' WRITE (6,'(a)') 'Pseudopotential successfully converted'
! ---------------------------------------------------------- ! ----------------------------------------------------------
return RETURN
end subroutine convert_mypp END SUBROUTINE convert_mypp

162
upftools/casino2upf.f90
View File

@ -29,9 +29,9 @@ PROGRAM casino2upf
PRINT*, 'Enter wavefunction files, starting with the ground state:' PRINT*, 'Enter wavefunction files, starting with the ground state:'
DO i=1,nofiles DO i=1,nofiles
CALL get_file ( wavefile(i) ) CALL get_file ( wavefile(i) )
OPEN(unit=i,file=wavefile(i),status='old',form='formatted') OPEN(unit=i,file=wavefile(i),status='old',form='formatted')
ENDDO ENDDO
OPEN(unit=99,file=filein,status='old',form='formatted') OPEN(unit=99,file=filein,status='old',form='formatted')
CALL read_casino(99,nofiles) CALL read_casino(99,nofiles)
CLOSE (unit=99) CLOSE (unit=99)
@ -44,7 +44,7 @@ PROGRAM casino2upf
CALL convert_casino CALL convert_casino
fileout=TRIM(filein)//'.UPF' fileout=trim(filein)//'.UPF'
PRINT '(''Output PP file in US format : '',a)', fileout PRINT '(''Output PP file in US format : '',a)', fileout
OPEN(unit=2,file=fileout,status='unknown',form='formatted') OPEN(unit=2,file=fileout,status='unknown',form='formatted')
@ -56,10 +56,10 @@ PROGRAM casino2upf
END PROGRAM casino2upf END PROGRAM casino2upf
MODULE casino MODULE casino
! !
! All variables read from CASINO file format ! All variables read from CASINO file format
! !
! trailing underscore means that a variable with the same name ! trailing underscore means that a variable with the same name
! is used in module 'upf' containing variables to be written ! is used in module 'upf' containing variables to be written
! !
@ -82,17 +82,17 @@ MODULE casino
REAL(8), ALLOCATABLE:: chi_(:,:), oc_(:) REAL(8), ALLOCATABLE:: chi_(:,:), oc_(:)
END MODULE casino END MODULE casino
! !
! ---------------------------------------------------------- ! ----------------------------------------------------------
SUBROUTINE read_casino(iunps,nofiles) SUBROUTINE read_casino(iunps,nofiles)
! ---------------------------------------------------------- ! ----------------------------------------------------------
! !
USE casino USE casino
USE upf , ONLY : els USE upf , ONLY : els
USE kinds USE kinds
IMPLICIT NONE IMPLICIT NONE
TYPE :: wavfun_list TYPE :: wavfun_list
INTEGER :: occ,eup,edwn, nquant, lquant INTEGER :: occ,eup,edwn, nquant, lquant
CHARACTER(len=2) :: label CHARACTER(len=2) :: label
#ifdef __STD_F95 #ifdef __STD_F95
REAL*8, POINTER :: wavefunc(:) REAL*8, POINTER :: wavefunc(:)
@ -112,7 +112,7 @@ SUBROUTINE read_casino(iunps,nofiles)
LOGICAL :: groundstate, found LOGICAL :: groundstate, found
CHARACTER(len=1), DIMENSION(0:3) :: convel=(/'s','p','d','f'/) CHARACTER(len=1), DIMENSION(0:3) :: convel=(/'s','p','d','f'/)
CHARACTER(len=2) :: label, rellab CHARACTER(len=2) :: label, rellab
REAL(DP), parameter :: r_exp=20._dp/1500._dp REAL(DP), PARAMETER :: r_exp=20._dp/1500._dp
INTEGER :: l, i, ir, nb, gsorbs, j,k,m,tmp, lquant, orbs, nquant INTEGER :: l, i, ir, nb, gsorbs, j,k,m,tmp, lquant, orbs, nquant
INTEGER, ALLOCATABLE :: gs(:,:) INTEGER, ALLOCATABLE :: gs(:,:)
@ -122,31 +122,31 @@ SUBROUTINE read_casino(iunps,nofiles)
nlc = 0 !These two values are always 0 for numeric pps nlc = 0 !These two values are always 0 for numeric pps
nnl = 0 !so lets just hard code them nnl = 0 !so lets just hard code them
nlcc_ = .FALSE. !Again these two are alwas false for CASINO pps nlcc_ = .false. !Again these two are alwas false for CASINO pps
bhstype = .FALSE. bhstype = .false.
READ(iunps,'(a2,35x,a2)') rellab, psd_ READ(iunps,'(a2,35x,a2)') rellab, psd_
READ(iunps,*) READ(iunps,*)
IF ( rellab .EQ. 'DF' ) THEN IF ( rellab == 'DF' ) THEN
rel_=1 rel_=1
ELSE ELSE
rel_=0 rel_=0
ENDIF ENDIF
READ(iunps,*) zmesh,zp_ !Here we are reading zmesh (atomic #) and READ(iunps,*) zmesh,zp_ !Here we are reading zmesh (atomic #) and
DO i=1,3 !zp_ (pseudo charge) DO i=1,3 !zp_ (pseudo charge)
READ(iunps,*) READ(iunps,*)
ENDDO ENDDO
READ(iunps,*) lmax_ !reading in lmax READ(iunps,*) lmax_ !reading in lmax
IF ( zp_.LE.0d0 ) & IF ( zp_<=0d0 ) &
CALL errore( 'read_casino','Wrong zp ',1 ) CALL errore( 'read_casino','Wrong zp ',1 )
IF ( lmax_.GT.3.OR.lmax_.LT.0 ) & IF ( lmax_>3.or.lmax_<0 ) &
CALL errore( 'read_casino','Wrong lmax ',1 ) CALL errore( 'read_casino','Wrong lmax ',1 )
lloc=lmax_ !think lloc shoudl always = lmax for this case yes/no ?? lloc=lmax_ !think lloc shoudl always = lmax for this case yes/no ??
! !
! compute the radial mesh ! compute the radial mesh
! !
@ -165,7 +165,7 @@ SUBROUTINE read_casino(iunps,nofiles)
ENDDO ENDDO
DO ir = 1, mesh_ DO ir = 1, mesh_
rab_(ir) = r_exp * r_(ir) !hardcoded at the moment rab_(ir) = r_exp * r_(ir) !hardcoded at the moment
END DO ENDDO
ALLOCATE(vnl(mesh_,0:lmax_)) ALLOCATE(vnl(mesh_,0:lmax_))
@ -179,7 +179,7 @@ SUBROUTINE read_casino(iunps,nofiles)
DO ir = 1, mesh_ DO ir = 1, mesh_
vnl(ir,l) = vnl(ir,l)/r_(ir) !Removing the factor of r CASINO has vnl(ir,l) = vnl(ir,l)/r_(ir) !Removing the factor of r CASINO has
ENDDO ENDDO
vnl(1,l) = 0 !correcting for the divide by zero vnl(1,l) = 0 !correcting for the divide by zero
ENDDO ENDDO
ALLOCATE(rho_atc_(mesh_)) ALLOCATE(rho_atc_(mesh_))
@ -192,7 +192,7 @@ SUBROUTINE read_casino(iunps,nofiles)
! !
DO l = 0, lmax_ DO l = 0, lmax_
IF ( l.NE.lloc ) vnl(:,l) = vnl(:,l) - vnl(:,lloc) IF ( l/=lloc ) vnl(:,l) = vnl(:,l) - vnl(:,lloc)
ENDDO ENDDO
@ -202,7 +202,7 @@ SUBROUTINE read_casino(iunps,nofiles)
mptr => mhead mptr => mhead
NULLIFY(mtail%p) NULLIFY(mtail%p)
groundstate=.TRUE. groundstate=.true.
DO j=1,nofiles DO j=1,nofiles
DO i=1,4 DO i=1,4
@ -212,13 +212,13 @@ SUBROUTINE read_casino(iunps,nofiles)
READ(j,*) orbs READ(j,*) orbs
IF ( groundstate ) THEN IF ( groundstate ) THEN
ALLOCATE( gs(orbs,3) ) ALLOCATE( gs(orbs,3) )
gs = 0 gs = 0
gsorbs = orbs gsorbs = orbs
END IF ENDIF
DO i=1,2 DO i=1,2
READ(j,*) READ(j,*)
@ -231,20 +231,20 @@ SUBROUTINE read_casino(iunps,nofiles)
READ(j,*) tmp, nquant, lquant READ(j,*) tmp, nquant, lquant
IF ( groundstate ) THEN IF ( groundstate ) THEN
found = .TRUE. found = .true.
DO m=1,orbs DO m=1,orbs
IF ( (nquant==gs(m,1) .AND. lquant==gs(m,2)) ) THEN IF ( (nquant==gs(m,1) .and. lquant==gs(m,2)) ) THEN
gs(m,3) = gs(m,3) + 1 gs(m,3) = gs(m,3) + 1
EXIT exit
END IF ENDIF
found = .FALSE. found = .false.
ENDDO ENDDO
IF (.NOT. found ) THEN IF (.not. found ) THEN
DO m=1,orbs DO m=1,orbs
@ -253,7 +253,7 @@ SUBROUTINE read_casino(iunps,nofiles)
gs(m,2) = lquant gs(m,2) = lquant
gs(m,3) = 1 gs(m,3) = 1
EXIT exit
ENDIF ENDIF
ENDDO ENDDO
@ -265,9 +265,9 @@ SUBROUTINE read_casino(iunps,nofiles)
ENDDO ENDDO
READ(j,*) READ(j,*)
READ(j,*) READ(j,*)
DO i=1,mesh_ DO i=1,mesh_
READ(j,*) READ(j,*)
ENDDO ENDDO
@ -275,34 +275,34 @@ SUBROUTINE read_casino(iunps,nofiles)
READ(j,'(13x,a2)', err=300) label READ(j,'(13x,a2)', err=300) label
READ(j,*) tmp, nquant, lquant READ(j,*) tmp, nquant, lquant
IF ( .NOT. groundstate ) THEN IF ( .not. groundstate ) THEN
found = .FALSE. found = .false.
DO m = 1,gsorbs DO m = 1,gsorbs
IF ( nquant == gs(m,1) .AND. lquant == gs(m,2) ) THEN IF ( nquant == gs(m,1) .and. lquant == gs(m,2) ) THEN
found = .TRUE. found = .true.
EXIT exit
END IF ENDIF
END DO ENDDO
mptr => mhead mptr => mhead
DO DO
IF ( .NOT. ASSOCIATED(mptr) )EXIT IF ( .not. associated(mptr) )exit
IF ( nquant == mptr%nquant .AND. lquant == mptr%lquant ) found = .TRUE. IF ( nquant == mptr%nquant .and. lquant == mptr%lquant ) found = .true.
mptr =>mptr%p mptr =>mptr%p
END DO ENDDO
IF ( found ) THEN IF ( found ) THEN
DO i=1,mesh_ DO i=1,mesh_
READ(j,*) READ(j,*)
ENDDO ENDDO
CYCLE CYCLE
END IF ENDIF
END IF ENDIF
#ifdef __STD_F95 #ifdef __STD_F95
IF ( ASSOCIATED(mtail%wavefunc) ) THEN IF ( associated(mtail%wavefunc) ) THEN
#else #else
IF ( ALLOCATED(mtail%wavefunc) ) THEN IF ( allocated(mtail%wavefunc) ) THEN
#endif #endif
ALLOCATE(mtail%p) ALLOCATE(mtail%p)
mtail=>mtail%p mtail=>mtail%p
@ -310,7 +310,7 @@ SUBROUTINE read_casino(iunps,nofiles)
ALLOCATE( mtail%wavefunc(mesh_) ) ALLOCATE( mtail%wavefunc(mesh_) )
ELSE ELSE
ALLOCATE( mtail%wavefunc(mesh_) ) ALLOCATE( mtail%wavefunc(mesh_) )
END IF ENDIF
mtail%label = label mtail%label = label
mtail%nquant = nquant mtail%nquant = nquant
mtail%lquant = lquant mtail%lquant = lquant
@ -318,17 +318,17 @@ SUBROUTINE read_casino(iunps,nofiles)
READ(j, *, err=300) (mtail%wavefunc(ir),ir=1,mesh_) READ(j, *, err=300) (mtail%wavefunc(ir),ir=1,mesh_)
ENDDO ENDDO
groundstate = .FALSE. groundstate = .false.
ENDDO ENDDO
nchi =0 nchi =0
mptr => mhead mptr => mhead
DO DO
IF ( .NOT. ASSOCIATED(mptr) )EXIT IF ( .not. associated(mptr) )exit
nchi=nchi+1 nchi=nchi+1
mptr =>mptr%p mptr =>mptr%p
END DO ENDDO
ALLOCATE(lchi_(nchi), els(nchi), nns_(nchi)) ALLOCATE(lchi_(nchi), els(nchi), nns_(nchi))
ALLOCATE(oc_(nchi)) ALLOCATE(oc_(nchi))
@ -336,16 +336,16 @@ SUBROUTINE read_casino(iunps,nofiles)
oc_ = 0 oc_ = 0
!Sort out the occupation numbers !Sort out the occupation numbers
DO i=1,gsorbs DO i=1,gsorbs
oc_(i)=gs(i,3) oc_(i)=gs(i,3)
ENDDO ENDDO
deallocate( gs ) DEALLOCATE( gs )
i=1 i=1
mptr => mhead mptr => mhead
DO DO
IF ( .NOT. ASSOCIATED(mptr) )EXIT IF ( .not. associated(mptr) )exit
nns_(i) = mptr%nquant nns_(i) = mptr%nquant
lchi_(i) = mptr%lquant lchi_(i) = mptr%lquant
els(i) = mptr%label els(i) = mptr%label
@ -353,18 +353,18 @@ SUBROUTINE read_casino(iunps,nofiles)
chi_(ir:,i) = mptr%wavefunc(ir) chi_(ir:,i) = mptr%wavefunc(ir)
ENDDO ENDDO
deallocate( mptr%wavefunc ) DEALLOCATE( mptr%wavefunc )
mptr =>mptr%p mptr =>mptr%p
i=i+1 i=i+1
END DO ENDDO
!Clean up the linked list (deallocate it) !Clean up the linked list (deallocate it)
DO DO
IF ( .NOT. ASSOCIATED(mhead) )EXIT IF ( .not. associated(mhead) )exit
mptr => mhead mptr => mhead
mhead => mhead%p mhead => mhead%p
deallocate( mptr ) DEALLOCATE( mptr )
END DO ENDDO
! !
@ -373,9 +373,9 @@ SUBROUTINE read_casino(iunps,nofiles)
ALLOCATE(rho_at_(mesh_)) ALLOCATE(rho_at_(mesh_))
rho_at_(:)=0.d0 rho_at_(:)=0.d0
DO nb = 1, nchi DO nb = 1, nchi
IF( oc_(nb).NE.0.d0) & IF( oc_(nb)/=0.d0) &
& rho_at_(:) = rho_at_(:) + oc_(nb)*chi_(:,nb)**2 & rho_at_(:) = rho_at_(:) + oc_(nb)*chi_(:,nb)**2
END DO ENDDO
! ---------------------------------------------------------- ! ----------------------------------------------------------
WRITE (6,'(a)') 'Pseudopotential successfully read' WRITE (6,'(a)') 'Pseudopotential successfully read'
! ---------------------------------------------------------- ! ----------------------------------------------------------
@ -405,7 +405,7 @@ SUBROUTINE convert_casino
rcloc = 0.0d0 rcloc = 0.0d0
nwfs = nchi nwfs = nchi
ALLOCATE( oc(nwfs), epseu(nwfs)) ALLOCATE( oc(nwfs), epseu(nwfs))
ALLOCATE(lchi(nwfs), nns(nwfs) ) ALLOCATE(lchi(nwfs), nns(nwfs) )
ALLOCATE(rcut (nwfs), rcutus (nwfs)) ALLOCATE(rcut (nwfs), rcutus (nwfs))
@ -416,7 +416,7 @@ SUBROUTINE convert_casino
rcutus(i)= 0.0d0 rcutus(i)= 0.0d0
oc (i) = oc_(i) oc (i) = oc_(i)
epseu(i) = 0.0d0 epseu(i) = 0.0d0
END DO ENDDO
DEALLOCATE (lchi_, oc_, nns_) DEALLOCATE (lchi_, oc_, nns_)
psd = psd_ psd = psd_
@ -430,8 +430,8 @@ SUBROUTINE convert_casino
lmax = lmax_-1 lmax = lmax_-1
ELSE ELSE
lmax = lmax_ lmax = lmax_
END IF ENDIF
nbeta= lmax_ nbeta= lmax_
mesh = mesh_ mesh = mesh_
ntwfc= nchi ntwfc= nchi
ALLOCATE( elsw(ntwfc), ocw(ntwfc), lchiw(ntwfc) ) ALLOCATE( elsw(ntwfc), ocw(ntwfc), lchiw(ntwfc) )
@ -439,7 +439,7 @@ SUBROUTINE convert_casino
lchiw(i) = lchi(i) lchiw(i) = lchi(i)
ocw(i) = oc(i) ocw(i) = oc(i)
elsw(i) = els(i) elsw(i) = els(i)
END DO ENDDO
CALL set_dft_from_name(dft_) CALL set_dft_from_name(dft_)
iexch = get_iexch() iexch = get_iexch()
icorr = get_icorr() icorr = get_icorr()
@ -465,12 +465,12 @@ SUBROUTINE convert_casino
DO ir = 1,mesh DO ir = 1,mesh
IF ( r(ir) > rmax ) THEN IF ( r(ir) > rmax ) THEN
kkbeta=ir kkbeta=ir
EXIT exit
END IF ENDIF
END DO ENDDO
! make sure kkbeta is odd as required for simpson ! make sure kkbeta is odd as required for simpson
IF(MOD(kkbeta,2) == 0) kkbeta=kkbeta-1 IF(mod(kkbeta,2) == 0) kkbeta=kkbeta-1
ikk2(:) = kkbeta ikk2(:) = kkbeta
ALLOCATE(aux(kkbeta)) ALLOCATE(aux(kkbeta))
ALLOCATE(betar(mesh,nbeta)) ALLOCATE(betar(mesh,nbeta))
@ -483,18 +483,18 @@ SUBROUTINE convert_casino
iv=0 iv=0
DO i=1,nchi DO i=1,nchi
l=lchi(i) l=lchi(i)
IF (l.NE.lloc) THEN IF (l/=lloc) THEN
iv=iv+1 iv=iv+1
lll(iv)=l lll(iv)=l
DO ir=1,kkbeta DO ir=1,kkbeta
betar(ir,iv)=chi_(ir,i)*vnl(ir,l) betar(ir,iv)=chi_(ir,i)*vnl(ir,l)
aux(ir) = chi_(ir,i)**2*vnl(ir,l) aux(ir) = chi_(ir,i)**2*vnl(ir,l)
END DO ENDDO
CALL simpson(kkbeta,aux,rab,vll) CALL simpson(kkbeta,aux,rab,vll)
dion(iv,iv) = 1.0d0/vll dion(iv,iv) = 1.0d0/vll
END IF ENDIF
IF(iv >= nbeta) EXIT ! skip additional pseudo wfns IF(iv >= nbeta) exit ! skip additional pseudo wfns
ENDDO ENDDO
@ -506,13 +506,13 @@ SUBROUTINE convert_casino
DO iv=1,nbeta DO iv=1,nbeta
ikk2(iv)=kkbeta ikk2(iv)=kkbeta
DO ir = kkbeta,1,-1 DO ir = kkbeta,1,-1
IF ( ABS(betar(ir,iv)) > 1.d-12 ) THEN IF ( abs(betar(ir,iv)) > 1.d-12 ) THEN
ikk2(iv)=ir ikk2(iv)=ir
EXIT exit
END IF ENDIF
END DO ENDDO
END DO ENDDO
END IF ENDIF
ALLOCATE (rho_at(mesh)) ALLOCATE (rho_at(mesh))
rho_at = rho_at_ rho_at = rho_at_
DEALLOCATE (rho_at_) DEALLOCATE (rho_at_)

426
upftools/cpmd2upf.f90
View File

@ -7,236 +7,236 @@
! !
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
program cpmd2upf PROGRAM cpmd2upf
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
! Convert a pseudopotential written in the CPMD format ! Convert a pseudopotential written in the CPMD format
! (TYPE=NORMCONSERVING NUMERIC only, single radial grid) ! (TYPE=NORMCONSERVING NUMERIC only, single radial grid)
! to unified pseudopotential format ! to unified pseudopotential format
! !
implicit none IMPLICIT NONE
character(len=256) filein, fileout CHARACTER(len=256) filein, fileout
! !
! !
call get_file ( filein ) CALL get_file ( filein )
open (unit = 1, file = filein, status = 'old', form = 'formatted') OPEN (unit = 1, file = filein, status = 'old', form = 'formatted')
call read_cpmd(1) CALL read_cpmd(1)
close (1) CLOSE (1)
! convert variables read from CPMD format into those needed ! convert variables read from CPMD format into those needed
! by the upf format - add missing quantities ! by the upf format - add missing quantities
call convert_cpmd CALL convert_cpmd
fileout=trim(filein)//'.UPF' fileout=trim(filein)//'.UPF'
print '(''Output PP file in UPF format : '',a)', fileout PRINT '(''Output PP file in UPF format : '',a)', fileout
open(unit=2,file=fileout,status='unknown',form='formatted') OPEN(unit=2,file=fileout,status='unknown',form='formatted')
call write_upf(2) CALL write_upf(2)
close (unit=2) CLOSE (unit=2)
stop STOP
20 call errore ('cpmd2upf', 'Reading pseudo file name ', 1) 20 CALL errore ('cpmd2upf', 'Reading pseudo file name ', 1)
end program cpmd2upf END PROGRAM cpmd2upf
module cpmd MODULE cpmd
! !
! All variables read from CPMD file format ! All variables read from CPMD file format
! !
character (len=80) title CHARACTER (len=80) title
! !
integer :: ixc INTEGER :: ixc
real(8) :: alphaxc real(8) :: alphaxc
integer :: z, zv INTEGER :: z, zv
! !
integer :: mesh_ INTEGER :: mesh_
real(8) :: amesh, amesh_ real(8) :: amesh, amesh_
real(8), allocatable :: r_(:) real(8), ALLOCATABLE :: r_(:)
! !
integer ::lmax_ INTEGER ::lmax_
real(8), allocatable :: vnl(:,:) real(8), ALLOCATABLE :: vnl(:,:)
real(8), allocatable :: chi_(:,:) real(8), ALLOCATABLE :: chi_(:,:)
! !
logical :: nlcc_ LOGICAL :: nlcc_
real(8), allocatable :: rho_atc_(:) real(8), ALLOCATABLE :: rho_atc_(:)
! !
integer :: maxinfo_, info_lines_ INTEGER :: maxinfo_, info_lines_
parameter (maxinfo_ = 100) PARAMETER (maxinfo_ = 100)
character (len=80), allocatable :: info_sect_(:) CHARACTER (len=80), ALLOCATABLE :: info_sect_(:)
!------------------------------ !------------------------------
end module cpmd END MODULE cpmd
! !
! ---------------------------------------------------------- ! ----------------------------------------------------------
subroutine read_cpmd(iunps) SUBROUTINE read_cpmd(iunps)
! ---------------------------------------------------------- ! ----------------------------------------------------------
! !
use cpmd USE cpmd
implicit none IMPLICIT NONE
integer :: iunps INTEGER :: iunps
! !
integer :: found = 0, closed = 0, unknown = 0 INTEGER :: found = 0, closed = 0, unknown = 0
integer :: i, l, ios INTEGER :: i, l, ios
character (len=80) line CHARACTER (len=80) line
character (len=4) token CHARACTER (len=4) token
real (8) :: vnl0(0:3) real (8) :: vnl0(0:3)
logical, external :: matches LOGICAL, EXTERNAL :: matches
integer, external :: locate INTEGER, EXTERNAL :: locate
! !
nlcc_ = .false. nlcc_ = .false.
info_lines_ = 0 info_lines_ = 0
10 read (iunps,'(A)',end=20,err=20) line 10 READ (iunps,'(A)',end=20,err=20) line
if (matches ("&ATOM", trim(line)) ) then IF (matches ("&ATOM", trim(line)) ) THEN
found = found + 1 found = found + 1
! Z ! Z
read (iunps,'(a)',end=200,err=200) line READ (iunps,'(a)',end=200,err=200) line
l = len_trim(line) l = len_trim(line)
i = locate('=',line) i = locate('=',line)
read (line(i+1:l),*) z READ (line(i+1:l),*) z
! ZV ! ZV
read (iunps,'(a)',end=200,err=200) line READ (iunps,'(a)',end=200,err=200) line
l = len_trim(line) l = len_trim(line)
i = locate('=',line) i = locate('=',line)
read (line(i+1:l),*) zv READ (line(i+1:l),*) zv
! XC ! XC
read (iunps,'(a)',end=200,err=200) line READ (iunps,'(a)',end=200,err=200) line
l = len_trim(line) l = len_trim(line)
i = locate('=',line) i = locate('=',line)
read (line(i+1:l),*) ixc, alphaxc READ (line(i+1:l),*) ixc, alphaxc
! TYPE ! TYPE
read (iunps,'(a)',end=200,err=200) line READ (iunps,'(a)',end=200,err=200) line
if (.not. matches("NORMCONSERVING",line) .or. & IF (.not. matches("NORMCONSERVING",line) .or. &
.not. matches("NUMERIC",line) ) & .not. matches("NUMERIC",line) ) &
call errore('read_cpmd','unknown type: '//line,1) CALL errore('read_cpmd','unknown type: '//line,1)
else if (matches ("&INFO", trim(line)) ) then ELSEIF (matches ("&INFO", trim(line)) ) THEN
found = found + 1 found = found + 1
! read (iunps,'(a)') title ! read (iunps,'(a)') title
! store info section for later perusal (FIXME: not yet implemented. 2004/10/12, AK) ! store info section for later perusal (FIXME: not yet implemented. 2004/10/12, AK)
allocate (info_sect_(maxinfo_)) ALLOCATE (info_sect_(maxinfo_))
do i=1,maxinfo_ DO i=1,maxinfo_
read (iunps,'(a)',end=20,err=20) title READ (iunps,'(a)',end=20,err=20) title
if (matches ("&END", trim(title)) ) then IF (matches ("&END", trim(title)) ) THEN
closed = closed + 1 closed = closed + 1
goto 10 GOTO 10
else ELSE
info_sect_(i) = trim(title) info_sect_(i) = trim(title)
info_lines_ = i info_lines_ = i
end if ENDIF
enddo ENDDO
else if (matches ("&POTENTIAL", trim(line)) ) then ELSEIF (matches ("&POTENTIAL", trim(line)) ) THEN
found = found + 1 found = found + 1
read (iunps,'(a)') line READ (iunps,'(a)') line
read (line,*,iostat=ios) mesh_, amesh READ (line,*,iostat=ios) mesh_, amesh
if ( ios /= 0) then IF ( ios /= 0) THEN
read (line,*,iostat=ios) mesh_ READ (line,*,iostat=ios) mesh_
amesh = -1.0d0 amesh = -1.0d0
end if ENDIF
allocate (r_(mesh_)) ALLOCATE (r_(mesh_))
! !
! determine the number of angular momenta ! determine the number of angular momenta
! !
read (iunps, '(a)') line READ (iunps, '(a)') line
ios = 1 ios = 1
lmax_=4 lmax_=4
do while (ios /= 0) DO WHILE (ios /= 0)
lmax_ = lmax_ - 1 lmax_ = lmax_ - 1
read(line,*,iostat=ios) r_(1),(vnl0(l),l=0,lmax_) READ(line,*,iostat=ios) r_(1),(vnl0(l),l=0,lmax_)
end do ENDDO
allocate (vnl(mesh_,0:lmax_)) ALLOCATE (vnl(mesh_,0:lmax_))
vnl(1,0:lmax_) = vnl0(0:lmax_) vnl(1,0:lmax_) = vnl0(0:lmax_)
do i=2,mesh_ DO i=2,mesh_
read(iunps, *) r_(i),(vnl(i,l),l=0,lmax_) READ(iunps, *) r_(i),(vnl(i,l),l=0,lmax_)
end do ENDDO
! get amesh if not available directly, check its value otherwise ! get amesh if not available directly, check its value otherwise
print "('Radial grid r(i) has ',i4,' points')", mesh_ PRINT "('Radial grid r(i) has ',i4,' points')", mesh_
print "('Assuming log radial grid: r(i)=exp[(i-1)*amesh]*r(1), with:')" PRINT "('Assuming log radial grid: r(i)=exp[(i-1)*amesh]*r(1), with:')"
if (amesh < 0.0d0) then IF (amesh < 0.0d0) THEN
amesh = log (r_(mesh_)/r_(1))/(mesh_-1) amesh = log (r_(mesh_)/r_(1))/(mesh_-1)
print "('amesh = log (r(mesh)/r(1))/(mesh-1) = ',f10.6)",amesh PRINT "('amesh = log (r(mesh)/r(1))/(mesh-1) = ',f10.6)",amesh
else ELSE
! not clear whether the value of amesh read from file ! not clear whether the value of amesh read from file
! matches the above definition, or if it is exp(amesh) ... ! matches the above definition, or if it is exp(amesh) ...
amesh_ = log (r_(mesh_)/r_(1))/(mesh_-1) amesh_ = log (r_(mesh_)/r_(1))/(mesh_-1)
if ( abs ( amesh - amesh_ ) > 1.0d-5 ) then IF ( abs ( amesh - amesh_ ) > 1.0d-5 ) THEN
if ( abs ( amesh - exp(amesh_) ) < 1.0d-5 ) then IF ( abs ( amesh - exp(amesh_) ) < 1.0d-5 ) THEN
amesh = log(amesh) amesh = log(amesh)
print "('amesh = log (value read from file) = ',f10.6)",amesh PRINT "('amesh = log (value read from file) = ',f10.6)",amesh
else ELSE
call errore ('cpmd2upf', 'unknown real-space grid',2) CALL errore ('cpmd2upf', 'unknown real-space grid',2)
end if ENDIF
else ELSE
print "('amesh = value read from file = ',f10.6)",amesh PRINT "('amesh = value read from file = ',f10.6)",amesh
end if ENDIF
end if ENDIF
! check if the grid is what we expect ! check if the grid is what we expect
do i=2,mesh_ DO i=2,mesh_
if ( abs(r_(i) - exp((i-1)*amesh)*r_(1)) > 1.0d-5) then IF ( abs(r_(i) - exp((i-1)*amesh)*r_(1)) > 1.0d-5) THEN
print "('grid point ',i4,': found ',f10.6,', expected ',f10.6)",& PRINT "('grid point ',i4,': found ',f10.6,', expected ',f10.6)",&
i, r_(i), exp((i-1)*amesh)*r_(1) i, r_(i), exp((i-1)*amesh)*r_(1)
call errore ('cpmd2upf', 'unknown real-space grid',1) CALL errore ('cpmd2upf', 'unknown real-space grid',1)
end if ENDIF
end do ENDDO
else if (matches ("&WAVEFUNCTION", trim(line)) ) then ELSEIF (matches ("&WAVEFUNCTION", trim(line)) ) THEN
found = found + 1 found = found + 1
! read (iunps,*) mesh_, amesh ! read (iunps,*) mesh_, amesh
read (iunps,'(a)') line READ (iunps,'(a)') line
read (line,*,iostat=ios) mesh_ READ (line,*,iostat=ios) mesh_
allocate(chi_(mesh_,lmax_+1)) ALLOCATE(chi_(mesh_,lmax_+1))
do i=1,mesh_ DO i=1,mesh_
read(iunps, *) r_(i),(chi_(i,l+1),l=0,lmax_) READ(iunps, *) r_(i),(chi_(i,l+1),l=0,lmax_)
end do ENDDO
else if (matches ("&NLCC", trim(line)) ) then ELSEIF (matches ("&NLCC", trim(line)) ) THEN
found = found + 1 found = found + 1
nlcc_ = .true. nlcc_ = .true.
read (iunps, '(a)') line READ (iunps, '(a)') line
if (.not. matches ("NUMERIC", trim(line)) ) & IF (.not. matches ("NUMERIC", trim(line)) ) &
call errore('read_cpmd',' only NUMERIC core-correction supported',1) CALL errore('read_cpmd',' only NUMERIC core-correction supported',1)
read(iunps, *) mesh_ READ(iunps, *) mesh_
allocate (rho_atc_(mesh_)) ALLOCATE (rho_atc_(mesh_))
read(iunps, * ) (r_(i), rho_atc_(i), i=1,mesh_) READ(iunps, * ) (r_(i), rho_atc_(i), i=1,mesh_)
else if (matches ("&ATDENS", trim(line)) ) then ELSEIF (matches ("&ATDENS", trim(line)) ) THEN
! skip over &ATDENS section, add others here, if there are more. ! skip over &ATDENS section, add others here, if there are more.
do while(.not. matches("&END", trim(line))) DO WHILE(.not. matches("&END", trim(line)))
read (iunps,'(a)') line READ (iunps,'(a)') line
end do ENDDO
else if (matches ("&END", trim(line)) ) then ELSEIF (matches ("&END", trim(line)) ) THEN
closed = closed + 1 closed = closed + 1
else ELSE
print*, 'line ignored: ', line PRINT*, 'line ignored: ', line
unknown = unknown + 1 unknown = unknown + 1
end if ENDIF
go to 10 GOTO 10
20 continue 20 CONTINUE
if (nlcc_ .and. found /= 5 .or. .not.nlcc_ .and. found /= 4) & IF (nlcc_ .and. found /= 5 .or. .not.nlcc_ .and. found /= 4) &
call errore('read_cpmd','some &FIELD card missing',found) CALL errore('read_cpmd','some &FIELD card missing',found)
if (closed /= found) & IF (closed /= found) &
call errore('read_cpmd','some &END card missing',closed) CALL errore('read_cpmd','some &END card missing',closed)
if (unknown /= 0 ) print '("WARNING: ",i3," cards not read")', unknown IF (unknown /= 0 ) PRINT '("WARNING: ",i3," cards not read")', unknown
return RETURN
200 call errore('read_cpmd','error in reading file',1) 200 CALL errore('read_cpmd','error in reading file',1)
end subroutine read_cpmd END SUBROUTINE read_cpmd
! ---------------------------------------------------------- ! ----------------------------------------------------------
subroutine convert_cpmd SUBROUTINE convert_cpmd
! ---------------------------------------------------------- ! ----------------------------------------------------------
! !
use cpmd USE cpmd
use upf USE upf
implicit none IMPLICIT NONE
real(8), parameter :: rmax = 10.0d0 real(8), PARAMETER :: rmax = 10.0d0
real(8), allocatable :: aux(:) real(8), ALLOCATABLE :: aux(:)
real(8) :: vll real(8) :: vll
character (len=20):: dft CHARACTER (len=20):: dft
character (len=2), external :: atom_name CHARACTER (len=2), EXTERNAL :: atom_name
integer :: lloc, kkbeta, my_lmax INTEGER :: lloc, kkbeta, my_lmax
integer :: l, i, ir, iv INTEGER :: l, i, ir, iv
! !
write(generated, '("Generated using unknown code")') WRITE(generated, '("Generated using unknown code")')
write(date_author,'("Author: unknown Generation date: as well")') WRITE(date_author,'("Author: unknown Generation date: as well")')
comment = 'Info: automatically converted from CPMD format' comment = 'Info: automatically converted from CPMD format'
! NOTE: many CPMD pseudopotentials created with the 'Hamann' code ! NOTE: many CPMD pseudopotentials created with the 'Hamann' code
@ -246,34 +246,34 @@ subroutine convert_cpmd
! we need to be able to ignore that part or the resulting UPF file ! we need to be able to ignore that part or the resulting UPF file
! will be useless. so we first print the info section and ask ! will be useless. so we first print the info section and ask
! for the LMAX to really use. AK 2005/03/30. ! for the LMAX to really use. AK 2005/03/30.
do i=1,info_lines_ DO i=1,info_lines_
print '(A)', info_sect_(i) PRINT '(A)', info_sect_(i)
enddo ENDDO
print '("lmax to use. (max.",I2,") > ",$)', lmax_ PRINT '("lmax to use. (max.",I2,") > ",$)', lmax_
read (5,*) my_lmax READ (5,*) my_lmax
if ((my_lmax <= lmax_) .and. (my_lmax >= 0)) lmax_ = my_lmax IF ((my_lmax <= lmax_) .and. (my_lmax >= 0)) lmax_ = my_lmax
print '("l local (max.",I2,") > ",$)', lmax_ PRINT '("l local (max.",I2,") > ",$)', lmax_
read (5,*) lloc READ (5,*) lloc
! reasonable assumption ! reasonable assumption
if (z > 18) then IF (z > 18) THEN
rel = 1 rel = 1
else ELSE
rel = 0 rel = 0
end if ENDIF
rcloc = 0.0d0 rcloc = 0.0d0
nwfs = lmax_+1 nwfs = lmax_+1
allocate( els(nwfs), oc(nwfs), epseu(nwfs)) ALLOCATE( els(nwfs), oc(nwfs), epseu(nwfs))
allocate(lchi(nwfs), nns(nwfs) ) ALLOCATE(lchi(nwfs), nns(nwfs) )
allocate(rcut (nwfs), rcutus (nwfs)) ALLOCATE(rcut (nwfs), rcutus (nwfs))
do i=1, nwfs DO i=1, nwfs
print '("Wavefunction # ",i1,": label, occupancy > ",$)', i PRINT '("Wavefunction # ",i1,": label, occupancy > ",$)', i
read (5,*) els(i), oc(i) READ (5,*) els(i), oc(i)
nns (i) = 0 nns (i) = 0
lchi(i) = i-1 lchi(i) = i-1
rcut(i) = 0.0d0 rcut(i) = 0.0d0
rcutus(i)= 0.0d0 rcutus(i)= 0.0d0
epseu(i) = 0.0d0 epseu(i) = 0.0d0
end do ENDDO
psd = atom_name (z) psd = atom_name (z)
pseudotype = 'NC' pseudotype = 'NC'
nlcc = nlcc_ nlcc = nlcc_
@ -281,20 +281,20 @@ subroutine convert_cpmd
etotps =0.0d0 etotps =0.0d0
ecutrho=0.0d0 ecutrho=0.0d0
ecutwfc=0.0d0 ecutwfc=0.0d0
if ( lmax_ == lloc) then IF ( lmax_ == lloc) THEN
lmax = lmax_-1 lmax = lmax_-1
else ELSE
lmax = lmax_ lmax = lmax_
end if ENDIF
nbeta= lmax_ nbeta= lmax_
mesh = mesh_ mesh = mesh_
ntwfc= nwfs ntwfc= nwfs
allocate( elsw(ntwfc), ocw(ntwfc), lchiw(ntwfc) ) ALLOCATE( elsw(ntwfc), ocw(ntwfc), lchiw(ntwfc) )
do i=1, nwfs DO i=1, nwfs
lchiw(i) = lchi(i) lchiw(i) = lchi(i)
ocw(i) = oc(i) ocw(i) = oc(i)
elsw(i) = els(i) elsw(i) = els(i)
end do ENDDO
iexch = ixc/1000 iexch = ixc/1000
icorr = (ixc-1000*iexch)/100 icorr = (ixc-1000*iexch)/100
igcx = (ixc-1000*iexch-100*icorr)/10 igcx = (ixc-1000*iexch-100*icorr)/10
@ -302,91 +302,91 @@ subroutine convert_cpmd
! !
! We have igcc=2 (PW91) and 3 (LYP) exchanged wrt CPMD conventions ! We have igcc=2 (PW91) and 3 (LYP) exchanged wrt CPMD conventions
! !
if (igcc.eq.3) then IF (igcc==3) THEN
igcc=2 igcc=2
else if (igcc.eq.2) then ELSEIF (igcc==2) THEN
igcc=3 igcc=3
end if ENDIF
allocate(rab(mesh)) ALLOCATE(rab(mesh))
allocate( r(mesh)) ALLOCATE( r(mesh))
r = r_ r = r_
rab = r * amesh rab = r * amesh
allocate (rho_atc(mesh)) ALLOCATE (rho_atc(mesh))
if (nlcc) rho_atc = rho_atc_ IF (nlcc) rho_atc = rho_atc_
allocate (vloc0(mesh)) ALLOCATE (vloc0(mesh))
! the factor 2 converts from Hartree to Rydberg ! the factor 2 converts from Hartree to Rydberg
vloc0(:) = vnl(:,lloc)*2.d0 vloc0(:) = vnl(:,lloc)*2.d0
if (nbeta > 0) then IF (nbeta > 0) THEN
allocate(ikk2(nbeta), lll(nbeta)) ALLOCATE(ikk2(nbeta), lll(nbeta))
kkbeta=mesh kkbeta=mesh
do ir = 1,mesh DO ir = 1,mesh
if ( r(ir) > rmax ) then IF ( r(ir) > rmax ) THEN
kkbeta=ir kkbeta=ir
exit exit
end if ENDIF
end do ENDDO
ikk2(:) = kkbeta ikk2(:) = kkbeta
allocate(aux(kkbeta)) ALLOCATE(aux(kkbeta))
allocate(betar(mesh,nbeta)) ALLOCATE(betar(mesh,nbeta))
allocate(qfunc(mesh,nbeta,nbeta)) ALLOCATE(qfunc(mesh,nbeta,nbeta))
allocate(dion(nbeta,nbeta)) ALLOCATE(dion(nbeta,nbeta))
allocate(qqq (nbeta,nbeta)) ALLOCATE(qqq (nbeta,nbeta))
qfunc(:,:,:)=0.0d0 qfunc(:,:,:)=0.0d0
dion(:,:) =0.d0 dion(:,:) =0.d0
qqq(:,:) =0.d0 qqq(:,:) =0.d0
iv=0 iv=0
do i=1,nwfs DO i=1,nwfs
l=lchi(i) l=lchi(i)
if (l.ne.lloc) then IF (l/=lloc) THEN
iv=iv+1 iv=iv+1
lll(iv)=l lll(iv)=l
do ir=1,kkbeta DO ir=1,kkbeta
! the factor 2 converts from Hartree to Rydberg ! the factor 2 converts from Hartree to Rydberg
betar(ir,iv) = 2.d0 * chi_(ir,l+1) * & betar(ir,iv) = 2.d0 * chi_(ir,l+1) * &
( vnl(ir,l) - vnl(ir,lloc) ) ( vnl(ir,l) - vnl(ir,lloc) )
aux(ir) = chi_(ir,l+1) * betar(ir,iv) aux(ir) = chi_(ir,l+1) * betar(ir,iv)
end do ENDDO
call simpson(kkbeta,aux,rab,vll) CALL simpson(kkbeta,aux,rab,vll)
dion(iv,iv) = 1.0d0/vll dion(iv,iv) = 1.0d0/vll
end if ENDIF
enddo ENDDO
end if ENDIF
allocate (rho_at(mesh)) ALLOCATE (rho_at(mesh))
rho_at = 0.d0 rho_at = 0.d0
do i=1,nwfs DO i=1,nwfs
rho_at(:) = rho_at(:) + ocw(i) * chi_(:,i) ** 2 rho_at(:) = rho_at(:) + ocw(i) * chi_(:,i) ** 2
end do ENDDO
allocate (chi(mesh,ntwfc)) ALLOCATE (chi(mesh,ntwfc))
chi = chi_ chi = chi_
! ---------------------------------------------------------- ! ----------------------------------------------------------
write (6,'(a)') 'Pseudopotential successfully converted' WRITE (6,'(a)') 'Pseudopotential successfully converted'
! ---------------------------------------------------------- ! ----------------------------------------------------------
return RETURN
end subroutine convert_cpmd END SUBROUTINE convert_cpmd
! !
! ------------------------------------------------------------------ ! ------------------------------------------------------------------
integer function locate(onechar,string) INTEGER FUNCTION locate(onechar,string)
! ------------------------------------------------------------------ ! ------------------------------------------------------------------
! !
character(len=1) :: onechar CHARACTER(len=1) :: onechar
character(len=*) :: string CHARACTER(len=*) :: string
! !
integer:: i INTEGER:: i
! !
do i=1,len_trim(string) DO i=1,len_trim(string)
if (string(i:i) .eq. "=") then IF (string(i:i) == "=") THEN
locate = i locate = i
return RETURN
end if ENDIF
end do ENDDO
locate = 0 locate = 0
return RETURN
end function locate END FUNCTION locate

392
upftools/fhi2upf.f90
View File

@ -7,246 +7,246 @@
! !
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
program fhi2upf PROGRAM fhi2upf
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
! Convert a pseudopotential file in Fritz-Haber numerical format ! Convert a pseudopotential file in Fritz-Haber numerical format
! either ".cpi" (fhi88pp) or ".fhi" (abinit) ! either ".cpi" (fhi88pp) or ".fhi" (abinit)
! to unified pseudopotential format ! to unified pseudopotential format
! May or may not work: carefully check what you get ! May or may not work: carefully check what you get
! Adapted from the converter written by Andrea Ferretti ! Adapted from the converter written by Andrea Ferretti
! !
implicit none IMPLICIT NONE
character(len=256) filein, fileout CHARACTER(len=256) filein, fileout
! !
! !
call get_file ( filein ) CALL get_file ( filein )
open (unit = 1, file = filein, status = 'old', form = 'formatted') OPEN (unit = 1, file = filein, status = 'old', form = 'formatted')
call read_fhi(1) CALL read_fhi(1)
close (1) CLOSE (1)
! convert variables read from FHI format into those needed ! convert variables read from FHI format into those needed
! by the upf format - add missing quantities ! by the upf format - add missing quantities
call convert_fhi CALL convert_fhi
fileout=trim(filein)//'.UPF' fileout=trim(filein)//'.UPF'
print '(''Output PP file in UPF format : '',a)', fileout PRINT '(''Output PP file in UPF format : '',a)', fileout
open(unit=2,file=fileout,status='unknown',form='formatted') OPEN(unit=2,file=fileout,status='unknown',form='formatted')
call write_upf(2) CALL write_upf(2)
close (unit=2) CLOSE (unit=2)
stop STOP
20 write (6,'("fhi2upf: error reading pseudopotential file name")') 20 WRITE (6,'("fhi2upf: error reading pseudopotential file name")')
stop STOP
end program fhi2upf END PROGRAM fhi2upf
module fhi MODULE fhi
! !
! All variables read from FHI file format ! All variables read from FHI file format
! !
type angular_comp TYPE angular_comp
real(8), pointer :: pot(:) real(8), POINTER :: pot(:)
real(8), pointer :: wfc(:) real(8), POINTER :: wfc(:)
real(8), pointer :: grid(:) real(8), POINTER :: grid(:)
real(8) :: amesh real(8) :: amesh
integer :: nmesh INTEGER :: nmesh
integer :: lcomp INTEGER :: lcomp
end type angular_comp END TYPE angular_comp
!------------------------------ !------------------------------
real(8) :: Zval ! valence charge real(8) :: Zval ! valence charge
integer :: lmax_ ! max l-component used INTEGER :: lmax_ ! max l-component used
logical :: nlcc_ LOGICAL :: nlcc_
real(8), allocatable :: rho_atc_(:) ! core charge real(8), ALLOCATABLE :: rho_atc_(:) ! core charge
type (angular_comp), pointer :: comp(:) ! PP numerical info TYPE (angular_comp), POINTER :: comp(:) ! PP numerical info
! (wfc, grid, potentials...) ! (wfc, grid, potentials...)
!------------------------------ !------------------------------
! variables for the abinit header ! variables for the abinit header
real(8) :: Zatom, Zion, r2well, rchrg, fchrg, qchrg real(8) :: Zatom, Zion, r2well, rchrg, fchrg, qchrg
integer :: pspdat = 0, pspcod = 0 , pspxc = 0, lloc_ = -1, mmax = 0 INTEGER :: pspdat = 0, pspcod = 0 , pspxc = 0, lloc_ = -1, mmax = 0
character(len=256) :: info CHARACTER(len=256) :: info
end module fhi END MODULE fhi
! !
! ---------------------------------------------------------- ! ----------------------------------------------------------
subroutine read_fhi(iunps) SUBROUTINE read_fhi(iunps)
! ---------------------------------------------------------- ! ----------------------------------------------------------
! !
use fhi USE fhi
implicit none IMPLICIT NONE
integer, parameter :: Nl=7 ! max number of l-components INTEGER, PARAMETER :: Nl=7 ! max number of l-components
integer :: iunps INTEGER :: iunps
real(8) :: r, rhoc, drhoc, d2rhoc real(8) :: r, rhoc, drhoc, d2rhoc
! !
integer :: l, i, idum, mesh INTEGER :: l, i, idum, mesh
! Start reading file ! Start reading file
read(iunps,'(a)') info READ(iunps,'(a)') info
read(info,*,iostat=i) Zval, l READ(info,*,iostat=i) Zval, l
if ( i /= 0 .or. zval <= 0.0 .or. zval > 100.0 ) then IF ( i /= 0 .or. zval <= 0.0 .or. zval > 100.0 ) THEN
write (6,'("read_fhi: assuming abinit format")') WRITE (6,'("read_fhi: assuming abinit format")')
read(iunps,*) Zatom, Zion, pspdat READ(iunps,*) Zatom, Zion, pspdat
read(iunps,*) pspcod, pspxc, lmax_,lloc_, mmax, r2well READ(iunps,*) pspcod, pspxc, lmax_,lloc_, mmax, r2well
if (pspcod /= 6) then IF (pspcod /= 6) THEN
write (6,'("read_fhi: unknown PP type ",i1,"...stopping")') pspcod WRITE (6,'("read_fhi: unknown PP type ",i1,"...stopping")') pspcod
stop STOP
end if ENDIF
read(iunps,*) rchrg, fchrg, qchrg READ(iunps,*) rchrg, fchrg, qchrg
! !
read(iunps,*) READ(iunps,*)
read(iunps,*) READ(iunps,*)
read(iunps,*) READ(iunps,*)
! !
read(iunps,*) Zval, l READ(iunps,*) Zval, l
if (abs(Zion-Zval) > 1.0d-8) then IF (abs(Zion-Zval) > 1.0d-8) THEN
write (6,'("read_fhi: Zval/Zion mismatch...stopping")') WRITE (6,'("read_fhi: Zval/Zion mismatch...stopping")')
stop STOP
end if ENDIF
if (l-1 /= lmax_) then IF (l-1 /= lmax_) THEN
write (6,'("read_fhi: lmax mismatch...stopping")') WRITE (6,'("read_fhi: lmax mismatch...stopping")')
stop STOP
end if ENDIF
else ELSE
info = ' ' info = ' '
end if ENDIF
lmax_ = l - 1 lmax_ = l - 1
if (lmax_+1 > Nl) then IF (lmax_+1 > Nl) THEN
write (6,'("read_fhi: too many l-components...stopping")') WRITE (6,'("read_fhi: too many l-components...stopping")')
stop STOP
end if ENDIF
do i=1,10 DO i=1,10
read(iunps,*) ! skipping 11 lines READ(iunps,*) ! skipping 11 lines
end do ENDDO
allocate( comp(0:lmax_) ) ALLOCATE( comp(0:lmax_) )
do l=0,lmax_ DO l=0,lmax_
comp(l)%lcomp = l comp(l)%lcomp = l
read(iunps,*) comp(l)%nmesh, comp(l)%amesh READ(iunps,*) comp(l)%nmesh, comp(l)%amesh
if (mmax > 0 .and. mmax /= comp(l)%nmesh) then IF (mmax > 0 .and. mmax /= comp(l)%nmesh) THEN
write (6,'("read_fhi: mismatched number of grid points...stopping")') WRITE (6,'("read_fhi: mismatched number of grid points...stopping")')
stop STOP
end if ENDIF
if ( l > 0) then IF ( l > 0) THEN
if (comp(l)%nmesh /= comp(0)%nmesh .or. & IF (comp(l)%nmesh /= comp(0)%nmesh .or. &
comp(l)%amesh /= comp(0)%amesh ) then comp(l)%amesh /= comp(0)%amesh ) THEN
write(6,'("read_fhi: different radial grids not allowed...stopping")') WRITE(6,'("read_fhi: different radial grids not allowed...stopping")')
stop STOP
end if ENDIF
end if ENDIF
mesh = comp(l)%nmesh mesh = comp(l)%nmesh
allocate( comp(l)%wfc(mesh), & ! wave-functions ALLOCATE( comp(l)%wfc(mesh), & ! wave-functions
comp(l)%pot(mesh), & ! potentials comp(l)%pot(mesh), & ! potentials
comp(l)%grid(mesh) ) ! real space radial grid comp(l)%grid(mesh) ) ! real space radial grid
! read the above quantities ! read the above quantities
do i=1,mesh DO i=1,mesh
read(iunps,*) idum, comp(l)%grid(i), & READ(iunps,*) idum, comp(l)%grid(i), &
comp(l)%wfc(i), & comp(l)%wfc(i), &
comp(l)%pot(i) comp(l)%pot(i)
end do ENDDO
end do ENDDO
nlcc_ =.false. nlcc_ =.false.
allocate(rho_atc_(comp(0)%nmesh)) ALLOCATE(rho_atc_(comp(0)%nmesh))
mesh = comp(0)%nmesh mesh = comp(0)%nmesh
do i=1,mesh DO i=1,mesh
read(iunps,*,end=10, err=20) r, rho_atc_(i), drhoc, d2rhoc READ(iunps,*,end=10, err=20) r, rho_atc_(i), drhoc, d2rhoc
if ( abs( r - comp(0)%grid(i) ) > 1.d-6 ) then IF ( abs( r - comp(0)%grid(i) ) > 1.d-6 ) THEN
write(6,'("read_fhi: radial grid for core charge? stopping")') WRITE(6,'("read_fhi: radial grid for core charge? stopping")')
stop STOP
end if ENDIF
end do ENDDO
nlcc_ = .true. nlcc_ = .true.
! ---------------------------------------------------------- ! ----------------------------------------------------------
write (6,'(a)') 'Pseudopotential with NLCC successfully read' WRITE (6,'(a)') 'Pseudopotential with NLCC successfully read'
! ---------------------------------------------------------- ! ----------------------------------------------------------
return RETURN
10 continue 10 CONTINUE
! ---------------------------------------------------------- ! ----------------------------------------------------------
write (6,'(a)') 'Pseudopotential without NLCC successfully read' WRITE (6,'(a)') 'Pseudopotential without NLCC successfully read'
! ---------------------------------------------------------- ! ----------------------------------------------------------
return RETURN
! !
20 write(6,'("read_fhi: error reading core charge")') 20 WRITE(6,'("read_fhi: error reading core charge")')
stop STOP
! !
100 write(6,'("read_fhi: error reading pseudopotential file")') 100 WRITE(6,'("read_fhi: error reading pseudopotential file")')
stop STOP
end subroutine read_fhi END SUBROUTINE read_fhi
! ---------------------------------------------------------- ! ----------------------------------------------------------
subroutine convert_fhi SUBROUTINE convert_fhi
! ---------------------------------------------------------- ! ----------------------------------------------------------
! !
use fhi USE fhi
use upf USE upf
use funct, ONLY : set_dft_from_name, get_iexch, get_icorr, get_igcx, get_igcc USE funct, ONLY : set_dft_from_name, get_iexch, get_icorr, get_igcx, get_igcc
use constants, ONLY : fpi USE constants, ONLY : fpi
implicit none IMPLICIT NONE
real(8), parameter :: rmax = 10.0d0 real(8), PARAMETER :: rmax = 10.0d0
real(8), allocatable :: aux(:) real(8), ALLOCATABLE :: aux(:)
real(8) :: vll real(8) :: vll
character (len=20):: dft CHARACTER (len=20):: dft
character (len=2), external:: atom_name CHARACTER (len=2), EXTERNAL:: atom_name
integer :: lloc, kkbeta INTEGER :: lloc, kkbeta
integer :: l, i, ir, iv INTEGER :: l, i, ir, iv
! !
if (nint(Zatom) > 0) then IF (nint(Zatom) > 0) THEN
psd = atom_name(nint(Zatom)) psd = atom_name(nint(Zatom))
else ELSE
print '("Atom name > ",$)' PRINT '("Atom name > ",$)'
read (5,'(a)') psd READ (5,'(a)') psd
end if ENDIF
if ( lloc_ < 0 ) then IF ( lloc_ < 0 ) THEN
print '("l local (max: ",i1,") > ",$)', lmax_ PRINT '("l local (max: ",i1,") > ",$)', lmax_
read (5,*) lloc READ (5,*) lloc
else ELSE
lloc = lloc_ lloc = lloc_
end if ENDIF
if (pspxc == 7) then IF (pspxc == 7) THEN
dft = 'PW' dft = 'PW'
else ELSE
if (pspxc > 0) then IF (pspxc > 0) THEN
print '("DFT read from abinit file: ",i1)', pspxc PRINT '("DFT read from abinit file: ",i1)', pspxc
end if ENDIF
print '("DFT > ",$)' PRINT '("DFT > ",$)'
read (5,'(a)') dft READ (5,'(a)') dft
end if ENDIF
write(generated, '("Generated using Fritz-Haber code")') WRITE(generated, '("Generated using Fritz-Haber code")')
write(date_author,'("Author: unknown Generation date: as well")') WRITE(date_author,'("Author: unknown Generation date: as well")')
if (trim(info) /= ' ') then IF (trim(info) /= ' ') THEN
comment = trim(info) comment = trim(info)
else ELSE
comment = 'Info: automatically converted from FHI format' comment = 'Info: automatically converted from FHI format'
end if ENDIF
! reasonable assumption ! reasonable assumption
rel = 1 rel = 1
rcloc = 0.0d0 rcloc = 0.0d0
nwfs = lmax_+1 nwfs = lmax_+1
allocate( els(nwfs), oc(nwfs), epseu(nwfs)) ALLOCATE( els(nwfs), oc(nwfs), epseu(nwfs))
allocate(lchi(nwfs), nns(nwfs) ) ALLOCATE(lchi(nwfs), nns(nwfs) )
allocate(rcut (nwfs), rcutus (nwfs)) ALLOCATE(rcut (nwfs), rcutus (nwfs))
do i=1, nwfs DO i=1, nwfs
print '("Wavefunction # ",i1,": label, occupancy > ",$)', i PRINT '("Wavefunction # ",i1,": label, occupancy > ",$)', i
read (5,*) els(i), oc(i) READ (5,*) els(i), oc(i)
nns (i) = 0 nns (i) = 0
lchi(i) = i-1 lchi(i) = i-1
rcut(i) = 0.0d0 rcut(i) = 0.0d0
rcutus(i)= 0.0d0 rcutus(i)= 0.0d0
epseu(i) = 0.0d0 epseu(i) = 0.0d0
end do ENDDO
pseudotype = 'NC' pseudotype = 'NC'
nlcc = nlcc_ nlcc = nlcc_
@ -254,91 +254,91 @@ subroutine convert_fhi
etotps = 0.0d0 etotps = 0.0d0
ecutrho=0.0d0 ecutrho=0.0d0
ecutwfc=0.0d0 ecutwfc=0.0d0
if ( lmax_ == lloc) then IF ( lmax_ == lloc) THEN
lmax = lmax_-1 lmax = lmax_-1
else ELSE
lmax = lmax_ lmax = lmax_
end if ENDIF
nbeta= lmax_ nbeta= lmax_
mesh = comp(0)%nmesh mesh = comp(0)%nmesh
ntwfc= nwfs ntwfc= nwfs
allocate( elsw(ntwfc), ocw(ntwfc), lchiw(ntwfc) ) ALLOCATE( elsw(ntwfc), ocw(ntwfc), lchiw(ntwfc) )
do i=1, nwfs DO i=1, nwfs
lchiw(i) = lchi(i) lchiw(i) = lchi(i)
ocw(i) = oc(i) ocw(i) = oc(i)
elsw(i) = els(i) elsw(i) = els(i)
end do ENDDO
call set_dft_from_name(dft) CALL set_dft_from_name(dft)
iexch = get_iexch() iexch = get_iexch()
icorr = get_icorr() icorr = get_icorr()
igcx = get_igcx() igcx = get_igcx()
igcc = get_igcc() igcc = get_igcc()
allocate(rab(mesh)) ALLOCATE(rab(mesh))
allocate( r(mesh)) ALLOCATE( r(mesh))
r = comp(0)%grid r = comp(0)%grid
rab = r * log( comp(0)%amesh ) rab = r * log( comp(0)%amesh )
if (nlcc) then IF (nlcc) THEN
allocate (rho_atc(mesh)) ALLOCATE (rho_atc(mesh))
rho_atc(:) = rho_atc_(:) / fpi rho_atc(:) = rho_atc_(:) / fpi
end if ENDIF
allocate (vloc0(mesh)) ALLOCATE (vloc0(mesh))
! the factor 2 converts from Hartree to Rydberg ! the factor 2 converts from Hartree to Rydberg
vloc0 = 2.d0*comp(lloc)%pot vloc0 = 2.d0*comp(lloc)%pot
if (nbeta > 0) then IF (nbeta > 0) THEN
allocate(ikk2(nbeta), lll(nbeta)) ALLOCATE(ikk2(nbeta), lll(nbeta))
kkbeta=mesh kkbeta=mesh
do ir = 1,mesh DO ir = 1,mesh
if ( r(ir) > rmax ) then IF ( r(ir) > rmax ) THEN
kkbeta=ir kkbeta=ir
exit exit
end if ENDIF
end do ENDDO
ikk2(:) = kkbeta ikk2(:) = kkbeta
allocate(aux(kkbeta)) ALLOCATE(aux(kkbeta))
allocate(betar(mesh,nbeta)) ALLOCATE(betar(mesh,nbeta))
allocate(qfunc(mesh,nbeta,nbeta)) ALLOCATE(qfunc(mesh,nbeta,nbeta))
allocate(dion(nbeta,nbeta)) ALLOCATE(dion(nbeta,nbeta))
allocate(qqq (nbeta,nbeta)) ALLOCATE(qqq (nbeta,nbeta))
qfunc(:,:,:)=0.0d0 qfunc(:,:,:)=0.0d0
dion(:,:) =0.d0 dion(:,:) =0.d0
qqq(:,:) =0.d0 qqq(:,:) =0.d0
iv=0 iv=0
do i=1,nwfs DO i=1,nwfs
l=lchi(i) l=lchi(i)
if (l.ne.lloc) then IF (l/=lloc) THEN
iv=iv+1 iv=iv+1
lll(iv)=l lll(iv)=l
do ir=1,kkbeta DO ir=1,kkbeta
! FHI potentials are in Hartree ! FHI potentials are in Hartree
betar(ir,iv) = 2.d0 * comp(l)%wfc(ir) * & betar(ir,iv) = 2.d0 * comp(l)%wfc(ir) * &
( comp(l)%pot(ir) - comp(lloc)%pot(ir) ) ( comp(l)%pot(ir) - comp(lloc)%pot(ir) )
aux(ir) = comp(l)%wfc(ir) * betar(ir,iv) aux(ir) = comp(l)%wfc(ir) * betar(ir,iv)
end do ENDDO
call simpson(kkbeta,aux,rab,vll) CALL simpson(kkbeta,aux,rab,vll)
dion(iv,iv) = 1.0d0/vll dion(iv,iv) = 1.0d0/vll
end if ENDIF
enddo ENDDO
end if ENDIF
allocate (rho_at(mesh)) ALLOCATE (rho_at(mesh))
rho_at = 0.d0 rho_at = 0.d0
do i=1,nwfs DO i=1,nwfs
l=lchi(i) l=lchi(i)
rho_at = rho_at + ocw(i) * comp(l)%wfc ** 2 rho_at = rho_at + ocw(i) * comp(l)%wfc ** 2
end do ENDDO
allocate (chi(mesh,ntwfc)) ALLOCATE (chi(mesh,ntwfc))
do i=1,ntwfc DO i=1,ntwfc
chi(:,i) = comp(i-1)%wfc(:) chi(:,i) = comp(i-1)%wfc(:)
end do ENDDO
! ---------------------------------------------------------- ! ----------------------------------------------------------
write (6,'(a)') 'Pseudopotential successfully converted' WRITE (6,'(a)') 'Pseudopotential successfully converted'
! ---------------------------------------------------------- ! ----------------------------------------------------------
return RETURN
end subroutine convert_fhi END SUBROUTINE convert_fhi

526
upftools/fpmd2upf.f90
View File

File diff suppressed because it is too large Load Diff

406
upftools/ncpp2upf.f90
View File

@ -7,281 +7,281 @@
! !
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
program ncpp2upf PROGRAM ncpp2upf
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
! Convert a pseudopotential written in PWSCF format ! Convert a pseudopotential written in PWSCF format
! (norm-conserving) to unified pseudopotential format ! (norm-conserving) to unified pseudopotential format
implicit none IMPLICIT NONE
character(len=256) filein, fileout CHARACTER(len=256) filein, fileout
! !
! !
call get_file ( filein ) CALL get_file ( filein )
open(unit=1,file=filein,status='old',form='formatted') OPEN(unit=1,file=filein,status='old',form='formatted')
call read_ncpp(1) CALL read_ncpp(1)
close (unit=1) CLOSE (unit=1)
! convert variables read from NCPP format into those needed ! convert variables read from NCPP format into those needed
! by the upf format - add missing quantities ! by the upf format - add missing quantities
call convert_ncpp CALL convert_ncpp
fileout=trim(filein)//'.UPF' fileout=trim(filein)//'.UPF'
print '(''Output PP file in US format : '',a)', fileout PRINT '(''Output PP file in US format : '',a)', fileout
open(unit=2,file=fileout,status='unknown',form='formatted') OPEN(unit=2,file=fileout,status='unknown',form='formatted')
call write_upf(2) CALL write_upf(2)
close (unit=2) CLOSE (unit=2)
stop STOP
20 call errore ('ncpp2upf', 'Reading pseudo file name ', 1) 20 CALL errore ('ncpp2upf', 'Reading pseudo file name ', 1)
end program ncpp2upf END PROGRAM ncpp2upf
module ncpp MODULE ncpp
! !
! All variables read from NCPP file format ! All variables read from NCPP file format
! !
! trailing underscore means that a variable with the same name ! trailing underscore means that a variable with the same name
! is used in module 'upf' containing variables to be written ! is used in module 'upf' containing variables to be written
! !
character(len=20) :: dft_ CHARACTER(len=20) :: dft_
character(len=2) :: psd_ CHARACTER(len=2) :: psd_
real(8) :: zp_ real(8) :: zp_
integer nlc, nnl, lmax_, lloc, nchi INTEGER nlc, nnl, lmax_, lloc, nchi
logical :: numeric, bhstype, nlcc_ LOGICAL :: numeric, bhstype, nlcc_
real(8) :: alpc(2), cc(2), alps(3,0:3), aps(6,0:3) real(8) :: alpc(2), cc(2), alps(3,0:3), aps(6,0:3)
real(8) :: a_nlcc, b_nlcc, alpha_nlcc real(8) :: a_nlcc, b_nlcc, alpha_nlcc
real(8) :: zmesh, xmin, dx real(8) :: zmesh, xmin, dx
real(8), allocatable:: r_(:), rab_(:) real(8), ALLOCATABLE:: r_(:), rab_(:)
integer :: mesh_ INTEGER :: mesh_
real(8), allocatable:: vnl(:,:), rho_atc_(:), rho_at_(:) real(8), ALLOCATABLE:: vnl(:,:), rho_atc_(:), rho_at_(:)
integer, allocatable:: lchi_(:) INTEGER, ALLOCATABLE:: lchi_(:)
real(8), allocatable:: chi_(:,:), oc_(:) real(8), ALLOCATABLE:: chi_(:,:), oc_(:)
end module ncpp END MODULE ncpp
! !
! ---------------------------------------------------------- ! ----------------------------------------------------------
subroutine read_ncpp(iunps) SUBROUTINE read_ncpp(iunps)
! ---------------------------------------------------------- ! ----------------------------------------------------------
!
use ncpp
use upf , only : els
implicit none
integer :: iunps
! !
character(len=1), dimension(0:3) :: convel=(/'S','P','D','F'/) USE ncpp
character(len=2) :: label USE upf , ONLY : els
IMPLICIT NONE
INTEGER :: iunps
!
CHARACTER(len=1), DIMENSION(0:3) :: convel=(/'S','P','D','F'/)
CHARACTER(len=2) :: label
real (8) :: x, qe_erf real (8) :: x, qe_erf
integer :: l, i, ir, nb, n INTEGER :: l, i, ir, nb, n
character (len=255) line CHARACTER (len=255) line
external qe_erf EXTERNAL qe_erf
read(iunps, '(a)', end=300, err=300 ) dft_ READ(iunps, '(a)', end=300, err=300 ) dft_
if (dft_(1:2).eq.'**') dft_ = 'PZ' IF (dft_(1:2)=='**') dft_ = 'PZ'
read (iunps, *, err=300) psd_, zp_, lmax_, nlc, nnl, nlcc_, & READ (iunps, *, err=300) psd_, zp_, lmax_, nlc, nnl, nlcc_, &
lloc, bhstype lloc, bhstype
if ( nlc.gt.2 .or. nnl.gt.3) & IF ( nlc>2 .or. nnl>3) &
call errore( 'read_ncpp','Wrong nlc or nnl',1 ) CALL errore( 'read_ncpp','Wrong nlc or nnl',1 )
if ( nlc* nnl .lt. 0 ) & IF ( nlc* nnl < 0 ) &
call errore( 'read_ncpp','nlc*nnl < 0 ? ',1 ) CALL errore( 'read_ncpp','nlc*nnl < 0 ? ',1 )
if ( zp_.le.0d0 ) & IF ( zp_<=0d0 ) &
call errore( 'read_ncpp','Wrong zp ',1 ) CALL errore( 'read_ncpp','Wrong zp ',1 )
if ( lmax_.gt.3.or.lmax_.lt.0 ) & IF ( lmax_>3.or.lmax_<0 ) &
call errore( 'read_ncpp','Wrong lmax ',1 ) CALL errore( 'read_ncpp','Wrong lmax ',1 )
if (lloc.eq.-1000) lloc=lmax_ IF (lloc==-1000) lloc=lmax_
! !
! In numeric pseudopotentials both nlc and nnl are zero. ! In numeric pseudopotentials both nlc and nnl are zero.
! !
numeric = nlc.le.0 .and. nnl.le.0 numeric = nlc<=0 .and. nnl<=0
if (.not.numeric) then IF (.not.numeric) THEN
! !
! read pseudopotentials in analytic form ! read pseudopotentials in analytic form
! !
read(iunps, *, err=300) & READ(iunps, *, err=300) &
( alpc(i), i=1, 2 ), ( cc(i), i=1,2 ) ( alpc(i), i=1, 2 ), ( cc(i), i=1,2 )
if ( abs(cc(1)+cc(2)-1.d0).gt.1.0d-6) & IF ( abs(cc(1)+cc(2)-1.d0)>1.0d-6) &
call errore ('read_ncpp','wrong pseudopotential coefficients',1) CALL errore ('read_ncpp','wrong pseudopotential coefficients',1)
do l = 0, lmax_ DO l = 0, lmax_
read (iunps, *, err=300) & READ (iunps, *, err=300) &
( alps(i,l),i=1,3 ), (aps(i,l),i=1,6) ( alps(i,l),i=1,3 ), (aps(i,l),i=1,6)
enddo ENDDO
if (nlcc_) then IF (nlcc_) THEN
read(iunps, *, err=300) & READ(iunps, *, err=300) &
a_nlcc, b_nlcc, alpha_nlcc a_nlcc, b_nlcc, alpha_nlcc
if (alpha_nlcc.le.0.d0) & IF (alpha_nlcc<=0.d0) &
call errore('read_ncpp','nlcc but alpha=0',1) CALL errore('read_ncpp','nlcc but alpha=0',1)
end if ENDIF
if (bhstype) call bachel(alps,aps,1,lmax_) IF (bhstype) CALL bachel(alps,aps,1,lmax_)
end if ENDIF
read(iunps, *, err=300) zmesh, xmin, dx, mesh_, nchi READ(iunps, *, err=300) zmesh, xmin, dx, mesh_, nchi
if ( mesh_.le.0) call errore( 'read_ncpp', 'mesh too small', 1) IF ( mesh_<=0) CALL errore( 'read_ncpp', 'mesh too small', 1)
if ( (nchi.lt.lmax_ .and. lloc.eq.lmax_).or. & IF ( (nchi<lmax_ .and. lloc==lmax_).or. &
(nchi.lt.lmax_+1 .and. lloc.ne.lmax_) ) & (nchi<lmax_+1 .and. lloc/=lmax_) ) &
call errore( 'read_ncpp', 'wrong no. of wfcts', 1 ) CALL errore( 'read_ncpp', 'wrong no. of wfcts', 1 )
! !
! compute the radial mesh ! compute the radial mesh
! !
allocate( r_(mesh_)) ALLOCATE( r_(mesh_))
allocate(rab_(mesh_)) ALLOCATE(rab_(mesh_))
do ir = 1, mesh_ DO ir = 1, mesh_
x = xmin + DBLE(ir-1) * dx x = xmin + dble(ir-1) * dx
r_ (ir) = exp(x) / zmesh r_ (ir) = exp(x) / zmesh
rab_(ir) = dx * r_(ir) rab_(ir) = dx * r_(ir)
end do ENDDO
allocate(vnl(mesh_,0:lmax_)) ALLOCATE(vnl(mesh_,0:lmax_))
if (numeric) then IF (numeric) THEN
! !
! read pseudopotentials in numeric form ! read pseudopotentials in numeric form
! !
do l = 0, lmax_ DO l = 0, lmax_
read(iunps, '(a)', err=300) READ(iunps, '(a)', err=300)
read(iunps, *, err=300) (vnl(ir,l),ir=1,mesh_) READ(iunps, *, err=300) (vnl(ir,l),ir=1,mesh_)
enddo ENDDO
allocate(rho_atc_(mesh_)) ALLOCATE(rho_atc_(mesh_))
if(nlcc_) then IF(nlcc_) THEN
read(iunps, *, err=300) ( rho_atc_(ir), ir=1,mesh_ ) READ(iunps, *, err=300) ( rho_atc_(ir), ir=1,mesh_ )
endif ENDIF
else ELSE
! !
! convert analytic to numeric form ! convert analytic to numeric form
! !
do l=0,lmax_ DO l=0,lmax_
! !
! DO NOT USE f90 ARRAY SYNTAX: qe_erf IS NOT AN INTRINSIC FUNCTION!!! ! DO NOT USE f90 ARRAY SYNTAX: qe_erf IS NOT AN INTRINSIC FUNCTION!!!
! !
do ir=1,mesh_ DO ir=1,mesh_
vnl(ir,l)= - ( cc(1)*qe_erf(sqrt(alpc(1))*r_(ir)) + & vnl(ir,l)= - ( cc(1)*qe_erf(sqrt(alpc(1))*r_(ir)) + &
cc(2)*qe_erf(sqrt(alpc(2))*r_(ir)) ) * zp_/r_(ir) cc(2)*qe_erf(sqrt(alpc(2))*r_(ir)) ) * zp_/r_(ir)
end do ENDDO
do n=1,nnl DO n=1,nnl
vnl(:,l)= vnl(:,l)+ (aps(n,l)+ aps(n+3,l)*r_(:)**2 )* & vnl(:,l)= vnl(:,l)+ (aps(n,l)+ aps(n+3,l)*r_(:)**2 )* &
exp(-alps(n,l)*r_(:)**2) exp(-alps(n,l)*r_(:)**2)
end do ENDDO
! !
! convert to Rydberg ! convert to Rydberg
! !
vnl(:,l) = vnl(:,l)*2.0d0 vnl(:,l) = vnl(:,l)*2.0d0
end do ENDDO
allocate(rho_atc_(mesh_)) ALLOCATE(rho_atc_(mesh_))
if (nlcc_) then IF (nlcc_) THEN
rho_atc_(:) =(a_nlcc+b_nlcc*(r_(:)**2))*exp(-alpha_nlcc*r_(:)**2) rho_atc_(:) =(a_nlcc+b_nlcc*(r_(:)**2))*exp(-alpha_nlcc*r_(:)**2)
where(abs(rho_atc_) < 1.0d-15) WHERE(abs(rho_atc_) < 1.0d-15)
rho_atc_ = 0 rho_atc_ = 0
end where END WHERE
end if ENDIF
endif ENDIF
! !
! subtract the local part ! subtract the local part
! !
do l = 0, lmax_ DO l = 0, lmax_
if ( l.ne.lloc ) vnl(:,l) = vnl(:,l) - vnl(:,lloc) IF ( l/=lloc ) vnl(:,l) = vnl(:,l) - vnl(:,lloc)
enddo ENDDO
! !
! read pseudowavefunctions ! read pseudowavefunctions
! !
allocate(lchi_(nchi), els(nchi)) ALLOCATE(lchi_(nchi), els(nchi))
allocate(oc_(nchi)) ALLOCATE(oc_(nchi))
allocate(chi_(mesh_,nchi)) ALLOCATE(chi_(mesh_,nchi))
do nb = 1, nchi DO nb = 1, nchi
! read wavefunction label and store for later ! read wavefunction label and store for later
read(iunps, '(a)', err=300) line READ(iunps, '(a)', err=300) line
read(iunps, *, err=300) lchi_( nb), oc_( nb ) READ(iunps, *, err=300) lchi_( nb), oc_( nb )
! !
! Test lchi and occupation numbers ! Test lchi and occupation numbers
! !
if ( nb.le.lmax_.and.lchi_(nb)+1.ne.nb) & IF ( nb<=lmax_.and.lchi_(nb)+1/=nb) &
call errore('read_ncpp','order of wavefunctions',nb) CALL errore('read_ncpp','order of wavefunctions',nb)
if (lchi_(nb).gt.lmax_ .or. lchi_(nb).lt.0) & IF (lchi_(nb)>lmax_ .or. lchi_(nb)<0) &
call errore('read_ncpp','wrong lchi',nb) CALL errore('read_ncpp','wrong lchi',nb)
if ( oc_(nb).lt.0.d0 .or. & IF ( oc_(nb)<0.d0 .or. &
oc_(nb).gt.2.d0*(2*lchi_(nb)+1)) & oc_(nb)>2.d0*(2*lchi_(nb)+1)) &
call errore('read_ncpp','wrong oc',nb) CALL errore('read_ncpp','wrong oc',nb)
! !
! parse and check wavefunction label ! parse and check wavefunction label
read(line,'(14x,a2)', err=222, end=222) label READ(line,'(14x,a2)', err=222, end=222) label
if (label(2:2).ne.convel(lchi_(nb))) goto 222 IF (label(2:2)/=convel(lchi_(nb))) GOTO 222
do l = 0, lmax_ DO l = 0, lmax_
if (label(2:2).eq.convel(l)) then IF (label(2:2)==convel(l)) THEN
els(nb) = label(1:2) els(nb) = label(1:2)
goto 223 GOTO 223
endif ENDIF
end do ENDDO
222 continue 222 CONTINUE
els(nb) = '*'//convel(lchi_(nb)) els(nb) = '*'//convel(lchi_(nb))
223 continue 223 CONTINUE
! !
! finally read the wavefunction ! finally read the wavefunction
read(iunps, *, err=300) (chi_(ir,nb),ir=1,mesh_) READ(iunps, *, err=300) (chi_(ir,nb),ir=1,mesh_)
enddo ENDDO
! !
! compute the atomic charges ! compute the atomic charges
! !
allocate(rho_at_(mesh_)) ALLOCATE(rho_at_(mesh_))
rho_at_(:)=0.d0 rho_at_(:)=0.d0
do nb = 1, nchi DO nb = 1, nchi
if( oc_(nb).ne.0.d0) & IF( oc_(nb)/=0.d0) &
rho_at_(:) = rho_at_(:) + oc_(nb)*chi_(:,nb)**2 rho_at_(:) = rho_at_(:) + oc_(nb)*chi_(:,nb)**2
end do ENDDO
! ---------------------------------------------------------- ! ----------------------------------------------------------
write (6,'(a)') 'Pseudopotential successfully read' WRITE (6,'(a)') 'Pseudopotential successfully read'
! ---------------------------------------------------------- ! ----------------------------------------------------------
return RETURN
300 call errore('read_ncpp','pseudo file is empty or wrong',1) 300 CALL errore('read_ncpp','pseudo file is empty or wrong',1)
end subroutine read_ncpp END SUBROUTINE read_ncpp
! ---------------------------------------------------------- ! ----------------------------------------------------------
subroutine convert_ncpp SUBROUTINE convert_ncpp
! ---------------------------------------------------------- ! ----------------------------------------------------------
use ncpp USE ncpp
use upf USE upf
use funct, ONLY : set_dft_from_name, get_iexch, get_icorr, get_igcx, get_igcc USE funct, ONLY : set_dft_from_name, get_iexch, get_icorr, get_igcx, get_igcc
implicit none IMPLICIT NONE
real(8), parameter :: rmax = 10.0d0 real(8), PARAMETER :: rmax = 10.0d0
real(8), allocatable :: aux(:) real(8), ALLOCATABLE :: aux(:)
real(8) :: vll real(8) :: vll
integer :: kkbeta, l, iv, ir, i INTEGER :: kkbeta, l, iv, ir, i
write(generated, '("Generated using ld1 code (maybe, or maybe not)")') WRITE(generated, '("Generated using ld1 code (maybe, or maybe not)")')
write(date_author,'("Author: unknown Generation date: as well")') WRITE(date_author,'("Author: unknown Generation date: as well")')
comment = 'Info: automatically converted from PWSCF format' comment = 'Info: automatically converted from PWSCF format'
! reasonable assumption ! reasonable assumption
if (zmesh > 18) then IF (zmesh > 18) THEN
rel = 1 rel = 1
else ELSE
rel = 0 rel = 0
end if ENDIF
rcloc = 0.0d0 rcloc = 0.0d0
nwfs = nchi nwfs = nchi
allocate( oc(nwfs), epseu(nwfs)) ALLOCATE( oc(nwfs), epseu(nwfs))
allocate(lchi(nwfs), nns(nwfs) ) ALLOCATE(lchi(nwfs), nns(nwfs) )
allocate(rcut (nwfs), rcutus (nwfs)) ALLOCATE(rcut (nwfs), rcutus (nwfs))
do i=1, nwfs DO i=1, nwfs
nns (i) = 0 nns (i) = 0
lchi(i) = lchi_(i) lchi(i) = lchi_(i)
rcut(i) = 0.0d0 rcut(i) = 0.0d0
rcutus(i)= 0.0d0 rcutus(i)= 0.0d0
oc (i) = oc_(i) oc (i) = oc_(i)
epseu(i) = 0.0d0 epseu(i) = 0.0d0
end do ENDDO
deallocate (lchi_, oc_) DEALLOCATE (lchi_, oc_)
psd = psd_ psd = psd_
pseudotype = 'NC' pseudotype = 'NC'
@ -290,96 +290,96 @@ subroutine convert_ncpp
etotps = 0.0d0 etotps = 0.0d0
ecutrho=0.0d0 ecutrho=0.0d0
ecutwfc=0.0d0 ecutwfc=0.0d0
if ( lmax_ == lloc) then IF ( lmax_ == lloc) THEN
lmax = lmax_-1 lmax = lmax_-1
else ELSE
lmax = lmax_ lmax = lmax_
end if ENDIF
nbeta= lmax_ nbeta= lmax_
mesh = mesh_ mesh = mesh_
ntwfc= nchi ntwfc= nchi
allocate( elsw(ntwfc), ocw(ntwfc), lchiw(ntwfc) ) ALLOCATE( elsw(ntwfc), ocw(ntwfc), lchiw(ntwfc) )
do i=1, nchi DO i=1, nchi
lchiw(i) = lchi(i) lchiw(i) = lchi(i)
ocw(i) = oc(i) ocw(i) = oc(i)
elsw(i) = els(i) elsw(i) = els(i)
end do ENDDO
call set_dft_from_name(dft_) CALL set_dft_from_name(dft_)
iexch = get_iexch() iexch = get_iexch()
icorr = get_icorr() icorr = get_icorr()
igcx = get_igcx() igcx = get_igcx()
igcc = get_igcc() igcc = get_igcc()
allocate(rab(mesh)) ALLOCATE(rab(mesh))
allocate( r(mesh)) ALLOCATE( r(mesh))
rab = rab_ rab = rab_
r = r_ r = r_
allocate (rho_atc(mesh)) ALLOCATE (rho_atc(mesh))
rho_atc = rho_atc_ rho_atc = rho_atc_
deallocate (rho_atc_) DEALLOCATE (rho_atc_)
allocate (vloc0(mesh)) ALLOCATE (vloc0(mesh))
vloc0(:) = vnl(:,lloc) vloc0(:) = vnl(:,lloc)
if (nbeta > 0) then IF (nbeta > 0) THEN
allocate(ikk2(nbeta), lll(nbeta)) ALLOCATE(ikk2(nbeta), lll(nbeta))
kkbeta=mesh kkbeta=mesh
do ir = 1,mesh DO ir = 1,mesh
if ( r(ir) > rmax ) then IF ( r(ir) > rmax ) THEN
kkbeta=ir kkbeta=ir
exit exit
end if ENDIF
end do ENDDO
! make sure kkbeta is odd as required for simpson ! make sure kkbeta is odd as required for simpson
if(mod(kkbeta,2) == 0) kkbeta=kkbeta-1 IF(mod(kkbeta,2) == 0) kkbeta=kkbeta-1
ikk2(:) = kkbeta ikk2(:) = kkbeta
allocate(aux(kkbeta)) ALLOCATE(aux(kkbeta))
allocate(betar(mesh,nbeta)) ALLOCATE(betar(mesh,nbeta))
allocate(qfunc(mesh,nbeta,nbeta)) ALLOCATE(qfunc(mesh,nbeta,nbeta))
allocate(dion(nbeta,nbeta)) ALLOCATE(dion(nbeta,nbeta))
allocate(qqq (nbeta,nbeta)) ALLOCATE(qqq (nbeta,nbeta))
qfunc(:,:,:)=0.0d0 qfunc(:,:,:)=0.0d0
dion(:,:) =0.d0 dion(:,:) =0.d0
qqq(:,:) =0.d0 qqq(:,:) =0.d0
iv=0 iv=0
do i=1,nchi DO i=1,nchi
l=lchi(i) l=lchi(i)
if (l.ne.lloc) then IF (l/=lloc) THEN
iv=iv+1 iv=iv+1
lll(iv)=l lll(iv)=l
do ir=1,kkbeta DO ir=1,kkbeta
betar(ir,iv)=chi_(ir,i)*vnl(ir,l) betar(ir,iv)=chi_(ir,i)*vnl(ir,l)
aux(ir) = chi_(ir,i)**2*vnl(ir,l) aux(ir) = chi_(ir,i)**2*vnl(ir,l)
end do ENDDO
call simpson(kkbeta,aux,rab,vll) CALL simpson(kkbeta,aux,rab,vll)
dion(iv,iv) = 1.0d0/vll dion(iv,iv) = 1.0d0/vll
end if ENDIF
if(iv >= nbeta) exit ! skip additional pseudo wfns IF(iv >= nbeta) exit ! skip additional pseudo wfns
enddo ENDDO
deallocate (vnl, aux) DEALLOCATE (vnl, aux)
! !
! redetermine ikk2 ! redetermine ikk2
! !
do iv=1,nbeta DO iv=1,nbeta
ikk2(iv)=kkbeta ikk2(iv)=kkbeta
do ir = kkbeta,1,-1 DO ir = kkbeta,1,-1
if ( abs(betar(ir,iv)) > 1.d-12 ) then IF ( abs(betar(ir,iv)) > 1.d-12 ) THEN
ikk2(iv)=ir ikk2(iv)=ir
exit exit
end if ENDIF
end do ENDDO
end do ENDDO
end if ENDIF
allocate (rho_at(mesh)) ALLOCATE (rho_at(mesh))
rho_at = rho_at_ rho_at = rho_at_
deallocate (rho_at_) DEALLOCATE (rho_at_)
allocate (chi(mesh,ntwfc))
chi = chi_
deallocate (chi_)
return ALLOCATE (chi(mesh,ntwfc))
end subroutine convert_ncpp chi = chi_
DEALLOCATE (chi_)
RETURN
END SUBROUTINE convert_ncpp

230
upftools/oldcp2upf.f90
View File

@ -7,139 +7,139 @@
! !
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
program oldcp2upf PROGRAM oldcp2upf
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
! Convert a pseudopotential written in the old CP90 format ! Convert a pseudopotential written in the old CP90 format
! (without core correction) to unified pseudopotential format ! (without core correction) to unified pseudopotential format
! !
implicit none IMPLICIT NONE
character(len=256) filein, fileout CHARACTER(len=256) filein, fileout
! !
! !
call get_file ( filein ) CALL get_file ( filein )
open (unit = 1, file = filein, status = 'old', form = 'formatted') OPEN (unit = 1, file = filein, status = 'old', form = 'formatted')
call read_oldcp(1) CALL read_oldcp(1)
close (1) CLOSE (1)
! convert variables read from old CP90 format into those needed ! convert variables read from old CP90 format into those needed
! by the upf format - add missing quantities ! by the upf format - add missing quantities
call convert_oldcp CALL convert_oldcp
fileout=trim(filein)//'.UPF' fileout=trim(filein)//'.UPF'
print '(''Output PP file in UPF format : '',a)', fileout PRINT '(''Output PP file in UPF format : '',a)', fileout
open(unit=2,file=fileout,status='unknown',form='formatted') OPEN(unit=2,file=fileout,status='unknown',form='formatted')
call write_upf(2) CALL write_upf(2)
close (unit=2) CLOSE (unit=2)
stop STOP
20 call errore ('oldcp2upf', 'Reading pseudo file name ', 1) 20 CALL errore ('oldcp2upf', 'Reading pseudo file name ', 1)
end program oldcp2upf END PROGRAM oldcp2upf
module oldcp MODULE oldcp
! !
! All variables read from old CP90 file format ! All variables read from old CP90 file format
! !
real(8) :: amesh, z, zv real(8) :: amesh, z, zv
integer :: exfact, lloc, nbeta_, mesh_ INTEGER :: exfact, lloc, nbeta_, mesh_
real(8) :: wrc1, rc1, wrc2, rc2, rcl(3,3), al(3,3), bl(3,3) real(8) :: wrc1, rc1, wrc2, rc2, rcl(3,3), al(3,3), bl(3,3)
real(8), allocatable :: r_(:), vnl(:,:), chi_(:,:) real(8), ALLOCATABLE :: r_(:), vnl(:,:), chi_(:,:)
! !
!------------------------------ !------------------------------
end module oldcp END MODULE oldcp
! !
! ---------------------------------------------------------- ! ----------------------------------------------------------
subroutine read_oldcp(iunps) SUBROUTINE read_oldcp(iunps)
! ---------------------------------------------------------- ! ----------------------------------------------------------
!
use oldcp
implicit none
integer :: iunps
! !
real(8), external :: qe_erf USE oldcp
integer :: i, l, j, jj IMPLICIT NONE
INTEGER :: iunps
! !
read(iunps,*, end=10, err=10) z, zv, nbeta_, lloc, exfact real(8), EXTERNAL :: qe_erf
if (z < 1 .or. z > 100 .or. zv < 1 .or. zv > 25 ) & INTEGER :: i, l, j, jj
call errore ('read_oldcp','wrong potential read',1) !
read(iunps,*, end=10, err=10) wrc1, rc1, wrc2, rc2 READ(iunps,*, end=10, err=10) z, zv, nbeta_, lloc, exfact
read(iunps,*, end=10, err=10) ( ( rcl(i,l), al(i,l), & IF (z < 1 .or. z > 100 .or. zv < 1 .or. zv > 25 ) &
CALL errore ('read_oldcp','wrong potential read',1)
READ(iunps,*, end=10, err=10) wrc1, rc1, wrc2, rc2
READ(iunps,*, end=10, err=10) ( ( rcl(i,l), al(i,l), &
bl(i,l), i = 1, 3), l = 1, 3) bl(i,l), i = 1, 3), l = 1, 3)
read(iunps,*, end=10, err=10) mesh_, amesh READ(iunps,*, end=10, err=10) mesh_, amesh
allocate(r_(mesh_)) ALLOCATE(r_(mesh_))
allocate (chi_(mesh_,nbeta_)) ALLOCATE (chi_(mesh_,nbeta_))
do l = 1, nbeta_ DO l = 1, nbeta_
if (l > 1) read(iunps,*, end=10, err=10) mesh_, amesh IF (l > 1) READ(iunps,*, end=10, err=10) mesh_, amesh
do j = 1, mesh_ DO j = 1, mesh_
read(iunps,*, end=10, err=10) jj, r_(j), chi_(j,l) READ(iunps,*, end=10, err=10) jj, r_(j), chi_(j,l)
end do ENDDO
end do ENDDO
! !
! convert analytic to numeric form ! convert analytic to numeric form
! !
allocate (vnl(mesh_,0:nbeta_)) ALLOCATE (vnl(mesh_,0:nbeta_))
do l=0,nbeta_ DO l=0,nbeta_
! !
! DO NOT USE f90 ARRAY SYNTAX: qe_erf IS NOT AN INTRINSIC FUNCTION!!! ! DO NOT USE f90 ARRAY SYNTAX: qe_erf IS NOT AN INTRINSIC FUNCTION!!!
! !
do j=1, mesh_ DO j=1, mesh_
vnl(j,l)= - (wrc1*qe_erf(sqrt(rc1)*r_(j)) + & vnl(j,l)= - (wrc1*qe_erf(sqrt(rc1)*r_(j)) + &
wrc2*qe_erf(sqrt(rc2)*r_(j)) ) * zv/r_(j) wrc2*qe_erf(sqrt(rc2)*r_(j)) ) * zv/r_(j)
end do ENDDO
! !
do i=1,3 DO i=1,3
vnl(:,l)= vnl(:,l)+ (al(i,l+1)+ bl(i,l+1)*r_(:)**2) * & vnl(:,l)= vnl(:,l)+ (al(i,l+1)+ bl(i,l+1)*r_(:)**2) * &
exp(-rcl(i,l+1)*r_(:)**2) exp(-rcl(i,l+1)*r_(:)**2)
end do ENDDO
end do ENDDO
return RETURN
10 call errore('read_oldcp','error in reading file',1) 10 CALL errore('read_oldcp','error in reading file',1)
end subroutine read_oldcp END SUBROUTINE read_oldcp
! ---------------------------------------------------------- ! ----------------------------------------------------------
subroutine convert_oldcp SUBROUTINE convert_oldcp
! ---------------------------------------------------------- ! ----------------------------------------------------------
! !
use oldcp USE oldcp
use upf USE upf
implicit none IMPLICIT NONE
real(8), parameter :: rmax = 10.0d0 real(8), PARAMETER :: rmax = 10.0d0
real(8), allocatable :: aux(:) real(8), ALLOCATABLE :: aux(:)
real(8) :: vll real(8) :: vll
character (len=20):: dft CHARACTER (len=20):: dft
character (len=2), external :: atom_name CHARACTER (len=2), EXTERNAL :: atom_name
integer :: kkbeta INTEGER :: kkbeta
integer :: l, i, ir, iv INTEGER :: l, i, ir, iv
! !
write(generated, '("Generated using unknown code")') WRITE(generated, '("Generated using unknown code")')
write(date_author,'("Author: unknown Generation date: as well")') WRITE(date_author,'("Author: unknown Generation date: as well")')
comment = 'Info: automatically converted from old CP90 format' comment = 'Info: automatically converted from old CP90 format'
! reasonable assumption ! reasonable assumption
if (z > 18) then IF (z > 18) THEN
rel = 1 rel = 1
else ELSE
rel = 0 rel = 0
end if ENDIF
rcloc = 0.0d0 rcloc = 0.0d0
nwfs = nbeta_ nwfs = nbeta_
allocate( els(nwfs), oc(nwfs), epseu(nwfs)) ALLOCATE( els(nwfs), oc(nwfs), epseu(nwfs))
allocate(lchi(nwfs), nns(nwfs) ) ALLOCATE(lchi(nwfs), nns(nwfs) )
allocate(rcut (nwfs), rcutus (nwfs)) ALLOCATE(rcut (nwfs), rcutus (nwfs))
do i=1, nwfs DO i=1, nwfs
print '("Wavefunction # ",i1,": label, occupancy > ",$)', i PRINT '("Wavefunction # ",i1,": label, occupancy > ",$)', i
read (5,*) els(i), oc(i) READ (5,*) els(i), oc(i)
nns (i) = 0 nns (i) = 0
lchi(i) = i-1 lchi(i) = i-1
rcut(i) = 0.0d0 rcut(i) = 0.0d0
rcutus(i)= 0.0d0 rcutus(i)= 0.0d0
epseu(i) = 0.0d0 epseu(i) = 0.0d0
end do ENDDO
psd = atom_name (nint(z)) psd = atom_name (nint(z))
pseudotype = 'NC' pseudotype = 'NC'
nlcc = .false. nlcc = .false.
@ -151,90 +151,90 @@ subroutine convert_oldcp
nbeta = nbeta_ nbeta = nbeta_
mesh = mesh_ mesh = mesh_
ntwfc = nwfs ntwfc = nwfs
allocate( elsw(ntwfc), ocw(ntwfc), lchiw(ntwfc) ) ALLOCATE( elsw(ntwfc), ocw(ntwfc), lchiw(ntwfc) )
do i=1, nwfs DO i=1, nwfs
lchiw(i) = lchi(i) lchiw(i) = lchi(i)
ocw(i) = oc(i) ocw(i) = oc(i)
elsw(i) = els(i) elsw(i) = els(i)
end do ENDDO
! !
if ( exfact.eq.0) then IF ( exfact==0) THEN
iexch=1; icorr=1; igcx=0; igcc=0 ! Perdew-Zunger iexch=1; icorr=1; igcx=0; igcc=0 ! Perdew-Zunger
else if ( exfact.eq.1) then ELSEIF ( exfact==1) THEN
iexch=1; icorr=3; igcx=1; igcc=3 ! Becke-Lee-Yang-Parr iexch=1; icorr=3; igcx=1; igcc=3 ! Becke-Lee-Yang-Parr
else if ( exfact.eq.2) then ELSEIF ( exfact==2) THEN
iexch=1; icorr=1; igcx=1; igcc=0 ! Becke88 exchange iexch=1; icorr=1; igcx=1; igcc=0 ! Becke88 exchange
else if (exfact.eq.-5.or.exfact.eq.3) then ELSEIF (exfact==-5.or.exfact==3) THEN
iexch=1; icorr=1; igcx=1; igcc=1 ! Becke88-Perdew 86 iexch=1; icorr=1; igcx=1; igcc=1 ! Becke88-Perdew 86
else if (exfact.eq.-6.or.exfact.eq.4) then ELSEIF (exfact==-6.or.exfact==4) THEN
iexch=1; icorr=4; igcx=2; igcc=2 ! Perdew-Wang 91 iexch=1; icorr=4; igcx=2; igcc=2 ! Perdew-Wang 91
else if (exfact.eq. 5) then ELSEIF (exfact== 5) THEN
iexch=1; icorr=4; igcx=3; igcc=4 ! Perdew-Becke-Erkerhof iexch=1; icorr=4; igcx=3; igcc=4 ! Perdew-Becke-Erkerhof
else ELSE
call errore('convert','Wrong xc in pseudopotential',1) CALL errore('convert','Wrong xc in pseudopotential',1)
end if ENDIF
allocate(rab(mesh)) ALLOCATE(rab(mesh))
allocate( r(mesh)) ALLOCATE( r(mesh))
r = r_ r = r_
rab = r * log( amesh ) rab = r * log( amesh )
! !
! convert analytic to numeric form ! convert analytic to numeric form
! !
! !
allocate (vloc0(mesh)) ALLOCATE (vloc0(mesh))
! the factor 2 converts from Hartree to Rydberg ! the factor 2 converts from Hartree to Rydberg
vloc0(:) = vnl(:,lloc)*2.d0 vloc0(:) = vnl(:,lloc)*2.d0
if (nbeta > 0) then IF (nbeta > 0) THEN
allocate(ikk2(nbeta), lll(nbeta)) ALLOCATE(ikk2(nbeta), lll(nbeta))
kkbeta=mesh kkbeta=mesh
do ir = 1,mesh DO ir = 1,mesh
if ( r(ir) > rmax ) then IF ( r(ir) > rmax ) THEN
kkbeta=ir kkbeta=ir
exit exit
end if ENDIF
end do ENDDO
ikk2(:) = kkbeta ikk2(:) = kkbeta
allocate(aux(kkbeta)) ALLOCATE(aux(kkbeta))
allocate(betar(mesh,nbeta)) ALLOCATE(betar(mesh,nbeta))
allocate(qfunc(mesh,nbeta,nbeta)) ALLOCATE(qfunc(mesh,nbeta,nbeta))
allocate(dion(nbeta,nbeta)) ALLOCATE(dion(nbeta,nbeta))
allocate(qqq (nbeta,nbeta)) ALLOCATE(qqq (nbeta,nbeta))
qfunc(:,:,:)=0.0d0 qfunc(:,:,:)=0.0d0
dion(:,:) =0.d0 dion(:,:) =0.d0
qqq(:,:) =0.d0 qqq(:,:) =0.d0
iv=0 iv=0
do i=1,nwfs DO i=1,nwfs
l=lchi(i) l=lchi(i)
if (l.ne.lloc) then IF (l/=lloc) THEN
iv=iv+1 iv=iv+1
lll(iv)=l lll(iv)=l
do ir=1,kkbeta DO ir=1,kkbeta
! the factor 2 converts from Hartree to Rydberg ! the factor 2 converts from Hartree to Rydberg
betar(ir,iv) = 2.d0 * chi_(ir,l+1) * & betar(ir,iv) = 2.d0 * chi_(ir,l+1) * &
( vnl(ir,l) - vnl(ir,lloc) ) ( vnl(ir,l) - vnl(ir,lloc) )
aux(ir) = chi_(ir,l+1) * betar(ir,iv) aux(ir) = chi_(ir,l+1) * betar(ir,iv)
end do ENDDO
call simpson(kkbeta,aux,rab,vll) CALL simpson(kkbeta,aux,rab,vll)
dion(iv,iv) = 1.0d0/vll dion(iv,iv) = 1.0d0/vll
end if ENDIF
enddo ENDDO
end if ENDIF
allocate (rho_at(mesh)) ALLOCATE (rho_at(mesh))
rho_at = 0.d0 rho_at = 0.d0
do i=1,nwfs DO i=1,nwfs
rho_at(:) = rho_at(:) + ocw(i) * chi_(:,i) ** 2 rho_at(:) = rho_at(:) + ocw(i) * chi_(:,i) ** 2
end do ENDDO
allocate (chi(mesh,ntwfc)) ALLOCATE (chi(mesh,ntwfc))
chi = chi_ chi = chi_
! ---------------------------------------------------------- ! ----------------------------------------------------------
write (6,'(a)') 'Pseudopotential successfully converted' WRITE (6,'(a)') 'Pseudopotential successfully converted'
! ---------------------------------------------------------- ! ----------------------------------------------------------
return RETURN
end subroutine convert_oldcp END SUBROUTINE convert_oldcp

448
upftools/read_upf.f90
View File

@ -5,32 +5,32 @@
! in the root directory of the present distribution, ! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt . ! or http://www.gnu.org/copyleft/gpl.txt .
! !
module pseudo MODULE pseudo
! !
! All variables to be read from the UPF file ! All variables to be read from the UPF file
! (UPF = unified pseudopotential format) ! (UPF = unified pseudopotential format)
! !
integer ,parameter :: npsx = 6 INTEGER ,PARAMETER :: npsx = 6
! npsx : maximum number of different pseudopotentials ! npsx : maximum number of different pseudopotentials
integer, parameter :: lmaxx = 3, nchix = 6, ndm = 2000 INTEGER, PARAMETER :: lmaxx = 3, nchix = 6, ndm = 2000
! lmaxx : maximum non local angular momentum in PP ! lmaxx : maximum non local angular momentum in PP
! nchix : maximum number of atomic wavefunctions per PP ! nchix : maximum number of atomic wavefunctions per PP
! ndm : maximum number of points in the radial mesh ! ndm : maximum number of points in the radial mesh
integer, parameter :: nbrx = 8, lqmax = 5, nqfx = 8 INTEGER, PARAMETER :: nbrx = 8, lqmax = 5, nqfx = 8
! nbrx : maximum number of beta functions ! nbrx : maximum number of beta functions
! lqmax : maximum number of angular momentum of Q ! lqmax : maximum number of angular momentum of Q
! nqfx : maximum number of coefficients in Q smoothing ! nqfx : maximum number of coefficients in Q smoothing
! !
! pp_header ! pp_header
character (len=80):: generated, date_author, comment CHARACTER (len=80):: generated, date_author, comment
character (len=2) :: psd(npsx), pseudotype CHARACTER (len=2) :: psd(npsx), pseudotype
character (len=20):: dft(npsx) CHARACTER (len=20):: dft(npsx)
integer :: lmax(npsx), mesh(npsx), nbeta(npsx), ntwfc(npsx) INTEGER :: lmax(npsx), mesh(npsx), nbeta(npsx), ntwfc(npsx)
logical :: nlcc(npsx), isus(npsx) LOGICAL :: nlcc(npsx), isus(npsx)
real(8) :: zp(npsx), ecutrho, ecutwfc, etotps real(8) :: zp(npsx), ecutrho, ecutwfc, etotps
real(8) :: oc(nchix,npsx) real(8) :: oc(nchix,npsx)
character(len=2) :: els(nchix,npsx) CHARACTER(len=2) :: els(nchix,npsx)
integer :: lchi(nchix,npsx) INTEGER :: lchi(nchix,npsx)
! !
! pp_mesh ! pp_mesh
real(8) :: r(ndm,npsx), rab(ndm,npsx) real(8) :: r(ndm,npsx), rab(ndm,npsx)
@ -43,11 +43,11 @@ module pseudo
! pp_nonlocal ! pp_nonlocal
! pp_beta ! pp_beta
real(8) :: betar(ndm, nbrx, npsx) real(8) :: betar(ndm, nbrx, npsx)
integer :: lll(nbrx,npsx), ikk2(nbrx,npsx) INTEGER :: lll(nbrx,npsx), ikk2(nbrx,npsx)
! pp_dij ! pp_dij
real(8) :: dion(nbrx,nbrx,npsx) real(8) :: dion(nbrx,nbrx,npsx)
! pp_qij ! pp_qij
integer :: nqf(npsx), nqlc(npsx) INTEGER :: nqf(npsx), nqlc(npsx)
real(8) :: rinner(lqmax,npsx), qqq(nbrx,nbrx,npsx), & real(8) :: rinner(lqmax,npsx), qqq(nbrx,nbrx,npsx), &
qfunc(ndm,nbrx,nbrx,npsx) qfunc(ndm,nbrx,nbrx,npsx)
! pp_qfcoef ! pp_qfcoef
@ -58,339 +58,339 @@ module pseudo
! !
! pp_rhoatom ! pp_rhoatom
real(8) :: rho_at(ndm,npsx) real(8) :: rho_at(ndm,npsx)
end module pseudo END MODULE pseudo
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
program read_ps PROGRAM read_ps
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
! Read pseudopotentials in the Unified Pseudopotential Format (UPF) ! Read pseudopotentials in the Unified Pseudopotential Format (UPF)
! !
implicit none IMPLICIT NONE
integer :: is, ios, iunps = 4 INTEGER :: is, ios, iunps = 4
character (len=256) :: filein CHARACTER (len=256) :: filein
! !
is = 0 is = 0
10 print '('' Input PP file # '',i2,'' in UPF format > '',$)', is+1 10 PRINT '('' Input PP file # '',i2,'' in UPF format > '',$)', is+1
read (5, '(a)', end = 20, err = 20) filein READ (5, '(a)', end = 20, err = 20) filein
open(unit=iunps,file=filein,status='old',form='formatted',iostat=ios) OPEN(unit=iunps,file=filein,status='old',form='formatted',iostat=ios)
if (ios.ne.0) stop IF (ios/=0) STOP
is = is + 1 is = is + 1
call read_pseudo(is, iunps) CALL read_pseudo(is, iunps)
close (unit=iunps) CLOSE (unit=iunps)
go to 10 GOTO 10
20 stop 20 STOP
end program read_ps END PROGRAM read_ps
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
subroutine read_pseudo (is, iunps) SUBROUTINE read_pseudo (is, iunps)
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
! Read pseudopotential in the Unified Pseudopotential Format (UPF) ! Read pseudopotential in the Unified Pseudopotential Format (UPF)
! !
use pseudo USE pseudo
implicit none IMPLICIT NONE
! !
integer :: is, iunps INTEGER :: is, iunps
! is : index of this pseudopotential ! is : index of this pseudopotential
! iunps: unit connected with pseudopotential file ! iunps: unit connected with pseudopotential file
! !
if (is < 0 .or. is > npsx ) call errore ('read_pseudo', 'Wrong is number', 1) IF (is < 0 .or. is > npsx ) CALL errore ('read_pseudo', 'Wrong is number', 1)
write ( *, * ) " Reading pseudopotential file in UPF format..." WRITE ( *, * ) " Reading pseudopotential file in UPF format..."
!------->Search for Header !------->Search for Header
call scan_begin (iunps, "HEADER", .true.) CALL scan_begin (iunps, "HEADER", .true.)
call read_pseudo_header (is, iunps) CALL read_pseudo_header (is, iunps)
call scan_end (iunps, "HEADER") CALL scan_end (iunps, "HEADER")
!-------->Search for mesh information !-------->Search for mesh information
call scan_begin (iunps, "MESH", .true.) CALL scan_begin (iunps, "MESH", .true.)
call read_pseudo_mesh (is, iunps) CALL read_pseudo_mesh (is, iunps)
call scan_end (iunps, "MESH") CALL scan_end (iunps, "MESH")
!-------->If present, search for nlcc !-------->If present, search for nlcc
if (nlcc (is) ) then IF (nlcc (is) ) THEN
call scan_begin (iunps, "NLCC", .true.) CALL scan_begin (iunps, "NLCC", .true.)
call read_pseudo_nlcc (is, iunps) CALL read_pseudo_nlcc (is, iunps)
call scan_end (iunps, "NLCC") CALL scan_end (iunps, "NLCC")
endif ENDIF
!-------->Search for Local potential !-------->Search for Local potential
call scan_begin (iunps, "LOCAL", .true.) CALL scan_begin (iunps, "LOCAL", .true.)
call read_pseudo_local (is, iunps) CALL read_pseudo_local (is, iunps)
call scan_end (iunps, "LOCAL") CALL scan_end (iunps, "LOCAL")
!-------->Search for Nonlocal potential !-------->Search for Nonlocal potential
call scan_begin (iunps, "NONLOCAL", .true.) CALL scan_begin (iunps, "NONLOCAL", .true.)
call read_pseudo_nl (is, iunps) CALL read_pseudo_nl (is, iunps)
call scan_end (iunps, "NONLOCAL") CALL scan_end (iunps, "NONLOCAL")
!-------->Search for atomic wavefunctions !-------->Search for atomic wavefunctions
call scan_begin (iunps, "PSWFC", .true.) CALL scan_begin (iunps, "PSWFC", .true.)
call read_pseudo_pswfc (is, iunps) CALL read_pseudo_pswfc (is, iunps)
call scan_end (iunps, "PSWFC") CALL scan_end (iunps, "PSWFC")
!-------->Search for atomic charge !-------->Search for atomic charge
call scan_begin (iunps, "RHOATOM", .true.) CALL scan_begin (iunps, "RHOATOM", .true.)
call read_pseudo_rhoatom (is, iunps) CALL read_pseudo_rhoatom (is, iunps)
call scan_end (iunps, "RHOATOM") CALL scan_end (iunps, "RHOATOM")
! !
write ( *, * ) " ...done" WRITE ( *, * ) " ...done"
return RETURN
end subroutine read_pseudo END SUBROUTINE read_pseudo
!--------------------------------------------------------------------- !---------------------------------------------------------------------
subroutine scan_begin (iunps, string, rew) SUBROUTINE scan_begin (iunps, string, rew)
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
implicit none IMPLICIT NONE
! Unit of the input file ! Unit of the input file
integer :: iunps INTEGER :: iunps
! Label to be matched ! Label to be matched
character (len=*) :: string CHARACTER (len=*) :: string
logical :: rew LOGICAL :: rew
! Flag: if .true. rewind the file ! Flag: if .true. rewind the file
character (len=80) :: rstring CHARACTER (len=80) :: rstring
! String read from file ! String read from file
integer :: ios INTEGER :: ios
logical, external :: matches LOGICAL, EXTERNAL :: matches
ios = 0 ios = 0
if (rew) rewind (iunps) IF (rew) REWIND (iunps)
do while (ios.eq.0) DO WHILE (ios==0)
read (iunps, *, iostat = ios, err = 300) rstring READ (iunps, *, iostat = ios, err = 300) rstring
if (matches ("<PP_"//string//">", rstring) ) return IF (matches ("<PP_"//string//">", rstring) ) RETURN
enddo ENDDO
300 call errore ('scan_begin', 'No '//string//' block', abs (ios) ) 300 CALL errore ('scan_begin', 'No '//string//' block', abs (ios) )
end subroutine scan_begin END SUBROUTINE scan_begin
!--------------------------------------------------------------------- !---------------------------------------------------------------------
subroutine scan_end (iunps, string) SUBROUTINE scan_end (iunps, string)
!--------------------------------------------------------------------- !---------------------------------------------------------------------
implicit none IMPLICIT NONE
! Unit of the input file ! Unit of the input file
integer :: iunps INTEGER :: iunps
! Label to be matched ! Label to be matched
character (len=*) :: string CHARACTER (len=*) :: string
! String read from file ! String read from file
character (len=80) :: rstring CHARACTER (len=80) :: rstring
integer :: ios INTEGER :: ios
logical, external :: matches LOGICAL, EXTERNAL :: matches
read (iunps, '(a)', iostat = ios, err = 300) rstring READ (iunps, '(a)', iostat = ios, err = 300) rstring
if (matches ("</PP_"//string//">", rstring) ) return IF (matches ("</PP_"//string//">", rstring) ) RETURN
300 call errore ('scan_end', & 300 CALL errore ('scan_end', &
'No '//string//' block end statement, possibly corrupted file', - 1) 'No '//string//' block end statement, possibly corrupted file', - 1)
end subroutine scan_end END SUBROUTINE scan_end
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
subroutine read_pseudo_header (is, iunps) SUBROUTINE read_pseudo_header (is, iunps)
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
use pseudo USE pseudo
implicit none IMPLICIT NONE
! !
integer :: is, iunps INTEGER :: is, iunps
! !
integer :: nv, ios, nw INTEGER :: nv, ios, nw
character (len=75) :: dummy CHARACTER (len=75) :: dummy
logical, external :: matches LOGICAL, EXTERNAL :: matches
read (iunps, *, err = 100, iostat = ios) nv, dummy READ (iunps, *, err = 100, iostat = ios) nv, dummy
read (iunps, *, err = 100, iostat = ios) psd (is), dummy READ (iunps, *, err = 100, iostat = ios) psd (is), dummy
read (iunps, *, err = 100, iostat = ios) pseudotype READ (iunps, *, err = 100, iostat = ios) pseudotype
if (matches (pseudotype, "US") ) isus (is) = .true. IF (matches (pseudotype, "US") ) isus (is) = .true.
read (iunps, *, err = 100, iostat = ios) nlcc (is), dummy READ (iunps, *, err = 100, iostat = ios) nlcc (is), dummy
read (iunps, '(a20,t24,a)', err = 100, iostat = ios) dft(is), dummy READ (iunps, '(a20,t24,a)', err = 100, iostat = ios) dft(is), dummy
read (iunps, * ) zp (is), dummy READ (iunps, * ) zp (is), dummy
read (iunps, * ) etotps, dummy READ (iunps, * ) etotps, dummy
read (iunps, * ) ecutwfc, ecutrho READ (iunps, * ) ecutwfc, ecutrho
read (iunps, * ) lmax (is), dummy READ (iunps, * ) lmax (is), dummy
read (iunps, *, err = 100, iostat = ios) mesh (is), dummy READ (iunps, *, err = 100, iostat = ios) mesh (is), dummy
read (iunps, *, err = 100, iostat = ios) ntwfc(is), nbeta (is), dummy READ (iunps, *, err = 100, iostat = ios) ntwfc(is), nbeta (is), dummy
read (iunps, '(a)', err = 100, iostat = ios) dummy READ (iunps, '(a)', err = 100, iostat = ios) dummy
do nw = 1, ntwfc(is) DO nw = 1, ntwfc(is)
read (iunps, * ) els (nw,is), lchi (nw, is), oc (nw, is) READ (iunps, * ) els (nw,is), lchi (nw, is), oc (nw, is)
enddo ENDDO
return RETURN
100 call errore ('read_pseudo_header', 'Reading pseudo file', abs (ios)) 100 CALL errore ('read_pseudo_header', 'Reading pseudo file', abs (ios))
end subroutine read_pseudo_header END SUBROUTINE read_pseudo_header
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
subroutine read_pseudo_local (is, iunps) SUBROUTINE read_pseudo_local (is, iunps)
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
use pseudo USE pseudo
implicit none IMPLICIT NONE
! !
integer :: is, iunps INTEGER :: is, iunps
! !
integer :: ir, ios INTEGER :: ir, ios
! !
read (iunps, *, err=100, iostat=ios) (vloc0(ir,is) , ir=1,mesh(is)) READ (iunps, *, err=100, iostat=ios) (vloc0(ir,is) , ir=1,mesh(is))
100 call errore ('read_pseudo_local','Reading pseudo file', abs(ios) ) 100 CALL errore ('read_pseudo_local','Reading pseudo file', abs(ios) )
return RETURN
end subroutine read_pseudo_local END SUBROUTINE read_pseudo_local
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
subroutine read_pseudo_mesh (is, iunps) SUBROUTINE read_pseudo_mesh (is, iunps)
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
use pseudo USE pseudo
implicit none IMPLICIT NONE
! !
integer :: is, iunps INTEGER :: is, iunps
! !
integer :: ir, ios INTEGER :: ir, ios
! !
call scan_begin (iunps, "R", .false.) CALL scan_begin (iunps, "R", .false.)
read (iunps, *, err = 100, iostat = ios) (r(ir,is), ir=1,mesh(is) ) READ (iunps, *, err = 100, iostat = ios) (r(ir,is), ir=1,mesh(is) )
call scan_end (iunps, "R") CALL scan_end (iunps, "R")
call scan_begin (iunps, "RAB", .false.) CALL scan_begin (iunps, "RAB", .false.)
read (iunps, *, err = 100, iostat = ios) (rab(ir,is), ir=1,mesh(is) ) READ (iunps, *, err = 100, iostat = ios) (rab(ir,is), ir=1,mesh(is) )
call scan_end (iunps, "RAB") CALL scan_end (iunps, "RAB")
return RETURN
100 call errore ('read_pseudo_mesh', 'Reading pseudo file', abs (ios) ) 100 CALL errore ('read_pseudo_mesh', 'Reading pseudo file', abs (ios) )
end subroutine read_pseudo_mesh END SUBROUTINE read_pseudo_mesh
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
subroutine read_pseudo_nl (is, iunps) SUBROUTINE read_pseudo_nl (is, iunps)
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
use pseudo USE pseudo
implicit none IMPLICIT NONE
! !
integer :: is, iunps INTEGER :: is, iunps
! !
integer :: nb, mb, n, ir, nd, ios, idum, ldum, icon, lp, i INTEGER :: nb, mb, n, ir, nd, ios, idum, ldum, icon, lp, i
! counters ! counters
character (len=75) :: dummy CHARACTER (len=75) :: dummy
! !
do nb = 1, nbeta (is) DO nb = 1, nbeta (is)
call scan_begin (iunps, "BETA", .false.) CALL scan_begin (iunps, "BETA", .false.)
read (iunps, *, err = 100, iostat = ios) idum, lll(nb,is), dummy READ (iunps, *, err = 100, iostat = ios) idum, lll(nb,is), dummy
read (iunps, '(i6)', err = 100, iostat = ios) ikk2(nb,is) READ (iunps, '(i6)', err = 100, iostat = ios) ikk2(nb,is)
read (iunps, *, err = 100, iostat = ios) & READ (iunps, *, err = 100, iostat = ios) &
(betar(ir,nb,is), ir=1,ikk2(nb,is)) (betar(ir,nb,is), ir=1,ikk2(nb,is))
do ir = ikk2(nb,is) + 1, mesh (is) DO ir = ikk2(nb,is) + 1, mesh (is)
betar (ir, nb, is) = 0.d0 betar (ir, nb, is) = 0.d0
enddo ENDDO
call scan_end (iunps, "BETA") CALL scan_end (iunps, "BETA")
enddo ENDDO
call scan_begin (iunps, "DIJ", .false.) CALL scan_begin (iunps, "DIJ", .false.)
read (iunps, *, err = 100, iostat = ios) nd, dummy READ (iunps, *, err = 100, iostat = ios) nd, dummy
dion (:,:,is) = 0.d0 dion (:,:,is) = 0.d0
do icon = 1, nd DO icon = 1, nd
read (iunps, *, err = 100, iostat = ios) nb, mb, dion(nb,mb,is) READ (iunps, *, err = 100, iostat = ios) nb, mb, dion(nb,mb,is)
dion (mb,nb,is) = dion (nb,mb,is) dion (mb,nb,is) = dion (nb,mb,is)
enddo ENDDO
call scan_end (iunps, "DIJ") CALL scan_end (iunps, "DIJ")
if (isus (is) ) then IF (isus (is) ) THEN
call scan_begin (iunps, "QIJ", .false.) CALL scan_begin (iunps, "QIJ", .false.)
read (iunps, *, err = 100, iostat = ios) nqf(is) READ (iunps, *, err = 100, iostat = ios) nqf(is)
nqlc (is)= 2 * lmax (is) + 1 nqlc (is)= 2 * lmax (is) + 1
if (nqlc(is).gt.lqmax .or. nqlc(is).lt.0) & IF (nqlc(is)>lqmax .or. nqlc(is)<0) &
call errore (' read_pseudo_nl', 'Wrong nqlc', nqlc (is) ) CALL errore (' read_pseudo_nl', 'Wrong nqlc', nqlc (is) )
if (nqf(is).ne.0) then IF (nqf(is)/=0) THEN
call scan_begin (iunps, "RINNER", .false.) CALL scan_begin (iunps, "RINNER", .false.)
read (iunps,*,err=100,iostat=ios) & READ (iunps,*,err=100,iostat=ios) &
(idum,rinner(i,is),i=1,nqlc(is)) (idum,rinner(i,is),i=1,nqlc(is))
call scan_end (iunps, "RINNER") CALL scan_end (iunps, "RINNER")
end if ENDIF
do nb = 1, nbeta(is) DO nb = 1, nbeta(is)
do mb = nb, nbeta(is) DO mb = nb, nbeta(is)
read (iunps,*,err=100,iostat=ios) idum, idum, ldum, dummy READ (iunps,*,err=100,iostat=ios) idum, idum, ldum, dummy
!" i j (l)" !" i j (l)"
if (ldum.ne.lll(mb,is) ) call errore ('read_pseudo_nl', & IF (ldum/=lll(mb,is) ) CALL errore ('read_pseudo_nl', &
'inconsistent angular momentum for Q_ij', 1) 'inconsistent angular momentum for Q_ij', 1)
read (iunps,*,err=100,iostat=ios) qqq(nb,mb,is), dummy READ (iunps,*,err=100,iostat=ios) qqq(nb,mb,is), dummy
! "Q_int" ! "Q_int"
qqq(mb,nb,is) = qqq(nb,mb,is) qqq(mb,nb,is) = qqq(nb,mb,is)
read (iunps,*,err=100,iostat=ios) & READ (iunps,*,err=100,iostat=ios) &
(qfunc(n,nb,mb,is), n=1,mesh(is)) (qfunc(n,nb,mb,is), n=1,mesh(is))
do n = 0, mesh (is) DO n = 0, mesh (is)
qfunc(n,mb,nb,is) = qfunc(n,nb,mb,is) qfunc(n,mb,nb,is) = qfunc(n,nb,mb,is)
enddo ENDDO
if (nqf(is).gt.0) then IF (nqf(is)>0) THEN
call scan_begin (iunps, "QFCOEF", .false.) CALL scan_begin (iunps, "QFCOEF", .false.)
read (iunps,*,err=100,iostat=ios) & READ (iunps,*,err=100,iostat=ios) &
((qfcoef(i,lp,nb,mb,is),i=1,nqf(is)),lp=1,nqlc(is)) ((qfcoef(i,lp,nb,mb,is),i=1,nqf(is)),lp=1,nqlc(is))
call scan_end (iunps, "QFCOEF") CALL scan_end (iunps, "QFCOEF")
end if ENDIF
enddo ENDDO
enddo ENDDO
call scan_end (iunps, "QIJ") CALL scan_end (iunps, "QIJ")
else ELSE
qqq (:,:,is) = 0.d0 qqq (:,:,is) = 0.d0
qfunc(:,:,:,is) =0.d0 qfunc(:,:,:,is) =0.d0
endif ENDIF
100 call errore ('read_pseudo_nl', 'Reading pseudo file', abs (ios) ) 100 CALL errore ('read_pseudo_nl', 'Reading pseudo file', abs (ios) )
return RETURN
end subroutine read_pseudo_nl END SUBROUTINE read_pseudo_nl
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
subroutine read_pseudo_nlcc (is, iunps) SUBROUTINE read_pseudo_nlcc (is, iunps)
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
use pseudo USE pseudo
implicit none IMPLICIT NONE
! !
integer :: is, iunps INTEGER :: is, iunps
! !
integer :: ir, ios INTEGER :: ir, ios
read (iunps, *, err = 100, iostat = ios) (rho_atc(ir,is), ir=1,mesh(is) ) READ (iunps, *, err = 100, iostat = ios) (rho_atc(ir,is), ir=1,mesh(is) )
! !
100 call errore ('read_pseudo_nlcc', 'Reading pseudo file', abs (ios) ) 100 CALL errore ('read_pseudo_nlcc', 'Reading pseudo file', abs (ios) )
return RETURN
end subroutine read_pseudo_nlcc END SUBROUTINE read_pseudo_nlcc
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
subroutine read_pseudo_pswfc (is, iunps) SUBROUTINE read_pseudo_pswfc (is, iunps)
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
use pseudo USE pseudo
implicit none IMPLICIT NONE
! !
integer :: is, iunps INTEGER :: is, iunps
! !
character (len=75) :: dummy CHARACTER (len=75) :: dummy
integer :: nb, ir, ios INTEGER :: nb, ir, ios
! !
do nb = 1, ntwfc(is) DO nb = 1, ntwfc(is)
read (iunps,*,err=100,iostat=ios) dummy !Wavefunction labels READ (iunps,*,err=100,iostat=ios) dummy !Wavefunction labels
read (iunps,*,err=100,iostat=ios) (chi(ir,nb,is), ir=1,mesh(is)) READ (iunps,*,err=100,iostat=ios) (chi(ir,nb,is), ir=1,mesh(is))
enddo ENDDO
100 call errore ('read_pseudo_pswfc', 'Reading pseudo file', abs(ios)) 100 CALL errore ('read_pseudo_pswfc', 'Reading pseudo file', abs(ios))
return RETURN
end subroutine read_pseudo_pswfc END SUBROUTINE read_pseudo_pswfc
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
subroutine read_pseudo_rhoatom (is, iunps) SUBROUTINE read_pseudo_rhoatom (is, iunps)
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
use pseudo USE pseudo
implicit none IMPLICIT NONE
! !
integer :: is, iunps INTEGER :: is, iunps
! !
integer :: ir, ios INTEGER :: ir, ios
read (iunps,*,err=100,iostat=ios) (rho_at(ir,is), ir=1,mesh(is)) READ (iunps,*,err=100,iostat=ios) (rho_at(ir,is), ir=1,mesh(is))
return RETURN
100 call errore ('read_pseudo_rhoatom','Reading pseudo file',abs(ios)) 100 CALL errore ('read_pseudo_rhoatom','Reading pseudo file',abs(ios))
end subroutine read_pseudo_rhoatom END SUBROUTINE read_pseudo_rhoatom

32
upftools/read_upf_tofile.f90
View File

@ -6,10 +6,10 @@
! or http://www.gnu.org/copyleft/gpl.txt . ! or http://www.gnu.org/copyleft/gpl.txt .
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
PROGRAM read_upf_tofile PROGRAM read_upf_tofile
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
! This small program reads the pseudopotential in the Unified ! This small program reads the pseudopotential in the Unified
! Pseudopotential Format and writes three files ! Pseudopotential Format and writes three files
! in a format which can be plotted. The files are: ! in a format which can be plotted. The files are:
! !
@ -21,10 +21,10 @@ PROGRAM read_upf_tofile
! PWSCF modules ! PWSCF modules
! !
! !
USE constants, only : fpi USE constants, ONLY : fpi
USE pseudo_types USE pseudo_types
USE upf_module USE upf_module
USE radial_grids, only : radial_grid_type, nullify_radial_grid USE radial_grids, ONLY : radial_grid_type, nullify_radial_grid
! !
IMPLICIT NONE IMPLICIT NONE
! !
@ -38,11 +38,11 @@ PROGRAM read_upf_tofile
TYPE (pseudo_upf) :: upf TYPE (pseudo_upf) :: upf
TYPE (radial_grid_type) :: grid TYPE (radial_grid_type) :: grid
! !
WRITE(6,'("Name of the upf file > ", $)') WRITE(6,'("Name of the upf file > ", $)')
READ(5,'(a)') file_pseudo READ(5,'(a)') file_pseudo
! nullify objects as soon as they are instantiated ! nullify objects as soon as they are instantiated
CALL nullify_pseudo_upf( upf ) CALL nullify_pseudo_upf( upf )
CALL nullify_radial_grid( grid ) CALL nullify_radial_grid( grid )
@ -53,39 +53,39 @@ PROGRAM read_upf_tofile
CALL read_upf(upf, grid, ierr, unit=iunps) CALL read_upf(upf, grid, ierr, unit=iunps)
! !
IF (ierr .NE. 0) & IF (ierr /= 0) &
CALL errore('read_upf_tofile','reading pseudo upf', ABS(ierr)) CALL errore('read_upf_tofile','reading pseudo upf', abs(ierr))
! !
CLOSE(iunps) CLOSE(iunps)
! !
OPEN(UNIT=iunps,FILE='filewfc',STATUS='unknown',FORM='formatted', & OPEN(UNIT=iunps,FILE='filewfc',STATUS='unknown',FORM='formatted', &
ERR=200, IOSTAT=ios) ERR=200, IOSTAT=ios)
200 CALL errore('read_upf_tofile','open error on file filewfc',ABS(ios)) 200 CALL errore('read_upf_tofile','open error on file filewfc',abs(ios))
DO n=1,upf%mesh DO n=1,upf%mesh
WRITE(iunps,'(30f12.6)') upf%r(n), (upf%chi(n,j), j=1,upf%nwfc) WRITE(iunps,'(30f12.6)') upf%r(n), (upf%chi(n,j), j=1,upf%nwfc)
END DO ENDDO
CLOSE(iunps) CLOSE(iunps)
OPEN(UNIT=iunps,FILE='filebeta',STATUS='unknown',FORM='formatted', & OPEN(UNIT=iunps,FILE='filebeta',STATUS='unknown',FORM='formatted', &
ERR=300, IOSTAT=ios) ERR=300, IOSTAT=ios)
300 CALL errore('read_upf_tofile','open error on file filebeta',ABS(ios)) 300 CALL errore('read_upf_tofile','open error on file filebeta',abs(ios))
DO n=1,upf%mesh DO n=1,upf%mesh
WRITE(iunps,'(30f12.6)') upf%r(n), (upf%beta(n,j), j=1,upf%nbeta) WRITE(iunps,'(30f12.6)') upf%r(n), (upf%beta(n,j), j=1,upf%nbeta)
END DO ENDDO
CLOSE(iunps) CLOSE(iunps)
OPEN(UNIT=iunps,FILE='filepot',STATUS='unknown',FORM='formatted', & OPEN(UNIT=iunps,FILE='filepot',STATUS='unknown',FORM='formatted', &
ERR=400, IOSTAT=ios) ERR=400, IOSTAT=ios)
400 CALL errore('read_upf_tofile','open error on file filepot',ABS(ios)) 400 CALL errore('read_upf_tofile','open error on file filepot',abs(ios))
DO n=1,upf%mesh DO n=1,upf%mesh
WRITE(iunps,'(4f12.6)') upf%r(n), upf%vloc(n), & WRITE(iunps,'(4f12.6)') upf%r(n), upf%vloc(n), &
upf%rho_at(n), upf%rho_atc(n)*fpi*upf%r(n)**2 upf%rho_at(n), upf%rho_atc(n)*fpi*upf%r(n)**2
END DO ENDDO
CLOSE(iunps) CLOSE(iunps)

308
upftools/rrkj2upf.f90
View File

@ -7,178 +7,178 @@
! !
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
program rrkj2upf PROGRAM rrkj2upf
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
! Convert a pseudopotential written in "rrkj3" format ! Convert a pseudopotential written in "rrkj3" format
! (Rabe-Rappe-Kaxiras-Joannopoulos with 3 Bessel functions) ! (Rabe-Rappe-Kaxiras-Joannopoulos with 3 Bessel functions)
! to unified pseudopotential format ! to unified pseudopotential format
! !
implicit none IMPLICIT NONE
character(len=256) filein, fileout CHARACTER(len=256) filein, fileout
! !
! !
call get_file ( filein ) CALL get_file ( filein )
open (unit = 1, file = filein, status = 'old', form = 'formatted') OPEN (unit = 1, file = filein, status = 'old', form = 'formatted')
call read_rrkj(1) CALL read_rrkj(1)
close (1) CLOSE (1)
! convert variables read from rrkj3 format into those needed ! convert variables read from rrkj3 format into those needed
! by the upf format - add missing quantities ! by the upf format - add missing quantities
call convert_rrkj CALL convert_rrkj
fileout=trim(filein)//'.UPF' fileout=trim(filein)//'.UPF'
print '(''Output PP file in UPF format : '',a)', fileout PRINT '(''Output PP file in UPF format : '',a)', fileout
open(unit=2,file=fileout,status='unknown',form='formatted') OPEN(unit=2,file=fileout,status='unknown',form='formatted')
call write_upf(2) CALL write_upf(2)
close (unit=2) CLOSE (unit=2)
stop STOP
20 write (6,'("rrkj2upf: error reading pseudopotential file name")') 20 WRITE (6,'("rrkj2upf: error reading pseudopotential file name")')
stop STOP
end program rrkj2upf END PROGRAM rrkj2upf
module rrkj3 MODULE rrkj3
! !
! All variables read from RRKJ3 file format ! All variables read from RRKJ3 file format
! !
! trailing underscore means that a variable with the same name ! trailing underscore means that a variable with the same name
! is used in module 'upf' containing variables to be written ! is used in module 'upf' containing variables to be written
! !
character(len=75):: titleps CHARACTER(len=75):: titleps
character (len=2), allocatable :: els_(:) CHARACTER (len=2), ALLOCATABLE :: els_(:)
integer :: pseudotype_, iexch_, icorr_, igcx_, igcc_, mesh_, & INTEGER :: pseudotype_, iexch_, icorr_, igcx_, igcc_, mesh_, &
nwfs_, nbeta_, lmax_ nwfs_, nbeta_, lmax_
logical :: rel_, nlcc_ LOGICAL :: rel_, nlcc_
real (8) :: zp_, etotps_, xmin, rmax, zmesh, dx, rcloc_ real (8) :: zp_, etotps_, xmin, rmax, zmesh, dx, rcloc_
integer, allocatable:: lchi_(:), nns_(:), ikk2_(:) INTEGER, ALLOCATABLE:: lchi_(:), nns_(:), ikk2_(:)
real (8), allocatable :: rcut_(:), rcutus_(:), oc_(:), & real (8), ALLOCATABLE :: rcut_(:), rcutus_(:), oc_(:), &
beta(:,:), dion_(:,:), qqq_(:,:), ddd(:,:), qfunc_(:,:,:), & beta(:,:), dion_(:,:), qqq_(:,:), ddd(:,:), qfunc_(:,:,:), &
rho_atc_(:), rho_at_(:), chi_(:,:), vloc_(:) rho_atc_(:), rho_at_(:), chi_(:,:), vloc_(:)
end module rrkj3 END MODULE rrkj3
! !
! ---------------------------------------------------------- ! ----------------------------------------------------------
subroutine read_rrkj(iunps) SUBROUTINE read_rrkj(iunps)
! ---------------------------------------------------------- ! ----------------------------------------------------------
! !
use rrkj3 USE rrkj3
implicit none IMPLICIT NONE
integer :: iunps INTEGER :: iunps
integer :: nb, mb, n, ir, ios INTEGER :: nb, mb, n, ir, ios
!--- > Start the header reading !--- > Start the header reading
read (iunps, '(a75)', err = 100) titleps READ (iunps, '(a75)', err = 100) titleps
read (iunps, *, err = 100) pseudotype_ READ (iunps, *, err = 100) pseudotype_
read (iunps, *, err = 100) rel_, nlcc_ READ (iunps, *, err = 100) rel_, nlcc_
read (iunps, *, err=100) iexch_, icorr_, igcx_, igcc_ READ (iunps, *, err=100) iexch_, icorr_, igcx_, igcc_
read (iunps, '(2e17.11,i5)') zp_, etotps_, lmax_ READ (iunps, '(2e17.11,i5)') zp_, etotps_, lmax_
read (iunps, '(4e17.11,i5)', err=100) xmin, rmax, zmesh, dx, mesh_ READ (iunps, '(4e17.11,i5)', err=100) xmin, rmax, zmesh, dx, mesh_
read (iunps, *, err=100) nwfs_, nbeta_ READ (iunps, *, err=100) nwfs_, nbeta_
allocate(rcut_(nwfs_), rcutus_(nwfs_)) ALLOCATE(rcut_(nwfs_), rcutus_(nwfs_))
read (iunps, *, err=100) (rcut_(nb), nb=1,nwfs_) READ (iunps, *, err=100) (rcut_(nb), nb=1,nwfs_)
read (iunps, *, err=100) (rcutus_(nb), nb=1,nwfs_) READ (iunps, *, err=100) (rcutus_(nb), nb=1,nwfs_)
allocate(els_(nwfs_), nns_(nwfs_), lchi_(nwfs_), oc_(nwfs_)) ALLOCATE(els_(nwfs_), nns_(nwfs_), lchi_(nwfs_), oc_(nwfs_))
do nb = 1, nwfs_ DO nb = 1, nwfs_
read (iunps, '(a2,2i3,f6.2)', err = 100) els_(nb), & READ (iunps, '(a2,2i3,f6.2)', err = 100) els_(nb), &
nns_(nb), lchi_(nb) , oc_(nb) nns_(nb), lchi_(nb) , oc_(nb)
enddo ENDDO
allocate(ikk2_(nbeta_)) ALLOCATE(ikk2_(nbeta_))
allocate(beta( mesh_,nbeta_)) ALLOCATE(beta( mesh_,nbeta_))
allocate(dion_(nbeta_,nbeta_)) ALLOCATE(dion_(nbeta_,nbeta_))
allocate(ddd (nbeta_,nbeta_)) ALLOCATE(ddd (nbeta_,nbeta_))
allocate(qqq_(nbeta_,nbeta_)) ALLOCATE(qqq_(nbeta_,nbeta_))
allocate(qfunc_(mesh_,nbeta_,nbeta_)) ALLOCATE(qfunc_(mesh_,nbeta_,nbeta_))
do nb = 1, nbeta_ DO nb = 1, nbeta_
read (iunps, *, err = 100) ikk2_(nb) READ (iunps, *, err = 100) ikk2_(nb)
read (iunps, *, err = 100) (beta (ir, nb) , ir = 1,ikk2_(nb) ) READ (iunps, *, err = 100) (beta (ir, nb) , ir = 1,ikk2_(nb) )
do ir = ikk2_(nb) + 1, mesh_ DO ir = ikk2_(nb) + 1, mesh_
beta (ir, nb) = 0.d0 beta (ir, nb) = 0.d0
enddo ENDDO
do mb = 1, nb DO mb = 1, nb
read (iunps, *, err = 100) dion_(nb, mb) READ (iunps, *, err = 100) dion_(nb, mb)
dion_(mb, nb) = dion_(nb, mb) dion_(mb, nb) = dion_(nb, mb)
if (pseudotype_.eq.3) then IF (pseudotype_==3) THEN
read (iunps, *, err = 100) qqq_(nb, mb) READ (iunps, *, err = 100) qqq_(nb, mb)
qqq_(mb, nb) = qqq_(nb, mb) qqq_(mb, nb) = qqq_(nb, mb)
read (iunps, *, err = 100) (qfunc_(n,nb, mb), n = 1, mesh_) READ (iunps, *, err = 100) (qfunc_(n,nb, mb), n = 1, mesh_)
do n = 1, mesh_ DO n = 1, mesh_
qfunc_(n, mb, nb) = qfunc_(n, nb, mb) qfunc_(n, mb, nb) = qfunc_(n, nb, mb)
enddo ENDDO
else ELSE
qqq_(nb, mb) = 0.d0 qqq_(nb, mb) = 0.d0
qqq_(mb, nb) = 0.d0 qqq_(mb, nb) = 0.d0
do n = 1, mesh_ DO n = 1, mesh_
qfunc_(n, nb, mb) = 0.d0 qfunc_(n, nb, mb) = 0.d0
qfunc_(n, mb, nb) = 0.d0 qfunc_(n, mb, nb) = 0.d0
enddo ENDDO
endif ENDIF
enddo ENDDO
enddo ENDDO
! !
! read the local potential ! read the local potential
! !
allocate(vloc_(mesh_)) ALLOCATE(vloc_(mesh_))
read (iunps, *, err = 100) rcloc_, (vloc_(ir ) , ir = 1, mesh_ ) READ (iunps, *, err = 100) rcloc_, (vloc_(ir ) , ir = 1, mesh_ )
! !
! read the atomic charge ! read the atomic charge
! !
allocate(rho_at_(mesh_)) ALLOCATE(rho_at_(mesh_))
read (iunps, *, err=100) (rho_at_(ir), ir=1,mesh_) READ (iunps, *, err=100) (rho_at_(ir), ir=1,mesh_)
! !
! if present read the core charge ! if present read the core charge
! !
allocate(rho_atc_(mesh_)) ALLOCATE(rho_atc_(mesh_))
if (nlcc_) then IF (nlcc_) THEN
read (iunps, *, err=100) (rho_atc_(ir), ir=1, mesh_) READ (iunps, *, err=100) (rho_atc_(ir), ir=1, mesh_)
endif ENDIF
! !
! read the pseudo wavefunctions of the atom ! read the pseudo wavefunctions of the atom
! !
allocate(chi_(mesh_,nwfs_)) ALLOCATE(chi_(mesh_,nwfs_))
read (iunps, *, err=100) ( (chi_(ir,nb), ir = 1,mesh_) , nb = 1, nwfs_) READ (iunps, *, err=100) ( (chi_(ir,nb), ir = 1,mesh_) , nb = 1, nwfs_)
! !
! ---------------------------------------------------------- ! ----------------------------------------------------------
write (6,'(a)') 'Pseudopotential successfully read' WRITE (6,'(a)') 'Pseudopotential successfully read'
! ---------------------------------------------------------- ! ----------------------------------------------------------
! !
return RETURN
100 write (6,'("read_rrkj: error reading pseudopotential file")') 100 WRITE (6,'("read_rrkj: error reading pseudopotential file")')
stop STOP
end subroutine read_rrkj END SUBROUTINE read_rrkj
subroutine convert_rrkj SUBROUTINE convert_rrkj
! ---------------------------------------------------------- ! ----------------------------------------------------------
! !
use rrkj3 USE rrkj3
use upf USE upf
use constants, only : fpi USE constants, ONLY : fpi
implicit none IMPLICIT NONE
integer i, n INTEGER i, n
real(8) :: x real(8) :: x
write(generated, '("Generated using Andrea Dal Corso code (rrkj3)")') WRITE(generated, '("Generated using Andrea Dal Corso code (rrkj3)")')
write(date_author,'("Author: Andrea Dal Corso Generation date: unknown")') WRITE(date_author,'("Author: Andrea Dal Corso Generation date: unknown")')
comment = 'Info:'//titleps comment = 'Info:'//titleps
if (rel_) then IF (rel_) THEN
rel = 1 rel = 1
else ELSE
rel = 0 rel = 0
end if ENDIF
rcloc = rcloc_ rcloc = rcloc_
nwfs = nwfs_ nwfs = nwfs_
allocate( els(nwfs), oc(nwfs), epseu(nwfs)) ALLOCATE( els(nwfs), oc(nwfs), epseu(nwfs))
allocate(lchi(nwfs), nns(nwfs) ) ALLOCATE(lchi(nwfs), nns(nwfs) )
allocate(rcut (nwfs), rcutus (nwfs)) ALLOCATE(rcut (nwfs), rcutus (nwfs))
do i=1, nwfs DO i=1, nwfs
nns (i) = nns_(i) nns (i) = nns_(i)
lchi(i) = lchi_(i) lchi(i) = lchi_(i)
rcut(i) = rcut_(i) rcut(i) = rcut_(i)
@ -186,15 +186,15 @@ subroutine convert_rrkj
oc (i) = oc_(i) oc (i) = oc_(i)
els(i) = els_(i) els(i) = els_(i)
epseu(i) = 0.0d0 epseu(i) = 0.0d0
end do ENDDO
deallocate (els_, oc_, rcutus_, rcut_, nns_) DEALLOCATE (els_, oc_, rcutus_, rcut_, nns_)
psd = titleps (7:8) psd = titleps (7:8)
if (pseudotype_.eq.3) then IF (pseudotype_==3) THEN
pseudotype = 'US' pseudotype = 'US'
else ELSE
pseudotype = 'NC' pseudotype = 'NC'
endif ENDIF
nlcc = nlcc_ nlcc = nlcc_
zp = zp_ zp = zp_
etotps = etotps_ etotps = etotps_
@ -204,85 +204,85 @@ subroutine convert_rrkj
mesh = mesh_ mesh = mesh_
nbeta = nbeta_ nbeta = nbeta_
ntwfc = 0 ntwfc = 0
do i=1, nwfs DO i=1, nwfs
if (oc(i) .gt. 1.0d-12) ntwfc = ntwfc + 1 IF (oc(i) > 1.0d-12) ntwfc = ntwfc + 1
end do ENDDO
allocate( elsw(ntwfc), ocw(ntwfc), lchiw(ntwfc) ) ALLOCATE( elsw(ntwfc), ocw(ntwfc), lchiw(ntwfc) )
n = 0 n = 0
do i=1, nwfs DO i=1, nwfs
if (oc(i) .gt. 1.0d-12) then IF (oc(i) > 1.0d-12) THEN
n = n + 1 n = n + 1
elsw(n) = els(i) elsw(n) = els(i)
ocw (n) = oc (i) ocw (n) = oc (i)
lchiw(n)=lchi(i) lchiw(n)=lchi(i)
end if ENDIF
end do ENDDO
iexch = iexch_ iexch = iexch_
icorr = icorr_ icorr = icorr_
igcx = igcx_ igcx = igcx_
igcc = igcc_ igcc = igcc_
allocate(rab(mesh)) ALLOCATE(rab(mesh))
allocate( r(mesh)) ALLOCATE( r(mesh))
! define logarithmic mesh ! define logarithmic mesh
do i = 1, mesh DO i = 1, mesh
x = xmin + DBLE(i-1) * dx x = xmin + dble(i-1) * dx
r (i) = exp(x) / zmesh r (i) = exp(x) / zmesh
rab(i) = dx * r(i) rab(i) = dx * r(i)
end do ENDDO
allocate (rho_atc(mesh)) ALLOCATE (rho_atc(mesh))
! rrkj rho_core(r) = 4pi*r^2*rho_core(r) UPF ! rrkj rho_core(r) = 4pi*r^2*rho_core(r) UPF
rho_atc (:) = rho_atc_(:) / fpi / r(:)**2 rho_atc (:) = rho_atc_(:) / fpi / r(:)**2
deallocate (rho_atc_) DEALLOCATE (rho_atc_)
allocate (vloc0(mesh)) ALLOCATE (vloc0(mesh))
vloc0 = vloc_ vloc0 = vloc_
deallocate (vloc_) DEALLOCATE (vloc_)
allocate(ikk2(nbeta), lll(nbeta)) ALLOCATE(ikk2(nbeta), lll(nbeta))
ikk2 = ikk2_ ikk2 = ikk2_
lll = lchi_ lll = lchi_
deallocate (ikk2_, lchi_) DEALLOCATE (ikk2_, lchi_)
! kkbeta = 0 ! kkbeta = 0
! do nb=1,nbeta ! do nb=1,nbeta
! kkbeta = max (kkbeta , ikk2(nb) ) ! kkbeta = max (kkbeta , ikk2(nb) )
! end do ! end do
allocate(betar(mesh,nbeta)) ALLOCATE(betar(mesh,nbeta))
betar = 0.0d0 betar = 0.0d0
do i=1, nbeta DO i=1, nbeta
betar(1:ikk2(i),i) = beta(1:ikk2(i),i) betar(1:ikk2(i),i) = beta(1:ikk2(i),i)
end do ENDDO
deallocate (beta) DEALLOCATE (beta)
allocate(dion(nbeta,nbeta)) ALLOCATE(dion(nbeta,nbeta))
dion = dion_ dion = dion_
deallocate (dion_) DEALLOCATE (dion_)
allocate(qqq(nbeta,nbeta)) ALLOCATE(qqq(nbeta,nbeta))
qqq = qqq_ qqq = qqq_
deallocate (qqq_) DEALLOCATE (qqq_)
allocate(qfunc(mesh,nbeta,nbeta)) ALLOCATE(qfunc(mesh,nbeta,nbeta))
qfunc = qfunc_ qfunc = qfunc_
nqf = 0 nqf = 0
nqlc= 0 nqlc= 0
allocate (rho_at(mesh)) ALLOCATE (rho_at(mesh))
rho_at = rho_at_ rho_at = rho_at_
deallocate (rho_at_) DEALLOCATE (rho_at_)
allocate (chi(mesh,ntwfc)) ALLOCATE (chi(mesh,ntwfc))
n = 0 n = 0
do i=1, nwfs DO i=1, nwfs
if (oc(i) .gt. 1.0d-12) then IF (oc(i) > 1.0d-12) THEN
n = n + 1 n = n + 1
chi(:,n) = chi_(:,i) chi(:,n) = chi_(:,i)
end if ENDIF
end do ENDDO
deallocate (chi_) DEALLOCATE (chi_)
return RETURN
end subroutine convert_rrkj END SUBROUTINE convert_rrkj

32
upftools/uspp2upf.f90
View File

@ -7,35 +7,35 @@
! !
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
program uspp2upf PROGRAM uspp2upf
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
! Convert a pseudopotential written in Vanderbilt format ! Convert a pseudopotential written in Vanderbilt format
! (unformatted) to unified pseudopotential format ! (unformatted) to unified pseudopotential format
! !
implicit none IMPLICIT NONE
character(len=256) filein, fileout CHARACTER(len=256) filein, fileout
! !
! !
call get_file ( filein ) CALL get_file ( filein )
open(unit=1,file=filein,status='old',form='unformatted') OPEN(unit=1,file=filein,status='old',form='unformatted')
call read_uspp(1) CALL read_uspp(1)
close (unit=1) CLOSE (unit=1)
! convert variables read from Vanderbilt format into those needed ! convert variables read from Vanderbilt format into those needed
! by the upf format - add missing quantities ! by the upf format - add missing quantities
call convert_uspp CALL convert_uspp
fileout=trim(filein)//'.UPF' fileout=trim(filein)//'.UPF'
print '(''Output PP file in UPF format : '',a)', fileout PRINT '(''Output PP file in UPF format : '',a)', fileout
open(unit=2,file=fileout,status='unknown',form='formatted') OPEN(unit=2,file=fileout,status='unknown',form='formatted')
call write_upf(2) CALL write_upf(2)
close (unit=2) CLOSE (unit=2)
stop STOP
20 write (6,'("uspp2upf: error reading pseudopotential file name")') 20 WRITE (6,'("uspp2upf: error reading pseudopotential file name")')
stop STOP
end program uspp2upf END PROGRAM uspp2upf

414
upftools/vanderbilt.f90
View File

@ -6,273 +6,273 @@
! or http://www.gnu.org/copyleft/gpl.txt . ! or http://www.gnu.org/copyleft/gpl.txt .
! !
! !
module Vanderbilt MODULE Vanderbilt
! !
! All variables read from Vanderbilt's file format ! All variables read from Vanderbilt's file format
! !
! trailing underscore means that a variable with the same name ! trailing underscore means that a variable with the same name
! is used in module 'upf' containing variables to be written ! is used in module 'upf' containing variables to be written
! !
integer :: nvalps, nang, nbeta_, kkbeta, nchi, ifpcor, keyps, & INTEGER :: nvalps, nang, nbeta_, kkbeta, nchi, ifpcor, keyps, &
mesh_, iver(3), idmy(3), nnlz, ifqopt, nqf_, irel, npf, & mesh_, iver(3), idmy(3), nnlz, ifqopt, nqf_, irel, npf, &
nlc, lloc nlc, lloc
real(8) :: z_, zp_, exfact, etot, eloc, rcloc_, rpcor, & real(8) :: z_, zp_, exfact, etot, eloc, rcloc_, rpcor, &
qtryc, ptryc, rinner1_ qtryc, ptryc, rinner1_
real(8), allocatable:: wwnlps(:), eeps(:), rinner_(:), rc(:), & real(8), ALLOCATABLE:: wwnlps(:), eeps(:), rinner_(:), rc(:), &
beta(:,:), ddd0(:,:), ddd(:,:), qqq_(:,:), eee(:), rho_atc_(:), & beta(:,:), ddd0(:,:), ddd(:,:), qqq_(:,:), eee(:), rho_atc_(:), &
r_(:), rab_(:), rho_at_(:), qfunc_(:,:,:), vloc(:), vloc_(:), & r_(:), rab_(:), rho_at_(:), qfunc_(:,:,:), vloc(:), vloc_(:), &
wf(:,:), qfcoef_(:,:,:,:) wf(:,:), qfcoef_(:,:,:,:)
integer, allocatable :: lll_(:), nnlzps(:), iptype(:) INTEGER, ALLOCATABLE :: lll_(:), nnlzps(:), iptype(:)
Character(len=20):: title CHARACTER(len=20):: title
end module Vanderbilt END MODULE Vanderbilt
! !
! ---------------------------------------------------------- ! ----------------------------------------------------------
subroutine read_uspp(iunit) SUBROUTINE read_uspp(iunit)
! ---------------------------------------------------------- ! ----------------------------------------------------------
! !
use Vanderbilt USE Vanderbilt
implicit none IMPLICIT NONE
integer :: iunit INTEGER :: iunit
! !
integer :: i, j, k, lp INTEGER :: i, j, k, lp
real(8) :: rinner1 real(8) :: rinner1
! !
! !
read (iunit) (iver(i),i=1,3),(idmy(i),i=1,3) READ (iunit) (iver(i),i=1,3),(idmy(i),i=1,3)
read (iunit) title, z_, zp_, exfact, nvalps, mesh_, etot READ (iunit) title, z_, zp_, exfact, nvalps, mesh_, etot
allocate(nnlzps(nvalps), wwnlps(nvalps), eeps(nvalps)) ALLOCATE(nnlzps(nvalps), wwnlps(nvalps), eeps(nvalps))
read (iunit) (nnlzps(i),wwnlps(i),eeps(i),i=1,nvalps) READ (iunit) (nnlzps(i),wwnlps(i),eeps(i),i=1,nvalps)
read (iunit) keyps, ifpcor, rinner1 READ (iunit) keyps, ifpcor, rinner1
if ( iver(1) .eq. 1 ) then IF ( iver(1) == 1 ) THEN
nang = nvalps nang = nvalps
nqf_ = 3 nqf_ = 3
nlc = 5 nlc = 5
elseif ( iver(1) .eq. 2 ) then ELSEIF ( iver(1) == 2 ) THEN
nang = nvalps nang = nvalps
nqf_ = 3 nqf_ = 3
nlc = 2 * nvalps - 1 nlc = 2 * nvalps - 1
else if ( iver(1) .ge. 3 ) then ELSEIF ( iver(1) >= 3 ) THEN
read (iunit) nang, lloc, eloc, ifqopt, nqf_, qtryc READ (iunit) nang, lloc, eloc, ifqopt, nqf_, qtryc
nlc = 2 * nang - 1 nlc = 2 * nang - 1
endif ENDIF
allocate(rinner_(2*nang-1)) ALLOCATE(rinner_(2*nang-1))
rinner_(1) = rinner1 rinner_(1) = rinner1
rinner1_ = rinner1 rinner1_ = rinner1
if (10*iver(1)+iver(2).ge.51) & IF (10*iver(1)+iver(2)>=51) &
read (iunit) (rinner_(i),i=1,nang*2-1) READ (iunit) (rinner_(i),i=1,nang*2-1)
if ( iver(1) .ge. 4 ) then IF ( iver(1) >= 4 ) THEN
read (iunit) irel READ (iunit) irel
else ELSE
irel = 0 irel = 0
end if ENDIF
allocate(rc(nang)) ALLOCATE(rc(nang))
read (iunit) (rc(i),i=1,nang) READ (iunit) (rc(i),i=1,nang)
read (iunit) nbeta_,kkbeta READ (iunit) nbeta_,kkbeta
! !
allocate(beta(kkbeta,nbeta_)) ALLOCATE(beta(kkbeta,nbeta_))
allocate(qfunc_(kkbeta,nbeta_,nbeta_)) ALLOCATE(qfunc_(kkbeta,nbeta_,nbeta_))
allocate(ddd0(nbeta_,nbeta_)) ALLOCATE(ddd0(nbeta_,nbeta_))
allocate(ddd (nbeta_,nbeta_)) ALLOCATE(ddd (nbeta_,nbeta_))
allocate(qqq_(nbeta_,nbeta_)) ALLOCATE(qqq_(nbeta_,nbeta_))
allocate(lll_(nbeta_)) ALLOCATE(lll_(nbeta_))
allocate(eee(nbeta_)) ALLOCATE(eee(nbeta_))
allocate(qfcoef_(nqf_,nlc,nbeta_,nbeta_)) ALLOCATE(qfcoef_(nqf_,nlc,nbeta_,nbeta_))
! !
do j=1,nbeta_ DO j=1,nbeta_
read (iunit) lll_(j),eee(j),(beta(i,j),i=1,kkbeta) READ (iunit) lll_(j),eee(j),(beta(i,j),i=1,kkbeta)
do k=j,nbeta_ DO k=j,nbeta_
read (iunit) ddd0(j,k),ddd(j,k),qqq_(j,k), & READ (iunit) ddd0(j,k),ddd(j,k),qqq_(j,k), &
(qfunc_(i,j,k),i=1,kkbeta), & (qfunc_(i,j,k),i=1,kkbeta), &
((qfcoef_(i,lp,j,k),i=1,nqf_),lp=1,2*nang-1) ((qfcoef_(i,lp,j,k),i=1,nqf_),lp=1,2*nang-1)
end do ENDDO
end do ENDDO
! !
allocate(iptype(nbeta_)) ALLOCATE(iptype(nbeta_))
if (10*iver(1)+iver(2).ge.72) & IF (10*iver(1)+iver(2)>=72) &
read (iunit) (iptype(j),j=1,nbeta_),npf,ptryc READ (iunit) (iptype(j),j=1,nbeta_),npf,ptryc
! !
allocate(vloc_(mesh_)) ALLOCATE(vloc_(mesh_))
read (iunit) rcloc_,(vloc_(i),i=1,mesh_) READ (iunit) rcloc_,(vloc_(i),i=1,mesh_)
! !
allocate(rho_atc_(mesh_)) ALLOCATE(rho_atc_(mesh_))
if (ifpcor.gt.0) then IF (ifpcor>0) THEN
read (iunit) rpcor READ (iunit) rpcor
read (iunit) (rho_atc_(i),i=1,mesh_) READ (iunit) (rho_atc_(i),i=1,mesh_)
end if ENDIF
! !
allocate(rho_at_(mesh_), vloc(mesh_)) ALLOCATE(rho_at_(mesh_), vloc(mesh_))
read (iunit) (vloc(i),i=1,mesh_) READ (iunit) (vloc(i),i=1,mesh_)
read (iunit) (rho_at_(i),i=1,mesh_) READ (iunit) (rho_at_(i),i=1,mesh_)
allocate(r_(mesh_), rab_(mesh_)) ALLOCATE(r_(mesh_), rab_(mesh_))
read (iunit) (r_(i),i=1,mesh_) READ (iunit) (r_(i),i=1,mesh_)
read (iunit) (rab_(i),i=1,mesh_) READ (iunit) (rab_(i),i=1,mesh_)
if (iver(1) .ge. 6) then IF (iver(1) >= 6) THEN
nchi = nvalps nchi = nvalps
if (iver(1) .ge. 7) read (iunit) nchi IF (iver(1) >= 7) READ (iunit) nchi
allocate(wf(mesh_,nchi)) ALLOCATE(wf(mesh_,nchi))
read (iunit) ((wf(i,j), i=1,mesh_),j=1,nchi) READ (iunit) ((wf(i,j), i=1,mesh_),j=1,nchi)
end if ENDIF
! !
! ---------------------------------------------------------- ! ----------------------------------------------------------
write (6,'(a)') 'Pseudopotential successfully read' WRITE (6,'(a)') 'Pseudopotential successfully read'
! ---------------------------------------------------------- ! ----------------------------------------------------------
! !
end subroutine read_uspp END SUBROUTINE read_uspp
! ---------------------------------------------------------- ! ----------------------------------------------------------
! ---------------------------------------------------------- ! ----------------------------------------------------------
subroutine read_vdb(iunit) SUBROUTINE read_vdb(iunit)
! ---------------------------------------------------------- ! ----------------------------------------------------------
! !
use Vanderbilt USE Vanderbilt
implicit none IMPLICIT NONE
integer :: iunit INTEGER :: iunit
! !
integer :: i, j, k, lp INTEGER :: i, j, k, lp
real(8) :: rinner1 real(8) :: rinner1
! !
! !
read(iunit, *) (iver(i),i=1,3),(idmy(i),i=1,3) READ(iunit, *) (iver(i),i=1,3),(idmy(i),i=1,3)
read(iunit,'(a20,3f15.9)' ) title, z_, zp_, exfact READ(iunit,'(a20,3f15.9)' ) title, z_, zp_, exfact
read(iunit, *) nvalps, mesh_, etot READ(iunit, *) nvalps, mesh_, etot
allocate(nnlzps(nvalps), wwnlps(nvalps), eeps(nvalps)) ALLOCATE(nnlzps(nvalps), wwnlps(nvalps), eeps(nvalps))
do i = 1,nvalps DO i = 1,nvalps
read(iunit, *) nnlzps(i), wwnlps(i), eeps(i) READ(iunit, *) nnlzps(i), wwnlps(i), eeps(i)
end do ENDDO
read(iunit, *) keyps, ifpcor, rinner1 READ(iunit, *) keyps, ifpcor, rinner1
if ( iver(1) .eq. 1 ) then IF ( iver(1) == 1 ) THEN
nang = nvalps nang = nvalps
nqf_ = 3 nqf_ = 3
nlc = 5 nlc = 5
elseif ( iver(1) .eq. 2 ) then ELSEIF ( iver(1) == 2 ) THEN
nang = nvalps nang = nvalps
nqf_ = 3 nqf_ = 3
nlc = 2 * nvalps - 1 nlc = 2 * nvalps - 1
else if ( iver(1) .ge. 3 ) then ELSEIF ( iver(1) >= 3 ) THEN
read(iunit, *) nang, lloc, eloc, ifqopt, nqf_, qtryc READ(iunit, *) nang, lloc, eloc, ifqopt, nqf_, qtryc
nlc = 2 * nang - 1 nlc = 2 * nang - 1
endif ENDIF
allocate(rinner_(2*nang-1)) ALLOCATE(rinner_(2*nang-1))
rinner_(1) = rinner1 rinner_(1) = rinner1
if (10*iver(1)+iver(2).ge.51) & IF (10*iver(1)+iver(2)>=51) &
read (iunit, *) (rinner_(i),i=1,nang*2-1) READ (iunit, *) (rinner_(i),i=1,nang*2-1)
if ( iver(1) .ge. 4 ) then IF ( iver(1) >= 4 ) THEN
read (iunit, *) irel READ (iunit, *) irel
else ELSE
irel = 0 irel = 0
end if ENDIF
allocate(rc(nang)) ALLOCATE(rc(nang))
read(iunit, *) ( rc(i), i=1,nang) READ(iunit, *) ( rc(i), i=1,nang)
read (iunit,* ) nbeta_, kkbeta READ (iunit,* ) nbeta_, kkbeta
allocate(beta(kkbeta,nbeta_)) ALLOCATE(beta(kkbeta,nbeta_))
allocate(qfunc_(kkbeta,nbeta_,nbeta_)) ALLOCATE(qfunc_(kkbeta,nbeta_,nbeta_))
allocate(ddd0(nbeta_,nbeta_)) ALLOCATE(ddd0(nbeta_,nbeta_))
allocate(ddd (nbeta_,nbeta_)) ALLOCATE(ddd (nbeta_,nbeta_))
allocate(qqq_(nbeta_,nbeta_)) ALLOCATE(qqq_(nbeta_,nbeta_))
allocate(lll_(nbeta_)) ALLOCATE(lll_(nbeta_))
allocate(eee (nbeta_)) ALLOCATE(eee (nbeta_))
allocate(qfcoef_(nqf_,nlc,nbeta_,nbeta_)) ALLOCATE(qfcoef_(nqf_,nlc,nbeta_,nbeta_))
do j=1,nbeta_ DO j=1,nbeta_
read ( iunit, *) lll_(j) READ ( iunit, *) lll_(j)
read ( iunit, *) eee(j), ( beta(i,j), i=1,kkbeta ) READ ( iunit, *) eee(j), ( beta(i,j), i=1,kkbeta )
do k=j,nbeta_ DO k=j,nbeta_
read( iunit, *) ddd0(j,k), ddd(j,k), qqq_(j,k), & READ( iunit, *) ddd0(j,k), ddd(j,k), qqq_(j,k), &
(qfunc_(i,j,k),i=1,kkbeta),& (qfunc_(i,j,k),i=1,kkbeta),&
((qfcoef_(i,lp,j,k),i=1,nqf_),lp=1,2*nang-1) ((qfcoef_(i,lp,j,k),i=1,nqf_),lp=1,2*nang-1)
enddo ENDDO
enddo ENDDO
allocate(iptype(nbeta_)) ALLOCATE(iptype(nbeta_))
if (10*iver(1)+iver(2).ge.72) then IF (10*iver(1)+iver(2)>=72) THEN
read ( iunit, * ) (iptype(i), i=1,nbeta_) READ ( iunit, * ) (iptype(i), i=1,nbeta_)
read ( iunit, * ) npf, ptryc READ ( iunit, * ) npf, ptryc
end if ENDIF
allocate(vloc_(mesh_)) ALLOCATE(vloc_(mesh_))
read(iunit, *) rcloc_, ( vloc_(i), i=1,mesh_) READ(iunit, *) rcloc_, ( vloc_(i), i=1,mesh_)
allocate(rho_atc_(mesh_))
if ( ifpcor.gt.0 ) then
read(iunit, *) rpcor
read(iunit, *) ( rho_atc_(i), i=1,mesh_)
endif
allocate(rho_at_(mesh_), vloc(mesh_)) ALLOCATE(rho_atc_(mesh_))
read(iunit, *) (vloc(i), i=1,mesh_) IF ( ifpcor>0 ) THEN
read(iunit, *) (rho_at_(i), i=1,mesh_) READ(iunit, *) rpcor
READ(iunit, *) ( rho_atc_(i), i=1,mesh_)
ENDIF
allocate(r_(mesh_),rab_(mesh_)) ALLOCATE(rho_at_(mesh_), vloc(mesh_))
read(iunit, *) (r_(i), i=1,mesh_) READ(iunit, *) (vloc(i), i=1,mesh_)
read(iunit, *) (rab_(i),i=1,mesh_) READ(iunit, *) (rho_at_(i), i=1,mesh_)
if (iver(1) .ge. 6) then ALLOCATE(r_(mesh_),rab_(mesh_))
READ(iunit, *) (r_(i), i=1,mesh_)
READ(iunit, *) (rab_(i),i=1,mesh_)
IF (iver(1) >= 6) THEN
nchi = nvalps nchi = nvalps
if (iver(1) .ge. 7) read (iunit, *) nchi IF (iver(1) >= 7) READ (iunit, *) nchi
allocate(wf(mesh_,nchi)) ALLOCATE(wf(mesh_,nchi))
read (iunit, *) ((wf(i,j), i=1,mesh_),j=1,nchi) READ (iunit, *) ((wf(i,j), i=1,mesh_),j=1,nchi)
end if ENDIF
return RETURN
end subroutine read_vdb END SUBROUTINE read_vdb
subroutine convert_uspp SUBROUTINE convert_uspp
! ---------------------------------------------------------- ! ----------------------------------------------------------
! !
use Vanderbilt USE Vanderbilt
use constants, only : fpi USE constants, ONLY : fpi
use upf USE upf
implicit none IMPLICIT NONE
integer i INTEGER i
character(len=1), dimension(0:3) :: convel=(/'S','P','D','F'/) CHARACTER(len=1), DIMENSION(0:3) :: convel=(/'S','P','D','F'/)
write(generated, '("Generated using Vanderbilt code, version ",3i3)') iver WRITE(generated, '("Generated using Vanderbilt code, version ",3i3)') iver
write(date_author,'("Author: unknown Generation date:",3i5)') idmy WRITE(date_author,'("Author: unknown Generation date:",3i5)') idmy
write(comment,'("Automatically converted from original format")') WRITE(comment,'("Automatically converted from original format")')
if (irel == 0) then IF (irel == 0) THEN
rel = 0 rel = 0
else if (irel == 1) then ELSEIF (irel == 1) THEN
rel = 2 rel = 2
else if (irel == 2) then ELSEIF (irel == 2) THEN
rel = 1 rel = 1
end if ENDIF
rcloc = rcloc_ rcloc = rcloc_
nwfs = nvalps nwfs = nvalps
allocate( els(nwfs), oc(nwfs), epseu(nwfs)) ALLOCATE( els(nwfs), oc(nwfs), epseu(nwfs))
allocate(lchi(nwfs), nns(nwfs) ) ALLOCATE(lchi(nwfs), nns(nwfs) )
allocate(rcut (nwfs), rcutus (nwfs)) ALLOCATE(rcut (nwfs), rcutus (nwfs))
do i=1, nwfs DO i=1, nwfs
nns (i) = nnlzps(i)/100 nns (i) = nnlzps(i)/100
lchi(i) = mod (nnlzps(i)/10,10) lchi(i) = mod (nnlzps(i)/10,10)
rcut(i) = rinner1_ rcut(i) = rinner1_
rcutus(i)= rc(lchi(i)+1) rcutus(i)= rc(lchi(i)+1)
oc (i) = wwnlps(i) oc (i) = wwnlps(i)
write(els(i),'(i1,a1)') nns(i), convel(lchi(i)) WRITE(els(i),'(i1,a1)') nns(i), convel(lchi(i))
epseu(i) = eeps(i) epseu(i) = eeps(i)
end do ENDDO
deallocate (nnlzps, rc, wwnlps, eeps) DEALLOCATE (nnlzps, rc, wwnlps, eeps)
psd = title psd = title
if (keyps.le.2) then IF (keyps<=2) THEN
pseudotype = 'NC' pseudotype = 'NC'
else ELSE
pseudotype = 'US' pseudotype = 'US'
end if ENDIF
nlcc = ifpcor.gt.0 nlcc = ifpcor>0
zp = zp_ zp = zp_
etotps = etot etotps = etot
ecutrho=0.0d0 ecutrho=0.0d0
@ -280,87 +280,87 @@ subroutine convert_uspp
lmax = nang - 1 lmax = nang - 1
mesh = mesh_ mesh = mesh_
nbeta = nbeta_ nbeta = nbeta_
if (nvalps .ne. nchi) then IF (nvalps /= nchi) THEN
print *, 'WARNING: verify info on atomic wavefunctions' PRINT *, 'WARNING: verify info on atomic wavefunctions'
end if ENDIF
ntwfc = nchi ntwfc = nchi
allocate( elsw(ntwfc), ocw(ntwfc), lchiw(ntwfc) ) ALLOCATE( elsw(ntwfc), ocw(ntwfc), lchiw(ntwfc) )
do i=1, min(ntwfc,nwfs) DO i=1, min(ntwfc,nwfs)
elsw(i) = els(i) elsw(i) = els(i)
ocw(i) = oc (i) ocw(i) = oc (i)
lchiw(i)=lchi(i) lchiw(i)=lchi(i)
end do ENDDO
if ( exfact.eq.0) then IF ( exfact==0) THEN
iexch=1; icorr=1; igcx=0; igcc=0 ! Perdew-Zunger iexch=1; icorr=1; igcx=0; igcc=0 ! Perdew-Zunger
else if ( exfact.eq.1) then ELSEIF ( exfact==1) THEN
iexch=1; icorr=3; igcx=1; igcc=3 ! Becke-Lee-Yang-Parr iexch=1; icorr=3; igcx=1; igcc=3 ! Becke-Lee-Yang-Parr
else if ( exfact.eq.2) then ELSEIF ( exfact==2) THEN
iexch=1; icorr=1; igcx=1; igcc=0 ! Becke88 exchange iexch=1; icorr=1; igcx=1; igcc=0 ! Becke88 exchange
else if (exfact.eq.-5.or.exfact.eq.3) then ELSEIF (exfact==-5.or.exfact==3) THEN
iexch=1; icorr=1; igcx=1; igcc=1 ! Becke88-Perdew 86 iexch=1; icorr=1; igcx=1; igcc=1 ! Becke88-Perdew 86
else if (exfact.eq.-6.or.exfact.eq.4) then ELSEIF (exfact==-6.or.exfact==4) THEN
iexch=1; icorr=4; igcx=2; igcc=2 ! Perdew-Wang 91 iexch=1; icorr=4; igcx=2; igcc=2 ! Perdew-Wang 91
else if (exfact.eq. 5) then ELSEIF (exfact== 5) THEN
iexch=1; icorr=4; igcx=3; igcc=4 ! Perdew-Becke-Erkerhof iexch=1; icorr=4; igcx=3; igcc=4 ! Perdew-Becke-Erkerhof
else ELSE
write (6,'("convert: wrong xc in pseudopotential ",f12.6)') exfact WRITE (6,'("convert: wrong xc in pseudopotential ",f12.6)') exfact
stop STOP
end if ENDIF
allocate (r(mesh), rab(mesh)) ALLOCATE (r(mesh), rab(mesh))
r = r_ r = r_
rab=rab_ rab=rab_
deallocate (r_, rab_) DEALLOCATE (r_, rab_)
allocate (rho_atc(mesh)) ALLOCATE (rho_atc(mesh))
! Vanderbilt rho_core(r) = 4pi*r^2*rho_core(r) UPF ! Vanderbilt rho_core(r) = 4pi*r^2*rho_core(r) UPF
rho_atc (1) = 0.d0 rho_atc (1) = 0.d0
rho_atc (2:mesh) = rho_atc_(2:mesh) / fpi / r(2:mesh)**2 rho_atc (2:mesh) = rho_atc_(2:mesh) / fpi / r(2:mesh)**2
deallocate (rho_atc_) DEALLOCATE (rho_atc_)
allocate (vloc0(mesh)) ALLOCATE (vloc0(mesh))
vloc0(2:mesh) = vloc_(2:mesh)/r(2:mesh) vloc0(2:mesh) = vloc_(2:mesh)/r(2:mesh)
vloc0(1) = vloc0(2) vloc0(1) = vloc0(2)
deallocate (vloc_) DEALLOCATE (vloc_)
allocate(ikk2(nbeta), lll(nbeta)) ALLOCATE(ikk2(nbeta), lll(nbeta))
ikk2 = kkbeta ikk2 = kkbeta
lll = lll_ lll = lll_
deallocate (lll_) DEALLOCATE (lll_)
allocate(betar(kkbeta,nbeta)) ALLOCATE(betar(kkbeta,nbeta))
betar = beta betar = beta
deallocate (beta) DEALLOCATE (beta)
allocate(dion(nbeta,nbeta)) ALLOCATE(dion(nbeta,nbeta))
dion = ddd0 dion = ddd0
deallocate (ddd0) DEALLOCATE (ddd0)
allocate(qqq(nbeta,nbeta)) ALLOCATE(qqq(nbeta,nbeta))
qqq = qqq_ qqq = qqq_
deallocate (qqq_) DEALLOCATE (qqq_)
allocate(qfunc(mesh,nbeta,nbeta)) ALLOCATE(qfunc(mesh,nbeta,nbeta))
qfunc(1:kkbeta,:,:) = qfunc_(1:kkbeta,:,:) qfunc(1:kkbeta,:,:) = qfunc_(1:kkbeta,:,:)
qfunc(kkbeta+1:mesh,:,:) = 0.d0 qfunc(kkbeta+1:mesh,:,:) = 0.d0
deallocate (qfunc_) DEALLOCATE (qfunc_)
nqf = nqf_ nqf = nqf_
nqlc= nlc nqlc= nlc
allocate(rinner(nqlc)) ALLOCATE(rinner(nqlc))
rinner = rinner_ rinner = rinner_
deallocate(rinner_) DEALLOCATE(rinner_)
allocate(qfcoef(nqf,nqlc,nbeta,nbeta)) ALLOCATE(qfcoef(nqf,nqlc,nbeta,nbeta))
qfcoef = qfcoef_ qfcoef = qfcoef_
deallocate (qfcoef_) DEALLOCATE (qfcoef_)
allocate (rho_at(mesh)) ALLOCATE (rho_at(mesh))
rho_at = rho_at_ rho_at = rho_at_
deallocate (rho_at_) DEALLOCATE (rho_at_)
allocate (chi(mesh,ntwfc)) ALLOCATE (chi(mesh,ntwfc))
chi = wf chi = wf
deallocate (wf) DEALLOCATE (wf)
return RETURN
end subroutine convert_uspp END SUBROUTINE convert_uspp

28
upftools/vdb2upf.f90
View File

@ -7,32 +7,32 @@
! !
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
program vdb2upf PROGRAM vdb2upf
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
! Convert a pseudopotential written in Vanderbilt format ! Convert a pseudopotential written in Vanderbilt format
! (formatted) to unified pseudopotential format ! (formatted) to unified pseudopotential format
! !
implicit none IMPLICIT NONE
character(len=256) filein, fileout CHARACTER(len=256) filein, fileout
! !
! !
call get_file ( filein ) CALL get_file ( filein )
open(unit=1,file=filein,status='old',form='formatted') OPEN(unit=1,file=filein,status='old',form='formatted')
call read_vdb(1) CALL read_vdb(1)
close (unit=1) CLOSE (unit=1)
! convert variables read from Vanderbilt format into those needed ! convert variables read from Vanderbilt format into those needed
! by the upf format - add missing quantities ! by the upf format - add missing quantities
call convert_uspp CALL convert_uspp
fileout=trim(filein)//'.UPF' fileout=trim(filein)//'.UPF'
print '(''Output PP file in UPF format : '',a)', fileout PRINT '(''Output PP file in UPF format : '',a)', fileout
open(unit=2,file=fileout,status='unknown',form='formatted') OPEN(unit=2,file=fileout,status='unknown',form='formatted')
call write_upf(2) CALL write_upf(2)
close (unit=2) CLOSE (unit=2)
stop STOP
end program vdb2upf END PROGRAM vdb2upf

766
upftools/virtual.f90
View File

File diff suppressed because it is too large Load Diff

506
upftools/write_upf.f90
View File

@ -5,445 +5,445 @@
! in the root directory of the present distribution, ! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt . ! or http://www.gnu.org/copyleft/gpl.txt .
! !
module upf MODULE upf
! !
! All variables to be written into the UPF file ! All variables to be written into the UPF file
! (UPF = unified pseudopotential format) ! (UPF = unified pseudopotential format)
! !
! pp_info ! pp_info
integer :: rel INTEGER :: rel
real(8) :: rcloc real(8) :: rcloc
integer :: nwfs INTEGER :: nwfs
real(8), allocatable :: oc(:), rcut(:), rcutus(:), epseu(:) real(8), ALLOCATABLE :: oc(:), rcut(:), rcutus(:), epseu(:)
character(len=2), allocatable :: els(:) CHARACTER(len=2), ALLOCATABLE :: els(:)
integer, allocatable:: lchi (:), nns (:) INTEGER, ALLOCATABLE:: lchi (:), nns (:)
! !
! pp_header ! pp_header
character (len=80):: generated, date_author, comment CHARACTER (len=80):: generated, date_author, comment
character (len=2) :: psd, pseudotype CHARACTER (len=2) :: psd, pseudotype
integer :: nv = 0 INTEGER :: nv = 0
integer :: iexch, icorr, igcx, igcc INTEGER :: iexch, icorr, igcx, igcc
integer :: lmax, mesh, nbeta, ntwfc INTEGER :: lmax, mesh, nbeta, ntwfc
logical :: nlcc LOGICAL :: nlcc
real(8) :: zp, ecutrho, ecutwfc, etotps real(8) :: zp, ecutrho, ecutwfc, etotps
real(8), allocatable :: ocw(:) real(8), ALLOCATABLE :: ocw(:)
character(len=2), allocatable :: elsw(:) CHARACTER(len=2), ALLOCATABLE :: elsw(:)
integer, allocatable:: lchiw(:) INTEGER, ALLOCATABLE:: lchiw(:)
! !
! pp_mesh ! pp_mesh
real(8), allocatable :: r(:), rab(:) real(8), ALLOCATABLE :: r(:), rab(:)
! !
! pp_nlcc ! pp_nlcc
real(8), allocatable :: rho_atc(:) real(8), ALLOCATABLE :: rho_atc(:)
! !
! pp_local ! pp_local
real(8), allocatable :: vloc0(:) real(8), ALLOCATABLE :: vloc0(:)
! !
! pp_nonlocal ! pp_nonlocal
! pp_beta ! pp_beta
real(8), allocatable :: betar(:,:) real(8), ALLOCATABLE :: betar(:,:)
integer, allocatable:: lll(:), ikk2(:) INTEGER, ALLOCATABLE:: lll(:), ikk2(:)
! pp_dij ! pp_dij
real(8), allocatable :: dion(:,:) real(8), ALLOCATABLE :: dion(:,:)
! pp_qij ! pp_qij
integer :: nqf, nqlc INTEGER :: nqf, nqlc
real(8), allocatable :: rinner(:), qqq(:,:), qfunc(:,:,:) real(8), ALLOCATABLE :: rinner(:), qqq(:,:), qfunc(:,:,:)
! pp_qfcoef ! pp_qfcoef
real(8), allocatable :: qfcoef(:,:,:,:) real(8), ALLOCATABLE :: qfcoef(:,:,:,:)
! !
! pp_pswfc ! pp_pswfc
real(8), allocatable :: chi(:,:) real(8), ALLOCATABLE :: chi(:,:)
! !
! pp_rhoatom ! pp_rhoatom
real(8), allocatable :: rho_at(:) real(8), ALLOCATABLE :: rho_at(:)
end module upf END MODULE upf
! !
subroutine write_upf(ounps) SUBROUTINE write_upf(ounps)
use upf, only: nlcc USE upf, ONLY: nlcc
integer :: ounps INTEGER :: ounps
call write_pseudo_comment(ounps) CALL write_pseudo_comment(ounps)
call write_pseudo_header(ounps) CALL write_pseudo_header(ounps)
call write_pseudo_mesh(ounps) CALL write_pseudo_mesh(ounps)
if (nlcc) call write_pseudo_nlcc(ounps) IF (nlcc) CALL write_pseudo_nlcc(ounps)
call write_pseudo_local(ounps) CALL write_pseudo_local(ounps)
call write_pseudo_nl(ounps) CALL write_pseudo_nl(ounps)
call write_pseudo_pswfc(ounps) CALL write_pseudo_pswfc(ounps)
call write_pseudo_rhoatom(ounps) CALL write_pseudo_rhoatom(ounps)
! !
print '("*** PLEASE TEST BEFORE USING!!! ***")' PRINT '("*** PLEASE TEST BEFORE USING!!! ***")'
print '("review the content of the PP_INFO fields")' PRINT '("review the content of the PP_INFO fields")'
! !
end subroutine write_upf END SUBROUTINE write_upf
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
subroutine write_pseudo_comment (ounps) SUBROUTINE write_pseudo_comment (ounps)
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
! !
! This routine writes the comments of the new UPF file ! This routine writes the comments of the new UPF file
! !
use upf USE upf
implicit none IMPLICIT NONE
integer :: ounps INTEGER :: ounps
integer :: nb, ios INTEGER :: nb, ios
write (ounps, '(a9)', err = 100, iostat = ios) "<PP_INFO>" WRITE (ounps, '(a9)', err = 100, iostat = ios) "<PP_INFO>"
write (ounps, '(a)', err = 100, iostat = ios) generated WRITE (ounps, '(a)', err = 100, iostat = ios) generated
write (ounps, '(a)', err = 100, iostat = ios) date_author WRITE (ounps, '(a)', err = 100, iostat = ios) date_author
write (ounps, '(a)', err = 100, iostat = ios) comment WRITE (ounps, '(a)', err = 100, iostat = ios) comment
if (rel==2) then IF (rel==2) THEN
write (ounps, '(i5,t14,a)', err = 100, iostat = ios) rel,& WRITE (ounps, '(i5,t14,a)', err = 100, iostat = ios) rel,&
&"The Pseudo was generated with a Full-Relativistic Calculation" &"The Pseudo was generated with a Full-Relativistic Calculation"
else if (rel==1) then ELSEIF (rel==1) THEN
write (ounps, '(i5,t14,a)', err = 100, iostat = ios) rel,& WRITE (ounps, '(i5,t14,a)', err = 100, iostat = ios) rel,&
&"The Pseudo was generated with a Scalar-Relativistic Calculation" &"The Pseudo was generated with a Scalar-Relativistic Calculation"
else if (rel==0) then ELSEIF (rel==0) THEN
write (ounps, '(i5,t14,a)', err = 100, iostat = ios) rel, & WRITE (ounps, '(i5,t14,a)', err = 100, iostat = ios) rel, &
& "The Pseudo was generated with a Non-Relativistic Calculation" & "The Pseudo was generated with a Non-Relativistic Calculation"
endif ENDIF
if (rcloc > 0.d0) & IF (rcloc > 0.d0) &
write (ounps, '(1pe19.11,t24,a)', err = 100, iostat = ios) & WRITE (ounps, '(1pe19.11,t24,a)', err = 100, iostat = ios) &
rcloc, "Local Potential cutoff radius" rcloc, "Local Potential cutoff radius"
if (nwfs>0) & IF (nwfs>0) &
write (ounps, '(a2,2a3,a6,3a19)', err = 100, iostat = ios) "nl", & WRITE (ounps, '(a2,2a3,a6,3a19)', err = 100, iostat = ios) "nl", &
&" pn", "l", "occ", "Rcut", "Rcut US", "E pseu" &" pn", "l", "occ", "Rcut", "Rcut US", "E pseu"
do nb = 1, nwfs DO nb = 1, nwfs
write (ounps, '(a2,2i3,f6.2,3f19.11)') els (nb) , nns (nb) , & WRITE (ounps, '(a2,2i3,f6.2,3f19.11)') els (nb) , nns (nb) , &
lchi (nb) , oc (nb) , rcut (nb) , rcutus (nb) , epseu(nb) lchi (nb) , oc (nb) , rcut (nb) , rcutus (nb) , epseu(nb)
enddo ENDDO
write (ounps, '(a10)', err = 100, iostat = ios) "</PP_INFO>" WRITE (ounps, '(a10)', err = 100, iostat = ios) "</PP_INFO>"
return RETURN
100 write(6,'("write_pseudo_comment: error writing pseudopotential file")') 100 WRITE(6,'("write_pseudo_comment: error writing pseudopotential file")')
stop STOP
end subroutine write_pseudo_comment END SUBROUTINE write_pseudo_comment
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
subroutine write_pseudo_header (ounps) SUBROUTINE write_pseudo_header (ounps)
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
! !
! This routine writes the header of the new UPF file ! This routine writes the header of the new UPF file
! !
use upf USE upf
implicit none IMPLICIT NONE
integer :: ounps INTEGER :: ounps
! !
character (len=4) :: shortname CHARACTER (len=4) :: shortname
character (len=20):: dft CHARACTER (len=20):: dft
integer :: nb, ios INTEGER :: nb, ios
! !
! !
write (ounps, '(//a11)', err = 100, iostat = ios) "<PP_HEADER>" WRITE (ounps, '(//a11)', err = 100, iostat = ios) "<PP_HEADER>"
write (ounps, '(t3,i2,t24,a)', err = 100, iostat = ios) nv, & WRITE (ounps, '(t3,i2,t24,a)', err = 100, iostat = ios) nv, &
"Version Number" "Version Number"
write (ounps, '(t3,a,t24,a)', err = 100, iostat = ios) psd , & WRITE (ounps, '(t3,a,t24,a)', err = 100, iostat = ios) psd , &
"Element" "Element"
if (pseudotype == 'NC') then IF (pseudotype == 'NC') THEN
write (ounps, '(a5,t24,a)', err = 100, iostat = ios) "NC", & WRITE (ounps, '(a5,t24,a)', err = 100, iostat = ios) "NC", &
"Norm - Conserving pseudopotential" "Norm - Conserving pseudopotential"
else if (pseudotype == 'US') then ELSEIF (pseudotype == 'US') THEN
write (ounps, '(a5,t24,a)', err = 100, iostat = ios) "US", & WRITE (ounps, '(a5,t24,a)', err = 100, iostat = ios) "US", &
"Ultrasoft pseudopotential" "Ultrasoft pseudopotential"
else ELSE
write(6,'("write_pseudo_header: unknown PP type ",A)') pseudotype WRITE(6,'("write_pseudo_header: unknown PP type ",A)') pseudotype
stop STOP
endif ENDIF
write (ounps, '(l5,t24,a)', err = 100, iostat = ios) nlcc , & WRITE (ounps, '(l5,t24,a)', err = 100, iostat = ios) nlcc , &
"Nonlinear Core Correction" "Nonlinear Core Correction"
call dftname (iexch, icorr, igcx, igcc, dft, shortname) CALL dftname (iexch, icorr, igcx, igcc, dft, shortname)
write (ounps, '(a,t24,a4,a)', err = 100, iostat = ios) & WRITE (ounps, '(a,t24,a4,a)', err = 100, iostat = ios) &
dft, shortname," Exchange-Correlation functional" dft, shortname," Exchange-Correlation functional"
write (ounps, '(f17.11,t24,a)') zp , "Z valence" WRITE (ounps, '(f17.11,t24,a)') zp , "Z valence"
write (ounps, '(f17.11,t24,a)') etotps, "Total energy" WRITE (ounps, '(f17.11,t24,a)') etotps, "Total energy"
write (ounps, '(2f11.7,t24,a)') ecutrho, ecutwfc, & WRITE (ounps, '(2f11.7,t24,a)') ecutrho, ecutwfc, &
"Suggested cutoff for wfc and rho" "Suggested cutoff for wfc and rho"
write (ounps, '(i5,t24,a)') lmax, "Max angular momentum component" WRITE (ounps, '(i5,t24,a)') lmax, "Max angular momentum component"
write (ounps, '(i5,t24,a)') mesh, "Number of points in mesh" WRITE (ounps, '(i5,t24,a)') mesh, "Number of points in mesh"
write (ounps, '(2i5,t24,a)', err = 100, iostat = ios) ntwfc, & WRITE (ounps, '(2i5,t24,a)', err = 100, iostat = ios) ntwfc, &
nbeta , "Number of Wavefunctions, Number of Projectors" nbeta , "Number of Wavefunctions, Number of Projectors"
write (ounps, '(a,t24,a2,a3,a6)', err = 100, iostat = ios) & WRITE (ounps, '(a,t24,a2,a3,a6)', err = 100, iostat = ios) &
" Wavefunctions", "nl", "l", "occ" " Wavefunctions", "nl", "l", "occ"
do nb = 1, ntwfc DO nb = 1, ntwfc
write (ounps, '(t24,a2,i3,f6.2)') elsw(nb), lchiw(nb), ocw(nb) WRITE (ounps, '(t24,a2,i3,f6.2)') elsw(nb), lchiw(nb), ocw(nb)
enddo ENDDO
!---> End header writing !---> End header writing
write (ounps, '(a12)', err = 100, iostat = ios) "</PP_HEADER>" WRITE (ounps, '(a12)', err = 100, iostat = ios) "</PP_HEADER>"
return RETURN
100 write(6,'("write_pseudo_header: error writing pseudopotential file")') 100 WRITE(6,'("write_pseudo_header: error writing pseudopotential file")')
stop STOP
end subroutine write_pseudo_header END SUBROUTINE write_pseudo_header
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
subroutine write_pseudo_mesh (ounps) SUBROUTINE write_pseudo_mesh (ounps)
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
! !
! This routine writes the atomic charge density to the new UPF file ! This routine writes the atomic charge density to the new UPF file
! !
use upf USE upf
implicit none IMPLICIT NONE
integer :: ounps INTEGER :: ounps
! !
integer :: ir, ios INTEGER :: ir, ios
! !
write (ounps, '(//a9)', err = 100, iostat = ios) "<PP_MESH>" WRITE (ounps, '(//a9)', err = 100, iostat = ios) "<PP_MESH>"
write (ounps, '(t3,a6)', err = 100, iostat = ios) "<PP_R>" WRITE (ounps, '(t3,a6)', err = 100, iostat = ios) "<PP_R>"
write (ounps, '(1p4e19.11)', err=100, iostat=ios) (r(ir), ir=1,mesh ) WRITE (ounps, '(1p4e19.11)', err=100, iostat=ios) (r(ir), ir=1,mesh )
write (ounps, '(t3,a7)', err = 100, iostat = ios) "</PP_R>" WRITE (ounps, '(t3,a7)', err = 100, iostat = ios) "</PP_R>"
write (ounps, '(t3,a8)', err = 100, iostat = ios) "<PP_RAB>" WRITE (ounps, '(t3,a8)', err = 100, iostat = ios) "<PP_RAB>"
write (ounps, '(1p4e19.11)', err=100, iostat=ios) (rab(ir), ir=1,mesh ) WRITE (ounps, '(1p4e19.11)', err=100, iostat=ios) (rab(ir), ir=1,mesh )
write (ounps, '(t3,a9)', err = 100, iostat = ios) "</PP_RAB>" WRITE (ounps, '(t3,a9)', err = 100, iostat = ios) "</PP_RAB>"
write (ounps, '(a10)', err = 100, iostat = ios) "</PP_MESH>" WRITE (ounps, '(a10)', err = 100, iostat = ios) "</PP_MESH>"
return RETURN
100 write(6,'("write_pseudo_mesh: error writing pseudopotential file")') 100 WRITE(6,'("write_pseudo_mesh: error writing pseudopotential file")')
stop STOP
end subroutine write_pseudo_mesh END SUBROUTINE write_pseudo_mesh
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
subroutine write_pseudo_nlcc (ounps) SUBROUTINE write_pseudo_nlcc (ounps)
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
! !
! This routine writes the core charge for the nonlinear core ! This routine writes the core charge for the nonlinear core
! correction of the new UPF file ! correction of the new UPF file
! !
use upf USE upf
implicit none IMPLICIT NONE
integer :: ounps INTEGER :: ounps
! !
integer :: ir, ios INTEGER :: ir, ios
write (ounps, '(//a9)', err = 100, iostat = ios) "<PP_NLCC>" WRITE (ounps, '(//a9)', err = 100, iostat = ios) "<PP_NLCC>"
write (ounps, '(1p4e19.11)', err=100, iostat=ios) & WRITE (ounps, '(1p4e19.11)', err=100, iostat=ios) &
( rho_atc(ir), ir = 1, mesh ) ( rho_atc(ir), ir = 1, mesh )
write (ounps, '(a10)', err = 100, iostat = ios) "</PP_NLCC>" WRITE (ounps, '(a10)', err = 100, iostat = ios) "</PP_NLCC>"
return RETURN
100 write(6,'("write_pseudo_nlcc: error writing pseudopotential file")') 100 WRITE(6,'("write_pseudo_nlcc: error writing pseudopotential file")')
stop STOP
end subroutine write_pseudo_nlcc END SUBROUTINE write_pseudo_nlcc
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
subroutine write_pseudo_local (ounps) SUBROUTINE write_pseudo_local (ounps)
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
! !
! This routine writes the local part of the new UPF file ! This routine writes the local part of the new UPF file
! !
use upf USE upf
implicit none IMPLICIT NONE
integer :: ounps INTEGER :: ounps
! !
integer :: ir, ios INTEGER :: ir, ios
write (ounps, '(//a10)', err = 100, iostat = ios) "<PP_LOCAL>" WRITE (ounps, '(//a10)', err = 100, iostat = ios) "<PP_LOCAL>"
write (ounps, '(1p4e19.11)', err=100, iostat=ios) & WRITE (ounps, '(1p4e19.11)', err=100, iostat=ios) &
( vloc0(ir), ir = 1, mesh ) ( vloc0(ir), ir = 1, mesh )
write (ounps, '(a11)', err = 100, iostat = ios) "</PP_LOCAL>" WRITE (ounps, '(a11)', err = 100, iostat = ios) "</PP_LOCAL>"
return RETURN
100 write(6,'("write_pseudo_local: error writing pseudopotential file")') 100 WRITE(6,'("write_pseudo_local: error writing pseudopotential file")')
stop STOP
end subroutine write_pseudo_local END SUBROUTINE write_pseudo_local
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
subroutine write_pseudo_nl (ounps) SUBROUTINE write_pseudo_nl (ounps)
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
! !
! This routine writes the non local part of the new UPF file ! This routine writes the non local part of the new UPF file
! !
use upf USE upf
implicit none IMPLICIT NONE
integer :: ounps INTEGER :: ounps
! !
integer :: nb, mb, n, ir, nd, i, lp, ios INTEGER :: nb, mb, n, ir, nd, i, lp, ios
write (ounps, '(//a13)', err = 100, iostat = ios) "<PP_NONLOCAL>" WRITE (ounps, '(//a13)', err = 100, iostat = ios) "<PP_NONLOCAL>"
do nb = 1, nbeta DO nb = 1, nbeta
write (ounps, '(t3,a9)', err = 100, iostat = ios) "<PP_BETA>" WRITE (ounps, '(t3,a9)', err = 100, iostat = ios) "<PP_BETA>"
write (ounps, '(2i5,t24,a)', err=100, iostat=ios) & WRITE (ounps, '(2i5,t24,a)', err=100, iostat=ios) &
nb, lll(nb), "Beta L" nb, lll(nb), "Beta L"
write (ounps, '(i6)', err=100, iostat=ios) ikk2 (nb) WRITE (ounps, '(i6)', err=100, iostat=ios) ikk2 (nb)
write (ounps, '(1p4e19.11)', err=100, iostat=ios) & WRITE (ounps, '(1p4e19.11)', err=100, iostat=ios) &
( betar(ir,nb), ir=1,ikk2(nb) ) ( betar(ir,nb), ir=1,ikk2(nb) )
write (ounps, '(t3,a10)', err = 100, iostat = ios) "</PP_BETA>" WRITE (ounps, '(t3,a10)', err = 100, iostat = ios) "</PP_BETA>"
enddo ENDDO
write (ounps, '(t3,a8)', err = 100, iostat = ios) "<PP_DIJ>" WRITE (ounps, '(t3,a8)', err = 100, iostat = ios) "<PP_DIJ>"
nd = 0 nd = 0
do nb = 1, nbeta DO nb = 1, nbeta
do mb = nb, nbeta DO mb = nb, nbeta
if ( abs(dion(nb,mb)) .gt. 1.0d-12 ) nd = nd + 1 IF ( abs(dion(nb,mb)) > 1.0d-12 ) nd = nd + 1
enddo ENDDO
enddo ENDDO
write (ounps, '(1p,i5,t24,a)', err=100, iostat=ios) & WRITE (ounps, '(1p,i5,t24,a)', err=100, iostat=ios) &
nd, "Number of nonzero Dij" nd, "Number of nonzero Dij"
do nb = 1, nbeta DO nb = 1, nbeta
do mb = nb, nbeta DO mb = nb, nbeta
if ( abs(dion(nb,mb)) .gt. 1.0d-12 ) & IF ( abs(dion(nb,mb)) > 1.0d-12 ) &
write(ounps,'(1p,2i5,e19.11)', err=100, iostat=ios) & WRITE(ounps,'(1p,2i5,e19.11)', err=100, iostat=ios) &
nb, mb, dion(nb,mb) nb, mb, dion(nb,mb)
enddo ENDDO
enddo ENDDO
write (ounps, '(t3,a9)', err=100, iostat=ios) "</PP_DIJ>" WRITE (ounps, '(t3,a9)', err=100, iostat=ios) "</PP_DIJ>"
if (pseudotype == 'US') then IF (pseudotype == 'US') THEN
write (ounps, '(t3,a8)', err = 100, iostat = ios) "<PP_QIJ>" WRITE (ounps, '(t3,a8)', err = 100, iostat = ios) "<PP_QIJ>"
write (ounps, '(i5,a)',err=100, iostat=ios) nqf," nqf.& WRITE (ounps, '(i5,a)',err=100, iostat=ios) nqf," nqf.&
& If not zero, Qij's inside rinner are computed using qfcoef's" & If not zero, Qij's inside rinner are computed using qfcoef's"
if (nqf.gt.0) then IF (nqf>0) THEN
write (ounps, '(t5,a11)', err=100, iostat=ios) "<PP_RINNER>" WRITE (ounps, '(t5,a11)', err=100, iostat=ios) "<PP_RINNER>"
write (ounps,'(i5,1pe19.11)', err=100, iostat=ios) & WRITE (ounps,'(i5,1pe19.11)', err=100, iostat=ios) &
(i, rinner(i), i = 1, nqlc) (i, rinner(i), i = 1, nqlc)
write (ounps, '(t5,a12)', err=100, iostat=ios) "</PP_RINNER>" WRITE (ounps, '(t5,a12)', err=100, iostat=ios) "</PP_RINNER>"
end if ENDIF
do nb = 1, nbeta DO nb = 1, nbeta
do mb = nb, nbeta DO mb = nb, nbeta
write (ounps, '(3i5,t24,a)', err=100, iostat=ios) & WRITE (ounps, '(3i5,t24,a)', err=100, iostat=ios) &
nb, mb, lll(mb) , "i j (l(j))" nb, mb, lll(mb) , "i j (l(j))"
write (ounps, '(1pe19.11,t24,a)', err=100, iostat=ios) & WRITE (ounps, '(1pe19.11,t24,a)', err=100, iostat=ios) &
qqq(nb,mb), "Q_int" qqq(nb,mb), "Q_int"
write (ounps, '(1p4e19.11)', err=100, iostat=ios) & WRITE (ounps, '(1p4e19.11)', err=100, iostat=ios) &
( qfunc (n,nb,mb), n=1,mesh ) ( qfunc (n,nb,mb), n=1,mesh )
if (nqf.gt.0) then IF (nqf>0) THEN
write (ounps, '(t5,a11)', err=100, iostat=ios) & WRITE (ounps, '(t5,a11)', err=100, iostat=ios) &
"<PP_QFCOEF>" "<PP_QFCOEF>"
write(ounps,'(1p4e19.11)', err=100, iostat=ios) & WRITE(ounps,'(1p4e19.11)', err=100, iostat=ios) &
((qfcoef(i,lp,nb,mb),i=1,nqf),lp=1,nqlc) ((qfcoef(i,lp,nb,mb),i=1,nqf),lp=1,nqlc)
write (ounps, '(t5,a12)', err=100, iostat=ios) & WRITE (ounps, '(t5,a12)', err=100, iostat=ios) &
"</PP_QFCOEF>" "</PP_QFCOEF>"
end if ENDIF
enddo ENDDO
enddo ENDDO
write (ounps, '(t3,a9)', err = 100, iostat = ios) "</PP_QIJ>" WRITE (ounps, '(t3,a9)', err = 100, iostat = ios) "</PP_QIJ>"
endif ENDIF
write (ounps, '(a14)', err = 100, iostat = ios) "</PP_NONLOCAL>" WRITE (ounps, '(a14)', err = 100, iostat = ios) "</PP_NONLOCAL>"
return RETURN
100 write(6,'("write_pseudo_nl: error writing pseudopotential file")') 100 WRITE(6,'("write_pseudo_nl: error writing pseudopotential file")')
stop STOP
end subroutine write_pseudo_nl END SUBROUTINE write_pseudo_nl
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
subroutine write_pseudo_pswfc (ounps) SUBROUTINE write_pseudo_pswfc (ounps)
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
! !
! This routine writes the pseudo atomic functions ! This routine writes the pseudo atomic functions
! of the new UPF file ! of the new UPF file
! !
use upf USE upf
implicit none IMPLICIT NONE
integer :: ounps INTEGER :: ounps
! !
integer :: nb, ir, ios INTEGER :: nb, ir, ios
write (ounps, '(//a10)', err = 100, iostat = ios) "<PP_PSWFC>" WRITE (ounps, '(//a10)', err = 100, iostat = ios) "<PP_PSWFC>"
do nb = 1, ntwfc DO nb = 1, ntwfc
write (ounps,'(a2,i5,f6.2,t24,a)', err=100, iostat=ios) & WRITE (ounps,'(a2,i5,f6.2,t24,a)', err=100, iostat=ios) &
elsw(nb), lchiw(nb), ocw(nb), "Wavefunction" elsw(nb), lchiw(nb), ocw(nb), "Wavefunction"
write (ounps, '(1p4e19.11)', err=100, iostat=ios) & WRITE (ounps, '(1p4e19.11)', err=100, iostat=ios) &
( chi(ir,nb), ir=1,mesh ) ( chi(ir,nb), ir=1,mesh )
enddo ENDDO
write (ounps, '(a11)', err = 100, iostat = ios) "</PP_PSWFC>" WRITE (ounps, '(a11)', err = 100, iostat = ios) "</PP_PSWFC>"
return RETURN
100 write(6,'("write_pseudo_pswfc: error writing pseudopotential file")') 100 WRITE(6,'("write_pseudo_pswfc: error writing pseudopotential file")')
stop STOP
end subroutine write_pseudo_pswfc END SUBROUTINE write_pseudo_pswfc
! !
!--------------------------------------------------------------------- !---------------------------------------------------------------------
subroutine write_pseudo_rhoatom (ounps) SUBROUTINE write_pseudo_rhoatom (ounps)
!--------------------------------------------------------------------- !---------------------------------------------------------------------
! !
! !
! This routine writes the atomic charge density to the new UPF file ! This routine writes the atomic charge density to the new UPF file
! !
use upf USE upf
implicit none IMPLICIT NONE
integer :: ounps INTEGER :: ounps
! !
integer :: ir, ios INTEGER :: ir, ios
write (ounps, '(//a12)', err = 100, iostat = ios) "<PP_RHOATOM>" WRITE (ounps, '(//a12)', err = 100, iostat = ios) "<PP_RHOATOM>"
write (ounps, '(1p4e19.11)', err = 100, iostat = ios) & WRITE (ounps, '(1p4e19.11)', err = 100, iostat = ios) &
( rho_at(ir), ir=1,mesh ) ( rho_at(ir), ir=1,mesh )
write (ounps, '(a13)', err = 100, iostat = ios) "</PP_RHOATOM>" WRITE (ounps, '(a13)', err = 100, iostat = ios) "</PP_RHOATOM>"
return RETURN
100 write(6,'("write_pseudo_rhoatom: error writing pseudopotential file")') 100 WRITE(6,'("write_pseudo_rhoatom: error writing pseudopotential file")')
stop STOP
end subroutine write_pseudo_rhoatom END SUBROUTINE write_pseudo_rhoatom
!--------------------------------------------------------------------- !---------------------------------------------------------------------
subroutine dftname(iexch, icorr, igcx, igcc, longname, shortname) SUBROUTINE dftname(iexch, icorr, igcx, igcc, longname, shortname)
!--------------------------------------------------------------------- !---------------------------------------------------------------------
implicit none IMPLICIT NONE
integer iexch, icorr, igcx, igcc INTEGER iexch, icorr, igcx, igcc
character (len=4) :: shortname CHARACTER (len=4) :: shortname
character (len=20):: longname CHARACTER (len=20):: longname
! !
! The data used to convert iexch, icorr, igcx, igcc ! The data used to convert iexch, icorr, igcx, igcc
! into a user-readable string ! into a user-readable string
! !
integer, parameter :: nxc = 6, ncc = 9, ngcx = 4, ngcc = 5 INTEGER, PARAMETER :: nxc = 6, ncc = 9, ngcx = 4, ngcc = 5
character (len=20) :: exc, corr, gradx, gradc CHARACTER (len=20) :: exc, corr, gradx, gradc
dimension exc (0:nxc), corr (0:ncc), gradx (0:ngcx), gradc (0:ngcc) DIMENSION exc (0:nxc), corr (0:ncc), gradx (0:ngcx), gradc (0:ngcc)
data exc / 'NOX ', 'SLA ', 'SL1 ', 'RXC ', 'OEP ', 'HF ', 'PB0X' / data exc / 'NOX ', 'SLA ', 'SL1 ', 'RXC ', 'OEP ', 'HF ', 'PB0X' /
data corr / 'NOC ', 'PZ ', 'VWN ', 'LYP ', 'PW ', 'WIG ', 'HL ',& data corr / 'NOC ', 'PZ ', 'VWN ', 'LYP ', 'PW ', 'WIG ', 'HL ',&
'OBZ ', 'OBW ', 'GL ' / 'OBZ ', 'OBW ', 'GL ' /
data gradx / 'NOGX', 'B88 ', 'GGX ', 'PBE ', 'TPSS' / data gradx / 'NOGX', 'B88 ', 'GGX ', 'PBE ', 'TPSS' /
data gradc / 'NOGC', 'P86 ', 'GGC ', 'BLYP', 'PBE ', 'TPSS' / data gradc / 'NOGC', 'P86 ', 'GGC ', 'BLYP', 'PBE ', 'TPSS' /
if (iexch==1.and.igcx==0.and.igcc==0) then IF (iexch==1.and.igcx==0.and.igcc==0) THEN
shortname = corr(icorr) shortname = corr(icorr)
else if (iexch==1.and.icorr==3.and.igcx==1.and.igcc==3) then ELSEIF (iexch==1.and.icorr==3.and.igcx==1.and.igcc==3) THEN
shortname = 'BLYP' shortname = 'BLYP'
else if (iexch==1.and.icorr==1.and.igcx==1.and.igcc==0) then ELSEIF (iexch==1.and.icorr==1.and.igcx==1.and.igcc==0) THEN
shortname = 'B88' shortname = 'B88'
else if (iexch==1.and.icorr==1.and.igcx==1.and.igcc==1) then ELSEIF (iexch==1.and.icorr==1.and.igcx==1.and.igcc==1) THEN
shortname = 'BP' shortname = 'BP'
else if (iexch==1.and.icorr==4.and.igcx==2.and.igcc==2) then ELSEIF (iexch==1.and.icorr==4.and.igcx==2.and.igcc==2) THEN
shortname = 'PW91' shortname = 'PW91'
else if (iexch==1.and.icorr==4.and.igcx==3.and.igcc==4) then ELSEIF (iexch==1.and.icorr==4.and.igcx==3.and.igcc==4) THEN
shortname = 'PBE' shortname = 'PBE'
else if (iexch==1.and.icorr==4.and.igcx==4.and.igcc==5) then ELSEIF (iexch==1.and.icorr==4.and.igcx==4.and.igcc==5) THEN
shortname = 'TPSS' shortname = 'TPSS'
else ELSE
shortname = ' ' shortname = ' '
end if ENDIF
write(longname,'(4a5)') exc(iexch),corr(icorr),gradx(igcx),gradc(igcc) WRITE(longname,'(4a5)') exc(iexch),corr(icorr),gradx(igcx),gradc(igcc)
return RETURN
end subroutine dftname END SUBROUTINE dftname