LCOV - code coverage report
Current view: top level - cdn_mt - rhosphnlo.f90 (source / functions) Hit Total Coverage
Test: combined.info Lines: 37 46 80.4 %
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_rhosphnlo
       8             :   !***********************************************************************
       9             :   ! Add the local orbital contributions to the charge density. The 
      10             :   ! corresponding summation of the pure apw contribuions is done in
      11             :   ! cdnval.
      12             :   ! Philipp Kurz 99/04
      13             :   !***********************************************************************
      14             : CONTAINS
      15        2328 :   SUBROUTINE rhosphnlo(itype,atoms,sphhar, uloulopn,dulon,uulon,&
      16        2328 :        ello,vr, aclo,bclo,cclo,acnmt,bcnmt,ccnmt,f,g, rho,qmtllo)
      17             : 
      18             :     USE m_constants, ONLY : c_light,sfp_const
      19             :     USE m_radsra
      20             :     USE m_radsrdn
      21             :     USE m_types
      22             :     IMPLICIT NONE
      23             :     TYPE(t_sphhar),INTENT(IN)   :: sphhar
      24             :     TYPE(t_atoms),INTENT(IN)    :: atoms
      25             :     !     ..
      26             :     !     .. Scalar Arguments ..
      27             :     INTEGER,    INTENT (IN) :: itype 
      28             :     !     ..
      29             :     !     .. Array Arguments ..
      30             :     REAL,    INTENT (IN) :: aclo(atoms%nlod),bclo(atoms%nlod),cclo(atoms%nlod,atoms%nlod)
      31             :     REAL,    INTENT (IN) :: acnmt(0:atoms%lmaxd,atoms%nlod,sphhar%nlhd)
      32             :     REAL,    INTENT (IN) :: bcnmt(0:atoms%lmaxd,atoms%nlod,sphhar%nlhd)
      33             :     REAL,    INTENT (IN) :: ccnmt(atoms%nlod,atoms%nlod,sphhar%nlhd)
      34             :     REAL,    INTENT (IN) :: dulon(atoms%nlod),uulon(atoms%nlod),vr(atoms%jmtd)
      35             :     REAL,    INTENT (IN) :: uloulopn(atoms%nlod,atoms%nlod),ello(atoms%nlod)
      36             :     REAL,    INTENT (IN) :: f(atoms%jmtd,2,0:atoms%lmaxd),g(atoms%jmtd,2,0:atoms%lmaxd)
      37             :     REAL,    INTENT (INOUT) :: qmtllo(0:atoms%lmaxd)
      38             :     REAL,    INTENT (INOUT) :: rho(atoms%jmtd,0:sphhar%nlhd)
      39             :     !     ..
      40             :     !     .. Local Scalars ..
      41             :     REAL dsdum,usdum ,c_1,c_2
      42             :     INTEGER j,l,lh,lo,lop,lp,nodedum
      43             :     REAL dus,ddn,c
      44             :     !     ..
      45             :     !     .. Local Arrays ..
      46         582 :     REAL,    ALLOCATABLE :: flo(:,:,:),glo(:,:)
      47        1164 :     REAL filo(atoms%jmtd,2)
      48             :     !     ..
      49         582 :     c = c_light(1.0)
      50         582 :     c_1 = 1.0 / atoms%neq(itype)
      51         582 :     c_2 = 1.0 /(atoms%neq(itype)*sfp_const)
      52             :     !
      53         680 :     DO lo = 1,atoms%nlo(itype)
      54          98 :        l = atoms%llo(lo,itype)
      55          98 :        qmtllo(l) = qmtllo(l) + (aclo(lo)*uulon(lo) +bclo(lo)*dulon(lo)) * c_1
      56         850 :        DO lop = 1,atoms%nlo(itype)
      57         268 :           IF (atoms%llo(lop,itype).EQ.l) THEN
      58          98 :              qmtllo(l) = qmtllo(l) + (cclo(lop,lo) *uloulopn(lop,lo)) * c_1
      59             :           END IF
      60             :        END DO
      61             :     END DO
      62         582 :     ALLOCATE ( flo(atoms%jmtd,2,atoms%nlod),glo(atoms%jmtd,2) )
      63             : 
      64             :     !---> calculate the local ortital radial functions
      65             : 
      66         680 :     DO lo = 1,atoms%nlo(itype)
      67          98 :        l = atoms%llo(lo,itype)
      68             :        CALL radsra(ello(lo),l,vr,atoms%rmsh(1,itype),atoms%dx(itype),atoms%jri(itype),c,&
      69          98 :             usdum,dus,nodedum,flo(:,1,lo),flo(:,2,lo))
      70             :        !+apw+lo
      71         680 :        IF (atoms%l_dulo(lo,itype).or.atoms%ulo_der(lo,itype).ge.1) THEN
      72             :           !--->    calculate orthogonal energy derivative at e
      73           0 :           j = atoms%ulo_der(lo,itype)
      74           0 :           IF(atoms%l_dulo(lo,itype)) j = 1
      75             :           CALL radsrdn(ello(lo),l,vr,atoms%rmsh(1,itype),atoms%dx(itype),atoms%jri(itype),c,&
      76           0 :                usdum,dsdum,ddn,nodedum,glo,filo,flo(:,:,lo),dus,j) ! filo is a dummy array&
      77           0 :           DO j=1,atoms%jri(itype)
      78           0 :              flo(j,1,lo) = glo(j,1)
      79           0 :              flo(j,2,lo) = glo(j,2)
      80             :           ENDDO
      81           0 :           ddn = sqrt(ddn)
      82           0 :           IF(atoms%l_dulo(lo,itype)) ddn=1.0
      83           0 :           flo(:,:,lo) = flo(:,:,lo)/ddn ! Normalize ulo (flo) if APW+lo is not used
      84             :        ENDIF
      85             :        !-apw+lo
      86             :     END DO
      87             : 
      88             :     !---> add the contribution of the local orbitals and flapw - lo cross-
      89             :     !---> terms to the spherical chargedensity inside the muffin tins.
      90             : 
      91         680 :     DO lo = 1,atoms%nlo(itype)
      92          98 :        l = atoms%llo(lo,itype)
      93       69772 :        DO j = 1,atoms%jri(itype)
      94             :           rho(j,0) = rho(j,0) + c_2 *&
      95             :                (aclo(lo) * ( f(j,1,l)*flo(j,1,lo) +f(j,2,l)*flo(j,2,lo) ) +&
      96       69772 :                bclo(lo) * ( g(j,1,l)*flo(j,1,lo) +g(j,2,l)*flo(j,2,lo) ) )
      97             :        END DO
      98        1020 :        DO lop = 1,atoms%nlo(itype)
      99         268 :           IF (atoms%llo(lop,itype).EQ.l) THEN
     100       69772 :              DO j = 1,atoms%jri(itype)
     101             :                 rho(j,0) = rho(j,0) + c_2 * cclo(lop,lo) *&
     102       69772 :                      ( flo(j,1,lop)*flo(j,1,lo) +flo(j,2,lop)*flo(j,2,lo) )
     103             :              END DO
     104             :           END IF
     105             :        END DO
     106             :     END DO
     107             : 
     108             :     !---> add the contribution of the local orbitals and flapw - lo cross-
     109             :     !---> terms to the non-spherical chargedensity inside the muffin tins.
     110             : 
     111        9304 :     DO lh = 1,sphhar%nlh(atoms%ntypsy(atoms%nat))
     112       89080 :        DO lp = 0,atoms%lmax(itype)
     113      112048 :           DO lo = 1,atoms%nlo(itype)
     114     8233134 :              DO j = 1,atoms%jri(itype)
     115             :                 rho(j,lh) = rho(j,lh) + c_1 * (&
     116             :                      acnmt(lp,lo,lh) * (f(j,1,lp)*flo(j,1,lo) +f(j,2,lp)*flo(j,2,lo) ) +&
     117     8152776 :                      bcnmt(lp,lo,lh) * (g(j,1,lp)*flo(j,1,lo) +g(j,2,lp)*flo(j,2,lo) ) )
     118             :              END DO
     119             :           END DO
     120             :        END DO
     121       11824 :        DO lo = 1,atoms%nlo(itype)
     122       14302 :           DO lop = 1,atoms%nlo(itype)
     123     1573260 :              DO j = 1,atoms%jri(itype)
     124             :                 rho(j,lh) = rho(j,lh) + c_1 * ccnmt(lop,lo,lh) *&
     125     1572000 :                      ( flo(j,1,lop)*flo(j,1,lo) +flo(j,2,lop)*flo(j,2,lo) )
     126             :              END DO
     127             :           END DO
     128             :        END DO
     129             :     END DO
     130         582 :     DEALLOCATE (flo,glo)
     131             : 
     132         582 :   END SUBROUTINE rhosphnlo
     133             : END MODULE m_rhosphnlo

Generated by: LCOV version 1.13