LCOV - code coverage report
Current view: top level - eigen - hlomat.F90 (source / functions) Hit Total Coverage
Test: combined.info Lines: 125 134 93.3 %
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_hlomat
       8             : !***********************************************************************
       9             : ! updates the hamiltonian  matrix with the contributions from the local
      10             : ! orbitals.
      11             : ! p.kurz sept. 1996
      12             : !***********************************************************************
      13             : CONTAINS
      14        1028 :   SUBROUTINE hlomat(input,atoms,mpi,lapw,ud,tlmplm,sym,cell,noco,isp,&
      15        1028 :        ntyp,na,fj,gj,alo1,blo1,clo1, iintsp,jintsp,chi,hmat)
      16             :     !
      17             :     USE m_hsmt_ab
      18             :     USE m_types
      19             :     IMPLICIT NONE
      20             :     TYPE(t_input),INTENT(IN)  :: input
      21             :     TYPE(t_atoms),INTENT(IN)  :: atoms
      22             :     TYPE(t_lapw),INTENT(IN)   :: lapw
      23             :     TYPE(t_mpi),INTENT(IN)    :: mpi
      24             :     TYPE(t_usdus),INTENT(IN)  :: ud
      25             :     TYPE(t_tlmplm),INTENT(IN) :: tlmplm
      26             :     TYPE(t_sym),INTENT(IN)    :: sym
      27             :     TYPE(t_cell),INTENT(IN)   :: cell
      28             :     TYPE(t_noco),INTENT(IN)   :: noco
      29             : 
      30             : 
      31             :     !     ..
      32             :     !     .. Scalar Arguments ..
      33             :     INTEGER, INTENT (IN) :: na,ntyp  
      34             :     INTEGER, INTENT (IN) :: isp !spin for usdus and tlmplm
      35             :     INTEGER, INTENT (IN) :: jintsp,iintsp
      36             :     COMPLEX, INTENT (IN) :: chi
      37             :     !     ..
      38             :     !     .. Array Arguments ..
      39             :     REAL, INTENT (IN) :: alo1(:),blo1(:),clo1(:)
      40             :     REAL,INTENT(IN)      :: fj(:,0:,:),gj(:,0:,:)
      41             : 
      42             :     CLASS(t_mat),INTENT (INOUT) :: hmat
      43             :     !     ..
      44             :     !     .. Local Scalars ..
      45             :     COMPLEX axx,bxx,cxx,dtd,dtu,dtulo,ulotd,ulotu,ulotulo,utd,utu, utulo
      46             :     INTEGER im,in,invsfct,l,lm,lmp,lo,lolo,lolop,lop,lp,i  
      47             :     INTEGER mp,nkvec,nkvecp,lmplm,loplo,kp,m,mlo,mlolo
      48             :     INTEGER locol,lorow,ii,ij,n,k,ab_size
      49             :     !     ..
      50             :     !     .. Local Arrays ..
      51        2056 :     COMPLEX, ALLOCATABLE :: ab(:,:,:),ax(:),bx(:),cx(:)
      52        1028 :     COMPLEX,ALLOCATABLE  :: abclo(:,:,:,:,:)
      53             :     !     ..
      54             : 
      55             : 
      56             :     !-->              synthesize the complex conjugates of a and b
      57        1028 :     ALLOCATE(ab(MAXVAL(lapw%nv),0:2*atoms%lmaxd*(atoms%lmaxd+2)+1,MIN(jintsp,iintsp):MAX(jintsp,iintsp)))
      58        3084 :     ALLOCATE(ax(MAXVAL(lapw%nv)),bx(MAXVAL(lapw%nv)),cx(MAXVAL(lapw%nv)))
      59        1028 :     ALLOCATE(abclo(3,-atoms%llod:atoms%llod,2*(2*atoms%llod+1),atoms%nlod,2))
      60        2056 :     DO i=MIN(jintsp,iintsp),MAX(jintsp,iintsp)
      61        2056 :        CALL hsmt_ab(sym,atoms,noco,isp,i,ntyp,na,cell,lapw,fj,gj,ab(:,:,i),ab_size,.TRUE.,abclo(:,:,:,:,i),alo1,blo1,clo1)
      62             :     ENDDO
      63             : 
      64             : 
      65        1028 :     mlo=0;mlolo=0
      66        2884 :     DO m=1,ntyp-1
      67        1856 :        mlo=mlo+atoms%nlo(m)
      68        2884 :        mlolo=mlolo+atoms%nlo(m)*(atoms%nlo(m)+1)/2
      69             :     ENDDO
      70             : 
      71             : 
      72        1028 :     !$OMP MASTER
      73        1028 :     IF ((atoms%invsat(na) == 0) .OR. (atoms%invsat(na) == 1)) THEN
      74             :        !--->    if this atom is the first of two atoms related by inversion,
      75             :        !--->    the contributions to the overlap matrix of both atoms are added
      76             :        !--->    at once. where it is made use of the fact, that the sum of
      77             :        !--->    these contributions is twice the real part of the contribution
      78             :        !--->    of each atom. note, that in this case there are twice as many
      79             :        !--->    (2*(2*l+1)) k-vectors (compare abccoflo and comments there).
      80             :        IF (atoms%invsat(na) == 0) invsfct = 1
      81        1028 :        IF (atoms%invsat(na) == 1) invsfct = 2
      82             :        !
      83             : 
      84        2968 :        DO lo = 1,atoms%nlo(ntyp)
      85        1940 :           l = atoms%llo(lo,ntyp)
      86             :           !--->       calculate the hamiltonian matrix elements with the regular
      87             :           !--->       flapw basis-functions
      88        5952 :           DO m = -l,l
      89        4012 :              lm = l* (l+1) + m
      90     2166616 :              DO kp = 1,lapw%nv(iintsp)
      91     2162604 :                 ax(kp) = CMPLX(0.0,0.0)
      92     2162604 :                 bx(kp) = CMPLX(0.0,0.0)
      93     2166616 :                 cx(kp) = CMPLX(0.0,0.0)
      94             :              END DO
      95       32176 :              DO lp = 0,atoms%lnonsph(ntyp)
      96      230044 :                 DO mp = -lp,lp
      97      197868 :                    lmp = lp* (lp+1) + mp
      98      197868 :                    in = tlmplm%ind(lmp,lm,ntyp,isp)
      99      197868 :                    IF (lmp==lm) in=(lm* (lm+3))/2
     100      226032 :                    IF (in.NE.-9999) THEN
     101       44376 :                       IF (in.GE.0) THEN
     102       43584 :                          utu = tlmplm%tuu(in,ntyp,isp)
     103       43584 :                          dtu = tlmplm%tdu(in,ntyp,isp)
     104       43584 :                          utd = tlmplm%tud(in,ntyp,isp)
     105       43584 :                          dtd = tlmplm%tdd(in,ntyp,isp)
     106             :                       ELSE
     107         792 :                          im = -in
     108         792 :                          utu = CONJG(tlmplm%tuu(im,ntyp,isp))
     109         792 :                          dtu = CONJG(tlmplm%tud(im,ntyp,isp))
     110         792 :                          utd = CONJG(tlmplm%tdu(im,ntyp,isp))
     111         792 :                          dtd = CONJG(tlmplm%tdd(im,ntyp,isp))
     112             :                       END IF
     113       44376 :                       utulo = tlmplm%tuulo(lmp,m,lo+mlo,isp)
     114       44376 :                       dtulo = tlmplm%tdulo(lmp,m,lo+mlo,isp)
     115             :                       !--->                   note, that utu,dtu... are the t-matrices and
     116             :                       !--->                   not their complex conjugates as in hssphn
     117             :                       !--->                   and that a,b,alo... are the complex
     118             :                       !--->                   conjugates of the a,b...-coefficients
     119    24880752 :                       DO kp = 1,lapw%nv(iintsp)
     120    24836376 :                          ax(kp) = ax(kp) + ab(kp,lmp,iintsp)*utu + ab(kp,ab_size/2+lmp,iintsp)*dtu
     121    24836376 :                          bx(kp) = bx(kp) + ab(kp,lmp,iintsp)*utd + ab(kp,ab_size/2+lmp,iintsp)*dtd
     122    24880752 :                          cx(kp) = cx(kp) + ab(kp,lmp,iintsp)*utulo + ab(kp,ab_size/2+lmp,iintsp)*dtulo
     123             :                       END DO
     124             :                    END IF
     125             :                 END DO
     126             :              END DO
     127             :              !+t3e
     128       23564 :              DO nkvec = 1,invsfct* (2*l+1)
     129       17612 :                 locol= lapw%nv(jintsp)+lapw%index_lo(lo,na)+nkvec !this is the column of the matrix
     130       21624 :                 IF (MOD(locol-1,mpi%n_size) == mpi%n_rank) THEN !only this MPI rank calculates this column
     131        8960 :                    locol=(locol-1)/mpi%n_size+1 !this is the column in local storage
     132        8960 :                    IF (hmat%l_real) THEN
     133     9410340 :                       DO kp = 1,lapw%nv(iintsp)
     134             :                          hmat%data_r(kp,locol) = hmat%data_r(kp,locol) + chi*invsfct * (&
     135             :                               REAL(abclo(1,m,nkvec,lo,jintsp))* REAL(ax(kp)) +&
     136             :                               AIMAG(abclo(1,m,nkvec,lo,jintsp))*AIMAG(ax(kp)) +&
     137             :                               REAL(abclo(2,m,nkvec,lo,jintsp))* REAL(bx(kp)) +&
     138             :                               AIMAG(abclo(2,m,nkvec,lo,jintsp))*AIMAG(bx(kp)) +&
     139             :                               REAL(abclo(3,m,nkvec,lo,jintsp))* REAL(cx(kp)) +&
     140     4701000 :                               AIMAG(abclo(3,m,nkvec,lo,jintsp))*AIMAG(cx(kp)) )
     141     4709340 :                          IF (input%l_useapw) THEN
     142             :                             !---> APWlo
     143             :                             hmat%data_r(kp,locol) = hmat%data_r(kp,locol) + 0.25 * atoms%rmt(ntyp)**2 * chi*invsfct * (&
     144             :                                  (CONJG(ab(kp,lm,iintsp))* ud%us(l,ntyp,isp)+&
     145             :                                  CONJG(ab(kp,ab_size/2+lm,iintsp))*ud%uds(l,ntyp,isp))*&
     146             :                                  (abclo(1,m,nkvec,lo,jintsp)*  ud%dus(l,ntyp,isp)&
     147             :                                  +abclo(2,m,nkvec,lo,jintsp)* ud%duds(l,ntyp,isp)&
     148           0 :                                  +abclo(3,m,nkvec,lo,jintsp)*ud%dulos(lo,ntyp,isp) ))
     149             :                          ENDIF
     150             :                       ENDDO
     151             :                    ELSE
     152      356432 :                       DO kp = 1,lapw%nv(iintsp)
     153             :                          hmat%data_c(kp,locol) = hmat%data_c(kp,locol) + chi*invsfct * (&
     154             :                               abclo(1,m,nkvec,lo,jintsp) * CONJG( ax(kp) ) +&
     155             :                               abclo(2,m,nkvec,lo,jintsp) * CONJG( bx(kp) ) +&
     156      177906 :                               abclo(3,m,nkvec,lo,jintsp) * CONJG( cx(kp) ) )
     157      178526 :                          IF (input%l_useapw) THEN
     158             :                             !---> APWlo
     159             :                             hmat%data_c(kp,locol)=hmat%data_c(kp,locol) + 0.25 * atoms%rmt(ntyp)**2 * chi*invsfct*(&
     160             :                                  (CONJG(ab(kp,lm,iintsp))* ud%us(l,ntyp,isp)+&
     161             :                                  CONJG(ab(kp,ab_size/2+lm,iintsp))*ud%uds(l,ntyp,isp))*&
     162             :                                  (abclo(1,m,nkvec,lo,jintsp)*  ud%dus(l,ntyp,isp)&
     163             :                                  +abclo(2,m,nkvec,lo,jintsp)* ud%duds(l,ntyp,isp)&
     164           0 :                                  +abclo(3,m,nkvec,lo,jintsp)*ud%dulos(lo,ntyp,isp) ))
     165             :                          ENDIF
     166             :                       ENDDO
     167             :                    ENDIF
     168             :                    !--->             jump to the last matrixelement of the current row
     169             :                 ENDIF
     170             :              END DO
     171             :           END DO
     172             :           !--->       calculate the hamiltonian matrix elements with other
     173             :           !--->       local orbitals at the same atom and with itself
     174        9908 :           DO nkvec = 1,invsfct* (2*l+1)
     175        6940 :              locol= lapw%nv(jintsp)+lapw%index_lo(lo,na)+nkvec !this is the column of the matrix
     176        8880 :              IF (MOD(locol-1,mpi%n_size) == mpi%n_rank) THEN !only this MPI rank calculates this column
     177        3526 :                 locol=(locol-1)/mpi%n_size+1 !this is the column in local storage
     178             :                 !--->          calculate the hamiltonian matrix elements with other
     179             :                 !--->          local orbitals at the same atom, if they have the same l
     180        6028 :                 DO lop = 1, MERGE(lo-1,atoms%nlo(ntyp),iintsp==jintsp)
     181        2502 :                    IF (lop==lo) CYCLE
     182        2502 :                    lp = atoms%llo(lop,ntyp)
     183       10762 :                    DO nkvecp = 1,invsfct* (2*lp+1)
     184        4734 :                       lorow=lapw%nv(iintsp)+lapw%index_lo(lop,na)+nkvecp
     185       21438 :                       DO m = -l,l
     186       14202 :                          lm = l* (l+1) + m
     187       33138 :                          DO mp = -lp,lp
     188       14202 :                             lmp = lp* (lp+1) + mp
     189       14202 :                             in = tlmplm%ind(lmp,lm,ntyp,isp)
     190       14202 :                             IF (lmp==lm) in=(lm* (lm+3))/2
     191       28404 :                             IF (in.NE.-9999) THEN
     192        4320 :                                IF (in.GE.0) THEN
     193           0 :                                   utu = tlmplm%tuu(in,ntyp,isp)
     194           0 :                                   dtu = tlmplm%tdu(in,ntyp,isp)
     195           0 :                                   utd = tlmplm%tud(in,ntyp,isp)
     196           0 :                                   dtd = tlmplm%tdd(in,ntyp,isp)
     197             :                                ELSE
     198        4320 :                                   im = -in
     199        4320 :                                   utu = CONJG(tlmplm%tuu(im,ntyp,isp))
     200        4320 :                                   dtu = CONJG(tlmplm%tud(im,ntyp,isp))
     201        4320 :                                   utd = CONJG(tlmplm%tdu(im,ntyp,isp))
     202        4320 :                                   dtd = CONJG(tlmplm%tdd(im,ntyp,isp))
     203             :                                END IF
     204        4320 :                                utulo = tlmplm%tuulo(lmp,m,lo+mlo,isp)
     205        4320 :                                dtulo = tlmplm%tdulo(lmp,m,lo+mlo,isp)
     206        4320 :                                ulotu=CONJG(tlmplm%tuulo(lm,mp,lop+mlo,isp))
     207        4320 :                                ulotd=CONJG(tlmplm%tdulo(lm,mp,lop+mlo,isp))
     208             :                                !--->                         note that lo > lop
     209        4320 :                                IF (lo>lop) THEN
     210        4320 :                                   lolop = ((lo-1)*lo)/2 + lop
     211        4320 :                                   ulotulo = CONJG(tlmplm%tuloulo (m,mp,lolop+mlolo,isp))
     212             :                                ELSE
     213           0 :                                   lolop = ((lop-1)*lop)/2 + lo
     214           0 :                                   ulotulo = CONJG(tlmplm%tuloulo (mp,m,lolop+mlolo,isp))
     215             :                                ENDIF
     216             :                                axx=CONJG(abclo(1,m,nkvec,lo,jintsp))*utu +&
     217             :                                     CONJG(abclo(2,m,nkvec,lo,jintsp))*utd +&
     218        4320 :                                     CONJG(abclo(3,m,nkvec,lo,jintsp))*utulo
     219             :                                bxx=CONJG(abclo(1,m,nkvec,lo,jintsp))*dtu +&
     220             :                                     CONJG(abclo(2,m,nkvec,lo,jintsp))*dtd +&
     221        4320 :                                     CONJG(abclo(3,m,nkvec,lo,jintsp))*dtulo
     222             :                                cxx = &
     223             :                                     CONJG(abclo(1,m,nkvec,lo,jintsp))*ulotu +&
     224             :                                     CONJG(abclo(2,m,nkvec,lo,jintsp))*ulotd +&
     225        4320 :                                     CONJG(abclo(3,m,nkvec,lo,jintsp))*ulotulo
     226        4320 :                                IF (hmat%l_real) THEN
     227             :                                   hmat%data_r(lorow,locol) = hmat%data_r(lorow,locol) + chi*invsfct * (&
     228             :                                        REAL(abclo(1,mp,nkvecp,lop,iintsp))* REAL(axx) -&
     229             :                                        AIMAG(abclo(1,mp,nkvecp,lop,iintsp))*AIMAG(axx) +&
     230             :                                        REAL(abclo(2,mp,nkvecp,lop,iintsp))* REAL(bxx) -&
     231             :                                        AIMAG(abclo(2,mp,nkvecp,lop,iintsp))*AIMAG(bxx) +&
     232             :                                        REAL(abclo(3,mp,nkvecp,lop,iintsp))* REAL(cxx) -&
     233        4320 :                                        AIMAG(abclo(3,mp,nkvecp,lop,iintsp))*AIMAG(cxx) )
     234             :                                ELSE
     235             :                                   hmat%data_c(lorow,locol) = hmat%data_c(lorow,locol) + chi*invsfct * CONJG(&
     236             :                                        abclo(1,mp,nkvecp,lop,iintsp) * axx +&
     237             :                                        abclo(2,mp,nkvecp,lop,iintsp) * bxx +&
     238           0 :                                        abclo(3,mp,nkvecp,lop,iintsp) * cxx )
     239             :                                ENDIF
     240             :                             END IF
     241             :                          END DO
     242             :                       END DO
     243             :                    END DO
     244             :                 END DO
     245             :                 !--->          calculate the hamiltonian matrix elements of one local
     246             :                 !--->          orbital with itself
     247        3526 :                 lop=lo
     248       13489 :                 DO nkvecp = 1,MERGE(nkvec,invsfct* (2*l+1),iintsp==jintsp)
     249        9963 :                    lorow=lapw%nv(iintsp)+lapw%index_lo(lop,na)+nkvecp
     250       41116 :                    DO m = -l,l
     251       27627 :                       lm = l* (l+1) + m
     252      118809 :                       DO mp = -l,l
     253       81219 :                          lmp = l* (l+1) + mp
     254       81219 :                          in = tlmplm%ind(lmp,lm,ntyp,isp)
     255       81219 :                          IF (lmp==lm) in=(lm* (lm+3))/2
     256      108846 :                          IF (in.NE.-9999) THEN
     257       27849 :                             IF (in.GE.0) THEN
     258       27738 :                                utu = tlmplm%tuu(in,ntyp,isp)
     259       27738 :                                dtu = tlmplm%tdu(in,ntyp,isp)
     260       27738 :                                utd = tlmplm%tud(in,ntyp,isp)
     261       27738 :                                dtd = tlmplm%tdd(in,ntyp,isp)
     262             :                             ELSE
     263         111 :                                im = -in
     264         111 :                                utu = CONJG(tlmplm%tuu(im,ntyp,isp))
     265         111 :                                dtu = CONJG(tlmplm%tud(im,ntyp,isp))
     266         111 :                                utd = CONJG(tlmplm%tdu(im,ntyp,isp))
     267         111 :                                dtd = CONJG(tlmplm%tdd(im,ntyp,isp))
     268             :                             END IF
     269       27849 :                             utulo = tlmplm%tuulo(lmp,m,lo+mlo,isp)
     270       27849 :                             dtulo = tlmplm%tdulo(lmp,m,lo+mlo,isp)
     271       27849 :                             ulotu = CONJG(tlmplm%tuulo(lm,mp,lo+mlo,isp))
     272       27849 :                             ulotd = CONJG(tlmplm%tdulo(lm,mp,lo+mlo,isp))
     273       27849 :                             lolo = ((lo-1)*lo)/2 + lo
     274       27849 :                             ulotulo =CONJG(tlmplm%tuloulo(m,mp,lolo+mlolo,isp))
     275             :                             axx = CONJG(abclo(1,m,nkvec,lo,jintsp))*utu +&
     276             :                                  CONJG(abclo(2,m,nkvec,lo,jintsp))*utd +&
     277       27849 :                                  CONJG(abclo(3,m,nkvec,lo,jintsp))*utulo
     278             :                             bxx = CONJG(abclo(1,m,nkvec,lo,jintsp))*dtu +&
     279             :                                  CONJG(abclo(2,m,nkvec,lo,jintsp))*dtd +&
     280       27849 :                                  CONJG(abclo(3,m,nkvec,lo,jintsp))*dtulo
     281             :                             cxx = CONJG(abclo(1,m,nkvec,lo,jintsp))*ulotu +&
     282             :                                  CONJG(abclo(2,m,nkvec,lo,jintsp))*ulotd +&
     283       27849 :                                  CONJG(abclo(3,m,nkvec,lo,jintsp))*ulotulo
     284       27849 :                             IF (hmat%l_real) THEN
     285             :                                hmat%data_r(lorow,locol) = hmat%data_r(lorow,locol) + chi*invsfct* (&
     286             :                                     REAL(abclo(1,mp,nkvecp,lo,iintsp))* REAL(axx) -&
     287             :                                     AIMAG(abclo(1,mp,nkvecp,lo,iintsp))*AIMAG(axx) +&
     288             :                                     REAL(abclo(2,mp,nkvecp,lo,iintsp))* REAL(bxx) -&
     289             :                                     AIMAG(abclo(2,mp,nkvecp,lo,iintsp))*AIMAG(bxx) +&
     290             :                                     REAL(abclo(3,mp,nkvecp,lo,iintsp))* REAL(cxx) -&
     291       26262 :                                     AIMAG(abclo(3,mp,nkvecp,lo,iintsp))*AIMAG(cxx) )
     292             :                             ELSE
     293             :                                hmat%data_c(lorow,locol) = hmat%data_c(lorow,locol) + chi*invsfct* CONJG(&
     294             :                                     abclo(1,mp,nkvecp,lo,iintsp)*axx +&
     295             :                                     abclo(2,mp,nkvecp,lo,iintsp)*bxx +&
     296        1587 :                                     abclo(3,mp,nkvecp,lo,iintsp)*cxx )
     297             :                             ENDIF
     298             :                          END IF
     299             :                       END DO
     300             :                    END DO
     301             :                 END DO
     302             :              ENDIF !If this lo to be calculated by mpi rank
     303             :           END DO
     304             :        END DO ! end of lo = 1,atoms%nlo loop
     305             : 
     306             :     END IF
     307             :     !$OMP END MASTER
     308        1028 :     !$OMP barrier
     309        1028 :   END SUBROUTINE hlomat
     310             : END MODULE m_hlomat

Generated by: LCOV version 1.13