LCOV - code coverage report
Current view: top level - orbdep - orbmom2.f90 (source / functions) Hit Total Coverage
Test: combined.info Lines: 51 51 100.0 %
Date: 2019-09-08 04:53:50 Functions: 1 1 100.0 %

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

Generated by: LCOV version 1.13