LCOV - code coverage report
Current view: top level - eigen - tlo.f90 (source / functions) Hit Total Coverage
Test: combined.info Lines: 88 92 95.7 %
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_tlo
       8             :       USE m_juDFT
       9             : !***********************************************************************
      10             : !     sets up the extra t-matrix elements due to the local orbitals.
      11             : !     only non=zero elements are calculated
      12             : !
      13             : !     p.kurz jul. 1996
      14             : !***********************************************************************
      15             :       CONTAINS
      16         248 :         SUBROUTINE tlo(atoms,sphhar,jspin,jsp,ntyp,enpara,lh0,input,vr,&
      17         248 :                        na,flo,f,g,usdus,uuilon,duilon,ulouilopn, tlmplm )
      18             :           !
      19             :           !*************** ABBREVIATIONS *****************************************
      20             :           ! tuulo      : t-matrix element of the lo and the apw radial fuction
      21             :           ! tdulo      : t-matrix element of the lo and the energy derivativ of 
      22             :           !              the apw radial fuction
      23             :           ! tuloulo    : t-matrix element of two los
      24             :           !c***********************************************************************
      25             :           !
      26             :           USE m_intgr, ONLY : intgr3  
      27             :           USE m_gaunt, ONLY: gaunt1
      28             :           USE m_types
      29             :           use m_constants
      30             :           IMPLICIT NONE
      31             :           TYPE(t_input),INTENT(IN)    :: input
      32             :           TYPE(t_sphhar),INTENT(IN)   :: sphhar
      33             :           TYPE(t_atoms),INTENT(IN)    :: atoms
      34             :           TYPE(t_usdus),INTENT(IN)    :: usdus
      35             :           TYPE(t_tlmplm),INTENT(INOUT):: tlmplm
      36             :           TYPE(t_enpara),INTENT(IN)   :: enpara
      37             :           !     ..
      38             :           !     .. Scalar Arguments ..
      39             :           INTEGER, INTENT (IN) :: jspin,jsp,ntyp ,lh0,na
      40             :           !     ..
      41             :           !     .. Array Arguments ..
      42             :           REAL,    INTENT (IN) :: vr(atoms%jmtd,0:sphhar%nlhd)
      43             :           REAL,    INTENT (IN) :: f(atoms%jmtd,2,0:atoms%lmaxd),g(atoms%jmtd,2,0:atoms%lmaxd)
      44             :           REAL,    INTENT (IN) :: flo(atoms%jmtd,2,atoms%nlod)
      45             :           REAL,    INTENT (IN) :: uuilon(atoms%nlod,atoms%ntype),duilon(atoms%nlod,atoms%ntype)
      46             :           REAL,    INTENT (IN) :: ulouilopn(atoms%nlod,atoms%nlod,atoms%ntype)
      47             :           !     ..
      48             :           !     .. Local Scalars ..
      49             :           COMPLEX cil
      50             :           INTEGER i,l,lh,lm ,lmin,lmp,lo,lop,loplo,lp,lpmax,lpmax0,lpmin,lpmin0,lpp ,mem,mp,mpp,m,lmx,mlo,mlolo
      51             :           !     ..
      52             :           !     .. Local Arrays ..
      53         496 :           REAL x(atoms%jmtd),ulovulo(atoms%nlod*(atoms%nlod+1)/2,lh0:sphhar%nlhd)
      54         496 :           REAL uvulo(atoms%nlod,0:atoms%lmaxd,lh0:sphhar%nlhd),dvulo(atoms%nlod,0:atoms%lmaxd,lh0:sphhar%nlhd)
      55             :           !     ..
      56             : 
      57         320 :           DO lo = 1,atoms%nlo(ntyp)
      58         196 :              l = atoms%llo(lo,ntyp)
      59        2116 :              DO lp = 0,atoms%lmax(ntyp)
      60        1796 :                 lmin = ABS(lp-l)
      61             :                 !               lmin = lp - l
      62        1796 :                 lmx = lp + l
      63       25896 :                 DO lh = lh0,sphhar%nlh(atoms%ntypsy(na))
      64       23904 :                    lpp = sphhar%llh(lh,atoms%ntypsy(na))
      65       23904 :                    IF ((MOD(l+lp+lpp,2).EQ.1) .OR. (lpp.LT.lmin) .OR.&
      66        1796 :                         (lpp.GT.lmx)) THEN
      67       19840 :                       uvulo(lo,lp,lh) = 0.0
      68       19840 :                       dvulo(lo,lp,lh) = 0.0
      69             :                    ELSE
      70     5784320 :                       DO i = 1,atoms%jri(ntyp)
      71     2892160 :                          x(i) = (f(i,1,lp)*flo(i,1,lo)+ f(i,2,lp)*flo(i,2,lo))*vr(i,lh)
      72             :                       END DO
      73        4064 :                       CALL intgr3(x,atoms%rmsh(:,ntyp),atoms%dx(ntyp),atoms%jri(ntyp),uvulo(lo,lp,lh))
      74     2892160 :                       DO i = 1,atoms%jri(ntyp)
      75     2892160 :                          x(i) = (g(i,1,lp)*flo(i,1,lo)+ g(i,2,lp)*flo(i,2,lo))*vr(i,lh)
      76             :                       END DO
      77        4064 :                       CALL intgr3(x,atoms%rmsh(:,ntyp),atoms%dx(ntyp),atoms%jri(ntyp),dvulo(lo,lp,lh))
      78             :                    END IF
      79             :                 END DO
      80             :              END DO
      81             :           END DO
      82         124 :           loplo = 0
      83         320 :           DO lop = 1,atoms%nlo(ntyp)
      84         196 :              lp = atoms%llo(lop,ntyp)
      85         588 :              DO lo = 1,lop
      86         268 :                 l = atoms%llo(lo,ntyp)
      87         268 :                 loplo = loplo + 1
      88         268 :                 IF (loplo>size(ulovulo,1))  CALL juDFT_error("loplo too large!!!" ,calledby ="tlo")
      89        3852 :                 DO lh = lh0,sphhar%nlh(atoms%ntypsy(na))
      90        3388 :                    lpp = sphhar%llh(lh,atoms%ntypsy(na))
      91        3388 :                    lmin = ABS(lp - l)
      92        3388 :                    lmx = lp + l
      93        3656 :                    IF ((MOD(l+lp+lpp,2).EQ.1).OR.(lpp.LT.lmin).OR.(lpp.GT.lmx)) THEN
      94        3196 :                       ulovulo(loplo,lh) = 0.0
      95             :                    ELSE
      96      271872 :                       DO i = 1,atoms%jri(ntyp)
      97      135936 :                          x(i) = (flo(i,1,lop)*flo(i,1,lo)+flo(i,2,lop)*flo(i,2,lo))*vr(i,lh)
      98             :                       END DO
      99         192 :                       CALL intgr3(x,atoms%rmsh(:,ntyp),atoms%dx(ntyp),atoms%jri(ntyp),ulovulo(loplo,lh))
     100             :                    END IF
     101             :                 END DO
     102             :              END DO
     103             :           END DO
     104             :           !---> generate the different t matrices
     105             :           !---> but first initialize them ( done in eigen )
     106             :           !     
     107             :           !---> generate the t-matrices. for optimal performance consider only
     108             :           !---> those combinations of l,l',l'',m,m',m'' that satisfy the three
     109             :           !---> conditions for non-zero gaunt-coeff. i.e.
     110             :           !---> |l - l''| <= l' <= l + l'' (triangular condition)
     111             :           !---> m' = m + m'' and l + l' + l'' even
     112             :           !---> loop over the local orbitals
     113         124 :           mlo=sum(atoms%nlo(:ntyp-1))
     114         320 :           DO lo = 1,atoms%nlo(ntyp)
     115         196 :              l = atoms%llo(lo,ntyp)
     116         780 :              DO m = -l,l
     117             :                 !--->       loop over the lattice harmonics
     118        7112 :                 DO lh = lh0,sphhar%nlh(atoms%ntypsy(na))
     119        6456 :                    lpp = sphhar%llh(lh,atoms%ntypsy(na))
     120        6456 :                    lpmin0 = ABS(l-lpp)
     121        6456 :                    lpmax0 = l + lpp
     122             :                    !--->          check that lpmax is smaller than the max l of the
     123             :                    !--->          wavefunction expansion at this atom
     124        6456 :                    lpmax = MIN(lpmax0,atoms%lmax(ntyp))
     125             :                    !--->          make sure that l + l'' + lpmax is even
     126        6456 :                    lpmax = lpmax - MOD(l+lpp+lpmax,2)
     127       17284 :                    DO mem = 1,sphhar%nmem(lh,atoms%ntypsy(na))
     128       10368 :                       mpp = sphhar%mlh(mem,lh,atoms%ntypsy(na))
     129       10368 :                       mp = m + mpp
     130       10368 :                       lpmin = MAX(lpmin0,ABS(mp))
     131             :                       !--->             make sure that l + l'' + lpmin is even
     132       10368 :                       lpmin = lpmin + MOD(ABS(lpmax-lpmin),2)
     133             :                       !--->             loop over l'
     134       33216 :                       DO lp = lpmin,lpmax,2
     135       16392 :                          lmp = lp* (lp+1) + mp
     136       16392 :                          cil = ((ImagUnit** (l-lp))*sphhar%clnu(mem,lh,atoms%ntypsy(na)))* gaunt1(lp,lpp,l,mp,mpp,m,atoms%lmaxd)
     137             :                          tlmplm%tuulo(lmp,m,lo+mlo,jsp) = &
     138       16392 :                               tlmplm%tuulo(lmp,m,lo+mlo,jsp) + cil*uvulo(lo,lp,lh)
     139             :                          tlmplm%tdulo(lmp,m,lo+mlo,jsp) = &
     140       26760 :                               tlmplm%tdulo(lmp,m,lo+mlo,jsp) + cil*dvulo(lo,lp,lh)
     141             :                       END DO
     142             :                    END DO
     143             :                 END DO
     144             :              END DO
     145             :           END DO
     146             :           !---> generate the t-matrix including two local orbitals for lo' >= lo
     147             :           !---> loop over lo'
     148         268 :           mlolo=dot_product(atoms%nlo(:ntyp-1),atoms%nlo(:ntyp-1)+1)/2
     149         320 :           DO lop = 1,atoms%nlo(ntyp)
     150         196 :              lp = atoms%llo(lop,ntyp)
     151         780 :              DO mp = -lp,lp
     152             :                 !--->       loop over the lattice harmonics
     153        7112 :                 DO lh = lh0,sphhar%nlh(atoms%ntypsy(na))
     154        6456 :                    lpp = sphhar%llh(lh,atoms%ntypsy(na))
     155       17284 :                    DO mem = 1,sphhar%nmem(lh,atoms%ntypsy(na))
     156       10368 :                       mpp = sphhar%mlh(mem,lh,atoms%ntypsy(na))
     157       10368 :                       m = mp - mpp
     158             :                       !--->             loop over lo
     159       31116 :                       DO lo = 1,lop
     160       14292 :                          l = atoms%llo(lo,ntyp)
     161       14292 :                          loplo = ((lop-1)*lop)/2 + lo
     162             :                          IF ((ABS(l-lpp).LE.lp) .AND. (lp.LE. (l+lpp)) .AND.&
     163       24660 :                               (MOD(l+lp+lpp,2).EQ.0) .AND. (ABS(m).LE.l)) THEN
     164         504 :                             cil = ((ImagUnit** (l-lp))*sphhar%clnu(mem,lh,atoms%ntypsy(na)))* gaunt1(lp,lpp,l,mp,mpp,m,atoms%lmaxd)
     165         504 :                             tlmplm%tuloulo(mp,m,loplo+mlolo,jsp) = tlmplm%tuloulo(mp,m,loplo+mlolo,jsp) + cil*ulovulo(loplo,lh)
     166             :                          END IF
     167             :                       END DO
     168             :                    END DO
     169             :                 END DO
     170             :              END DO
     171             :           END DO
     172             :           !---> add the diagonal terms from the muffin-tin hamiltonian. these
     173             :           !---> terms have to be made hermitian. if second variation is switched
     174             :           !---> on, the t-matrices contain only the contributions from the
     175             :           !---> non-spherical hamiltonian.
     176         124 :           IF (.NOT.input%secvar) THEN
     177         320 :              DO lo = 1,atoms%nlo(ntyp)
     178         196 :                 l = atoms%llo(lo,ntyp)
     179         780 :                 DO m = -l,l
     180         460 :                    lm = l* (l+1) + m
     181             :                    tlmplm%tuulo(lm,m,lo+mlo,jsp) = tlmplm%tuulo(lm,m,lo+mlo,jsp) + 0.5 * usdus%uulon(lo,ntyp,jspin) *&
     182         460 :                         ( enpara%el0(l,ntyp,jspin)+enpara%ello0(lo,ntyp,jspin) )
     183             :                    tlmplm%tdulo(lm,m,lo+mlo,jsp) = tlmplm%tdulo(lm,m,lo+mlo,jsp) + 0.5 * usdus%dulon(lo,ntyp,jspin) *&
     184         460 :                         ( enpara%el0(l,ntyp,jspin)+enpara%ello0(lo,ntyp,jspin) ) + 0.5 * usdus%uulon(lo,ntyp,jspin)
     185         460 :                    IF (atoms%ulo_der(lo,ntyp).GE.1) THEN
     186           0 :                       tlmplm%tuulo(lm,m,lo+mlo,jsp) = tlmplm%tuulo(lm,m,lo+mlo,jsp) + 0.5 * uuilon(lo,ntyp)
     187           0 :                       tlmplm%tdulo(lm,m,lo+mlo,jsp) = tlmplm%tdulo(lm,m,lo+mlo,jsp) + 0.5 * duilon(lo,ntyp)
     188             :                    ENDIF
     189             :                    !+apw_lo
     190         656 :                    IF (atoms%l_dulo(lo,ntyp)) THEN         
     191           0 :                       tlmplm%tuulo(lm,m,lo+mlo,jsp) = tlmplm%tuulo(lm,m,lo+mlo,jsp) + 0.5
     192           0 :                       tlmplm%tdulo(lm,m,lo+mlo,jsp) = 0.0
     193             :                    ENDIF
     194             :                    !+apw_lo
     195             :                  END DO
     196             :              END DO
     197         320 :              DO lop = 1,atoms%nlo(ntyp)
     198         196 :                 lp = atoms%llo(lop,ntyp)
     199         516 :                 DO lo = atoms%lo1l(lp,ntyp),lop
     200         196 :                    loplo = ((lop-1)*lop)/2 + lo
     201         852 :                    DO m = -lp,lp
     202             :                       tlmplm%tuloulo(m,m,loplo+mlolo,jsp) = tlmplm%tuloulo(m,m,loplo+mlolo,jsp) + 0.5* (enpara%ello0(lop,ntyp,jspin)+&
     203             :                            enpara%ello0(lo,ntyp,jspin))* usdus%uloulopn(lop,lo,ntyp,jspin) + 0.5* (ulouilopn(lop,lo,ntyp) +&
     204         656 :                            ulouilopn(lo,lop,ntyp))
     205             :                    END DO
     206             :                 END DO
     207             :              END DO
     208             :           END IF
     209             : 
     210         124 :         END SUBROUTINE tlo
     211             :       END MODULE m_tlo

Generated by: LCOV version 1.13