diff --git a/2D_TSC.f90 b/2D_TSC.f90 deleted file mode 100644 index 4debc769..00000000 --- a/2D_TSC.f90 +++ /dev/null @@ -1,904 +0,0 @@ -subroutine ham_slab_surface_zeeman(k, Hamk_slab_surf_zeeman) - ! This subroutine is used to caculate Hamiltonian for - ! slab system with surface Zeeman splitting. - ! - ! History - ! 4/18/2010 by Quansheng Wu - ! 6/21/2022 by Aiyun Luo - ! 4/07/2024 by Jingnan Hu - ! Copyright (c) 2010 QuanSheng Wu. All rights reserved. - - use para - implicit none - - ! loop index - integer :: i1, i2, i, ii - - ! wave vector in 2d - real(Dp), intent(in) :: k(2) - - ! Hamiltonian of slab system with surface Zeeman splitting - complex(Dp), intent(out) :: Hamk_slab_surf_zeeman(Num_wann*nslab,Num_wann*nslab) - - ! the factor 2 is induced by spin - complex(Dp), allocatable :: Hij(:, :, :) - - allocate( Hij(-ijmax:ijmax,Num_wann,Num_wann)) - - call ham_qlayer2qlayer2(k,Hij) - - Hamk_slab_surf_zeeman= 0.0d0 - ! i1 column index - do i1=1, nslab - ! i2 row index - do i2=1, nslab - if (abs(i2-i1).le.ijmax)then - Hamk_slab_surf_zeeman((i2-1)*Num_wann+1:(i2-1)*Num_wann+Num_wann,& - (i1-1)*Num_wann+1:(i1-1)*Num_wann+Num_wann )& - = Hij(i1-i2,1:Num_wann,1:Num_wann) - endif - enddo ! i2 - enddo ! i1 - - !> There are several types of Zeeman splitting - - !> 1. Add Zeeman splitting only in the bottom slab - if(Add_surf_zeeman_field == 1) then - do i=1, Num_wann/2 - ii= i - !>Bz_surf - Hamk_slab_surf_zeeman(ii, ii)= Hamk_slab_surf_zeeman(ii, ii)+ Bz_surf* eV2Hartree - Hamk_slab_surf_zeeman(ii+Num_wann/2, ii+Num_wann/2)= Hamk_slab_surf_zeeman(ii+Num_wann/2, ii+Num_wann/2)- Bz_surf* eV2Hartree - !>Bx_surf, By_surf - Hamk_slab_surf_zeeman(ii, ii+Num_wann/2)= Hamk_slab_surf_zeeman(ii, ii+Num_wann/2)+ Bx_surf* eV2Hartree- zi*By_surf* eV2Hartree - Hamk_slab_surf_zeeman(ii+Num_wann/2, ii)= Hamk_slab_surf_zeeman(ii+Num_wann/2, ii)+ Bx_surf* eV2Hartree+ zi*By_surf* eV2Hartree - enddo - endif - - !> 2. Add Zeeman splitting only in the top slab - if(Add_surf_zeeman_field == 2) then - do i=1, Num_wann/2 - ii= (nslab-1)*Num_wann+ i - !>Bz_surf - Hamk_slab_surf_zeeman(ii, ii)= Hamk_slab_surf_zeeman(ii, ii)+ Bz_surf* eV2Hartree - Hamk_slab_surf_zeeman(ii+Num_wann/2, ii+Num_wann/2)= Hamk_slab_surf_zeeman(ii+Num_wann/2, ii+Num_wann/2)- Bz_surf* eV2Hartree - !>Bx_surf, By_surf - Hamk_slab_surf_zeeman(ii, ii+Num_wann/2)= Hamk_slab_surf_zeeman(ii, ii+Num_wann/2)+ Bx_surf* eV2Hartree- zi*By_surf* eV2Hartree - Hamk_slab_surf_zeeman(ii+Num_wann/2, ii)= Hamk_slab_surf_zeeman(ii+Num_wann/2, ii)+ Bx_surf* eV2Hartree+ zi*By_surf* eV2Hartree - enddo - endif - - !> 3. Add Zeeman splitting only in top & bottom two slab - if(Add_surf_zeeman_field == 3) then - do i=1, Num_wann/2 - ii= i - !>Bz_surf - Hamk_slab_surf_zeeman(ii, ii)= Hamk_slab_surf_zeeman(ii, ii)+ Bz_surf* eV2Hartree - Hamk_slab_surf_zeeman(ii+Num_wann/2, ii+Num_wann/2)= Hamk_slab_surf_zeeman(ii+Num_wann/2, ii+Num_wann/2)- Bz_surf* eV2Hartree - !>Bx_surf, By_surf - Hamk_slab_surf_zeeman(ii, ii+Num_wann/2)= Hamk_slab_surf_zeeman(ii, ii+Num_wann/2)+ Bx_surf* eV2Hartree- zi*By_surf* eV2Hartree - Hamk_slab_surf_zeeman(ii+Num_wann/2, ii)= Hamk_slab_surf_zeeman(ii+Num_wann/2, ii)+ Bx_surf* eV2Hartree+ zi*By_surf* eV2Hartree - enddo - do i=1, Num_wann/2 - ii= (nslab-1)*Num_wann+ i - !>Bz_surf - Hamk_slab_surf_zeeman(ii, ii)= Hamk_slab_surf_zeeman(ii, ii)+ Bz_surf* eV2Hartree - Hamk_slab_surf_zeeman(ii+Num_wann/2, ii+Num_wann/2)= Hamk_slab_surf_zeeman(ii+Num_wann/2, ii+Num_wann/2)- Bz_surf* eV2Hartree - !>Bx_surf, By_surf - Hamk_slab_surf_zeeman(ii, ii+Num_wann/2)= Hamk_slab_surf_zeeman(ii, ii+Num_wann/2)+ Bx_surf* eV2Hartree- zi*By_surf* eV2Hartree - Hamk_slab_surf_zeeman(ii+Num_wann/2, ii)= Hamk_slab_surf_zeeman(ii+Num_wann/2, ii)+ Bx_surf* eV2Hartree+ zi*By_surf* eV2Hartree - enddo - endif - - ! check hermitcity - do i1=1,nslab*Num_wann - do i2=1,nslab*Num_wann - if(abs(Hamk_slab_surf_zeeman(i1,i2)-conjg(Hamk_slab_surf_zeeman(i2,i1))).ge.1e-6)then - write(stdout,*)'there are something wrong with Hamk_slab_surf_zeeman' - stop - endif - enddo - enddo - - deallocate(Hij) - return - end subroutine ham_slab_surface_zeeman - - subroutine ham_slab_BdG(k,Hamk_slab_BdG) - ! This subroutine is used to caculate Hamiltonian for - ! slab BdG system . - ! - ! History - ! 03/30/2022 by Aiyun Luo - ! 4/07/2024 by Jingnan Hu - - use para - use Kronecker, only : KronProd ! Kroneker product - - implicit none - - ! loop index - integer :: i1, i2 - - ! wave vector in 2d - real(Dp), intent(in) :: k(2) - - !real(Dp) :: k1(2) - - - ! Hamiltonian of slab BdG system - complex(Dp), intent(out) :: Hamk_slab_BdG(Num_wann_BdG*nslab,Num_wann_BdG*nslab) - - ! Hamiltonian of slab system with Zeeman splitting in the top or bottom surface - complex(Dp), allocatable :: Hamk_slab(:,:) - complex(Dp), allocatable :: Hamk_slab_minus(:,:) - - ! superconducting pairing strength, here we only consider the onsite s-wave pairing - complex(Dp), allocatable :: Hamk_Delta(:,:) - - ! Pauli matrices - complex(Dp) :: sigmax(2,2), sigmay(2,2), sigmaz(2,2), sigma0(2,2) - - ! indetify diagnoal matrix for construct s-wave pairing - complex(Dp), allocatable :: I_nslab(:,:) - complex(Dp), allocatable :: I_norb(:,:) - complex(Dp), allocatable :: I_mu(:,:) - complex(Dp), allocatable :: Hamk_temp(:,:) - - allocate(Hamk_slab(Num_wann*nslab,Num_wann*nslab)) - allocate(Hamk_slab_minus(Num_wann*nslab,Num_wann*nslab)) - allocate(I_nslab(nslab, nslab)) - allocate(I_norb(Num_wann/2, Num_wann/2)) - allocate(I_mu(nslab*Num_wann, nslab*Num_wann)) - allocate(Hamk_temp(Num_wann, Num_wann)) - allocate(Hamk_Delta(Num_wann*Nslab, Num_wann*Nslab)) - - Hamk_slab_BdG = 0.0d0 - Hamk_slab = 0.0d0; Hamk_slab_minus = 0.0d0 - I_nslab = 0.0d0; I_norb = 0.0d0 - I_mu = 0.0d0 - Hamk_temp = 0.0d0; Hamk_Delta = 0.0d0 - - sigmax(1,1)= (0.0d0, 0.0d0); sigmax(1,2)= (1.0d0, 0.0d0) - sigmax(2,1)= (1.0d0, 0.0d0); sigmax(2,2)= (0.0d0, 0.0d0) - - sigmay(1,1)= (0.0d0, 0.0d0); sigmay(1,2)= (0.0d0,-1.0d0) - sigmay(2,1)= (0.0d0, 1.0d0); sigmay(2,2)= (0.0d0, 0.0d0) - - sigmaz(1,1)= (1.0d0, 0.0d0); sigmaz(1,2)= ( 0.0d0, 0.0d0) - sigmaz(2,1)= (0.0d0, 0.0d0); sigmaz(2,2)= (-1.0d0, 0.0d0) - - sigma0(1,1)= (1.0d0, 0.0d0); sigma0(1,2)= (0.0d0, 0.0d0) - sigma0(2,1)= (0.0d0, 0.0d0); sigma0(2,2)= (1.0d0, 0.0d0) - - call ham_slab_surface_zeeman( k, Hamk_slab) - call ham_slab_surface_zeeman(-k, Hamk_slab_minus) - - !> s-wave superconducting pairing for basis: up up dn dn (wannier90_hr.dat from vasp) - !> s-wave pairing: Kron(I_nslab, Kron(i*sigmay*Delta_BdG, I_norb)) - call eye_mat(Num_wann/2, I_norb) - call eye_mat(nslab*Num_wann,I_mu) - - if(Add_Delta_BdG == 1) then - I_nslab(1,1)=1.0d0 - endif - - if(Add_Delta_BdG == 2) then - I_nslab(nslab,nslab)=1.0d0 - endif - - if(Add_Delta_BdG == 3) then - call eye_mat(nslab, I_nslab) - endif - - Hamk_temp= KronProd(zi*Delta_BdG*sigmay*eV2Hartree, I_norb) - Hamk_Delta= KronProd(I_nslab, Hamk_temp) - - !> constructing the slab BdG Hamiltonian with top or bottom surface exchange field - !> basis: C1^dag, C2^dag, C1, C2 - Hamk_slab_BdG(1:nslab*Num_wann,1:nslab*Num_wann)= Hamk_slab-mu_BdG*eV2Hartree*I_mu - Hamk_slab_BdG(nslab*Num_wann+1:nslab*Num_wann_BdG,nslab*Num_wann+1:nslab*Num_wann_BdG)= -1.0d0*conjg(Hamk_slab_minus)+mu_BdG*eV2Hartree*I_mu - !> add onsite s-wave pairing into slab BdG Hamiltonian - Hamk_slab_BdG(1:nslab*Num_wann, nslab*Num_wann+1: nslab*Num_wann_BdG)= Hamk_Delta - Hamk_slab_BdG(nslab*Num_wann+1: nslab*Num_wann_BdG, 1:nslab*Num_wann)= transpose(conjg(Hamk_Delta)) - - ! check hermitcity - do i1=1,nslab*Num_wann_BdG - do i2=1,nslab*Num_wann_BdG - if(abs(Hamk_slab_BdG(i1,i2)-conjg(Hamk_slab_BdG(i2,i1))).ge.1e-6)then - write(stdout,*)'there are something wrong with Hamk_slab_BdG' - stop - endif - enddo - enddo - - deallocate(Hamk_slab) - deallocate(Hamk_slab_minus) - deallocate(I_nslab) - deallocate(I_norb) - deallocate(Hamk_temp) - deallocate(Hamk_Delta) - return -end subroutine ham_slab_BdG - -subroutine eye_mat(ndim, A) - use para, only : Dp - implicit none - - integer, intent(in) :: ndim - complex(Dp), intent(out) :: A(ndim, ndim) - - !> loop index - integer :: i, j - - do i=1, ndim - do j=1, ndim - if(i.eq.j) then - A(i, j)= 1.0d0 - else - A(i, j)= 0.0d0 - endif - enddo ! i - enddo ! j - - return -end subroutine eye_mat - -subroutine ek_slab_BdG - !> This subroutine is used for calculating BdG energy - !> dispersion with wannier functions for 2D slab system - !> Added by Aiyun Luo at 2022/03 - ! - ! Copyright (c) 2010 QuanSheng Wu. All rights reserved. - - use wmpi - use para - implicit none - - ! loop index - integer :: i, j, l, lwork, ierr, io - - real(Dp) :: k(2), emin, emax, maxweight - - ! time measurement - real(dp) :: time_start, time_end, time_start0 - - ! parameters for zheev - real(Dp), allocatable :: rwork(:) - complex(Dp), allocatable :: work(:) - - ! eigenvalue - real(Dp), allocatable :: eigenvalue_BdG(:) - - ! energy dispersion - real(Dp),allocatable :: ekslab_BdG(:,:), ekslab_BdG_mpi(:,:) - - !> color for plot, surface state weight - real(dp), allocatable :: surf_l_weight_BdG(:, :), surf_l_weight_BdG_mpi(:, :) - real(dp), allocatable :: surf_r_weight_BdG(:, :), surf_r_weight_BdG_mpi(:, :) - - ! hamiltonian slab - complex(Dp),allocatable ::CHamk_BdG(:,:) - - lwork= 16*Nslab*Num_wann_BdG - ierr = 0 - - - allocate(eigenvalue_BdG(nslab*Num_wann_BdG)) - allocate( surf_l_weight_BdG (Nslab* Num_wann_BdG, knv2)) - allocate( surf_l_weight_BdG_mpi (Nslab* Num_wann_BdG, knv2)) - allocate( surf_r_weight_BdG (Nslab* Num_wann_BdG, knv2)) - allocate( surf_r_weight_BdG_mpi (Nslab* Num_wann_BdG, knv2)) - allocate(ekslab_BdG(Nslab*Num_wann_BdG,knv2)) - allocate(ekslab_BdG_mpi(Nslab*Num_wann_BdG,knv2)) - allocate(CHamk_BdG(nslab*Num_wann_BdG,nslab*Num_wann_BdG)) - allocate(work(lwork)) - allocate(rwork(lwork)) - - surf_l_weight_BdG= 0d0 - surf_l_weight_BdG_mpi= 0d0 - surf_r_weight_BdG= 0d0 - surf_r_weight_BdG_mpi= 0d0 - - ! sweep k - ekslab_BdG=0.0d0 - ekslab_BdG_mpi=0.0d0 - time_start= 0d0 - time_start0= 0d0 - call now(time_start0) - time_start= time_start0 - time_end = time_start0 - do i= 1+cpuid, knv2, num_cpu - if (cpuid==0.and. mod(i/num_cpu, 4)==0) & - write(stdout, '(a, i9, " /", i10, a, f10.1, "s", a, f10.1, "s")') & - ' Slabek: ik', i, knv2, ' time left', & - (knv2-i)*(time_end- time_start)/num_cpu, & - ' time elapsed: ', time_end-time_start0 - - call now(time_start) - - k= k2_path(i, :) - chamk_BdG=0.0d0 - - call ham_slab_BdG(k,Chamk_BdG) - - - eigenvalue_BdG=0.0d0 - - ! diagonal Chamk - call eigensystem_c('V', 'U', Num_wann_BdG*Nslab, CHamk_BdG, eigenvalue_BdG) - - ekslab_BdG(:,i)=eigenvalue_BdG - - ! H*chamk(:,n)=E(n)*chamk(:,n) - !> Nslab*Num_wann - !> rho(:)=abs(chamk(:,n))**2 - !> (a1 o1, o2 o3, a2, o1, o2, o3; a1 o1, o2 o3, a2, o1, o2, o3), (a1 o1, o2 o3, a2, o1, o2, o3; a1 o1, o2 o3, a2, o1, o2, o3), (a1 o1, o2 o3, a2, o1, o2, o3; a1 o1, o2 o3, a2, o1, o2, o3), - do j=1, Nslab* Num_wann_BdG - !> left is the bottom surface - do l= 1, NBottomOrbitals - io= BottomOrbitals(l) - surf_l_weight_BdG(j, i)= surf_l_weight_BdG(j, i) & - + abs(CHamk_BdG(io, j))**2 & ! first slab -- electron - + abs(CHamk_BdG(Num_wann*Nslab+io, j))**2 ! first slab -- hole - enddo ! l sweeps the selected orbitals - - !> right is the top surface - do l= 1, NTopOrbitals - io= Num_wann*(Nslab-1)+ TopOrbitals(l) - surf_r_weight_BdG(j, i)= surf_r_weight_BdG(j, i) & - + abs(CHamk_BdG(io, j))**2 & ! first slab -- electron - + abs(CHamk_BdG(Num_wann*Nslab+io, j))**2 ! first slab -- hole - enddo ! l sweeps the selected orbitals - - enddo ! j - call now(time_end) - enddo ! i - -#if defined (MPI) - call mpi_allreduce(ekslab_BdG,ekslab_BdG_mpi,size(ekslab_BdG),& - mpi_dp,mpi_sum,mpi_cmw,ierr) - call mpi_allreduce(surf_l_weight_BdG, surf_l_weight_BdG_mpi,size(surf_l_weight_BdG),& - mpi_dp,mpi_sum,mpi_cmw,ierr) - call mpi_allreduce(surf_r_weight_BdG, surf_r_weight_BdG_mpi,size(surf_r_weight_BdG),& - mpi_dp,mpi_sum,mpi_cmw,ierr) -#else - ekslab_BdG_mpi= ekslab_BdG - surf_l_weight_BdG_mpi= surf_l_weight_BdG - surf_r_weight_BdG_mpi= surf_r_weight_BdG -#endif - - ekslab_BdG_mpi= ekslab_BdG_mpi/eV2Hartree - - ekslab_BdG=ekslab_BdG_mpi - - maxweight=maxval(surf_r_weight_BdG_mpi+ surf_l_weight_BdG_mpi) - surf_l_weight_BdG= surf_l_weight_BdG_mpi/ maxweight - surf_r_weight_BdG= surf_r_weight_BdG_mpi/ maxweight - - outfileindex= outfileindex+ 1 - if(cpuid==0)then - open(unit=outfileindex, file='slabek_BdG.dat') - write(outfileindex, "('#', a10, a15, 5X, 2a16 )")'# k', ' E', 'BS weight', 'TS weight' - do j=1, Num_wann_BdG*Nslab - do i=1, knv2 - !write(outfileindex,'(3f15.7, i8)')k2len(i), ekslab(j,i), & - ! (surf_weight(j, i)) - write(outfileindex,'(2f15.7, 2f16.7)')k2len(i)*Angstrom2atomic, ekslab_BdG(j,i), & - (surf_l_weight_BdG(j, i)), & - (surf_r_weight_BdG(j, i)) - enddo - write(outfileindex , *)'' - enddo - close(outfileindex) - write(stdout,*) 'calculate energy band done' - endif - - emin= minval(ekslab_BdG)-0.5d0 - emax= maxval(ekslab_BdG)+0.5d0 - !> write script for gnuplot - outfileindex= outfileindex+ 1 - if (cpuid==0) then - open(unit=outfileindex, file='slabek_BdG.gnu') - write(outfileindex, '(a)')"set encoding iso_8859_1" - write(outfileindex, '(a)')'#set terminal postscript enhanced color' - write(outfileindex, '(a)')"#set output 'slabek_BdG.eps'" - write(outfileindex, '(3a)')'#set terminal pngcairo truecolor enhanced', & - ' font ",60" size 1920, 1680' - write(outfileindex, '(3a)')'set terminal png truecolor enhanced', & - ' font ",60" size 1920, 1680' - write(outfileindex, '(a)')"set output 'slabek_BdG.png'" - write(outfileindex,'(2a)') 'set palette defined ( 0 "green", ', & - '5 "yellow", 10 "red" )' - write(outfileindex, '(a)')'set style data linespoints' - write(outfileindex, '(a)')'unset ztics' - write(outfileindex, '(a)')'unset key' - write(outfileindex, '(a)')'set pointsize 0.8' - write(outfileindex, '(a)')'set border lw 3 ' - write(outfileindex, '(a)')'set view 0,0' - write(outfileindex, '(a)')'#set xtics font ",36"' - write(outfileindex, '(a)')'#set ytics font ",36"' - write(outfileindex, '(a)')'#set ylabel font ",36"' - write(outfileindex, '(a)')'#set xtics offset 0, -1' - write(outfileindex, '(a)')'set ylabel offset -1, 0 ' - write(outfileindex, '(a, f10.5, a)')'set xrange [0: ', maxval(k2len)*Angstrom2atomic, ']' - if (index(Particle,'phonon')/=0) then - write(outfileindex, '(a, f10.5, a)')'set yrange [0:', emax, ']' - write(outfileindex, '(a)')'set ylabel "Frequency (THz)"' - else - write(outfileindex, '(a)')'set ylabel "Energy (eV)"' - write(outfileindex, '(a, f10.5, a, f10.5, a)')'set yrange [', emin, ':', emax, ']' - endif - write(outfileindex, 202, advance="no") (trim(k2line_name(i)), k2line_stop(i)*Angstrom2atomic, i=1, nk2lines) - write(outfileindex, 203)trim(k2line_name(nk2lines+1)), k2line_stop(nk2lines+1)*Angstrom2atomic - - do i=1, nk2lines-1 - if (index(Particle,'phonon')/=0) then - write(outfileindex, 204)k2line_stop(i+1)*Angstrom2atomic, 0.0, k2line_stop(i+1)*Angstrom2atomic, emax - else - write(outfileindex, 204)k2line_stop(i+1)*Angstrom2atomic, emin, k2line_stop(i+1)*Angstrom2atomic, emax - endif - enddo - write(outfileindex, '(a)')'#rgb(r,g,b) = int(r)*65536 + int(g)*256 + int(b)' - write(outfileindex, '(2a)')"#plot 'slabek.dat' u 1:2:(rgb(255,$3, 3)) ", & - "w lp lw 2 pt 7 ps 1 lc rgb variable" - write(outfileindex, '(2a)')"# (a) " - write(outfileindex, '(2a)')"# plot the top and bottom surface's weight together" - write(outfileindex, '(2a)')"#plot 'slabek.dat' u 1:2:($3+$4) ", & - "w lp lw 2 pt 7 ps 1 lc palette" - write(outfileindex, '(2a)')"# (b) " - write(outfileindex, '(2a)') & - "# plot top and bottom surface's weight with red and blue respectively" - write(outfileindex,'(2a)') 'set palette defined ( -1 "blue", ', & - '0 "grey", 1 "red" )' - write(outfileindex, '(2a)')"plot 'slabek_BdG.dat' u 1:2:($4-$3) ", & - "w lp lw 2 pt 7 ps 1 lc palette" - - !write(outfileindex, '(2a)')"splot 'slabek.dat' u 1:2:3 ", & - ! "w lp lw 2 pt 13 palette" - close(outfileindex) - endif - - 202 format('set xtics (',:20('"',A3,'" ',F10.5,',')) - 203 format(A3,'" ',F10.5,')') - 204 format('set arrow from ',F10.5,',',F10.5, & - ' to ',F10.5,',',F10.5, ' nohead') - - deallocate(eigenvalue_BdG) - deallocate( surf_l_weight_BdG ) - deallocate( surf_l_weight_BdG_mpi ) - deallocate( surf_r_weight_BdG ) - deallocate( surf_r_weight_BdG_mpi ) - deallocate(ekslab_BdG) - deallocate(ekslab_BdG_mpi) - deallocate(CHamk_BdG) - deallocate(work) - deallocate(rwork) - -return -end subroutine ek_slab_BdG - -subroutine wannier_center2D_BdG - ! This suboutine is used for wannier center calculation for slab system - ! - ! Copyright (c) 2010 QuanSheng Wu. All rights reserved. - - use para - use wmpi - implicit none - - integer :: Nkx - integer :: Nky - - integer :: i, j, l, ia, ia1, m - integer :: nfill - - integer :: ikx - integer :: iky - - integer :: ierr - - !> k points in kx-ky plane - real(dp), allocatable :: kpoints(:, :, :) - - !> hamiltonian for each k point - !> and also the eigenvector of hamiltonian after eigensystem_c - complex(dp), allocatable :: Hamk(:, :) - complex(dp), allocatable :: Hamk_dag(:, :) - - !> eigenvector for each kx - complex(dp), allocatable :: Eigenvector(:, :, :) - - !> Mmnkb= - !> |u_n(k)> is the periodic part of wave function - complex(dp), allocatable :: Mmnkb(:, :) - complex(dp), allocatable :: Mmnkb_com(:, :) - complex(dp), allocatable :: Mmnkb_full(:, :) - - !> - complex(dp), allocatable :: Lambda_eig(:) - complex(dp), allocatable :: Lambda(:, :) - complex(dp), allocatable :: Lambda0(:, :) - - !> three matrix for SVD - !> M= U.Sigma.V^\dag - !> VT= V^\dag - complex(dp), allocatable :: U(:, :) - real (dp), allocatable :: Sigma(:, :) - complex(dp), allocatable :: VT(:, :) - - !> wannier centers for each ky, bands - real(dp), allocatable :: WannierCenterKy(:, :) - real(dp), allocatable :: WannierCenterKy_mpi(:, :) - - !> eigenvalue - real(dp), allocatable :: eigenvalue(:) - - !> 2D surface BZ - real(dp) :: kx - real(dp) :: ky - real(dp) :: k(2), b(2) - real(dp) :: k0(2), k1(2), k2(2) - - !> b.R - real(dp) :: br - - !> exp(-i*b.R) - complex(dp) :: ratio - - real(dp) :: slab_Rua(2) - real(dp) :: slab_Rub(2) - real(dp) :: slab_Kua(2) - real(dp) :: slab_Kub(2) - real(dp) :: cell_slab - - !> for each orbital, it correspond to an atom - !> dim= Num_wann_BdG - integer, allocatable :: AtomIndex_orbital(:) - - !> atom position in the unit cell - !> for slab BdG system, dim=Nslab*Origin_cell%Num_atoms - real(dp), allocatable :: AtomsPosition_unitcell(:, :) - real(dp), allocatable :: AtomsPosition_supercell(:,:) - - real(dp) :: Umatrix_t(3,3) - - - Nkx= Nk1 - Nky= Nk2 - - nfill= Num_wann*Nslab - - allocate(kpoints(2, Nkx, Nky)) - kpoints= 0d0 - - allocate(Lambda_eig(nfill)) - allocate(Lambda(nfill, nfill)) - allocate(Lambda0(nfill, nfill)) - allocate(Mmnkb(nfill, nfill)) - allocate(Mmnkb_com(nfill, nfill)) - allocate(Mmnkb_full(Num_wann_BdG*Nslab, Num_wann_BdG*Nslab)) - allocate(hamk(Num_wann_BdG*Nslab, Num_wann_BdG*Nslab)) - allocate(hamk_dag(Num_wann_BdG*Nslab, Num_wann_BdG*Nslab)) - allocate(Eigenvector(Num_wann_BdG*Nslab, Num_wann_BdG*Nslab, Nkx)) - allocate(eigenvalue(Num_wann_BdG*Nslab)) - allocate(U(nfill, nfill)) - allocate(Sigma(nfill, nfill)) - allocate(VT(nfill, nfill)) - allocate(WannierCenterKy(nfill, Nky)) - allocate(WannierCenterKy_mpi(nfill, Nky)) - allocate(AtomIndex_orbital(Num_wann_BdG*Nslab)) - allocate(AtomsPosition_unitcell(3, Origin_cell%Num_atoms)) - allocate(AtomsPosition_supercell(3, Nslab*Origin_cell%Num_atoms)) - WannierCenterKy= 0d0 - WannierCenterKy_mpi= 0d0 - hamk=0d0 - eigenvalue=0d0 - Eigenvector=0d0 - Mmnkb_full=0d0 - Mmnkb=0d0 - Mmnkb_com=0d0 - Lambda =0d0 - Lambda0=0d0 - U= 0d0 - Sigma= 0d0 - VT= 0d0 - - slab_Rua= 0.0d0 - slab_Rub= 0.0d0 - slab_Kua= 0.0d0 - slab_kub= 0.0d0 - cell_slab= 0.0d0 - - slab_Rua= Rua_new(1:2) - slab_Rub= Rub_new(1:2) - cell_slab= slab_Rua(1)* slab_Rub(2)- slab_Rua(2)* slab_Rub(1) - cell_slab= abs(cell_slab) - - if (abs(cell_slab)< 1e-6) stop "cell_volume equal to 0" - - slab_Kua(1)= 2d0*pi/cell_slab*slab_Rub(2) - slab_Kua(2)=-2d0*pi/cell_slab*slab_Rub(1) - slab_Kub(1)=-2d0*pi/cell_slab*slab_Rua(2) - slab_Kub(2)= 2d0*pi/cell_slab*slab_Rua(1) - - if (cpuid==0) then - write(stdout, *)'2D Primitive Cell_Volume: ', cell_slab - write(stdout, *)'slab_Rua, slab_Rub' - write(stdout, '(3f10.4)')slab_Rua - write(stdout, '(3f10.4)')slab_Rub - write(stdout, *)'slab_Kua, slab_Kub' - write(stdout, '(3f10.4)')slab_Kua - write(stdout, '(3f10.4)')slab_Kub - endif - - b= 0.0d0 - b(1)= 1.d0/real(Nkx) - b(2)= 0.d0 - b= b(1)*slab_Kua+ b(2)*slab_Kub - - k0= K2D_start - k1= K2D_vec1 - k2= K2D_vec2 - do iky=1, Nky - do ikx=1, Nkx - kpoints(:, ikx, iky)= k0+ k1*dble(ikx-1.d0)/dble(Nkx)+ k2*(iky-1)/dble(Nky-1d0) - enddo - enddo - - !> set up atom index for each orbitals in the basis - if (soc>0) then !> with spin-orbit coupling - l= 0 - do i=1, Nslab - do ia=1, Origin_cell%Num_atoms !> spin up - do j=1, Origin_cell%nprojs(ia) - l= l+ 1 - AtomIndex_orbital(l)= ia+ (i-1)*Origin_cell%Num_atoms !> electron - AtomIndex_orbital(l+ Num_wann*Nslab)= ia+ (i-1)*Origin_cell%Num_atoms !> hole - enddo ! j - enddo ! ia - do ia=1, Origin_cell%Num_atoms !> spin down - do j=1, Origin_cell%nprojs(ia) - l= l+ 1 - AtomIndex_orbital(l)= ia+ (i-1)*Origin_cell%Num_atoms !> electron - AtomIndex_orbital(l+ Num_wann*Nslab)= ia+ (i-1)*Origin_cell%Num_atoms !> hole - enddo ! j - enddo ! ia - enddo ! i - endif - - if (cpuid==0) then - write(stdout, *)'AtomIndex_orbital: ' - write(stdout, *)AtomIndex_orbital - endif - - Umatrix_t= transpose(Umatrix) - call inv_r(3, Umatrix_t) - - !> set up atoms' position in the unit cell of the new basis - !> only for 2D slab system - AtomsPosition_unitcell=0.0d0 - do ia=1, Origin_cell%Num_atoms - do i=1, 3 - do j=1,3 - AtomsPosition_unitcell(i,ia)= AtomsPosition_unitcell(i, ia)+ & - Umatrix_t(i,j)*Origin_cell%Atom_position_cart(j, ia) - enddo ! j - enddo ! i - enddo ! ia - - if (cpuid==0) then - write(stdout, *)'AtomPosition_unitcell: ' - do ia= 1, Origin_cell%Num_atoms - write(stdout, "(3f12.6)")AtomsPosition_unitcell(:,ia) - enddo - endif - - !> set up atoms' position in the supercell - !> actually, we only need the first two corordinates: x, y - AtomsPosition_supercell=0.0d0 - ia1= 0 - do i=1, Nslab - do ia=1, Origin_cell%Num_atoms - ia1= ia1+ 1 - AtomsPosition_supercell(1, ia1)= AtomsPosition_unitcell(1,ia) - AtomsPosition_supercell(2, ia1)= AtomsPosition_unitcell(2,ia) - enddo ! ia - enddo ! i - - if (cpuid==0) then - write(stdout, *) 'AtomPosition_supercell: ' - do ia=1, Nslab*Origin_cell%Num_atoms - write(stdout, "(3f12.6)")AtomsPosition_supercell(:,ia) - enddo - endif - - - !> for each ky, we can get wanniercenter - do iky=1+ cpuid, nky, num_cpu - Lambda0=0d0 - do i=1, nfill - Lambda0(i, i)= 1d0 ! lam0=I - enddo - - if (cpuid==0) print *, iky, nky - !> for each kx, we get the eigenvectors - do ikx=1, nkx - k(1)= kpoints(1, ikx, iky) - k(2)= kpoints(2, ikx, iky) - - call ham_slab_BdG(k,hamk) - - !> diagonal hamk - call eigensystem_c('V', 'U', Num_wann_BdG*Nslab, hamk, eigenvalue) - - Eigenvector(:, :, ikx)= hamk - enddo - - !> - !> sum over kx to get wanniercenters - do ikx=1, nkx - Mmnkb= 0d0 - hamk_dag= Eigenvector(:, :, ikx) - if (ikx==nkx) then - hamk= Eigenvector(:, :, 1) - else - hamk= Eigenvector(:, :, ikx+ 1) - endif - - do l=1, Nslab*2 - do m=1, Num_wann - ia= AtomIndex_orbital(m+ (l-1)*Num_wann) - br= b(1)*AtomsPosition_supercell(1, ia)+ & - b(2)*AtomsPosition_supercell(2, ia) - ratio= cos(br)- zi* sin(br) - - do i= 1, nfill - do j= 1, nfill - Mmnkb(i, j)= Mmnkb(i, j)+ & - conjg(hamk_dag((l-1)*Num_wann+m, i))* & - hamk((l-1)*Num_wann+m, j)* ratio - enddo ! j - enddo ! i - enddo ! m - enddo ! l - - !> - !call mat_mul(Num_wann_BdG*Nslab, hamk_dag, hamk, Mmnkb_full) - !Mmnkb= Mmnkb_full(1:nfill, 1:nfill) - - !Mmnkb_com= 0d0 - !hamk_dag= Eigenvector(:, :, ikx) - !hamk= Eigenvector(:, :, ikx+1) - !do i=1, nfill - ! do j=1, nfill - ! do l= 1, Num_wann*Nslab - ! Mmnkb_com(i, j)= Mmnkb_com(i, j)+ conjg(hamk_dag(l, i))* hamk(l, j) - ! enddo - ! enddo - !enddo - - !print *, maxval(real(Mmnkb-Mmnkb_com)) - !stop - - - !> perform Singluar Value Decomposed of Mmnkb - call zgesvd_pack(nfill, Mmnkb, U, Sigma, VT) - - !> after the calling of zgesvd_pack, Mmnkb becomes a temporal matrix - U= conjg(transpose(U)) - VT= conjg(transpose(VT)) - call mat_mul(nfill, VT, U, Mmnkb) - - !> check hermicity - !do i=1, nfill - ! do j=i, nfill - ! if (abs(Mmnkb(i, j)-conjg(Mmnkb(j, i)))>0.0001d0)then - ! print *, 'Mmnkb is not Hermitian' - ! print*, i, j, Mmnkb(i, j), Mmnkb(j, i) - - ! endif - ! enddo - !enddo - - !stop - - - call mat_mul(nfill, Mmnkb, Lambda0, Lambda) - Lambda0 = Lambda - enddo !< ikx - - !> diagonalize Lambda to get the eigenvalue - call zgeev_pack(nfill, Lambda, Lambda_eig) - do i=1, nfill - WannierCenterKy(i, iky)= aimag(log(Lambda_eig(i)))/2d0/pi - enddo - - enddo !< iky - -#if defined (MPI) - call mpi_allreduce(WannierCenterKy, WannierCenterKy_mpi, & - size(WannierCenterKy), mpi_dp, mpi_sum, mpi_cmw, ierr) -#else - WannierCenterKy_mpi= WannierCenterKy -#endif - - - outfileindex= outfileindex+ 1 - if (cpuid==0) then - open(unit=outfileindex, file='wanniercenter_BdG.dat') - !do iky=1, Nky - ! write(outfileindex, '(10000f16.8)') kpoints(2, 1, iky), & - ! dmod(sum(WannierCenterKy_mpi(:, iky)), 1d0), & - ! WannierCenterKy_mpi(:, iky) - !enddo - do i=1, nfill - do iky=1, Nky - write(outfileindex, '(10000f16.8)') kpoints(2, 1, iky), & - dmod(WannierCenterKy_mpi(i, iky), 1d0) - enddo - enddo - close(outfileindex) - endif - - - outfileindex= outfileindex+ 1 - if (cpuid==0) then - open(unit=outfileindex, file='wanniercenter_BdG_total.dat') - do iky=1, Nky - write(outfileindex, '(10000f16.8)') kpoints(2, 1, iky), & - dmod(sum(WannierCenterKy_mpi(:, iky)), 1d0) - enddo - !do i=1, nfill - !do iky=1, Nky - ! write(outfileindex, '(10000f16.8)') kpoints(2, 1, iky), & - ! dmod(WannierCenterKy_mpi(i, iky), 1d0) - !enddo - !enddo - close(outfileindex) - endif - - outfileindex= outfileindex+ 1 - if (cpuid==0) then - open(unit=outfileindex, file='wcc_slab_BdG.gnu') - - write(outfileindex,*) 'set encoding iso_8859_1' - write(outfileindex,*) 'set terminal postscript enhanced color font "Roman,36" ' - write(outfileindex,*) "set output 'wcc_slab_BdG.eps'" - write(outfileindex,*) 'set size ratio -1 ' - write(outfileindex,*) 'set multiplot ' - write(outfileindex,*) 'unset key' - write(outfileindex,*) 'set border lw 1 ' - write(outfileindex,*) 'set xtics 0.5 nomirror ' - write(outfileindex,*) 'set xtics ("k_y" 0, "-{/Symbol p}" -0.5, "{/Symbol p}" 0.5) ' - write(outfileindex,*) 'set ytics 0.5 nomirror ' - write(outfileindex,*) 'set xrange [-0.50: 0.5]' - write(outfileindex,*) 'set yrange [-0.50: 0.5]' - write(outfileindex,*) 'set ylabel "{/Symbol q}(2{/Symbol p})" rotate by 90 offset 2.8,0 ' - write(outfileindex,*) 'plot "wanniercenter_BdG.dat" u 1:2 w p pt 7 ps 0.6 lc rgb "blue"' - close(outfileindex) - endif - - outfileindex= outfileindex+ 1 - if (cpuid==0) then - open(unit=outfileindex, file='wcc_slab_BdG_total.gnu') - - write(outfileindex,*) 'set encoding iso_8859_1' - write(outfileindex,*) 'set terminal postscript enhanced color font "Roman,36" ' - write(outfileindex,*) "set output 'wcc_slab_BdG_total.eps'" - write(outfileindex,*) 'set size ratio -1 ' - write(outfileindex,*) 'set multiplot ' - write(outfileindex,*) 'unset key' - write(outfileindex,*) 'set border lw 1 ' - write(outfileindex,*) 'set xtics 0.5 nomirror ' - write(outfileindex,*) 'set xtics ("k_y" 0, "-{/Symbol p}" -0.5, "{/Symbol p}" 0.5) ' - write(outfileindex,*) 'set ytics 0.5 nomirror ' - write(outfileindex,*) 'set xrange [-0.50: 0.5]' - write(outfileindex,*) 'set yrange [-0.50: 0.5]' - write(outfileindex,*) 'set ylabel "{/Symbol q}(2{/Symbol p})" rotate by 90 offset 2.8,0 ' - write(outfileindex,*) 'plot "wanniercenter_BdG_total.dat" u 1:2 w p pt 7 ps 0.6 lc rgb "blue"' - close(outfileindex) - endif - - return - end subroutine wannier_center2D_BdG diff --git a/ek_slab.f90 b/ek_slab.f90 deleted file mode 100644 index 0fbfaa14..00000000 --- a/ek_slab.f90 +++ /dev/null @@ -1,752 +0,0 @@ - subroutine ek_slab - !> This subroutine is used for calculating energy - !> dispersion with wannier functions for 2D slab system - ! - ! Copyright (c) 2010 QuanSheng Wu. All rights reserved. - - use wmpi - use para - implicit none - - ! loop index - integer :: i, j, l, lwork, ierr, io - - real(Dp) :: k(2), emin, emax, maxweight - - ! time measurement - real(dp) :: time_start, time_end, time_start0 - - ! parameters for zheev - real(Dp), allocatable :: rwork(:) - complex(Dp), allocatable :: work(:) - - ! eigenvalue - real(Dp), allocatable :: eigenvalue(:) - - ! energy dispersion - real(Dp),allocatable :: ekslab(:,:), ekslab_mpi(:,:) - - !> color for plot, surface state weight - real(dp), allocatable :: surf_l_weight(:, :), surf_l_weight_mpi(:, :) - real(dp), allocatable :: surf_r_weight(:, :), surf_r_weight_mpi(:, :) - - ! hamiltonian slab - complex(Dp),allocatable ::CHamk(:,:) - - lwork= 16*Nslab*Num_wann - ierr = 0 - - - allocate(eigenvalue(nslab*Num_wann)) - allocate( surf_l_weight (Nslab* Num_wann, knv2)) - allocate( surf_l_weight_mpi (Nslab* Num_wann, knv2)) - allocate( surf_r_weight (Nslab* Num_wann, knv2)) - allocate( surf_r_weight_mpi (Nslab* Num_wann, knv2)) - allocate(ekslab(Nslab*Num_wann,knv2)) - allocate(ekslab_mpi(Nslab*Num_wann,knv2)) - allocate(CHamk(nslab*Num_wann,nslab*Num_wann)) - allocate(work(lwork)) - allocate(rwork(lwork)) - - surf_l_weight= 0d0 - surf_l_weight_mpi= 0d0 - surf_r_weight= 0d0 - surf_r_weight_mpi= 0d0 - - ! sweep k - ekslab=0.0d0 - ekslab_mpi=0.0d0 - time_start= 0d0 - time_start0= 0d0 - call now(time_start0) - time_start= time_start0 - time_end = time_start0 - do i= 1+cpuid, knv2, num_cpu - if (cpuid==0.and. mod(i/num_cpu, 4)==0) & - write(stdout, '(a, i9, " /", i10, a, f10.1, "s", a, f10.1, "s")') & - ' Slabek: ik', i, knv2, ' time left', & - (knv2-i)*(time_end- time_start)/num_cpu, & - ' time elapsed: ', time_end-time_start0 - - call now(time_start) - - k= k2_path(i, :) - chamk=0.0d0 - - !> surface Zeeman splitting for BdG - if (abs(Bz_surf)>eps9.or.abs(Bx_surf)>eps9.or.abs(By_surf)>eps9) then - call ham_slab_surface_zeeman(k,Chamk) - !> no surface Zeeman splitting - else - call ham_slab(k,Chamk) - endif - - eigenvalue=0.0d0 - - ! diagonal Chamk - call eigensystem_c('V', 'U', Num_wann*Nslab, CHamk, eigenvalue) - - ekslab(:,i)=eigenvalue - - ! H*chamk(:,n)=E(n)*chamk(:,n) - !> Nslab*Num_wann - !> rho(:)=abs(chamk(:,n))**2 - !> (a1 o1, o2 o3, a2, o1, o2, o3; a1 o1, o2 o3, a2, o1, o2, o3), (a1 o1, o2 o3, a2, o1, o2, o3; a1 o1, o2 o3, a2, o1, o2, o3), (a1 o1, o2 o3, a2, o1, o2, o3; a1 o1, o2 o3, a2, o1, o2, o3), - do j=1, Nslab* Num_wann - !> left is the bottom surface - do l= 1, NBottomOrbitals - io= BottomOrbitals(l) - surf_l_weight(j, i)= surf_l_weight(j, i) & - + abs(CHamk(io, j))**2 ! first slab - enddo ! l sweeps the selected orbitals - - !> right is the top surface - do l= 1, NTopOrbitals - io= Num_wann*(Nslab-1)+ TopOrbitals(l) - surf_r_weight(j, i)= surf_r_weight(j, i) & - + abs(CHamk(io, j))**2 ! first slab - enddo ! l sweeps the selected orbitals - - !do l=1, Num_wann - ! surf_l_weight(j, i)= surf_l_weight(j, i) & - ! + abs(CHamk(l, j))**2 ! first slab - ! !+ abs(CHamk(Num_wann+ l, j))**2 & ! the second slab - ! surf_r_weight(j, i)= surf_r_weight(j, i) & - ! + abs(CHamk(Num_wann*Nslab- l+ 1, j))**2 !& ! last slab - ! !+ abs(CHamk(Num_wann*(Nslab-1)- l, j))**2 ! last second slab - !enddo ! l - enddo ! j - call now(time_end) - enddo ! i - -#if defined (MPI) - call mpi_allreduce(ekslab,ekslab_mpi,size(ekslab),& - mpi_dp,mpi_sum,mpi_cmw,ierr) - call mpi_allreduce(surf_l_weight, surf_l_weight_mpi,size(surf_l_weight),& - mpi_dp,mpi_sum,mpi_cmw,ierr) - call mpi_allreduce(surf_r_weight, surf_r_weight_mpi,size(surf_r_weight),& - mpi_dp,mpi_sum,mpi_cmw,ierr) -#else - ekslab_mpi= ekslab - surf_l_weight_mpi= surf_l_weight - surf_r_weight_mpi= surf_r_weight -#endif - - - - !> deal with phonon system - if (index(Particle,'phonon')/=0) then - do i=1, knv2 - do j=1, Num_wann*Nslab - ekslab_mpi(j, i)= sqrt(abs(ekslab_mpi(j, i)))*sign(1d0, ekslab_mpi(j, i)) - enddo - enddo - endif - ekslab_mpi= ekslab_mpi/eV2Hartree - - ekslab=ekslab_mpi - - maxweight=maxval(surf_r_weight_mpi+ surf_l_weight_mpi) - surf_l_weight= surf_l_weight_mpi/ maxweight - surf_r_weight= surf_r_weight_mpi/ maxweight - - outfileindex= outfileindex+ 1 - if(cpuid==0)then - open(unit=outfileindex, file='slabek.dat') - write(outfileindex, "('#', a10, a15, 5X, 2a16 )")'# k', ' E', 'BS weight', 'TS weight' - do j=1, Num_wann*Nslab - do i=1, knv2 - !write(outfileindex,'(3f15.7, i8)')k2len(i), ekslab(j,i), & - ! (surf_weight(j, i)) - write(outfileindex,'(2f15.7, 2f16.7)')k2len(i)*Angstrom2atomic, ekslab(j,i), & - (surf_l_weight(j, i)), & - (surf_r_weight(j, i)) - enddo - write(outfileindex , *)'' - enddo - close(outfileindex) - write(stdout,*) 'calculate energy band done' - endif - - emin= minval(ekslab)-0.5d0 - emax= maxval(ekslab)+0.5d0 - !> write script for gnuplot - outfileindex= outfileindex+ 1 - if (cpuid==0) then - open(unit=outfileindex, file='slabek.gnu') - write(outfileindex, '(a)')"set encoding iso_8859_1" - write(outfileindex, '(a)')'#set terminal postscript enhanced color' - write(outfileindex, '(a)')"#set output 'slabek.eps'" - write(outfileindex, '(3a)')'#set terminal pngcairo truecolor enhanced', & - ' font ",60" size 1920, 1680' - write(outfileindex, '(3a)')'set terminal png truecolor enhanced', & - ' font ",60" size 1920, 1680' - write(outfileindex, '(a)')"set output 'slabek.png'" - write(outfileindex,'(2a)') 'set palette defined ( 0 "green", ', & - '5 "yellow", 10 "red" )' - write(outfileindex, '(a)')'set style data linespoints' - write(outfileindex, '(a)')'unset ztics' - write(outfileindex, '(a)')'unset key' - write(outfileindex, '(a)')'set pointsize 0.8' - write(outfileindex, '(a)')'set border lw 3 ' - write(outfileindex, '(a)')'set view 0,0' - write(outfileindex, '(a)')'#set xtics font ",36"' - write(outfileindex, '(a)')'#set ytics font ",36"' - write(outfileindex, '(a)')'#set ylabel font ",36"' - write(outfileindex, '(a)')'#set xtics offset 0, -1' - write(outfileindex, '(a)')'set ylabel offset -1, 0 ' - write(outfileindex, '(a, f10.5, a)')'set xrange [0: ', maxval(k2len)*Angstrom2atomic, ']' - if (index(Particle,'phonon')/=0) then - write(outfileindex, '(a, f10.5, a)')'set yrange [0:', emax, ']' - write(outfileindex, '(a)')'set ylabel "Frequency (THz)"' - else - write(outfileindex, '(a)')'set ylabel "Energy (eV)"' - write(outfileindex, '(a, f10.5, a, f10.5, a)')'set yrange [', emin, ':', emax, ']' - endif - write(outfileindex, 202, advance="no") (trim(k2line_name(i)), k2line_stop(i)*Angstrom2atomic, i=1, nk2lines) - write(outfileindex, 203)trim(k2line_name(nk2lines+1)), k2line_stop(nk2lines+1)*Angstrom2atomic - - do i=1, nk2lines-1 - if (index(Particle,'phonon')/=0) then - write(outfileindex, 204)k2line_stop(i+1)*Angstrom2atomic, 0.0, k2line_stop(i+1)*Angstrom2atomic, emax - else - write(outfileindex, 204)k2line_stop(i+1)*Angstrom2atomic, emin, k2line_stop(i+1)*Angstrom2atomic, emax - endif - enddo - write(outfileindex, '(a)')'#rgb(r,g,b) = int(r)*65536 + int(g)*256 + int(b)' - write(outfileindex, '(2a)')"#plot 'slabek.dat' u 1:2:(rgb(255,$3, 3)) ", & - "w lp lw 2 pt 7 ps 1 lc rgb variable" - write(outfileindex, '(2a)')"# (a) " - write(outfileindex, '(2a)')"# plot the top and bottom surface's weight together" - write(outfileindex, '(2a)')"#plot 'slabek.dat' u 1:2:($3+$4) ", & - "w lp lw 2 pt 7 ps 1 lc palette" - write(outfileindex, '(2a)')"# (b) " - write(outfileindex, '(2a)') & - "# plot top and bottom surface's weight with red and blue respectively" - write(outfileindex,'(2a)') 'set palette defined ( -1 "blue", ', & - '0 "grey", 1 "red" )' - write(outfileindex, '(2a)')"plot 'slabek.dat' u 1:2:($4-$3) ", & - "w lp lw 2 pt 7 ps 1 lc palette" - - !write(outfileindex, '(2a)')"splot 'slabek.dat' u 1:2:3 ", & - ! "w lp lw 2 pt 13 palette" - close(outfileindex) - endif - - 202 format('set xtics (',:20('"',A3,'" ',F10.5,',')) - 203 format(A3,'" ',F10.5,')') - 204 format('set arrow from ',F10.5,',',F10.5, & - ' to ',F10.5,',',F10.5, ' nohead') - - deallocate(eigenvalue) - deallocate( surf_l_weight ) - deallocate( surf_l_weight_mpi ) - deallocate( surf_r_weight ) - deallocate( surf_r_weight_mpi ) - deallocate(ekslab) - deallocate(ekslab_mpi) - deallocate(CHamk) - deallocate(work) - deallocate(rwork) - - return - end subroutine ek_slab - -subroutine ek_slab_sparseHR - use para - use sparse - implicit none - - !> some temporary integers - integer :: ik, ia1, ia2, i, j, ierr, ib, iq, ig - - ! wave vector - real(dp) :: k(2) - - !> dim= Ndimq, knv3 - integer :: Ndimq - real(dp), allocatable :: W(:) - real(dp), allocatable :: eigv(:, :) - real(dp), allocatable :: eigv_mpi(:, :) - - real(dp) :: emin, emax - real(dp) :: time_start, time_end, time_start0 - - integer :: nnzmax, nnz - complex(dp), allocatable :: acoo(:) - integer, allocatable :: jcoo(:) - integer, allocatable :: icoo(:) - - !> eigenvector of the sparse matrix acoo. Dim=(Ndimq, neval) - complex(dp), allocatable :: psi(:) - complex(dp), allocatable :: zeigv(:, :) - - !> print the weight for the Selected_WannierOrbitals - real(dp), allocatable :: dos_selected(:, :, :) - real(dp), allocatable :: dos_selected_mpi(:, :, :) - - real(dp), allocatable :: dos_l_selected(:, :, :) - real(dp), allocatable :: dos_l_selected_mpi(:, :, :) - real(dp), allocatable :: dos_r_selected(:, :, :) - real(dp), allocatable :: dos_r_selected_mpi(:, :, :) - - !number of ARPACK eigenvalues - integer :: neval - - ! number of Arnoldi vectors - integer :: nvecs - - !shift-invert sigma - complex(dp) :: sigma - - !> time measurement - real(dp) :: time1, time2, time3 - - logical :: ritzvec - - Ndimq= Num_wann* Nslab - nnzmax= Num_wann*(2*ijmax+1)*Ndimq+Ndimq - if(Is_Sparse_Hr) nnzmax=splen*Nslab+Ndimq - if (NumSelectedEigenVals==0) NumSelectedEigenVals=Ndimq - neval=NumSelectedEigenVals - if (neval>=Ndimq) neval= Ndimq- 2 - - !> ncv - nvecs=int(2*neval) - - ! if (nvecs<50) nvecs= 50 - if (nvecs>Ndimq) nvecs= Ndimq - - - sigma=(1d0,0d0)*E_arc - - allocate( acoo(nnzmax), stat= ierr) - call printallocationinfo('acoo', ierr) - allocate( jcoo(nnzmax), stat= ierr) - call printallocationinfo('jcoo', ierr) - allocate( icoo(nnzmax), stat= ierr) - call printallocationinfo('icoo', ierr) - allocate( W( neval), stat= ierr) - allocate( eigv( neval, knv2)) - call printallocationinfo('eigv', ierr) - allocate( eigv_mpi( neval, knv2), stat= ierr) - call printallocationinfo('eigv_mpi', ierr) - allocate( psi(ndimq)) - allocate( zeigv(ndimq,nvecs), stat= ierr) - call printallocationinfo('zeigv', ierr) - allocate( dos_selected (neval, knv2, NumberofSelectedOrbitals_groups), stat= ierr) - call printallocationinfo('dos_selected', ierr) - allocate( dos_selected_mpi (neval, knv2, NumberofSelectedOrbitals_groups), stat= ierr) - call printallocationinfo('dos_selected_mpi', ierr) - allocate( dos_l_selected (neval, knv2, NumberofSelectedOrbitals_groups), stat= ierr) - call printallocationinfo('dos_l_selected', ierr) - allocate( dos_l_selected_mpi (neval, knv2, NumberofSelectedOrbitals_groups), stat= ierr) - call printallocationinfo('dos_l_selected_mpi', ierr) - allocate( dos_r_selected (neval, knv2, NumberofSelectedOrbitals_groups), stat= ierr) - call printallocationinfo('dos_r_selected', ierr) - allocate( dos_r_selected_mpi (neval, knv2, NumberofSelectedOrbitals_groups), stat= ierr) - call printallocationinfo('dos_r_selected_mpi', ierr) - dos_l_selected= 0d0 - dos_l_selected_mpi= 0d0 - dos_r_selected= 0d0 - dos_r_selected_mpi= 0d0 - dos_selected= 0d0 - dos_selected_mpi= 0d0 - - eigv_mpi= 0d0 - eigv = 0d0 - acoo= 0d0 - - !> calculate the along special k line - time_start= 0d0 - time_start0= 0d0 - call now(time_start0) - time_start= time_start0 - time_end = time_start0 - ritzvec= .true. - do ik=1+ cpuid, knv2, num_cpu - if (cpuid==0.and. mod(ik/num_cpu, 4)==0) & - write(stdout, '(a, i9, " /", i10, a, f10.1, "s", a, f10.1, "s")') & - ' Slabek: ik', ik, knv2, ' time left', & - (knv2-ik)*(time_end- time_start)/num_cpu, & - ' time elapsed: ', time_end-time_start0 - - call now(time_start) - - k= k2_path(ik, :) - nnz= nnzmax - call now(time1) - call ham_slab_sparseHR(nnz, k, acoo,jcoo,icoo) - call now(time2) - - !> diagonalization by call zheev in lapack - W= 0d0 - - call arpack_sparse_coo_eigs(Ndimq,nnzmax,nnz,acoo,jcoo,icoo,neval,nvecs,W,sigma, zeigv, ritzvec) - - call now(time3) - eigv(1:neval, ik)= W(1:neval) - - !> calculate the weight on the selected orbitals - do ib= 1, neval - psi(:)= zeigv(:, ib) !> the eigenvector of ib'th band - do ig=1, NumberofSelectedOrbitals_groups - do iq=1, Nslab - do i= 1, NumberofSelectedOrbitals(ig) - j= Num_wann*(iq-1)+ Selected_WannierOrbitals(ig)%iarray(i) - dos_selected(ib, ik, ig)= dos_selected(ib, ik, ig)+ abs(psi(j))**2 - - enddo ! sweep the selected orbitals - enddo ! iq sweep the magnetic supercell - - do iq=1, 2 ! edge states - if (iq>Nslab) cycle - do i= 1, NumberofSelectedOrbitals(ig) - j= Num_wann*(iq-1)+ Selected_WannierOrbitals(ig)%iarray(i) - dos_l_selected(ib, ik, ig)= dos_l_selected(ib, ik, ig)+ abs(psi(j))**2 - enddo ! sweep the selected orbitals - enddo ! iq sweep the magnetic supercell - do iq=Nslab-1, Nslab ! edge states - if (iq<1) cycle - do i= 1, NumberofSelectedOrbitals(ig) - j= Num_wann*(iq-1)+ Selected_WannierOrbitals(ig)%iarray(i) - dos_r_selected(ib, ik, ig)= dos_r_selected(ib, ik, ig)+ abs(psi(j))**2 - enddo ! sweep the selected orbitals - enddo ! iq sweep the magnetic supercell - enddo ! ig - enddo ! ib sweep the eigenvalue - - if (cpuid==0)write(stdout, '(a, f20.2, a)')' >> Time cost for constructing H: ', time2-time1, ' s' - if (cpuid==0)write(stdout, '(a, f20.2, a)')' >> Time cost for diagonalize H: ', time3-time2, ' s' - call now(time_end) - enddo !ik - -#if defined (MPI) - call mpi_allreduce(eigv,eigv_mpi,size(eigv),& - mpi_dp,mpi_sum,mpi_cmw,ierr) - call mpi_allreduce(dos_selected, dos_selected_mpi,size(dos_selected),& - mpi_dp,mpi_sum,mpi_cmw,ierr) - - call mpi_allreduce(dos_l_selected, dos_l_selected_mpi,size(dos_l_selected),& - mpi_dp,mpi_sum,mpi_cmw,ierr) - call mpi_allreduce(dos_r_selected, dos_r_selected_mpi,size(dos_r_selected),& - mpi_dp,mpi_sum,mpi_cmw,ierr) -#else - eigv_mpi= eigv - dos_selected_mpi= dos_selected - dos_l_selected_mpi= dos_l_selected - dos_r_selected_mpi= dos_r_selected -#endif - - !> minimum and maximum value of energy bands - emin= minval(eigv_mpi)-0.5d0 - emax= maxval(eigv_mpi)+0.5d0 - - eigv_mpi= eigv_mpi/eV2Hartree - - outfileindex= outfileindex+ 1 - if (cpuid.eq.0) then - open(unit=outfileindex, file='slabek.dat') - write(outfileindex, '("#", a14, a15, a)')'k ', ' E', ' Weight on the selected orbitals' - do j=1, neval - do i=1,knv2 - write(outfileindex,'(200f16.8)')k2len(i)*Angstrom2atomic, eigv_mpi(j, i), & - (dos_l_selected_mpi(j, i, ig), dos_r_selected_mpi(j, i, ig), & - ig=1, NumberofSelectedOrbitals_groups) - enddo - write(outfileindex , *)'' - enddo - close(outfileindex) - write(stdout,*) 'calculate landau level done' - endif - - outfileindex= outfileindex+ 1 - - emin= minval(eigv_mpi)-0.5d0 - emax= maxval(eigv_mpi)+0.5d0 - !> write script for gnuplot - outfileindex= outfileindex+ 1 - if (cpuid==0) then - open(unit=outfileindex, file='slabek.gnu') - write(outfileindex, '(a)')"set encoding iso_8859_1" - write(outfileindex, '(a)')'#set terminal postscript enhanced color' - write(outfileindex, '(a)')"#set output 'slabek.eps'" - write(outfileindex, '(3a)')'#set terminal pngcairo truecolor enhanced', & - ' font ",60" size 1920, 1680' - write(outfileindex, '(3a)')'set terminal png truecolor enhanced', & - ' font ",60" size 1920, 1680' - write(outfileindex, '(a)')"set output 'slabek.png'" - write(outfileindex,'(2a)') 'set palette defined ( 0 "green", ', & - '5 "yellow", 10 "red" )' - write(outfileindex, '(a)')'set style data linespoints' - write(outfileindex, '(a)')'unset ztics' - write(outfileindex, '(a)')'unset key' - write(outfileindex, '(a)')'set pointsize 0.8' - write(outfileindex, '(a)')'set border lw 3 ' - write(outfileindex, '(a)')'set view 0,0' - write(outfileindex, '(a)')'#set xtics font ",36"' - write(outfileindex, '(a)')'#set ytics font ",36"' - write(outfileindex, '(a)')'#set ylabel font ",36"' - write(outfileindex, '(a)')'#set xtics offset 0, -1' - write(outfileindex, '(a)')'set ylabel offset -1, 0 ' - write(outfileindex, '(a, f10.5, a)')'set xrange [0: ', maxval(k2len*Angstrom2atomic), ']' - if (index(Particle,'phonon')/=0) then - write(outfileindex, '(a, f10.5, a)')'set yrange [0:', emax, ']' - write(outfileindex, '(a)')'set ylabel "Frequency (THz)"' - else - write(outfileindex, '(a)')'set ylabel "Energy (eV)"' - write(outfileindex, '(a, f10.5, a, f10.5, a)')'set yrange [', emin, ':', emax, ']' - endif - write(outfileindex, 202, advance="no") (trim(k2line_name(i)), k2line_stop(i)*Angstrom2atomic, i=1, nk2lines) - write(outfileindex, 203)trim(k2line_name(nk2lines+1)), k2line_stop(nk2lines+1)*Angstrom2atomic - - do i=1, nk2lines-1 - if (index(Particle,'phonon')/=0) then - write(outfileindex, 204)k2line_stop(i+1)*Angstrom2atomic, 0.0, k2line_stop(i+1)*Angstrom2atomic, emax - else - write(outfileindex, 204)k2line_stop(i+1)*Angstrom2atomic, emin, k2line_stop(i+1)*Angstrom2atomic, emax - endif - enddo - write(outfileindex, '(a)')'#rgb(r,g,b) = int(r)*65536 + int(g)*256 + int(b)' - write(outfileindex, '(2a)')"#plot 'slabek.dat' u 1:2:(rgb(255,$3, 3)) ", & - "w lp lw 2 pt 7 ps 1 lc rgb variable" - write(outfileindex, '(2a)')"# plot the top and bottom surface's weight together" - write(outfileindex, '(2a)')"plot 'slabek.dat' u 1:2:($3+$4) ", & - "w lp lw 2 pt 7 ps 1 lc palette" - write(outfileindex, '(2a)')"#" - write(outfileindex, '(2a)')"# plot top and bottom surface's weight with different color" - write(outfileindex,'(2a)') '#set palette defined ( -1 "blue", ', & - '0 "grey", 1 "red" )' - write(outfileindex, '(2a)')"#plot 'slabek.dat' u 1:2:($4-$3) ", & - "w lp lw 2 pt 7 ps 1 lc palette" - - !write(outfileindex, '(2a)')"splot 'slabek.dat' u 1:2:3 ", & - ! "w lp lw 2 pt 13 palette" - close(outfileindex) - endif - - 202 format('set xtics (',:20('"',A3,'" ',F10.5,',')) - 203 format(A3,'" ',F10.5,')') - 204 format('set arrow from ',F10.5,',',F10.5, & - ' to ',F10.5,',',F10.5, ' nohead') - - - -#if defined (MPI) - call mpi_barrier(mpi_cmw, ierr) -#endif - - deallocate( acoo) - deallocate( jcoo) - deallocate( icoo) - deallocate( W) - deallocate( eigv) - deallocate( eigv_mpi) - deallocate( zeigv) - deallocate( dos_selected) - deallocate( dos_selected_mpi) - - return -end subroutine ek_slab_sparseHR - - - subroutine ek_slab_kplane - !> This subroutine is used for calculating energy - !> dispersion with wannier functions for 2D slab system - ! - ! Copyright (c) 2010 QuanSheng Wu. All rights reserved. - - use wmpi - use para - implicit none - - - ! loop index - integer :: i, j, l, lwork, ierr, kn12, ik, istart, iend - - ! wave vector - real(Dp) :: k(2) - - real(Dp) :: time_start, time_end - - real(Dp), allocatable :: eigenvalue(:) - - ! energy dispersion - real(Dp),allocatable :: ekslab(:,:) - real(Dp),allocatable :: ekslab_mpi(:,:) - - real(dp), allocatable :: k12(:,:) - real(dp), allocatable :: k12_shape(:,:) - - !> color for plot, surface state weight - real(dp), allocatable :: surf_weight(:, :) - real(dp), allocatable :: surf_weight_mpi(:, :) - - complex(Dp),allocatable ::CHamk(:,:) - - kn12= nk1*nk2 - lwork= 16*Nslab*Num_wann - ierr = 0 - - allocate(eigenvalue(nslab*Num_wann)) - allocate( surf_weight (Nslab* Num_wann, kn12)) - allocate( surf_weight_mpi (Nslab* Num_wann, kn12)) - allocate(ekslab(Nslab*Num_wann,kn12)) - allocate(ekslab_mpi(Nslab*Num_wann,kn12)) - allocate(CHamk(nslab*Num_wann,nslab*Num_wann)) - allocate(k12(2,kn12)) - allocate(k12_shape(2,kn12)) - - surf_weight= 0d0 - surf_weight_mpi= 0d0 - - !> set up k slice - ik =0 - do i= 1, nk1 - do j= 1, nk2 - ik =ik +1 - k12(:, ik)=K2D_start+ (i-1)*K2D_vec1/dble(nk1-1) & - + (j-1)*K2D_vec2/dble(nk2-1) - k12_shape(:, ik)= k12(1, ik)* Ka2+ k12(2, ik)* Kb2 - enddo - enddo - - ! sweep k - ekslab=0.0d0 - ekslab_mpi=0.0d0 - time_start= 0d0 - time_end= 0d0 - do i=1+cpuid, kn12, num_cpu - if (cpuid==0.and. mod(i/num_cpu, 100)==0) & - write(stdout, *) 'SlabBand_plane, ik ', i, 'Nk',nk1*nk2, 'time left', & - (nk1*nk2-i)*(time_end- time_start)/num_cpu, ' s' - call now(time_start) - - k= k12(:, i) - chamk=0.0d0 - - call ham_slab(k,Chamk) - - eigenvalue=0.0d0 - - ! diagonal Chamk - call eigensystem_c('V', 'U', Num_wann*Nslab, CHamk, eigenvalue) - - ekslab(:,i)=eigenvalue - - do j=1, Nslab* Num_wann - do l=1, Num_wann - surf_weight(j, i)= surf_weight(j, i) & - + abs(CHamk(l, j))**2 & ! first slab - + abs(CHamk(Num_wann*Nslab- l+ 1, j))**2 !& ! last slab - !+ abs(CHamk(Num_wann+ l, j))**2 & ! the second slab - !+ abs(CHamk(Num_wann*(Nslab-1)- l, j))**2 ! last second slab - enddo ! l - !surf_weight(j, i)= (surf_weight(j, i)) - enddo ! j - call now(time_end) - enddo ! i - -#if defined (MPI) - call mpi_allreduce(ekslab,ekslab_mpi,size(ekslab),& - mpi_dp,mpi_sum,mpi_cmw,ierr) - call mpi_allreduce(surf_weight, surf_weight_mpi,size(surf_weight),& - mpi_dp,mpi_sum,mpi_cmw,ierr) -#else - ekslab_mpi= ekslab - surf_weight_mpi= surf_weight -#endif - - !> deal with phonon system - if (index(Particle,'phonon')/=0) then - do i=1, kn12 - do j=1, Num_wann*Nslab - ekslab_mpi(j, i)= sqrt(abs(ekslab_mpi(j, i)))*sign(1d0, ekslab_mpi(j, i)) - enddo - enddo - endif - ekslab_mpi= ekslab_mpi/eV2Hartree - - ekslab=ekslab_mpi - if (maxval(surf_weight_mpi)<0.00001d0)surf_weight_mpi=1d0 - surf_weight= surf_weight_mpi/ maxval(surf_weight_mpi) - - - istart= Numoccupied*Nslab-1 - iend= Numoccupied*Nslab+2 - outfileindex= outfileindex+ 1 - if (cpuid==0) then - open(unit=outfileindex, file='slabek_plane.dat') - write(outfileindex, '(4a16, a)')'# kx', ' ky', ' k1', ' k2', ' (E(ib), dos(ib)), ib=1, NumberofSelectedOrbitals' - write(outfileindex, '(a, 2i10)')'# Nk1, Nk2=', Nk1, Nk2 - do i=1, kn12 - write(outfileindex,'(2000f16.7)')k12_shape(:,i), k12(:,i), & - (ekslab(j,i), (255-surf_weight(j, i)*255d0), j=istart, iend) - if (mod(i, nk1)==0) write (outfileindex, *)' ' - enddo - close(outfileindex) - write(stdout,*) 'calculate energy band done' - endif - - outfileindex= outfileindex+ 1 - if (cpuid==0) then - open(unit=outfileindex, file='slabek_plane-matlab.dat') - write(outfileindex, '(4a16, a)')'% kx', ' ky', ' k1', ' k2', ' (E(ib), dos(ib)), ib=1, NumberofSelectedOrbitals' - write(outfileindex, '(a, 2i10)')'% Nk1, Nk2=', Nk1, Nk2 - do i=1, kn12 - write(outfileindex,'(2000f16.7)')k12_shape(:,i), k12(:,i), & - (ekslab(j,i), (255-surf_weight(j, i)*255d0), j=istart, iend) - enddo - close(outfileindex) - endif - - - !> write out a script that can be used for gnuplot - outfileindex= outfileindex+ 1 - if (cpuid==0)then - open(unit=outfileindex, file='slabek_plane.gnu') - write(outfileindex, '(a)')"set encoding iso_8859_1" - write(outfileindex, '(a)')'#set terminal postscript enhanced color' - write(outfileindex, '(a)')"#set output 'slabek_plane.eps'" - write(outfileindex, '(3a)')'set terminal png truecolor enhanced', & - ' size 1920, 1680 font ",36"' - write(outfileindex, '(a)')"set output 'slabek_plane.png'" - write(outfileindex, '(a)')'set palette rgbformulae 33,13,10' - write(outfileindex, '(a)')'unset key' - write(outfileindex, '(a)')'set pm3d' - write(outfileindex, '(a)')'set origin 0.2, 0' - write(outfileindex, '(a)')'set size 0.8, 1' - write(outfileindex, '(a)')'set border lw 3' - write(outfileindex, '(a)')'#set xtics font ",24"' - write(outfileindex, '(a)')'#set ytics font ",24"' - write(outfileindex, '(a)')'set size ratio -1' - write(outfileindex, '(a)')'set xtics' - write(outfileindex, '(a)')'set ytics' - write(outfileindex, '(a)')'set view 80,60' - write(outfileindex, '(a)')'set xlabel "k_1"' - write(outfileindex, '(a)')'set ylabel "k_2"' - write(outfileindex, '(a)')'set zlabel "Energy (eV)" rotate by 90' - write(outfileindex, '(a)')'unset colorbox' - write(outfileindex, '(a)')'set autoscale fix' - write(outfileindex, '(a)')'set pm3d interpolate 4,4' - write(outfileindex, '(2a)')"splot 'slabek_plane.dat' u 1:2:7 w pm3d, \" - write(outfileindex, '(2a)')" 'slabek_plane.dat' u 1:2:9 w pm3d" - - close(outfileindex) - - endif ! cpuid - -#if defined (MPI) - call mpi_barrier(mpi_cmw, ierr) -#endif - - deallocate(eigenvalue) - deallocate( surf_weight ) - deallocate( surf_weight_mpi ) - deallocate(ekslab) - deallocate(ekslab_mpi) - deallocate(CHamk) - - return - end subroutine ek_slab_kplane - diff --git a/main.f90 b/main.f90 deleted file mode 100644 index f7ff0b81..00000000 --- a/main.f90 +++ /dev/null @@ -1,758 +0,0 @@ -!--------+--------+--------+--------+--------+--------+--------+------! -! Main program of WannierTools based on tight binding model formated -! as wannier90_hr.dat defined in Wannier90 software package. -! -! Ref: -! WannierTools : An open-source software package for novel topological materials -! QuanSheng Wu and ShengNan Zhang and Hai-Feng Song and Matthias Troyer and Alexey A. Soluyanov -! Computer Physics Communications 224, 405 (2018) -! Magnetoresistance from Fermi surface topology, -! ShengNan Zhang, QuanSheng Wu, Yi Liu, and Oleg V. Yazyev, -! Phys. Rev. B 99, 035142 (2019) -! -! constructed by Q.S.Wu on 4/9/2010 -! change by Q.S.Wu on 4/22/2010 -! changed by Q.S.wu on July/15/2010 -! Jan 25 2015 by Q.S.Wu at ETH Zurich -! version 2.2.1 At EPFL, Switzerland, Sep. 14. 2017 -! version 2.4.0 At EPFL, Switzerland, Aug. 31. 2018 -! version 2.4.1 At EPFL, Switzerland, Oct. 15. 2018 -! version 2.4.2 At EPFL, Switzerland, July. 9. 2019 -! version 2.5.0 At EPFL, Switzerland, Dec. 9. 2019, magnetoresistance, band unfolding -! version 2.5.1 At EPFL, Switzerland, Mar. 6. 2020, For WannierTools tutorial 2020 -! version 2.6.0 At EPFL, Switzerland, Feb.15. 2021, Landau level, sparse Hamiltonian, TBG -! version 2.6.1 At Beijing, China, April 10. 2022 clean for the Wannier90 tutorial 2022 -! version 2.7.0 At IOP CAS Beijing, China, July 22. 2023, added ANE, SHC, -! added symmetrization part for magnetic hamiltonian fixed several bugs -! version 2.7.1 At IOP CAS Beijing, China, May 6 2024, try to build interface with openmx -! to adapted the non-orthogonal basis; fixed several bugs -! -! Corresponding to Quansheng Wu: wuquansheng@gmail.com, quansheng.wu@iphy.ac.cn -! -! License: GPL V3 -!--------+--------+--------+--------+--------+--------+--------+------! - - program main - - use wmpi - use para - implicit none - - !> file existence - logical :: exists - integer :: ierr - character(8) :: cht - - !> time measure - real(Dp) :: time_start, time_end, time_init - - - !> version of WannierTools - version='2.7.1' - - ierr = 0 - cpuid= 0 - num_cpu= 1 - !> initial the environment of mpi -#if defined (MPI) - call mpi_init(ierr) - call mpi_comm_rank(mpi_cmw,cpuid,ierr) - call mpi_comm_size(mpi_cmw,num_cpu,ierr) -#endif - - if (cpuid==0) open(unit=stdout, file='WT.out') - - !> if mpi initial wrong, alarm - if (cpuid==0.and.ierr.ne.0)then - write(stdout,*)'mpi initialize wrong' - stop - endif - - call now(time_init) - call header - - !> print information for mpi - if (cpuid==0) then - write(stdout, '(1x, a, i5, a)')'You are using ', num_cpu, ' CPU cores' - write(stdout, *)' ' - endif - - !> readin the control parameters for this program - call now(time_start) - call readinput - call now(time_end) - call print_time_cost(time_start, time_end, 'readinput') - - !> set Num_wann from wt.in, Num_wann should be consistent with the hr.dat - Num_wann= sum(Origin_cell%nprojs) - if (SOC>0) num_wann= 2*num_wann - - !> We need to extend the spinless hamiltonian to spinfull hamiltonian if - !> we want to add Zeeman field when spin-orbit coupling is not included in - !> the hr file. - if (Add_Zeeman_Field.and.SOC==0)then - Num_wann= Num_wann*2 - if (cpuid==0) then - write(stdout,*)'>> Num_wann is doubled due to the consideration of Zeeman effect' - write(stdout,*)">> Num_wann : ", Num_wann - endif - endif - - !> dimension for slab BdG hamiltonians - Num_wann_BdG= 2*Num_wann - - !> dimension for surface green's function - Ndim= Num_wann* Np - - !> Check the symmetry operator if Symmetry_Import_calc= T - call now(time_start) - call symmetry - call now(time_end) - call print_time_cost(time_start, time_end, 'symmetry') - - - if (cpuid==0)then - write(stdout,*) ' >> Begin to read Hmn_R.data' - endif - - !>> Read Hamiltonian - if(Is_HrFile) then - !> allocate necessary arrays for tight binding hamiltonians - !> normal hmnr file - if(.not. Is_Sparse_Hr) then - !> for the dense hr file, we allocate HmnR - call readNormalHmnR() - if (valley_projection_calc) call read_valley_operator - !> sparse hmnr input - else - call readSparseHmnR() - - !> read valley operator - if (valley_projection_calc) call readsparse_valley_operator - - !> for non-Orthogonal basis, we have to read the overlap matrix - if (.not.Orthogonal_Basis) call readsparse_overlap - end if - else - stop "We only support Is_HrFile=.true. for this version" - end if - - if (cpuid==0)then - write(stdout,*) ' << Read Hmn_R.data successfully' - endif - - !> unfold bulk band line mode - if (BulkBand_unfold_line_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of unfolding bulk band' - call now(time_start) - call unfolding_kpath - call now(time_end) - call print_time_cost(time_start, time_end, 'BulkBand_unfold_line_calc') - if(cpuid.eq.0)write(stdout, *)'<< End of unfolding bulk band' - endif - - - !> unfold bulk band kplane mode - if (BulkBand_unfold_plane_calc.or.QPI_unfold_plane_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of unfolding bulk band in plane mode' - call now(time_start) - call unfolding_kplane - call now(time_end) - call print_time_cost(time_start, time_end, 'BulkBand_unfold_plane_calc') - if(cpuid.eq.0)write(stdout, *)'<< End of unfolding bulk band in plane mode' - endif - - !> bulk band - if (BulkBand_calc.or.BulkBand_line_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating bulk band' - call now(time_start) - if (Is_Sparse_Hr) then - if (valley_projection_calc) then - call sparse_ekbulk_valley - else - call sparse_ekbulk - endif - else - if (valley_projection_calc) then - call ek_bulk_line_valley - else - call ek_bulk_line - endif - !call ek_bulk_spin - !call ek_bulk_mirror_z - end if - call now(time_end) - call print_time_cost(time_start, time_end, 'BulkBand') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating bulk band' - endif - - !> bulk band of a series k points. - if (BulkBand_points_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the bulk band in points mode' - call now(time_start) - call ek_bulk_point_mode - call now(time_end) - call print_time_cost(time_start, time_end, 'BulkBand_points') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating the bulk band in points mode' - endif - - - !> bulk band in a plane. For Dirac or Weyl cone - if (BulkBand_plane_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the bulk band in plane' - call now(time_start) - - if (Is_Sparse_Hr) then - call sparse_ekbulk_plane - else - call ek_bulk_plane - endif - - !call ek_bulk_plane_C2yT - call now(time_end) - call print_time_cost(time_start, time_end, 'BulkBand_plane') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating the bulk band in plane' - endif - - - if (LandauLevel_B_dos_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating Landau level spectrum' - call now(time_start) - call LandauLevel_B_dos_Lanczos - call now(time_end) - call print_time_cost(time_start, time_end, 'LandauLevel_B_dos_calc') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating Landau level spectrum' - endif - - - if (LandauLevel_k_dos_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating Landau level spectrum' - call now(time_start) - call LandauLevel_k_dos_Lanczos - call now(time_end) - call print_time_cost(time_start, time_end, 'LandauLevel_k_dos_calc') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating Landau level spectrum' - endif - - if (Hof_Butt_calc.or.LandauLevel_B_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> start of calculating the Hofstader butterfly ' - call now(time_start) - if (Is_HrFile) then - if(Is_Sparse_Hr) then - call sparse_landau_level_B - else - call landau_level_B - end if - endif - call now(time_end) - call print_time_cost(time_start, time_end, 'Hof_Butt_calc') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating the Hofstader butterfly' - endif - - - !> calculate LandauLevel along kpath with fixed B set by Nslab - if (LandauLevel_kplane_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start to calculate LandauLevel_kplane_calc' - call now(time_start) - if (Is_HrFile) then - call landau_level_kplane - endif - call now(time_end) - call print_time_cost(time_start, time_end, 'LandauLevel_kplane_calc') - if(cpuid.eq.0)write(stdout, *)'End of LandauLevel_kplane_calc calculation' - endif - - - !> calculate LandauLevel along kpath with fixed B set by Magq - if (LandauLevel_k_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start to calculate LandauLevel_k_calc' - call now(time_start) - if (Is_HrFile) then - if(Is_Sparse_Hr.or.Num_wann*Magq>2000) then - call sparse_landau_level_k - else - call landau_level_k - endif - else - endif - call now(time_end) - call print_time_cost(time_start, time_end, 'LandauLevel_k_calc') - if(cpuid.eq.0)write(stdout, *)'End of LandauLevel_k_calc calculation' - endif - - - if (BulkBand_cube_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the bulk band in a cube of BZ' - call now(time_start) - call ek_bulk_cube - call now(time_end) - call print_time_cost(time_start, time_end, 'BulkBand_cube') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating the bulk band in a cube of BZ' - endif - - - !> Find nodes in BZ - if (FindNodes_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of nodes searching' - call now(time_start) - call FindNodes - call now(time_end) - call print_time_cost(time_start, time_end, 'FindNodes') - if(cpuid.eq.0)write(stdout, *)'<< End of nodes searching' - endif - - !> calculate Fermi surface on a k plane - if (BulkFS_Plane_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the bulk FS in a k plane' - call now(time_start) - call fermisurface_kplane - call now(time_end) - call print_time_cost(time_start, time_end, 'BulkFS_Plane') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating the bulk FS in a k plane' - endif - - if (BulkFS_Plane_stack_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the bulk FS in a k plane stacking' - call now(time_start) - call fermisurface_stack - call now(time_end) - call print_time_cost(time_start, time_end, 'BulkFS_Plane_stack') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating the bulk FS in a k plane stacking' - endif - - - !> get fermi level - if (FermiLevel_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of getting Fermi level' - call now(time_start) - call get_fermilevel - call now(time_end) - call print_time_cost(time_start, time_end, 'FermiLevel_calc') - if(cpuid.eq.0)write(stdout, *)'<< End of getting Fermi level' - endif - - - !> calculate 3D Fermi surface - if (BulkFS_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the bulk FS' - call now(time_start) - call fermisurface3D - call now(time_end) - call print_time_cost(time_start, time_end, 'BulkFS') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating the bulk FS' - endif - - !> calculate density of state and joint density of state - if (JDos_calc.and.Dos_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating DOS and Jdos for bulk system' - call now(time_start) - call dos_joint_dos - call now(time_end) - call print_time_cost(time_start, time_end, 'Dos_calc and Jdos_calc') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating the DOS and Jdos for bulk system' - else - if (Dos_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating DOS for bulk system' - call now(time_start) - if(.not. Is_Sparse_Hr) then - call dos_sub - else - call dos_sparse - end if - call now(time_end) - call print_time_cost(time_start, time_end, 'Dos_calc') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating the DOS for bulk system' - endif - - if (JDos_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating JDOS for bulk system' - call now(time_start) - call Joint_dos - call now(time_end) - call print_time_cost(time_start, time_end, 'JDos_calc') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating the JDOS for bulk system' - endif - endif - - !> effective mass - if (EffectiveMass_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the effective mass' - call now(time_start) - call effective_mass_calc - call now(time_end) - call print_time_cost(time_start, time_end, 'EffectiveMass_calc') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating the effective mass' - endif - - - if (BulkGap_plane_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the bulk gap in plane' - call now(time_start) - !call psik_bulk - !call ek_bulk_polar - !call ek_bulk_fortomas - !call ek_bulk2D - !call ek_bulk2D_spin - call gapshape - call now(time_end) - call print_time_cost(time_start, time_end, 'BulkGap_plane') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating the bulk gap in plane' - endif - - if (BulkGap_Cube_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> start of calculating the bulk gap in Cube' - call now(time_start) - call gapshape3D - call now(time_end) - call print_time_cost(time_start, time_end, 'BulkGap_Cube') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating the bulk gap in Cube' - endif - - !> slab band kplane mode - if (SlabBand_plane_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the slab band structure in k plane mode' - call now(time_start) - call ek_slab_kplane - call now(time_end) - call print_time_cost(time_start, time_end, 'SlabBand_plane') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating the slab band structure in k plane mode' - endif - - !> Wave function of Slab - if (SlabBandWaveFunc_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the slab band wave function' - call now(time_start) - call psik_slab - call now(time_end) - call print_time_cost(time_start, time_end, 'SlabBandWaveFunc_calc') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating the slab band wave function' - endif - - !> slab band kpath mode - if (SlabBand_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the slab band structure' - call now(time_start) - if (Is_Sparse_Hr) then - call ek_slab_sparseHR - else - call ek_slab - endif - call now(time_end) - call print_time_cost(time_start, time_end, 'SlabBand_calc') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating the slab band structure' - endif - - !> slab band BdG - if (SlabBdG_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the slab BdG band structure' - call now(time_start) - call ek_slab_BdG - call now(time_end) - call print_time_cost(time_start, time_end, 'SlabBand') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating the slab BdG band structure' - endif - - - - if (BerryCurvature_slab_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the Berry curvature for a slab system' - call now(time_start) - call berry_curvarture_slab - call now(time_end) - call print_time_cost(time_start, time_end, 'BerryCurvature_slab') - if(cpuid.eq.0)write(stdout, *)'End of calculating the Berry curvature for a slab system' - endif - - if (Berrycurvature_kpath_EF_calc.or.BerryCurvature_kpath_Occupied_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the Berry curvature' - call now(time_start) - call berry_curvarture_line - call now(time_end) - call print_time_cost(time_start, time_end, 'BerryCurvature') - if(cpuid.eq.0)write(stdout, *)'End of calculating the Berry curvature' - endif - - if (BerryCurvature_calc.or.Berrycurvature_EF_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the Berry curvature' - call now(time_start) - call berry_curvarture_plane_full - call now(time_end) - call print_time_cost(time_start, time_end, 'BerryCurvature') - if(cpuid.eq.0)write(stdout, *)'End of calculating the Berry curvature' - endif - - if (BerryCurvature_Cube_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the Berry curvature in a k-cube' - call now(time_start) - call berry_curvarture_cube - call now(time_end) - call print_time_cost(time_start, time_end, 'BerryCurvature_Cube') - if(cpuid.eq.0)write(stdout, *)'End of calculating the Berry curvature in a cube' - endif - - - if (WireBand_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the wire band' - call now(time_start) - call ek_ribbon - call now(time_end) - call print_time_cost(time_start, time_end, 'WireBand') - if(cpuid.eq.0)write(stdout, *)'End of calculating the wire band' - endif - - !> Chirality of Weyl points calculation - if (WeylChirality_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of chirality of Weyl points calculating' - call now(time_start) - call wannier_center3D_weyl - call now(time_end) - call print_time_cost(time_start, time_end, 'WeylChirality_calc') - if(cpuid.eq.0)write(stdout, *)'<< End of chirality of Weyl points calculating' - endif - - - !> wannier center calculate - if (wanniercenter_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the Wilson loop' - call now(time_start) - call wannier_center3D_plane_adaptive - call now(time_end) - call print_time_cost(time_start, time_end, 'WannierCenter') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating the Wilson loop' - endif - - !> Slab BdG wannier center calculate - if (BdGChern_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the Wilson loop for Slab BdG' - call now(time_start) - call wannier_center2D_BdG ! tmp added by luoay at 2022/04/02 - call now(time_end) - call print_time_cost(time_start, time_end, 'WannierCenterBdG') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating the Wilson loop' - endif - - - !> mirror chern number calculation - if (MirrorChern_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the mirror chern number' - call now(time_start) - call wannier_center3D_plane_mirror - call now(time_end) - call print_time_cost(time_start, time_end, 'MirrorChern_calc') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating the mirror chern number' - endif - - !> wannier center calculattion for the whole BZ, 6 planes - if (Z2_3D_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating Z2 number for the bulk' - call now(time_start) - !call Z2_3D - call Z2_3D_adaptive - call now(time_end) - call print_time_cost(time_start, time_end, 'Z2_calc') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating Z2 number for the bulk' - endif - - !> wannier center calculattion for the whole BZ, 6 planes - if (Chern_3D_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating Chern number for the bulk' - call now(time_start) - call Chern_3D - call now(time_end) - call print_time_cost(time_start, time_end, 'Chern_3D_calc') - if(cpuid.eq.0)write(stdout, *)'<< End of calculating Chern number for the bulk' - endif - - - if (BerryPhase_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the Berry phase' - call now(time_start) - call berryphase - call now(time_end) - call print_time_cost(time_start, time_end, 'BerryPhase') - if(cpuid.eq.0)write(stdout, *)'End of calculating the Berry phase' - endif - - !> calculate ordinary hall effect with Boltzmann transport - if (Boltz_evolve_k)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start to calculate ordinary hall effects for different k' - call now(time_start) - call evolve_k_ohe - call now(time_end) - call print_time_cost(time_start, time_end, 'Boltz_evolve_k') - if(cpuid.eq.0)write(stdout, *)'End of OHE calculation' - endif - - !> calculate with Boltzmann transport - if (Boltz_k_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start to calculate ordinary hall effects for different k' - call now(time_start) - call sigma_k_ohe - call now(time_end) - call print_time_cost(time_start, time_end, 'Boltz_k_calc') - if(cpuid.eq.0)write(stdout, *)'End of OHE calculation' - endif - - !> calculate ordinary hall effect with Boltzmann transport - if (Boltz_OHE_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start to calculate ordinary hall effects' - call now(time_start) - call sigma_resistivity - call now(time_end) - call print_time_cost(time_start, time_end, 'Boltz_OHE_calc') - if(cpuid.eq.0)write(stdout, *)'End of OHE calculation' - endif - - !> calculate spin hall conductivity - if (SHC_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start to calculate spin hall conductivity' - call now(time_start) - call sigma_SHC - call now(time_end) - call print_time_cost(time_start, time_end, 'SHC_calc') - if(cpuid.eq.0)write(stdout, *)'End of SHC calculation' - endif - - !> calculate anomalouls hall conductivity - if (AHC_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start to calculate anomalouls hall conductivity' - call now(time_start) - call sigma_AHC - call now(time_end) - call print_time_cost(time_start, time_end, 'AHC_calc') - if(cpuid.eq.0)write(stdout, *)'End of AHC calculation' - endif - - !> calculate anomalouls nernst coefficient - if (ANE_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start to calculate anomalouls nernst coefficient' - call now(time_start) - call alpha_ANE - call now(time_end) - call print_time_cost(time_start, time_end, 'ANE_calc') - if(cpuid.eq.0)write(stdout, *)'End of ANE calculation' - endif - - !> surface state - if (SlabSS_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the surface state' - call now(time_start) - call surfstat - call now(time_end) - call print_time_cost(time_start, time_end, 'SlabSS_calc') - if(cpuid.eq.0)write(stdout, *)'End of calculating the surface state' - endif - - !> fermi arc - if (SlabArc_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the surface arc' - call now(time_start) - call SurfaceDOSkk - call now(time_end) - call print_time_cost(time_start, time_end, 'SlabArc') - if(cpuid.eq.0)write(stdout, *)'End of calculating the surface arc' - endif - - !> fermi arc QPI in kpath mode - if (SlabQPI_kpath_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the surface QPI in kpath mode' - call now(time_start) - call surfstat_jdos - call now(time_end) - call print_time_cost(time_start, time_end, 'SlabQPI') - if(cpuid.eq.0)write(stdout, *)'End of calculating the surface QPI in kpath mode' - endif - - !> Surface State QPI in kplane mode - if (SlabQPI_calc.or.SlabQPI_kplane_calc) then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the surface QPI' - call now(time_start) - call SurfaceDOSkk - call now(time_end) - call print_time_cost(time_start, time_end, 'SlabQPI') - if(cpuid.eq.0)write(stdout, *)'End of calculating the surface QPI' - endif - - !> calculate spin-texture - if (SlabSpintexture_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the spin texture for surface' - call now(time_start) - !call spintext - call SurfaceDOSkk - call now(time_end) - call print_time_cost(time_start, time_end, 'SlabSpintexture') - if(cpuid.eq.0)write(stdout, *)'End of calculating the spin texture for surface' - endif - - !> calculate spin-texture for bulk bands - if (BulkSpintexture_calc)then - if(cpuid.eq.0)write(stdout, *)' ' - if(cpuid.eq.0)write(stdout, *)'>> Start of calculating the spin texture for surface' - call now(time_start) - call fermisurface_kplane - call now(time_end) - call print_time_cost(time_start, time_end, 'SlabSpintexture') - if(cpuid.eq.0)write(stdout, *)'End of calculating the spin texture for surface' - endif - - call now(time_end) - - if(cpuid.eq.0)write(stdout, *)' ' - call print_time_cost(time_init, time_end, 'whole program') - call footer - - -#if defined (MPI) - call mpi_finalize(ierr) -#endif - - end !<< end of main program diff --git a/module.f90 b/module.f90 deleted file mode 100644 index 19b130fa..00000000 --- a/module.f90 +++ /dev/null @@ -1,1136 +0,0 @@ -#if defined (INTELMKL) - include 'mkl_dss.f90' -#endif - - module prec - !>> A module controls the precision. - !> when the nnzmax is larger than 2,147,483,647 then li=8, - !> otherwise, li=4. - !> warning: li=4 was tested, li=8 is not tested yet. - integer,parameter :: li=4 ! long integer - integer,parameter :: Dp=kind(1.0d0) ! double precision - end module prec - - module wmpi - use prec - -#if defined (MPI) - include 'mpif.h' -#endif - - integer :: cpuid ! CPU id for mpi - integer :: num_cpu ! Number of processors for mpi - -#if defined (MPI) - integer, parameter :: mpi_in= mpi_integer - integer, parameter :: mpi_dp= mpi_double_precision - integer, parameter :: mpi_dc= mpi_double_complex - integer, parameter :: mpi_cmw= mpi_comm_world -#endif - - !> Define a structure containing information for doing communication - type WTParCSRComm - - !> mpi communicator - integer :: comm - - !> how many cpus that we need to send data on - integer :: NumSends - - !> which cpus that we need to send data on - integer, pointer :: SendCPUs(:) - - !> when before we send the vector data to other cpus, we need to get the - !> data which should be sent, then put these data to a array called - !> x_buf_data(:). The array SendMapElements(:) gives the position of the - !> data in vector that should be sent. - integer, pointer :: SendMapStarts(:) - - !> with this array, we can select the vector data that should be sent - integer(li), pointer :: SendMapElements(:) - - !> How many cpus that we need to recieve data from - integer :: NumRecvs - - !> Which cpus that we need to recieve data from - integer, pointer :: RecvCPUs(:) - - !> When recieved data from other cpus, we need to arrange those data into - !> an array. The length of this - integer, pointer :: RecvVecStarts(:) - end type WTParCSRComm - - !> Define a structure containing information for doing communication - type WTParVecComm - - !> mpi communicator - integer :: comm - - !> how many cpus that we need to send data on - integer :: NumSends - - !> which cpus that we need to send data on - integer, pointer :: SendCPUs(:) - - !> when before we send the vector data to other cpus, we need to get the - !> data which should be sent, then put these data to a array called - !> x_buf_data(:). The array SendMapElements(:) gives the position of the - !> data in vector that should be sent. - integer, pointer :: RecvMapStarts(:) - - !> with this array, we can select the vector data that should be sent - integer(li), pointer :: RecvMapElements(:) - - !> How many cpus that we need to recieve data from - integer :: NumRecvs - - !> Which cpus that we need to recieve data from - integer, pointer :: RecvCPUs(:) - - !> When recieved data from other cpus, we need to arrange those data into - !> an array. The length of this - integer, pointer :: SendVecStarts(:) - - integer :: NumRowsDiag - integer :: NumRowsOffd - - integer(li), pointer :: RowMapOffd(:) - integer(li), pointer :: LocalIndexOffd(:) - integer(li), pointer :: LocalIndexDiag(:) - end type WTParVecComm - - - - !> define a handle for comm, that can be created and destroyed - type WTCommHandle - - type(WTParCSRComm), pointer :: sendrecv - - integer :: numrequest - integer, pointer :: mpirequest(:) - - complex(dp), pointer :: senddata(:) - complex(dp), pointer :: recvdata(:) - - end type WTCommHandle - - integer :: BasisStart - integer :: BasisEnd - - contains - - !> generate partition for any vector with a given length - subroutine WTGeneratePartition(length, nprocs, part) - - implicit none - - integer(li), intent(in) :: length - integer, intent(in) :: nprocs - integer(li), intent(out) :: part(nprocs+1) - - integer :: i - integer(li) :: div - integer(li) :: mod1 - - mod1= mod(length, nprocs) - if (mod1.eq.0) then !< each cpu has the same load balance - div= length/nprocs - do i=0, nprocs-1 - part(i+1)=1+ i*div - enddo - else - div= length/nprocs+ 1 - do i=0, nprocs - if (i.ge. (nprocs-mod1)) then - part(i+1)= 1+ i*div- (nprocs-mod1) - else - part(i+1)= 1+ i*(div-1) !< the main cpu will get smaller data - endif - enddo - endif - part(nprocs+1)= length+ 1 - - return - end subroutine WTGeneratePartition - - !> generate local partition for any vector with a given length - subroutine WTGenerateLocalPartition(length, nprocs, icpu, first, last) - implicit none - integer, intent(in) :: nprocs - integer, intent(in) :: icpu - integer(li), intent(in) :: length - integer(li), intent(out) :: first - integer(li), intent(out) :: last - - integer(li) :: div - integer(li) :: mod1 - - mod1= mod(length, nprocs) - if (mod1.eq.0) then !< each cpu has the same load balance - div= length/nprocs - first=1+ icpu*div - last=(1+ icpu)*div - else - div= length/nprocs+ 1 - if (icpu.ge. (nprocs-mod1)) then - first= 1+ icpu*div- (nprocs-mod1) - last= (1+ icpu)*div- (nprocs-mod1) - else - first= 1+ icpu*(div-1) - last= (1+ icpu)*(div-1)!< the main cpu will get smaller data - endif - endif - - return - end subroutine WTGenerateLocalPartition - - !> given the send data, recieve data and sendrecv list, we can use - !> this subroutine to send and recieve data from other cpus. - !> when finished this subroutine calls, we need call WTCommHandleDestroy - !> to check whether the send recv operation is finished - subroutine WTCommHandleCreate(SendRecv, SendData, RecvData, & - CommHandle) - - implicit none - - !* in variables - type(WTParCSRComm), intent(in), pointer :: SendRecv - complex(dp), pointer :: SendData(:) - complex(dp), pointer :: RecvData(:) - - !* out variables - type(WTCommHandle), pointer :: CommHandle - - integer(li) :: VecStart - integer(li) :: VecLen - - !> sendrecv data - integer, pointer :: SendCPUs(:) - integer, pointer :: SendMapStarts(:) - integer(li), pointer :: SendMapElements(:) - integer, pointer :: RecvCPUs(:) - integer, pointer :: RecvVecStarts(:) - - integer :: NumRecvs - integer :: NumSends - integer :: NumRequest - integer, pointer :: MpiRequest(:) - - integer :: ierr - integer :: comm - integer :: NCPUs - integer :: cpu_id - - integer :: i, j - integer :: icpu - - !* initialize null pointers - SendCPUs=> Null() - SendMapStarts=> Null() - SendMapElements=> Null() - RecvCPUs=> Null() - RecvVecStarts=> Null() - MpiRequest=> Null() - -#if defined (MPI) - comm= SendRecv%Comm - call mpi_comm_size(comm, NCPUS, ierr) - call mpi_comm_rank(comm, cpu_id, ierr) -#endif - NumSends= SendRecv%NumSends - NumRecvs= SendRecv%NumRecvs - NumRequest= NumSends+ NumRecvs - - SendCPUs=> SendRecv%SendCPUs - SendMapStarts=> SendRecv%SendMapStarts - SendMapElements=> SendRecv%SendMapElements - RecvCPUs=> SendRecv%RecvCPUs - RecvVecStarts=> SendRecv%RecvVecStarts - - MpiRequest=> Null() - if (.not.associated(CommHandle)) allocate(CommHandle) - allocate(CommHandle%MpiRequest(NumRequest)) - MpiRequest=> CommHandle%MpiRequest - - !> recieve data from other cpus using non-block communication - j=1 - do i=1, NumRecvs - icpu= RecvCPUs(i) - VecStart= RecvVecStarts(i) - VecLen= RecvVecStarts(i+1)- RecvVecStarts(i) -#if defined (MPI) - call mpi_irecv(RecvData(VecStart), VecLen, mpi_dc, icpu, & - 0, comm, MpiRequest(j), ierr) -#endif - j=j+1 - enddo - - !> send data to other cpus using non-block communication - do i=1, NumSends - icpu= SendCPUs(i) - VecStart= SendMapStarts(i) - VecLen= SendMapStarts(i+1)- SendMapStarts(i) -#if defined (MPI) - call mpi_isend(SendData(VecStart), VecLen, mpi_dc, icpu, & - 0, comm, MpiRequest(j), ierr) -#endif - j=j+1 - enddo - - CommHandle%NumRequest= NumRequest - CommHandle%SendData=> SendData - CommHandle%RecvData=> RecvData - CommHandle%SendRecv=> SendRecv - - return - - end subroutine WTCommHandleCreate - - subroutine WTCommHandleDestroy(CommHandle) - - implicit none - - type(WTCommHandle), pointer :: CommHandle - - integer :: ierr - integer :: NumRequest - integer, pointer :: MpiRequest(:) - integer, pointer :: MpiStatus(:) - - NumRequest= CommHandle%NumRequest - MpiRequest=> CommHandle%MpiRequest - - if (.not.associated(CommHandle)) return - - if (NumRequest>0) then -#if defined (MPI) - allocate(MpiStatus(mpi_status_size*NumRequest)) - call mpi_waitall(NumRequest, MpiRequest, MpiStatus, ierr) -#endif - endif - - return - end subroutine WTCommHandleDestroy - - !> define my mpi_allreduce for complex array - subroutine mp_allreduce_z(comm, ndim, vec, vec_mpi) - implicit none - - integer, intent(in) :: comm - integer, intent(in) :: ndim - complex(dp), intent(in) :: vec(ndim) - complex(dp), intent(inout) :: vec_mpi(ndim) - - integer :: ierr - - vec_mpi= 0d0 - -#if defined (MPI) - call mpi_allreduce(vec, vec_mpi, ndim, & - mpi_dc, mpi_sum, comm, ierr) -#else - vec_mpi= vec -#endif - - return - end subroutine mp_allreduce_z - - end module wmpi - - module para - !> Some global parameters - ! - !> Copyright (c) 2010 QuanSheng Wu. All rights reserved. - ! - !> add namelist for convenience June 5th 2016 by QuanSheng Wu - - use wmpi - use prec - implicit none - - character(80) :: version - - integer,parameter :: stdout= 8 - - type int_array1D - integer :: length - integer, allocatable :: iarray(:) - end type int_array1D - - !> define the file index to void the same index in different subroutines - integer, public, save :: outfileindex= 11932 - - character(80) :: Hrfile ! filename - character(80) :: Overlapfile ! overlap matrix between basis only when Orthogonal_Basis=F - character(80) :: Particle ! phonon, electron - character(80) :: Package ! VASP, QE - character(80) :: KPorTB ! KP or TB - logical :: Orthogonal_Basis ! True or False for Orthogonal basis or non-orthogonal basis - logical :: Is_Sparse_Hr, Is_Sparse, Is_Hrfile - namelist / TB_FILE / Hrfile, Particle, Package, KPorTB, Is_Hrfile, & - Is_Sparse, Is_Sparse_Hr, Orthogonal_Basis, Overlapfile - - !> control parameters - logical :: BulkBand_calc ! Flag for bulk energy band calculation - logical :: BulkBand_line_calc ! Flag for bulk energy band calculation - logical :: BulkBand_unfold_line_calc ! Flag for bulk energy band calculation - logical :: BulkBand_unfold_plane_calc ! Flag for bulk energy band calculation - logical :: QPI_unfold_plane_calc ! Flag for bulk energy band calculation - logical :: Landaulevel_unfold_line_calc ! Flag for bulk energy band calculation - logical :: BulkFatBand_calc ! Flag for bulk energy band calculation - logical :: BulkBand_plane_calc ! Flag for bulk energy band calculation for a fixed k plane - logical :: BulkBand_cube_calc ! Flag for bulk energy band calculation for a fixed k plane - logical :: BulkBand_points_calc ! Flag for bulk energy band calculation for some k points - logical :: BulkFS_calc ! Flag for bulk 3D fermi surface in 3D BZ calculation - logical :: BulkFS_plane_calc ! Flag for bulk fermi surface for a fix k plane calculation - logical :: BulkFS_plane_stack_calc ! Flag for bulk fermi surface for a fix k plane calculation - logical :: BulkGap_cube_calc ! Flag for Gap_cube calculation - logical :: BulkGap_plane_calc ! Flag for Gap_plane calculation - logical :: SlabBand_calc ! Flag for 2D slab energy band calculation - logical :: SlabBdG_calc ! Flag for 2D slab BdG energy band calculation - logical :: SlabBandWaveFunc_calc ! Flag for 2D slab band wave function - logical :: SlabBand_plane_calc ! Flag for 2D slab energy band calculation - logical :: WireBand_calc ! Flag for 1D wire energy band calculation - logical :: SlabSS_calc ! Flag for surface state ARPES spectrum calculation - logical :: Dos_calc ! Flag for density of state calculation - logical :: ChargeDensity_selected_bands_calc ! Flag for charge density - logical :: ChargeDensity_selected_energies_calc ! Flag for charge density - logical :: JDos_calc ! Flag for joint density of state calculation - logical :: SlabArc_calc ! Flag for surface state fermi-arc calculation - logical :: SlabQPI_calc ! Flag for surface state QPI spectrum calculation in a given k plane in 2D BZ - logical :: SlabQPI_kplane_calc ! is the same as SlabQPI_calc - logical :: SlabQPI_kpath_calc ! Flag for surface state QPI spectrum calculation in a given kpath in 2D BZ - logical :: SlabSpintexture_calc ! Flag for surface state spin-texture calculation - logical :: BulkSpintexture_calc ! Flag for spin-texture calculation - logical :: WannierCenter_calc ! Flag for Wilson loop calculation - logical :: BdGChern_calc ! Flag for Wilson loop calculation of Slab BdG Hamiltonian - logical :: Z2_3D_calc ! Flag for Z2 number calculations of 6 planes - logical :: WeylChirality_calc ! Weyl chirality calculation - logical :: NLChirality_calc ! Chirality calculation for nodal line - logical :: Chern_3D_calc ! Flag for Chern number calculations of 6 planes - logical :: MirrorChern_calc ! Flag for mirror Chern number calculations - logical :: BerryPhase_calc ! Flag for Berry phase calculation - logical :: BerryCurvature_calc ! Flag for Berry curvature calculation - logical :: BerryCurvature_plane_selectedbands_calc ! Flag for Berry curvature calculation - logical :: BerryCurvature_EF_calc ! Flag for Berry curvature calculation - logical :: BerryCurvature_kpath_EF_calc ! Flag for Berry curvature calculation in kpath model at EF - logical :: BerryCurvature_kpath_Occupied_calc ! Flag for Berry curvature calculation in kpath model sum over all occupied bands - logical :: BerryCurvature_Cube_calc ! Flag for Berry curvature calculation - logical :: BerryCurvature_slab_calc ! Flag for Berry curvature calculation for a slab system - logical :: EffectiveMass_calc ! Flag for effective mass calculation - logical :: FindNodes_calc ! Flag for effective mass calculation - logical :: TBtoKP_calc ! Flag for kp model construction from tight binding model - logical :: Hof_Butt_calc ! Flag for Hofstader butterfly - logical :: LandauLevel_B_calc ! Flag for Hofstader butterfly - logical :: LOTO_correction ! Flag for LOTO correction of phonon spectrum - logical :: Boltz_OHE_calc ! Flag for Boltzmann tranport under magnetic field - logical :: Boltz_Berry_correction ! Flag for Boltzmann tranport under magnetic field - logical :: Symmetry_Import_calc ! Flag for Boltzmann tranport under magnetic field using symmetry - logical :: Boltz_evolve_k ! Flag for Boltzmann tranport under magnetic field - logical :: Boltz_k_calc ! Flag for Boltzmann tranport under magnetic field - logical :: AHC_calc ! Flag for Boltzmann tranport under magnetic field - logical :: SHC_calc ! Flag for spin Hall effect calculation - logical :: LandauLevel_k_calc ! Flag for landau level calculation along k direction with fixed B - logical :: LandauLevel_kplane_calc ! Flag for landau level calculation along in a kplane in the magnetic BZ - logical :: LandauLevel_k_dos_calc ! Flag for landau level spectrum mode calculation along k direction with fixed B - logical :: LandauLevel_B_dos_calc ! Flag for landau level spectrum mode calculation for different B with given k point - logical :: LandauLevel_wavefunction_calc ! Flag for landau level calculation along k direction with fixed B - logical :: OrbitalTexture_calc ! Flag for Orbital texture calculation in a given k plane - logical :: OrbitalTexture_3D_calc ! Flag for Orbital texture calculation in a given k plane - logical :: Fit_kp_calc ! Flag for fitting kp model - logical :: DMFT_MAG_calc ! DMFT loop in uniform magnetic field - logical :: LanczosSeqDOS_calc ! DOS - logical :: Translate_to_WS_calc ! whether translate the k points into the Wigner-Seitz cell - logical :: FermiLevel_calc ! calculate Fermi level for a given temperature Beta=1/T - logical :: ANE_calc ! calculate anomalous nernst coefficient - - logical :: LanczosBand_calc=.false. - logical :: LanczosDos_calc= .false. - logical :: landau_chern_calc = .false. - logical :: export_newhr = .false. - logical :: export_maghr =.false. - logical :: valley_projection_calc ! for valley projection, only for sparse hamiltonina, you need to provide the valley operator - - logical :: w3d_nested_calc = .false. - - namelist / Control / BulkBand_calc, BulkFS_calc, BulkFS_Plane_calc, & - BulkFS_plane_stack_calc, BulkGap_plane_calc, & - QPI_unfold_plane_calc, & - BulkBand_unfold_line_calc, & - Landaulevel_unfold_line_calc, & - BulkBand_unfold_plane_calc, & - BulkBand_points_calc, BulkBand_cube_calc, BulkBand_line_calc, & - BulkGap_cube_calc, BulkSpintexture_calc, BulkFatBand_calc, & - SlabBand_calc, SlabBand_plane_calc, SlabBandWaveFunc_calc,& - SlabQPI_calc, SlabQPI_kpath_calc, SlabQPI_kplane_calc, & - SlabSS_calc, SlabArc_calc, SlabSpintexture_calc,& - ChargeDensity_selected_bands_calc, & - ChargeDensity_selected_energies_calc, & - WireBand_calc, & - WannierCenter_calc,BerryPhase_calc, & - BerryCurvature_EF_calc, BerryCurvature_calc, & - Berrycurvature_kpath_EF_calc, BerryCurvature_kpath_Occupied_calc, & - BerryCurvature_plane_selectedbands_calc, & - BerryCurvature_slab_calc, MirrorChern_calc, BerryCurvature_Cube_calc, & - Z2_3D_calc, Chern_3D_calc, WeylChirality_calc, NLChirality_calc, & - Dos_calc, JDos_calc, EffectiveMass_calc, & - FindNodes_calc, TBtoKP_calc, LOTO_correction, & - BulkBand_plane_calc, Hof_Butt_calc, Symmetry_Import_calc, & - Boltz_Berry_correction, & - Boltz_k_calc, Boltz_evolve_k, Boltz_OHE_calc, AHC_Calc, SHC_calc, & - LandauLevel_k_calc, OrbitalTexture_calc, OrbitalTexture_3D_calc, & - LandauLevel_wavefunction_calc, Fit_kp_calc, DMFT_MAG_calc, & - LanczosSeqDOS_calc, Translate_to_WS_calc, LandauLevel_k_dos_calc, & - LandauLevel_B_dos_calc,LanczosBand_calc,LanczosDos_calc, & - LandauLevel_B_calc, LandauLevel_kplane_calc,landau_chern_calc, & - FermiLevel_calc,ANE_calc, export_newhr,export_maghr,w3d_nested_calc, & - valley_projection_calc, BdGChern_calc, SlabBdG_calc - - integer :: Nslab ! Number of slabs for 2d Slab system - integer :: Nslab1 ! Number of slabs for 1D wire system - integer :: Nslab2 ! Number of slabs for 1D wire system - - integer :: Np !> Number of princple layers for surface green's function - - integer, public, save :: ijmax=10 - - integer :: Ndim !> Leading dimension of surface green's function - - integer :: Numoccupied !> Number of occupied bands for bulk unit cell - - - real(dp) :: Ntotch !> Number of electrons - - integer :: Num_wann ! Number of Wannier functions - - integer :: Num_wann_BdG ! Number of Wannier functions for BdG - - integer :: Nrpts ! Number of R points - integer :: Nrpts_valley ! Number of R points - - - integer :: Nk ! number of k points for different use - integer :: Nk1 ! number of k points for different use - integer :: Nk2 ! number of k points for different use - integer :: Nk3 ! number of k points for different use - integer, parameter :: Nk2_max= 4096 ! maximum number of k points - - integer, public, save :: Nr1=5 - integer, public, save :: Nr2=5 - integer, public, save :: Nr3=2 - - - integer,parameter :: kmesh(2)=(/200 , 200/) ! kmesh used for spintexture - integer,parameter :: knv=kmesh(1)*kmesh(2) ! number of k points used for spintexture - - - integer :: Soc, SOC_in ! A parameter to control soc; Soc=0 means no spin-orbit coupling; Soc>0 means spin-orbit coupling - - - real(Dp) :: eta ! used to calculate dos epsilon+i eta - real(Dp) :: Eta_Arc ! used to calculate dos epsilon+i eta - - real(Dp) :: EF_broadening ! used to define the energy range around fermi energy in calculating sigma_OHE - - - integer :: OmegaNum ! The number of energy slices between OmegaMin and OmegaMax - integer :: OmegaNum_unfold ! The number of energy slices between OmegaMin and OmegaMax - real(dp), allocatable :: Omega_array(:) - - integer :: NumLCZVecs !> number of Lanczos vectors - integer :: NumSelectedEigenVals !> number of Selected eigen values - - integer :: NumRandomConfs !> number of random configurations, used in the Lanczos DOS calculation, default is 1 - - real(dp) :: OmegaMin, OmegaMax ! omega interval - - real(Dp) :: E_arc ! Fermi energy for arc calculation - - - real(Dp) :: Gap_threshold ! threshold value for output the the k points data for Gap3D - - !>> some parameters for DMFT - !> The inverse of temperature Beta= 1/(KB*T), Beta*T=11600, T is in unit of Kelvin - real(dp) :: Beta - - !> temperature related parameters, read from input.dat - !> be used to define a range of temperatures, in units of Kelvin - real(dp) :: Tmin - real(dp) :: Tmax - integer :: NumT - - !> magnetic field times time in units of Tesla*ps - real(dp) :: BTauMax, Relaxation_Time_Tau - integer :: NBTau, BTauNum - integer :: Nslice_BTau_Max - - real(dp) :: symprec= 1E-4 - - !> cut of radial for summation over R vectors - real(dp) :: Rcut - - !> a integer to control the magnetic filed, Magp should smaller than Nq - integer :: Magp, Magp_min, Magp_max, Magq - - !>> parameters for wilson loop calculation (Wannier charge center) - - !> the difference of the wilson loop between two neighbouring k points - real(dp) :: wcc_neighbour_tol - real(dp) :: wcc_calc_tol - - !> projection_weight_mode='UNFOLDEDKPOITNS', 'NORMAL' - !> if project on the single K of another lattice, especially for twisted bilayer systems, - !> you have to specify the new lattice. For smaller new lattice, the bands will be unfolded - !> for larger new lattice, the bands will be folded. - character(20) :: projection_weight_mode - - !> specify the atom index that located on the top surface that you want to study - integer :: topsurface_atom_index - real(dp) :: shift_to_topsurface_cart(3) - - !> a tag to control how do we call ARPACK to diagonalize a sparse matrix - !> value: zndrv1 using A*x - !> zndrv2 using inv(A) - !> default "zndrv1" - character(20) :: arpack_solver - - !> a real number to control when it's a cycle in subroutine RKF45_pack - !> by default RKF45_PERIODIC_LEVEL= 1 - real(dp) :: RKF45_PERIODIC_LEVEL - - !> an integer to print the messages - !> iprint_level=3 : print all the debug messages - integer :: iprint_level = 1 - - !> namelist parameters - namelist /PARAMETERS/ Eta_Arc,EF_broadening, OmegaNum, OmegaNum_unfold, OmegaMin, OmegaMax, & - E_arc, Nk1, Nk2, Nk3, NP, Gap_threshold, Tmin, Tmax, NumT, & - NBTau, BTauNum, BTauMax, Rcut, Magp, Magq, Magp_min, Magp_max, Nslice_BTau_Max, & - wcc_neighbour_tol, wcc_calc_tol, Beta,NumLCZVecs, iprint_level, & - Relaxation_Time_Tau, symprec, arpack_solver, RKF45_PERIODIC_LEVEL, & - NumRandomConfs, NumSelectedEigenVals, projection_weight_mode, topsurface_atom_index - - real(Dp) :: E_fermi ! Fermi energy, search E-fermi in OUTCAR for VASP, set to zero for Wien2k - - real(dp) :: surf_onsite !> surface onsite energy shift - - real(dp) :: Bx, By, Bz !> magnetic field (in Tesla) - real(dp) :: Btheta, Bphi !> magnetic field direction, Bx=cos(theta)*sin(phi), By=sin(theta)*sin(phi), Bz=cos(phi) - real(dp) :: Bmagnitude ! sqrt(Bx*Bx+By*By+Bz*Bz) in Tesla - real(dp) :: Bdirection(3) !> a unit vector to represent the direction of B. - - !>Zeeman field on surface for slab hamiltonian - integer :: Add_surf_zeeman_field ! A parameter to control surface zeeman field; - ! Add_surf_zeeman_field=1 means Zeeman field only in the bottom slab; - ! Add_surf_zeeman_field=2 means Zeeman field only in the top slab; - ! Add_surf_zeeman_field=3 means Zeeman field only in top & bottom two slab - real(dp) :: Bx_surf, By_surf, Bz_surf !> surface zeeman field - - !> for the parameters of BdG Hamiltionian - integer :: Add_Delta_BdG ! A parameter to control s-wave superconducting pairing; - ! Add_Delta_BdG=1 means s-wave superconducting pairing only in the bottom slab; - ! Add_Delta_BdG=2 means s-wave superconducting pairing only in the top slab; - ! Add_Delta_BdG=3 means s-wave superconducting pairing in whole slab - real(dp) :: mu_BdG !> Chemical potential mu - real(dp) :: Delta_BdG !> s-wave superconducting pairing - - - !> related to Zeeman effect, Zeeman energy =Effective_gfactor*Bohr_magneton*magneticfield - !> eg. Effective_gfactor=2, magneticfield=1Tesla, then Zeeman_energy_in_eV =1.16*1E-4 eV - logical :: Add_Zeeman_Field ! if consider zeeman effect in the tight binding model - real(dp) :: Effective_gfactor ! in unit of Bohr magneton - real(dp), parameter :: Bohr_magneton= 0.5d0 ! in unit of Hatree atomic unit - - !> You can specify the Zeeman energy in unit of eV in the input.dat/wt.in directly - !> or you can specify magnetic field and Effective_gfactor together - !> But if you use Zeeman_energy_in_eV, you can't specify the direction - real(dp) :: Zeeman_energy_in_eV - - !> Electric field along the stacking direction of a 2D system in eV/Angstrom - real(dp) :: Electric_field_in_eVpA - real(dp) :: Symmetrical_Electric_field_in_eVpA - integer :: center_atom_for_electric_field(2) ! At this atom, the electric potential is zero - logical :: Inner_symmetrical_Electric_Field - - !> a parameter to control the Vacumm thickness for the slab system - !> only used for generating the POSCAR_slab - real(dp) :: Vacuum_thickness_in_Angstrom - - !> system parameters namelist - !> Some parameters that relate to the properties of the bulk hamiltonian - namelist / SYSTEM / Soc, E_fermi, Bx, By, Bz, Btheta, Bphi, surf_onsite, & - Nslab, Nslab1, Nslab2, Numoccupied, Ntotch, Bmagnitude, Add_surf_zeeman_field, Bx_surf, By_surf, Bz_surf, Add_Delta_BdG, Delta_BdG, mu_BdG, & - Add_Zeeman_Field, Effective_gfactor, Zeeman_energy_in_eV, & - Electric_field_in_eVpA, Symmetrical_Electric_field_in_eVpA, & - Inner_symmetrical_Electric_Field, ijmax, & - Vacuum_thickness_in_Angstrom, center_atom_for_electric_field - - real(dp),parameter :: alpha= 1.20736d0*1D-6 !> e/2/h*a*a a=1d-10m, h is the planck constant then the flux equals alpha*B*s - - !> some parameters related to atomic units - !> https://en.wikipedia.org/wiki/Hartree_atomic_units 2020 - !> WannierTools codes use Hatree atomic units - real(dp),parameter :: Time_atomic=2.4188843265857E-17 ! atomic unit of time \hbar/E_Hatree - real(dp),parameter :: Bohr_radius=5.29177210903E-11 ! Bohr radius in meters - real(dp),parameter :: Angstrom2atomic=1d0/0.529177210903d0 ! Angstrom to atomic length unit (Bohr radius) - real(dp),parameter :: Ang2Bohr=1d0/0.529177210903d0 ! Angstrom to atomic length unit (Bohr radius) - real(dp),parameter :: eV2Hartree= 1d0/27.211385d0 ! electron Voltage to Hartree unit - real(dp),parameter :: Echarge= 1.602176634E-19 ! electron charge in SI unit - real(dp),parameter :: hbar= 1.054571817E-34 ! electron charge in SI unit - real(dp),parameter :: epsilon0= 8.85418781762E-12 ! dielectric constant in SI unit - real(dp),parameter :: Magneticfluxdensity_atomic= 2.35051756758*1E5 ! magnetic field strength in SI unit - - real(dp),parameter :: Pi= 3.14159265358979d0 ! circumference ratio pi - real(dp),parameter :: twopi=2d0*Pi ! two times of Pi - real(dp),parameter :: half= 0.5d0 ! 1/2 - real(dp),parameter :: zero= 0.0d0 ! 0 - real(dp),parameter :: one = 1.0d0 ! 1 - real(dp),parameter :: eps3= 1e-3 ! 0.001 - real(dp),parameter :: eps4= 1e-4 ! 0.0001 - real(dp),parameter :: eps6= 1e-6 ! 0.000001 - real(dp),parameter :: eps8= 1e-8 ! 0.000001 - real(dp),parameter :: eps9= 1e-9 ! 0.000000001 - real(dp),parameter :: eps12= 1e-12 ! 0.000000000001 - complex(dp),parameter :: zzero= (0.0d0, 0d0) ! 0 - complex(dp),parameter :: One_complex= (1.0d0, 0d0) ! 0 - - real(Dp),parameter :: Ka(2)=(/1.0d0,0.0d0/) - real(Dp),parameter :: Kb(2)=(/0.0d0,1.0d0/) - - real(Dp),public, save :: Ra2(2) - real(Dp),public, save :: Rb2(2) - - real(Dp),public, save :: Ka2(2) - real(Dp),public, save :: Kb2(2) - - !> build a type for cell information - type cell_type - !> real space lattice vectors - real(dp) :: Rua(3) ! Three vectors to define the cell box - real(dp) :: Rub(3) - real(dp) :: Ruc(3) - real(dp) :: lattice(3, 3) - - !> a, b, c, alpha, beta, gamma - real(dp) :: cell_parameters(6) - real(dp) :: reciprocal_cell_parameters(6) - - !> reciprocal space lattice vectors - real(dp) :: Kua(3) ! three reciprocal primitive vectors - real(dp) :: Kub(3) ! three reciprocal primitive vectors - real(dp) :: Kuc(3) ! three reciprocal primitive vectors - real(dp) :: reciprocal_lattice(3, 3) - - integer :: Num_atoms ! number of atoms in one primitive cell - integer :: Num_atom_type ! number of atom's type in one primitive cell - integer, allocatable :: Num_atoms_eachtype(:) ! number of atoms for each atom's type in one primitive cell - character(10), allocatable :: Name_of_atomtype(:) ! type of atom - integer, allocatable :: itype_atom(:) ! type of atom - character(10), allocatable :: Atom_name(:) ! Atom's name - - real(dp) :: CellVolume ! Cell volume - real(dp) :: ReciprocalCellVolume - - real(dp), allocatable :: Atom_position_cart(:, :) ! Atom's cartesian position, only the atoms which have Wannier orbitals - real(dp), allocatable :: Atom_position_direct(:, :) - real(dp), allocatable :: wannier_centers_cart(:, :) - real(dp), allocatable :: wannier_centers_direct(:, :) - real(dp), allocatable :: Atom_magnetic_moment(:, :) ! magnetic moment - - integer :: max_projs - integer, allocatable :: nprojs(:) ! Number of projectors for each atoms - integer :: NumberofSpinOrbitals - integer, allocatable :: spinorbital_to_atom_index(:) - integer, allocatable :: spinorbital_to_projector_index(:) - character(10), allocatable :: proj_name(:, :) - end type cell_type - - type dense_tb_hr - !> define a new type to describe the tight-binding Hamiltonian stored as - !> dense Wannier90 hr format - - !> number of R lattice vector points - integer :: nrpts - - !> R lattice vectors in units of three primitive lattice vectors - integer, allocatable :: irvec(:, :) - - !> related cell - type(cell_type) :: cell - - !> degenercy of R point induced by Wigner-Seitz cell integration - integer, allocatable :: ndegen_R(:) - - !> Hamiltonian value - complex(dp), allocatable :: HmnR(:, :, :) - - end type dense_tb_hr - - - - - !> This is the main unit cell specified by user. - !> LATTICE, ATOM_POSITIONS, PROJECTORS - type(cell_type) :: Origin_cell - - !> Usually, Fold_cell is smaller than Origin_cell. - type(cell_type) :: Folded_cell - - !> a global shift between the origin cell to Folded_cell - !> pos_cart_sc= Origin_cell%Atom_position_cart(:, ia)+shift_pos_cart - real(dp) :: global_shift_SC_to_PC_cart(3) - - !> magnetic super cell after adding magnetic field, the size of it is Nslab. - type(cell_type) :: Magnetic_cell - - !> A new cell defined by SURFACE card. - type(cell_type) :: Cell_defined_by_surface - - real(dp),public, save :: Rua_new(3) !> three primitive vectors in new coordinate system, see slab part - real(dp),public, save :: Rub_new(3) !> three primitive vectors in new coordinate system, see slab part - real(dp),public, save :: Ruc_new(3) !> three primitive vectors in new coordinate system, see slab part - - !> magnetic supercell - real(dp),public, save :: Rua_mag(3) ! three primitive vectors in Cartsien coordinatec - real(dp),public, save :: Rub_mag(3) ! three primitive vectors in Cartsien coordinatec - real(dp),public, save :: Ruc_mag(3) ! three primitive vectors in Cartsien coordinatec - - !> reciprocal lattice for magnetic supercell - real(dp),public, save :: Kua_mag(3) ! three reciprocal primitive vectors - real(dp),public, save :: Kub_mag(3) ! three reciprocal primitive vectors - real(dp),public, save :: Kuc_mag(3) ! three reciprocal primitive vectors - - real(dp),public, save :: Urot(3, 3) ! Rotate matrix for the new primitve cell - - ! k list for 3D case band - integer :: nk3lines ! Howmany k lines for bulk band calculation - integer :: nk3_band ! Howmany k points for each k line - character(4), allocatable :: k3line_name(:) ! Name of the K points - real(dp),allocatable :: k3line_stop(:) ! Connet points - real(dp),allocatable :: k3line_start(:, :) ! Start point for each k line - real(dp),allocatable :: k3line_end(:, :) ! End point for each k line - real(dp),allocatable :: K3list_band(:, :) ! coordinate of k points for bulk band calculation in kpath mode - real(dp),allocatable :: K3len(:) ! put all k points in a line in order to plot the bands - real(dp),allocatable :: K3points(:, :) ! coordinate of k points for bulk band calculation in cube mode - - !> k points in the point mode - integer :: Nk3_point_mode - real(dp), allocatable :: k3points_pointmode_cart(:, :) - real(dp), allocatable :: k3points_pointmode_direct(:, :) - - !> k points in unfolded BZ in the point mode - !> sometimes is used for projection - integer :: Nk3_unfold_point_mode - real(dp), allocatable :: k3points_unfold_pointmode_cart(:, :) - real(dp), allocatable :: k3points_unfold_pointmode_direct(:, :) - - !> kpath for unfold supercell - real(dp),allocatable :: K3len_unfold(:) ! put all k points in a line in order to plot the bands - real(dp),allocatable :: k3line_unfold_stop(:) ! Connet points - - - - !> kpath for magnetic supercell - real(dp),allocatable :: K3len_mag(:) ! put all k points in a line in order to plot the bands - real(dp),allocatable :: k3line_mag_stop(:) ! Connet points - - ! k path for berry phase, read from the input.dat - ! in the KPATH_BERRY card - integer :: NK_Berry - character(10) :: DirectOrCart_Berry ! Whether direct coordinates or Cartisen coordinates - real(dp), allocatable :: k3points_Berry(:, :) ! only in direct coordinates - - !>> top surface atoms - integer :: NtopAtoms, NtopOrbitals ! Select atoms on the top surface for surface state output - integer, allocatable :: TopAtoms(:) ! Select atoms on the top surface for surface state output - integer, allocatable :: TopOrbitals(:) ! Orbitals on the top surface for surface state output - - !>> bottom surface atoms - integer :: NBottomAtoms, NBottomOrbitals ! Select atoms on the bottom surface for surface state output - integer, allocatable :: BottomAtoms(:) ! Select atoms on the bottom surface for surface state output - integer, allocatable :: BottomOrbitals(:) ! Orbitals on the bottom surface for surface state output - - !>> effective mass - real(dp), public, save :: dk_mass ! k step for effective mass calculation - integer , public, save :: iband_mass ! the i'th band for effective mass calculation - real(dp), public, save :: k_mass(3) ! the k point for effective mass calculation - - !> klist for 2D case include all 2D system - integer :: nk2lines ! Number of k lines for 2D slab band calculation - integer :: knv2 ! Number of k points for each k line - real(dp) :: kp(2, 32) ! start k point for each k line - real(dp) :: ke(2, 32) ! end k point for each k line - real(dp) :: k2line_stop(32) - character(4) :: k2line_name(32) - real(dp),allocatable :: k2len(:) - real(dp),allocatable :: k2_path(:, :) - - !> A kpoint for 3D system--> only one k point - real(dp), public, save :: Kpoint_3D_direct(3) ! the k point for effective mass calculation - real(dp), public, save :: Kpoint_3D_cart(3) ! the k point for effective mass calculation - - character(10) :: DirectOrCart_SINGLE ! Whether direct coordinates or Cartisen coordinates - real(dp), public, save :: Single_KPOINT_3D_DIRECT(3) ! the k point for effective mass calculation - real(dp), public, save :: Single_KPOINT_3D_CART(3) ! the k point for effective mass calculation - real(dp), public, save :: Single_KPOINT_2D_DIRECT(2) ! a single k point in the 2D slab BZ - real(dp), public, save :: Single_KPOINT_2D_CART(2) - - !> kpoints plane for 2D system--> arcs - real(dp) :: K2D_start(2) ! start k point for 2D system calculation, like arcs - real(dp) :: K2D_vec1(2) ! the 1st k vector for the k plane - real(dp) :: K2D_vec2(2) ! the 2nd k vector for the k plane - - !> kpoints plane for 3D system --> gapshape - real(dp) :: K3D_start(3) ! the start k point for the 3D k plane - real(dp) :: K3D_vec1(3) ! the 1st k vector for the 3D k plane - real(dp) :: K3D_vec2(3) ! the 2nd k vector for the 3D k plane - real(dp) :: K3D_vec3(3) - - !> kpoints plane for 3D system --> gapshape3D - real(dp) :: K3D_start_cube(3) ! the start k point for the k cube - real(dp) :: K3D_vec1_cube(3) ! the 1st k vector for the k cube - real(dp) :: K3D_vec2_cube(3) ! the 2nd k vector for the k cube - real(dp) :: K3D_vec3_cube(3) ! the 3rd k vector for the k cube - - integer, allocatable :: irvec(:,:) ! R coordinates in fractional units - integer, allocatable :: irvec_valley(:,:) ! R coordinates in fractional units - real(dp), allocatable :: crvec(:,:) ! R coordinates in Cartesian coordinates in units of Angstrom - complex(dp), allocatable :: HmnR(:,:,:) ! Hamiltonian m,n are band indexes - complex(dp), allocatable :: valley_operator_R(:,:,:) ! Hamiltonian m,n are band indexes - - - !sparse HmnR arraies - integer,allocatable :: hicoo(:), hjcoo(:), hirv(:, :) - complex(dp),allocatable :: hacoo(:) - - !> overlap matrix in sparse format - integer,allocatable :: sicoo(:), sjcoo(:), sirv(:, :) - complex(dp),allocatable :: sacoo(:) - - !> valley operator - integer,allocatable :: valley_operator_icoo(:), valley_operator_jcoo(:), valley_operator_irv(:) - complex(dp),allocatable :: valley_operator_acoo(:) - - !> sparse hr length - integer :: splen, splen_input, splen_valley_input, splen_overlap_input - - - integer, allocatable :: ndegen(:) ! degree of degeneracy of R point - - complex(dp), allocatable :: HmnR_newcell(:,:,:) ! Hamiltonian m,n are band indexes - real(dp), allocatable :: Atom_position_cart_newcell(:,:) ! Hamiltonian m,n are band indexes - real(dp), allocatable :: Atom_position_direct_newcell(:,:) ! Hamiltonian m,n are band indexes - integer, allocatable :: irvec_newcell(:,:) ! R coordinates - integer, allocatable :: ndegen_newcell(:) ! degree of degeneracy of R point - real(dp),public, save :: Rua_newcell(3) !> three rotated primitive vectors in old coordinate system - real(dp),public, save :: Rub_newcell(3) !> three rotated primitive vectors in old coordinate system - real(dp),public, save :: Ruc_newcell(3) !> three rotated primitive vectors in old coordinate system - real(dp),public, save :: Kua_newcell(3) ! three reciprocal primitive vectors, a - real(dp),public, save :: Kub_newcell(3) ! three reciprocal primitive vectors, b - real(dp),public, save :: Kuc_newcell(3) ! three reciprocal primitive vectors, c - - complex(dp),parameter :: zi=(0.0d0, 1.0d0) ! complex constant 0+1*i - complex(dp),parameter :: pi2zi=(0.0d0, 6.283185307179586d0) ! 2*pi*zi - - !> define surface - real(dp), public, save :: Umatrix(3, 3) ! a matrix change old primitive cell to new primitive cell which can define new surface, it is a 3*3 matrix - integer, public, save :: MillerIndices(3) ! a matrix change old primitive cell to new primitive cell which can define new surface, it is a 3*3 matrix - - character(10) :: AngOrBohr ! Angstrom unit to Bohr unit - character(10) :: DirectOrCart ! Whether direct coordinates or Cartisen coordinates - real(dp) :: MagneticSuperCellVolume ! Cell volume - real(dp) :: MagneticSuperProjectedArea !Projected area respect to the first vector specifed in SURFACE card in Angstrom^2 - real(dp) :: kCubeVolume - real(dp) :: MagneticReciprocalCellVolume - - !> the start index for each atoms, only consider the spinless component - integer, allocatable :: orbitals_start(:) - - !> symmetry operator apply on function basis - complex(dp), allocatable :: inversion(:, :) - complex(dp), allocatable :: mirror_x(:, :) - complex(dp), allocatable :: mirror_y(:, :) - complex(dp), allocatable :: mirror_z(:, :) - complex(dp), allocatable :: C2yT(:, :) - complex(dp), allocatable :: glide(:, :) - - !> a sparse format to store C3z operator, test only for pz orbital or s orbital - complex(dp), allocatable :: C3z_acoo(:) - integer, allocatable :: C3z_icoo(:) - integer, allocatable :: C3z_jcoo(:) - - !> symmetry operator apply on coordinate system - real(dp), allocatable :: inv_op(:, :) - real(dp), allocatable :: mirror_z_op(:, :) - real(dp), allocatable :: mirror_x_op(:, :) - real(dp), allocatable :: mirror_y_op(:, :) - real(dp), allocatable :: glide_y_op(:, :) - character(10) :: point_group_operator_name(48) - - !> weyl point information from the input.dat - integer :: Num_Weyls - character(10) :: DirectOrCart_Weyl ! Whether direct coordinates or Cartisen coordinates - real(dp) :: kr0 - real(dp), allocatable :: weyl_position_cart(:, :) - real(dp), allocatable :: weyl_position_direct(:, :) - - !> nodal loop information from the input.dat - integer :: Num_NLs - character(10) :: DirectOrCart_NL ! Whether direct coordinates or Cartisen coordinates - real(dp) :: Rbig_NL - real(dp) :: rsmall_a_NL, rsmall_b_NL - real(dp), allocatable :: NL_center_position_cart(:, :) - real(dp), allocatable :: NL_center_position_direct(:, :) - - - !> parameters for tbtokp - integer :: Num_selectedbands_tbtokp - integer, allocatable :: Selected_bands_tbtokp(:) - real(dp) :: k_tbtokp(3) ! The K point that used to construct kp model - - - !> for phonon LO-TO correction. By T.T Zhang - real(dp), public, save :: Diele_Tensor(3, 3) ! di-electric tensor - real(dp), allocatable :: Born_Charge(:, :, :) - real(dp), allocatable :: Atom_Mass(:) - - real(dp), parameter :: VASPToTHZ= 29.54263748d0 ! By T.T zhang - - type kcube_type - !> define a module for k points in BZ in purpose of MPI - - integer :: Nk_total - integer :: Nk_current - integer :: Nk_start - integer :: Nk_end - integer, allocatable :: ik_array(:) - integer, allocatable :: IKleft_array(:) - - real(dp), allocatable :: Ek_local(:) - real(dp), allocatable :: Ek_total(:) - real(dp), allocatable :: k_direct(:, :) - real(dp), allocatable :: weight_k(:) - - !> velocities - real(dp), allocatable :: vx_local(:) - real(dp), allocatable :: vx_total(:) - real(dp), allocatable :: vy_local(:) - real(dp), allocatable :: vy_total(:) - real(dp), allocatable :: vz_local(:) - real(dp), allocatable :: vz_total(:) - real(dp), allocatable :: weight_k_local(:) - end type kcube_type - - type(kcube_type) :: KCube3D - - !> gather the reduced k points and the original k points - type kcube_type_symm - !> Nk1*Nk2*Nk3 - integer :: Nk_total - !> total number of reduced k points - integer :: Nk_total_symm - !> relate the full kmesh to the reduced k point - integer, allocatable :: ik_relate(:) - !> reduced k points - integer, allocatable :: ik_array_symm(:) - real(dp), allocatable :: weight_k(:) - end type kcube_type_symm - - type(kcube_type_symm) :: KCube3D_symm - - !> Select those atoms which used in the construction of the Wannier functions - !> It can be useful when calculate the projected weight related properties - !> such as the surface state, slab energy bands. - integer :: NumberofSelectedAtoms_groups - type(int_array1D), allocatable :: Selected_Atoms(:) - integer, allocatable :: NumberofSelectedAtoms(:) - - !> selected wannier orbitals - !> this part can be read from the input.dat or wt.in file - !> if not specified in the input.dat or wt.in, we will try to specify it from the - !> SelectedAtoms part. - integer :: NumberofSelectedOrbitals_groups - integer, allocatable :: NumberofSelectedOrbitals(:) - type(int_array1D), allocatable :: Selected_WannierOrbitals(:) - - !> selected bands for magnetoresistance - integer :: NumberofSelectedBands - integer, allocatable :: Selected_band_index(:) - - !> selected occupied bands for wannier charge center(Wilson loop) calculation - !> the bands should be continous - integer :: NumberofSelectedOccupiedBands - integer, allocatable :: Selected_Occupiedband_index(:) - - !> index for non-spin polarization - integer, allocatable :: index_start(:) - integer, allocatable :: index_end(:) - - !> time - character(8) :: date_now - character(10) :: time_now - character(5) :: zone_now - - !> total number of symmetry operators in the system - integer :: number_group_generators - integer :: number_group_operators - - !> point group generator operation defined by the BasicOperations_space - integer , allocatable :: generators_find(:) - - !> translation operator generators in fractional/direct coordinate - real(dp), allocatable :: tau_find(:,:) - - !> point group operators in cartesian and direct coordinate - real(dp), allocatable :: pggen_cart(:, :, :) - real(dp), allocatable :: pggen_direct(:, :, :) - - !> space group operators in cartesian and direct coordinate - real(dp), allocatable :: pgop_cart(:, :, :) - real(dp), allocatable :: pgop_direct(:, :, :) - real(dp), allocatable :: tau_cart(:,:) - real(dp), allocatable :: tau_direct(:,:) - real(dp), allocatable :: spatial_inversion(:) - - !> build a map between atoms under the symmetry operation - !> dimension number_group_operators, Num_atoms - integer, allocatable :: imap_sym(:, :) - - real(dp) :: time_cost_t1=0d0 - real(dp) :: time_cost_t2=0d0 - real(dp) :: time_cost_t3=0d0 - - end module para - - - module wcc_module - ! module for Wannier charge center (Wilson loop) calculations. - use para - implicit none - - - type kline_wcc_type - ! define a type of all properties at the k point to get the wcc - real(dp) :: k(3) ! coordinate - real(dp) :: delta ! apart from the start point - real(dp), allocatable :: wcc(:) ! 1:Numoccupied, wannier charge center - real(dp), allocatable :: gap(:) ! 1:Numoccupied, the distance between wcc neighbours - real(dp) :: largestgap_pos_i ! largest gap position - real(dp) :: largestgap_pos_val ! largest gap position value - real(dp) :: largestgap_val ! largest gap value - logical :: converged ! converged or not - logical :: calculated - end type kline_wcc_type - - type kline_integrate_type - ! define a type of all properties at the k point for integration - real(dp) :: k(3) ! coordinate - real(dp) :: delta ! apart from the start point - real(dp) :: b(3) ! dis - logical :: calculated - ! We only store the eigenvectors of the occupied states - complex(dp), allocatable :: eig_vec(:, :) !dim= (num_wann, NumOccupied) - end type kline_integrate_type - - end module wcc_module - diff --git a/readinput.f90 b/readinput.f90 deleted file mode 100644 index 9f29fc5a..00000000 --- a/readinput.f90 +++ /dev/null @@ -1,5029 +0,0 @@ -subroutine readinput - ! Read in the control paramters from wt.in, - ! and set default values if not specified in the wt.in - ! - ! Constructed on 4/22/2010 by QS.Wu - - use wmpi - use para - implicit none - - character*12 :: fname='wt.in' - character*25 :: char_temp - character*256 :: inline - logical :: exists, lfound - real(dp) :: cell_volume, cell_volume2 - - integer :: i, j, ia, ik, iq, io, it, idummy, ig, NN, stat, istart, iend - integer :: NumberOfspinorbitals, NumberOfspinorbitals_unfold - - integer, allocatable :: iarray_temp(:) - - real(dp) :: t1, temp - real(dp) :: pos(3), k1(3), k2(3), k(3), kstart(3), kend(3) - real(dp) :: R1(3), R2(3), R3(3), Rt(3), Rt2(3) - real(dp), external :: norm, angle - - real(dp), allocatable :: mass_temp(:) - real(dp), allocatable :: Born_Charge_temp(:, :, :) - - inquire(file=fname,exist=exists) - if (exists)then - if(cpuid==0)write(stdout,*) ' ' - if(cpuid==0)write(stdout,*) '>>>Read some paramters from wt.in' - open(unit=1001,file=fname,status='old') - else - if(cpuid==0)write(stdout,*)'file' ,fname, 'dosnot exist' - stop - endif - -!===============================================================================================================! -! TB_FILE namelist -!===============================================================================================================! - - Particle='electron' - Package= 'VASP' - KPorTB = 'TB' - Is_HrFile= .TRUE. - Is_Sparse_Hr= .FALSE. - Is_Sparse = .FALSE. - Orthogonal_Basis = .TRUE. - read(1001, TB_FILE, iostat= stat) - if (stat/=0) then - Hrfile='wannier90_hr.dat' - Particle='electron' - inquire(file='wannier90_hr.dat',exist=exists) - - backspace(1001) - read(1001,fmt='(A)') inline - write(*,'(A)') & - '>>> ERROR : Invalid line in namelist TB_FILE : '//trim(inline) - - if (.not.exists) stop "ERROR>> TB_FIlE namelist should be given or wannier90_hr.dat should exist" - - endif - if(cpuid==0)write(stdout,'(1x, a, a6, a)')"You are using : ", KPorTB, " model" - Is_Sparse_Hr= (Is_Sparse_Hr.or.Is_Sparse) - if(cpuid==0) then - if(Is_HrFile) then - write(stdout,'(1x, a)')"Tight-binding Hamiltonian FROM: Hr File" - write(stdout,'(1x, a, L2)')"Is_Sparse_Hr= ", Is_Sparse_Hr - if(Is_Sparse_Hr) write(stdout,'(1x, a)')"Tight-binding Hamiltonian FROM: Sparse Hr File" - else - write(stdout,'(1x, a)')"Tight-binding Hamiltonian FROM: fitting" - end if - end if - if(cpuid==0)write(stdout,'(1x, a, a25)')"Tight-binding Hamiltonian filename : ",Hrfile - if(cpuid==0)write(stdout,'(1x, a, a25)')"System of particle: ", Particle - if(cpuid==0)write(stdout,'(1x, a, a25)')"Tight-binding Hamiltonian obtained from package : ",Package - - if (index(Particle, 'electron')==0 .and. index(Particle, 'phonon')==0 & - .and. index(Particle, 'photon')==0) then - write(stdout, *)' ERROR: Particle shoule equal either "electron"' , & - '"phonon", or "photon"' - stop - endif - -!===============================================================================================================! -!> CONTROL namelist -!===============================================================================================================! - - BulkBand_calc = .FALSE. - BulkBand_line_calc = .FALSE. - BulkBand_unfold_line_calc = .FALSE. - Landaulevel_unfold_line_calc = .FALSE. - BulkBand_unfold_plane_calc = .FALSE. - QPI_unfold_plane_calc = .FALSE. - BulkFatBand_calc = .FALSE. - BulkBand_plane_calc = .FALSE. - BulkBand_cube_calc = .FALSE. - BulkFS_calc = .FALSE. - BulkFS_Plane_calc = .FALSE. - BulkFS_plane_stack_calc = .FALSE. - BulkGap_cube_calc = .FALSE. - BulkGap_plane_calc = .FALSE. - SlabBand_calc = .FALSE. - SlabBandWaveFunc_calc = .FALSE. - WireBand_calc = .FALSE. - SlabSS_calc = .FALSE. - SlabArc_calc = .FALSE. - SlabQPI_calc = .FALSE. - SlabQPI_kpath_calc = .FALSE. - SlabQPI_kplane_calc = .FALSE. - SlabSpintexture_calc = .FALSE. - BulkSpintexture_calc = .FALSE. - wanniercenter_calc = .FALSE. - Z2_3D_calc = .FALSE. - Chern_3D_calc = .FALSE. - WeylChirality_calc = .FALSE. - NLChirality_calc = .FALSE. - BerryPhase_calc = .FALSE. - BerryCurvature_calc = .FALSE. - BerryCurvature_EF_calc = .FALSE. - BerryCurvature_plane_selectedbands_calc = .FALSE. - BerryCurvature_Cube_calc = .FALSE. - BerryCurvature_slab_calc = .FALSE. - Berrycurvature_kpath_EF_calc = .FALSE. - BerryCurvature_kpath_Occupied_calc = .FALSE. - MirrorChern_calc = .FALSE. - Dos_calc = .FALSE. - JDos_calc = .FALSE. - EffectiveMass_calc = .FALSE. - FindNodes_calc = .FALSE. - LOTO_correction = .FALSE. - Boltz_OHE_calc = .FALSE. - Boltz_Berry_correction= .FALSE. - AHC_calc = .FALSE. - SHC_calc = .FALSE. - Hof_Butt_calc = .FALSE. - LandauLevel_k_calc = .FALSE. - LandauLevel_B_calc = .FALSE. - LandauLevel_wavefunction_calc = .FALSE. - OrbitalTexture_calc = .FALSE. - OrbitalTexture_3D_calc = .FALSE. - Fit_kp_calc = .FALSE. - DMFT_MAG_calc = .FALSE. ! not finished yet - Symmetry_Import_calc = .FALSE. - LanczosSeqDOS_calc = .FALSE. - LandauLevel_kplane_calc = .FALSE. - LandauLevel_k_dos_calc = .FALSE. - LandauLevel_B_dos_calc = .FALSE. - Translate_to_WS_calc = .FALSE. - FermiLevel_calc = .FALSE. - ANE_calc = .FALSE. - w3d_nested_calc =.false. - valley_projection_calc =.false. - ChargeDensity_selected_bands_calc= .FALSE. - ChargeDensity_selected_energies_calc= .FALSE. - - SlabBdG_calc = .FALSE. - BdGChern_calc = .FALSE. - - read(1001, CONTROL, iostat=stat) - SlabQPI_kplane_calc= SlabQPI_kplane_calc.or.SlabQPI_calc - - if (stat/=0) then - write(*, *)"ERROR: namelist CONTROL should be set" - write(*, *)"You should set one of these functions to be T." - write(*, *)"And please make sure that the spelling are correct." - write(*, *)"BulkBand_calc, BulkBand_plane_calc, BulkFS_calc" - write(*, *)"BulkBand_line_calc, BulkBand_cube_calc" - write(*, *)"Landaulevel_unfold_line_calc, " - write(*, *)"BulkBand_unfold_line_calc, " - write(*, *)"BulkBand_unfold_plane_calc, " - write(*, *)"QPI_unfold_plane_calc, " - write(*, *)"BulkFatBand_calc, " - write(*, *)"BulkGap_cube_calc,BulkGap_plane_calc" - write(*, *)"SlabBand_calc,SlabBdG_calc,SlabBandWaveFunc_calc" - write(*, *)"WireBand_calc,SlabSS_calc,SlabArc_calc " - write(*, *)"SlabQPI_calc" - write(*, *)"SlabQPI_kpath_calc" - write(*, *)"SlabQPI_kplane_calc" - write(*, *)"SlabSpintexture,wanniercenter_calc" - write(*, *)"BerryPhase_calc,BerryCurvature_calc, BerryCurvature_EF_calc" - write(*, *)"Berrycurvature_kpath_EF_calc, BerryCurvature_kpath_Occupied_calc" - write(*, *)"BerryCurvature_slab_calc, BerryCurvature_Cube_calc" - write(*, *)"Dos_calc, JDos_calc, FindNodes_calc" - write(*, *)"BulkFS_plane_calc" - write(*, *)"BulkFS_plane_stack_calc" - write(*, *)"Z2_3D_calc" - write(*, *)"Chern_3D_calc" - write(*, *)"MirrorChern_calc" - write(*, *)"BdGChern_calc" - write(*, *)"WeylChirality_calc" - write(*, *)"NLChirality_calc" - write(*, *)"LOTO_correction" - write(*, *)"AHC_calc" - write(*, *)"SHC_calc" - write(*, *)"Hof_Butt_calc" - write(*, *)"Boltz_OHE_calc" - write(*, *)"Boltz_Berry_correction" - write(*, *)"DMFT_MAG_calc" - write(*, *)"Fit_kp_calc" - write(*, *)"OrbitalTexture_calc" - write(*, *)"OrbitalTexture_3D_calc" - write(*, *)"LandauLevel_wavefunction_calc" - write(*, *)"LandauLevel_k_calc" - write(*, *)"LandauLevel_kplane_calc" - write(*, *)"LandauLevel_B_calc" - write(*, *)"Hof_Butt_calc" - write(*, *)"LandauLevel_k_dos_calc" - write(*, *)"LandauLevel_B_dos_calc" - write(*, *)"Translate_to_WS_calc" - write(*, *)"FermiLevel_calc" - write(*, *)"ANE_calc" - write(*, *)"valley_projection_calc" - write(*, *)"ChargeDensity_selected_energies_calc" - write(*, *)"ChargeDensity_selected_bands_calc" - write(*, *)"The default Vaule is F" - - backspace(1001) - read(1001,fmt='(A)') inline - write(*,'(A)') & - '>>> ERROR : Invalid line in namelist CONTROL : '//trim(inline) - - - stop - endif - - !> In order to be compatiable with the old version, we keep the bulkband_calc. - BulkBand_line_calc= BulkBand_line_calc.or.BulkBand_calc - BulkBand_unfold_line_calc= BulkBand_unfold_line_calc.or.Landaulevel_unfold_line_calc - - if (MirrorChern_calc) Symmetry_Import_calc = .true. - - !> control parameters - if (cpuid==0) then - write(stdout, *) " " - write(stdout, *) ">>>Control parameters: " - write(stdout, *) "BulkBand_line_calc : ", BulkBand_line_calc - write(stdout, *) "BulkBand_plane_calc : ", BulkBand_plane_calc - write(stdout, *) "Landaulevel_unfold_line_calc : ", Landaulevel_unfold_line_calc - write(stdout, *) "BulkBand_unfold_line_calc : ", BulkBand_unfold_line_calc - write(stdout, *) "BulkBand_unfold_plane_calc : ", BulkBand_unfold_plane_calc - write(stdout, *) "QPI_unfold_plane_calc : ", QPI_unfold_plane_calc - write(stdout, *) "BulkFatBand_calc : ", BulkFatBand_calc - write(stdout, *) "BulkBand_cube_calc : ", BulkBand_cube_calc - write(stdout, *) "BulkFS_calc : ", BulkFS_calc - write(stdout, *) "BulkFS_Plane_calc : ", BulkFS_Plane_calc - write(stdout, *) "BulkFS_plane_stack_calc : ", BulkFS_plane_stack_calc - write(stdout, *) "BulkGap_cube_calc : ", BulkGap_cube_calc - write(stdout, *) "BulkGap_plane_calc : ", BulkGap_plane_calc - write(stdout, *) "SlabBand_calc : ", SlabBand_calc - write(stdout, *) "SlabBandWaveFunc_calc : ", SlabBandWaveFunc_calc - write(stdout, *) "SlabSS_calc : ", SlabSS_calc - write(stdout, *) "SlabArc_calc : ", SlabArc_calc - write(stdout, *) "SlabSpintexture_calc : ", SlabSpintexture_calc - write(stdout, *) "wanniercenter_calc : ", wanniercenter_calc - write(stdout, *) "BerryPhase_calc : ", BerryPhase_calc - write(stdout, *) "BerryCurvature_calc : ", BerryCurvature_calc - write(stdout, *) "BerryCurvature_EF_calc : ", BerryCurvature_EF_calc - write(stdout, *) "BerryCurvature_kpath_EF_calc : ", BerryCurvature_kpath_EF_calc - write(stdout, *) "BerryCurvature_kpath_Occupied_calc: ", BerryCurvature_kpath_Occupied_calc - write(stdout, *) "BerryCurvature_Cube_calc : ", BerryCurvature_Cube_calc - write(stdout, *) "BerryCurvature_slab_calc : ", BerryCurvature_slab_calc - write(stdout, *) "Dos_calc : ", DOS_calc - write(stdout, *) "Z2_3D_calc : ", Z2_3D_calc - write(stdout, *) "WeylChirality_calc : ", WeylChirality_calc - write(stdout, *) "NLChirality_calc : ", NLChirality_calc - write(stdout, *) "Chern_3D_calc : ", Chern_3D_calc - write(stdout, *) "MirrorChern_calc : ", MirrorChern_calc - write(stdout, *) "JDos_calc : ", JDOS_calc - write(stdout, *) "FindNodes_calc : ", FindNodes_calc - write(stdout, *) "EffectiveMass_calc : ", EffectiveMass_calc - write(stdout, *) "AHC_calc : ", AHC_calc - write(stdout, *) "SHC_calc : ", SHC_calc - write(stdout, *) "Boltz_OHE_calc : ", Boltz_OHE_calc - write(stdout, *) "Boltz_Berry_correction : ", Boltz_Berry_correction - write(stdout, *) "LOTO_correction : ", LOTO_correction - write(stdout, *) "OrbitalTexture_calc : ", OrbitalTexture_calc - write(stdout, *) "OrbitalTexture_3D_calc : ", OrbitalTexture_3D_calc - write(stdout, *) "LandauLevel_k_calc : ", LandauLevel_k_calc - write(stdout, *) "LandauLevel_B_calc : ", LandauLevel_B_calc - write(stdout, *) "LandauLevel_wavefunction_calc : ", LandauLevel_wavefunction_calc - write(stdout, *) "Fit_kp_calc : ", Fit_kp_calc - write(stdout, *) "DMFT_MAG_calc : ", DMFT_MAG_calc - write(stdout, *) "Translate_to_WS_calc : ", Translate_to_WS_calc - write(stdout, *) "LandauLevel_kplane_calc : ", LandauLevel_kplane_calc - write(stdout, *) "LandauLevel_k_dos_calc : ", LandauLevel_k_dos_calc - write(stdout, *) "LandauLevel_B_dos_calc : ", LandauLevel_B_dos_calc - write(stdout, *) "FermiLevel_calc : ", FermiLevel_calc - write(stdout, *) "ANE_calc : ", ANE_calc - write(stdout, *) "Symmetry_Import_calc : ", Symmetry_Import_calc - write(stdout, *) "ChargeDensity_selected_bands_calc : ", ChargeDensity_selected_bands_calc - write(stdout, *) "ChargeDensity_selected_energies_calc : ", ChargeDensity_selected_energies_calc - write(stdout, *) "valley_projection_calc : " , valley_projection_calc - write(stdout, *) "SlabBdG_calc : ", SlabBdG_calc - write(stdout, *) "BdGChern_calc : ", BdGChern_calc - endif - -!===============================================================================================================! -!> SYSTEM namelist -!===============================================================================================================! - - !> set system parameters by default - Nslab= 10 - Nslab1= 1 - Nslab2= 1 - Numoccupied = 0 - Ntotch = 0 - SOC = 0 - SOC_in = 0 - E_FERMI = 0d0 - - !> By default magnetic field is zero - Bx = 0d0 - By = 0d0 - Bz = 0d0 - - !>Zeeman field on surface for slab hamiltonian - Add_surf_zeeman_field= 1 - Bx_surf= 0d0 - By_surf= 0d0 - Bz_surf= 0d0 - - !>Chemical potential mu for BdG - mu_BdG = 0d0 - - !>s-Wave Superconducting gap - Add_Delta_BdG = 3 - Delta_BdG = 0d0 - - Bmagnitude = 0d0 - Btheta = -99999d0 - Bphi = -99999d0 - surf_onsite = 0d0 - - !> By default, we don't add zeeman field - Add_Zeeman_Field = .FALSE. - - !> by default, g-factor is 2 - Effective_gfactor = 2d0 - Zeeman_energy_in_eV = 0d0 - - !> by default, Electric_field_in_eVpA=0 - Electric_field_in_eVpA= 0d0 - Symmetrical_Electric_field_in_eVpA= 0d0 - Inner_symmetrical_Electric_Field= .False. - !> by default we don't set the center atom - center_atom_for_electric_field = -1 - - !> by default, Vacuum_thickness_in_Angstrom= 20 Angstrom - Vacuum_thickness_in_Angstrom = 20d0 - - !> read system parameters from file - read(1001, SYSTEM, iostat=stat) - if (stat/=0) then - write(*, *)"ERROR: namelist SYSTEM is wrong and should be set correctly" - - backspace(1001) - read(1001,fmt='(A)') inline - write(*,'(A)') & - '>>> ERROR : Invalid line in namelist SYSTEM : '//trim(inline) - - stop - endif - SOC_in=SOC - - if (SOC == -1) then - write(*, *)"ERROR: you should set SOC in namelist SYSTEM correctly" - stop - endif - - if (Numoccupied == 0) then - if (Z2_3D_calc.or.Chern_3D_calc.or.BulkFS_calc & - .or.BulkGap_plane_calc.or.WannierCenter_calc.or.& - BerryPhase_calc.or.BerryCurvature_EF_calc.or.BerryCurvature_calc.or.& - BerryCurvature_plane_selectedbands_calc.or.BerryCurvature_slab_calc.or.& - MirrorChern_calc.or.WeylChirality_calc.or.NLChirality_calc.or.& - FindNodes_calc) then - write(*, *)"ERROR: you should set Numoccupied in namelist SYSTEM correctly" - stop - else - Numoccupied = 1 - endif - endif - - - if (abs(Ntotch) 0) then - Ntotch = Numoccupied - else - Ntotch = Numoccupied*2 - endif - endif - - if (.not.Add_Zeeman_Field) then - Zeeman_energy_in_eV = 0d0 - Effective_gfactor = 0d0 - endif - - if (cpuid==0) then - write(stdout, *) " " - write(stdout, *) ">>>System parameters: " - write(stdout, '(1x, a, i6 )')"NumSlabs :", Nslab - write(stdout, '(1x, a, i6)')"Nslab1 for ribbon :", Nslab1 - write(stdout, '(1x, a, i6)')"Nslab2 for ribbon :", Nslab2 - write(stdout, '(1x, a, i6)')"Number of Occupied bands:", NumOccupied - write(stdout, '(1x, a, f12.6)')"Number of total electrons:", Ntotch - write(stdout, '(1x, a, i6)')"With SOC or not in Hrfile:", SOC - write(stdout, '(1x, a, 3f16.6)')"Fermi energy (eV) :", E_FERMI - write(stdout, '(1x, a, 3f16.6)')"surf_onsite (eV): ", surf_onsite - write(stdout, '(1x, a, L)')"Add_Zeeman_Field: ", Add_Zeeman_Field - write(stdout, '(1x, a, i6)')"Add_surf_zeeman_field for slab system: ",Add_surf_zeeman_field - write(stdout, '(1x, a, 3f16.6)')"Zeeman_energy_in_eV (eV): ", Zeeman_energy_in_eV - write(stdout, '(1x, a, 3f16.6)')"Electric_field_in_eVpA (eV/Angstrom): ", Electric_field_in_eVpA - write(stdout, '(1x, a, 3f16.6)')"Symmetrical_Electric_field_in_eVpA (eV/Angstrom): ", Symmetrical_Electric_field_in_eVpA - write(stdout, '(1x, a, L)')"Inner_symmetrical_Electric_Field: ", Inner_symmetrical_Electric_Field - write(stdout, '(1x, a, i6 )')"ijmax :", ijmax - endif - - if (cpuid==0) then - write(stdout, *) " " - write(stdout, "(1x,a)") "**Notes**: There are two ways to specify magnetic field." - write(stdout, "(1x,a)") "1. specify Bmagnitude, Btheta, Bphi" - write(stdout, "(1x,a)") "2. specify Bx, By, Bz" - write(stdout, "(1x,a)") "Bmagnitude, Bx, By, Bz are real numbers in unit of Tesla. and Bx, By, Bz " - write(stdout, "(1x,a)") "are in the cartesian coordinates. Btheta is the angle with z axial " - write(stdout, "(1x,a)") " and Bphi is the angle with respect to x axial in the x-y plane" - write(stdout, "(1x,a)") " Btheta is in [0, 180], Bphi is in [0, 360)." - write(stdout, "(1x,a)") "If you specify both of them together, we will choose the first one." - write(stdout, "(1x,a)") "If choose the first one, but not specify Btheta, Bphi, then " - write(stdout, "(1x,a)") "by default we set Btheta=0, Bphi=0 which means B is along z direction." - write(stdout, '(1x, a, 3f16.6)')"Bx_surf, By_surf, Bz_surf :", Bx_surf,By_surf, Bz_surf - write(stdout, '(1x, a, 3f16.6)')"Chemical potential mu for BdG (eV):", mu_BdG - write(stdout, '(1x, a, i6)')"Add_Delta_BdG for slab system: ", Add_Delta_BdG - write(stdout, '(1x, a, 3f16.6)')"s-wave superconducting pairing Delta (eV): ", Delta_BdG - endif - - !> check if Bmagnitude is specified in the input.dat/wt.in - if (abs(Bmagnitude)>eps6 .and. (abs(Bx)+abs(By)+abs(Bz))>eps6) then - if (cpuid==0) then - write(stdout, *) " " - write(stdout, *) " Warning: You specify Bmagnitude and Bx, By, Bz at the same time " - write(stdout, *) " in the SYSTEM namelist in the wt.in/input.dat." - write(stdout, *) " However, we will only take Bmagnitude and Btheta, Bphi but discard Bx,By,Bz. " - write(stdout, *) " Bx,By,Bz will be calculated as Bx=Bmagnitude*sin(Btheta*pi/180)*cos(bphi/180*pi). " - write(stdout, *) " By=Bmagnitude*sin(Btheta*pi/180)*sin(bphi/180*pi), " - write(stdout, *) " Bz=cos(btheta/180*pi). " - endif - endif - - if (abs(Bmagnitude)eps6) then - if (abs(Btheta+99999d0)>You specified the magnitude of magnetic field, " - write(stdout, '(1x, a, f16.6)')"So we will take this option but discard the setting of Bx, By, Bz" - write(stdout, '(1x, a, f16.6)')"Bmagnitude (in Tesla) :", Bmagnitude - write(stdout, '(1x, a, 3f16.6)')"Btheta, Bphi :", Btheta, Bphi - write(stdout, '(1x, a, 3f16.6)')"Bx, By, Bz (in Tesla) :", Bx, By, Bz - write(stdout, '(1x, a, 3f16.6)')"B direction cosines :", Bdirection - endif - else - if (abs(Bx)+abs(By)+abs(Bz)>eps6) then - if (cpuid==0)then - write(stdout, '(1x, a, f16.6)')">>You did not specified the magnitude of magnetic field, " - write(stdout, '(1x, a, f16.6)')" but set Bx, By, Bz. So we will set the magnetic direction" - write(stdout, '(1x, a, f16.6)')" from Bx, By, Bz but discard the settings of Btheta, Bphi." - endif - Bmagnitude= sqrt(Bx*Bx+By*By+Bz*Bz) !> in Tesla - Bdirection(1)=Bx/Bmagnitude - Bdirection(2)=By/Bmagnitude - Bdirection(3)=Bz/Bmagnitude - - Btheta= acos(Bdirection(3))*180d0/pi - if (abs(Bx)+abs(By)>You did not specified the magnitude of magnetic field, " - write(stdout, '(1x, a, f16.6)')" and also didn't set Bx, By, Bz. So we will set the magnetic direction" - write(stdout, '(1x, a, f16.6)')" from the settings of Btheta, Bphi." - write(stdout, '(1x, a, f16.6)')" If you even didn't set Btheta, Bphi, we will take the default value, " - write(stdout, '(1x, a, f16.6)')" Btheta=0, Bphi=0 which means B is along z direction" - endif - - if (abs(Btheta+99999d0)>You didn't set Btheta, and we set it to 0." - endif - else - if (cpuid==0)then - write(stdout, '(1x, a, f16.6)')">>You set Btheta, and we will take it." - endif - endif - if (abs(Bphi+99999d0)>You didn't set Bphi, and we set it to 0." - endif - else - if (cpuid==0)then - write(stdout, '(1x, a, f16.6)')">>You set Bphi, and we will take it." - endif - endif - Bdirection(1)=sin(Btheta/180d0*pi)*cos(Bphi/180d0*pi) - Bdirection(2)=sin(Btheta/180d0*pi)*sin(Bphi/180d0*pi) - Bdirection(3)=cos(Btheta/180d0*pi) - Bmagnitude= 1d0 - Bx=Bmagnitude*sin(Btheta/180d0*pi)*cos(Bphi/180d0*pi) - By=Bmagnitude*sin(Btheta/180d0*pi)*sin(Bphi/180d0*pi) - Bz=Bmagnitude*cos(Btheta/180d0*pi) - endif - - if (cpuid==0)then - write(stdout, '(1x, a, f16.6)')"Bmagnitude (in Tesla) :", Bmagnitude - write(stdout, '(1x, a, 3f16.6)')"Btheta, Bphi :", Btheta, Bphi - write(stdout, '(1x, a, 3f16.6)')"Bx, By, Bz (in Tesla) :", Bx, By, Bz - write(stdout, '(1x, a, 3f16.6)')"B direction cosines :", Bdirection - endif - endif - - !> change the unit of magnetic field from Tesla to atomic unit - !> 1 atomic unit = hbar/(e*a0^2) Tesla - !> 1 Tesla= (e*a0^2)/hbar a.u. - Bmagnitude= Bmagnitude*Echarge*bohr_radius**2/hbar - Bx=Bmagnitude*sin(Btheta/180d0*pi)*cos(Bphi/180d0*pi) - By=Bmagnitude*sin(Btheta/180d0*pi)*sin(Bphi/180d0*pi) - Bz=Bmagnitude*cos(Btheta/180d0*pi) - -!===============================================================================================================! -!> PARAMETERS namelist -!===============================================================================================================! - - - !> set up parameters for calculation - E_arc = 0.0d0 - Eta_Arc= 0.001d0 - EF_broadening= 0.05d0 - OmegaNum = 100 - OmegaNum_unfold = 0 - OmegaMin = -1d0 - OmegaMax = 1d0 - Nk1 = 10 - Nk2 = 10 - Nk3 = 1 - NP = 2 - Gap_threshold= 0.01d0 - Tmin = 100. ! in Kelvin - Tmax = 100. ! in Kelvin - NumT= 1 - NBTau = 1 - BTauNum = 1 - Nslice_BTau_Max = 5000 - BTauMax = 0d0 - Rcut = 999999d0 - Magp= 1 - Magq= 0 - Magp_min=0 - Magp_max=0 - wcc_calc_tol= 0.08 - wcc_neighbour_tol= 0.3 - NumLCZVecs=100 - NumRandomConfs=1 - NumSelectedEigenVals=0 - Beta= 100 - Relaxation_Time_Tau= 1d0 ! in ps - topsurface_atom_index= 0 - arpack_solver= 'zndrv1' - RKF45_PERIODIC_LEVEL= 1 - iprint_level = 1 - - - !> by default, we only project on atoms for a given wave function - projection_weight_mode = "NORMAL" - - - read(1001, PARAMETERS, iostat= stat) - if (Magp<1) Magp= 0 - if (Magp_max<1) Magp_max= Magp - if (Magq==0) Magq= Nslab - if (Is_Sparse_Hr) then - if (OmegaNum_unfold==0) OmegaNum_unfold= 4*OmegaNum - else - if (OmegaNum_unfold==0) OmegaNum_unfold= 200 - endif - - if (stat>0) then - - backspace(1001) - read(1001,fmt='(A)') inline - write(*,'(A)') & - '>>> ERROR : Invalid line in namelist PARAMETERS : '//trim(inline) - - endif - - NBTau= max(NBTau, BTauNum) - - projection_weight_mode= upper(projection_weight_mode) - if (cpuid==0) then - write(stdout, *) " " - write(stdout, *) ">>>calculation parameters : " - write(stdout, '(1x, a, f16.5)')'E_arc : ', E_arc - write(stdout, '(1x, a, f16.5)')'Eta_arc : ', Eta_arc - write(stdout, '(1x, a, f16.5)')'symprec : ', symprec - write(stdout, '(1x, a, f16.5)')'EF_broadening : ', EF_broadening - write(stdout, '(1x, a, f16.5)')'Gap_threshold', Gap_threshold - write(stdout, '(1x, a, f16.5)')'OmegaMin : ', OmegaMin - write(stdout, '(1x, a, f16.5)')'OmegaMax : ', OmegaMax - write(stdout, '(1x, a, i6 )')'OmegaNum : ', OmegaNum - write(stdout, '(1x, a, i6 )')'OmegaNum_unfold : ', OmegaNum_unfold - write(stdout, '(1x, a, i6 )')'Nk1 : ', Nk1 - write(stdout, '(1x, a, i6 )')'Nk2 : ', Nk2 - write(stdout, '(1x, a, i6 )')'Nk3 : ', Nk3 - write(stdout, '(1x, a, i6 )')'NP number of principle layers : ', Np - write(stdout, '(1x, a, f16.5)')'Tmin(Kelvin) : ', Tmin - write(stdout, '(1x, a, f16.5)')'Tmax(Kelvin) : ', Tmax - write(stdout, '(1x, a, i6 )')'NumT : ', NumT - write(stdout, '(1x, a, i6 )')'NBTau : ', NBTau - write(stdout, '(1x, a, f16.5)')'Beta : ', Beta - write(stdout, '(1x, a, i6 )')'Nslice_BTau_Max : ', Nslice_BTau_Max - write(stdout, '(1x, a, f16.5)')'BTauMax(Tesla.ps)', BTauMax - write(stdout, '(1x, a, f16.5)')'Relaxation_Time_Tau (ps)', Relaxation_Time_Tau - write(stdout, '(1x, a, f16.5)')'Rcut', Rcut - write(stdout, '(1x, a, i16 )')'Magp', Magp - write(stdout, '(1x, a, i16 )')'iprint_level', iprint_level - write(stdout, '(1x, a, f16.2)')'RKF45_PERIODIC_LEVEL', RKF45_PERIODIC_LEVEL - write(stdout, '(1x, a, i16 )')'Magp_min', Magp_min - write(stdout, '(1x, a, i16 )')'Magp_max', Magp_max - write(stdout, '(1x, a, f16.5)')'wcc_calc_tol', wcc_calc_tol - write(stdout, '(1x, a, f16.5)')'wcc_neighbour_tol', wcc_neighbour_tol - write(stdout, '(1x, a, i6 )')'NumLCZVecs', NumLCZVecs - write(stdout, '(1x, a, i6 )')'NumSelectedEigenVals', NumSelectedEigenVals - write(stdout, '(1x, a, i6 )')'NumRandomConfs:', NumRandomConfs - write(stdout, '(1x, a, a )')'Projection weight mode:', projection_weight_mode - write(stdout, '(1x, a, i8 )')'The size of magnetic supercell is Magq= :', Magq - endif - - !> changed to atomic units - E_arc= E_arc*eV2Hartree - Eta_Arc = Eta_Arc*eV2Hartree - OmegaMin= OmegaMin*eV2Hartree - OmegaMax= OmegaMax*eV2Hartree - Gap_threshold= Gap_threshold*eV2Hartree - Rcut= Rcut*Ang2Bohr - - !> change the unit of relaxtion time from ps to atomic unit - Relaxation_Time_Tau= Relaxation_Time_Tau*1E-12/Time_atomic - - !> change the unit of B*Tau from T*ps to atomic unit - BTauMax= BTauMax/Magneticfluxdensity_atomic*Relaxation_Time_Tau - - !> - allocate(Omega_array(OmegaNum)) - if (OmegaNum==1) then - Omega_array(1)= OmegaMin - else - do i=1, OmegaNum - Omega_array(i)= OmegaMin+ (OmegaMax-OmegaMin)* (i-1d0)/dble(OmegaNum-1) - enddo ! i - endif - -!===============================================================================================================! -!> LATTICE card -!===============================================================================================================! - - NK = Nk1 - - !> Read the cell information include the lattice and atom's position - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 100)inline - inline= upper(inline) - if (trim(adjustl(inline))=='LATTICE') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found LATTICE card' - exit - endif - enddo -100 continue - - if (lfound) then - read(1001, *)inline ! The unit of lattice vector - inline= upper(inline) - AngOrBohr=trim(adjustl(inline)) - read(1001, *)Origin_cell%Rua - read(1001, *)Origin_cell%Rub - read(1001, *)Origin_cell%Ruc - else - stop 'ERROR: please set lattice information' - endif - - if (index(AngOrBohr, 'ANG')>0) then - !> the input unit is Angstrom - Origin_cell%Rua= Origin_cell%Rua*Angstrom2atomic - Origin_cell%Rub= Origin_cell%Rub*Angstrom2atomic - Origin_cell%Ruc= Origin_cell%Ruc*Angstrom2atomic - endif - Origin_cell%lattice(:, 1)= Origin_cell%Rua - Origin_cell%lattice(:, 2)= Origin_cell%Rub - Origin_cell%lattice(:, 3)= Origin_cell%Ruc - - !> cell parameters - Origin_cell%cell_parameters(1)= norm(Origin_cell%Rua) - Origin_cell%cell_parameters(2)= norm(Origin_cell%Rub) - Origin_cell%cell_parameters(3)= norm(Origin_cell%Ruc) - Origin_cell%cell_parameters(4)= angle(Origin_cell%Rub, Origin_cell%Ruc) - Origin_cell%cell_parameters(5)= angle(Origin_cell%Rua, Origin_cell%Ruc) - Origin_cell%cell_parameters(6)= angle(Origin_cell%Rua, Origin_cell%Rub) - - !> transform lattice from direct space to reciprocal space - - Origin_cell%Kua= 0d0 - Origin_cell%Kub= 0d0 - Origin_cell%Kuc= 0d0 - - call get_volume(Origin_cell%Rua, Origin_cell%Rub, Origin_cell%Ruc, Origin_cell%CellVolume) - Origin_cell%ReciprocalCellVolume= (2d0*pi)**3/Origin_cell%CellVolume - - call get_reciprocal_lattice(Origin_cell%Rua, Origin_cell%Rub, Origin_cell%Ruc, & - Origin_cell%Kua, Origin_cell%Kub, Origin_cell%Kuc) - - Origin_cell%reciprocal_lattice(:, 1)= Origin_cell%Kua - Origin_cell%reciprocal_lattice(:, 2)= Origin_cell%Kub - Origin_cell%reciprocal_lattice(:, 3)= Origin_cell%Kuc - - !> cell parameters - Origin_cell%reciprocal_cell_parameters(1)= norm(Origin_cell%Kua) - Origin_cell%reciprocal_cell_parameters(2)= norm(Origin_cell%Kub) - Origin_cell%reciprocal_cell_parameters(3)= norm(Origin_cell%Kuc) - Origin_cell%reciprocal_cell_parameters(4)= angle(Origin_cell%Kub, Origin_cell%Kuc) - Origin_cell%reciprocal_cell_parameters(5)= angle(Origin_cell%Kua, Origin_cell%Kuc) - Origin_cell%reciprocal_cell_parameters(6)= angle(Origin_cell%Kua, Origin_cell%Kub) - - if(cpuid==0)write(stdout, '(a)') '>> lattice information (Angstrom)' - if(cpuid==0)write(stdout, '(6a12)')" a", " b", " c", 'alpha', 'beta', 'gamma' - if(cpuid==0)write(stdout, '(6f12.6)')Origin_cell%cell_parameters/Angstrom2atomic - if(cpuid==0)write(stdout, '(a)')" Three Lattice vectors of the unfolded cell: " - if(cpuid==0)write(stdout, '(3f12.6)')Origin_cell%Rua/Angstrom2atomic - if(cpuid==0)write(stdout, '(3f12.6)')Origin_cell%Rub/Angstrom2atomic - if(cpuid==0)write(stdout, '(3f12.6)')Origin_cell%Ruc/Angstrom2atomic - - if(cpuid==0)write(stdout, '(a)') '>> Reciprocal lattice information (1/Angstrom)' - if(cpuid==0)write(stdout, '(6a12)')" a", " b", " c", 'alpha', 'beta', 'gamma' - if(cpuid==0)write(stdout, '(6f12.6)')Origin_cell%reciprocal_cell_parameters*Angstrom2atomic - if(cpuid==0)write(stdout, '(a)')" Three reciprocal lattice vectors of the primitive cell: " - if(cpuid==0)write(stdout, '(3f12.6)')Origin_cell%Kua*Angstrom2atomic - if(cpuid==0)write(stdout, '(3f12.6)')Origin_cell%Kub*Angstrom2atomic - if(cpuid==0)write(stdout, '(3f12.6)')Origin_cell%Kuc*Angstrom2atomic - -!===============================================================================================================! -!> ATOM_POSITIONS card -!===============================================================================================================! - - !> Read atom positions information - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 101)inline - inline=upper(inline) - if (trim(adjustl(inline))=='ATOM_POSITIONS') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found ATOM_POSITIONS card' - exit - endif - enddo -101 continue - - if (lfound) then - read(1001, *)Origin_cell%Num_atoms ! total number of atoms - if(cpuid==0)write(stdout, '(a, i5)')'Origin_cell%Num_atoms', Origin_cell%Num_atoms - allocate(Origin_cell%atom_name(Origin_cell%Num_atoms)) - allocate(Origin_cell%Atom_position_cart(3, Origin_cell%Num_atoms)) - allocate(Origin_cell%Atom_position_direct(3, Origin_cell%Num_atoms)) - allocate(Atom_position_cart_newcell(3, Origin_cell%Num_atoms)) - allocate(Atom_position_direct_newcell(3, Origin_cell%Num_atoms)) - allocate(Origin_cell%Atom_magnetic_moment(3, Origin_cell%Num_atoms)) - Origin_cell%Atom_magnetic_moment= 0d0 - read(1001, *)inline ! The unit of lattice vector - DirectOrCart= trim(adjustl(inline)) - - !> check whether we have the magnetic moment in the POSITION card - do i=1, Origin_cell%Num_atoms - read(1001, *, err=132) Origin_cell%atom_name(i), Origin_cell%Atom_position_cart(:, i), Origin_cell%Atom_magnetic_moment(:, i) - if(cpuid==0)write(stdout, '(a4,3f12.6)')Origin_cell%atom_name(i), Origin_cell%Atom_position_cart(:, i) - if (index(DirectOrCart, "D")>0)then - pos= Origin_cell%Atom_position_cart(:, i) - Origin_cell%Atom_position_cart(:, i)= pos(1)*Origin_cell%Rua+ pos(2)*Origin_cell%Rub+ pos(3)*Origin_cell%Ruc - else - if (index(AngOrBohr, 'ANG')>0) then - Origin_cell%Atom_position_cart(:, i)= Origin_cell%Atom_position_cart(:, i)*Angstrom2atomic - endif - endif - enddo - go to 133 - -132 continue - !> if the code comes to here, it means there is no atom's magnetic moment in the POSITION card - if (cpuid==0) write(stdout, *) ' ' - if (cpuid==0) write(stdout, *) & - "Warning: You didn't specify the atom magnetic moment in the ATOMIC_POSITION card", & - " Or the format is wrong. ", & - "So we set all the Atom-magnetic-moments to zero." - Origin_cell%Atom_magnetic_moment= 0d0 - rewind(1001) - do while (.true.) - read(1001, *)inline - inline=upper(inline) - if (trim(adjustl(inline))=='ATOM_POSITIONS') then - exit - endif - enddo - !> skip two lines - read(1001, *) - read(1001, *) - - do i=1, Origin_cell%Num_atoms - read(1001, *, err=134) Origin_cell%atom_name(i), Origin_cell%Atom_position_cart(:, i) - !> Origin_cell%Atom_position_cart is in the cartesian coordinate. - if (index(DirectOrCart, "D")>0)then - pos= Origin_cell%Atom_position_cart(:, i) - Origin_cell%Atom_position_cart(:, i)= pos(1)*Origin_cell%Rua+ pos(2)*Origin_cell%Rub+ pos(3)*Origin_cell%Ruc - else - if (index(AngOrBohr, 'ANG')>0) then - Origin_cell%Atom_position_cart(:, i)= Origin_cell%Atom_position_cart(:, i)*Angstrom2atomic - endif - endif - enddo - go to 133 -134 continue - write(*, *)"ERROR happens in the ATOMIC_POSITION card" - write(*, *)"This is a free format card, between lines there should be any comments" - write(*, *)"The number in the second line should be the same as the number of lines of the atom positions." - stop "ERROR: please set ATOMIC_POSITION card correctly, see manual on www.wanniertools.com" - -133 continue - - do ia=1, Origin_cell%Num_atoms - call cart_direct_real(Origin_cell%Atom_position_cart(:, ia), & - Origin_cell%Atom_position_direct(:, ia), Origin_cell%lattice) - enddo - - if(cpuid==0)write(stdout,'(a)')' ' - if(cpuid==0)write(stdout,'(a)')'>> Atom position and magnetic moment of Original lattice' - if(cpuid==0)write(stdout,'(13X, 2a36, a24)')' Catesian(Ang)', 'Fractional(Direct)', 'Magnetic moment' - if(cpuid==0)write(stdout,'(a)')'------------------------------------------------------------------------------------------------------------------' - if(cpuid==0)write(stdout,'(a6, 2X, a10, 6a12, 3a8)')'index', 'Atom Name ', ' x', ' y', ' z', 'a', 'b', 'c', 'Mx', 'My', 'Mz' - if(cpuid==0)write(stdout,'(a)')'------------------------------------------------------------------------------------------------------------------' - do i=1, Origin_cell%Num_atoms - if(cpuid==0)write(stdout, '(i6,2X, a10,6f12.6,3f8.3)')i, Origin_cell%atom_name(i), & - Origin_cell%Atom_position_cart(:, i)/Angstrom2atomic, Origin_cell%Atom_position_direct(:,i), Origin_cell%Atom_magnetic_moment(:, i) - enddo - - else - stop "ERROR: please set atom's positions information correctly" - endif - - - !> setup atom type - if (allocated(iarray_temp))deallocate(iarray_temp) - allocate(iarray_temp(Origin_cell%Num_atoms)) - iarray_temp= 1 - do ia=1, Origin_cell%Num_atoms - char_temp= Origin_cell%atom_name(ia) - do i=ia+1, Origin_cell%Num_atoms - if (char_temp==Origin_cell%atom_name(i).and.iarray_temp(i)/=0)then - iarray_temp(i)=0 - endif - enddo - enddo - Origin_cell%Num_atom_type= sum(iarray_temp) - - allocate(Origin_cell%Name_of_atomtype(Origin_cell%Num_atom_type)) - allocate(Origin_cell%Num_atoms_eachtype(Origin_cell%Num_atom_type)) - allocate(Origin_cell%itype_atom(Origin_cell%Num_atoms)) - it = 0 - do ia=1, Origin_cell%Num_atoms - if (iarray_temp(ia)/=0) then - it= it+ 1 - Origin_cell%Name_of_atomtype(it)= Origin_cell%atom_name(ia) - endif - enddo - - !> find the type of atoms and label them - do ia=1, Origin_cell%Num_atoms - do i=1, Origin_cell%Num_atom_type - if (Origin_cell%atom_name(ia)==Origin_cell%Name_of_atomtype(i))then - Origin_cell%itype_atom(ia)= i - endif - enddo - enddo - - do i=1, Origin_cell%Num_atom_type - it = 0 - do ia=1, Origin_cell%Num_atoms - if (Origin_cell%atom_name(ia)==Origin_cell%Name_of_atomtype(i))then - it = it+ 1 - endif - enddo - Origin_cell%Num_atoms_eachtype(i)= it - enddo - - -!===============================================================================================================! -!> PROJECTORS card -!===============================================================================================================! - - !> Read projectors information - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 102)inline - inline=upper(inline) - if (trim(adjustl(inline))=='PROJECTORS'.or.& - trim(adjustl(inline))=='PROJECTOR') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found PROJECTORS card' - exit - endif - enddo -102 continue - - if (lfound) then - allocate(Origin_cell%nprojs(Origin_cell%Num_atoms)) - Origin_cell%nprojs= 0 - read(1001, *)Origin_cell%nprojs - if(cpuid==0)write(stdout, '(a)')' >>Number of projectors per atoms:' - if(cpuid==0)write(stdout, '(10i6)')Origin_cell%nprojs - - Origin_cell%max_projs= maxval(Origin_cell%nprojs) - allocate(Origin_cell%proj_name(Origin_cell%max_projs, Origin_cell%Num_atoms)) - Origin_cell%proj_name= ' ' - do i=1, Origin_cell%Num_atoms - read(1001, *)char_temp, Origin_cell%proj_name(1:Origin_cell%nprojs(i), i) - if(cpuid==0)write(stdout, '(40a8)') & - char_temp, Origin_cell%proj_name(1:Origin_cell%nprojs(i), i) - !> change the projector name to upper case - do j=1, Origin_cell%nprojs(i) - Origin_cell%proj_name(j, i)= upper(Origin_cell%proj_name(j, i)) - enddo - enddo - - else - stop "ERROR: please set projectors for Wannier functions information" - endif - - !> set up orbitals_start - allocate(orbitals_start(Origin_cell%Num_atoms)) - orbitals_start= 1 - do i=1, Origin_cell%Num_atoms-1 - orbitals_start(i+1)= orbitals_start(i)+ Origin_cell%nprojs(i) - enddo - - !> orbital index order - allocate(index_start(Origin_cell%Num_atoms)) - allocate(index_end (Origin_cell%Num_atoms)) - index_start= 0 - index_end= 0 - index_start(1)= 1 - index_end(1)= Origin_cell%nprojs(1) - do i=2, Origin_cell%Num_atoms - index_start(i)= index_start(i-1)+ Origin_cell%nprojs(i-1) - index_end(i)= index_end(i-1)+ Origin_cell%nprojs(i) - enddo - - - - !> read Wannier centres - NumberOfspinorbitals= sum(Origin_cell%nprojs) - if (SOC>0.or.Add_Zeeman_Field) NumberOfspinorbitals= 2*NumberOfspinorbitals - Origin_cell%NumberOfspinorbitals= NumberOfspinorbitals - allocate(Origin_cell%spinorbital_to_atom_index(NumberOfspinorbitals)) - allocate(Origin_cell%spinorbital_to_projector_index(NumberOfspinorbitals)) - allocate(Origin_cell%wannier_centers_cart(3, NumberOfspinorbitals)) - allocate(Origin_cell%wannier_centers_direct(3, NumberOfspinorbitals)) - Origin_cell%wannier_centers_direct= 0d0 - Origin_cell%wannier_centers_cart= 0d0 - !> default wannier centers - i= 0 - do ia= 1, Origin_cell%Num_atoms - do j= 1, Origin_cell%nprojs(ia) - i= i+ 1 - Origin_cell%spinorbital_to_atom_index(i)= ia - Origin_cell%spinorbital_to_projector_index(i)= j - Origin_cell%wannier_centers_cart(:, i)= Origin_cell%Atom_position_cart(:, ia) - call cart_direct_real(Origin_cell%wannier_centers_cart(:, i), & - Origin_cell%wannier_centers_direct(:, i), & - Origin_cell%lattice) - if (SOC>0.or.Add_Zeeman_Field) then - Origin_cell%spinorbital_to_atom_index(i+NumberOfspinorbitals/2)= ia - Origin_cell%spinorbital_to_projector_index(i+NumberOfspinorbitals/2)= j - Origin_cell%wannier_centers_cart(:, i+NumberOfspinorbitals/2)= Origin_cell%Atom_position_cart(:, ia) - call cart_direct_real(Origin_cell%wannier_centers_cart(:, i+NumberOfspinorbitals/2), & - Origin_cell%wannier_centers_direct(:, i+NumberOfspinorbitals/2), & - Origin_cell%lattice) - endif - enddo ! j - enddo ! ia - - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 110)inline - inline=upper(inline) - if (trim(adjustl(inline))=='WANNIER_CENTERS' & - .or. trim(adjustl(inline))=='WANNIER_CENTRES') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found WANNIER_CENTERS card' - exit - endif - enddo - - if (lfound) then - read(1001, *)inline ! Direct or Cartesian - inline= upper(inline) - DirectOrCart= trim(adjustl(inline)) - - it= 0 - if (index(DirectOrCart, "D")>0)then - if (SOC==0.and.Add_Zeeman_Field) then - do i=1, NumberOfspinorbitals/2 - read(1001, *, end=207, err=207) Origin_cell%wannier_centers_direct(:, i) - it= it+ 2 - call direct_cart_real(Origin_cell%wannier_centers_direct(:, i), & - Origin_cell%wannier_centers_cart(:, i), Origin_cell%lattice) - Origin_cell%wannier_centers_cart(:, i+NumberOfspinorbitals/2)= & - Origin_cell%wannier_centers_cart(:, i) - Origin_cell%wannier_centers_direct(:, i+NumberOfspinorbitals/2)= & - Origin_cell%wannier_centers_direct(:, i) - enddo - else - do i=1, NumberOfspinorbitals - read(1001, *, end=207, err=207) Origin_cell%wannier_centers_direct(:, i) - it= it+ 1 - call direct_cart_real(Origin_cell%wannier_centers_direct(:, i), & - Origin_cell%wannier_centers_cart(:, i), Origin_cell%lattice) - enddo - endif - - else - if (SOC==0.and.Add_Zeeman_Field) then - do i=1, NumberOfspinorbitals/2 - read(1001, *, end=207, err=207) Origin_cell%wannier_centers_cart(:, i) - Origin_cell%wannier_centers_cart(:, i)= Origin_cell%wannier_centers_cart(:, i)*Angstrom2atomic - it= it+ 2 - call cart_direct_real(Origin_cell%wannier_centers_cart(:, i), & - Origin_cell%wannier_centers_direct(:, i), Origin_cell%lattice) - Origin_cell%wannier_centers_cart(:, i+NumberOfspinorbitals/2)= & - Origin_cell%wannier_centers_cart(:, i) - Origin_cell%wannier_centers_direct(:, i+NumberOfspinorbitals/2)= & - Origin_cell%wannier_centers_direct(:, i) - enddo - else - do i=1, NumberOfspinorbitals - read(1001, *, end=207, err=207) Origin_cell%wannier_centers_cart(:, i) - if (index(AngOrBohr, 'ANG')>0) then - Origin_cell%wannier_centers_cart(:, i)= Origin_cell%wannier_centers_cart(:, i)*Angstrom2atomic - endif - it= it+ 1 - call cart_direct_real(Origin_cell%wannier_centers_cart(:, i), & - Origin_cell%wannier_centers_direct(:, i), Origin_cell%lattice) - enddo - endif - endif - endif ! found Origin_cell%wannier_ceters card -207 continue - if (it< NumberOfspinorbitals.and.cpuid==0) then - write(stdout, *)' ' - write(stdout, *)' >>>> Error happens in Wannier_centres card' - write(stdout, *)' Error: the number of Origin_cell%wannier_ceters lines should ' - write(stdout, *)' equal to the number wannier functions (include spin)' - write(stdout, *)' Num_wann', NumberOfspinorbitals, ' the centres lines you given ', it - write(stdout, *)' Otherwise, if you do not know the meaning of this,' - write(stdout, *)' please delete this card' - stop - endif - - - -110 continue - - if (lfound) then - if (cpuid==0) then - write(stdout, *)" " - write(stdout, *)">> Wannier centers from wt.in, in unit of unit lattice vectors" - write(stdout, '(a6, 6a10)')'iwann', 'R1', 'R2', 'R3', 'x', 'y', 'z' - do i=1, NumberOfspinorbitals - write(stdout, '(i6, 6f10.6)')i, Origin_cell%wannier_centers_direct(:, i), & - Origin_cell%wannier_centers_cart(:, i)/Angstrom2atomic - enddo - endif - else - if (cpuid==0) then - write(stdout, *)" " - write(stdout, *)">> Wannier centers by default, in unit of unit lattice vectors" - write(stdout, '(a6, 6a10)')'iwann', 'R1', 'R2', 'R3', 'x', 'y', 'z' - do i=1, NumberOfspinorbitals - write(stdout, '(i6, 6f10.6)')i, Origin_cell%wannier_centers_direct(:, i), & - Origin_cell%wannier_centers_cart(:, i)/Angstrom2atomic - enddo - endif - endif - - !> write out the origin cell - call writeout_poscar(Origin_cell, 'POSCAR-origin') - -!===============================================================================================================! -!> LATTICE_UNFOLD card -!===============================================================================================================! - - !>> This segment is for folded lattice which is smaller than the original lattice usually - !> read folded lattice information - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 1080)inline - inline= upper(inline) - if (trim(adjustl(inline))=='LATTICE_UNFOLD') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found LATTICE_UNFOLD card' - exit - endif - enddo -1080 continue - - if (lfound) then - read(1001, *)inline ! The unit of lattice vector - inline= upper(inline) - AngOrBohr=trim(adjustl(inline)) - read(1001, *)Folded_cell%Rua - read(1001, *)Folded_cell%Rub - read(1001, *)Folded_cell%Ruc - if (index(AngOrBohr, 'ANG')>0) then - Folded_cell%Rua= Folded_cell%Rua*Angstrom2atomic - Folded_cell%Rub= Folded_cell%Rub*Angstrom2atomic - Folded_cell%Ruc= Folded_cell%Ruc*Angstrom2atomic - endif - - else - if (cpuid==0) write(stdout, *)"We didn't found LATTICE_UNFOLD card, so it is the same as the unit cell." - Folded_cell%Rua=Origin_cell%Rua - Folded_cell%Rub=Origin_cell%Rub - Folded_cell%Ruc=Origin_cell%Ruc - endif - - !> cell parameters - Folded_cell%cell_parameters(1)= norm(Folded_cell%Rua) - Folded_cell%cell_parameters(2)= norm(Folded_cell%Rub) - Folded_cell%cell_parameters(3)= norm(Folded_cell%Ruc) - Folded_cell%cell_parameters(4)= angle(Folded_cell%Rub, Folded_cell%Ruc) - Folded_cell%cell_parameters(5)= angle(Folded_cell%Rua, Folded_cell%Ruc) - Folded_cell%cell_parameters(6)= angle(Folded_cell%Rua, Folded_cell%Rub) - - - !> transform lattice from direct space to reciprocal space - - Folded_cell%Kua= 0d0 - Folded_cell%Kub= 0d0 - Folded_cell%Kuc= 0d0 - call get_volume(Folded_cell%Rua, Folded_cell%Rub, Folded_cell%Ruc, Folded_cell%CellVolume ) - Folded_cell%ReciprocalCellVolume= (2d0*3.1415926535d0)**3/Folded_cell%CellVolume - - call get_reciprocal_lattice(Folded_cell%Rua, Folded_cell%Rub, Folded_cell%Ruc, & - Folded_cell%Kua, Folded_cell%Kub, Folded_cell%Kuc) - - !> reciprlcal cell parameters - Folded_cell%reciprocal_cell_parameters(1)= norm(Folded_cell%Kua) - Folded_cell%reciprocal_cell_parameters(2)= norm(Folded_cell%Kub) - Folded_cell%reciprocal_cell_parameters(3)= norm(Folded_cell%Kuc) - Folded_cell%reciprocal_cell_parameters(4)= angle(Folded_cell%Kub, Folded_cell%Kuc) - Folded_cell%reciprocal_cell_parameters(5)= angle(Folded_cell%Kua, Folded_cell%Kuc) - Folded_cell%reciprocal_cell_parameters(6)= angle(Folded_cell%Kua, Folded_cell%Kub) - - if(cpuid==0)write(stdout, '(a)') '>> Folded lattice information (Angstrom)' - if(cpuid==0)write(stdout, '(6a12)')" a", " b", " c", 'alpha', 'beta', 'gamma' - if(cpuid==0)write(stdout, '(6f12.6)')Folded_cell%cell_parameters/Angstrom2atomic - if(cpuid==0)write(stdout, '(a)')" Three Lattice vectors of unfolded cell: " - if(cpuid==0)write(stdout, '(3f12.6)')Folded_cell%Rua/Angstrom2atomic - if(cpuid==0)write(stdout, '(3f12.6)')Folded_cell%Rub/Angstrom2atomic - if(cpuid==0)write(stdout, '(3f12.6)')Folded_cell%Ruc/Angstrom2atomic - - if(cpuid==0)write(stdout, '(a)') '>> Folded Reciprocal lattice information (1/Angstrom)' - if(cpuid==0)write(stdout, '(6a12)')" a", " b", " c", 'alpha', 'beta', 'gamma' - if(cpuid==0)write(stdout, '(6f12.6)')Folded_cell%reciprocal_cell_parameters*Angstrom2atomic - if(cpuid==0)write(stdout, '(a)')" Three reciprocal lattice vectors of unfolded cell: " - if(cpuid==0)write(stdout, '(3f12.6)')Folded_cell%Kua*Angstrom2atomic - if(cpuid==0)write(stdout, '(3f12.6)')Folded_cell%Kub*Angstrom2atomic - if(cpuid==0)write(stdout, '(3f12.6)')Folded_cell%Kuc*Angstrom2atomic - - !> calculate the coordinates of Origin_cell in the unit of Folded_cell - call cart_direct_real_unfold(Origin_cell%Rua, R1) - call cart_direct_real_unfold(Origin_cell%Rub, R2) - call cart_direct_real_unfold(Origin_cell%Ruc, R3) - - if(cpuid==0) then - write(stdout, '(a)') ' ' - write(stdout, '(a)') '>> The relation between the original lattice and the unfolded lattice' - write(stdout, '(a, f12.6)') '>> The cell volume ratio is: ', Origin_cell%CellVolume/Folded_cell%CellVolume - write(stdout, '(a, f12.6)') '>> The lattice constant a ratio is: ', Origin_cell%cell_parameters(1)/Folded_cell%cell_parameters(1) - write(stdout, '(a, f12.6)') '>> The lattice constant b ratio is: ', Origin_cell%cell_parameters(2)/Folded_cell%cell_parameters(2) - write(stdout, '(a, f12.6)') '>> The lattice constant c ratio is: ', Origin_cell%cell_parameters(3)/Folded_cell%cell_parameters(3) - write(stdout, '(a, 3f12.6)') '>> Origin_cell in unit of Folded_cell: R1 ', R1 - write(stdout, '(a, 3f12.6)') '>> Origin_cell in unit of Folded_cell: R2 ', R2 - write(stdout, '(a, 3f12.6)') '>> Origin_cell in unit of Folded_cell: R3 ', R3 - write(stdout, '(a)') ' ' - endif - - -!===============================================================================================================! -!> ATOM_POSITIONS_UNFOLD card -!===============================================================================================================! - - !> Read atom positions information - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 1013)inline - inline=upper(inline) - if (trim(adjustl(inline))=='ATOM_POSITIONS_UNFOLD') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found ATOM_POSITIONS_UNFOLD card' - exit - endif - enddo -1013 continue - - if (lfound) then - read(1001, *)Folded_cell%Num_atoms ! total number of atoms - if(cpuid==0)write(stdout, '(a, i5)')'Folded_cell%Num_atoms', Folded_cell%Num_atoms - allocate(Folded_cell%atom_name(Folded_cell%Num_atoms)) - allocate(Folded_cell%Atom_position_cart(3, Folded_cell%Num_atoms)) - allocate(Folded_cell%Atom_position_direct(3, Folded_cell%Num_atoms)) - allocate(Folded_cell%Atom_magnetic_moment(3, Folded_cell%Num_atoms)) - Folded_cell%Atom_magnetic_moment= 0d0 - read(1001, *)inline ! The unit of lattice vector - DirectOrCart= trim(adjustl(inline)) - - !> check whether we have the magnetic moment in the POSITION card - do i=1, Folded_cell%Num_atoms - read(1001, *, err=1320) Folded_cell%atom_name(i), Folded_cell%Atom_position_cart(:, i), Folded_cell%Atom_magnetic_moment(:, i) - if(cpuid==0)write(stdout, '(a4,3f12.6)')Folded_cell%atom_name(i), Folded_cell%Atom_position_cart(:, i) - if (index(DirectOrCart, "D")>0)then - pos= Folded_cell%Atom_position_cart(:, i) - Folded_cell%Atom_position_cart(:, i)= pos(1)*Folded_cell%Rua+ pos(2)*Folded_cell%Rub+ pos(3)*Folded_cell%Ruc - else - if (index(AngOrBohr, 'ANG')>0) then - Folded_cell%Atom_position_cart(:, i)= Folded_cell%Atom_position_cart(:, i)*Angstrom2atomic - endif - endif - enddo - go to 1330 - -1320 continue - !> if the code comes to here, it means there is no atom's magnetic moment in the POSITION card - if (cpuid==0) write(stdout, *) ' ' - if (cpuid==0) write(stdout, *) & - "Warning: You didn't specify the atom magnetic moment in the ATOMIC_POSITION card", & - " Or the format is wrong. ", & - "So we set all the Atom-magnetic-moments to zero." - Folded_cell%Atom_magnetic_moment= 0d0 - rewind(1001) - do while (.true.) - read(1001, *)inline - inline=upper(inline) - if (trim(adjustl(inline))=='ATOM_POSITIONS_UNFOLD') then - exit - endif - enddo - !> skip two lines - read(1001, *) - read(1001, *) - - do i=1, Folded_cell%Num_atoms - read(1001, *, err=1340) Folded_cell%atom_name(i), Folded_cell%Atom_position_cart(:, i) - !> Folded_cell%Atom_position_cart is in the cartesian coordinate. - if (index(DirectOrCart, "D")>0)then - pos= Folded_cell%Atom_position_cart(:, i) - Folded_cell%Atom_position_cart(:, i)= pos(1)*Folded_cell%Rua+ pos(2)*Folded_cell%Rub+ pos(3)*Folded_cell%Ruc - else - if (index(AngOrBohr, 'ANG')>0) then - Folded_cell%Atom_position_cart(:, i)= Folded_cell%Atom_position_cart(:, i)*Angstrom2atomic - endif - endif - enddo - go to 1330 -1340 continue - write(*, *)"ERROR happens in the ATOM_POSITION_UNFOLD card" - write(*, *)"This is a free format card, between lines there should be any comments" - write(*, *)"The number in the second line should be the same as the number of lines of the atom positions." - stop "ERROR: please set ATOM_POSITION_UNFOLD card correctly, see manual on www.wanniertools.com" - -1330 continue - - if(cpuid==0)write(stdout,'(a)')' ' - do ia=1, Folded_cell%Num_atoms - call cart_direct_real_unfold(Folded_cell%Atom_position_cart(:, ia), Folded_cell%Atom_position_direct(:, ia)) - if(cpuid==0)write(stdout, '(a4,3f12.6)')Folded_cell%atom_name(ia), Folded_cell%Atom_position_direct(:, ia) - enddo - else - if (abs(Folded_cell%CellVolume-Origin_cell%CellVolume)>eps6) then - call printerrormsg("ERROR: please set ATOM_POSITIONS_UNFOLD since you set LATTICE_UNFOLD") - else - Folded_cell%Num_atoms= Origin_cell%Num_atoms - allocate(Folded_cell%atom_name(Folded_cell%Num_atoms)) - allocate(Folded_cell%Atom_position_cart(3, Folded_cell%Num_atoms)) - allocate(Folded_cell%Atom_position_direct(3, Folded_cell%Num_atoms)) - allocate(Folded_cell%Atom_magnetic_moment(3, Folded_cell%Num_atoms)) - Folded_cell%atom_name= Origin_cell%atom_name - Folded_cell%Atom_position_cart= Origin_cell%Atom_position_cart - Folded_cell%Atom_position_direct= Origin_cell%Atom_position_direct - Folded_cell%Atom_magnetic_moment= Origin_cell%Atom_magnetic_moment - endif - endif - - if(cpuid==0)write(stdout,'(a)')' ' - if(cpuid==0)write(stdout,'(a)')'>>> Atom position and magnetic moment of Unfolded lattice' - if(cpuid==0)write(stdout,'(13X, 2a36, a24)')' Catesian(Ang)', 'Fractional(Direct)', 'Magnetic moment' - if(cpuid==0)write(stdout,'(a)')'------------------------------------------------------------------------------------------------------------------' - if(cpuid==0)write(stdout,'(a6, 2X, a10, 6a12, 3a8)')'index', 'Atom Name ', ' x', ' y', ' z', 'a', 'b', 'c', 'Mx', 'My', 'Mz' - if(cpuid==0)write(stdout,'(a)')'------------------------------------------------------------------------------------------------------------------' - do i=1, Folded_cell%Num_atoms - if(cpuid==0)write(stdout, '(i6,2X, a10,6f12.6,3f8.3)')i, Folded_cell%atom_name(i), & - Folded_cell%Atom_position_cart(:, i)/Angstrom2atomic, Folded_cell%Atom_position_direct(:,i), Folded_cell%Atom_magnetic_moment(:, i) - enddo - - - !> setup atom type - if (allocated(iarray_temp))deallocate(iarray_temp) - allocate(iarray_temp(Folded_cell%Num_atoms)) - iarray_temp= 1 - do ia=1, Folded_cell%Num_atoms - char_temp= Folded_cell%atom_name(ia) - do i=ia+1, Folded_cell%Num_atoms - if (char_temp==Folded_cell%atom_name(i).and.iarray_temp(i)/=0)then - iarray_temp(i)=0 - endif - enddo - enddo - Folded_cell%Num_atom_type= sum(iarray_temp) - - allocate(Folded_cell%Name_of_atomtype(Folded_cell%Num_atom_type)) - allocate(Folded_cell%Num_atoms_eachtype(Folded_cell%Num_atom_type)) - allocate(Folded_cell%itype_atom(Folded_cell%Num_atoms)) - it = 0 - do ia=1, Folded_cell%Num_atoms - if (iarray_temp(ia)/=0) then - it= it+ 1 - Folded_cell%Name_of_atomtype(it)= Folded_cell%atom_name(ia) - endif - enddo - - !> find the type of atoms and label them - do ia=1, Folded_cell%Num_atoms - do i=1, Folded_cell%Num_atom_type - if (Folded_cell%atom_name(ia)==Folded_cell%Name_of_atomtype(i))then - Folded_cell%itype_atom(ia)= i - endif - enddo - enddo - - do i=1, Folded_cell%Num_atom_type - it = 0 - do ia=1, Folded_cell%Num_atoms - if (Folded_cell%atom_name(ia)==Folded_cell%Name_of_atomtype(i))then - it = it+ 1 - endif - enddo - Folded_cell%Num_atoms_eachtype(i)= it - enddo - - call writeout_poscar(Folded_cell, "POSCAR-Folded") -!===============================================================================================================! -!> PROJECTORS_UNFOLD card -!===============================================================================================================! - - !> Read projectors information for unfolded lattice - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 1020)inline - inline=upper(inline) - if (trim(adjustl(inline))=='PROJECTORS_UNFOLD'.or.& - trim(adjustl(inline))=='PROJECTOR_UNFOLD') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found PROJECTORS_UNFOLD card' - exit - endif - enddo -1020 continue - - if (lfound) then - allocate(Folded_cell%nprojs(Folded_cell%Num_atoms)) - Folded_cell%nprojs= 0 - read(1001, *)Folded_cell%nprojs - if(cpuid==0)write(stdout, '(a)')' >>Number of projectors per atoms:' - if(cpuid==0)write(stdout, '(10i6)')Folded_cell%nprojs - - Folded_cell%max_projs= maxval(Folded_cell%nprojs) - allocate(Folded_cell%proj_name(Folded_cell%max_projs, Folded_cell%Num_atoms)) - Folded_cell%proj_name= ' ' - do i=1, Folded_cell%Num_atoms - read(1001, *)char_temp, Folded_cell%proj_name(1:Folded_cell%nprojs(i), i) - if(cpuid==0)write(stdout, '(40a8)') & - char_temp, Folded_cell%proj_name(1:Folded_cell%nprojs(i), i) - enddo - else - if (abs(Folded_cell%CellVolume-Origin_cell%CellVolume)>eps6) then - call printerrormsg("ERROR: please set PROJECTORS_UNFOLD since you set LATTICE_UNFOLD") - else - allocate(Folded_cell%nprojs(Folded_cell%Num_atoms)) - Folded_cell%nprojs= Origin_cell%nprojs - Folded_cell%max_projs= maxval(Folded_cell%nprojs) - allocate(Folded_cell%proj_name(Folded_cell%max_projs, Folded_cell%Num_atoms)) - Folded_cell%proj_name= Origin_cell%proj_name - endif - endif - - !> Wannier centres for unfoled lattice - NumberOfspinorbitals_unfold= sum(Folded_cell%nprojs) - if (SOC>0) NumberOfspinorbitals_unfold= 2*NumberOfspinorbitals_unfold - Folded_cell%NumberOfspinorbitals= NumberOfspinorbitals_unfold - allocate(Folded_cell%spinorbital_to_atom_index(NumberOfspinorbitals_unfold)) - allocate(Folded_cell%spinorbital_to_projector_index(NumberOfspinorbitals_unfold)) - allocate(Folded_cell%wannier_centers_cart(3, NumberOfspinorbitals_unfold)) - allocate(Folded_cell%wannier_centers_direct(3, NumberOfspinorbitals_unfold)) - Folded_cell%wannier_centers_direct= 0d0 - Folded_cell%wannier_centers_cart= 0d0 - !> default wannier centers - i= 0 - do ia= 1, Folded_cell%Num_atoms - do j= 1, Folded_cell%nprojs(ia) - i= i+ 1 - Folded_cell%spinorbital_to_atom_index(i)= ia - Folded_cell%spinorbital_to_projector_index(i)= j - Folded_cell%wannier_centers_cart(:, i)= Folded_cell%Atom_position_cart(:, ia) - call cart_direct_real_unfold(Folded_cell%wannier_centers_cart(:, i), & - Folded_cell%wannier_centers_direct(:, i)) - if (SOC>0) then - Folded_cell%spinorbital_to_atom_index(i+NumberOfspinorbitals_unfold/2)= ia - Folded_cell%spinorbital_to_projector_index(i+NumberOfspinorbitals_unfold/2)= j - Folded_cell%wannier_centers_cart(:, i+NumberOfspinorbitals_unfold/2)= Folded_cell%Atom_position_cart(:, ia) - call cart_direct_real_unfold(Folded_cell%wannier_centers_cart(:, i+NumberOfspinorbitals_unfold/2), & - Folded_cell%wannier_centers_direct(:, i+NumberOfspinorbitals_unfold/2)) - endif - enddo ! j - enddo ! ia - -!===============================================================================================================! -!> MILLER_INDICES card -!===============================================================================================================! - - !> read surface information by Miller indices - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 224)inline - inline=upper(inline) - if (trim(adjustl(inline))=='MILLER_INDICES' & - .or. trim(adjustl(inline))=='MILLER_INDEX') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found MILLER_INDEX card for slab calculations' - exit - endif - enddo -224 continue - - MillerIndices= 0 - if (lfound) then - read(1001, *, err=225, iostat=stat) MillerIndices(:) -225 continue - if (stat/=0) stop "Something wrong with setting of MillerIndices, they should be like this 1 0 0" - if (cpuid.eq.0) then - write(stdout, '(a, 3i6)')' Miller indices are :', MillerIndices - endif - call MillerIndicestoumatrix() - endif - -!===============================================================================================================! -!> SURFACE card -!===============================================================================================================! - - !> read surface information - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 103)inline - inline=upper(inline) - if (trim(adjustl(inline))=='SURFACE') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found SURFACE card' - exit - endif - enddo -103 continue - - if (.not.lfound.and.sum(abs(MillerIndices))==0) then - Umatrix(1, :)=(/1d0, 0d0, 0d0/) - Umatrix(2, :)=(/0d0, 1d0, 0d0/) - Umatrix(3, :)=(/0d0, 0d0, 1d0/) - MillerIndices= (/0, 0, 1/) - if (cpuid==0) then - write(stdout, *) "Warnning: You didn't set SURFACE card, by default, it's (001) surface." - write(stdout, '(a, 3f12.6)')' The 1st vector on surface :', Umatrix(1, :) - write(stdout, '(a, 3f12.6)')' The 2nd vector on surface :', Umatrix(2, :) - write(stdout, '(a, 3f12.6)')' The 3rd vector out of surface :', Umatrix(3, :) - endif - endif - - if (lfound) then - !> read information for new lattice - !> in order to get different surface state - !> R1'=U11*R1+U12*R2+U13*R3 - !> R2'=U21*R1+U22*R2+U23*R3 - !> R3'=U31*R1+U32*R2+U33*R3 - read(1001, *)Umatrix(1, :) - read(1001, *)Umatrix(2, :) - - Umatrix(3,:)=(/0.0,0.0,1.0/) - read(1001, *, err=260, iostat=stat)Umatrix(3, :) - -260 continue - - if (cpuid==0) then - write(stdout, '(a)')' ' - write(stdout, '(a)')'>> new vectors to define the surface (in unit of lattice vector)' - write(stdout, '(a, 3f12.6)')' The 1st vector on surface :', Umatrix(1, :) - write(stdout, '(a, 3f12.6)')' The 2nd vector on surface :', Umatrix(2, :) - write(stdout, '(a, 3f12.6)')' The 3rd vector out of surface :', Umatrix(3, :) - endif - - if (sum(abs(MillerIndices))>0 .and. cpuid==0) then - write(stdout, '(a, a, a)')' Attention: you specified surface information twice.' , & - ' However, we only take the information from SURFACE card, ', & - ' and omit the settings by MILLER_INDEX card' - endif - endif - - !> check whether Umatrix is right - !> the volume of the new cell should be the same as the old ones - !> Here R1, R2, R3 are vectors defined by SURFACE CARD in original cartesian coordinates - R1= Umatrix(1, 1)*Origin_cell%Rua+ Umatrix(1, 2)*Origin_cell%Rub+ Umatrix(1, 3)*Origin_cell%Ruc - R2= Umatrix(2, 1)*Origin_cell%Rua+ Umatrix(2, 2)*Origin_cell%Rub+ Umatrix(2, 3)*Origin_cell%Ruc - R3= Umatrix(3, 1)*Origin_cell%Rua+ Umatrix(3, 2)*Origin_cell%Rub+ Umatrix(3, 3)*Origin_cell%Ruc - - cell_volume2= R1(1)*(R2(2)*R3(3)- R2(3)*R3(2)) & - +R1(2)*(R2(3)*R3(1)- R2(1)*R3(3)) & - +R1(3)*(R2(1)*R3(2)- R2(2)*R3(1)) - - if (cell_volume2<0) then - R3=-R3 - Umatrix(3, :)= -Umatrix(3, :) - endif - - if (abs(abs(cell_volume2)-abs(Origin_cell%CellVolume))> 0.001d0.and.cpuid==0) then - write(stdout, '(a)')' ' - write(stdout, '(2a)')' Warnning: The Umatrix is wrongly set, the new cell', & - 'volume should be the same as the old ones. ' - write(stdout, '(a,2f10.4)')' cell_volume vs cell_volume-new', Origin_cell%CellVolume, cell_volume2 - write(stdout, '(a)')" However, don't worry, WannierTools will help you to find a suitable rotation matrix." - write(stdout, '(a)')" I am looking for new unit cell atuomatically: " - endif - if (abs(abs(cell_volume2)-abs(Origin_cell%CellVolume))> 0.001d0) then - call FindTheThirdLatticeVector() - R1= Umatrix(1, 1)*Origin_cell%Rua+ Umatrix(1, 2)*Origin_cell%Rub+ Umatrix(1, 3)*Origin_cell%Ruc - R2= Umatrix(2, 1)*Origin_cell%Rua+ Umatrix(2, 2)*Origin_cell%Rub+ Umatrix(2, 3)*Origin_cell%Ruc - R3= Umatrix(3, 1)*Origin_cell%Rua+ Umatrix(3, 2)*Origin_cell%Rub+ Umatrix(3, 3)*Origin_cell%Ruc - if (cpuid==0) then - write(stdout, '(a)')' ' - write(stdout, '(a)')'>> New SURFACE CARD:' - write(stdout, '(a, 3f12.6)')' The 1st vector on surface :', Umatrix(1, :) - write(stdout, '(a, 3f12.6)')' The 2nd vector on surface :', Umatrix(2, :) - write(stdout, '(a, 3f12.6)')' The 3rd vector out of surface :', Umatrix(3, :) - endif - endif - - !> print out the new basis - if (cpuid.eq.0) then - write(stdout, *)" " - write(stdout, *)"The rotated new unit cell in cartesian coordinates : " - write(stdout, '(3f12.6)') R1 - write(stdout, '(3f12.6)') R2 - write(stdout, '(3f12.6)') R3 - - call get_volume(R1, R2, R3, cell_volume2) - write(stdout, '(a, f18.5, a)')"New cell's Volume is ", cell_volume2/(Angstrom2atomic**3), 'Ang^3' - write(stdout, *)" " - endif - - if (cpuid.eq.0) then - write(stdout, *)"Fractional coordinates of atoms in units of new lattice vectors : " - do ia=1, Origin_cell%Num_atoms - call rotate_newlattice(Origin_cell%Atom_position_direct(:, ia), Rt) - call transformtohomecell(Rt) - if(cpuid==0)write(stdout, '(a4,3f12.6)')Origin_cell%atom_name(ia), Rt - enddo - write(stdout, *)" " - endif - - !> print out the new basis - outfileindex= outfileindex+ 1 - if (cpuid.eq.0) then - open(outfileindex, file="POSCAR-rotated") - write(outfileindex, '(a)')"Rotated POSCAR by SURFACE card in wt.in by WannierTools" - write(outfileindex, '(a)')"1.0" - write(outfileindex, '(3f12.6)') R1/Angstrom2atomic - write(outfileindex, '(3f12.6)') R2/Angstrom2atomic - write(outfileindex, '(3f12.6)') R3/Angstrom2atomic - write(outfileindex, '(300A6)') Origin_cell%Name_of_atomtype - write(outfileindex, '(300i6)') Origin_cell%Num_atoms_eachtype - write(outfileindex, '(a)')"Direct" - do ia=1, Origin_cell%Num_atoms - call rotate_newlattice(Origin_cell%Atom_position_direct(:, ia), Rt) - call transformtohomecell(Rt) - if(cpuid==0)write(outfileindex, '(3f12.6, a9)')Rt, trim(adjustl(Origin_cell%atom_name(ia))) - enddo - close(outfileindex) - endif - - !> three lattice vectors in old cartesian coordinates - Rua_newcell= R1 - Rub_newcell= R2 - Ruc_newcell= R3 - - - !> Setting the new cell defined by SURFACE card - Cell_defined_by_surface%Rua = R1 - Cell_defined_by_surface%Rub = R2 - Cell_defined_by_surface%Ruc = R3 - Cell_defined_by_surface%lattice(:, 1)= R1 - Cell_defined_by_surface%lattice(:, 2)= R2 - Cell_defined_by_surface%lattice(:, 3)= R3 - - Cell_defined_by_surface%Num_atoms = Origin_cell%Num_atoms - Cell_defined_by_surface%max_projs = Origin_cell%max_projs - Cell_defined_by_surface%NumberOfspinorbitals = Origin_cell%NumberOfspinorbitals - Cell_defined_by_surface%Num_atom_type= Origin_cell%Num_atom_type - allocate(Cell_defined_by_surface%Num_atoms_eachtype(Origin_cell%Num_atom_type)) - allocate(Cell_defined_by_surface%Name_of_atomtype(Origin_cell%Num_atom_type)) - allocate(Cell_defined_by_surface%itype_atom(Origin_cell%Num_atoms)) - allocate(Cell_defined_by_surface%Atom_name(Origin_cell%Num_atoms)) - allocate(Cell_defined_by_surface%Atom_position_cart (3, Origin_cell%Num_atoms)) - allocate(Cell_defined_by_surface%Atom_position_direct(3, Origin_cell%Num_atoms)) - allocate(Cell_defined_by_surface%nprojs(Origin_cell%Num_atoms)) - allocate(Cell_defined_by_surface%spinorbital_to_atom_index(Origin_cell%NumberOfspinorbitals)) - allocate(Cell_defined_by_surface%spinorbital_to_projector_index(Origin_cell%NumberOfspinorbitals)) - Cell_defined_by_surface%Num_atoms_eachtype= Origin_cell%Num_atoms_eachtype - Cell_defined_by_surface%Name_of_atomtype= Origin_cell%Name_of_atomtype - Cell_defined_by_surface%itype_atom= Origin_cell%itype_atom - Cell_defined_by_surface%Atom_name= Origin_cell%Atom_name - Cell_defined_by_surface%nprojs= Origin_cell%nprojs - do ia=1, Origin_cell%Num_atoms - call rotate_newlattice(Origin_cell%Atom_position_direct(:, ia), Rt) - call transformtohomecell(Rt) - Atom_position_direct_newcell(:, ia)= Rt - Cell_defined_by_surface%Atom_position_direct(:, ia)= Rt - call direct_cart_real_newcell(Rt, Atom_position_cart_newcell(:, ia)) - Cell_defined_by_surface%Atom_position_cart(:, ia)= Atom_position_cart_newcell(:, ia) - enddo - - !> try to find one atom on the top surface according to the third coordinate of Atom_position_direct - idummy= 0 - temp=Cell_defined_by_surface%Atom_position_direct(3, 1) - if (topsurface_atom_index==0) then - topsurface_atom_index= 1 - do ia=2, Origin_cell%Num_atoms - if (Cell_defined_by_surface%Atom_position_direct(3, ia)>temp) then - temp= Cell_defined_by_surface%Atom_position_direct(3, ia) - topsurface_atom_index= ia - endif - enddo - endif - !> shift the top surface atom to 0.99 along R3' - Rt= (/0d0, 0d0, & - 0.95d0-Cell_defined_by_surface%Atom_position_direct(3, topsurface_atom_index)/) - call direct_cart_real(Rt, shift_to_topsurface_cart, Cell_defined_by_surface%lattice) - - !> shift all atoms by Rt - do ia=1, Origin_cell%Num_atoms - Rt2= Cell_defined_by_surface%Atom_position_direct(:, ia)+ Rt - call transformtohomecell(Rt2) - Cell_defined_by_surface%Atom_position_direct(:, ia)= Rt2 - call direct_cart_real(Rt2, Atom_position_cart_newcell(:, ia), Cell_defined_by_surface%lattice) - Cell_defined_by_surface%Atom_position_cart(:, ia)= Atom_position_cart_newcell(:, ia) - enddo - - !> write out - if (cpuid==0) then - write(stdout, '(a)') ' ' - write(stdout, '(a, i6, 1x, a)') " >> Top surface atom is ", topsurface_atom_index, & - Cell_defined_by_surface%Atom_name(topsurface_atom_index) - write(stdout, '(a)') ' ' - endif - - !> default wannier centers - i= 0 - do ia= 1, Cell_defined_by_surface%Num_atoms - do j= 1, Cell_defined_by_surface%nprojs(ia) - i= i+ 1 - Cell_defined_by_surface%spinorbital_to_atom_index(i)= ia - Cell_defined_by_surface%spinorbital_to_projector_index(i)= j - if (SOC>0.or.Add_Zeeman_Field) then - Cell_defined_by_surface%spinorbital_to_atom_index(i+NumberOfspinorbitals/2)= ia - Cell_defined_by_surface%spinorbital_to_projector_index(i+NumberOfspinorbitals/2)= j - endif - enddo ! j - enddo ! ia - - call writeout_poscar(Cell_defined_by_surface, 'POSCAR-SURFACE') - - !> generate POSCAR for slab system - call generate_slab_poscar(Cell_defined_by_surface) - - !> get the surface vector, we should set the new coordinate system - !> set R1 to the new x direction ex' - !> set R1\cross R2 to the new z direction ez' - !> set ey'= ez'\cross ex' - !> then e_i'= \sum_j U_ij e_j - Urot= 0d0 - !> e_x' - Urot(1, :)= R1/norm(R1) - - !> e_z' - Urot(3, 1)= (R1(2)*R2(3)- R1(3)*R2(2)) - Urot(3, 2)= (R1(3)*R2(1)- R1(1)*R2(3)) - Urot(3, 3)= (R1(1)*R2(2)- R1(2)*R2(1)) - Urot(3, :)= Urot(3, :)/norm(Urot(3, :)) - - !> e_y'= e_z'\cross e_x' - Urot(2, 1)= (Urot(3, 2)*Urot(1, 3)- Urot(3, 3)*Urot(1, 2)) - Urot(2, 2)= (Urot(3, 3)*Urot(1, 1)- Urot(3, 1)*Urot(1, 3)) - Urot(2, 3)= (Urot(3, 1)*Urot(1, 2)- Urot(3, 2)*Urot(1, 1)) - Urot(2, :)= Urot(2, :)/norm(Urot(2, :)) - - !> Here Rua_new, Origin_cell%Rub_new, Origin_cell%Ruc_new are vectors defined by SURFACE CARD in new coordinates - call rotate(R1, Rua_new) - call rotate(R2, Rub_new) - call rotate(R3, Ruc_new) - - !> then transform R1, R2 to the new coordinates - !> R1'_j= \sum_i U_ij R_i - !> because the z direction is perpendicular to R1, R2, - !> so the z coordinates for R1, R2 in the new axis are zero - Ra2(1)= Urot(1, 1)*R1(1)+ Urot(1, 2)*R1(2)+ Urot(1, 3)*R1(3) - Ra2(2)= Urot(2, 1)*R1(1)+ Urot(2, 2)*R1(2)+ Urot(2, 3)*R1(3) - Rb2(1)= Urot(1, 1)*R2(1)+ Urot(1, 2)*R2(2)+ Urot(1, 3)*R2(3) - Rb2(2)= Urot(2, 1)*R2(1)+ Urot(2, 2)*R2(2)+ Urot(2, 3)*R2(3) - - !> get the surface reciprocal vector - cell_volume=Ra2(1)*Rb2(2)- Rb2(1)*Ra2(2) - cell_volume= abs(cell_volume) - - if (abs(cell_volume)<1e-6) stop 'cell_volume equal zero' - - Ka2(1)= 2d0*pi/cell_volume*Rb2(2) - Ka2(2)=-2d0*pi/cell_volume*Rb2(1) - Kb2(1)=-2d0*pi/cell_volume*Ra2(2) - Kb2(2)= 2d0*pi/cell_volume*Ra2(1) - - if (cpuid==0) then - write(stdout, *)'2D Primitive Cell_Volume: ', Cell_Volume/Angstrom2atomic/Angstrom2atomic - write(stdout, *)'Ra2, Rb2' - write(stdout, '(3f10.4)')Ra2/Angstrom2atomic - write(stdout, '(3f10.4)')Rb2/Angstrom2atomic - write(stdout, *)'Ka2, Kb2' - write(stdout, '(3f10.4)')ka2/Angstrom2atomic - write(stdout, '(3f10.4)')kb2/Angstrom2atomic - endif - - -!===============================================================================================================! -!> Set magnetic super cell -!===============================================================================================================! - - !> magnetic supercell stacks along Origin_cell%Ruc_newcell direction which is defined - !> as the third vector in SURFACE card - !> The size of the supercell is Nslab - !> Magnetic field is along Rua_newcell - Rua_mag= Rua_newcell - Rub_mag= Rub_newcell - Ruc_mag= Ruc_newcell*Magq - Magnetic_cell%Rua= Rua_mag - Magnetic_cell%Rub= Rub_mag - Magnetic_cell%Ruc= Ruc_mag - - Magnetic_cell%cell_parameters(1)= norm(Magnetic_cell%Rua) - Magnetic_cell%cell_parameters(2)= norm(Magnetic_cell%Rub) - Magnetic_cell%cell_parameters(3)= norm(Magnetic_cell%Ruc) - Magnetic_cell%cell_parameters(4)= angle(Magnetic_cell%Rub, Magnetic_cell%Ruc) - Magnetic_cell%cell_parameters(5)= angle(Magnetic_cell%Ruc, Magnetic_cell%Rua) - Magnetic_cell%cell_parameters(6)= angle(Magnetic_cell%Rua, Magnetic_cell%Rub) - - !> transform lattice from direct space to reciprocal space - call get_volume(Magnetic_cell%Rua, Magnetic_cell%Rub, Magnetic_cell%Ruc, Magnetic_cell%CellVolume) - - !> Volume of reciprocal lattice of magnetic supercell, in unit of (1/Bohr)**3 - Magnetic_cell%ReciprocalCellVolume= (2d0*pi)**3/Magnetic_cell%CellVolume - - !> Reciprocal lattice vectors in unit of 1/Bohr - call get_reciprocal_lattice(Magnetic_cell%Rua, Magnetic_cell%Rub, Magnetic_cell%Ruc, & - Magnetic_cell%Kua, Magnetic_cell%Kub, Magnetic_cell%Kuc) - - if(cpuid==0)write(stdout, '(a)') '>> lattice information of the magnetic supercell (Angstrom)' - if(cpuid==0)write(stdout, '(3f12.6)')Magnetic_cell%Rua/Angstrom2atomic - if(cpuid==0)write(stdout, '(3f12.6)')Magnetic_cell%Rub/Angstrom2atomic - if(cpuid==0)write(stdout, '(3f12.6)')Magnetic_cell%Ruc/Angstrom2atomic - - if(cpuid==0)write(stdout, '(a)') '>> Reciprocal lattice information of the magnetic supercell (1/Angstrom)' - if(cpuid==0)write(stdout, '(3f12.6)')Magnetic_cell%Kua*Angstrom2atomic - if(cpuid==0)write(stdout, '(3f12.6)')Magnetic_cell%Kub*Angstrom2atomic - if(cpuid==0)write(stdout, '(3f12.6)')Magnetic_cell%Kuc*Angstrom2atomic - - MagneticSuperProjectedArea= Magnetic_cell%CellVolume/norm(R1) - - !> get atoms' position in the magnetic supercell - Magnetic_cell%Num_atoms = Origin_cell%Num_atoms*Magq - Magnetic_cell%max_projs = Origin_cell%max_projs*Magq - Magnetic_cell%NumberOfspinorbitals = Origin_cell%NumberOfspinorbitals*Magq - Magnetic_cell%Num_atom_type= Origin_cell%Num_atom_type - allocate(Magnetic_cell%Num_atoms_eachtype(Origin_cell%Num_atom_type)) - allocate(Magnetic_cell%Name_of_atomtype(Origin_cell%Num_atom_type)) - allocate(Magnetic_cell%itype_atom(Magnetic_cell%Num_atoms)) - allocate(Magnetic_cell%Atom_name(Magnetic_cell%Num_atoms)) - allocate(Magnetic_cell%nprojs(Magnetic_cell%Num_atoms)) - allocate(Magnetic_cell%Atom_position_cart (3, Magnetic_cell%Num_atoms)) - allocate(Magnetic_cell%Atom_position_direct(3, Magnetic_cell%Num_atoms)) - allocate(Magnetic_cell%wannier_centers_cart(3, Magnetic_cell%NumberOfspinorbitals)) - allocate(Magnetic_cell%wannier_centers_direct(3, Magnetic_cell%NumberOfspinorbitals)) - Magnetic_cell%Num_atoms_eachtype= Origin_cell%Num_atoms_eachtype*Magq - Magnetic_cell%Name_of_atomtype= Origin_cell%Name_of_atomtype - do iq=1, Magq - do ia=1, Origin_cell%Num_atoms - Magnetic_cell%itype_atom((iq-1)*Origin_cell%Num_atoms+ia)= Origin_cell%itype_atom(ia) - Magnetic_cell%Atom_name((iq-1)*Origin_cell%Num_atoms+ia)= Origin_cell%Atom_name(ia) - enddo - enddo - do iq=1, Magq - do ia=1, Origin_cell%Num_atoms - call rotate_newlattice(Origin_cell%Atom_position_direct(:, ia), Rt) - Magnetic_cell%Atom_position_direct(1:2, (iq-1)*Origin_cell%Num_atoms+ia)= Rt(1:2) - Magnetic_cell%Atom_position_direct(3, (iq-1)*Origin_cell%Num_atoms+ia)= (Rt(3)+ iq-1d0)/Magq - call direct_cart_real_magneticcell(Magnetic_cell%Atom_position_direct(:, (iq-1)*Origin_cell%Num_atoms+ia), & - Magnetic_cell%Atom_position_cart(:, (iq-1)*Origin_cell%Num_atoms+ia)) - enddo - do i=1, NumberOfspinorbitals - call rotate_newlattice(Origin_cell%wannier_centers_direct(:, i), Rt) - Magnetic_cell%wannier_centers_direct(1:2, (iq-1)*NumberOfspinorbitals+i)= Rt(1:2) - Magnetic_cell%wannier_centers_direct(3, (iq-1)*NumberOfspinorbitals+i)= (Rt(3)+ iq-1d0)/Magq - call direct_cart_real_magneticcell(Magnetic_cell%wannier_centers_direct(:, (iq-1)*NumberOfspinorbitals+i), & - Magnetic_cell%wannier_centers_cart(:, (iq-1)*NumberOfspinorbitals+i)) - enddo - enddo - - Magnetic_cell%NumberOfspinorbitals= Origin_cell%NumberOfspinorbitals*Magq - allocate(Magnetic_cell%spinorbital_to_atom_index(Magnetic_cell%NumberOfspinorbitals)) - allocate(Magnetic_cell%spinorbital_to_projector_index(Magnetic_cell%NumberOfspinorbitals)) - do iq=1, Magq - istart= (iq-1)*Origin_cell%NumberOfspinorbitals+1 - iend = iq*Origin_cell%NumberOfspinorbitals - Magnetic_cell%spinorbital_to_atom_index(istart:iend)= Origin_cell%spinorbital_to_atom_index+istart-1 - Magnetic_cell%spinorbital_to_projector_index(istart:iend)= Origin_cell%spinorbital_to_projector_index+istart-1 - enddo - - do iq=1, Magq - do ia= 1, Origin_cell%Num_atoms - Magnetic_cell%nprojs(ia+(iq-1)*Origin_cell%Num_atoms)= Origin_cell%nprojs(ia) - enddo - enddo - - i=0 - do ia= 1, Magnetic_cell%Num_atoms - do j= 1, Magnetic_cell%nprojs(ia) - i= i+ 1 - Magnetic_cell%spinorbital_to_atom_index(i)= ia - Magnetic_cell%spinorbital_to_projector_index(i)= j - if (SOC>0.or.Add_Zeeman_Field) then - Magnetic_cell%spinorbital_to_atom_index(i+Magq*NumberOfspinorbitals/2)= ia - Magnetic_cell%spinorbital_to_projector_index(i+Magq*NumberOfspinorbitals/2)= j - endif - enddo - enddo - - call writeout_poscar(Magnetic_cell, "POSCAR-mag") - - if (cpuid==0) then - write(stdout, *)" " - write(stdout, '(a, f16.8, a)')'3D Primitive Origin_cell%CellVolume: ', Origin_cell%CellVolume/(Angstrom2atomic**3), ' in Angstrom^3' - write(stdout, '(a, f16.8, a)')'3D Magnetic supercell Volume: ', Magnetic_cell%CellVolume/(Angstrom2atomic**3), ' in Angstrom^3' - write(stdout, '(a, f16.8, a)')'Projected area of magnetic supercell normal to the first vector specifed in SURFACE card: ', & - MagneticSuperProjectedArea, ' in Angstrom^2' - endif - -!===============================================================================================================! -!> KPATH_BULK card -!===============================================================================================================! - - - !> read kpath_bulk information - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 104)inline - inline=upper(inline) - if (trim(adjustl(inline))=='KPATH_BULK') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found KPATH_BULK card' - exit - endif - enddo - - !> kline for 3d band stOrigin_cell%Ructure - !> high symmetry k points - read(1001, *) nk3lines - if(cpuid==0)write(stdout, '(a, 40i5)')'Number of K lines : ', nk3lines - allocate(k3line_start(3, nk3lines)) - allocate(k3line_end(3, nk3lines)) - allocate(k3line_name(nk3lines+1)) - allocate(k3line_stop(nk3lines+1)) - allocate(k3line_mag_stop(nk3lines+1)) - allocate(k3line_unfold_stop(nk3lines+1)) - k3line_mag_stop= 0d0 - k3line_unfold_stop= 0d0 - k3line_stop= 0d0 - k3line_start= 0d0 - k3line_end= 0d0 - k3line_name= ' ' - it=0 - do i=1, nk3lines - read(1001, *, err=201) k3line_name(i), k3line_start(:, i), & - char_temp, k3line_end(:, i) - it= it+ 1 - if(cpuid==0)write(stdout, '(a5, 3f9.4, 2x, a5, 3f9.4)')& - k3line_name(i), k3line_start(:, i), & - char_temp, k3line_end(:, i) - - enddo -201 continue - if (it< nk3lines.and.cpuid==0) then - write(stdout, *)' ' - write(stdout, *)' >>>> Error happens in KPATH_BULK card' - write(stdout, *)' Error: the number of kpath lines should consistent' - write(stdout, *)' Nk3lines ', nk3lines, ' the k lines you given ', it - write(stdout, *)' Please set nk3lines to be ', it - stop - endif - - k3line_name(nk3lines+1)= char_temp - - NN= Nk - nk3_band= NN*nk3lines - - allocate(k3len(nk3_band)) - allocate(k3len_mag(nk3_band)) - allocate(k3len_unfold(nk3_band)) - allocate(k3points(3, nk3_band)) - k3len=0d0 - k3len_mag=0d0 - k3len_unfold=0d0 - k3points= 0d0 - t1= 0d0 - do j=1, nk3lines - do i=1, NN - kstart= k3line_start(:, j) - kend = k3line_end(:, j) - k1= kstart(1)*Origin_cell%Kua+ kstart(2)*Origin_cell%Kub+ kstart(3)*Origin_cell%Kuc - k2= kend(1)*Origin_cell%Kua+ kend(2)*Origin_cell%Kub+ kend(3)*Origin_cell%Kuc - !k1= kstart - !k2= kend - - k3points(:, i+ (j-1)*NN)= kstart+ (kend- kstart)*dble(i-1)/dble(NN-1) - - temp= dsqrt((k2(1)- k1(1))**2 & - +(k2(2)- k1(2))**2 & - +(k2(3)- k1(3))**2)/dble(NN-1) - - if (i.gt.1) then - t1=t1+temp - endif - k3len(i+(j-1)*NN)= t1 - enddo - k3line_stop(j+1)= t1 - enddo - - !> for magnetic supercell - t1=0 - do j=1, nk3lines - do i=1, NN - kstart= k3line_start(:, j) - kend = k3line_end(:, j) - k1= kstart(1)*Magnetic_cell%Kua+ kstart(2)*Magnetic_cell%Kub+ kstart(3)*Magnetic_cell%Kuc - k2= kend(1)*Magnetic_cell%Kua+ kend(2)*Magnetic_cell%Kub+ kend(3)*Magnetic_cell%Kuc - - temp= dsqrt((k2(1)- k1(1))**2 & - +(k2(2)- k1(2))**2 & - +(k2(3)- k1(3))**2)/dble(NN-1) - - if (i.gt.1) then - t1=t1+temp - endif - k3len_mag(i+(j-1)*NN)= t1 - enddo - k3line_mag_stop(j+1)= t1 - enddo - - !> for unfolded cell - - !> for magnetic supercell - t1=0 - do j=1, nk3lines - do i=1, NN - kstart= k3line_start(:, j) - kend = k3line_end(:, j) - k1= kstart(1)*Folded_cell%Kua+ kstart(2)*Folded_cell%Kub+ kstart(3)*Folded_cell%Kuc - k2= kend(1)*Folded_cell%Kua+ kend(2)*Folded_cell%Kub+ kend(3)*Folded_cell%Kuc - - temp= dsqrt((k2(1)- k1(1))**2 & - +(k2(2)- k1(2))**2 & - +(k2(3)- k1(3))**2)/dble(NN-1) - - if (i.gt.1) then - t1=t1+temp - endif - k3len_unfold(i+(j-1)*NN)= t1 - enddo - k3line_unfold_stop(j+1)= t1 - enddo - - - -104 continue - if (.not.lfound .and. (BulkBand_line_calc.or.LandauLevel_k_calc)) then - stop 'ERROR: please set KPATH_BULK for bulk band stOrigin_cell%Ructure calculation' - endif - -!===============================================================================================================! -!> KPATH_SLAB card -!===============================================================================================================! - - !> read kpath_slab information - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 105)inline - inline=upper(inline) - if (trim(adjustl(inline))=='KPATH_SLAB') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found KPATH_SLAB card' - exit - endif - enddo - - !> read in k lines for 2D system - k2line_name= ' ' - if (cpuid==0) write(stdout, *)'k lines for 2D system' - read(1001, *)nk2lines - if (cpuid==0) write(stdout, *)'No. of k lines for 2D system : ', nk2lines - it = 0 - do i=1, nk2lines - read(1001, *, err=202) k2line_name(i), kp(:, i), & - char_temp, ke(:, i) - it= it+ 1 - if (cpuid==0) write(stdout, '(a6, 2f9.5, 4x, a6, 2f9.5)')& - k2line_name(i), kp(:, i), & - char_temp, ke(:, i) - enddo -202 continue - - if (it< nk2lines.and.cpuid==0) then - write(stdout, *)' ' - write(stdout, *)' >>>> Error happens in KPATH_SLAB card' - write(stdout, *)' Error: the number of kpath lines should consistent' - write(stdout, *)' Nk2lines ', nk2lines, ' the k lines you given ', it - write(stdout, *)' Please set nk2lines to be ', it - stop - endif - - k2line_name(nk2lines+1) = char_temp - - - NN= Nk - knv2= NN*nk2lines - allocate( k2_path(knv2, 2)) - allocate( k2len (knv2)) - k2_path= 0d0 - k2len= 0d0 - - t1=0d0 - k2len=0d0 - k2line_stop= 0d0 - do j=1, nk2lines - do i=1, NN - kstart(1:2)= kp(:, j) - kend(1:2) = ke(:, j) - k1(1:2)= kstart(1)*Ka2+ kstart(2)*Kb2 - k2(1:2)= kend(1)*Ka2+ kend(2)*Kb2 - k2_path(i+(j-1)*NN,:)= kstart(1:2)+ (kend(1:2)-kstart(1:2))*(i-1)/dble(NN-1) - - temp= dsqrt((k2(1)- k1(1))**2 & - +(k2(2)- k1(2))**2)/dble(NN-1) - - if (i.gt.1) then - t1=t1+temp - endif - k2len(i+(j-1)*NN)= t1 - enddo - k2line_stop(j+1)= t1 - - enddo - - -105 continue - if (.not.lfound .and.(SlabBand_calc .or. SlabSS_calc)) then - stop 'ERROR: please set KPATH_SLAB for slab band stOrigin_cell%Ructure calculation' - endif - - - !> read kplane_slab information - !> default value for KPLANE_SLAB - K2D_start= (/-0.5, -0.5/) - K2D_vec1 = (/ 1.0, 0.0/) - K2D_vec2 = (/ 0.0, 1.0/) - - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 106)inline - inline=upper(inline) - if (trim(adjustl(inline))=='KPLANE_SLAB') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found KPLANE_SLAB card' - exit - endif - enddo - - !> kpoints plane for 2D system--> arcs - it = 0 - read(1001, *, err=203)K2D_start - it= it+ 1 - read(1001, *, err=203)K2D_vec1 - it= it+ 1 - read(1001, *, err=203)K2D_vec2 - it= it+ 1 -203 continue - if (it< 3.and.cpuid==0) then - write(stdout, *)' ' - write(stdout, *)' >>>> Error happens in KPLANE_SLAB card' - write(stdout, *)' Error: There are three lines in this card to specify the start point' - write(stdout, *)' of vectors, and two lines to assign two vectors.' - write(stdout, *)" If you don't know the meaning of this card, please delete this card" - stop - endif - - -106 continue - - if (cpuid==0) write(stdout, *)'>> Kpoints plane for 2D system--> arcs ' - if (cpuid==0) write(stdout, '((a, 2f8.4))')'K2D_start:', K2D_start - if (cpuid==0) write(stdout, '((a, 2f8.4))')'The first vector: ', K2D_vec1 - if (cpuid==0) write(stdout, '((a, 2f8.4))')'The second vector: ', K2D_vec2 - if (.not.lfound .and.(SlabArc_calc .or. SlabSpintexture_calc)) then - stop 'ERROR: please set KPLANE_SLAB for arc or spintexture calculations' - endif - - -!===============================================================================================================! -!> KPLANE_BULK card -!===============================================================================================================! - - !> read kplane_bulk information - !> default value for KPLANE_BULK - K3D_start= (/ 0.0, 0.0, 0.0/) - K3D_vec1 = (/ 1.0, 0.0, 0.0/) - K3D_vec2 = (/ 0.0, 0.5, 0.0/) - - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 107)inline - inline=upper(inline) - if (trim(adjustl(inline))=='KPLANE_BULK') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found KPLANE_BULK card' - exit - endif - enddo - - !> check whether we have a line to determine the coordinates - read(1001, *, end= 107)inline - inline=trim(adjustl(inline)) - if (index(inline, 'C')==0.and.index(inline, 'D')==0 & - .and.index(inline, 'c')==0.and.index(inline, 'd')==0)then - DirectOrCart='D' - - rewind(1001) - do while (.true.) - read(1001, *, end= 107)inline - inline=upper(inline) - if (trim(adjustl(inline))=='KPLANE_BULK') then - lfound= .true. - exit - endif - enddo - goto 2061 - elseif (index(inline, 'c')==1.or.index(inline, 'C')==1)then - DirectOrCart='C' - else - DirectOrCart='D' - endif - -2061 continue - - !> kpoints plane for 3D system--> gapshape - it= 0 - read(1001, *, err=206)K3D_start - it= it+ 1 - read(1001, *, err=206)K3D_vec1 - it= it+ 1 - read(1001, *, err=206)K3D_vec2 - it= it+ 1 - - if (index(DirectOrCart, 'C')>0) then - call cart_direct_rec(K3D_start, k1) - K3D_start= k1 - call cart_direct_rec(K3D_vec1, k1) - K3D_vec1= k1 - call cart_direct_rec(K3D_vec2, k1) - K3D_vec2= k1 - endif - -206 continue - if (it< 3.and.cpuid==0) then - write(stdout, *)' ' - write(stdout, *)' >>>> Error happens in KPLANE_BULK card' - write(stdout, *)' Error: There are three lines in this card to specify the start point' - write(stdout, *)' of vectors, and two lines to assign two vectors.' - write(stdout, *)" If you don't know the meaning of this card, please delete this card" - stop - endif - - -107 continue - - if (cpuid==0) write(stdout, *)'>> Kpoints plane for 3D system--> gapshape ' - if (cpuid==0) write(stdout, '((a, 3f8.4))')'k3D_start : ', K3D_start - if (cpuid==0) write(stdout, '((a, 3f8.4))')'The 1st vector: ', K3D_vec1 - if (cpuid==0) write(stdout, '((a, 3f8.4))')'The 2nd vector: ', K3D_vec2 - if (.not.lfound .and.(BulkGap_plane_calc .or. wanniercenter_calc)) then - stop 'ERROR: please set KPLANE_bulk for gap or WCC calculations' - endif - -!===============================================================================================================! -!> KCUBE_BULK card -!===============================================================================================================! - - !> read kcube_bulk information - !> default value for KCUBE_BULK - K3D_start_cube= (/ 0.0, 0.0, 0.0/) - K3D_vec1_cube = (/ 1.0, 0.0, 0.0/) - K3D_vec2_cube = (/ 0.0, 1.0, 0.0/) - K3D_vec3_cube = (/ 0.0, 0.0, 1.0/) - - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 108)inline - inline= upper(inline) - if (trim(adjustl(inline))=='KCUBE_BULK') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found KCUBE_BULK card' - exit - endif - enddo - - !> kpoints plane for 3D system--> gapshape - it= 0 - read(1001, *, err=204)K3D_start_cube - it= it+ 1 - read(1001, *, err=204)K3D_vec1_cube - it= it+ 1 - read(1001, *, err=204)K3D_vec2_cube - it= it+ 1 - read(1001, *, err=204)K3D_vec3_cube - it= it+ 1 -204 continue - if (it< 3.and.cpuid==0) then - write(stdout, *)' ' - write(stdout, *)' >>>> Error happens in KCUBE_BULK card' - write(stdout, *)' Error: There are four lines in this card to specify the start point' - write(stdout, *)' of vectors, and three lines to assign two vectors.' - write(stdout, *)" If you don't know the meaning of this card, please delete this card" - stop - endif -108 continue - - kCubeVolume= K3D_vec1_cube(1)*(K3D_vec2_cube(2)*K3D_vec3_cube(3) & - - K3D_vec2_cube(3)*K3D_vec3_cube(2)) & - + K3D_vec1_cube(2)*(K3D_vec2_cube(3)*K3D_vec3_cube(1) & - - K3D_vec2_cube(1)*K3D_vec3_cube(3)) & - + K3D_vec1_cube(3)*(K3D_vec2_cube(1)*K3D_vec3_cube(2) & - - K3D_vec2_cube(2)*K3D_vec3_cube(1)) - - kCubeVolume= kCubeVolume*Origin_cell%ReciprocalCellVolume - - - if (cpuid==0) write(stdout, *)'>> Kpoints cube for 3D system--> gapshape3D ' - if (cpuid==0) write(stdout, '((a, 3f8.4))')'k3D_start :', K3D_start_cube - if (cpuid==0) write(stdout, '((a, 3f8.4))')'The 1st vector: ', K3D_vec1_cube - if (cpuid==0) write(stdout, '((a, 3f8.4))')'The 2nd vector: ', K3D_vec2_cube - if (cpuid==0) write(stdout, '((a, 3f8.4))')'The 3rd vector: ', K3D_vec3_cube - if (cpuid==0) write(stdout, '((a, 3f8.4))')'kCubeVolume: ', kCubeVolume*Angstrom2atomic**3 - if (cpuid==0) write(stdout, '((a, 3f8.4))')'ReciprocalOrigin_cell%CellVolume: ', & - Origin_cell%ReciprocalCellVolume*Angstrom2atomic**3 - if (.not.lfound .and.(BulkGap_cube_calc)) then - stop 'ERROR: please set KCUBE_BULK for gap3D calculations' - endif - -!===============================================================================================================! -!> KPATH_BERRY card -!===============================================================================================================! - - !> set default parameters for Berry phase calculation - NK_Berry= 2 - allocate(k3points_Berry(3, NK_Berry)) - DirectOrCart_Berry='Direct' - k3points_Berry= 0d0 - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 113)inline - inline=upper(inline) - if (trim(adjustl(inline))=='KPATH_BERRY') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found KPATH_BERRY card' - exit - endif - enddo - - read(1001, *, end=208, err=208)NK_Berry - if (cpuid==0) write(stdout, '(a, i10)')'NK_Berry', NK_Berry - read(1001, *, end=208, err=208)inline ! The unit of lattice vector - DirectOrCart_Berry= trim(adjustl(inline)) - - deallocate(k3points_Berry) - allocate(k3points_Berry(3, NK_Berry)) - k3points_Berry= 0d0 - - it= 0 - if (index(DirectOrCart_Berry, "D")>0)then - do ik=1, NK_Berry - read(1001, *, end=208, err=208)k3points_Berry(:, ik) ! The unit of lattice vector - it = it+ 1 - enddo - else - do ik=1, NK_Berry - read(1001, *, end=208, err=208)k ! The unit of lattice vector - call cart_direct_rec(k, k3points_Berry(:, ik)) - it = it+ 1 - enddo - endif ! Direct or Cart coordinates -208 continue - - if (it< NK_Berry.and. cpuid==0) then - write(stdout, *)"ERROR: something wrong in the KPATH_BERRY card" - write(stdout, *)"No. of kpoints for berry is not consistent with No. of lines" - write(stdout, *)"I found ", it, " lines" - write(stdout, *)"while you set NK_Berry to be ", NK_Berry - stop - endif - -113 continue - - if (cpuid==0) write(stdout, *)' ' - if (.not.lfound.and.cpuid==0.and.BerryPhase_calc)then - write(stdout, *)'Error : you have to set KPATH_BERRY card with a list of k points' - stop - endif - - !< end of Berry phase setting - - -!===============================================================================================================! -!> KPOINT_BULK card -!===============================================================================================================! - - - !> default parameters for KPOINT - Kpoint_3D_direct = 0 - Kpoint_3D_cart = 0 - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 114)inline - inline= upper(inline) - if (trim(adjustl(inline))=='KPOINT_BULK') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found KPOINT_BULK card' - if (cpuid==0) write(stdout, *)'This card should like this:' - if (cpuid==0) write(stdout, *)'KPOINT_BULK' - if (cpuid==0) write(stdout, *)'direct' - if (cpuid==0) write(stdout, *)'0.0 0.0 0.0 ! three real number' - exit - endif - enddo - - read(1001, *)inline ! The unit of lattice vector - inline=upper(inline) - DirectOrCart= trim(adjustl(inline)) - if (index(DirectOrCart, "D")>0)then - read(1001, *)Kpoint_3D_direct - call direct_cart_rec(Kpoint_3D_direct, Kpoint_3D_cart) - else - read(1001, *)Kpoint_3D_cart - call cart_direct_rec(Kpoint_3D_cart, Kpoint_3D_direct) - endif - -114 continue - if (cpuid==0) write(stdout, *)' ' - if (.not.lfound.and.cpuid==0)write(stdout, *)'>> Using default parameters for Kpoint_3D' - if (cpuid==0) then - write(stdout, '(a, 3f7.4, a)')'>> k points ', Kpoint_3D_direct, " in unit of reciprocal primitive cell" - write(stdout, '(a, 3f7.4, a)')'>> k points ', Kpoint_3D_cart*Angstrom2atomic, " in Cartesian coordinates" - endif - -!===============================================================================================================! -!> EFFECTIVE_MASS card -!===============================================================================================================! - - !>> setting up effective mass calculation - !> default parameters for effective mass calculation - dk_mass= 0.01 ! in unit of 1/Ang - iband_mass= NumOccupied - k_mass= 0 - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 109)inline - inline= upper(inline) - if (trim(adjustl(inline))=='EFFECTIVE_MASS') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found EFFECTIVE_MASS card' - exit - endif - enddo - - it= 0 - read(1001, *, end=205, err=205)iband_mass - it= it+ 1 - read(1001, *, end=205, err=205)dk_mass - it= it+ 1 - read(1001, *, end=205, err=205)k_mass - it= it+ 1 -205 continue - if (it< 3.and.cpuid==0) then - write(stdout, *)' ' - write(stdout, *)' >>>> Error happens in EFFECTIVE_MASS card' - write(stdout, *)' Error: There are three lines in this card to specify the iband_mass' - write(stdout, *)" , dk_mass and k_mass, like this: " - write(stdout, *)"EFFECTIVE_MASS" - write(stdout, *)" 6 ! the 6'th band" - write(stdout, *)" 0.01 ! in unit of 1/Bohr" - write(stdout, *)" 0 0 0 ! k point" - stop - endif - - -109 continue - dk_mass= dk_mass/Angstrom2atomic - if (cpuid==0) write(stdout, *)' ' - if (.not.lfound.and.cpuid==0)write(stdout, *)'>> Using default parameters for effective mass calculation' - if (cpuid==0) write(stdout, *)'>> Effective mass calculation parameters ' - if (cpuid==0) write(stdout, '(a, i5, a)')'>> The ', iband_mass, "'th band" - if (cpuid==0) write(stdout, '(a, f7.4, a)')'>> k step ', dk_mass*Angstrom2atomic, " in unit of 1/Angstrom" - if (cpuid==0) write(stdout, '(a, 3f7.4, a)')'>> k points ', k_mass, " in unit of reciprocal primitive cell" - k1=k_mass - call direct_cart_rec(k1, k_mass) - if (cpuid==0) write(stdout, '(a, 3f7.4, a)')'>> k points ', k_mass*Angstrom2atomic, " in unit of 1/Angstrom" - -!===============================================================================================================! -!> KPOINTS_3D card -!===============================================================================================================! - - !>> setting up a series of k points in 3D BZ - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 321)inline - inline=upper(inline) - if (trim(adjustl(inline))=='KPOINTS_3D') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found KPOINTS_3D card' - exit - endif - enddo - - read(1001, *, end=319, err=319, iostat=stat)Nk3_point_mode ! The unit of lattice vector - allocate(k3points_pointmode_cart(3, Nk3_point_mode)) - allocate(k3points_pointmode_direct(3, Nk3_point_mode)) - k3points_pointmode_cart= 0d0 - k3points_pointmode_direct= 0d0 - - read(1001, *, end=319, err=319, iostat=stat)inline ! The unit of lattice vector - inline= upper(inline) - if (index(trim(adjustl(inline)), "D")>0)then - do ik= 1, Nk3_point_mode - read(1001, *, end=319, err=319, iostat=stat)k3points_pointmode_direct(:, ik) - call direct_cart_rec(k3points_pointmode_direct(:, ik), & - k3points_pointmode_cart(:, ik)) - enddo - else - do ik= 1, Nk3_point_mode - read(1001, *, end=319, err=319, iostat=stat)k3points_pointmode_cart(:, ik) - call cart_direct_rec(k3points_pointmode_cart(:, ik), & - k3points_pointmode_direct(:, ik)) - enddo - endif - - 319 continue - if (stat/=0 .and. cpuid==0) then - write(stdout, '(8f10.5)') "ERROR: there are something wrong in KPOINTS_3D card" - write(stdout, '(8f10.5)') "It should be like this:" - write(stdout, '(8f10.5)') "The number of lines below 'Direct' " - write(stdout, '(8f10.5)') "should be the same as the number of k points" - write(stdout, '(8f10.5)') "KPOINTS_3D" - write(stdout, '(8f10.5)') "4 ! number of k points" - write(stdout, '(8f10.5)') "Direct" - write(stdout, '(8f10.5)') "0.0 0.0 0.0" - write(stdout, '(8f10.5)') "0.5 0.0 0.0" - write(stdout, '(8f10.5)') "0.0 0.5 0.0" - write(stdout, '(8f10.5)') "0.0 0.0 0.5" - stop - endif - - !> print out the single kpoint positions - if (cpuid==0) then - write(stdout, '(a)')" " - write(stdout, '(a)')"KPOINTS_3D positions" - write(stdout, '(8a10)')"index", "kx", 'ky', 'kz', 'k1', 'k2', 'k3' - do ik=1, Nk3_point_mode - write(stdout, '(i8,4x,8f10.5)')ik, k3points_pointmode_cart(:, ik)*Angstrom2atomic, k3points_pointmode_direct(:, ik) - enddo - write(stdout, '(a)')" " - endif - - 321 continue - if (cpuid==0) write(stdout, *)' ' - if (.not. lfound) then - Nk3_point_mode = 1 - allocate(k3points_pointmode_cart(3, Nk3_point_mode)) - allocate(k3points_pointmode_direct(3, Nk3_point_mode)) - k3points_pointmode_cart= 0d0 - k3points_pointmode_direct= 0d0 - endif - if (.not.lfound.and.cpuid==0)write(stdout, *)'>> We use the default values for k3points_pointmode_direct=[0,0,0]' - if (.not.lfound.and.cpuid==0)write(stdout, *)'>> and Nk3_point_mode = 1' - -!===============================================================================================================! -!> KPOINTS_FOLD_3D card -!===============================================================================================================! - - !>> setting up a series of k points in the folded 3D BZ - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 3210)inline - inline=upper(inline) - if (trim(adjustl(inline))=='KPOINTS_FOLD_3D'.or.trim(adjustl(inline))=='KPOINTS_FOLDED_3D') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found KPOINTS_FOLD_3D card' - exit - endif - enddo - - read(1001, *, end=3190, err=3190, iostat=stat)Nk3_unfold_point_mode ! The unit of lattice vector - allocate(k3points_unfold_pointmode_cart(3, Nk3_unfold_point_mode)) - allocate(k3points_unfold_pointmode_direct(3, Nk3_unfold_point_mode)) - k3points_unfold_pointmode_cart= 0d0 - k3points_unfold_pointmode_direct= 0d0 - - read(1001, *, end=3190, err=3190, iostat=stat)inline ! The unit of lattice vector - inline=upper(inline) - if (index(trim(adjustl(inline)), "D")>0)then - do ik= 1, Nk3_unfold_point_mode - read(1001, *, end=3190, err=3190, iostat=stat)k3points_unfold_pointmode_direct(:, ik) - call direct_cart_rec_unfold(k3points_unfold_pointmode_direct(:, ik), & - k3points_unfold_pointmode_cart(:, ik)) - enddo - else - do ik= 1, Nk3_point_mode - read(1001, *, end=3190, err=3190, iostat=stat)k3points_unfold_pointmode_cart(:, ik) - call cart_direct_rec_unfold(k3points_unfold_pointmode_cart(:, ik), & - k3points_unfold_pointmode_direct(:, ik)) - enddo - endif - - 3190 continue - if (stat/=0 .and. cpuid==0) then - write(stdout, '(8f10.5)') "ERROR: there are something wrong in KPOINTS_FOLD_3D card" - write(stdout, '(8f10.5)') "It should be like this:" - write(stdout, '(8f10.5)') "The number of lines below 'Direct' " - write(stdout, '(8f10.5)') "should be the same as the number of k points" - write(stdout, '(8f10.5)') "KPOINTS_FOLD_3D" - write(stdout, '(8f10.5)') "4 ! number of k points" - write(stdout, '(8f10.5)') "Direct" - write(stdout, '(8f10.5)') "0.0 0.0 0.0" - write(stdout, '(8f10.5)') "0.5 0.0 0.0" - write(stdout, '(8f10.5)') "0.0 0.5 0.0" - write(stdout, '(8f10.5)') "0.0 0.0 0.5" - endif - - !> print out the set of kpoints' positions - if (cpuid==0) then - write(stdout, '(a)')" " - write(stdout, '(a)')"KPOINTS_FOLD_3D positions" - write(stdout, '(8a10)')"index", "kx", 'ky', 'kz', 'k1', 'k2', 'k3' - do ik=1, Nk3_unfold_point_mode - write(stdout, '(i8, 4x,8f10.5)')ik, k3points_unfold_pointmode_cart(:, ik)*Angstrom2atomic, & - k3points_unfold_pointmode_direct(:, ik) - enddo - write(stdout, '(a)')" " - endif - - 3210 continue - if (cpuid==0) write(stdout, *)' ' - if (.not. lfound) then - Nk3_unfold_point_mode = 1 - allocate(k3points_unfold_pointmode_cart(3, Nk3_unfold_point_mode)) - allocate(k3points_unfold_pointmode_direct(3, Nk3_unfold_point_mode)) - k3points_unfold_pointmode_cart= 0d0 - k3points_unfold_pointmode_direct= 0d0 - endif - if (.not.lfound.and.cpuid==0)write(stdout, *)'>> We use the default values for k3points_unfold_pointmode_direct=[0,0,0]' - if (.not.lfound.and.cpuid==0)write(stdout, *)'>> and Nk3_unfold_point_mode = 1' - - -!===============================================================================================================! -!> SINGLEKPOINT_2D card -!===============================================================================================================! - - !>> setting up a single k points in 2D BZ - Single_KPOINT_2D_CART= [0.d0, 0d0] - Single_KPOINT_2D_DIRECT= [0.d0, 0d0] - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 308)inline - inline=upper(inline) - if (trim(adjustl(inline))=='SINGLEKPOINT_2D') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found SINGLEKPOINT_2D card' - exit - endif - enddo - - read(1001, *, end=307, err=307, iostat=stat)inline ! The unit of lattice vector - inline=upper(inline) - DirectOrCart_SINGLE= trim(adjustl(inline)) - if (index(DirectOrCart_SINGLE, "D")>0)then - read(1001, *, end=307, err=307, iostat=stat)Single_KPOINT_2D_DIRECT(1:2) - else - stop " for SINGLEKPOINT_2D, we only support Direct coordinates" - endif - -307 continue - if (stat/=0 .and. cpuid==0) then - write(stdout, '(8f10.5)') "ERROR: there is something wrong in SINGLEKPOINT_2D card" - write(stdout, '(8f10.5)') "It should be like this:" - write(stdout, '(8f10.5)') "SINGLEKPOINT_2D" - write(stdout, '(8f10.5)') "Direct" - write(stdout, '(8f10.5)') "0.0 0.0" - endif - - !> print out the single kpoint positions - if (cpuid==0) then - write(stdout, '(a)')" " - write(stdout, '(a)')"SingleKPOINT_2D positions in fractional coordinates" - write(stdout, '(8a10)')'k1', 'k2', 'k3' - write(stdout, '(8f10.5)')Single_KPOINT_2D_DIRECT - write(stdout, '(a)')" " - endif - -308 continue - if (cpuid==0) write(stdout, *)' ' - if (.not.lfound.and.cpuid==0)write(stdout, *)'>> We use the default values for Single_KPOINT_2D_DIRECT=[0,0]' - - - -!===============================================================================================================! -!> SINGLEKPOINT_3D card -!===============================================================================================================! - - - !>> setting up a single k points in 3D BZ - Single_KPOINT_3D_CART= [0.d0, 0d0, 0d0] - Single_KPOINT_3D_DIRECT= [0.d0, 0d0, 0d0] - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 311)inline - inline=upper(inline) - if (trim(adjustl(inline))=='SINGLEKPOINT_3D') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found SINGLEKPOINT_3D card' - exit - endif - enddo - - read(1001, *, end=309, err=309, iostat=stat)inline ! The unit of lattice vector - inline=upper(inline) - DirectOrCart_SINGLE= trim(adjustl(inline)) - if (index(DirectOrCart_SINGLE, "D")>0)then - read(1001, *, end=309, err=309, iostat=stat)Single_KPOINT_3D_DIRECT(1:3) - call direct_cart_rec(Single_KPOINT_3D_DIRECT, Single_KPOINT_3D_CART) - else - read(1001, *, end=309, err=309, iostat=stat)Single_KPOINT_3D_CART(1:3) - call cart_direct_rec(Single_KPOINT_3D_CART, Single_KPOINT_3D_DIRECT) - endif - -309 continue - if (stat/=0 .and. cpuid==0) then - write(stdout, '(8f10.5)') "ERROR: there is something wrong in SINGLEKPOINT_3D card" - write(stdout, '(8f10.5)') "It should be like this:" - write(stdout, '(8f10.5)') "SINGLEKPOINT_3D" - write(stdout, '(8f10.5)') "Direct" - write(stdout, '(8f10.5)') "0.0 0.0 0.0" - endif - - !> print out the single kpoint positions - if (cpuid==0) then - write(stdout, '(a)')" " - write(stdout, '(a)')"Single_KPOINT_3D positions" - write(stdout, '(8a10)')"kx", 'ky', 'kz', 'k1', 'k2', 'k3' - write(stdout, '(8f10.5)') Single_KPOINT_3D_CART*Angstrom2atomic, Single_KPOINT_3D_DIRECT - write(stdout, '(a)')" " - endif - -311 continue - if (cpuid==0) write(stdout, *)' ' - if (.not.lfound.and.cpuid==0)write(stdout, *)'>> We use the default values for Single_KPOINT_3D_DIRECT=[0,0,0]' - - -!===============================================================================================================! -!> SURFACE_ATOMS card -!===============================================================================================================! - - !> setup the atoms on top and bottom surface that used for output the - !> surface-state spectrum - !> by default we output all the atoms' weight - NtopAtoms = Origin_cell%Num_atoms - NbottomAtoms= Origin_cell%Num_atoms - allocate(TopAtoms(NtopAtoms)) - allocate(BottomAtoms(NbottomAtoms)) - do i=1, NTopAtoms - TopAtoms(i)= i - enddo - do i=1, NBottomAtoms - BottomAtoms(i)= i - enddo - - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 112, err=116, iostat=stat)inline - inline=upper(inline) - if (trim(adjustl(inline))=='SURFACE_ATOMS') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found SURFACE_ATOMS card' - exit - endif - enddo - if (allocated(TopAtoms))deallocate(TopAtoms) - allocate(TopAtoms(1)) - read(1001, '(A)', end= 112, err=116, iostat=stat)inline - !> first count howmany values - call param_get_range_vector('TOPATOMS',inline,NTopAtoms,.true., TOPATOMS) - if (allocated(TopAtoms))deallocate(TopAtoms) - allocate(TopAtoms(NTopAtoms)) - !> then get values - call param_get_range_vector('TOPATOMS',inline,NTopAtoms,.false., TopAtoms) - - - if (allocated(BottomAtoms))deallocate(BottomAtoms) - allocate(BottomAtoms(1)) - read(1001, '(A)', end= 112, err=116, iostat=stat)inline - !> first count howmany values - call param_get_range_vector('BOTTOMATOMS',inline,NBottomAtoms,.true., BottomAtoms) - if (allocated(BottomAtoms))deallocate(BottomAtoms) - allocate(BottomAtoms(NBottomAtoms)) - !> then get values - call param_get_range_vector('BOTTOMATOMS',inline,NBottomAtoms,.false., BottomAtoms) - - !> error happens when reading SURFACE_ATOMS -116 if (stat/=0 .and. cpuid==0) then - write(stdout, '(a)')'>>> ERROR: There are something wrong with the SURFACE_ATOMS card' - write(stdout, '(a)')' It should like this:' - write(stdout, '(a)')'SURFACE_ATOMS ' - write(stdout, '(a)')"1 3 ! top surface's atom index '" - write(stdout, '(a)')"2 4 ! bottom surface's atom index '" - endif - - -112 continue - if (.not.lfound.and.cpuid==0)write(stdout, *)'>> Output all atoms weight for surface state spectrum' - if (cpuid==0) write(stdout, *)'> NtopAtoms ', NtopAtoms - if (cpuid==0) write(stdout, '(a)')'> TopAtoms ' - if (cpuid==0) write(stdout, '(10i6)')TopAtoms - if (cpuid==0) write(stdout, '(a, i10)')'> NbottomAtoms ', NbottomAtoms - if (cpuid==0) write(stdout, '(a)')'> BottomAtoms ' - if (cpuid==0) write(stdout, '(10i6)')BottomAtoms - - NtopOrbitals=0 - do i=1, NTopAtoms - NtopOrbitals= NtopOrbitals+ Origin_cell%nprojs(TopAtoms(i)) - enddo - if (SOC>0) NtopOrbitals= NtopOrbitals*2 - allocate(TopOrbitals(NtopOrbitals)) - TopOrbitals= 1 - - !> set up top surface orbitals for output the surface spectrum - io=0 - do i=1, NTopAtoms - do j=1, Origin_cell%nprojs(TopAtoms(i)) - io =io+ 1 - TopOrbitals(io)= orbitals_start(TopAtoms(i))+ j- 1 - if (SOC>0)TopOrbitals(io+ NtopOrbitals/2 )= orbitals_start(TopAtoms(i))+ j- 1+ NumberOfspinorbitals/2 - enddo ! j - enddo ! i - - NBottomOrbitals=0 - do i=1, NBottomAtoms - NBottomOrbitals= NBottomOrbitals+ Origin_cell%nprojs(BottomAtoms(i)) - enddo - if (SOC>0) NBottomOrbitals= NBottomOrbitals*2 - allocate(BottomOrbitals(NBottomOrbitals)) - BottomOrbitals= 1 - - !> set up Bottom surface orbitals for output the surface spectrum - io=0 - do i=1, NBottomAtoms - do j=1, Origin_cell%nprojs(BottomAtoms(i)) - io =io+ 1 - BottomOrbitals(io)= orbitals_start(BottomAtoms(i))+ j- 1 - if (SOC>0)BottomOrbitals(io+ NBottomOrbitals/2)= orbitals_start(BottomAtoms(i))+ j- 1+ NumberOfspinorbitals/2 - enddo ! j - enddo ! i - - if (cpuid==0) write(stdout, *)'> NtopOrbitals ', NtopOrbitals - if (cpuid==0) write(stdout, '(a)')'> TopOrbitals ' - if (cpuid==0) write(stdout, '(10i6)')TopOrbitals - if (cpuid==0) write(stdout, '(a,999i4)')'> NBottomOrbitals ', NBottomOrbitals - if (cpuid==0) write(stdout, '(a)')'> BottomOrbitals ' - if (cpuid==0) write(stdout, '(10i6)')BottomOrbitals - -!===============================================================================================================! -!> NL_CHIRALITY card -!===============================================================================================================! - - - !> setup for Weyl points chirality calculation - !> default - Num_NLs= 0 ! in unit of 1/Ang - Rbig_NL= 0d0 - rsmall_a_NL= 0d0 - rsmall_b_NL= 0d0 - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 211)inline - inline=upper(inline) - if (trim(adjustl(inline))=='NL_CHIRALITY') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found NL_CHIRALITY card' - exit - endif - enddo - - read(1001, *, end=219, err=219)Num_NLs - allocate(NL_center_position_cart(3, Num_NLs)) - allocate(NL_center_position_direct(3, Num_NLs)) - NL_center_position_cart= 0d0 - NL_center_position_direct= 0d0 - read(1001, *, end=219, err=219)inline ! The unit of lattice vector - inline=upper(inline) - DirectOrCart_NL= trim(adjustl(inline)) - read(1001, *, end=219, err=219)Rbig_NL, rsmall_a_NL, rsmall_b_NL - it= 0 - do i=1, Num_NLs - if (index(DirectOrCart_NL, "D")>0)then - read(1001, *, end=219, err=219)NL_center_position_direct(:, i) - call direct_cart_rec(NL_center_position_direct(:, i), NL_center_position_cart(:, i)) - it = it+ 1 - else - read(1001, *, end=219, err=219)NL_center_position_cart(:, i) - call cart_direct_rec(NL_center_position_cart(:, i), NL_center_position_direct(:, i)) - it = it+ 1 - endif - enddo - -219 continue - - !> print out the Weyl positions - if (cpuid==0.and.lfound) then - write(stdout, '(a)')" " - write(stdout, '(a)')"Nodal Line center positions" - write(stdout, '(8a10)')"kx", 'ky', 'kz', 'k1', 'k2', 'k3' - do i=1, Num_NLs - write(stdout, '(8f10.5)')NL_center_position_cart(:, i)*Angstrom2atomic, NL_center_position_direct(:, i) - enddo - - write(stdout, '(a)')" " - endif - - - if (it< Num_NLs.and.cpuid==0) then - write(stdout, *)' Error: Num_NLs should the same as ', & - ' the number of weyl position lines' - write(stdout, *)' Num_NLs = ', Num_NLs - write(stdout, *)' Num of pos lines = ', it - stop - endif - -211 continue - if (cpuid==0) write(stdout, *)' ' - if (.not.lfound.and.cpuid==0)write(stdout, *)'>> We do not calculate chirality for nodal lines' - if (.not.lfound.and.NLChirality_calc.and.cpuid==0) then - write(stdout, *) 'ERROR: you should specify the NL_CHIRALITY card, see documentation' - endif - - - !> setup for Weyl points chirality calculation - !> default - Num_Weyls= 0 ! in unit of 1/Ang - kr0=0 - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 111)inline - inline=upper(inline) - if (trim(adjustl(inline))=='WEYL_CHIRALITY') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found WEYL_CHIRALITY card' - exit - endif - enddo - - read(1001, *, end=209, err=209)Num_Weyls - allocate(weyl_position_direct(3, Num_Weyls)) - allocate(weyl_position_cart(3, Num_Weyls)) - weyl_position_direct= 0d0 - weyl_position_cart= 0d0 - read(1001, *, end=209, err=209)inline ! The unit of lattice vector - inline=upper(inline) - DirectOrCart_Weyl= trim(adjustl(inline)) - read(1001, *, end=209, err=209)kr0 - it= 0 - do i=1, Num_Weyls - if (index(DirectOrCart_Weyl, "D")>0)then - read(1001, *, end=209, err=209)weyl_position_direct(:, i) - call direct_cart_rec(weyl_position_direct(:, i), weyl_position_cart(:, i)) - it = it+ 1 - else - read(1001, *, end=209, err=209)weyl_position_cart(:, i) - weyl_position_cart(:, i) = weyl_position_cart(:, i)/Angstrom2atomic - call cart_direct_rec(weyl_position_cart(:, i), weyl_position_direct(:, i)) - it = it+ 1 - endif - enddo - -209 continue - - !> print out the Weyl positions - if (cpuid==0.and.lfound) then - write(stdout, '(a)')" " - write(stdout, '(a)')"Weyl point positions" - write(stdout, '(8a10)')"kx", 'ky', 'kz', 'k1', 'k2', 'k3' - do i=1, Num_Weyls - write(stdout, '(8f10.5)')weyl_position_cart(:, i)*Angstrom2atomic, weyl_position_direct(:, i) - enddo - - write(stdout, '(a)')" " - endif - - - if (it< Num_Weyls.and.cpuid==0) then - write(stdout, *)' Error: Num_Weyls should the same as ', & - ' the number of weyl position lines' - write(stdout, *)' Num_Weyls = ', Num_Weyls - write(stdout, *)' Num of pos lines = ', it - stop - endif - -111 continue - if (cpuid==0) write(stdout, *)' ' - if (.not.lfound.and.cpuid==0)write(stdout, *)'>> We do not calculate chirality for weyl points' - if (.not.lfound.and.WeylChirality_calc.and.cpuid==0) then - write(stdout, *) 'ERROR: you should specify the WEYL_CHIRALITY card, see documentation' - endif - -!===============================================================================================================! -!> SELECTED_ATOMS card -!===============================================================================================================! - -! SELECTED_ATOMS -! 2 ! NumberofSelectedAtoms_groups -! 1-3 8 ! atom indicies of group 1 -! 4-6 9 ! atom indicies of group 2 - - - !>> parameters for SelectedAtoms - !> this part is useful for surfstat or other slab or bulk band stOrigin_cell%Ructure calculations - rewind(1001) - lfound = .false. - stat=0 - do while (.true.) - read(1001, *, end= 332)inline - inline=upper(inline) - if (trim(adjustl(inline))=='SELECTED_ATOMS'.OR.trim(adjustl(inline))=='SELECTEDATOMS') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found SELECTED_ATOMS card' - exit - endif - enddo - - it= 0 - stat= 0 - NumberofSelectedAtoms_groups= 0 - read(1001, *, err=332, iostat=stat)NumberofSelectedAtoms_groups - allocate(NumberofSelectedAtoms(NumberofSelectedAtoms_groups)) - allocate(Selected_Atoms(NumberofSelectedAtoms_groups)) - do i=1, NumberofSelectedAtoms_groups - read(1001, '(A)', err=332, iostat=stat)inline - idummy=1 - if (allocated(Selected_Atoms(i)%iarray))deallocate(Selected_Atoms(i)%iarray) - allocate(Selected_Atoms(i)%iarray(1)) - - !> first count howmany atoms for each line - call param_get_range_vector('SelectedAtoms',inline,idummy,.true., Selected_Atoms(i)%iarray) - NumberofSelectedAtoms(i)=idummy - Selected_Atoms(i)%length=idummy - if (idummy>0) then - if (allocated(Selected_Atoms(i)%iarray))deallocate(Selected_Atoms(i)%iarray) - allocate(Selected_Atoms(i)%iarray(idummy)) - !> then get values - call param_get_range_vector('SelectedAtoms',inline,idummy,.false., Selected_Atoms(i)%iarray) - else - stop 'NumberofSelectedAtoms should be an integer and larger than zero' - endif - enddo - -332 continue - if (stat/=0) then - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, '(a)')'Error: Please set the right number of atoms in wt.in like this:' - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, '(a)')'SELECTED_ATOMS' - if (cpuid==0) write(stdout, '(a)')'2 ! number of groups' - if (cpuid==0) write(stdout, '(a)')'1 2-4 ! atomic indices ' - if (cpuid==0) write(stdout, '(a)')'3 5 ! atomic indices ' - stop 'Errors happen in the WT.in, please check informations in the WT.out' - endif - - !> setup SelectedAtoms if not specified by wt.in - if (.not.allocated(Selected_Atoms)) then - NumberofSelectedAtoms_groups=1 - allocate(NumberofSelectedAtoms(NumberofSelectedAtoms_groups)) - allocate(Selected_Atoms(NumberofSelectedAtoms_groups)) - allocate(Selected_Atoms(1)%iarray(Origin_cell%Num_atoms)) - NumberofSelectedAtoms(1)=Origin_cell%Num_atoms - Selected_Atoms(1)%length=Origin_cell%Num_atoms - do ia=1, Origin_cell%Num_atoms - Selected_Atoms(1)%iarray(ia)= ia - enddo - endif - - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, '(a,i4,a)')'>> There are ', NumberofSelectedAtoms_groups, ' groups of SelectedAtoms' - do i=1, NumberofSelectedAtoms_groups - if (cpuid==0) write(stdout, '(a, i3)')'Group : ', i - if (cpuid==0) write(stdout, '(a, 3i10)')'>> Number of atoms selected', & - NumberofSelectedAtoms(i) - if (cpuid==0) write(stdout, '(a)')'>> Selected atoms are' - if (cpuid==0) write(stdout, '(10(i5, 2X, a))') & - (Selected_Atoms(i)%iarray(ia), Origin_cell%atom_name(Selected_Atoms(i)%iarray(ia)), ia=1, NumberofSelectedAtoms(i)) - enddo - -!===============================================================================================================! -!> SELECTEDWANNIERORBITALS card -!===============================================================================================================! - - !>> parameters for selectedorbitals - !> this part is useful for surfstat or other slab or bulk band stOrigin_cell%Ructure calculations - rewind(1001) - lfound = .false. - stat=0 - do while (.true.) - read(1001, *, end= 331)inline - inline=upper(inline) - if (trim(adjustl(inline))=='SELECTED_WANNIERORBITALS'.or.trim(adjustl(inline))=='SELECTEDWANNIERORBITALS') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found SELECTED_WANNIERORBITALS card' - exit - endif - enddo - - it= 0 - stat= 0 - NumberofSelectedOrbitals_groups= 0 - read(1001, *, err=332, iostat=stat)NumberofSelectedOrbitals_groups - allocate(Selected_WannierOrbitals(NumberofSelectedOrbitals_groups)) - allocate(NumberofSelectedOrbitals(NumberofSelectedOrbitals_groups)) - - do i=1, NumberofSelectedOrbitals_groups - read(1001, '(A)', err=332, iostat=stat)inline - !> first count howmany orbitals selected - idummy= 1 - if (allocated(Selected_WannierOrbitals(i)%iarray))deallocate(Selected_WannierOrbitals(i)%iarray) - allocate(Selected_WannierOrbitals(i)%iarray(1)) - - call param_get_range_vector('SelectedOrbitals',inline,idummy,.true., Selected_WannierOrbitals(i)%iarray) - NumberofSelectedOrbitals(i)= idummy - Selected_WannierOrbitals(i)%length= idummy - - if (NumberofSelectedOrbitals(i)>0) then - if (allocated(Selected_WannierOrbitals(i)%iarray))deallocate(Selected_WannierOrbitals(i)%iarray) - allocate(Selected_WannierOrbitals(i)%iarray(idummy)) - - !> then get values - call param_get_range_vector('SelectedOrbitals',inline,idummy,.false., Selected_WannierOrbitals(i)%iarray) - else - stop 'NumberofSelectedOrbitals should be an integer and larger than zero' - endif - enddo - -331 continue - if (stat/=0) then - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, '(a)')'Error: Please set the right number of orbitals and orbitals in wt.in like this:' - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, '(a)')'SELECTED_WANNIERORBITALS' - if (cpuid==0) write(stdout, '(a)')'2 ! number of groups of selectedorbitals' - if (cpuid==0) write(stdout, '(a)')'1-3 ! orbitals indices ' - if (cpuid==0) write(stdout, '(a)')'4-7 ! orbitals indices ' - stop 'Errors happen in the WT.in, please check informations in the WT.out' - endif - - - !> setup SelectedOrbitals if not specified by wt.in - !> by default we take the orbitals associated with Selected_Atoms - if (.not.allocated(Selected_WannierOrbitals)) then - NumberofSelectedOrbitals_groups= NumberofSelectedAtoms_groups - allocate(NumberofSelectedOrbitals(NumberofSelectedAtoms_groups)) - allocate(Selected_WannierOrbitals(NumberofSelectedAtoms_groups)) - NumberofSelectedOrbitals= 0 - - do ig=1, NumberofSelectedOrbitals_groups - do i=1, NumberofSelectedAtoms(ig) - ia = Selected_Atoms(ig)%iarray(i) - NumberofSelectedOrbitals(ig)= NumberofSelectedOrbitals(ig)+ Origin_cell%nprojs(ia) - enddo - if (SOC>0) NumberofSelectedOrbitals(ig)= NumberofSelectedOrbitals(ig)*2 - - allocate(Selected_WannierOrbitals(ig)%iarray(NumberofSelectedOrbitals(ig))) - Selected_WannierOrbitals(ig)%iarray = 0 - io= 0 - do i=1, NumberofSelectedAtoms(ig) - ia = Selected_Atoms(ig)%iarray(i) - do j=1, Origin_cell%nprojs(ia) - io = io+ 1 - Selected_WannierOrbitals(ig)%iarray(io)= index_start(ia)+ j- 1 - enddo - enddo - if (SOC>0) then - do i=1, NumberofSelectedAtoms(ig) - ia = Selected_Atoms(ig)%iarray(i) - do j=1, Origin_cell%nprojs(ia) - io = io+ 1 - Selected_WannierOrbitals(ig)%iarray(io)=index_start(ia)+ j+ NumberOfspinorbitals/2- 1 - enddo - enddo - endif - enddo ! groups - endif - - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, '(a,i3,a)')'>> There are ', NumberofSelectedOrbitals_groups, ' groups of SelectedOrbitals' - do ig=1, NumberofSelectedOrbitals_groups - if (cpuid==0) write(stdout, *)'>> SelectedOrbitals' - if (cpuid==0) write(stdout, '(a, 3i10)')'>> Number of orbitals selected (exclude spin degenarcy)', & - NumberofSelectedOrbitals(ig) - if (cpuid==0) write(stdout, '(a)')'>> Orbitals are' - if (cpuid==0) write(stdout, '(12i8)')Selected_WannierOrbitals(ig)%iarray(:) - enddo - -!===============================================================================================================! -!> SELECTED_OCCUPIEDBANDS card -!===============================================================================================================! - - !> parameters for selectedOccupiedBands - rewind(1001) - lfound = .false. - stat=0 - do while (.true.) - read(1001, *, end= 232)inline - inline=upper(inline) - if (trim(adjustl(inline))=='SELECTED_OCCUPIEDBANDS' .or.& - trim(adjustl(inline))=='SELECTED_OCCUPIED_BANDS'.or.& - trim(adjustl(inline))=='SELECTEDOCCUPIEDBANDS') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found SELECTED_OCCUPIED_BANDS card' - exit - endif - enddo - - it= 0 - stat= 0 - NumberofSelectedOccupiedBands= 0 - read(1001, '(A)', err=232, iostat=stat)inline - !> get howmany integer numbers specified in the inline string - call param_get_range_vector('SelectedOccupiedBands',inline,idummy,.true., Selected_Occupiedband_index) - NumberofSelectedOccupiedBands= idummy - - if (NumberofSelectedOccupiedBands>0) then - allocate(Selected_Occupiedband_index(NumberofSelectedOccupiedBands)) - Selected_Occupiedband_index= 0 - call param_get_range_vector('SelectedOccupiedBands',inline,idummy,.false., Selected_Occupiedband_index) - else - stop 'NumberofSelectedOccupiedBands should be an integer and larger than zero' - endif - -232 continue - if (stat/=0) then - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, '(a)')'Error: Please set the right number of bands and band indices in wt.in like this:' - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, '(a)')'SELECTED_OCCUPIED_BANDS' - if (cpuid==0) write(stdout, '(a)')'4-7 ! band indices ' - stop 'Errors happen in the WT.in, please check informations in the WT.out' - endif - - !> setup SELECTEDOccupiedBANDS - !> if not given SELECTED_OCCUPIED_BANDS section, we will use NumOccupied as the inputs - if (.not.allocated(Selected_Occupiedband_index))then - NumberofSelectedOccupiedBands= NumOccupied - allocate(Selected_Occupiedband_index(NumberofSelectedOccupiedBands)) - do i=1, NumberofSelectedOccupiedBands - Selected_Occupiedband_index(i)= i - enddo - endif - - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'>> SELECTED_OCCUPIED_BANDS' - if (cpuid==0) write(stdout, '(a, 3i10)')'>> Number of Occupied bands selected ', & - NumberofSelectedOccupiedBands - if (cpuid==0) write(stdout, '(a)')'>> OccupiedBand indices are' - if (cpuid==0) write(stdout, '(12i6)')Selected_Occupiedband_index(:) - if (cpuid==0) write(stdout, *) ' ' - -!===============================================================================================================! -!> SELECTEDBANDS card -!===============================================================================================================! - - !> parameters for selectedbands - rewind(1001) - lfound = .false. - stat=0 - do while (.true.) - read(1001, *, end= 231)inline - inline=upper(inline) - if (trim(adjustl(inline))=='SELECTED_BANDS'.or.trim(adjustl(inline))=='SELECTEDBANDS') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found SELECTED_BANDS card' - exit - endif - enddo - - it= 0 - stat= 0 - NumberofSelectedBands= 0 - read(1001, *, err=231, iostat=stat)NumberofSelectedBands - - if (NumberofSelectedBands>0) then - allocate(Selected_band_index(NumberofSelectedBands)) - Selected_band_index= 0 - read(1001, *, err=231, iostat=stat) (Selected_band_index(i), i=1, NumberofSelectedBands) - else - stop 'NumberofSelectedBands should be an integer and larger than zero' - endif - -231 continue - if (stat/=0) then - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, '(a)')'Error: Please set the right number of bands and band indices in wt.in like this:' - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, '(a)')'SELECTED_BANDS' - if (cpuid==0) write(stdout, '(a)')'4 ! number of selected bands' - if (cpuid==0) write(stdout, '(a)')'4 5 6 7 ! band indices ' - stop 'Errors happen in the WT.in, please check informations in the WT.out' - endif - - !> setup SELECTEDBANDS - if (.not.allocated(Selected_band_index))then - NumberofSelectedBands= NumberOfspinorbitals - allocate(Selected_band_index(NumberofSelectedBands)) - do i=1, NumberOfspinorbitals - Selected_band_index(i)= i - enddo - endif - - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'>> SELECTEDBANDS' - if (cpuid==0) write(stdout, '(a, 3i10)')'>> Number of bands selected ', & - NumberofSelectedBands - if (cpuid==0) write(stdout, '(a)')'>> Band indices are' - if (cpuid==0) write(stdout, '(12i6)')Selected_band_index(:) - if (cpuid==0) write(stdout, *) ' ' - - -!===============================================================================================================! -!> TBTOKP card -!===============================================================================================================! - - - !> parameters for tbtokp - Num_selectedbands_tbtokp = 0 - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 220)inline - inline=upper(inline) - if (trim(adjustl(inline))=='TBTOKP') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found TBTOKP card' - exit - endif - enddo - - it= 0 - stat= 0 - Num_selectedbands_tbtokp= 0 - k_tbtokp= 0d0 - read(1001, *, err=220, iostat=stat)Num_selectedbands_tbtokp - if (Num_selectedbands_tbtokp==0 .and. TBtoKP_calc) then - stop 'Num_selectedbands_tbtokp should be an integer which is larger than zero if TBtoKP_calc=T' - endif - - if (Num_selectedbands_tbtokp>0) then - allocate(Selected_bands_tbtokp(Num_selectedbands_tbtokp)) - Selected_bands_tbtokp= 0 - read(1001, *, err=220, iostat=stat) (Selected_bands_tbtokp(i), i=1, Num_selectedbands_tbtokp) - else - stop 'Num_selectedbands_tbtokp should be larger than zero' - endif - read(1001, *, err=220, iostat=stat) k_tbtokp - - if (cpuid==0) write(stdout, *)' ' - if (.not.lfound.and.cpuid==0)write(stdout, *)'>>We donot constOrigin_cell%Ruct kp model.' - if (cpuid==0) write(stdout, '(a, i10)')'>> Number of bands selected for kp model', & - Num_selectedbands_tbtokp - if (cpuid==0) write(stdout, '(a)')'>> Band indices are' - if (cpuid==0) write(stdout, '(10i5)')Selected_bands_tbtokp(:) - if (cpuid==0) write(stdout, '(a, 3f10.6)')'k point to constOrigin_cell%Ruct kp model in fractional coordinates', k_tbtokp - -220 continue - if (stat/=0) then - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, '(a)')'Error: Please set the right number of bands and band indices in wt.in like this:' - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, '(a)')'TBTOKP' - if (cpuid==0) write(stdout, '(a)')'8 ! number of selected bands to constOrigin_cell%Ruct kp model' - if (cpuid==0) write(stdout, '(a)')'1 2 3 4 5 6 7 8 ! band indices ' - if (cpuid==0) write(stdout, '(a)')'0 0 0 ! k point in fractional coordinates ' - stop 'Errors happen in the WT.in, please check informations in the WT.out' - endif - -!===============================================================================================================! -!> ATOM_MASS card -!===============================================================================================================! - - !> for phonon system, LO-TO correction, by T.T Zhang - !> Atomic MASS in unit of g/mol - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 221)inline - inline=upper(inline) - if (trim(adjustl(inline))=='ATOM_MASS') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found ATOM_MASS card' - exit - endif - enddo -221 continue - - if (lfound) then - read(1001,*)Origin_cell%Num_atom_type - if(cpuid==0)write(stdout,'(a,i10,a)')'There are', Origin_cell%Num_atom_type, 'kind of atoms' - if (.not.allocated(Origin_cell%Num_atoms_eachtype))allocate(Origin_cell%Num_atoms_eachtype(Origin_cell%Num_atom_type)) - allocate(mass_temp(Origin_cell%Num_atom_type)) - allocate(ATOM_MASS(Origin_cell%Num_atoms)) - read(1001,*)Origin_cell%Num_atoms_eachtype(1:Origin_cell%Num_atom_type) - read(1001,*)mass_temp(1:Origin_cell%Num_atom_type) - do i= 1, Origin_cell%Num_atom_type - if (cpuid==0)write(stdout,'(a,i10,a)')'Each type have', Origin_cell%Num_atoms_eachtype(i), ' atoms' - if (cpuid==0)write(stdout,'(a,f12.6)')'And their mass is', mass_temp(i) - enddo - it=0 - do i=1, Origin_cell%Num_atom_type - do j=1, Origin_cell%Num_atoms_eachtype(i) - it=it+1 - ATOM_MASS(it)=mass_temp(i) - enddo - enddo - else - if (LOTO_correction)stop "ERROR: please set ATOM_MASS card for LOTO correction of phonon spectrum" - endif - - !>> setup Dielectric tensor for a given material - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 222)inline - inline=upper(inline) - if (trim(adjustl(inline))=='LOTO_DT') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found LOTO_DT card for LOTO correction' - exit - endif - enddo -222 continue - - if (lfound) then - read(1001, *)Diele_Tensor(1,:) ! Diele_Tensor is a 3*3 tensor for a material - if (cpuid==0)write(stdout,'(a,3f12.5)')'Diele_tensor(1,:)',Diele_Tensor(1,:) - read(1001, *)Diele_Tensor(2,:) - if (cpuid==0)write(stdout,'(a,3f12.5)')'Diele_tensor(2,:)',Diele_Tensor(2,:) - read(1001, *)Diele_Tensor(3,:) - if (cpuid==0)write(stdout,'(a,3f12.5)')'Diele_tensor(3,:)',Diele_Tensor(3,:) - else - if (LOTO_correction) then - if (cpuid==0) then - write(stdout, *)"ERROR: please set LOTO_DT card for LOTO correction of phonon spectrum" - write(stdout, *)"ERROR: please set Dielectronic Tensor information" - stop "ERROR: Check error messages in WT.out" - endif - endif - endif - - !>> setup Born charge for a given material - rewind(1001) - lfound = .false. - do while (.true.) - read(1001, *, end= 223)inline - inline=upper(inline) - if (trim(adjustl(inline))=='LOTO_BC') then - lfound= .true. - if (cpuid==0) write(stdout, *)' ' - if (cpuid==0) write(stdout, *)'We found LOTO_BC card for LOTO correction' - exit - endif - enddo -223 continue - - if (lfound) then - it=0 - allocate(Born_Charge(Origin_cell%Num_atoms,3,3)) - allocate(Born_Charge_temp(Origin_cell%Num_atom_type,3,3)) - do i=1,Origin_cell%Num_atom_type - read(1001, *)Born_Charge_temp(i,1,:) - read(1001, *)Born_Charge_temp(i,2,:) - read(1001, *)Born_Charge_temp(i,3,:) - do j=1,Origin_cell%Num_atoms_eachtype(i) - it=it+1 - Born_Charge(it,:,:)=Born_Charge_temp(i,:,:) - if (cpuid==0) then - write(stdout,'(a,i3,2X,a6)')'Born_Charge for atom ', it, Origin_cell%atom_name(it) - write(stdout,'(3f12.5)')Born_Charge(it,1,:) - write(stdout,'(3f12.5)')Born_Charge(it,2,:) - write(stdout,'(3f12.5)')Born_Charge(it,3,:) - endif - enddo - enddo - else - if (LOTO_correction) then - if (cpuid==0) then - write(stdout, *)"ERROR: please set LOTO_BC card for LOTO correction of phonon spectrum" - write(stdout, *)"ERROR: please set Born charge information" - stop "ERROR: Check error messages in WT.out" - endif - endif - endif - - ! build the map between supercell (Origin_cell) and primitive cell (Folded_cell) - if (BulkBand_unfold_line_calc.or.BulkBand_unfold_plane_calc.or.QPI_unfold_plane_calc.or.Landaulevel_unfold_line_calc)then - call build_map_supercell_primitivecell - endif - - !> close wt.in - close(1001) - - eta=(omegamax- omegamin)/omeganum*2d0 - - if(cpuid==0)write(stdout,*)'<<= 'a'.AND.ch <= 'z') ch = CHAR(ICHAR(ch)+DUC) - s2(i:i) = ch - enddo - end function upper - -end subroutine readinput - - - !> rotate a vector in unit of the original lattice vector into the new lattice - !> vector defined by Umatrix -subroutine rotate_newlattice(R1, R2) - use para, only : dp, Umatrix - implicit none - real(dp), intent(in) :: R1(3) - real(dp), intent(inout) :: R2(3) - real(dp), allocatable :: Umatrix_inv(:, :) - - allocate(Umatrix_inv(3, 3)) - Umatrix_inv= Umatrix - - call inv_r(3, Umatrix_inv) - - R2(1)= Umatrix_inv(1, 1)*R1(1)+ Umatrix_inv(2, 1)*R1(2)+ Umatrix_inv(3, 1)*R1(3) - R2(2)= Umatrix_inv(1, 2)*R1(1)+ Umatrix_inv(2, 2)*R1(2)+ Umatrix_inv(3, 2)*R1(3) - R2(3)= Umatrix_inv(1, 3)*R1(1)+ Umatrix_inv(2, 3)*R1(2)+ Umatrix_inv(3, 3)*R1(3) - - deallocate(Umatrix_inv) - - return -end subroutine rotate_newlattice - - -subroutine set_kcube3d - use para - implicit none - - integer :: knv3, knv3_mod - integer :: ik, ik1, ik2, ik3 - - !> Distribute k kpoints in the 3DCube into different MPI threads - knv3= Nk1*Nk2*NK3 - KCube3D%Nk_total= knv3 - knv3_mod= mod(knv3, num_cpu) - if (knv3_mod==0) then !> perfect divided - KCube3D%Nk_current= knv3/num_cpu - KCube3D%Nk_start=1+ knv3*cpuid/num_cpu - KCube3D%Nk_end =(1+cpuid)*knv3/num_cpu - else if (knv3/num_cpu==0) then !> Number of MPI threads is large than knv3 - KCube3D%Nk_current= 1 !> one k piont per MPI thread - KCube3D%Nk_start= cpuid+ 1 !> one k piont per MPI thread - KCube3D%Nk_end = cpuid+ 1 - if (cpuid+1 > knv3) then - KCube3D%Nk_start= 1 - KCube3D%Nk_end = 0 - endif - else - KCube3D%Nk_current= knv3/num_cpu+ 1 - if (cpuid< knv3_mod) then - KCube3D%Nk_start= 1+ cpuid*KCube3D%Nk_current - KCube3D%Nk_end = (1+cpuid)*KCube3D%Nk_current - else - KCube3D%Nk_start= knv3_mod*KCube3D%Nk_current+ & - (cpuid-knv3_mod)*(KCube3D%Nk_current-1)+1 - KCube3D%Nk_end = knv3_mod*KCube3D%Nk_current+ & - (cpuid-knv3_mod+1)*(KCube3D%Nk_current-1) - endif - endif - - !> calculate the volume of the k cube - - if (allocated(KCube3D%k_direct))deallocate(KCube3D%k_direct) - allocate(KCube3D%k_direct(3, KCube3D%Nk_start:KCube3D%Nk_end)) - - do ik= KCube3D%Nk_start, KCube3D%Nk_end - ik1= (ik-1)/(Nk2*Nk3)+1 - ik2= ((ik-1-(ik1-1)*Nk2*Nk3)/Nk3)+1 - ik3= (ik-(ik2-1)*Nk3- (ik1-1)*Nk2*Nk3) - KCube3D%k_direct(:, ik)= K3D_start_cube+ K3D_vec1_cube*(ik1-1)/dble(Nk1) & - + K3D_vec2_cube*(ik2-1)/dble(Nk2) & - + K3D_vec3_cube*(ik3-1)/dble(Nk3) - enddo - -end subroutine set_kcube3d - -!> rotate a vector to the new coordinate system -!> rotate the vector from the original coordinate to the new coordinate -!> which defined like this: x is along R1', z is along R1'xR2', y is along z x y -!> Urot is a matrix linking the old coordinate and the new coordinate -subroutine rotate(R1, R2) - use para, only : dp, Urot - implicit none - real(dp), intent(in) :: R1(3) - real(dp), intent(inout) :: R2(3) - - R2(1)= Urot(1, 1)*R1(1)+ Urot(1, 2)*R1(2)+ Urot(1, 3)*R1(3) - R2(2)= Urot(2, 1)*R1(1)+ Urot(2, 2)*R1(2)+ Urot(2, 3)*R1(3) - R2(3)= Urot(3, 1)*R1(1)+ Urot(3, 2)*R1(2)+ Urot(3, 3)*R1(3) - - return -end subroutine rotate - - -!> transform from Cartesian coordinates to direct lattice vector basis for the magnetic cell -subroutine cart_direct_real_magneticcell(R1, R2) - use para, only : dp, Magnetic_cell - implicit none - real(dp), intent(in) :: R1(3) - real(dp), intent(inout) :: R2(3) - real(dp), allocatable :: mata(:, :) - - allocate(mata(3, 3)) - - mata(1, :)= Magnetic_cell%Rua - mata(2, :)= Magnetic_cell%Rub - mata(3, :)= Magnetic_cell%Ruc - - call inv_r(3, mata) - R2= R1(1)*mata(1, :)+ R1(2)*mata(2, :)+ R1(3)*mata(3, :) - - deallocate(mata) - - return -end subroutine cart_direct_real_magneticcell - - - -!> transform from Cartesian coordinates to direct lattice vector basis for the newcell defined by SURFACE card -subroutine cart_direct_real_newcell(R1, R2) - use para - implicit none - real(dp), intent(in) :: R1(3) - real(dp), intent(inout) :: R2(3) - real(dp), allocatable :: mata(:, :) - - allocate(mata(3, 3)) - - mata(1, :)= Rua_newcell - mata(2, :)= Rub_newcell - mata(3, :)= Ruc_newcell - - call inv_r(3, mata) - R2= R1(1)*mata(1, :)+ R1(2)*mata(2, :)+ R1(3)*mata(3, :) - - deallocate(mata) - - return -end subroutine cart_direct_real_newcell - - - !> transform from Cartesian coordinates to direct lattice vector basis -subroutine cart_direct_real_unfold(R1, R2) - use para - implicit none - real(dp), intent(in) :: R1(3) - real(dp), intent(inout) :: R2(3) - real(dp), allocatable :: mata(:, :) - - allocate(mata(3, 3)) - - mata(1, :)= Folded_cell%Rua - mata(2, :)= Folded_cell%Rub - mata(3, :)= Folded_cell%Ruc - - call inv_r(3, mata) - R2= R1(1)*mata(1, :)+ R1(2)*mata(2, :)+ R1(3)*mata(3, :) - - deallocate(mata) - - return -end subroutine cart_direct_real_unfold - - - - !> transform from Cartesian coordinates to direct lattice vector basis -subroutine cart_direct_real(R1, R2, lattice) - use para, only : dp - implicit none - real(dp), intent(in) :: R1(3) - real(dp), intent(inout) :: R2(3) - real(dp), intent(in) :: lattice(3, 3) - real(dp), allocatable :: mata(:, :) - - allocate(mata(3, 3)) - - mata= transpose(lattice) - - call inv_r(3, mata) - R2= R1(1)*mata(1, :)+ R1(2)*mata(2, :)+ R1(3)*mata(3, :) - - deallocate(mata) - - return -end subroutine cart_direct_real - - !> transform from direct lattice vector basis to Cartesian coordinates for the newcell defined by SURFACE card -subroutine direct_cart_real_newcell(R1, R2) - use para, only : dp, Rua_newcell, Rub_newcell, Ruc_newcell - implicit none - real(dp), intent(in) :: R1(3) - real(dp), intent(inout) :: R2(3) - - R2= R1(1)*Rua_newcell+ R1(2)*Rub_newcell+ R1(3)*Ruc_newcell - - return -end subroutine direct_cart_real_newcell - -!> transform from direct lattice vector basis to Cartesian coordinates for the magnetic cell -subroutine direct_cart_real_magneticcell(R1, R2) - use para, only : dp, Magnetic_cell - implicit none - real(dp), intent(in) :: R1(3) - real(dp), intent(inout) :: R2(3) - - R2= R1(1)*Magnetic_cell%Rua+ R1(2)*Magnetic_cell%Rub+ R1(3)*Magnetic_cell%Ruc - - return -end subroutine direct_cart_real_magneticcell - - - - !> transform from direct lattice vector basis to Cartesian coordinates -subroutine direct_cart_real_unfold(R1, R2) - use para - implicit none - real(dp), intent(in) :: R1(3) - real(dp), intent(inout) :: R2(3) - - R2= R1(1)*Folded_cell%Rua+ R1(2)*Folded_cell%Rub+ R1(3)*Folded_cell%Ruc - - return -end subroutine direct_cart_real_unfold - - - !> transform from direct lattice vector basis to Cartesian coordinates -subroutine direct_cart_real(R1, R2, lattice) - use para, only : dp - implicit none - real(dp), intent(in) :: R1(3) - real(dp), intent(inout) :: R2(3) - real(dp), intent(in) :: lattice(3, 3) - - R2= R1(1)*lattice(:, 1)+ R1(2)*lattice(:, 2)+ R1(3)*lattice(:, 3) - - return -end subroutine direct_cart_real - - !> transform from Cartesian coordinates to reciprocal lattice vector basis -subroutine cart_direct_rec_newcell(k1, k2) - use para - implicit none - real(dp), intent(in) :: k1(3) - real(dp), intent(inout) :: k2(3) - - real(dp), allocatable :: mata(:, :) - - allocate(mata(3, 3)) - - mata(1, :)= Kua_newcell - mata(2, :)= Kub_newcell - mata(3, :)= Kuc_newcell - - call inv_r(3, mata) - K2= k1(1)*mata(1, :)+ k1(2)*mata(2, :)+ k1(3)*mata(3, :) - - deallocate(mata) - - return -end subroutine cart_direct_rec_newcell - - - !> transform from Cartesian coordinates to reciprocal lattice vector basis -subroutine cart_direct_rec_unfold(k1, k2) - use para - implicit none - real(dp), intent(in) :: k1(3) - real(dp), intent(inout) :: k2(3) - - real(dp), allocatable :: mata(:, :) - - allocate(mata(3, 3)) - - mata(1, :)= Folded_cell%Kua - mata(2, :)= Folded_cell%Kub - mata(3, :)= Folded_cell%Kuc - - call inv_r(3, mata) - K2= k1(1)*mata(1, :)+ k1(2)*mata(2, :)+ k1(3)*mata(3, :) - - deallocate(mata) - - return -end subroutine cart_direct_rec_unfold - - - !> transform from Cartesian coordinates to reciprocal lattice vector basis for magnetic supercell -subroutine cart_direct_rec_magneticcell(k1, k2) - use para, only : dp, Magnetic_cell - implicit none - real(dp), intent(in) :: k1(3) - real(dp), intent(inout) :: k2(3) - - real(dp), allocatable :: mata(:, :) - - allocate(mata(3, 3)) - - mata(1, :)= Magnetic_cell%Kua - mata(2, :)= Magnetic_cell%Kub - mata(3, :)= Magnetic_cell%Kuc - - call inv_r(3, mata) - K2= k1(1)*mata(1, :)+ k1(2)*mata(2, :)+ k1(3)*mata(3, :) - - deallocate(mata) - - return -end subroutine cart_direct_rec_magneticcell - - - !> transform from Cartesian coordinates to reciprocal lattice vector basis -subroutine cart_direct_rec(k1, k2) - use para - implicit none - real(dp), intent(in) :: k1(3) - real(dp), intent(inout) :: k2(3) - - real(dp), allocatable :: mata(:, :) - - allocate(mata(3, 3)) - - mata(1, :)= Origin_cell%Kua - mata(2, :)= Origin_cell%Kub - mata(3, :)= Origin_cell%Kuc - - call inv_r(3, mata) - k2= k1(1)*mata(1, :)+ k1(2)*mata(2, :)+ k1(3)*mata(3, :) - - deallocate(mata) - - return -end subroutine cart_direct_rec - -subroutine direct_cart_rec_newcell(k1, k2) - use para - implicit none - real(dp), intent(in) :: k1(3) - real(dp), intent(inout) :: k2(3) - - K2= k1(1)*Kua_newcell+ k1(2)*Kub_newcell+ k1(3)*Kuc_newcell - - return -end subroutine direct_cart_rec_newcell - -subroutine direct_cart_rec_magneticcell(k1, k2) - use para, only : dp, Magnetic_cell - implicit none - real(dp), intent(in) :: k1(3) - real(dp), intent(inout) :: k2(3) - - K2= k1(1)*Magnetic_cell%Kua+ k1(2)*Magnetic_cell%Kub+ k1(3)*Magnetic_cell%Kuc - - return -end subroutine direct_cart_rec_magneticcell - - -subroutine direct_cart_rec(k1, k2) - use para - implicit none - real(dp), intent(in) :: k1(3) - real(dp), intent(inout) :: k2(3) - - K2= k1(1)*Origin_cell%Kua+ k1(2)*Origin_cell%Kub+ k1(3)*Origin_cell%Kuc - - return -end subroutine direct_cart_rec - -subroutine direct_cart_rec_unfold(k1, k2) - use para - implicit none - real(dp), intent(in) :: k1(3) - real(dp), intent(inout) :: k2(3) - - K2= k1(1)*Folded_cell%Kua+ k1(2)*Folded_cell%Kub+ k1(3)*Folded_cell%Kuc - - return -end subroutine direct_cart_rec_unfold - - - !> define a new unit cell with the given MillerIndices [hkl] -subroutine MillerIndicestoumatrix() - use para - implicit none - integer :: i1, i2, i3, h, k, l, it - real(dp) :: R1(3), R2(3), R3(3), Rhkl(3), dot - - integer, allocatable :: vector_on_hkl_surface(:, :) - integer :: Nvectors_on_hkl_surface - real(dp) :: smallest_area, area - real(dp) :: largestangle, angle - real(dp) :: smallest_volume, cell_volume - real(dp) :: smallest_length - real(dp) :: norm_1, norm_2, norm_3 - - integer :: iRmax - iRmax= 6 - - allocate(vector_on_hkl_surface(3, (2*iRmax+1)**3)) - vector_on_hkl_surface= 0 - - h= MillerIndices(1) - k= MillerIndices(2) - l= MillerIndices(3) - Rhkl= h*Origin_cell%Rua+ k*Origin_cell%Rub+ l*Origin_cell%Ruc - - !> Firstly, find all vectors that are orthorgonal to hkl - it= 0 - do i1=-iRmax, iRmax - do i2=-iRmax, iRmax - do i3=-iRmax, iRmax - if (i1==0 .and. i2==0 .and. i3==0) cycle - !R= i1*Origin_cell%Rua+i2*Origin_cell%Rub+i3*Origin_cell%Ruc - !dot=abs(R(1)*Rhkl(1)+ R(2)*Rhkl(2)+ R(3)*Rhkl(3)) - dot=abs(i1*h+i2*k+i3*l) - if (dot secondly, find the smallest area and the largest - !> angle of two vectors - smallest_area= 99999999d0 - largestangle= 0 - do i1=1, Nvectors_on_hkl_surface - do i2=i1+1, Nvectors_on_hkl_surface - R1= vector_on_hkl_surface(1, i1)*Origin_cell%Rua+ & - vector_on_hkl_surface(2, i1)*Origin_cell%Rub+ & - vector_on_hkl_surface(3, i1)*Origin_cell%Ruc - R2= vector_on_hkl_surface(1, i2)*Origin_cell%Rua+ & - vector_on_hkl_surface(2, i2)*Origin_cell%Rub+ & - vector_on_hkl_surface(3, i2)*Origin_cell%Ruc - dot= R1(1)*R2(1)+ R1(2)*R2(2)+ R1(3)*R2(3) - norm_1= sqrt(R1(1)*R1(1)+ R1(2)*R1(2)+ R1(3)*R1(3)) - norm_2= sqrt(R2(1)*R2(1)+ R2(2)*R2(2)+ R2(3)*R2(3)) - if (norm_1*norm_2 thirdly, find the largest - !> angle in those two vectors which have smallest area - largestangle= 0 - do i1=1, Nvectors_on_hkl_surface - do i2=i1+1, Nvectors_on_hkl_surface - R1= vector_on_hkl_surface(1, i1)*Origin_cell%Rua+ & - vector_on_hkl_surface(2, i1)*Origin_cell%Rub+ & - vector_on_hkl_surface(3, i1)*Origin_cell%Ruc - R2= vector_on_hkl_surface(1, i2)*Origin_cell%Rua+ & - vector_on_hkl_surface(2, i2)*Origin_cell%Rub+ & - vector_on_hkl_surface(3, i2)*Origin_cell%Ruc - - R3(1)= R1(2)*R2(3)- R1(3)*R2(2) - R3(2)= R1(3)*R2(1)- R1(1)*R2(3) - R3(3)= R1(1)*R2(2)- R1(2)*R2(1) - area= dsqrt(R3(1)*R3(1)+ R3(2)*R3(2)+ R3(3)*R3(3)) - - dot= R1(1)*R2(1)+ R1(2)*R2(2)+ R1(3)*R2(3) - norm_1= dsqrt(R1(1)*R1(1)+ R1(2)*R1(2)+ R1(3)*R1(3)) - norm_2= dsqrt(R2(1)*R2(1)+ R2(2)*R2(2)+ R2(3)*R2(3)) - angle= dacos(dot/norm_1/norm_2) - if (angle>pi/2d0) angle= abs(angle-pi) - - if (dabs(area- smallest_area) largestangle)largestangle= angle - endif - enddo - enddo - - !> thirdly, find the two vectors which have smallest area and largest - !> angle - l1: do i1=1, Nvectors_on_hkl_surface - do i2=i1+1, Nvectors_on_hkl_surface - R1= vector_on_hkl_surface(1, i1)*Origin_cell%Rua+ & - vector_on_hkl_surface(2, i1)*Origin_cell%Rub+ & - vector_on_hkl_surface(3, i1)*Origin_cell%Ruc - R2= vector_on_hkl_surface(1, i2)*Origin_cell%Rua+ & - vector_on_hkl_surface(2, i2)*Origin_cell%Rub+ & - vector_on_hkl_surface(3, i2)*Origin_cell%Ruc - dot= R1(1)*R2(1)+ R1(2)*R2(2)+ R1(3)*R2(3) - norm_1= dsqrt(R1(1)*R1(1)+ R1(2)*R1(2)+ R1(3)*R1(3)) - norm_2= dsqrt(R2(1)*R2(1)+ R2(2)*R2(2)+ R2(3)*R2(3)) - angle= dacos(dot/norm_1/norm_2) - R3(1)= R1(2)*R2(3)- R1(3)*R2(2) - R3(2)= R1(3)*R2(1)- R1(1)*R2(3) - R3(3)= R1(1)*R2(2)- R1(2)*R2(1) - area= dsqrt(R3(1)*R3(1)+ R3(2)*R3(2)+ R3(3)*R3(3)) - if (angle>pi/2d0) angle= abs(angle-pi) - if (dabs(area- smallest_area) The last step, find the third vector that makes the new unit cell has - !> the same volume as the old unit cell - smallest_volume= 9999999d0 - R1= Umatrix(1, 1)*Origin_cell%Rua+ Umatrix(1, 2)*Origin_cell%Rub+ Umatrix(1, 3)*Origin_cell%Ruc - R2= Umatrix(2, 1)*Origin_cell%Rua+ Umatrix(2, 2)*Origin_cell%Rub+ Umatrix(2, 3)*Origin_cell%Ruc - do i1=-iRmax, iRmax - do i2=-iRmax, iRmax - do i3=-iRmax, iRmax - if (i1==0 .and. i2==0 .and. i3==0) cycle - R3= i1*Origin_cell%Rua+i2*Origin_cell%Rub+i3*Origin_cell%Ruc - cell_volume= R1(1)*(R2(2)*R3(3)- R2(3)*R3(2)) & - +R1(2)*(R2(3)*R3(1)- R2(1)*R3(3)) & - +R1(3)*(R2(1)*R3(2)- R2(2)*R3(1)) - cell_volume= dabs(cell_volume) - if (cell_volume< eps9) cycle - if (cell_volume< smallest_volume) smallest_volume= cell_volume - enddo - enddo - enddo - - !> find the third vector with the shortest length - smallest_length= 9999999d0 - do i1=-iRmax, iRmax - do i2=-iRmax, iRmax - do i3=-iRmax, iRmax - if (i1==0 .and. i2==0 .and. i3==0) cycle - R3= i1*Origin_cell%Rua+i2*Origin_cell%Rub+i3*Origin_cell%Ruc - cell_volume= R1(1)*(R2(2)*R3(3)- R2(3)*R3(2)) & - +R1(2)*(R2(3)*R3(1)- R2(1)*R3(3)) & - +R1(3)*(R2(1)*R3(2)- R2(2)*R3(1)) - cell_volume= dabs(cell_volume) - if (dabs(cell_volume- smallest_volume) define a new unit cell with the given two vectors of the SURFACE card -subroutine FindTheThirdLatticeVector() - use para - implicit none - integer :: i1, i2, i3, h, k, l, it - real(dp) :: R1(3), R2(3), R3(3), cross(3), dot - - integer, allocatable :: vectors_parallel_umatrix1(:, :) - integer, allocatable :: vectors_parallel_umatrix2(:, :) - integer :: Nvectors_parallel_umatrix1, Nvectors_parallel_umatrix2 - real(dp) :: smallest_volume, cell_volume - real(dp) :: smallest_length - real(dp) :: norm_3 - - integer :: iRmax - iRmax= 6 - - allocate(vectors_parallel_umatrix1(3, (2*iRmax+1)**3)) - allocate(vectors_parallel_umatrix2(3, (2*iRmax+1)**3)) - vectors_parallel_umatrix1= 0 - vectors_parallel_umatrix2= 0 - - !> Firstly, find all vectors that are parallel to Umatrix(1,:) - it= 0 - do i1=-iRmax, iRmax - do i2=-iRmax, iRmax - do i3=-iRmax, iRmax - if (i1==0 .and. i2==0 .and. i3==0) cycle - !R= i1*Origin_cell%Rua+i2*Origin_cell%Rub+i3*Origin_cell%Ruc - !dot=abs(R(1)*Rhkl(1)+ R(2)*Rhkl(2)+ R(3)*Rhkl(3)) - cross(1)= Umatrix(1, 2)*i3- i2*Umatrix(1, 3) - cross(2)= Umatrix(1, 3)*i1- i3*Umatrix(1, 1) - cross(3)= Umatrix(1, 1)*i2- i1*Umatrix(1, 2) - dot = i1*Umatrix(1, 1)+ i2*Umatrix(1, 2)+ i3*Umatrix(1, 3) - if ((abs(cross(1))+abs(cross(2))+abs(cross(3)))0) then - it= it+1 - vectors_parallel_umatrix1(1, it)= i1 - vectors_parallel_umatrix1(2, it)= i2 - vectors_parallel_umatrix1(3, it)= i3 - endif - enddo - enddo - enddo - Nvectors_parallel_umatrix1= it - - !> and select the shortest vectors_parallel_umatrix1 - smallest_length= 9999999d0 - do it= 1, Nvectors_parallel_umatrix1 - R1= vectors_parallel_umatrix1(1, it)*Origin_cell%Rua+ & - vectors_parallel_umatrix1(2, it)*Origin_cell%Rub+ & - vectors_parallel_umatrix1(3, it)*Origin_cell%Ruc - norm_3= dsqrt(R1(1)*R1(1)+ R1(2)*R1(2)+ R1(3)*R1(3)) - if (norm_3< smallest_length) then - smallest_length= norm_3 - Umatrix(1, :) = vectors_parallel_umatrix1(:, it) - endif - enddo - - - !> secondly, find all vectors that are parallel to Umatrix(2,:) - it= 0 - do i1=-iRmax, iRmax - do i2=-iRmax, iRmax - do i3=-iRmax, iRmax - if (i1==0 .and. i2==0 .and. i3==0) cycle - !R= i1*Origin_cell%Rua+i2*Origin_cell%Rub+i3*Origin_cell%Ruc - !dot=abs(R(1)*Rhkl(1)+ R(2)*Rhkl(2)+ R(3)*Rhkl(3)) - cross(1)= Umatrix(2, 2)*i3- i2*Umatrix(2, 3) - cross(2)= Umatrix(2, 3)*i1- i3*Umatrix(2, 1) - cross(3)= Umatrix(2, 1)*i2- i1*Umatrix(2, 2) - dot = i1*Umatrix(2, 1)+ i2*Umatrix(2, 2)+ i3*Umatrix(2, 3) - if ((abs(cross(1))+abs(cross(2))+abs(cross(3)))0) then - it= it+1 - vectors_parallel_umatrix2(1, it)= i1 - vectors_parallel_umatrix2(2, it)= i2 - vectors_parallel_umatrix2(3, it)= i3 - endif - enddo - enddo - enddo - Nvectors_parallel_umatrix2= it - - !> and select the shortest vectors_parallel_umatrix1 - smallest_length= 9999999d0 - do it= 1, Nvectors_parallel_umatrix2 - R2= vectors_parallel_umatrix2(1, it)*Origin_cell%Rua+ & - vectors_parallel_umatrix2(2, it)*Origin_cell%Rub+ & - vectors_parallel_umatrix2(3, it)*Origin_cell%Ruc - norm_3= dsqrt(R2(1)*R2(1)+ R2(2)*R2(2)+ R2(3)*R2(3)) - if (norm_3< smallest_length) then - smallest_length= norm_3 - Umatrix(2, :) = vectors_parallel_umatrix2(:, it) - endif - enddo - - !> The last step, find the third vector that makes the new unit cell has - !> the same volume as the old unit cell - smallest_volume= 9999999d0 - R1= Umatrix(1, 1)*Origin_cell%Rua+ Umatrix(1, 2)*Origin_cell%Rub+ Umatrix(1, 3)*Origin_cell%Ruc - R2= Umatrix(2, 1)*Origin_cell%Rua+ Umatrix(2, 2)*Origin_cell%Rub+ Umatrix(2, 3)*Origin_cell%Ruc - do i1=-iRmax, iRmax - do i2=-iRmax, iRmax - do i3=-iRmax, iRmax - if (i1==0 .and. i2==0 .and. i3==0) cycle - R3= i1*Origin_cell%Rua+i2*Origin_cell%Rub+i3*Origin_cell%Ruc - cell_volume= R1(1)*(R2(2)*R3(3)- R2(3)*R3(2)) & - +R1(2)*(R2(3)*R3(1)- R2(1)*R3(3)) & - +R1(3)*(R2(1)*R3(2)- R2(2)*R3(1)) - cell_volume= dabs(cell_volume) - if (cell_volume< eps9) cycle - if (cell_volume< smallest_volume) smallest_volume= cell_volume - enddo - enddo - enddo - - !> find the third vector with the shortest length - smallest_length= 9999999d0 - do i1=-iRmax, iRmax - do i2=-iRmax, iRmax - do i3=-iRmax, iRmax - if (i1==0 .and. i2==0 .and. i3==0) cycle - R3= i1*Origin_cell%Rua+i2*Origin_cell%Rub+i3*Origin_cell%Ruc - cell_volume= R1(1)*(R2(2)*R3(3)- R2(3)*R3(2)) & - +R1(2)*(R2(3)*R3(1)- R2(1)*R3(3)) & - +R1(3)*(R2(1)*R3(2)- R2(2)*R3(1)) - cell_volume= dabs(cell_volume) - if (dabs(cell_volume- smallest_volume) use MillerIndicestoumatrix - if (abs(cell_volume- Origin_cell%CellVolume)> eps9 ) then - !> first find the Miller indices - h=int(Umatrix(1, 2)*Umatrix(2, 3)-Umatrix(1, 3)*Umatrix(2, 2)) - k=int(Umatrix(1, 3)*Umatrix(2, 1)-Umatrix(1, 1)*Umatrix(2, 3)) - l=int(Umatrix(1, 1)*Umatrix(2, 2)-Umatrix(1, 2)*Umatrix(2, 1)) - - call gcd_reduce(h, k, l) - MillerIndices(1)=h - MillerIndices(2)=k - MillerIndices(3)=l - - if (cpuid.eq.0) then - write(stdout, '(a, 3i5)')'>> Miller indices for SURFACE are : ', h, k, l - endif - - call MillerIndicestoumatrix() - endif - - return -end subroutine FindTheThirdLatticeVector - -!> a function to reduce h, k, l by their GCD (Greatest common divisor) -subroutine gcd_reduce(h, k, l) - use para, only : dp - implicit none - - integer, intent(inout) :: h, k, l - integer :: i - real(dp) :: rmiller(3), r3(3), sumr - rmiller(1)= dble(h) - rmiller(2)= dble(k) - rmiller(3)= dble(l) - - do i=1, 3 - if (rmiller(i)<1E-3) cycle - r3= rmiller/rmiller(i) - sumr= abs(mod(sum(r3), 1d0)) - sumr=min(abs(sumr-1d0), abs(sumr)) - if (sumr<1E-3) then - h= int(r3(1)) - k= int(r3(2)) - l= int(r3(3)) - return - endif - enddo - - return -end subroutine gcd_reduce - - - !> move the atoms into the home unitcell [0, 1)*[0, 1)*[0, 1) -subroutine transformtohomecell(pos) - ! Transform the k points to the 1st BZ - ! - ! By QuanSheng Wu - ! - ! wuquansheng@gmail.com - ! - ! Nov 9 2016 at ETHZ - - use para, only : dp - - integer :: i - real(dp), intent(inout) :: pos(3) - - do i=1, 3 - do while (.true.) - if (pos(i)>= 0.0d0 .and. pos(i)<1.0d0) then - exit - else if (pos(i)< 0.0d0) then - pos(i)= pos(i)+ 1d0 - else if (pos(i)>=1.0d0) then - pos(i)= pos(i)- 1d0 - endif - enddo - enddo - - return -end subroutine transformtohomecell - -!====================================================================! -subroutine param_get_range_vector(keyword,inline,length,lcount,i_value) -!====================================================================! -!! Read a range vector eg. 1,2,3,4-10 or 1 3 400:100 -!! if(lcount) we return the number of states in length -!! From Wannier90, modified by QSWU -!====================================================================! - -!> usage -!> first count howmany values -!> call param_get_range_vector('TOPATOMS','1,2,3,4-10',NTopAtoms,lcount=.true., TOPATOMS) -!> then get values -!> call param_get_range_vector('TOPATOMS','1,2,3,4-10',NTopAtoms,lcount=.false., TopAtoms) - - implicit none - - character(len=*), intent(in) :: keyword - character(len=*), intent(inout) :: inline - integer, intent(inout) :: length - !! Number of states - logical, intent(in) :: lcount - !! If T only count states - integer, intent(out) :: i_value(length) - !! States specified in range vector - - integer :: loop,num1,num2,i_punc - integer :: counter,i_digit,loop_r,range_size - character(len=256) :: dummy - character(len=10), parameter :: c_digit="0123456789" - character(len=2) , parameter :: c_range="-:" - character(len=3) , parameter :: c_sep=" ,;" - character(len=5) , parameter :: c_punc=" ,;-:" - character(len=2) , parameter :: comment_punc="#!%" - character(len=5) :: c_num1,c_num2 - - !> remove the comment part - i_punc= scan(inline,comment_punc) - if (i_punc>0) then - dummy= inline(1:i_punc-1) - else - dummy=adjustl(inline) - endif - - dummy=adjustl(dummy) - - counter=0 - do - i_punc=scan(dummy,c_punc) - if(i_punc==0) call printerrormsg('Error parsing keyword '//trim(keyword)) - c_num1=dummy(1:i_punc-1) - read(c_num1,*,err=1201,end=1201) num1 - dummy=adjustl(dummy(i_punc:)) - !look for range - if(scan(dummy,c_range)==1) then - i_digit=scan(dummy,c_digit) - dummy=adjustl(dummy(i_digit:)) - i_punc=scan(dummy,c_punc) - c_num2=dummy(1:i_punc-1) - read(c_num2,*,err=1201,end=1201) num2 - dummy=adjustl(dummy(i_punc:)) - range_size=abs(num2-num1)+1 - do loop_r=1,range_size - counter=counter+1 - if(.not. lcount) i_value(counter)=min(num1,num2)+loop_r-1 - end do - else - counter=counter+1 - if(.not. lcount) i_value(counter)=num1 - end if - - if(scan(dummy,c_sep)==1) dummy=adjustl(dummy(2:)) - if(scan(dummy,c_range)==1) call printerrormsg('Error parsing keyword '//trim(keyword)//' incorrect range') - if(index(dummy,' ')==1) exit - end do - - if(lcount) length=counter - if(.not.lcount) then - do loop=1,counter-1 - do loop_r=loop+1,counter - if(i_value(loop)==i_value(loop_r)) & - call printerrormsg('Error parsing keyword '//trim(keyword)//' duplicate values') - end do - end do - end if - - return - -1201 call printerrormsg('Error parsing keyword '//trim(keyword)) - - -end subroutine param_get_range_vector - - -!> Write out the POSCAR for a given cell -subroutine writeout_poscar(cell, poscarname) - use para - implicit none - - integer :: ia - type(cell_type) :: cell - character(*) :: poscarname - - !> print out the new basis - outfileindex= outfileindex+ 1 - if (cpuid.eq.0) then - open(outfileindex, file=poscarname) - write(outfileindex, '(a)')"POSCAR for generated by WannierTools" - write(outfileindex, '(a)')"1.0" - write(outfileindex, '(3f12.6)') cell%Rua/Angstrom2atomic - write(outfileindex, '(3f12.6)') cell%Rub/Angstrom2atomic - write(outfileindex, '(3f12.6)') cell%Ruc/Angstrom2atomic - write(outfileindex, '(30A6)') cell%Name_of_atomtype - write(outfileindex, '(30i6)') cell%Num_atoms_eachtype - write(outfileindex, '(a)')"Direct" - do ia=1, cell%Num_atoms - if(cpuid==0)write(outfileindex, '(3f12.6, a9)')cell%Atom_position_direct(:, ia), trim(adjustl(cell%Atom_name(ia))) - enddo - close(outfileindex) - endif - return -end subroutine writeout_poscar - - -!> generate the POSCAR for slab system -!> necessary input: -!> Nslab -!> SURFACE -!> Vacuum_thickness_in_Angstrom -subroutine generate_slab_poscar(cell) - use para - implicit none - - type(cell_type) :: cell - - integer :: i, it, ia - real(dp) :: angle_t, ratio - real(dp) :: R1(3), R2(3), R3(3), R3_slab(3), R12_cross(3) - integer, allocatable :: Num_atoms_eachtype(:) - real(dp), allocatable :: pos_cart(:, :) - character(10), allocatable :: atom_name(:) - integer :: Num_atoms_slab, num_atoms_primitive_cell - real(dp), external :: norm, angle - - R1=cell%Rua - R2=cell%Rub - R3=cell%Ruc - - !> R12_cross=R1xR2 - call cross_product(R1, R2, R12_cross) - - !> angle of R12_cross and R3 - angle_t= angle (R12_cross, R3) - angle_t= angle_t*pi/180d0 - - ratio= Vacuum_thickness_in_Angstrom/cos(angle_t)/norm(R3) - - R3_slab= (Nslab+ ratio)*R3 - - - num_atoms_primitive_cell= cell%Num_atoms - Num_atoms_slab= cell%Num_atoms*Nslab - allocate(atom_name(Num_atoms_slab)) - allocate(Num_atoms_eachtype(cell%Num_atom_type)) - Num_atoms_eachtype= cell%Num_atoms_eachtype*Nslab - - allocate(pos_cart(3, Num_atoms_slab)) - pos_cart=0d0 - - it= 0 - do ia=1, num_atoms_primitive_cell - do i=1, Nslab - it=it+1 - pos_cart(:, it)= cell%Atom_position_cart(:, ia)+ R3*(i-1d0+ratio/2d0) - atom_name(it)= cell%atom_name(ia) - enddo - enddo - - !> print out the new basis - outfileindex= outfileindex+ 1 - if (cpuid.eq.0) then - open(outfileindex, file="POSCAR-slab") - write(outfileindex, '(a)')"POSCAR for slab defined by SURFACE card and Nslab and Vacuum_thickness_in_Angstrom in wt.in by WannierTools" - write(outfileindex, '(a)')"1.0" - write(outfileindex, '(3f12.6)') R1/Angstrom2atomic - write(outfileindex, '(3f12.6)') R2/Angstrom2atomic - write(outfileindex, '(3f12.6)') R3_slab/Angstrom2atomic - write(outfileindex, '(30A6)') cell%Name_of_atomtype - write(outfileindex, '(30i6)') Num_atoms_eachtype - write(outfileindex, '(a)')"Cartesian" - do ia=1, Num_atoms_slab - if(cpuid==0)write(outfileindex, '(3f12.6, a9)')pos_cart(:, ia)/Angstrom2atomic, trim(adjustl(atom_name(ia))) - enddo - close(outfileindex) - endif - return -end subroutine generate_slab_poscar - -!> generate a POSCAR for supercell defined by Nslab1, Nslab2, Nslab3 -!> necessary input: -!> Nslab1, Nslab2, Nslab3 -subroutine generate_supercell_poscar() - use para - implicit none - - integer :: i, it, ia - real(dp) :: angle_t, ratio - real(dp) :: R1(3), R2(3), R3(3), R3_slab(3), R12_cross(3) - integer, allocatable :: Num_atoms_eachtype(:) - real(dp), allocatable :: pos_cart(:, :) - character(10), allocatable :: atom_name(:) - integer :: Num_atoms_slab, num_atoms_primitive_cell - real(dp), external :: norm, angle - - R1=Cell_defined_by_surface%Rua - R2=Cell_defined_by_surface%Rub - R3=Cell_defined_by_surface%Ruc - - !> R12_cross=R1xR2 - call cross_product(R1, R2, R12_cross) - - !> angle of R12_cross and R3 - angle_t= angle (R12_cross, R3) - angle_t= angle_t*pi/180d0 - - ratio= Vacuum_thickness_in_Angstrom/cos(angle_t)/norm(R3) - - R3_slab= (Nslab+ ratio)*R3 - - - num_atoms_primitive_cell= Cell_defined_by_surface%Num_atoms - Num_atoms_slab= Cell_defined_by_surface%Num_atoms*Nslab - allocate(atom_name(Num_atoms_slab)) - allocate(Num_atoms_eachtype(Cell_defined_by_surface%Num_atom_type)) - Num_atoms_eachtype= Cell_defined_by_surface%Num_atoms_eachtype*Nslab - - allocate(pos_cart(3, Num_atoms_slab)) - pos_cart=0d0 - - it= 0 - do ia=1, num_atoms_primitive_cell - do i=1, Nslab - it=it+1 - pos_cart(:, it)= Cell_defined_by_surface%Atom_position_cart(:, ia)+ R3*(i-1d0+ratio/2d0) - atom_name(it)= Cell_defined_by_surface%atom_name(ia) - enddo - enddo - - !> print out the new basis - outfileindex= outfileindex+ 1 - if (cpuid.eq.0) then - open(outfileindex, file="POSCAR-slab") - write(outfileindex, '(a)')"POSCAR for slab defined by SURFACE card and Nslab and Vacuum_thickness_in_Angstrom in wt.in by WannierTools" - write(outfileindex, '(a)')"1.0" - write(outfileindex, '(3f12.6)') R1/Angstrom2atomic - write(outfileindex, '(3f12.6)') R2/Angstrom2atomic - write(outfileindex, '(3f12.6)') R3_slab/Angstrom2atomic - write(outfileindex, '(30A6)') Cell_defined_by_surface%Name_of_atomtype - write(outfileindex, '(30i6)') Num_atoms_eachtype - write(outfileindex, '(a)')"Cartesian" - do ia=1, Num_atoms_slab - if(cpuid==0)write(outfileindex, '(3f12.6, a9)')pos_cart(:, ia)/Angstrom2atomic, trim(adjustl(atom_name(ia))) - enddo - close(outfileindex) - endif - return -end subroutine generate_supercell_poscar - -subroutine get_reciprocal_lattice(R1, R2, R3, K1, K2, K3) - !> Get reciprocal lattice vectors with given direct lattice vectors - !> volume= R1.(R2xR3) - !> K1=2*pi* R2xR3/volume - !> K2=2*pi* R3xR1/volume - !> K3=2*pi* R1xR2/volume - use para, only : dp, pi - implicit none - real(dp) :: volume - real(dp), intent(in) :: R1(3), R2(3), R3(3) - real(dp), intent(out) :: K1(3), K2(3), K3(3) - - call cross_product(R2, R3, K1) - call cross_product(R3, R1, K2) - call cross_product(R1, R2, K3) - volume=dot_product(K1, R1) - - K1=2d0*pi*K1/volume - K2=2d0*pi*K2/volume - K3=2d0*pi*K3/volume - return -end subroutine get_reciprocal_lattice - -subroutine get_volume(R1, R2, R3, volume) - !> Get volume with three given vectors - !> volume= R1.(R2xR3) - use para, only : dp - implicit none - real(dp) :: R0(3) - real(dp), intent(in) :: R1(3), R2(3), R3(3) - real(dp), intent(out) :: volume - - call cross_product(R2, R3, R0) - volume=dot_product(R0, R1) - return -end subroutine get_volume - - -!> not finish yet -subroutine build_map_supercell_primitivecell - !> build the map between supercell (Origin_cell) and primitive cell (Folded_cell) - use para - implicit none - - integer :: i, ia, ja, map_ia, Nleft - real(dp), external :: norm - real(dp) :: pos_cart_sc(3), pos_cart_pc(3), pos_direct_pc(3), pos_direct_sc(3) - real(dp) :: tau_i_tilde(3), tau_j_tilde(3), dij_tilde_cart(3), dij_tilde_direct(3) - character*40 :: atom_name_pc - real(dp) :: tol, shift_pos_cart(3) - real(dp), allocatable :: pos_cart_sc_all(:, :), pos_cart_pc_all(:, :) - real(dp), allocatable :: pos_direct_sc_all(:, :), pos_direct_pc_all(:, :) - - allocate(pos_cart_sc_all(3, Origin_cell%Num_atoms)) - allocate(pos_cart_pc_all(3, Folded_cell%Num_atoms)) - allocate(pos_direct_sc_all(3, Origin_cell%Num_atoms)) - allocate(pos_direct_pc_all(3, Folded_cell%Num_atoms)) - pos_cart_sc_all= 0d0 - pos_cart_pc_all= 0d0 - pos_direct_sc_all= 0d0 - pos_direct_pc_all= 0d0 - - !>> try to find the global shift between the supercell and the primitive cell (PC) - !> first, we need to transform all the atom's position in the supercell to fractional unit of PC - !> sweep atom in supercell (Origin_cell) - do i=1, NumberofSelectedAtoms(1) - ia= Selected_Atoms(1)%iarray(i) - pos_cart_sc= Origin_cell%Atom_position_cart(:, ia) - !> transform the cartesian coordinates of atom's position in supercell to - !> the fractional coordinates of primitive cell - call cart_direct_real_unfold(pos_cart_sc, pos_direct_pc) - - !> find the atom in primitive cell that the atom in supercell is mapped onto. - !> shift pos_direct_pc to the home unit cell [-0.5, 0.5) - call in_home_cell_regularization(pos_direct_pc) - pos_direct_sc_all(:, i)= pos_direct_pc - call direct_cart_real_unfold(pos_direct_pc, pos_cart_pc) - pos_cart_sc_all(:, i)= pos_cart_pc - enddo - - !> move all atoms in the PC to the home unit cell [-0.5, 0.5) - do ia=1, Folded_cell%Num_atoms - pos_cart_pc= Folded_cell%Atom_position_cart(:, ia) - call cart_direct_real_unfold(pos_cart_pc, pos_direct_pc) - call in_home_cell_regularization(pos_direct_pc) - call direct_cart_real_unfold(pos_direct_pc, pos_cart_pc) - pos_cart_pc_all(:, ia)= pos_cart_pc - pos_direct_pc_all(:, ia)= pos_direct_pc - enddo - - tol = 0.10d0 ! tolrence is tol*(lattice constant) - !> remove the identity positions - call eliminate_duplicates_periodic_with_tol(3, NumberofSelectedAtoms(1), pos_direct_sc_all, Nleft, tol) - - do ia= 1, Nleft - call direct_cart_real_unfold(pos_direct_sc_all(:, ia), pos_cart_sc_all(:, ia)) - enddo - - if (Nleft.ne.Folded_cell%Num_atoms) then - print *, 'Error : something wrong with the settings of Foldedcell', & - ' or there are some duplicated positions in ATOMIC_POSITION', & - ' or the Folded cell(PC) does not match with the super cell(SC)', & - ' or We support only one group of selected atoms', & - ' Nleft, Folded_cell%Num_atoms', & - Nleft, Folded_cell%Num_atoms - - print *, 'The selected atoms position' - do i=1, NumberofSelectedAtoms(1) - !ia= Selected_Atoms(1)%iarray(i) - write(*, '(i7, 30f14.6)')ia, pos_cart_sc_all(:, i ), pos_direct_sc_all(:, i ) - enddo - print *, 'The reduced atoms position' - do ia=1, Nleft - write(*, '(i7, 30f14.6)')ia, pos_cart_sc_all(:, ia), pos_direct_sc_all(:, ia) - enddo - print *, 'Atoms position in Folded cell' - do ia=1, Folded_cell%Num_atoms - write(*, '(i7, 30f14.6)')ia, pos_cart_pc_all(:, ia), pos_direct_pc_all(:, ia) - enddo - stop - endif - - !> shift_pos_cart is a shift that match the Folded_cell and the Origin_cell - shift_pos_cart= -sum(pos_cart_sc_all(:, 1:Nleft), dim=2)+ & - sum(pos_cart_pc_all(:, 1:Nleft), dim=2) - shift_pos_cart= shift_pos_cart/Folded_cell%Num_atoms - global_shift_SC_to_PC_cart= shift_pos_cart - - if (cpuid.eq.0)then - !write(stdout, *) 'The atoms position after shift in the home unit cell' - !do i=1, NumberofSelectedAtoms(1) - ! ia= Selected_Atoms(1)%iarray(i) - ! write(stdout, '(i7, 30f14.6)')ia, pos_cart_sc_all(:, ia), pos_direct_sc_all(:, ia) - !enddo - !write(stdout, *) 'The reduced atoms position' - !do ia=1, Nleft - ! write(stdout, '(i7, 30f14.6)')ia, pos_cart_sc_all(:, ia), pos_direct_sc_all(:, ia) - !enddo - !write(stdout, *) 'Atoms position in Folded cell' - !do ia=1, Folded_cell%Num_atoms - ! write(stdout, '(i7, 30f14.6)')ia, pos_cart_pc_all(:, ia), pos_direct_pc_all(:, ia) - !enddo - - write(stdout, *)' ' - write(stdout, *) '>>> Table of a map between a supercell (sc) and a primitive cell (pc)' - write(stdout, '(2x, a, 3f14.6 )')' A global shift between from the sc to pc is ', global_shift_SC_to_PC_cart - write(stdout,'(2x, a)')'------------------------------------------------------------------------------------------------------------------' - write(stdout, '(1x, a7, 12x, a7, 16x, a20, 25x, a20)') "idx_sc", 'idx_pc', ' atom position in sc', 'atom position in pc' - write(stdout,'(2x, a)')'------------------------------------------------------------------------------------------------------------------' - endif - - - - !> sweep atom in supercell (Origin_cell) - do i=1, NumberofSelectedAtoms(1) - ia= Selected_Atoms(1)%iarray(i) - - !> added the global shift - pos_cart_sc= Origin_cell%Atom_position_cart(:, ia)+shift_pos_cart - !> transform the cartesian coordinates of atom's position in supercell to - !> the fractional coordinates of primitive cell - call cart_direct_real_unfold(pos_cart_sc, pos_direct_pc) - - !> find the atom in primitive cell that the atom in supercell is mapped onto. - !> shift pos_direct_pc to the home unit cell [-0.5, 0.5) - call in_home_cell_regularization(pos_direct_pc) - tau_i_tilde= pos_direct_pc - do ja=1, Folded_cell%Num_atoms - tau_j_tilde= Folded_cell%Atom_position_direct(:, ja) - call periodic_diff(tau_j_tilde, tau_i_tilde, dij_tilde_direct) - call direct_cart_real_unfold(dij_tilde_direct, dij_tilde_cart) - if (norm(dij_tilde_cart)<0.5*Angstrom2atomic) exit - enddo - map_ia= ja - - if (map_ia>Folded_cell%Num_atoms) then - map_ia=0 - atom_name_pc= 'None' - call direct_cart_real_unfold(tau_i_tilde, pos_cart_pc) - if (cpuid.eq.0)then - write(stdout, '((i7, 2X, a5), " -->", (i7, 2X, a5) 9f14.6)')ia, Origin_cell%Atom_name(ia), map_ia, atom_name_pc, & - Origin_cell%Atom_position_cart(:, ia)/Angstrom2atomic - endif - else - atom_name_pc= Folded_cell%Atom_name(map_ia) - call direct_cart_real_unfold(tau_i_tilde, pos_cart_pc) - if (cpuid.eq.0)then - write(stdout, '((i7, 2X, a5), " -->", (i7, 2X, a5), 9f14.6)')ia, Origin_cell%Atom_name(ia), map_ia, atom_name_pc, & - Origin_cell%Atom_position_cart(:, ia)/Angstrom2atomic, Folded_cell%Atom_position_cart(:, map_ia)/Angstrom2atomic - endif - endif - - enddo - if (cpuid.eq.0)then - write(stdout, *)' ' - endif - - return -end subroutine build_map_supercell_primitivecell - -subroutine eliminate_duplicates_periodic_with_tol(ndim1, ndim2, array2, Nleft, tol) - ! Eliminate the duplicated rows of a 2-dimensional array2 - !> 0-1 = 0 is defined here - ! - ! By QuanSheng Wu - ! - ! wuquansheng@gmail.com - ! - ! Jan 2 2023 @ Beijing - - use para, only : dp - implicit none - integer, intent(in) :: ndim1, ndim2 - integer, intent(out) :: Nleft - real(dp), intent(in) :: tol - real(dp), intent(inout) :: array2(ndim1, ndim2) - real(dp), allocatable :: array2_left(:, :) - - integer :: it, ik, ik1 - logical :: Logical_duplicate - real(dp) :: diff(3) - - allocate(array2_left(ndim1, ndim2)) - array2_left=0 - array2_left(:, 1)= array2(:, 1) - - Nleft = 1 - it= 1 - do ik=2, ndim2 - Logical_duplicate= .False. - do ik1=1, Nleft - call periodic_diff(array2(:, ik), array2_left(:, ik1), diff) - if (sum(abs(diff))