slomat.F90 8.09 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 27
    !***********************************************************************
    ! 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
    IMPLICIT NONE
28
    TYPE(t_input),INTENT(IN)  :: input
29 30
    TYPE(t_atoms),INTENT(IN)  :: atoms
    TYPE(t_lapw),INTENT(IN)   :: lapw
Daniel Wortmann's avatar
Daniel Wortmann committed
31 32 33
    TYPE(t_mpi),INTENT(IN)    :: mpi
    TYPE(t_cell),INTENT(IN)   :: cell
    TYPE(t_noco),INTENT(IN)   :: noco
34 35
    !     ..
    !     .. Scalar Arguments ..
Daniel Wortmann's avatar
Daniel Wortmann committed
36
    INTEGER, INTENT (IN)      :: na,ntyp 
37
    INTEGER, INTENT (IN)      :: jintsp,iintsp
Daniel Wortmann's avatar
Daniel Wortmann committed
38 39
    COMPLEX, INTENT (IN)      :: chi
    INTEGER, INTENT(IN)       :: isp
40 41
    !     ..
    !     .. Array Arguments ..
Daniel Wortmann's avatar
Daniel Wortmann committed
42 43 44 45 46
    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
    
47 48 49
    !     ..
    !     .. Local Scalars ..
    REAL con,dotp,fact1,fact2,fact3,fl2p1
Daniel Wortmann's avatar
Daniel Wortmann committed
50 51
    INTEGER invsfct,k ,l,lo,lop,lp,nkvec,nkvecp,kp,i
    INTEGER locol,lorow
52 53
    !     ..
    !     ..
Daniel Wortmann's avatar
Daniel Wortmann committed
54 55 56

    COMPLEX,   ALLOCATABLE  :: cph(:,:)
    ALLOCATE(cph(MAXVAL(lapw%nv),2))
57
    DO i=MIN(jintsp,iintsp),MAX(jintsp,iintsp)
58
       CALL lapw%phase_factors(i,atoms%taual(:,na),-1*noco%qss,cph(:,i))
Daniel Wortmann's avatar
Daniel Wortmann committed
59
    ENDDO
60 61 62 63 64 65 66 67 68 69

    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
70 71 72 73
   
       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
74
          l = atoms%llo(lo,ntyp)
Daniel Wortmann's avatar
Daniel Wortmann committed
75 76 77 78 79 80 81 82
          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
83
             !+t3e
84
             locol = lapw%nv(jintsp)+lapw%index_lo(lo,na)+nkvec !this is the column of the matrix
Daniel Wortmann's avatar
Daniel Wortmann committed
85 86
             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
87
                !-t3e
88
                k = lapw%kvec(nkvec,lo,na)
89 90
                !--->          calculate the overlap matrix elements with the regular
                !--->          flapw basis-functions
91
                DO kp = 1,lapw%nv(iintsp)
92
                   fact2 = con * fl2p1 * (&
93
                        fj(kp,l,iintsp)* ( alo1(lo) + &
Daniel Wortmann's avatar
Daniel Wortmann committed
94
                        clo1(lo)*ud%uulon(lo,ntyp,isp))+&
95
                        gj(kp,l,iintsp)* ( blo1(lo) * ud%ddn(l,ntyp,isp)+&
Daniel Wortmann's avatar
Daniel Wortmann committed
96
                        clo1(lo)*ud%dulon(lo,ntyp,isp)))
97
                   dotp = dot_PRODUCT(lapw%gk(:,k,jintsp),lapw%gk(:,kp,iintsp))
Daniel Wortmann's avatar
Daniel Wortmann committed
98 99
                   IF (smat%l_real) THEN
                      smat%data_r(kp,locol) = smat%data_r(kp,locol) + chi*invsfct*fact2 * legpol(l,dotp) *&
100
                           cph(k,jintsp)*CONJG(cph(kp,iintsp))
101
                   ELSE
Daniel Wortmann's avatar
Daniel Wortmann committed
102
                      smat%data_c(kp,locol) = smat%data_c(kp,locol) + chi*invsfct*fact2 * legpol(l,dotp) *&
103
                           cph(k,jintsp)*CONJG(cph(kp,iintsp))
104 105 106 107 108 109 110 111 112
                   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
113 114 115 116 117 118
                           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)))
119
                      DO nkvecp = 1,invsfct* (2*lp+1)
120
                         kp = lapw%kvec(nkvecp,lop,na)
121 122
                         lorow=lapw%nv(iintsp)+lapw%index_lo(lop,na)+nkvecp
                         dotp = dot_PRODUCT(lapw%gk(:,k,jintsp),lapw%gk(:,kp,iintsp))
Daniel Wortmann's avatar
Daniel Wortmann committed
123 124
                         IF (smat%l_real) THEN
                            smat%data_r(lorow,locol) =smat%data_r(lorow,locol)+chi*invsfct*fact3*legpol(l,dotp)* &
125
                                 cph(k,jintsp)*conjg(cph(kp,iintsp))
126
                         ELSE
Daniel Wortmann's avatar
Daniel Wortmann committed
127
                            smat%data_c(lorow,locol) =smat%data_c(lorow,locol)+chi*invsfct*fact3*legpol(l,dotp)*&
128
                                 cph(k,jintsp)*CONJG(cph(kp,iintsp)) 
129 130 131 132 133 134 135 136
                         ENDIF
                      END DO
                   ELSE
                   END IF
                END DO
                !--->          calculate the overlap matrix elements of one local
                !--->          orbital with itself
                DO nkvecp = 1,nkvec
137
                   kp = lapw%kvec(nkvecp,lo,na)
138 139
                   lorow=lapw%nv(iintsp)+lapw%index_lo(lo,na)+nkvecp
                   dotp = dot_PRODUCT(lapw%gk(:,k,jintsp),lapw%gk(:,kp,iintsp))
Daniel Wortmann's avatar
Daniel Wortmann committed
140 141
                   IF (smat%l_real) THEN
                      smat%data_r(lorow,locol) = smat%data_r(lorow,locol) + chi*invsfct*fact1*legpol(l,dotp) *&
142
                           cph(k,jintsp)*CONJG(cph(kp,iintsp))
143
                   ELSE
Daniel Wortmann's avatar
Daniel Wortmann committed
144
                      smat%data_c(lorow,locol) = smat%data_c(lorow,locol) + chi*invsfct*fact1*legpol(l,dotp)*&
145
                           cph(k,jintsp)*CONJG(cph(kp,iintsp))
146 147 148 149 150 151 152 153 154
                   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
155
  PURE REAL FUNCTION legpol(l,arg)
156 157 158 159
    !
    IMPLICIT NONE
    !     ..
    !     .. Scalar Arguments ..
Daniel Wortmann's avatar
Daniel Wortmann committed
160 161
    REAL,INTENT(IN)   :: arg
    INTEGER,INTENT(IN):: l
162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179
    !     ..
    !     .. 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