mirror of https://gitlab.com/QEF/q-e.git
Some cleanup and output formatting
This commit is contained in:
Ivan Carnimeo
parent
43337fbe8d
commit
1a3858ead4
|
|
@ -11,13 +11,14 @@
|
|||
!
|
||||
!----------------------------------------------------------------------------
|
||||
program band_interpolation
|
||||
USE io_global, ONLY : stdout
|
||||
USE globalmod, ONLY : print_bands, read_xml_input, method, deallocate_global
|
||||
USE idwmod, ONLY : idw
|
||||
USE fouriermod, ONLY : fourier, fourierdiff
|
||||
USE mp_global, ONLY : mp_startup
|
||||
implicit none
|
||||
!
|
||||
write(*,*) 'PROGRAM: band_interpolation '
|
||||
write(stdout,'(A)') 'PROGRAM: band_interpolation '
|
||||
!
|
||||
#if defined(__MPI)
|
||||
CALL mp_startup ( )
|
||||
|
|
@ -47,8 +48,8 @@ implicit none
|
|||
!
|
||||
else
|
||||
!
|
||||
write(*,*) 'ERROR: Wrong method ', TRIM(method)
|
||||
stop
|
||||
write(stdout, '(A,A)') 'method: ', TRIM(method)
|
||||
Call errore('band_interpolation ' , ' wrong method ', 1)
|
||||
!
|
||||
end if
|
||||
!
|
||||
|
|
@ -94,13 +95,13 @@ subroutine read_input_file ()
|
|||
!
|
||||
! Read input file
|
||||
!
|
||||
USE io_global, ONLY : stdout
|
||||
USE parser, ONLY : read_line
|
||||
USE input_parameters, ONLY : k_points, nkstot
|
||||
USE read_cards_module, ONLY : card_kpoints
|
||||
USE globalmod, ONLY : method
|
||||
USE fouriermod, ONLY : miller_max, check_periodicity, card_user_stars, card_roughness
|
||||
USE idwmod, ONLY : p_metric, scale_sphere
|
||||
USE io_global, ONLY : stdout
|
||||
implicit none
|
||||
integer, parameter :: iunit = 5
|
||||
integer :: ios, i
|
||||
|
|
@ -158,7 +159,7 @@ implicit none
|
|||
Call errore('band_interpolation ' , ' wrong number of k-points ', 1)
|
||||
end if
|
||||
!
|
||||
Write(stdout,'(A,A)') 'Interpolation method: ', method
|
||||
write(stdout,'(A,A)') 'Interpolation method: ', method
|
||||
if( TRIM(method).ne.'idw'.and.TRIM(method).ne.'idw-sphere'&
|
||||
.and.TRIM(method).ne.'fourier'.and.TRIM(method).ne.'fourier-diff' ) &
|
||||
Call errore('band_interpolation', 'Wrong interpolation method ', 1)
|
||||
|
|
|
|||
|
|
@ -11,23 +11,27 @@
|
|||
!
|
||||
!----------------------------------------------------------------------------
|
||||
MODULE fouriermod
|
||||
USE kinds, ONLY : dp
|
||||
USE kinds, ONLY : dp
|
||||
USE io_global, ONLY : stdout
|
||||
implicit none
|
||||
save
|
||||
real(dp), parameter :: eps = 0.000010d0, Zero = 0.0d0, One = 1.0d0, Two = 2.0d0, Four = 4.0d0
|
||||
real(dp), parameter :: Pi = Four*atan(One)
|
||||
!
|
||||
! whether to check if the Star functions have the lattice periodicity (particularly useful for user-defined Star functions)
|
||||
logical :: check_periodicity = .false.
|
||||
!
|
||||
! the largest Miller index used to generate all the lattice vectors inside an outer shell
|
||||
! the largest Miller index used to generate the Star vectors from which the Star functions are built
|
||||
integer :: miller_max
|
||||
!
|
||||
! definition of the roughness functional
|
||||
integer :: RoughN
|
||||
real(dp), allocatable :: RoughC(:)
|
||||
!
|
||||
integer :: NStars ! total number of Star functions
|
||||
real(dp), allocatable :: VecStars(:,:) ! symmetry inequivalent lattice vectors generating the Star functions (one per Star)
|
||||
integer :: NUser ! (Optional) number of user-given star functions
|
||||
real(dp), allocatable :: VecUser(:,:) ! (Optional) user-given star functions
|
||||
integer :: NUser ! (Optional) number of user-defined Star vectors
|
||||
real(dp), allocatable :: VecUser(:,:) ! (Optional) user-defined Star vectors
|
||||
!
|
||||
logical :: trough = .false.
|
||||
logical :: tuser = .false.
|
||||
|
|
@ -45,11 +49,11 @@ implicit none
|
|||
!
|
||||
! local variables
|
||||
integer :: Na, ib, ik
|
||||
complex(dp), allocatable :: fStarsOnQ(:,:) ! Star functions at uniform q-points
|
||||
complex(dp), allocatable :: fStarsOnK(:,:) ! Star functions at path of k-points
|
||||
complex(dp), allocatable :: matQQ(:,:) ! this is exactly H in the reference article
|
||||
complex(dp), allocatable :: fStarsOnQ(:,:) ! Star functions values at q-points (uniform grid)
|
||||
complex(dp), allocatable :: fStarsOnK(:,:) ! Star functions values at k-points (path for band structure)
|
||||
complex(dp), allocatable :: matQQ(:,:) ! this is exactly the H matrix in the reference article
|
||||
complex(dp), allocatable :: matKQ(:,:) ! this is an intermediate quantity S_m(q)*S_m(k)/rho(R_m) to construct J
|
||||
complex(dp), allocatable :: matJ(:,:) ! this is exactly J in the reference article
|
||||
complex(dp), allocatable :: matJ(:,:) ! this is exactly the J matrix in the reference article
|
||||
complex(dp), allocatable :: ek_c(:,:), eq_c(:,:) ! complex band energies (for ZGEMM)
|
||||
real(dp) :: vec(3)
|
||||
complex(dp) :: fStar
|
||||
|
|
@ -63,53 +67,50 @@ implicit none
|
|||
complex(dp), allocatable :: matC(:,:) ! coefficients for m= 2 ,..., NStars
|
||||
complex(dp), allocatable :: matC1(:) ! coefficient for m=1 are treated separately
|
||||
!
|
||||
write(*,'(A)') '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
|
||||
write(*,'(A)') 'Fourier difference interpolation method'
|
||||
if(check_periodicity) write(*,*) 'Checking Star functions periodicity (WARNING: time consuming)'
|
||||
write(stdout,'(A)') ''
|
||||
write(stdout,'(A)') '--- Fourier difference interpolation method ---'
|
||||
write(stdout,'(A)') ''
|
||||
if(check_periodicity) write(stdout,'(A)') 'Checking Star functions periodicity (WARNING: time consuming)'
|
||||
!
|
||||
Na = Nq - 1 ! dimension of the linear system
|
||||
!
|
||||
! Computing b = e(q_i) - e(q_Nq) i = 1, ... , Nq-1
|
||||
write(*,'(A)') 'Computing the RHS of the linear system '
|
||||
! b = e(q_i) - e(q_Nq) i = 1, ... , Nq-1
|
||||
write(stdout,'(A)') 'Computing the RHS of the linear system '
|
||||
allocate( matB(Na,Nb), matX(Na,Nb) )
|
||||
do ib = 1, Nb
|
||||
matB(1:Na,ib) = (One, Zero) * ( eq(1:Na,ib) - eq(Nq,ib) )
|
||||
end do
|
||||
matX = matB ! matX will be overwritten with the solution of Ax=b
|
||||
!
|
||||
! Computing A
|
||||
write(*,'(A)') 'Computing the Star functions basis set'
|
||||
write(stdout,'(A)') 'Computing the Star functions basis set'
|
||||
Call find_stars(NSym, Op, at, .true.)
|
||||
!
|
||||
if(check_periodicity) then
|
||||
write(*,*) 'Checking Star functions periodicity'
|
||||
write(stdout,'(A)') 'Checking the Star functions periodicity'
|
||||
Call check_stars(Nq, q, NSym, Op, bg)
|
||||
end if
|
||||
!
|
||||
! fStarsOnQ = [S_m(q_i)-S_m(q_Nq)] / sqrt(rho_m)
|
||||
write(*,*) 'Computing the Star functions values at the uniform grid points (fStarsOnQ)'
|
||||
write(stdout,'(A)') 'Computing the Star functions values at the uniform grid points (fStarsOnQ)'
|
||||
allocate( fStarsOnQ(Na,NStars), matS(NStars) )
|
||||
fStarsOnQ = (Zero, Zero)
|
||||
Call compute_stars(fStarsOnQ, Na, Nq, q, NSym, Op, 2, .true., matS)
|
||||
!
|
||||
! matQQ = fStarsOnQ * fStarsOnQ^T = sum_m [S_m(q_i)-S_m(q_Nq)]*[S_m(q_j)-S_m(q_Nq)] / rho_m
|
||||
!write(*,*) 'Computing fStarsOnQ * fStarsOnQ*...'
|
||||
allocate(matQQ(Na,Na), matA(Na,Na))
|
||||
matQQ = (Zero, Zero)
|
||||
Call ZGEMM('N', 'C', Na, Na, NStars, (One,Zero), fStarsOnQ, Na, fStarsOnQ, Na, (Zero,Zero), matQQ, Na)
|
||||
matA = matQQ
|
||||
!
|
||||
write(*,*) 'Computing the interpolation coefficients solving the linear system (ZGESV) '
|
||||
write(stdout,'(A)') 'Computing the interpolation coefficients solving the linear system (ZGESV) '
|
||||
allocate( IPIV(Na) )
|
||||
Call ZGESV(Na, Nb, matQQ, Na, IPIV, matX, Na, INFO)
|
||||
deallocate(IPIV)
|
||||
!write(*,'(A)') 'Checking A*x - b = 0...'
|
||||
write(*,'(A)') 'Checking solution '
|
||||
write(stdout,'(A)') 'Solution check'
|
||||
Call ZGEMM('N', 'N', Na, Nb, Na, (One,Zero), matA, Na, matX, Na, -(One,Zero), matB, Na)
|
||||
Call MatCheck_k('A*x - b = 0', matB, Na, Nb)
|
||||
!
|
||||
! C_m,ib = rho^(-1)_m sum_m=2 lambda_iq,ib * [S_m(q_i)-S_m(q_Nq)] m = 2, ... NStars
|
||||
!write(*,*) 'Computing coefficients...'
|
||||
allocate( matC(NStars,Nb), matC1(Nb) )
|
||||
matC = (Zero, Zero)
|
||||
Call ZGEMM('C', 'N', NStars, Nb, Na, (One, Zero), fStarsOnQ, Na, matX, Na, (Zero, Zero), matC, NStars)
|
||||
|
|
@ -121,9 +122,8 @@ implicit none
|
|||
matC1(ib) = eq(Nq,ib) - dot_product(matC(:,ib),matS(:))
|
||||
end do
|
||||
!
|
||||
!write(*,*) 'Computing bands...'
|
||||
! fStarsOnK = S_m(k)
|
||||
write(*,*) 'Computing the Star functions values at the requested bands k-points (fStarsOnK)'
|
||||
write(stdout,'(A)') 'Computing the Star functions values at the requested bands k-points (fStarsOnK)'
|
||||
allocate( fStarsOnK(nkstot,NStars), ek_c(nkstot,Nb) )
|
||||
fStarsOnK = (Zero, Zero)
|
||||
Call compute_stars(fStarsOnK, nkstot, nkstot, xk, NSym, Op, 0)
|
||||
|
|
@ -174,46 +174,44 @@ implicit none
|
|||
real(dp), allocatable :: rmatQQ_(:,:)
|
||||
real(dp), allocatable :: rmatJ(:,:)
|
||||
!
|
||||
write(*,'(A)') '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
|
||||
write(*,'(A)') 'Fourier interpolation method'
|
||||
if(check_periodicity) write(*,*) 'Checking Star functions periodicity (WARNING: time consuming)'
|
||||
write(*,*) 'Creating the Star functions basis set'
|
||||
write(stdout,'(A)') ''
|
||||
write(stdout,'(A)') '--- Fourier interpolation method ---'
|
||||
write(stdout,'(A)') ''
|
||||
if(check_periodicity) write(stdout,'(A)') 'Checking Star functions periodicity (WARNING: time consuming)'
|
||||
write(stdout,'(A)') 'Computing the Star functions basis set'
|
||||
Call find_stars(NSym, Op, at)
|
||||
!
|
||||
if(check_periodicity) then
|
||||
write(*,*) 'Checking Star functions periodicity...'
|
||||
write(stdout,'(A)') 'Checking the Star functions periodicity...'
|
||||
Call check_stars(Nq, q, NSym, Op, bg)
|
||||
end if
|
||||
!
|
||||
! fStarsOnQ = S_m(q) / sqrt(rho_m)
|
||||
write(*,*) 'Computing the Star functions values at the uniform grid points (fStarsOnQ)'
|
||||
write(stdout,'(A)') 'Computing the Star functions values at the uniform grid points (fStarsOnQ)'
|
||||
allocate( fStarsOnQ(Nq,NStars) )
|
||||
fStarsOnQ = (Zero, Zero)
|
||||
Call compute_stars(fStarsOnQ, Nq, Nq, q, NSym, Op, 2)
|
||||
!
|
||||
! matQQ = fStarsOnQ * fStarsOnQ^T = sum_m S_m(q_i) S_m(q_j) / rho_m
|
||||
!write(*,*) 'Computing fStarsOnQ * fStarsOnQ^T...'
|
||||
allocate(matQQ(Nq,Nq))
|
||||
matQQ = (Zero, Zero)
|
||||
Call ZGEMM('N', 'C', Nq, Nq, NStars, (One,Zero), fStarsOnQ, Nq, fStarsOnQ, Nq, (Zero,Zero), matQQ, Nq)
|
||||
!
|
||||
! matQQ --> matQQ^(-1)
|
||||
!write(*,*) 'Inverting fStarsOnQ * fStarsOnQ^T...'
|
||||
write(*,*) 'Computing the interpolation coefficients with matrix inversion '
|
||||
write(stdout,'(A)') 'Computing the interpolation coefficients with matrix inversion '
|
||||
allocate( rmatQQ(Nq,Nq), rmatQQ_(Nq,Nq), rmatJ(Nq,Nq) )
|
||||
rmatQQ(:,:) = dble(matQQ(:,:))
|
||||
rmatQQ_(:,:) = rmatQQ(:,:)
|
||||
rmatJ(:,:) = Zero
|
||||
Call MatInv('G', Nq, rmatQQ)
|
||||
write(*,*) 'Checking inverse...'
|
||||
write(stdout,'(A)') 'Solution check'
|
||||
Call DGEMM("N", "N", Nq, Nq, Nq, One, rmatQQ, Nq, rmatQQ_, Nq, Zero, rmatJ, Nq)
|
||||
Call MatCheck('rmatJ',rmatJ,Nq,Nq)
|
||||
Call MatCheck('A * A^(-1) = I',rmatJ,Nq,Nq)
|
||||
matQQ(:,:) = (One,Zero) * rmatQQ(:,:)
|
||||
deallocate( rmatQQ, rmatQQ_, rmatJ )
|
||||
!
|
||||
! fStarsOnK = S_m(k) / sqrt(rho_m)
|
||||
!write(*,*) 'Computing fStarsOnK...'
|
||||
write(*,*) 'Computing the Star functions values at the requested bands k-points (fStarsOnK)'
|
||||
write(stdout,'(A)') 'Computing the Star functions values at the requested bands k-points (fStarsOnK)'
|
||||
allocate( fStarsOnK(nkstot,NStars) )
|
||||
fStarsOnK = (Zero, Zero)
|
||||
Call compute_stars(fStarsOnK, nkstot, nkstot, xk, NSym, Op, 2)
|
||||
|
|
@ -280,16 +278,17 @@ implicit none
|
|||
NAll = (2 * miller_max + 1 )**3 ! from -miller_max to miller_max is (2*miller_max + 1), for 3 space directions
|
||||
if(Skip000) then
|
||||
NAll = NAll - 1 ! remove the (0, 0, 0) lattice vector
|
||||
write(*,*) 'Skipping the (0,0,0) lattice vector...'
|
||||
write(stdout,'(5X,A)') 'Skipping the (0,0,0) lattice vector'
|
||||
else
|
||||
write(*,*) 'Including the (0,0,0) lattice vector...'
|
||||
write(stdout,'(5X,A)') 'Including the (0,0,0) lattice vector'
|
||||
end if
|
||||
!
|
||||
if(NUser.gt.0) then
|
||||
NAll = NAll + NUser
|
||||
write(*,*) "Creating ", NAll, " vectors from ", miller_max, " indexes and ", NUser, " user-given vectors"
|
||||
write(stdout,'(5X,3(A,I5),A)') "Creating ", NAll, " Star vectors from ", miller_max, " indexes and ", &
|
||||
NUser, " user-given vectors"
|
||||
else
|
||||
write(*,*) "Creating ", NAll, " vectors from ", miller_max, " indexes"
|
||||
write(stdout,'(5X,2(A,I5),A)') "Creating ", NAll, " Star vectors from ", miller_max, " indexes"
|
||||
end if
|
||||
!
|
||||
allocate ( VecAll(3,NAll), ModAll(NAll), MapAll(NAll) )
|
||||
|
|
@ -317,16 +316,15 @@ implicit none
|
|||
end if
|
||||
!
|
||||
if(ivec.ne.NAll) then
|
||||
write(*,*) "ERROR: wrong number of lattice vectors for a given miller_max"
|
||||
write(*,*) "miller_max= ",miller_max," ivec=",ivec," NAll=",NAll, " NUser=",NUser
|
||||
stop
|
||||
write(stdout,'(5X,4(A,I5))') "miller_max= ",miller_max," ivec=",ivec," NAll=",NAll, " NUser=",NUser
|
||||
Call errore('find_stars ', ' wrong number of lattice vectors for a given miller_max ' , 1 )
|
||||
endif
|
||||
!
|
||||
write(*,*) "Sorting vectors in shells..."
|
||||
write(stdout,'(5X,A)') "Sorting Star vectors in shells"
|
||||
Call hpsort_eps (NAll, ModAll, MapAll, eps)
|
||||
!
|
||||
write(*,*) "Removing symmetry equivalent lattice vectors..."
|
||||
if(NUser.gt.0) write(*,*) "WARNING: user-given vectors will be removed they are symmetry equivalent"
|
||||
write(stdout,'(5X,A)') "Removing symmetry equivalent lattice vectors"
|
||||
if(NUser.gt.0) write(stdout,'(5X,A)') "WARNING: user-given vectors will be removed if they are symmetry equivalent"
|
||||
!
|
||||
allocate( VecInq(3,NAll) )
|
||||
VecInq = Zero
|
||||
|
|
@ -335,7 +333,7 @@ implicit none
|
|||
NStars = 0
|
||||
do jj = 1, NAll
|
||||
!
|
||||
if(jj.eq.1.or.mod(jj,NPrint).eq.0) write(*,'(5X,I10,A,f12.2,A,I10,A)') &
|
||||
if(jj.eq.1.or.mod(jj,NPrint).eq.0) write(stdout,'(7X,I10,A,f12.2,A,I10,A)') &
|
||||
jj-1, ' (',dble(100*(jj-1))/dble(NAll), '%) vectors analysed ... ', NStars, " Stars found"
|
||||
!
|
||||
jvec = MapAll(jj)
|
||||
|
|
@ -366,7 +364,7 @@ implicit none
|
|||
!
|
||||
end do
|
||||
!
|
||||
write(*,*) NStars, " Stars of symmetry inequivalent lattice vectors found..."
|
||||
write(stdout,'(5X,I5,A)') NStars, " Stars of symmetry inequivalent lattice vectors found..."
|
||||
!
|
||||
! Knowing NStars we can now allocate VecStars with the right size
|
||||
! and deallocate the over-sized VecInq
|
||||
|
|
@ -396,6 +394,13 @@ implicit none
|
|||
integer :: istar, ip, ig, jg, kg, isym
|
||||
complex(dp) :: fp, fpg
|
||||
!
|
||||
if(NUser.gt.0) then
|
||||
write(stdout,'(5X,A)') 'WARNING: since user-defined Star-vectors have been specified, &
|
||||
the program will not stop if the Star functions'
|
||||
write(stdout,'(5X,A)') ' do not have the reciprocal lattice periodicity &
|
||||
(bands symmetry might be broken) '
|
||||
end if
|
||||
!
|
||||
do istar = 1, NStars
|
||||
vec(:) = VecStars(:,istar)
|
||||
do ip = 1, Np
|
||||
|
|
@ -408,19 +413,13 @@ implicit none
|
|||
fpg = star_function(0, pvec(:), vec, NSym, Op)
|
||||
if(abs(fp-fpg).gt.Thr) then
|
||||
if(NUser.gt.0) then
|
||||
write(*,'(A)') 'WARNING: A Star function does not have reciprocal lattice periodicity'
|
||||
else
|
||||
write(*,'(A)') 'ERROR: A Star function does not have reciprocal lattice periodicity'
|
||||
end if
|
||||
write(*,'(A,I5,A,3f12.4)') 'istar: ', istar, ' vec: ', vec(:)
|
||||
write(*,'(A,I5,A,3f12.4,A,2f24.12)') 'ip: ', ip, ' P-vec: ', p(:,ip), ' fp: ', fp
|
||||
write(*,'(3(A,I5),A,3f12.4)') 'ig: ', ig, ' jg: ', jg, ' kg: ', kg, ' G-vec: ', gvec(:)
|
||||
write(*,'(A,3f12.4,A,2f24.12)') 'P+G-vec: ', pvec(:), ' fpg: ', fpg
|
||||
if(NUser.gt.0) then
|
||||
write(stdout,'(5X,A,I5,A,3f12.6)') 'WARNING: broken traslational symmetry for Star ', istar, &
|
||||
', Star vector ', vec(:)
|
||||
go to 30
|
||||
else
|
||||
stop
|
||||
end if
|
||||
write(stdout,'(5X,A,I5,A,3f12.6)') 'Star ', istar, ', Star vector ', vec(:)
|
||||
Call errore('check_stars ', ' broken traslational symmetry for this Star function ', 1)
|
||||
end if
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
|
|
@ -431,14 +430,14 @@ implicit none
|
|||
fpg = star_function(0, pvec(:), vec, NSym, Op)
|
||||
if(abs(fp-fpg).gt.Thr) then
|
||||
if(NUser.gt.0) then
|
||||
write(*,'(A)') 'WARNING: A Star function does not have reciprocal lattice periodicity'
|
||||
write(stdout,'(5X,2(A,I5),A,3f12.6)') 'WARNING: symmetry operation ', isym, 'broken for Star ', istar, &
|
||||
', Star vector ', vec(:)
|
||||
go to 30
|
||||
else
|
||||
write(*,'(A)') 'ERROR: A Star function does not have reciprocal lattice periodicity'
|
||||
write(stdout,'(5X,2(A,I5),A,3f12.6)') 'symmetry operation ', isym, ' is broken for Star ', istar, &
|
||||
', Star vector ', vec(:)
|
||||
Call errore('check_stars ', ' this symmetry operation is broken for this Star function ', 1)
|
||||
end if
|
||||
write(*,'(A,I5,A,3f12.4)') 'istar: ', istar, ' vec: ', vec(:)
|
||||
write(*,'(A,I5,A,3f12.4,A,2f24.12)') 'ip: ', ip, ' P-vec: ', p(:,ip), ' fp: ', fp
|
||||
write(*,'(A,I5,A,3f12.4,A,2f24.12)') 'isym: ', isym, ' OpP: ', pvec(:), ' fpg: ', fpg
|
||||
if(NUser.le.0) stop
|
||||
end if
|
||||
end do
|
||||
30 continue
|
||||
|
|
@ -486,25 +485,18 @@ implicit none
|
|||
complex(dp) :: fStar ! S_m(p_i)
|
||||
complex(dp) :: fStarN ! S_m(p_Np)
|
||||
!
|
||||
if(ialpha.lt.0.or.ialpha.gt.2) then
|
||||
write(*,*) 'ERROR: wrong ialpha in compute_stars'
|
||||
stop
|
||||
end if
|
||||
if(ialpha.lt.0.or.ialpha.gt.2) Call errore( 'compute_stars ' , ' wrong ialpha in compute_stars', 1 )
|
||||
!
|
||||
if(present(DoDiff_)) then
|
||||
DoDiff = DoDiff_
|
||||
if(.not.present(S)) then
|
||||
write(*,*) 'ERROR: please provide S with DoDiff=.true.'
|
||||
stop
|
||||
endif
|
||||
if(.not.present(S)) Call errore( 'compute_stars ' , ' please provide S with DoDiff=.true.' , 1 )
|
||||
else
|
||||
DoDiff = .false.
|
||||
end if
|
||||
!
|
||||
write(*,'(A,L,3(A,I5))') 'compute_stars: DoDiff: ', DoDiff, ' LDA: ', LDA, ' Np:', Np, ' NStars:', NStars
|
||||
if((DoDiff.and.(LDA.ne.(Np-1))).or.(.not.DoDiff.and.(LDA.ne.Np))) then
|
||||
write(*,*) 'ERROR: Wrong dimensions in compute_stars'
|
||||
stop
|
||||
write(stdout,'(A,L,3(A,I5))') 'compute_stars: DoDiff: ', DoDiff, ' LDA: ', LDA, ' Np:', Np, ' NStars:', NStars
|
||||
Call errore( 'compute_stars ' , ' Wrong dimensions in compute_stars', 1 )
|
||||
end if
|
||||
!
|
||||
do istar = 1, NStars
|
||||
|
|
@ -526,7 +518,8 @@ implicit none
|
|||
fStar = star_function(0, p(1:3,ip), vec, NSym, Op)
|
||||
A(ip,istar) = alpha * (fStar-fStarN)
|
||||
end do
|
||||
if(abs(aimag(A(ip,istar))).gt.eps) write(*,*) "Star function: ", ip, istar, A(ip,istar), " WARNING non zero imaginary part!!"
|
||||
if(abs(aimag(A(ip,istar))).gt.eps) write(stdout,'(5X, A,2I5,2f12.6,A)') &
|
||||
"Star function: ", ip, istar, A(ip,istar), " WARNING non zero imaginary part!!"
|
||||
end do
|
||||
!
|
||||
return
|
||||
|
|
@ -534,11 +527,18 @@ implicit none
|
|||
end subroutine compute_stars
|
||||
!----------------------------------------------------------------------------
|
||||
complex(dp) function star_function (iprint, p, vec, NSym, Op)
|
||||
! computes:
|
||||
! S_m(p) = 1\sqrt(NSym) * \sum^NSym e^(2i\pi * (Op*vec) * p )
|
||||
! where:
|
||||
! p ... a reciprocal k-point vector
|
||||
! vec ... a direct lattice vector
|
||||
! Op ... all the space group symmetry operation matrices
|
||||
implicit none
|
||||
integer, intent(in) :: iprint
|
||||
integer, intent(in) :: iprint ! just a debug option for printing
|
||||
integer, intent(in) :: NSym
|
||||
real(dp), intent(in) :: p(1:3), vec(3)
|
||||
real(dp), intent(in) :: Op(1:3,1:3,1:NSym)
|
||||
!
|
||||
! local variables
|
||||
real(dp) :: vecOp(3)
|
||||
real(dp) :: diffMod
|
||||
|
|
@ -558,7 +558,7 @@ implicit none
|
|||
do jsym = 1, NVec
|
||||
! for vecInq=Zero diffMod never .lt.eps
|
||||
diffMod = sqrt((vecOp(1)-vecInq(1,jsym))**2 + (vecOp(2)-vecInq(2,jsym))**2 + (vecOp(3)-vecInq(3,jsym))**2 )
|
||||
if(iprint.gt.0) write(*,'(2(I5,3f6.2,3x))') isym, vecOp(:), jsym, vecInq(:,jsym)
|
||||
if(iprint.gt.0) write(stdout,'(5X,2(I5,3f6.2,3x))') isym, vecOp(:), jsym, vecInq(:,jsym)
|
||||
if(diffMod.lt.eps) go to 20 ! vecOp already included
|
||||
end do
|
||||
! vecOp is new
|
||||
|
|
@ -567,7 +567,7 @@ implicit none
|
|||
carg = (Zero,One) * Two * Pi * dot_product(vecOp,p)
|
||||
cfunc = cfunc + exp(carg)
|
||||
20 continue
|
||||
if(iprint.gt.0) write(*,'(I5,3x,2f12.4)') NVec, cfunc
|
||||
if(iprint.gt.0) write(stdout,'(I5,3x,2f12.4)') NVec, cfunc
|
||||
end do
|
||||
carg = (One,Zero) * sqrt(dble(NVec))
|
||||
star_function = cfunc/carg
|
||||
|
|
@ -601,7 +601,7 @@ implicit none
|
|||
end function sqrt_rho
|
||||
!----------------------------------------------------------------------------
|
||||
subroutine applyOp(isym, OpMat, vec, vecOp)
|
||||
! apply symmetry operation in OpMat:
|
||||
! apply the symmetry operation in OpMat to vec, and return result in vecOp:
|
||||
! vecOp = OpMat * vec
|
||||
implicit none
|
||||
integer, intent(in) :: isym
|
||||
|
|
@ -614,13 +614,12 @@ implicit none
|
|||
vecErr = abs(sqrt(dot_product(vec,vec))-sqrt(dot_product(vecOp,vecOp)))
|
||||
!
|
||||
if (vecErr.gt.eps) then
|
||||
write(*,*) "ERROR: non-unitary symmetry operation found"
|
||||
write(*,*) "isym: ", isym
|
||||
write(*,*) "vec: ", vec(:)
|
||||
write(*,*) "vecOp: ", vecOp(:)
|
||||
write(*,*) "vecErr: ", vecErr
|
||||
write(stdout,'(A,I5)') "isym: ", isym
|
||||
write(stdout,'(A,3f12.6)') "vec: ", vec(:)
|
||||
write(stdout,'(A,3f12.6)') "vecOp: ", vecOp(:)
|
||||
write(stdout,'(A,f12.6)') "vecErr: ", vecErr
|
||||
Call MatPrt("OpMat", 3, 3, OpMat)
|
||||
stop
|
||||
Call errore('applyOp ', ' non-unitary symmetry operation found ', 1 )
|
||||
endif
|
||||
!
|
||||
return
|
||||
|
|
|
|||
|
|
@ -11,7 +11,8 @@
|
|||
!
|
||||
!----------------------------------------------------------------------------
|
||||
MODULE globalmod
|
||||
USE kinds, ONLY : dp
|
||||
USE kinds, ONLY : dp
|
||||
USE io_global, ONLY : stdout
|
||||
implicit none
|
||||
!
|
||||
! a string describing the method used for interpolation
|
||||
|
|
@ -21,11 +22,11 @@ implicit none
|
|||
integer :: Nb
|
||||
!
|
||||
! uniform grid of q-points in the IBZ (cart. coord. in units 2pi/alat)
|
||||
integer :: Nq, Nlines
|
||||
integer :: Nq
|
||||
real(dp), allocatable :: q(:,:), eq(:,:)
|
||||
!
|
||||
! path of k-points in the IBZ
|
||||
real(dp), allocatable :: k(:,:), ek(:,:)
|
||||
! band energies of the path of k-points in the IBZ
|
||||
real(dp), allocatable :: ek(:,:)
|
||||
!
|
||||
! Crystal data
|
||||
real(dp) :: at(3,3) ! real-space lattice translation vectors (cart. coord. in units of alat) a_i(:) = at(:,i)/alat
|
||||
|
|
@ -41,7 +42,6 @@ subroutine read_xml_input ()
|
|||
!
|
||||
! read the xml input file and make all allocations
|
||||
!
|
||||
USE io_global, ONLY : stdout
|
||||
use qes_read_module, ONLY : qes_read
|
||||
use qes_types_module, ONLY : band_structure_type, atomic_structure_type, symmetries_type, basis_set_type
|
||||
use fox_dom
|
||||
|
|
@ -76,7 +76,7 @@ implicit none
|
|||
Nq = bandstr%nks
|
||||
Nb = bandstr%nbnd
|
||||
!
|
||||
write(stdout,'(2(I5,A))') Nq, ' points on the uniform grid, ', Nb, ' bands'
|
||||
write(stdout,'(A,2(I5,A))') 'The uniform grid contains ', Nq, ' q-points and ', Nb, ' bands'
|
||||
!write(stdout,'(A)') 'iq, q(iq, :), e(iq, :)'
|
||||
!
|
||||
allocate( q(3, Nq), eq(Nq, Nb), ek(nkstot,Nb) )
|
||||
|
|
@ -85,7 +85,7 @@ implicit none
|
|||
q(:,iq) = bandstr%ks_energies(iq)%k_point%k_point(:)
|
||||
end do
|
||||
do iq = 1, Nq
|
||||
eq(iq,:) = bandstr%ks_energies(iq)%eigenvalues%vector(:)*27.211386245988
|
||||
eq(iq,:) = bandstr%ks_energies(iq)%eigenvalues%vector(:)*27.2113862459880d0
|
||||
!write(stdout, '(I5,11f12.6)') iq, q(iq, :), eq(iq, :)
|
||||
end do
|
||||
!
|
||||
|
|
@ -96,16 +96,16 @@ implicit none
|
|||
at(1:3,2) = atstr%cell%a2 / atstr%alat
|
||||
at(1:3,3) = atstr%cell%a3 / atstr%alat
|
||||
write(stdout,'(A)') ' Crystal lattice vectors found '
|
||||
write(stdout,'(A,3f12.6)') 'Ra: ' , at(:,1)
|
||||
write(stdout,'(A,3f12.6)') 'Rb: ' , at(:,2)
|
||||
write(stdout,'(A,3f12.6)') 'Rc: ' , at(:,3)
|
||||
write(stdout,'(A,3f12.4)') ' Ra: ' , at(:,1)
|
||||
write(stdout,'(A,3f12.4)') ' Rb: ' , at(:,2)
|
||||
write(stdout,'(A,3f12.4)') ' Rc: ' , at(:,3)
|
||||
bg(1:3,1) = basisstr%reciprocal_lattice%b1
|
||||
bg(1:3,2) = basisstr%reciprocal_lattice%b2
|
||||
bg(1:3,3) = basisstr%reciprocal_lattice%b3
|
||||
write(stdout,'(A)') ' Reciprocal lattice vectors found '
|
||||
write(stdout,'(A,3f12.6)') 'Ga: ' , bg(:,1)
|
||||
write(stdout,'(A,3f12.6)') 'Gb: ' , bg(:,2)
|
||||
write(stdout,'(A,3f12.6)') 'Gc: ' , bg(:,3)
|
||||
write(stdout,'(A,3f12.4)') ' Ga: ' , bg(:,1)
|
||||
write(stdout,'(A,3f12.4)') ' Gb: ' , bg(:,2)
|
||||
write(stdout,'(A,3f12.4)') ' Gc: ' , bg(:,3)
|
||||
Nsym = symstr%nsym
|
||||
write(stdout,'(I5,A)') Nsym, ' symmetry operations found '
|
||||
!
|
||||
|
|
@ -164,7 +164,7 @@ implicit none
|
|||
write(formt,'(A,I5,A)') '(', Nb+1 ,'f24.6)'
|
||||
write(filename, '(A,A)') TRIM(label),'.dat'
|
||||
!
|
||||
write(*,*) 'writing band structure on ', filename
|
||||
write(stdout,'(A,A)') 'writing band structure on ', filename
|
||||
!
|
||||
open(2, file=filename, status='unknown')
|
||||
!
|
||||
|
|
|
|||
|
|
@ -11,6 +11,8 @@
|
|||
!
|
||||
!----------------------------------------------------------------------------
|
||||
MODULE idwmod
|
||||
USE kinds, ONLY : dp
|
||||
USE io_global, ONLY : stdout
|
||||
!
|
||||
! An inverse distance weighting (idw) interpolation is computed here, using the metric proposed by Shepard
|
||||
! (ACM '68: Proceedings of the 1968 23rd ACM national conferenceJanuary 1968 Pages 517–524,
|
||||
|
|
@ -19,8 +21,6 @@ MODULE idwmod
|
|||
!
|
||||
implicit none
|
||||
save
|
||||
!
|
||||
integer, parameter :: dp = selected_real_kind(14,200)
|
||||
!
|
||||
integer :: p_metric ! metric for the (inverse) distance
|
||||
!
|
||||
|
|
@ -43,12 +43,13 @@ implicit none
|
|||
integer :: ib, iq, jq, ik, NCount(2)
|
||||
!
|
||||
if (iwhat.ne.1.and.iwhat.ne.2) then
|
||||
write(*,*) 'wrong iwhat in IDW method'
|
||||
write(stdout,'(A)') 'wrong iwhat in IDW method'
|
||||
stop
|
||||
else
|
||||
write(*,'(A)') '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
|
||||
write(*,'(A)') 'Inverse distance weighting (IDW) interpolation method'
|
||||
write(*,'(4(A,I5))') 'iwhat: ',iwhat, ' Nb: ',Nb, ' Nq: ',Nq, ' Nk: ',nkstot
|
||||
write(stdout,'(A)') ''
|
||||
write(stdout,'(A)') '--- Inverse distance weighting (IDW) interpolation method ---'
|
||||
write(stdout,'(A)') ''
|
||||
!write(stdout,'(4(A,I5))') 'iwhat: ',iwhat, ' Nb: ',Nb, ' Nq: ',Nq, ' Nk: ',nkstot
|
||||
end if
|
||||
!
|
||||
if(iwhat.eq.2) then
|
||||
|
|
@ -69,7 +70,7 @@ implicit none
|
|||
end do
|
||||
end do
|
||||
R = scale_sphere * Rmin
|
||||
write(*,*) 'Sphere radius: ', Rmin, ' Scaled sphere radius: ', R
|
||||
write(stdout,'(2(A,f12.6))') 'Minimum spacing between the uniform grid points: ', Rmin, ' Scaled sphere radius: ', R
|
||||
end if
|
||||
!
|
||||
dthr = 0.0000010d0
|
||||
|
|
@ -110,22 +111,20 @@ implicit none
|
|||
else
|
||||
ek(ik,ib) = eq(iq,ib)
|
||||
NCount(1) = NCount(1) + 1
|
||||
!write(*,*) ib, ik, iq, ' found', d
|
||||
go to 10
|
||||
end if
|
||||
end do
|
||||
ek(ik,ib) = esum / dsum
|
||||
!
|
||||
if(dsum.lt.dthr) then
|
||||
write(*,'(A,3f12.6)') 'ERROR: no uniform grid points found for k-point:', xk(:,ik)
|
||||
write(*,'(A)') ' increase the search radius and check nosym=true in SCF '
|
||||
write(*,'(2I5, 3f12.6, 2I5)') ib, ik, esum, dsum, ek(ik, ib), NCount(:)
|
||||
stop
|
||||
write(stdout,'(A,3f12.6)') 'no uniform grid points found for k-point:', xk(:,ik)
|
||||
write(stdout,'(A)') 'increase the search radius and check nosym=true in SCF '
|
||||
write(stdout,'(2I5, 3f12.6, 2I5)') ib, ik, esum, dsum, ek(ik, ib), NCount(:)
|
||||
Call errore( 'idw ', ' wrong sphere radius ', 1 )
|
||||
endif
|
||||
!
|
||||
10 continue
|
||||
!
|
||||
!write(*,*) ib, ik, iq, esum, dsum, ek(ik, ib)
|
||||
end do
|
||||
end do
|
||||
!
|
||||
|
|
|
|||
Loading…
Reference in New Issue