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

          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        1848 :   SUBROUTINE rhonmtlo(atoms,sphhar,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_eigVecCoeffs), INTENT(IN)    :: eigVecCoeffs
      28             :     TYPE(t_denCoeffs),    INTENT(INOUT) :: denCoeffs
      29             : 
      30             :     INTEGER, INTENT (IN) :: ne, ispin
      31             : 
      32             :     REAL,    INTENT (IN) :: we(:)!(nobd)
      33             : 
      34             :     !     .. Local Scalars ..
      35             :     COMPLEX cmv,fact,cf1
      36             :     INTEGER i,jmem,l,lh,lmp,lo,lop,lp,lpmax,lpmax0,lpmin,lpmin0,m,lpp ,mp,mpp,na,neqat0,nn,ntyp
      37             :     !     ..
      38             :     !     ..
      39             : 
      40             :     !---> for optimal performance consider only
      41             :     !---> those combinations of l,l',l'',m,m',m'' that satisfy the three
      42             :     !---> conditions for non-zero gaunt-coeff. i.e.
      43             :     !---> |l - l''| <= l' <= l + l'' (triangular condition)
      44             :     !---> m' + m'' = m and l + l' + l'' even
      45             : 
      46        1848 :     neqat0 = 0
      47        5992 :     DO ntyp = 1,atoms%ntype
      48             :        !--->    loop over the lattice harmonics
      49       53520 :        DO lh = 1,sphhar%nlh(atoms%ntypsy(neqat0+1))
      50       49376 :           lpp = sphhar%llh(lh,atoms%ntypsy(neqat0+1))
      51      146036 :           DO jmem = 1,sphhar%nmem(lh,atoms%ntypsy(neqat0+1))
      52       92516 :              mpp = sphhar%mlh(jmem,lh,atoms%ntypsy(neqat0+1))
      53       92516 :              cmv = CONJG(sphhar%clnu(jmem,lh,atoms%ntypsy(neqat0+1)))
      54      177676 :              DO lo = 1,atoms%nlo(ntyp)
      55       35784 :                 l = atoms%llo(lo,ntyp)
      56       35784 :                 lpmin0 = ABS(l-lpp)
      57       35784 :                 lpmax0 = l + lpp
      58             :                 !--->             check that lpmax is smaller than the max l of the
      59             :                 !--->             wavefunction expansion at this atom
      60       35784 :                 lpmax = MIN(lpmax0,atoms%lmax(ntyp))
      61             :                 !--->             make sure that l + l'' + lpmax is even
      62       35784 :                 lpmax = lpmax - MOD(l+lpp+lpmax,2)
      63      202796 :                 DO m = -l,l
      64             : 
      65             :                    !--->                add flapw - local orbital cross-terms
      66             : 
      67             :                    !--->                add terms containing gaunt1(l,lp,lpp,m,mp,mpp)
      68             :                    !--->                note that gaunt1(l,lp,lpp,m,mp,mpp) computes the
      69             :                    !--->                integral of conjg(y(l,m))*y(lp,mp)*y(lpp,mpp),
      70             :                    !--->                however, since the gaunt coef. are real, this is
      71             :                    !--->                the same as int. y(l,m)*conjg(y(lp,mp)*y(lpp,mpp))
      72       74496 :                    mp = m - mpp
      73       74496 :                    lpmin = MAX(lpmin0,ABS(mp))
      74             :                    !--->                make sure that l + l'' + lpmin is even
      75       74496 :                    lpmin = lpmin + MOD(ABS(lpmax-lpmin),2)
      76             :                    !--->                loop over l'
      77      180208 :                    DO lp = lpmin,lpmax,2
      78      105712 :                       lmp = lp* (lp+1) + mp
      79      105712 :                       fact = cmv* (ImagUnit** (l-lp))*gaunt1(l,lp,lpp,m,mp,mpp,atoms%lmaxd)
      80      105712 :                       na = neqat0
      81      368384 :                       DO nn = 1,atoms%neq(ntyp)
      82      188176 :                          na = na + 1
      83     6887629 :                          DO i = 1,ne
      84     6593741 :                             cf1 = fact *  eigVecCoeffs%ccof(m,i,lo,na,ispin)
      85             :                             denCoeffs%acnmt(lp,lo,lh,ntyp,ispin) = denCoeffs%acnmt(lp,lo,lh,ntyp,ispin) +&
      86     6593741 :                                                                    we(i) * REAL(cf1 * CONJG(eigVecCoeffs%acof(i,lmp,na,ispin)) )
      87             :                             denCoeffs%bcnmt(lp,lo,lh,ntyp,ispin) = denCoeffs%bcnmt(lp,lo,lh,ntyp,ispin) +&
      88     6781917 :                                                                    we(i) * REAL(cf1 * CONJG(eigVecCoeffs%bcof(i,lmp,na,ispin)) )
      89             :                          END DO
      90             :                       END DO
      91             :                    END DO
      92             : 
      93             :                    !--->                add terms containing gaunt1(lp,l,lpp,mp,m,mpp)
      94       74496 :                    mp = m + mpp
      95       74496 :                    lpmin = MAX(lpmin0,ABS(mp))
      96             :                    !--->                make sure that l + l'' + lpmin is even
      97       74496 :                    lpmin = lpmin + MOD(ABS(lpmax-lpmin),2)
      98             :                    !--->                loop over l'
      99      180208 :                    DO lp = lpmin,lpmax,2
     100      105712 :                       lmp = lp* (lp+1) + mp
     101      105712 :                       fact = cmv* (ImagUnit** (lp-l))*gaunt1(lp,l,lpp,mp,m,mpp,atoms%lmaxd)
     102      105712 :                       na = neqat0
     103      368384 :                       DO nn = 1,atoms%neq(ntyp)
     104      188176 :                          na = na + 1
     105     6887629 :                          DO i = 1,ne
     106     6593741 :                             cf1 = fact * CONJG(eigVecCoeffs%ccof(m,i,lo,na,ispin))
     107             :                             denCoeffs%acnmt(lp,lo,lh,ntyp,ispin) = denCoeffs%acnmt(lp,lo,lh,ntyp,ispin) +&
     108     6593741 :                                                                    we(i) * REAL(cf1 * eigVecCoeffs%acof(i,lmp,na,ispin) )
     109             :                             denCoeffs%bcnmt(lp,lo,lh,ntyp,ispin) = denCoeffs%bcnmt(lp,lo,lh,ntyp,ispin) +&
     110     6781917 :                                                                    we(i) * REAL(cf1 * eigVecCoeffs%bcof(i,lmp,na,ispin) )
     111             :                          END DO
     112             :                       END DO
     113             :                    END DO
     114             : 
     115             :                    !--->                add local orbital - local orbital terms
     116      251832 :                    DO lop = 1,atoms%nlo(ntyp)
     117      141552 :                       lp = atoms%llo(lop,ntyp)
     118             : 
     119             :                       !--->                   add terms containing gaunt1(l,lp,lpp,m,mp,mpp)
     120      141552 :                       mp = m - mpp
     121      216048 :                       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
     122        4608 :                          fact = cmv* (ImagUnit** (l-lp))*gaunt1(l,lp,lpp,m,mp,mpp,atoms%lmaxd)
     123        4608 :                          na = neqat0
     124       12816 :                          DO nn = 1,atoms%neq(ntyp)
     125        8208 :                             na = na + 1
     126      304105 :                             DO i = 1,ne
     127             :                                denCoeffs%ccnmt(lop,lo,lh,ntyp,ispin) =&
     128             :                                   denCoeffs%ccnmt(lop,lo,lh,ntyp,ispin) +&
     129      299497 :                                   we(i) * REAL(fact * CONJG(eigVecCoeffs%ccof(mp,i,lop,na,ispin))*eigVecCoeffs%ccof(m,i,lo,na,ispin))
     130             :                             END DO
     131             :                          END DO
     132             :                       END IF
     133             : 
     134             :                    END DO
     135             :                 END DO
     136             :              END DO
     137             :           END DO
     138             :        END DO
     139        5992 :        neqat0 = neqat0 + atoms%neq(ntyp)
     140             :     END DO
     141             : 
     142        1848 :   END SUBROUTINE rhonmtlo
     143             : END MODULE m_rhonmtlo

Generated by: LCOV version 1.13