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_wann_anglmom
8 : !***********************************************************************
9 : ! Compute matrix elements of angular momentum operator
10 : ! in the muffin-tin spheres.
11 : !
12 : ! Frank Freimuth
13 : !***********************************************************************
14 : CONTAINS
15 0 : SUBROUTINE wann_anglmom(atoms,usdus,jspin,acof,bcof,ccof, mmn)
16 : USE m_types
17 : IMPLICIT NONE
18 : ! .. scalar arguments ..
19 : TYPE(t_atoms),INTENT(in)::atoms
20 : TYPE(t_usdus),INTENT(in)::usdus
21 : INTEGER,INTENT(IN) ::jspin
22 : ! .. array arguments ..
23 : COMPLEX, INTENT (in) :: ccof(-atoms%llod:,:,:,:) !ccof(-llod:llod,noccbd,atoms%nlod,natd)
24 : COMPLEX, INTENT (in) :: acof(:,0:,:)!acof(noccbd,0:lmd,natd)
25 : COMPLEX, INTENT (in) :: bcof(:,0:,:)!bcof(noccbd,0:lmd,natd)
26 : COMPLEX, INTENT (inout) :: mmn(:,:,:)!mmn(3,noccbd,noccbd)
27 : ! .. local scalars ..
28 : LOGICAL :: l_select
29 : INTEGER :: i,j,l,lo,lop,m,natom,nn,ntyp
30 : INTEGER :: nt1,nt2,lm,n,ll1,indat
31 : COMPLEX :: suma_z,sumb_z
32 : COMPLEX :: suma_p,sumb_p
33 : COMPLEX :: suma_m,sumb_m
34 : COMPLEX :: suma_x,sumb_x
35 : COMPLEX :: suma_y,sumb_y
36 : REAL :: lplus,lminus
37 : ! ..
38 : ! .. local arrays ..
39 0 : COMPLEX, ALLOCATABLE :: qlo_z(:,:,:,:,:)
40 0 : COMPLEX, ALLOCATABLE :: qlo_p(:,:,:,:,:)
41 0 : COMPLEX, ALLOCATABLE :: qlo_m(:,:,:,:,:)
42 :
43 0 : COMPLEX, ALLOCATABLE :: qaclo_z(:,:,:,:),qbclo_z(:,:,:,:)
44 0 : COMPLEX, ALLOCATABLE :: qaclo_p(:,:,:,:),qbclo_p(:,:,:,:)
45 0 : COMPLEX, ALLOCATABLE :: qaclo_m(:,:,:,:),qbclo_m(:,:,:,:)
46 : ! ..
47 : ! .. intrinsic functions ..
48 : INTRINSIC conjg
49 :
50 : ALLOCATE (qlo_z(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%nlod,atoms%ntype) &
51 : ,qaclo_z(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%ntype),&
52 0 : qbclo_z(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%ntype) )
53 :
54 : ALLOCATE (qlo_p(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%nlod,atoms%ntype) &
55 : ,qaclo_p(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%ntype),&
56 0 : qbclo_p(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%ntype) )
57 :
58 : ALLOCATE (qlo_m(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%nlod,atoms%ntype)&
59 : ,qaclo_m(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%ntype),&
60 0 : qbclo_m(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%ntype) )
61 :
62 0 : INQUIRE(file='select_anglmom',exist=l_select)
63 0 : WRITE(*,*)'select_anglmom: ',l_select
64 0 : IF(l_select) THEN
65 0 : OPEN(866,file='select_anglmom')
66 0 : READ(866,*)indat
67 0 : CLOSE(866)
68 0 : WRITE(*,*)'anglmom for atom=',indat
69 0 : WRITE(*,*)atoms%ntype
70 0 : WRITE(*,*)atoms%neq(indat)
71 : ENDIF
72 :
73 : !-----> lapw-lapw-Terms
74 0 : DO i = 1,SIZE(acof,1)
75 0 : DO j = 1,SIZE(acof,1)
76 0 : DO n = 1,atoms%ntype
77 0 : nt1 = atoms%firstAtom(n)
78 0 : nt2 = nt1 + atoms%neq(n) - 1
79 0 : DO l = 0,atoms%lmax(n)
80 0 : suma_z = CMPLX(0.,0.); sumb_z = CMPLX(0.,0.)
81 0 : suma_m = CMPLX(0.,0.); sumb_m = CMPLX(0.,0.)
82 0 : suma_p = CMPLX(0.,0.); sumb_p = CMPLX(0.,0.)
83 0 : IF(l_select .AND. (n.NE.indat)) CYCLE
84 0 : ll1 = l* (l+1)
85 0 : DO m = -l,l
86 0 : lm = ll1 + m
87 0 : lplus=SQRT(REAL( (l-m)*(l+m+1) ) )
88 0 : lminus=SQRT(REAL( (l+m)*(l-m+1) ) )
89 0 : DO natom = nt1,nt2
90 : suma_z = suma_z + acof(i,lm,natom)*&
91 0 : CONJG(acof(j,lm,natom))*REAL(m)
92 : sumb_z = sumb_z + bcof(i,lm,natom)*&
93 0 : CONJG(bcof(j,lm,natom))*REAL(m)
94 0 : IF(m+1.LE.l)THEN
95 : suma_p = suma_p + acof(i,lm,natom)*&
96 0 : CONJG(acof(j,lm+1,natom))*lplus
97 : sumb_p = sumb_p + bcof(i,lm,natom)*&
98 0 : CONJG(bcof(j,lm+1,natom))*lplus
99 : ENDIF
100 0 : IF(m-1.GE.-l)THEN
101 : suma_m = suma_m + acof(i,lm,natom)*&
102 0 : CONJG(acof(j,lm-1,natom))*lminus
103 : sumb_m = sumb_m + bcof(i,lm,natom)*&
104 0 : CONJG(bcof(j,lm-1,natom))*lminus
105 : ENDIF
106 : ENDDO
107 : ENDDO
108 0 : mmn(3,j,i) = mmn(3,j,i) + (suma_z+sumb_z*usdus%ddn(l,n,jspin))
109 :
110 0 : suma_x=0.5*(suma_p+suma_m)
111 0 : sumb_x=0.5*(sumb_p+sumb_m)
112 0 : mmn(1,j,i) = mmn(1,j,i) + (suma_x+sumb_x*usdus%ddn(l,n,jspin))
113 :
114 0 : suma_y=CMPLX(0.0,-0.5)*(suma_p-suma_m)
115 0 : sumb_y=CMPLX(0.0,-0.5)*(sumb_p-sumb_m)
116 0 : mmn(2,j,i) = mmn(2,j,i) + (suma_y+sumb_y*usdus%ddn(l,n,jspin))
117 : ENDDO ! l
118 : ENDDO ! n
119 : ENDDO ! j
120 : ENDDO ! i
121 :
122 :
123 : !---> Terms involving local orbitals.
124 0 : qlo_z = 0.0; qlo_p = 0.0; qlo_m = 0.0
125 0 : qaclo_z = 0.0; qaclo_p = 0.0; qaclo_m = 0.0
126 0 : qbclo_z = 0.0; qbclo_p = 0.0; qbclo_m = 0.0
127 :
128 : natom = 0
129 0 : DO ntyp = 1,atoms%ntype
130 0 : DO nn = 1,atoms%neq(ntyp)
131 0 : natom = natom + 1
132 0 : IF(l_select .AND. (ntyp.NE.indat)) CYCLE
133 0 : DO lo = 1,atoms%nlo(ntyp)
134 0 : l = atoms%llo(lo,ntyp)
135 0 : ll1 = l* (l+1)
136 0 : DO m = -l,l
137 0 : lm = ll1 + m
138 0 : lplus=SQRT(REAL( (l-m)*(l+m+1) ) )
139 0 : lminus=SQRT(REAL( (l+m)*(l-m+1) ) )
140 0 : DO i = 1,SIZE(acof,1)
141 0 : DO j = 1,SIZE(acof,1)
142 : qbclo_z(j,i,lo,ntyp) = qbclo_z(j,i,lo,ntyp) + (&
143 : bcof(i,lm,natom) * CONJG(ccof(m,j,lo,natom)) +&
144 0 : ccof(m,i,lo,natom)*CONJG(bcof(j,lm,natom)) )*REAL(m)
145 :
146 : qaclo_z(j,i,lo,ntyp) = qaclo_z(j,i,lo,ntyp) + (&
147 : acof(i,lm,natom) * CONJG(ccof(m,j,lo,natom)) +&
148 0 : ccof(m,i,lo,natom)*CONJG(acof(j,lm,natom)) )*REAL(m)
149 0 : IF(m+1.LE.l)THEN
150 : qbclo_p(j,i,lo,ntyp) = qbclo_p(j,i,lo,ntyp) + (&
151 : bcof(i,lm,natom) * CONJG(ccof(m+1,j,lo,natom)) +&
152 0 : ccof(m,i,lo,natom)*CONJG(bcof(j,lm+1,natom)) )*lplus
153 :
154 : qaclo_p(j,i,lo,ntyp) = qaclo_p(j,i,lo,ntyp) + (&
155 : acof(i,lm,natom) * CONJG(ccof(m+1,j,lo,natom)) +&
156 0 : ccof(m,i,lo,natom)*CONJG(acof(j,lm+1,natom)) )*lplus
157 : ENDIF
158 0 : IF(m-1.GE.-l)THEN
159 : qbclo_m(j,i,lo,ntyp) = qbclo_m(j,i,lo,ntyp) + (&
160 : bcof(i,lm,natom) * CONJG(ccof(m-1,j,lo,natom)) +&
161 0 : ccof(m,i,lo,natom)*CONJG(bcof(j,lm-1,natom)) )*lminus
162 :
163 : qaclo_m(j,i,lo,ntyp) = qaclo_m(j,i,lo,ntyp) + (&
164 : acof(i,lm,natom) * CONJG(ccof(m-1,j,lo,natom)) +&
165 0 : ccof(m,i,lo,natom)*CONJG(acof(j,lm-1,natom)) )*lminus
166 : ENDIF
167 :
168 : ENDDO !j
169 : ENDDO !i
170 : ENDDO !m
171 0 : DO lop = 1,atoms%nlo(ntyp)
172 0 : IF (atoms%llo(lop,ntyp).EQ.l) THEN
173 0 : DO m = -l,l
174 0 : lplus=SQRT(REAL( (l-m)*(l+m+1) ) )
175 0 : lminus=SQRT(REAL( (l+m)*(l-m+1) ) )
176 0 : DO i = 1,SIZE(acof,1)
177 0 : DO j = 1,SIZE(acof,1)
178 : qlo_z(j,i,lop,lo,ntyp) = qlo_z(j,i,lop,lo,ntyp) + &
179 : CONJG(ccof(m,j,lop,natom))&
180 0 : *ccof(m,i,lo,natom)*REAL(m)
181 0 : IF(m+1.LE.l)THEN
182 : qlo_p(j,i,lop,lo,ntyp) = &
183 : qlo_p(j,i,lop,lo,ntyp) + &
184 : CONJG(ccof(m+1,j,lop,natom))&
185 0 : *ccof(m,i,lo,natom)*lplus
186 :
187 : ENDIF
188 0 : IF(m-1.GE.-l)THEN
189 : qlo_m(j,i,lop,lo,ntyp) = &
190 : qlo_m(j,i,lop,lo,ntyp) + &
191 : CONJG(ccof(m-1,j,lop,natom))&
192 0 : *ccof(m,i,lo,natom)*lminus
193 : ENDIF
194 : ENDDO ! j
195 : ENDDO ! i
196 : ENDDO ! m
197 : ENDIF
198 : ENDDO ! lop
199 : ENDDO ! lo
200 : ENDDO ! nn
201 : ENDDO ! ntyp
202 : !---> perform summation of the coefficients with the integrals
203 : !---> of the radial basis functions
204 0 : DO ntyp = 1,atoms%ntype
205 0 : IF(l_select .AND. (ntyp.NE.indat) ) CYCLE
206 0 : DO lo = 1,atoms%nlo(ntyp)
207 0 : l = atoms%llo(lo,ntyp)
208 0 : DO j = 1,SIZE(acof,1)
209 0 : DO i = 1,SIZE(acof,1)
210 : mmn(3,i,j)= mmn(3,i,j) + &
211 : qaclo_z(i,j,lo,ntyp)*usdus%uulon(lo,ntyp,jspin) +&
212 0 : qbclo_z(i,j,lo,ntyp)*usdus%dulon(lo,ntyp,jspin)
213 :
214 : suma_p=qaclo_p(i,j,lo,ntyp)*usdus%uulon(lo,ntyp,jspin) +&
215 0 : qbclo_p(i,j,lo,ntyp)*usdus%dulon(lo,ntyp,jspin)
216 :
217 : suma_m=qaclo_m(i,j,lo,ntyp)*usdus%uulon(lo,ntyp,jspin) +&
218 0 : qbclo_m(i,j,lo,ntyp)*usdus%dulon(lo,ntyp,jspin)
219 :
220 0 : suma_x= 0.5*(suma_p+suma_m)
221 0 : suma_y=CMPLX(0.0,-0.5)*(suma_p-suma_m)
222 :
223 0 : mmn(1,i,j)= mmn(1,i,j) + suma_x
224 0 : mmn(2,i,j)= mmn(2,i,j) + suma_y
225 :
226 : ENDDO !i
227 : ENDDO !j
228 0 : DO lop = 1,atoms%nlo(ntyp)
229 0 : IF (atoms%llo(lop,ntyp).EQ.l) THEN
230 0 : DO j = 1,SIZE(acof,1)
231 0 : DO i = 1,SIZE(acof,1)
232 : mmn(3,i,j) = mmn(3,i,j) + &
233 0 : qlo_z(i,j,lop,lo,ntyp)*usdus%uloulopn(lop,lo,ntyp,jspin)
234 0 : suma_p=qlo_p(i,j,lop,lo,ntyp)*usdus%uloulopn(lop,lo,ntyp,jspin)
235 0 : suma_m=qlo_m(i,j,lop,lo,ntyp)*usdus%uloulopn(lop,lo,ntyp,jspin)
236 0 : mmn(1,i,j) = mmn(1,i,j) + 0.5*(suma_p+suma_m)
237 : mmn(2,i,j) = mmn(2,i,j) + &
238 0 : CMPLX(0.0,-0.5)*(suma_p-suma_m)
239 : ENDDO ! i
240 : ENDDO ! j
241 : ENDIF
242 : ENDDO !lop
243 : ENDDO !lo
244 : ENDDO !ntyp
245 0 : DEALLOCATE ( qlo_z,qaclo_z,qbclo_z )
246 0 : DEALLOCATE ( qlo_m,qaclo_m,qbclo_m )
247 0 : DEALLOCATE ( qlo_p,qaclo_p,qbclo_p )
248 :
249 0 : END SUBROUTINE wann_anglmom
250 : END MODULE m_wann_anglmom
|
