!=======================================================================
!
!  PROGRAM  PHASE/0 2014.02 ($Rev: 376 $)
!
!  MODULE: m_ES_ExactExchange
!
!  AUTHOR(S): T. Yamamoto   November/22/2009
!
!  Contact address :  Phase System Consortium
!                     E-mail: phase_system@nims.go.jp URL https://azuma.nims.go.jp
!
!
!
!=======================================================================
!
!     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_ES_ExactExchange
  use m_Electronic_Structure,only: totch,zaj_l,occup_l,neordr,eko_l,vnlph_l,fsr_l,fsi_l
  use m_NonLocal_Potential, only : snl,qr_optimized
  use m_PlaneWaveBasisSet,  only : ngabc,igf,kg1,kg,kgp,nbase,nbmx,iba,m_pwBS_kinetic_energies &
       &                         , nbase_gamma,igfp_l,ngpt_l,m_pwBS_sphrp_exx
  use m_Kpoints,            only : kv3,vkxyz,kv3_ek,vkxyz_ek,k_symmetry,qwgt,qwgt_ek,mp_index &
       &                         , m_Kp_sample_mesh, kshift
  use m_FFT,                only : nfft,fft_box_size_WF &
       &                         , m_FFT_alloc_WF_work &
       &                         , m_FFT_dealloc_WF_work &
       &                         , m_FFT_WF, fft_box_size_CD, nfftp_nonpara, m_FFT_CD0
  use m_Ionic_System,       only : zeta1, qex, iatom, ntyp, natm, ityp, pos, iwei, napt
  use m_PseudoPotential,    only : qitg_l, iqitg, nqitg, m_PP_include_vanderbilt_pot &
       &                         , ilmt,iqitg,nloc,ntau,ival,isph,il2p,dl2p,modnrm &
       &                         , nlmta,lmta,lmtt,ltp,mtp,taup,nloc,m_PP_find_maximum_l &
       &                         , m_PP_tell_lmtt_l_m_tau &
       &                         , m_PP_set_index_arrays1,m_PP_set_index_arrays2 &
       &                         , radr,xh,rmax,nmesh,mmesh, qrspspw
 
  use m_Files,              only : nfout
  use m_Timing,             only : tstatc0_begin,tstatc0_end
  use m_Control_Parameters, only : nspin,ipri,kimg,neg,printable,af,ekmode &
       &                         , alpha_exx,omega_exx,sw_screened_exchange  &
       &                         , sw_singular_correction,reduction_factor_exx &
       &                         , way_ksample,m_CtrlP_cachesize,sw_rspace_hyb &
       &                         , sw_precalculate,sw_rsb
  use m_Crystal_Structure,  only : univol,altv,rltv,nopr,tau,op
  ! nopr : # of operations
  ! tau  : nonprimitive translation vector
  ! op   : rotation matrix in real space 
  use m_Const_Parameters,   only : DP, CMPLDP, SKIP, EXECUT, ON, OFF, DIRECT, INVERSE, DELTA, DELTA10 &
       &                         , DELTA07, PAI2, PAI4, PAI, ELECTRON, GAMMA, BUCS &
       &                         , MONKHORST_PACK, MESH
  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,idisp_e &
       &                         , map_z,np_e,mpi_k_world,myrank_k,map_k,ista_k,iend_k &
       &                         , ista_kg1_k, np_kg1_k, mp_kg1_k &
#ifdef TRANSPOSE
       &                         , ierr,mp_e,nis_e,nie_e,nel_e
#else
       &                         , ierr
#endif

! ============================ KT_Test ================================ 12.5Exp
  use m_Control_Parameters,    only : nmax_G_hyb
  use m_PlaneWaveBasisSet,     only : kgp, kg1, kg
! ===================================================================== 12.5Exp

  use m_Realspace, only : nmesh_rs_aug_max,nmesh_rs_aug,meshx_rs_aug,meshy_rs_aug,meshz_rs_aug,meshxyz_rs_aug &
  & , qr_clm_ylm,dqr_clm_ylm
  use m_ES_RSB, only : overlap,m_ES_RSB_unitary_transform_wf,m_ES_RSB_unitary_transform_vec,m_ES_RSB_alloc,m_ES_RSB_doit

  implicit none

  integer :: sw_update_wfv = ON
  integer :: nval
  integer :: nval_old
  integer :: nfftwf
  integer :: ntrs ! ntrs = 1, if TRS is used. Otherwise, ntrs=0
  integer, allocatable :: ngpt_exx(:,:,:) ! d(kgp,nopr,0:ntrs)
  real(kind=DP), allocatable :: qitg_exx(:,:,:) ! d(kgp,nqitg,nqmk)
  real(kind=DP), allocatable :: ylm_exx(:,:,:) ! d(kgp,maxylm,nqmk)
  real(kind=DP), allocatable :: vc(:,:) ! d(kgp,nqmk)
  real(kind=DP), allocatable :: wfv(:,:,:,:) ! d(kg1,nval,kv3,kimg)
  real(kind=DP), allocatable :: wfv_old(:,:,:,:) ! d(kg1,nval_old,kv3,kimg)
  real(kind=DP), allocatable :: fsr_exx(:,:,:) ! d(nval,nlmta,kv3)
  real(kind=DP), allocatable :: fsi_exx(:,:,:) ! d(nval,nlmta,kv3)
  real(kind=DP), allocatable :: fsr_exx_old(:,:,:) ! d(nval,nlmta,kv3)
  real(kind=DP), allocatable :: fsi_exx_old(:,:,:) ! d(nval,nlmta,kv3)
  real(kind=DP), allocatable :: occup_val(:,:) ! d(nval,kv3)
  real(kind=DP), allocatable :: occup_val_old(:,:) ! d(nval_old,kv3)
  real(kind=DP), allocatable :: dfsr_exx(:,:,:,:) ! d(nval,nlmta,kv3,3)
  real(kind=DP), allocatable :: dfsi_exx(:,:,:,:) ! d(nval,nlmta,kv3,3)
  real(kind=DP), allocatable :: dfsr_l(:,:,:,:) ! d(np_e,nlmta,ista_k:iend_k,3)
  real(kind=DP), allocatable :: dfsi_l(:,:,:,:) ! d(np_e,nlmta,ista_k:iend_k,3)

  integer :: ikgamma
  logical, allocatable :: qmk_zero(:,:) ! d(kv3bz,kv3)
  logical, allocatable :: qmk_zero2(:) ! d(kv3bz*kv3)
  real(kind=DP), allocatable :: qmk(:,:) !d(kv3bz*kv3,3)
  integer, allocatable :: iqmk(:,:) !d(kv3bz,kv3))
  integer :: nqmk
  integer :: kv3bz

  real(kind=DP), allocatable :: eexx_kb(:,:)
  !
  ! q(BZ) = S*k(IBZ)
  ! 
  ! Symmetry operations in space group:
  !    Os={S|u}
  !    Or={R|t}
  !
  ! Wavefunction coefficient:
  !    c(q,SG) = c(k,G) exp(i(k+G)*t)
  !            = c(k,G) exp(-i(q+SG)*u)
  !
  !    If time reversal symmetry is present,
  !         c(-q,-G) = c*(q,G)
  !
  integer, allocatable :: ikp(:) ! d(kv3bz)
  integer, allocatable :: iops(:) ! d(kv3bz) No. of S_inv = R :  Or={R|t}
  integer, allocatable :: iopt(:) ! d(kv3bz) No. of S         :  Os={S|u}
  integer, allocatable :: itrs(:) ! d(kv3bz) Time reversal symmetry, 0 or 1
  real(kind=DP), allocatable :: vkbz(:,:) ! d(kv3bz,3) k-points in Full BZ
  real(kind=DP), allocatable :: wbz(:) ! d(kv3bz) weight for k-points in Full BZ

  real(kind=DP), allocatable :: oprec(:,:,:) ! d(3,3,nopr) Reciprocal space rotation matrix
  real(kind=DP), allocatable :: opdir(:,:,:) ! d(3,3,nopr) Direct space rotation matrix

  integer :: nface
  integer, allocatable :: iface_bz(:,:) ! d(3,nface)
  integer :: n_bz_mesh(3)

  real(kind=DP), allocatable :: crotylm(:,:,:) ! d(mmax,nsph,nopr)
  integer, allocatable :: iylm(:,:,:) ! d(mmax,nsph,nopr)
  integer, allocatable :: nylm(:,:) ! d(nsph,nopr)
  integer, allocatable :: isph_lmta(:) ! d(nlmta))
  integer, allocatable :: lmta_rot(:,:,:) ! d(mmax,nlmta,nopr))
  integer, allocatable :: ia_lmta(:) !(nlmta)

  logical, save :: preproc_done=.false.
  integer :: n,ibsize,iwidth,maxm
  integer, parameter :: mcritical = 4*2+1
  integer, allocatable :: il3(:)
  integer, allocatable, dimension(:) :: nqitg_sp,nqitg_sp0    
  integer, allocatable, dimension(:) :: iq2l3 ! d(nqitg)
  integer, allocatable, dimension(:,:) :: nc  ! d(maxm,nqitg)
  integer :: mc ! maxval(nc)
  integer, allocatable, dimension(:,:,:) :: nc2lmt1, nc2lmt2, nc2n ! d(mc,maxm,nqitg)

  logical :: wf_is_real=.false.

!  real(kind=DP), allocatable, dimension(:,:,:,:) :: qr_clm_ylm
!  real(kind=DP), allocatable, dimension(:,:,:,:,:) :: dqr_clm_ylm
  integer, allocatable, dimension(:) :: igfp_l_red
  real(kind=DP), allocatable, dimension(:,:) :: eko_hyb
  real(kind=DP), allocatable, dimension(:,:,:,:,:) :: fsrqm,fsiqm
  include 'mpif.h'                                      ! MPI
  !integer istatus(mpi_status_size)                      ! MPI

contains

! ====================== KT_Test ==================================== 12.5
  subroutine m_ES_EXX_set_nmax_G_hyb
    if ( nmax_G_hyb == 0 ) then
       nmax_G_hyb = kgp
    else if ( nmax_G_hyb == -1 ) then
       nmax_G_hyb = kg
    else if ( nmax_G_hyb == -2 ) then
       nmax_G_hyb = kg /2
    else if ( nmax_G_hyb == -3 ) then
       nmax_G_hyb = kg1
    endif
!
    write(nfout,*) 'nmax_G_hyb is set to ', nmax_G_hyb

  end subroutine m_ES_EXX_set_nmax_G_hyb
! ================================================================== 12.5

  subroutine m_ES_EXX_update(on_or_off)
    implicit none
    integer, intent(in) :: on_or_off

    sw_update_wfv = on_or_off
    if(printable) then
       if(sw_update_wfv==ON) then
          write(nfout,'(" EXX: wfv will be updated.")')
       else
          write(nfout,'(" EXX: wfv will be conserved.")')
       end if
    end if
  end subroutine m_ES_EXX_update

  subroutine m_ES_EXX_kbz
    implicit none
    integer :: ik, jk, iopr, i, j, ikbz, jkbz, jtrs
    integer :: i1, i2, i3
    real(kind=DP) :: rkxyz(3), kxyz(3), df(3), ko(3)
    logical :: ltrue
    integer :: g0(3)
    real(kind=DP) :: x(3), y(3)
    real(kind=DP) :: wtot
    real(kind=DP) :: ss(3,3)
    real(kind=DP) :: dk(3)

    allocate(oprec(3,3,nopr))
    do iopr=1,nopr
       do j=1,3
          x = matmul(op(:,:,iopr),rltv(:,j))
          do i=1,3
             y = altv(:,i)
             oprec(i,j,iopr) = dot_product(y,x)/PAI2
          end do
       end do
    end do

    write(nfout,'("k-points in IBZ")')
    write(nfout,'("ik, k1, k2, k3")')
    do ik=1,kv3,nspin
       write(nfout,'(i5,3(1x,f10.5))') (ik-1)/nspin+1, vkxyz(ik,1:3,BUCS)
    end do

    call m_ES_EXX_fbz_faces ! -> iface_bz

    !!if(sw_memory_reduction_exx==OFF) then
       if(kv3/nspin==1) then
          kv3bz = 1
          n_bz_mesh(1:3) = 1
       else
          if(way_ksample == MONKHORST_PACK) then
             n_bz_mesh(1:3) = mp_index(1:3)
          else
             call m_Kp_sample_mesh(n_bz_mesh)
          end if
          kv3bz = n_bz_mesh(1)*n_bz_mesh(2)*n_bz_mesh(3)
       end if
    !!else
    !!   if(kv3/nspin==1) then
    !!      kv3bz = 1
    !!      n_bz_mesh(1:3) = 1
    !!   else
    !!      if(way_ksample == MONKHORST_PACK) then
    !!         n_bz_mesh(1:3) = mp_index(1:3)/reduction_factor_exx(1:3)
    !!      else
    !!         call m_Kp_sample_mesh(n_bz_mesh)
    !!         n_bz_mesh(1:3) = n_bz_mesh(1:3)/reduction_factor_exx(1:3)
    !!      end if
    !!      kv3bz = n_bz_mesh(1)*n_bz_mesh(2)*n_bz_mesh(3)
    !!      reduction_factor_exx(1:3) = 1
    !!   end if
    !!end if

    allocate(vkbz(kv3bz,3))
    allocate(wbz(kv3bz))
    wbz(1:kv3bz) = product(reduction_factor_exx(1:3))/dble(kv3bz)

    ikbz = 0
    do i1=0,n_bz_mesh(1)-1
       do i2=0,n_bz_mesh(2)-1
          do i3=0,n_bz_mesh(3)-1
             rkxyz(1) = (dble(i1) + kshift(1)) / dble(n_bz_mesh(1))  ! USAMI
             rkxyz(2) = (dble(i2) + kshift(2)) / dble(n_bz_mesh(2))
             rkxyz(3) = (dble(i3) + kshift(3)) / dble(n_bz_mesh(3))
             call m_ES_EXX_move_k_into_fbz(rkxyz,ko)
             do ik=1,kv3
                dk(1:3) = vkxyz(ik,1:3,BUCS)-ko(1:3)
                if( abs(dk(1)-nint(dk(1)))<DELTA07 .and. &
                  & abs(dk(2)-nint(dk(2)))<DELTA07 .and. &
                  & abs(dk(3)-nint(dk(3)))<DELTA07 ) then
                  ko(1:3) = vkxyz(ik,1:3,BUCS)
                  exit
                end if
             end do
             ikbz = ikbz + 1
             vkbz(ikbz,1:3) = ko(1:3)
          end do
       end do
    end do

    write(nfout,'("k-points in BZ")')
    write(nfout,'("ikbz k1 k2 k3 wbz")')
    do ikbz=1,kv3bz
       write(nfout,'(i7,4(1x,f20.5))') ikbz, vkbz(ikbz,1:3), wbz(ikbz)
    end do

    allocate(ikp(kv3bz))
    allocate(iops(kv3bz))
    allocate(iopt(kv3bz)); iopt = 0
    allocate(itrs(kv3bz)); itrs = 0

    ! q(bz) = S*k'(ibz)
    do ikbz=1,kv3bz
       ikp(ikbz) = 0
       LOOP_S: do jtrs=0,1
          do iopr=1,nopr
             rkxyz = (1-2*jtrs) * matmul(oprec(:,:,iopr),vkbz(ikbz,1:3))
             do jk=1,kv3,nspin
                dk(1:3) = vkxyz(jk,1:3,BUCS)-rkxyz(1:3)
                if( abs(dk(1)-nint(dk(1)))<DELTA07 .and. &
                  & abs(dk(2)-nint(dk(2)))<DELTA07 .and. &
                  & abs(dk(3)-nint(dk(3)))<DELTA07 ) then
                   g0(1:3) = nint(dk(1:3))
                   ikp(ikbz) = jk
                   iops(ikbz) = iopr
                   itrs(ikbz) = jtrs
                  exit LOOP_S
                end if
             end do
          end do
       end do LOOP_S
       if(ikp(ikbz) == 0) then
          write(nfout,'("ikbz=",i5)') ikbz
          write(nfout,'(" ikp=",i5)') ikp(ikbz)
          write(nfout,'("rkxyz=",3(1x,f20.5))') rkxyz(1:3)
          stop "Did not find the index of k' in IBZ."
       end if

       do iopr=1,nopr
          ss = matmul(op(:,:,iopr),op(:,:,iops(ikbz)))
          if(abs(ss(1,1)-1.d0)<DELTA07 .and. &
           & abs(ss(2,2)-1.d0)<DELTA07 .and. &
           & abs(ss(3,3)-1.d0)<DELTA07 .and. &
           & abs(ss(1,2))<DELTA07 .and. &
           & abs(ss(1,3))<DELTA07 .and. &
           & abs(ss(2,3))<DELTA07) then
             iopt(ikbz) = iopr
             exit
          end if
       end do

       !   k'(bz) is transferable to k in IBZ by a symmetry operation.
       !   g0 = k(ibz) - R k(bz)
       !    0 = k(ibz) - R k'(bz)
       !    k'(bz) = k(bz) + R^inv g0

       rkxyz = (1-2*itrs(ikbz)) * matmul(oprec(:,:,iopt(ikbz)),g0(1:3))
       vkbz(ikbz,1:3) = vkbz(ikbz,1:3) + rkxyz(1:3)

    end do

    ntrs = maxval(itrs)

    write(nfout,'("k-points in BZ")')
    write(nfout,'("ikbz k1 k2 k3 wbz")')
    do ikbz=1,kv3bz
       write(nfout,'(i7,4(1x,f20.5))') ikbz, vkbz(ikbz,1:3), wbz(ikbz)
    end do

    write(nfout,'(2x,"ikbz",3x,"ikp",2x,"iops",2x,"iopt",2x,"itrs")')
    do ikbz=1,kv3bz
       write(nfout,'(i5,4(1x,i5))') ikbz, ikp(ikbz), iops(ikbz), iopt(ikbz), itrs(ikbz)
    end do
       !!stop 'Check ikp, ikq, iops, iopt, itrs'

    !!write(nfout,'("Check: q_on_k_centered_mesh")')
    !!do ik=1,kv3
    !!   i1 = 0
    !!   do ikbz=1,kv3bz
    !!      write(nfout,*) ik,ikbz,q_on_k_centered_mesh(ikbz,ik)
    !!      if(q_on_k_centered_mesh(ikbz,ik)) i1 = i1 + 1
    !!   end do
    !!   write(nfout,'("ik=",i5,"number of reduced k-vector=",i5)') ik,i1
    !!end do
       !!stop 'Check q_on_k_centered_mesh'
  end subroutine m_ES_EXX_kbz

  subroutine m_ES_EXX_fbz_faces
    implicit none
    integer :: n
    integer :: i,j,k
    real(kind=DP) :: mtr(3,3)
    integer, parameter :: nface_max = 125
    logical :: exists_in_fbz(nface_max)
    integer :: iface(3,nface_max)
    real(kind=DP), parameter :: lambda = 1.d0+1.d-8
    real(kind=DP) :: gg, gg_ref

    do i=1,3
       do j=1,3
          mtr(i,j) = dot_product(rltv(:,i),rltv(:,j))
       end do
    end do

    n=0
    do i=-2,2
       do j=-2,2
          do k=-2,2
             if(i == 0 .and. j == 0 .and. k == 0) cycle
             n=n+1
             iface(1,n)=i
             iface(2,n)=j
             iface(3,n)=k
          end do
       end do
    end do

    exists_in_fbz(1:nface_max) = .true.
    do i=1,n
       if(exists_in_fbz(i)) then
          gg_ref = dot_product(iface(:,i),matmul(mtr,iface(:,i)))
          do j=1,n
             if(i /= j) then
                gg = dot_product(iface(:,i),matmul(mtr,iface(:,j)))
                if(gg*lambda > gg_ref) exists_in_fbz(j) = .false.
             end if
          end do
       end if
    end do

    nface = 0
    do i=1,n
       if(exists_in_fbz(i)) nface = nface + 1
    end do
    allocate(iface_bz(3,nface))
    nface = 0
    do i=1,n
       if(exists_in_fbz(i)) then
          nface = nface + 1
          iface_bz(1:3,nface) = iface(1:3,i)
       end if
    end do

    ! Write FBZ faces
    write(nfout,'("FBZ faces: iface_bz(3,nface)")')
    write(nfout,'("nface=",i5)') nface
    write(nfout,'("i, n1, n2, n3")')
    do i=1,nface
       write(nfout,'(i5,3(1x,i5))') i, iface_bz(1:3,i)
    end do
  end subroutine m_ES_EXX_fbz_faces

  subroutine m_ES_EXX_move_k_into_fbz(ki,ko)
    implicit none
    real(kind=DP), intent(in) :: ki(3)
    real(kind=DP), intent(out) :: ko(3)

    integer :: i, j
    real(kind=DP) :: mtr(3,3)
    real(kind=DP), parameter :: lambda = 1.d0+1.d-8
    real(kind=DP) :: gg, gg_ref

    do i=1,3
       do j=1,3
          mtr(i,j) = dot_product(rltv(:,i),rltv(:,j))
       end do
    end do

    ko(1:3) = ki(1:3)
    do i=1,nface
       gg_ref = dot_product(iface_bz(:,i),matmul(mtr,iface_bz(:,i))) * 0.5d0
       do 
          gg = dot_product(iface_bz(:,i),matmul(mtr,ko))
          if(gg > gg_ref*lambda) then
             ko(1:3) = ko(1:3) - dble(iface_bz(1:3,i))
          else
             exit
          end if
       end do
    end do
  end subroutine m_ES_EXX_move_k_into_fbz

  subroutine m_ES_EXX_init
    implicit none
    integer :: ik, ikbz, ii,ierr
    real(kind=DP) :: dk(3)
    integer,save  :: id_sname = -1
    call tstatc0_begin('m_ES_EXX_init ',id_sname,level=1)

    call m_ES_EXX_kbz ! -> ntrs, etc.

    ikgamma = 1
    do ik=1,kv3,nspin
       if( abs(vkxyz(ik,1,BUCS))<DELTA07 .and. &
         & abs(vkxyz(ik,2,BUCS))<DELTA07 .and. &
         & abs(vkxyz(ik,3,BUCS))<DELTA07 ) then
          ikgamma = ik
          exit
       end if
    end do

    allocate(qmk_zero(kv3bz,kv3)); qmk_zero = .false.
    allocate(qmk(kv3bz*kv3,3))
    allocate(qmk_zero2(kv3bz*kv3))
    allocate(iqmk(kv3bz,kv3))
    nqmk = 0
    do ik=1,kv3
       do ikbz=1,kv3bz
          if(.not.q_on_k_centered_mesh(ikbz,ik)) cycle
          if( abs(vkbz(ikbz,1)-vkxyz(ik,1,BUCS))<DELTA07 .and. &
            & abs(vkbz(ikbz,2)-vkxyz(ik,2,BUCS))<DELTA07 .and. &
            & abs(vkbz(ikbz,3)-vkxyz(ik,3,BUCS))<DELTA07 ) then
             qmk_zero(ikbz,ik) = .true.
          end if
          !Debug!write(nfout,'("EXX: qmk_zero(",i5,",",i5,")=",L)') ikbz,ik,qmk_zero(ikbz,ik)
          if(nqmk==0) then
             nqmk = nqmk + 1
             qmk(nqmk,1:3) = vkbz(ikbz,1:3)-vkxyz(ik,1:3,BUCS)    
             iqmk(ikbz,ik) = nqmk
             qmk_zero2(nqmk) = qmk_zero(ikbz,ik)
          else
             dk(1:3) = vkbz(ikbz,1:3)-vkxyz(ik,1:3,BUCS)    
             do ii=1,nqmk
                if( abs(qmk(ii,1)-dk(1))<DELTA07 .and. &
                  & abs(qmk(ii,2)-dk(2))<DELTA07 .and. &
                  & abs(qmk(ii,3)-dk(3))<DELTA07 ) then
                  iqmk(ikbz,ik) = ii
                  go to 100
                end if
             end do
             nqmk = nqmk + 1
             qmk(nqmk,1:3) = dk(1:3)
             iqmk(ikbz,ik) = nqmk
             qmk_zero2(nqmk) = qmk_zero(ikbz,ik)
         100 continue
          end if
       end do
    end do

    nfftwf = product(fft_box_size_WF(1:3,1))
    if(sw_rspace_hyb==ON)then
        allocate(igfp_l_red(kgp));igfp_l_red=0
        do ii=ista_kngp,iend_kngp
           igfp_l_red(ii) = igfp_l(ii)
        enddo
        call mpi_allreduce(MPI_IN_PLACE,igfp_l_red,kgp,mpi_integer,mpi_sum,mpi_comm_group,ierr)
    endif

    call tstatc0_end(id_sname)
!!    stop 'Check m_ES_EXX_init'
  end subroutine m_ES_EXX_init
 
  subroutine m_ES_EXX_crotylm
    implicit none
    integer :: l1max, mmax, nsph
    integer :: ia1,it1,il1,im1,tau1,lmt1,lmtt1,isph1
    integer :: ia2,it2,il2,im2,tau2,lmt2,lmtt2,isph2
    integer :: iy,ilmta1,iopr
    integer :: iopr1,iopr2
    integer :: invop(nopr)
    integer :: i,j
    real(kind=DP) :: ss(3,3)
    real(kind=DP) :: x(3), y(3)
    integer,save  :: id_sname = -1
    call tstatc0_begin('m_ES_EXX_crotylm ',id_sname,level=1)

    do iopr1=1,nopr
       do iopr2=1,nopr
          ss = matmul(op(:,:,iopr1),op(:,:,iopr2))
          if(abs(ss(1,1)-1.d0)<DELTA07 .and. &
          & abs(ss(2,2)-1.d0)<DELTA07 .and. &
          & abs(ss(3,3)-1.d0)<DELTA07 .and. &
          & abs(ss(1,2))<DELTA07 .and. &
          & abs(ss(1,3))<DELTA07 .and. &
          & abs(ss(2,3))<DELTA07) then
             invop(iopr1) = iopr2
             exit
          end if
       end do
    end do

    l1max = nloc
    mmax  = 2*l1max-1
    nsph = l1max**2
    if(.not.allocated(crotylm)) allocate(crotylm(mmax,nsph,nopr))
    crotylm = 0.0d0
    if(.not.allocated(iylm))    allocate(iylm(mmax,nsph,nopr))
    if(.not.allocated(nylm))    allocate(nylm(nsph,nopr))
    call get_crotylm(l1max,mmax,nsph,nopr,crotylm,iylm,nylm,op)
    !! Check
    !do iopr=1,nopr
    !   write(nfout,'("iopr=",i5)') iopr 
    !   do isph1=1,nsph
    !      write(nfout,'("isph=",i5)') isph1 
    !      do iy=1,nylm(isph1,iopr)
    !         write(nfout,'("> iylm=",i5," Clm",f16.8)') iylm(iy,isph1,iopr), crotylm(iy,isph1,iopr)
    !      end do
    !   end do
    !end do

    if(.not.allocated(isph_lmta)) allocate(isph_lmta(nlmta))
    if(.not.allocated(lmta_rot))  allocate(lmta_rot(mmax,nlmta,nopr))
    lmta_rot = 0
    if(.not.allocated(ia_lmta))   allocate(ia_lmta(nlmta))
    do ia1=1,natm
       it1=ityp(ia1)
       do lmt1=1,ilmt(it1)

          !!call m_PP_tell_lmtt_l_m_tau(lmt1,it1,lmtt1,il1,im1,tau1,isph1)
          il1  = ltp( lmt1, it1)
          im1  = mtp( lmt1, it1)
          tau1 = taup(lmt1, it1)
          lmtt1 = lmtt(lmt1,it1)
          isph1 = (il1-1)**2 + im1

          ilmta1 = lmta(lmt1,ia1)
          ia_lmta(ilmta1) = ia1
          isph_lmta(ilmta1) = isph1
          do iopr=1,nopr
             ia2=napt(ia1,invop(iopr))
             it2=ityp(ia2)
             if(it1/=it2) stop 'm_ES_EXX_crotylm: it1 and it2 differ.'
             do lmt2=1,ilmt(it2)
                il2  = ltp( lmt2, it2)
                tau2 = taup(lmt2, it2)
                if(il1==il2.and.tau1==tau2) then
                   im2  = mtp( lmt2, it2)
                   lmtt2 = lmtt(lmt2,it2)
                   !!call m_PP_tell_lmtt_l_m_tau(lmt2,it2,lmtt2,il2,im2,tau2,isph2)
                   isph2 = (il2-1)**2 + im2
                   do iy=1,nylm(isph1,iopr)
                      if(isph2 == iylm(iy,isph1,iopr)) then
                         lmta_rot(iy,ilmta1,iopr) = lmta(lmt2,ia2)
                      end if
                   end do
                end if
             end do
          end do
       end do
    end do

   !! Check
   !do iopr=1,nopr
   !   write(nfout,'("iopr=",i5)') iopr
   !   do ilmta1=1,nlmta
   !      isph1 = isph_lmta(ilmta1)
   !      write(nfout,'("ilmta1=",i5," isph1=",i5)') ilmta1,isph1
   !      do iy=1,nylm(isph1,iopr)
   !         !!isph2 = iylm(iy,isph1,iopr)
   !         write(nfout,'("iy=",i5," lmta_rot=",i5," Clm=",f16.8)') &
   !         !!  & iy, lmta_rot(iy,ilmta1,iopr), crotylm(iy,isph2,iopr)
   !           & iy, lmta_rot(iy,ilmta1,iopr), crotylm(iy,isph1,iopr)
   !      end do
   !   end do
   !end do

    if(.not.allocated(opdir)) allocate(opdir(3,3,nopr))
    do iopr=1,nopr
       do j=1,3
          x = matmul(op(:,:,iopr),altv(:,j))
          do i=1,3
             y = rltv(:,i)
             opdir(i,j,iopr) = dot_product(y,x)/PAI2
          end do
       end do
    end do

    call tstatc0_end(id_sname)
  end subroutine m_ES_EXX_crotylm

  subroutine m_ES_EXX_dealloc
    implicit none
    deallocate(vc)
    deallocate(wfv)
    deallocate(occup_val)
    deallocate(ngpt_exx)
    if(modnrm == EXECUT) then
       deallocate(ylm_exx)
       deallocate(qitg_exx)
       deallocate(fsr_exx)
       deallocate(fsi_exx)
    end if
  end subroutine m_ES_EXX_dealloc
  
  subroutine m_ES_EXX_set_fsr_fsi(fsr,fsi)
    real(kind=DP),intent(in),dimension(neg,nlmta,kv3) :: fsr,fsi

    fsr_exx(1:nval,:,:) = fsr(1:nval,:,:)
    fsi_exx(1:nval,:,:) = fsi(1:nval,:,:)
  end subroutine m_ES_EXX_set_fsr_fsi

  subroutine m_ES_EXX_gather_valence_states(nfout,transform)
    implicit none
    integer, intent(in) :: nfout
    logical, optional, intent(in) :: transform

    integer :: ik,ib,ib1,ibm,irev
    real(kind=DP), allocatable :: wfv_mpi(:,:,:,:) ! d(kg1,nval,kv3,kimg)
    real(kind=DP), allocatable :: occup_val_mpi(:,:) ! d(nval,kv3)
    real(kind=DP), allocatable :: fsr_mpi(:,:,:) ! d(nval,nlmta,kv3)
    real(kind=DP), allocatable :: fsi_mpi(:,:,:) ! d(nval,nlmta,kv3)
    real(kind=DP), allocatable :: efsr_l(:,:) ! d(np_e,nlmta)
    real(kind=DP), allocatable :: efsi_l(:,:) ! d(np_e,nlmta)

    logical :: trans
    integer,save  :: id_sname = -1

    if(sw_update_wfv==OFF) return

    trans = .true.
    if(present(transform)) trans = transform
    call tstatc0_begin('m_ES_EXX_gather_valence_states ',id_sname,level=1)


    if(sw_rsb==ON.and.trans) then
       do ik=1,kv3,af+1
          if(map_k(ik) /= myrank_k) cycle
          call UnitaryTransform_WF(INVERSE,ik,zaj_l,.true.,.true.)
       enddo
       !call m_ES_RSB_alloc()
       !call m_ES_RSB_doit(verbose=.false.)
    endif

    ibm = 0
    do ik=1,kv3,af+1
       if(map_k(ik) /= myrank_k) cycle
       do ib=1,neg
          ib1 = neordr(ib,ik)
          if(map_e(ib1) == myrank_e) then
             if(occup_l(map_z(ib1),ik) > DELTA) then
                ibm = max(ib,ibm)
             end if
          end if
       end do
    end do
    if(npes>1) then
       call mpi_allreduce(ibm,irev,1,MPI_INTEGER,MPI_MAX,mpi_comm_group,ierr)
       nval = irev
    else
       nval = ibm
    end if

    !Debug!write(nfout,*) 'm_ES_EXX_gather_valence_states: ibm=',ibm
    !Debug!write(nfout,*) 'm_ES_EXX_gather_valence_states: nval=',nval

    if(allocated(wfv)) deallocate(wfv)
    if(allocated(occup_val)) deallocate(occup_val)
    allocate(wfv(kg1,nval,kv3,kimg))
    allocate(occup_val(nval,kv3))
    wfv = 0.d0
    occup_val = 0.d0
    if(modnrm == EXECUT) then
       if(allocated(fsr_exx)) deallocate(fsr_exx)
       if(allocated(fsi_exx)) deallocate(fsi_exx)
       allocate(fsr_exx(nval,nlmta,kv3))
       allocate(fsi_exx(nval,nlmta,kv3))
       allocate(efsr_l(np_e,nlmta));efsr_l=0.d0
       allocate(efsi_l(np_e,nlmta));efsi_l=0.d0
       fsr_exx = 0.d0
       fsi_exx = 0.d0
    end if
    wf_is_real = .not.allocated(fsi_l)
    do ik=1,kv3,af+1
       if(map_k(ik) /= myrank_k) cycle
       if(modnrm == EXECUT) call get_expkt_fs(ik,fsr_l,fsi_l,efsr_l,efsi_l)
       do ib=1,nval
          ib1 = neordr(ib,ik)
          if(map_e(ib1) == myrank_e) then
             wfv(1:kg1,ib,ik,1:kimg) = zaj_l(1:kg1,map_z(ib1),ik,1:kimg)
             occup_val(ib,ik) = occup_l(map_z(ib1),ik)
             if(modnrm == EXECUT) then
                fsr_exx(ib,1:nlmta,ik) = efsr_l(map_z(ib1),1:nlmta)
                fsi_exx(ib,1:nlmta,ik) = efsi_l(map_z(ib1),1:nlmta)
             end if
          end if
       end do
    end do    
    if(modnrm == EXECUT) then
       deallocate(efsr_l)
       deallocate(efsi_l)
    end if

    if(npes>1) then
       allocate(wfv_mpi(kg1,nval,kv3,kimg))
       allocate(occup_val_mpi(nval,kv3))
       call mpi_allreduce(wfv,wfv_mpi,kg1*nval*kv3*kimg,MPI_DOUBLE_PRECISION,MPI_SUM,mpi_comm_group,ierr)
       call mpi_allreduce(occup_val,occup_val_mpi,nval*kv3,MPI_DOUBLE_PRECISION,MPI_SUM,mpi_comm_group,ierr)
       wfv = wfv_mpi
       occup_val = occup_val_mpi
       deallocate(wfv_mpi)
       deallocate(occup_val_mpi)
       if(modnrm == EXECUT) then
          allocate(fsr_mpi(nval,nlmta,kv3))
          allocate(fsi_mpi(nval,nlmta,kv3))
          call mpi_allreduce(fsr_exx,fsr_mpi,nval*nlmta*kv3,MPI_DOUBLE_PRECISION,MPI_SUM,mpi_comm_group,ierr)
          call mpi_allreduce(fsi_exx,fsi_mpi,nval*nlmta*kv3,MPI_DOUBLE_PRECISION,MPI_SUM,mpi_comm_group,ierr)
          fsr_exx = fsr_mpi
          fsi_exx = fsi_mpi
          deallocate(fsr_mpi)
          deallocate(fsi_mpi)
       end if
    end if

    if(sw_rspace_hyb==ON .and. modnrm==EXECUT.and.sw_precalculate==ON)then
       if(allocated(fsrqm)) deallocate(fsrqm)
       if(allocated(fsiqm)) deallocate(fsiqm)
       allocate(fsrqm(nmesh_rs_aug_max,nlmta,nval,kv3bz,nspin));fsrqm=0.d0
       allocate(fsiqm(nmesh_rs_aug_max,nlmta,nval,kv3bz,nspin));fsiqm=0.d0
       call build_fsqm()
    endif

    !Debug!write(nfout,'("occup_val:")')
    !Debug!do ik=1,kv3,af+1
    !Debug!   write(nfout,'("ik=",i5)') ik
    !Debug!   write(nfout,'(128(1x,f10.5))') occup_val(1:nval,ik)
    !Debug!end do

    if(sw_rsb==ON.and.trans) then
       do ik=1,kv3,af+1
          if(map_k(ik) /= myrank_k) cycle
          call UnitaryTransform_WF(DIRECT,ik,zaj_l,.true.,.true.)
       enddo
    endif

    call tstatc0_end(id_sname)
  end subroutine m_ES_EXX_gather_valence_states

  subroutine build_fsqm()
    integer :: jkbz,kk,kop,jop,jtrs,m
    integer :: ia,it,imesh,lmt1,lmt2,nma,ilmta1,ilmta2,ispin
    real(kind=DP), allocatable, dimension(:) :: fsr, fsi !d(nlmta)
    real(kind=DP), allocatable, dimension(:) :: cosqmkr,sinqmkr
    real(kind=DP) :: fr,fi
    real(kind=DP) :: qm
    allocate(fsr(nlmta));fsr=0.d0
    allocate(fsi(nlmta));fsi=0.d0
    fsrqm = 0.d0
    fsiqm = 0.d0
    do ispin=1,nspin,af+1
       do jkbz=1,kv3bz
          ! q(bz) = S*k(ibz)
          kk = ikp(jkbz) + ispin - 1
          kop = iops(jkbz)
          jop = iopt(jkbz) 
          jtrs = itrs(jkbz)
          do m=1,nval
             call get_Rot_betar_dot_WFs(kk,m,jop,kop,jtrs,fsr,fsi)
             do ia=1,natm
                it = ityp(ia)
                if( m_PP_include_vanderbilt_pot(it) == SKIP) cycle
                nma = nmesh_rs_aug(ia)
                do lmt1=1,ilmt(it)
                   ilmta1 = lmta(lmt1,ia)
                   do lmt2=1,ilmt(it)
                      ilmta2 = lmta(lmt2,ia)
                      fr = fsr(ilmta2)
                      fi = fsi(ilmta2)
                      do imesh=1,nma
                         qm = qr_clm_ylm(imesh,ia,lmt1,lmt2)
                         fsrqm(imesh,ilmta1,m,jkbz,ispin) = fsrqm(imesh,ilmta1,m,jkbz,ispin)+qm*fr
                         fsiqm(imesh,ilmta1,m,jkbz,ispin) = fsiqm(imesh,ilmta1,m,jkbz,ispin)+qm*fi
                      enddo
                   enddo
                enddo
             enddo
          enddo
       enddo
    enddo
    deallocate(fsr)
    deallocate(fsi)
  end subroutine build_fsqm

  subroutine m_ES_EXX_kernel(nfout)
    implicit none
    integer, intent(in) :: nfout
    
    integer :: ik,ikbz,ig,kgs
    real(kind=DP) :: fac, wi, kg(3), vzero, g2
    real(kind=DP), dimension(6) :: ttr

    integer,save  :: id_sname = -1
    call tstatc0_begin('m_ES_EXX_kernel ',id_sname,level=1)

!!$    allocate(vc(kgp,nqmk))
    if(.not.allocated(vc)) allocate(vc(nmax_G_hyb,nqmk))

    call getttr(rltv,ttr)

    fac = PAI4/univol

    if(sw_singular_correction==ON) then
       call singular_correction(vzero)
    else
       vzero = 0.d0
    end if
    vzero = vzero*dble(kv3bz)/product(reduction_factor_exx(1:3))

    if(sw_screened_exchange==OFF) then
       do ik=1,nqmk
          kgs=1
          if(qmk_zero2(ik)) then
             kgs=2
             vc(1,ik) = vzero
          end if
          do ig=kgs,nmax_G_hyb
             kg(1:3) = qmk(ik,1:3) + ngabc(ig,1:3)
             g2          = ttr(1)*kg(1)*kg(1) &
             &           + ttr(2)*kg(2)*kg(2) &
             &           + ttr(3)*kg(3)*kg(3) &
             &           + ttr(4)*kg(1)*kg(2) &
             &           + ttr(5)*kg(2)*kg(3) &
             &           + ttr(6)*kg(3)*kg(1)
             vc(ig,ik) = fac / g2
          end do
       end do
    else
       wi = 1.d0/(4.d0*omega_exx*omega_exx)
       do ik=1,nqmk
          kgs=1
          if(qmk_zero2(ik)) then
             kgs=2
             vc(1,ik) = vzero
          end if
          do ig=kgs,nmax_G_hyb
             kg(1:3) = qmk(ik,1:3) + ngabc(ig,1:3)
             g2          = ttr(1)*kg(1)*kg(1) &
             &           + ttr(2)*kg(2)*kg(2) &
             &           + ttr(3)*kg(3)*kg(3) &
             &           + ttr(4)*kg(1)*kg(2) &
             &           + ttr(5)*kg(2)*kg(3) &
             &           + ttr(6)*kg(3)*kg(1)
             vc(ig,ik) = fac / g2 * (1.d0-exp(-g2*wi))
          end do
       end do
    end if

    vc = -alpha_exx * vc

    call tstatc0_end(id_sname)

    !!stop 'm_ES_EXX_kernel: Singular correction'

  contains

    subroutine singular_correction(chi)
      implicit none 
      real(kind=DP), intent(out) :: chi

      real(kind=DP), parameter :: gam  = 1.d0 ! Bohr^-2
      !real(kind=DP), parameter :: gam1 = 1.d0 ! Bohr^-2
      !real(kind=DP), parameter :: gam2 = 2.d0 ! bohr^-2
      real(kind=DP) :: chig1, chig2, chig3, gam3
      real(kind=DP) :: chi0, chi1, chi2
      !real(kind=DP) :: chi_app

      !chig1 = chig(gam1)
      !chig2 = chig(gam2)
      !chi_app = chig1 + (chig1-chig2)/(gam2-gam1) * gam1

      call chig_deriv(gam,chi0,chi1,chi2)
      chi = chi0 - chi1*gam + 0.5d0*chi2*gam**2

      if(sw_screened_exchange==ON) then
         gam3 = 1.d0/(4.d0*omega_exx**2)
         chig3 = chig(gam3)
         chi = chi - chig3
      !   chi_app = chi_app - chig3
      end if

      if(printable) then
         write(nfout,'("EXX: Singular correction: chi(0)=",f10.5)') chi
         write(nfout,'("EXX: chi0(",f10.5,") =",f10.5)') gam, chi0
         write(nfout,'("EXX: chi1(",f10.5,") =",f10.5)') gam, chi1
         write(nfout,'("EXX: chi2(",f10.5,") =",f10.5)') gam, chi2
      !   write(nfout,'("EXX: chi(0) =",f10.5,"(Linear approx.)")') chi_app
      !   write(nfout,'("EXX: chi(",f10.5,") =",f10.5)') gam1, chig1
      !   write(nfout,'("EXX: chi(",f10.5,") =",f10.5)') gam2, chig2
         if(sw_screened_exchange==ON) &
          & write(nfout,'("EXX: chi0(",f10.5,") =",f10.5)') gam3, chig3 
      end if
    end subroutine singular_correction

    function chig(gam)
      implicit none 
      real(kind=DP) :: chig
      real(kind=DP), intent(in) :: gam

      integer :: ig, ikbz, kgs
      real(kind=DP) :: sumg, sumgk

      sumg = 0.d0
      do ikbz=1,kv3bz
         if(.not.q_on_k_centered_mesh(ikbz,ikgamma)) cycle
         kgs=1
         if(qmk_zero(ikbz,ikgamma)) kgs=2
         sumgk = 0.d0
         do ig=kgs,nmax_G_hyb
            kg(1:3) = vkbz(ikbz,1:3) + ngabc(ig,1:3)
            g2          = ttr(1)*kg(1)*kg(1) &
            &           + ttr(2)*kg(2)*kg(2) &
            &           + ttr(3)*kg(3)*kg(3) &
            &           + ttr(4)*kg(1)*kg(2) &
            &           + ttr(5)*kg(2)*kg(3) &
            &           + ttr(6)*kg(3)*kg(1)
            sumgk = sumgk + exp(-gam*g2) / g2
         end do
         sumg = sumg + wbz(ikbz) * sumgk
      end do
      sumg = fac * sumg

      chig = 1.d0/sqrt(PAI*gam) - sumg
    end function chig

    subroutine chig_deriv(gam,chi0,chi1,chi2)
      implicit none
      real(kind=DP), intent(in) :: gam
      real(kind=DP), intent(out) :: chi0, chi1, chi2

      integer :: ig, ikbz, kgs
      real(kind=DP) :: sumg0, sumgk0
      real(kind=DP) :: sumg1, sumgk1
      real(kind=DP) :: sumg2, sumgk2
      real(kind=DP) :: expg2

      sumg0 = 0.d0
      sumg1 = 0.d0
      sumg2 = 0.d0
      do ikbz=1,kv3bz
         if(.not.q_on_k_centered_mesh(ikbz,ikgamma)) cycle
         kgs=1
         if(qmk_zero(ikbz,ikgamma)) kgs=2
         sumgk0 = 0.d0
         sumgk1 = 0.d0
         sumgk2 = 0.d0
         do ig=kgs,nmax_G_hyb
            kg(1:3) = vkbz(ikbz,1:3) + ngabc(ig,1:3)
            g2          = ttr(1)*kg(1)*kg(1) &
            &           + ttr(2)*kg(2)*kg(2) &
            &           + ttr(3)*kg(3)*kg(3) &
            &           + ttr(4)*kg(1)*kg(2) &
            &           + ttr(5)*kg(2)*kg(3) &
            &           + ttr(6)*kg(3)*kg(1)
            expg2 = exp(-gam*g2)
            sumgk0 = sumgk0 + expg2 / g2
            sumgk1 = sumgk1 + expg2
            sumgk2 = sumgk2 + expg2 * g2
         end do
         sumg0 = sumg0 + wbz(ikbz) * sumgk0
         sumg1 = sumg1 + wbz(ikbz) * sumgk1
         sumg2 = sumg2 + wbz(ikbz) * sumgk2
      end do
      chi0 =  1.d0/sqrt(PAI*gam) - fac*sumg0
      chi1 = -0.5d0/sqrt(PAI*gam**3) + fac*sumg1
      chi2 =  0.75d0/sqrt(PAI*gam**5) - fac*sumg2
    end subroutine chig_deriv

  end subroutine m_ES_EXX_kernel

  subroutine m_ES_EXX_get_vexx(nfout,ispin,ib,ik,nff,fsr,fsi,vxw)
    implicit none
    integer, intent(in) :: nfout
    integer, intent(in) :: ispin,ib,ik
    integer, intent(in) :: nff
    real(kind=DP), intent(in)  :: fsr(nlmta),fsi(nlmta)
    real(kind=DP), intent(out) :: vxw(nff,kimg) 

    real(kind=DP), allocatable :: efsr_l(:)
    real(kind=DP), allocatable :: efsi_l(:)
    real(kind=DP) :: nfftwf
    integer :: id_sname=-1
    call tstatc0_begin('m_ES_EXX_get_vexx ',id_sname,level=1)

    vxw = 0.0d0
    allocate(efsr_l(nlmta));efsr_l=0.d0
    allocate(efsi_l(nlmta));efsi_l=0.d0
    if(modnrm == EXECUT) call get_expkt_fs_b(ik,ib,fsr,fsi,efsr_l,efsi_l)
    if(kimg==1) then
       call apply_Vx_to_WF( ispin, ib, ik, zaj_l(1,ib,ik,1), zaj_l(1,ib,ik,1), efsr_l, efsr_l, vxw )
    else
       call apply_Vx_to_WF( ispin, ib, ik, zaj_l(1,ib,ik,1), zaj_l(1,ib,ik,2), efsr_l, efsi_l, vxw )
    endif
    deallocate(efsr_l)
    deallocate(efsi_l)
    call tstatc0_end(id_sname)
  end subroutine m_ES_EXX_get_vexx

  subroutine m_ES_EXX_eigenvalue(nfout)
    ! For initialization of eko_l
    implicit none
    integer, intent(in) :: nfout

    integer :: ik,ib,ig,ispin
    real(kind=DP) :: eko
    real(kind=DP), allocatable, dimension(:,:) :: vxw !d(kg1,kimg)
    real(kind=DP), allocatable :: efsr_l(:,:) ! d(np_e,nlmta)
    real(kind=DP), allocatable :: efsi_l(:,:) ! d(np_e,nlmta)
    real(kind=DP) :: eexx
    integer,save  :: id_sname = -1
    if(sw_rsb==ON)then
       call EXX_eigenvalue_rsb(nfout)
       return
    endif
    call tstatc0_begin('m_ES_EXX_eigenvalue ',id_sname,level=1)

    if(.not.allocated(eko_hyb))then
       allocate(eko_hyb(np_e,ista_k:iend_k));eko_hyb=0.d0
    endif
    eko_hyb = 0.0d0

    !!if(modnrm == EXECUT) then
       allocate(efsr_l(np_e,nlmta));efsr_l=0.d0
       allocate(efsi_l(np_e,nlmta));efsi_l=0.d0
    !!end if

    if(.not.allocated(eexx_kb)) allocate(eexx_kb(np_e,ista_k:iend_k))
    eexx_kb = 0.0d0
    call m_FFT_alloc_WF_work()
    allocate(vxw(kg1,kimg))

    !!write(nfout,'("m_ES_EXX_eigenvalue")')

    eko_l(:,:) = 0.d0
    wf_is_real = .not.allocated(fsi_l)
    do ispin=1,nspin,af+1
       do ik=ispin, kv3+ispin-nspin, nspin
          if(map_k(ik) /= myrank_k) cycle ! MPI
          if(modnrm == EXECUT) call get_expkt_fs(ik,fsr_l,fsi_l,efsr_l,efsi_l)
!! Debug
!!          if(check_ibz_k(ik)) cycle
!!
          do ib=1,np_e   ! MPI
             !!write(nfout,'("ispin,ik,ib=",3i5)') ispin,ik,ib
             eko = 0.d0;eexx=0.d0
             if(kimg==1) then
                call apply_Vx_to_WF( ispin, ib, ik, zaj_l(1,ib,ik,1), zaj_l(1,ib,ik,1), &
                     &               efsr_l(ib,1:nlmta), efsr_l(ib,1:nlmta), vxw, eexx )
                eexx_kb(ib,ik) = occup_l(ib,ik)*eexx
                do ig=1,iba(ik)
                   eko = eko + zaj_l(ig,ib,ik,1)*vxw(ig,1)
                end do
             else
                call apply_Vx_to_WF( ispin, ib, ik, zaj_l(1,ib,ik,1), zaj_l(1,ib,ik,2), &
                        &               efsr_l(ib,1:nlmta), efsi_l(ib,1:nlmta), vxw, eexx )
                eexx_kb(ib,ik) = occup_l(ib,ik)*eexx
                if(k_symmetry(ik) == GAMMA) then
                   do ig=2,iba(ik)
                      eko = eko + zaj_l(ig,ib,ik,1) * vxw(ig,1) + zaj_l(ig,ib,ik,2) * vxw(ig,2)
                   end do
                   eko = eko * 2.d0 + zaj_l(1,ib,ik,1) * vxw(1,1)
                else
                   do ig=1,iba(ik)
                      eko = eko + zaj_l(ig,ib,ik,1)*vxw(ig,1) + zaj_l(ig,ib,ik,2)*vxw(ig,2)
                   end do
                end if
             end if
             eko_l(ib,ik) = eko_l(ib,ik) + eko
             eko_hyb(ib,ik) = eko
          end do
       end do
    end do

    deallocate(vxw)
    call m_FFT_dealloc_WF_work()

! debug
!    write(nfout,'("DEBUG: m_ES_EXX_eigenvalue")')
!    do ik=1,kv3
!       if(map_k(ik) /= myrank_k) cycle ! MPI
!! Debug
!!          if(check_ibz_k(ik)) cycle
!!
!       write(nfout,'("DEBUG: ik=",i5)') ik
!       write(nfout,'("DEBUG: vkxyz=",3f12.5)') vkxyz(ik,1:3,BUCS)
!       write(nfout,'("DEBUG: eko_l=",5f12.5)') eko_l(1:np_e,ik)
!    end do
!    stop 'debug m_ES_EXX_eigenvalue'
! end debug

    !!if(modnrm == EXECUT) then
       deallocate(efsr_l)
       deallocate(efsi_l)
    !!end if

    call tstatc0_end(id_sname)
  end subroutine m_ES_EXX_eigenvalue

  subroutine EXX_eigenvalue_rsb(nfout)
    ! For initialization of eko_l
    implicit none
    integer, intent(in) :: nfout

    integer :: ik,ib,ig,ispin
    real(kind=DP) :: eko
    real(kind=DP), allocatable, dimension(:,:,:,:) :: vxw !d(kg1,kimg)
    real(kind=DP), allocatable, dimension(:,:) :: vxwt !d(kg1,kimg)
    real(kind=DP), allocatable :: efsr_l(:,:) ! d(np_e,nlmta)
    real(kind=DP), allocatable :: efsi_l(:,:) ! d(np_e,nlmta)
    real(kind=DP) :: eexx
    integer,save  :: id_sname = -1
    call tstatc0_begin('m_ES_EXX_eigenvalue ',id_sname,level=1)

    if(.not.allocated(eko_hyb))then
       allocate(eko_hyb(np_e,ista_k:iend_k));eko_hyb=0.d0
    endif
    eko_hyb = 0.0d0

    !!if(modnrm == EXECUT) then
       allocate(efsr_l(np_e,nlmta));efsr_l=0.d0
       allocate(efsi_l(np_e,nlmta));efsi_l=0.d0
    !!end if

    if(.not.allocated(eexx_kb)) allocate(eexx_kb(np_e,ista_k:iend_k))
    eexx_kb = 0.0d0
    call m_FFT_alloc_WF_work()
    allocate(vxwt(kg1,kimg))
    allocate(vxw(kg1,np_e,ista_k:iend_k,kimg))
    !!write(nfout,'("m_ES_EXX_eigenvalue")')

    eko_l(:,:) = 0.d0
    wf_is_real = .not.allocated(fsi_l)
    do ispin=1,nspin,af+1
       do ik=ispin, kv3+ispin-nspin, nspin
          if(map_k(ik) /= myrank_k) cycle ! MPI
          call UnitaryTransform_WF(INVERSE,ik,zaj_l,.true.,.true.)
          if(modnrm == EXECUT) call get_expkt_fs(ik,fsr_l,fsi_l,efsr_l,efsi_l)
!! Debug
!!          if(check_ibz_k(ik)) cycle
!!
          do ib=1,np_e   ! MPI
             !!write(nfout,'("ispin,ik,ib=",3i5)') ispin,ik,ib
             eko = 0.d0;eexx=0.d0
             if(kimg==1) then
                call apply_Vx_to_WF( ispin, ib, ik, zaj_l(1,ib,ik,1), zaj_l(1,ib,ik,1), &
                     &               efsr_l(ib,1:nlmta), efsr_l(ib,1:nlmta), vxwt, eexx )
                vxw(:,ib,ik,:) = vxwt(:,:)
                eexx_kb(ib,ik) = occup_l(ib,ik)*eexx
                !do ig=1,iba(ik)
                !   eko = eko + zaj_l(ig,ib,ik,1)*vxw(ig,1)
                !end do
             else
                call apply_Vx_to_WF( ispin, ib, ik, zaj_l(1,ib,ik,1), zaj_l(1,ib,ik,2), &
                        &               efsr_l(ib,1:nlmta), efsi_l(ib,1:nlmta), vxwt, eexx )
                vxw(:,ib,ik,:) = vxwt(:,:)
                eexx_kb(ib,ik) = occup_l(ib,ik)*eexx
                !if(k_symmetry(ik) == GAMMA) then
                !   do ig=2,iba(ik)
                !      eko = eko + zaj_l(ig,ib,ik,1) * vxw(ig,1) + zaj_l(ig,ib,ik,2) * vxw(ig,2)
                !   end do
                !   eko = eko * 2.d0 + zaj_l(1,ib,ik,1) * vxw(1,1)
                !else
                !   do ig=1,iba(ik)
                !      eko = eko + zaj_l(ig,ib,ik,1)*vxw(ig,1) + zaj_l(ig,ib,ik,2)*vxw(ig,2)
                !   end do
                !end if
             end if
             !eko_l(ib,ik) = eko_l(ib,ik) + eko
             !eko_hyb(ib,ik) = eko
          end do

          call UnitaryTransform_WF(DIRECT,ik,vxw,.false.,.false.)
          call UnitaryTransform_WF(DIRECT,ik,zaj_l,.true.,.true.)
          do ib=1,np_e
             eko=0.d0
             if(kimg==1)then
                do ig=1,iba(ik)
                   eko = eko + zaj_l(ig,ib,ik,1)*vxw(ig,ib,ik,1)
                end do
             else
                if(k_symmetry(ik) == GAMMA) then
                   do ig=2,iba(ik)
                      eko = eko + zaj_l(ig,ib,ik,1) * vxw(ig,ib,ik,1) + zaj_l(ig,ib,ik,2) * vxw(ig,ib,ik,2)
                   end do
                   eko = eko * 2.d0 + zaj_l(1,ib,ik,1) * vxw(1,ib,ik,1)
                else
                   do ig=1,iba(ik)
                      eko = eko + zaj_l(ig,ib,ik,1)*vxw(ig,ib,ik,1) + zaj_l(ig,ib,ik,2)*vxw(ig,ib,ik,2)
                   end do
                end if
             endif
             eko_l(ib,ik) = eko_l(ib,ik) + eko
             eko_hyb(ib,ik) = eko
          enddo
       end do
    end do

    deallocate(vxw)
    call m_FFT_dealloc_WF_work()

! debug
!    write(nfout,'("DEBUG: m_ES_EXX_eigenvalue")')
!    do ik=1,kv3
!       if(map_k(ik) /= myrank_k) cycle ! MPI
!! Debug
!!          if(check_ibz_k(ik)) cycle
!!
!       write(nfout,'("DEBUG: ik=",i5)') ik
!       write(nfout,'("DEBUG: vkxyz=",3f12.5)') vkxyz(ik,1:3,BUCS)
!       write(nfout,'("DEBUG: eko_l=",5f12.5)') eko_l(1:np_e,ik)
!    end do
!    stop 'debug m_ES_EXX_eigenvalue'
! end debug

    !!if(modnrm == EXECUT) then
       deallocate(efsr_l)
       deallocate(efsi_l)
    !!end if

    call tstatc0_end(id_sname)
  end subroutine EXX_eigenvalue_rsb

  subroutine m_ES_EXX_eigenvalue_for_each_k(ispin,ik,update_eko)
    implicit none
    integer, intent(in) :: ispin, ik
    logical,intent(in),optional :: update_eko

    integer :: ib,ig
    real(kind=DP) :: eko
    real(kind=DP), allocatable, dimension(:,:) :: vxw !d(kg1,kimg)
    real(kind=DP), allocatable :: efsr_l(:,:) ! d(np_e,nlmta)
    real(kind=DP), allocatable :: efsi_l(:,:) ! d(np_e,nlmta)
    real(kind=DP) :: exx
    integer,save  :: id_sname = -1
    if(sw_rsb==ON)then
       call eigenvalue_for_each_k_rsb(ispin,ik,update_eko)
       return
    endif
    call tstatc0_begin('m_ES_EXX_eigenvalue_for_each_k ',id_sname,level=1)

    if(.not.allocated(eko_hyb))then
       allocate(eko_hyb(np_e,ista_k:iend_k));eko_hyb=0.d0
    endif
    eko_hyb(:,ik) = 0.0d0
    if(.not.present(update_eko))then
       eko_l(:,ik) = 0.d0
    else
       if(update_eko) eko_l(:,ik) = 0.d0
    endif
    allocate(vxw(kg1,kimg))
    !!if(modnrm == EXECUT) then
       allocate(efsr_l(np_e,nlmta));efsr_l=0.d0
       allocate(efsi_l(np_e,nlmta));efsi_l=0.d0
    !!end if
    wf_is_real = .not.allocated(fsi_l)
    if(modnrm == EXECUT) call get_expkt_fs(ik,fsr_l,fsi_l,efsr_l,efsi_l)

    !!write(nfout,'("m_ES_EXX_eigenvalue_for_each_k")')

    do ib=1,np_e   ! MPI
       !!write(nfout,'("ispin,ik,ib=",3i5)') ispin,ik,ib
       eko = 0.d0;exx=0.d0
       if (kimg==1) then
          call apply_Vx_to_WF( ispin, ib, ik, zaj_l(1,ib,ik,1), zaj_l(1,ib,ik,1), &
               &               efsr_l(ib,1:nlmta), efsr_l(ib,1:nlmta), vxw, exx )
          eexx_kb(ib,ik) = occup_l(ib,ik)*exx
          do ig=1,iba(ik)
             eko = eko + zaj_l(ig,ib,ik,1)*vxw(ig,1)
          end do
       else
          call apply_Vx_to_WF( ispin, ib, ik, zaj_l(1,ib,ik,1), zaj_l(1,ib,ik,2), &
               &               efsr_l(ib,1:nlmta), efsi_l(ib,1:nlmta), vxw, exx )
          eexx_kb(ib,ik) = occup_l(ib,ik)*exx
          if(k_symmetry(ik) == GAMMA) then
             do ig=2,iba(ik)
                eko = eko + zaj_l(ig,ib,ik,1) * vxw(ig,1) + zaj_l(ig,ib,ik,2) * vxw(ig,2)
             end do
             eko = eko * 2.d0 + zaj_l(1,ib,ik,1) * vxw(1,1)
          else
             do ig=1,iba(ik)
                eko = eko + zaj_l(ig,ib,ik,1)*vxw(ig,1) + zaj_l(ig,ib,ik,2)*vxw(ig,2)
             end do
          end if
       end if

       !Debug!write(nfout,'("ib=",i5," eko=",e20.8)') ib, eko

       if(.not.present(update_eko)) then
          eko_l(ib,ik) = eko_l(ib,ik) + eko
       else
          if(update_eko) eko_l(ib,ik) = eko_l(ib,ik) + eko
       endif
       eko_hyb(ib,ik) = eko
    end do

    deallocate(vxw)
    !!if(modnrm == EXECUT) then
       deallocate(efsr_l)
       deallocate(efsi_l)
    !!end if
   
    !!stop 'debug m_ES_EXX_eigenvalue_for_each_k'

    call tstatc0_end(id_sname)
  end subroutine m_ES_EXX_eigenvalue_for_each_k

  subroutine eigenvalue_for_each_k_rsb(ispin,ik,update_eko)
    implicit none
    integer, intent(in) :: ispin, ik
    logical,intent(in),optional :: update_eko

    integer :: ib,ig
    real(kind=DP) :: eko
    real(kind=DP), allocatable, dimension(:,:,:,:) :: vxw !d(kg1,kimg)
    real(kind=DP), allocatable, dimension(:,:) :: vxwt !d(kg1,kimg)
    real(kind=DP), allocatable :: efsr_l(:,:) ! d(np_e,nlmta)
    real(kind=DP), allocatable :: efsi_l(:,:) ! d(np_e,nlmta)
    real(kind=DP) :: exx
    integer,save  :: id_sname = -1
    call tstatc0_begin('eigenvalue_for_each_k_rsb ',id_sname,level=1)

    if(.not.allocated(eko_hyb))then
       allocate(eko_hyb(np_e,ista_k:iend_k));eko_hyb=0.d0
    endif

    eko_hyb(:,ik) = 0.0d0
    if(.not.present(update_eko))then
       eko_l(:,ik) = 0.d0
    else
       if(update_eko) eko_l(:,ik) = 0.d0
    endif
    allocate(vxw(kg1,np_e,ista_k:iend_k,kimg))
    allocate(vxwt(kg1,kimg))
    !!if(modnrm == EXECUT) then
       allocate(efsr_l(np_e,nlmta));efsr_l=0.d0
       allocate(efsi_l(np_e,nlmta));efsi_l=0.d0
    !!end if

    call UnitaryTransform_WF(INVERSE,ik,zaj_l,.true.,.true.)

    wf_is_real = .not.allocated(fsi_l)
    if(modnrm == EXECUT) call get_expkt_fs(ik,fsr_l,fsi_l,efsr_l,efsi_l)

    !!write(nfout,'("m_ES_EXX_eigenvalue_for_each_k")')

    do ib=1,np_e   ! MPI
       !!write(nfout,'("ispin,ik,ib=",3i5)') ispin,ik,ib
       eko = 0.d0;exx=0.d0
       if (kimg==1) then
          call apply_Vx_to_WF( ispin, ib, ik, zaj_l(1,ib,ik,1), zaj_l(1,ib,ik,1), &
               &               efsr_l(ib,1:nlmta), efsr_l(ib,1:nlmta), vxwt, exx )
          eexx_kb(ib,ik) = occup_l(ib,ik)*exx
          vxw(:,ib,ik,:) = vxwt(:,:)
          !do ig=1,iba(ik)
          !   eko = eko + zaj_l(ig,ib,ik,1)*vxw(ig,1)
          !end do
       else
          call apply_Vx_to_WF( ispin, ib, ik, zaj_l(1,ib,ik,1), zaj_l(1,ib,ik,2), &
               &               efsr_l(ib,1:nlmta), efsi_l(ib,1:nlmta), vxwt, exx )
          vxw(:,ib,ik,:) = vxwt(:,:)
          eexx_kb(ib,ik) = occup_l(ib,ik)*exx
          !if(k_symmetry(ik) == GAMMA) then
          !   do ig=2,iba(ik)
          !      eko = eko + zaj_l(ig,ib,ik,1) * vxw(ig,1) + zaj_l(ig,ib,ik,2) * vxw(ig,2)
          !   end do
          !   eko = eko * 2.d0 + zaj_l(1,ib,ik,1) * vxw(1,1)
          !else
          !   do ig=1,iba(ik)
          !      eko = eko + zaj_l(ig,ib,ik,1)*vxw(ig,1) + zaj_l(ig,ib,ik,2)*vxw(ig,2)
          !   end do
          !end if
       end if

       !Debug!write(nfout,'("ib=",i5," eko=",e20.8)') ib, eko

       !if(.not.present(update_eko)) then
       !   eko_l(ib,ik) = eko_l(ib,ik) + eko
       !else
       !   if(update_eko) eko_l(ib,ik) = eko_l(ib,ik) + eko
       !endif
       !eko_hyb(ib,ik) = eko
    end do

    call UnitaryTransform_WF(DIRECT,ik,vxw,.false.,.false.)
    call UnitaryTransform_WF(DIRECT,ik,zaj_l,.true.,.true.)
    do ib=1,np_e
       eko = 0.d0
       if(kimg==1)then
          do ig=1,iba(ik)
             eko = eko + zaj_l(ig,ib,ik,1)*vxw(ig,ib,ik,1)
          enddo
       else
          if(k_symmetry(ik) == GAMMA) then
             do ig=2,iba(ik)
                eko = eko + zaj_l(ig,ib,ik,1) * vxw(ig,ib,ik,1) + zaj_l(ig,ib,ik,2) * vxw(ig,ib,ik,2)
             end do
             eko = eko * 2.d0 + zaj_l(1,ib,ik,1) * vxw(1,ib,ik,1)
          else
             do ig=1,iba(ik)
                eko = eko + zaj_l(ig,ib,ik,1)*vxw(ig,ib,ik,1) + zaj_l(ig,ib,ik,2)*vxw(ig,ib,ik,2)
             end do
          end if
       endif
       if(.not.present(update_eko)) then
          eko_l(ib,ik) = eko_l(ib,ik) + eko
       else
          if(update_eko) eko_l(ib,ik) = eko_l(ib,ik) + eko
       endif
       eko_hyb(ib,ik) = eko
    enddo

    deallocate(vxw)
    deallocate(vxwt)
    !!if(modnrm == EXECUT) then
       deallocate(efsr_l)
       deallocate(efsi_l)
    !!end if
   
    !!stop 'debug m_ES_EXX_eigenvalue_for_each_k'

    call tstatc0_end(id_sname)
  end subroutine eigenvalue_for_each_k_rsb

  subroutine m_ES_EXX_cp_eigenvalue(ik)
     integer, intent(in) :: ik
     eko_l(1:np_e,ik) = eko_hyb(1:np_e,ik)
  end subroutine m_ES_EXX_cp_eigenvalue

  subroutine m_ES_EXX_Diagonal_part(ispin,ik,vxdi)
    implicit none
    integer, intent(in) :: ispin, ik
    real(kind=DP), intent(out), dimension(kg1) :: vxdi

    integer :: ib,ig
    integer :: ii,m,jkbz,kk,jk,jop,jtrs
    real(kind=DP) :: fac, occupation
    real(kind=DP), allocatable, dimension(:) :: rho, pot, vx, vxq !d(nfft)
    real(kind=DP), allocatable, dimension(:) :: rhor, rhoi !d(kg1)

    real(kind=DP), allocatable, dimension(:,:,:,:) :: vxdi_t

    integer,save  :: id_sname = -1
    call tstatc0_begin('m_ES_EXX_Diagonal_part ',id_sname,level=1)


    allocate(rho(nfft))
    allocate(pot(nfft))
    allocate(vx(nfft)); vx = 0.d0
    allocate(vxq(nfft))
    allocate(rhor(nmax_G_hyb)); rhor = 0.d0
    allocate(rhoi(nmax_G_hyb)); rhoi = 0.d0

    ! rho(G) = sum_q sum_m |phi_m(q+G)|^2
    do jkbz=1,kv3bz
       if(.not.q_on_k_centered_mesh(jkbz,ik)) cycle
       ! q(bz) = S*k(ibz)
       kk = ikp(jkbz) + ispin - 1
       jop = iopt(jkbz)
       jtrs = itrs(jkbz)
       !Debug!write(nfout,'("jkbz=",i5," kk=",i5," jop=",i5," jtrs=",i5)') jkbz,kk,jop,jtrs
! === DEBUB by tkato 2013/02/21 ================================================
       rhor = 0.0d0
       rhoi = 0.0d0
! ==============================================================================
       do m=1,nval
          if(occup_val(m,kk) < DELTA) cycle
          occupation = wbz(jkbz)*occup_val(m,kk)/qwgt(kk)/dble(kv3)
          if(kimg==1) then
             do ii=1,iba(kk)
                rhor(ii) = rhor(ii) + occupation * ( wfv(ii,m,kk,1) * wfv(ii,m,kk,1) )
             end do
          else
             do ii=1, min( iba(kk), nmax_G_hyb )
                rhor(ii) = rhor(ii) + occupation * ( wfv(ii,m,kk,1) * wfv(ii,m,kk,1) &
                                                 & + wfv(ii,m,kk,2) * wfv(ii,m,kk,2) )
             end do
          end if
       end do
       call map_Rot_WFG_on_FFT_box(kk,jop,jtrs,rhor,rhoi,rho)
       call m_FFT_WF(ELECTRON,nfout,rho,INVERSE,OFF) ! rho(R)

       do ii=1, min( kg, nmax_G_hyb )
          rhor(ii) = vc(ii,iqmk(jkbz,ik))
          rhoi(ii) = 0.d0
       end do
       call map_RHOG_on_FFT_box(rhor,rhoi,pot)
       call m_FFT_WF(ELECTRON,nfout,pot,INVERSE,OFF) ! pot(R)

       call product_on_FFT_box(pot,rho,vxq) ! vx(R)
       vx = vx + vxq
    end do

    call m_FFT_WF(ELECTRON,nfout,vx,DIRECT,OFF) ! vx(G)
    call map_FFT_box_on_RHOG(rhor,rhoi,vx) 
    fac = 1.d0/dble(nfftwf)
    vxdi = 0.0d0
    do ii=1,iba(ik)
       ig = nbase(ii,ik)
       if ( ig <= nmax_G_hyb ) then
          vxdi(ii) = fac * rhor(ig)
       endif
    end do
 
    deallocate(rho)
    deallocate(pot)
    deallocate(vx)
    deallocate(rhor)
    deallocate(rhoi)

    call tstatc0_end(id_sname)
  end subroutine m_ES_EXX_Diagonal_part

  subroutine m_ES_EXX_add_Diagonal_part(ik,ibo,vxdi,vnldi)
    implicit none
    integer, intent(in) :: ik, ibo
    real(kind=DP), intent(in), dimension(kg1) :: vxdi
    real(kind=DP), intent(out), dimension(kg1) :: vnldi

    integer :: ib

    ib = map_z(ibo)
    vnldi = vnldi + vxdi
  end subroutine m_ES_EXX_add_Diagonal_part

  subroutine m_ES_Vexx_W(ik)
    implicit none
    integer, intent(in) :: ik

    integer :: ib,ig,ispin
    real(kind=DP), allocatable, dimension(:,:) :: vxw !d(kg1,kimg)
    real(kind=DP), allocatable :: efsr_l(:,:) ! d(np_e,nlmta)
    real(kind=DP), allocatable :: efsi_l(:,:) ! d(np_e,nlmta)
    integer,save  :: id_sname = -1
    if(sw_rsb==ON)then
       call Vexx_W_rsb(ik) 
       return
    endif
    call tstatc0_begin('m_ES_Vexx_W ',id_sname,level=1)

    ispin = mod(ik-1,nspin)+1

    allocate(vxw(kg1,kimg))
    !!if(modnrm == EXECUT) then
       allocate(efsr_l(np_e,nlmta));efsr_l=0.d0
       allocate(efsi_l(np_e,nlmta));efsi_l=0.d0
    !!end if
    wf_is_real = .not.allocated(fsi_l)
    if(modnrm == EXECUT) call get_expkt_fs(ik,fsr_l,fsi_l,efsr_l,efsi_l)

    !!write(nfout,'("m_ES_Vexx_W")')

    do ib=1,np_e   ! MPI
       !!write(nfout,'("ik,ib=",3i5)') ik,ib
       if(kimg==1) then
          call apply_Vx_to_WF( ispin, ib, ik, zaj_l(1,ib,ik,1), zaj_l(1,ib,ik,1), &
               &               efsr_l(ib,1:nlmta), efsr_l(ib,1:nlmta), vxw )
          do ig=1,iba(ik)
             vnlph_l(ig,ib,1) = vnlph_l(ig,ib,1) + vxw(ig,1)
          end do
       else
          call apply_Vx_to_WF( ispin, ib, ik, zaj_l(1,ib,ik,1), zaj_l(1,ib,ik,2), &
               &               efsr_l(ib,1:nlmta), efsi_l(ib,1:nlmta), vxw )
          do ig=1,iba(ik)
             vnlph_l(ig,ib,1) = vnlph_l(ig,ib,1) + vxw(ig,1)
             vnlph_l(ig,ib,2) = vnlph_l(ig,ib,2) + vxw(ig,2)
          end do
       end if 
    end do

    deallocate(vxw)
    !!if(modnrm == EXECUT) then
       deallocate(efsr_l)
       deallocate(efsi_l)
    !!end if

    call tstatc0_end(id_sname)
  end subroutine m_ES_Vexx_W

  subroutine Vexx_W_rsb(ik)
    implicit none
    integer, intent(in) :: ik

    integer :: ib,ig,ispin
    real(kind=DP), allocatable, dimension(:,:) :: vxwt !d(kg1,kimg)
    real(kind=DP), allocatable, dimension(:,:,:,:) :: vxw !d(kg1,kimg)
    real(kind=DP), allocatable :: efsr_l(:,:) ! d(np_e,nlmta)
    real(kind=DP), allocatable :: efsi_l(:,:) ! d(np_e,nlmta)
    integer,save  :: id_sname = -1
    call tstatc0_begin('m_ES_Vexx_W ',id_sname,level=1)

    ispin = mod(ik-1,nspin)+1

    allocate(vxw(kg1,np_e,ista_k:iend_k,kimg))
    allocate(vxwt(kg1,kimg))
    call UnitaryTransform_WF(INVERSE,ik,zaj_l,.true.,.true.)

    !!if(modnrm == EXECUT) then
       allocate(efsr_l(np_e,nlmta));efsr_l=0.d0
       allocate(efsi_l(np_e,nlmta));efsi_l=0.d0
    !!end if
    wf_is_real = .not.allocated(fsi_l)
    if(modnrm == EXECUT) call get_expkt_fs(ik,fsr_l,fsi_l,efsr_l,efsi_l)

    !!write(nfout,'("m_ES_Vexx_W")')

    do ib=1,np_e   ! MPI
       !!write(nfout,'("ik,ib=",3i5)') ik,ib
       if(kimg==1) then
          call apply_Vx_to_WF( ispin, ib, ik, zaj_l(1,ib,ik,1), zaj_l(1,ib,ik,1), &
               &               efsr_l(ib,1:nlmta), efsr_l(ib,1:nlmta), vxwt )
          vxw(:,ib,ik,:) = vxwt(:,:)
       else
          call apply_Vx_to_WF( ispin, ib, ik, zaj_l(1,ib,ik,1), zaj_l(1,ib,ik,2), &
               &               efsr_l(ib,1:nlmta), efsi_l(ib,1:nlmta), vxwt )
          vxw(:,ib,ik,:) = vxwt(:,:)
       end if 
       !if(kimg==2) vxw(:,ib,ista_k,2) = -vxw(:,ib,ista_k,2)
    end do

    ! vxw to submat space
    call UnitaryTransform_WF(DIRECT,ik,vxw,.false.,.false.)

    do ib=1,np_e
       if(kimg==1)then
          do ig=1,iba(ik)
             vnlph_l(ig,ib,1) = vnlph_l(ig,ib,1) + vxw(ig,ib,ik,1)
          end do
       else
          do ig=1,iba(ik)
             vnlph_l(ig,ib,1) = vnlph_l(ig,ib,1) + vxw(ig,ib,ik,1)
             vnlph_l(ig,ib,2) = vnlph_l(ig,ib,2) + vxw(ig,ib,ik,2)
          end do
       endif
    enddo

    call UnitaryTransform_WF(DIRECT,ik,zaj_l,.true.,.true.)
    deallocate(vxwt)
    deallocate(vxw)
    !!if(modnrm == EXECUT) then
       deallocate(efsr_l)
       deallocate(efsi_l)
    !!end if

    call tstatc0_end(id_sname)
  end subroutine Vexx_W_rsb

  subroutine m_ES_Vexx_W_RMM_rsb(ik,vxwout)
    integer, intent(in) :: ik
    real(kind=DP),dimension(kg1,np_e,kimg),intent(out) :: vxwout

    integer :: ib,ig,ispin
    real(kind=DP), allocatable, dimension(:,:,:,:) :: vxw !d(kg1,kimg)
    real(kind=DP), allocatable, dimension(:,:) :: vxwt !d(kg1,kimg)
    real(kind=DP), allocatable :: efsr_l(:,:) ! d(np_e,nlmta)
    real(kind=DP), allocatable :: efsi_l(:,:) ! d(np_e,nlmta)
    integer,save  :: id_sname = -1
    call tstatc0_begin('m_ES_Vexx_W_RMM ',id_sname,level=1)

    ispin = mod(ik-1,nspin)+1

    wf_is_real = .not.allocated(fsi_l)
    allocate(vxw(kg1,np_e,ista_k:iend_k,kimg));vxw=0.d0
    allocate(vxwt(kg1,kimg));vxwt=0.d0
    !wf to rsb-space
    call UnitaryTransform_WF(INVERSE,ik,zaj_l,.true.,.true.)
    !!if(modnrm == EXECUT) then
       allocate(efsr_l(np_e,nlmta))
       allocate(efsi_l(np_e,nlmta))
       call get_expkt_fs(ik,fsr_l,fsi_l,efsr_l,efsi_l)
    !!end if
    !if(modnrm == EXECUT) call get_expkt_fs(ik,fsr_l,fsi_l,efsr_l,efsi_l)

    do ib=1,np_e
       if(kimg==1) then
          call apply_Vx_to_WF( ispin, ib, ik, zaj_l(1,ib,ik,1), zaj_l(1,ib,ik,1), &
               &               efsr_l(ib,1:nlmta), efsr_l(ib,1:nlmta), vxwt )
          vxw(:,ib,ik,:) = vxwt(:,:)
       else
          call apply_Vx_to_WF( ispin, ib, ik, zaj_l(1,ib,ik,1), zaj_l(1,ib,ik,2), &
               &               efsr_l(ib,1:nlmta), efsi_l(ib,1:nlmta), vxwt )
          vxw(:,ib,ik,:) = vxwt(:,:)
       end if
    enddo

    ! vxw & wf to submat space
    call UnitaryTransform_WF(DIRECT,ik,vxw,.false.,.false.)
    call UnitaryTransform_WF(DIRECT,ik,zaj_l,.true.,.true.)

    vxwout(:,:,:) = vxw(:,:,ik,:)

    deallocate(vxwt)
    deallocate(vxw)
    !!if(modnrm == EXECUT) then
       deallocate(efsr_l)
       deallocate(efsi_l)
    !!end if

    call tstatc0_end(id_sname)
  end subroutine m_ES_Vexx_W_RMM_rsb

  subroutine m_ES_Vexx_add_vexx(ik,ibo,vxw_exx)
    integer, intent(in) :: ik,ibo
    real(kind=DP),dimension(kg1,np_e,kimg),intent(in) :: vxw_exx
    integer :: ib
    ib = map_z(ibo)
    vnlph_l(:,ib,:) = vnlph_l(:,ib,:)+vxw_exx(:,ib,:)
  end subroutine m_ES_Vexx_add_vexx

  subroutine m_ES_Vexx_W_RMM(ik,ibo)
    implicit none
    integer, intent(in) :: ik, ibo

    integer :: ib,ig,ispin
    real(kind=DP), allocatable, dimension(:,:) :: vxw !d(kg1,kimg)
    real(kind=DP), allocatable :: efsr_l(:,:) ! d(np_e,nlmta)
    real(kind=DP), allocatable :: efsi_l(:,:) ! d(np_e,nlmta)
    integer,save  :: id_sname = -1
    call tstatc0_begin('m_ES_Vexx_W_RMM ',id_sname,level=1)

    ispin = mod(ik-1,nspin)+1

    wf_is_real = .not.allocated(fsi_l)
    allocate(vxw(kg1,kimg))
    !!if(modnrm == EXECUT) then
       allocate(efsr_l(np_e,nlmta))
       allocate(efsi_l(np_e,nlmta))
       call get_expkt_fs(ik,fsr_l,fsi_l,efsr_l,efsi_l)
    !!end if
    if(modnrm == EXECUT) call get_expkt_fs(ik,fsr_l,fsi_l,efsr_l,efsi_l)

    ib = map_z(ibo)        ! MPI

    if(kimg==1) then
       call apply_Vx_to_WF( ispin, ib, ik, zaj_l(1,ib,ik,1), zaj_l(1,ib,ik,1), &
            &               efsr_l(ib,1:nlmta), efsr_l(ib,1:nlmta), vxw )
       do ig=1,iba(ik)
          vnlph_l(ig,ib,1) = vnlph_l(ig,ib,1) + vxw(ig,1)
       end do
    else
       call apply_Vx_to_WF( ispin, ib, ik, zaj_l(1,ib,ik,1), zaj_l(1,ib,ik,2), &
            &               efsr_l(ib,1:nlmta), efsi_l(ib,1:nlmta), vxw )
       do ig=1,iba(ik)
          vnlph_l(ig,ib,1) = vnlph_l(ig,ib,1) + vxw(ig,1)
          vnlph_l(ig,ib,2) = vnlph_l(ig,ib,2) + vxw(ig,2)
       end do
    end if

    deallocate(vxw)
    !!if(modnrm == EXECUT) then
       deallocate(efsr_l)
       deallocate(efsi_l)
    !!end if

    call tstatc0_end(id_sname)
  end subroutine m_ES_Vexx_W_RMM

  subroutine m_ES_Vexx_energy(vexx)
    implicit none
    real(kind=DP), intent(out) :: vexx

    integer :: ik,ib,ig,ispin
    real(kind=DP) :: ve, vexx_mpi
    real(kind=DP), allocatable, dimension(:,:) :: vxw !d(kg1,kimg)
    real(kind=DP), allocatable :: efsr_l(:,:) ! d(np_e,nlmta)
    real(kind=DP), allocatable :: efsi_l(:,:) ! d(np_e,nlmta)
    integer,save  :: id_sname = -1
    call tstatc0_begin('m_ES_Vexx_energy ',id_sname,level=1)

    if(.not.allocated(eexx_kb)) allocate(eexx_kb(np_e,ista_k:iend_k))
    eexx_kb = 0.0d0
    call m_FFT_alloc_WF_work()
    allocate(vxw(kg1,kimg))
    !!if(modnrm == EXECUT) then
       allocate(efsr_l(np_e,nlmta));efsr_l=0.d0
       allocate(efsi_l(np_e,nlmta));efsi_l=0.d0
    !!end if

    !!write(nfout,'("m_ES_Vexx_energy")')

    vexx = 0.d0
    wf_is_real = .not.allocated(fsi_l)
    do ispin=1,nspin,af+1
       do ik=ispin, kv3+ispin-nspin, nspin
          if(map_k(ik) /= myrank_k) cycle ! MPI
          if(modnrm == EXECUT) call get_expkt_fs(ik,fsr_l,fsi_l,efsr_l,efsi_l)
          do ib=1,np_e   ! MPI
             if(occup_l(ib,ik) < DELTA) cycle
             !!write(nfout,'("ispin,ik,ib=",3i5)') ispin,ik,ib
             ve = 0.d0
             if(kimg==1) then
                call apply_Vx_to_WF( ispin, ib, ik, zaj_l(1,ib,ik,1), zaj_l(1,ib,ik,1),&
                     &               efsr_l(ib,1:nlmta), efsr_l(ib,1:nlmta), vxw )
                do ig=1,iba(ik)
                   ve = ve + zaj_l(ig,ib,ik,1) * vxw(ig,1)
                end do
             else
                call apply_Vx_to_WF( ispin, ib, ik, zaj_l(1,ib,ik,1), zaj_l(1,ib,ik,2), &
                     &               efsr_l(ib,1:nlmta), efsi_l(ib,1:nlmta), vxw )

                if(k_symmetry(ik) == GAMMA) then
                   do ig=2,iba(ik)
                      ve = ve + zaj_l(ig,ib,ik,1) * vxw(ig,1) + zaj_l(ig,ib,ik,2) * vxw(ig,2)
                   end do
                   ve = ve * 2.d0 + zaj_l(1,ib,ik,1) * vxw(1,1)
                else
                   do ig=1,iba(ik)
                      ve = ve + zaj_l(ig,ib,ik,1) * vxw(ig,1) + zaj_l(ig,ib,ik,2) * vxw(ig,2)
                   end do
                end if
             end if
             vexx = vexx + occup_l(ib,ik) * ve
             eexx_kb(ib,ik) = occup_l(ib,ik) * ve
          end do
       end do
    end do

    vexx = vexx / dble(kv3/nspin)
    if(nspin==1) vexx = 2.d0 * vexx
    
    deallocate(vxw)
    !!if(modnrm == EXECUT) then
       deallocate(efsr_l)
       deallocate(efsi_l)
    !!end if
    call m_FFT_dealloc_WF_work()

    if(npes>1) then
       call mpi_allreduce(vexx,vexx_mpi,1,MPI_DOUBLE_PRECISION,MPI_SUM,mpi_comm_group,ierr)
       vexx = vexx_mpi
    end if

    call tstatc0_end(id_sname)
  end subroutine m_ES_Vexx_energy

  subroutine apply_Vx_to_WF(ispin,ib,ik,wfr,wfi,bdwr,bdwi,vxw,eexx)
    implicit none
    integer, intent(in)                       :: ispin, ib,ik
    real(kind=DP), intent(in), dimension(kg1) :: wfr, wfi
    real(kind=DP), intent(in), dimension(nlmta) :: bdwr, bdwi
    real(kind=DP), intent(out), dimension(kg1,kimg) :: vxw
    real(kind=DP), intent(out), optional :: eexx
    real(kind=DP) :: exx
    integer :: kk,m,ig,ii,jop,kop,jtrs
    integer :: jkbz
    real(kind=DP) :: fac, ph, occupation, dnorm
    real(kind=DP) :: skg(3)
    real(kind=DP), allocatable, dimension(:) :: rho,phi !d(nfft)
    real(kind=DP), allocatable, dimension(:) :: wfn,wfm !d(nfft)
    real(kind=DP), allocatable, dimension(:) :: sumdel !d(nfft)
    real(kind=DP), allocatable, dimension(:) :: rhogr, rhogi !d(kgp)
    real(kind=DP), allocatable, dimension(:) :: wfsr,wfsi !d(kg1)
    real(kind=DP), allocatable, dimension(:) :: cosgt, singt !d(kg1)
    real(kind=DP), allocatable, dimension(:) :: fsr, fsi !d(nlmta)
    real(kind=DP), allocatable, dimension(:) :: qvr, qvi !d(nlmta)
    real(kind=DP), allocatable, dimension(:) :: sumqvr, sumqvi !d(nlmta)
    real(kind=DP), allocatable, dimension(:) :: rhor,rhoi
    real(kind=DP), allocatable, dimension(:) :: afft
    real(kind=DP) :: ifac
    integer,save  :: id_sname = -1,id_sname1=-2,id_sname2=-3,id_sname3=-4
    call tstatc0_begin('apply_Vx_to_WF ',id_sname,1)

    allocate(rho(nfft))
    allocate(phi(nfft))
    allocate(wfn(nfft))
    allocate(wfm(nfft))
    allocate(sumdel(nfft))
    allocate(rhogr(nmax_G_hyb))
    if(sw_rspace_hyb==ON)then
       allocate(rhor(nfftp_nonpara/2));rhor=0.d0
       allocate(rhoi(nfftp_nonpara/2));rhoi=0.d0
       allocate(afft(nfftp_nonpara));afft=0.d0
    endif
    if(kimg==2) allocate(rhogi(nmax_G_hyb))
    allocate(wfsr(kg1))
    if(kimg==2) allocate(wfsi(kg1))
    allocate(cosgt(kg1))
    if(kimg==2) allocate(singt(kg1))
    if(modnrm == EXECUT) then
       allocate(fsr(nlmta))
!       if(k_symmetry(ik) /= GAMMA) allocate(fsi(nlmta))
       allocate(fsi(nlmta))

       allocate(qvr(nlmta))
!       if(k_symmetry(ik) /= GAMMA) allocate(qvi(nlmta))
       allocate(qvi(nlmta))

       allocate(sumqvr(nlmta))
!       if(k_symmetry(ik) /= GAMMA) allocate(sumqvi(nlmta))
       allocate(sumqvi(nlmta))

       fac = 1.d0/dble(nfftwf)
       sumqvr = 0.d0
!       if(k_symmetry(ik) /= GAMMA) sumqvi = 0.d0
       sumqvi = 0.d0
    end if

    call map_WFG_on_FFT_box(ik,wfr,wfi,wfn)
    call m_FFT_WF(ELECTRON,nfout,wfn,INVERSE,OFF) ! wfn(R)

    sumdel = 0.d0
    do jkbz=1,kv3bz
       if(.not.q_on_k_centered_mesh(jkbz,ik)) cycle
       ! q(bz) = S*k(ibz)
       kk = ikp(jkbz) + ispin - 1
       kop = iops(jkbz)
       jop = iopt(jkbz) 
       jtrs = itrs(jkbz)
!! Debug
!!       if(check_bz_k(jkbz)) cycle
!!
       !Debug!  write(nfout,'("jkbz=",i5," kk=",i5," jop=",i5," jtrs=",i5)') jkbz,kk,jop,jtrs
       if(kimg==1) then
          do ig=1,iba(kk)
             ii = nbase(ig,kk)
             skg(1:3) = vkxyz(kk,1:3,BUCS) + ngabc(ii,1:3)
             ph = PAI2 * dot_product(skg,tau(:,kop,BUCS))
             cosgt(ig) = cos(ph)
          end do
       else
          do ig=1,iba(kk)
             ii = nbase(ig,kk)
             skg(1:3) = vkxyz(kk,1:3,BUCS) + ngabc(ii,1:3)
             ph = PAI2 * dot_product(skg,tau(:,kop,BUCS))
             cosgt(ig) = cos(ph)
             singt(ig) = sin(ph)
          end do
       end if
       do m=1,nval
          if(occup_val(m,kk) < DELTA) cycle
          if(sw_rsb==ON)then
             if(.not.overlap(ib,m))cycle
          endif
          occupation = wbz(jkbz) * occup_val(m,kk)/qwgt(kk)/dble(kv3)
          !Debug!write(nfout,'("m=",i5," occp=",f15.5)') m, occupation
          if(kimg==1) then
             dnorm = 0.d0
             do ig=1,iba(kk)
                wfsr(ig) = wfv(ig,m,kk,1) * cosgt(ig)  
                dnorm = dnorm + wfsr(ig)*wfsr(ig)
             end do
             dnorm = 1.d0/sqrt(dnorm)
             wfsr = wfsr * dnorm
             call map_Rot_WFG_on_FFT_box(kk,jop,jtrs,wfsr,wfsr,wfm)
          else
             if(jtrs==0) then
                do ig=1,iba(kk)
                   wfsr(ig) = wfv(ig,m,kk,1) * cosgt(ig) - wfv(ig,m,kk,2) * singt(ig)
                   wfsi(ig) = wfv(ig,m,kk,2) * cosgt(ig) + wfv(ig,m,kk,1) * singt(ig)
                end do
             else
                do ig=1,iba(kk)
                   wfsr(ig) = wfv(ig,m,kk,1) * cosgt(ig) - wfv(ig,m,kk,2) * singt(ig)
                   wfsi(ig) = -wfv(ig,m,kk,2) * cosgt(ig) - wfv(ig,m,kk,1) * singt(ig)
                end do
             end if
             call map_Rot_WFG_on_FFT_box(kk,jop,jtrs,wfsr,wfsi,wfm)
          end if
          call m_FFT_WF(ELECTRON,nfout,wfm,INVERSE,OFF) ! wfm(R)
          call product_on_FFT_box(wfn,wfm,rho) ! rho_soft(R)
          call m_FFT_WF(ELECTRON,nfout,rho,DIRECT,OFF) ! rho_soft(G)

          if(kimg==1) then
             call map_FFT_box_on_RHOG(rhogr,rhogr,rho)
             do ii=1,nmax_G_hyb
                rhogr(ii) = vc(ii,iqmk(jkbz,ik)) * rhogr(ii) ! phi(G) = Vc(G,q) * rho(G)
             end do
             call map_RHOG_on_FFT_box(rhogr,rhogr,phi)
          else
             call map_FFT_box_on_RHOG(rhogr,rhogi,rho)
             !! rho(G) = rho_soft(G) + rho_hard(G)
             if(modnrm == EXECUT) then
!!$                call tstatc0_begin('hardpart, part 1 ',id_sname1,1)
                do ii=1, min( kg, nmax_G_hyb )
                   rhogr(ii) = fac * rhogr(ii)
                   rhogi(ii) = fac * rhogi(ii)
                end do
                do ii=kg+1, nmax_G_hyb
                   rhogr(ii) = 0.d0
                   rhogi(ii) = 0.d0
                end do
            ! debug
            !!  write(nfout,*) 'm=',m
            !!  write(nfout,*) 'soft rhogr(1)=',rhogr(1)
            !!  write(nfout,*) 'soft rhogi(1)=',rhogi(1)
            ! end debug
                !!fsr(1:nlmta) = fsr_exx(m,1:nlmta,kk)
                !!fsi(1:nlmta) = fsi_exx(m,1:nlmta,kk)
                if(sw_rspace_hyb==OFF .or. (sw_rspace_hyb==ON .and. sw_precalculate==OFF)) &
               &   call get_Rot_betar_dot_WFs(kk,m,jop,kop,jtrs,fsr,fsi)
!! Debug
!                write(nfout,'("jkbz=",i5," kk=",i5," jop=",i5," m=",i5)') jkbz, kk, jop, m
!                do ii=1,nlmta
!                   write(nfout,'("ilmta1=",i5," fsr=",f20.5," fsi=",f20.5)') &
!                    & ii,fsr(ii),fsi(ii)
!                end do
!! End Debug
#ifdef HYB_ORG
                call add_RHOG_hard_part(iqmk(jkbz,ik),rhogr,rhogi,bdwr,bdwi,fsr,fsi)
#else
! ====================== KT_Test ================================ 12.5Exp
!                call add_RHOG_hard_part2(iqmk(jkbz,ik),rhogr,rhogi,bdwr,bdwi,fsr,fsi)
!
                if(sw_rspace_hyb==ON)then
                   if(sw_precalculate==OFF)then
                      call add_RHOG_hard_part_rs(iqmk(jkbz,ik),rhor,rhoi,bdwr,bdwi,fsr,fsi)
                   else
                      call add_RHOG_hard_part_rs2(iqmk(jkbz,ik),rhor,rhoi,&
                     & fsrqm(:,:,m,jkbz,ispin),fsiqm(:,:,m,jkbz,ispin),bdwr,bdwi)
                   endif
                   call map_RHOG_on_FFT_box_hard(rhor,rhoi,afft)
                   call m_FFT_CD0(nfout,afft,DIRECT)
                   call map_FFT_box_on_RHOG_hard(rhor,rhoi,afft)
                   do ii=1,nmax_G_hyb
                      rhogr(ii) = rhogr(ii) + rhor(ii)
                      rhogi(ii) = rhogi(ii) + rhoi(ii)
                   end do
                else
                   call add_RHOG_hard_part2A(iqmk(jkbz,ik),rhogr,rhogi,bdwr,bdwi,fsr,fsi)
                endif
! =============================================================== 12.5Exp
#endif
            ! debug
            !!  write(nfout,*) 'm=',m
            !!  write(nfout,*) 'soft+hard rhogr(1)=',rhogr(1)
            !!  write(nfout,*) 'soft+hard rhogi(1)=',rhogi(1)
            ! end debug
!!$                call tstatc0_end(id_sname1)
             end if
             if(present(eexx))then
                call sum_rho_vc_rho(rhogr,rhogi,vc(1,iqmk(jkbz,ik)),exx)
                eexx = eexx + occupation * exx
             endif
             do ii=1,nmax_G_hyb
                rhogr(ii) = vc(ii,iqmk(jkbz,ik)) * rhogr(ii) ! phi(G) = Vc(G,q) * rho(G)
                rhogi(ii) = vc(ii,iqmk(jkbz,ik)) * rhogi(ii) ! phi(G) = Vc(G,q) * rho(G)
             end do
             !! Dij[Vnm] = Sum_G Qij(G) * Vnm(G)
             !! Hi[Vnm] = Sum_j Dij[Vnm] <beta_j|psi_m>
#ifdef HYB_ORG
             if(modnrm == EXECUT) call integrate_QijVnm(iqmk(jkbz,ik),rhogr,rhogi,fsr,fsi,qvr,qvi)
#else
! ====================== KT_Test ================================ 12.5Exp
!             if (modnrm == EXECUT) call integrate_QijVnm2(iqmk(jkbz,ik),rhogr,rhogi,fsr,fsi,qvr,qvi)
!
             if (modnrm == EXECUT) then
!!$                call tstatc0_begin('hardpart, part 2 ',id_sname2,1)
                if(sw_rspace_hyb==ON)then
                   call map_RHOG_on_FFT_box_hard_inv(rhogr,rhogi,afft)
                   call m_FFT_CD0(nfout,afft,INVERSE)
                   call map_FFT_box_on_RHOG_hard_inv(rhor,rhoi,afft)
                   if(sw_precalculate==OFF)then
                      call integrate_QijVnm_rs(iqmk(jkbz,ik),rhor,rhoi,fsr,fsi,qvr,qvi)
                   else
                      call integrate_QijVnm_rs2(iqmk(jkbz,ik),rhor,rhoi, &
                    & fsrqm(:,:,m,jkbz,ispin),fsiqm(:,:,m,jkbz,ispin),qvr,qvi)
                   endif
                else
                   call integrate_QijVnm2A(iqmk(jkbz,ik),rhogr,rhogi,fsr,fsi,qvr,qvi)
                endif
!!$                call tstatc0_end(id_sname2)
             endif
! =============================================================== 12.5Exp
#endif
             call map_RHOG_on_FFT_box(rhogr,rhogi,phi)
          end if

          call m_FFT_WF(ELECTRON,nfout,phi,INVERSE,OFF) ! phi(R)
          call product_on_FFT_box(phi,wfm,rho) ! delta(R)
          sumdel = sumdel + occupation * rho ! sum delta(R)
          !! Bin = Sum_m fm * Hi[Vnm]
          if(modnrm == EXECUT) then
             sumqvr = sumqvr + occupation * qvr ! sum_m qvr_m
             sumqvi = sumqvi + occupation * qvi ! sum_m qvi_m
          end if
       end do 
    end do 
    call m_FFT_WF(ELECTRON,nfout,sumdel,DIRECT,OFF) ! sum delta(G)
    if(kimg==1) then
       call map_FFT_box_on_WFG(ik,vxw(1,1),vxw(1,1),sumdel)
    else
       call map_FFT_box_on_WFG(ik,vxw(1,1),vxw(1,2),sumdel)
    end if

    if(modnrm == EXECUT)  then
       fac = 1.d0/dble(nfftwf)
    else
       fac = 1.d0/dble(nfftwf)**2
    end if
    vxw = fac*vxw
    !! Vx|psi_n> = Vx_soft|psi_n> + Sum_i |beta_i> Bin
    !write(nfout,'("sumqvr=")')
    !write(nfout,'(5f10.5)') sumqvr
    !write(nfout,'("sumqvi=")')
    !write(nfout,'(5f10.5)') sumqvi
    if(modnrm == EXECUT) then
!!$       call tstatc0_begin('hardpart, part 3 ',id_sname3,1)
       call add_Vx_hard_part(ik,vxw,sumqvr,sumqvi)
!!$       call tstatc0_end(id_sname3)
    endif

    deallocate(rho)
    deallocate(phi)
    deallocate(wfn)
    deallocate(wfm)
    deallocate(sumdel)
    deallocate(rhogr)
    if(kimg==2) deallocate(rhogi)
    deallocate(wfsr)
    if(kimg==2) deallocate(wfsi)
    deallocate(cosgt)
    if(kimg==2) deallocate(singt)
    if(modnrm == EXECUT) then
       deallocate(fsr)
!       if(k_symmetry(ik) /= GAMMA) deallocate(fsi)
       if(allocated(fsi)) deallocate(fsi)

       deallocate(qvr)
!       if(k_symmetry(ik) /= GAMMA) deallocate(qvi)
       if(allocated(qvi)) deallocate(qvi)

       deallocate(sumqvr)
!       if(k_symmetry(ik) /= GAMMA) deallocate(sumqvi)
       if(allocated(sumqvi)) deallocate(sumqvi)
    end if

    if(sw_rspace_hyb==ON)then
       deallocate(rhor)
       deallocate(rhoi)
       deallocate(afft)
    endif
    !!stop 'Debug: apply_Vx_to_WF'

    call tstatc0_end(id_sname)
  end subroutine apply_Vx_to_WF

  subroutine m_ES_EXX_energy2(eexx)
    implicit none
    real(kind=DP), intent(out) :: eexx
    real(kind=DP) :: fac,eexx_mpi
    integer :: ispin,ik,ib,ib1,ierr
    eexx = 0.0d0
    do ispin=1,nspin,af+1
       do ik=ispin, kv3+ispin-nspin, nspin
          if(map_k(ik) /= myrank_k) cycle ! MPI
          do ib=1,np_e   ! MPI
             if(occup_l(ib,ik) < DELTA) cycle
             eexx = eexx + eexx_kb(ib,ik)
          enddo
       enddo
    enddo
    eexx = eexx/dble(kv3/nspin)
    if(modnrm == EXECUT) then
       fac = 0.5d0
    else
       fac = 0.5d0/dble(nfftwf)**2
    end if
    eexx = fac * eexx
    if(nspin==1) eexx = 2.d0 * eexx

    if(npes>1) then
       call mpi_allreduce(eexx,eexx_mpi,1,MPI_DOUBLE_PRECISION,MPI_SUM,mpi_comm_group,ierr)
       eexx = eexx_mpi
    end if

  end subroutine m_ES_EXX_energy2

  subroutine m_ES_EXX_energy(eexx)
    implicit none
    real(kind=DP), intent(out) :: eexx

    integer :: jk
    integer :: ispin,ik,ib,ib1
    real(kind=DP) :: fac, ex, eexx_mpi, f0, f1
    real(kind=DP), allocatable , dimension(:) :: rho,phi !d(nfft)
    real(kind=DP), allocatable, dimension(:) :: wfn,wfm !d(nfft)
    real(kind=DP), allocatable, dimension(:) :: rhogr,rhogi ! d(kgp)
    real(kind=DP), allocatable, dimension(:) :: wfsr,wfsi !d(kg1)
    real(kind=DP), allocatable, dimension(:) :: cosgt, singt !d(kg1)
    real(kind=DP), allocatable, dimension(:) :: fsr, fsi !d(nlmta)
    real(kind=DP), allocatable :: efsr_l(:,:) ! d(np_e,nlmta)
    real(kind=DP), allocatable :: efsi_l(:,:) ! d(np_e,nlmta)
    integer,save  :: id_sname = -1
    call tstatc0_begin('m_ES_EXX_energy ',id_sname,level=1)

    call m_FFT_alloc_WF_work()

    allocate(rho(nfft))
    allocate(phi(nfft))
    allocate(wfn(nfft))
    allocate(wfm(nfft))
    allocate(rhogr(nmax_G_hyb))
    if(kimg==2) allocate(rhogi(nmax_G_hyb))
    allocate(wfsr(kg1))
    if(kimg==2) allocate(wfsi(kg1))
    allocate(cosgt(kg1))
    if(kimg==2) allocate(singt(kg1))
    !!if(modnrm == EXECUT) then
       allocate(efsr_l(np_e,nlmta));efsr_l=0.d0
       allocate(efsi_l(np_e,nlmta));efsi_l=0.d0
    !!end if
    if(modnrm == EXECUT) then
       allocate(fsr(nlmta));fsr=0.d0
       allocate(fsi(nlmta));fsi=0.d0
       f0 = 1.d0/dble(nfftwf)
       f1 = 0.d0/dble(product(fft_box_size_CD(1:3,1)))
    end if

    eexx = 0.d0
    wf_is_real = .not.allocated(fsi_l)
    do ispin=1,nspin,af+1
       do ik=ispin, kv3+ispin-nspin, nspin
          if(map_k(ik) /= myrank_k) cycle ! MPI
          if(sw_rsb==ON) call UnitaryTransform_WF(INVERSE,ik,zaj_l,.true.,.true.)
          if(modnrm == EXECUT) call get_expkt_fs(ik,fsr_l,fsi_l,efsr_l,efsi_l)
          do ib=1,np_e   ! MPI
             !Debug!write(nfout,'("ik=",i5,1x,"ib=",i5)') ik,ib
             if(occup_l(ib,ik) < DELTA) cycle
             ex = 0.d0
             if(kimg==1) then
                call get_EXX_energy_of_a_state(ispin,ik,zaj_l(1,ib,ik,1),zaj_l(1,ib,ik,1),efsr_l(ib,1:nlmta),efsr_l(ib,1:nlmta),ex)
             else
                call get_EXX_energy_of_a_state(ispin,ik,zaj_l(1,ib,ik,1),zaj_l(1,ib,ik,2),efsr_l(ib,1:nlmta),efsi_l(ib,1:nlmta),ex)
             end if
             eexx = eexx + occup_l(ib,ik) * ex
          end do
          if(sw_rsb==ON) call UnitaryTransform_WF(DIRECT,ik,zaj_l,.true.,.true.)
       end do
    end do
    eexx = eexx/dble(kv3/nspin)

    if(modnrm == EXECUT) then
       fac = 0.5d0
    else
       fac = 0.5d0/dble(nfftwf)**2
    end if
    eexx = fac * eexx
    if(nspin==1) eexx = 2.d0 * eexx

    call m_FFT_dealloc_WF_work()

    deallocate(rho)
    deallocate(phi)
    deallocate(wfn)
    deallocate(wfm)
    deallocate(rhogr)
    if(kimg==2) deallocate(rhogi)
    deallocate(wfsr)
    if(kimg==2) deallocate(wfsi)
    deallocate(cosgt)
    if(kimg==2) deallocate(singt)
    !!if(modnrm == EXECUT) then
       deallocate(efsr_l)
       deallocate(efsi_l)
    !!end if
    if(modnrm == EXECUT) then
       deallocate(fsr)
       deallocate(fsi)
    end if

    if(npes>1) then
       call mpi_allreduce(eexx,eexx_mpi,1,MPI_DOUBLE_PRECISION,MPI_SUM,mpi_comm_group,ierr)
       eexx = eexx_mpi
    end if

    call tstatc0_end(id_sname)
  contains

    subroutine get_EXX_energy_of_a_state(ispin,ik,wfr,wfi,bdwr,bdwi,eexx)
      implicit none
      integer, intent(in)                       :: ispin, ik
      real(kind=DP), intent(in), dimension(kg1) :: wfr, wfi
      real(kind=DP), intent(in), dimension(nlmta) :: bdwr, bdwi
      real(kind=DP), intent(inout)              :: eexx

      integer :: m, jkbz, kk, jop, kop, ii, ig, jtrs
      real(kind=DP) :: exx, ph, skg(3), occupation, dnorm

      real(kind=DP), allocatable, dimension(:) :: rhor,rhoi
      real(kind=DP), allocatable, dimension(:) :: afft

      call map_WFG_on_FFT_box(ik,wfr,wfi,wfn)
      call m_FFT_WF(ELECTRON,nfout,wfn,INVERSE,OFF) ! wfn(R)

      if(sw_rspace_hyb==ON)then
         allocate(rhor(nfftp_nonpara/2));rhor=0.d0
         allocate(rhoi(nfftp_nonpara/2));rhoi=0.d0
         allocate(afft(nfftp_nonpara));afft=0.d0
      endif

      do jkbz=1,kv3bz
         if(.not.q_on_k_centered_mesh(jkbz,ik)) cycle
         ! q(bz) = S*k'(ibz)
         kk = ikp(jkbz) + ispin - 1
         kop = iops(jkbz)
         jop = iopt(jkbz)
         jtrs = itrs(jkbz)
         if(kimg==1) then
            do ig=1,iba(kk)
               ii = nbase(ig,kk)
               skg(1:3) = vkxyz(kk,1:3,BUCS) + ngabc(ii,1:3)
               ph = PAI2 * dot_product(skg,tau(:,kop,BUCS))
               cosgt(ig) = cos(ph)
            end do
         else
            do ig=1,iba(kk)
               ii = nbase(ig,kk)
               skg(1:3) = vkxyz(kk,1:3,BUCS) + ngabc(ii,1:3)
               ph = PAI2 * dot_product(skg,tau(:,kop,BUCS))
               cosgt(ig) = cos(ph)
               singt(ig) = sin(ph)
            end do
         end if
         do m=1,nval
            if(occup_val(m,kk) < DELTA) cycle
          if(sw_rsb==ON)then
             if(.not.overlap(ib,m))cycle
          endif
            occupation = wbz(jkbz) * occup_val(m,kk)/qwgt(kk)/dble(kv3)
            if(kimg==1) then
               dnorm = 0.d0
               do ig=1,iba(kk)
                  wfsr(ig) = wfv(ig,m,kk,1) * cosgt(ig)
                  dnorm = dnorm + wfsr(ig)*wfsr(ig)
               end do
               dnorm = 1.d0/sqrt(dnorm)
               wfsr = wfsr * dnorm
               call map_Rot_WFG_on_FFT_box(kk,jop,jtrs,wfsr,wfsr,wfm)
            else
               if(jtrs==0) then
                  do ig=1,iba(kk)
                     wfsr(ig) = wfv(ig,m,kk,1) * cosgt(ig) - wfv(ig,m,kk,2) * singt(ig)
                     wfsi(ig) = wfv(ig,m,kk,2) * cosgt(ig) + wfv(ig,m,kk,1) * singt(ig)
                  end do
               else
                  do ig=1,iba(kk)
                     wfsr(ig) = wfv(ig,m,kk,1) * cosgt(ig) - wfv(ig,m,kk,2) * singt(ig)
                     wfsi(ig) = -wfv(ig,m,kk,2) * cosgt(ig) - wfv(ig,m,kk,1) * singt(ig)
                  end do
               end if
               call map_Rot_WFG_on_FFT_box(kk,jop,jtrs,wfsr,wfsi,wfm)
            end if
            call m_FFT_WF(ELECTRON,nfout,wfm,INVERSE,OFF) ! wfm(R)
            call product_on_FFT_box(wfn,wfm,rho) ! rho_soft(R)
            call m_FFT_WF(ELECTRON,nfout,rho,DIRECT,OFF) ! rho_soft(G)

! ===== ktDEBUG ======================================================== 12.0
            if ( kimg == 1 ) then
               allocate( rhogi(nmax_G_hyb) )
               rhogi = 0.0d0
            endif
! ====================================================================== 12.0

            call map_FFT_box_on_RHOG(rhogr,rhogi,rho)
            !! rho(G) = rho_soft(G) + rho_hard(G)
            if(modnrm == EXECUT) then
               do ig=1, min( kg, nmax_G_hyb )
                  rhogr(ig) = f0 * rhogr(ig)
                  rhogi(ig) = f0 * rhogi(ig)
               end do
               do ig=kg+1,nmax_G_hyb
                  rhogr(ig) = 0.d0
                  rhogi(ig) = 0.d0
               end do
            ! debug
            !!  write(nfout,*) 'm=',m
            !!  write(nfout,*) 'soft rhogr(1)=',rhogr(1)
            !!  write(nfout,*) 'soft rhogi(1)=',rhogi(1)
            ! end debug
               !!fsr(1:nlmta) = fsr_exx(m,1:nlmta,kk)
               !!fsi(1:nlmta) = fsi_exx(m,1:nlmta,kk)
               call get_Rot_betar_dot_WFs(kk,m,jop,kop,jtrs,fsr,fsi)
#ifdef HYB_ORG
               call add_RHOG_hard_part(iqmk(jkbz,ik),rhogr,rhogi,bdwr,bdwi,fsr,fsi)
#else
!!!               call add_RHOG_hard_part2(iqmk(jkbz,ik),rhogr,rhogi,bdwr,bdwi,fsr,fsi)
                if(sw_rspace_hyb==ON)then
                   if(sw_precalculate==OFF)then
                      call add_RHOG_hard_part_rs(iqmk(jkbz,ik),rhor,rhoi,bdwr,bdwi,fsr,fsi)
                   else
                      call add_RHOG_hard_part_rs2(iqmk(jkbz,ik),rhor,rhoi,&
                     & fsrqm(:,:,m,jkbz,ispin),fsiqm(:,:,m,jkbz,ispin),bdwr,bdwi)
                   endif
                   call map_RHOG_on_FFT_box_hard(rhor,rhoi,afft)
                   call m_FFT_CD0(nfout,afft,DIRECT)
                   call map_FFT_box_on_RHOG_hard(rhor,rhoi,afft)
                   do ii=1,nmax_G_hyb
                      rhogr(ii) = rhogr(ii) + rhor(ii)
                      rhogi(ii) = rhogi(ii) + rhoi(ii)
                   end do
                else
                   call add_RHOG_hard_part2A(iqmk(jkbz,ik),rhogr,rhogi,bdwr,bdwi,fsr,fsi)
                endif
#endif
            ! debug
            !!  write(nfout,*) 'm=',m
            !!  write(nfout,*) 'soft+hard rhogr(1)=',rhogr(1)
            !!  write(nfout,*) 'soft+hard rhogi(1)=',rhogi(1)
            ! end debug
            end if
            call sum_rho_vc_rho(rhogr,rhogi,vc(1,iqmk(jkbz,ik)),exx)
            !Debug!write(nfout,'("jkbz=",i5,1x,"m=",i5,1x,"exx=",e20.8,1x)') jkbz,m,-0.5d0/dble(nfftwf)**2*exx
            eexx = eexx + occupation * exx

! ===== ktDEBUG ======================================================== 12.0
            if ( kimg == 1 ) deallocate( rhogi )
! ====================================================================== 12.0

         end do 
      end do 

      if(sw_rspace_hyb==ON)then
         deallocate(rhor)
         deallocate(rhoi)
         deallocate(afft)
      endif

    end subroutine get_EXX_energy_of_a_state
  end subroutine m_ES_EXX_energy

  subroutine product_on_FFT_box(wfn,wfm,rho)
    implicit none
    real(kind=DP), intent(in), dimension(nfft) :: wfn,wfm
    real(kind=DP), intent(out), dimension(nfft) :: rho

    integer :: i, ire, iim, ik

    if(kv3/nspin==1 .and. k_symmetry(1) == GAMMA) then
       do i=1,nfft,2
          ire = i
          iim = i+1
          rho(ire) = wfn(ire)*wfm(ire)
          rho(iim) = 0.d0
       end do
    else
       do i=1,nfft,2
          ire = i
          iim = i+1
          rho(ire) = wfn(ire)*wfm(ire) + wfn(iim)*wfm(iim)
          rho(iim) = wfn(ire)*wfm(iim) - wfn(iim)*wfm(ire)
       end do
    end if
  end subroutine product_on_FFT_box

  subroutine sum_rho_vc_rho(rhor,rhoi,vc,exx)
    implicit none
    real(kind=DP), intent(in), dimension(nmax_G_hyb) :: rhor,rhoi
    real(kind=DP), intent(in), dimension(nmax_G_hyb) :: vc
    real(kind=DP), intent(out) :: exx

    integer :: ig

    exx = 0.d0

    if(kimg==1) then
       do ig=1,nmax_G_hyb
          exx = exx + vc(ig) * rhor(ig)*rhor(ig)
       end do
    else
       do ig=1,nmax_G_hyb
          exx = exx + vc(ig) * (rhor(ig)*rhor(ig)+rhoi(ig)*rhoi(ig))
       end do
    end if
  end subroutine sum_rho_vc_rho

  subroutine map_WFG_on_FFT_box(ik,wfr,wfi,bfft)
    implicit none
    integer, intent(in)                         :: ik
    real(kind=DP), intent(in), dimension(kg1)   :: wfr, wfi
    real(kind=DP), intent(out), dimension(nfft) :: bfft

    integer :: i,i1,ri, j, i2, ii

    bfft = 0.d0
    if(k_symmetry(ik) == GAMMA) then
       if(kimg == 1) then
          i1 = igf(1)
          bfft(i1) = wfr(1)
#ifdef NEC_TUNE_SMP
!CDIR NODEP
#endif
          do ii = 2, iba(ik)
             i = nbase(ii,ik)
             i1 = igf(i)
             bfft(i1) = wfr(ii)
             j = nbase_gamma(ii,2)
             i2 = igf(j)
             bfft(i2) = wfr(ii)
          end do
       else ! kimg == 2
          i1 = 2*igf(1) - 1
          bfft(i1)   = wfr(1)
          bfft(i1+1) = wfi(1)
#ifdef NEC_TUNE_SMP
!CDIR NODEP
#endif
          do ii = 2, iba(ik)
             i = nbase(ii,ik)
             i1 = 2*igf(i)-1
             bfft(i1  ) = wfr(ii)
             bfft(i1+1) = wfi(ii)
             j = nbase_gamma(ii,2)
             i2 = 2*igf(j)-1
             bfft(i2  ) = wfr(ii)
             bfft(i2+1) = -wfi(ii)
          end do
       end if
    else
      if(kimg == 1) then 
#ifdef NEC_TUNE_SMP
!CDIR NODEP
#endif
        do i = 1, iba(ik)
           i1 = igf(nbase(i,ik))
           bfft(i1) = wfr(i)
        end do
      else ! kimg == 2
#ifdef NEC_TUNE_SMP
!CDIR NODEP
#endif
        do i = 1, iba(ik)
           i1 = 2*igf(nbase(i,ik)) - 1
           bfft(i1) = wfr(i)
           i2 = 2*igf(nbase(i,ik))
           bfft(i2) = wfi(i)
        end do
      end if
    end if
  end subroutine map_WFG_on_FFT_box

  subroutine map_Rot_WFG_on_FFT_box(ik,nop,jtrs,wfr,wfi,bfft)
    implicit none
    integer, intent(in)                         :: ik,nop,jtrs
    real(kind=DP), intent(in), dimension(kg1)   :: wfr, wfi
    real(kind=DP), intent(out), dimension(nfft) :: bfft

    integer :: i,i1,ri, j, i2, ii, ip

    bfft = 0.d0
    if(k_symmetry(ik) == GAMMA) then
       if(kimg == 1) then
          i1 = igf(1)
          bfft(i1) = wfr(1)
#ifdef NEC_TUNE_SMP
!CDIR NODEP
#endif
          do ii = 2, iba(ik)
             i = nbase(ii,ik)
             i1 = igf(ngpt_exx(i,nop,jtrs))
             bfft(i1) = wfr(ii)
             j = nbase_gamma(ii,2)
             i2 = igf(ngpt_exx(j,nop,jtrs))
             bfft(i2) = wfr(ii)
          end do
       else ! kimg == 2
          i1 = 2*igf(1) - 1
          bfft(i1)   = wfr(1)
          bfft(i1+1) = wfi(1)
#ifdef NEC_TUNE_SMP
!CDIR NODEP
#endif
          do ii = 2, iba(ik)
             i = nbase(ii,ik)
             i1 = 2*igf(ngpt_exx(i,nop,jtrs))-1
             bfft(i1  ) = wfr(ii)
             bfft(i1+1) = wfi(ii)
             j = nbase_gamma(ii,2)
             i2 = 2*igf(ngpt_exx(j,nop,jtrs))-1
             bfft(i2  ) = wfr(ii)
             bfft(i2+1) = -wfi(ii)
          end do
       end if
    else
      if(kimg == 1) then 
#ifdef NEC_TUNE_SMP
!CDIR NODEP
#endif
        do i = 1, iba(ik)
           i1 = igf(ngpt_exx(nbase(i,ik),nop,jtrs))
           bfft(i1) = wfr(i)
        end do
      else ! kimg == 2
#ifdef NEC_TUNE_SMP
!CDIR NODEP
#endif
        do i = 1, iba(ik)
           ip = igf(ngpt_exx(nbase(i,ik),nop,jtrs))
           i1 = 2*ip - 1
           bfft(i1) = wfr(i)
           i2 = 2*ip
           bfft(i2) = wfi(i)
        end do
      end if
    end if
  end subroutine map_Rot_WFG_on_FFT_box

  subroutine map_FFT_box_on_WFG(ik,wfr,wfi,bfft)
    implicit none
    integer, intent(in)                        :: ik
    real(kind=DP), intent(out), dimension(kg1) :: wfr, wfi
    real(kind=DP), intent(in), dimension(nfft) :: bfft

    integer :: i,i1,ri, j, i2, ii

    if(k_symmetry(ik) == GAMMA) then
       if(kimg == 1) then
          wfr = 0.d0

          i1 = igf(1)
          wfr(1) = bfft(i1)
#ifdef NEC_TUNE_SMP
!CDIR NODEP
#endif
          do ii = 2, iba(ik)
             i = nbase(ii,ik)
             i1 = igf(i)
             wfr(ii) = bfft(i1)
          end do
       else ! kimg == 2
          wfr = 0.d0
          wfi = 0.d0

          i1 = 2*igf(1) - 1
          wfr(1) = bfft(i1)
          wfi(1) = bfft(i1+1)
#ifdef NEC_TUNE_SMP
!CDIR NODEP
#endif
          do ii = 2, iba(ik)
             i = nbase(ii,ik)
             i1 = 2*igf(i)-1
             wfr(ii) = bfft(i1  )
             wfi(ii) = bfft(i1+1)
          end do
       end if
    else
       if(kimg == 1) then
          wfr = 0.d0
#ifdef NEC_TUNE_SMP
!CDIR NODEP
#endif
          do i = 1, iba(ik)
             i1 = igf(nbase(i,ik))
             wfr(i) = bfft(i1)
          end do
       else ! kimg == 2
          wfr = 0.d0
          wfi = 0.d0
#ifdef NEC_TUNE_SMP
!CDIR NODEP
#endif
          do i = 1, iba(ik)
             i1 = 2*igf(nbase(i,ik)) - 1
             wfr(i) = bfft(i1)
             i2 = 2*igf(nbase(i,ik))
             wfi(i) = bfft(i2)
          end do
       end if
    end if
  end subroutine map_FFT_box_on_WFG

  subroutine map_FFT_box_on_RHOG(rhor,rhoi,afft)
    implicit none
    real(kind=DP), intent(out), dimension(nmax_G_hyb) :: rhor, rhoi
    real(kind=DP), intent(in), dimension(nfft) :: afft

    integer :: i,i1,i2

    if(kimg == 1) then
#ifdef NEC_TUNE_SMP
!CDIR NODEP
#endif
       do i = 1, min( kg, nmax_G_hyb )
          i1 = igf(i)
          rhor(i) = afft(i1)
       end do
    else ! kimg==2
#ifdef NEC_TUNE_SMP
!CDIR NODEP
#endif
       do i = 1, min( kg, nmax_G_hyb )
          i1 = 2*igf(i) - 1
          rhor(i) = afft(i1)
          i2 = 2*igf(i)
          rhoi(i) = afft(i2)
       end do
    end if
  end subroutine map_FFT_box_on_RHOG

  subroutine map_RHOG_on_FFT_box(rhor,rhoi,afft)
    implicit none
    real(kind=DP), intent(in), dimension(nmax_G_hyb) :: rhor, rhoi
    real(kind=DP), intent(out), dimension(nfft) :: afft

    integer :: i,i1,i2

    afft = 0.d0

    if(kimg == 1) then
#ifdef NEC_TUNE_SMP
!CDIR NODEP
#endif
       do i = 1, min( kg, nmax_G_hyb )
          i1 = igf(i)
          afft(i1) = rhor(i)
       end do
    else ! kimg==2
#ifdef NEC_TUNE_SMP
!CDIR NODEP
#endif
       do i = 1, min( kg, nmax_G_hyb )
          i1 = 2*igf(i) - 1
          afft(i1) = rhor(i)
          i2 = 2*igf(i)
          afft(i2) = rhoi(i)
       end do
    end if
  end subroutine map_RHOG_on_FFT_box

  subroutine map_RHOG_on_FFT_box_hard(rhor,rhoi,afft)
    implicit none
    real(kind=DP), intent(in), dimension(nfftp_nonpara/2) :: rhor, rhoi
    real(kind=DP), intent(out), dimension(nfftp_nonpara) :: afft

    integer :: i,i1,i2

    afft(:) = 0.d0

    do i = 1, nfftp_nonpara/2
!       i1 = (igfp_l(i)-1)*kimg+1
       i1 = (i-1)*kimg+1
       afft(i1)   = rhor(i)
       afft(i1+1) = rhoi(i)
    end do
  end subroutine map_RHOG_on_FFT_box_hard

  subroutine map_RHOG_on_FFT_box_hard_inv(rhor,rhoi,afft)
    implicit none
    real(kind=DP), intent(in), dimension(nfftp_nonpara/2) :: rhor, rhoi
    real(kind=DP), intent(out), dimension(nfftp_nonpara) :: afft
    integer :: i,i1,i2

    afft(:) = 0.d0

    do i = 1, nmax_G_hyb
       i1 = (igfp_l_red(i)-1)*kimg+1
       afft(i1) = rhor(i)
       afft(i1+1) = rhoi(i)
    end do
  end subroutine map_RHOG_on_FFT_box_hard_inv

  subroutine map_FFT_box_on_RHOG_hard(rhor,rhoi,afft)
    implicit none
    real(kind=DP), intent(in), dimension(nfftp_nonpara) :: afft
    real(kind=DP), intent(out), dimension(nfftp_nonpara/2) :: rhor, rhoi
    real(kind=DP) :: rinplw
    integer :: i,i1,i2

    rinplw = 1.d0/product(fft_box_size_CD(1:3,1))
    rhor(:)=0.d0
    rhoi(:)=0.d0
    do i = 1, nmax_G_hyb
       i1 = (igfp_l_red(i)-1)*kimg+1
       rhor(i) = afft(i1)*rinplw
       rhoi(i) = afft(i1+1)*rinplw
    end do
  end subroutine map_FFT_box_on_RHOG_hard

  subroutine map_FFT_box_on_RHOG_hard_inv(rhor,rhoi,afft)
    implicit none
    real(kind=DP), intent(in), dimension(nfftp_nonpara) :: afft
    real(kind=DP), intent(out), dimension(nfftp_nonpara/2) :: rhor, rhoi
    real(kind=DP) :: rinplw
    integer :: i,i1,i2

    rinplw = 1.d0/product(fft_box_size_CD(1:3,1))
    rhor(:)=0.d0
    rhoi(:)=0.d0
    do i = 1, nfftp_nonpara/2
       i1 = (i-1)*kimg+1
       rhor(i) = afft(i1)*rinplw 
       rhoi(i) = afft(i1+1)*rinplw
    end do
  end subroutine map_FFT_box_on_RHOG_hard_inv

  subroutine m_ES_EXX_ngpt()
    implicit none

    integer :: i,j,iopr,ii
    integer :: ia,ib,ic
    integer :: namin,namax,nbmin,nbmax,ncmin,ncmax
    integer, allocatable, dimension(:,:)   :: ngpt_t
    integer, allocatable, dimension(:,:,:) :: g_list
    integer,save  :: id_sname = -1
    call tstatc0_begin('m_ES_EXX_ngpt ',id_sname,level=1)

    allocate(ngpt_exx(kgp,nopr,0:ntrs)); ngpt_exx = 0

    if(npes > 1) then
       allocate(ngpt_t(kgp,nopr)); ngpt_t = 0
       do iopr=1,nopr
          do i = ista_kngp, iend_kngp
             ngpt_t(i,iopr) = ngpt_l(i,iopr)
          end do
       end do
       call mpi_allreduce(ngpt_t,ngpt_exx,kgp*nopr,mpi_integer,mpi_sum,mpi_comm_group,ierr)
       deallocate(ngpt_t)
    else
       do iopr=1,nopr
          do i = ista_kngp, iend_kngp
             ngpt_exx(i,iopr,0) = ngpt_l(i,iopr)
          end do
       end do
    end if

    !! Time reversal symmetry

   if(ntrs>0) then
    !!! Old code (too slow)
    !do iopr=1,nopr
    !   do i=1,kgp
    !      ii = ngpt_exx(i,iopr,0)
    !      ia = -ngabc(ii,1)
    !      ib = -ngabc(ii,2)
    !      ic = -ngabc(ii,3)
    !      do j=1,kgp
    !         if(ia==ngabc(j,1) .and. ib==ngabc(j,2) .and. ic==ngabc(j,3)) then
    !            ngpt_exx(i,iopr,1) = j
    !            exit
    !         end if
    !      end do
    !   end do
    !end do

    namin = 0; namax = 0
    nbmin = 0; nbmax = 0
    ncmin = 0; ncmax = 0
    do i=1,kgp
       ia = ngabc(i,1)
       ib = ngabc(i,2)
       ic = ngabc(i,3)
       namin = min(ia,namin)
       namax = max(ia,namax)
       nbmin = min(ib,nbmin)
       nbmax = max(ib,nbmax)
       ncmin = min(ic,ncmin)
       ncmax = max(ic,ncmax)
    end do
    !!!write(nfout,'("namin,namax=",2(1x,i7))') namin,namax 
    !!!write(nfout,'("nbmin,nbmax=",2(1x,i7))') nbmin,nbmax 
    !!!write(nfout,'("ncmin,ncmax=",2(1x,i7))') ncmin,ncmax 
    allocate(g_list(namin:namax,nbmin:nbmax,ncmin:ncmax))
    do i=1,kgp
       ia = ngabc(i,1)
       ib = ngabc(i,2)
       ic = ngabc(i,3)
       g_list(ia,ib,ic) = i
    end do
    do iopr=1,nopr
       do i=1,kgp
          ii = ngpt_exx(i,iopr,0)
          ia = -ngabc(ii,1)
          ib = -ngabc(ii,2)
          ic = -ngabc(ii,3)
    !!!      j = g_list(ia,ib,ic)
    !!!      if(ngpt_exx(i,iopr,1) /= j ) then
    !!!         stop 'Error: G_list'
    !!!      end if
          ngpt_exx(i,iopr,1) = g_list(ia,ib,ic)
       end do
    end do
    deallocate(g_list)
   end if

    call tstatc0_end(id_sname)
    !!!stop 'Check: G_list'
  end subroutine m_ES_EXX_ngpt

  subroutine m_ES_EXX_occup(nfout)
    implicit none
    integer, intent(in) :: nfout

    real(kind=DP) :: chgt, chg(nspin), zet
    integer :: ik,ib,is,it
    integer,save  :: id_sname = -1
    call tstatc0_begin('m_ES_EXX_occup ',id_sname,level=1)

    chg(1:nspin) = 0.d0
    do it=1,ntyp
       chgt = ival(it) * iatom(it) + qex(it)
       if(nspin==1) then
          chg(1) = chg(1) + chgt
       else
          zet = zeta1(it)
          chg(1) = chg(1) + chgt * (1.d0+zet)/2.d0
          chg(2) = chg(2) + chgt * (1.d0-zet)/2.d0
       end if
    end do
    if(nspin==1) chg(1) = chg(1)/2.d0

    !!nval = nint((totch+1.0d0))/2
    nval = nint(maxval(chg)+0.1d0)

    !DEBUG!write(nfout,'("DEBUG: nval=",i10)') nval
    !DEBUG!write(nfout,'("DEBUG: neordr=",5i5)') neordr(1:neg,ista_k:iend_k)
    !DEBUG!write(nfout,'("DEBUG: nval=",i10)') nval
    !DEBUG!write(nfout,'("DEBUG: neordr=",5i5)') neordr(1:neg,ista_k:iend_k)

    occup_l(1:np_e,ista_k:iend_k) = 0.d0
    do ik=1,kv3,af+1
       if(map_k(ik) /= myrank_k) cycle ! MPI
       do ib=ista_e,iend_e,istep_e
          !!if(ib>nval) cycle
          if(neordr(ib,ik)>nval) cycle
          occup_l(map_z(ib),ik) = kv3*qwgt(ik)
       end do
    end do
    !DEBUG!write(nfout,'("DEBUG: occup_l=",5f10.5)') occup_l(1:np_e,ista_k:iend_k)
    !DEBUG!write(nfout,'("DEBUG: occup_l=",5f10.5)') occup_l(1:np_e,ista_k:iend_k)
    call tstatc0_end(id_sname)
  end subroutine m_ES_EXX_occup

  subroutine m_ES_EXX_store_wfv()
    implicit none
    allocate(wfv_old(kg1,nval,kv3,kimg))
    allocate(occup_val_old(nval,kv3))
    if(modnrm == EXECUT) then
       allocate(fsr_exx_old(nval,nlmta,kv3))
       allocate(fsi_exx_old(nval,nlmta,kv3))
    end if

    wfv_old  = wfv
    occup_val_old = occup_val
    nval_old = nval
    if(modnrm == EXECUT) then
       fsr_exx_old = fsr_exx
       fsi_exx_old = fsi_exx
    end if
  end subroutine m_ES_EXX_store_wfv

  subroutine m_ES_EXX_restore_wfv()
    implicit none
    if(allocated(wfv)) deallocate(wfv)
    if(allocated(occup_val)) deallocate(occup_val)
    if(modnrm == EXECUT) then
       if(allocated(fsr_exx)) deallocate(fsr_exx)
       if(allocated(fsi_exx)) deallocate(fsi_exx)
    end if
    nval = nval_old
    allocate(wfv(kg1,nval,kv3,kimg))
    allocate(occup_val(nval,kv3))
    if(modnrm == EXECUT) then
       allocate(fsr_exx(nval,nlmta,kv3))
       allocate(fsi_exx(nval,nlmta,kv3))
    end if
    wfv = wfv_old
    occup_val = occup_val_old
    if(modnrm == EXECUT) then
       fsr_exx = fsr_exx_old
       fsi_exx = fsi_exx_old
    end if
    deallocate(wfv_old)
    deallocate(occup_val_old)
    if(modnrm == EXECUT) then
       deallocate(fsr_exx_old)
       deallocate(fsi_exx_old)
    end if
  end subroutine m_ES_EXX_restore_wfv

  function q_on_k_centered_mesh(iq,ik) result(ltf)
    implicit none
    integer, intent(in) :: iq, ik

    logical :: ltf
    real(kind=DP) :: qv(3), kv(3) 
    integer :: dv(3)

    qv(1:3) = vkbz(iq,1:3)
    kv(1:3) = vkxyz(ik,1:3,BUCS)
 
    dv(1:3) = nint( (qv(1:3) - kv(1:3)) * n_bz_mesh(1:3) )

    ltf = .false.
    if(mod(dv(1),reduction_factor_exx(1)) == 0 .and. &
     & mod(dv(2),reduction_factor_exx(2)) == 0 .and. &
     & mod(dv(3),reduction_factor_exx(3)) == 0 ) then
       ltf = .true.
    end if
  end function q_on_k_centered_mesh

!! For debug
  function check_ibz_k(ik) result(ltf)
    implicit none
    integer, intent(in) :: ik

    logical :: ltf
    real(kind=DP) :: vkx, vky, vkz

    open(1000,file="ibz.data")
    read(1000,*) vkx, vky, vkz
    close(1000)

    ltf = .true.
    if(abs(vkxyz(ik,1,BUCS) - vkx) < DELTA07 .and. & 
     & abs(vkxyz(ik,2,BUCS) - vky) < DELTA07 .and. & 
     & abs(vkxyz(ik,3,BUCS) - vkz) < DELTA07 ) then
       ltf = .false.
       write(nfout,'("IBZ k: ",3f20.5)') vkxyz(ik,1:3,BUCS)
    end if
  end function check_ibz_k

  function check_bz_k(ik) result(ltf)
    implicit none
    integer, intent(in) :: ik

    logical :: ltf
    real(kind=DP) :: vkx, vky, vkz

    open(1100,file="bz.data")
    read(1100,*) vkx, vky, vkz
    close(1100)

    ltf = .true.
    if(abs(vkbz(ik,1) - vkx) < DELTA07 .and. &
     & abs(vkbz(ik,2) - vky) < DELTA07 .and. &
     & abs(vkbz(ik,3) - vkz) < DELTA07 ) then
       write(nfout,'(" BZ k: ",3f20.5)') vkbz(ik,1:3)
       ltf = .false.
    end if
  end function check_bz_k

!! For ultrasoft pseudopotentials 
  subroutine m_ES_EXX_ylm()
    implicit none

    integer :: i,n,ik,ig
    real(kind=DP), allocatable, dimension(:) :: ylm_t ! d(kngp,n)
    real(kind=DP), allocatable, dimension(:,:) :: gqmk ! d(ista_kngp:iend_kngp,3)
    real(kind=DP), allocatable, dimension(:) :: gqmkr ! d(ista_kngp:iend_kngp)

    real(kind=DP) :: kg(3), ttr(6), g2
    integer,save  :: id_sname = -1
    call tstatc0_begin('m_ES_EXX_ylm ',id_sname,level=1)

    call getttr(rltv,ttr)

    call m_PP_find_maximum_l(n)    ! n-1: maximum l
    n = (n-1) + (n-1) + 1
    n = n*n
    if(.not.allocated(ylm_exx)) allocate(ylm_exx(kgp,n,nqmk))

    allocate(gqmk(ista_kngp:iend_kngp,3))
    allocate(gqmkr(ista_kngp:iend_kngp))
    do ik=1,nqmk
       do ig=ista_kngp,iend_kngp
          kg(1:3) = qmk(ik,1:3) + ngabc(ig,1:3)
          g2          = ttr(1)*kg(1)*kg(1) &
          &           + ttr(2)*kg(2)*kg(2) &
          &           + ttr(3)*kg(3)*kg(3) &
          &           + ttr(4)*kg(1)*kg(2) &
          &           + ttr(5)*kg(2)*kg(3) &
          &           + ttr(6)*kg(3)*kg(1)
          gqmk(ig,1:3) = kg(1:3)
          gqmkr(ig) = sqrt(g2)
       end do
       if(npes > 1) then
          allocate(ylm_t(kgp))
          do i=1,n
             ylm_t = 0.d0
             call m_pwBS_sphrp_exx(i,rltv,ista_kngp,iend_kngp,gqmk,gqmkr,ylm_t(ista_kngp:iend_kngp))
             call mpi_allreduce(ylm_t,ylm_exx(1,i,ik),kgp,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
          end do
          deallocate(ylm_t)
       else
          do i=1,n
             call m_pwBS_sphrp_exx(i,rltv,ista_kngp,iend_kngp,gqmk,gqmkr,ylm_exx(1,i,ik))
          end do
       end if
    end do
    !!stop 'm_ES_EXX_ylm'
    deallocate(gqmk)
    deallocate(gqmkr)

    !!call check_qitg()
    !!call check_qitg_qmk()
    !!call check_ylm_exx()

    call tstatc0_end(id_sname)
  end subroutine m_ES_EXX_ylm

  subroutine check_qitg()
    implicit none
    integer :: iq 

    do iq=1,nqitg
       write(nfout,'("iq=",i5,1x,"qitg_l=",f20.5,1x,"qitg_exx=",f20.5,1x)') &
         & iq, qitg_l(1,iq), qitg_exx(1,iq,1)/univol
    end do

    do iq=1,nqitg
       write(nfout,'("iq=",i5,1x,"diff=",f20.5)') &
         & iq, sum(qitg_l(1:nmax_G_hyb,iq)-qitg_exx(1:nmax_G_hyb,iq,1)/univol)
    end do

    stop 'check_qitg'
  end subroutine check_qitg

  subroutine check_qitg_qmk()
    implicit none
    integer :: iq, ik

    do ik=1,nqmk
    do iq=1,nqitg
       write(nfout,'("iq=",i5,1x,"qitg_exx=",f20.5,1x)') &
         & iq, qitg_exx(1,iq,ik)/univol
    end do
    end do

    do ik=1,nqmk
    do iq=1,nqitg
       write(nfout,'("iq=",i5,1x,"sum=",f20.5)') &
         & iq, sum(qitg_exx(1:nmax_G_hyb,iq,ik)/univol)
    end do
    end do

    stop 'check_qitg_qmk'
  end subroutine check_qitg_qmk

  subroutine check_ylm_exx()
    implicit none
    integer :: i, n, ik

    call m_PP_find_maximum_l(n)    ! n-1: maximum l
    n = (n-1) + (n-1) + 1
    n = n*n

    do ik=1,nqmk
    do i=1,n
       write(nfout,'("i=",i5,1x,"ylm_exx=",f20.5,1x)') &
         & i, ylm_exx(1,i,ik)
    end do
    end do

    do ik=1,nqmk
    do i=1,n
       write(nfout,'("i=",i5,1x,"sum=",f20.5)') &
         & i, sum(qitg_exx(1:nmax_G_hyb,i,ik))
    end do
    end do

    stop 'check_ylm_exx'
  end subroutine check_ylm_exx

  subroutine hard_part_preproc()
    integer :: it,ncache
    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(nqitg_sp(ntyp)); allocate(nqitg_sp0(ntyp))
    allocate(iq2l3(nqitg))
    allocate(nc(mcritical,nqitg));nc=0
! =================================== Added by K. Tagami =======
    nqitg_sp = 0; nqitg_sp0 = 0; iq2l3 = 0
! ==============================================================
    call m_PP_set_index_arrays1(nfout,ntyp,nqitg,mcritical,n**2,il3 &
    & ,maxm,mc,nqitg_sp,nqitg_sp0,iq2l3,nc,.true.)
    allocate(nc2lmt1(mc,maxm,nqitg))
    allocate(nc2lmt2(mc,maxm,nqitg))
    allocate(nc2n(mc,maxm,nqitg))
! ==================================== Added by K. Tagami ======
    nc2lmt1 = 0;  nc2lmt2 = 0; nc2n = 0
! =============================================================
    call m_PP_set_index_arrays2(nfout,mc,maxm,nqitg,mcritical,n**2,il3,iq2l3 &
    & ,nc2lmt1,nc2lmt2,nc2n,nc,.true.) ! -> nc2lmt1, nc2lmt2, nc2n, nc

    ncache = (m_CtrlP_cachesize()*1024)*3/4
    if(ncache == 0) then
       ibsize =  nmax_G_hyb
    else
       iwidth = 0
       do it = 1, ntyp
          iwidth = max(iwidth,nqitg_sp(it)-nqitg_sp0(it)+1)
       end do
       ibsize=ncache/(8*(iwidth + 2))
    end if
#ifdef HYB_DISABLE_BLOCKING
    ibsize = nmax_G_hyb
#endif
    preproc_done = .true.
  end subroutine hard_part_preproc

  subroutine add_RHOG_hard_part2A(iqmk,rhogr,rhogi,fnr,fni,fmr,fmi)
    implicit none
    integer, intent(in) :: iqmk
    real(kind=DP), intent(inout) :: rhogr(nmax_G_hyb)
    real(kind=DP), intent(inout) :: rhogi(nmax_G_hyb)
    real(kind=DP), intent(in) :: fnr(nlmta)
    real(kind=DP), intent(in) :: fni(nlmta)
    real(kind=DP), intent(in) :: fmr(nlmta)
    real(kind=DP), intent(in) :: fmi(nlmta)

    integer :: it,ia,i,lmt1,lmt2,np,il1,il2,tau1,tau2,ilmta1,ilmta2
    integer :: l3,ilm3,iil
    real(kind=DP) :: ph, hr, hi, fac, f0
    real(kind=DP), allocatable :: cosgt(:), singt(:)

    real(kind=DP), allocatable, dimension(:) :: ylm_sum,ylm_sum2

    real(kind=DP), allocatable :: qitg_red(:,:),ylm_red(:,:)
    real(kind=DP), allocatable :: rhogr_red(:),rhogi_red(:)
    real(kind=DP) :: yr,yi
    integer :: ibl1,ibl2,iq,inn,ip,m

    integer,save  :: id_sname = -1

    call tstatc0_begin('add_RHOG_hard_part2A ',id_sname,1)

    if(.not.preproc_done) call hard_part_preproc()

    allocate(cosgt(ibsize))
    allocate(singt(ibsize))
    allocate(ylm_sum(ibsize));ylm_sum=0.d0
    allocate(ylm_sum2(ibsize));ylm_sum2=0.d0

    allocate(qitg_red(ibsize,nqitg))
    allocate(ylm_red(ibsize,n*n))
    allocate(rhogr_red(ibsize))
    allocate(rhogi_red(ibsize))
! --
    do ibl1=1, nmax_G_hyb, ibsize
       rhogr_red=0.d0;  rhogi_red=0.d0

       ibl2=ibl1+ibsize-1

       if (ibl2.gt.nmax_G_hyb) ibl2 = nmax_G_hyb

       do iq=1,nqitg
          do i=1,ibl2-ibl1+1
             qitg_red(i,iq) = qitg_exx(i+ibl1-1,iq,iqmk)
          enddo
       enddo
       do inn=1,n*n
          do i=1,ibl2-ibl1+1
             ylm_red(i,inn) = ylm_exx(i+ibl1-1,inn,iqmk)
          enddo
       enddo

       do ia=1,natm
          it = ityp(ia)
          if( m_PP_include_vanderbilt_pot(it) == SKIP) cycle
          do i=1,ibl2-ibl1+1
             ph = PAI2 * dot_product(pos(ia,1:3),ngabc(i+ibl1-1,1:3)+qmk(iqmk,1:3))
             cosgt(i) = cos(ph);  singt(i) = sin(ph)
          end do
          do iq = nqitg_sp0(it), nqitg_sp(it)
             l3 = iq2l3(iq)
             iil = mod(l3,4)
             ylm_sum  = 0.d0;  ylm_sum2 = 0.d0

             do m = 1, 2*l3+1
                ilm3 = l3*l3+m
                yr=0.d0;  yi=0.d0

                do ip=1,nc(m,iq)
                   lmt1 = nc2lmt1(ip,m,iq);  lmt2 = nc2lmt2(ip,m,iq)
                   ilmta1 = lmta(lmt1,ia);   ilmta2 = lmta(lmt2,ia)
                   np = nc2n(ip,m,iq)
                   hr = fnr(ilmta1)*fmr(ilmta2) + fni(ilmta1)*fmi(ilmta2)
                   hi = fnr(ilmta1)*fmi(ilmta2) - fni(ilmta1)*fmr(ilmta2)
                   f0 = iwei(ia) * dl2p(lmt1,lmt2,np,it)
                   yr = yr + f0*hr;  yi = yi + f0*hi
                   !do i=1,ibl2-ibl1+1
                   !   ylm_sum(i)  = ylm_sum(i)  + f0*ylm_red(i,ilm3)*hr
                   !   ylm_sum2(i) = ylm_sum2(i) + f0*ylm_red(i,ilm3)*hi
                   !enddo
                enddo
                do i=1,ibl2-ibl1+1
                   ylm_sum(i)  = ylm_sum(i)  + yr*ylm_red(i,ilm3)
                   ylm_sum2(i) = ylm_sum2(i) + yi*ylm_red(i,ilm3)
                enddo
             enddo

             if(iil==0) then
                do i=1,ibl2-ibl1+1
                   fac =  qitg_red(i,iq)
                   rhogr_red(i) = rhogr_red(i) + fac * (cosgt(i)*ylm_sum(i) +singt(i)*ylm_sum2(i))
                   rhogi_red(i) = rhogi_red(i) + fac * (cosgt(i)*ylm_sum2(i)-singt(i)*ylm_sum(i))
                end do
             else if(iil==1) then
                do i=1,ibl2-ibl1+1
                   fac =  qitg_red(i,iq)
                   rhogr_red(i) = rhogr_red(i) + fac * (cosgt(i)*ylm_sum2(i)-singt(i)*ylm_sum(i))
                   rhogi_red(i) = rhogi_red(i) - fac * (cosgt(i)*ylm_sum(i) +singt(i)*ylm_sum2(i))
                end do
             else if(iil==2) then
                do i=1,ibl2-ibl1+1
                   fac =  qitg_red(i,iq)
                   rhogr_red(i) = rhogr_red(i) - fac * (cosgt(i)*ylm_sum(i) +singt(i)*ylm_sum2(i))
                   rhogi_red(i) = rhogi_red(i) - fac * (cosgt(i)*ylm_sum2(i)-singt(i)*ylm_sum(i))
                end do
             else if(iil==3) then
                do i=1,ibl2-ibl1+1
                   fac =  qitg_red(i,iq)
                   rhogr_red(i) = rhogr_red(i) - fac * (cosgt(i)*ylm_sum2(i)-singt(i)*ylm_sum(i))
                   rhogi_red(i) = rhogi_red(i) + fac * (cosgt(i)*ylm_sum(i) +singt(i)*ylm_sum2(i))
                end do
             end if
          enddo
       enddo

       do i=ibl1,ibl2
          rhogr(i) = rhogr(i) + rhogr_red(i-ibl1+1)
          rhogi(i) = rhogi(i) + rhogi_red(i-ibl1+1)
       enddo
       
    enddo
    
    deallocate(cosgt); deallocate(singt)
    deallocate(ylm_sum); deallocate(ylm_sum2)
    deallocate(qitg_red); deallocate(ylm_red)
    deallocate(rhogr_red); deallocate(rhogi_red)

    call tstatc0_end(id_sname)
  end subroutine add_RHOG_hard_part2A

  subroutine add_RHOG_hard_part2(iqmk,rhogr,rhogi,fnr,fni,fmr,fmi)
    implicit none
    integer, intent(in) :: iqmk
    real(kind=DP), intent(inout) :: rhogr(nmax_G_hyb)
    real(kind=DP), intent(inout) :: rhogi(nmax_G_hyb)
    real(kind=DP), intent(in) :: fnr(nlmta)
    real(kind=DP), intent(in) :: fni(nlmta)
    real(kind=DP), intent(in) :: fmr(nlmta)
    real(kind=DP), intent(in) :: fmi(nlmta)

    integer :: it,ia,i,lmt1,lmt2,np,il1,il2,tau1,tau2,ilmta1,ilmta2
    integer :: l3,ilm3,iil
    real(kind=DP) :: ph, hr, hi, fac, f0
    real(kind=DP), allocatable :: cosgt(:), singt(:)

    real(kind=DP), allocatable, dimension(:) :: ylm_sum,ylm_sum2

    real(kind=DP), allocatable :: qitg_red(:,:),ylm_red(:,:)
    real(kind=DP), allocatable :: rhogr_red(:),rhogi_red(:)
    real(kind=DP) :: yr,yi
    integer :: ibl1,ibl2,iq,inn,ip,m

    integer,save  :: id_sname = -1

    call tstatc0_begin('add_RHOG_hard_part2 ',id_sname,1)

    if(.not.preproc_done) call hard_part_preproc()

    allocate(cosgt(ibsize))
    allocate(singt(ibsize))
    allocate(ylm_sum(ibsize));ylm_sum=0.d0
    allocate(ylm_sum2(ibsize));ylm_sum2=0.d0

    allocate(qitg_red(ibsize,nqitg))
    allocate(ylm_red(ibsize,n*n))
    allocate(rhogr_red(ibsize))
    allocate(rhogi_red(ibsize))

    do ibl1=1,nmax_G_hyb,ibsize
    rhogr_red=0.d0
    rhogi_red=0.d0
    ibl2=ibl1+ibsize-1
    if(ibl2.gt.nmax_G_hyb) ibl2=nmax_G_hyb

    do iq=1,nqitg
       do i=1,ibl2-ibl1+1
          qitg_red(i,iq) = qitg_exx(i+ibl1-1,iq,iqmk)
       enddo
    enddo
    do inn=1,n*n
       do i=1,ibl2-ibl1+1
          ylm_red(i,inn) = ylm_exx(i+ibl1-1,inn,iqmk)
       enddo
    enddo

    do ia=1,natm
       it = ityp(ia)
       if( m_PP_include_vanderbilt_pot(it) == SKIP) cycle
       do i=1,ibl2-ibl1+1
          ph = PAI2 * dot_product(pos(ia,1:3),ngabc(i+ibl1-1,1:3)+qmk(iqmk,1:3))
          cosgt(i) = cos(ph)
          singt(i) = sin(ph)
       end do
       do iq = nqitg_sp0(it), nqitg_sp(it)
          l3 = iq2l3(iq)
          iil = mod(l3,4)
          ylm_sum  = 0.d0
          ylm_sum2 = 0.d0
          do m = 1, 2*l3+1
             ilm3 = l3*l3+m
             yr=0.d0
             yi=0.d0
             do ip=1,nc(m,iq)
                lmt1 = nc2lmt1(ip,m,iq)
                lmt2 = nc2lmt2(ip,m,iq)
                ilmta1 = lmta(lmt1,ia)
                ilmta2 = lmta(lmt2,ia)
                np = nc2n(ip,m,iq)
                hr = fnr(ilmta1)*fmr(ilmta2) + fni(ilmta1)*fmi(ilmta2)
                hi = fnr(ilmta1)*fmi(ilmta2) - fni(ilmta1)*fmr(ilmta2)
                f0 = iwei(ia) * dl2p(lmt1,lmt2,np,it)
                yr = yr + f0*hr
                yi = yi + f0*hi
                !do i=1,ibl2-ibl1+1
                !   ylm_sum(i)  = ylm_sum(i)  + f0*ylm_red(i,ilm3)*hr
                !   ylm_sum2(i) = ylm_sum2(i) + f0*ylm_red(i,ilm3)*hi
                !enddo
             enddo
             do i=1,ibl2-ibl1+1
                ylm_sum(i)  = ylm_sum(i)  + yr*ylm_red(i,ilm3)
                ylm_sum2(i) = ylm_sum2(i) + yi*ylm_red(i,ilm3)
             enddo
          enddo 
          if(iil==0) then
             do i=1,ibl2-ibl1+1
                fac =  qitg_red(i,iq)
                rhogr_red(i) = rhogr_red(i) + fac * (cosgt(i)*ylm_sum(i) +singt(i)*ylm_sum2(i))
                rhogi_red(i) = rhogi_red(i) + fac * (cosgt(i)*ylm_sum2(i)-singt(i)*ylm_sum(i))
             end do
          else if(iil==1) then
             do i=1,ibl2-ibl1+1
                fac =  qitg_red(i,iq)
                rhogr_red(i) = rhogr_red(i) + fac * (cosgt(i)*ylm_sum2(i)-singt(i)*ylm_sum(i))
                rhogi_red(i) = rhogi_red(i) - fac * (cosgt(i)*ylm_sum(i) +singt(i)*ylm_sum2(i))
             end do
          else if(iil==2) then
             do i=1,ibl2-ibl1+1
                fac =  qitg_red(i,iq)
                rhogr_red(i) = rhogr_red(i) - fac * (cosgt(i)*ylm_sum(i) +singt(i)*ylm_sum2(i))
                rhogi_red(i) = rhogi_red(i) - fac * (cosgt(i)*ylm_sum2(i)-singt(i)*ylm_sum(i))
             end do
          else if(iil==3) then
             do i=1,ibl2-ibl1+1
                fac =  qitg_red(i,iq)
                rhogr_red(i) = rhogr_red(i) - fac * (cosgt(i)*ylm_sum2(i)-singt(i)*ylm_sum(i))
                rhogi_red(i) = rhogi_red(i) + fac * (cosgt(i)*ylm_sum(i) +singt(i)*ylm_sum2(i))
             end do
          end if
       enddo
    enddo
    do i=ibl1,ibl2
       rhogr(i) = rhogr(i) + rhogr_red(i-ibl1+1)
       rhogi(i) = rhogi(i) + rhogi_red(i-ibl1+1)
    enddo

    enddo

    deallocate(cosgt)
    deallocate(singt)
    deallocate(ylm_sum)
    deallocate(ylm_sum2)
    deallocate(qitg_red)
    deallocate(ylm_red)
    deallocate(rhogr_red)
    deallocate(rhogi_red)
    call tstatc0_end(id_sname)
  end subroutine add_RHOG_hard_part2

  subroutine add_RHOG_hard_part_rs2(iqmk,rhor,rhoi,qmfnr,qmfni,fmr,fmi)
    integer, intent(in) :: iqmk
    real(kind=DP), intent(out) :: rhor(nfftp_nonpara/2)
    real(kind=DP), intent(out) :: rhoi(nfftp_nonpara/2)
    real(kind=DP), intent(in) :: qmfnr(nmesh_rs_aug_max,nlmta)
    real(kind=DP), intent(in) :: qmfni(nmesh_rs_aug_max,nlmta)
    real(kind=DP), intent(in) :: fmr(nlmta)
    real(kind=DP), intent(in) :: fmi(nlmta)
    real(kind=DP), dimension(:), allocatable :: cosqmkr,sinqmkr
    real(kind=DP), allocatable, dimension(:) :: rtmp,itmp
    real(kind=DP) :: fr,fi,co,si,qmr,qmi,rr,ii
    integer :: ia,it,lmt1,ilmta1,ind,imesh,nma
    integer,save  :: id_sname = -1
    call tstatc0_begin('add_RHOG_hard_part_rs2 ',id_sname,1)
    allocate(cosqmkr(nmesh_rs_aug_max));cosqmkr=0.d0
    allocate(sinqmkr(nmesh_rs_aug_max));sinqmkr=0.d0
    allocate(rtmp(nmesh_rs_aug_max));rtmp=0.d0
    allocate(itmp(nmesh_rs_aug_max));itmp=0.d0
    rhor(:) = 0.d0;rhoi(:) = 0.d0
    do ia=1,natm
       it = ityp(ia)
       if( m_PP_include_vanderbilt_pot(it) == SKIP) cycle
       call qmk_dot_r(iqmk,ia,cosqmkr,sinqmkr)
       nma = nmesh_rs_aug(ia)
       rtmp=0.d0;itmp=0.d0
       do lmt1=1,ilmt(it)
          ilmta1 = lmta(lmt1,ia)
          fr =  fmr(ilmta1)
          fi = -fmi(ilmta1) ! c.c. of fsr
          do imesh=1,nma
             co =  cosqmkr(imesh)
             si = -sinqmkr(imesh) ! c.c. of exp(i(G+q-k))
             qmr = qmfnr(imesh,ilmta1)
             qmi = qmfni(imesh,ilmta1)
             rr = co*qmr-si*qmi
             ii = co*qmi+si*qmr
             rtmp(imesh) = rtmp(imesh) + rr*fr-ii*fi
             itmp(imesh) = itmp(imesh) + ii*fr+rr*fi
          enddo
       enddo
       do imesh=1,nma
          ind = meshxyz_rs_aug(imesh,ia)
          rhor(ind) = rhor(ind) + rtmp(imesh)
          rhoi(ind) = rhoi(ind) + itmp(imesh)
       enddo
    enddo
    deallocate(cosqmkr) 
    deallocate(sinqmkr) 
    deallocate(rtmp)
    deallocate(itmp)
    call tstatc0_end(id_sname)
  end subroutine add_RHOG_hard_part_rs2

  subroutine add_RHOG_hard_part_rs(iqmk,rhor,rhoi,fnr,fni,fmr,fmi)
    implicit none
    integer, intent(in) :: iqmk
    real(kind=DP), intent(out) :: rhor(nfftp_nonpara/2)
    real(kind=DP), intent(out) :: rhoi(nfftp_nonpara/2)
    real(kind=DP), intent(in) :: fnr(nlmta)
    real(kind=DP), intent(in) :: fni(nlmta)
    real(kind=DP), intent(in) :: fmr(nlmta)
    real(kind=DP), intent(in) :: fmi(nlmta)
    integer :: n,it,ia,imesh,lmt1,lmt2,il1,il2,tau1,tau2,ilmta1,ilmta2
    integer :: nma
    real(kind=DP), dimension(:), allocatable :: cosqmkr,sinqmkr
    real(kind=DP) :: rr,ii,si,co,qm
    integer :: ind
    real(kind=DP), allocatable, dimension(:) :: rtmp,itmp
    integer,save  :: id_sname = -1
    call tstatc0_begin('add_RHOG_hard_part_rs ',id_sname,1)
    allocate(cosqmkr(nmesh_rs_aug_max));cosqmkr=0.d0
    allocate(sinqmkr(nmesh_rs_aug_max));sinqmkr=0.d0
    allocate(rtmp(nmesh_rs_aug_max));rtmp=0.d0
    allocate(itmp(nmesh_rs_aug_max));itmp=0.d0
    rhor(:) = 0.d0;rhoi(:) = 0.d0
    do ia=1,natm
       it = ityp(ia)
       if( m_PP_include_vanderbilt_pot(it) == SKIP) cycle
       call qmk_dot_r(iqmk,ia,cosqmkr,sinqmkr)
       nma = nmesh_rs_aug(ia)
       rtmp=0.d0;itmp=0.d0
       do lmt1=1,ilmt(it)
          ilmta1 = lmta(lmt1,ia)
          do lmt2 = 1, ilmt(it)
             ilmta2 = lmta(lmt2,ia)
             rr = fnr(ilmta1)*fmr(ilmta2) + fni(ilmta1)*fmi(ilmta2)
             ii = fnr(ilmta1)*fmi(ilmta2) - fni(ilmta1)*fmr(ilmta2)
             do imesh=1,nma
                co = cosqmkr(imesh)
                si = sinqmkr(imesh)
                qm = qr_clm_ylm(imesh,ia,lmt1,lmt2)
                rtmp(imesh) = rtmp(imesh) + qm*(rr*co+ii*si)
                itmp(imesh) = itmp(imesh) + qm*(ii*co-rr*si)
             enddo
          enddo
       enddo
       do imesh=1,nma
          ind = meshxyz_rs_aug(imesh,ia)
          rhor(ind) = rhor(ind) + rtmp(imesh)
          rhoi(ind) = rhoi(ind) + itmp(imesh)
       enddo
    enddo
    deallocate(cosqmkr)
    deallocate(sinqmkr)
    deallocate(rtmp)
    deallocate(itmp)
    call tstatc0_end(id_sname)
  end subroutine add_RHOG_hard_part_rs

  subroutine qmk_dot_r(iqmk,ia,zc_ar,zs_ar)
    integer, intent(in) :: iqmk,ia 
    real(kind=DP),dimension(nmesh_rs_aug_max),intent(out) :: zc_ar,zs_ar
    integer :: i
    real(kind=DP) :: inl,inm,inn
    real(kind=DP) :: rx,ry,rz,kdr
    integer :: id_sname = -1
    inl = 1.d0/dble(fft_box_size_CD(1,1))
    inm = 1.d0/dble(fft_box_size_CD(2,1))
    inn = 1.d0/dble(fft_box_size_CD(3,1))
    do i=1,nmesh_rs_aug(ia)
       rx = dble(meshx_rs_aug(i,ia))*inl
       ry = dble(meshy_rs_aug(i,ia))*inm
       rz = dble(meshz_rs_aug(i,ia))*inn
       kdr = (rx*qmk(iqmk,1)+ry*qmk(iqmk,2)+rz*qmk(iqmk,3))*PAI2
       zc_ar(i) = dcos(kdr)
       zs_ar(i) = dsin(kdr)
    enddo
  end subroutine qmk_dot_r

  subroutine add_RHOG_hard_part(iqmk,rhogr,rhogi,fnr,fni,fmr,fmi)
    implicit none
    integer, intent(in) :: iqmk
    real(kind=DP), intent(inout) :: rhogr(nmax_G_hyb)
    real(kind=DP), intent(inout) :: rhogi(nmax_G_hyb)
    real(kind=DP), intent(in) :: fnr(nlmta)
    real(kind=DP), intent(in) :: fni(nlmta)
    real(kind=DP), intent(in) :: fmr(nlmta)
    real(kind=DP), intent(in) :: fmi(nlmta)

    integer :: n,it,ia,i,lmt1,lmt2,np,il1,il2,tau1,tau2,ilmta1,ilmta2
    integer :: l3,ilm3,iiqitg,iil
    integer, allocatable :: il3(:)
    real(kind=DP) :: ph, hr, hi, fac, f0
    real(kind=DP), allocatable :: cosgt(:), singt(:)
    real(kind=DP), allocatable :: zsr(:), zsi(:)
    real(kind=DP), allocatable :: qitg_red(:,:),ylm_red(:,:)
    real(kind=DP), allocatable :: rhogr_red(:),rhogi_red(:)
    !!real(kind=DP), allocatable :: ylm(:)
    integer,save  :: id_sname = -1
    call tstatc0_begin('add_RHOG_hard_part ',id_sname,1)

    allocate(cosgt(nmax_G_hyb))
    allocate(singt(nmax_G_hyb))
    allocate(zsr(nmax_G_hyb))
    allocate(zsi(nmax_G_hyb))
    !!allocate(ylm(nmax_G_hyb))

    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..)

    do ia=1,natm
       it = ityp(ia)
       if( m_PP_include_vanderbilt_pot(it) == SKIP) cycle
       do i=1,nmax_G_hyb
          ph = PAI2 * dot_product(pos(ia,1:3),ngabc(i,1:3)+qmk(iqmk,1:3))
          cosgt(i) = cos(ph)
          singt(i) = sin(ph)
       end do
       do lmt1 = 1, ilmt(it)
          il1  = ltp( lmt1, it)
          tau1 = taup(lmt1, it)
          ilmta1 = lmta(lmt1,ia)
          do lmt2 = 1, ilmt(it)
             if(il2p(lmt1,lmt2,it)==0) cycle
             il2  = ltp( lmt2, it)
             tau2 = taup(lmt2, it)
             ilmta2 = lmta(lmt2,ia)
             hr = fnr(ilmta1)*fmr(ilmta2) + fni(ilmta1)*fmi(ilmta2)
             hi = fnr(ilmta1)*fmi(ilmta2) - fni(ilmta1)*fmr(ilmta2)
             do i=1,nmax_G_hyb
                zsr(i) = cosgt(i) * hr + singt(i) * hi
                zsi(i) = cosgt(i) * hi - singt(i) * hr
             end do
             do np = 1, il2p(lmt1,lmt2,it)
                ilm3 = isph(lmt1,lmt2,np,it)
                l3 = il3(ilm3)
            !! Debug !!
            !!    if(l3 /= 0) cycle
            !! End Debug !!
                if(lmt2>=lmt1) then
                   iiqitg = iqitg(il1,tau1,il2,tau2,l3+1,it)
                else
                   iiqitg = iqitg(il2,tau2,il1,tau1,l3+1,it)
                end if
                if(iiqitg == 0) cycle
                f0 = iwei(ia) * dl2p(lmt1,lmt2,np,it)
                iil = mod(l3,4)
                if(iil==0) then
                   do i=1,nmax_G_hyb
                      fac = f0 * qitg_exx(i,iiqitg,iqmk) * ylm_exx(i,ilm3,iqmk)
                      rhogr(i) = rhogr(i) + fac * zsr(i)
                      rhogi(i) = rhogi(i) + fac * zsi(i)
                   end do
                else if(iil==1) then
                   do i=1,nmax_G_hyb
                      fac = f0 * qitg_exx(i,iiqitg,iqmk) * ylm_exx(i,ilm3,iqmk)
                      rhogr(i) = rhogr(i) + fac * zsi(i)
                      rhogi(i) = rhogi(i) - fac * zsr(i)
                   end do
                else if(iil==2) then
                   do i=1,nmax_G_hyb
                      fac = f0 * qitg_exx(i,iiqitg,iqmk) * ylm_exx(i,ilm3,iqmk)
                      rhogr(i) = rhogr(i) - fac * zsr(i)
                      rhogi(i) = rhogi(i) - fac * zsi(i)
                   end do
                else if(iil==3) then
                   do i=1,nmax_G_hyb
                      fac = f0 * qitg_exx(i,iiqitg,iqmk) * ylm_exx(i,ilm3,iqmk)
                      rhogr(i) = rhogr(i) - fac * zsi(i)
                      rhogi(i) = rhogi(i) + fac * zsr(i)
                   end do
                end if
             end do
          end do
       end do
    end do

    deallocate(cosgt)
    deallocate(singt)
    deallocate(zsr)
    deallocate(zsi)
    !!deallocate(ylm)
    deallocate(il3)

    call tstatc0_end(id_sname)
  end subroutine add_RHOG_hard_part

  subroutine integrate_QijVnm(iqmk,potr,poti,fmr,fmi,qvr,qvi)
    implicit none
    integer, intent(in) :: iqmk
    real(kind=DP), intent(in) :: potr(nmax_G_hyb)
    real(kind=DP), intent(in) :: poti(nmax_G_hyb)
    real(kind=DP), intent(in) :: fmr(nlmta)
    real(kind=DP), intent(in) :: fmi(nlmta)
    real(kind=DP), intent(out) :: qvr(nlmta)
    real(kind=DP), intent(out) :: qvi(nlmta)

    integer :: n,it,ia,i,lmt1,lmt2,np,il1,il2,tau1,tau2,ilmta1,ilmta2
    integer :: l3,ilm3,iiqitg,iil
    integer, allocatable :: il3(:)
    real(kind=DP) :: ph, hr, hi, fac, f0
    real(kind=DP) :: cosgt, singt
    real(kind=DP) :: dr, di
    real(kind=DP), allocatable :: zsr(:), zsi(:)
    integer,save  :: id_sname = -1

    call tstatc0_begin('integrate_QijVnm ',id_sname,1)

    allocate(zsr(nmax_G_hyb))
    allocate(zsi(nmax_G_hyb))

    qvr(1:nlmta) = 0.d0
    qvi(1:nlmta) = 0.d0

    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..)

    do ia=1,natm
       it = ityp(ia)
       if( m_PP_include_vanderbilt_pot(it) == SKIP) cycle
       do i=1,nmax_G_hyb
          ph = PAI2 * dot_product(pos(ia,1:3),ngabc(i,1:3)+qmk(iqmk,1:3)) 
          cosgt = cos(ph)
          singt = sin(ph)
          zsr(i) = cosgt * potr(i) - singt * poti(i)
          zsi(i) = cosgt * poti(i) + singt * potr(i)
       end do
       do lmt1 = 1, ilmt(it)
          il1  = ltp( lmt1, it)
          tau1 = taup(lmt1, it)
          ilmta1 = lmta(lmt1,ia)
          do lmt2 = 1, ilmt(it)
             il2  = ltp( lmt2, it)
             tau2 = taup(lmt2, it)
             ilmta2 = lmta(lmt2,ia)
             dr = 0.d0
             di = 0.d0
             do np = 1, il2p(lmt1,lmt2,it)
                ilm3 = isph(lmt1,lmt2,np,it)
                l3 = il3(ilm3)
            !! Debug !!
            !!    if(l3 /= 0) cycle
            !! End Debug !!
                if(lmt2>=lmt1) then
                   iiqitg = iqitg(il1,tau1,il2,tau2,l3+1,it)
                else
                   iiqitg = iqitg(il2,tau2,il1,tau1,l3+1,it)
                end if
                if(iiqitg == 0) cycle
                f0 = iwei(ia) * dl2p(lmt1,lmt2,np,it)
                iil = mod(l3,4)
                if(iil==0) then
                   do i=1,nmax_G_hyb
                      fac = f0 * qitg_exx(i,iiqitg,iqmk) * ylm_exx(i,ilm3,iqmk)
                      dr = dr + fac * zsr(i)
                      di = di + fac * zsi(i)
                   end do
                else if(iil==1) then
                   do i=1,nmax_G_hyb
                      fac = f0 * qitg_exx(i,iiqitg,iqmk) * ylm_exx(i,ilm3,iqmk)
                      dr = dr - fac * zsi(i)
                      di = di + fac * zsr(i)
                   end do
                else if(iil==2) then
                   do i=1,nmax_G_hyb
                      fac = f0 * qitg_exx(i,iiqitg,iqmk) * ylm_exx(i,ilm3,iqmk)
                      dr = dr - fac * zsr(i)
                      di = di - fac * zsi(i)
                   end do
                else if(iil==3) then
                   do i=1,nmax_G_hyb
                      fac = f0 * qitg_exx(i,iiqitg,iqmk) * ylm_exx(i,ilm3,iqmk)
                      dr = dr + fac * zsi(i)
                      di = di - fac * zsr(i)
                   end do
                end if
             end do
             di = -di
             qvr(ilmta1) = qvr(ilmta1) + dr * fmr(ilmta2) - di * fmi(ilmta2)
             qvi(ilmta1) = qvi(ilmta1) + di * fmr(ilmta2) + dr * fmi(ilmta2)
          end do
       end do
    end do

    deallocate(zsr)
    deallocate(zsi)
    deallocate(il3)

    call tstatc0_end(id_sname)
  end subroutine integrate_QijVnm

  subroutine integrate_QijVnm2(iqmk,potr,poti,fmr,fmi,qvr,qvi)
    implicit none
    integer, intent(in) :: iqmk
    real(kind=DP), intent(in) :: potr(nmax_G_hyb)
    real(kind=DP), intent(in) :: poti(nmax_G_hyb)
    real(kind=DP), intent(in) :: fmr(nlmta)
    real(kind=DP), intent(in) :: fmi(nlmta)
    real(kind=DP), intent(out) :: qvr(nlmta)
    real(kind=DP), intent(out) :: qvi(nlmta)

    integer :: it,ia,i,lmt1,lmt2,np,il1,il2,tau1,tau2,ilmta1,ilmta2
    integer :: l3,ilm3,iiqitg,iil
    real(kind=DP) :: ph, hr, hi, fac, f0
    real(kind=DP) :: cosgt, singt
    real(kind=DP) :: dr, di
    real(kind=DP), allocatable :: zsr(:), zsi(:)

    real(kind=DP), allocatable :: qitg_red(:,:),ylm_red(:,:)
    integer :: ibl1,ibl2,iq,inn,ip,m

    integer,save  :: id_sname = -1
    call tstatc0_begin('integrate_QijVnm2 ',id_sname,1)

    if(.not.preproc_done) call hard_part_preproc()

    qvr(1:nlmta) = 0.d0
    qvi(1:nlmta) = 0.d0

    allocate(zsr(ibsize))
    allocate(zsi(ibsize))
    allocate(qitg_red(ibsize,nqitg))
    allocate(ylm_red(ibsize,n*n))
    
    do ibl1=1,nmax_G_hyb,ibsize
    ibl2=ibl1+ibsize-1
    if(ibl2.gt.nmax_G_hyb) ibl2=nmax_G_hyb

    do iq=1,nqitg
       do i=1,ibl2-ibl1+1
          qitg_red(i,iq) = qitg_exx(i+ibl1-1,iq,iqmk)
       enddo
    enddo
    do inn=1,n*n
       do i=1,ibl2-ibl1+1
          ylm_red(i,inn) = ylm_exx(i+ibl1-1,inn,iqmk)
       enddo
    enddo

    do ia=1,natm
       it = ityp(ia)
       if( m_PP_include_vanderbilt_pot(it) == SKIP) cycle
       do i=1,ibl2-ibl1+1
          ph = PAI2 * dot_product(pos(ia,1:3),ngabc(i+ibl1-1,1:3)+qmk(iqmk,1:3)) 
          cosgt = cos(ph)
          singt = sin(ph)
          zsr(i) = cosgt * potr(i+ibl1-1) - singt * poti(i+ibl1-1)
          zsi(i) = cosgt * poti(i+ibl1-1) + singt * potr(i+ibl1-1)
       end do
       do iq=nqitg_sp0(it), nqitg_sp(it)
          l3 = iq2l3(iq)
          iil = mod(l3,4)

          do m = 1, 2*l3+1
             ilm3 = l3*l3+m

             dr = 0.d0
             di = 0.d0
             if(iil==0) then
                do i=1,ibl2-ibl1+1
                   fac =  qitg_red(i,iq) * ylm_red(i,ilm3)
                   dr = dr + fac * zsr(i)
                   di = di + fac * zsi(i)
                end do
             else if(iil==1) then
                do i=1,ibl2-ibl1+1
                   fac =  qitg_red(i,iq) * ylm_red(i,ilm3)
                   dr = dr - fac * zsi(i)
                   di = di + fac * zsr(i)
                end do
             else if(iil==2) then
                do i=1,ibl2-ibl1+1
                   fac =  qitg_red(i,iq) * ylm_red(i,ilm3)
                   dr = dr - fac * zsr(i)
                   di = di - fac * zsi(i)
                end do
             else if(iil==3) then
                do i=1,ibl2-ibl1+1
                   fac =  qitg_red(i,iq) * ylm_red(i,ilm3)
                   dr = dr + fac * zsi(i)
                   di = di - fac * zsr(i)
                end do
             end if
             di = -di
             do ip=1,nc(m,iq)
                lmt1 = nc2lmt1(ip,m,iq)
                lmt2 = nc2lmt2(ip,m,iq)
                ilmta1 = lmta(lmt1,ia)
                ilmta2 = lmta(lmt2,ia)
                np = nc2n(ip,m,iq)
                f0 = iwei(ia) * dl2p(lmt1,lmt2,np,it)
                qvr(ilmta1) = qvr(ilmta1) + f0 * (dr * fmr(ilmta2) - di * fmi(ilmta2))
                qvi(ilmta1) = qvi(ilmta1) + f0 * (di * fmr(ilmta2) + dr * fmi(ilmta2))
             end do
          end do
       end do
    end do

    enddo

    deallocate(zsr)
    deallocate(zsi)

    call tstatc0_end(id_sname)
  end subroutine integrate_QijVnm2

! ================================== KT_Test ========================= 12.5Exp
  subroutine integrate_QijVnm2A(iqmk,potr,poti,fmr,fmi,qvr,qvi)
    implicit none
    integer, intent(in) :: iqmk
    real(kind=DP), intent(in) :: potr(nmax_G_hyb)
    real(kind=DP), intent(in) :: poti(nmax_G_hyb)
    real(kind=DP), intent(in) :: fmr(nlmta)
    real(kind=DP), intent(in) :: fmi(nlmta)
    real(kind=DP), intent(out) :: qvr(nlmta)
    real(kind=DP), intent(out) :: qvi(nlmta)

    integer :: it,ia,i,lmt1,lmt2,np,il1,il2,tau1,tau2,ilmta1,ilmta2
    integer :: l3,ilm3,iiqitg,iil
    real(kind=DP) :: ph, hr, hi, fac, f0
    real(kind=DP) :: cosgt, singt
    real(kind=DP) :: dr, di
    real(kind=DP), allocatable :: zsr(:), zsi(:)

    real(kind=DP), allocatable :: qitg_red(:,:),ylm_red(:,:)
    integer :: ibl1,ibl2,iq,inn,ip,m
    
    integer,save  :: id_sname = -1
    call tstatc0_begin('integrate_QijVnm2A ',id_sname,1)

    if(.not.preproc_done) call hard_part_preproc()

    qvr(1:nlmta) = 0.d0;  qvi(1:nlmta) = 0.d0

    allocate(zsr(ibsize)); allocate(zsi(ibsize))
    allocate(qitg_red(ibsize,nqitg))
    allocate(ylm_red(ibsize,n*n))
    
    do ibl1=1, nmax_G_hyb, ibsize
       ibl2=ibl1+ibsize-1

       if(ibl2.gt.nmax_G_hyb) ibl2 = nmax_G_hyb

       do iq=1,nqitg
          do i=1,ibl2-ibl1+1
             qitg_red(i,iq) = qitg_exx(i+ibl1-1,iq,iqmk)
          enddo
       enddo
       do inn=1,n*n
          do i=1,ibl2-ibl1+1
             ylm_red(i,inn) = ylm_exx(i+ibl1-1,inn,iqmk)
          enddo
       enddo
       
       do ia=1,natm
          it = ityp(ia)
          if( m_PP_include_vanderbilt_pot(it) == SKIP) cycle
          do i=1,ibl2-ibl1+1
             ph = PAI2 * dot_product(pos(ia,1:3),ngabc(i+ibl1-1,1:3)+qmk(iqmk,1:3)) 
             cosgt = cos(ph); singt = sin(ph)
             zsr(i) = cosgt * potr(i+ibl1-1) - singt * poti(i+ibl1-1)
             zsi(i) = cosgt * poti(i+ibl1-1) + singt * potr(i+ibl1-1)
          end do
          do iq=nqitg_sp0(it), nqitg_sp(it)
             l3 = iq2l3(iq)
             iil = mod(l3,4)
             
             do m = 1, 2*l3+1
                ilm3 = l3*l3+m
                
                dr = 0.d0; di = 0.d0
                if(iil==0) then
                   do i=1,ibl2-ibl1+1
                      fac =  qitg_red(i,iq) * ylm_red(i,ilm3)
                      dr = dr + fac * zsr(i)
                      di = di + fac * zsi(i)
                   end do
                else if(iil==1) then
                   do i=1,ibl2-ibl1+1
                      fac =  qitg_red(i,iq) * ylm_red(i,ilm3)
                      dr = dr - fac * zsi(i)
                      di = di + fac * zsr(i)
                   end do
                else if(iil==2) then
                   do i=1,ibl2-ibl1+1
                      fac =  qitg_red(i,iq) * ylm_red(i,ilm3)
                      dr = dr - fac * zsr(i)
                      di = di - fac * zsi(i)
                   end do
                else if(iil==3) then
                   do i=1,ibl2-ibl1+1
                      fac =  qitg_red(i,iq) * ylm_red(i,ilm3)
                      dr = dr + fac * zsi(i)
                      di = di - fac * zsr(i)
                   end do
                end if
                di = -di
                do ip=1,nc(m,iq)
                   lmt1 = nc2lmt1(ip,m,iq); lmt2 = nc2lmt2(ip,m,iq)
                   ilmta1 = lmta(lmt1,ia);  ilmta2 = lmta(lmt2,ia)
                   np = nc2n(ip,m,iq)
                   f0 = iwei(ia) * dl2p(lmt1,lmt2,np,it)
                   qvr(ilmta1) = qvr(ilmta1) + f0 * (dr * fmr(ilmta2) - di * fmi(ilmta2))
                   qvi(ilmta1) = qvi(ilmta1) + f0 * (di * fmr(ilmta2) + dr * fmi(ilmta2))
                end do
             end do
          end do
       end do
       
    enddo
    
    deallocate(zsr);  deallocate(zsi)
    deallocate(qitg_red); deallocate(ylm_red)

    call tstatc0_end(id_sname)
  end subroutine integrate_QijVnm2A
! ========================================================================= 125.Exp

  subroutine integrate_QijVnm_rs2(iqmk,potr,poti,fmrq,fmiq,qvr,qvi)
    integer, intent(in) :: iqmk
    real(kind=DP), intent(in) :: potr(nfftp_nonpara/2)
    real(kind=DP), intent(in) :: poti(nfftp_nonpara/2)
    real(kind=DP), intent(in) :: fmrq(nmesh_rs_aug_max,nlmta)
    real(kind=DP), intent(in) :: fmiq(nmesh_rs_aug_max,nlmta)
    real(kind=DP), intent(out) :: qvr(nlmta)
    real(kind=DP), intent(out) :: qvi(nlmta)
    real(kind=DP), dimension(:), allocatable :: cosqmkr,sinqmkr
    real(kind=DP), allocatable, dimension(:) :: rra,iia
    integer :: ia,it,lmt1,ilmta1
    integer :: imesh,nma,ind
    real(kind=DP) :: co,si
    real(kind=DP) :: qr,qi,qmr,qmi,rr,ii
    integer :: id_sname=-1
    call tstatc0_begin('integrate_QijVnm_rs2 ',id_sname,1)
    allocate(cosqmkr(nmesh_rs_aug_max));cosqmkr=0.d0
    allocate(sinqmkr(nmesh_rs_aug_max));sinqmkr=0.d0
    allocate(rra(nmesh_rs_aug_max));rra=0.d0
    allocate(iia(nmesh_rs_aug_max));iia=0.d0
    qvr(:) = 0.d0
    qvi(:) = 0.d0
    do ia=1,natm
       it = ityp(ia)
       if( m_PP_include_vanderbilt_pot(it) == SKIP) cycle
       call qmk_dot_r(iqmk,ia,cosqmkr,sinqmkr)
       nma = nmesh_rs_aug(ia)
       do imesh=1,nma
          ind = meshxyz_rs_aug(imesh,ia)
          co  =  cosqmkr(imesh)
          si  = -sinqmkr(imesh)
          rra(imesh) =  potr(ind)*co+poti(ind)*si
          iia(imesh) = -poti(ind)*co+potr(ind)*si
       enddo
       do lmt1=1,ilmt(it)
          ilmta1 = lmta(lmt1,ia)
          qr=0.d0;qi=0.d0
          do imesh=1,nma
             qmr = fmrq(imesh,ilmta1)
             qmi = fmiq(imesh,ilmta1)
             rr = rra(imesh)
             ii = iia(imesh)
             qr = qr+qmr*rr-qmi*ii
             qi = qi+qmr*ii+qmi*rr
          enddo
          qvr(ilmta1) = qr
          qvi(ilmta1) = qi
       enddo
    enddo
    deallocate(cosqmkr)
    deallocate(sinqmkr)
    deallocate(rra,iia)
    call tstatc0_end(id_sname)
  end subroutine integrate_QijVnm_rs2

  subroutine integrate_QijVnm_rs(iqmk,potr,poti,fmr,fmi,qvr,qvi)
    integer, intent(in) :: iqmk
    real(kind=DP), intent(in) :: potr(nfftp_nonpara/2)
    real(kind=DP), intent(in) :: poti(nfftp_nonpara/2)
    real(kind=DP), intent(in) :: fmr(nlmta)
    real(kind=DP), intent(in) :: fmi(nlmta)
    real(kind=DP), intent(out) :: qvr(nlmta)
    real(kind=DP), intent(out) :: qvi(nlmta)
    integer :: n,it,ia,imesh,lmt1,lmt2,il1,il2,tau1,tau2,ilmta1,ilmta2
    real(kind=DP), dimension(:), allocatable :: cosqmkr,sinqmkr
    real(kind=DP) :: co,si,rr,ii,rrr,iii,qr,qi,qqr,qqi,qm
    real(kind=DP), allocatable, dimension(:) :: rra,iia
    integer :: nma,ind
    integer :: id_sname=-1
    call tstatc0_begin('integrate_QijVnm_rs ',id_sname,1)
    allocate(cosqmkr(nmesh_rs_aug_max));cosqmkr=0.d0
    allocate(sinqmkr(nmesh_rs_aug_max));sinqmkr=0.d0
    allocate(rra(nmesh_rs_aug_max));rra=0.d0
    allocate(iia(nmesh_rs_aug_max));iia=0.d0
    qvr(:) = 0.d0
    qvi(:) = 0.d0
    do ia=1,natm
       it = ityp(ia)
       if( m_PP_include_vanderbilt_pot(it) == SKIP) cycle
       call qmk_dot_r(iqmk,ia,cosqmkr,sinqmkr)
       nma = nmesh_rs_aug(ia)
       do imesh=1,nma
          ind = meshxyz_rs_aug(imesh,ia)
          co  =  cosqmkr(imesh)
          si  = -sinqmkr(imesh)
          rra(imesh) =  potr(ind)*co+poti(ind)*si
          iia(imesh) = -poti(ind)*co+potr(ind)*si
       enddo
       do lmt1=1,ilmt(it)
          ilmta1 = lmta(lmt1,ia)
          qqr=0.d0;qqi=0.d0
          do lmt2 = 1, ilmt(it)
             ilmta2 = lmta(lmt2,ia)
             rr =  fmr(ilmta2)
             ii =  fmi(ilmta2)
             qr=0.d0;qi=0.d0
             do imesh=1,nma
                qm = qr_clm_ylm(imesh,ia,lmt1,lmt2)
                qr = qr+qm*rra(imesh)
                qi = qi+qm*iia(imesh)
             enddo
             qqr = qqr+(qr*rr-qi*ii)
             qqi = qqi+(qr*ii+qi*rr)
          enddo
          qvr(ilmta1) = qqr
          qvi(ilmta1) = qqi
       enddo
    enddo
    deallocate(cosqmkr)
    deallocate(sinqmkr)
    deallocate(rra,iia)
    call tstatc0_end(id_sname)
  end subroutine integrate_QijVnm_rs

  subroutine integrate_QijVnm_drv_rs(iqmk,potr,poti,fmr,fmi,dfmr,dfmi,qvr,qvi,dqvr,dqvi,gqvr,gqvi)
    integer, intent(in) :: iqmk
    real(kind=DP), intent(in) :: potr(nfftp_nonpara/2)
    real(kind=DP), intent(in) :: poti(nfftp_nonpara/2)
    real(kind=DP), intent(in) :: fmr(nlmta)
    real(kind=DP), intent(in) :: fmi(nlmta)
    real(kind=DP), intent(in) :: dfmr(nlmta,3)
    real(kind=DP), intent(in) :: dfmi(nlmta,3)
    real(kind=DP), intent(out) :: qvr(nlmta)
    real(kind=DP), intent(out) :: qvi(nlmta)
    real(kind=DP), intent(out) :: dqvr(nlmta,3)
    real(kind=DP), intent(out) :: dqvi(nlmta,3)
    real(kind=DP), intent(out) :: gqvr(nlmta,3)
    real(kind=DP), intent(out) :: gqvi(nlmta,3)
    integer :: n,it,ia,imesh,lmt1,lmt2,il1,il2,tau1,tau2,ilmta1,ilmta2
    real(kind=DP), dimension(:), allocatable :: cosqmkr,sinqmkr
    real(kind=DP) :: co,si,rr,ii,rrr,iii,qr,qi,qqr,qqi,qm
    real(kind=DP), allocatable, dimension(:) :: rra,iia
    integer :: nma,ind
    real(kind=DP) :: er(3), ei(3),dqm(3),dqqr(3),dqqi(3),der(3),dei(3),drr(3),dii(3)
    integer :: id_sname=-1
    call tstatc0_begin('integrate_QijVnm_drv_rs ',id_sname,1)
    allocate(cosqmkr(nmesh_rs_aug_max));cosqmkr=0.d0
    allocate(sinqmkr(nmesh_rs_aug_max));sinqmkr=0.d0
    allocate(rra(nmesh_rs_aug_max));rra=0.d0
    allocate(iia(nmesh_rs_aug_max));iia=0.d0
    qvr(:) = 0.d0
    qvi(:) = 0.d0
    dqvr(1:nlmta,1:3) = 0.d0
    dqvi(1:nlmta,1:3) = 0.d0
    gqvr(1:nlmta,1:3) = 0.d0
    gqvi(1:nlmta,1:3) = 0.d0
    do ia=1,natm
       it = ityp(ia)
       if( m_PP_include_vanderbilt_pot(it) == SKIP) cycle
       call qmk_dot_r(iqmk,ia,cosqmkr,sinqmkr)
       nma = nmesh_rs_aug(ia)
       do imesh=1,nma
          ind = meshxyz_rs_aug(imesh,ia)
          co  =  cosqmkr(imesh)
          si  = -sinqmkr(imesh)
          rra(imesh) =  potr(ind)*co+poti(ind)*si
          iia(imesh) = -poti(ind)*co+potr(ind)*si
       enddo
       do lmt1=1,ilmt(it)
          ilmta1 = lmta(lmt1,ia)
          qqr=0.d0;qqi=0.d0
          dqqr=0.d0;dqqi=0.d0
          der=0.d0;dei=0.d0
          do lmt2 = 1, ilmt(it)
             ilmta2 = lmta(lmt2,ia)
             rr =  fmr(ilmta2)
             ii =  fmi(ilmta2)
             drr(1:3) =  dfmr(ilmta2,1:3)
             dii(1:3) =  dfmi(ilmta2,1:3)
             qr=0.d0;qi=0.d0
             er=0.d0;ei=0.d0
             do imesh=1,nma
                qm = qr_clm_ylm(imesh,ia,lmt1,lmt2)
                dqm(1:3) = dqr_clm_ylm(imesh,ia,lmt1,lmt2,1:3)
                qr = qr+qm*rra(imesh)
                qi = qi+qm*iia(imesh)
                er(1:3) = er(1:3)+dqm(1:3)*rra(imesh)
                ei(1:3) = ei(1:3)+dqm(1:3)*iia(imesh)
             enddo
             qqr = qqr+(qr*rr-qi*ii)
             qqi = qqi+(qr*ii+qi*rr)
             dqqr(1:3) = dqqr(1:3)+qr*drr(1:3)-qi*dii(1:3)
             dqqi(1:3) = dqqi(1:3)+qr*dii(1:3)+qi*drr(1:3)
             der(1:3)  = der(1:3) +er(1:3)*rr-ei(1:3)*ii
             dei(1:3)  = dei(1:3) +er(1:3)*ii+ei(1:3)*rr
          enddo
          qvr(ilmta1) = qqr
          qvi(ilmta1) = qqi
          dqvr(ilmta1,1:3) = dqqr(1:3)
          dqvi(ilmta1,1:3) = dqqi(1:3)
          gqvr(ilmta1,1:3) = der(1:3)
          gqvi(ilmta1,1:3) = dei(1:3)
       enddo
    enddo
    deallocate(cosqmkr)
    deallocate(sinqmkr)
    deallocate(rra,iia)
    call tstatc0_end(id_sname)
  end subroutine integrate_QijVnm_drv_rs

  subroutine add_Vx_hard_part(ik,vxw,sumqvr,sumqvi)
  !!subroutine add_Vx_hard_part(ik,vxw1,sumqvr,sumqvi)
    implicit none
    integer, intent(in) :: ik
    real(kind=DP), intent(inout) :: vxw(kg1,kimg)
    !!real(kind=DP), intent(inout) :: vxw1(kg1,kimg)
    real(kind=DP), intent(in) :: sumqvr(nlmta)
    real(kind=DP), intent(in) :: sumqvi(nlmta)

    !!real(kind=DP) :: vxw(kg1,kimg)

    integer :: it,ia,i,il1,ilmtt1,ilmta1,iil,iksnl
    integer :: lmt1,lmtt1
    real(kind=DP) :: fac, ph
    real(kind=DP), allocatable :: cosgt(:) ! d(kg1)
    real(kind=DP), allocatable :: singt(:) ! d(kg1)
    integer,save  :: id_sname = -1
    call tstatc0_begin('add_Vx_hard_part ',id_sname)

    allocate(cosgt(kg1))
    allocate(singt(kg1))

    iksnl = (ik-1)/nspin + 1

    !debug
    !! vxw = 0.d0
    !end debug

    do ia=1,natm
       it = ityp(ia)
       if( m_PP_include_vanderbilt_pot(it) == SKIP) cycle
       do i=1,iba(ik)
          ph = PAI2 * dot_product(pos(ia,1:3),vkxyz(ik,1:3,BUCS)+ngabc(nbase(i,ik),1:3))
          cosgt(i) = cos(ph)
          singt(i) = sin(ph)
       end do
       do lmt1 = 1, ilmt(it)
          il1  = ltp(lmt1,it)
          lmtt1 = lmtt(lmt1,it)
          ilmta1 = lmta(lmt1,ia)
          iil=mod(il1-1,4)
          if(iil==0) then
             do i=1,iba(ik)
                fac = iwei(ia)*snl(i,lmtt1,iksnl)
                vxw(i,1) = vxw(i,1) + fac * (cosgt(i)*sumqvr(ilmta1)+singt(i)*sumqvi(ilmta1))
                if(kimg==2) vxw(i,2) = vxw(i,2) + fac * (cosgt(i)*sumqvi(ilmta1)-singt(i)*sumqvr(ilmta1))
             end do
          else if(iil==1) then
             do i=1,iba(ik)
                fac = iwei(ia)*snl(i,lmtt1,iksnl)
                vxw(i,1) = vxw(i,1) + fac * (cosgt(i)*sumqvi(ilmta1)-singt(i)*sumqvr(ilmta1))
                if(kimg==2) vxw(i,2) = vxw(i,2) - fac * (cosgt(i)*sumqvr(ilmta1)+singt(i)*sumqvi(ilmta1))
             end do
          else if(iil==2) then
             do i=1,iba(ik)
                fac = -iwei(ia)*snl(i,lmtt1,iksnl)
                vxw(i,1) = vxw(i,1) + fac * (cosgt(i)*sumqvr(ilmta1)+singt(i)*sumqvi(ilmta1))
                if(kimg==2) vxw(i,2) = vxw(i,2) + fac * (cosgt(i)*sumqvi(ilmta1)-singt(i)*sumqvr(ilmta1))
             end do
          else if(iil==3) then
             do i=1,iba(ik)
                fac = -iwei(ia)*snl(i,lmtt1,iksnl)
                vxw(i,1) = vxw(i,1) + fac * (cosgt(i)*sumqvi(ilmta1)-singt(i)*sumqvr(ilmta1))
                if(kimg==2) vxw(i,2) = vxw(i,2) - fac * (cosgt(i)*sumqvr(ilmta1)+singt(i)*sumqvi(ilmta1))
             end do
          end if
       end do
    end do

    deallocate(cosgt)
    deallocate(singt)

    !debug
    !! write(nfout,'("vxw ik =",i5)') ik
    !! write(nfout,'("vxw norm =",f10.5)') sum(vxw(1:iba(ik),1)**2+vxw(1:iba(ik),2)**2)
    !end debug

    call tstatc0_end(id_sname)
  end subroutine add_Vx_hard_part

  subroutine get_Rot_betar_dot_WFs(ik,ib,jop,kop,jtrs,fsr,fsi)
    implicit none
    integer, intent(in)                          :: ik,ib,jop,kop,jtrs
    real(kind=DP), intent(out), dimension(nlmta) :: fsr,fsi

    integer :: ilmta1,ilmta2,isph1,isph2,iy
    !!integer :: prim(3), ia
    integer :: ia
    real(kind=DP) :: prim(3)
    real(kind=DP) :: coskt(natm), sinkt(natm)
    real(kind=DP) :: ph, tmpr, tmpi
    integer,save  :: id_sname = -1
    call tstatc0_begin('get_Rot_betar_dot_WFs ',id_sname)

    if(jop==1) then
       fsr(1:nlmta) = fsr_exx(ib,1:nlmta,ik)
       fsi(1:nlmta) = fsi_exx(ib,1:nlmta,ik)
    else
       fsr = 0.d0
       fsi = 0.d0
       do ilmta1=1,nlmta       
          isph1=isph_lmta(ilmta1)
          do iy=1,nylm(isph1,jop)
             isph2 = iylm(iy,isph1,jop)
             ilmta2=lmta_rot(iy,ilmta1,jop)
             fsr(ilmta1) = fsr(ilmta1) + crotylm(iy,isph1,jop) * fsr_exx(ib,ilmta2,ik)
             fsi(ilmta1) = fsi(ilmta1) + crotylm(iy,isph1,jop) * fsi_exx(ib,ilmta2,ik)
          end do
       end do 
    end if

    if(jop>1) then
       do ia=1,natm
          !!prim(1:3) = nint( matmul(opdir(:,:,kop),pos(ia,1:3)) + tau(1:3,kop,BUCS) - pos(napt(ia,kop),1:3) )
          prim(1:3) = matmul(opdir(:,:,kop),pos(ia,1:3)) + tau(1:3,kop,BUCS) - pos(napt(ia,kop),1:3)
          ph = PAI2 * dot_product(vkxyz(ik,1:3,BUCS),prim) 
          coskt(ia) = cos(ph)
          sinkt(ia) = sin(ph)
       end do
       do ilmta1=1,nlmta
          ia = ia_lmta(ilmta1)
          tmpr = fsr(ilmta1)
          tmpi = fsi(ilmta1)
          fsr(ilmta1) = coskt(ia) * tmpr - sinkt(ia) * tmpi
          fsi(ilmta1) = coskt(ia) * tmpi + sinkt(ia) * tmpr 
       end do
    end if

    if(jtrs==1) fsi = -fsi

    call tstatc0_end(id_sname)
  end subroutine get_Rot_betar_dot_WFs

  subroutine get_expkt_fs_b(ik,ib,fsr_l,fsi_l,efsr_l,efsi_l)
    implicit none
    integer, intent(in) :: ik,ib
    real(kind=DP), intent(in), dimension(nlmta) :: fsr_l,fsi_l
    real(kind=DP), intent(out), dimension(nlmta) :: efsr_l,efsi_l

    integer :: it, ia, lmt, ilmta
    real(kind=DP) :: ph, coskt, sinkt
    efsr_l(1:nlmta) = 0.d0
    efsi_l(1:nlmta) = 0.d0
    do ia=1,natm
       it = ityp(ia)
       if( m_PP_include_vanderbilt_pot(it) == SKIP) cycle
       ph = PAI2 * dot_product(pos(ia,1:3),vkxyz(ik,1:3,BUCS))
       coskt = cos(ph)
       sinkt = sin(ph)
       do lmt = 1, ilmt(it)
          ilmta = lmta(lmt,ia)
          efsr_l(ilmta) = coskt * fsr_l(ilmta) - sinkt * fsi_l(ilmta)
          efsi_l(ilmta) = sinkt * fsr_l(ilmta) + coskt * fsi_l(ilmta)
       end do
    end do
  end subroutine get_expkt_fs_b

  subroutine get_expkt_fs(ik,fsr_l,fsi_l,efsr_l,efsi_l)
    implicit none
    integer, intent(in) :: ik
    real(kind=DP), intent(in), dimension(np_e,nlmta,ista_k:iend_k) :: fsr_l,fsi_l
    real(kind=DP), intent(out), dimension(np_e,nlmta) :: efsr_l,efsi_l

    integer :: it, ia, lmt, ilmta
    real(kind=DP) :: ph, coskt, sinkt

    efsr_l(1:np_e,1:nlmta) = 0.d0
    efsi_l(1:np_e,1:nlmta) = 0.d0
    do ia=1,natm
       it = ityp(ia)
       if( m_PP_include_vanderbilt_pot(it) == SKIP) cycle
       ph = PAI2 * dot_product(pos(ia,1:3),vkxyz(ik,1:3,BUCS))
       coskt = cos(ph)
       sinkt = sin(ph)
       do lmt = 1, ilmt(it)
          ilmta = lmta(lmt,ia)
          efsr_l(1:np_e,ilmta) = coskt * fsr_l(1:np_e,ilmta,ik) - sinkt * fsi_l(1:np_e,ilmta,ik)
          efsi_l(1:np_e,ilmta) = sinkt * fsr_l(1:np_e,ilmta,ik) + coskt * fsi_l(1:np_e,ilmta,ik)
       end do
    end do
  end subroutine get_expkt_fs

  subroutine m_ES_EXX_Force(force)
    implicit none
    real(kind=DP), intent(out) :: force(natm,3)

    integer :: ik,ib,ig,ispin,ia
    real(kind=DP), allocatable :: force_l(:,:) ! d(natm,3)
    real(kind=DP), allocatable :: force_mpi(:,:) ! d(natm,3)
    real(kind=DP), allocatable :: efsr_l(:,:) ! d(np_e,nlmta)
    real(kind=DP), allocatable :: efsi_l(:,:) ! d(np_e,nlmta)
    real(kind=DP), allocatable :: defsr_l(:,:,:) ! d(np_e,nlmta,3)
    real(kind=DP), allocatable :: defsi_l(:,:,:) ! d(np_e,nlmta,3)
    integer,save  :: id_sname = -1

    if(modnrm /= EXECUT) then
       force = 0.d0
       return
    end if

    call tstatc0_begin('m_ES_EXX_Force ',id_sname,level=1)

    call m_FFT_alloc_WF_work()

    allocate(force_l(natm,3))
    allocate(efsr_l(np_e,nlmta));efsr_l=0.d0
    allocate(efsi_l(np_e,nlmta));efsi_l=0.d0

    !!write(nfout,'("m_ES_EXX_force")')

    allocate(dfsr_l(np_e,nlmta,ista_k:iend_k,3));dfsr_l=0.d0
    allocate(dfsi_l(np_e,nlmta,ista_k:iend_k,3));dfsi_l=0.d0
    call drv_betar_dot_WFs_exx() !-> dfsr_l, dfsi_l

    allocate(dfsr_exx(nval,nlmta,kv3,3));dfsr_exx=0.d0
    allocate(dfsi_exx(nval,nlmta,kv3,3));dfsi_exx=0.d0
    call gather_drv_bdw_exx() !-> dfsr_exx, dfsi_exx

    force = 0.d0
    wf_is_real = .not.allocated(fsi_l)
    do ispin=1,nspin,af+1
       do ik=ispin, kv3+ispin-nspin, nspin
          if(map_k(ik) /= myrank_k) cycle ! MPI
          call get_expkt_fs(ik,fsr_l,fsi_l,efsr_l,efsi_l)
          do ib=1,np_e   ! MPI
             if(occup_l(ib,ik) < DELTA) cycle
             !!write(nfout,'("ispin,ik,ib=",3i5)') ispin,ik,ib
             force_l = 0.d0
             if(kimg==1) then
                call calc_EXX_Force(ispin,ik,zaj_l(1,ib,ik,1),zaj_l(1,ib,ik,1) &
                                 & ,efsr_l(ib,1:nlmta),efsr_l(ib,1:nlmta) &
                                 & ,dfsr_l(ib,1:nlmta,ik,1:3),dfsr_l(ib,1:nlmta,ik,1:3),force_l)
             else
                call calc_EXX_Force(ispin,ik,zaj_l(1,ib,ik,1),zaj_l(1,ib,ik,2) &
                                 & ,efsr_l(ib,1:nlmta),efsi_l(ib,1:nlmta) &
                                 & ,dfsr_l(ib,1:nlmta,ik,1:3),dfsi_l(ib,1:nlmta,ik,1:3),force_l)
             end if
             force = force + occup_l(ib,ik) * force_l
          end do
       end do
    end do

    force = -force / dble(kv3/nspin)
    if(nspin==1) force = 2.d0 * force
    
    deallocate(force_l)
    deallocate(efsr_l)
    deallocate(efsi_l)
    deallocate(dfsr_l)
    deallocate(dfsi_l)
    deallocate(dfsr_exx)
    deallocate(dfsi_exx)

    call m_FFT_dealloc_WF_work()

    if(npes>1) then
       allocate(force_mpi(natm,3))
       call mpi_allreduce(force,force_mpi,natm*3,MPI_DOUBLE_PRECISION,MPI_SUM,mpi_comm_group,ierr)
       force = force_mpi
       deallocate(force_mpi)
    end if

    !! Reduced coordinate -> Cartesian coordinate
    do ia=1,natm
       force(ia,1:3) = matmul(transpose(rltv),force(ia,1:3))
    end do

    call tstatc0_end(id_sname)
  end subroutine m_ES_EXX_Force

  subroutine calc_EXX_Force(ispin,ik,wfr,wfi,bdwr,bdwi,dbdwr,dbdwi,force_l)
    implicit none
    integer, intent(in)                       :: ispin, ik
    real(kind=DP), intent(in), dimension(kg1) :: wfr, wfi
    real(kind=DP), intent(in), dimension(nlmta) :: bdwr, bdwi
    real(kind=DP), intent(in), dimension(nlmta,3) :: dbdwr, dbdwi
    real(kind=DP), intent(inout), dimension(natm,3) :: force_l

    integer :: kk,m,ig,ii,jop,kop,jtrs
    integer :: jkbz
    real(kind=DP) :: fac, ph, occupation, dnorm
    real(kind=DP) :: skg(3)
    real(kind=DP), allocatable, dimension(:) :: rho,phi !d(nfft)
    real(kind=DP), allocatable, dimension(:) :: wfn,wfm !d(nfft)
! === This array is not allocated . But initialized... by tkato 2013/02/16 =====
!   real(kind=DP), allocatable, dimension(:) :: sumdel !d(nfft)
! ==============================================================================
    real(kind=DP), allocatable, dimension(:) :: rhogr, rhogi !d(kgp)
    real(kind=DP), allocatable, dimension(:) :: wfsr,wfsi !d(kg1)
    real(kind=DP), allocatable, dimension(:) :: cosgt, singt !d(kg1)
    real(kind=DP), allocatable, dimension(:) :: fsr, fsi !d(nlmta)
    real(kind=DP), allocatable, dimension(:,:) :: dfsr, dfsi !d(nlmta,3)
    real(kind=DP), allocatable, dimension(:) :: qvr, qvi !d(nlmta)
    real(kind=DP), allocatable, dimension(:,:) :: dqvr, dqvi !d(nlmta,3)
    real(kind=DP), allocatable, dimension(:,:) :: gqvr, gqvi !d(nlmta,3)
    real(kind=DP), allocatable, dimension(:) :: sumqvr, sumqvi !d(nlmta)
    real(kind=DP), allocatable, dimension(:,:) :: sumdqvr, sumdqvi !d(nlmta)
    real(kind=DP), allocatable, dimension(:) :: rhor,rhoi
    real(kind=DP), allocatable, dimension(:) :: afft
    integer,save  :: id_sname = -1
    call tstatc0_begin('calc_EXX_Force ',id_sname)

    allocate(rho(nfft))
    allocate(phi(nfft))
    allocate(wfn(nfft))
    allocate(wfm(nfft))
    allocate(rhogr(nmax_G_hyb))
    if(kimg==2) allocate(rhogi(nmax_G_hyb))
    if(sw_rspace_hyb==ON)then
       allocate(rhor(nfftp_nonpara/2));rhor=0.d0
       allocate(rhoi(nfftp_nonpara/2));rhoi=0.d0
       allocate(afft(nfftp_nonpara));afft=0.d0
    endif
    allocate(wfsr(kg1))
    if(kimg==2) allocate(wfsi(kg1))
    allocate(cosgt(kg1))
    if(kimg==2) allocate(singt(kg1))
    if(modnrm == EXECUT) then
       allocate(fsr(nlmta))
       allocate(dfsr(nlmta,3))
       allocate(fsi(nlmta))
       allocate(dfsi(nlmta,3))
       allocate(qvr(nlmta))
       allocate(qvi(nlmta))
       allocate(dqvr(nlmta,3))
       allocate(dqvi(nlmta,3))
       allocate(gqvr(nlmta,3))
       allocate(gqvi(nlmta,3))
       allocate(sumqvr(nlmta))
       allocate(sumqvi(nlmta))
       allocate(sumdqvr(nlmta,3))
       allocate(sumdqvi(nlmta,3))
       fac = 1.d0/dble(nfftwf)
       sumqvr = 0.d0
       sumdqvr = 0.d0
       sumqvi = 0.d0
       sumdqvi = 0.d0
    end if

    call map_WFG_on_FFT_box(ik,wfr,wfi,wfn)
    call m_FFT_WF(ELECTRON,nfout,wfn,INVERSE,OFF) ! wfn(R)

! === This array is not allocated . But initialized... by tkato 2013/02/16 =====
!   sumdel = 0.d0
! ==============================================================================

    do jkbz=1,kv3bz
       if(.not.q_on_k_centered_mesh(jkbz,ik)) cycle
       ! q(bz) = S*k(ibz)
       kk = ikp(jkbz) + ispin - 1
       kop = iops(jkbz)
       jop = iopt(jkbz) 
       jtrs = itrs(jkbz)
!! Debug
!!       if(check_bz_k(jkbz)) cycle
!!
       !Debug!  write(nfout,'("jkbz=",i5," kk=",i5," jop=",i5," jtrs=",i5)') jkbz,kk,jop,jtrs
       if(kimg==1) then
          do ig=1,iba(kk)
             ii = nbase(ig,kk)
             skg(1:3) = vkxyz(kk,1:3,BUCS) + ngabc(ii,1:3)
             ph = PAI2 * dot_product(skg,tau(:,kop,BUCS))
             cosgt(ig) = cos(ph)
          end do
       else
          do ig=1,iba(kk)
             ii = nbase(ig,kk)
             skg(1:3) = vkxyz(kk,1:3,BUCS) + ngabc(ii,1:3)
             ph = PAI2 * dot_product(skg,tau(:,kop,BUCS))
             cosgt(ig) = cos(ph)
             singt(ig) = sin(ph)
          end do
       end if
       do m=1,nval
          if(occup_val(m,kk) < DELTA) cycle
!          if(sw_rsb==ON)then
!             if(.not.overlap(ib,m))cycle
!          endif
          occupation = wbz(jkbz) * occup_val(m,kk)/qwgt(kk)/dble(kv3)
          !Debug!write(nfout,'("m=",i5," occp=",f15.5)') m, occupation
          if(kimg==1) then
             dnorm = 0.d0
             do ig=1,iba(kk)
                wfsr(ig) = wfv(ig,m,kk,1) * cosgt(ig)  
                dnorm = dnorm + wfsr(ig)*wfsr(ig)
             end do
             dnorm = 1.d0/sqrt(dnorm)
             wfsr = wfsr * dnorm
             call map_Rot_WFG_on_FFT_box(kk,jop,jtrs,wfsr,wfsr,wfm)
          else
             if(jtrs==0) then
                do ig=1,iba(kk)
                   wfsr(ig) = wfv(ig,m,kk,1) * cosgt(ig) - wfv(ig,m,kk,2) * singt(ig)
                   wfsi(ig) = wfv(ig,m,kk,2) * cosgt(ig) + wfv(ig,m,kk,1) * singt(ig)
                end do
             else
                do ig=1,iba(kk)
                   wfsr(ig) = wfv(ig,m,kk,1) * cosgt(ig) - wfv(ig,m,kk,2) * singt(ig)
                   wfsi(ig) = -wfv(ig,m,kk,2) * cosgt(ig) - wfv(ig,m,kk,1) * singt(ig)
                end do
             end if
             call map_Rot_WFG_on_FFT_box(kk,jop,jtrs,wfsr,wfsi,wfm)
          end if
          call m_FFT_WF(ELECTRON,nfout,wfm,INVERSE,OFF) ! wfm(R)
          call product_on_FFT_box(wfn,wfm,rho) ! rho_soft(R)
          call m_FFT_WF(ELECTRON,nfout,rho,DIRECT,OFF) ! rho_soft(G)

          if(kimg==1) then
             call map_FFT_box_on_RHOG(rhogr,rhogr,rho)
             do ii=1,nmax_G_hyb
                rhogr(ii) = vc(ii,iqmk(jkbz,ik)) * rhogr(ii) ! phi(G) = Vc(G,q) * rho(G)
             end do
             call map_RHOG_on_FFT_box(rhogr,rhogr,phi)
          else
             call map_FFT_box_on_RHOG(rhogr,rhogi,rho)
             !! rho(G) = rho_soft(G) + rho_hard(G)

             do ii=1, min( kg, nmax_G_hyb )
                rhogr(ii) = fac * rhogr(ii)
                rhogi(ii) = fac * rhogi(ii)
             end do
             do ii=kg+1,nmax_G_hyb
                rhogr(ii) = 0.d0
                rhogi(ii) = 0.d0
             end do

             call get_Rot_betar_dot_WFs_drv(kk,m,jop,kop,jtrs,fsr,fsi,dfsr,dfsi)

#ifdef HYB_ORG
             call add_RHOG_hard_part(iqmk(jkbz,ik),rhogr,rhogi,bdwr,bdwi,fsr,fsi)
#else
             if(sw_rspace_hyb==ON)then
                if(sw_precalculate==OFF)then
                   call add_RHOG_hard_part_rs(iqmk(jkbz,ik),rhor,rhoi,bdwr,bdwi,fsr,fsi)
                else
                   call add_RHOG_hard_part_rs2(iqmk(jkbz,ik),rhor,rhoi,&
                 & fsrqm(:,:,m,jkbz,ispin),fsiqm(:,:,m,jkbz,ispin),bdwr,bdwi)
                endif
                call map_RHOG_on_FFT_box_hard(rhor,rhoi,afft)
                call m_FFT_CD0(nfout,afft,DIRECT)
                call map_FFT_box_on_RHOG_hard(rhor,rhoi,afft)
                do ii=1,nmax_G_hyb
                   rhogr(ii) = rhogr(ii) + rhor(ii)
                   rhogi(ii) = rhogi(ii) + rhoi(ii)
                end do
             else
                call add_RHOG_hard_part2(iqmk(jkbz,ik),rhogr,rhogi,bdwr,bdwi,fsr,fsi)
             endif
#endif
             do ii=1,nmax_G_hyb
                rhogr(ii) = vc(ii,iqmk(jkbz,ik)) * rhogr(ii) ! phi(G) = Vc(G,q) * rho(G)
                rhogi(ii) = vc(ii,iqmk(jkbz,ik)) * rhogi(ii) ! phi(G) = Vc(G,q) * rho(G)
             end do

             !! Dij[Vnm] = Sum_G Qij(G) * Vnm(G)
             !! hi[Vnm] = Sum_j Dij[Vnm] <beta_j|psi_m>
             !! Hi[Vnm] = Sum_j Dij[Vnm] <dbeta_j/dR|psi_m>
             !! Eij[Vnm] = -i Sum_G G * Qij(G) * Vnm(G)
             !! Ki[Vnm] = Sum_j Eij[Vnm] <beta_j|psi_m>
             if(sw_rspace_hyb==ON)then
                call map_RHOG_on_FFT_box_hard_inv(rhogr,rhogi,afft)
                call m_FFT_CD0(nfout,afft,INVERSE)
                call map_FFT_box_on_RHOG_hard_inv(rhor,rhoi,afft)
                call integrate_QijVnm_drv_rs(iqmk(jkbz,ik),rhor,rhoi,fsr,fsi,dfsr,dfsi,qvr,qvi,dqvr,dqvi,gqvr,gqvi)
             else
                call integrate_QijVnm_drv(iqmk(jkbz,ik),rhogr,rhogi,fsr,fsi,dfsr,dfsi,qvr,qvi,dqvr,dqvi,gqvr,gqvi)
             endif
             !Debug!
             !do ii=1,nlmta
             !   write(nfout,'(i5,1x,"fsr=",f20.5,1x,"fsi=",f20.5)') ii,fsr(ii),fsi(ii)
             !end do
             !do ii=1,nlmta
             !   write(nfout,'(i5,1x,"dfsr=",3f20.5)') ii,dfsr(ii,1:3)
             !   write(nfout,'(i5,1x,"dfsi=",3f20.5)') ii,dfsi(ii,1:3)
             !end do
             !do ii=1,nlmta
             !   write(nfout,'(i5,1x,"qvr=",f20.5,1x,"qvi=",f20.5)') ii,qvr(ii),qvi(ii)
             !end do
             !do ii=1,nlmta
             !   write(nfout,'(i5,1x,"dqvr=",3f20.5)') ii,dqvr(ii,1:3)
             !   write(nfout,'(i5,1x,"dqvi=",3f20.5)') ii,dqvi(ii,1:3)
             !end do
             !do ii=1,nlmta
             !   write(nfout,'(i5,1x,"gqvr=",3f20.5)') ii,gqvr(ii,1:3)
             !   write(nfout,'(i5,1x,"gqvi=",3f20.5)') ii,gqvi(ii,1:3)
             !end do
             !End Debug!

          end if

          !! Bin = Sum_m fm * hi[Vnm]
          !! Cin = Sum_m fm * ( Hi[Vnm] + Ki[Vnm] )
          sumqvr = sumqvr + occupation * qvr ! sum_m qvr_m
          sumqvi = sumqvi + occupation * qvi ! sum_m qvi_m
          sumdqvr = sumdqvr + occupation * (dqvr+gqvr) ! sum_m (dqvr_m + gqvr_m)
          sumdqvi = sumdqvi + occupation * (dqvi+gqvi) ! sum_m (dqvi_m + gqvi_m)
       end do 
    end do 

    !! dEXX/dR(n) = Sum_i Re[ <psi_n|dbeta_i/dR> * Bin +  <psi_n|beta_i> * Cin ]
    call sum_EXX_force_terms(force_l,bdwr,bdwi,dbdwr,dbdwi,sumqvr,sumqvi,sumdqvr,sumdqvi)

    deallocate(rho)
    deallocate(phi)
    deallocate(wfn)
    deallocate(wfm)
    deallocate(rhogr)
    if(kimg==2) deallocate(rhogi)
    deallocate(wfsr)
    if(kimg==2) deallocate(wfsi)
    deallocate(cosgt)
    if(kimg==2) deallocate(singt)
    deallocate(fsr)
    deallocate(fsi)
    deallocate(dfsr)
    deallocate(dfsi)
    deallocate(qvr)
    deallocate(qvi)
    deallocate(dqvr)
    deallocate(dqvi)
    deallocate(gqvr)
    deallocate(gqvi)
    deallocate(sumqvr)
    deallocate(sumqvi)
    deallocate(sumdqvr)
    deallocate(sumdqvi)

    if(sw_rspace_hyb==ON)then
       deallocate(rhor)
       deallocate(rhoi)
       deallocate(afft)
    endif
    !!stop 'Debug: calc_EXX_Force'

    call tstatc0_end(id_sname)
  end subroutine calc_EXX_Force

  subroutine sum_EXX_force_terms(force_l,bdwr,bdwi,dbdwr,dbdwi,sumqvr,sumqvi,sumdqvr,sumdqvi)
    implicit none
    real(kind=DP), intent(inout) :: force_l(natm,3)
    real(kind=DP), intent(in) :: bdwr(nlmta), bdwi(nlmta)
    real(kind=DP), intent(in) :: dbdwr(nlmta,3), dbdwi(nlmta,3)
    real(kind=DP), intent(in) :: sumqvr(nlmta), sumqvi(nlmta)
    real(kind=DP), intent(in) :: sumdqvr(nlmta,3), sumdqvi(nlmta,3)

    integer :: ia,it,lmt1,ip

    do ia=1,natm
       it=ityp(ia)
       if( m_PP_include_vanderbilt_pot(it) == SKIP) cycle
       do lmt1 = 1, ilmt(it)
          ip = lmta(lmt1,ia)
          force_l(ia,1:3) = force_l(ia,1:3) &
                        & + dbdwr(ip,1:3)*sumqvr(ip) + dbdwi(ip,1:3)*sumqvi(ip) &
                        & + bdwr(ip)*sumdqvr(ip,1:3) + bdwi(ip)*sumdqvi(ip,1:3)
       end do
    end do
  end subroutine sum_EXX_force_terms

  subroutine get_Rot_betar_dot_WFs_drv(ik,ib,jop,kop,jtrs,fsr,fsi,dfsr,dfsi)
    implicit none
    integer, intent(in)                          :: ik,ib,jop,kop,jtrs
    real(kind=DP), intent(out), dimension(nlmta) :: fsr,fsi
    real(kind=DP), intent(out), dimension(nlmta,3) :: dfsr,dfsi

    integer :: ilmta1,ilmta2,isph1,isph2,iy
    !!integer :: prim(3), ia
    integer :: ia, i
    real(kind=DP) :: prim(3)
    real(kind=DP) :: coskt(natm), sinkt(natm)
    real(kind=DP) :: ph, tmpr, tmpi
    integer,save  :: id_sname = -1
    call tstatc0_begin('get_Rot_betar_dot_WFs_drv ',id_sname)

    if(jop==1) then
       fsr(1:nlmta) = fsr_exx(ib,1:nlmta,ik)
       fsi(1:nlmta) = fsi_exx(ib,1:nlmta,ik)
       dfsr(1:nlmta,1:3) = dfsr_exx(ib,1:nlmta,ik,1:3)
       dfsi(1:nlmta,1:3) = dfsi_exx(ib,1:nlmta,ik,1:3)
    else
       fsr = 0.d0
       fsi = 0.d0
       dfsr = 0.d0
       dfsi = 0.d0
       do ilmta1=1,nlmta       
          isph1=isph_lmta(ilmta1)
          do iy=1,nylm(isph1,jop)
             isph2 = iylm(iy,isph1,jop)
             ilmta2=lmta_rot(iy,ilmta1,jop)
             fsr(ilmta1) = fsr(ilmta1) + crotylm(iy,isph1,jop) * fsr_exx(ib,ilmta2,ik)
             fsi(ilmta1) = fsi(ilmta1) + crotylm(iy,isph1,jop) * fsi_exx(ib,ilmta2,ik)
             dfsr(ilmta1,1:3) = dfsr(ilmta1,1:3) + crotylm(iy,isph1,jop) * dfsr_exx(ib,ilmta2,ik,1:3)
             dfsi(ilmta1,1:3) = dfsi(ilmta1,1:3) + crotylm(iy,isph1,jop) * dfsi_exx(ib,ilmta2,ik,1:3)
          end do
       end do 
    end if

    if(jop>1) then
       do ia=1,natm
          !!prim(1:3) = nint( matmul(opdir(:,:,kop),pos(ia,1:3)) + tau(1:3,kop,BUCS) - pos(napt(ia,kop),1:3) )
          prim(1:3) = matmul(opdir(:,:,kop),pos(ia,1:3)) + tau(1:3,kop,BUCS) - pos(napt(ia,kop),1:3)
          ph = PAI2 * dot_product(vkxyz(ik,1:3,BUCS),prim) 
          coskt(ia) = cos(ph)
          sinkt(ia) = sin(ph)
       end do
       do ilmta1=1,nlmta
          ia = ia_lmta(ilmta1)
          tmpr = fsr(ilmta1)
          tmpi = fsi(ilmta1)
          fsr(ilmta1) = coskt(ia) * tmpr - sinkt(ia) * tmpi
          fsi(ilmta1) = coskt(ia) * tmpi + sinkt(ia) * tmpr 
          do i=1,3
             tmpr = dfsr(ilmta1,i)
             tmpi = dfsi(ilmta1,i)
             dfsr(ilmta1,i) = coskt(ia) * tmpr - sinkt(ia) * tmpi
             dfsi(ilmta1,i) = coskt(ia) * tmpi + sinkt(ia) * tmpr 
          end do
       end do
    end if

    if(jtrs==1) then
       fsi = -fsi
       dfsi = -dfsi
    end if

    call tstatc0_end(id_sname)
  end subroutine get_Rot_betar_dot_WFs_drv

  subroutine integrate_QijVnm_drv(iqmk,potr,poti,fmr,fmi,dfmr,dfmi,qvr,qvi,dqvr,dqvi,gqvr,gqvi)
    implicit none
    integer, intent(in) :: iqmk
    real(kind=DP), intent(in) :: potr(nmax_G_hyb)
    real(kind=DP), intent(in) :: poti(nmax_G_hyb)
    real(kind=DP), intent(in) :: fmr(nlmta)
    real(kind=DP), intent(in) :: fmi(nlmta)
    real(kind=DP), intent(in) :: dfmr(nlmta,3)
    real(kind=DP), intent(in) :: dfmi(nlmta,3)
    real(kind=DP), intent(out) :: qvr(nlmta)
    real(kind=DP), intent(out) :: qvi(nlmta)
    real(kind=DP), intent(out) :: dqvr(nlmta,3)
    real(kind=DP), intent(out) :: dqvi(nlmta,3)
    real(kind=DP), intent(out) :: gqvr(nlmta,3)
    real(kind=DP), intent(out) :: gqvi(nlmta,3)

    integer :: n,it,ia,i,j,lmt1,lmt2,np,il1,il2,tau1,tau2,ilmta1,ilmta2
    integer :: l3,ilm3,iiqitg,iil
    integer, allocatable :: il3(:)
    real(kind=DP) :: ph, hr, hi, fac, f0
    real(kind=DP) :: cosgt, singt
    real(kind=DP) :: fr, fi
    real(kind=DP) :: dr, di
    real(kind=DP) :: er(3), ei(3)
    real(kind=DP), allocatable :: zsr(:), zsi(:)
    real(kind=DP), allocatable :: gvec(:,:)
    integer,save  :: id_sname = -1
    call tstatc0_begin('integrate_QijVnm_drv ',id_sname)

    allocate(zsr(nmax_G_hyb))
    allocate(zsi(nmax_G_hyb))
    allocate(gvec(nmax_G_hyb,3))

    qvr(1:nlmta) = 0.d0
    qvi(1:nlmta) = 0.d0
    dqvr(1:nlmta,1:3) = 0.d0
    dqvi(1:nlmta,1:3) = 0.d0
    gqvr(1:nlmta,1:3) = 0.d0
    gqvi(1:nlmta,1:3) = 0.d0

    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..)

    do j=1,3
       do i=1,nmax_G_hyb
          gvec(i,j) = ngabc(i,j) + qmk(iqmk,j)
       end do
    end do

    do ia=1,natm
       it = ityp(ia)
       if( m_PP_include_vanderbilt_pot(it) == SKIP) cycle
       do i=1,nmax_G_hyb
          ph = PAI2 * dot_product(pos(ia,1:3),gvec(i,1:3)) 
          cosgt = cos(ph)
          singt = sin(ph)
          zsr(i) = cosgt * potr(i) - singt * poti(i)
          zsi(i) = cosgt * poti(i) + singt * potr(i)
       end do
       do lmt1 = 1, ilmt(it)
          il1  = ltp( lmt1, it)
          tau1 = taup(lmt1, it)
          ilmta1 = lmta(lmt1,ia)
          do lmt2 = 1, ilmt(it)
             il2  = ltp( lmt2, it)
             tau2 = taup(lmt2, it)
             ilmta2 = lmta(lmt2,ia)
             dr = 0.d0
             di = 0.d0
             er(1:3) = 0.d0
             ei(1:3) = 0.d0
             do np = 1, il2p(lmt1,lmt2,it)
                ilm3 = isph(lmt1,lmt2,np,it)
                l3 = il3(ilm3)
           !! Debug !!
           !!    if(l3 /= 0) cycle
           !! End Debug !!
                if(lmt2>=lmt1) then
                   iiqitg = iqitg(il1,tau1,il2,tau2,l3+1,it)
                else
                   iiqitg = iqitg(il2,tau2,il1,tau1,l3+1,it)
                end if
                if(iiqitg == 0) cycle
                f0 = iwei(ia) * dl2p(lmt1,lmt2,np,it)
                iil = mod(l3,4)
                if(iil==0) then
                   do i=1,nmax_G_hyb
                      fac = f0 * qitg_exx(i,iiqitg,iqmk) * ylm_exx(i,ilm3,iqmk)
                      fr = fac * zsr(i)
                      fi = fac * zsi(i)
                      dr = dr + fr
                      di = di + fi
                      er = er + fr * gvec(i,1:3)
                      ei = ei + fi * gvec(i,1:3)
                   end do
                else if(iil==1) then
                   do i=1,nmax_G_hyb
                      fac = f0 * qitg_exx(i,iiqitg,iqmk) * ylm_exx(i,ilm3,iqmk)
                      fr = - fac * zsi(i) 
                      fi =   fac * zsr(i)
                      dr = dr + fr
                      di = di + fi
                      er = er + fr * gvec(i,1:3)
                      ei = ei + fi * gvec(i,1:3)
                   end do
                else if(iil==2) then
                   do i=1,nmax_G_hyb
                      fac = f0 * qitg_exx(i,iiqitg,iqmk) * ylm_exx(i,ilm3,iqmk)
                      fr = - fac * zsr(i)
                      fi = - fac * zsi(i)
                      dr = dr + fr
                      di = di + fi
                      er = er + fr * gvec(i,1:3)
                      ei = ei + fi * gvec(i,1:3)
                   end do
                else if(iil==3) then
                   do i=1,nmax_G_hyb
                      fac = f0 * qitg_exx(i,iiqitg,iqmk) * ylm_exx(i,ilm3,iqmk)
                      fr =   fac * zsi(i)
                      fi = - fac * zsr(i)
                      dr = dr + fr
                      di = di + fi
                      er = er + fr * gvec(i,1:3)
                      ei = ei + fi * gvec(i,1:3)
                   end do
                end if
             end do
             di = -di
             ei = -ei
             qvr(ilmta1) = qvr(ilmta1) + dr * fmr(ilmta2) - di * fmi(ilmta2)
             qvi(ilmta1) = qvi(ilmta1) + di * fmr(ilmta2) + dr * fmi(ilmta2)
             dqvr(ilmta1,1:3) = dqvr(ilmta1,1:3) + dr * dfmr(ilmta2,1:3) - di * dfmi(ilmta2,1:3)
             dqvi(ilmta1,1:3) = dqvi(ilmta1,1:3) + di * dfmr(ilmta2,1:3) + dr * dfmi(ilmta2,1:3)
             gqvr(ilmta1,1:3) = gqvr(ilmta1,1:3) + ei(1:3) * fmr(ilmta2) + er(1:3) * fmi(ilmta2)
             gqvi(ilmta1,1:3) = gqvi(ilmta1,1:3) - er(1:3) * fmr(ilmta2) + ei(1:3) * fmi(ilmta2)
          end do
       end do
    end do

    deallocate(zsr)
    deallocate(zsi)
    deallocate(gvec)
    deallocate(il3)

    call tstatc0_end(id_sname)
  end subroutine integrate_QijVnm_drv

  subroutine gather_drv_bdw_exx()
    implicit none

    integer :: ik,ib,ib1,ibm,irev
    real(kind=DP), allocatable :: dfsr_mpi(:,:,:,:) ! d(nval,nlmta,kv3,3)
    real(kind=DP), allocatable :: dfsi_mpi(:,:,:,:) ! d(nval,nlmta,kv3,3)

    integer,save  :: id_sname = -1

    call tstatc0_begin('gather_drv_bdw_exx ',id_sname)

    dfsr_exx = 0.d0
    dfsi_exx = 0.d0

    do ik=1,kv3,af+1
       if(map_k(ik) /= myrank_k) cycle
       do ib=1,nval
          ib1 = neordr(ib,ik)
          if(map_e(ib1) == myrank_e) then
             dfsr_exx(ib,1:nlmta,ik,1:3) = dfsr_l(map_z(ib1),1:nlmta,ik,1:3)
             dfsi_exx(ib,1:nlmta,ik,1:3) = dfsi_l(map_z(ib1),1:nlmta,ik,1:3)
          end if
       end do
    end do    

    if(npes>1) then
       allocate(dfsr_mpi(nval,nlmta,kv3,3))
       allocate(dfsi_mpi(nval,nlmta,kv3,3))
       call mpi_allreduce(dfsr_exx,dfsr_mpi,nval*nlmta*kv3*3,MPI_DOUBLE_PRECISION,MPI_SUM,mpi_comm_group,ierr)
       call mpi_allreduce(dfsi_exx,dfsi_mpi,nval*nlmta*kv3*3,MPI_DOUBLE_PRECISION,MPI_SUM,mpi_comm_group,ierr)
       dfsr_exx = dfsr_mpi
       dfsi_exx = dfsi_mpi
       deallocate(dfsr_mpi)
       deallocate(dfsi_mpi)
    end if

    call tstatc0_end(id_sname)
  end subroutine gather_drv_bdw_exx

  subroutine drv_betar_dot_WFs_exx()
    implicit none

    integer :: ik,ib,it,ia,i,il1,ilmtt1,ilmta1,iil,iksnl
    integer :: lmt1,lmtt1
    real(kind=DP) :: fac, ph, fr, fi
    real(kind=DP), allocatable :: cosgt(:) ! d(kg1)
    real(kind=DP), allocatable :: singt(:) ! d(kg1)
    real(kind=DP), allocatable :: gvec(:,:) ! d(kg1,3)

    integer,save  :: id_sname = -1
    call tstatc0_begin('drv_betar_dot_WFs_exx ',id_sname)

    allocate(cosgt(kg1))
    allocate(singt(kg1))
    allocate(gvec(kg1,3))

    dfsr_l = 0.d0
    dfsi_l = 0.d0

    do ik=1,kv3,af+1
       if(map_k(ik) /= myrank_k) cycle ! MPI
       iksnl = (ik-1)/nspin + 1
       do ia=1,natm
          it = ityp(ia)
          if( m_PP_include_vanderbilt_pot(it) == SKIP) cycle
          do i=1,iba(ik)
             gvec(i,1:3) = vkxyz(ik,1:3,BUCS)+ngabc(nbase(i,ik),1:3)
             ph = PAI2 * dot_product(pos(ia,1:3),gvec(i,1:3))
             cosgt(i) = cos(ph)
             singt(i) = sin(ph)
          end do
          do lmt1 = 1, ilmt(it)
             il1  = ltp(lmt1,it)
             lmtt1 = lmtt(lmt1,it)
             ilmta1 = lmta(lmt1,ia)
             iil=mod(il1,4) !! i^(L+1)
             if(iil==0) then
                do ib=1,np_e
                   if(occup_l(ib,ik) < DELTA) cycle
                   do i=1,iba(ik)
                      fac = snl(i,lmtt1,iksnl)
                      fr = fac * ( cosgt(i)*zaj_l(i,ib,ik,1)-singt(i)*zaj_l(i,ib,ik,2) )
                      fi = fac * ( cosgt(i)*zaj_l(i,ib,ik,2)+singt(i)*zaj_l(i,ib,ik,1) )
                      dfsr_l(ib,ilmta1,ik,1:3) = dfsr_l(ib,ilmta1,ik,1:3) + gvec(i,1:3) * fr
                      dfsi_l(ib,ilmta1,ik,1:3) = dfsi_l(ib,ilmta1,ik,1:3) + gvec(i,1:3) * fi
                   end do
                end do
             else if(iil==1) then
                do ib=1,np_e
                   if(occup_l(ib,ik) < DELTA) cycle
                   do i=1,iba(ik)
                      fac = snl(i,lmtt1,iksnl)
                      fr = -fac * ( cosgt(i)*zaj_l(i,ib,ik,2)+singt(i)*zaj_l(i,ib,ik,1) )
                      fi =  fac * ( cosgt(i)*zaj_l(i,ib,ik,1)-singt(i)*zaj_l(i,ib,ik,2) )
                      dfsr_l(ib,ilmta1,ik,1:3) = dfsr_l(ib,ilmta1,ik,1:3) + gvec(i,1:3) * fr
                      dfsi_l(ib,ilmta1,ik,1:3) = dfsi_l(ib,ilmta1,ik,1:3) + gvec(i,1:3) * fi
                   end do
                end do
             else if(iil==2) then
                do ib=1,np_e
                   if(occup_l(ib,ik) < DELTA) cycle
                   do i=1,iba(ik)
                      fac = snl(i,lmtt1,iksnl)
                      fr = -fac * ( cosgt(i)*zaj_l(i,ib,ik,1)-singt(i)*zaj_l(i,ib,ik,2) )
                      fi = -fac * ( cosgt(i)*zaj_l(i,ib,ik,2)+singt(i)*zaj_l(i,ib,ik,1) )
                      dfsr_l(ib,ilmta1,ik,1:3) = dfsr_l(ib,ilmta1,ik,1:3) + gvec(i,1:3) * fr
                      dfsi_l(ib,ilmta1,ik,1:3) = dfsi_l(ib,ilmta1,ik,1:3) + gvec(i,1:3) * fi
                   end do
                end do
             else if(iil==3) then
                do ib=1,np_e
                   if(occup_l(ib,ik) < DELTA) cycle
                   do i=1,iba(ik)
                      fac = snl(i,lmtt1,iksnl)
                      fr =  fac * ( cosgt(i)*zaj_l(i,ib,ik,2)+singt(i)*zaj_l(i,ib,ik,1) )
                      fi = -fac * ( cosgt(i)*zaj_l(i,ib,ik,1)-singt(i)*zaj_l(i,ib,ik,2) )
                      dfsr_l(ib,ilmta1,ik,1:3) = dfsr_l(ib,ilmta1,ik,1:3) + gvec(i,1:3) * fr
                      dfsi_l(ib,ilmta1,ik,1:3) = dfsi_l(ib,ilmta1,ik,1:3) + gvec(i,1:3) * fi
                   end do
                end do
             end if
          end do
       end do
    end do

    deallocate(cosgt)
    deallocate(singt)
    deallocate(gvec)

    call tstatc0_end(id_sname)
  end subroutine drv_betar_dot_WFs_exx

end module m_ES_ExactExchange
