!=======================================================================
!
!  SOFTWARE NAME : PHASE (ver. 6.01)
!
!  MODULE: m_BP_Properties
!
!  AUTHOR(S): T. Yamamoto   Oct/01/2004
!
!  Contact address :  Phase System Consortium
!                     E-mail: phase_system@nims.go.jp URL https://azuma.nims.go.jp
!  
!
!
! ==============
!  patch 0.1 by K. Tagami @adv    2008/10/19
!
!     patch 0.1 :  correction in the case when nspin==2
!=======================================================================
!
!     The original version of this set of the computer programs "PHASE"
!  was developed by the members of the Theory Group of Joint Research
!  Center for Atom Technology (JRCAT), based in Tsukuba, in the period
!  1993-2001.
!
!     Since 2002, this set has been tuned and new functions have been
!  added to it as a part of the national project "Frontier Simulation
!  Software for Industrial Science (FSIS)",  which is supported by
!  the IT program of the Ministry of Education, Culture, Sports,
!  Science and Technology (MEXT) of Japan.
!     Since 2006, this program set has been developed as a part of the
!  national project "Revolutionary Simulation Software (RSS21)", which
!  is supported by the next-generation IT program of MEXT of Japan.
!   Since 2013, this program set has been further developed centering on PHASE System
!  Consortium.
!   The activity of development of this program set has been supervised by Takahisa Ohno.
!
!
module m_BerryPhase
! $Id: m_BerryPhase.F90 376 2014-06-17 07:48:31Z jkoga $
use m_Const_Parameters,    only : DP, PAI, PAI2, PAI4, ON, OFF
use m_Control_Parameters,  only : ipriberry, nspin, printable
use m_Files,               only : nfout
use m_Parallelization,    only : mpi_comm_group,ista_kngp,iend_kngp,npes,mype &
       &              , nrank_e,myrank_e,map_e,ista_e,iend_e,istep_e &
       &              , map_z,np_e,mpi_k_world,myrank_k,map_k,ista_k,iend_k &
       &              , map_ek &
#ifdef TRANSPOSE
       &              , ierr,mp_e,nis_e,nie_e,nel_e &
       &              , ista_g1,iend_g1,np_g1,mp_g1,nis_g1,nie_g1,nel_g1
#else
       &              , ierr
#endif

implicit none
include 'mpif.h'
integer, private :: n1,n2,jpara
integer, private :: ig
integer, private :: nkvec,nkprep
integer, private :: nstate = -1
integer, private :: ikp = 0
integer, private :: sw_symmetry = 2 ! 1->idetical, 2->inversion, 3->full
integer, private :: sw_deficit = ON ! 0->off, 1->on
real(kind=DP), private :: g(3)
real(kind=DP), allocatable, private :: kvec(:,:) ! dim(3,nkvec)
real(kind=DP), allocatable, private :: wgh(:) ! dim(nkprep)
real(kind=DP), allocatable, private :: wfbp0(:,:,:,:) ! dim(kg,np_e,2,nspin)
real(kind=DP), allocatable, private :: wfbp1(:,:,:,:) ! dim(kg,np_e,2,nspin)
real(kind=DP), allocatable, private :: wfbp2(:,:,:,:) ! dim(kg,np_e,2,nspin)
integer, private :: kgbp0,kgbp1,kgbp2
complex(kind=DP), allocatable, private :: det(:,:,:) ! dim(jpara,nkprep,nspin)
real(kind=DP) :: kshift_BP(2)
logical, private :: ikp0 = .true.

! for the US correction
real(kind=DP), allocatable, private :: fsr_k0(:,:,:),fsi_k0(:,:,:) ! dim(np_e,nlmta,nspin)
real(kind=DP), allocatable, private :: fsr_k1(:,:,:),fsi_k1(:,:,:) ! dim(np_e,nlmta,nspin)
real(kind=DP), allocatable, private :: fsr_k2(:,:,:),fsi_k2(:,:,:) ! dim(np_e,nlmta,nspin
real(kind=DP), allocatable, private :: zfcos(:),zfsin(:) ! dim(natm)
real(kind=DP), allocatable, private :: ftqer(:,:,:),ftqei(:,:,:) ! dim(nlmt,nlmt,natm)

! Tags
character(len("berry_phase")),private,parameter :: tag_berry_phase = "berry_phase"
character(len("sw_berry_phase")),private,parameter :: tag_sw_berry_phase = "sw_berry_phase"
character(len("g_index")),private,parameter :: tag_g_index = "g_index"
character(len("mesh")),private,parameter :: tag_mesh = "mesh"
character(len("n1")),private,parameter :: tag_n1 = "n1"
character(len("n2")),private,parameter :: tag_n2 = "n2"
character(len("j")),private,parameter :: tag_j = "j"
character(len("kshift")),private,parameter :: tag_kshift = "kshift"
character(len("k1")),private,parameter :: tag_k1 = "k1"
character(len("k2")),private,parameter :: tag_k2 = "k2"
character(len("sw_symmetry")),private,parameter :: tag_sw_symmetry = "sw_symmetry"
character(len("sw_deficit")),private,parameter :: tag_sw_deficit = "sw_deficit"

! MPI
!integer, private :: istatus
integer, private :: istatus(mpi_status_size)

contains

subroutine m_BP_rd_parameters
use m_Crystal_Structure, only : rltv
use m_Control_Parameters,  only : icond,sw_berry_phase
use m_Const_Parameters, only : FIXED_CHARGE,FIXED_CHARGE_CONTINUATION
implicit none

integer :: iret, f_selectBlock, f_getIntValue, f_getRealValue &
        & ,f_getRealVectorValue
integer :: f_selectParentBlock, f_selectTop
real(kind=DP) :: dret

if(icond /= FIXED_CHARGE .and. icond /= FIXED_CHARGE_CONTINUATION) return

iret = f_selectTop()
if( f_selectBlock( tag_berry_phase) == 0) then
  if( f_getIntValue( tag_sw_berry_phase, iret) == 0) sw_berry_phase = iret
  if( f_getIntValue( tag_sw_symmetry, iret) == 0) sw_symmetry = iret
  if( f_getIntValue( tag_sw_deficit, iret) == 0) sw_deficit = iret
  if( f_getIntValue( tag_g_index, iret) == 0) then
    ig = iret
  else
    ig = 1 ! default value
  end if
  if( f_selectBlock( tag_mesh) == 0) then
    if( f_getIntValue( tag_n1, iret) == 0) n1 = iret
    if( f_getIntValue( tag_n2, iret) == 0) n2 = iret
    if( f_getIntValue( tag_j, iret) == 0)  jpara = iret
  else
    n1 = 4 ! default value
    n2 = 4 ! default value
    jpara = 20 ! default value
  end if
  iret = f_selectParentBlock()
  if( f_selectBlock( tag_kshift) == 0) then
    if( f_getRealValue( tag_k1, dret, '' ) == 0) kshift_BP(1) = dret
    if( f_getRealValue( tag_k2, dret, '' ) == 0) kshift_BP(2) = dret
  else
    kshift_BP(1:2) = 0.d0 ! default value
  end if
  iret = f_selectParentBlock()
end if
iret = f_selectParentBlock()

if(sw_berry_phase == ON .and. printable) then
   write(nfout,'(1x,"<< Berry Phase")')
   write(nfout,'(1x,"ig=",i1,1x,"g=",3(1x,f10.5))') ig,rltv(1:3,ig)
   write(nfout,'(1x,"n1=",i3,1x,"n2=",i3,1x,"J=",i3)') n1,n2,jpara
   write(nfout,'(1x,"k1=",f8.5,1x,"k2=",f8.5)') kshift_BP(1:2)
   write(nfout,'(1x,"sw_symmetry = ",i1)') sw_symmetry
   write(nfout,'(1x,"sw_deficit = ",i1)') sw_deficit
   write(nfout,'(1x,"   Berry Phase >>")')
end if

end subroutine m_BP_rd_parameters


subroutine m_BP_gen_Kpoints(preallocation)
use m_Kpoints, only: special_kpoints, kshift, mp_index
use m_Crystal_Structure, only : rltv, nopr, op, imag
use m_Const_Parameters,  only : CARTS,BUCS,PARA
use m_Kpoints, only : kv3, vkxyz, qwgt, m_Kp_alloc_kpoints
implicit none

logical, intent(in) :: preallocation

! local variables
integer :: i,j,k
integer :: printlevel = 1
integer :: nkpoint,nsym
integer, parameter :: nkpmax0 = 10000
real(kind=DP) :: kpoint(3,nkpmax0), weight(nkpmax0)
real(kind=DP) :: bmat(3,3)
real(kind=DP) :: c(3,2),b(3,2)
real(kind=DP) :: cdot,g2,dg,w
real(kind=DP) :: a1(3),a2(3),a3(3),volg
real(kind=DP) :: rot(3,3,48),rot_g(3)
real(kind=DP) :: scaled_g(3),scaled_a3(3)
real(kind=DP) :: theta
real(kind=DP), parameter :: eps = 1.d-12
logical :: sw_trs = .true. ! time reversal symmetry
logical :: magnetic, use_trs

use_trs = .true.
if(imag/=PARA) then
   magnetic = .true.
else
   magnetic = .false.
end if
bmat(1:3,1:3)=rltv(1:3,1:3)/PAI2

g(1:3) = bmat(1:3,ig)
k=0
do i=1,3
  if(i /= ig) then
    k=k+1
    b(1:3,k)=bmat(1:3,i)
  end if
end do

g2 = sum(g(1:3)**2)
do k=1,2
  cdot = sum(b(1:3,k)*g(1:3))/g2 
  c(1:3,k) = b(1:3,k) - cdot*g(1:3)
end do

call cross(c(1,2),g,a1)
volg = sum(c(1:3,1)*a1(1:3))
a1(1:3)=a1(1:3)/volg
call cross(g,c(1,1),a2)
a2(1:3)=a2(1:3)/volg
call cross(c(1,1),c(1,2),a3)
a3(1:3)=a3(1:3)/volg

nsym=0
do i=1,nopr
  do j=1,3
    rot_g(j) = sum(op(j,1:3,i)*g(1:3))
  end do
  if(abs(rot_g(1)-g(1)) < eps .and. &
   & abs(rot_g(2)-g(2)) < eps .and. &
   & abs(rot_g(3)-g(3)) < eps ) then
    nsym=nsym+1
    rot(1:3,1:3,nsym) = op(1:3,1:3,i)
  end if
end do

if(preallocation .and. printable) then
write(nfout,'(1x,"<< k-points for an area integral in Berry phase calc.")')
write(nfout,*) 'c1 = ',c(1:3,1)
write(nfout,*) 'c2 = ',c(1:3,2)
write(nfout,*) 'g  = ',g(1:3)
write(nfout,*) 'a1 = ',a1(1:3)
write(nfout,*) 'a2 = ',a2(1:3)
write(nfout,*) 'a3 = ',a3(1:3)
theta = sum(a1(1:3)*a2(1:3))/(sqrt(sum(a1(1:3)**2))*sqrt(sum(a2(1:3)**2)))
theta = acos(theta)*360/PAI2
write(nfout,*) 'angle between a1 and a2 (deg.) =',theta
end if

! debug
!if(printable) then
!write(nfout,*) '<< left symmetry operations >>'
!write(nfout,*) 'Nsym = ', nsym
!do i=1,nsym
!  write(nfout,'(1x,"i=",i2)') i
!  write(nfout,'(1x,3(f10.5,1x))') rot(1,1:3,i)
!  write(nfout,'(1x,3(f10.5,1x))') rot(2,1:3,i)
!  write(nfout,'(1x,3(f10.5,1x))') rot(3,1:3,i)
!end do
!end if
! end debug

! for identical symmetry olny
if(sw_symmetry == 1 .or. sw_symmetry == 2) then
  nsym=1
  rot(1:3,1:3,nsym) = 0.d0
  do i=1,3
    rot(i,i,nsym) = 1.d0
  end do
end if
if(sw_symmetry == 1) sw_trs = .false.

mp_index(1)=n1
mp_index(2)=n2
mp_index(3)=1
kshift(1:2)=kshift_BP(1:2)
kshift(3)=0.d0
scaled_g(1:3)  = g(1:3)/dble(100)
scaled_a3(1:3) = a3(1:3)*dble(100)
nkprep = 0
call special_kpoints(printlevel,nfout,nsym,rot &
  & , c(1,1),c(1,2),scaled_g,a1,a2,scaled_a3 &
  !& , c(1,1),c(1,2),g,a1,a2,a3 &
  & , nkprep,nkpmax0,kpoint,weight,magnetic,use_trs)
if(preallocation.and.printable) then
   write(nfout,'(1x,"   k-points for an area integral in Berry phase calc. >>")')
end if

nkvec=nkprep*jpara
allocate(kvec(3,nkvec))
allocate(wgh(nkprep))
dg = 1.d0/jpara
nkvec=0
do j=1,nkprep
  wgh(j)=weight(j)/dble(nspin)
  do i=1,jpara
    nkvec=nkvec+1
    kvec(1:2,nkvec) = kpoint(1:2,j)
    kvec(3,nkvec)   = dg*dble(i-1)
  end do
end do

!kv3 = nkvec*nspin
!call m_Kp_alloc_kpoints


if(.not.preallocation) then

kv3 = nkvec
w=1.d0/dble(kv3)
do i=1,nkvec
  vkxyz(i,1:3,CARTS) = 0.d0
  do j=1,2
    vkxyz(i,1:3,CARTS) = vkxyz(i,1:3,CARTS)+ c(1:3,j)*kvec(j,i)
  end do
  vkxyz(i,1:3,CARTS) = vkxyz(i,1:3,CARTS)+ g(1:3)*kvec(j,i)
  vkxyz(i,1:3,CARTS) = vkxyz(i,1:3,CARTS)*PAI2
  qwgt(i) = w
end do

if(printable) then
write(nfout,'("<< generated k-points")')
do i=1,nkvec
  write(nfout,'(1x,i4," k=",3(1x,f10.5),1x," k_cart=", &
    & 3(1x,f10.5),1x,"w= ",f10.5)') &
    & i,kvec(1:3,i),vkxyz(i,1:3,CARTS),qwgt(i)
end do
write(nfout,'("   generated k-points >>")')
end if

allocate(det(jpara,nkprep,nspin));det=(0.d0,0.d0)

call set_dk_BP()

else
   kv3 = nkvec*nspin
   deallocate(kvec,wgh)
end if

!stop 'm_BP_gen_Kpoints'

contains

  subroutine cross(a,b,c)
  implicit none
  real(kind=DP), intent(in) :: a(3),b(3)
  real(kind=DP), intent(out) :: c(3)

  !local variables
  integer :: i,j,k

  c(1) = a(2)*b(3)-a(3)*b(2)
  c(2) = a(3)*b(1)-a(1)*b(3)
  c(3) = a(1)*b(2)-a(2)*b(1)

  end subroutine cross

  subroutine set_dk_BP()
  use m_PseudoPotential, only : dk_BP

  dk_BP(1) = sqrt(sum(g(1:3)**2))/jpara*PAI2
  !dk_BP(1) = 0.d0 ! for debug of Fourier transforms
if(printable) then
  write(nfout,*) '!** set_dk_BP: dk_BP=',dk_BP(1)
end if

  end subroutine set_dk_BP

end subroutine m_BP_gen_Kpoints



subroutine calc_phase_for_Berry()
use m_Ionic_System,        only : pos,natm

! local variables
integer       :: ia
real(kind=DP) :: ph

if(.not.allocated(zfcos)) allocate(zfcos(natm),zfsin(natm))

! debug
!do ia=1,natm
!  if(printable) write(nfout,*) ia,': pos=',pos(ia,1:3)
!end do
!if(printable) write(nfout,*) '--- ia,zfcos,zfsin ---'
! end debug
do ia=1,natm
  ph = pos(ia,ig)*PAI2
  zfcos(ia) = cos(ph)
  zfsin(ia) = sin(ph)
  ! debug
  ! if(printable) write(nfout,*) ia,zfcos(ia),zfsin(ia)
  ! end debug
end do

end subroutine calc_phase_for_Berry



subroutine m_BP_calc_det()
use m_PseudoPotential,     only : nlmta
! === DEBUG by T.Kato 2013/07/11 ===============================================
!use m_Electronic_Structure, only : neg, neordr
use m_Electronic_Structure, only : neordr
use m_Control_Parameters, only : neg
! ==============================================================================
implicit none

! local variables
integer :: i,k,k1,k2,j1,j2,kg,nk1,nk2
integer :: ik,is
integer :: j1_mpi,j1_ordr
real(kind=DP) :: mr(nstate,nstate),mi(nstate,nstate)
real(kind=DP), allocatable :: mr_mpi(:,:),mi_mpi(:,:)
real(kind=DP), allocatable :: wfbp(:,:,:,:)
real(kind=DP), allocatable :: fsr_k(:,:,:),fsi_k(:,:,:)

! for debug
integer :: n


nk1 = mod(ikp,jpara)
nk2 = ikp/jpara+1

if(jpara>1) then

kg = min(kgbp1,kgbp2)

allocate(wfbp(kgbp2,nstate,2,nspin))
call copy_old_wfbp_to_temp_wfbp(kgbp2,wfbp2,wfbp) ! MPI
if(sw_deficit == ON) then
  allocate(fsr_k(nstate,nlmta,nspin),fsi_k(nstate,nlmta,nspin))
  call copy_old_fs_to_temp_fs(fsr_k2,fsi_k2,fsr_k,fsi_k) ! MPI
!debug
! if(printable) then
!    do i=1,nlmta
!    do n=1,nstate
!      write(nfout,'("n=",i2," i=",i2," fsr_k2=",f10.5," fsr_k=",f10.5)') & 
!           &         n,i,fsr_k2(n,i),fsr_k(n,i)
!      write(nfout,'("n=",i2," i=",i2," fsi_k2=",f10.5," fsi_k=",f10.5)') & 
!           &         n,i,fsi_k2(n,i),fsi_k(n,i)
!    end do
!    end do
! end if
!end debug
end if

SPIN: do is =1,nspin
mr=0.d0; mi=0.d0
ik=is
do j2=1,nstate
  do j1=1,neg
    if(map_ek(j1,ik) /= mype) cycle
    j1_mpi = map_z(j1)
    j1_ordr = neordr(j1,ik)
    !if(printable) write(nfout,*) 'j1=',j1,' j1_mpi=',j1_mpi,' j1_ordr=',j1_ordr,' mype=',mype
    if(j1_ordr > nstate) cycle
    !if(printable) write(nfout,*) '>>>> j1_ordr is lower than nstate+1.'
    do i=1,kg
      !debug
      !if(i<10.and.printable) write(nfout,'("OM: wfbp1 = ",2f10.5)')  wfbp1(i,j1_mpi,1:2) 
      !if(i<10.and.printable) write(nfout,'("OM: wfbp2 = ",2f10.5)')  wfbp(i,j2,1:2) 
      !debug end
      mr(j1_ordr,j2) = mr(j1_ordr,j2) + &
      & wfbp1(i,j1_mpi,1,is)*wfbp(i,j2,1,is) + wfbp1(i,j1_mpi,2,is)*wfbp(i,j2,2,is)
      mi(j1_ordr,j2) = mi(j1_ordr,j2) - &
      & wfbp1(i,j1_mpi,2,is)*wfbp(i,j2,1,is) + wfbp1(i,j1_mpi,1,is)*wfbp(i,j2,2,is)
    end do
    if(sw_deficit == ON) &
    & call add_deficit_term(mr(j1_ordr,j2),mi(j1_ordr,j2) &
    &                      ,fsr_k1,fsi_k1 &
    &                      ,fsr_k,fsi_k &
    &                      ,j1_mpi,j2,is)
  end do
end do
call mpi_barrier(mpi_comm_group,ierr)
if(npes>1) then
  allocate(mr_mpi(nstate,nstate),mi_mpi(nstate,nstate))
  mr_mpi=0.d0; mi_mpi=0.d0
  call mpi_allreduce(mr,mr_mpi,nstate**2,mpi_double_precision,mpi_sum &
                   &,mpi_comm_group,ierr)
  mr = mr_mpi
  call mpi_allreduce(mi,mi_mpi,nstate**2,mpi_double_precision,mpi_sum &
                   &,mpi_comm_group,ierr)
  mi = mi_mpi
  deallocate(mr_mpi,mi_mpi)
end if

call determinant(nstate,mr,mi,det(nk1,nk2,is))

if(ipriberry > 1 .and. printable) then
   write(nfout,'(1x,"Overlap matrix: k1=",i4," k2=",i4," is=",i4)') nk1,nk1+1,is
   write(nfout,'(1x,"ikp=",i4)') ikp
   write(nfout,'(1x,"ikprep=",i4)') nk2
   write(nfout,'(1x,"kg=",i0)') kg
   write(nfout,'(1x,"Real part:")')
   do j1=1,nstate
      write(nfout,'(50(1x,f10.5))') mr(j1,1:nstate)
   end do
   write(nfout,'(1x,"Imag part:")')
   do j1=1,nstate
      write(nfout,'(50(1x,f10.5))') mi(j1,1:nstate)
   end do
   write(nfout,'(1x,"Determinant: k1=",i4," k2=",i4," is=",i4)') nk1,nk1+1,is
   write(nfout,'("Det = ",e25.14," +i ",e25.14)') det(nk1,nk2,is)
end if

end do SPIN
deallocate(wfbp)
if(sw_deficit==ON) deallocate(fsr_k,fsi_k)

end if

if(nk1==jpara-1) then
  kg = min(kgbp2,kgbp0)

  allocate(wfbp(kgbp0,nstate,2,nspin))
  call copy_old_wfbp_to_temp_wfbp(kgbp0,wfbp0,wfbp) ! MPI
  if(sw_deficit == ON) then
    allocate(fsr_k(nstate,nlmta,nspin),fsi_k(nstate,nlmta,nspin))
    call copy_old_fs_to_temp_fs(fsr_k0,fsi_k0,fsr_k,fsi_k) ! MPI
! debug
! if(printable) then
!    do i=1,nlmta
!    do n=1,nstate
!      write(nfout,'("n=",i2," i=",i2," fsr_k0=",f10.5," fsr_k=",f10.5)') & 
!           &         n,i,fsr_k0(n,i),fsr_k(n,i)
!      write(nfout,'("n=",i2," i=",i2," fsi_k0=",f10.5," fsi_k=",f10.5)') & 
!           &         n,i,fsi_k0(n,i),fsi_k(n,i)
!    end do
!    end do
! end if
! end debug
  end if

  SPIN2: do is=1,nspin
  mr =0.d0; mi=0.d0
  ik = is
  do j2=1,nstate
    do j1=1,neg
      if(map_ek(j1,ik) /= mype) cycle
      j1_mpi = map_z(j1)
      j1_ordr = neordr(j1,ik)
      !if(printable) write(nfout,*) 'j1=',j1,' j1_mpi=',j1_mpi,' j1_ordr=',j1_ordr,' mype=',mype
      if(j1_ordr > nstate) cycle
      !if(printable) write(nfout,*) '>>>> j1_ordr is lower than nstate+1.'
      do i=1,kg
        !debug
        !if(i<10.and.printable) write(nfout,'("OM: wfbp2 = ",2f10.5)')  wfbp2(i,j1_mpi,1:2)
        !if(i<10.and.printable) write(nfout,'("OM: wfbp0 = ",2f10.5)')  wfbp(i,j2,1:2)
        !debug end
        mr(j1_ordr,j2) = mr(j1_ordr,j2) + &
        & wfbp2(i,j1_mpi,1,is)*wfbp(i,j2,1,is) + wfbp2(i,j1_mpi,2,is)*wfbp(i,j2,2,is)
        mi(j1_ordr,j2) = mi(j1_ordr,j2) - &
        & wfbp2(i,j1_mpi,2,is)*wfbp(i,j2,1,is) + wfbp2(i,j1_mpi,1,is)*wfbp(i,j2,2,is)
      end do
      if(sw_deficit == ON) &
      & call add_deficit_term(mr(j1_ordr,j2),mi(j1_ordr,j2) &
      &                      ,fsr_k2,fsi_k2 &
      &                      ,fsr_k,fsi_k &
      &                      ,j1_mpi,j2,is)
    end do
  end do
  call mpi_barrier(mpi_comm_group,ierr)

! ==================== modified by K. Tagami ========= 0.1
!    deallocate(wfbp)
!    if(sw_deficit==ON) deallocate(fsr_k,fsi_k)
! ==================================================== 0.1
  if(npes>1) then
    allocate(mr_mpi(nstate,nstate),mi_mpi(nstate,nstate))
    mr_mpi=0.d0; mi_mpi=0.d0
    call mpi_allreduce(mr,mr_mpi,nstate**2,mpi_double_precision,mpi_sum &
                     &,mpi_comm_group,ierr)
    mr = mr_mpi
    call mpi_allreduce(mi,mi_mpi,nstate**2,mpi_double_precision,mpi_sum &
                     &,mpi_comm_group,ierr)
    mi = mi_mpi
    deallocate(mr_mpi,mi_mpi)
  end if

  call determinant(nstate,mr,mi,det(jpara,nk2,is))

  if(ipriberry > 1 .and. printable) then
     write(nfout,'(1x,"Overlap matrix: k1=",i4," k2=",i4," is=",i4)') jpara,jpara+1,is
     write(nfout,'(1x,"ikprep=",i4)') nk2
     write(nfout,'(1x,"Real part:")')
     do j1=1,nstate
        write(nfout,'(50(1x,f10.5))') mr(j1,1:nstate)
     end do
     write(nfout,'(1x,"Imag part:")')
     do j1=1,nstate
        write(nfout,'(50(1x,f10.5))') mi(j1,1:nstate)
     end do
! =================== modified by K. Tagami ====== 0.1
!!     write(nfout,'(1x,"Determinant: k1=",i4," k2=",i4," is=",i4)') jpara,jpara+1
       write(nfout,'(1x,"Determinant: k1=",i4," k2=",i4," is=",i4)') jpara,jpara+1, is
! ================================================ 0.1
     write(nfout,'("Det = ",e25.14," +i ",e25.14)') det(jpara,nk2,is)
  end if

  end do SPIN2

! ================= Added by K. Tagami ==== 0.1
  deallocate(wfbp)
  if(sw_deficit==ON) deallocate(fsr_k,fsi_k)
! ===========================================

  if(allocated(wfbp0)) deallocate(wfbp0)
  if(allocated(wfbp1)) deallocate(wfbp1)
  if(allocated(wfbp2)) deallocate(wfbp2)
  if(allocated(fsr_k0)) deallocate(fsr_k0,fsi_k0)
  if(allocated(fsr_k1)) deallocate(fsr_k1,fsi_k1)
  if(allocated(fsr_k2)) deallocate(fsr_k2,fsi_k2)

end if

contains

subroutine add_deficit_term(mr,mi,fr1,fi1,fr2,fi2,j1,j2,ispin)
use m_Const_Parameters,    only : SKIP
use m_Ionic_System,        only : natm, ityp
use m_PseudoPotential,     only : index_lmt1_lmt2,lmta &
       &                        , ltp,mtp,taup,ilmt &
       &                        , qitg_BP,iqitg,isph,il2p,dl2p &
       &                        , m_PP_include_vanderbilt_pot &
       &                        , n_non0_lmtxlmt &
       &                        , nlmta
implicit none
real(kind=DP), intent(inout) :: mr,mi
real(kind=DP), intent(in), dimension(np_e,nlmta,nspin) :: fr1,fi1
real(kind=DP), intent(in), dimension(nstate,nlmta,nspin) :: fr2,fi2
integer, intent(in) :: j1,j2,ispin

! local varialbes
integer :: ia,it,ik,ip,lmt1,lmt2,u,v
real(kind=DP) :: eps = 1.d-13
real(kind=DP) :: hsr,hsi
integer :: mdvdb

ATOM: do ia = 1, natm
  it = ityp(ia)
  mdvdb = m_PP_include_vanderbilt_pot(it)
  if(mdvdb == SKIP) cycle ATOM
! debug
!  if(printable) write(nfout,*) 'ia=',ia,' it=',it
! end debug
  LMT_1: do lmt1=1,ilmt(it)
    u = lmta(lmt1,ia)
    !LMT_2: do lmt2=lmt1,ilmt(it)
    LMT_2: do lmt2=1,ilmt(it)
      v = lmta(lmt2,ia)
      hsr = fr1(j1,u,ispin)*fr2(j2,v,ispin) + fi1(j1,u,ispin)*fi2(j2,v,ispin)
      hsi = fr1(j1,u,ispin)*fi2(j2,v,ispin) - fi1(j1,u,ispin)*fr2(j2,v,ispin)
      mr = mr + ftqer(lmt1,lmt2,ia)*hsr-ftqei(lmt1,lmt2,ia)*hsi
      mi = mi + ftqei(lmt1,lmt2,ia)*hsr+ftqer(lmt1,lmt2,ia)*hsi
! debug
!if(printable) then
!  write(nfout,*) '---- ftqe & hs ----'
!  write(nfout,*) 'lmt1 = ',lmt1
!  write(nfout,*) 'lmt2 = ',lmt2
!  write(nfout,*) 'ftqe = ',ftqer(lmt1,lmt2,ia),ftqei(lmt1,lmt2,ia)
!  write(nfout,*) 'hs   = ',hsr,hsi
!end if
! end debug
    end do LMT_2
  end do LMT_1
end do ATOM

end subroutine add_deficit_term

end subroutine m_BP_calc_det



subroutine copy_old_wfbp_to_temp_wfbp(kg,old_wfbp,temp_wfbp)
! === DEBUG by T.Kato 2013/07/11 ===============================================
!use m_Electronic_Structure, only : neg, neordr
use m_Electronic_Structure, only : neordr
use m_Control_Parameters, only : neg
! ==============================================================================
integer, intent(in) :: kg
real(kind=DP), intent(in) :: old_wfbp(kg,np_e,2,nspin)
real(kind=DP), intent(out) :: temp_wfbp(kg,nstate,2,nspin)

! local variables
real(kind=DP), allocatable :: tmp(:,:,:,:)
integer :: datasize,ie,je,j
integer :: is,ik

datasize = kg*mp_e*2*nspin
allocate(tmp(kg,mp_e,2,nspin)); tmp = 0.d0 ! MPI

! debug
!if(printable) then
!  write(nfout,*) 'copy wfbp to tmp'
!  write(nfout,*) 'kg=',kg
!  write(nfout,*) 'mp_e=',mp_e
!  write(nfout,*) 'datasize = ', datasize
!end if
! end debug
call mpi_barrier(mpi_comm_group,ierr)

do j=0,nrank_e-1
  if(j==myrank_e) tmp(1:kg,1:np_e,1:2,1:nspin) = old_wfbp(1:kg,1:np_e,1:2,1:nspin)
  call mpi_bcast(tmp(1,1,1,1),datasize,mpi_double_precision &
              & ,j,mpi_k_world(myrank_k),ierr)
  do is=1,nspin
  ik=is
  do ie = 1, nel_e(j)
    je = nis_e(j)-1+ie
    je = neordr(je,ik)
    if(je > nstate) cycle
    temp_wfbp(1:kg,je,1:2,is) = tmp(1:kg,ie,1:2,is)
  end do
  end do
  call mpi_barrier(mpi_comm_group,ierr)
end do

deallocate(tmp)

call mpi_barrier(mpi_comm_group,ierr)


end subroutine copy_old_wfbp_to_temp_wfbp


subroutine copy_old_fs_to_temp_fs(old_fsr,old_fsi,temp_fsr,temp_fsi)
! === DEBUG by T.Kato 2013/07/11 ===============================================
!use m_Electronic_Structure, only : neg, neordr
use m_Electronic_Structure, only : neordr
use m_Control_Parameters, only : neg
! ==============================================================================
use m_PseudoPotential,     only : nlmta
real(kind=DP), intent(in) :: old_fsr(np_e,nlmta,nspin),old_fsi(np_e,nlmta,nspin)
real(kind=DP), intent(out) :: temp_fsr(nstate,nlmta,nspin),temp_fsi(nstate,nlmta,nspin)

! local variables
real(kind=DP), allocatable :: tmp(:,:,:,:)
integer :: datasize,ie,je,j
integer :: is,ik

datasize = mp_e*nlmta*2*nspin
allocate(tmp(mp_e,nlmta,2,nspin)); tmp = 0.d0 ! MPI

! debug
!if(printable) then
!  write(nfout,*) 'copy fsr,fsi to tmp'
!  write(nfout,*) 'mp_e=',mp_e
!  write(nfout,*) 'nlmta =',nlmta
!  write(nfout,*) 'datasize = ', datasize
!end if
! end debug
call mpi_barrier(mpi_comm_group,ierr)

do j=0,nrank_e-1
  if(j==myrank_e) then
    tmp(1:np_e,1:nlmta,1,1:nspin) = old_fsr(1:np_e,1:nlmta,1:nspin)
    tmp(1:np_e,1:nlmta,2,1:nspin) = old_fsi(1:np_e,1:nlmta,1:nspin)
  end if
  call mpi_bcast(tmp(1,1,1,1),datasize,mpi_double_precision &
              & ,j,mpi_k_world(myrank_k),ierr)
  do is=1,nspin
  ik=is
  do ie = 1, nel_e(j)
    je = nis_e(j)-1+ie
    je = neordr(je,ik)
    if(je > nstate) cycle
    temp_fsr(je,1:nlmta,is) = tmp(ie,1:nlmta,1,is)
    temp_fsi(je,1:nlmta,is) = tmp(ie,1:nlmta,2,is)
  end do
  end do
  call mpi_barrier(mpi_comm_group,ierr)
end do

deallocate(tmp)

end subroutine copy_old_fs_to_temp_fs


subroutine constract_of_ftq()
use m_Const_Parameters,    only : SKIP,zi
use m_Ionic_System,        only : natm, ityp
use m_PseudoPotential,     only : index_lmt1_lmt2,lmta &
       &                        , ltp,mtp,taup,ilmt,nlmt &
       &                        , qitg_BP,iqitg,isph,il2p,dl2p &
       &                        , n_non0_lmtxlmt &
       &                        , m_PP_include_vanderbilt_pot &
       &                        , m_PP_find_maximum_l

! local varialbes
integer :: ia,it,ik,ip,lmt1,lmt2,u,v
real(kind=DP) :: fac
integer :: il1,il2,tau1,tau2,l3
integer :: n,ilm3,iiqitg
real(kind=DP) :: dk(3),ylm,dga
real(kind=DP) :: ftqr,ftqi,ftqb
integer :: mdvdb
integer, allocatable :: il3(:)

call m_PP_find_maximum_l(n)   !  n-1: maximum l
n = (n-1) + (n-1) + 1
allocate(il3(n**2)); call substitute_il3(n**2,il3) ! -(b_Elec..)

allocate(ftqer(nlmt,nlmt,natm)); ftqer=0.d0
allocate(ftqei(nlmt,nlmt,natm)); ftqei=0.d0

dk(1:3)=g(1:3)/jpara*PAI2

if(ipriberry > 0.and.printable) then
  write(nfout,*) '<< Construction of Qlmt(dk): start >>'
  write(nfout,*) 'dk = ', dk(1:3)
end if
! debug
!  do ia=1,natm
!    it = ityp(ia)
!    if(printable) write(nfout,'("ia=",i3," it=",i3)') ia,it
!    do ip=1,n_non0_lmtxlmt(it)
!    lmt1 = index_lmt1_lmt2(ip,it,1)
!      il1 = ltp(lmt1,it)
!      tau1 = taup(lmt1,it)
!      lmt2 = index_lmt1_lmt2(ip,it,2)
!      il2 = ltp(lmt2,it)
!      tau2 = taup(lmt2,it)
!      do n=1,il2p(lmt1,lmt2,it)
!        ilm3 = isph(lmt1,lmt2,n,it); l3=il3(ilm3)
!        iiqitg = iqitg(il1,tau1,il2,tau2,l3+1,it)
!        if(printable) write(nfout,'("lmt1=",i3,"lmt2=",i3,"n=",i3,"q_BP=",f10.5))') lmt1,lmt2,n,qitg_BP(1,iiqitg)
!      end do
!    end do
!  end do
! end debug

ATOM: do ia = 1, natm
  it = ityp(ia)
  mdvdb = m_PP_include_vanderbilt_pot(it)
  if(mdvdb == SKIP) cycle ATOM
! debug
!  if(printable) write(nfout,*) 'ia=',ia,' it=',it
! end debug
  LMT_1: do lmt1=1,ilmt(it)
    il1 = ltp(lmt1,it)
    tau1 = taup(lmt1,it)
    LMT_2: do lmt2=lmt1,ilmt(it)
      il2 = ltp(lmt2,it)
      tau2 = taup(lmt2,it)
! debug
!if(printable) then
!  write(nfout,*) 'lmt1 = ',lmt1
!  write(nfout,*) 'lmt2 = ',lmt2
!end if
! end debug
      ftqr = 0.d0
      ftqi = 0.d0
      LM3: do n=1,il2p(lmt1,lmt2,it)
        ilm3 = isph(lmt1,lmt2,n,it); l3=il3(ilm3)
        iiqitg = iqitg(il1,tau1,il2,tau2,l3+1,it)
        if(iiqitg == 0) cycle LM3
        call sphrp2_for_Berry(ilm3,dk,ylm)
        ftqb = qitg_BP(1,iiqitg)*dl2p(lmt1,lmt2,n,it)*ylm
! debug
!if(printable) then
!  write(nfout,*) '---- n = ',n,' ----'
!  write(nfout,*) 'l3 = ',l3
!  write(nfout,*) 'qitg_BP = ',qitg_BP(1,iiqitg)
!  write(nfout,*) 'dl2p    = ',dl2p(lmt1,lmt2,n,it)
!  write(nfout,*) 'ylm     = ',ylm
!  write(nfout,*) 'ftqb    = ',ftqb
!end if
! end debug
        if(mod(l3,2)==0) then
          ftqr=ftqr+real(zi**(-l3))*ftqb
        else
          ftqi=ftqi+dimag(zi**(-l3))*ftqb
        end if
      end do LM3
      ! remove exponetal factor
      !ftqer(lmt1,lmt2,ia) = ftqr*zfcos(ia)+ftqi*zfsin(ia)
      ftqer(lmt1,lmt2,ia) = ftqr
      ftqer(lmt2,lmt1,ia) = ftqer(lmt1,lmt2,ia)
      !ftqei(lmt1,lmt2,ia) = ftqi*zfcos(ia)-ftqr*zfsin(ia)
      ftqei(lmt1,lmt2,ia) = ftqi
      ftqei(lmt2,lmt1,ia) = ftqei(lmt1,lmt2,ia)
! debug
!if(printable) then
!  write(nfout,*) '---- ftqe ----'
!  write(nfout,*) 'ftq  = ',ftqr,ftqi
!  write(nfout,*) '(zfcos,zfsin) = ',zfcos(ia),zfsin(ia)
!  write(nfout,*) 'ftqe = ',ftqer(lmt1,lmt2,ia),ftqei(lmt1,lmt2,ia)
!end if
! end debug
    end do LMT_2
  end do LMT_1
end do ATOM

deallocate(il3)

if(ipriberry > 0.and.printable) then
  write(nfout,*) '<< Constuction of Qlmt(dk): end >>'
end if

end subroutine constract_of_ftq


subroutine BP_line_integral(phi,cphi,ikprep,ispin)
implicit none
real(kind=DP), intent(out) :: phi
complex(kind=DP), intent(out) :: cphi
integer, intent(in) :: ikprep, ispin

! local variables
integer :: k

cphi = cmplx(1.d0,0.d0)
do k=1,jpara
  if(printable) write(nfout,'(1x,"Det = ",e25.12," + i ",e25.12)') det(k,ikprep,ispin)
  cphi = cphi*det(k,ikprep,ispin)
end do

phi = dimag(log(cphi))

if(printable) then
   write(nfout,'("cphi = ",e25.12,1x,e25.12)') cphi
   write(nfout,'("phi = ",e25.12)') phi
end if


end subroutine BP_line_integral



subroutine m_BP_Polarization()
use m_Files, only : nfout, nfzaj
use m_Electronic_Structure, only : zaj_l, occup_l
use m_Crystal_Structure, only : univol
use m_Control_Parameters, only : nspin
use m_Ionic_System,        only : pos,natm

! =============================== KT_add =================== 13.0C
use m_Ionic_System,        only : ityp
use m_PseudoPotential, only : ival
! ========================================================== 13.0C

implicit none

! local variables
integer :: i,is,ia
real(kind=DP) :: glen, polar, dir(3)
real(kind=DP), allocatable :: phi(:,:) ! dim(nkprep)
complex(kind=DP), allocatable :: cphi(:,:) ! dim(nkprep)
real(kind=DP) :: fac
real(kind=DP) :: berry_phase, berry_ion, berry_tot
real(kind=DP) :: polar_ele, polar_ion, polar_tot, polar_max

if(mype /= 0) return ! MPI

allocate(phi(nkprep,nspin),cphi(nkprep,nspin))
do is=1,nspin
   do i=1,nkprep
      if(printable) &
      & write(nfout,'("is=",i3," ik=",i3," kprep=",2(1x,f10.5))') &
                 & is,i,kvec(1:2,i*jpara)
      call BP_line_integral(phi(i,is),cphi(i,is),i,is)
   end do
end do
glen = sqrt(sum(g(1:3)**2))

! =============================== KT_add  =================== 13.0C
berry_phase = 0.0d0
! =========================================================== 13.0C

do is = 1,nspin
   berry_phase = berry_phase + sum(phi(1:nkprep,is)*wgh(1:nkprep))
end do
fac = 2.d0/dble(nspin)
berry_phase = fac*berry_phase
berry_phase = 4.d0*atan(tan(0.25d0*berry_phase))
polar_ele = berry_phase/(univol*glen*PAI2)
berry_ion = 0.d0

do ia=1,natm
! ============================ KT_mod =================== 13.0C
!   berry_ion = berry_ion + pos(ia,ig)
   berry_ion = berry_ion + ival(ityp(ia)) *pos(ia,ig)
! ======================================================= 13.0C
end do

berry_ion = PAI2*berry_ion
berry_ion = 4.d0*atan(tan(0.25d0*berry_ion))
polar_ion = berry_ion/(univol*glen*PAI2)
berry_tot = 4.d0*atan(tan(0.25d0*(berry_ion+berry_phase)))
polar_tot = berry_tot/(univol*glen*PAI2)
polar_max = 1.d0/(univol*glen)

if(printable) then
   write(nfout,'("<< Results of Berry phase calc.")')

   do i=1,nkprep
      write(nfout,'("ik=",i3," kprep=",2(1x,f10.5))') i,kvec(1:2,i*jpara)
   end do
   write(nfout,'(1x,3x,"is",3x,"k",13x,"phi",18x,"wgh")')
   do is=1,nspin
      do i=1,nkprep
         write(nfout,'(1x,i4,1x,i4,2(1x,f20.10))') is,i,phi(i,is),wgh(i)
      end do
   end do

   dir(1:3) = g(1:3)/glen
   write(nfout,'(1x,"Unit cell volume        =",1x,e25.14)') univol
   write(nfout,'(1x,"direction of G          =",3(1x,e25.14))') dir(1:3)
   write(nfout,'(1x,"Berry phase (ele)       =",1x,e25.14)') berry_phase
   write(nfout,'(1x,"Berry phase (ion)       =",1x,e25.14)') berry_ion
   write(nfout,'(1x,"Berry phase (total)     =",1x,e25.14)') berry_tot
   write(nfout,'(1x,"Electronic polarization =",1x,e25.14)') polar_ele
   write(nfout,'(1x,"Ionic polarization      =",1x,e25.14)') polar_ion
   write(nfout,'(1x,"Total polarization      =",1x,e25.14)') polar_tot
   write(nfout,'(1x,"Maximun polarization    =",1x,e25.14)') polar_max

   write(nfout,'("   Results of Berry phase calc.>>")')
end if

call m_BP_write_Berry_phase(cphi,phi,nkprep)

deallocate(phi)

end subroutine m_BP_Polarization


subroutine m_BP_write_Berry_phase(cphi,phi,nkprep)
use m_Files, only : nfout, nfberry, m_Files_open_nfberry
use m_Ionic_System, only : displaced_atom,displacement,pos,natm
use m_Crystal_Structure, only : strain, sw_strained_cell
implicit none
integer, intent(in) :: nkprep
complex(kind=DP), intent(in) :: cphi(nkprep,nspin)
real(kind=DP), intent(in) :: phi(nkprep,nspin)

! local variables
integer :: i,ia,is

call m_Files_open_nfberry()
write(nfberry,'(3(1x,i5),3(1x,e25.14))') nkprep,ig,displaced_atom,displacement(1:3)
do is=1,nspin
do i=1,nkprep
   write(nfberry,'(i5,4(1x,e25.14))') i,cphi(i,is),phi(i,is),wgh(i)
end do 
end do
if(sw_strained_cell == ON) then
   write(nfberry,'(3(1x,e25.14))') strain(1,1:3)
   write(nfberry,'(3(1x,e25.14))') strain(2,1:3)
   write(nfberry,'(3(1x,e25.14))') strain(3,1:3)
   write(nfberry,*) natm
   do ia=1,natm
      write(nfberry,'(i7,3(1x,e25.14))') ia,pos(ia,1:3)
   end do
end if

end subroutine m_BP_write_Berry_phase


subroutine m_BP_write_wfbp
use m_Files, only : nfout, nfzaj
use m_PlaneWaveBasisSet, only : nbase, iba
use m_Electronic_Structure, only : totch, zaj_l
use m_Control_Parameters, only : nspin
implicit none

! local variables
integer :: jj,n,j,jmax

! debug
!integer :: is
!real(kind=DP) :: norm,defi
! end debug

if(nstate <= 0) nstate = int(totch + 1.d-13)/2

if(sw_deficit == ON) then
!  if(ikp==0) then
  if(ikp0) then
    call calc_phase_for_Berry()
    call constract_of_ftq()
    ikp0 = .false.
  end if
  call m_BP_save_betar_dot_WFs()
end if

if(allocated(wfbp2)) then
  if(allocated(wfbp1)) deallocate(wfbp1)
  kgbp1 = kgbp2
  allocate(wfbp1(kgbp1,np_e,2,nspin))
  wfbp1 = wfbp2
  deallocate(wfbp2)
end if

kgbp2 = nbase(iba(1),1)
allocate(wfbp2(kgbp2,np_e,2,nspin))

if(printable) then
   write(nfout,'("<< Writing Wavefunctions for Berry Phase calc. >>")')
   !write(nfout,*) 'debug iba=',iba(1)
   !write(nfout,*) 'debug kgbp2=',kgbp2
end if
do n=1,np_e
  !if(printable) write(nfout,'(1x,"n=",i3)') n
  jj=1
  do j=1,kgbp2
    if(nbase(jj,1) == j) then
      wfbp2(j,n,1,1:nspin) = zaj_l(jj,n,1:nspin,1)
      wfbp2(j,n,2,1:nspin) = zaj_l(jj,n,1:nspin,2)
      jj = jj + 1
    else
      wfbp2(j,n,1,1:nspin) = 0.d0
      wfbp2(j,n,2,1:nspin) = 0.d0
    end if
    ! debug
    !if(j < 21.and.printable) write(nfout,'("j=",i2,"wfbp=",2(1x,f10.5))') &
    !   & j,wfbp2(j,n,1,is),wfbp2(j,n,2,is)
    ! end debug
  end do
end do

! debug
!if(printable) then
!write(nfout,*) 'berry check norm: kgbp2=',kgbp2
!do is=1,nspin
!do n=1,np_e
!  defi = norm_deficit(n,is)
!  write(nfout,'(1x,"n=",i3," defi = ",f15.10)') n,defi
!  norm = 0.d0
!  do j=1,kgbp2
!    norm = norm + wfbp2(j,n,1)**2 + wfbp2(j,n,2)**2
!  end do
!  write(nfout,'(1x,"n=",i3," norm = ",f10.5)') n,norm
!  write(nfout,'(1x,"n=",i3," total norm = ",f15.10)') n,norm+defi
!end do
!end do
!call mpi_barrier(mpi_comm_group,ierr)
!end if
! end debug

if((jpara>1 .and. mod(ikp,jpara) /= 0) .or. jpara==1)  &
  & call m_BP_calc_det()

ikp = ikp + 1

contains

function norm_deficit(n,is) result(norm)
use m_PseudoPotential,     only : nlmta
use m_Electronic_Structure,only : fsr_l,fsi_l ! dim(np_e,nlmta,ista_k:iend_k)
use m_Ionic_System,        only : natm, ityp
use m_PseudoPotential,     only : n_non0_lmtxlmt,index_lmt1_lmt2,lmta &
       &                          , ltp,mtp,ilmt,q

real(kind=DP) :: norm ! a result

integer, intent(in) :: n ! a band index
integer, intent(in) :: is ! a spin index

! local varialbes
integer :: ia,it,ik,ip,lmt1,lmt2,u,v
real(kind=DP) :: eps = 1.d-13
real(kind=DP) :: fac

norm = 0.d0

ik=is ! for ekcal mode

do ia = 1, natm
  it = ityp(ia)
! debug
!  if(printable) write(nfout,*) 'n_non0_lmtxlmt = ',n_non0_lmtxlmt(it)
! end debug
  LMT: do ip = 1, n_non0_lmtxlmt(it)
    lmt1 = index_lmt1_lmt2(ip,it,1)
    lmt2 = index_lmt1_lmt2(ip,it,2)
! debug
!if(printable) then
!  write(nfout,*) 'lmt1 = ',lmt1
!  write(nfout,*) 'lmt2 = ',lmt2
!end if
! end debug
    if(lmt2 < lmt1) cycle LMT
      u = lmta(lmt1,ia)
      v = lmta(lmt2,ia)
      if(ltp(lmt1,it) /= ltp(lmt2,it) .or. &
        & mtp(lmt1,it) /= mtp(lmt2,it) ) cycle LMT
      fac = q(lmt1,lmt2,it)
      if(abs(fac) < eps) cycle LMT
      if(lmt1 /= lmt2) fac=2.d0*fac
! debug
!if(printable) then
!  write(nfout,*) 'u = ',u
!  write(nfout,*) 'v = ',v
!  write(nfout,*) 'fsr = ',fsr_l(n,u,ik)
!  write(nfout,*) 'fsi = ',fsi_l(n,v,ik)
!  write(nfout,*) 'q = ',q(lmt1,lmt2,it)
!end if
! end debug
      norm = norm + &
           & fac*(fsr_l(n,u,ik)*fsr_l(n,v,ik)+fsi_l(n,u,ik)*fsi_l(n,v,ik))
  end do LMT
end do

end function norm_deficit

end subroutine m_BP_write_wfbp



subroutine m_BP_write_wfbp_gshift
use m_Files, only : nfout, nfzaj
use m_PlaneWaveBasisSet, only : kgp, ngabc, nbase, iba
use m_Electronic_Structure, only : totch, zaj_l
use m_Control_Parameters, only : nspin
implicit none

! local variables
integer :: jj,n,i,j,k,jmax
integer :: igs(3)
integer :: iga,igb,igc,jga,jgb,jgc

! debug
!real(kind=DP) :: norm
! end debug

if(mod(ikp,jpara)/=0) return

if(nstate <= 0) nstate = int(totch + 1.d-13)/2

igs(1:3) = 0
do i=1,3
  if(i == ig) igs(i) = 1
end do 

kgbp0 = 1
jj=1
if(printable) then
   write(nfout,'("<< Writing Wavefunctions for Berry Phase calc. >>")')
   !write(nfout,*) 'debug kgp=',kgp
   !write(nfout,*) 'debug iba=',iba(1)
end if
loop_i: do i=1,kgp
  iga = ngabc(i,1)+igs(1)
  igb = ngabc(i,2)+igs(2)
  igc = ngabc(i,3)+igs(3)
  if(jj>iba(1)) then
    kgbp0 =i-1
    exit loop_i
  end if
  loop_j: do j=1,iba(1)
    k=nbase(j,1)
    jga = ngabc(k,1)
    jgb = ngabc(k,2)
    jgc = ngabc(k,3)
    if(iga == jga .and. igb == jgb .and. igc == jgc) then
      jj=jj+1
      exit loop_j
    end if
  end do loop_j
end do loop_i

!if(printable) then
!write(nfout,*) 'debug jj=',jj
!write(nfout,*) 'debug kgbp0=',kgbp0
!end if

allocate(wfbp0(kgbp0,np_e,2,nspin)); wfbp0 = 0.d0
do n=1,np_e
  loop_i2: do i=1,kgbp0
    iga = ngabc(i,1)+igs(1)
    igb = ngabc(i,2)+igs(2)
    igc = ngabc(i,3)+igs(3)
    loop_j2: do j=1,iba(1)
      k=nbase(j,1)
      jga = ngabc(k,1)
      jgb = ngabc(k,2)
      jgc = ngabc(k,3)
      if(iga == jga .and. igb == jgb .and. igc == jgc) then
        wfbp0(i,n,1,1:nspin) = zaj_l(j,n,1:nspin,1)
        wfbp0(i,n,2,1:nspin) = zaj_l(j,n,1:nspin,2)
        exit loop_j2
      end if
    end do loop_j2
  end do loop_i2
  ! debug
  !if(printable) then
  !do j=1,20
  !  write(nfout,'("j=",i2,"wfbp0=",2(1x,f10.5))') &
  !     & j,wfbp0(j,n,1),wfbp0(j,n,2)
  !end do
  !end if
  ! end debug
end do
call mpi_barrier(mpi_comm_group,ierr)

! debug
!if(printable) then
!write(nfout,*) 'berry check norm (gshift): kgbp0=',kgbp0
!do n=1,np_e
!  norm = 0.d0
!  do j=1,kgbp0
!    norm = norm + wfbp0(j,n,1)**2 + wfbp0(j,n,2)**2
!  end do
!  write(nfout,'(1x,"n=",i3," norm = ",f10.5)') n,norm
!end do
!call mpi_barrier(mpi_comm_group,ierr)
!end if
! end debug

end subroutine m_BP_write_wfbp_gshift



subroutine m_BP_save_betar_dot_WFs
use m_Electronic_Structure,only : fsr_l, fsi_l ! dim(np_e,nlmta,ista_k:iend_k)
use m_PseudoPotential,     only : nlmta, lmta, ilmt
use m_Ionic_System,        only : natm, ityp
implicit none

! local variables
integer :: ik,ia,i,j,n,nkp,ikprep,is

ik=1 ! for ekcal mode
nkp = mod(ikp,jpara)+1
ikprep = ikp/jpara + 1

! debug
!if(printable) then
!  write(nfout,*) 'debug(m_BP_save_betar_dot_WFs)'
!  write(nfout,*) 'nstate=',nstate
!  write(nfout,*) 'nlmta=',nlmta
!  write(nfout,*) 'jpara=',jpara
!  write(nfout,*) 'nkp=',nkp
!  write(nfout,*) 'ikprep=',ikprep
!end if
! end debug

if(allocated(fsr_k2)) then
   if(allocated(fsr_k1)) deallocate(fsr_k1,fsi_k1)
   allocate(fsr_k1(np_e,nlmta,nspin),fsi_k1(np_e,nlmta,nspin))
   fsr_k1 = fsr_k2
   fsi_k1 = fsi_k2
   deallocate(fsr_k2,fsi_k2)
end if

allocate(fsr_k2(np_e,nlmta,nspin),fsi_k2(np_e,nlmta,nspin))
do is=1,nspin
do i=1,nlmta
  do n=1,np_e
    fsr_k2(n,i,is) = fsr_l(n,i,is)
    fsi_k2(n,i,is) = fsi_l(n,i,is)
  end do
end do
end do
if(nkp == 1) then
  allocate(fsr_k0(np_e,nlmta,nspin),fsi_k0(np_e,nlmta,nspin))
  do is=1,nspin
  do ia=1,natm
    do j=1,ilmt(ityp(ia))
       i=lmta(j,ia)
       do n=1,np_e
          fsr_k0(n,i,is) = fsr_l(n,i,is)*zfcos(ia)+fsi_l(n,i,is)*zfsin(ia)
          fsi_k0(n,i,is) = fsi_l(n,i,is)*zfcos(ia)-fsr_l(n,i,is)*zfsin(ia)
       end do
    end do
  end do
  end do
end if

end subroutine m_BP_save_betar_dot_WFs



subroutine determinant(n,mr,mi,det)
implicit none
integer, intent(in) :: n
real(kind=DP), intent(inout) :: mr(n,n),mi(n,n)
complex(kind=DP), intent(out) :: det

! local variables
integer :: i,pivot(n),parity
real(kind=DP) :: dr,di,dt

! debug
!if(printable) then
!write(nfout,'("before LU decomposition")')
!write(nfout,'("real part:")')
!do i=1,n
!   write(nfout,'(50(1x,e25.12))') mr(i,1:n)
!end do
!write(nfout,'("imag part:")')
!do i=1,n
!   write(nfout,'(50(1x,e25.12))') mi(i,1:n)
!end do
!end if
! end debug

call LU_decomposition(n,mr,mi,pivot,parity)

! debug
!if(printable) then
!write(nfout,'("after LU decomposition")')
!write(nfout,'("real part:")')
!do i=1,n
!   write(nfout,'(50(1x,e25.12))') mr(i,1:n)
!end do
!write(nfout,'("imag part:")')
!do i=1,n
!   write(nfout,'(50(1x,e25.12))') mi(i,1:n)
!end do
!end if
! end debug

dr=1.d0
di=0.d0
do i=1,n
  ! debug
  !if(printable) write(nfout,'(1x,i3," mr=",e25.12," mi=",e25.12)') i,mr(i,i),mi(i,i)
  ! end debug
  dt = dr*mr(i,i) - di*mi(i,i)
  di = di*mr(i,i) + dr*mi(i,i)
  dr = dt
end do
det = cmplx(dr,di)
det = parity*det

end subroutine determinant



subroutine LU_decomposition(n,mr,mi,pivot,parity)
implicit none
integer, intent(in) :: n
real(kind=DP), intent(inout) :: mr(n,n),mi(n,n)
integer, intent(out) :: pivot(n),parity

! local variables
integer :: i,j,k,imax
real(kind=DP) :: big,scaling(n)
real(kind=DP) :: t,dr,di
real(kind=DP) :: sumr,sumi,mt

real(kind=DP), parameter :: eps = 3.5d-15

parity = 1

do i=1,n
  big = 0.d0
  do j=1,n
    t = sqrt( mr(i,j)**2 + mi(i,j)**2 )
    if(t > big)  big = t
  end do
  if(big == 0.d0) then
    if(printable) then
       write(nfout,*) 'Error(LU_decomposition): Singular matrix'
       write(nfout,*) 'i=',i
    end if
    stop 'LU_decomposition'
  else
    scaling(i) = 1.d0/big
  end if
end do

do j=1,n
  do i=1,j-1
    sumr=0.d0
    sumi=0.d0
    do k=1,i-1
      sumr = sumr + ( mr(i,k)*mr(k,j) - mi(i,k)*mi(k,j) )
      sumi = sumi + ( mi(i,k)*mr(k,j) + mr(i,k)*mi(k,j) )
    end do
    mr(i,j) = mr(i,j) - sumr
    mi(i,j) = mi(i,j) - sumi
  end do
  big = 0.d0
  do i=j,n
    sumr=0.d0
    sumi=0.d0
    do k=1,j-1
      sumr = sumr + ( mr(i,k)*mr(k,j) - mi(i,k)*mi(k,j) )
      sumi = sumi + ( mi(i,k)*mr(k,j) + mr(i,k)*mi(k,j) )
    end do
    sumr = mr(i,j) - sumr
    sumi = mi(i,j) - sumi
    t = scaling(i)*sqrt(sumr**2+sumi**2)
    if( t >= big) then
      big = t
      imax = i
    end if
    mr(i,j) = sumr
    mi(i,j) = sumi
  end do
  if(j /= imax) then
    do k=1,n
      dr = mr(imax,k)
      di = mi(imax,k)
      mr(imax,k) = mr(j,k)
      mi(imax,k) = mi(j,k)
      mr(j,k) = dr
      mi(j,k) = di
    end do
    parity = -parity
    scaling(imax) = scaling(j)
  end if
  pivot(j) = imax
  if( dsqrt(mr(j,j)**2+mi(j,j)**2) < eps ) then
    mr(j,j) = 0.d0
    mi(j,j) = 0.d0
  end if
  if(j /= n ) then
    t  =  mr(j,j)**2 + mi(j,j)**2
    dr =  mr(j,j)/t
    di = -mi(j,j)/t
    do i=j+1,n
      mt      = mr(i,j)*dr - mi(i,j)*di
      mi(i,j) = mi(i,j)*dr + mr(i,j)*di
      mr(i,j) = mt
    end do
  end if
end do

end subroutine LU_decomposition

subroutine m_BP_wd_cntn_data()
  use m_Files, only : nfcntn_berry,m_Files_open_nfcntn_berry,m_Files_close_nfcntn_berry,nfout
  use m_ErrorMessages, only : EOF_REACHED
  logical :: logica

  if(.not.allocated(det)) return 
  call m_Files_open_nfcntn_berry()
  rewind nfcntn_berry
  if(mype==0)then
     write(nfcntn_berry) ikp
     write(nfcntn_berry) kgbp0
     write(nfcntn_berry) kgbp1
     write(nfcntn_berry) kgbp2
     write(nfcntn_berry) det
  endif

! fsr, fsi related
  logica = allocated(fsr_k2)
  if(mype==0) write(nfcntn_berry) logica
  if(logica) call write_fs(fsr_k2,nfcntn_berry)

  logica = allocated(fsi_k2)
  if(mype==0) write(nfcntn_berry) logica
  if(logica) call write_fs(fsi_k2,nfcntn_berry)

  logica = allocated(fsr_k1)
  if(mype==0) write(nfcntn_berry) logica
  if(logica) call write_fs(fsr_k1,nfcntn_berry)

  logica = allocated(fsi_k1)
  if(mype==0) write(nfcntn_berry) logica
  if(logica) call write_fs(fsi_k1,nfcntn_berry)

  logica = allocated(fsr_k0)
  if(mype==0) write(nfcntn_berry) logica
  if(logica) call write_fs(fsr_k0,nfcntn_berry)

  logica = allocated(fsi_k0)
  if(mype==0) write(nfcntn_berry) logica
  if(logica) call write_fs(fsi_k0,nfcntn_berry)

! wf related
  logica = allocated(wfbp2)
  if(mype==0) write(nfcntn_berry) logica
  if(logica) call write_wf(kgbp2,wfbp2,nfcntn_berry)

  logica = allocated(wfbp1)
  if(mype==0) write(nfcntn_berry) logica
  if(logica) call write_wf(kgbp1,wfbp1,nfcntn_berry)

  logica = allocated(wfbp0)
  if(mype==0) write(nfcntn_berry) logica
  if(logica) call write_wf(kgbp0,wfbp0,nfcntn_berry)

  call m_Files_close_nfcntn_berry()

end subroutine m_BP_wd_cntn_data

subroutine m_BP_rd_cntn_data()
  use m_Files,           only : nfcntn_berry,m_Files_open_nfcntn_berry,m_Files_close_nfcntn_berry,nfout
  use m_PseudoPotential, only : nlmta
  use m_ErrorMessages,   only : EOF_REACHED
  logical :: logica
  if(.not.allocated(det)) return
  call m_Files_open_nfcntn_berry()
  rewind nfcntn_berry
  if(mype==0)then
     read(nfcntn_berry,end=9999,err=9999) ikp
     read(nfcntn_berry,end=9999,err=9999) kgbp0
     read(nfcntn_berry,end=9999,err=9999) kgbp1
     read(nfcntn_berry,end=9999,err=9999) kgbp2
     read(nfcntn_berry,end=9999,err=9999) det
  endif
  call mpi_bcast(ikp,1,mpi_double_precision,0,mpi_comm_group,ierr)
  call mpi_bcast(kgbp0,1,mpi_double_precision,0,mpi_comm_group,ierr)
  call mpi_bcast(kgbp1,1,mpi_double_precision,0,mpi_comm_group,ierr)
  call mpi_bcast(kgbp2,1,mpi_double_precision,0,mpi_comm_group,ierr)
  call mpi_bcast(det,jpara*nkprep*nspin,mpi_double_precision,0,mpi_comm_group,ierr)

  if(mype==0) read(nfcntn_berry,end=9999,err=9999) logica
  call mpi_bcast(logica,1,mpi_logical,0,mpi_comm_group,ierr)
  if (logica) then
     if(.not.allocated(fsr_k2)) allocate(fsr_k2(np_e,nlmta,nspin))
     call read_fs(fsr_k2,nfcntn_berry,1)
  endif

  if(mype==0) read(nfcntn_berry,end=9999,err=9999) logica
  call mpi_bcast(logica,1,mpi_logical,0,mpi_comm_group,ierr)
  if (logica) then
     if(.not.allocated(fsi_k2)) allocate(fsi_k2(np_e,nlmta,nspin))
     call read_fs(fsi_k2,nfcntn_berry,2)
  endif

  if(mype==0) read(nfcntn_berry,end=9999,err=9999) logica
  call mpi_bcast(logica,1,mpi_logical,0,mpi_comm_group,ierr)
  if (logica) then
     if(.not.allocated(fsr_k1)) allocate(fsr_k1(np_e,nlmta,nspin))
     call read_fs(fsr_k1,nfcntn_berry,3)
  endif

  if(mype==0) read(nfcntn_berry,end=9999,err=9999) logica
  call mpi_bcast(logica,1,mpi_logical,0,mpi_comm_group,ierr)
  if (logica) then
     if(.not.allocated(fsi_k1)) allocate(fsi_k1(np_e,nlmta,nspin))
     call read_fs(fsi_k1,nfcntn_berry,4)
  endif

  if(mype==0) read(nfcntn_berry,end=9999,err=9999) logica
  call mpi_bcast(logica,1,mpi_logical,0,mpi_comm_group,ierr)
  if (logica) then
     if(.not.allocated(fsr_k0)) allocate(fsr_k0(np_e,nlmta,nspin))
     call read_fs(fsr_k0,nfcntn_berry,5) 
  endif

  if(mype==0) read(nfcntn_berry,end=9999,err=9999) logica
  call mpi_bcast(logica,1,mpi_logical,0,mpi_comm_group,ierr)
  if (logica) then
     if(.not.allocated(fsi_k0)) allocate(fsi_k0(np_e,nlmta,nspin))
     call read_fs(fsi_k0,nfcntn_berry,6)
  endif

  if(mype==0) read(nfcntn_berry,end=9999,err=9999) logica
  call mpi_bcast(logica,1,mpi_logical,0,mpi_comm_group,ierr)
  if (logica) then
     if(allocated(wfbp2)) deallocate(wfbp2)
     allocate(wfbp2(kgbp2,np_e,2,nspin))
     call read_wf(kgbp2,wfbp2,nfcntn_berry,7)
  endif

  if(mype==0) read(nfcntn_berry,end=9999,err=9999) logica
  call mpi_bcast(logica,1,mpi_logical,0,mpi_comm_group,ierr)
  if(logica) then
     if(allocated(wfbp1)) deallocate(wfbp1)
     allocate(wfbp1(kgbp1,np_e,2,nspin))
     call read_wf(kgbp1,wfbp1,nfcntn_berry,8)
  endif

  if(mype==0) read(nfcntn_berry,end=9999,err=9999) logica
  call mpi_bcast(logica,1,mpi_logical,0,mpi_comm_group,ierr)
  if(logica) then
     if(allocated(wfbp0)) deallocate(wfbp0)
     allocate(wfbp0(kgbp0,np_e,2,nspin))
     call read_wf(kgbp0,wfbp0,nfcntn_berry,9)
  endif

  call m_Files_close_nfcntn_berry()
  return

9999 continue
    call phase_error_wo_filename(EOF_REACHED, nfout, nfcntn_berry, __LINE__, __FILE__)
end subroutine m_BP_rd_cntn_data

subroutine write_fs(fs,nf)
!!$  use m_Electronic_Structure, only : neg
  use m_Control_Parameters, only : neg
  use m_PseudoPotential, only : nlmta
  real(kind=DP),intent(in),dimension(np_e,nlmta,nspin) :: fs
  integer, intent(in) :: nf
  real(kind=DP),allocatable,dimension(:,:) :: f
  integer :: is,ib
  integer :: ierr
  allocate(f(nlmta,nspin));f=0.0d0
  do is=1,nspin
    do ib=1,neg 
       if(map_ek(ib,is) == mype) then
          f(:,:) = fs(map_z(ib),:,:)
         if(map_ek(ib,is)/=0) call mpi_send(f,nlmta*nspin,mpi_double_precision,0,1,mpi_comm_group,ierr)
       else if (mype==0 .and. map_ek(ib,is) /= 0)then
          call mpi_recv(f,nlmta*nspin,mpi_double_precision,map_ek(ib,is),1,mpi_comm_group,istatus,ierr)
       endif
       if(mype==0) write(nf) f
    enddo
  enddo
  deallocate(f)
end subroutine write_fs

subroutine read_fs(fs,nf,tag)
!!$  use m_Electronic_Structure, only : neg
  use m_Control_Parameters, only : neg
  use m_PseudoPotential, only : nlmta
  use m_ErrorMessages, only : EOF_REACHED
  use m_Files, only : nfout
  real(kind=DP),intent(out),dimension(np_e,nlmta,nspin) :: fs
  integer, intent(in) :: nf
  integer, intent(in) :: tag
  real(kind=DP),allocatable,dimension(:,:) :: f
  integer :: is,ib
  integer :: ierr
  allocate(f(nlmta,nspin));f=0.0d0
  fs = 0.d0
  do is=1,nspin
    do ib=1,neg 
       if(mype==0) read(nf,end=9999,err=9999) f
       if(mype==0 .and. map_ek(ib,is)/=0)then
          call mpi_send(f,nlmta*nspin,mpi_double_precision,map_ek(ib,is),tag,mpi_comm_group,ierr)
       else if (map_ek(ib,is)==mype .and. map_ek(ib,is) /= 0)then
          call mpi_recv(f,nlmta*nspin,mpi_double_precision,0,tag,mpi_comm_group,istatus,ierr)
       endif
       if(map_ek(ib,is) == mype) fs(map_z(ib),:,:) = f(:,:)
    enddo
  enddo
  deallocate(f)
  return
9999 continue
  call phase_error_wo_filename(EOF_REACHED, nfout, nf, __LINE__, __FILE__)
end subroutine read_fs

subroutine write_wf(n1,wf,nf)
  use m_Control_Parameters, only : neg
  integer, intent(in) :: n1
  real(kind=DP), dimension(n1,np_e,2,nspin),intent(in) :: wf
  integer, intent(in) :: nf
  real(kind=DP), allocatable,dimension(:,:) :: wft
  integer :: is,ib
  integer :: ierr
  allocate(wft(n1,2));wft=0.d0
  do is=1,nspin
     do ib=1,neg
        if(map_ek(ib,is) == mype)then
           wft(:,1) = wf(:,map_z(ib),1,is)
           wft(:,2) = wf(:,map_z(ib),2,is)
           if(map_ek(ib,is)/=0) call mpi_send(wft,n1*2,mpi_double_precision,0,1,mpi_comm_group,ierr)
        else if (mype==0 .and. map_ek(ib,is) /= 0) then
           call mpi_recv(wft,n1*2,mpi_double_precision,map_ek(ib,is),1,mpi_comm_group,istatus,ierr)
        endif
        if(mype==0) write(nf) wft
     enddo
  enddo
  deallocate(wft)
end subroutine write_wf

subroutine read_wf(n1,wf,nf,tag)
  use m_Control_Parameters, only : neg
  use m_ErrorMessages, only : EOF_REACHED
  use m_Files, only : nfout
  integer, intent(in) :: n1
  real(kind=DP), dimension(n1,np_e,2,nspin),intent(out) :: wf
  integer, intent(in) :: nf
  integer, intent(in) :: tag
  real(kind=DP), allocatable,dimension(:,:) :: wft
  integer :: is,ib
  integer :: ierr
  wf = 0.d0
  allocate(wft(n1,2));wft=0.d0
  do is=1,nspin
     do ib=1,neg
        if(mype==0) read(nf,end=9999,err=9999) wft
        if(mype==0 .and. map_ek(ib,is)/=0)then
           call mpi_send(wft,n1*2,mpi_double_precision,map_ek(ib,is),tag,mpi_comm_group,ierr)
        else if (map_ek(ib,is) == mype .and. map_ek(ib,is) /= 0) then
           call mpi_recv(wft,n1*2,mpi_double_precision,0,tag,mpi_comm_group,istatus,ierr)
        endif
        if(map_ek(ib,is) == mype) then
           wf(:,map_z(ib),1,is) = wft(:,1)
           wf(:,map_z(ib),2,is) = wft(:,2)
        endif
     enddo
  enddo
  deallocate(wft)
  return
9999 continue
  call phase_error_wo_filename(EOF_REACHED, nfout, nf, __LINE__, __FILE__)
end subroutine read_wf

end module m_BerryPhase

