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