LCOV - code coverage report
Current view: top level - wannier - wann_mmkb_int.F (source / functions) Hit Total Coverage
Test: combined.info Lines: 0 44 0.0 %
Date: 2019-09-08 04:53:50 Functions: 0 1 0.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_wann_mmkb_int
       8             :       contains
       9           0 :       subroutine wann_mmkb_int(
      10             :      >               interchi,addnoco,addnoco2,nvd,k1d,k2d,k3d,
      11           0 :      >               n3d,k1,k2,k3,
      12             :      >               nv,neigd,nbasfcn,zMat,nslibd,
      13           0 :      >               k1_b,k2_b,k3_b,
      14             :      >               nv_b,zMat_b,nslibd_b,
      15           0 :      >               nbnd,rgphs,ustep,ig,gb,
      16           0 :      <               mmnk)
      17             : 
      18             :       USE m_types
      19             : 
      20             : #include "cpp_double.h"
      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,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           0 :       complex,allocatable::stepf_c(:,:)
      38           0 :       complex,allocatable::phasusbmat_c(:,:)
      39           0 :       real,allocatable::stepf_r(:,:)
      40           0 :       real,allocatable::phasusbmat_r(:,:)
      41           0 :       real,allocatable::mmnk_tmp(:,:)
      42             :       integer i,j1,j2,j3,i1,i2,i3,j,in,m,n
      43             :       real phase
      44             : 
      45           0 :       IF(zMat%l_real) THEN
      46           0 :          allocate(mmnk_tmp(nslibd,nslibd_b))
      47           0 :          allocate(phasusbmat_r(nv,nslibd_b))
      48           0 :          allocate(stepf_r(nv_b,nv))
      49           0 :          stepf_r = 0.0
      50             :       ELSE
      51           0 :          allocate(phasusbmat_c(nv,nslibd_b))
      52           0 :          allocate(stepf_c(nv_b,nv))
      53           0 :          stepf_c = CMPLX(0.0,0.0)
      54             :       END IF
      55             : 
      56           0 :       do i =1,nv
      57           0 :        j1 =-k1(i)  - gb(1)
      58           0 :        j2 =-k2(i)  - gb(2)
      59           0 :        j3 =-k3(i)  - gb(3)
      60           0 :        do j = 1,nv_b
      61             : c-->     determine index and phase factor
      62           0 :          i1 =j1 + k1_b(j) 
      63           0 :          i2 =j2 + k2_b(j) 
      64           0 :          i3 =j3 + k3_b(j) 
      65           0 :          in = ig(i1,i2,i3)
      66           0 :          if (in.eq.0) cycle
      67           0 :          phase = rgphs(i1,i2,i3)
      68           0 :          IF (zMat%l_real) THEN
      69           0 :             stepf_r(j,i) = phase*real(ustep(in))
      70             :          ELSE
      71           0 :             stepf_c(j,i) = conjg(phase*ustep(in))
      72             :          END IF
      73             :        enddo
      74             :       enddo
      75           0 :       IF(zMat%l_real) THEN
      76             :          call CPP_BLAS_sgemm('T','N',nv,nslibd_b,nv_b,real(1.0),
      77             :      &               stepf_r,nv_b,zMat_b%data_r(1+addnoco2,1),nbasfcn,
      78             : c     &               stepf_r,nv_b,zMat_b%data_r,nbasfcn,
      79           0 :      &               real(0.0),phasusbmat_r,nv)
      80             :          call CPP_BLAS_sgemm('T','N',nslibd,nslibd_b,nv,real(1.0),
      81             :      &               zMat%data_r(1+addnoco,1),nbasfcn,phasusbmat_r,nv,
      82             : c     &               zMat%data_r,nbasfcn,phasusbmat_r,nv,
      83           0 :      &               real(0.0),mmnk_tmp,nbnd)
      84             :          mmnk(1:nslibd,1:nslibd_b)=mmnk(1:nslibd,1:nslibd_b)+
      85           0 :      &               mmnk_tmp(1:nslibd,1:nslibd_b)*interchi
      86             :       ELSE
      87             :          call CPP_BLAS_cgemm('T','N',nv,nslibd_b,nv_b,cmplx(1.0),
      88             :      &               stepf_c,nv_b,zMat_b%data_c(1+addnoco2,1),
      89             : c     &               stepf_c,nv_b,zMat_b%data_c,
      90             :      &               nbasfcn,cmplx(0.0),
      91           0 :      &               phasusbmat_c,nv)
      92           0 :          phasusbmat_c=conjg(phasusbmat_c)            
      93             :          call CPP_BLAS_cgemm('T','N',nslibd,nslibd_b,nv,interchi, 
      94             :      &               zMat%data_c(1+addnoco,1),nbasfcn,phasusbmat_c,nv,
      95             : c     &               zMat%data_c,nbasfcn,phasusbmat_c,nv,
      96           0 :      &               cmplx(1.0),mmnk,nbnd)
      97             :       END IF
      98             : 
      99           0 :       IF(zMat%l_real) THEN
     100           0 :          deallocate(mmnk_tmp)
     101           0 :          deallocate(phasusbmat_r,stepf_r)
     102             :       ELSE
     103           0 :          deallocate(phasusbmat_c,stepf_c)
     104             :       END IF
     105             : 
     106           0 :       end subroutine
     107             :       end module m_wann_mmkb_int

Generated by: LCOV version 1.13