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

          Line data    Source code
       1             : MODULE m_tlmplm
       2             : 
       3             :   IMPLICIT NONE
       4             :   !*********************************************************************
       5             :   !     sets up the local Hamiltonian, i.e. the Hamiltonian in the
       6             :   !     l',m',l,m,u- basis which is independent from k!
       7             :   !*********************************************************************
       8             : CONTAINS
       9        1164 :   SUBROUTINE tlmplm(n,sphhar,atoms,enpara,&
      10             :        jspin,jsp,mpi,v,input,td,ud)
      11             :     USE m_constants
      12             :     USE m_intgr, ONLY : intgr3
      13             :     USE m_genMTBasis
      14             :     USE m_tlo
      15             :     USE m_gaunt, ONLY: gaunt1
      16             :     USE m_types
      17             :     IMPLICIT NONE
      18             : 
      19             :     TYPE(t_input),INTENT(IN)    :: input
      20             :     TYPE(t_sphhar),INTENT(IN)   :: sphhar
      21             :     TYPE(t_atoms),INTENT(IN)    :: atoms
      22             :     TYPE(t_enpara),INTENT(IN)   :: enpara
      23             :     TYPE(t_mpi),INTENT(IN)      :: mpi
      24             :     TYPE(t_potden),INTENT(IN)    :: v
      25             :     TYPE(t_tlmplm),INTENT(INOUT) :: td
      26             :     TYPE(t_usdus),INTENT(INOUT)  :: ud
      27             : 
      28             :     INTEGER, INTENT (IN) :: n,jspin,jsp !atom index,physical spin&spin index for data
      29             : 
      30        3492 :     REAL, ALLOCATABLE   :: dvd(:,:),dvu(:,:),uvd(:,:),uvu(:,:),f(:,:,:,:),g(:,:,:,:),x(:),flo(:,:,:)
      31        1164 :     INTEGER,ALLOCATABLE :: indt(:)
      32        1164 :     REAL,ALLOCATABLE    :: vr0(:,:)
      33             :    
      34             : 
      35             :     COMPLEX  :: cil
      36             :     REAL     :: temp
      37             :     INTEGER i,l,l2,lamda,lh,lm,lmin,lmin0,lmp,lmpl,lmplm,lmx,lmxx,lp,info,in
      38             :     INTEGER lp1,lpl ,mem,mems,mp,mu,nh,na,m,nsym,s,i_u,jspin1,jspin2
      39             : 
      40        1164 :     ALLOCATE( dvd(0:atoms%lmaxd*(atoms%lmaxd+3)/2,0:sphhar%nlhd ))
      41        1164 :     ALLOCATE( dvu(0:atoms%lmaxd*(atoms%lmaxd+3)/2,0:sphhar%nlhd ))
      42        1164 :     ALLOCATE( uvd(0:atoms%lmaxd*(atoms%lmaxd+3)/2,0:sphhar%nlhd ))
      43        1164 :     ALLOCATE( uvu(0:atoms%lmaxd*(atoms%lmaxd+3)/2,0:sphhar%nlhd ))
      44        1164 :     ALLOCATE( f(atoms%jmtd,2,0:atoms%lmaxd,2),g(atoms%jmtd,2,0:atoms%lmaxd,2),x(atoms%jmtd))
      45             : 
      46        1164 :     ALLOCATE( flo(atoms%jmtd,2,atoms%nlod))
      47        1164 :     ALLOCATE( indt(0:SIZE(td%tuu,1)-1))
      48        1164 :     ALLOCATE( vr0(SIZE(v%mt,1),0:SIZE(v%mt,2)-1))
      49             : 
      50             : 
      51             :     
      52        1164 :     vr0=v%mt(:,:,n,jsp)
      53        1164 :     IF (jsp<3) vr0(:,0)=0.0
      54             : 
      55        2328 :     DO i=MERGE(1,jspin,jspin>2),MERGE(2,jspin,jspin>2)
      56        2328 :        CALL genMTBasis(atoms,enpara,v,mpi,n,i,ud,f(:,:,:,i),g(:,:,:,i),flo)
      57             :     ENDDO
      58        1164 :     IF (jspin>2) THEN
      59             :        jspin1=1
      60             :        jspin2=2
      61             :     ELSE
      62        1164 :        jspin1=jspin;jspin2=jspin
      63             :     END IF
      64        1164 :     na=SUM(atoms%neq(:n-1))+1
      65        1164 :     nsym = atoms%ntypsy(na)
      66        1164 :     nh = sphhar%nlh(nsym)
      67             :     !
      68             :     !--->    generate the irreducible integrals (u(l'):v(lamda,nu:u(l))
      69             :     !--->    for l' .ge. l, but only those that will contribute
      70             :     !
      71       11808 :     DO lp = 0,atoms%lmax(n)
      72       10644 :        lp1 = (lp* (lp+1))/2
      73       66192 :        DO l = 0,lp
      74       54384 :           lpl = lp1 + l
      75             :           !--->    loop over non-spherical components of the potential: must
      76             :           !--->    satisfy the triangular conditions and that l'+l+lamda even
      77             :           !--->    (conditions from the gaunt coefficient)
      78      905100 :           DO lh = MERGE(1,0,jspin<3), nh
      79      840072 :              lamda = sphhar%llh(lh,nsym)
      80      840072 :              lmin = lp - l
      81      840072 :              lmx = lp + l
      82      894456 :              IF ((mod(lamda+lmx,2).EQ.1) .OR. (lamda.LT.lmin) .OR. (lamda.GT.lmx)) THEN
      83      546984 :                 uvu(lpl,lh) = 0.0
      84      546984 :                 dvd(lpl,lh) = 0.0
      85      546984 :                 uvd(lpl,lh) = 0.0
      86      546984 :                 dvu(lpl,lh) = 0.0
      87             :              ELSE
      88   360330240 :                 DO i = 1,atoms%jri(n)
      89   180165120 :                    x(i) = (f(i,1,lp,jspin1)*f(i,1,l,jspin2)+f(i,2,lp,jspin1)*f(i,2,l,jspin2))* vr0(i,lh)
      90             :                 END DO
      91      293088 :                 CALL intgr3(x,atoms%rmsh(1,n),atoms%dx(n),atoms%jri(n),temp)
      92      293088 :                 uvu(lpl,lh) = temp
      93   180165120 :                 DO i = 1,atoms%jri(n)
      94   180165120 :                    x(i) = (g(i,1,lp,jspin1)*f(i,1,l,jspin2)+g(i,2,lp,jspin1)*f(i,2,l,jspin2))* vr0(i,lh)
      95             :                 END DO
      96      293088 :                 CALL intgr3(x,atoms%rmsh(1,n),atoms%dx(n),atoms%jri(n),temp)
      97      293088 :                 dvu(lpl,lh) = temp
      98   180165120 :                 DO i = 1,atoms%jri(n)
      99   180165120 :                    x(i) = (f(i,1,lp,jspin1)*g(i,1,l,jspin2)+f(i,2,lp,jspin1)*g(i,2,l,jspin2))* vr0(i,lh)
     100             :                 END DO
     101      293088 :                 CALL intgr3(x,atoms%rmsh(1,n),atoms%dx(n),atoms%jri(n),temp)
     102      293088 :                 uvd(lpl,lh) = temp
     103   180165120 :                 DO i = 1,atoms%jri(n)
     104   180165120 :                    x(i) = (g(i,1,lp,jspin1)*g(i,1,l,jspin2)+g(i,2,lp,jspin1)*g(i,2,l,jspin2))* vr0(i,lh)
     105             :                 END DO
     106      293088 :                 CALL intgr3(x,atoms%rmsh(1,n),atoms%dx(n),atoms%jri(n),temp)
     107      293088 :                 dvd(lpl,lh) = temp
     108             :              END IF
     109             :           END DO
     110             :        END DO
     111             :     END DO
     112             : 
     113        1164 :     td%tuu(0:,n,jsp) = cmplx(0.0,0.0)
     114        1164 :     td%tdd(0:,n,jsp) = cmplx(0.0,0.0)
     115        1164 :     td%tud(0:,n,jsp) = cmplx(0.0,0.0)
     116        1164 :     td%tdu(0:,n,jsp) = cmplx(0.0,0.0)
     117     4666520 :     indt=0
     118             :     !--->    generate the various t(l'm',lm) matrices for l'm'.ge.lm
     119             :     !--->    loop over l'm'
     120       11808 :     DO lp = 0,atoms%lmax(n)
     121       10644 :        lp1 = (lp* (lp+1))/2
     122      109932 :        DO mp = -lp,lp
     123       98124 :           lmp = lp* (lp+1) + mp
     124       98124 :           lmpl = (lmp* (lmp+1))/2
     125             :           !--->    loop over lattice harmonics
     126     1626276 :           DO lh = MERGE(1,0,jspin<3), nh
     127     1517508 :              lamda = sphhar%llh(lh,nsym)
     128     1517508 :              lmin0 = abs(lp-lamda)
     129     1517508 :              IF (lmin0.GT.lp) CYCLE
     130             :              !-->     ensure l+l'+lamda even
     131     1336992 :              lmxx = lp - mod(lamda,2)
     132     1336992 :              mems = sphhar%nmem(lh,nsym)
     133     4023248 :              DO mem = 1,mems
     134     2588132 :                 mu = sphhar%mlh(mem,lh,nsym)
     135     2588132 :                 m = mp - mu
     136     2588132 :                 lmin = max(lmin0,abs(m))
     137     2588132 :                 l2 = abs(lmxx-lmin)
     138     2588132 :                 lmin = lmin + mod(l2,2)
     139     8102096 :                 DO l = lmin,lmxx,2
     140     3996456 :                    lm = l* (l+1) + m
     141     3996456 :                    IF (lm.GT.lmp) CYCLE
     142     3486188 :                    lpl = lp1 + l
     143     3486188 :                    lmplm = lmpl + lm
     144             :                    cil = ((ImagUnit** (l-lp))*sphhar%clnu(mem,lh,nsym))*&
     145     3486188 :                         gaunt1(lp,lamda,l,mp,mu,m,atoms%lmaxd)
     146     3486188 :                    td%tuu(lmplm,n,jsp) = td%tuu(lmplm,n,jsp) + cil*uvu(lpl,lh)
     147     3486188 :                    td%tdd(lmplm,n,jsp) = td%tdd(lmplm,n,jsp) + cil*dvd(lpl,lh)
     148     3486188 :                    td%tud(lmplm,n,jsp) = td%tud(lmplm,n,jsp) + cil*uvd(lpl,lh)
     149     3486188 :                    td%tdu(lmplm,n,jsp) = td%tdu(lmplm,n,jsp) + cil*dvu(lpl,lh)
     150     6584588 :                    indt(lmplm) = 1
     151             :                 END DO
     152             :              END DO
     153             :           END DO
     154             :        END DO
     155             :     END DO
     156             :     !--->    set up mapping array
     157       11808 :     DO lp = 0,atoms%lmax(n)
     158      109932 :        DO mp = -lp,lp
     159       98124 :           lmp = lp* (lp+1) + mp
     160     1022964 :           DO l = 0,atoms%lmax(n)
     161     9647724 :              DO m = -l,l
     162     8635404 :                 lm = l* (l+1) + m
     163     9549600 :                 IF (lmp.GE.lm) THEN
     164     4366764 :                    lmplm = (lmp* (lmp+1))/2 + lm
     165     4366764 :                    IF (indt(lmplm).NE.0) THEN
     166     1002480 :                       td%ind(lmp,lm,n,jsp) = lmplm
     167             :                    ELSE
     168     3364284 :                       td%ind(lmp,lm,n,jsp) = -9999
     169             :                    END IF
     170             :                 ELSE
     171     4268640 :                    lmplm = (lm* (lm+1))/2 + lmp
     172     4268640 :                    IF (indt(lmplm).NE.0) THEN
     173      905736 :                       td%ind(lmp,lm,n,jsp) = -lmplm
     174             :                    ELSE
     175     3362904 :                       td%ind(lmp,lm,n,jsp) = -9999
     176             :                    END IF
     177             :                 END IF
     178             :              END DO
     179             :           END DO
     180             :        END DO
     181             :     ENDDO
     182             : 
     183             :     !
     184             :     !--->   set up the t-matrices for the local orbitals,
     185             :     !--->   if there are any
     186        1164 :     IF (atoms%nlo(n).GE.1) THEN
     187             :        CALL tlo(atoms,sphhar,jspin,jsp,n,enpara,1,input,v%mt(1,0,n,jsp),&
     188         124 :             na,flo,f(:,:,:,jspin),g(:,:,:,jspin),ud, ud%uuilon(:,:,jspin),ud%duilon(:,:,jspin),ud%ulouilopn(:,:,:,jspin), td)
     189             : 
     190             :     ENDIF
     191        1164 :   END SUBROUTINE tlmplm
     192             : END MODULE m_tlmplm

Generated by: LCOV version 1.13