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 160 : allocate(mmnk_tmp(nslibd,nslibd_b))
49 160 : allocate(phasusbmat_r(nv,nslibd_b))
50 160 : 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
|
