Line data Source code
1 : !--------------------------------------------------------------------------------
2 : ! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
3 : ! This file is part of FLEUR and available as free software under the conditions
4 : ! of the MIT license as expressed in the LICENSE file in more detail.
5 : !--------------------------------------------------------------------------------
6 :
7 : MODULE m_rhonmtlo
8 : !
9 : !***********************************************************************
10 : ! This subroutine is the equivalent of rhomt for the local orbital
11 : ! contributions to the charge.
12 : ! acnmt, bcnmt, ccnmt are the equivalents of uunmt, ddnmt, udnmt dunmt
13 : ! in rhonmt
14 : ! p.kurz sept. 1996
15 : !***********************************************************************
16 : !
17 : CONTAINS
18 0 : SUBROUTINE rhonmtlo(atoms,sphhar,sym,ne,we,eigVecCoeffs,denCoeffs,ispin)
19 : USE m_gaunt,ONLY:gaunt1
20 : USE m_types
21 : use m_constants
22 :
23 : IMPLICIT NONE
24 :
25 : TYPE(t_sphhar), INTENT(IN) :: sphhar
26 : TYPE(t_atoms), INTENT(IN) :: atoms
27 : TYPE(t_sym), INTENT(IN) :: sym
28 : TYPE(t_eigVecCoeffs), INTENT(IN) :: eigVecCoeffs
29 : TYPE(t_denCoeffs), INTENT(INOUT) :: denCoeffs
30 :
31 : INTEGER, INTENT (IN) :: ne, ispin
32 :
33 : REAL, INTENT (IN) :: we(:)!(nobd)
34 :
35 : ! .. Local Scalars ..
36 : COMPLEX cmv,fact,cf1
37 : INTEGER i,jmem,l,lh,lmp,lo,lop,lp,lpmax,lpmax0,lpmin,lpmin0,m,lpp ,mp,mpp,na,neqat0,nn,ntyp
38 : ! ..
39 : ! ..
40 :
41 : !---> for optimal performance consider only
42 : !---> those combinations of l,l',l'',m,m',m'' that satisfy the three
43 : !---> conditions for non-zero gaunt-coeff. i.e.
44 : !---> |l - l''| <= l' <= l + l'' (triangular condition)
45 : !---> m' + m'' = m and l + l' + l'' even
46 :
47 0 : DO ntyp = 1,atoms%ntype
48 0 : neqat0 = atoms%firstAtom(ntyp) - 1
49 : !---> loop over the lattice harmonics
50 0 : DO lh = 1,sphhar%nlh(sym%ntypsy(neqat0+1))
51 0 : lpp = sphhar%llh(lh,sym%ntypsy(neqat0+1))
52 0 : DO jmem = 1,sphhar%nmem(lh,sym%ntypsy(neqat0+1))
53 0 : mpp = sphhar%mlh(jmem,lh,sym%ntypsy(neqat0+1))
54 0 : cmv = CONJG(sphhar%clnu(jmem,lh,sym%ntypsy(neqat0+1)))
55 0 : DO lo = 1,atoms%nlo(ntyp)
56 0 : l = atoms%llo(lo,ntyp)
57 0 : lpmin0 = ABS(l-lpp)
58 0 : lpmax0 = l + lpp
59 : !---> check that lpmax is smaller than the max l of the
60 : !---> wavefunction expansion at this atom
61 0 : lpmax = MIN(lpmax0,atoms%lmax(ntyp))
62 : !---> make sure that l + l'' + lpmax is even
63 0 : lpmax = lpmax - MOD(l+lpp+lpmax,2)
64 0 : DO m = -l,l
65 :
66 : !---> add flapw - local orbital cross-terms
67 :
68 : !---> add terms containing gaunt1(l,lp,lpp,m,mp,mpp)
69 : !---> note that gaunt1(l,lp,lpp,m,mp,mpp) computes the
70 : !---> integral of conjg(y(l,m))*y(lp,mp)*y(lpp,mpp),
71 : !---> however, since the gaunt coef. are real, this is
72 : !---> the same as int. y(l,m)*conjg(y(lp,mp)*y(lpp,mpp))
73 0 : mp = m - mpp
74 0 : lpmin = MAX(lpmin0,ABS(mp))
75 : !---> make sure that l + l'' + lpmin is even
76 0 : lpmin = lpmin + MOD(ABS(lpmax-lpmin),2)
77 : !---> loop over l'
78 0 : DO lp = lpmin,lpmax,2
79 0 : lmp = lp* (lp+1) + mp
80 0 : fact = cmv* (ImagUnit** (l-lp))*gaunt1(l,lp,lpp,m,mp,mpp,atoms%lmaxd)
81 0 : na = neqat0
82 0 : DO nn = 1,atoms%neq(ntyp)
83 0 : na = na + 1
84 0 : DO i = 1,ne
85 0 : cf1 = fact * eigVecCoeffs%ccof(m,i,lo,na,ispin)
86 : denCoeffs%acnmt(lp,lo,lh,ntyp,ispin) = denCoeffs%acnmt(lp,lo,lh,ntyp,ispin) +&
87 0 : we(i) * REAL(cf1 * CONJG(eigVecCoeffs%abcof(i,lmp,0,na,ispin)) )
88 : denCoeffs%bcnmt(lp,lo,lh,ntyp,ispin) = denCoeffs%bcnmt(lp,lo,lh,ntyp,ispin) +&
89 0 : we(i) * REAL(cf1 * CONJG(eigVecCoeffs%abcof(i,lmp,1,na,ispin)) )
90 : END DO
91 : END DO
92 : END DO
93 :
94 : !---> add terms containing gaunt1(lp,l,lpp,mp,m,mpp)
95 0 : mp = m + mpp
96 0 : lpmin = MAX(lpmin0,ABS(mp))
97 : !---> make sure that l + l'' + lpmin is even
98 0 : lpmin = lpmin + MOD(ABS(lpmax-lpmin),2)
99 : !---> loop over l'
100 0 : DO lp = lpmin,lpmax,2
101 0 : lmp = lp* (lp+1) + mp
102 0 : fact = cmv* (ImagUnit** (lp-l))*gaunt1(lp,l,lpp,mp,m,mpp,atoms%lmaxd)
103 0 : na = neqat0
104 0 : DO nn = 1,atoms%neq(ntyp)
105 0 : na = na + 1
106 0 : DO i = 1,ne
107 0 : cf1 = fact * CONJG(eigVecCoeffs%ccof(m,i,lo,na,ispin))
108 : denCoeffs%acnmt(lp,lo,lh,ntyp,ispin) = denCoeffs%acnmt(lp,lo,lh,ntyp,ispin) +&
109 0 : we(i) * REAL(cf1 * eigVecCoeffs%abcof(i,lmp,0,na,ispin) )
110 : denCoeffs%bcnmt(lp,lo,lh,ntyp,ispin) = denCoeffs%bcnmt(lp,lo,lh,ntyp,ispin) +&
111 0 : we(i) * REAL(cf1 * eigVecCoeffs%abcof(i,lmp,1,na,ispin) )
112 : END DO
113 : END DO
114 : END DO
115 :
116 : !---> add local orbital - local orbital terms
117 0 : DO lop = 1,atoms%nlo(ntyp)
118 0 : lp = atoms%llo(lop,ntyp)
119 :
120 : !---> add terms containing gaunt1(l,lp,lpp,m,mp,mpp)
121 0 : mp = m - mpp
122 0 : IF ((ABS(l-lpp).LE.lp) .AND.(lp.LE. (l+lpp)) .AND.(MOD(l+lp+lpp,2).EQ.0) .AND.(ABS(mp).LE.lp)) THEN
123 0 : fact = cmv* (ImagUnit** (l-lp))*gaunt1(l,lp,lpp,m,mp,mpp,atoms%lmaxd)
124 0 : na = neqat0
125 0 : DO nn = 1,atoms%neq(ntyp)
126 0 : na = na + 1
127 0 : DO i = 1,ne
128 : denCoeffs%ccnmt(lop,lo,lh,ntyp,ispin) =&
129 : denCoeffs%ccnmt(lop,lo,lh,ntyp,ispin) +&
130 0 : we(i) * REAL(fact * CONJG(eigVecCoeffs%ccof(mp,i,lop,na,ispin))*eigVecCoeffs%ccof(m,i,lo,na,ispin))
131 : END DO
132 : END DO
133 : END IF
134 :
135 : END DO
136 : END DO
137 : END DO
138 : END DO
139 : END DO
140 : END DO
141 :
142 0 : END SUBROUTINE rhonmtlo
143 : END MODULE m_rhonmtlo
|
