LCOV - code coverage report
Current view: top level - eigen - slomat.F90 (source / functions) Hit Total Coverage
Test: combined.info Lines: 46 54 85.2 %
Date: 2019-09-08 04:53:50 Functions: 2 2 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_slomat
       8             :   !***********************************************************************
       9             :   ! updates the overlap matrix with the contributions from the local
      10             :   ! orbitals.
      11             :   !                                                p.kurz sept. 1996
      12             :   !***********************************************************************
      13             : CONTAINS
      14        1028 :   SUBROUTINE slomat(&
      15             :        input,atoms,mpi,lapw,cell,noco,ntyp,na,&
      16        1028 :        isp,ud, alo1,blo1,clo1,fj,gj,&
      17             :        iintsp,jintsp,chi,smat)
      18             :     !***********************************************************************
      19             :     ! locol stores the number of columns already processed; on parallel
      20             :     !       computers this decides, whether the LO-contribution is
      21             :     !       done on this node                                          gb00
      22             :     !
      23             :     ! function legpol() at end of module
      24             :     !***********************************************************************
      25             :     USE m_constants,ONLY: fpi_const
      26             :     USE m_types
      27             :     IMPLICIT NONE
      28             :     TYPE(t_input),INTENT(IN)  :: input
      29             :     TYPE(t_atoms),INTENT(IN)  :: atoms
      30             :     TYPE(t_lapw),INTENT(IN)   :: lapw
      31             :     TYPE(t_mpi),INTENT(IN)    :: mpi
      32             :     TYPE(t_cell),INTENT(IN)   :: cell
      33             :     TYPE(t_noco),INTENT(IN)   :: noco
      34             :     !     ..
      35             :     !     .. Scalar Arguments ..
      36             :     INTEGER, INTENT (IN)      :: na,ntyp 
      37             :     INTEGER, INTENT (IN)      :: jintsp,iintsp
      38             :     COMPLEX, INTENT (IN)      :: chi
      39             :     INTEGER, INTENT(IN)       :: isp
      40             :     !     ..
      41             :     !     .. Array Arguments ..
      42             :     REAL,   INTENT (IN)       :: alo1(atoms%nlod),blo1(atoms%nlod),clo1(atoms%nlod)
      43             :     REAL,    INTENT (IN) :: fj(:,0:,:),gj(:,0:,:)
      44             :     TYPE(t_usdus),INTENT(IN)  :: ud
      45             :     CLASS(t_mat),INTENT(INOUT) :: smat
      46             : 
      47             :     !     ..
      48             :     !     .. Local Scalars ..
      49             :     REAL con,dotp,fact1,fact2,fact3,fl2p1
      50             :     INTEGER invsfct,k ,l,lo,lop,lp,nkvec,nkvecp,kp,i
      51             :     INTEGER locol,lorow
      52             :     !     ..
      53             :     !     ..
      54             : 
      55        1028 :     COMPLEX,   ALLOCATABLE  :: cph(:,:)
      56        1028 :     ALLOCATE(cph(MAXVAL(lapw%nv),2))
      57        2056 :     DO i=MIN(jintsp,iintsp),MAX(jintsp,iintsp)
      58        2056 :        CALL lapw%phase_factors(i,atoms%taual(:,na),noco%qss,cph(:,i))
      59             :     ENDDO
      60             : 
      61        1028 :     IF ((atoms%invsat(na) == 0) .OR. (atoms%invsat(na) == 1)) THEN
      62             :        !--->    if this atom is the first of two atoms related by inversion,
      63             :        !--->    the contributions to the overlap matrix of both atoms are added
      64             :        !--->    at once. where it is made use of the fact, that the sum of
      65             :        !--->    these contributions is twice the real part of the contribution
      66             :        !--->    of each atom. note, that in this case there are twice as many
      67             :        !--->    (2*(2*l+1)) k-vectors (compare abccoflo and comments there).
      68             :        IF (atoms%invsat(na) == 0) invsfct = 1
      69        1028 :        IF (atoms%invsat(na) == 1) invsfct = 2
      70             : 
      71        1028 :        con = fpi_const/SQRT(cell%omtil)* ((atoms%rmt(ntyp))**2)/2.0
      72             : 
      73        2968 :        DO lo = 1,atoms%nlo(ntyp) !loop over all LOs for this atom
      74             : 
      75        1940 :           l = atoms%llo(lo,ntyp)
      76        1940 :           fl2p1 = (2*l+1)/fpi_const
      77             :           fact1 = (con**2)* fl2p1 * (&
      78             :                alo1(lo)* (  alo1(lo) + &
      79             :                2*clo1(lo) * ud%uulon(lo,ntyp,isp) ) +&
      80             :                blo1(lo)* (  blo1(lo) * ud%ddn(l, ntyp,isp) +&
      81             :                2*clo1(lo) * ud%dulon(lo,ntyp,isp) ) +&
      82        1940 :                clo1(lo)*    clo1(lo) )
      83        9908 :           DO nkvec = 1,invsfct* (2*l+1) !Each LO can have several functions
      84        6940 :              locol = lapw%nv(jintsp)+lapw%index_lo(lo,na)+nkvec !this is the column of the matrix
      85        8880 :              IF (MOD(locol-1,mpi%n_size) == mpi%n_rank) THEN
      86        3526 :                 locol=(locol-1)/mpi%n_size+1 !this is the column in local storage!
      87        3526 :                 k = lapw%kvec(nkvec,lo,na)
      88             :                 !--->          calculate the overlap matrix elements with the regular
      89             :                 !--->          flapw basis-functions
      90     1931728 :                 DO kp = 1,lapw%nv(iintsp)
      91             :                    fact2 = con * fl2p1 * (&
      92             :                         fj(kp,l,iintsp)* ( alo1(lo) + &
      93             :                         clo1(lo)*ud%uulon(lo,ntyp,isp))+&
      94             :                         gj(kp,l,iintsp)* ( blo1(lo) * ud%ddn(l,ntyp,isp)+&
      95     1928202 :                         clo1(lo)*ud%dulon(lo,ntyp,isp)))
      96     1928202 :                    dotp = dot_PRODUCT(lapw%gk(:,k,jintsp),lapw%gk(:,kp,iintsp))
      97     1931728 :                    IF (smat%l_real) THEN
      98             :                       smat%data_r(kp,locol) = smat%data_r(kp,locol) + chi*invsfct*fact2 * legpol(l,dotp) *&
      99     1880400 :                            cph(k,jintsp)*CONJG(cph(kp,iintsp))
     100             :                    ELSE
     101             :                       smat%data_c(kp,locol) = smat%data_c(kp,locol) + chi*invsfct*fact2 * legpol(l,dotp) *&
     102       47802 :                            cph(k,jintsp)*CONJG(cph(kp,iintsp))
     103             :                    ENDIF
     104             :                 END DO
     105             :                 !--->          calculate the overlap matrix elements with other local
     106             :                 !--->          orbitals at the same atom, if they have the same l
     107        6028 :                 DO lop = 1, MERGE(lo-1,atoms%nlo(ntyp),iintsp==jintsp)
     108        2502 :                    IF (lop==lo) CYCLE !Do later
     109        2502 :                    lp = atoms%llo(lop,ntyp)
     110        6028 :                    IF (l == lp) THEN
     111             :                       fact3 = con**2 * fl2p1 * (&
     112             :                            alo1(lop)*(alo1(lo) + &
     113             :                            clo1(lo)*ud%uulon(lo,ntyp,isp))+&
     114             :                            blo1(lop)*(blo1(lo)*ud%ddn(l,ntyp,isp) +&
     115             :                            clo1(lo)*ud%dulon(lo,ntyp,isp))+&
     116             :                            clo1(lop)*(alo1(lo)*ud%uulon(lop,ntyp,isp)+&
     117             :                            blo1(lo)*ud%dulon(lop,ntyp,isp)+&
     118           0 :                            clo1(lo)*ud%uloulopn(lop,lo,ntyp,isp)))
     119           0 :                       DO nkvecp = 1,invsfct* (2*lp+1)
     120           0 :                          kp = lapw%kvec(nkvecp,lop,na)
     121           0 :                          lorow=lapw%nv(iintsp)+lapw%index_lo(lop,na)+nkvecp
     122           0 :                          dotp = dot_PRODUCT(lapw%gk(:,k,jintsp),lapw%gk(:,kp,iintsp))
     123           0 :                          IF (smat%l_real) THEN
     124             :                             smat%data_r(lorow,locol) =smat%data_r(lorow,locol)+chi*invsfct*fact3*legpol(l,dotp)* &
     125           0 :                                  cph(k,jintsp)*conjg(cph(kp,iintsp))
     126             :                          ELSE
     127             :                             smat%data_c(lorow,locol) =smat%data_c(lorow,locol)+chi*invsfct*fact3*legpol(l,dotp)*&
     128           0 :                                  cph(k,jintsp)*CONJG(cph(kp,iintsp)) 
     129             :                          ENDIF
     130             :                       END DO
     131             :                    ENDIF
     132             :                 END DO
     133             :                 !--->          calculate the overlap matrix elements of one local
     134             :                 !--->          orbital with itself
     135        3526 :                 lop=lo
     136       13489 :                 DO nkvecp = 1,MERGE(nkvec,invsfct* (2*l+1),iintsp==jintsp)
     137        9963 :                    kp = lapw%kvec(nkvecp,lo,na)
     138        9963 :                    lorow=lapw%nv(iintsp)+lapw%index_lo(lo,na)+nkvecp
     139        9963 :                    dotp = dot_PRODUCT(lapw%gk(:,k,jintsp),lapw%gk(:,kp,iintsp))
     140       13489 :                    IF (smat%l_real) THEN
     141             :                       smat%data_r(lorow,locol) = smat%data_r(lorow,locol) + chi*invsfct*fact1*legpol(l,dotp) *&
     142        9558 :                            cph(k,jintsp)*CONJG(cph(kp,iintsp))
     143             :                    ELSE
     144             :                       smat%data_c(lorow,locol) = smat%data_c(lorow,locol) + chi*invsfct*fact1*legpol(l,dotp)*&
     145         405 :                            cph(k,jintsp)*CONJG(cph(kp,iintsp))
     146             :                    ENDIF
     147             :                 END DO
     148             :              ENDIF ! mod(locol-1,n_size) = nrank 
     149             :           END DO
     150             :        END DO
     151             :     END IF
     152        1028 :   END SUBROUTINE slomat
     153             :   !===========================================================================
     154     1938165 :   PURE REAL FUNCTION legpol(l,arg)
     155             :     !
     156             :     IMPLICIT NONE
     157             :     !     ..
     158             :     !     .. Scalar Arguments ..
     159             :     REAL,INTENT(IN)   :: arg
     160             :     INTEGER,INTENT(IN):: l
     161             :     !     ..
     162             :     !     .. Local Scalars ..
     163             :     INTEGER lp
     164             :     !     ..
     165             :     !     .. Local Arrays ..
     166     3876330 :     REAL plegend(0:l)
     167             :     !     ..
     168     1938165 :     plegend(0) = 1.0
     169     1938165 :     IF (l.GE.1) THEN
     170     1466859 :        plegend(1) = arg
     171     1484184 :        DO lp = 1,l - 1
     172     1484184 :           plegend(lp+1) = (lp+lp+1)*arg*plegend(lp)/ (lp+1) -lp*plegend(lp-1)/ (lp+1)
     173             :        END DO
     174             :     END IF
     175     1938165 :     legpol = plegend(l)
     176     1938165 :   END FUNCTION legpol
     177             :   !===========================================================================
     178             : END MODULE m_slomat

Generated by: LCOV version 1.13