LCOV - code coverage report
Current view: top level - wannier - wann_mmkb_int.F (source / functions) Coverage Total Hit
Test: FLEUR test coverage Lines: 82.6 % 46 38
Test Date: 2025-06-14 04:34:23 Functions: 100.0 % 1 1

            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_wann_mmkb_int
       8              :          use m_juDFT
       9              :       contains
      10           40 :       subroutine wann_mmkb_int(
      11              :      >               interchi,addnoco,addnoco2,nvd,k1d,k2d,k3d,
      12           40 :      >               n3d,k1,k2,k3,
      13              :      >               nv,neigd,nbasfcn,nbasfcn_b,zMat,nslibd,
      14           40 :      >               k1_b,k2_b,k3_b,
      15              :      >               nv_b,zMat_b,nslibd_b,
      16           40 :      >               nbnd,rgphs,ustep,ig,gb,
      17           40 :      <               mmnk)
      18              : 
      19              :       USE m_types
      20              : 
      21              :       implicit none
      22              : 
      23              :       TYPE(t_mat), INTENT(IN) :: zMat, zMat_b
      24              : 
      25              :       integer, intent(in) :: addnoco,addnoco2
      26              :       integer, intent(in) :: nvd,n3d,k1(nvd),k2(nvd),k3(nvd)
      27              :       integer, intent(in) :: nv,neigd,nbasfcn,nbasfcn_b,nslibd,nslibd_b
      28              :       integer, intent(in) :: nv_b,k1_b(nvd),k2_b(nvd),k3_b(nvd)
      29              :       integer, intent(in) :: nbnd
      30              :       integer, intent(in) :: k1d,k2d,k3d
      31              :       complex, intent(in) :: rgphs(-k1d:k1d,-k2d:k2d,-k3d:k3d)
      32              :       complex, intent(in) :: ustep(n3d),interchi
      33              :       integer, intent(in) :: ig(-k1d:k1d,-k2d:k2d,-k3d:k3d)
      34              :       integer, intent(in) :: gb(3)
      35              :       complex, intent(inout) :: mmnk(nbnd,nbnd)
      36              : 
      37           40 :       complex,allocatable::stepf_c(:,:)
      38           40 :       complex,allocatable::phasusbmat_c(:,:)
      39           40 :       real,allocatable::stepf_r(:,:)
      40           40 :       real,allocatable::phasusbmat_r(:,:)
      41           40 :       real,allocatable::mmnk_tmp(:,:)
      42              :       integer i,j1,j2,j3,i1,i2,i3,j,in,m,n
      43              :       real phase
      44              : 
      45           40 :       call timestart("wann_mmkb_int")
      46              : 
      47           40 :       IF(zMat%l_real) THEN
      48           80 :          allocate(mmnk_tmp(nslibd,nslibd_b))
      49           80 :          allocate(phasusbmat_r(nv,nslibd_b))
      50           80 :          allocate(stepf_r(nv_b,nv))
      51       354510 :          stepf_r = 0.0
      52              :       ELSE
      53            0 :          allocate(phasusbmat_c(nv,nslibd_b))
      54            0 :          allocate(stepf_c(nv_b,nv))
      55            0 :          stepf_c = CMPLX(0.0,0.0)
      56              :       END IF
      57              : 
      58         3869 :       do i =1,nv
      59         3829 :        j1 =-k1(i)  - gb(1)
      60         3829 :        j2 =-k2(i)  - gb(2)
      61         3829 :        j3 =-k3(i)  - gb(3)
      62       354510 :        do j = 1,nv_b
      63              : c-->     determine index and phase factor
      64       350641 :          i1 =j1 + k1_b(j) 
      65       350641 :          i2 =j2 + k2_b(j) 
      66       350641 :          i3 =j3 + k3_b(j) 
      67       350641 :          in = ig(i1,i2,i3)
      68       350641 :          if (in.eq.0) cycle
      69       350641 :          phase = rgphs(i1,i2,i3)
      70       354470 :          IF (zMat%l_real) THEN
      71       350641 :             stepf_r(j,i) = phase*real(ustep(in))
      72              :          ELSE
      73            0 :             stepf_c(j,i) = conjg(phase*ustep(in))
      74              :          END IF
      75              :        enddo
      76              :       enddo
      77           40 :       IF(zMat%l_real) THEN
      78              :          call dgemm('T','N',nv,nslibd_b,nv_b,real(1.0),
      79              :      &               stepf_r,nv_b,zMat_b%data_r(1+addnoco2,1),nbasfcn_b,
      80              : c     &               stepf_r,nv_b,zMat_b%data_r,nbasfcn_b,
      81           40 :      &               real(0.0),phasusbmat_r,nv)
      82              :          call dgemm('T','N',nslibd,nslibd_b,nv,real(1.0),
      83              :      &               zMat%data_r(1+addnoco,1),nbasfcn,phasusbmat_r,nv,
      84              : c     &               zMat%data_r,nbasfcn,phasusbmat_r,nv,
      85           40 :      &               real(0.0),mmnk_tmp,nbnd)
      86              :          mmnk(1:nslibd,1:nslibd_b)=mmnk(1:nslibd,1:nslibd_b)+
      87         2920 :      &               mmnk_tmp(1:nslibd,1:nslibd_b)*interchi
      88              :       ELSE
      89              :          call zgemm('T','N',nv,nslibd_b,nv_b,cmplx(1.0),
      90              :      &               stepf_c,nv_b,zMat_b%data_c(1+addnoco2,1),
      91              : c     &               stepf_c,nv_b,zMat_b%data_c,
      92              :      &               nbasfcn_b,cmplx(0.0),
      93            0 :      &               phasusbmat_c,nv)
      94            0 :          phasusbmat_c=conjg(phasusbmat_c)            
      95              :          call zgemm('T','N',nslibd,nslibd_b,nv,interchi, 
      96              :      &               zMat%data_c(1+addnoco,1),nbasfcn,phasusbmat_c,nv,
      97              : c     &               zMat%data_c,nbasfcn,phasusbmat_c,nv,
      98            0 :      &               cmplx(1.0),mmnk,nbnd)
      99              :       END IF
     100              : 
     101           40 :       IF(zMat%l_real) THEN
     102           40 :          deallocate(mmnk_tmp)
     103           40 :          deallocate(phasusbmat_r,stepf_r)
     104              :       ELSE
     105            0 :          deallocate(phasusbmat_c,stepf_c)
     106              :       END IF
     107              : 
     108           40 :       call timestop("wann_mmkb_int")
     109           40 :       end subroutine
     110              :       end module m_wann_mmkb_int
        

Generated by: LCOV version 2.0-1