Line data Source code
1 : MODULE m_orbmom2
2 : ! ***************************************************************
3 : ! perform the sum over m (for each l) and calculate the
4 : ! spherical contribution to orbital moment.
5 : ! ***************************************************************
6 : !
7 : CONTAINS
8 183 : SUBROUTINE orbmom2(atoms,itype,ispin,ddn,orb,uulon,dulon,uloulopn,clmom)
9 :
10 : ! USE m_types, ONLY : t_orb,t_orbl,t_orblo
11 : USE m_types
12 : USE m_constants
13 : IMPLICIT NONE
14 :
15 : TYPE(t_atoms),INTENT(IN) :: atoms
16 : ! ..
17 : ! .. Scalar Arguments ..
18 : INTEGER, INTENT (IN) :: itype, ispin
19 : ! ..
20 : ! .. Array Arguments ..
21 : REAL, INTENT (IN) :: ddn(0:atoms%lmaxd),uulon(atoms%nlod),dulon(atoms%nlod)
22 : REAL, INTENT (IN) :: uloulopn(atoms%nlod,atoms%nlod)
23 : TYPE (t_orb), INTENT (IN) :: orb
24 : REAL, INTENT (OUT) :: clmom(3)
25 : ! ..
26 : ! .. Local Scalars ..
27 : INTEGER l , ilo, ilop,m
28 : REAL qmtt, qmttx, qmtty, sumlm
29 : COMPLEX orbp, orbm
30 : ! ..
31 : ! .. Local Arrays ..
32 183 : REAL qmtl(0:atoms%lmaxd),qmtlx(0:atoms%lmaxd),qmtly(0:atoms%lmaxd)
33 :
34 183 : qmtt = 0.
35 183 : qmttx = 0.
36 183 : qmtty = 0.
37 1900 : DO l = 0,atoms%lmax(itype)
38 : !---> lm-decomposed density for each atom type
39 1717 : qmtl(l) = 0.
40 1717 : qmtlx(l) = 0.
41 1717 : qmtly(l) = 0.
42 18147 : DO m = -l,l
43 : ! lz
44 16247 : sumlm = m * (orb%uu(l,m,itype,ispin) + orb%dd(l,m,itype,ispin) * ddn(l) )
45 : ! lx,ly
46 16247 : orbp = SQRT(REAL((l-m)*(l+m+1))) * ( orb%uup(l,m,itype,ispin) + orb%ddp(l,m,itype,ispin) * ddn(l) )
47 :
48 16247 : orbm = SQRT(REAL((l+m)*(l-m+1))) * ( orb%uum(l,m,itype,ispin) + orb%ddm(l,m,itype,ispin) * ddn(l) )
49 : !+gu
50 16247 : IF (m.EQ.l) orbp = CMPLX(0.0,0.0)
51 16247 : IF (m.EQ.-l) orbm = CMPLX(0.0,0.0)
52 : !+gu
53 16247 : qmtl(l) = qmtl(l) + sumlm
54 16247 : qmtlx(l) = qmtlx(l) + 0.5*( REAL(orbp)+ REAL(orbm))
55 17964 : qmtly(l) = qmtly(l) + 0.5*(AIMAG(orbp)-AIMAG(orbm))
56 : !
57 : ENDDO
58 : ENDDO
59 : !
60 : ! --> LO contribution
61 360 : DO ilo = 1, atoms%nlo(itype)
62 177 : l = atoms%llo(ilo,itype)
63 554 : DO m = -l,l
64 377 : sumlm = m * (orb%uulo(ilo,m,itype,ispin) * uulon(ilo) + orb%dulo(ilo,m,itype,ispin) * dulon(ilo) )
65 :
66 : orbp = SQRT(REAL((l-m)*(l+m+1))) * ( orb%uulop(ilo,m,itype,ispin) * uulon(ilo) +&
67 377 : orb%dulop(ilo,m,itype,ispin) * dulon(ilo) )
68 :
69 : orbm = SQRT(REAL((l+m)*(l-m+1))) * ( orb%uulom(ilo,m,itype,ispin) * uulon(ilo) +&
70 377 : orb%dulom(ilo,m,itype,ispin) * dulon(ilo) )
71 :
72 377 : IF (m.EQ.l) orbp = CMPLX(0.0,0.0)
73 377 : IF (m.EQ.-l) orbm = CMPLX(0.0,0.0)
74 :
75 377 : qmtl(l) = qmtl(l) + sumlm
76 377 : qmtlx(l) = qmtlx(l) + 0.5*( REAL(orbp)+ REAL(orbm))
77 554 : qmtly(l) = qmtly(l) + 0.5*(AIMAG(orbp)-AIMAG(orbm))
78 : ENDDO
79 693 : DO ilop = 1, atoms%nlo(itype)
80 510 : IF (atoms%llo(ilop,itype).EQ.l) THEN
81 554 : DO m = -l,l
82 377 : sumlm = m * orb%z(ilo,ilop,m,itype,ispin) * uloulopn(ilo,ilop)
83 377 : orbp = SQRT(REAL((l-m)*(l+m+1))) * orb%p(ilo,ilop,m,itype,ispin) * uloulopn(ilo,ilop)
84 377 : orbm = SQRT(REAL((l+m)*(l-m+1))) * orb%m(ilo,ilop,m,itype,ispin) * uloulopn(ilo,ilop)
85 377 : IF (m.EQ.l) orbp = CMPLX(0.0,0.0)
86 377 : IF (m.EQ.-l) orbm = CMPLX(0.0,0.0)
87 :
88 377 : qmtl(l) = qmtl(l) + sumlm
89 377 : qmtlx(l) = qmtlx(l) + 0.5*( REAL(orbp)+ REAL(orbm))
90 554 : qmtly(l) = qmtly(l) + 0.5*(AIMAG(orbp)-AIMAG(orbm))
91 : ENDDO
92 : ENDIF
93 : ENDDO
94 : ENDDO
95 : !
96 : ! --> sum up & print
97 1900 : DO l = 0,atoms%lmax(itype)
98 1717 : qmtl(l) = qmtl(l) / atoms%neq(itype)
99 1717 : qmtlx(l) = qmtlx(l) / atoms%neq(itype)
100 1717 : qmtly(l) = qmtly(l) / atoms%neq(itype)
101 1717 : qmtt = qmtt + qmtl(l)
102 1717 : qmttx = qmttx + qmtlx(l)
103 1900 : qmtty = qmtty + qmtly(l)
104 : ENDDO
105 183 : clmom(1) = qmttx
106 183 : clmom(2) = qmtty
107 183 : clmom(3) = qmtt
108 :
109 : ! The following output was commented out, because the subroutine is now used in parallel.
110 : ! Jan. 2019 U.Alekseeva
111 : !
112 : ! WRITE (oUnit,FMT=8100) itype, (qmtl(l),l=0,3), qmtt
113 : ! WRITE (oUnit,FMT=8100) itype, (qmtlx(l),l=0,3),qmttx
114 : ! WRITE (oUnit,FMT=8100) itype, (qmtly(l),l=0,3),qmtty
115 : !8100 FORMAT (' -->',i2,2x,4f9.5,2x,f9.5)
116 :
117 183 : END SUBROUTINE orbmom2
118 : END MODULE m_orbmom2
|
