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
|
