#ifdef NEC_TIMER
#  define START_TIMER(a) call start_timer(a)
#  define STOP_TIMER(a)  call stop_timer(a)
#else
#  define START_TIMER(a)
#  define STOP_TIMER(a)
#endif
!=======================================================================
!
!  PROGRAM  PHASE/0 2014.03 ($Rev$)
!
!  MODULE:  m_ES_WF_by_SDorCG
!
!  AUTHOR(S): T. Yamasaki   August/20/2003
!  
!  FURTHER MODIFICATION: T. Yamasaki, January/13/2004
!  
!  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_WF_by_SDorCG
!     (m_ESsd or m_ESSD)
! $Id: m_ES_WF_by_SDorCG.F90.01 409 2014-10-27 09:24:52Z jkoga $
! This module evolves wave functions.
! MSD: modified steepest descent algorithm (Original subroutine name was
! "msdv").
! Following lines are comments in the "msdv".
!
!!$C ref.: Williams and Soler, Bull.Am.Phys.Soc.32 ('87),p562.
!!$c
!!$c      revised by T.Yamasaki
!!$c         #1) 2 folding inline expansion at an do loop of NEG is 
!!$c            rewrited as before as a simple do loop
!!$c                                               5th May 1994
!!$c         #2) Parallelization                   9th May 1994
!!$c         #3) Parallelization transient
!!$c                         by T.Yamasaki        15th May 1994
!!$c
!!$c         #4)  Following arrays are removed from the arguments.
!!$c                                  ----> 31th May '94 Y.M
!!$cc   >        VXC,CHGQ,PSC,ZFM3,
!!$c                                  ----> 3rd June '94, Y.M.
!!$cc   W        W31,
!!$c                                  ----> 3rd June '94, Y.M.
!!$cc   W        W310,
!!$c
!!$c         #5)  data array size is reduced by T.Yamasaki
!!$c             snlfmc(kng1,klmt),snlfms(kng1,klmt)
!!$c          -->  snlfmc(kng1), snlfms(kng1)       on 17th Jun. 1994
!!$c
!!$c         #6) Data parallelization               on 24th Jun. 1994
!!$c                 eko --> eko_l             by T.Yamasaki  
!!$c         #7) indx0 is removed                      26th Jun. 1994
!!$c         #8) Interface has changed                 27th Jun. 1994
!!$c         #9) imsd is added in the argument list     4th Aug. 1994
!!$cc      imsd = 1
!!$cc    for preconditioning IMSD=2   '94.6.14 Tsuyoshi Miyazaki
!!$cc      imsd = 2
!!$c         #10) ivanl is inserted in the arugment list  13th Sep. 1994
!!$c         #11) A do loop of 450 is tuned up.        15th Sep. 1994
!!$c         #12) Spin polarization is introduced.     11th Dec. 1994
!!$c         #13) vlhxc --> vlhxc_l                    31st Jan. 1995
!!$c                                          by T.Yamasaki
!!$c         #14) gx,gy,gz --> ngabc, vx,vy,vz --> vkxyz
!!$c                   by T.Yamasaki                on 15th Feb. 1995
!!$c         #15) antiferromagnetic calculation is added on 9th Jul. 1996
!!$c                                          by H.Sawada
!
! The "msdv" subroutine was translated into a subroutine,
! "evolve_WFs_in_MSD_direction" by T. Yamasaki in 1999.
!
  use m_Control_Parameters,  only : nspin,ipri,iprisolver,kimg,neg,af
  use m_Const_Parameters,    only : DP,SP,DIRECT,ON,SD,MSD,eazyCG,CG,SKIP,EXECUT,zi &
 &                                , ORTHONORMALIZATION, NORMALIZATION, ELECTRON &
 &                                , OTHER_BANDS, SAME_BAND, ALL_BANDS, SCF, OFF, GAMMA
  use m_Crystal_Structure,   only : rltv
  use m_Electronic_Structure,only : zaj_l, afft,bfft &
 &                                , eko_l,vnlph_l,vlhxcQ &
 &                                , vlhxc_l &
 &                                , m_ES_sum_of_LocalPart,m_ES_sum_of_LocalPart2
!FNS  use m_ES_ortho            ,only : m_ES_MGS_4_each_k                                 &
  use m_ES_ortho            ,only : m_ES_MGS_4_each_k   
  use m_ES_nonlocal         ,only : sc,ss,qc                                          &
 &                                , m_ES_dealloc_afft_scss_etc                        
!FNS  use m_FFT,                 only : nfft, fft_box_size_WF, m_FFT_Vlocal_W, m_FFT_WF
  use m_FFT,                 only : nfft, fft_box_size_WF
  use m_Ionic_System,        only : ntyp, natm, ityp, iwei
  use m_Kpoints,             only : kv3,vkxyz,k_symmetry
  use m_NonLocal_Potential,  only : snl
  use m_Files,               only : nfout
  use m_Parallelization,     only : mpi_comm_group,is_kngp,ie_kngp,npes,mype &
       &, nrank_e, myrank_e, map_e, ista_e, iend_e, istep_e, map_z, np_e &
       &, nrank_k, myrank_k, map_k, ista_k, iend_k, mpi_k_world, nis_k, nel_k, ierr
!FNS  use m_PlaneWaveBasisSet,   only : kg1,iba, igf, nbase, m_pwBS_kinetic_energies
  use m_PlaneWaveBasisSet,   only : kg1,iba, igf, nbase
  use m_PseudoPotential,     only : ilmt, lmtt, ltp, mtp, q, dion, modnrm, nlmta &
       &                           ,m_PP_include_vanderbilt_pot,ipaw,dion_paw
  use m_Timing,              only : tstatc0_begin, tstatc0_end
!$$#ifdef PARA3D
  use m_Electronic_Structure,only : zaj_l_3D,zaj_ball &
       &                          , eko_l_3D,vnlph_l_3D,nrvf_ordr,neordr,neordr_old &
       &                          , fsr_l_3D,fsi_l_3D ,fsr_l_2d,fsi_l_2d,fsr_l,fsi_l  &
       &                          , vlhxc_l, vlhxc_l_3D                               &
       &                          , m_ES_Vlocal_in_Rspace_3D                          &
       &                          , m_ES_WF_in_Rspace_3D                              &
       &                          , m_ES_decide_precon_factor_3D                      &
       &                          , m_ES_decide_precon_factor_3D_F                    &
       &                          , m_ES_eigen_values_for_each_k_3D                   &
       &                          , m_ES_sort_eigen_values_3D                         &
       &                          , m_ES_wd_eko_3D                                    &
       &                          , m_ES_wd_zaj_small_portion_3D                      &
       &                          , m_ES_sum_of_LocalPart_3D                          &
       &                          , nblocksize_mgs_default
  use m_ES_ortho            ,only : m_ES_MGS_4_each_k_3D                              &
 &                                , m_ES_orthogonalize_SD_to_WFs_3D                   
  use m_ES_nonlocal         ,only : sc_l_3D                                           &
 &                                , m_ES_alloc_afft_scss_etc_3D                       &
 &                                , m_ES_Vnonlocal_W_3D                               &
 &                                , m_ES_betar_dot_WFs_4_each_k_3D                    &
 &                                , m_ES_betar_dot_Psi_4_each_k_3D                    
  use m_NonLocal_Potential,  only : snl, snl_l_3D
  use m_FFT,                 only : m_FFT_WF_3D        &
       &                          , m_FFT_Inverse_3D   &
       &                          , m_FFT_Direct_3D    &
       &                          , m_FFT_Vlocal_W_3D
  use m_Parallelization,     only : nel_fft_z => nel_fft_z_3D &
       &                          , nel_fft_x => nel_fft_x_3D &
       &                          , nel_fft_y => nel_fft_y_3D &
       &                          , map_fft_x => map_fft_x_3D &
       &                          , mp_fft_x  => mp_fft_x_3D  &
       &                          , myrank_e_3D, nrank_e_3D   &
       &                          , myrank_g_3D, nrank_g_3D   &
       &                          , myrank_k_3D, map_k_3D   &
       &                          , ista_e_3D, iend_e_3D, np_e_3D, mp_e_3D, np_fs_3D &
       &                          , nis_e_3D, nie_e_3D, nel_e_3D &
       &                          , ista_g1k_3D, iend_g1k_3D, np_g1k_3D, mp_g1k_3D, nel_g1k_3D  &
       &                          , ista_g1_3D,  iend_g1_3D,  np_g1_3D   &
       &                          , mpi_ke_world,  mpi_kg_world, ista_g1k, iend_g1k &
       &                          , nis_g1k_3D, nie_g1k_3D, neg_g, neg_g_all &
       &                          , nel_eg_3D, nis_eg_3D, nie_eg_3D, neg_gg, neg_gg_all &
       &                          , ista_k_3D, iend_k_3D, ista_atm_3D, iend_atm_3D
  use m_PlaneWaveBasisSet,   only : kg, nbase_gamma, m_pwBS_kinetic_energies_3D
  use m_PseudoPotential,     only : nlmtt
  use m_Control_Parameters,  only : nblocksize_fftw, nblocksize_fftw_is_given
  use z_interface_3D
!$$#endif
       
#ifdef NEC_TIMER
  use nec_timer
#endif
  implicit none
!$$#ifdef PARA3D
! === This should be modified after zaj_old is 3D-decomposed!!! by T.Kato ======
  real(kind=DP),public,allocatable,dimension(:,:,:,:):: zaj_old    !d(kg1,np_e,ista_k:iend_k,kimg)
  real(kind=DP),public,allocatable,dimension(:,:,:,:):: zaj_old_3D !d(kg1,np_e,ista_k:iend_k,kimg)
! ==============================================================================
!$$#endif
  real(kind=DP),private,allocatable,dimension(:,:,:,:):: wfsd_l  !d(kg1,np_e,ik:ik,kimg)
! ----------- Added by T. Yamasaki, 28 June 2008 -----
  real(kind=DP),private,allocatable,dimension(:,:,:,:):: wfred_l !d(kg1,np_e,ista_k:iend_k,kimg)
!$$#ifdef PARA3D
  real(kind=DP),private,allocatable,dimension(:,:,:,:):: wfred_l_3D !d(kg1,np_e,ista_k:iend_k,kimg)
!$$#endif
  logical, private                                    :: wfred_is_allocated = .false.
! ----------------------------------------------------
!FJFJ  real(kind=DP),private,allocatable,dimension(:,:,:,:):: wfsd_old!d(kg1,np_e,ista_k:iend_k,kimg)
  real(kind=DP),public ,allocatable,dimension(:,:,:,:):: wfsd_old!d(kg1,np_e,ista_k:iend_k,kimg)
  real(kind=DP),private,allocatable,dimension(:,:,:,:):: wfsd_np !d(kg1,np_e,1,kimg)
  real(kind=DP),private,allocatable,dimension(:,:,:)  :: bsdr_l, bsdi_l !d(np_e,nlmta,1)
  real(kind=DP),private,allocatable,dimension(:,:,:)  :: bsdr_np, bsdi_np !d(np_e,nlmta,1)

  real(kind=DP),private,allocatable,dimension(:)          :: dzajn2  !d(kv3)
  real(kind=DP),private                               :: betacg
!$$#ifdef PARA3D
  real(kind=DP), private, allocatable, dimension(:,:,:,:) :: wfsd_l_3D
!FJFJ  real(kind=DP), private, allocatable, dimension(:,:,:,:) :: wfsd_old_3D
  real(kind=DP), public , allocatable, dimension(:,:,:,:) :: wfsd_old_3D
  real(kind=DP), private, allocatable, dimension(:,:,:)  :: bsdr_l_3D, bsdi_l_3D
!$$#endif

!   1. m_ESsd_alloc_dzajn2            <-(Initial_Electronic_Structure)
!   2. m_ESsd_dealloc_dzajn2          <-(Finalization_of_mpi)
!   3. m_ESsd_alloc_zaj_old           <-(Initial_Electronic_Structure)
!   4. m_ESsd_evolve_WFs_again        <-(Renewal_of_WaveFunctions) ->(5)
!   5. evolve_each_WF_again           <-(4)
!   6. m_ESsd_decide_CG_direction     <-(Renewal_of_WaveFunctions) ->(7)
!   7. decide_CG_direction_core       <-(6,) ->(16,29)
!   8. m_ESsd_renew_WF_by_SDorCG      <-(Renewal_of_WaveFunctions) ->(9,10,11,12,13,14)
!   9. evolve_WFs_in_MSD_direction    <-(8) ->(15,19)
!  10. evolve_WFs_in_SD_direction     <-(8)
!  11. evolve_WFs_in_eazyCG_direction <-(8) ->(16,17,18,26,28,30,33)
!  12. evolve_WFs_in_CG_direction     <-(8) ->(18,26,28,29)
!  13. evolve_WFs_in_CG_direction0    <-(8) ->(26,27)
!  14. vlhxc_l_zero_term              <-(8)
!  15. modified_steepest_descent      <-(9)
!  16. square_of_SD_direction(ik,ibo,dz) <-(7,11)
!  17. square_of_SD_direction2(ik,ibo,dz) <-(11)
!  18. SD_direction                   <-(11,12)
!  19. Vnonlocal_Diagonal_part        <-(9)
!  20.  - Vnonlocal_D_vanderbilt_case, - Vnonlocal_D_norm_conserve_case
!  21. m_ESsd_reset_dzajn2            <-(Renewal_of_WaveFunctions)
!  22. m_ESsd_copy_zaj_to_zaj_old     <-(Renewal_of_WaveFunctions)
!  23. m_ESsd_copy_zaj_old_to_zaj     <-(m_ES_WF_by_RMM.zajold2zaj_phi2zaj_old)
!  24. m_ESsd_copy_phi_to_zaj_old     <-(m_ES_WF_by_RMM.zajold2zaj_phi2zaj_old)
!  25. m_ESsd_diff_WFs_to_zaj_old     <-(m_ES_WF_by_RMM.m_ESrmm_renew_WF)
!  26. WF_conjugate_gradient          <-(11,12,13)
!  27. WF_conjugate_gradient0         <-(13)
!  28. make_CG_direction              <-(11,12)
!  29. orthogonalize_SD_drctns        <-(7,12)
!  30. Precon_dot_SD                  <-(11)  ->(31)
!  31. decide_precon_factor_wfsd      <-(30)  ->(32)
!  32. kinetic_energy_wfsd            <-(31)
!  33. cp_wfsd_to_wfsd_old            <-(11)

  include 'mpif.h'

contains
  subroutine m_ESsd_alloc_dzajn2
    allocate(dzajn2(ista_k:iend_k)); dzajn2 = 0.d0
  end subroutine m_ESsd_alloc_dzajn2

  subroutine m_ESsd_dealloc_dzajn2
    deallocate(dzajn2)
  end subroutine m_ESsd_dealloc_dzajn2

  subroutine m_ESsd_alloc_zaj_old
    allocate(zaj_old(kg1,np_e,ista_k:iend_k,kimg))
!$$#ifdef PARA3D
! === This should be modified after zaj_old is 3D-decomposed!!! by T.Kato ======
    allocate(zaj_old_3D(maxval(np_g1k_3D),np_e_3D,ista_k_3D:iend_k_3D,kimg))
! ==============================================================================
!$$#endif
  end subroutine m_ESsd_alloc_zaj_old

  subroutine m_ESsd_alloc_wfsd
    if(.not.allocated(wfsd_old)) then
       allocate(wfsd_old(kg1,np_e,ista_k:iend_k,kimg))
       wfsd_old = 0.d0
!$$#ifdef PARA3D
! ==============================================================================
       allocate(wfsd_old_3D(maxval(np_g1k_3D),np_e_3D,ista_k_3D:iend_k_3D,kimg))
       wfsd_old_3D = 0.d0
! ==============================================================================
!$$#endif
    end if
  end subroutine m_ESsd_alloc_wfsd

  subroutine m_ESsd_dealloc_wfsd
    if(allocated(wfsd_old)) deallocate(wfsd_old)
!$$#ifdef PARA3D
! ==============================================================================
    if(allocated(wfsd_old)) deallocate(wfsd_old_3D)
! ==============================================================================
!$$#endif
  end subroutine m_ESsd_dealloc_wfsd

! -------------------- Added by T. Yamasaki, 28 June 2008 --->>
  subroutine m_ESsd_alloc_wfred()
    allocate(wfred_l(kg1,np_e,ista_k:iend_k,kimg)); wfred_l = 0.d0
!$$#ifdef PARA3D
    allocate(wfred_l_3D(maxval(np_g1k_3D),np_e_3D,ista_k_3D:iend_k_3D,kimg)); wfred_l_3D = 0.d0
!$$#endif
    wfred_is_allocated = .true.
  end subroutine m_ESsd_alloc_wfred

  subroutine m_ESsd_dealloc_wfred()
    deallocate(wfred_l)
!$$#ifdef PARA3D
    deallocate(wfred_l_3D)
!$$#endif
    wfred_is_allocated = .false.
  end subroutine m_ESsd_dealloc_wfred

!$$#ifdef PARA3D
  subroutine cp_wfred_3D(ik)
    integer, intent(in) :: ik
    integer :: ir, ib, ig
    do ir = 1, kimg
       do ib = 1, np_e_3D
          do ig = 1, np_g1k_3D(ik)
             wfred_l_3D(ig,ib,ik,ir) = zaj_l_3D(ig,ib,ik,ir) - zaj_old_3D(ig,ib,ik,ir)
          end do
       end do
    end do
  end subroutine cp_wfred_3D
!$$#endif
! ----------------------------------<<

!$$#ifdef PARA3D
  subroutine alloc_wfsd_bsdri_3D(ik)
    integer, intent(in) :: ik
    allocate(wfsd_l_3D(maxval(np_g1k_3D),np_e_3D,ik:ik,kimg)); wfsd_l_3D = 0.d0
    allocate(bsdr_l_3D(np_e_3D,nlmta,ik:ik))
    allocate(bsdi_l_3D(np_e_3D,nlmta,ik:ik)); bsdi_l_3D = 0.0d0
!!$    write(nfout,'(" -- bsdr_l, bsdi_l have been allocated --  np_e, nlmta, ik = ",3i5)') np_e,nlmta,ik
  end subroutine alloc_wfsd_bsdri_3D
!$$#endif

!$$#ifdef PARA3D
  subroutine dealloc_wfsd_bsdri_3D()
    deallocate(wfsd_l_3D)
    deallocate(bsdr_l_3D)
    deallocate(bsdi_l_3D)
  end subroutine dealloc_wfsd_bsdri_3D
!$$#endif

  subroutine alloc_wfsdnp_bsdrinp(ik)
    integer, intent(in) :: ik
    allocate(wfsd_np(kg1,np_e,ik:ik,kimg))
    allocate(bsdr_np(np_e,nlmta,ik:ik))
    allocate(bsdi_np(np_e,nlmta,ik:ik))
  end subroutine alloc_wfsdnp_bsdrinp

  subroutine dealloc_wfsdnp_bsdrinp()
    deallocate(wfsd_np)
    deallocate(bsdr_np)
    deallocate(bsdi_np)
  end subroutine dealloc_wfsdnp_bsdrinp

  subroutine m_ESsd_dealloc_zaj_old
    if(allocated(zaj_old)) deallocate(zaj_old)
!$$#ifdef PARA3D
! === This should be modified after zaj_old is 3D-decomposed!!! by T.Kato ======
    if(allocated(zaj_old_3D)) deallocate(zaj_old_3D)
! ==============================================================================
!$$#endif
!!$    deallocate(wfsd_l)
!!$    deallocate(wfsd_np)
!!$    deallocate(bsdr_l)
!!$    deallocate(bsdi_l)
!!$    deallocate(bsdr_np)
!!$    deallocate(bsdi_np)
  end subroutine m_ESsd_dealloc_zaj_old

  subroutine m_ESsd_evolve_WFs_again(nfout,isolver2,mode,dtim_old,dtim_new)
#ifdef __TIMER__
    use m_Const_Parameters,   only : VDB
    use m_ES_ortho,           only : mgs_4_each_k_G_3D
#endif
    integer,       intent(in) :: nfout,isolver2 &
         &                     , mode   ! mode = {ORTHONORMALIZATION | NORMALIZATION}
    real(kind=DP), intent(in) :: dtim_old, dtim_new
    integer       :: ispin, ik, iksnl
    real(kind=DP), pointer, dimension(:) :: ekin
#ifdef __TIMER__
    integer       :: ierr
#endif

!$$#ifdef PARA3D
    real(kind=DP), pointer, dimension(:) :: ekin_l_3D
    real(kind=DP), allocatable, dimension(:) ::  afft_l
    integer             :: lsize, ierr
    lsize = max(maxval(nel_fft_x(:)),maxval(nel_fft_y(:)),maxval(nel_fft_z(:)))
    allocate(afft_l(lsize*kimg), stat=ierr)
     if(ierr /= 0) then
        write(nfout,*)' m_ESsubmat_Renew_WF : Not allocated afft_l array'
        call flush(nfout)
        call mpi_abort()
     endif
    call m_ES_alloc_afft_scss_etc_3D()
    ekin_l_3D => sc_l_3D(1:kg1)
!$$#endif

!$$#ifdef PARA3D
    do ispin = 1, nspin, af+1
#ifdef __TIMER__
       call mpi_barrier(mpi_comm_group, ierr)
       call timer_sta(1)
#endif
       call m_ES_Vlocal_in_Rspace_3D(ispin,afft_l,afft_l,lsize,1,OFF)   ! (ptfft1)
#ifdef __TIMER__
       call timer_end(1)
#endif
       do ik = ispin, kv3-nspin+ispin, nspin
          if(map_k_3D(ik) == myrank_k_3D ) then                     ! MPI
             call m_pwBS_kinetic_energies_3D(ik,vkxyz,ekin_l_3D) !-(PWBS) (diakin) ->ekin
             call evolve_each_WF_again_3D(ik,isolver2,dtim_new,dtim_old)  !-(m_ES_WF_by_SDorCG)
#ifdef __TIMER__
             if(modnrm == EXECUT) then
                call mpi_barrier(mpi_k_world(myrank_k), ierr)
                call timer_sta(4)
                call m_ES_betar_dot_WFs_4_each_k_3D(nfout,ik)   ! -> fsr_l,fsi_l
                call timer_end(4)
                call mpi_barrier(mpi_k_world(myrank_k), ierr)
                call timer_sta(5)
                call mgs_4_each_k_G_3D(ista_k_3D,iend_k_3D,ik,zaj_l_3D,mode &
               &                      ,fsr_l_3D,fsi_l_3D,mod_pot=VDB)!-(m_E.S.)
                call timer_end(5)
             else
                call mpi_barrier(mpi_k_world(myrank_k), ierr)
                call timer_sta(5)
                call mgs_4_each_k_G_3D(ista_k_3D,iend_k_3D,ik,zaj_l_3D,mode &
               &                      ,mod_pot=NORMCONSERVATION)!-(m_E.S.)
                call timer_end(5)
                call mpi_barrier(mpi_k_world(myrank_k), ierr)
                call timer_sta(4)
                call m_ES_betar_dot_WFs_4_each_k_3D(nfout,ik)   ! -> fsr_l,fsi_l
                call timer_end(4)
             end if
#else
             call m_ES_MGS_4_each_k_3D(nfout,ik,mode)
#endif
#ifdef __TIMER__
             call mpi_barrier(mpi_comm_group, ierr)
             call timer_sta(6)
#endif
             call m_ES_eigen_values_for_each_k_3D(ispin,ik,ekin_l_3D,afft_l,lsize)
#ifdef __TIMER__
             call timer_end(6)
#endif
          end if
       end do
    end do

#ifdef LMM_PREVIOUS
    call m_ES_sort_eigen_values_3D !-(m_Elec.)
    call m_ESsd_sort_zaj_old_3D()
#endif

    deallocate(afft_l)

!$$#endif

    call m_ES_dealloc_afft_scss_etc()

  end subroutine m_ESsd_evolve_WFs_again

!$$#ifdef PARA3D
  subroutine evolve_each_WF_again_3D(ik,isolver2,dt_new,dt_old)
  use m_Parallelization     ,only : np_e => np_e_3D 

    integer,       intent(in) :: ik,isolver2
    real(kind=DP), intent(in) :: dt_new,dt_old
    integer ::        ir, ib, ig
    real(kind=DP) ::  dtt
    integer   :: id_sname = -1
    call tstatc0_begin('evolve_each_WF_again_3D ', id_sname,1)

!!$    if(isolver2 == CG .or. isolver2 == eazyCG) then
    if(isolver2 == eazyCG) then
       do ir = 1, kimg
          do ib = 1, np_e
             do ig = 1, np_g1k_3D(ik)
                zaj_l_3D(ig,ib,ik,ir) = zaj_old_3D(ig,ib,ik,ir) + dt_new*wfsd_l_3D(ig,ib,ik,ir)
             end do
          end do
       end do
    else
       dtt = dt_new/dt_old
!!$       if(ipri >= 3) write(nfout,'(" dtt = ",f8.4)') dtt
! ------------------- Revised by T. Yamasaki,  31 Oct 2008 --->>
       if(wfred_is_allocated) then
          do ir = 1, kimg
             do ib = 1, np_e
                do ig = 1, np_g1k_3D(ik)
! ------------------- Revised by T. Yamasaki,  03 July 2008 --->>
                   zaj_l_3D(ig,ib,ik,ir) = zaj_old_3D(ig,ib,ik,ir) + dtt*wfred_l_3D(ig,ib,ik,ir)
! ------------------------------------<<
                end do
             end do
          end do
       else if(.not.wfred_is_allocated) then
          do ir = 1, kimg
             do ib = 1, np_e
                do ig = 1, np_g1k_3D(ik)
                   zaj_l_3D(ig,ib,ik,ir) = (1-dtt)*zaj_old_3D(ig,ib,ik,ir) + dtt*zaj_l_3D(ig,ib,ik,ir)
                end do
             end do
          end do
       end if
! <----------------
    end if
    call tstatc0_end(id_sname)
  end subroutine evolve_each_WF_again_3D
!$$#endif
             
  subroutine m_ESsd_decide_CG_direction(precon)
    integer, intent(in) :: precon

    integer ispin, iksnl, ik
    real(kind=DP), parameter             :: Delta = 1.d-10
    real(kind=DP), pointer, dimension(:) :: ekin, p
    real(kind=DP)                        :: gmgm, gmmgmm, sumdz2, x
!$$#ifdef PARA3D
    real(kind=DP), pointer, dimension(:) :: ekin_l_3D
    real(kind=DP), allocatable, dimension(:) ::  afft_l
    integer             :: lsize, ierr
!   lsize = max(nel_fft_x(myrank_g_3D),nel_fft_y(myrank_g_3D),nel_fft_z(myrank_g_3D))
    lsize = max(maxval(nel_fft_x(:)),maxval(nel_fft_y(:)),maxval(nel_fft_z(:)))
    allocate(afft_l(lsize*kimg), stat=ierr)
     if(ierr /= 0) then
        write(nfout,*)' m_ESsubmat_Renew_WF : Not allocated afft_l array'
        call flush(nfout)
        call mpi_abort()
     endif
    call m_ES_alloc_afft_scss_etc_3D()
    ekin_l_3D => sc_l_3D(1:kg1)
!$$#endif
    gmgm = 0.d0; gmmgmm = 0.d0

    do ispin = 1, nspin, (af+1)
!$$#ifdef PARA3D
       call m_ES_Vlocal_in_Rspace_3D(ispin,afft,afft_l,lsize,1,OFF)   ! (ptfft1) -> afft
!$$#endif
       do ik = ispin, kv3-nspin+ispin, nspin
!$$#ifdef PARA3D
          if(map_k_3D(ik) == myrank_k_3D) then           ! MPI
             iksnl = (ik-1)/nspin + 1
             call alloc_wfsd_bsdri_3D(ik)
!FJFJ             call decomp_eko_l_3D(eko_l,eko_l_3D(:,ik),ik)
!FJFJ             call decomp_snl_l_3D(snl,snl_l_3D,ik,nlmtt,iksnl)
!FJFJ             call decomp_fsr_l_3D(fsr_l,fsr_l_3D,ik,nrvf_ordr,'    ')
!FJFJ             if(.not.(kv3/nspin == 1 .and. k_symmetry(1) == GAMMA .and. kimg == 2)) then
!FJFJ                call decomp_fsr_l_3D(fsi_l,fsi_l_3D,ik,nrvf_ordr,'    ')
!FJFJ             endif

             call m_ES_Vnonlocal_W_3D(ik,iksnl,ispin,ON)    ! (nonloc) ->(vnlph_l)

!FJFJ             call decomp_vnlph_l_r_3D(vnlph_l_3D,vnlph_l,ik,1)
!FJFJ             if (kimg == 2) then
!FJFJ                call decomp_vnlph_l_r_3D(vnlph_l_3D,vnlph_l,ik,2)
!FJFJ             endif

             call m_pwBS_kinetic_energies_3D(ik,vkxyz,ekin_l_3D) ! -(m_PWBS) (diakin) ->ekin
             call decide_CG_direction_core_3D &     ! -(m_ES_WF_by_SDorCG) ->wfsd_l
                  &(precon,ik,ekin_l_3D,afft_l,lsize,sumdz2)
             gmgm   = gmgm + sumdz2
             gmmgmm = gmmgmm + dzajn2(ik)
             dzajn2(ik) = sumdz2
             if(ipri >= 2) write(nfout,'(" dzajn2(",i3,") = ",d20.8)') ik,dzajn2(ik)
             call dealloc_wfsd_bsdri_3D()
!$$#endif
          end if
       enddo
    enddo

    if(npes > 1) then
       call mpi_allreduce(gmgm,x,1,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)    ! MPI
       gmgm = x
       call mpi_allreduce(gmmgmm,x,1,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)    ! MPI
       gmmgmm = x
    end if

    if(gmmgmm > Delta) then
       betacg = gmgm/gmmgmm
    else
       betacg = 0.d0
    endif
    if(ipri >= 1) write(nfout,'(" ! betacg = ",d20.8," gmgm = ",d20.8," gmmgmm = ",d20.8)') betacg,gmgm,gmmgmm
    if(betacg > 1.d0) then
       betacg = 0.d0
       if(ipri >= 1) write(nfout,*) ' beta for CG is too large, and it sets to be zero'
    else if(betacg < 0.d0) then
       betacg = 0.d0
       if(ipri >= 1) write(nfout,*) ' beta for CG is less than zero, and it sets to be zero'
    end if

!$$#ifdef PARA3D
    deallocate(afft_l)
!$$#endif
    call m_ES_dealloc_afft_scss_etc()
!!$  contains
!!$    subroutine bcast_dzajn2                     ! MPI
!!$      integer       :: i
!!$
!!$      do i = 0, nrank_k-1
!!$         call mpi_bcast(dzajn2(nis_k(i)),nel_k(i),mpi_double_precision &
!!$              & ,i*nrank_e,mpi_comm_group,ierr)
!!$      end do
!!$    end subroutine bcast_dzajn2
  end subroutine m_ESsd_decide_CG_direction


  subroutine m_ESsd_renew_WF_by_SDorCG(nfout,isolver,precon,dtim)
#ifdef __TIMER__
    use m_Const_Parameters,   only : VDB
    use m_ES_ortho,           only : mgs_4_each_k_G_3D
#endif
    integer, intent(in) :: nfout,isolver, precon
    real(kind=DP)       :: dtim

    integer                              :: ispin, iksnl, ik, mode, ipri0
    real(kind=DP), pointer, dimension(:) :: ekin, p, vnldi
    real(kind=DP)                        :: vlhxc0
!$$#ifdef PARA3D
    real(kind=DP), pointer, dimension(:) :: ekin_l_3D
    real(kind=DP), allocatable, dimension(:) ::  afft_l
    integer             :: lsize, ierr, ii
!$$#endif
!$$#ifdef PARA3D
! ==============================================================================
    real(kind=DP) :: p_3D(maxval(np_g1k_3D))
    real(kind=DP) :: vnldi_3D(maxval(np_g1k_3D))
! ==============================================================================
!$$#endif

!$$#ifdef PARA3D
    call m_ES_alloc_afft_scss_etc_3D()
!   lsize = max(nel_fft_x(myrank_g_3D),nel_fft_y(myrank_g_3D),nel_fft_z(myrank_g_3D))
    lsize = max(maxval(nel_fft_x(:)),maxval(nel_fft_y(:)),maxval(nel_fft_z(:)))
    allocate(afft_l(lsize*kimg), stat=ierr)
     if(ierr /= 0) then
        write(nfout,*)' m_ESsubmat_Renew_WF : Not allocated afft_l array'
        call flush(nfout)
        call mpi_abort(mpi_comm_world, 201, ierr)
     endif
    ekin_l_3D => sc_l_3D
!$$#endif

    mode = ORTHONORMALIZATION

    if(iprisolver >= 2) then
       if(isolver == SD) then
          write(nfout,'(" !! isolver_core = SD")')
       else if(isolver == MSD) then
          write(nfout,'(" !! isolver_core = MSD")')
       else if(isolver == CG) then
          write(nfout,'(" !! isolver_core = CG")')
       end if
    end if

!$$#ifdef PARA3D
    do ispin = 1, nspin, (af+1)
       if(isolver == MSD) then
          call vlhxc_l_zero_term_3D(vlhxc0,ispin) ! -(m_ES_WF_by_SDorCG) ->vlhxc0
       end if
#ifdef __TIMER__
       call mpi_barrier(mpi_comm_group, ierr)
       call timer_sta(1)
#endif
       call m_ES_Vlocal_in_Rspace_3D(ispin,afft,afft_l,lsize,1,OFF)      ! (ptfft1) vlhxc_l->afft
#ifdef __TIMER__
       call timer_end(1)
#endif
       do ik = ispin, kv3-nspin+ispin, nspin
          if(map_k_3D(ik) == myrank_k_3D) then           ! MPI
             iksnl = (ik-1)/nspin + 1
#ifdef __TIMER__
             call mpi_barrier(mpi_k_world(myrank_k), ierr)
             call timer_sta(2)
#endif
             call m_ES_Vnonlocal_W_3D(ik,iksnl,ispin,ON)    ! (nonloc) ->(vnlph_l)
#ifdef __TIMER__
             call timer_end(2)
#endif
             call m_pwBS_kinetic_energies_3D(ik,vkxyz,ekin_l_3D) ! (diakin) ->ekin
             if(isolver == SD) then
!#if 0
!                call evolve_WFs_in_SD_direction_3D_2&      ! -(m_ES_WF_by_SDorCG)
!                     &(precon,ik,dtim,ekin_l_3D,afft_l,lsize,p_3D)
!#else
                call evolve_WFs_in_SD_direction_3D_F&      ! -(m_ES_WF_by_SDorCG)
                     &(precon,ik,dtim,ekin_l_3D, afft_l,lsize)
!#endif
             else if(isolver == MSD ) then
#ifdef __TIMER__
                call mpi_barrier(mpi_k_world(myrank_k), ierr)
                call timer_sta(3)
#endif
!#if 0
!                call evolve_WFs_in_MSD_direction_3D&     !-(m_ES_WF_by_SDorCG) 
!                     &(precon,ik,iksnl,ispin,dtim,ekin_l_3D,afft_l,lsize,p_3D,vnldi_3D,vlhxc0)
!#else
                call evolve_WFs_in_MSD_direction_3D_F&     !-(m_ES_WF_by_SDorCG) 
                     &(precon,ik,iksnl,ispin,dtim,ekin_l_3D,afft_l,lsize,vlhxc0)
!#endif
#ifdef __TIMER__
                call timer_end(3)
#endif
                if(ipri>=3.and.ik==1) &
                     & call m_ES_wd_zaj_small_portion_3D(nfout,ik," -- after MSD --",16)
             else if(isolver == eazyCG) then
                write(nfout,'("Not support Multi Parallel for eazyCG")') 
                call flush(nfout)
                write(1002,'("Not support Multi Parallel for eazyCG")') 
                call flush(1002)
!               call evolve_WFs_in_eazyCG_direction(precon,ik,dtim,ekin,afft,bfft,p)
             else if(isolver == CG) then
! ==============================================================================
START_TIMER('CG_Initialize')
!FJFJ           call decomp_wfsd_l_3D(wfsd_old(:,:,ik:ik,:), wfsd_old_3D(:,:,ik:ik,:), ik)
!!              call decomp_fsr_l_2D(fsr_l,fsr_l_2D,ik)
!!              if(.not.(kv3/nspin == 1 .and. k_symmetry(1) == GAMMA .and. kimg == 2)) then
!!                 call decomp_fsr_l_2D(fsi_l,fsi_l_2D,ik)
!!              endif
STOP_TIMER('CG_Initialize')
! ==============================================================================
!               call evolve_WFs_in_CG_direction_3D(precon,ik,dtim,ekin,afft,bfft,p_3D)
                call evolve_WFs_in_CG_direction_3D(precon,ik,dtim,ekin_l_3D,afft_l,lsize)
!!$                call evolve_WFs_in_CG_direction0(precon,ik,dtim,ekin,afft,bfft,p)
! ==============================================================================
START_TIMER('CG_Finalize')
!FJFJ           call decomp_wfsd_l_r_3D(wfsd_old(:,:,ik:ik,:), wfsd_old_3D(:,:,ik:ik,:), ik)
STOP_TIMER('CG_Finalize')
! ==============================================================================
             endif
! --------------- Added by T. Yamasaki, 28 June 2008 ---
             if(wfred_is_allocated) then
                call cp_wfred_3D(ik)
             end if
! ------------------------------------------------------<<
#ifdef __TIMER__
             if(modnrm == EXECUT) then
                call mpi_barrier(mpi_k_world(myrank_k), ierr)
                call timer_sta(4)
                call m_ES_betar_dot_WFs_4_each_k_3D(nfout,ik)   ! -> fsr_l,fsi_l
                call timer_end(4)
                call mpi_barrier(mpi_k_world(myrank_k), ierr)
                call timer_sta(5)
                call mgs_4_each_k_G_3D(ista_k_3D,iend_k_3D,ik,zaj_l_3D,mode &
               &                      ,fsr_l_3D,fsi_l_3D,mod_pot=VDB)!-(m_E.S.)
                call timer_end(5)
             else
                call mpi_barrier(mpi_k_world(myrank_k), ierr)
                call timer_sta(5)
                call mgs_4_each_k_G_3D(ista_k_3D,iend_k_3D,ik,zaj_l_3D,mode &
               &                      ,mod_pot=NORMCONSERVATION)!-(m_E.S.)
                call timer_end(5)
                call mpi_barrier(mpi_k_world(myrank_k), ierr)
                call timer_sta(4)
                call m_ES_betar_dot_WFs_4_each_k_3D(nfout,ik)   ! -> fsr_l,fsi_l
                call timer_end(4)
             end if
#else
             call m_ES_MGS_4_each_k_3D(nfout,ik,mode)
#endif

#ifdef __TIMER__
             call mpi_barrier(mpi_k_world(myrank_k), ierr)
             call timer_sta(6)
#endif
             call m_ES_eigen_values_for_each_k_3D(ispin,ik,ekin_l_3D,afft_l,lsize)
#ifdef __TIMER__
             call timer_end(6)
#endif
          end if
       enddo
    enddo

#ifdef LMM_PREVIOUS
    call m_ES_sort_eigen_values_3D()   ! -> neordr, nrvf_ordr
    call m_ESsd_sort_zaj_old_3D()
#endif

    deallocate(afft_l)
!$$#endif
    call get_ipri0(ipri, ipri0)
!$$#ifdef PARA3D
    if(ipri0 >= 2) call m_ES_wd_eko_3D(nfout,mode=SCF)
!$$#endif
    call m_ES_dealloc_afft_scss_etc()

  contains
    subroutine get_ipri0(ipri_in, ipri_out)
      integer, intent(in)  :: ipri_in
      integer, intent(out) :: ipri_out
      if(npes > 1) then
         if(mype == 0) ipri_out = ipri_in
         call mpi_bcast(ipri_out,1,mpi_integer,0,mpi_comm_group,ierr)
      else
         ipri_out = ipri_in
      end if
    end subroutine get_ipri0
  end subroutine m_ESsd_renew_WF_by_SDorCG
  
!$$#ifdef PARA3D
  subroutine evolve_WFs_in_MSD_direction_3D&
       &(precon,ik,iksnl,ispin,dtim,ekin,afft_l,lsize,p,vnldi,vlhxc0)
    integer, intent(in)        :: precon, ik, iksnl, ispin, lsize
    real(kind=DP), intent(in)  :: dtim
!!  real(kind=DP), intent(in)  :: ekin(kg1)
    real(kind=DP), intent(in)  :: ekin(maxval(np_g1k_3D))
    real(kind=DP), intent(in)  :: afft_l(lsize*kimg)
    real(kind=DP)              :: p(maxval(np_g1k_3D)), vnldi(maxval(np_g1k_3D))
    real(kind=DP), intent(in)  :: vlhxc0

    integer ib, ig, ilen
    integer :: id_sname = -1
! === FFT Marge. by T.Kato ===============================================================
    integer :: ibsize, isrsize, fft_l_size
    real(kind=DP), allocatable, dimension(:,:) :: wk_bfft_l
    real(kind=DP), allocatable, dimension(:,:) :: bfft_l
! ========================================================================================
    call tstatc0_begin('evolve_WFs_in_MSD_direction_3D ', id_sname,1)
! === FFT Marge. by T.Kato ===============================================================
    ibsize = 1
!   if (nblocksize_fftw_is_given) then
!      ibsize = nblocksize_fftw
!      if (ibsize < 1) ibsize = 1
!   endif
    isrsize = min(lsize,mp_g1k_3D(ik))
    fft_l_size  = nel_fft_x(myrank_g_3D)
    allocate(wk_bfft_l(lsize*kimg,ibsize) ,stat=ierr)
    allocate(bfft_l(lsize*kimg,ibsize) ,stat=ierr)
    if (ierr /= 0) then
       write(nfout,*)' evolve_WFs_in_CG_direction_3D :  Not allocate '
       call flush(nfout)
       call mpi_abort(mpi_comm_world, 205, ierr)
    endif
! ========================================================================================

#ifdef NEC_TUNE_SMP
!CDIR PARALLEL DO private(bfft,vnldi,p)
#endif
    do ib = 1, np_e_3D ! MPI
START_TIMER('MSD_temporary_FFT')
       call m_ES_WF_in_Rspace_3D(ik,ib,ib,ibsize,lsize,wk_bfft_l)

       if(ipri >= 2) then
          write(nfout,'(" --- afft_l and bfft_l <<evolve_WFs_in_MSD_direction_3D>>,  ib = ",i5)') ib
          write(nfout,'(" afft_l: ",5d16.8)') (afft_l(ig),ig=1,min(5,lsize*kimg))
          write(nfout,'(" bfft_l: ",5d16.8)') (bfft_l(ig,1),ig=1,min(5,lsize*kimg,1))
       end if

       call m_FFT_Vlocal_W_3D(afft_l,wk_bfft_l,lsize,ibsize,nel_fft_y(myrank_g_3D))
       call m_FFT_Direct_3D(bfft_l,nfout,wk_bfft_l,lsize,ibsize,OFF,OFF)
       call map_fft_to_WF_3D(ik,lsize,ibsize,wk_bfft_l,bfft_l,isrsize,fft_l_size)
STOP_TIMER('MSD_temporary_FFT')
START_TIMER('MSD_Vnonlocal_Diagonal_part_3D')
       call Vnonlocal_Diagonal_part_3D(ispin,ik,iksnl,ib,vnldi)
STOP_TIMER('MSD_Vnonlocal_Diagonal_part_3D')
                                         ! -(m_ES_WF_by_SDorCG) (nonldj)
       if(ipri >= 2) then
          ilen = iend_g1k_3D(ik)-ista_g1k_3D(ik)+1
          write(nfout,'(" --- vnlph_l <<evolve_WFs_in_MSD_direction_3D>>,  ib = ",i5)') ib
                       write(nfout,'(" vnlph_l: Re ",5d16.8)') (vnlph_l_3D(ig,ib,1),ig=1,min(5,ilen))
          if(kimg== 2) write(nfout,'(" vnlph_l: Im ",5d16.8)') (vnlph_l_3D(ig,ib,2),ig=1,min(5,ilen))

          write(nfout,'(" vnldi ",5d16.8)') (vnldi(ig),ig=1,min(5,ilen))
          write(nfout,'(" VlocalW: Re ",5d16.8)') (bfft_l(2*ig-1,1),ig=1,min(5,iend_g1k_3D(ik)-ista_g1k_3D(ik)+1))
          write(nfout,'(" VlocalW: Im ",5d16.8)') (bfft_l(2*ig  ,1),ig=1,min(5,iend_g1k_3D(ik)-ista_g1k_3D(ik)+1))
          write(nfout,'(" vlhxc0 = ",5d16.8)') vlhxc0
       end if
START_TIMER('MSD_modified_steepest_descent_3D')
       call modified_steepest_descent_3D&   ! -(m_ES_WF_by_SDorCG)
            &(precon,ik,ib,dtim,vnldi,vlhxc0,ekin,bfft_l,lsize,p)
STOP_TIMER('MSD_modified_steepest_descent_3D')
    end do
    call tstatc0_end(id_sname)
  end subroutine evolve_WFs_in_MSD_direction_3D
!$$#endif

!$$#ifdef PARA3D
  subroutine evolve_WFs_in_SD_direction_3D_2&
       &(precon,ik,dtim,ekin,afft_l,lsize,p)
    integer, intent(in)        :: precon, ik, lsize
    real(kind=DP), intent(in)  :: dtim,ekin(kg1)
    real(kind=DP), intent(in)  :: afft_l(lsize*kimg)
    real(kind=DP)              :: p(maxval(np_g1k_3D))
! === FFT Marge. by T.Kato ===============================================================
    integer :: ibsize, isrsize, fft_l_size
    real(kind=DP), allocatable, dimension(:,:) :: wk_bfft_l
    real(kind=DP), allocatable, dimension(:,:) :: bfft_l
! ========================================================================================

    integer :: ib
    integer :: id_sname = -1
    call tstatc0_begin('evolve_WFs_in_SD_direction_3D_2 ', id_sname,1)
! === FFT Marge. by T.Kato ===============================================================
    ibsize = 1
!   if (nblocksize_fftw_is_given) then
!      ibsize = nblocksize_fftw
!      if (ibsize < 1) ibsize = 1
!   endif
    isrsize = min(lsize,mp_g1k_3D(ik))
    fft_l_size  = nel_fft_x(myrank_g_3D)
    allocate(wk_bfft_l(lsize*kimg,ibsize) ,stat=ierr)
    allocate(bfft_l(lsize*kimg,ibsize) ,stat=ierr)
    if (ierr /= 0) then
       write(nfout,*)' evolve_WFs_in_CG_direction_3D :  Not allocate '
       call flush(nfout)
       call mpi_abort(mpi_comm_world, 205, ierr)
    endif
! ========================================================================================

    do ib = 1, np_e_3D ! MPI
START_TIMER('SD_temporary_FFT')
       call m_ES_WF_in_Rspace_3D(ik,ib,ib,ibsize,lsize,wk_bfft_l)
       call m_FFT_Vlocal_W_3D(afft_l,wk_bfft_l,lsize,ibsize,nel_fft_y(myrank_g_3D))
       call m_FFT_Direct_3D(bfft_l,nfout,wk_bfft_l,lsize,ibsize,OFF,OFF)
       call map_fft_to_WF_3D(ik,lsize,ibsize,wk_bfft_l,bfft_l,isrsize,fft_l_size)
STOP_TIMER('SD_temporary_FFT')
START_TIMER('SD_steepest_descent_3D_2')
!      call steepest_descent_3D_2(precon,ik,ib,dtim,ekin,bfft,p)
       call steepest_descent_3D_2(precon,ik,ib,dtim,ekin,bfft_l,lsize,p)
STOP_TIMER('SD_steepest_descent_3D_2')
                                         ! -(m_ES_WF_by_SDorCG)
    end do
    call tstatc0_end(id_sname)
  end subroutine evolve_WFs_in_SD_direction_3D_2
!$$#endif


!$$#ifdef PARA3D
  subroutine evolve_WFs_in_CG_direction_3D(precon,ik,dtim,ekin_l,afft_l,lsize)
    integer, intent(in)        :: precon, ik, lsize
    real(kind=DP), intent(in)  :: dtim,ekin_l(np_g1k_3D(ik))
    real(kind=DP), intent(in)  :: afft_l(lsize*kimg)
    real(kind=DP)              :: p(maxval(np_g1k_3D))

    integer :: ib
    integer :: id_sname = -1
! === FFT Marge. by T.Kato ===============================================================
    integer :: ib1, ib2, ibsize, ibesize
    integer :: ibsize, isrsize, fft_l_size
    real(kind=DP), allocatable, dimension(:,:) :: wk_bfft_l
    real(kind=DP), allocatable, dimension(:,:) :: VlocalW
    real(kind=DP), allocatable, dimension(:,:) :: p_l
! ========================================================================================
    call tstatc0_begin('evolve_WFs_in_CG_direction_3D ', id_sname,1)
! === FFT Marge. by T.Kato ===============================================================
    ibsize = 1
    if (nblocksize_fftw_is_given) then
       ibsize = nblocksize_fftw
       if (ibsize < 1) ibsize = 1
    endif
    isrsize = min(lsize,mp_g1k_3D(ik))
    fft_l_size  = nel_fft_x(myrank_g_3D)
    allocate(wk_bfft_l(lsize*kimg,ibsize) ,stat=ierr)
    allocate(VlocalW(lsize*kimg,ibsize) ,stat=ierr)
!P! allocate(p_l(mp_g1k_3D(ik),ibsize) ,stat=ierr)
    allocate(p_l(mp_g1k_3D(ik),np_e_3D) ,stat=ierr)
    if (ierr /= 0) then
       write(nfout,*)' evolve_WFs_in_CG_direction_3D :  Not allocate '
       call flush(nfout)
       call mpi_abort(mpi_comm_world, 205, ierr)
    endif
! ========================================================================================

    call alloc_wfsd_bsdri_3D(ik)
!P!
    call m_ES_decide_precon_factor_3D_F(precon,ik,1,np_e_3D,np_e_3D,ekin_l,p_l)  ! -> p(1:iba(ik))
!P!

    do ib = 1, np_e_3D, ibsize ! MPI
       ib2 = min(ib1+ibsize-1,np_e_3D)
       ibesize = ib2 - ib1 + 1
START_TIMER('CG_temporary_FFT')
       call m_ES_WF_in_Rspace_3D(ik,ib,ib,ibsize,lsize,wk_bfft_l)
       call m_FFT_Vlocal_W_3D(afft_l,wk_bfft_l,lsize,ibsize,nel_fft_y(myrank_g_3D))
       call m_FFT_Direct_3D(VlocalW,nfout,wk_bfft_l,lsize,ibsize,OFF,OFF)
       call map_fft_to_WF_3D(ik,lsize,ibsize,wk_bfft_l,VlocalW,isrsize,fft_l_size)
STOP_TIMER('CG_temporary_FFT')
START_TIMER('CG_SD_direction_3D')
       call SD_direction_3D(precon,ik,ib1,ib2,ibesize,ekin_l,VlocalW,lsize,p_l)
                                                          ! -(m_ES_WF_by_SDorCG) -> wfsd_l
STOP_TIMER('CG_SD_direction_3D')
       !                wfsd_l : -(H-e_{k\mu}^m)\Psi_{k\mu}^m
    end do

START_TIMER('CG_orthogonalize_SD_drctns_3D')
    call orthogonalize_SD_drctns_3D(ik,to=SAME_BAND) ! -(m_ES_WF_by_SDorCG) ->(wfsd_l,bsd(ri)_l)
STOP_TIMER('CG_orthogonalize_SD_drctns_3D')
START_TIMER('CG_make_CG_direction_3D')
    call make_CG_direction_3D(ik)       ! -(m_ES_WF_by_SDorCG) -> wfsd_l + betacg*wfsd_old -> wfsd_l
STOP_TIMER('CG_make_CG_direction_3D')
!!$    call orthogonalize_SD_drctns(ik,to=SAME_BAND) ! Actually, CG direction ->(wfsd_l,bsd(ri)_l)

START_TIMER('CG_WF_conjugate_gradient_3D')
    do ib = 1, np_e_3D ! MPI
       call WF_conjugate_gradient_3D(ik,ib,dtim) !-(m_ES_WF_by_SDorCG)
    end do
STOP_TIMER('CG_WF_conjugate_gradient_3D')

!!$    do ib = ista_e, iend_e, istep_e      ! MPI
!!$       call m_ES_WF_in_Rspace(ik,ib,bfft)! (swffft)
!!$       call m_FFT_Vlocal_W(afft,bfft)    ! (afft, bfft) -> (bfft)
!!$       call m_FFT_WF(ELECTRON,nfout,bfft,DIRECT,ON)
!!$       call WF_conjugate_gradient0(precon,ik,ib,dtim,ekin,bfft,p)
!!$       !    ~~~~~~~~~~~~~~~~~~~~~~         -(m_ES_WF_by_SDorCG)
!!$    end do

START_TIMER('CG_cp_wfsd_to_wfsd_old_3D')
    call cp_wfsd_to_wfsd_old_3D(ik)    ! -(m_ES_WF_by_SDorCG) wfsd_l ->wfsd_old
STOP_TIMER('CG_cp_wfsd_to_wfsd_old_3D')

    call dealloc_wfsd_bsdri_3D()
! === FFT Marge. by T.Kato ===============================================================
    deallocate(wk_bfft_l)
    deallocate(VlocalW)
    deallocate(p_l)
! ========================================================================================
    call tstatc0_end(id_sname)
  end subroutine evolve_WFs_in_CG_direction_3D
!$$#endif


!$$#ifdef PARA3D
  subroutine vlhxc_l_zero_term_3D(vlhxc0,ispin)
    real(kind=DP), intent(out) :: vlhxc0
    integer, intent(in)        :: ispin

    if(myrank_g_3D == 0) vlhxc0 = vlhxc_l_3D(1,1,ispin)
    call mpi_bcast(vlhxc0,1,mpi_double_precision,0,mpi_ke_world,ierr)
  end subroutine vlhxc_l_zero_term_3D
!$$#endif

!$$#ifdef PARA3D
  subroutine modified_steepest_descent_3D&
       &(precon,ik,ibo,dtim,vnldi,vlhxc0,ekin,VlocalW,lsize,p)
    integer      , intent(in)                  :: precon,ik,ibo,lsize
    real(kind=DP), intent(in)                  :: dtim
    real(kind=DP), intent(in), dimension(maxval(np_g1k_3D)) :: vnldi
    real(kind=DP), intent(in)                  :: vlhxc0
!!  real(kind=DP), intent(in), dimension(kg1)  :: ekin
    real(kind=DP), intent(in), dimension(maxval(np_g1k_3D))  :: ekin
!   real(kind=DP), intent(in), dimension(lsize*kimg,ibesize) :: VlocalW
    real(kind=DP), intent(in), dimension(lsize*kimg,1) :: VlocalW
    real(kind=DP)            , dimension(maxval(np_g1k_3D)) :: p

    integer       :: i, i1, ib, iadd
    real(kind=DP) :: evr,devr,denom, wdi, evi,e1, devi, fdexp

    ib = ibo ! MPI
    denom = 1.d0/product(fft_box_size_WF(1:3,1))
    call m_ES_decide_precon_factor_3D(precon,ik,ibo,ekin,p)  ! -> p(1:iba(ik))
    if(ipri >= 3) then
       write(nfout,'(" ekin : ",5d16.8)') (ekin(i),i=1,iba(ik))
       write(nfout,'(" p    : ",5d16.8)') (p(i),i=1,iend_g1k_3D(ik)-ista_g1k_3D(ik)+1)
    end if

    if(kimg == 1) then
       do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
          iadd = i - ista_g1k_3D(ik) + 1
          i1    = igf(nbase(i,ik))
          evr   = zaj_l_3D(iadd,ib,ik,1)
!!        devr  = (ekin(i)-eko_l_3D(ib,ik))*evr&
          devr  = (ekin(iadd)-eko_l_3D(ib,ik))*evr&
               & + VlocalW(iadd,1)*denom + vnlph_l_3D(iadd,ib,1)
!!        wdi   = ekin(i) + vlhxc0 + vnldi(iadd) - eko_l_3D(ib,ik)
          wdi   = ekin(iadd) + vlhxc0 + vnldi(iadd) - eko_l_3D(ib,ik)
          fdexp = dexp( -p(iadd) * wdi * dtim)
          zaj_l_3D(iadd,ib,ik,1) = (fdexp - 1)*devr/wdi + evr
       end do
    else if(kimg == 2) then
       do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
          iadd = i - ista_g1k_3D(ik) + 1
          i1    = igf(nbase(i,ik))
          evr   = zaj_l_3D(iadd,ib,ik,1);    evi   = zaj_l_3D(iadd,ib,ik,2)
!!        e1    = ekin(i) - eko_l_3D(ib,ik)
          e1    = ekin(iadd) - eko_l_3D(ib,ik)
          devr  = e1*evr+VlocalW(2*iadd-1,1)*denom+vnlph_l_3D(iadd,ib,1)
          devi  = e1*evi+VlocalW(2*iadd  ,1)*denom+vnlph_l_3D(iadd,ib,2)
!!        wdi   = ekin(i) + vlhxc0 + vnldi(iadd) - eko_l_3D(ib,ik)
          wdi   = ekin(iadd) + vlhxc0 + vnldi(iadd) - eko_l_3D(ib,ik)
          fdexp = dexp( -p(iadd) * wdi * dtim)
          zaj_l_3D(iadd,ib,ik,1) = (fdexp - 1)*devr/wdi + evr
          zaj_l_3D(iadd,ib,ik,2) = (fdexp - 1)*devi/wdi + evi
       end do
    end if
  end subroutine modified_steepest_descent_3D
!$$#endif

!$$#ifdef PARA3D
  subroutine steepest_descent_3D_2(precon,ik,ibo,dtim,ekin,VlocalW,lsize,p)
    integer      , intent(in)                  :: precon,ik,ibo,lsize
    real(kind=DP), intent(in)                  :: dtim
    real(kind=DP), intent(in), dimension(kg1)  :: ekin
!   real(kind=DP), intent(in), dimension(lsize*kimg,ibesize) :: VlocalW
    real(kind=DP), intent(in), dimension(lsize*kimg,1) :: VlocalW
    real(kind=DP)            , dimension(maxval(np_g1k_3D)) :: p

    integer       :: i, i1, ib, iadd
    real(kind=DP) :: evr,devr,denom, evi,e1, devi

    ib = ibo ! MPI
    denom = 1.d0/product(fft_box_size_WF(1:3,1))
    call m_ES_decide_precon_factor_3D(precon,ik,ibo,ekin,p)  ! -> p(1:iba(ik))

    if(kimg == 1) then
       do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
          iadd = i - ista_g1k_3D(ik) + 1
          i1    = igf(nbase(i,ik))
          evr   = zaj_l_3D(iadd,ib,ik,1)
          devr  = (ekin(i)-eko_l_3D(ib,ik))*evr + VlocalW(iadd,1)*denom + vnlph_l_3D(iadd,ib,1)
          zaj_l_3D(iadd,ib,ik,1) = evr - p(iadd)*dtim*devr
       end do
    else if(kimg == 2) then
       do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
          iadd = i - ista_g1k_3D(ik) + 1
          i1    = igf(nbase(i,ik))
          evr   = zaj_l_3D(iadd,ib,ik,1);    evi   = zaj_l_3D(iadd,ib,ik,2)
          e1    = ekin(i) - eko_l_3D(ib,ik)
          devr  = e1*evr+VlocalW(2*iadd-1,1)*denom+vnlph_l_3D(iadd,ib,1)
          devi  = e1*evi+VlocalW(2*iadd  ,1)*denom+vnlph_l_3D(iadd,ib,2)
          zaj_l_3D(iadd,ib,ik,1) = evr - p(iadd)*dtim*devr
          zaj_l_3D(iadd,ib,ik,2) = evi - p(iadd)*dtim*devi
       end do
    end if
  end subroutine steepest_descent_3D_2
!$$#endif

  subroutine square_of_SD_direction(ik,ibo,dz)
    integer,       intent(in)       :: ik,ibo
    real(kind=DP), intent(out)      :: dz  ! dz = <wfsd|w|wfsd>
    integer                         :: i,ib

    dz = 0.d0
    if(modnrm == EXECUT) then
       call m_ES_sum_of_LocalPart(ik,ibo,bsdr_l,bsdi_l,dz)
    end if
    ib = map_z(ibo)                     ! MPI
    if(k_symmetry(ik) == GAMMA) then
       if(kimg == 1) then
          dz = dz + wfsd_l(1,ib,ik,1)*wfsd_l(1,ib,ik,1)
          do i = 2, iba(ik)
             dz = dz + 2.d0*wfsd_l(i,ib,ik,1)*wfsd_l(i,ib,ik,1)
          end do
       else
          dz = dz + wfsd_l(1,ib,ik,1)**2 + wfsd_l(1,ib,ik,2)**2
          do i = 2, iba(ik)
             dz = dz + 2.d0*(wfsd_l(i,ib,ik,1)**2 + wfsd_l(i,ib,ik,2)**2)
          end do
       end if
    else
       if(kimg == 1) then
          do i = 1, iba(ik)
             dz = dz + wfsd_l(i,ib,ik,1)*wfsd_l(i,ib,ik,1)
          end do
       else
          do i = 1, iba(ik)
             dz = dz + wfsd_l(i,ib,ik,1)**2 + wfsd_l(i,ib,ik,2)**2
          end do
       end if
    end if
  end subroutine square_of_SD_direction

!$$#ifdef PARA3D
  subroutine square_of_SD_direction_3D(ik,ib,dz)
    integer,       intent(in)       :: ik,ib
    real(kind=DP), intent(out)      :: dz  ! dz = <wfsd|w|wfsd>
    integer                         :: i,iadd

    dz = 0.d0
    if(modnrm == EXECUT) then
       if (myrank_g_3D == 0) then
          call m_ES_sum_of_LocalPart_3D(ik,ib,bsdr_l_3D,bsdi_l_3D,dz)
       end if
    end if
    if(k_symmetry(ik) == GAMMA) then
       if(kimg == 1) then
          do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
             if (i == 1) then 
                dz = dz + wfsd_l_3D(1,ib,ik,1)*wfsd_l_3D(1,ib,ik,1)
             else
                iadd = i-ista_g1k_3D(ik)+1
                dz = dz + 2.d0*wfsd_l_3D(iadd,ib,ik,1)*wfsd_l_3D(iadd,ib,ik,1)
             end if
          end do
       else
          do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
             if (i == 1) then 
                dz = dz + wfsd_l_3D(1,ib,ik,1)**2 + wfsd_l_3D(1,ib,ik,2)**2
             else
                iadd = i-ista_g1k_3D(ik)+1
                dz = dz + 2.d0*(wfsd_l_3D(iadd,ib,ik,1)**2 + wfsd_l_3D(iadd,ib,ik,2)**2)
             end if
          end do
       end if
    else
       if(kimg == 1) then
          do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
             iadd = i-ista_g1k_3D(ik)+1
             dz = dz + wfsd_l_3D(iadd,ib,ik,1)*wfsd_l_3D(iadd,ib,ik,1)
          end do
       else
          do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
             iadd = i-ista_g1k_3D(ik)+1
             dz = dz + wfsd_l_3D(iadd,ib,ik,1)**2 + wfsd_l_3D(iadd,ib,ik,2)**2
          end do
       end if
    end if
  end subroutine square_of_SD_direction_3D
!$$#endif

  subroutine square_of_SD_direction2(ik,ibo,dz)
    integer,       intent(in)       :: ik,ibo
    real(kind=DP), intent(out)      :: dz  ! dz = <wfsd|w|wfsd>
    integer                         :: i,ib

    ib = map_z(ibo)                     ! MPI
    dz = 0.d0
    if(modnrm == EXECUT) then
       call m_ES_sum_of_LocalPart2(ik,ibo,bsdr_l,bsdi_l,bsdr_np,bsdi_np,dz)
    end if
    if(k_symmetry(ik) == GAMMA) then
       if(kimg == 1) then
          dz = dz + wfsd_l(1,ib,ik,1)*wfsd_np(1,ib,ik,1)
          do i = 2, iba(ik)
             dz = dz + 2.d0*wfsd_l(i,ib,ik,1)*wfsd_np(i,ib,ik,1)
          end do
       else
          dz = dz + wfsd_l(1,ib,ik,1)*wfsd_np(1,ib,ik,1)
          do i = 2, iba(ik)
             dz = dz + 2.d0*( wfsd_l(i,ib,ik,1)*wfsd_np(i,ib,ik,1) &
                  &         + wfsd_l(i,ib,ik,2)*wfsd_np(i,ib,ik,2))
          end do
       end if
    else
       if(kimg == 1) then
          do i = 1, iba(ik)
             dz = dz + wfsd_l(i,ib,ik,1)*wfsd_np(i,ib,ik,1)
          end do
       else
          do i = 1, iba(ik)
             dz = dz + wfsd_l(i,ib,ik,1)*wfsd_np(i,ib,ik,1) &
                  &  + wfsd_l(i,ib,ik,2)*wfsd_np(i,ib,ik,2)
          end do
       end if
    end if
  end subroutine square_of_SD_direction2

!$$#ifdef PARA3D
  subroutine SD_direction_3D(precon,ik,ib1,ib2,ibesize,ekin_l,VlocalW,lsize,p_l)
    integer      , intent(in)                  :: precon,ik,ib1,ib2,ibesize,lsize
    real(kind=DP), intent(in), dimension(np_g1k_3D(ik))  :: ekin_l
    real(kind=DP), intent(in), dimension(lsize*kimg,ibesize) :: VlocalW
    real(kind=DP)            , dimension(mp_g1k_3D(ik),np_e_3D) :: p_l

    integer       :: i, i1, ib, iadd
    real(kind=DP) :: devr,denom, e1, devi

    denom = 1.d0/product(fft_box_size_WF(1:3,1))
!P  call m_ES_decide_precon_factor_3D(precon,ik,ibo,ekin,p)  ! -> p(1:iba(ik))

    if(kimg == 1) then
       do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
          iadd = i - ista_g1k_3D(ik) + 1
!xx       i1    = igf(nbase(i,ik))
          do ib = ib1, ib2
             devr  = (ekin_l(iadd)-eko_l_3D(ib,ik))*zaj_l_3D(iadd,ib,ik,1)&
                  & + VlocalW(iadd,ib-ib1+1)*denom + vnlph_l_3D(iadd,ib,1)
             wfsd_l_3D(iadd,ib,ik,1) = - p_l(iadd,ib)*devr
          end do
       end do
    else if(kimg == 2) then
       do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
          iadd = i - ista_g1k_3D(ik) + 1
!xx       i1    = igf(nbase(i,ik))
          do ib = ib1, ib2
             e1    = ekin_l(iadd) - eko_l_3D(ib,ik)
             devr  = e1*zaj_l_3D(iadd,ib,ik,1) + VlocalW(2*iadd-1,ib-ib1+1)*denom+vnlph_l_3D(iadd,ib,1)
             devi  = e1*zaj_l_3D(iadd,ib,ik,2) + VlocalW(2*iadd  ,ib-ib1+1)*denom+vnlph_l_3D(iadd,ib,2)
             wfsd_l_3D(iadd,ib,ik,1) = - p_l(iadd,ib)*devr
             wfsd_l_3D(iadd,ib,ik,2) = - p_l(iadd,ib)*devi
          end do
       end do
    end if
  end subroutine SD_direction_3D
!$$#endif

!$$#ifdef PARA3D
  subroutine Vnonlocal_Diagonal_part_3D(ispin,ik,iksnl,ibo,vnldi)
    integer, intent(in)                        :: ispin, ik, iksnl,ibo
    real(kind=DP), intent(out), dimension(maxval(np_g1k_3D)) :: vnldi

    integer :: it,mdvdb,ib

    ib = ibo ! MPI
    vnldi = 0.d0
    do it = 1, ntyp
       mdvdb = m_PP_include_vanderbilt_pot(it)
       if(mdvdb == SKIP) then
          call Vnonlocal_D_norm_conserve_case
       else if(mdvdb == EXECUT) then
          call Vnonlocal_D_vanderbilt_case
       end if
    end do
  contains
    subroutine Vnonlocal_D_vanderbilt_case
      integer       :: ia, p1,p2,lmtt1,il1,lmtt2,il2,i,iadd
      real(kind=DP) :: ph,fac, dion_eq

      do p1 = 1, ilmt(it)
         lmtt1 = lmtt(p1,it); il1 = ltp(p1,it)
         do p2 = p1, ilmt(it)
            lmtt2 = lmtt(p2,it); il2 = ltp(p2,it)
            if( p1 /= p2) then
               ph = 2.d0*real(zi**(il2-il1))
            else
               ph = 1.d0
            endif
            if(mod(il1+il2,2) == 1) cycle
            dion_eq = dion(p1,p2,it)-eko_l_3D(ib,ik)*q(p1,p2,it)
            fac = 0.d0
            do ia = 1, natm
               if(ityp(ia) /= it) cycle
               if(ipaw(it)==0) then
                   fac = fac + ph*iwei(ia) * (dion_eq+vlhxcQ(p1,p2,ia,ispin))
               else
                   fac = ph*iwei(ia) * &
                        & (dion_paw(p1,p2,ispin,ia)-eko_l_3D(ib,ik)*q(p1,p2,it)+vlhxcQ(p1,p2,ia,ispin))
               end if
            end do

            do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
               iadd = i - ista_g1k_3D(ik) + 1
               vnldi(iadd) = vnldi(iadd)+fac*snl(i,lmtt1,iksnl)*snl(i,lmtt2,iksnl)
            end do
         end do
      end do
    end subroutine Vnonlocal_D_vanderbilt_case

    subroutine Vnonlocal_D_norm_conserve_case
      integer       :: ia, lmt1,lmt2,lmtt1,il1,im1,il2,im2,i,iadd
      real(kind=DP) :: ph,fac

      ph = 0.d0
      do ia = 1, natm
         if(ityp(ia) /= it) cycle
         ph = ph + iwei(ia)
      end do
      do lmt1 = 1, ilmt(it)
         lmtt1 = lmtt(lmt1,it); il1 = ltp(lmt1,it); im1 = mtp(lmt1,it)
         do lmt2 = lmt1, ilmt(it)
            il2 = ltp(lmt2,it); im2 = mtp(lmt2,it)
            if(il1 /= il2 .or. im1 /= im2) cycle
            if(mod(il1+il2,2) == 1) cycle
            fac = ph * dion(lmt1,lmt2,it)
            do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
               iadd = i - ista_g1k_3D(ik) + 1
               vnldi(iadd)  = vnldi(iadd) + fac * snl(i,lmtt1,iksnl)**2
            end do
         end do
      end do
    end subroutine Vnonlocal_D_norm_conserve_case
  end subroutine Vnonlocal_Diagonal_part_3D
!$$#endif

  subroutine m_ESsd_reset_dzajn2
    dzajn2 = 0.d0
  end subroutine m_ESsd_reset_dzajn2
       
!$$#ifdef PARA3D
  subroutine m_ESsd_copy_zaj_to_zaj_old_3D
    integer :: ik, ir
    do ir = 1, kimg
       do ik = 1, kv3, af+1
          if(map_k_3D(ik) /= myrank_k_3D) cycle                       ! MPI
          zaj_old_3D(:,:,ik,ir) = zaj_l_3D(:,:,ik,ir)
       end do
    end do
  end subroutine m_ESsd_copy_zaj_to_zaj_old_3D
!$$#endif

!$$#ifdef PARA3D
  subroutine m_ESsd_copy_zaj_old_to_zaj_3D(ik,ibo)
    integer, intent(in)                           :: ik, ibo

    integer    :: ir, ib

    ib = ibo
     do ir = 1, kimg
       zaj_l_3D(:,ib,ik,ir) = zaj_old_3D(:,ib,ik,ir)
    end do
  end subroutine m_ESsd_copy_zaj_old_to_zaj_3D
!$$#endif

!$$#ifdef PARA3D
  subroutine m_ESsd_copy_phi_to_zaj_old_3D(ik,ibo,phi)
    integer, intent(in)                           :: ik, ibo
    real(kind=DP),intent(in),dimension(maxval(np_g1k_3D),kimg)  :: phi

    integer    :: ir, ib

    ib = ibo
     do ir = 1, kimg
       zaj_old_3D(:,ib,ik,ir) = phi(:,ir)
    end do
  end subroutine m_ESsd_copy_phi_to_zaj_old_3D
!$$#endif

  subroutine m_ESsd_diff_WFs_to_zaj_old(dt)
    real(kind=DP), intent(in) :: dt
    integer                   :: ik, ir
    real(kind=DP), parameter  :: Delta = 1.d-10
    real(kind=DP)             :: rdt

    if(dt < Delta ) then
       if(ipri >=1 ) write(nfout,'(" !! dt is smaller than ",d20.8)') Delta
       rdt = 0.d0
    else
       rdt = 1.d0/dt
    end if

    do ir = 1, kimg
       do ik = 1, kv3, af+1
          if(map_k(ik) /= myrank_k) cycle                ! MPI
          zaj_old(:,:,ik,ir) = rdt * (zaj_l(:,:,ik,ir) - zaj_old(:,:,ik,ir))
       end do
    end do
  end subroutine m_ESsd_diff_WFs_to_zaj_old

!$$#if PARA3D
  subroutine WF_conjugate_gradient_3D(ik,ibo,dtim)
! \Psi_{k\mu}^{m+1} = \Psi_{k\mu}^{m} + \Delta t_{opt}^{m} d^{m}
!   d^{m} = g^{m} + \beta_CG d^{m-1}
!   g^{m} = - \Phi_{k\mu}^{m}
!   d^{m-1} = (\Psi_{k\mu}^{m} - \Psi_{k\mu}^{m-1})\frac{1}{\Delta t_{opt}^{m-1}}
!
    integer      , intent(in)                  :: ik,ibo
    real(kind=DP), intent(in)                  :: dtim

    integer       :: i,ib,iadd
    real(kind=DP) :: evr,evi

    ib = ibo                    ! MPI
    if(kimg == 1) then
       do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
          iadd = i - ista_g1k_3D(ik) + 1
          evr   = zaj_l_3D(iadd,ib,ik,1)
          zaj_l_3D(iadd,ib,ik,1) = evr + dtim*wfsd_l_3D(iadd,ib,ik,1)
       end do
    else if(kimg == 2) then
       do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
          iadd = i - ista_g1k_3D(ik) + 1
          evr   = zaj_l_3D(iadd,ib,ik,1);  evi   = zaj_l_3D(iadd,ib,ik,kimg)
          zaj_l_3D(iadd,ib,ik,1) = evr + dtim*wfsd_l_3D(iadd,ib,ik,1)
          zaj_l_3D(iadd,ib,ik,2) = evi + dtim*wfsd_l_3D(iadd,ib,ik,2)
       end do
    end if
  end subroutine WF_conjugate_gradient_3D
!$$#endif


!$$#ifdef PARA3D
  subroutine make_CG_direction_3D(ik)
    integer, intent(in) :: ik

    real(kind=DP), parameter             :: Delta = 1.d-20
    integer :: i, ib, iadd
    integer :: id_sname = -1
    call tstatc0_begin('make_CG_direction_3D', id_sname)

    if(betacg > Delta) then
       if(kimg == 1) then
          do ib = 1, np_e_3D
             do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
                iadd = i - ista_g1k_3D(ik) + 1
                wfsd_l_3D(iadd,ib,ik,1) = wfsd_l_3D(iadd,ib,ik,1) + betacg*wfsd_old_3D(iadd,ib,ik,1)
             end do
          end do
       else
          do ib = 1, np_e_3D
             do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
                iadd = i - ista_g1k_3D(ik) + 1
                wfsd_l_3D(iadd,ib,ik,1) = wfsd_l_3D(iadd,ib,ik,1) + betacg*wfsd_old_3D(iadd,ib,ik,1)
                wfsd_l_3D(iadd,ib,ik,2) = wfsd_l_3D(iadd,ib,ik,2) + betacg*wfsd_old_3D(iadd,ib,ik,2)
             end do
          end do
       end if
    end if
    call tstatc0_end(id_sname)
  end subroutine make_CG_direction_3D
!$$#endif

!$$#ifdef PARA3D
  subroutine orthogonalize_SD_drctns_3D(ik,to)
    integer, intent(in) :: ik,to

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

!!$    if(modnrm == EXECUT) call m_ES_betar_dot_Psi_4_each_k(wfsd_l,ista_k,iend_k,ik,bsdr_l,bsdi_l)
START_TIMER('CG2_m_ES_betar_dot_Psi_4_each_k_3D')
    if(modnrm == EXECUT) call m_ES_betar_dot_Psi_4_each_k_3D(wfsd_l_3D,ik,ik,ik,bsdr_l_3D,bsdi_l_3D)
STOP_TIMER('CG2_m_ES_betar_dot_Psi_4_each_k_3D')
    !                                                          ->bsd(ri)_l
START_TIMER('CG2_m_ES_orthogonalize_SD_to_WFs_3D')
    call m_ES_orthogonalize_SD_to_WFs_3D(ik,to,wfsd_l_3D,bsdr_l_3D,bsdi_l_3D) ! ->(wfsd_l,bsd(ri)_l)
STOP_TIMER('CG2_m_ES_orthogonalize_SD_to_WFs_3D')

!!$    call orthogonalize_SD(ik,wfsd_l,bsdr_l,bsdi_l)           !-(m_E.S.) ->(wfsd_l)
    call tstatc0_end(id_sname)
  end subroutine orthogonalize_SD_drctns_3D
!$$#endif

  subroutine Precon_dot_SD(ik,ekin,p)
    integer,      intent(in)                 :: ik
    real(kind=DP),intent(in),dimension(kg1)  :: ekin
    real(kind=DP),           dimension(kg1)  :: p

    integer :: ib, ri, i

    do ri = 1, kimg
       do ib = ista_e, iend_e, istep_e
          do i = 1, iba(ik)
             wfsd_np(i,map_z(ib),ik,ri) = wfsd_l(i,map_z(ib),ik,ri)
          end do
       end do
    end do

    do ib = ista_e, iend_e, istep_e   ! MPI
       call decide_precon_factor_wfsd(ik,ib,ekin,p)
       if(kimg == 1) then
          do i = 1, iba(ik)
             wfsd_l(i,map_z(ib),ik,1) = p(i)*wfsd_l(i,map_z(ib),ik,1)
          end do
       else if(kimg == 2) then
          do i = 1, iba(ik)
             wfsd_l(i,map_z(ib),ik,1) = p(i)*wfsd_l(i,map_z(ib),ik,1)
             wfsd_l(i,map_z(ib),ik,2) = p(i)*wfsd_l(i,map_z(ib),ik,2)
          end do
       end if
    end do

  end subroutine Precon_dot_SD

  subroutine decide_precon_factor_wfsd(ik,ib,ekin,p)
    integer, intent(in)                         :: ik,ib
    real(kind=DP), intent(in),  dimension(kg1)  :: ekin
    real(kind=DP), intent(out), dimension(kg1)  :: p

    integer       :: i
    real(kind=DP) :: ektot, x, x1, x2, d_ektot

    call kinetic_energy_wfsd(ik,ib,ekin,ektot)   ! -(m_ES_WF_by_SDorCG)
    d_ektot = 1.d0/ektot
    p = 0.d0
    do i = 1, iba(ik)
       x = ekin(i)*d_ektot
       x1 = 27 + ( 18 + (12 + 8*x) *x) *x
       x2 = 16*(x*x)*(x*x)
       p(i)  = x1/(x1 + x2 )
    end do
  end subroutine decide_precon_factor_wfsd

  subroutine kinetic_energy_wfsd(ik,ib,dekin,ektot)
    integer, intent(in) :: ik, ib
    real(kind=DP), intent(in), dimension(kg1)  :: dekin
    real(kind=DP), intent(out)                 :: ektot
    integer  :: i, ri
    ektot = 0.d0

    do ri = 1, kimg
       do i = 1, iba(ik)
          ektot = ektot + dekin(i)*wfsd_l(i,map_z(ib),ik,ri)**2   ! MPI
       end do
    end do

    if(k_symmetry(ik) == GAMMA) ektot = ektot*2.d0

  end subroutine kinetic_energy_wfsd

!$$#ifdef PARA3D
  subroutine cp_wfsd_to_wfsd_old_3D(ik)
    integer, intent(in) :: ik
    wfsd_old_3D(:,:,ik,:) = wfsd_l_3D(:,:,ik,:)
  end subroutine cp_wfsd_to_wfsd_old_3D
!$$#endif

  subroutine m_ESsd_dealloc
    if(allocated(zaj_old)) deallocate(zaj_old)
    if(allocated(dzajn2)) deallocate(dzajn2)


  end subroutine m_ESsd_dealloc

!$$#ifdef PARA3D

!------------------------------------------------------------------------------
!------------------------------------------------------------------------------
!------------------------------------------------------------------------------
!------------------------------------------------------------------------------
  subroutine evolve_WFs_in_SD_direction_3D_F&
       &(precon,ik,dtim,ekin_l_3D,afft_l,lsize)
    integer, intent(in)        :: precon, ik, lsize
    real(kind=DP), intent(in)  :: dtim, ekin_l_3D(np_g1k_3D(ik)), afft_l(lsize*kimg)

    real(kind=DP), allocatable,dimension(:,:) :: wk_bfft_l
    real(kind=DP), allocatable,dimension(:,:) :: bfft_l
    real(kind=DP), allocatable,dimension(:,:) :: p_l_3D

    integer :: ib1, ib2, ibsize, ibesize
    integer :: isrsize, fft_l_size

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

    ibsize = 1
    if (nblocksize_fftw_is_given) then
       ibsize = nblocksize_fftw
       if (ibsize < 1) ibsize = 1
    endif
    isrsize = min(lsize,mp_g1k_3D(ik))
    fft_l_size  = nel_fft_x(myrank_g_3D)

    allocate(wk_bfft_l(lsize*kimg,ibsize) ,stat=ierr)
    allocate(bfft_l(lsize*kimg,ibsize) ,stat=ierr)
!P! allocate(p_l_3D(mp_g1k_3D(ik),ibsize) ,stat=ierr)
    allocate(p_l_3D(mp_g1k_3D(ik),np_e_3D) ,stat=ierr)
     if (ierr /= 0) then
        write(nfout,*)' m_ES_WF_in_Rspace_3D :  Not allocate '
        call flush(nfout)
        call mpi_abort(mpi_comm_world, 203, ierr)
     endif
!P!
    call m_ES_decide_precon_factor_3D_F(precon,ik,1,np_e_3D,np_e_3D,ekin_l_3D,p_l_3D)! -> p(1:iba(ik))
!P!
    do ib1 = 1, np_e_3D, ibsize
       ib2 = min(ib1+ibsize-1,np_e_3D)
       ibesize = ib2 - ib1 + 1

       call m_ES_WF_in_Rspace_3D(ik,ib1,ib2,ibsize,lsize,wk_bfft_l)
       call m_FFT_Vlocal_W_3D(afft_l,wk_bfft_l,lsize,ibesize,nel_fft_y(myrank_g_3D))
       call m_FFT_Direct_3D (bfft_l, nfout, wk_bfft_l, lsize, ibesize, OFF, OFF)

       call map_fft_to_WF_3D(ik, lsize, ibesize, wk_bfft_l, bfft_l, isrsize, fft_l_size)

       call steepest_descent_3D(precon,ik,ib1,ib2,ibesize,dtim,ekin_l_3D,bfft_l,lsize,p_l_3D)
                                         ! -(m_ES_WF_by_SDorCG)
    end do

    deallocate(wk_bfft_l)
    deallocate(bfft_l)
    deallocate(p_l_3D)

    call tstatc0_end(id_sname)
  end subroutine evolve_WFs_in_SD_direction_3D_F

!===============================================================================
  subroutine steepest_descent_3D(precon,ik,ib1,ib2,ibesize,dtim,ekin_l_3D,VlocalW,lsize,p_l_3D)
    integer      , intent(in)                  :: precon, ik, ib1, ib2, ibesize, lsize
    real(kind=DP), intent(in)                  :: dtim
    real(kind=DP), intent(in), dimension(np_g1k_3D(ik))  :: ekin_l_3D
    real(kind=DP), intent(in), dimension(lsize*kimg,ibesize) :: VlocalW
!P! real(kind=DP)            , dimension(mp_g1k_3D(ik),ibesize)  :: p_l_3D
    real(kind=DP)            , dimension(mp_g1k_3D(ik),np_e_3D)  :: p_l_3D

    integer       :: iadd, i, ib
    real(kind=DP) :: evr,devr,denom, evi,e1, devi

    denom = 1.d0/product(fft_box_size_WF(1:3,1))
!P! call m_ES_decide_precon_factor_3D(precon,ik,ib1,ib2,ibesize,ekin,p_l_3D)  ! -> p(1:iba(ik))

    if(kimg == 1) then
       do i=ista_g1k_3D(ik), iend_g1k_3D(ik)
          iadd = i-ista_g1k_3D(ik)+1
          do ib = ib1, ib2
             evr   = zaj_l_3D(iadd,ib,ik,1)
             e1    = ekin_l_3D(iadd)-eko_l_3D(ib,ik)
             devr  = e1*evr + VlocalW(iadd,ib-ib1+1)*denom + vnlph_l_3D(iadd,ib,1)
!P!          zaj_l_3D(iadd,ib,ik,1) = evr - p_l_3D(iadd,ib-ib1+1)*dtim*devr
             zaj_l_3D(iadd,ib,ik,1) = evr - p_l_3D(iadd,ib)*dtim*devr
          enddo
       end do
    else if(kimg == 2) then
       do i=ista_g1k_3D(ik), iend_g1k_3D(ik)
          iadd = i-ista_g1k_3D(ik)+1
          do ib = ib1, ib2
             evr   = zaj_l_3D(iadd,ib,ik,1)
             evi   = zaj_l_3D(iadd,ib,ik,2)
             e1    = ekin_l_3D(iadd) - eko_l_3D(ib,ik)
             devr  = e1*evr + VlocalW(2*iadd-1,ib-ib1+1)*denom + vnlph_l_3D(iadd,ib,1)
             devi  = e1*evi + VlocalW(2*iadd  ,ib-ib1+1)*denom + vnlph_l_3D(iadd,ib,2)
!P!          zaj_l_3D(iadd,ib,ik,1) = evr - p_l_3D(iadd,ib-ib1+1)*dtim*devr
!P!          zaj_l_3D(iadd,ib,ik,2) = evi - p_l_3D(iadd,ib-ib1+1)*dtim*devi
             zaj_l_3D(iadd,ib,ik,1) = evr - p_l_3D(iadd,ib)*dtim*devr
             zaj_l_3D(iadd,ib,ik,2) = evi - p_l_3D(iadd,ib)*dtim*devi
         end do
       end do
    end if
  end subroutine steepest_descent_3D

!===============================================================================
  subroutine evolve_WFs_in_MSD_direction_3D_F  &
 &           (precon,ik,iksnl,ispin,dtim,ekin_l_3D,afft_l,lsize,vlhxc0)
    integer, intent(in)        :: precon, ik, iksnl, ispin, lsize
    real(kind=DP), intent(in)  :: dtim, ekin_l_3D(np_g1k_3D(ik)), afft_l(lsize*kimg), vlhxc0

    real(kind=DP), allocatable,dimension(:,:) :: p_l_3D, vnldi_l_3D

    real(kind=DP), allocatable,dimension(:,:) :: wk_bfft_l
    real(kind=DP), allocatable,dimension(:,:) :: bfft_l

    integer :: isrsize, fft_l_size
    integer ib1, ib2, ibsize, ibesize, ib, ig
    integer :: id_sname = -1
    call tstatc0_begin('evolve_WFs_in_MSD_direction_3D ', id_sname,1)

    ibsize = 1
    if (nblocksize_fftw_is_given) then
       ibsize = nblocksize_fftw
       if (ibsize < 1) ibsize = 1
    endif
    isrsize = min(lsize,mp_g1k_3D(ik))
    fft_l_size  = nel_fft_x(myrank_g_3D)

    allocate(wk_bfft_l(lsize*kimg,ibsize) ,stat=ierr)
    allocate(bfft_l(lsize*kimg,ibsize) ,stat=ierr)
!P! allocate(p_l_3D(mp_g1k_3D(ik),ibsize), stat=ierr)
    allocate(p_l_3D(mp_g1k_3D(ik),np_e_3D), stat=ierr)
    allocate(vnldi_l_3D(mp_g1k_3D(ik),ibsize), stat=ierr)
     if (ierr /= 0) then
        write(nfout,*)' evolve_WFs_in_MSD_direction_3D :  Not allocate '
        call flush(nfout)
        call mpi_abort(mpi_comm_world, 205, ierr)
     endif
!P!
    call m_ES_decide_precon_factor_3D_F(precon,ik,1,np_e_3D,np_e_3D,ekin_l_3D,p_l_3D)! -> p(1:iba(ik))
!P!
    do ib1 = 1, np_e_3D, ibsize
       ib2 = min(ib1+ibsize-1,np_e_3D)
       ibesize = ib2 - ib1 + 1

       call m_ES_WF_in_Rspace_3D(ik,ib1,ib2,ibsize,lsize,wk_bfft_l)

       if(ipri >= 2) then
          write(nfout,'(" --- afft and bfft <<evolve_WFs_in_MSD_direction_3D>>,  ib1 = ",i5)') ib1
          write(nfout,'(" afft: ",5d16.8)') (afft_l(ig),ig=1,min(5,lsize))
          write(nfout,'(" bfft: ",5d16.8)') (wk_bfft_l(ig,1),ig=1,min(5,lsize))
       end if

       call m_FFT_Vlocal_W_3D(afft_l,wk_bfft_l,lsize,ibesize,nel_fft_y(myrank_g_3D))
       call m_FFT_Direct_3D (bfft_l, nfout, wk_bfft_l, lsize, ibesize, OFF, OFF)

       call Vnonlocal_Diagonal_part_3D_F(ispin,ik,iksnl,ib1,ib2,ibesize,vnldi_l_3D)
                                         ! -(m_ES_WF_by_SDorCG) (nonldj)

       call map_fft_to_WF_3D(ik, lsize, ibesize, wk_bfft_l, bfft_l, isrsize, fft_l_size)

       if(ipri >= 2) then
        do ib = ib1, ib2
          write(nfout,'(" --- vnlph_l <<evolve_WFs_in_MSD_direction>>,  ib = ",i5)') ib
                      write(nfout,'(" vnlph_l: Re ",5d16.8)') (vnlph_l(ig,ib,1),ig=1,min(5,iba(ik)))
          if(kimg== 2) then
             write(nfout,'(" vnlph_l: Im ",5d16.8)') (vnlph_l(ig,ib,2),ig=1,min(5,iba(ik)))
          end if
          write(nfout,'(" vnldi ",5d16.8)') (vnldi_l_3D(ig,1),ig=1,min(5,iba(ik)))
          write(nfout,'(" VlocalW: Re ",5d16.8)') (bfft_l(ig,1),ig=1,min(5,iba(ik)))
          write(nfout,'(" VlocalW: Im ",5d16.8)') (bfft_l(ig,1),ig=1,min(5,iba(ik)))
          write(nfout,'(" vlhxc0 = ",5d16.8)') vlhxc0
        end do
       end if

       call modified_steepest_descent_3D_F&   ! -(m_ES_WF_by_SDorCG)
            &(precon,ik,ib1,ib2,ibesize,dtim,vnldi_l_3D,vlhxc0,ekin_l_3D,bfft_l,lsize,p_l_3D)
    end do

    deallocate(wk_bfft_l)
    deallocate(bfft_l)
    deallocate(p_l_3D)
    deallocate(vnldi_l_3D)

    call tstatc0_end(id_sname)
  end subroutine evolve_WFs_in_MSD_direction_3D_F

!===============================================================================
  subroutine Vnonlocal_Diagonal_part_3D_F(ispin,ik,iksnl,ib1,ib2,ibesize,vnldi_l_3D)
    integer, intent(in)                        :: ispin, ik, iksnl, ib1, ib2, ibesize
    real(kind=DP), intent(out), dimension(mp_g1k_3D(ik),ibesize) :: vnldi_l_3D
    integer :: it,mdvdb,ib,    i,j

#ifdef VNONLOCAL_SPEED
    integer :: p1, p2, lmtt1, lmtt2, il1, il2, icnt
    integer, save :: icnt_lmt = 0
    logical, save :: first_call = .true.

    if (first_call) then
      do it = 1, ntyp
         icnt = 0
         do p1 = 1, ilmt(it)
            lmtt1 = lmtt(p1,it)
            il1 = ltp(p1,it)
            do p2 = p1, ilmt(it)
               lmtt2 = lmtt(p2,it)
               il2 = ltp(p2,it)
               if(mod(il1+il2,2) == 1) cycle
               icnt = icnt + 1
            end do
         end do
         if (icnt_lmt < icnt) then
            icnt_lmt = icnt
         end if
      end do
      first_call = .false.
      write(nfout,'("Vnonlocal_Diagonal_part_3D ntyp=",i8)') ntyp
      write(nfout,'("Vnonlocal_Diagonal_part_3D icnt_lmt=",i8)') icnt_lmt
    end if
#endif

    vnldi_l_3D = 0.d0
    do it = 1, ntyp
       mdvdb = m_PP_include_vanderbilt_pot(it)
       if(mdvdb == SKIP) then
          call Vnonlocal_D_norm_conserve_case
       else if(mdvdb == EXECUT) then
          call Vnonlocal_D_vanderbilt_case
       end if
    end do

  contains

#ifdef VNONLOCAL_SPEED
    subroutine Vnonlocal_D_vanderbilt_case
      integer       :: ia, p1,p2,lmtt1,il1,lmtt2,il2,i,iadd,icnt
      real(kind=DP) :: ph, dion_eq
      real(kind=DP) :: fac_l(ib1:ib2,icnt_lmt), mpi(ib1:ib2,icnt_lmt), fac

      if(ipaw(it)==0) then
         icnt = 0
         fac_l = 0.0d0
         do p1 = 1, ilmt(it)
            lmtt1 = lmtt(p1,it); il1 = ltp(p1,it)
            do p2 = p1, ilmt(it)
               lmtt2 = lmtt(p2,it); il2 = ltp(p2,it)
               if( p1 /= p2) then
                  ph = 2.d0*real(zi**(il2-il1))
               else
                  ph = 1.d0
               endif
               if(mod(il1+il2,2) == 1) cycle
               icnt = icnt + 1

               do ib = ib1, ib2
                  do ia = ista_atm_3D, iend_atm_3D
                     if(ityp(ia) /= it) cycle
                     dion_eq = dion(p1,p2,it)-eko_l_3D(ib,ik)*q(p1,p2,it)
                     fac_l(ib,icnt) = fac_l(ib,icnt) + ph*iwei(ia) * (dion_eq+vlhxcQ(p1,p2,ia,ispin))
                  end do
               end do
            end do
         end do
         if (nrank_g_3D > 1) then
            call mpi_allreduce(fac_l,mpi,(ib2-ib1+1)*icnt_lmt,mpi_double_precision &
           &                   ,mpi_sum,mpi_ke_world,ierr)    ! MPI
            fac_l = mpi
         end if
         icnt = 0
         do p1 = 1, ilmt(it)
            lmtt1 = lmtt(p1,it)
            il1 = ltp(p1,it)
            do p2 = p1, ilmt(it)
               lmtt2 = lmtt(p2,it)
               il2 = ltp(p2,it)
               if(mod(il1+il2,2) == 1) cycle
               icnt = icnt + 1

               do ib = ib1, ib2
                  do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
                     iadd = i-ista_g1k_3D(ik)+1
                     vnldi_l_3D(iadd,ib-ib1+1) = vnldi_l_3D(iadd,ib-ib1+1) + fac_l(ib,icnt) &
                    &                         *snl_l_3D(iadd,lmtt1,iksnl)*snl_l_3D(iadd,lmtt2,iksnl)
                  end do
               end do
            end do
         end do
      else
         do p1 = 1, ilmt(it)
            lmtt1 = lmtt(p1,it); il1 = ltp(p1,it)
            do p2 = p1, ilmt(it)
               lmtt2 = lmtt(p2,it); il2 = ltp(p2,it)
               if( p1 /= p2) then
                  ph = 2.d0*real(zi**(il2-il1))
               else
                  ph = 1.d0
               endif
               if(mod(il1+il2,2) == 1) cycle
               do ib = ib1, ib2
                  fac = 0.d0
                  do ia = natm, natm
                     if(ityp(ia) /= it) cycle
                     fac = ph*iwei(ia) * (dion_paw(p1,p2,ispin,ia) &
                    &                   -eko_l_3D(ib,ik)*q(p1,p2,it)+vlhxcQ(p1,p2,ia,ispin))
                  end do
                  do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
                        iadd = i-ista_g1k_3D(ik)+1
                        vnldi_l_3D(iadd,ib-ib1+1) = vnldi_l_3D(iadd,ib-ib1+1) &
                       &                + fac*snl_l_3D(iadd,lmtt1,iksnl)*snl_l_3D(iadd,lmtt2,iksnl)
                  end do
               end do
            end do
         end do
      end if

    end subroutine Vnonlocal_D_vanderbilt_case
#else
    subroutine Vnonlocal_D_vanderbilt_case
      integer       :: ia, p1,p2,lmtt1,il1,lmtt2,il2,i,iadd
      real(kind=DP) :: ph,fac, dion_eq

      do p1 = 1, ilmt(it)
         lmtt1 = lmtt(p1,it); il1 = ltp(p1,it)
         do p2 = p1, ilmt(it)
            lmtt2 = lmtt(p2,it); il2 = ltp(p2,it)
            if( p1 /= p2) then
               ph = 2.d0*real(zi**(il2-il1))
            else
               ph = 1.d0
            endif
            if(mod(il1+il2,2) == 1) cycle

            do ib = ib1, ib2
               dion_eq = dion(p1,p2,it)-eko_l_3D(ib,ik)*q(p1,p2,it)
               fac = 0.d0
               do ia = 1, natm
                  if(ityp(ia) /= it) cycle
                  if(ipaw(it)==0) then
                      fac = fac + ph*iwei(ia) * (dion_eq+vlhxcQ(p1,p2,ia,ispin))
                  else
                      fac = ph*iwei(ia) * (dion_paw(p1,p2,ispin,ia) &
                     &                     -eko_l_3D(ib,ik)*q(p1,p2,it)+vlhxcQ(p1,p2,ia,ispin))
                  end if
               end do

               do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
                  iadd = i-ista_g1k_3D(ik)+1
                  vnldi_l_3D(iadd,ib-ib1+1) = vnldi_l_3D(iadd,ib-ib1+1) &
                 &                       + fac*snl_l_3D(iadd,lmtt1,iksnl)*snl_l_3D(iadd,lmtt2,iksnl)
               end do
            end do

         end do
      end do
    end subroutine Vnonlocal_D_vanderbilt_case
#endif
!! #endif VNONLOCAL_SPEED

    subroutine Vnonlocal_D_norm_conserve_case
      integer       :: ia, lmt1,lmt2,lmtt1,il1,im1,il2,im2,i,iadd
      real(kind=DP) :: ph,fac

      ph = 0.d0
      do ia = 1, natm
         if(ityp(ia) /= it) cycle
         ph = ph + iwei(ia)
      end do
      do lmt1 = 1, ilmt(it)
         lmtt1 = lmtt(lmt1,it); il1 = ltp(lmt1,it); im1 = mtp(lmt1,it)
         do lmt2 = lmt1, ilmt(it)
            il2 = ltp(lmt2,it); im2 = mtp(lmt2,it)
            if(il1 /= il2 .or. im1 /= im2) cycle
            if(mod(il1+il2,2) == 1) cycle
            fac = ph * dion(lmt1,lmt2,it)
            do ib = ib1, ib2
               do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
                  iadd = i-ista_g1k_3D(ik)+1
                  vnldi_l_3D(iadd,ib-ib1+1)  = vnldi_l_3D(iadd,ib-ib1+1)  &
                 &                           + fac * snl_l_3D(iadd,lmtt1,iksnl)**2
               end do
            end do
         end do
      end do
    end subroutine Vnonlocal_D_norm_conserve_case
  end subroutine Vnonlocal_Diagonal_part_3D_F

!===============================================================================
  subroutine modified_steepest_descent_3D_F&
       &(precon,ik,ib1,ib2,ibesize,dtim,vnldi_l_3D,vlhxc0,ekin_l_3D,VlocalW,lsize,p_l_3D)
    integer      , intent(in)                  :: precon,ik,ib1,ib2,ibesize,lsize
    real(kind=DP), intent(in)                  :: dtim
    real(kind=DP), intent(in)                  :: vlhxc0
    real(kind=DP), intent(in), dimension(np_g1k_3D(ik))  :: ekin_l_3D
    real(kind=DP), intent(in), dimension(lsize*kimg,ibesize) :: VlocalW
    real(kind=DP), intent(in), dimension(mp_g1k_3D(ik),ibesize)  :: vnldi_l_3D
!P! real(kind=DP)            , dimension(mp_g1k_3D(ik),ibesize)  :: p_l_3D
    real(kind=DP)            , dimension(mp_g1k_3D(ik),np_e_3D)  :: p_l_3D

    integer       :: i, ib, iadd,j
    real(kind=DP) :: evr,devr,denom, wdi, evi,e1, devi, fdexp

    denom = 1.d0/product(fft_box_size_WF(1:3,1))
!P! call m_ES_decide_precon_factor_3D(precon,ik,ib1,ib2,ibesize,ekin,p_l_3D)  ! -> p(1:iba(ik))
    if(ipri >= 3) then
       write(nfout,'(" ekin : ",5d16.8)') (ekin_l_3D(i),i=1,np_g1k_3D(ik))
       write(nfout,'(" p    : ",5d16.8)') (p_l_3D(i,1),i=1,iba(ik))
    end if

    if(kimg == 1) then
       do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
          iadd = i-ista_g1k_3D(ik)+1
          do ib = ib1, ib2
             evr   = zaj_l_3D(iadd,ib,ik,1)
             e1    = ekin_l_3D(iadd)-eko_l_3D(ib,ik)
             devr  = e1*evr + VlocalW(iadd,ib-ib1+1)*denom + vnlph_l_3D(iadd,ib,1)
             wdi   = ekin_l_3D(iadd) + vlhxc0 + vnldi_l_3D(iadd,ib-ib1+1) - eko_l_3D(ib,ik)
!P!          fdexp = dexp( -p_l_3D(iadd,ib-ib1+1) * wdi * dtim)
             fdexp = dexp( -p_l_3D(iadd,ib) * wdi * dtim)
             zaj_l_3D(iadd,ib,ik,1) = (fdexp - 1)*devr/wdi + evr
          enddo
       end do
    else if(kimg == 2) then
       do i = ista_g1k_3D(ik), iend_g1k_3D(ik)
          iadd = i-ista_g1k_3D(ik)+1
          do ib = ib1, ib2
             evr   = zaj_l_3D(iadd,ib,ik,1)
             evi   = zaj_l_3D(iadd,ib,ik,2)
             e1    = ekin_l_3D(iadd) - eko_l_3D(ib,ik)
             devr  = e1*evr + VlocalW(2*iadd-1,ib-ib1+1)*denom + vnlph_l_3D(iadd,ib,1)
             devi  = e1*evi + VlocalW(2*iadd,  ib-ib1+1)*denom + vnlph_l_3D(iadd,ib,2)
             wdi   = ekin_l_3D(iadd) + vlhxc0 + vnldi_l_3D(iadd,ib-ib1+1) - eko_l_3D(ib,ik)
!P!          fdexp = dexp( -p_l_3D(iadd,ib-ib1+1) * wdi * dtim)
             fdexp = dexp( -p_l_3D(iadd,ib) * wdi * dtim)
             zaj_l_3D(iadd,ib,ik,1) = (fdexp - 1)*devr/wdi + evr
             zaj_l_3D(iadd,ib,ik,2) = (fdexp - 1)*devi/wdi + evi
          end do
       end do
    end if
!!$    call tstatc0_end(id_sname)
  end subroutine modified_steepest_descent_3D_F

!===============================================================================
  subroutine map_fft_to_WF_3D(ik,lsize, ibesize, wk_bfft_l, bfft_l, isrsize, fftsize)
    use m_Parallelization,     only : fft_wf_scnt, fft_wf_rcnt &
   &                                , fft_wf_recv &
   &                                , fft_wf_index, fft_wf_dist &
   &                                , fft_wf_maxrecv, fft_wf_maxsend

    integer, intent(in)  :: ik, lsize, ibesize, isrsize, fftsize
    real(kind=DP), dimension(lsize*kimg,ibesize), intent(in)  :: wk_bfft_l
    real(kind=DP), dimension(lsize*kimg,ibesize), intent(out) :: bfft_l
    integer, dimension(0:nrank_g_3D-1)                       ::req_r,req_s
    integer, dimension(MPI_STATUS_SIZE,0:nrank_g_3D-1)       ::sta_r, sta_s
    integer, parameter :: itag = 11

    real(kind=DP), allocatable, dimension(:,:) :: sendbuf, recvbuf
    integer :: icnt_send, icnt_recv, ierr, lrank, i, j, k, iadd

    if (fft_wf_maxsend(ik) /= 0) then
       allocate(sendbuf(fft_wf_maxsend(ik)*kimg*ibesize,0:nrank_g_3D-1), stat=ierr)
       sendbuf = 0.0d0
    endif
    if (fft_wf_maxrecv(ik) /= 0) then
       allocate(recvbuf(fft_wf_maxrecv(ik)*kimg*ibesize,0:nrank_g_3D-1), stat=ierr)
       recvbuf = 0.0d0
    endif
     if (ierr /= 0) then
        write(nfout,*)' map_info_fft_to_WF_3D :  Not allocate '
        call flush(nfout)
        call mpi_abort(mpi_comm_world, 211, ierr)
     endif

    if (fft_wf_maxrecv(ik) /= 0) then
       icnt_recv = 0
       lrank = mod(myrank_g_3D,nrank_g_3D)
       do i = 0, nrank_g_3D - 1
          lrank = lrank + 1
          if (lrank > nrank_g_3D -1) lrank = 0
          if (fft_wf_rcnt(lrank,ik) /= 0) then
             call mpi_irecv(recvbuf(1,lrank), fft_wf_rcnt(lrank,ik)*kimg*ibesize, &
            &               mpi_double_precision, lrank, itag, mpi_ke_world, req_r(icnt_recv), ierr)
              if (ierr /= 0) then
                 write(nfout,*)' map_info_fft_to_WF_3D :  mpi_irecv error'
                 call flush(nfout)
                 call mpi_abort(mpi_comm_world, 212, ierr)
              endif
             icnt_recv = icnt_recv + 1
          endif
       enddo
    endif

    if (fft_wf_maxsend(ik) /= 0) then
       if (kimg == 1) then
          do k = 1, nel_fft_x(myrank_g_3D)
             if(fft_wf_index(k,ik) == 0) cycle
             do i = 1, ibesize
                sendbuf(ibesize*(fft_wf_index(k,ik)-1)+i,fft_wf_dist(k,ik)) = wk_bfft_l(k,i)
             enddo
          end do
       else
          do k = 1, nel_fft_x(myrank_g_3D)
             if(fft_wf_index(k,ik) == 0) cycle
             do i = 1, ibesize
                iadd = ibesize*2*(fft_wf_index(k,ik)-1)+i*2
                sendbuf(iadd-1,fft_wf_dist(k,ik)) = wk_bfft_l(k*2-1,i)
                sendbuf(iadd,  fft_wf_dist(k,ik)) = wk_bfft_l(k*2  ,i)
             enddo
          end do
       end if

       icnt_send = 0
       lrank = mod((myrank_g_3D+1),nrank_g_3D)
       do i = 0, nrank_g_3D - 1
          lrank = lrank + 1
          if (lrank > (nrank_g_3D - 1)) lrank = 0
          if (fft_wf_scnt(lrank,ik) /= 0) then
             call mpi_isend(sendbuf(1,lrank), fft_wf_scnt(lrank,ik)*kimg*ibesize, &
            &               mpi_double_precision, lrank, itag, mpi_ke_world, req_s(icnt_send), ierr)
              if (ierr /= 0) then
                 write(nfout,*)' map_info_fft_to_WF_3D :  mpi_isend error'
                 call flush(nfout)
                 call mpi_abort(mpi_comm_world, 213, ierr)
              endif
             icnt_send = icnt_send + 1
          endif
       enddo
    endif

    if (fft_wf_maxrecv(ik) /= 0) then
       call mpi_waitall(icnt_recv, req_r, sta_r, ierr)
        if (ierr /= 0) then
           write(nfout,*)' map_info_fft_to_WF_3D :  mpi_waitall error'
           call flush(nfout)
           call mpi_abort(mpi_comm_world, 214, ierr)
        endif
    endif

    if (fft_wf_maxsend(ik) /= 0) then
       call mpi_waitall(icnt_send, req_s, sta_s, ierr)
        if (ierr /= 0) then
           write(nfout,*)' map_info_fft_to_WF_3D :  mpi_waitall error'
           call flush(nfout)
           call mpi_abort(mpi_comm_world, 215, ierr)
        endif
    endif

    bfft_l = 0.0d0
    if (kimg == 1) then
       do i = 0, nrank_g_3D - 1
          if (fft_wf_rcnt(i,ik) /= 0) then
             do k = 1, fft_wf_rcnt(i,ik)
                do j = 1, ibesize
                   bfft_l(fft_wf_recv(k,ik,i),j) = recvbuf(ibesize*(k-1)+j,i)
                enddo
             end do
          end if
       end do
    else
       do i = 0, nrank_g_3D - 1
          if (fft_wf_rcnt(i,ik) /= 0) then
             do k = 1, fft_wf_rcnt(i,ik)
                do j = 1, ibesize
                   iadd = ibesize*2*(k-1)+j*2
                   bfft_l(fft_wf_recv(k,ik,i)*2-1,j) = recvbuf(iadd-1,i)
                   bfft_l(fft_wf_recv(k,ik,i)*2  ,j) = recvbuf(iadd,  i)
                enddo
             end do
          end if
       end do
    end if

    if (allocated(sendbuf)) deallocate(sendbuf)
    if (allocated(recvbuf)) deallocate(recvbuf)

  end subroutine map_fft_to_WF_3D

  subroutine m_ESsd_sort_zaj_old_3D()
    real(kind=DP), allocatable, dimension(:,:,:)   :: wk_zaj,wk_ball0,wk_ball1
    real(kind=DP), allocatable, dimension(:,:,:,:) :: wk_mpi
    real(kind=DP), allocatable, dimension(:,:,:)     :: wk_ball00,wk_ball01
    integer,                    dimension(neg)     :: t_ordr, k_ordr, tr_neg
!!  integer(kind=4),            dimension(0:nrank_g-1) :: recvcnt, recvdsp
    integer               :: max_g1k, ib, jb, kb, ik, nb, i

    max_g1k = maxval(np_g1k_3D(:))

    do ib = 1, neg
       tr_neg(neg_g_all(ib)) = ib
    end do

!!  do i = 0, nrank_g - 1
!!     recvcnt(i) = nel_e_3D(i) * max_g1k * kimg
!!  end do
!!  recvdsp(0) = 0
!!  do i = 1, nrank_g - 1
!!     recvdsp(i) = recvdsp(i-1) + recvcnt(i-1)
!!  end do

    do ik = 1, kv3, af+1
       if(map_k_3D(ik) /= myrank_k_3D) cycle    ! MPI

       allocate(wk_zaj(max_g1k,mp_e_3D,kimg), stat=ierr)
       wk_zaj = 0.0d0
       allocate(wk_mpi(max_g1k,mp_e_3D,kimg,0:nrank_e_3D-1), stat=ierr)

       do kb = 1, kimg
          do jb = 1, np_e_3D
             do ib = 1, np_g1k_3D(ik)
                wk_zaj(ib,jb,kb) = zaj_old_3D(ib,jb,ik,kb)
             end do
          end do
       end do

       call mpi_allgather(wk_zaj, max_g1k*mp_e_3D*kimg, MPI_DOUBLE_PRECISION, &
      &                   wk_mpi, max_g1k*mp_e_3D*kimg, MPI_DOUBLE_PRECISION, mpi_kg_world, ierr )
!!     call mpi_allgatherv(wk_zaj, max_g1k*np_e_3D*kimg, MPI_DOUBLE_PRECISION, &
!!    &                    wk_mpi, recvcnt, recvdsp, MPI_DOUBLE_PRECISION, mpi_kg_world, ierr )

       deallocate(wk_zaj)
       allocate(wk_ball0(max_g1k,neg,kimg), stat=ierr)

       do nb = 0, nrank_e_3D-1
          do kb = 1, kimg
             do jb = nis_e_3D(nb), nie_e_3D(nb)
                do ib = 1, np_g1k_3D(ik)
                   wk_ball0(ib,neg_g_all(jb),kb) = wk_mpi(ib,jb-nis_e_3D(nb)+1,kb,nb)
                end do
             end do
          end do
       end do

       deallocate(wk_mpi)
       allocate(wk_ball1(max_g1k,neg,kimg), stat=ierr)

       do kb = 1, kimg
          do jb = 1, neg
             do ib = 1, np_g1k_3D(ik)
                wk_ball1(ib,tr_neg(jb),kb) = wk_ball0(ib,neordr_old(jb,ik),kb)
             end do
          end do
       end do

       do kb = 1, kimg
          do jb = ista_e_3D, iend_e_3D
             do ib = 1, np_g1k_3D(ik)
                zaj_old_3D(ib,jb-ista_e_3D+1,ik,kb) = wk_ball1(ib,jb,kb)
             end do
          end do
       end do

       deallocate(wk_ball0)
       deallocate(wk_ball1)
    end do

  end subroutine m_ESsd_sort_zaj_old_3D

!===============================================================================
  subroutine decide_CG_direction_core_3D(precon,ik,ekin_l,afft_l,lsize,sumdz2)
    integer, intent(in)        :: precon, ik, lsize
    real(kind=DP), intent(in)  :: ekin_l(np_g1k_3D(ik))
    real(kind=DP), intent(in)  :: afft_l(lsize*kimg)
    real(kind=DP), intent(out) :: sumdz2

    real(kind=DP), allocatable, dimension(:,:) :: wk_bfft_l
    real(kind=DP), allocatable,dimension(:,:) :: VlocalW
    real(kind=DP), allocatable,dimension(:,:) :: p_l

    integer :: lsize, ibsize, flag, iesize
    integer :: ib1, ib2, ibesize
    integer :: isrsize, fft_l_size

    integer :: ib
    integer :: id_sname = -1
    call tstatc0_begin('decide_CG_direction_core ', id_sname,1)

    ibsize = 1
    if (nblocksize_fftw_is_given) then
       ibsize = nblocksize_fftw
       if (ibsize < 1) ibsize = 1
    endif
    isrsize = min(lsize,mp_g1k_3D(ik))
    fft_l_size  = nel_fft_x(myrank_g_3D)

    allocate(wk_bfft_l(lsize*kimg,ibsize) ,stat=ierr)
    allocate(VlocalW(lsize*kimg,ibsize) ,stat=ierr)
!P! allocate(p_l(mp_g1k_3D(ik),ibsize) ,stat=ierr)
    allocate(p_l(mp_g1k_3D(ik),np_e_3D) ,stat=ierr)
     if (ierr /= 0) then
        write(nfout,*)' m_ES_WF_in_Rspace_3D :  Not allocate '
        call flush(nfout)
        call mpi_abort(mpi_comm_world, 203, ierr)
     endif
!P!
    call m_ES_decide_precon_factor_3D_F(precon,ik,1,np_e_3D,np_e_3D,ekin_l,p_l)! -> p(1:iba(ik))
!P!

    do ib = 1, np_e_3D, ibsize           ! MPI
       ib2 = min(ib1+ibsize-1,np_e_3D)
       ibesize = ib2 - ib1 + 1

       call m_ES_WF_in_Rspace_3D(ik,ib,ib,ibsize,lsize,wk_bfft_l)
       call m_FFT_Vlocal_W_3D(afft_l,wk_bfft_l,lsize,ibsize,nel_fft_y(myrank_g_3D))
       call m_FFT_Direct_3D (VlocalW, nfout, wk_bfft_l, lsize, ibesize, OFF, OFF)

       call map_fft_to_WF_3D(ik, lsize, ibesize, wk_bfft_l, VlocalW, isrsize, fft_l_size)

       call SD_direction_3D(precon,ik,ib1,ib2,ibesize,ekin_l,VlocalW,lsize,p_l)
    end do

!$    call orthogonalize_SD_drctns(ik,to=OTHER_BANDS)  ! -(m_ES_WF_by_SDorCG) ->(wfsd_l, bsd(ri)_l)
    call orthogonalize_SD_drctns_3D(ik,to=OTHER_BANDS)  ! -(m_ES_WF_by_SDorCG) ->(wfsd_l, bsd(ri)_l)

    call WFSD_dot_WFSD                   ! -(contained here)
    !    ~~~~~~~~~~~~~

    deallocate(wk_bfft_l)
    deallocate(VlocalW)
    deallocate(p_l)

    call tstatc0_end(id_sname)
  contains
    subroutine WFSD_dot_WFSD
      real(kind=DP) :: sum_mpi   ! MPI
      real(kind=DP) :: dz
      integer :: ib

      sumdz2 = 0.d0
      do ib = 1, np_e_3D                   ! MPI
         call square_of_SD_direction_3D(ik,ib,dz)
!!$         write(nfout,'(" dz = ",d20.8)') dz
         sumdz2 = sumdz2 + dz
      end do
!!$      write(nfout,'(" sumdz2 = ",d20.8)') sumdz2
      if(npes > 1) then
         call mpi_allreduce(sumdz2,sum_mpi,1,mpi_double_precision &
              & ,mpi_sum,mpi_k_world(myrank_k),ierr)    ! MPI
         sumdz2 = sum_mpi                               ! MPI
      end if
    end subroutine WFSD_dot_WFSD
  end subroutine decide_CG_direction_core_3D

!===============================================================================

!$$#endif

end module m_ES_WF_by_SDorCG
