!=======================================================================
!
!  PROGRAM  PHASE/0 2018.01 ($Rev: 577 $)
!
!  MODULE: m_ES_dos
!
!  AUTHOR(S): T. Yamasaki   August/20/2003
!      Further modification by T. Yamasaki   May/09/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_dos
!     (m_ESdos)
! $Id: m_ES_dos.F90 577 2017-12-15 05:26:08Z jkoga $
!
! This module was originally coded by T. Yamasaki (FUJITSU Laboratories) in 2001.
! And this is transferred as match to PHASE by T. Yamasaki, 18th May. 2003.
!
  use m_Kpoints, only :              kv3, kv3_ek, qwgt,vkxyz_ek &
       &                           , np0,np2,ip20,iwt,ip2cub,nxyz_tetra,trmat &
       &                           , m_Kp_sample_mesh, qwgt_ek
  use m_Files, only :                nfout
!!$  use m_Files, only :                nfdos, nfout
  use m_Timing, only :               tstatc0_begin, tstatc0_end
  use m_Control_Parameters, only   : ekmode, ipridos, nspin, neg, af &
       &                            ,nwd_dos_window_width &
       &                            ,deltaE_dos,  variance_dos_GaussD &
       &                            ,sw_pdos, pdos_method, norbital &
       &                            ,maxorb, l_orb, t_orb, rc_orb, k_orb &
       &                            ,sw_orb_popu,dos_subroutine &
       &                            ,ipriinputfile, printable, sw_dos
  use m_Const_Parameters, only :     DP,Hartree,BUCS,EK,SCF, ALDOS, LAYERDOS, ON, OFF, TOTAL, PAI2
  use m_Parallelization, only :      mpi_comm_group,map_ek,mype,map_e,map_k,myrank_e,myrank_k &
       &                            ,ierr,np_e,map_z,ista_e,npes, nrank_e
  use m_PseudoPotential, only :      nlmta_phi,nlmtt_phi &
       &                            ,m_PP_tell_iorb_ia_l_m_tau, qorb &
       &                            ,m_PP_tell_iorb_lmtt, ltp_phi, mtp_phi, taup_phi &
       &                            ,lmta_phi, nlmt_phi, ilmt_phi
  use m_Nonlocal_Potential,  only : norm_phig
  use m_Crystal_Structure, only   : nopr, il, univol, altv
  use m_Electronic_Structure, only : occup_l, eko_l,eko_ek,totch, neordr &
       &                           , vbm, check_if_metalic_flag, metalic_system &
       &                           , compr_l, compi_l
  
!!$ASASASASAS
  use m_Kpoints,            only : k_symmetry
  use m_Const_Parameters,   only : GAMMA
  use m_Ionic_System,       only : iproj_group, natm, ityp, cps
!!$ASASASASAS

! =================================== added by K. Tagami ============ 11.0
  use m_Const_Parameters,   only : CMPLDP
  use m_Control_Parameters,   only : ndim_spinor, ndim_magmom, ndim_chgpot, noncol
  use m_ES_NonCollinear,    only : m_ES_DensMat_To_MagMom_porb
! =================================================================== 11.0

! =================================== added by K. Tagami ============ 11.0
  use m_PseudoPotential, only :    modnrm
  use m_Parallelization, only :    ista_e,iend_e,istep_e, np_e
  use m_Control_Parameters,   only : kimg, hardpart_subroutine, &
       &                             calc_dos_magmom_contrib, sw_rspace_ldos
  use m_Const_Parameters,   only : EXECUT, ELECTRON, DIRECT, YES, NO
  use m_PlaneWaveBasisSet, only :  kgp
  use m_FFT, only :                nfft, nfftp, nfftp_nonpara, fft_box_size_WF, &
       &                           fft_box_size_CD, &
       &                           m_FFT_alloc_WF_work, m_FFT_dealloc_WF_work, &
       &                           m_FFT_CD_inverse0,   m_FFT_WF, &
       &                           m_FFT_alloc_CD_box, m_FFT_dealloc_CD_box
  use m_Charge_Density, only :     chgq_l, chgq_enl, &
       &                           m_CD_hardpart_sub_noncl, &
       &                           m_CD_hardpart_sub2_noncl, &
       &                           m_CD_map_chgq_to_fft_box, &
       &                           m_CD_set_ylm_enl_etc, &
       &                           m_CD_dealloc_ylm_enl_etc, &
       &                           m_CD_map_chgqenl_to_fft_box_kt, &
       &                           m_CD_map_valence_charge_to_fft_box, &
       &                           m_CD_restore_chgq, m_CD_keep_retrieve_hsr
  use m_Electronic_Structure,only :m_ES_WF_in_Rspace
! =================================================================== 11.0


! =============== KT_add =============== 13.0E
  use m_Control_Parameters,  only : smearing_width_fdirac => width, width_tetra, &
       &                            orb_popu_method, sw_diagonalize_population
  use m_Electronic_Structure, only : efermi
! ====================================== 13.0E

  implicit none

  real(kind=DP),private ::                            Eminimum, Emaximum
  integer,private ::                                  nEwindows, nETailWindows
  integer,private,parameter ::                        nETailMax = 1000
  real(kind=DP),private ::                            ValenceBandMaximum
  real(kind=DP),private,parameter ::                  DeltaD = 1.d-18
  real(kind=DP),private,parameter ::                  DeltaDVBM = 1.d-4
  real(kind=DP),private ::                            sqrtDVI

!!$  real(kind=DP),public ::  deltaE_dos_GaussD = 1.d-4
!!$  real(kind=DP),public ::  variance_dos_GaussD = 1.d-6
!!$  integer,public ::        nwd_dos_window_width = 10

  real(kind=DP),private,allocatable,dimension(:,:) :: eko
  real(kind=DP),private,allocatable,dimension(:,:) :: dos
  real(kind=DP),private,allocatable,dimension(:,:) :: sumdos
  real(kind=DP),private,allocatable,dimension(:,:) :: dos_weight

! ===================== added by K. Tagami =============================== 11.0
  real(kind=DP),private,allocatable,dimension(:,:,:) :: dos_weight_noncl
! ======================================================================== 11.0

  integer, private ::                                 ndim_dos_weight1, ndim_dos_weight2

  !-- PDOS --
  real(kind=DP),private,allocatable,dimension(:,:,:,:) :: compr
  real(kind=DP),private,allocatable,dimension(:,:,:,:) :: compi
  real(kind=DP),private,allocatable,dimension(:,:) :: norm_phig_mpi
  real(kind=DP),private,allocatable,dimension(:,:,:) :: pdos
  real(kind=DP),private,allocatable,dimension(:,:,:) :: sumpdos

  character(len("pdos")),private,parameter :: tag_pdos       = "pdos"
  character(len("sw_pdos")),private,parameter :: tag_sw_pdos = "sw_pdos"
  character(len("sw_orb_popu")),private,parameter :: tag_sw_orb_popu = "sw_orb_popu"
  character(len("method")),private,parameter :: tag_method   = "method"
  character(len("element")),private,parameter :: tag_element = "element"
  character(len("orbitals")),private,parameter :: tag_orbitals = "orbitals"
  character(len("l")),private,parameter ::        tag_l    = "l"
  character(len("t")),private,parameter ::        tag_t    = "t"
  character(len("k")),private,parameter ::        tag_k    = "k"
  character(len("rc")),private,parameter ::       tag_rc   = "rc"
  character(len("projector")),private,parameter :: tag_projector = "projector"
  character(len("wavefunction")),private,parameter :: tag_wavefunction = "wavefunction"
  character(len("mulliken")),private,parameter :: tag_mulliken = "mulliken"

! -- pCOHP --
  character(len("pcohp")),private,parameter :: &
       &         tag_pcohp = "pcohp"
  character(len("sw_calc_pcohp")),private,parameter :: &
       &         tag_sw_calc_pcohp = "sw_calc_pcohp"
  character(len("atom1")),private,parameter :: &
       &         tag_atom1 = "atom1"
  character(len("max_distance_from_atom1")),private,parameter :: &
       &         tag_max_distance_from_atom1 = "max_distance_from_atom1"
!
  integer :: sw_calc_pcohp = off
  integer :: atom1_pcohp = 0
  real(kind=DP) :: max_distance_from_atom1_pcohp = 8.0d0  ! bohr

  real(kind=DP), private, allocatable :: pcohp(:,:,:,:)
  real(kind=DP), private, allocatable :: sum_pcohp(:,:,:,:)

  ! --- POSTPROCESSING ---
  character(len("Postprocessing")),private,parameter :: tag_postprocessing    = "postprocessing"

  include 'mpif.h'
contains
  subroutine m_ESdos_alloc_dos_weight()
    if(.not.allocated(dos_weight)) then
       if(ekmode == ON) then
          allocate(dos_weight(neg,kv3_ek))
       else if(ekmode == OFF) then
          allocate(dos_weight(neg,kv3))
       end if
    end if
  end subroutine m_ESdos_alloc_dos_weight

  subroutine m_ESdos_dealloc_dos_weight()
    if(allocated(dos_weight)) deallocate(dos_weight)
  end subroutine m_ESdos_dealloc_dos_weight

! ========================= added by K. Tagami =============== 11.0
  subroutine m_ESdos_alloc_dos_wght_noncl()
    if (.not.allocated(dos_weight_noncl)) then
       if (ekmode == ON) then
          allocate( dos_weight_noncl(neg,kv3_ek,ndim_magmom) )
       else if (ekmode == OFF) then
          allocate( dos_weight_noncl(neg,kv3,ndim_magmom) )
       end if
       dos_weight_noncl = 0.0d0
    end if
  end subroutine m_ESdos_alloc_dos_wght_noncl

  subroutine m_ESdos_dealloc_dos_wght_noncl()
    if (allocated(dos_weight_noncl)) deallocate(dos_weight_noncl)
  end subroutine m_ESdos_dealloc_dos_wght_noncl
! ================================================================ 11.0

  subroutine m_ESdos_put_dos_weight(ne,nk,dos_weight_from)
    integer, intent(in) :: ne, nk
    real(kind=DP), intent(in), dimension(ne,nk) :: dos_weight_from
    if(.not.allocated(dos_weight)) &
         & stop ' dos_weight is not allocated <<m_ESdos_put_dos_weight>>'

    if(ekmode == ON) then
       if( ne /= neg .or. nk /= kv3_ek) then
          write(nfout,'(" !ldos ne /= neg or nk /= kv3_ek ",&
               & ": ne, neg, nk, kv3_ek = ",4i6," <<m_ESdos_put_dos_weight>>")') ne,neg,nk,kv3_ek
          stop ' ne /= neg or nk /= kv3_ek <<m_ESdos_put_dos_weight>>'
       end if
    else if(ekmode == OFF) then
       if( ne /= neg .or. nk /= kv3) then
          write(nfout,'(" !ldos ne /= neg or nk /= kv3 ",&
               & ": ne, neg, nk, kv3 = ",4i6," <<m_ESdos_put_dos_weight>>")') ne,neg,nk,kv3
          stop ' ne /= neg or nk /= kv3 <<m_ESdos_put_dos_weight>>'
       end if
    end if
    dos_weight(:,:) = dos_weight_from(:,:)
  end subroutine m_ESdos_put_dos_weight
    
! ============================== added by K. Tagami =============== 11.0
  subroutine m_ESdos_put_dos_weight_noncl(ne,nk,dos_weight_from)
    integer, intent(in) :: ne, nk
    real(kind=DP), intent(in), dimension(ne,nk,ndim_magmom) :: dos_weight_from

    if (.not.allocated(dos_weight_noncl)) &
         & stop ' dos_weight_noncl is not allocated <<m_ESdos_put_dos_weight_noncl>>'

    if (ekmode == ON) then
       if ( ne /= neg .or. nk /= kv3_ek) then
          write(nfout,'(" !ldos ne /= neg or nk /= kv3_ek ",&
               & ": ne, neg, nk, kv3_ek = ",4i6," <<m_ESdos_put_dos_weight_nocl>>")') &
               &  ne,neg,nk,kv3_ek
          stop ' ne /= neg or nk /= kv3_ek <<m_ESdos_put_dos_weight_noncl>>'
       end if

    else if(ekmode == OFF) then
       if ( ne /= neg .or. nk /= kv3) then
          write(nfout,'(" !ldos ne /= neg or nk /= kv3 ",&
               & ": ne, neg, nk, kv3 = ",4i6," <<m_ESdos_put_dos_weight_noncl>>")') &
               &    ne,neg,nk,kv3
          stop ' ne /= neg or nk /= kv3 <<m_ESdos_put_dos_weight_noncl>>'
       end if
    end if
    dos_weight_noncl(:,:,:) = dos_weight_from(:,:,:)

  end subroutine m_ESdos_put_dos_weight_noncl
! ============================================================== 11.0

  subroutine find_Erange(ek,neg,kv)
    integer, intent(in) :: neg,kv
    real(kind=DP), intent(in) :: ek(neg,kv)
    integer :: i, is
    logical :: found
    real(kind=DP) :: DeltaE, t
    real(kind=DP) :: derfc

    DeltaE = DeltaE_dos

    Eminimum = 9999.99d0;
    Emaximum  = -9999.99d0;

    sqrtdVI = 1.d0/dsqrt(2*Variance_dos_GaussD)
    t = DeltaE * sqrtdVI  ! t = DeltaE/dsqrt(2*Variance_dos_GaussD)

    if(ipridos >= 2) then
       write(nfout,'(" Attenuation check of a Gassuian function (find_Erange)")')
       write(nfout,'(" sqrtdVI = ",f10.5," DeltaE = ",f10.5, " t = ",f10.5 )')&
         & sqrtdVI, DeltaE, t
    end if

    i = 0; found = .false.
    do while(.not.found.and.i<=nETailMax)
       i = i + 1
       found = derfc(t*i) < DeltaD
    end do
    nETailWindows = i

    if(ipridos >= 2) write(nfout,'(" nETailWindows = ",i5)') nETailWindows

    Eminimum = minval(ek)
    Emaximum = maxval(ek)
!!$    write(nfout,'(" !! minval(ek), maxval(ek) = ",2f10.6)') Eminimum, Emaximum

    i = abs(Eminimum/DeltaE) + 1
    is = sign(1.d0,Eminimum)
    Eminimum = i*DeltaE*is - nETailWindows*DeltaE

    i = abs(Emaximum/DeltaE) + 1
    is = sign(1.d0,Emaximum)
    Emaximum = i*DeltaE*is + nETailWindows*DeltaE
    nEwindows = (Emaximum - Eminimum)/DeltaE + 1

    if(ipridos >= 2) then
       write(nfout,'(" Emaximum = ",f8.4, " Eminimum = ",f8.4 &
            & , " nEwindows = ",i8)') Emaximum, Eminimum, nEwindows+2*nETailWindows
    end if

  end subroutine find_Erange

! ================================= KT_add ======================== 13.0E
  subroutine find_Erange_fermidirac(ek,neg,kv)
    integer, intent(in) :: neg,kv
    real(kind=DP), intent(in) :: ek(neg,kv)
    integer :: i, is
    logical :: found
    real(kind=DP) :: DeltaE, t
    real(kind=DP) :: xx, yy
!
    real(kind=DP) :: threshold = 1.0E-4
!
    DeltaE = DeltaE_dos

    Eminimum = 9999.99d0;    Emaximum  = -9999.99d0;
    Eminimum = minval(ek);  Emaximum = maxval(ek)

    xx = 2.0D0 *log( 2.0D0 *sqrt(1.0D0 /threshold ) )  ! width of extent of df/dx
                                                       ! f: Fermi-Dirac fn
    xx = xx *smearing_width_fdirac

    nETailWindows = xx / DeltaE +1

    i = abs(Eminimum/DeltaE) +1;  is = sign(1.d0,Eminimum)
    Eminimum = i*DeltaE*is -nETailWindows*DeltaE

    i = abs(Emaximum/DeltaE) +1;  is = sign(1.d0,Emaximum)
    Emaximum = i*DeltaE*is + nETailWindows*DeltaE

    nEwindows = (Emaximum -Eminimum)/DeltaE +1
    if(ipridos >= 2) write(nfout,'(" nETailWindows = ",i5)') nETailWindows


  end subroutine find_Erange_fermidirac
! =========================================================== 13.0E

  subroutine alloc_eko_and_substitution(kv)
    integer, intent(in) :: kv
    integer ::             ik,ie,ip,iksnl
    integer :: iorb,iopr
    real(kind=DP),allocatable, dimension(:,:) :: eko_mpi
    real(kind=DP),allocatable, dimension(:,:,:,:) :: compr_mpi
    real(kind=DP),allocatable, dimension(:,:,:,:) :: compi_mpi
    real(kind=DP),allocatable, dimension(:,:) :: norm_phig_mpi2

! ==================== added by K. Tagami ================== 11.0
#ifdef forsafe
    integer :: ksym_ik
#endif
! ========================================================== 11.0

    if(npes>=2) allocate(eko_mpi(neg,kv))
    if(npes>=2 .and. sw_pdos == ON) then
       allocate(compr_mpi(neg,nlmta_phi,nopr,kv)); compr_mpi=0.d0
       allocate(compi_mpi(neg,nlmta_phi,nopr,kv)); compi_mpi=0.d0
       allocate(norm_phig_mpi2(nlmtt_phi,kv/nspin)); norm_phig_mpi2=0.d0
    end if

    allocate(eko(neg,kv));  eko = 0.d0
    if(sw_pdos == ON) then
       allocate(compr(neg,nlmta_phi,nopr,kv));  compr = 0.d0
       allocate(compi(neg,nlmta_phi,nopr,kv));  compi = 0.d0
       if(.not.allocated(norm_phig_mpi)) allocate(norm_phig_mpi(nlmtt_phi,kv/nspin))
       norm_phig_mpi=0.d0
    end if

! Substitution eko_l for eko in the order of thier values
    do ik = 1, kv
       if(map_k(ik) /= myrank_k) cycle
! ============================= added by K. Tagami ============== 11.0
#ifdef forsafe
       ksym_ik = k_symmetry(ik)
#endif
! =============================================================== 11.0
       iksnl = (ik-1)/nspin + 1
       do ie = 1, neg
          ip = neordr(ie,ik)
          if(map_e(ip) == myrank_e) then
             eko(ie,ik) = eko_l(map_z(ip),ik)
             if(sw_pdos == ON) then
                compr(ie,1:nlmta_phi,1:nopr,ik) = compr_l(map_z(ip),1:nlmta_phi,1:nopr,ik)
!!$ASASASASAS
!!$                compi(ie,1:nlmta_phi,1:nopr,ik) = compi_l(map_z(ip),1:nlmta_phi,1:nopr,ik)

! ========================== modified by K. Tagami =========== 11.0
!                if ( k_symmetry(ik) /= GAMMA ) then
#ifdef forsafe
                if ( ksym_ik  /= GAMMA ) then
#else
                if ( k_symmetry(ik) /= GAMMA ) then
#endif                   
! ============================================================= 11.0
                   compi(ie,1:nlmta_phi,1:nopr,ik) = compi_l(map_z(ip),1:nlmta_phi,1:nopr,ik)
                else
!                   compi = 0.0d0   
                   compi(ie,1:nlmta_phi,1:nopr,ik) = 0.0d0
                endif
!!$ASASASASAS
                norm_phig_mpi(1:nlmtt_phi,iksnl)  = norm_phig(1:nlmtt_phi,iksnl)
             end if
          end if
       end do
    end do
    if(npes >=2 ) then
       call mpi_allreduce(eko,eko_mpi,neg*kv,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
       if(sw_pdos == ON) then
          call mpi_allreduce(compr,compr_mpi,neg*nlmta_phi*nopr*kv,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
          call mpi_allreduce(compi,compi_mpi,neg*nlmta_phi*nopr*kv,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
          call mpi_allreduce(norm_phig_mpi,norm_phig_mpi2,nlmtt_phi*kv/nspin,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
          norm_phig_mpi2 = norm_phig_mpi2 / dble(nrank_e)
       end if

       eko = eko_mpi
       if(sw_pdos == ON) then
          compr = compr_mpi
          compi = compi_mpi
          norm_phig_mpi = norm_phig_mpi2
       end if
    end if
    if(ipridos >= 2) then
       ! -- writing --
       write(nfout,'(" !dos: eko <<alloc_eko_and_substitution>>")')
       do ik = 1, kv
          write(nfout,'(" !dos: ik = ",i5)') ik
          write(nfout,'(" !dos: ",10f8.4)') (eko(ie,ik),ie=1,neg)
       end do
       if(sw_pdos == ON) then
          do ik = 1, kv
             iksnl = (ik-1)/nspin + 1
             do iopr=1,nopr
                do iorb=1,nlmta_phi
                   write(nfout,'(" !dos: ik=",i5," iopr=",i5," iorb=",i5)')&
                        &  ik,iopr,iorb
                   write(nfout,'(" !dos compr: ",10f8.4)') &
                        & compr(1:neg,iorb,iopr,ik)
!!$ASASASASAS
!!$                write(nfout,'(" !dos compi: ",10f8.4)') &
!!$                              & compi(1:neg,iorb,iopr,ik)
! =========================== modified by K. Tagami ========= 11.0
!                if ( k_symmetry(ik) /= GAMMA ) then
#ifdef forsafe
                   if ( ksym_ik /= GAMMA ) then
#else
                      if ( k_symmetry(ik) /= GAMMA ) then
#endif
! =========================================================== 11.0

                         write(nfout,'(" !dos compi: ",10f8.4)') &
                              & compi(1:neg,iorb,iopr,ik)
                      endif
!!$ASASASASAS
                   end do
                end do
             write(nfout,'(" !dos norm_phig: ",10f8.4)') &
                          & norm_phig_mpi(1:nlmtt_phi,iksnl)
          end do
       end if
    end if
    if(npes>=2) then
       if(allocated(eko_mpi)) deallocate(eko_mpi)
       if(sw_pdos == ON) then
          if(allocated(compr_mpi)) deallocate(compr_mpi)
          if(allocated(compi_mpi)) deallocate(compi_mpi)
          if(allocated(norm_phig_mpi2)) deallocate(norm_phig_mpi2)
       end if
    end if
  end subroutine alloc_eko_and_substitution

! ========================= added by K. Tagami =================== 11.0
  subroutine alloc_eko_and_substit_noncl(kv)
    integer, intent(in) :: kv
    integer ::             ik,ie,ip,iksnl
    integer :: iorb,iopr
    integer :: is

#ifdef forsafe
    integer :: ksym_ik
#endif

    real(kind=DP),allocatable, dimension(:,:) :: eko_mpi
    real(kind=DP),allocatable, dimension(:,:,:,:) :: compr_mpi
    real(kind=DP),allocatable, dimension(:,:,:,:) :: compi_mpi
    real(kind=DP),allocatable, dimension(:,:) :: norm_phig_mpi2

    if(npes>=2) allocate(eko_mpi(neg,kv/ndim_spinor))

    if(npes>=2 .and. sw_pdos == ON) then
       allocate(compr_mpi(neg,nlmta_phi,nopr,kv)); compr_mpi=0.d0
       allocate(compi_mpi(neg,nlmta_phi,nopr,kv)); compi_mpi=0.d0

       allocate(norm_phig_mpi2(nlmtt_phi,kv/ndim_spinor));
       norm_phig_mpi2 = 0.d0
    end if

    allocate(eko(neg,kv/ndim_spinor));  eko = 0.d0

    if(sw_pdos == ON) then
       allocate(compr(neg,nlmta_phi,nopr,kv));  compr = 0.d0
       allocate(compi(neg,nlmta_phi,nopr,kv));  compi = 0.d0

       allocate(norm_phig_mpi(nlmtt_phi,kv/ndim_spinor));
       norm_phig_mpi=0.d0
    end if

! Substitution eko_l for eko in the order of thier values
    do ik = 1, kv, ndim_spinor

! ============================= added by K. Tagami ============== 11.0
#ifdef forsafe
       ksym_ik = k_symmetry(ik)
#endif
! =============================================================== 11.0

       if(map_k(ik) /= myrank_k) cycle
       iksnl = (ik-1)/ndim_spinor + 1

       do ie = 1, neg
          ip = neordr(ie,ik)

          if (map_e(ip) == myrank_e) then
             eko( ie,iksnl ) = eko_l( map_z(ip),ik )

             if(sw_pdos == ON) then
                Do is=1, ndim_spinor
                   compr(ie,1:nlmta_phi,1:nopr,ik+is-1) &
                        & = compr_l(map_z(ip),1:nlmta_phi,1:nopr,ik+is-1)
! ========================== modified by K. Tagami =========== 11.0
!                   if ( k_symmetry(ik) /= GAMMA ) then
#ifdef forsafe
                   if ( ksym_ik  /= GAMMA ) then
#else
                   if ( k_symmetry(ik) /= GAMMA ) then
#endif
! ============================================================= 11.0
                      compi(ie,1:nlmta_phi,1:nopr,ik+is-1) &
                           & = compi_l(map_z(ip),1:nlmta_phi,1:nopr,ik+is-1)
                   else
!                      compi = 0.0d0  
                      compi(ie,1:nlmta_phi,1:nopr,ik+is-1) = 0.0d0
                   endif
                End do
                norm_phig_mpi(1:nlmtt_phi,iksnl)  = norm_phig(1:nlmtt_phi,iksnl)
             end if

          end if
       end do
    end do
    
    if (npes >=2 ) then
       call mpi_allreduce( eko, eko_mpi, neg*kv/ndim_spinor, mpi_double_precision, &
            &              mpi_sum, mpi_comm_group, ierr )
       if (sw_pdos == ON) then
          call mpi_allreduce( compr, compr_mpi, neg*nlmta_phi*nopr*kv, &
               &              mpi_double_precision, mpi_sum, mpi_comm_group, ierr )
          call mpi_allreduce( compi, compi_mpi, neg*nlmta_phi*nopr*kv, &
               &              mpi_double_precision, mpi_sum, mpi_comm_group, ierr )
          call mpi_allreduce( norm_phig_mpi, norm_phig_mpi2, nlmtt_phi*kv/ndim_spinor, &
               &              mpi_double_precision, mpi_sum, mpi_comm_group, ierr )
          norm_phig_mpi2 = norm_phig_mpi2 / dble(nrank_e)
       end if

       eko = eko_mpi

       if(sw_pdos == ON) then
          compr = compr_mpi;        compi = compi_mpi
          norm_phig_mpi = norm_phig_mpi2
       end if
    end if

    if(ipridos >= 2) then
       ! -- writing --
       write(nfout,'(" !dos: eko <<alloc_eko_and_substi_noncl>>")')

       do ik = 1, kv, ndim_spinor
          iksnl = (ik-1)/ndim_spinor + 1
          write(nfout,'(" !dos: ik = ",i5)') ik
          write(nfout,'(" !dos: ",10f8.4)') (eko(ie,iksnl),ie=1,neg)
       end do

       if(sw_pdos == ON) then
          do ik = 1, kv, ndim_spinor
             iksnl = (ik-1)/ndim_spinor + 1

             do iopr=1,nopr
                do iorb=1,nlmta_phi
                   write(nfout,'(" !dos: ik=",i5," iopr=",i5," iorb=",i5)')&
                        &  ik,iopr,iorb
                   write(nfout,'(" !dos compr: ",10f8.4)') &
                        & compr(1:neg,iorb,iopr,ik)
! =========================== modified by K. Tagami ========= 11.0
!                   if ( k_symmetry(ik) /= GAMMA ) then
#ifdef forsafe
                   if ( ksym_ik /= GAMMA ) then
#else
                   if ( k_symmetry(ik) /= GAMMA ) then
#endif
! =========================================================== 11.0
                      write(nfout,'(" !dos compi: ",10f8.4)') &
                           & compi(1:neg,iorb,iopr,ik)
                   endif
                end do
             end do
             write(nfout,'(" !dos norm_phig: ",10f8.4)') &
                          & norm_phig_mpi(1:nlmtt_phi,iksnl)
          end do
       end if
    end if

    if(npes>=2) then
       if(allocated(eko_mpi)) deallocate(eko_mpi)
       if(sw_pdos == ON) then
          if(allocated(compr_mpi)) deallocate(compr_mpi)
          if(allocated(compi_mpi)) deallocate(compi_mpi)
          if(allocated(norm_phig_mpi2)) deallocate(norm_phig_mpi2)
       end if
    end if

  end subroutine alloc_eko_and_substit_noncl
! =================================================================== 11.0

  subroutine alloc_eko_and_substitution_ek(kv3_ek)
    integer, intent(in) :: kv3_ek 
    integer :: ik,ie,ib,jb,ibo,jbo
    integer,allocatable,dimension(:) :: neordr_ek
    integer,parameter :: delta = 1.d-12

    allocate(eko(neg,kv3_ek))
    allocate(neordr_ek(neg))
    do ik = 1, kv3_ek
       neordr_ek = (/(ib,ib=1,neg)/)
       do ib = 1,neg-1
          do jb = ib+1, neg
             ibo = neordr_ek(ib)
             jbo = neordr_ek(jb)
             if(eko_ek(jbo,ik) < eko_ek(ibo,ik)-delta) then
                neordr_ek(jb) = ibo
                neordr_ek(ib) = jbo
             end if
          end do
       end do
! Substitution eko_ek for eko in the order of thier values
       do ie = 1, neg
          eko(ie,ik) = eko_ek(neordr_ek(ie),ik)
       end do
    end do
!!$    write(nfout,'(" !! eko (alloc_eko_and_substitution_ek)")')
!!$    do ik = 1, kv3_ek
!!$       write(nfout,'(" !! ik = ",i5, "(",3f8.4,")")') ik, (vkxyz_ek(ib,ik,BUCS),ib=1,3)
!!$       write(nfout,'("(eko_ek): ",8f10.6)') (eko_ek(ie,ik),ie=1,neg)
!!$       write(nfout,'("(eko):    ",8f10.6)') (eko(ie,ik),ie=1,neg)
!!$    end do
    deallocate(neordr_ek)
  end subroutine alloc_eko_and_substitution_ek

! ============================== added by K. Tagami ============= 11.0
  subroutine alloc_eko_and_substit_ek_noncl(kv3_ek)
    integer, intent(in) :: kv3_ek 
    integer :: ik,ie,ib,jb,ibo,jbo
    integer :: iksnl

    integer,allocatable,dimension(:) :: neordr_ek
    integer,parameter :: delta = 1.d-12

    allocate(eko(neg,kv3_ek/ndim_spinor))
    allocate(neordr_ek(neg))

    do ik = 1, kv3_ek, ndim_spinor
       iksnl = ( ik -1 ) /ndim_spinor + 1

       neordr_ek = (/(ib,ib=1,neg)/)
       do ib = 1,neg-1
          do jb = ib+1, neg
             ibo = neordr_ek(ib)
             jbo = neordr_ek(jb)
             if(eko_ek(jbo,ik) < eko_ek(ibo,ik)-delta) then
                neordr_ek(jb) = ibo
                neordr_ek(ib) = jbo
             end if
          end do
       end do
! Substitution eko_ek for eko in the order of thier values
       do ie = 1, neg
          eko(ie,iksnl) = eko_ek(neordr_ek(ie),ik)
       end do
    end do

    deallocate(neordr_ek)
  end subroutine alloc_eko_and_substit_ek_noncl
! ===================================================================== 11.0

  subroutine dealloc_eko()
    deallocate(eko)
    if(sw_pdos == ON) then
       deallocate(compr,compi)
    end if
  end subroutine dealloc_eko

  subroutine alloc_dos(i0,icomponent)
    integer,intent(in) :: i0,icomponent

! ============================== modified by K. Tagami ================= 11.0
!    allocate(dos(i0:nEwindows,nspin)); dos = 0.d0
!    allocate(sumdos(i0:nEwindows,nspin)); sumdos = 0.d0
!    if(icomponent == TOTAL .and. sw_pdos == ON) then
!       allocate(pdos(i0:nEwindows,nlmta_phi,nspin)); pdos = 0.d0
!       allocate(sumpdos(i0:nEwindows,nlmta_phi,nspin)); sumpdos = 0.d0
!    end if

    if ( noncol ) then
       allocate(dos(i0:nEwindows,ndim_magmom)); dos = 0.d0
       allocate(sumdos(i0:nEwindows,ndim_magmom)); sumdos = 0.d0
       if(icomponent == TOTAL .and. sw_pdos == ON) then
          allocate(pdos(i0:nEwindows,nlmta_phi,ndim_magmom)); pdos = 0.d0
          allocate(sumpdos(i0:nEwindows,nlmta_phi,ndim_magmom)); sumpdos = 0.d0
       end if
    else
       allocate(dos(i0:nEwindows,nspin)); dos = 0.d0
       allocate(sumdos(i0:nEwindows,nspin)); sumdos = 0.d0
       if(icomponent == TOTAL .and. sw_pdos == ON) then
          allocate(pdos(i0:nEwindows,nlmta_phi,nspin)); pdos = 0.d0
          allocate(sumpdos(i0:nEwindows,nlmta_phi,nspin)); sumpdos = 0.d0
       end if
    endif
! ========================================================================== 11.0
  end subroutine alloc_dos

  subroutine dealloc_dos()
    deallocate(dos)
    deallocate(sumdos)
    if(sw_pdos == ON) then
       if(allocated(pdos)) deallocate(pdos)
       if(allocated(sumpdos)) deallocate(sumpdos)
    end if
  end subroutine dealloc_dos

  subroutine make_dos_with_GaussianDistrib( kv, iwsc, kpt_weight )
    integer, intent(in) :: kv, iwsc
    real(kind=DP), intent(in) :: kpt_weight( kv )

    integer ::             i, ik, is, ie, id, ispin, iorb, iopr, lmtt, iksnl
    real(kind=DP) ::       Es, e, El, Eu, tl, tu, w, DeltaE
    real(kind=DP) ::       derf
    real(kind=DP) ::       porb

    DeltaE = DeltaE_dos
    Es = Eminimum - DeltaE*0.5d0
    
    if(ipridos >= 2) write(nfout,'(" !! Es, DeltaE = ",2d20.10)') Es, DeltaE
    dos = 0.d0; sumdos = 0.d0
    if(sw_pdos == ON) then
       pdos=0.d0; sumpdos=0.d0
    end if
    do ispin = 1, nspin
       do ik = ispin, kv, nspin
          iksnl = (ik-1)/nspin + 1
          do i = 1, neg
             w = 1.d0
             if(iwsc >= 1 ) w = dos_weight(i,ik)
             e = eko(i,ik) - nETailWindows*DeltaE - Es
             is = e/DeltaE
             ie = is + 2*nETailWindows
             if(is < 0) then
                if(ipridos >= 2) write(nfout,'(" is = ",i5," < 0")') is
                is = 0
             end if
             if(ie >= nEWindows ) then
                if(ipridos >= 2) write(nfout,'(" ie = ",i5, " > nEWindows")')ie
                ie = nEWindows-1
             end if
             if(ipridos >= 2) then
                write(nfout,'(" !! eko(",i3,",",i3,") = ",f10.6," is, ie = ",2i7, 2f10.6)') &
                     & i,ik, eko(i,ik),is,ie, Es+is*DeltaE, Es+ie*DeltaE
             end if

             do id = is, ie
                El = Es + id*DeltaE
                Eu = El + DeltaE
                tl = (El - eko(i,ik))*sqrtdVI
                tu = (Eu - eko(i,ik))*sqrtdVI
                !  d = (derf(tl) - derf(tu))*0.5d0/(DeltaE*kv)
                dos(id+1,ispin) = dos(id+1,ispin) &
                     & + w *2 *(derf(tu) - derf(tl)) *0.5d0 /DeltaE *kpt_weight(ik)
             end do
             if(iwsc == TOTAL .and. sw_pdos == ON) then
                do iorb = 1,nlmta_phi
                   call m_PP_tell_iorb_lmtt(iorb,lmtt)
                   porb = 0.d0
!!$ASASASASAS
!!$                do iopr=1,nopr
!!$                   porb = porb + (compr(i,iorb,iopr,ik)**2 &
!!$                        &       + compi(i,iorb,iopr,ik)**2) &
!!$                        &     *(1.d0+qorb(iorb)/norm_phig_mpi(lmt,iksnl))
!!$                end do
                   if ( k_symmetry(ik) == GAMMA ) then
                      do iopr=1,nopr
                         porb = porb + compr(i,iorb,iopr,ik)**2  /2.0 &
                              &     *(1.d0+qorb(iorb)/(norm_phig_mpi(lmtt,iksnl)*2.) )
                      end do
                   else
                      do iopr=1,nopr
                         porb = porb + (compr(i,iorb,iopr,ik)**2 &
                              &       + compi(i,iorb,iopr,ik)**2) &
                              &     *(1.d0+qorb(iorb)/norm_phig_mpi(lmtt,iksnl))
                      end do
                   endif
!!$ASASASASAS
                   porb = porb/dble(nopr)
                   do id = is, ie
                      El = Es + id*DeltaE
                      Eu = El + DeltaE
                      tl = (El - eko(i,ik))*sqrtdVI
                      tu = (Eu - eko(i,ik))*sqrtdVI
                      !  d = (derf(tl) - derf(tu))*0.5d0/(DeltaE*kv)
                      pdos(id+1,iorb,ispin) = pdos(id+1,iorb,ispin) &
                           & + porb *w *2 *(derf(tu) - derf(tl)) *0.5d0 /DeltaE &
                           &        *kpt_weight(ik)
                   end do
                end do
             end if
          end do
       end do
       sumdos(1,ispin) = dos(1,ispin)*DeltaE
       do id = 1, nEWindows-1
          sumdos(id+1,ispin) = sumdos(id,ispin) + dos(id+1,ispin)*DeltaE
       end do
       if(sw_pdos == ON) then
          do iorb = 1,nlmta_phi
             sumpdos(1,iorb,ispin) = pdos(1,iorb,ispin)*DeltaE
             do id = 1, nEWindows-1
                sumpdos(id+1,iorb,ispin) = sumpdos(id,iorb,ispin) + pdos(id+1,iorb,ispin)*DeltaE
             end do
          end do
       end if
    end do
  end subroutine make_dos_with_GaussianDistrib

! ==================================== added by K. Tagami ============== 11.0
  subroutine mkdos_with_GaussDistrib_noncl( kv, iwsc, kpt_weight )
    integer, intent(in) :: kv, iwsc
    real(kind=DP), intent(in) :: kpt_weight( kv )

    integer :: i, ik, is, ie, id, ispin, iorb, iopr, lmtt, iksnl
    integer :: is1, is2, istmp, ismax
    real(kind=DP) ::       Es, e, El, Eu, tl, tu, w, DeltaE
    real(kind=DP) ::       derf

    complex(kind=CMPLDP) :: z1, z2, ztemp

    real(kind=DP) ::       porb( nlmta_phi, ndim_magmom )
    complex(kind=CMPLDP) ::     porb_ssrep( nlmta_phi, ndim_chgpot )

    DeltaE = DeltaE_dos
    Es = Eminimum - DeltaE*0.5d0
    
    if (ipridos >= 2) write(nfout,'(" !! Es, DeltaE = ",2d20.10)') Es, DeltaE
    dos = 0.d0; sumdos = 0.d0
    if (sw_pdos == ON) then
       pdos=0.d0; sumpdos=0.d0
    end if
    
    do ik = 1, kv, ndim_spinor
       iksnl = (ik-1)/ndim_spinor + 1
       do i = 1, neg

          e = eko(i,iksnl) - nETailWindows*DeltaE - Es
          
          is = e/DeltaE
          ie = is + 2*nETailWindows
          if(is < 0) then
             if(ipridos >= 2) write(nfout,'(" is = ",i5," < 0")') is
             is = 0
          end if
          if(ie >= nEWindows ) then
             if(ipridos >= 2) write(nfout,'(" ie = ",i5, " > nEWindows")')ie
             ie = nEWindows-1
          end if
          if(ipridos >= 2) then
             write(nfout,'(" !! eko(",i3,",",i3,") = ",f10.6," is, ie = ",2i7, 2f10.6)') &
                  & i,ik, eko(i,iksnl),is,ie, Es+is*DeltaE, Es+ie*DeltaE
          end if

          if ( calc_dos_magmom_contrib == YES ) then
             ismax = ndim_magmom
          else
             ismax = 1
          endif

          Do istmp=1, ismax
             w = dos_weight_noncl(i,ik,istmp)

             do id = is, ie
                El = Es + id*DeltaE
                Eu = El + DeltaE
                tl = (El - eko(i,iksnl))*sqrtdVI
                tu = (Eu - eko(i,iksnl))*sqrtdVI
                !  d = (derf(tl) - derf(tu))*0.5d0/(DeltaE*kv)
                dos(id+1,istmp) = dos(id+1,istmp) &
                     & + w *(derf(tu) - derf(tl)) *0.5d0 /DeltaE *kpt_weight(ik)
             end do
          End do

          if (iwsc == TOTAL .and. sw_pdos == ON) then
             w = 1.0d0;   porb_ssrep = 0.0d0

             Do iorb = 1,nlmta_phi
                call m_PP_tell_iorb_lmtt(iorb,lmtt)
                
                if ( k_symmetry(ik) == GAMMA ) then
                   stop 'Not supported : Gamma in noncollinear system'
                   
                else
                   
                   Do is1=1, ndim_spinor
                      Do is2=1, ndim_spinor
                         istmp = ( is1 -1 )*ndim_spinor + is2
                         
                         ztemp = 0.0d0
                         do iopr=1,nopr
                            z1 = dcmplx( compr(i,iorb,iopr,ik+is1-1 ), &
                                 &       compi(i,iorb,iopr,ik+is1-1 ) )
                            z2 = dcmplx( compr(i,iorb,iopr,ik+is2-1 ), &
                                 &       compi(i,iorb,iopr,ik+is2-1 ) )
                            ztemp = ztemp + z1 *conjg(z2) &
                                 &      *( 1.d0+qorb(iorb)/norm_phig_mpi(lmtt,iksnl) )
                         end do
                         
                         porb_ssrep(iorb,istmp) = porb_ssrep(iorb,istmp) &
                              &                   + ztemp /dble(nopr)
                      End do
                   End do
                endif
             End do
             
             call m_ES_DensMat_To_MagMom_porb( nlmta_phi, porb_ssrep, porb )
             
             Do iorb = 1,nlmta_phi
                do id = is, ie
                   El = Es + id*DeltaE
                   Eu = El + DeltaE
                   tl = (El - eko(i,iksnl))*sqrtdVI
                   tu = (Eu - eko(i,iksnl))*sqrtdVI
                   !  d = (derf(tl) - derf(tu))*0.5d0/(DeltaE*kv)
                   pdos(id+1,iorb,:) = pdos(id+1,iorb,:) &
                        & + porb(iorb,:) *w *(derf(tu) - derf(tl)) &
                        &                *0.5d0 /DeltaE *kpt_weight(ik)
                end do
             End do

          end if
       end do
    end do

    sumdos(1,:) = dos(1,:)*DeltaE

    do id = 1, nEWindows-1
       sumdos(id+1,:) = sumdos(id,:) + dos(id+1,:)*DeltaE
    end do

    if(sw_pdos == ON) then
       do iorb = 1,nlmta_phi
          sumpdos(1,iorb,:) = pdos(1,iorb,:)*DeltaE
          do id = 1, nEWindows-1
             sumpdos(id+1,iorb,:) = sumpdos(id,iorb,:) + pdos(id+1,iorb,:)*DeltaE
          end do
       end do
    end if

  end subroutine mkdos_with_GaussDistrib_noncl
! =================================================================== 11.0

! ====================== KT_add ======================= 13.0E
  subroutine make_dos_with_FDiracDistrib( kv, iwsc, kpt_weight )
    integer, intent(in) :: kv, iwsc
    real(kind=DP), intent(in) :: kpt_weight( kv )

    integer ::             i, ik, is, ie, id, ispin, iorb, iopr, lmtt, iksnl
    real(kind=DP) ::       Es, e, Ene1, c1, c2, w, DeltaE
    real(kind=DP) ::       porb

    DeltaE = DeltaE_dos
    Es = Eminimum - DeltaE*0.5d0
    
!    width_fermi_dirac = width

    if(ipridos >= 2) write(nfout,'(" !! Es, DeltaE = ",2d20.10)') Es, DeltaE
    dos = 0.d0; sumdos = 0.d0
    if(sw_pdos == ON) then
       pdos=0.d0; sumpdos=0.d0
    end if
    do ispin = 1, nspin
       do ik = ispin, kv, nspin
          iksnl = (ik-1)/nspin + 1
          do i = 1, neg
             w = 1.d0
             if(iwsc >= 1 ) w = dos_weight(i,ik)
             e = eko(i,ik) - nETailWindows*DeltaE - Es
             is = e/DeltaE
             ie = is + 2*nETailWindows
             if(is < 0) then
                if(ipridos >= 2) write(nfout,'(" is = ",i5," < 0")') is
                is = 0
             end if
             if(ie >= nEWindows ) then
                if(ipridos >= 2) write(nfout,'(" ie = ",i5, " > nEWindows")')ie
                ie = nEWindows-1
             end if
             if(ipridos >= 2) then
                write(nfout,'(" !! eko(",i3,",",i3,") = ",f10.6," is, ie = ",2i7, 2f10.6)') &
                     & i,ik, eko(i,ik),is,ie, Es+is*DeltaE, Es+ie*DeltaE
             end if

             do id = is, ie
                ene1 = Es +id*DeltaE
                call width_fermi_dirac( ene1, eko(i,ik), smearing_width_fdirac, c1, c2 )
!!!                dos(id+1,ispin) = dos(id+1,ispin) + w *c1 *2.0d0 /dble(kv)
                dos(id+1,ispin) = dos(id+1,ispin) + w *c1 *2.0d0 *kpt_weight(ik)
             end do
             if(iwsc == TOTAL .and. sw_pdos == ON) then
                do iorb = 1,nlmta_phi
                   call m_PP_tell_iorb_lmtt(iorb,lmtt)
                   porb = 0.d0
!!$ASASASASAS
!!$                do iopr=1,nopr
!!$                   porb = porb + (compr(i,iorb,iopr,ik)**2 &
!!$                        &       + compi(i,iorb,iopr,ik)**2) &
!!$                        &     *(1.d0+qorb(iorb)/norm_phig_mpi(lmt,iksnl))
!!$                end do
                   if ( k_symmetry(ik) == GAMMA ) then
                      do iopr=1,nopr
                         porb = porb + compr(i,iorb,iopr,ik)**2  /2.0 &
                              &     *(1.d0+qorb(iorb)/(norm_phig_mpi(lmtt,iksnl)*2.) )
                      end do
                   else
                      do iopr=1,nopr
                         porb = porb + (compr(i,iorb,iopr,ik)**2 &
                              &       + compi(i,iorb,iopr,ik)**2) &
                              &     *(1.d0+qorb(iorb)/norm_phig_mpi(lmtt,iksnl))
                      end do
                   endif
!!$ASASASASAS
                   porb = porb/dble(nopr)
                   do id = is, ie
                      ene1 = Es +id*DeltaE
                      call width_fermi_dirac( ene1, eko(i,ik), &
                           &                  smearing_width_fdirac, c1, c2  )
                      pdos(id+1,iorb,ispin) = pdos(id+1,iorb,ispin) &
!!!                           & + porb *w *c1 *2.0d0 /dble(kv)
                           & + porb *w *c1 *2.0d0 *kpt_weight(ik)
                   end do
                end do
             end if
          end do
       end do
       sumdos(1,ispin) = dos(1,ispin)*DeltaE
       do id = 1, nEWindows-1
          sumdos(id+1,ispin) = sumdos(id,ispin) + dos(id+1,ispin)*DeltaE
       end do
       if(sw_pdos == ON) then
          do iorb = 1,nlmta_phi
             sumpdos(1,iorb,ispin) = pdos(1,iorb,ispin)*DeltaE
             do id = 1, nEWindows-1
                sumpdos(id+1,iorb,ispin) = sumpdos(id,iorb,ispin) + pdos(id+1,iorb,ispin)*DeltaE
             end do
          end do
       end if
    end do
  end subroutine make_dos_with_FDiracDistrib
! =============================================================== 13.0E

  subroutine get_VBM(total_charge,deltad)
    real(kind=DP), intent(in) :: total_charge, deltad
    integer :: i
    logical :: found
    found = .false.
    i = nEWindows

    if(check_if_metalic_flag .and. .not.metalic_system) then
          ValenceBandMaximum = vbm
          if(ipridos >= 1) then
             if(dabs(ValenceBandMaximum) < 1.d6) then
                write(nfout,'(" ValenceBandMaximum = vbm = ",f12.4," total_charge = ",f12.4 &
                     & ," (m_ES_dos.get_VBM)")') ValenceBandMaximum,total_charge
             else
                write(nfout,'(" ValenceBandMaximum is not calculated")')
             end if
          end if
    else
! ============================== modified by K. Tagami ================ 11.0
!       if(nspin == 1) then
!          do while(.not.found.and.i >= 1)
!             i = i - 1
!             if(sumdos(i,nspin) < total_charge - deltad) found = .true.
!          end do
!       else if(nspin == 2) then
!          do while(.not.found.and.i<= nEWindows)
!             i = i - 1
!             if(sumdos(i,1)+sumdos(i,2) < total_charge - deltad) found = .true.
!          end do
!       end if

       if ( noncol ) then
          do while(.not.found.and.i >= 1)
             i = i - 1
             if(sumdos(i,1) < total_charge - deltad) found = .true.
          end do
       else
          if(nspin == 1) then
             do while(.not.found.and.i >= 1)
                i = i - 1
                if(sumdos(i,nspin) < total_charge - deltad) found = .true.
             end do
          else if(nspin == 2) then
             do while(.not.found.and.i<= nEWindows)
                i = i - 1
                if(sumdos(i,1)+sumdos(i,2) < total_charge - deltad) found = .true.
             end do
          end if
       endif
! ========================================================================= 11.0

       ValenceBandMaximum = Eminimum + i*DeltaE_dos
       if(ipridos >= 1) then
          write(nfout,'(" ValenceBandMaximum = ",f12.4, " i = ",i5," DeltaE_dos = ",d13.5 &
               & ," total_charge = ",f12.4," (m_ES_dos.get_VBM)")') &
               & ValenceBandMaximum,i,DeltaE_dos,total_charge
       end if
    end if

  end subroutine get_VBM

  subroutine write_dos(nf)
    integer, intent(in) :: nf
    integer       :: i, ii, nwdwidth, id, nrEWindows
    real(kind=DP) :: e,e_eV, dos_hr, dos_hr2, dos_eV, dos_eV2 &
         & , sumtotal, sumdos_avr, sumdos_avr2

    if(nwd_dos_window_width >= 1 .and. nwd_dos_window_width <= nEWindows) then
       nwdwidth = nwd_dos_window_width
    else
       nwdwidth = 1
    end if
    id = nwdwidth/2
    nrEWindows = nEWindows/nwdwidth * nwdwidth


    if(nspin == 1) then
       write(nf,'("  No.   E(hr.)        dos(hr.)         E(eV)          dos(eV)              sum")')
       do i = 1, nrEWindows, nwdwidth
          e = Eminimum + (i-1+id)*DeltaE_dos
          e_eV = (e - ValenceBandMaximum)*Hartree
          dos_hr = 0.d0; sumdos_avr = 0.d0
          do ii = i, i+nwdwidth-1
             dos_hr = dos_hr + dos(ii,nspin)
             sumdos_avr = sumdos_avr + sumdos(ii,nspin)
          end do
          dos_hr = dos_hr/nwdwidth; sumdos_avr = sumdos_avr/nwdwidth
!!$          dos_eV = dos(i,nspin)/Hartree
          dos_eV = dos_hr/Hartree
          write(nf,'(i7,f10.5,f18.10,f14.6,f18.10,f20.10)') i+id, e, dos_hr &
               & , e_eV, dos_eV, sumdos_avr
       end do
    else if(nspin == 2) then
       write(nf,'(1x,a47,5x,a45,6x,a27)') "No.  E(hr.)    dos_up(hr.)       dos_down(hr.)" &
            & ,"E(eV)         dos_up(eV)        dos_down(eV)" &
            & ,"sum_up   sum_down sum_total"
       do i = 1, nrEWindows, nwdwidth
          e = Eminimum + (i-1+id)*DeltaE_dos
          e_eV = (e - ValenceBandMaximum)*Hartree
          dos_hr = 0.d0; dos_hr2 = 0.d0;  sumdos_avr = 0.d0; sumdos_avr2 = 0.d0
          do ii = i, i+nwdwidth-1
             dos_hr  = dos_hr + dos(ii,1)
             dos_hr2 = dos_hr2 + dos(ii,2)
             sumdos_avr  = sumdos_avr  + sumdos(ii,1)
             sumdos_avr2 = sumdos_avr2 + sumdos(ii,2)
          end do
          dos_hr = dos_hr/nwdwidth; dos_hr2 = dos_hr2/nwdwidth
          sumdos_avr = sumdos_avr/nwdwidth; sumdos_avr2 = sumdos_avr2/nwdwidth
!!$          dos_eV  = dos(i,1)/Hartree
!!$          dos_eV2 = dos(i,2)/Hartree
!!$          sumtotal = sumdos(i,1) + sumdos(i,2)
          dos_eV  = dos_hr/Hartree
          dos_eV2 = dos_hr2/Hartree
          sumtotal = sumdos_avr + sumdos_avr2
          write(nf,'(i7,f9.4,2f18.10,f15.4,2f18.10,3f10.4)') &
               & i, e, dos_hr,dos_hr2,e_eV, dos_eV, dos_eV2, sumdos_avr,sumdos_avr2,sumtotal
       end do
    end if
    write(nf,'("END")')
  end subroutine write_dos

! ================================== added by K. Tagami ================= 11.0
  subroutine write_dos_noncl(nf)
    integer, intent(in) :: nf
    integer       :: i, ii, nwdwidth, id, nrEWindows

    real(kind=DP) :: dos_hr( ndim_magmom ), sumdos_avr( ndim_magmom )
    real(kind=DP) :: dos_eV( ndim_magmom )
    real(kind=DP) :: e, e_eV
    real(kind=DP) :: sumtotal

    if(nwd_dos_window_width >= 1 .and. nwd_dos_window_width <= nEWindows) then
       nwdwidth = nwd_dos_window_width
    else
       nwdwidth = 1
    end if
    id = nwdwidth/2

    nrEWindows = nEWindows/nwdwidth * nwdwidth

    write(nf,'(2x,A,5x,A,4x,A)') "No.      E(eV)",&
         &     "  dos_chg(eV)    dos_mx(eV)    dos_my(eV)    dos_mz(eV)", &
         &      "sum_chg     sum_mx      sum_my      sum_mz"

    do i = 1, nrEWindows, nwdwidth
       e = Eminimum + (i-1+id)*DeltaE_dos
       e_eV = (e - ValenceBandMaximum)*Hartree

       dos_hr = 0.d0; sumdos_avr = 0.d0
       do ii = i, i+nwdwidth-1
          dos_hr(:) = dos_hr(:) + dos(ii,:)
          sumdos_avr(:) = sumdos_avr(:) + sumdos(ii,:)
       end do

       dos_hr = dos_hr/nwdwidth; sumdos_avr = sumdos_avr/nwdwidth
       dos_eV = dos_hr/Hartree

       write(nf,'(i5,f14.8,4f14.8,4f12.6)') &
               & i, e_eV, dos_eV(1:ndim_magmom), sumdos_avr(1:ndim_magmom)
!       write(nf,*) &
!               & i, e_eV, dos_eV(1:ndim_magmom), sumdos_avr(1:ndim_magmom)
    end do

    write(nf,'("END")')
  end subroutine write_dos_noncl

  subroutine write_dos_noncl_for_totchg(nf)

    integer, intent(in) :: nf
    integer       :: i, ii, nwdwidth, id, nrEWindows
    real(kind=DP) :: e,e_eV, dos_hr, dos_hr2, dos_eV, dos_eV2 &
         & , sumtotal, sumdos_avr, sumdos_avr2

    if(nwd_dos_window_width >= 1 .and. nwd_dos_window_width <= nEWindows) then
       nwdwidth = nwd_dos_window_width
    else
       nwdwidth = 1
    end if
    id = nwdwidth/2

    nrEWindows = nEWindows/nwdwidth * nwdwidth

    write(nf,'("     No.   E(hr.)        dos(hr.)         E(eV)          dos(eV)              sum")')

    do i = 1, nrEWindows, nwdwidth
       e = Eminimum + (i-1+id)*DeltaE_dos
       e_eV = (e - ValenceBandMaximum)*Hartree
       dos_hr = 0.d0; sumdos_avr = 0.d0

       do ii = i, i+nwdwidth-1
          dos_hr = dos_hr + dos(ii,1)
          sumdos_avr = sumdos_avr + sumdos(ii,1)
       end do

       dos_hr = dos_hr/nwdwidth; sumdos_avr = sumdos_avr/nwdwidth
       dos_eV = dos_hr/Hartree

       write(nf,'(i7,f10.5,f18.10,f14.6,f18.10,f20.10)') i+id, e, dos_hr &
            & , e_eV, dos_eV, sumdos_avr
    end do

    write(nf,'("END")')
  end subroutine write_dos_noncl_for_totchg
! ======================================================================== 11.0

  subroutine write_pdos(nf)
    integer, intent(in) :: nf

    integer :: iorb

    do iorb=1,nlmta_phi
       call write_pdos_orbital(nf,iorb)
!!$ASASASASAS
!!$       write(nf,'("END")')
!!$ASASASASAS
    end do

  end subroutine write_pdos

! =================================== added by K. Tagami =============== 11.0
  subroutine write_pdos_noncl(nf)
    integer, intent(in) :: nf
    integer :: iorb

    do iorb=1,nlmta_phi
       call write_pdos_orbital_noncl(nf,iorb)
    end do

  end subroutine write_pdos_noncl
! ========================================================================= 11.0

  subroutine write_pdos_orbital(nf,iorb)
    integer, intent(in) :: nf
    integer, intent(in) :: iorb
    integer :: ia,il,im,tau,nspher
    integer       :: i, ii, nwdwidth, id, nrEWindows
    real(kind=DP) :: e,e_eV, dos_hr, dos_hr2, dos_eV, dos_eV2 &
         & , sumtotal, sumdos_avr, sumdos_avr2

    if(nwd_dos_window_width >= 1 .and. nwd_dos_window_width <= nEWindows) then
       nwdwidth = nwd_dos_window_width
    else
       nwdwidth = 1
    end if
    id = nwdwidth/2
    nrEWindows = nEWindows/nwdwidth * nwdwidth

    call m_PP_tell_iorb_ia_l_m_tau(iorb,ia,il,im,tau)
!!$ASASASASAS
    if ( iproj_group(ia)== 0 ) return
!!$ASASASASAS
    if ( sw_diagonalize_population == ON ) then
       write(nf,'("PDOS: ia= ",i0," l=",i3," m''=",i3," t=",i3)') ia,il-1,im,tau
    else
       write(nf,'("PDOS: ia= ",i0," l=",i3," m=",i3," t=",i3)') ia,il-1,im,tau
    endif

    if(nspin == 1) then
       write(nf,'("  No.   E(hr.)        dos(hr.)         E(eV)          dos(eV)              sum")')
       do i = 1, nrEWindows, nwdwidth
          e = Eminimum + (i-1+id)*DeltaE_dos
          e_eV = (e - ValenceBandMaximum)*Hartree
          dos_hr = 0.d0; sumdos_avr = 0.d0
          do ii = i, i+nwdwidth-1
             dos_hr = dos_hr + pdos(ii,iorb,nspin)
             sumdos_avr = sumdos_avr + sumpdos(ii,iorb,nspin)
          end do
          dos_hr = dos_hr/nwdwidth; sumdos_avr = sumdos_avr/nwdwidth
          dos_eV = dos_hr/Hartree
          write(nf,'(i5,f10.5,f18.10,f14.6,f18.10,f20.10)') i+id, e, dos_hr &
               & , e_eV, dos_eV, sumdos_avr
       end do
    else if(nspin == 2) then
       write(nf,'(1x,a47,5x,a45,6x,a27)') "No.  E(hr.)    dos_up(hr.)       dos_down(hr.)" &
            & ,"E(eV)         dos_up(eV)        dos_down(eV)" &
            & ,"sum_up   sum_down sum_total"
       do i = 1, nrEWindows, nwdwidth
          e = Eminimum + (i-1+id)*DeltaE_dos
          e_eV = (e - ValenceBandMaximum)*Hartree
          dos_hr = 0.d0; dos_hr2 = 0.d0;  sumdos_avr = 0.d0; sumdos_avr2 = 0.d0
          do ii = i, i+nwdwidth-1
             dos_hr  = dos_hr + pdos(ii,iorb,1)
             dos_hr2 = dos_hr2 + pdos(ii,iorb,2)
             sumdos_avr  = sumdos_avr  + sumpdos(ii,iorb,1)
             sumdos_avr2 = sumdos_avr2 + sumpdos(ii,iorb,2)
          end do
          dos_hr = dos_hr/nwdwidth; dos_hr2 = dos_hr2/nwdwidth
          sumdos_avr = sumdos_avr/nwdwidth; sumdos_avr2 = sumdos_avr2/nwdwidth
          dos_eV  = dos_hr/Hartree
          dos_eV2 = dos_hr2/Hartree
          sumtotal = sumdos_avr + sumdos_avr2
          write(nf,'(i5,f9.4,2f18.10,f15.4,2f18.10,3f10.4)') &
               & i, e, dos_hr,dos_hr2,e_eV, dos_eV, dos_eV2, sumdos_avr,sumdos_avr2,sumtotal
       end do
    end if
!!$ASASASASAS
    write(nf,'("END")')
!!$ASASASASAS
  end subroutine write_pdos_orbital

! ================================= added by K. Tagami ==================== 11.0
  subroutine write_pdos_orbital_noncl(nf,iorb)
    integer, intent(in) :: nf
    integer, intent(in) :: iorb
    integer :: ia,il,im,tau,nspher
    integer       :: i, ii, nwdwidth, id, nrEWindows

    real(kind=DP) :: dos_hr( ndim_magmom ), sumdos_avr( ndim_magmom )
    real(kind=DP) :: dos_eV( ndim_magmom )
    real(kind=DP) :: e, e_eV

    if(nwd_dos_window_width >= 1 .and. nwd_dos_window_width <= nEWindows) then
       nwdwidth = nwd_dos_window_width
    else
       nwdwidth = 1
    end if
    id = nwdwidth/2

    nrEWindows = nEWindows/nwdwidth * nwdwidth

    call m_PP_tell_iorb_ia_l_m_tau(iorb,ia,il,im,tau)
    if ( iproj_group(ia)== 0 ) return

! ---
    write(nf,'("PDOS: ia= ",i0," l=",i3," m=",i3," t=",i3)') ia,il-1,im,tau

    write(nf,'(2x,A,5x,A,4x,A)') "No.      E(eV)",&
         &     "  dos_chg(eV)    dos_mx(eV)    dos_my(eV)    dos_mz(eV)", &
         &      "sum_chg     sum_mx      sum_my      sum_mz"

    do i = 1, nrEWindows, nwdwidth
       e = Eminimum + (i-1+id)*DeltaE_dos
       e_eV = (e - ValenceBandMaximum)*Hartree

       dos_hr = 0.0d0; sumdos_avr = 0.0d0
       do ii = i, i+nwdwidth-1
          dos_hr(:)  = dos_hr(:) + pdos(ii,iorb,:)
          sumdos_avr(:)  = sumdos_avr(:)  + sumpdos(ii,iorb,:)
       end do

       dos_hr = dos_hr/nwdwidth;         sumdos_avr = sumdos_avr/nwdwidth;
       dos_eV  = dos_hr/Hartree;   

       write(nf,'(i5,f14.8,4f14.8,4f12.6)') &
               & i, e_eV, dos_eV(1:ndim_magmom), sumdos_avr(1:ndim_magmom)
    end do

    write(nf,'("END")')
  end subroutine write_pdos_orbital_noncl
! ========================================================================= 11.0

  subroutine m_ESdos_gaussdistrib(nfdos,icomponent)
    integer, intent(in) ::      nfdos, icomponent

    call alloc_eko_and_substitution(kv3) ! eko_l -> eko
    call find_Erange(eko,neg,kv3)
    call alloc_dos(1,icomponent)
    call make_dos_with_GaussianDistrib( kv3, icomponent, qwgt )
    if(icomponent == TOTAL) call get_VBM(totch,DeltaDVBM)
    if(mype == 0) call write_dos(nfdos)
!!$    call write_dos(nfout)
    if(mype == 0 .and. icomponent == TOTAL .and. sw_pdos == ON) then
       call write_pdos(nfdos)
    end if
! ---
    if ( sw_calc_pcohp == ON ) call m_ES_calc_pcohp
! ---
    call dealloc_eko()
    call dealloc_dos()
  end subroutine m_ESdos_gaussdistrib

! ================================ added by K. Tagami =================== 11.0
  subroutine m_ESdos_gaussdistrib_noncl(nfdos,icomponent)
    integer, intent(in) ::      nfdos, icomponent

    call alloc_eko_and_substit_noncl(kv3) ! eko_l -> eko
    call find_Erange( eko, neg, kv3/ndim_spinor )
    call alloc_dos(1,icomponent)
    
    call mkdos_with_GaussDistrib_noncl( kv3, icomponent, qwgt )
    if(icomponent == TOTAL) call get_VBM(totch,DeltaDVBM)

    if(mype == 0) then
       if ( calc_dos_magmom_contrib == YES ) then
          call write_dos_noncl(nfdos)
       else
          call write_dos_noncl_for_totchg(nfdos)
       endif
    endif

    if(mype == 0 .and. icomponent == TOTAL .and. sw_pdos == ON) then
       call write_pdos_noncl(nfdos)
    end if

    call dealloc_eko()
    call dealloc_dos()
  end subroutine m_ESdos_gaussdistrib_noncl
! ======================================================================= 11.0

  subroutine m_ESdos_gaussdistrib_ek(nfdos,icomponent)
    integer, intent(in) ::      nfdos, icomponent

    call alloc_eko_and_substitution_ek(kv3_ek) ! eko_ek -> eko
    call find_Erange(eko,neg,kv3_ek)
    call alloc_dos(1,icomponent)
    call make_dos_with_GaussianDistrib( kv3_ek, icomponent, qwgt_ek )
    if(icomponent == TOTAL) call get_VBM(totch,DeltaDVBM)
    if(mype == 0) call write_dos(nfdos)
    call dealloc_eko()
    call dealloc_dos()
  end subroutine m_ESdos_gaussdistrib_ek

! ==================================== added by K. Tagami ================ 11.0
  subroutine m_ESdos_gaussdistrib_ek_noncl(nfdos,icomponent)
    integer, intent(in) ::      nfdos, icomponent

    call alloc_eko_and_substit_ek_noncl(kv3_ek) ! eko_ek -> eko
    call find_Erange(eko,neg,kv3_ek/ndim_spinor)
    call alloc_dos(1,icomponent)

    call mkdos_with_GaussDistrib_noncl( kv3_ek, icomponent, qwgt_ek )
    if(icomponent == TOTAL) call get_VBM(totch,DeltaDVBM)

    if(mype == 0) then
       if ( calc_dos_magmom_contrib == YES ) then
          call write_dos_noncl(nfdos)
       else
          call write_dos_noncl_for_totchg(nfdos)
       endif
    endif

    call dealloc_eko()
    call dealloc_dos()
  end subroutine m_ESdos_gaussdistrib_ek_noncl
! ========================================================================= 11.0

! ==================- KT_add ================= 13.0E
  subroutine m_ESdos_FdiracDistrib(nfdos,icomponent)
    integer, intent(in) ::      nfdos, icomponent

    call alloc_eko_and_substitution(kv3) ! eko_l -> eko
    call find_Erange_fermidirac(eko,neg,kv3)

    call alloc_dos(1,icomponent)
    call make_dos_with_FDiracDistrib( kv3, icomponent, qwgt )

!!!    if(icomponent == TOTAL) call get_VBM(totch,DeltaDVBM)
    if(icomponent == TOTAL) then
       ValenceBandMaximum = efermi
       write(nfout,*) '!!!! Efermi is used as ValenceBandMaximum in the Fermi Dirac case'
    endif

    if(mype == 0) call write_dos(nfdos)
!!$    call write_dos(nfout)
    if(mype == 0 .and. icomponent == TOTAL .and. sw_pdos == ON) then
       call write_pdos(nfdos)
    end if
    if ( sw_calc_pcohp == ON ) call m_ES_calc_pcohp

    call dealloc_eko(); call dealloc_dos()

  end subroutine m_ESdos_FdiracDistrib

  subroutine m_ESdos_FDiracDistrib_ek(nfdos,icomponent)
    integer, intent(in) ::      nfdos, icomponent

    call alloc_eko_and_substitution_ek(kv3_ek) ! eko_ek -> eko
    call find_Erange_fermidirac(eko,neg,kv3_ek)

    call alloc_dos(1,icomponent)
    call make_dos_with_FDiracDistrib( kv3_ek, icomponent, qwgt_ek )

    if(icomponent == TOTAL) then
       ValenceBandMaximum = efermi
       write(nfout,*) '!!!! Efermi is used as ValenceBandMaximum in the Fermi Dirac case'
    endif

    if(mype == 0) call write_dos(nfdos)
    call dealloc_eko();     call dealloc_dos()
  end subroutine m_ESdos_FDiracDistrib_ek
! ============================================ 13.0E

  subroutine m_ESdos_write_dos_header(nfdos,aldos_or_layerdos,icomponent)
    integer, intent(in):: nfdos, aldos_or_layerdos, icomponent
    if(mype == 0) then
       if(aldos_or_layerdos == ALDOS) then
          write(nfdos,'("ALDOS     num_atom = ",i7)') icomponent
       else if(aldos_or_layerdos == LAYERDOS) then
          write(nfdos,'("LAYERDOS   num_layer = ",i7)') icomponent
       end if
    end if
  end subroutine m_ESdos_write_dos_header

  ! ----------------------------------------------

  subroutine m_ESdos_tetrahedral(nfdos,icomponent,mode)
    integer, intent(in) ::  nfdos, mode,icomponent
!!$#ifndef NO_TETRAHEDRON
    real(kind=DP), parameter :: delta = 1.d-12
    integer, parameter       :: idim = 3
    integer        :: neig,ispin,ip2,ik, ip, ib, jb, ie
    real(kind=DP)  :: et,wei,clpm
    real(kind=DP), allocatable, dimension(:,:,:)   :: eeig2, eeig2_mpi
    real(kind=DP), allocatable,dimension(:,:)  :: dos_weight2 ! d(neg,np2)
    real(kind=DP), allocatable, dimension(:,:,:,:) :: compr, compr_mpi
    real(kind=DP), allocatable, dimension(:,:,:,:) :: compi, compi_mpi
    real(kind=DP), allocatable, dimension(:,:) :: norm_phig_mpi, norm_phig_mpi2
    real(kind=DP), pointer, dimension(:) :: eawk,cdwk,cswk,e
    real(kind=DP), allocatable, dimension(:,:) ::  e_mpi,e_mpi2
    real(kind=DP), pointer, dimension(:,:,:) :: cdos,cind
    real(kind=DP), allocatable, dimension(:,:) :: doswk,dosinwk
    integer, allocatable, dimension(:,:) :: nttra ! d(mtetra,4)
    integer ::                                  id_sname = -1
    integer :: i,iorb,iopr,ikorb,lmtt, ipridos_t, nEwindows_plus,mtetra,ikt,iloop
    integer, parameter :: ncl = 8
    real(kind=DP) :: porb

    call tstatc0_begin('m_ESdos_tetrahedral ', id_sname)

    if(mode /= SCF .and. mode /= EK) then
       write(nfout,'(" !dos:  mode = ",i6," <<m_ESdos_tetrahedral>>")') mode
       return
    end if

    if(npes > 1) then
       if(mype == 0) ipridos_t = ipridos
       call mpi_bcast(ipridos_t, 1, mpi_integer, 0, mpi_comm_group, ierr)
    else
       ipridos_t = ipridos
    end if

    if(ipridos_t >= 3) then
       if(printable) write(nfout,'(" !dos: np2, np0 = ",2i7," <<m_ESdos_tetrahedral>>")') np2, np0
       allocate(e_mpi(neg,kv3)); allocate(e_mpi2(neg,kv3))
       if(printable) write(nfout,'(" !dos: icomponent = ",i9," <<m_ESdos_tetrahedral>>")') icomponent
       if(printable) write(nfout,'(" !dos: --energy_eigenvalue--")')
       e_mpi = 0.d0; e_mpi2 = 0.d0
       do ik = 1, kv3, af+1
          if(map_k(ik) /= myrank_k) cycle
          do ie = 1, neg
             ip = neordr(ie,ik)
             if(map_e(ip) == myrank_e) e_mpi(ie,ik) = eko_l(map_z(ip),ik)
          end do
       end do
       if(npes >=2) then
          call mpi_allreduce(e_mpi,e_mpi2,neg*kv3,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
          e_mpi = e_mpi2
       end if
       if(printable) then
          do ik = 1, kv3
             write(nfout,'(" !dos:  ik = ",i7)') ik
             write(nfout,'(" !dos: ",8f10.6)') (e_mpi(ie,ik),ie=1,neg)
          end do
       end if
       deallocate(e_mpi,e_mpi2)
    end if

    allocate(eeig2(np2,neg,nspin)); eeig2 = 0.d0
    if(icomponent == TOTAL .and. sw_pdos == ON) then
       allocate(compr(neg,nlmta_phi,nopr,np2*nspin));  compr = 0.d0
       allocate(compi(neg,nlmta_phi,nopr,np2*nspin));  compi = 0.d0
       allocate(norm_phig_mpi(nlmtt_phi,np2));  norm_phig_mpi = 0.d0
    end if

    if(mode==EK .and. ipridos_t >= 1) then
       write(nfout,'(" !dos eko_ek ")')
       do ispin=1,nspin
          do ip2=1,np2
             ik = nspin*(ip2-1)+ispin
             write(nfout,'(" !dos -- ik = ",i5)') ik
             write(nfout,'(" !dos ",8f8.4)')(eko_ek(ib,ik),ib=1,neg)
          end do
       end do
    end if

    neig=neg
    do ispin=1,nspin
       do ip2=1,np2
          ik=nspin*(ip2-1)+ispin
          if(mode == EK) then
             do ib=1,neg
                eeig2(ip2,ib,ispin)=eko_ek(ib,ik)
             enddo
             do ib = 1,neg-1
                do jb = ib+1, neg
                   if(eeig2(ip2,jb,ispin) < eeig2(ip2,ib,ispin)-delta) then
                      et = eeig2(ip2,ib,ispin)
                      eeig2(ip2,ib,ispin) = eeig2(ip2,jb,ispin)
                      eeig2(ip2,jb,ispin) = et
                   end if
                end do
             end do
          else if(mode == SCF) then
             if(map_k(ik) /= myrank_k) cycle
             do ib = 1, neg
                ip = neordr(ib,ik)
                if(map_e(ip) == myrank_e) then
                   eeig2(ip2,ib,ispin)=eko_l(map_z(ip),ik)
                   if(icomponent == TOTAL .and. sw_pdos == ON) then
                      compr(ib,1:nlmta_phi,1:nopr,ik)=compr_l(map_z(ip),1:nlmta_phi,1:nopr,ik)
!!$ASASASASAS
!!$                      compi(ib,1:nlmta_phi,1:nopr,ik)=compi_l(map_z(ip),1:nlmta_phi,1:nopr,ik)
                      if ( k_symmetry(ik) /= GAMMA ) then
                         compi(ib,1:nlmta_phi,1:nopr,ik)=compi_l(map_z(ip),1:nlmta_phi,1:nopr,ik)
                      else
!                         compi = 0.0d0
                         compi(ib,1:nlmta_phi,1:nopr,ik) = 0.0d0
                      endif
!!$ASASASASAS
                      norm_phig_mpi(1:nlmtt_phi,ip2)=norm_phig(1:nlmtt_phi,ip2)
                   end if
                end if
             enddo
          end if
       enddo
    end do

    if(mode == SCF) then
       if(npes >= 2) then
          !allocate(eeig2_mpi(np2,neg,nspin)); eeig2_mpi = 0.d0
          call mpi_allreduce(MPI_IN_PLACE,eeig2,np2*neg*nspin,mpi_double_precision,mpi_sum &
               & , mpi_comm_group,ierr)
          !eeig2 = eeig2_mpi
          !deallocate(eeig2_mpi)
          if(icomponent == TOTAL .and. sw_pdos == ON) then
            !allocate(compr_mpi(neg,nlmta_phi,nopr,np2*nspin)); compr_mpi = 0.d0
            !allocate(compi_mpi(neg,nlmta_phi,nopr,np2*nspin)); compi_mpi = 0.d0
            !allocate(norm_phig_mpi2(nlmtt_phi,np2)); norm_phig_mpi2 = 0.d0
            call mpi_allreduce(MPI_IN_PLACE,compr,neg*nlmta_phi*nopr*np2*nspin,mpi_double_precision,mpi_sum &
               & , mpi_comm_group,ierr)
            call mpi_allreduce(MPI_IN_PLACE,compi,neg*nlmta_phi*nopr*np2*nspin,mpi_double_precision,mpi_sum &
               & , mpi_comm_group,ierr)
            call mpi_allreduce(MPI_IN_PLACE,norm_phig_mpi,nlmtt_phi*np2,mpi_double_precision,mpi_sum &
               & , mpi_comm_group,ierr)

            norm_phig_mpi = norm_phig_mpi / dble(nrank_e)

            !compr = compr_mpi
            !compi = compi_mpi
            !norm_phig_mpi = norm_phig_mpi2
            !deallocate(compr_mpi,compi_mpi,norm_phig_mpi2)
          end if
       end if
    end if

    if(ipridos >= 2) then
!!$       if(mype == 0) then
          write(nfout,'(" !dos: --eeig2(energy_eigenvalue)--")')
          iloop = (neg-1)/ncl+1
          do ispin = 1, nspin
             write(nfout,'(" !dos: ispin = ",i5)') ispin
             do ip2 = 1, np2
                do i = 1, iloop
                   write(nfout,'(" !dos: (",i5,") ",8f9.5)') &
                        & ip2,(eeig2(ip2,ib,ispin),ib=ncl*(i-1)+1,min(neg,ncl*i))
                end do
!!$                write(nfout,'(" !dos:  ip2 = ",i7)') ip2
!!$                write(nfout,'(" !dos: ",8f9.5)') (eeig2(ip2,ib,ispin),ib=1,neg)
             end do
          end do
          if(sw_pdos == ON) then
          do ispin=1,nspin
             write(nfout,'(" !dos: ispin = ",i5)') ispin
             do ip2 = 1, np2 
                ikorb=nspin*(ik-1)+ispin
                write(nfout,'(" !dos:  ip2 = ",i7)') ip2
                write(nfout,'(" !dos norm_phig: ",10f8.4)') &
                          & norm_phig_mpi(1:nlmtt_phi,ip2)
                do iopr=1,nopr
                   do iorb=1,nlmta_phi
                      write(nfout,'(" !dos: ik=",i5," iopr=",i5," iorb=",i5)')&
                              &  ikorb,iopr,iorb
                      write(nfout,'(" !dos compr: ",10f8.4)') &
                              & compr(1:neg,iorb,iopr,ikorb)
                      write(nfout,'(" !dos compi: ",10f8.4)') &
                              & compi(1:neg,iorb,iopr,ikorb)
                   end do
                end do
             end do
          end do
          end if
!!$       end if
    end if

    if(mode == EK) then
       call find_Erange(eko_ek,neg,kv3_ek)
    else
       Eminimum = minval(eeig2) - 0.005 ! (hartree)
       Emaximum = maxval(eeig2) + 0.005 ! (hartree)
       nEWindows = (Emaximum - Eminimum)/DeltaE_dos + 1
    end if
       
    if(ipridos >= 2) &
         & write(nfout,'(" !dos: Emaximum, Eminimum, nEwindows = ",2f10.6,i7)') &
         &       Eminimum,Emaximum, nEWindows

    call alloc_dos(0,icomponent)

    if(nspin == 1) then
       wei = 2.d0
    else
       wei = 1.d0
    end if

    if(ipridos >= 2) write(nfout,*) ' === tetrahedron method', &
                &  ' for k-space integration === <<m_ESdos_tetrahedral>>'
    if(ipridos >= 2) write(nfout,'(" !m_ES_dos dos_subroutine = ",i5)') dos_subroutine

    do ispin=1,nspin
!!$       write(nfout,*) ' ispin=',ispin
!!$       write(nfout,'(" !! nxyz_tetra = ",3i7)') nxyz_tetra(1:3)
!!$       write(nfout,'(" !! np0 = ",i7)') np0
!!$       do ik = 1, np0
!!$          write(nfout,'(" !! ik, ip20 = ",2i6," <<m_ESdos_tetrahedral>>")') ik,ip20(ik)
!!$       end do
       if(dos_subroutine == 3) then
          allocate(e(0:nEwindows))
          e(0:nEwindows) = (/(Eminimum + DeltaE_dos*ie,ie=0,nEWindows)/)
          ! e(0) = Eminimum, e(1) = Eminimum+DeltaE_dos, e(2) = Eminimum+DeltaE_dos*2,...

          allocate(cdos(np2,neg,0:nEWindows)); cdos = 0.d0
          allocate(cind(np2,neg,0:nEWindows)); cind = 0.d0
          allocate(eawk(np0)); eawk = 0.d0
          allocate(cdwk(np0)); cdwk = 0.d0
          allocate(cswk(np0)); cswk = 0.d0
          call nstt3i(idim,nEwindows,e,nxyz_tetra(1),nxyz_tetra(2),nxyz_tetra(3) &
               &  ,np2,np2,neig,eeig2(1,1,ispin) &
               &  ,ip20,np0,eawk,cdwk,cswk,np2,neig,cdos,cind,width_tetra ) ! -> cdos, cind
          deallocate(cswk,cdwk,eawk)
          clpm = 1.d0
          do ik=1,np2
             ikt = nspin*(ik-1)+ispin
             if(icomponent == TOTAL .and. sw_pdos == ON) ikorb=nspin*(ik-1)+ispin
             do ib = 1, neg
!!$             if(icomponent >= 1) clpm = dos_weight(ib,ik)
                if(icomponent /= TOTAL) clpm = dos_weight(ib,ikt)

                do ie = 0, nEwindows
                   dos(ie,ispin) = dos(ie,ispin) + cdos(ik,ib,ie)*clpm*wei
                   sumdos(ie,ispin) = sumdos(ie,ispin) + cind(ik,ib,ie)*clpm*wei
                end do
                if(icomponent == TOTAL .and. sw_pdos == ON) then
                   do iorb = 1,nlmta_phi
                      call m_PP_tell_iorb_lmtt(iorb,lmtt)
                      porb = 0.d0
!!$ASASASASAS
!!$                      do iopr=1,nopr
!!$                         porb = porb + (   compr(ib,iorb,iopr,ikorb)**2 &
!!$                              &          + compi(ib,iorb,iopr,ikorb)**2) &
!!$                              &        *(1.d0+qorb(iorb)/norm_phig_mpi(lmt,ik))
!!$                      end do
                      if ( k_symmetry(ik) == GAMMA) then
                         do iopr=1,nopr
                            porb = porb + compr(ib,iorb,iopr,ikorb)**2 /2.0 &
                            &  *(1.d0+qorb(iorb)/(norm_phig_mpi(lmtt,ik)*2.) )
                         end do
                      else
                         do iopr=1,nopr
                            porb = porb + ( compr(ib,iorb,iopr,ikorb)**2 &
                                 &        + compi(ib,iorb,iopr,ikorb)**2) &
                            &    *(1.d0+qorb(iorb)/norm_phig_mpi(lmtt,ik))
                         enddo
                      endif
!!$ASASASASAS
                      porb = porb/dble(nopr)
                      ! debug
                      ! print *,'debug iorb=',iorb,' porb=',porb
                      ! end debug
                      do ie = 0, nEwindows
                         pdos(ie,iorb,ispin) = pdos(ie,iorb,ispin) + cdos(ik,ib,ie)*wei*porb
                         sumpdos(ie,iorb,ispin) = sumpdos(ie,iorb,ispin) + cind(ik,ib,ie)*wei*porb
                      end do
                   end do
                end if
             end do
          end do
          deallocate(cind,cdos)
          deallocate(e)
       else if(dos_subroutine == 4) then
          allocate(cdos(0:nEwindows,np2,neg)); cdos = 0.d0
          allocate(cind(0:nEwindows,np2,neg)); cind = 0.d0
          nEwindows_plus = nEwindows
          if(mod(nEwindows_plus,2)==1) nEwindows_plus = nEwindows_plus+1
          allocate(doswk(0:nEwindows_plus,4))
          allocate(dosinwk(0:nEwindows_plus,4))
          mtetra = product(nxyz_tetra(1:3))*6
          allocate(nttra(mtetra,4))
          call prepare_nttra(nxyz_tetra,mtetra,nttra)
          write(nfout,'(" !dos after prepare_nttra")')
          write(nfout,'(" !dos neig = ",i5)') neig
          cdos = 0.d0; cind =0.d0
          call nstt4i(ipridos,idim,nEwindows,nxyz_tetra,np2,np2,neig,eeig2(1,1,ispin) &
               &   ,  ip20,np0,np2,neig,mtetra,nttra,deltae_dos &
               &   ,  nEwindows_plus,doswk,dosinwk,cdos,cind)
          deallocate(nttra)
          deallocate(dosinwk,doswk)
          clpm = 1.d0
          do ik=1,np2
             ikt=nspin*(ik-1)+ispin
             do ib = 1, neg
                if(icomponent /= TOTAL) clpm = dos_weight(ib,ikt)
                ! clpm -> clpm(ib,ik)
                do ie = 0, nEwindows
                   dos(ie,ispin) = dos(ie,ispin) + cdos(ie,ik,ib)*clpm*wei
                   sumdos(ie,ispin) = sumdos(ie,ispin) + cind(ie,ik,ib)*clpm*wei
                end do
             end do
          end do
          if(icomponent == TOTAL .and. sw_pdos == ON) then
             do ik = 1,np2
                ikorb=nspin*(ik-1)+ispin
                do ib = 1, neg
                   do iorb = 1,nlmta_phi
                      call m_PP_tell_iorb_lmtt(iorb,lmtt)
                      porb = 0.d0
!!$ASASASASAS
!!$                      do iopr=1,nopr
!!$                         porb = porb + (   compr(ib,iorb,iopr,ikorb)**2 &
!!$                              &          + compi(ib,iorb,iopr,ikorb)**2) &
!!$                              &        *(1.d0+qorb(iorb)/norm_phig_mpi(lmt,ik))
!!$                      end do
                      if ( k_symmetry(ik) == GAMMA ) then
                         do iopr=1,nopr
                            porb = porb + compr(ib,iorb,iopr,ikorb)**2 /2.0 &
                              &   *(1.d0+qorb(iorb)/(norm_phig_mpi(lmtt,ik)*2.))
                           end do
                      else
                         do iopr=1,nopr
                            porb = porb + ( compr(ib,iorb,iopr,ikorb)**2 &
                                 &    + compi(ib,iorb,iopr,ikorb)**2) &
                                 &   *(1.d0+qorb(iorb)/norm_phig_mpi(lmtt,ik))
                         end do
                      endif
!!$ASASASASAS
                      porb = porb/dble(nopr)
                      ! porb -> porb(ib,iorb,ik)
                      ! debug
                      ! print *,'debug iorb=',iorb,' porb=',porb
                      ! end debug
                      do ie = 0, nEwindows
                         pdos(ie,iorb,ispin) = pdos(ie,iorb,ispin) + cdos(ie,ik,ib)*wei*porb
                         sumpdos(ie,iorb,ispin) = sumpdos(ie,iorb,ispin) + cind(ie,ik,ib)*wei*porb
                      end do
                   end do
                end do
             end do
          end if
          deallocate(cind,cdos)
       else if(dos_subroutine == 5) then
          nEwindows_plus = nEwindows
          if(mod(nEwindows_plus,2)==1) nEwindows_plus = nEwindows_plus+1
          allocate(doswk(0:nEwindows_plus,4))
          allocate(dosinwk(0:nEwindows_plus,4))
          mtetra = product(nxyz_tetra(1:3))*6
          allocate(nttra(mtetra,4))
          call prepare_nttra(nxyz_tetra,mtetra,nttra)
          allocate(dos_weight2(neg,np2))
          if(icomponent == TOTAL) then
             dos_weight2 = 1.d0
          else
             do ik = 1, np2
                ikt = nspin*(ik-1)+ispin
                do ib = 1, neg
                   dos_weight2(ib,ik) = dos_weight(ib,ikt)
                end do
             end do
          end if
          call care_of_degenerate_state(neig,np2,nspin,ispin,eeig2,dos_weight2) !dos_weight
          dos_weight2 = dos_weight2*wei
          dos(:,ispin) = 0.d0
          sumdos(:,ispin) = 0.d0
          call nstt5i(ipridos,idim,Eminimum,Emaximum,nEwindows,nxyz_tetra,np2,np2 &
               &   ,  neig,eeig2(1,1,ispin) &
               &   ,  ip20,np0,np2,neig,mtetra,nttra,deltae_dos,dos_weight2 &
               &   ,  nEwindows_plus,doswk,dosinwk,dos(0,ispin),sumdos(0,ispin))

          if(icomponent == TOTAL .and. sw_pdos == ON) then
             do iorb = 1, nlmta_phi
                call m_PP_tell_iorb_lmtt(iorb,lmtt)
                do ik = 1, np2
                   ikorb=nspin*(ik-1)+ispin
                   do ib = 1, neg
                      porb = 0.d0
!!$ASASASASAS
!!$                      do iopr=1,nopr
!!$                         porb = porb + (   compr(ib,iorb,iopr,ikorb)**2 &
!!$                              &          + compi(ib,iorb,iopr,ikorb)**2) &
!!$                              &        *(1.d0+qorb(iorb)/norm_phig_mpi(lmt,ik))
!!$                      end do
                      if ( k_symmetry(ik) == GAMMA ) then
                         do iopr=1,nopr
                            porb = porb + compr(ib,iorb,iopr,ikorb)**2 /2.0 &
                             &   *(1.d0+qorb(iorb)/(norm_phig_mpi(lmtt,ik)*2.) )
                         end do
                      else
                         do iopr=1,nopr
                            porb = porb + ( compr(ib,iorb,iopr,ikorb)**2 &
                                 &      + compi(ib,iorb,iopr,ikorb)**2) &
                                 &    *(1.d0+qorb(iorb)/norm_phig_mpi(lmtt,ik))
                         end do
                      endif
!!$ASASASASAS
                      dos_weight2(ib,ik) = porb/dble(nopr)*wei
                   end do
                end do
                call care_of_degenerate_state(neig,np2,nspin,ispin,eeig2,dos_weight2) !dos_weight
                call nstt5i(ipridos,idim,Eminimum,Emaximum,nEwindows,nxyz_tetra,np2 &
                     &   ,  np2,neig,eeig2(1,1,ispin) &
                     &   ,  ip20,np0,np2,neig,mtetra,nttra,deltae_dos,dos_weight2 &
                     &   ,  nEwindows_plus,doswk,dosinwk,pdos(0,iorb,ispin),sumpdos(0,iorb,ispin))
             end do
          end if
          deallocate(dos_weight2)
          deallocate(nttra)
          deallocate(dosinwk,doswk)
       !np2: #kpoints independent
       !np0: #all kpoints
!!$       call doscal_nstt(nEwindows,nxyz_tetra,np2,neig,eeig2(1,1,ispin),ip20,np0,wei,cdos,cind)

       end if
    end do

    deallocate(eeig2)

    if(icomponent == TOTAL) call get_VBM(totch,1.d-12)  ! -> ValenceBandMaximum
    if(mype == 0) call write_dos(nfdos)
    if(mype == 0 .and. icomponent == TOTAL .and. sw_pdos == ON) call write_pdos(nfdos)

    call dealloc_dos()
    call tstatc0_end(id_sname)
!!$#endif
  end subroutine m_ESdos_tetrahedral


! ============================= added by K. Tagami ======================= 11.0
  subroutine m_ESdos_tetrahedral_noncl(nfdos,icomponent,mode)

    integer, intent(in) ::  nfdos, mode,icomponent
!!$#ifndef NO_TETRAHEDRON
    real(kind=DP), parameter :: delta = 1.d-12
    integer, parameter       :: idim = 3
    integer        :: neig, ip2, ik, ip, ib, jb, ie
    real(kind=DP)  :: et,wei,clpm
    real(kind=DP), pointer, dimension(:,:,:)   :: eeig2, eeig2_mpi
    real(kind=DP), allocatable,dimension(:,:)  :: dos_weight2 ! d(neg,np2)

    real(kind=DP), pointer, dimension(:,:,:,:) :: compr, compr_mpi
    real(kind=DP), pointer, dimension(:,:,:,:) :: compi, compi_mpi
    real(kind=DP), pointer, dimension(:,:) :: norm_phig_mpi, norm_phig_mpi2
    real(kind=DP), pointer, dimension(:) :: eawk,cdwk,cswk,e
    real(kind=DP), allocatable, dimension(:,:) ::  e_mpi,e_mpi2

    real(kind=DP), pointer, dimension(:,:,:) :: cdos,cind
    real(kind=DP), allocatable, dimension(:,:) :: doswk,dosinwk
    integer, allocatable, dimension(:,:) :: nttra ! d(mtetra,4)
    integer ::                                  id_sname = -1
    integer :: i, iorb,iopr, lmtt, ipridos_t, nEwindows_plus, mtetra, iloop
    integer, parameter :: ncl = 8

! -------
    complex(kind=CMPLDP), allocatable :: porb_ssrep(:,:)
    complex(kind=CMPLDP), allocatable :: porb_ssrep5(:,:,:)
    real(kind=DP), allocatable :: porb(:,:)
    real(kind=DP), allocatable :: dos_weight3(:,:,:)
!
    integer :: is1, is2, istmp, ismax
    complex(kind=CMPLDP) :: z1, z2, ztemp
! ---

    call tstatc0_begin('m_ESdos_tetrahedral_noncl ', id_sname)

    if(mode /= SCF .and. mode /= EK) then
       write(nfout,'(" !dos:  mode = ",i6," <<m_ESdos_tetrahedral_noncl>>")') mode
       return
    end if

    if(npes > 1) then
       if(mype == 0) ipridos_t = ipridos
       call mpi_bcast(ipridos_t, 1, mpi_integer, 0, mpi_comm_group, ierr)
    else
       ipridos_t = ipridos
    end if

! --------------------------------------------------------
    if (ipridos_t >= 3) then
       if (printable) then
          write(nfout,'(" !dos: np2, np0 = ",2i7," <<m_ESdos_tetrahedral_noncl>>")') &
               &      np2, np0
       endif

       allocate(e_mpi(neg,kv3)); allocate(e_mpi2(neg,kv3))

       if (printable) then
          write(nfout,'(" !dos: icomponent = ",i9," <<m_ESdos_tetrahedral_noncl>>")') &
               &      icomponent
       endif

       if(printable) write(nfout,'(" !dos: --energy_eigenvalue--")')
       e_mpi = 0.d0; e_mpi2 = 0.d0

       do ik = 1, kv3, ndim_spinor
          if (map_k(ik) /= myrank_k) cycle
          do ie = 1, neg
             ip = neordr(ie,ik)
             if (map_e(ip) == myrank_e) e_mpi(ie,ik) = eko_l(map_z(ip),ik)
          end do
       end do

       if (npes >=2) then
          call mpi_allreduce( e_mpi, e_mpi2, neg*kv3, mpi_double_precision, &
               &              mpi_sum, mpi_comm_group, ierr )
          e_mpi = e_mpi2
       end if
       if (printable) then
          do ik = 1, kv3, ndim_spinor
             write(nfout,'(" !dos:  ik = ",i7)') ik
             write(nfout,'(" !dos: ",8f10.6)') (e_mpi(ie,ik),ie=1,neg)
          end do
       end if
       deallocate(e_mpi,e_mpi2)
    end if
! --------------------------------------------------

    allocate( eeig2(np2,neg,1) ); eeig2 = 0.d0
    if (icomponent == TOTAL .and. sw_pdos == ON) then
       allocate( compr(neg,nlmta_phi,nopr,np2*ndim_spinor));  compr = 0.d0
       allocate( compi(neg,nlmta_phi,nopr,np2*ndim_spinor));  compi = 0.d0
       allocate( norm_phig_mpi(nlmtt_phi,np2));  norm_phig_mpi = 0.d0
    end if

    if (mode==EK .and. ipridos_t >= 1) then
       write(nfout,'(" !dos eko_ek ")')
       do ip2=1,np2
          ik = ndim_spinor*( ip2 -1 ) +1
          write(nfout,'(" !dos -- ik = ",i5)') ik
          write(nfout,'(" !dos ",8f8.4)')( eko_ek(ib,ik),ib=1,neg)
       end do
    end if

    neig=neg

! -------------------------------------------------------
    Do ip2=1, np2
       ik = ndim_spinor *(ip2-1) +1

       if(mode == EK) then
          do ib=1,neg
             eeig2(ip2,ib,1)=eko_ek(ib,ik)
          enddo
          do ib = 1,neg-1
             do jb = ib+1, neg
                if ( eeig2(ip2,jb,1) < eeig2(ip2,ib,1)-delta) then
                   et = eeig2(ip2,ib,1)
                   eeig2(ip2,ib,1) = eeig2(ip2,jb,1)
                   eeig2(ip2,jb,1) = et
                end if
             end do
          end do
       else if(mode == SCF) then
          if(map_k(ik) /= myrank_k) cycle

          do ib = 1, neg
             ip = neordr(ib,ik)
             if (map_e(ip) == myrank_e) then
                eeig2(ip2,ib,1) = eko_l(map_z(ip),ik)
                if (icomponent == TOTAL .and. sw_pdos == ON) then

                   Do is1=1, ndim_spinor
                      compr(ib,1:nlmta_phi,1:nopr,ik+is1-1) &
                           &  = compr_l(map_z(ip),1:nlmta_phi,1:nopr,ik+is1-1)
                      
                      if ( k_symmetry(ik) /= GAMMA ) then
                         compi(ib,1:nlmta_phi,1:nopr,ik+is1-1) &
                              &  = compi_l(map_z(ip),1:nlmta_phi,1:nopr,ik+is1-1)
                      else
                         stop "Not supported : Gamma symmetry in noncollinear"
                      endif
                   End do
                   norm_phig_mpi(1:nlmtt_phi,ip2) = norm_phig(1:nlmtt_phi,ip2)
                end if
             end if
          enddo
       end if

    End do
! -------------------------------------------------------

    if (mode == SCF) then
       if (npes >= 2) then
          allocate(eeig2_mpi(np2,neg,1)); eeig2_mpi = 0.d0
          call mpi_allreduce( eeig2, eeig2_mpi, np2*neg, mpi_double_precision, &
               &              mpi_sum, mpi_comm_group, ierr )
          eeig2 = eeig2_mpi
          deallocate(eeig2_mpi)

          if (icomponent == TOTAL .and. sw_pdos == ON) then
            allocate( compr_mpi(neg,nlmta_phi,nopr,np2*ndim_spinor) ); compr_mpi=0.d0
            allocate( compi_mpi(neg,nlmta_phi,nopr,np2*ndim_spinor) ); compi_mpi=0.d0
            allocate( norm_phig_mpi2(nlmtt_phi,np2) ); norm_phig_mpi2 = 0.d0
            call mpi_allreduce( compr, compr_mpi, neg*nlmta_phi*nopr*np2*ndim_spinor,&
                 &              mpi_double_precision, mpi_sum, mpi_comm_group, ierr )
            call mpi_allreduce( compi,compi_mpi, neg*nlmta_phi*nopr*np2*ndim_spinor, &
                 &              mpi_double_precision, mpi_sum, mpi_comm_group, ierr )
            call mpi_allreduce( norm_phig_mpi, norm_phig_mpi2, nlmtt_phi*np2, &
                 &              mpi_double_precision, mpi_sum, mpi_comm_group, ierr )

            compr = compr_mpi;    compi = compi_mpi
            norm_phig_mpi = norm_phig_mpi2 / dble(nrank_e)
            deallocate(compr_mpi,compi_mpi,norm_phig_mpi2)
          end if

       end if
    end if

! ------------------------------------------------------------
    if (ipridos >= 2) then

       write(nfout,'(" !dos: --eeig2(energy_eigenvalue)--")')
       iloop = (neg-1)/ncl+1

       do ip2 = 1, np2
          do i = 1, iloop
             write(nfout,'(" !dos: (",i5,") ",8f9.5)') &
                  & ip2,(eeig2(ip2,ib,1),ib=ncl*(i-1)+1,min(neg,ncl*i))
          end do
       end do

       if (sw_pdos == ON) then

          do ip2 = 1, np2 
             ik = ndim_spinor *(ip2-1) + 1

             write(nfout,'(" !dos:  ip2 = ",i7)') ip2
             write(nfout,'(" !dos norm_phig: ",10f8.4)') &
                  & norm_phig_mpi(1:nlmtt_phi,ip2)
             
             do iopr=1,nopr
                do iorb=1,nlmta_phi
                   write(nfout,'(" !dos: ik=",i5," iopr=",i5," iorb=",i5)')&
                        &  ik, iopr, iorb
                   write(nfout,'(" !dos compr: ",10f8.4)') &
                        & compr(1:neg,iorb,iopr,ik)
                   write(nfout,'(" !dos compi: ",10f8.4)') &
                        & compi(1:neg,iorb,iopr,ik)
                end do
             end do
          end do
       end if

    end if
! -----------------------------------------------------

    if (mode == EK) then
       
       allocate( e_mpi( neg,kv3_ek/ndim_spinor) );   e_mpi = 0.d0;

       do ip2=1, np2
          ik = ( ip2 -1 )*ndim_spinor + 1
          e_mpi( :, ip2 ) = eko_ek( :, ik )
       end do
       call find_Erange( e_mpi, neg, kv3_ek /ndim_spinor )
       deallocate( e_mpi )

    else
       Eminimum = minval(eeig2) - 0.005 ! (hartree)
       Emaximum = maxval(eeig2) + 0.005 ! (hartree)
       nEWindows = (Emaximum - Eminimum)/DeltaE_dos + 1
    end if
       
    if (ipridos >= 2) &
         & write(nfout,'(" !dos: Emaximum, Eminimum, nEwindows = ",2f10.6,i7)') &
         &       Eminimum,Emaximum, nEWindows

    call alloc_dos(0,icomponent)

! ----------------------------------------------------
    wei = 1.d0                ! ??????????????? 2.0 ? docchi _
 
    if(ipridos >= 2) write(nfout,*) ' === tetrahedron method', &
                &  ' for k-space integration === <<m_ESdos_tetrahedral_noncl>>'
    if(ipridos >= 2) write(nfout,'(" !m_ES_dos dos_subroutine = ",i5)') dos_subroutine

! ---------------------------------------------------

    if ( calc_dos_magmom_contrib == YES ) then
       ismax = ndim_magmom
    else
       ismax = 1
    endif
! -------------------------------------------------

    if (dos_subroutine == 3) then
       allocate(e(0:nEwindows))
       e(0:nEwindows) = (/(Eminimum + DeltaE_dos*ie,ie=0,nEWindows)/)
                      ! e(0) = Eminimum, e(1) = Eminimum+DeltaE_dos, 
                      ! e(2) = Eminimum+DeltaE_dos*2,...
       
       allocate(cdos(np2,neg,0:nEWindows)); cdos = 0.d0
       allocate(cind(np2,neg,0:nEWindows)); cind = 0.d0
       allocate(eawk(np0)); eawk = 0.d0
       allocate(cdwk(np0)); cdwk = 0.d0
       allocate(cswk(np0)); cswk = 0.d0

       call nstt3i(idim,nEwindows,e,nxyz_tetra(1),nxyz_tetra(2),nxyz_tetra(3) &
            &  ,np2,np2,neig,eeig2(1,1,1) &
            &  ,ip20,np0,eawk,cdwk,cswk,np2,neig,cdos,cind,width_tetra ) ! -> cdos, cind
       deallocate(cswk,cdwk,eawk)

       clpm = 1.d0

       if (icomponent == TOTAL .and. sw_pdos == ON) then
          allocate( porb_ssrep( nlmta_phi, ndim_chgpot ) ); porb_ssrep = 0.0d0
          allocate( porb( nlmta_phi, ndim_magmom ) ); porb = 0.0d0
       endif

       do ip2 = 1, np2
          ik = ndim_spinor *(ip2-1) +1

          do ib = 1, neg
             
             Do istmp=1, ismax
                clpm = dos_weight_noncl( ib,ik,istmp )

                do ie = 0, nEwindows
                   dos(ie,istmp) = dos(ie,istmp) + cdos(ip2,ib,ie)*clpm*wei
                   sumdos(ie,istmp) = sumdos(ie,istmp) + cind(ip2,ib,ie)*clpm*wei
                end do
             End do

             if (icomponent == TOTAL .and. sw_pdos == ON) then
                clpm = 1.0d0
                porb_ssrep = 0.d0

! -----------------
                Do iorb = 1,nlmta_phi
                   call m_PP_tell_iorb_lmtt(iorb,lmtt)

                   if ( k_symmetry(ik) == GAMMA ) then
                      stop 'Not supported '
                   else

                      Do is1=1, ndim_spinor
                         Do is2=1, ndim_spinor
                            istmp = ( is1 -1 )*ndim_spinor + is2
                            
                            ztemp = 0.0d0
                            do iopr=1,nopr
                               z1 = dcmplx( compr(ib,iorb,iopr,ik+is1-1 ), &
                                    &       compi(ib,iorb,iopr,ik+is1-1 ) )
                               z2 = dcmplx( compr(ib,iorb,iopr,ik+is2-1 ), &
                                    &       compi(ib,iorb,iopr,ik+is2-1 ) )
                               ztemp = ztemp + z1 *conjg(z2) &
                                    &      *( 1.d0+qorb(iorb)/norm_phig_mpi(lmtt,ip2) )
                            end do
                            
                            porb_ssrep(iorb,istmp) = porb_ssrep(iorb,istmp) &
                                 &                   + ztemp /dble(nopr)
                         End do
                      End do
                   endif
                End Do
! ---------------------
                call m_ES_DensMat_To_MagMom_porb( nlmta_phi, porb_ssrep, porb )

                do ie = 0, nEwindows
                   pdos(ie,iorb,:) = pdos(ie,iorb,:) &
                        &           + cdos(ip2,ib,ie) *wei *porb(iorb,:)
                   sumpdos(ie,iorb,:) = sumpdos(ie,iorb,:) &
                        &           + cind(ip2,ib,ie) *wei *porb(iorb,:)
                end do

             end if
          end do
       end do

       deallocate(cind,cdos);     deallocate(e)
       if ( allocated( porb ) ) deallocate( porb )
       if ( allocated( porb_ssrep ) ) deallocate( porb_ssrep )

! ---------------------------------------------------
    else if(dos_subroutine == 4) then
       allocate(cdos(0:nEwindows,np2,neg)); cdos = 0.d0
       allocate(cind(0:nEwindows,np2,neg)); cind = 0.d0
       nEwindows_plus = nEwindows

       if(mod(nEwindows_plus,2)==1) nEwindows_plus = nEwindows_plus+1
       allocate(doswk(0:nEwindows_plus,4))
       allocate(dosinwk(0:nEwindows_plus,4))
       mtetra = product(nxyz_tetra(1:3))*6

       allocate(nttra(mtetra,4))
       call prepare_nttra(nxyz_tetra,mtetra,nttra)
       write(nfout,'(" !dos after prepare_nttra")')
       write(nfout,'(" !dos neig = ",i5)') neig

       cdos = 0.d0; cind =0.d0
       call nstt4i(ipridos,idim,nEwindows,nxyz_tetra,np2,np2,neig,eeig2(1,1,1) &
            &   ,  ip20,np0,np2,neig,mtetra,nttra,deltae_dos &
            &   ,  nEwindows_plus,doswk,dosinwk,cdos,cind)
       deallocate(nttra);     deallocate(dosinwk,doswk)

       clpm = 1.d0

       do ip2 = 1,np2
          ik = ndim_spinor*(ip2-1) +1

          do ib = 1, neg
             Do istmp=1, ismax
                clpm = dos_weight_noncl(ib,ik,istmp)
                                       ! clpm -> clpm(ib,ik)
                do ie = 0, nEwindows
                   dos(ie,istmp) = dos(ie,istmp) + cdos(ie,ip2,ib)*clpm*wei
                   sumdos(ie,istmp) = sumdos(ie,istmp) + cind(ie,ip2,ib)*clpm*wei
                end do
             End do
          end do
       end do

       if (icomponent == TOTAL .and. sw_pdos == ON) then
          allocate( porb_ssrep( nlmta_phi, ndim_chgpot ) ); porb_ssrep = 0.0d0
          allocate( porb( nlmta_phi, ndim_magmom ) ); porb = 0.0d0

          do ip2 = 1,np2
             ik = ndim_spinor *(ip2-1) +1

             do ib = 1, neg
                porb_ssrep = 0.d0

                do iorb = 1,nlmta_phi
                   call m_PP_tell_iorb_lmtt(iorb,lmtt)

                   if ( k_symmetry(ik) == GAMMA ) then
                      stop 'Not supported '
                   else
                      Do is1=1, ndim_spinor
                         Do is2=1, ndim_spinor
                            istmp = ( is1 -1 )*ndim_spinor + is2

                            ztemp = 0.0d0
                            do iopr=1,nopr
                               z1 = dcmplx( compr(ib,iorb,iopr,ik+is1-1 ), &
                                    &       compi(ib,iorb,iopr,ik+is1-1 ) )
                               z2 = dcmplx( compr(ib,iorb,iopr,ik+is2-1 ), &
                                    &       compi(ib,iorb,iopr,ik+is2-1 ) )
                               ztemp = ztemp + z1 *conjg(z2) &
                                    &      *( 1.d0+qorb(iorb)/norm_phig_mpi(lmtt,ip2) )
                            end do

                            porb_ssrep(iorb,istmp) = porb_ssrep(iorb,istmp) &
                                 &                   + ztemp /dble(nopr)
                         End do
                      End do
                   end if
                End do
! -----                      
                call m_ES_DensMat_To_MagMom_porb( nlmta_phi, porb_ssrep, porb )
!
                do ie = 0, nEwindows
                   pdos(ie,iorb,:) = pdos(ie,iorb,:) &
                        &           + cdos(ie,ip2,ib) *wei *porb(iorb,:)
                   sumpdos(ie,iorb,:) = sumpdos(ie,iorb,:) &
                        &           + cind(ie,ip2,ib) *wei *porb(iorb,:)
                end do
             end do
          end do

          deallocate( porb ); deallocate( porb_ssrep )
       end if

       deallocate(cind,cdos)

! ---------------------------------------------------------------
    else if(dos_subroutine == 5) then
       nEwindows_plus = nEwindows
       if(mod(nEwindows_plus,2)==1) nEwindows_plus = nEwindows_plus+1
       allocate(doswk(0:nEwindows_plus,4))
       allocate(dosinwk(0:nEwindows_plus,4))
       mtetra = product(nxyz_tetra(1:3))*6
       
       allocate(nttra(mtetra,4))
       call prepare_nttra(nxyz_tetra,mtetra,nttra)
       allocate(dos_weight2(neg,np2))
          
       Do istmp=1, ismax

          do ip2 = 1, np2
             ik = ndim_spinor *(ip2-1) +1
             do ib = 1, neg
                dos_weight2(ib,ip2) = dos_weight_noncl(ib,ik,istmp)
             end do
          end do

          call care_of_degenerate_state( neig, np2, 1, 1, eeig2, dos_weight2 )
                                                       !dos_weight

          dos_weight2 = dos_weight2*wei

          dos(:,istmp) = 0.d0;           sumdos(:,istmp) = 0.d0

          call nstt5i(ipridos,idim,Eminimum,Emaximum,nEwindows,nxyz_tetra,np2,np2 &
               &   ,  neig,eeig2(1,1,1) &
               &   ,  ip20,np0,np2,neig,mtetra,nttra,deltae_dos,dos_weight2 &
               &   ,  nEwindows_plus,doswk,dosinwk,dos(0,istmp),sumdos(0,istmp) )
       End do

       if (icomponent == TOTAL .and. sw_pdos == ON) then
          
          allocate( porb_ssrep5( neg, np2, ndim_chgpot ) ); porb_ssrep5 = 0.0d0
          allocate( dos_weight3( neg, np2, ndim_magmom ) ); dos_weight3 = 0.0d0

          do iorb = 1, nlmta_phi
             call m_PP_tell_iorb_lmtt(iorb,lmtt)

             porb_ssrep5 = 0.0d0
! ---------------
             do ip2 = 1, np2
                ik = ndim_spinor*( ip2 -1 ) +1

                do ib = 1, neg
                   if ( k_symmetry(ik) == GAMMA ) then
                      stop 'Not supported '
                   else
                      Do is1=1, ndim_spinor
                         Do is2=1, ndim_spinor
                            istmp = ( is1 -1 )*ndim_spinor + is2

                            ztemp = 0.0d0
                            do iopr=1,nopr
                               z1 = dcmplx( compr(ib,iorb,iopr,ik+is1-1 ), &
                                    &       compi(ib,iorb,iopr,ik+is1-1 ) )
                               z2 = dcmplx( compr(ib,iorb,iopr,ik+is2-1 ), &
                                    &       compi(ib,iorb,iopr,ik+is2-1 ) )
                               ztemp = ztemp + z1 *conjg(z2) &
                                    &      *( 1.d0+qorb(iorb)/norm_phig_mpi(lmtt,ip2) )
                            end do

                            porb_ssrep5(ib,ip2,istmp) = porb_ssrep5(ib,ip2,istmp) &
                                 &                   + ztemp /dble(nopr)
                         End do
                      End Do

                   endif

                end do
             end do
! ---------------
             call m_ES_DensMat_To_MagMom_porb( np2*neg, porb_ssrep5, dos_weight3 )
             dos_weight3 = dos_weight3 *wei
! ------------------------------------ - - -- - 
             Do istmp=1, ndim_magmom
                call care_of_degenerate_state( neig, np2, 1, 1, eeig2, &
                     &                         dos_weight3(:,:,istmp) )
                                                               !dos_weight
                call nstt5i( ipridos, idim, Eminimum, Emaximum, nEwindows, &
                     &       nxyz_tetra, np2, np2, neig, eeig2(1,1,1), &
                     &       ip20, np0, np2, neig, mtetra, nttra, deltae_dos, &
                     &       dos_weight3(:,:,istmp), nEwindows_plus, &
                     &       doswk, dosinwk, pdos(0,iorb,istmp), &
                     &       sumpdos(0,iorb,istmp) )
             End Do

          end do
          
          deallocate( dos_weight3 );  deallocate( porb_ssrep5 )

       end if

       deallocate(dos_weight2);    deallocate(nttra);  deallocate(dosinwk,doswk)
    end if
! ----------------------------------------------------------

    deallocate(eeig2)

    if(icomponent == TOTAL) call get_VBM(totch,1.d-12)  ! -> ValenceBandMaximum

    if(mype == 0) then
       if ( calc_dos_magmom_contrib == YES ) then
          call write_dos_noncl(nfdos)
       else
          call write_dos_noncl_for_totchg(nfdos)
       endif
    endif

    if(mype == 0 .and. icomponent == TOTAL .and. sw_pdos == ON) then
       call write_pdos_noncl(nfdos)
    endif

    call dealloc_dos()
    call tstatc0_end(id_sname)
!!$#endif
  end subroutine m_ESdos_tetrahedral_noncl
! ==================================================================== 11.0

  subroutine doscal_nstt(nEwindows,nxyz_tetra,np2,neg,eeig2,ip20,np0,wei,cdos,cind)
    integer, intent(in) :: nEwindows, np2, neg, np0
    integer, intent(in), dimension(3) :: nxyz_tetra
    real(kind=DP), intent(in), dimension(np2,neg) ::eeig2
    integer, intent(in), dimension(np0) :: ip20
    real(kind=DP), intent(in)           :: wei
    real(kind=DP), dimension(np2,neg,0:nEwindows) :: cdos, cind

    integer :: mtetra
    integer, allocatable, dimension(:,:)     :: nttra  ! d(mtetra,4)
    integer, allocatable, dimension(:)       :: ip8    ! d(8)
    real(kind=DP), allocatable, dimension(:) :: voltt  ! d(mtetra)
    real(kind=DP), allocatable, dimension(:,:) :: vctk, vwork ! d(4,3)
    integer, allocatable, dimension(:)       :: k_sample_mesh !d(3)
    real(kind=DP), dimension(4)              :: e
    integer, parameter :: D12 = 1, D13 = 2, D14 = 3, D23 = 4, D24 = 5 &
         &         , D34 = 6, DM  = 7, DA  = 8, mdoswk = da
    real(kind=DP), allocatable, dimension(:,:) :: dos ! d(nEwindows,neg)
    real(kind=DP), allocatable, dimension(:)   :: d

    integer :: ix,iy,iz,icub,npx,npy,ni,ip0,kx,ky,kz,nx1,ny1,nz1,nd,nn,nt,i,j,nxx,nyy,nzz,nv(3),iv,ib,ie
    integer :: iswap1, iswap2, ns, ne, idos
    real(kind=DP) :: sumv,es,ee,v,x,f0,f1,f2,f3,ed

    mtetra = product(nxyz_tetra(1:3))*6
    allocate(nttra(mtetra,4))
    allocate(voltt(mtetra))

    allocate(ip8(8))
    npx = nxyz_tetra(1)+1
    npy = nxyz_tetra(2)+1
    icub = 0
    do iz = 0, nxyz_tetra(3)-1
       do iy = 0, nxyz_tetra(2)-1
          do ix = 0, nxyz_tetra(1)-1
             icub = icub+1
             ni=npx*(npy*iz+iy)+ix
             do kz=1,2
                do ky=1,2
                   do kx=1,2
                      ip0 = ni+npx*(npy*(kz-1)+ky-1)+kx
                      ip8(kx+2*(ky-1)+4*(kz-1)) = ip0
                   end do
                end do
             end do
             nttra((icub-1)*6+1, 1:4) = (/ip8(1),ip8(2),ip8(4),ip8(8)/)
             nttra((icub-1)*6+2, 1:4) = (/ip8(1),ip8(2),ip8(6),ip8(8)/)
             nttra((icub-1)*6+3, 1:4) = (/ip8(1),ip8(5),ip8(6),ip8(8)/)
             nttra((icub-1)*6+4, 1:4) = (/ip8(1),ip8(3),ip8(4),ip8(8)/)
             nttra((icub-1)*6+5, 1:4) = (/ip8(1),ip8(3),ip8(7),ip8(8)/)
             nttra((icub-1)*6+6, 1:4) = (/ip8(1),ip8(5),ip8(7),ip8(8)/)
          end do
       end do
    end do
    deallocate(ip8)

    nxx = nxyz_tetra(1)
    nyy = nxyz_tetra(2)
    nzz = nxyz_tetra(3)
    allocate(k_sample_mesh(3))
    call m_Kp_sample_mesh(k_sample_mesh)
    nx1 = max(k_sample_mesh(1),1)
    ny1 = max(k_sample_mesh(2),1)
    nz1 = max(k_sample_mesh(3),1)
    deallocate(k_sample_mesh)
    nd = nx1*ny1*nz1
    if(ipridos >=2 ) write(nfout,'(" nd = ",i8)') nd
    allocate(vctk(4,3),vwork(4,3))
    if(ipridos>=2) write(nfout,'(" trmat = ",9f8.4)') trmat
    sumv = 0.d0
    do nt = 1, mtetra
       if(ipridos>=2) write(nfout,'(" nt = ",i8," : ",4i8)') nt, nttra(nt,1:4)
       do i = 1,4
          nn = nttra(nt,i)
          ix = mod(nn-1,nxx+1)
          iy = mod((nn-ix-1)/(nxx+1),nyy+1)
          iz = (nn-ix-1-iy*(nxx+1))/((nxx+1)*(nyy+1))
          nv(1) = ix*ny1*nz1; nv(2) = nx1*iy*nz1; nv(3) = nx1*ny1*iz
          if(ipridos >=2) write(nfout,'("  nvtk(",i4,",1:3) = ",3i8)') i,nv(1:3)
          vctk(i,1:3) = matmul(trmat,nv)/dble(nd)
       end do
       if(ipridos >=2) then
          write(nfout,'("  v(1) = ",3f8.4)') vctk(1,1:3)
          write(nfout,'("  v(2) = ",3f8.4)') vctk(2,1:3)
          write(nfout,'("  v(3) = ",3f8.4)') vctk(3,1:3)
          write(nfout,'("  v(4) = ",3f8.4)') vctk(4,1:3)
       end if

       do j = 1, 3
          vwork(1,j) = vctk(4,j) - vctk(1,j)
          vwork(2,j) = vctk(4,j) - vctk(2,j)
          vwork(3,j) = vctk(4,j) - vctk(3,j)
       enddo
       !     outer production
       vwork(4,1) = vwork(1,2)*vwork(2,3) - vwork(1,3)*vwork(2,2)
       vwork(4,2) = vwork(1,3)*vwork(2,1) - vwork(1,1)*vwork(2,3)
       vwork(4,3) = vwork(1,1)*vwork(2,2) - vwork(1,2)*vwork(2,1)
       !     inner procution
       voltt(nt) = dabs(dot_product(vwork(3,1:3),vwork(4,1:3)))/6.d0
       sumv = sumv + voltt(nt)
       if(ipridos >= 2) write(nfout,'(3x,i3,2x,f18.12)') nt,voltt(nt)
    end do
    if(ipridos >= 2) write(nfout,'(" sumv = ",f16.8, " univol*sumv/(2pi)**3 = ",f16.8)') sumv,univol*sumv/(PAI2*PAI2*PAI2)
    if(ipridos >= 2) write(nfout,'(" np2 = ",i8)') np2
    
    es = minval(eeig2)-0.005
    ee = maxval(eeig2)+0.005

    allocate(d(mdoswk))
    allocate(dos(nEwindows,neg))
    do iv = 1, mtetra
       v = 6.0d0*voltt(iv)*univol/(PAI2*PAI2*PAI2*nspin)
       write(nfout,'(" iv = ",i8," v = ",d12.4)') iv,v
       dos = 0.d0
       do ib = 1 ,neg
          do ie = 1, 4
             if(ip20(nttra(iv,ie)) > np2) then
                write(nfout,'(" nttra(iv,ie) = ",i8)') nttra(iv,ie)
             end if
             e(ie) = eeig2(ip20(nttra(iv,ie)),ib)
          end do
          do iswap1 = 1, 3
             do iswap2 = iswap1+1,4
                if(e(iswap1) < e(iswap2)) then
                   x = e(iswap1)
                   e(iswap1) = e(iswap2)
                   e(iswap2) = x
                end if
             end do
          end do
          if(e(4) > ee) cycle
          NS = (E(4) - ES)/DELTAE_dos + 1
          IF(NS.GT.nEwindows) cycle
          NE = (E(1) - ES)/DELTAE_dos + 1
          IF(NE.GT.nEwindows) NE = nEwindows

          write(nfout,'(" (iv,ib)=(",i4,",",i4,"), e = ",4f8.4," ns, ne = ",2i8)') iv,ib,e(1:4),ns,ne
          IF((NE-NS) == 0) THEN
             DOS(NS,ib) = DOS(NS,ib) + V/DELTAE_dos
          ELSE IF((NE-NS).EQ.1 ) THEN
             DOS(NS,ib) = DOS(NS,ib) + V/(2.D0*DELTAE_dos)
             DOS(NE,ib) = DOS(NE,ib) + V/(2.D0*DELTAE_dos)
          ELSE
             D(D34) = E(3) - E(4)
             D(D24) = E(2) - E(4)
             D(D14) = E(1) - E(4)
             D(D23) = E(2) - E(3)
             D(D13) = E(1) - E(3)
             D(D12) = E(1) - E(2)
             D(DM) = D(D13) + D(D24)
             D(DA) = (E(1)*E(2)-E(3)*E(4))/D(DM)

             if(d(d34).lt.deltae_dos) then
                f0 = 0.d0
             else
                f0 = v/(d(d34)*d(d24)*d(d14))
             endif

             F1 = V/D(DM)
             if(d(d23).lt.deltae_dos) then
                f2 = 0.d0
             else
                f2 = v*d(dm)/(d(d24)*d(d14)*d(d23)*d(d13))
             endif
             if(d(d12).lt.deltae_dos) then
                f3 = 0.d0
             else
                f3 = v/(d(d14)*d(d13)*d(d12))
             endif

             DO IDOS = NS, NE
                ED = ES + DELTAE_dos*(IDOS-0.5)
                IF(ED.LE.E(3)) THEN
                   DOS(IDOS,ib) = DOS(IDOS,ib) + (ED - E(4))*(ED - E(4)) * F0
                ELSE IF(ED.LE.E(2)) THEN
                   DOS(IDOS,ib) = DOS(IDOS,ib) + F1 - F2*(ED - D(DA))*(ED - D(DA))
                ELSE IF(ED.LE.E(1)) THEN
                   DOS(IDOS,ib) = DOS(IDOS,ib) + (ED - E(1))*(ED - E(1)) * F3
                ENDIF
             end DO
          ENDIF
          write(nfout,'(" tetra = ",i8," ik = ",4i8," ns,ne=",2i8)') &
               & iv, (ip20(nttra(iv,ie)),ie=1,4), ns, ne
!!$),ip20(nttra(iv,2)),ip20(nttra(iv,3)),ip20(nttra(iv,4)),ns,ne
          write(nfout,'(" dos = ",6d12.4)') (dos(idos,ib),idos=min(ns+10,ne),min(ns+15,ne))
          do ie = 1, 4
             i = ip20(nttra(iv,ie))
             do idos = ns, ne
                cdos(i,ib,idos) = cdos(i,ib,idos) + dos(idos,ib)*0.25/wei
             end do
          end do
       end do
    end do
    do i = 1, np2
       do ib = 1, neg
          cind(i,ib,1) = cdos(i,ib,1)*deltaE_dos
          do idos = 2, nEwindows
             cind(i,ib,idos) = cind(i,ib,idos-1)+cdos(i,ib,idos)*deltaE_dos
          end do
       end do
    end do
    deallocate(d)
    deallocate(dos)
    deallocate(vctk,vwork)
    deallocate(voltt,nttra)
  end subroutine doscal_nstt
 
  subroutine m_ESdos_rd_pdos_param(nfout)
    use m_Const_Parameters, only : FMAXVALLEN, ON, NOCONV, LOWER &
          &                      , Projector, Wavefunction, Mulliken
    use m_Ionic_System, only : speciesname,ntyp
    integer, intent(in) :: nfout

    character(len=FMAXVALLEN) :: rstr
    integer :: iret, f_selectBlock, f_getStringValue, f_getIntValue
    integer :: f_selectTop, f_selectParentBlock
    real(kind=DP) :: dret
    logical :: prealloc, tag_is_found
    integer :: i,it,n

    iret = f_selectTop()

    if( f_selectBlock(tag_postprocessing) == 0) then

! --- pdos
       if( f_selectBlock(tag_pdos) == 0) then
          if(f_getIntValue( tag_sw_orb_popu, iret) == 0) sw_orb_popu = iret
          if(f_getIntValue( tag_sw_pdos, iret) == 0) then
             sw_pdos = iret
             if(sw_pdos == ON) sw_orb_popu = ON
!             if ( sw_pdos == ON ) sw_dos = ON
          end if
!!$if(sw_orb_popu == ON) then
!!$   iret = f_getStringValue(tag_method,rstr,LOWER)
!!$   if( rstr == tag_projector) then
!!$      pdos_method = Projector
!!$   else if( rstr == tag_wavefunction) then
!!$      pdos_method = Wavefunction
!!$   else if( rstr == tag_mulliken) then
!!$      pdos_method = Mulliken
!!$   end if
!!$   if( f_selectBlock(tag_orbitals) == 0) then
!!$      prealloc = .true.
!!$      call set_orbitals(prealloc) ! --> norbital 
!!$      prealloc = .false.
!!$      call set_orbitals(prealloc) ! --> l_orb,t_orb
!!$      iret = f_selectParentBlock()
!!$   else
!!$      stop ' orbitals are not given properly in the inputfile'
!!$   end if
!!$end if
          if(ipriinputfile >= 1) then
             write(nfout,'(" !** sw_pdos             = ",i3)') sw_pdos
             write(nfout,'(" !** sw_orb_popu         = ",i3)') sw_orb_popu
!!$write(nfout,'(" !** pdos_method         = ",i3)') pdos_method
!!$if(sw_orb_popu == ON) then
!!$   write(nfout,'(" !** === orbitals === ")')
!!$   write(nfout,'(" !**   no   l   t   rc       k         type")')
!!$   n = 0
!!$   do it=1,ntyp
!!$      do i=1,norbital(it)
!!$         n = n + 1
!!$         write(nfout,'(" !** ",3i4,2f10.5,a6)') &
!!$           & n,l_orb(i,it),t_orb(i,it),rc_orb(i,it),k_orb(i,it),speciesname(it)
!!$      end do
!!$   end do
!!$end if
          end if
          iret = f_selectParentBlock()
       end if             ! pdos
       iret = f_selectParentBlock()
    end if

  contains

    subroutine set_orbitals(prealloc)
      logical, intent(in) :: prealloc

      character(len=FMAXVALLEN) :: rstr
      integer :: i,iret,ip,rint,it
      integer :: f_selectFirstTableLine, f_selectNextTableLine &
           &, f_getIntValue, f_getRealValue, f_getStringValue
      real(kind=DP) :: dret
      logical :: first

      if(.not.prealloc) then
         maxorb = 0
         do it=1,ntyp
            maxorb = max(maxorb,norbital(it))
         end do
         allocate(l_orb(maxorb,ntyp))
         allocate(t_orb(maxorb,ntyp))
         allocate(rc_orb(maxorb,ntyp)); rc_orb=0.d0
         allocate(k_orb(maxorb,ntyp)); k_orb=0.d0
      else
         allocate(norbital(ntyp)); norbital = 0
      end if

      do it=1,ntyp
         i = 1
         first = .true.
         do while(.true.)
            if (first) then
               if(f_selectFirstTableLine() /= 0) then
                  exit
               end if
               first = .false.
            else
               if(f_selectNextTableLine() /= 0) then
                  exit
               end if
            end if
            iret = f_getStringValue(tag_element,rstr,NOCONV)
            if(rstr == speciesname(it)) then
               if(.not.prealloc) then
                  ip = i
                  if( f_getIntValue(tag_l, rint) == 0) l_orb(ip,it) = rint
                  if( f_getIntValue(tag_t, rint) == 0) t_orb(ip,it) = rint
                  if( f_getRealValue(tag_rc, dret, 'bohr') == 0) rc_orb(ip,it) = dret
                  if( f_getRealValue(tag_k, dret, '') == 0) k_orb(ip,it) = dret
               end if
               i = i + 1
            end if

         end do
         norbital(it) = i - 1
      end do

    end subroutine set_orbitals

  end subroutine m_ESdos_rd_pdos_param

  subroutine prepare_nttra(nxyz_tetra,mtetra,nttra)
    integer, intent(in),  dimension(3)        :: nxyz_tetra
    integer, intent(in)                       :: mtetra
    integer, intent(out), dimension(mtetra,4) :: nttra

    integer :: npx,npy,icub,ix,iy,iz,ni,kx,ky,kz,ip0
    integer, allocatable, dimension(:) :: ip8

    allocate(ip8(8))
    npx = nxyz_tetra(1)+1
    npy = nxyz_tetra(2)+1
    icub = 0
    do iz = 0, nxyz_tetra(3)-1
       do iy = 0, nxyz_tetra(2)-1
          do ix = 0, nxyz_tetra(1)-1
             icub = icub+1
             ni=npx*(npy*iz+iy)+ix
             do kz=1,2
                do ky=1,2
                   do kx=1,2
                      ip0 = ni+npx*(npy*(kz-1)+ky-1)+kx
                      ip8(kx+2*(ky-1)+4*(kz-1)) = ip0
                   end do
                end do
             end do
             nttra((icub-1)*6+1, 1:4) = (/ip8(1),ip8(2),ip8(4),ip8(8)/)
             nttra((icub-1)*6+2, 1:4) = (/ip8(1),ip8(2),ip8(6),ip8(8)/)
             nttra((icub-1)*6+3, 1:4) = (/ip8(1),ip8(5),ip8(6),ip8(8)/)
             nttra((icub-1)*6+4, 1:4) = (/ip8(1),ip8(3),ip8(4),ip8(8)/)
             nttra((icub-1)*6+5, 1:4) = (/ip8(1),ip8(3),ip8(7),ip8(8)/)
             nttra((icub-1)*6+6, 1:4) = (/ip8(1),ip8(5),ip8(7),ip8(8)/)
          end do
       end do
    end do
    deallocate(ip8)
  end subroutine prepare_nttra

  subroutine care_of_degenerate_state(neig,np2,nspin,ispin,eeig2,dos_weight2)
    integer, intent(in) :: neig,np2,nspin,ispin
!!$    real(kind=DP),intent(in),dimension(neig,np2,nspin) :: eeig2
    real(kind=DP),intent(in),dimension(np2,neig,nspin) :: eeig2
    real(kind=DP),intent(inout),dimension(neig,np2) :: dos_weight2(neig,np2)
    real(kind=DP) :: eps,c1
    integer :: k2, ieig, n, i, ie
! ---- following lines are the later part of subroutine nstt3i --
!     take care of a weight on a degenerate state
!
    eps = dfloat(10)**(-5)

    do k2=1,np2
       if(ipridos >= 3) write(nfout,'(" k2 = ",i5," <<care_of_degenerate_state>>")') k2
       ieig=1
40     continue
       n=1
!!$do 42 i=1,20
       do i=1,neig
          if(ieig+i.gt.neig) go to 44
          if(dabs(eeig2(k2,ieig+i,ispin)-eeig2(k2,ieig,ispin)).lt.eps) then
             n=n+1
             cycle
          end if
          go to 44
       end do

44     continue

       if(ipridos >= 3) write(nfout,'("       n = ",i5)')  n
       c1=0
       do i=0,n-1
          if(ieig+i>neig) then
             if(ipridos>=1) write(nfout,'(" ieig+i = ",i8," > neig = ",i8)') ieig+i,neig
             cycle
          end if
          c1=c1+dos_weight2(ieig+i,k2)
       end do
       c1=c1/n
       do i=0,n-1
          if(ieig+i>neig) then
             if(ipridos>=1) write(nfout,'(" ieig+i = ",i8," > neig = ",i8)') ieig+i,neig
             cycle
          end if
          dos_weight2(ieig+i,k2)=c1
       end do
       ieig=ieig+n
       if(ieig.lt.neig) go to 40
    end do
  end subroutine care_of_degenerate_state

! ==================== added by K. Tagami ==================== 11.0
  subroutine m_ESdos_set_dos_weight_noncl()
    integer,allocatable,dimension(:,:) :: meshwk
    integer :: ik, ip, ib,j,i
    integer :: ekmode_t

    integer :: is, istmp

    real(kind=DP) :: denom, chgq0( ndim_magmom )
    real(kind=DP), allocatable, dimension(:,:) :: bfft_kt 
    real(kind=DP), allocatable, dimension(:,:) :: chgq_enl_kt(:,:,:)

    allocate( chgq_enl_kt(kgp,kimg,ndim_magmom) )
    chgq_enl_kt = 0.0d0

    denom = 1.d0/product(fft_box_size_WF(1:3,1))

    dos_weight_noncl = 0.0d0

    if ( calc_dos_magmom_contrib == NO ) then
       dos_weight_noncl( :,:,1 ) = 1.0d0
       return
    endif

! === ASMS 2017/09/04
    call m_CD_keep_retrieve_hsr(.true.)
! === ASMS 2017/09/04

    if (ekmode == ON) then
       do ik = 1, kv3, ndim_spinor
          call m_FFT_alloc_WF_work()
          allocate(bfft_kt(nfft,ndim_spinor))
          do ib = 1, neg
             bfft_kt = 0.d0
             if (map_ek(ib,ik) == mype ) then
                Do is=1, ndim_spinor
                   call m_ES_WF_in_Rspace(ik+is-1,ib,bfft_kt(:,is))
                End do
                ip = mype
             end if
             if (npes > 1) then
                call mpi_bcast( bfft_kt, nfft*ndim_spinor, mpi_double_precision,&
                     &          ip, mpi_comm_group, ierr )
             endif
             
             call set_dos_contrib_softpart(1,ib)
          end do

          deallocate(bfft_kt)
          call m_FFT_dealloc_WF_work()
          
          if (modnrm == EXECUT) then
             call m_FFT_alloc_CD_box()
             do ib = 1, neg
                call m_CD_hardpart_sub_noncl( nfout, ik, ib, chgq0 )  ! -> chgq_l
                call set_dos_contrib_hardpart( ik, ib )
             End do
             call m_FFT_dealloc_CD_box()
          end if
       end do

    else if (ekmode == OFF) then
       if (modnrm == EXECUT) call m_CD_set_ylm_enl_etc()
       
       if (hardpart_subroutine==2.or.sw_rspace_ldos==ON)then
             
          do ik = 1, kv3, ndim_spinor
             if (map_k(ik) /= myrank_k) cycle
                
             call m_FFT_alloc_WF_work()
             allocate( bfft_kt(nfft,ndim_spinor) )

             do ib = ista_e, iend_e, istep_e
                bfft_kt = 0.d0
                Do is=1, ndim_spinor
                   call m_ES_WF_in_Rspace(ik+is-1,ib,bfft_kt(:,is))
                End do
                call set_dos_contrib_softpart(ik,ib)
             end do

             deallocate(bfft_kt)
             call m_FFT_dealloc_WF_work()
                
             if (modnrm == EXECUT) then
                call m_FFT_alloc_CD_box()
                do ib = ista_e, iend_e, istep_e
                   call m_CD_hardpart_sub2_noncl( nfout, ik, ib, chgq0, &
                        &                         chgq_enl_kt )     ! -> chgq_enl
                   call set_dos_contrib_hardpart( ik, ib )
                end do
                call m_FFT_dealloc_CD_box()
             end if
                
          end do

       else

          do ik = 1, kv3, ndim_spinor
             if (map_k(ik) /= myrank_k) cycle
             call m_FFT_alloc_WF_work()
             allocate( bfft_kt(nfft,ndim_spinor) ); bfft_kt = 0.d0

             do ib = 1,neg
                if(map_e(ib)/=myrank_e) cycle
                bfft_kt = 0.d0
                Do is=1, ndim_spinor
                   call m_ES_WF_in_Rspace(ik+is-1,ib,bfft_kt(:,is))
                End do
                call set_dos_contrib_softpart(ik,ib)
             end do

             deallocate(bfft_kt)
             call m_FFT_dealloc_WF_work()
          enddo

!          if (npes > 1) call mpi_barrier(mpi_comm_group,ierr)
             
          if (modnrm == EXECUT) then
             do ik = 1, kv3, ndim_spinor
                call m_FFT_alloc_CD_box()
                do ib = 1,neg
                   call m_CD_hardpart_sub_noncl( nfout, ik, ib, chgq0 )
                   call set_dos_contrib_hardpart(ik,ib)
                end do
                call m_FFT_dealloc_CD_box()
             enddo
          endif
       endif

    end if

    if ( npes > 1 ) call allreduce_dos_weight_noncl

    if (modnrm == EXECUT) call m_CD_dealloc_ylm_enl_etc()
    if (hardpart_subroutine/=2.and.sw_rspace_ldos==OFF) call m_CD_restore_chgq()
    deallocate( chgq_enl_kt )

! === ASMS 2017/09/04
    call m_CD_keep_retrieve_hsr(.false.)
! === ASMS 2017/09/04

  contains

    subroutine set_dos_contrib_softpart(ik,ib)
      integer, intent(in) :: ik,ib

      integer :: i, nel
      integer :: is1, is2, istmp
      real(kind=DP) :: rho_magmom(ndim_magmom)
      real(kind=DP) :: c_nr(ndim_spinor,ndim_spinor)
      real(kind=DP) :: c_ni(ndim_spinor,ndim_spinor)
      real(kind=DP) :: cr, ci, denom

      real(kind=DP), allocatable :: afft_kt(:,:)

      nel = product(fft_box_size_WF(1:3,1))
      denom = 1.d0/dble(nel)

      allocate( afft_kt(nfft,ndim_magmom) );  afft_kt = 0.0d0

      do i = 1, nfft-1, 2

         Do is1 = 1, ndim_spinor
            Do is2 = 1, ndim_spinor
               istmp = ( is1 -1 )*ndim_spinor + is2            
            
               cr =    bfft_kt(i,  is1) *bfft_kt(i,  is2) &
                    & +bfft_kt(i+1,is1) *bfft_kt(i+1,is2)
               
               ci =   -bfft_kt(i,  is1) *bfft_kt(i+1,is2) &
                    & +bfft_kt(i+1,is1) *bfft_kt(i,  is2)
         
               c_nr(is1,is2) = cr;   c_ni(is1,is2) = ci
            End do
         End do
! --------------------------- convert charge from ss-rep to magmom-rep --
         rho_magmom(1) = c_nr(1,1) + c_nr(2,2);         ! ctot
         rho_magmom(2) = c_nr(1,2) + c_nr(2,1);         ! mx
         rho_magmom(3) = c_ni(2,1) - c_ni(1,2);         ! my
         rho_magmom(4) = c_nr(1,1) - c_nr(2,2);          ! mz
! -----------------------------------------------------------------------
         afft_kt(i,:) = rho_magmom(:)
      End do
!
      Do istmp=1, ndim_magmom
         call m_FFT_WF( ELECTRON, nfout, afft_kt(:,istmp), DIRECT, ON )
      End do
      Do istmp=1, ndim_magmom
         dos_weight_noncl(ib, ik, istmp) = afft_kt(1,istmp) *denom
      End Do
!
!      write(950,*) 'ik ib  ', ik, ib
!      write(950,*) 'afft = ', afft_kt(1,1)
!      write(950,*) 'dos w = ', dos_weight_noncl( ib,ik,1 )
!
    end subroutine set_dos_contrib_softpart

    subroutine set_dos_contrib_hardpart(ik,ib)
      integer, intent(in) :: ik,ib

      if ( mype == 0 ) then
         dos_weight_noncl( ib,ik,: ) = dos_weight_noncl( ib,ik,: ) &
              &                      + chgq0(:) *univol
      endif
    end subroutine set_dos_contrib_hardpart

    subroutine allreduce_dos_weight_noncl
      integer :: size1
      real(kind=DP), allocatable :: dos_weight_mpi(:,:,:)

      if ( ekmode == ON ) then
         size1 = neg *kv3_ek *ndim_magmom
         allocate( dos_weight_mpi( neg, kv3_ek, ndim_magmom ) )
      else
         size1 = neg *kv3 *ndim_magmom
         allocate( dos_weight_mpi( neg, kv3, ndim_magmom ) )
      endif
      
      dos_weight_mpi = 0.0d0
      call mpi_allreduce( dos_weight_noncl, dos_weight_mpi, size1, &
           &              mpi_double_precision, mpi_sum, mpi_comm_group, ierr )
      dos_weight_noncl = dos_weight_mpi
      deallocate(dos_weight_mpi)
    end subroutine allreduce_dos_weight_noncl

  end subroutine m_ESdos_set_dos_weight_noncl

! ============================================================ 11.0

  subroutine m_ESdos_rd_pcohp_param(nfout)
    use m_Const_Parameters, only : FMAXVALLEN, ON, LOWER
    integer, intent(in) :: nfout

    character(len=FMAXVALLEN) :: rstr
    integer :: iret, f_selectBlock, f_getStringValue, f_getIntValue, f_getRealValue
    integer :: f_selectTop, f_selectParentBlock
    real(kind=DP) :: dret
    logical :: prealloc, tag_is_found
    integer :: i,it,n

    iret = f_selectTop()

    if( f_selectBlock(tag_postprocessing) == 0) then
! ---  pcohp --
       if( f_selectBlock( tag_pcohp ) == 0) then
          if ( f_getIntValue( tag_sw_calc_pcohp, iret) == 0) sw_calc_pcohp = iret

          if ( sw_calc_pcohp == ON ) then
             if ( nopr > 1 ) stop "Nopr > 1 is no supported"

             sw_dos = ON ;  sw_pdos = ON;  orb_popu_method = 2
             if(printable) then
                write(nfout,'(A)') "!** orb_popu_method is forced to be 2"
             endif

             if ( f_getIntValue( tag_atom1, iret) == 0 ) then
                if ( iret > 0 .and. iret <= natm ) then
                   atom1_pcohp = iret
                else
                   write(*,*) "set atom1 in the range [1: ", natm ,"]"
                   stop
                endif
             endif
             if ( f_getRealValue( tag_max_distance_from_atom1, dret, "") == 0) then
                max_distance_from_atom1_pcohp = dret
             endif
             if(printable) then
                write(nfout,*) ' ** atom1 of pcohp is ', atom1_pcohp
                write(nfout,*) ' ** max_distance_from_atom1 is ', &
                     &              max_distance_from_atom1_pcohp
             endif
          endif
          iret = f_selectParentBlock()
       endif
! ----------
    end if
  end subroutine m_ESdos_rd_pcohp_param

  subroutine m_ES_calc_pcohp
    integer :: ia, ja, it1, it2
    integer :: ik, ispin, lmt1, lmt2
    integer :: i, is, ie, id
    real(kind=DP) :: c1, w, e, El, Eu, tl, tu, Es, DeltaE, distance
    complex(kind=CMPLDP) :: z1
    
    complex(kind=CMPLDP), allocatable :: mat_p(:,:,:)
    complex(kind=CMPLDP), allocatable :: mat_h(:,:)
    
    integer, parameter :: lun = 355

! --- init --
    allocate( mat_p( neg,nlmt_phi,nlmt_phi ) );
    allocate( mat_h( nlmt_phi,nlmt_phi ) );
    
    allocate( pcohp( 1:nEwindows,nlmt_phi,nlmt_phi,nspin ) ); 
    allocate( sum_pcohp( 1:nEWindows,nlmt_phi,nlmt_phi,nspin ) ); 

    DeltaE = DeltaE_dos
    Es = Eminimum - DeltaE*0.5d0

    if ( mype == 0 ) then
       open( unit=lun, file='pcohp.data', status='unknown', form ='formatted' )
    endif

! ---- begin -----
    ia = atom1_pcohp
    Do ja=1, natm
       if ( ia == ja ) cycle

       call calc_distance_from_atom1( ia, ja, distance )
       if ( distance > max_distance_from_atom1_pcohp ) cycle
       
       it1 = ityp(ia);  it2 = ityp(ja)

       pcohp = 0.0d0;     sum_pcohp = 0.0d0
       
       Do ik=1, kv3
          ispin = mod( ik -1, nspin ) +1
          call calc_matrix_p_nosym( ik, ia, ja, mat_p )
          call calc_matrix_h( ik, ia, ja, mat_p, mat_h )
          
          Do lmt1=1, ilmt_phi(it1)
             Do lmt2=1, ilmt_phi(it2)

                do i = 1, neg
                   w = 1.d0
                   z1 = mat_p(i,lmt1,lmt2) *conjg( mat_h(lmt1,lmt2) )
                   c1 = real(z1)
                   
                   e = eko(i,ik) -nETailWindows*DeltaE -Es
                   is = e /DeltaE;      ie = is +2*nETailWindows
                   
                   if (is < 0) is = 0
                   if (ie >= nEWindows )ie = nEWindows-1
                   
                   do id = is, ie
                      El = Es + id*DeltaE;    Eu = El + DeltaE
                      tl = (El -eko(i,ik))*sqrtdVI;   tu = (Eu -eko(i,ik))*sqrtdVI
                      
                      pcohp(id+1,lmt1,lmt2,ispin) = pcohp(id+1,lmt1,lmt2,ispin) &
                           & + c1 *w *2 *(derf(tu) -derf(tl)) *0.5d0 /DeltaE &
                           &            *qwgt(ik)
                   end do
                end do
             end Do
          end Do
          ! ---- integ --
          Do lmt1=1, ilmt_phi(it1)
             Do lmt2=1, ilmt_phi(it2)
                sum_pcohp(1,lmt1,lmt2,ispin) = pcohp(1,lmt1,lmt2,ispin)*DeltaE
                do id = 1, nEWindows-1
                   sum_pcohp(id+1,lmt1,lmt2,ispin) &
                        & = sum_pcohp(id,lmt1,lmt2,ispin) &
                        &   +pcohp(id+1,lmt1,lmt2,ispin) *DeltaE
                end do
             End Do
          ENd Do
          
       end Do   ! ik
       ! --
       if ( mype == 0 )  then
!          call write_pcohp_full( lun, ia, ja )
          call write_pcohp_sum_over_atom( lun, ia, ja )
       endif
    End Do
    
    ! --- finalize--
    if ( mype == 0 ) close( lun )

    deallocate( mat_p ); deallocate( mat_h )
    deallocate( pcohp ); deallocate( sum_pcohp )

  contains 
    
    subroutine calc_distance_from_atom1( ia, ja, dist_min )
      integer, intent(in) :: ia, ja
      real(kind=DP), intent(out) :: dist_min
      
      integer :: nx, ny, nz
      real(kind=DP) :: x1, y1, z1, dist
      
      dist_min = 1.0D3
      Do nx=-1, 1
         Do ny=-1, 1
            Do nz=-1, 1
               x1 = cps(ja,1) -cps(ia,1) +nx*altv(1,1) +ny*altv(1,2) +nz*altv(1,3)
               y1 = cps(ja,2) -cps(ia,2) +nx*altv(2,1) +ny*altv(2,2) +nz*altv(2,3)
               z1 = cps(ja,3) -cps(ia,3) +nx*altv(3,1) +ny*altv(3,2) +nz*altv(3,3)
               dist = sqrt( x1**2 +y1**2 +z1**2 )
               dist_min = min( dist_min, dist )
            End Do
         ENd Do
      End Do
    end subroutine calc_distance_from_atom1

  end subroutine m_ES_calc_pcohp

  subroutine write_pcohp_full( nf, ia, ja )
    integer, intent(in) :: nf, ia, ja
    
    integer :: it1, it2, lmt1, lmt2, il1, il2, im1, im2, tau1, tau2
    integer :: id, nrEWindows, ii, i, nwdwidth
    real(kind=DP) :: e, e_eV, pcohp_hr, pcohp_hr2, sum_pcohp_avr, sum_pcohp_avr2
    real(kind=DP) :: pcohp_eV, pcohp_eV2, sumtotal

    if(nwd_dos_window_width >= 1 .and. nwd_dos_window_width <= nEWindows) then
       nwdwidth = nwd_dos_window_width
    else
       nwdwidth = 1
    end if
    id = nwdwidth/2
    nrEWindows = nEWindows/nwdwidth * nwdwidth

    if ( iproj_group(ia)== 0 ) return
    if ( iproj_group(ja)== 0 ) return

    it1 = ityp(ia);     it2 = ityp(ja)

    Do lmt1=1, ilmt_phi(it1)
       il1 = ltp_phi(lmt1,it1); im1 = mtp_phi(lmt1,it1);  tau1 = taup_phi(lmt1,it1)

       Do lmt2=1, ilmt_phi(it2)
          il2 = ltp_phi(lmt2,it2); im2 = mtp_phi(lmt2,it2);  tau2 = taup_phi(lmt2,it2)

          write(nf,'(A,I5,3(A,I3),A,I5,3(A,I3))') &
               &       "-PCOHP: ia= ", ia, " l=", il1-1," m=", im1," t=", tau1, &
               &       "        ja= ", ja, " l=", il2-1," m=", im2," t=", tau2

          if (nspin == 1) then
             write(nf,*) "     E(eV)          pcohp(eV)           sum(eV)"
             do i = 1, nrEWindows, nwdwidth
                e = Eminimum + (i-1+id)*DeltaE_dos
                e_eV = (e - ValenceBandMaximum)*Hartree
                pcohp_hr = 0.d0;  sum_pcohp_avr = 0.d0

                do ii = i, i+nwdwidth-1
                   pcohp_hr = pcohp_hr + pcohp(ii,lmt1,lmt2,nspin)
                   sum_pcohp_avr = sum_pcohp_avr + sum_pcohp(ii,lmt1,lmt2,nspin)
                end do
                pcohp_hr = pcohp_hr /nwdwidth;  
                sum_pcohp_avr = sum_pcohp_avr /nwdwidth
!                pcohp_eV = pcohp_hr /Hartree    ! ???
                pcohp_eV = pcohp_hr

                write(nf,'(f14.6,f18.10,f20.10)') &
                     &     e_eV, -pcohp_eV, -sum_pcohp_avr
             end do

          else if(nspin == 2) then
             write(nf,*) "   E(eV)         pcohp_up(eV)        pcohp_down(eV)" &
                  & ,"   sum_up    sum_down  sum_total"

             do i = 1, nrEWindows, nwdwidth
                e = Eminimum + (i-1+id)*DeltaE_dos
                e_eV = (e - ValenceBandMaximum)*Hartree
                pcohp_hr = 0.d0; pcohp_hr2 = 0.d0;  
                sum_pcohp_avr = 0.d0; sum_pcohp_avr2 = 0.d0

                do ii = i, i+nwdwidth-1
                   pcohp_hr  = pcohp_hr  + pcohp(ii,lmt1,lmt2,1)
                   pcohp_hr2 = pcohp_hr2 + pcohp(ii,lmt1,lmt2,2)
                   sum_pcohp_avr  = sum_pcohp_avr  + sum_pcohp(ii,lmt1,lmt2,1)
                   sum_pcohp_avr2 = sum_pcohp_avr2 + sum_pcohp(ii,lmt1,lmt2,2)
                end do
                pcohp_hr = pcohp_hr/nwdwidth; pcohp_hr2 = pcohp_hr2/nwdwidth
                sum_pcohp_avr = sum_pcohp_avr/nwdwidth; 
                sum_pcohp_avr2 = sum_pcohp_avr2/nwdwidth

!                pcohp_eV  = pcohp_hr/Hartree
!                pcohp_eV2 = pcohp_hr2/Hartree
                pcohp_eV  = pcohp_hr; 
                pcohp_eV2 = pcohp_hr2
                sumtotal = sum_pcohp_avr + sum_pcohp_avr2
                write(nf,'(f15.4,2f18.10,3f10.4)') &
                     &    e_eV, -pcohp_eV, -pcohp_eV2, &
                     &    -sum_pcohp_avr, -sum_pcohp_avr2, -sumtotal
             end do
          end if
          write(nf,*) 'END'
       end Do
    end Do

  end subroutine write_pcohp_full

  subroutine write_pcohp_sum_over_atom( nf, ia, ja )
    integer, intent(in) :: nf, ia, ja
    
    integer :: it1, it2, lmt1, lmt2, il1, il2, im1, im2, tau1, tau2
    integer :: id, nrEWindows, ii, i, nwdwidth
    real(kind=DP) :: e, e_eV, pcohp_hr, pcohp_hr2, sum_pcohp_avr, sum_pcohp_avr2
    real(kind=DP) :: pcohp_eV, pcohp_eV2, sumtotal

    if(nwd_dos_window_width >= 1 .and. nwd_dos_window_width <= nEWindows) then
       nwdwidth = nwd_dos_window_width
    else
       nwdwidth = 1
    end if
    id = nwdwidth/2
    nrEWindows = nEWindows/nwdwidth * nwdwidth

    if ( iproj_group(ia)== 0 ) return
    if ( iproj_group(ja)== 0 ) return

    it1 = ityp(ia);     it2 = ityp(ja)

    write(nf,'(A,I5,A,I5)') &
         &       "-PCOHP: ia= ", ia, "        ja= ", ja
    if (nspin == 1) then
       write(nf,*) "     E(eV)          pcohp(eV)           sum(eV)"
       do i = 1, nrEWindows, nwdwidth
          e = Eminimum + (i-1+id)*DeltaE_dos
          e_eV = (e - ValenceBandMaximum)*Hartree
          pcohp_hr = 0.d0;  sum_pcohp_avr = 0.d0

          Do lmt1=1, ilmt_phi(it1)
             Do lmt2=1, ilmt_phi(it2)
                do ii = i, i+nwdwidth-1
                   pcohp_hr = pcohp_hr + pcohp(ii,lmt1,lmt2,nspin)
                   sum_pcohp_avr = sum_pcohp_avr + sum_pcohp(ii,lmt1,lmt2,nspin)
                end do
             End Do
          End Do
          pcohp_hr = pcohp_hr /nwdwidth;  
          sum_pcohp_avr = sum_pcohp_avr /nwdwidth
!                pcohp_eV = pcohp_hr /Hartree    ! ???
          pcohp_eV = pcohp_hr
          sum_pcohp_avr = sum_pcohp_avr *Hartree

          write(nf,'(f14.6,f18.10,f20.10)') &
               &     e_eV, -pcohp_eV, -sum_pcohp_avr
       end do
    else if(nspin == 2) then
       write(nf,*) "   E(eV)         pcohp_up(eV)        pcohp_down(eV)" &
            & ,"sum_up   sum_down sum_total"
       do i = 1, nrEWindows, nwdwidth
          e = Eminimum + (i-1+id)*DeltaE_dos
          e_eV = (e - ValenceBandMaximum)*Hartree
          pcohp_hr = 0.d0; pcohp_hr2 = 0.d0;  
          sum_pcohp_avr = 0.d0; sum_pcohp_avr2 = 0.d0

          Do lmt1=1, ilmt_phi(it1)
             Do lmt2=1, ilmt_phi(it2)
                do ii = i, i+nwdwidth-1
                   pcohp_hr  = pcohp_hr  + pcohp(ii,lmt1,lmt2,1)
                   pcohp_hr2 = pcohp_hr2 + pcohp(ii,lmt1,lmt2,2)
                   sum_pcohp_avr  = sum_pcohp_avr  + sum_pcohp(ii,lmt1,lmt2,1)
                   sum_pcohp_avr2 = sum_pcohp_avr2 + sum_pcohp(ii,lmt1,lmt2,2)
                end do
             end Do
          end Do
          pcohp_hr = pcohp_hr/nwdwidth; pcohp_hr2 = pcohp_hr2/nwdwidth
          sum_pcohp_avr = sum_pcohp_avr/nwdwidth; 
          sum_pcohp_avr2 = sum_pcohp_avr2/nwdwidth

!                pcohp_eV  = pcohp_hr/Hartree
!                pcohp_eV2 = pcohp_hr2/Hartree
          pcohp_eV  = pcohp_hr
          pcohp_eV2 = pcohp_hr2

          sum_pcohp_avr  = sum_pcohp_avr  *Hartree
          sum_pcohp_avr2 = sum_pcohp_avr2 *Hartree

          sumtotal = sum_pcohp_avr + sum_pcohp_avr2
          write(nf,'(f15.4,2f18.10,3f10.4)') &
               &    e_eV, -pcohp_eV, -pcohp_eV2, &
               &    -sum_pcohp_avr, -sum_pcohp_avr2, -sumtotal
       end do
    end if
    write(nf,*) 'END'
  end subroutine write_pcohp_sum_over_atom

  subroutine calc_matrix_H( ik, ia, ja, mat_p, mat_H )
    integer, intent(in) :: ia, ja, ik
    complex(kind=CMPLDP), intent(in)  :: mat_p(neg,nlmt_phi,nlmt_phi)
    complex(kind=CMPLDP), intent(out) :: mat_h(nlmt_phi,nlmt_phi)
    
    integer :: it1, it2, lmt1, lmt2, ie
    complex(kind=CMPLDP) :: z1

    it1 = ityp(ia);     it2 = ityp(ja)

    mat_h = 0.0d0

    Do lmt1=1, ilmt_phi(it1)
       Do lmt2=1, ilmt_phi(it2)
          z1 = 0.0d0
          Do ie=1, neg
!             z1 = z1 + ( eko(ie,ik) -ValenceBandMaximum ) *mat_p(ie,lmt1,lmt2)
             z1 = z1 + eko(ie,ik) *mat_p(ie,lmt1,lmt2)
          End Do
          mat_h(lmt1,lmt2) = z1
       End Do
    End Do
  end subroutine calc_matrix_H

  subroutine calc_matrix_P_nosym( ik, ia, ja, mat_p )
    integer, intent(in) :: ia, ja, ik
    complex(kind=CMPLDP), intent(out) :: mat_p(neg,nlmt_phi,nlmt_phi)

    integer :: it1, it2, iorb1, iorb2, lmt1, lmt2, iopr1, iopr2, ie, i
    complex(kind=CMPLDP) :: porb, z1, z2
    logical :: First = .true.

    it1 = ityp(ia);     it2 = ityp(ja)

    mat_p = 0.0d0

    Do ie=1, neg
       Do lmt1=1, ilmt_phi(it1)
          iorb1 = lmta_phi(lmt1,ia)

          Do lmt2=1, ilmt_phi(it2)
             iorb2 = lmta_phi(lmt2,ja)

             porb = 0.0d0
             if ( k_symmetry(ik) == GAMMA ) then
                do iopr1=1, 1
                   porb = porb +compr(ie,iorb1,iopr1,ik) &
                        &      *compr(ie,iorb2,iopr1,ik) /2.0d0
                end do
             else
                Do iopr1=1, 1
                   z1 = cmplx( compr(ie,iorb1,iopr1,ik), compi(ie,iorb1,iopr1,ik) )
                   z2 = cmplx( compr(ie,iorb2,iopr1,ik), compi(ie,iorb2,iopr1,ik) )
                   porb = porb +conjg(z1)* z2
                end do
             endif
             mat_p( ie, lmt1, lmt2 ) = porb 

          ENd Do
       End Do
    End Do
  end subroutine calc_matrix_P_nosym

end module m_ES_dos

