orbmom2.f90 4.06 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 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 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
MODULE m_orbmom2
  !     ***************************************************************
  !     perform the sum over m (for each l) and calculate the
  !     spherical contribution to orbital moment.                
  !     ***************************************************************
  !
CONTAINS
  SUBROUTINE orbmom2(atoms,itype,ddn,orb, &
       uulon,dulon,uloulopn,orbl,orblo, clmom)

    !      USE m_types, ONLY : t_orb,t_orbl,t_orblo
    USE m_types
    IMPLICIT NONE

    TYPE(t_atoms),INTENT(IN)   :: atoms
    !     ..
    !     .. Scalar Arguments ..
    INTEGER, INTENT (IN) :: itype 
    !     ..
    !     .. Array Arguments ..
    REAL,    INTENT (IN) :: ddn(0:atoms%lmaxd),uulon(atoms%nlod),dulon(atoms%nlod)
    REAL,    INTENT (IN) :: uloulopn(atoms%nlod,atoms%nlod)
    TYPE (t_orb),  INTENT (IN) :: orb(0:atoms%lmaxd,-atoms%lmaxd:atoms%lmaxd)
    TYPE (t_orbl), INTENT (IN) :: orbl(atoms%nlod,-atoms%llod:atoms%llod)
    TYPE (t_orblo),INTENT (IN) :: orblo(atoms%nlod,atoms%nlod,-atoms%llod:atoms%llod)
    REAL,    INTENT (OUT) :: clmom(3)
    !     ..
    !     .. Local Scalars ..
    INTEGER l , ilo, ilop,m
    REAL qmtt, qmttx, qmtty, sumlm
    COMPLEX orbp, orbm
    !     ..
    !     .. Local Arrays ..
    REAL qmtl(0:atoms%lmaxd),qmtlx(0:atoms%lmaxd),qmtly(0:atoms%lmaxd)

    qmtt = 0.
    qmttx = 0.
    qmtty = 0.
    DO l = 0,atoms%lmax(itype)
       !--->    lm-decomposed density for each atom type
       qmtl(l) = 0.
       qmtlx(l) = 0.
       qmtly(l) = 0.
       DO m = -l,l
          ! lz
          sumlm = m * (orb(l,m)%uu + orb(l,m)%dd * ddn(l) ) 
          ! lx,ly
          orbp = SQRT(REAL((l-m)*(l+m+1))) * ( orb(l,m)%uup + orb(l,m)%ddp * ddn(l) ) 

          orbm = SQRT(REAL((l+m)*(l-m+1))) * ( orb(l,m)%uum + orb(l,m)%ddm * ddn(l) )
          !+gu
          IF (m.EQ.l)  orbp = CMPLX(0.0,0.0)
          IF (m.EQ.-l) orbm = CMPLX(0.0,0.0)
          !+gu
          qmtl(l)  = qmtl(l)  + sumlm
          qmtlx(l) = qmtlx(l) + 0.5*( REAL(orbp)+ REAL(orbm))
          qmtly(l) = qmtly(l) + 0.5*(AIMAG(orbp)-AIMAG(orbm))
          ! 
       ENDDO
    ENDDO
    !
    ! --> LO contribution
    DO ilo = 1, atoms%nlo(itype)
       l = atoms%llo(ilo,itype)
       DO m = -l,l
          sumlm = m * (orbl(ilo,m)%uulo * uulon(ilo) + orbl(ilo,m)%dulo * dulon(ilo) )

          orbp = SQRT(REAL((l-m)*(l+m+1))) * ( orbl(ilo,m)%uulop * uulon(ilo) +&
               orbl(ilo,m)%dulop * dulon(ilo) )

          orbm = SQRT(REAL((l+m)*(l-m+1))) * ( orbl(ilo,m)%uulom * uulon(ilo) +&
               orbl(ilo,m)%dulom * dulon(ilo) )

          IF (m.EQ.l)  orbp = CMPLX(0.0,0.0)
          IF (m.EQ.-l) orbm = CMPLX(0.0,0.0)

          qmtl(l)  = qmtl(l)  + sumlm
          qmtlx(l) = qmtlx(l) + 0.5*( REAL(orbp)+ REAL(orbm))
          qmtly(l) = qmtly(l) + 0.5*(AIMAG(orbp)-AIMAG(orbm))
       ENDDO
       DO ilop = 1, atoms%nlo(itype)
          IF (atoms%llo(ilop,itype).EQ.l) THEN
             DO m = -l,l
                sumlm = m * orblo(ilo,ilop,m)%z * uloulopn(ilo,ilop)
                orbp = SQRT(REAL((l-m)*(l+m+1))) * orblo(ilo,ilop,m)%p * uloulopn(ilo,ilop)
                orbm = SQRT(REAL((l+m)*(l-m+1))) * orblo(ilo,ilop,m)%m * uloulopn(ilo,ilop)
                IF (m.EQ.l)  orbp = CMPLX(0.0,0.0)
                IF (m.EQ.-l) orbm = CMPLX(0.0,0.0)

                qmtl(l)  = qmtl(l)  + sumlm
                qmtlx(l) = qmtlx(l) + 0.5*( REAL(orbp)+ REAL(orbm))
                qmtly(l) = qmtly(l) + 0.5*(AIMAG(orbp)-AIMAG(orbm))
             ENDDO
          ENDIF
       ENDDO
    ENDDO
    !
    ! --> sum up & print
    DO l = 0,atoms%lmax(itype)
       qmtl(l)  = qmtl(l)  / atoms%neq(itype)
       qmtlx(l) = qmtlx(l) / atoms%neq(itype)
       qmtly(l) = qmtly(l) / atoms%neq(itype)
       qmtt =  qmtt  + qmtl(l)
       qmttx = qmttx + qmtlx(l)
       qmtty = qmtty + qmtly(l)
    ENDDO
    clmom(1) = qmttx
    clmom(2) = qmtty
    clmom(3) = qmtt

    WRITE (6,FMT=8100) itype, (qmtl(l),l=0,3), qmtt
    WRITE (6,FMT=8100) itype, (qmtlx(l),l=0,3),qmttx
    WRITE (6,FMT=8100) itype, (qmtly(l),l=0,3),qmtty
8100 FORMAT (' -->',i2,2x,4f9.5,2x,f9.5)

  END SUBROUTINE orbmom2
END MODULE m_orbmom2