q_mt_sl.f90 5.17 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
MODULE m_qmtsl
CONTAINS
  !***********************************************************************
  ! Calculates the mt-spheres contribution to the layer charge for states 
  !  {En} at the current k-point. 
  !                                      Yury Koroteev 2003
  !                     from eparas.F  by  Philipp Kurz 99/04
  !
  !***********************************************************************
  !
  SUBROUTINE q_mt_sl(jsp,atoms,nobd,nsld, ikpt,ne,ccof, skip_t,noccbd,acof,bcof,usdus, &
       nmtsl,nsl, qmtslk)
    USE m_types
    IMPLICIT NONE
    TYPE(t_usdus),INTENT(IN)   :: usdus
    TYPE(t_atoms),INTENT(IN)   :: atoms
    !     ..
    !     .. Scalar Arguments ..
    INTEGER, INTENT (IN) :: nobd,jsp      
    INTEGER, INTENT (IN) :: ne,ikpt ,skip_t,noccbd
    INTEGER, INTENT (IN) :: nsl,nsld
    !     ..
    !     .. Array Arguments ..
Daniel Wortmann's avatar
Daniel Wortmann committed
24 25 26 27
    COMPLEX, INTENT (IN)  :: ccof(-atoms%llod:atoms%llod,nobd,atoms%nlod,atoms%nat)
    COMPLEX, INTENT (IN)  :: acof(:,0:,:)!(nobd,0:dimension%lmd,atoms%nat)
    COMPLEX, INTENT (IN)  :: bcof(:,0:,:)!(nobd,0:dimension%lmd,atoms%nat)
    INTEGER, INTENT (IN)  :: nmtsl(atoms%ntype,atoms%nat)
28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43
    REAL,    INTENT (OUT) :: qmtslk(:,:)!(nsl,dimension%neigd)
    !     ..
    !     .. Local Scalars ..
    INTEGER i,l,lo ,natom,nn,ntyp,nt1,nt2,m
    INTEGER lm,n,ll1,ipol,icore,index,nl
    REAL fac,sabd,ss,qq
    COMPLEX suma,sumb,sumab,sumba
    !     ..
    !     .. Local Arrays ..
    REAL, ALLOCATABLE :: qlo(:,:,:),qmt(:,:),qmtlo(:,:)
    REAL, ALLOCATABLE :: qaclo(:,:,:),qbclo(:,:,:),qmttot(:,:)
    !     ..
    !     .. Intrinsic Functions ..
    INTRINSIC conjg,cmplx


Daniel Wortmann's avatar
Daniel Wortmann committed
44 45 46
    ALLOCATE ( qlo(nobd,atoms%nlod,atoms%ntype),qmt(atoms%ntype,SIZE(qmtslk,2)) )
    ALLOCATE ( qaclo(nobd,atoms%nlod,atoms%ntype),qbclo(nobd,atoms%nlod,atoms%ntype) )
    ALLOCATE ( qmttot(atoms%ntype,SIZE(qmtslk,2)),qmtlo(atoms%ntype,SIZE(qmtslk,2)) )
47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155
    !
    !--->    l-decomposed density for each valence state
    !
    !         DO 140 i = (skip_t+1),ne    ! this I need for all states
    DO i = 1,ne              ! skip in next loop
       nt1 = 1
       DO n = 1,atoms%ntype
          fac = 1./atoms%neq(n)
          nt2 = nt1 + atoms%neq(n) - 1
          sabd = 0.0
          DO l = 0,atoms%lmax(n)
             suma = CMPLX(0.,0.)
             sumb = CMPLX(0.,0.)
             ll1 = l* (l+1)
             DO m = -l,l
                lm = ll1 + m
                DO natom = nt1,nt2
                   suma = suma + acof(i,lm,natom)*CONJG(acof(i,lm,natom))
                   sumb = sumb + bcof(i,lm,natom)*CONJG(bcof(i,lm,natom))
                ENDDO
             enddo
             ss = suma + sumb*usdus%ddn(l,n,jsp)
             sabd = sabd + ss
          enddo
          qmt(n,i) = sabd*fac
          nt1 = nt1 + atoms%neq(n)
       enddo
    enddo
    !                  
    !---> initialize qlo
    !
    qlo=0.0
    qaclo=0.0
    qbclo=0.0
    !
    !---> density for each local orbital and valence state
    !
    natom = 0
    DO ntyp = 1,atoms%ntype
       DO nn = 1,atoms%neq(ntyp)
          natom = natom + 1
          DO lo = 1,atoms%nlo(ntyp)
             l = atoms%llo(lo,ntyp)
             ll1 = l* (l+1)
             DO i = 1,ne
                DO m = -l,l
                   lm = ll1 + m
                   qlo(i,lo,ntyp) = qlo(i,lo,ntyp) +&
                        ccof(m,i,lo,natom)*CONJG(ccof(m,i,lo,natom))
                   qbclo(i,lo,ntyp) = qbclo(i,lo,ntyp) +&
                        bcof(i,lm,natom)*CONJG(ccof(m,i,lo,natom)) +&
                        ccof(m,i,lo,natom)*CONJG(bcof(i,lm,natom))
                   qaclo(i,lo,ntyp) = qaclo(i,lo,ntyp) +&
                        acof(i,lm,natom)*CONJG(ccof(m,i,lo,natom)) +&
                        ccof(m,i,lo,natom)*CONJG(acof(i,lm,natom))
                ENDDO
             ENDDO
          ENDDO
       ENDDO
    ENDDO
    natom = 1
    DO ntyp = 1,atoms%ntype
       IF (atoms%invsat(natom).EQ.1) THEN
          DO lo = 1,atoms%nlo(ntyp)
             DO i = 1,ne
                qlo(i,lo,ntyp) = 2*qlo(i,lo,ntyp)
             ENDDO
          ENDDO
       ENDIF
       natom = natom + atoms%neq(ntyp)
    ENDDO
    !
    !--->  l-decomposed density for each valence state
    !--->      ( a contribution from local orbitals)
    !--->                       and
    !--->  total  l-decomposed density for each valence state
    !
    DO i = 1,ne
       DO ntyp = 1,atoms%ntype
          fac = 1.0/atoms%neq(ntyp)
          qq = 0.0
          DO lo = 1,atoms%nlo(ntyp)
             qq = qq + qlo(i,lo,ntyp)*usdus%uloulopn(lo,lo,ntyp,jsp) +&
                  qaclo(i,lo,ntyp)*usdus%uulon(lo,ntyp,jsp)     +&
                  qbclo(i,lo,ntyp)*usdus%dulon(lo,ntyp,jsp)    
          ENDDO
          qmtlo(ntyp,i) = qq*fac
          qmttot(ntyp,i) = qmt(ntyp,i) + qmtlo(ntyp,i)
       ENDDO
    ENDDO
    !
    DO i = 1,ne
       DO nl = 1,nsl
          qq = 0.0
          DO ntyp = 1,atoms%ntype
             qq = qq + qmttot(ntyp,i)*nmtsl(ntyp,nl)
          ENDDO
          qmtslk(nl,i) = qq
       ENDDO
    ENDDO
    !        DO ntyp = 1,ntype
    !        write(*,*) qmttot(ntyp,1)
    !        write(*,*) (nmtsl(ntyp,nl),nl=1,nsl)
    !        ENDDO
    !
    DEALLOCATE ( qlo,qmt,qmtlo,qaclo,qbclo,qmttot )

  END SUBROUTINE q_mt_sl
END MODULE m_qmtsl