slomat.F90 8.11 KB
Newer Older
1 2 3 4 5 6
!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

7 8 9 10 11 12 13 14
MODULE m_slomat
  !***********************************************************************
  ! updates the overlap matrix with the contributions from the local
  ! orbitals.
  !                                                p.kurz sept. 1996
  !***********************************************************************
CONTAINS
  SUBROUTINE slomat(&
Daniel Wortmann's avatar
Daniel Wortmann committed
15 16 17
       input,atoms,mpi,lapw,cell,noco,ntyp,na,&
       isp,ud, alo1,blo1,clo1,fj,gj,&
       iintsp,jintsp,chi,smat)
18 19 20 21 22 23 24 25 26
    !***********************************************************************
    ! locol stores the number of columns already processed; on parallel
    !       computers this decides, whether the LO-contribution is
    !       done on this node                                          gb00
    !
    ! function legpol() at end of module
    !***********************************************************************
    USE m_constants,ONLY: fpi_const
    USE m_types
Daniel Wortmann's avatar
Daniel Wortmann committed
27
    USE m_apws
28
    IMPLICIT NONE
29
    TYPE(t_input),INTENT(IN)  :: input
30 31
    TYPE(t_atoms),INTENT(IN)  :: atoms
    TYPE(t_lapw),INTENT(IN)   :: lapw
Daniel Wortmann's avatar
Daniel Wortmann committed
32 33 34
    TYPE(t_mpi),INTENT(IN)    :: mpi
    TYPE(t_cell),INTENT(IN)   :: cell
    TYPE(t_noco),INTENT(IN)   :: noco
35 36
    !     ..
    !     .. Scalar Arguments ..
Daniel Wortmann's avatar
Daniel Wortmann committed
37 38 39 40
    INTEGER, INTENT (IN)      :: na,ntyp 
    INTEGER, INTENT (IN)      :: iintsp,jintsp
    COMPLEX, INTENT (IN)      :: chi
    INTEGER, INTENT(IN)       :: isp
41 42
    !     ..
    !     .. Array Arguments ..
Daniel Wortmann's avatar
Daniel Wortmann committed
43 44 45 46 47
    REAL,   INTENT (IN)       :: alo1(atoms%nlod),blo1(atoms%nlod),clo1(atoms%nlod)
    REAL,    INTENT (IN) :: fj(:,0:,:),gj(:,0:,:)
    TYPE(t_usdus),INTENT(IN)  :: ud
    CLASS(t_mat),INTENT(INOUT) :: smat
    
48 49 50
    !     ..
    !     .. Local Scalars ..
    REAL con,dotp,fact1,fact2,fact3,fl2p1
Daniel Wortmann's avatar
Daniel Wortmann committed
51 52
    INTEGER invsfct,k ,l,lo,lop,lp,nkvec,nkvecp,kp,i
    INTEGER locol,lorow
53 54
    !     ..
    !     ..
Daniel Wortmann's avatar
Daniel Wortmann committed
55 56 57 58 59 60

    COMPLEX,   ALLOCATABLE  :: cph(:,:)
    ALLOCATE(cph(MAXVAL(lapw%nv),2))
    DO i=MIN(iintsp,jintsp),MAX(iintsp,jintsp)
       CALL lapw%phase_factors(i,atoms%taual(:,na),noco%qss,cph(:,i))
    ENDDO
61 62 63 64 65 66 67 68 69 70

    IF ((atoms%invsat(na).EQ.0) .OR. (atoms%invsat(na).EQ.1)) THEN
       !--->    if this atom is the first of two atoms related by inversion,
       !--->    the contributions to the overlap matrix of both atoms are added
       !--->    at once. where it is made use of the fact, that the sum of
       !--->    these contributions is twice the real part of the contribution
       !--->    of each atom. note, that in this case there are twice as many
       !--->    (2*(2*l+1)) k-vectors (compare abccoflo and comments there).
       IF (atoms%invsat(na).EQ.0) invsfct = 1
       IF (atoms%invsat(na).EQ.1) invsfct = 2
Daniel Wortmann's avatar
Daniel Wortmann committed
71 72 73 74
   
       con = fpi_const/SQRT(cell%omtil)* ((atoms%rmt(ntyp))**2)/2.0

       DO lo = 1,atoms%nlo(ntyp) !loop over all LOs for this atom
75
          l = atoms%llo(lo,ntyp)
Daniel Wortmann's avatar
Daniel Wortmann committed
76 77 78 79 80 81 82 83
          fl2p1 = (2*l+1)/fpi_const
          fact1 = (con**2)* fl2p1 * (&
               alo1(lo)* (  alo1(lo) + &
               2*clo1(lo) * ud%uulon(lo,ntyp,isp) ) +&
               blo1(lo)* (  blo1(lo) * ud%ddn(l, ntyp,isp) +&
               2*clo1(lo) * ud%dulon(lo,ntyp,isp) ) +&
               clo1(lo)*    clo1(lo) )
          DO nkvec = 1,invsfct* (2*l+1) !Each LO can have several functions
84
             !+t3e
Daniel Wortmann's avatar
Daniel Wortmann committed
85 86 87
             locol = lapw%nv(iintsp)+lapw%index_lo(lo,ntyp)+nkvec !this is the column of the matrix
             IF (MOD(locol-1,mpi%n_size).EQ.mpi%n_rank) THEN
                locol=(locol-1)/mpi%n_size+1 !this is the column in local storage
88
                !-t3e
Daniel Wortmann's avatar
Daniel Wortmann committed
89
                k = lapw%kvec(nkvec,lo,ntyp)
90 91 92 93
                !--->          calculate the overlap matrix elements with the regular
                !--->          flapw basis-functions
                DO kp = 1,lapw%nv(jintsp)
                   fact2 = con * fl2p1 * (&
Daniel Wortmann's avatar
Daniel Wortmann committed
94 95 96 97 98 99 100 101
                        fj(kp,l,jintsp)* ( alo1(lo) + &
                        clo1(lo)*ud%uulon(lo,ntyp,isp))+&
                        gj(kp,l,jintsp)* ( blo1(lo) * ud%ddn(l,ntyp,isp)+&
                        clo1(lo)*ud%dulon(lo,ntyp,isp)))
                   dotp = dot_PRODUCT(lapw%gk(:,k,iintsp),lapw%gk(:,kp,jintsp))
                   IF (smat%l_real) THEN
                      smat%data_r(kp,locol) = smat%data_r(kp,locol) + chi*invsfct*fact2 * legpol(l,dotp) *&
                           cph(k,iintsp)*CONJG(cph(kp,jintsp))
102
                   ELSE
Daniel Wortmann's avatar
Daniel Wortmann committed
103 104
                      smat%data_c(kp,locol) = smat%data_c(kp,locol) + chi*invsfct*fact2 * legpol(l,dotp) *&
                           cph(k,iintsp)*CONJG(cph(kp,jintsp))
105 106 107 108 109 110 111 112 113
                   ENDIF
                END DO
                !--->          calculate the overlap matrix elements with other local
                !--->          orbitals at the same atom, if they have the same l
                DO lop = 1, (lo-1)
                   lp = atoms%llo(lop,ntyp)
                   IF (l.EQ.lp) THEN
                      fact3 = con**2 * fl2p1 * (&
                           alo1(lop)*(alo1(lo) + &
Daniel Wortmann's avatar
Daniel Wortmann committed
114 115 116 117 118 119
                           clo1(lo)*ud%uulon(lo,ntyp,isp))+&
                           blo1(lop)*(blo1(lo)*ud%ddn(l,ntyp,isp) +&
                           clo1(lo)*ud%dulon(lo,ntyp,isp))+&
                           clo1(lop)*(alo1(lo)*ud%uulon(lop,ntyp,isp)+&
                           blo1(lo)*ud%dulon(lop,ntyp,isp)+&
                           clo1(lo)*ud%uloulopn(lop,lo,ntyp,isp)))
120
                      DO nkvecp = 1,invsfct* (2*lp+1)
Daniel Wortmann's avatar
Daniel Wortmann committed
121 122 123 124 125 126
                         kp = lapw%kvec(nkvecp,lop,ntyp)
                         lorow=lapw%nv(jintsp)+lapw%index_lo(lop,ntyp)+nkvecp
                         dotp = dot_PRODUCT(lapw%gk(:,k,iintsp),lapw%gk(:,kp,jintsp))
                         IF (smat%l_real) THEN
                            smat%data_r(lorow,locol) =smat%data_r(lorow,locol)+chi*invsfct*fact3*legpol(l,dotp)* &
                                 cph(k,iintsp)*conjg(cph(kp,jintsp))
127
                         ELSE
Daniel Wortmann's avatar
Daniel Wortmann committed
128 129
                            smat%data_c(lorow,locol) =smat%data_c(lorow,locol)+chi*invsfct*fact3*legpol(l,dotp)*&
                                 cph(k,iintsp)*CONJG(cph(kp,jintsp)) 
130 131 132 133 134 135 136 137
                         ENDIF
                      END DO
                   ELSE
                   END IF
                END DO
                !--->          calculate the overlap matrix elements of one local
                !--->          orbital with itself
                DO nkvecp = 1,nkvec
Daniel Wortmann's avatar
Daniel Wortmann committed
138 139 140 141 142 143
                   kp = lapw%kvec(nkvecp,lo,ntyp)
                   lorow=lapw%nv(jintsp)+lapw%index_lo(lo,ntyp)+nkvecp
                   dotp = dot_PRODUCT(lapw%gk(:,k,iintsp),lapw%gk(:,kp,jintsp))
                   IF (smat%l_real) THEN
                      smat%data_r(lorow,locol) = smat%data_r(lorow,locol) + chi*invsfct*fact1*legpol(l,dotp) *&
                           cph(k,iintsp)*CONJG(cph(kp,jintsp))
144
                   ELSE
Daniel Wortmann's avatar
Daniel Wortmann committed
145 146
                      smat%data_c(lorow,locol) = smat%data_c(lorow,locol) + chi*invsfct*fact1*legpol(l,dotp)*&
                           cph(k,iintsp)*CONJG(cph(kp,jintsp))
147 148 149 150 151 152 153 154 155
                   ENDIF
                END DO
             ENDIF ! mod(locol-1,n_size) = nrank 
             !-t3e
          END DO
       END DO
    END IF
  END SUBROUTINE slomat
  !===========================================================================
Daniel Wortmann's avatar
Daniel Wortmann committed
156
  PURE REAL FUNCTION legpol(l,arg)
157 158 159 160
    !
    IMPLICIT NONE
    !     ..
    !     .. Scalar Arguments ..
Daniel Wortmann's avatar
Daniel Wortmann committed
161 162
    REAL,INTENT(IN)   :: arg
    INTEGER,INTENT(IN):: l
163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180
    !     ..
    !     .. Local Scalars ..
    INTEGER lp
    !     ..
    !     .. Local Arrays ..
    REAL plegend(0:l)
    !     ..
    plegend(0) = 1.0
    IF (l.GE.1) THEN
       plegend(1) = arg
       DO lp = 1,l - 1
          plegend(lp+1) = (lp+lp+1)*arg*plegend(lp)/ (lp+1) -lp*plegend(lp-1)/ (lp+1)
       END DO
    END IF
    legpol = plegend(l)
  END FUNCTION legpol
  !===========================================================================
END MODULE m_slomat