Commit b9b9a74f authored by Daniel Wortmann's avatar Daniel Wortmann

Small refactoring of tlmplm part

parent 516ab03d
......@@ -91,7 +91,7 @@ SUBROUTINE cdnval(eig_id, mpi,kpts,jspin,noco,input,banddos,cell,atoms,enpara,st
INTEGER :: ikpt,jsp_start,jsp_end,ispin,jsp
INTEGER :: iErr,nbands,noccbd,iType
INTEGER :: skip_t,skip_tt,nStart,nEnd,nbasfcn
LOGICAL :: l_orbcomprot, l_real, l_write, l_dosNdir, l_corespec
LOGICAL :: l_orbcomprot, l_real, l_dosNdir, l_corespec
! Local Arrays
REAL, ALLOCATABLE :: we(:)
......@@ -159,10 +159,9 @@ SUBROUTINE cdnval(eig_id, mpi,kpts,jspin,noco,input,banddos,cell,atoms,enpara,st
END IF
8000 FORMAT (/,/,10x,'valence density: spin=',i2)
l_write = input%cdinf.AND.mpi%irank==0
DO iType = 1, atoms%ntype
DO ispin = jsp_start, jsp_end
CALL genMTBasis(atoms,enpara,vTot,mpi,iType,ispin,l_write,usdus,f(:,:,0:,ispin),g(:,:,0:,ispin),flo(:,:,:,ispin))
CALL genMTBasis(atoms,enpara,vTot,mpi,iType,ispin,usdus,f(:,:,0:,ispin),g(:,:,0:,ispin),flo(:,:,:,ispin))
END DO
IF (noco%l_mperp) CALL denCoeffsOffdiag%addRadFunScalarProducts(atoms,f,g,flo,iType)
IF (banddos%l_mcd) CALL mcd_init(atoms,input,dimension,vTot%mt(:,0,:,:),g,f,mcd,iType,jspin)
......
......@@ -24,6 +24,7 @@ eigen/rad_ovlp.f90
eigen/setabc1lo.f90
eigen/slomat.F90
eigen/tlmplm_cholesky.F90
eigen/tlmplm.F90
eigen/tlmplm_store.F90
eigen/tlo.f90
eigen/vacfun.f90
......
MODULE m_tlmplm
IMPLICIT NONE
!*********************************************************************
! sets up the local Hamiltonian, i.e. the Hamiltonian in the
! l',m',l,m,u- basis which is independent from k!
!*********************************************************************
CONTAINS
SUBROUTINE tlmplm(n,sphhar,atoms,enpara,&
jspin,jsp,mpi,v,input,td,ud)
USE m_constants
USE m_intgr, ONLY : intgr3
USE m_genMTBasis
USE m_tlo
USE m_gaunt, ONLY: gaunt1
USE m_types
IMPLICIT NONE
TYPE(t_input),INTENT(IN) :: input
TYPE(t_sphhar),INTENT(IN) :: sphhar
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_enpara),INTENT(IN) :: enpara
TYPE(t_mpi),INTENT(IN) :: mpi
TYPE(t_potden),INTENT(IN) :: v
TYPE(t_tlmplm),INTENT(INOUT) :: td
TYPE(t_usdus),INTENT(INOUT) :: ud
INTEGER, INTENT (IN) :: n,jspin,jsp !atom index,physical spin&spin index for data
REAL dvd(0:atoms%lmaxd*(atoms%lmaxd+3)/2,0:sphhar%nlhd )
REAL dvu(0:atoms%lmaxd*(atoms%lmaxd+3)/2,0:sphhar%nlhd )
REAL uvd(0:atoms%lmaxd*(atoms%lmaxd+3)/2,0:sphhar%nlhd )
REAL uvu(0:atoms%lmaxd*(atoms%lmaxd+3)/2,0:sphhar%nlhd )
REAL f(atoms%jmtd,2,0:atoms%lmaxd),g(atoms%jmtd,2,0:atoms%lmaxd),x(atoms%jmtd)
REAL flo(atoms%jmtd,2,atoms%nlod)
INTEGER:: indt(0:SIZE(td%tuu,1)-1)
REAL vr0(SIZE(v%mt,1),0:SIZE(v%mt,2)-1)
COMPLEX :: cil
REAL :: temp
INTEGER i,l,l2,lamda,lh,lm,lmin,lmin0,lmp,lmpl,lmplm,lmx,lmxx,lp,info,in
INTEGER lp1,lpl ,mem,mems,mp,mu,nh,na,m,nsym,s,i_u
vr0=v%mt(:,:,n,jsp)
IF (jsp<3) vr0(:,0)=0.0
CALL genMTBasis(atoms,enpara,v,mpi,n,jspin,ud,f,g,flo)
nsym = atoms%ntypsy(na)
nh = sphhar%nlh(nsym)
!
!---> generate the irreducible integrals (u(l'):v(lamda,nu:u(l))
!---> for l' .ge. l, but only those that will contribute
!
DO lp = 0,atoms%lmax(n)
lp1 = (lp* (lp+1))/2
DO l = 0,lp
lpl = lp1 + l
!---> loop over non-spherical components of the potential: must
!---> satisfy the triangular conditions and that l'+l+lamda even
!---> (conditions from the gaunt coefficient)
DO lh = 1, nh
lamda = sphhar%llh(lh,nsym)
lmin = lp - l
lmx = lp + l
IF ((mod(lamda+lmx,2).EQ.1) .OR. (lamda.LT.lmin) .OR. (lamda.GT.lmx)) THEN
uvu(lpl,lh) = 0.0
dvd(lpl,lh) = 0.0
uvd(lpl,lh) = 0.0
dvu(lpl,lh) = 0.0
ELSE
DO i = 1,atoms%jri(n)
x(i) = (f(i,1,lp)*f(i,1,l)+f(i,2,lp)*f(i,2,l))* vr0(i,lh)
END DO
CALL intgr3(x,atoms%rmsh(1,n),atoms%dx(n),atoms%jri(n),temp)
uvu(lpl,lh) = temp
DO i = 1,atoms%jri(n)
x(i) = (g(i,1,lp)*f(i,1,l)+g(i,2,lp)*f(i,2,l))* vr0(i,lh)
END DO
CALL intgr3(x,atoms%rmsh(1,n),atoms%dx(n),atoms%jri(n),temp)
dvu(lpl,lh) = temp
DO i = 1,atoms%jri(n)
x(i) = (f(i,1,lp)*g(i,1,l)+f(i,2,lp)*g(i,2,l))* vr0(i,lh)
END DO
CALL intgr3(x,atoms%rmsh(1,n),atoms%dx(n),atoms%jri(n),temp)
uvd(lpl,lh) = temp
DO i = 1,atoms%jri(n)
x(i) = (g(i,1,lp)*g(i,1,l)+g(i,2,lp)*g(i,2,l))* vr0(i,lh)
END DO
CALL intgr3(x,atoms%rmsh(1,n),atoms%dx(n),atoms%jri(n),temp)
dvd(lpl,lh) = temp
END IF
END DO
END DO
END DO
td%tuu(0:,n,jsp) = cmplx(0.0,0.0)
td%tdd(0:,n,jsp) = cmplx(0.0,0.0)
td%tud(0:,n,jsp) = cmplx(0.0,0.0)
td%tdu(0:,n,jsp) = cmplx(0.0,0.0)
indt=0
!---> generate the various t(l'm',lm) matrices for l'm'.ge.lm
!---> loop over l'm'
DO lp = 0,atoms%lmax(n)
lp1 = (lp* (lp+1))/2
DO mp = -lp,lp
lmp = lp* (lp+1) + mp
lmpl = (lmp* (lmp+1))/2
!---> loop over lattice harmonics
DO lh = 1, nh
lamda = sphhar%llh(lh,nsym)
lmin0 = abs(lp-lamda)
IF (lmin0.GT.lp) CYCLE
!--> ensure l+l'+lamda even
lmxx = lp - mod(lamda,2)
mems = sphhar%nmem(lh,nsym)
DO mem = 1,mems
mu = sphhar%mlh(mem,lh,nsym)
m = mp - mu
lmin = max(lmin0,abs(m))
l2 = abs(lmxx-lmin)
lmin = lmin + mod(l2,2)
DO l = lmin,lmxx,2
lm = l* (l+1) + m
IF (lm.GT.lmp) CYCLE
lpl = lp1 + l
lmplm = lmpl + lm
cil = ((ImagUnit** (l-lp))*sphhar%clnu(mem,lh,nsym))*&
gaunt1(lp,lamda,l,mp,mu,m,atoms%lmaxd)
td%tuu(lmplm,n,jsp) = td%tuu(lmplm,n,jsp) + cil*uvu(lpl,lh)
td%tdd(lmplm,n,jsp) = td%tdd(lmplm,n,jsp) + cil*dvd(lpl,lh)
td%tud(lmplm,n,jsp) = td%tud(lmplm,n,jsp) + cil*uvd(lpl,lh)
td%tdu(lmplm,n,jsp) = td%tdu(lmplm,n,jsp) + cil*dvu(lpl,lh)
indt(lmplm) = 1
END DO
END DO
END DO
END DO
END DO
!---> set up mapping array
DO lp = 0,atoms%lmax(n)
DO mp = -lp,lp
lmp = lp* (lp+1) + mp
DO l = 0,atoms%lmax(n)
DO m = -l,l
lm = l* (l+1) + m
IF (lmp.GE.lm) THEN
lmplm = (lmp* (lmp+1))/2 + lm
IF (indt(lmplm).NE.0) THEN
td%ind(lmp,lm,n,jsp) = lmplm
ELSE
td%ind(lmp,lm,n,jsp) = -9999
END IF
ELSE
lmplm = (lm* (lm+1))/2 + lmp
IF (indt(lmplm).NE.0) THEN
td%ind(lmp,lm,n,jsp) = -lmplm
ELSE
td%ind(lmp,lm,n,jsp) = -9999
END IF
END IF
END DO
END DO
END DO
ENDDO
!
!---> set up the t-matrices for the local orbitals,
!---> if there are any
IF (atoms%nlo(n).GE.1) THEN
CALL tlo(atoms,sphhar,jspin,jsp,n,enpara,1,input,v%mt(1,0,n,jsp),&
na,flo,f,g,ud, ud%uuilon(:,:,jspin),ud%duilon(:,:,jspin),ud%ulouilopn(:,:,:,jspin), td)
ENDIF
END SUBROUTINE tlmplm
END MODULE m_tlmplm
This diff is collapsed.
!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------
MODULE m_genMTBasis
CONTAINS
SUBROUTINE genMTBasis(atoms,enpara,vTot,mpi,iType,jspin,l_write,usdus,f,g,flo)
SUBROUTINE genMTBasis(atoms,enpara,vTot,mpi,iType,jspin,usdus,f,g,flo)
USE m_types
USE m_radfun
USE m_radflo
!$ use omp_lib
USE m_types
USE m_radfun
USE m_radflo
IMPLICIT NONE
IMPLICIT NONE
TYPE(t_atoms), INTENT(IN) :: atoms
TYPE(t_enpara), INTENT(IN) :: enpara
TYPE(t_potden), INTENT(IN) :: vTot
TYPE(t_mpi), INTENT(IN) :: mpi
TYPE(t_usdus), INTENT(INOUT) :: usdus
TYPE(t_atoms), INTENT(IN) :: atoms
TYPE(t_enpara), INTENT(IN) :: enpara
TYPE(t_potden), INTENT(IN) :: vTot
TYPE(t_mpi), INTENT(IN) :: mpi
TYPE(t_usdus), INTENT(INOUT) :: usdus
INTEGER, INTENT(IN) :: iType
INTEGER, INTENT(IN) :: jspin
INTEGER, INTENT(IN) :: iType
INTEGER, INTENT(IN) :: jspin
LOGICAL, INTENT(IN) :: l_write
REAL, INTENT(INOUT) :: f(atoms%jmtd,2,0:atoms%lmaxd)
REAL, INTENT(INOUT) :: g(atoms%jmtd,2,0:atoms%lmaxd)
REAL, INTENT(INOUT) :: flo(atoms%jmtd,2,atoms%nlod)
REAL, INTENT(INOUT) :: f(atoms%jmtd,2,0:atoms%lmaxd)
REAL, INTENT(INOUT) :: g(atoms%jmtd,2,0:atoms%lmaxd)
REAL, INTENT(INOUT) :: flo(atoms%jmtd,2,atoms%nlod)
INTEGER :: l,nodeu,noded
REAL :: wronk
INTEGER :: l,nodeu,noded
REAL :: wronk
IF (l_write) WRITE (6,FMT=8000) iType
LOGICAL :: l_write
l_write=mpi%irank==0 &
!$ .and.omp_get_num_threads()==1
DO l = 0,atoms%lmax(iType)
CALL radfun(l,iType,jspin,enpara%el0(l,iType,jspin),vTot%mt(:,0,iType,jspin),atoms,&
f(1,1,l),g(1,1,l),usdus,nodeu,noded,wronk)
IF (l_write) THEN
WRITE (6,FMT=8010) l,enpara%el0(l,iType,jspin),usdus%us(l,iType,jspin),usdus%dus(l,iType,jspin),&
nodeu,usdus%uds(l,iType,jspin),usdus%duds(l,iType,jspin),noded,usdus%ddn(l,iType,jspin),wronk
END IF
END DO
! Generate the extra wavefunctions for the local orbitals, if there are any.
IF (atoms%nlo(iType).GE.1) THEN
CALL radflo(atoms,iType,jspin,enpara%ello0(1,1,jspin),vTot%mt(:,0,iType,jspin),f,g,mpi,&
usdus,usdus%uuilon(1,1,jspin),usdus%duilon(1,1,jspin),usdus%ulouilopn(1,1,1,jspin),flo)
END IF
IF (l_write) WRITE (6,FMT=8000) iType
8000 FORMAT (1x,/,/,' wavefunction parameters for atom type',i3,':',&
/,t32,'radial function',t79,'energy derivative',/,t3,&
'l',t8,'energy',t26,'value',t39,'derivative',t53,&
'nodes',t68,'value',t81,'derivative',t95,'nodes',t107,&
'norm',t119,'wronskian')
8010 FORMAT (i3,f10.5,2 (5x,1p,2e16.7,i5),1p,2e16.7)
DO l = 0,atoms%lmax(iType)
CALL radfun(l,iType,jspin,enpara%el0(l,iType,jspin),vTot%mt(:,0,iType,jspin),atoms,&
f(1,1,l),g(1,1,l),usdus,nodeu,noded,wronk)
IF (l_write) THEN
WRITE (6,FMT=8010) l,enpara%el0(l,iType,jspin),usdus%us(l,iType,jspin),usdus%dus(l,iType,jspin),&
nodeu,usdus%uds(l,iType,jspin),usdus%duds(l,iType,jspin),noded,usdus%ddn(l,iType,jspin),wronk
END IF
END DO
END SUBROUTINE genMTBasis
! Generate the extra wavefunctions for the local orbitals, if there are any.
IF (atoms%nlo(iType).GE.1) THEN
CALL radflo(atoms,iType,jspin,enpara%ello0(1,1,jspin),vTot%mt(:,0,iType,jspin),f,g,mpi,&
usdus,usdus%uuilon(1,1,jspin),usdus%duilon(1,1,jspin),usdus%ulouilopn(1,1,1,jspin),flo)
END IF
8000 FORMAT (1x,/,/,' wavefunction parameters for atom type',i3,':',&
/,t32,'radial function',t79,'energy derivative',/,t3,&
'l',t8,'energy',t26,'value',t39,'derivative',t53,&
'nodes',t68,'value',t81,'derivative',t95,'nodes',t107,&
'norm',t119,'wronskian')
8010 FORMAT (i3,f10.5,2 (5x,1p,2e16.7,i5),1p,2e16.7)
END SUBROUTINE genMTBasis
END MODULE m_genMTBasis
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment