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

295 lines
13 KiB
Plaintext
Raw Permalink Blame History

#############
# Graveyard #
#############
A place for potentially useful routines not yet part of the codes or removed.
1) From ephwann_shuffle.f90
! --------------------------------------------------------------------------------------------------------
! SP - This is a possible optimization using a look-up table. Might be useful in some case. Do not remove.
! Was remove from main implementation because only works when using homogeneous grids without symmetries.
!
! SP: Create a look-up table for the exponential of the factor.
! This can only work with homogeneous fine grids.
!
COMPLEX(KIND = DP) :: tablex (4*nkc1+1,nkf1)
! Look-up table for the exponential (speed optimization) in the case of
! homogeneous grids.
IF ((nkf1 >0) .AND. (nkf2 > 0) .AND. (nkf3 > 0) .AND. &
(nqf1 >0) .AND. (nqf2 > 0) .AND. (nqf3 > 0) .AND. .NOT. mp_mesh_k .AND. .NOT. lscreen) THEN
! Make a check
IF ((nqf1>nkf1) .OR. (nqf2>nkf2) .OR. (nqf3>nkf3)) &
CALL errore('The fine q-grid cannot be larger than the fine k-grid',1)
! Along x
DO ikx = -2*nkc1, 2*nkc1
DO ikfx = 0, nkf1-1
!rdotk = twopi * ( xk(1)*irvec_kk(1,ir))
rdotk_scal = twopi * ( (REAL(ikfx,KIND = DP)/nkf1) * ikx )
tablex(ikx+2*nkc1+1,ikfx+1) = EXP(ci*rdotk_scal )
ENDDO
ENDDO
! For k+q
DO ikx = -2*nkc1, 2*nkc1
DO ikfx = 0, 2*nkf1
rdotk_scal = twopi * ( (REAL(ikfx,KIND = DP)/nkf1) * ikx )
tableqx(ikx+2*nkc1+1,ikfx+1) = EXP(ci*rdotk_scal )
ENDDO
ENDDO
! Along y
DO ikx = -2*nkc2, 2*nkc2
DO ikfx = 0, nkf2-1
rdotk_scal = twopi * ( (REAL(ikfx,KIND = DP)/nkf2) * ikx )
tabley(ikx+2*nkc2+1,ikfx+1) = EXP(ci*rdotk_scal )
ENDDO
ENDDO
! For k+q
DO ikx = -2*nkc2, 2*nkc2
DO ikfx = 0, 2*nkf2
rdotk_scal = twopi * ( (REAL(ikfx,KIND = DP)/nkf2) * ikx )
tableqy(ikx+2*nkc2+1,ikfx+1) = EXP(ci*rdotk_scal )
ENDDO
ENDDO
! Along z
DO ikx = -2*nkc3, 2*nkc3
DO ikfx = 0, nkf3-1
rdotk_scal = twopi * ( (REAL(ikfx,KIND = DP)/nkf3) * ikx )
tablez(ikx+2*nkc3+1,ikfx+1) = EXP(ci*rdotk_scal )
ENDDO
ENDDO
! For k+q
DO ikx = -2*nkc3, 2*nkc3
DO ikfx = 0, 2*nkf3
rdotk_scal = twopi * ( (REAL(ikfx,KIND = DP)/nkf3) * ikx )
tableqz(ikx+2*nkc3+1,ikfx+1) = EXP(ci*rdotk_scal )
ENDDO
ENDDO
ENDIF
! --------------------------------------------------------------------------------------------------------
2) From ephwann_shuffle.f90
! SP: Compute the cfac only once here since the same are use in both hamwan2bloch and dmewan2bloch
! + optimize the 2\pi r\cdot k with Blas
IF ((nkf1 >0) .AND. (nkf2 > 0) .AND. (nkf3 > 0) .AND. &
(nqf1 > 0) .AND. (nqf2 > 0) .AND. (nqf3 > 0) .AND. .NOT. mp_mesh_k .AND. .NOT. lscreen) THEN
! We need to use NINT (nearest INTEGER to x) rather than INT
xkk1 = NINT(xkk(1)*(nkf1)) + 1
xkk2 = NINT(xkk(2)*(nkf2)) + 1
xkk3 = NINT(xkk(3)*(nkf3)) + 1
xkq1 = NINT(xkq2(1)*(nkf1)) + 1
xkq2 = NINT(xkq2(2)*(nkf2)) + 1
xkq3 = NINT(xkq2(3)*(nkf3)) + 1
!
! SP: Look-up table is more effecient than calling the exp function.
DO ir = 1, nrr_k
cfac(ir) = ( tablex(irvec_k(1,ir)+2*nkc1+1,xkk1) *&
tabley(irvec_k(2,ir)+2*nkc2+1,xkk2) * tablez(irvec_k(3,ir)+2*nkc3+1,xkk3) ) / ndegen_k(ir)
cfacq(ir) = ( tableqx(irvec_k(1,ir)+2*nkc1+1,xkq1) *&
tableqy(irvec_k(2,ir)+2*nkc2+1,xkq2) * tableqz(irvec_k(3,ir)+2*nkc3+1,xkq3) ) / ndegen_k(ir)
ENDDO
!DBSP
!IF ((iq == 1) .AND. (ik ==12)) THEN
! CALL DGEMV('t', 3, nrr_k, twopi, irvec_r, 3, xkk, 1, 0.0_DP, rdotk, 1 )
! cfac1(:) = EXP(ci*rdotk(:) ) / ndegen_k(:)
! CALL DGEMV('t', 3, nrr_k, twopi, irvec_r, 3, xkq2, 1, 0.0_DP, rdotk, 1 )
! cfacq1(:) = EXP(ci*rdotk(:) ) / ndegen_k(:)
!ENDIF
ELSE
CALL DGEMV('t', 3, nrr_k, twopi, irvec_r, 3, xkk, 1, 0.0_DP, rdotk, 1 )
cfac(:) = EXP(ci*rdotk(:) ) / ndegen_k(:)
CALL DGEMV('t', 3, nrr_k, twopi, irvec_r, 3, xkq2, 1, 0.0_DP, rdotk, 1 )
cfacq(:) = EXP(ci*rdotk(:) ) / ndegen_k(:)
ENDIF
!
! --------------------------------------------------------------------------------------------------------
3) wan2bloch.f90 in the hamwan2bloch subroutine
! This old random matrix generation is removed
! Generate a pertubation matrix of size (nbnd x nbnd) made of random number
CALL init_random_seed()
! SP: Using random_number does not work because the perturbation needs to be the
! same when calling hamwan2bloch at k and k+q (see ephwann_shuffle).
! Therefore I fix a "random" number 0.25644832 + 0.01 * ibnd and 0.11584272 + 0.025 * jbnd
P(:, :) = czero
DO ibnd = 1, nbnd
DO jbnd = 1, nbnd
!CALL random_number(rand1)
!CALL random_number(rand2)
rand1 = 0.25644832 + 0.01 * ibnd
rand2 = 0.11584272 + 0.025 * jbnd
P(jbnd, ibnd) = CMPLX(rand1, rand2, KIND = DP)
ENDDO
ENDDO
! Hermitize the Perturbation matrix and make it small
P = 0.5d0 * (P + TRANSPOSE(CONJG(P))) * ABS(MINVAL(w)) * 0.1d0
! --------------------------------------------------------------------------------------------------------
4) qdabs.f90 Renormalization of velocity matrix with scissor operator
!--------------------------------------------------------------------------
SUBROUTINE renorm_eig(ikk, ikq, nrr_k, dims, ndegen_k, irvec_k, irvec_r, cufkk, cufkq, cfac, cfacq)
!--------------------------------------------------------------------------
!!
!! This routine computes the renormalization of the eigenenergies to be applied
!! in case one read external eigenvalues.
!! The implementation follows Eq. 30 of Phys. Rev. B 62, 4927 (2000)
!! Samuel Ponce, Kyle and Emmanouil Kioupakis
!! S. Tiwari: slight modification in case of scisso operator
USE kinds, ONLY : DP
USE elph2, ONLY : xkfd, chw, chw_ks, etf_ks, etf, vmef, nkqf
USE epwcom, ONLY : use_ws, nbndsub
USE constants_epw, ONLY : eps40, ryd2mev, twopi, zero, eps6, ci, czero, one, ryd2ev
USE wan2bloch, ONLY : hamwan2bloch, vmewan2bloch
USE io_global, ONLY : stdout, ionode_id
!
IMPLICIT NONE
!
INTEGER, INTENT(in) :: ikk
!! Current k point on that core (ikk = 2 * ik + 1)
INTEGER, INTENT(in) :: ikq
!! k+q point on that core
INTEGER, INTENT(in) :: nrr_k
!! Number of WS points for electrons
INTEGER, INTENT(in) :: dims
!! Dims is either nbndsub if use_ws or 1 if not
INTEGER, INTENT(in) :: ndegen_k(nrr_k, dims, dims)
!! Wigner-Seitz number of degenerescence (weights) for the electrons grid
INTEGER, INTENT(in) :: irvec_k(3, nrr_k)
!! Integer components of the ir-th Wigner-Seitz grid point in the basis of the lattice vectors for electrons
REAL(KIND = DP), INTENT(in) :: irvec_r(3, nrr_k)
!! Wigner-Size supercell vectors, store in real instead of integer
COMPLEX(KIND = DP), INTENT(inout) :: cufkk(nbndsub, nbndsub)
!! Rotation matrix, fine mesh, points k
COMPLEX(KIND = DP), INTENT(inout) :: cufkq(nbndsub, nbndsub)
!! the same, for points k+q
COMPLEX(KIND = DP) :: cufkkd(nbndsub,nbndsub)
!! Rotation matrix, shifted mesh, points k
COMPLEX(KIND = DP) :: cufkqd(nbndsub,nbndsub)
!! Rotation matrix, shifted mesh, k+q
COMPLEX(KIND = DP), INTENT(in) :: cfac(nrr_k, dims, dims)
!! Exponential factor
COMPLEX(KIND = DP), INTENT(in) :: cfacq(nrr_k, dims, dims)
!! Exponential factor
!
! Local variables
INTEGER :: icounter
!! Integer counter for displaced points
INTEGER :: ibnd
!! Band index
INTEGER :: jbnd
!! Band index
INTEGER :: ir
!! Counter for WS loop
INTEGER :: iw
!! Counter on bands when use_ws == .TRUE.
INTEGER :: iw2
!! Counter on bands when use_ws == .TRUE.
REAL(KIND = DP) :: rdotk(nrr_k)
!! $r\cdot k$
REAL(KIND = DP) :: rdotk2(nrr_k)
!! $r\cdot k$
REAL(KIND = DP) :: etfd(nbndsub, nkqf, 6)
!! interpolated eigenvalues (nbnd, nkqf) eigenvalues for shifted grid in the case of eig_read
REAL(KIND = DP) :: etfd_ks(nbndsub, nkqf, 6)
!! interpolated eigenvalues (nbnd, nkqf) KS eigenvalues for shifted grid in the case of eig_read
COMPLEX(KIND = DP) :: cfacd(nrr_k, dims, dims, 6)
!! Used to store $e^{2\pi r \cdot k}$ exponential of displaced vector
COMPLEX(KIND = DP) :: cfacqd(nrr_k, dims, dims, 6)
!! Used to store $e^{2\pi r \cdot k+q}$ exponential of dispaced vector
!
cfacd(:, :, :, :) = czero
cfacqd(:, :, :, :)= czero
DO icounter = 1, 6
CALL DGEMV('t', 3, nrr_k, twopi, irvec_r, 3, xkfd(:, ikk, icounter), 1, 0.0_DP, rdotk, 1)
CALL DGEMV('t', 3, nrr_k, twopi, irvec_r, 3, xkfd(:, ikq, icounter), 1, 0.0_DP, rdotk2, 1)
IF (use_ws) THEN
DO iw = 1, dims
DO iw2 = 1, dims
DO ir = 1, nrr_k
IF (ndegen_k(ir, iw2, iw) > 0) THEN
cfacd(ir, iw2, iw, icounter) = EXP(ci * rdotk(ir)) / ndegen_k(ir, iw2, iw)
cfacqd(ir, iw2, iw, icounter) = EXP(ci * rdotk2(ir)) / ndegen_k(ir, iw2, iw)
ENDIF
ENDDO
ENDDO
ENDDO
ELSE
cfacd(:, 1, 1, icounter) = EXP(ci * rdotk(:)) / ndegen_k(:, 1, 1)
cfacqd(:, 1, 1, icounter) = EXP(ci * rdotk2(:)) / ndegen_k(:, 1, 1)
ENDIF
!
CALL hamwan2bloch(nbndsub, nrr_k, cufkkd, etfd(:, ikk, icounter), chw, cfacd, dims)
CALL hamwan2bloch(nbndsub, nrr_k, cufkqd, etfd(:, ikq, icounter), chw, cfacqd, dims)
CALL hamwan2bloch(nbndsub, nrr_k, cufkkd, etfd_ks(:, ikk, icounter), chw_ks, cfacd, dims)
CALL hamwan2bloch(nbndsub, nrr_k, cufkqd, etfd_ks(:, ikq, icounter), chw_ks, cfacqd, dims)
ENDDO ! icounter
! -----------------------------------------------------------------------------------------
CALL vmewan2bloch(nbndsub, nrr_k, irvec_k, cufkk, vmef(:, :, :, ikk), &
etf(:, ikk), etf_ks(:, ikk), chw_ks, cfac, dims)
CALL vmewan2bloch(nbndsub, nrr_k, irvec_k, cufkq, vmef(:, :, :, ikq), &
etf(:, ikq), etf_ks(:, ikq), chw_ks, cfacq, dims)
! To Satisfy Phys. Rev. B 62, 4927-4944 (2000) , Eq. (30)
DO ibnd = 1, nbndsub
!WRITE(stdout,'(/5x,a,I10,E22.14)')'etfd-etfd_KS',ibnd,etfd(ibnd,ikk,1)-etfd_ks(ibnd,ikk,1)*ryd2ev
!WRITE(stdout,'(/5x,a,I10,E22.14)')'etf-etf_KS',ibnd,etf(ibnd,ikk)-etf_ks(ibnd,ikk)*ryd2ev
DO jbnd = 1, nbndsub
IF (ABS(etfd_ks(ibnd, ikk, 1) - etfd_ks(jbnd, ikk, 2)) > eps6) THEN
vmef(1, ibnd, jbnd, ikk) = vmef(1, ibnd, jbnd, ikk) * (etfd(ibnd, ikk, 1) - etfd(jbnd, ikk, 2)) / &
(etfd_ks(ibnd, ikk, 1) - etfd_ks(jbnd, ikk, 2))
ENDIF
IF (ABS(etfd_ks(ibnd, ikk, 3) - etfd_ks(jbnd, ikk, 4)) > eps6) THEN
vmef(2, ibnd, jbnd, ikk) = vmef(2, ibnd, jbnd, ikk) * (etfd(ibnd, ikk, 3) - etfd(jbnd, ikk, 4)) / &
(etfd_ks(ibnd, ikk, 3) - etfd_ks(jbnd, ikk, 4))
ENDIF
IF (ABS(etfd_ks(ibnd, ikk, 5) - etfd_ks(jbnd, ikk, 6)) > eps6) THEN
vmef(3, ibnd, jbnd, ikk) = vmef(3, ibnd, jbnd, ikk) * (etfd(ibnd, ikk, 5) - etfd(jbnd, ikk, 6)) / &
(etfd_ks(ibnd, ikk, 5) - etfd_ks(jbnd, ikk, 6))
ENDIF
IF (ABS(etfd_ks(ibnd, ikq, 1) - etfd_ks(jbnd, ikq, 2)) > eps6) THEN
vmef(1, ibnd, jbnd, ikq) = vmef(1, ibnd, jbnd, ikq) * (etfd(ibnd, ikq, 1) - etfd(jbnd, ikq, 2)) / &
(etfd_ks(ibnd, ikq, 1) - etfd_ks(jbnd, ikq, 2))
ENDIF
IF (ABS(etfd_ks(ibnd, ikq, 3) - etfd_ks(jbnd, ikq, 4)) > eps6) THEN
vmef(2, ibnd, jbnd, ikq) = vmef(2, ibnd, jbnd, ikq) * (etfd(ibnd, ikq, 3) - etfd(jbnd, ikq, 4)) / &
(etfd_ks(ibnd, ikq, 3) - etfd_ks(jbnd, ikq, 4))
ENDIF
IF (ABS(etfd_ks(ibnd, ikq, 5) - etfd_ks(jbnd, ikq, 6)) > eps6) THEN
vmef(3, ibnd, jbnd, ikq) = vmef(3, ibnd, jbnd, ikq) * (etfd(ibnd, ikq, 5) - etfd(jbnd, ikq, 6) ) / &
(etfd_ks(ibnd, ikq, 5) - etfd_ks(jbnd, ikq, 6))
ENDIF
ENDDO
ENDDO
!
!-----------------------------------------------------------------------
END SUBROUTINE renorm_eig
!-----------------------------------------------------------------------
5) from qdabs.f90, Subroutine build_quasi_eig for future implementation of adaptive grid
!-------------------------------------------------------------------------------------
IF ((initial_E > E_mesh(meshin)) .AND. (initial_E <= E_mesh(meshin + 1))) THEN
IF ((final_E <= (E_mesh(meshin + 1))) .AND. (final_E > (E_mesh(meshin)))) THEN
IF (cv == 10) THEN
check = INT(check_final(j, k_final, k_init, v, iq, imode, tot_pool, &
index_buf_pool(1:tot_pool, 1:5), nq, 2))
ELSE
check = INT(check_final(c, k_final, k_init, v, iq, imode, tot_pool, &
index_buf_pool(1:tot_pool, 1:5), nq, 2))
ENDIF
!
IF (check == -1) THEN
suc = 2
ELSE
WRITE(stdout, '(5x,a)')'Found_match'
ENDIF
ELSE
suc = 0
ENDIF
ENDIF
!-------------------------------------------------------------------------------------
Reference in New Issue View Git Blame Copy Permalink