!=======================================================================
!
!  PROGRAM  PHASE/0 2014.01 (rev.375)
!
!  "First-principles Electronic Structure Calculation Program"
!
!  MODULE: m_ES_IO
!
!  AUTHOR(S): T. Yamasaki   August/20/2003
!  
!  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 program set had been intensively developed as a part of the following 
!  national projects supported by the Ministry of Education, Culture, Sports, Science and 
!  Technology (MEXT) of Japan; "Frontier Simulation Software for Industrial Science 
!  (FSIS)" from 2002 to 2005, "Revolutionary Simulation Software (RSS21)" from 2006 to 
!  2008. "Research and Development of Innovative Simulation Software (RISS)" from 2008 
!  to 2013. These projects is lead by the Center for Research on Innovative Simulation 
!  Software (CISS), the Institute of Industrial Science (IIS), the University of Tokyo.
!   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_IO
! $Id: m_ES_IO.F90 324 2013-06-24 11:32:23Z yamasaki $
  use m_Electronic_Structure, only : zaj_l,neordr,nrvf_ordr,eko_l,occup_l,efermi,efermi_spin,totch&
       &                            ,vnlph_l,vlhxc_l,eko_ek
  use m_Electronic_Structure, only : m_ES_WF_in_Rspace
  use m_PlaneWaveBasisSet,    only : kgp,kg1,ngabc,nbase,iba
  use m_Kpoints,              only : kv3, vkxyz, vkxyz_ek, kv3_ek, k_symmetry, qwgt
  use m_Timing,               only : tstatc0_begin, tstatc0_end
  use m_Control_Parameters,   only : nspin,kimg,neg,num_extra_bands,af,ipri, printable, neg_previous &
       &                           , wf_filetype, wf_title, eigmin_wf, eigmax_wf, ekmode, neg_is_enlarged &
       &                           , icond, fixed_charge_k_parallel, sw_ekzaj, numk_zajsaved, Nw_Psicoef
  use m_Const_parameters,     only : DP, SP, CMPLDP, BUCS, OFF, YES, EK, SCF, DENSITY_ONLY &
       &                           , CUBE, VTK, BINARY, GAMMA, GAMMA_base_symmetrization, ONE_BY_ONE &
       &                           , FIXED_CHARGE, FIXED_CHARGE_CONTINUATION, DELTA &
       &                           , EFERMI_VICINITY, ALL_VALUES, GRID, ON
  use m_Parallelization,      only : mpi_comm_group,mpi_k_world,is_kngp,ie_kngp,npes,mype,ierr,map_k &
       &                           , map_ek,ista_e,iend_e,istep_e,map_z, np_e &
       &                           , ista_k,iend_k,myrank_e,myrank_k,map_e,nrank_e &
       &                           , ista_kngp,iend_kngp, nrank_k  &
       &                           , ista_g1k,iend_g1k, np_g1k , myrank_g, nrank_g
  use m_IterationNumbers,     only : nk_in_the_process, nk_converged, nkgroup &
       &                           , first_kpoint_in_this_job, iteration_ionic, iteration_electronic
  use m_FFT,                  only : fft_box_size_WF,nfft
  use m_Crystal_Structure,    only : altv, sw_fix_total_spin
  use m_Ionic_System,         only : natm,natm2,iatomn,m_IS_pack_all_ions_in_uc
  use m_PseudoPotential,      only : ival
  use m_Crystal_Structure,    only : univol

! ===================================== added by K. Tagami ============= 11.0
  use m_Control_Parameters,    only : ndim_spinor, noncol, &
       &                              previous_nspin_collinear, &
       &                              previous_nband_collinear
! ====================================================================== 11.0
  use m_ErrorMessages,        only : EOF_REACHED

  implicit none
  include 'mpif.h'

  integer istatus(mpi_status_size)

  real(kind=SP), allocatable, dimension(:,:)  :: wf_l   ! work wave functions

!   3. m_ESIO_rd_EigenValues_etc    <-(Initial_Electronic_Structure)
!   4. m_ESIO_wd_EigenValues_etc    <-(WriteDownData_onto_Files)
!   x. m_ESIO_wd_EigenValues        <-(WriteDownData_onto_Files)
!   x. m_ESIO_wd_EigenValues_ek     <-(WriteDownData_onto_Files_ek)
!   x. m_ESIO_wd_vlhxc              <-(WriteDownData_onto_Files)
!  59. m_ESIO_rd_WFs                <-(Initial_Electronic_Structure)
!  60. m_ESIO_wd_WFs                <-(WriteDownData_onto_Files)
!  22. wd_vnlph_l_small_portion

contains
  subroutine m_ESIO_rd_EigenValues_etc(nfout,nfcntn_bin,F_CNTN_BIN_partitioned)
    integer, intent(in) :: nfout, nfcntn_bin
    logical, intent(in) :: F_CNTN_BIN_partitioned
    integer  :: ik, ie
    integer, allocatable, dimension(:,:) :: n1_wk, n2_wk  ! MPI
    real(DP),allocatable, dimension(:,:) :: e1_wk, e2_wk  ! MPI
!!$    read(nfcntn_bin) neordr,nrvf_ordr,eko_l,occup_l,efermi,totch

    if(F_CNTN_BIN_partitioned) then
       if(neg_previous /= neg) then
          write(nfout,'(" !! neg_previous /= neg <<m_ESIO_rd_EigenValues_etc>>")')
          write(nfout,'(" !! neg_prevous = ",i8)') neg_previous
          write(nfout,'(" !! neg         = ",i8)') neg
          write(nfout,'(" neg_previous sould be neg when F_CNTN_BIN_in_partitioned is true")')
          stop ' neg_previous sould be neg when F_CNTN_BIN_in_partitioned is true'
       end if
       allocate(n1_wk(neg,iend_k-ista_k+1), n2_wk(neg,iend_k-ista_k+1))
       allocate(e1_wk(np_e,iend_k-ista_k+1),e2_wk(np_e,iend_k-ista_k+1))
       n1_wk = 0; n2_wk = 0
       e1_wk = 0; e2_wk = 0
       ! -- neordr, nrvf_ordr --
       read(nfcntn_bin) n1_wk
       read(nfcntn_bin) n2_wk
       do ik = ista_k, iend_k
          neordr(1:neg,ik) = n1_wk(1:neg,ik-ista_k+1)
          nrvf_ordr(1:neg,ik) = n2_wk(1:neg,ik-ista_k+1)
       end do
       ! -- eko_l, occup_l --
       read(nfcntn_bin) e1_wk
       read(nfcntn_bin) e2_wk
       do ik = ista_k, iend_k
          do ie = ista_e, iend_e
             eko_l(map_z(ie),ik) = e1_wk(ie-ista_e+1,ik-ista_k+1)
             occup_l(map_z(ie),ik) = e2_wk(ie-ista_e+1,ik-ista_k+1)
          end do
       end do
       deallocate(e2_wk,e1_wk,n2_wk,n1_wk)
       ! -- nfermi, totch --
       read(nfcntn_bin) efermi, totch
    else
       allocate(n1_wk(neg_previous,kv3),n2_wk(neg_previous,kv3)) ! MPI
       allocate(e1_wk(neg_previous,kv3),e2_wk(neg_previous,kv3)) ! MPI
       n1_wk = 0; n2_wk = 0
       e1_wk = 0; e2_wk = 0

       ! -- neordr, nrvf_ordr --
       if(mype == 0) read(nfcntn_bin) n1_wk                ! MPI
       if(mype == 0) read(nfcntn_bin) n2_wk                ! MPI
       if(npes > 1) then
          call mpi_bcast(n1_wk,neg_previous*kv3,mpi_integer,0,mpi_comm_group,ierr) ! MPI
          call mpi_bcast(n2_wk,neg_previous*kv3,mpi_integer,0,mpi_comm_group,ierr) ! MPI
       endif
       do ik = ista_k, iend_k                              ! MPI
          neordr(1:neg_previous,ik) = n1_wk(1:neg_previous,ik)
          nrvf_ordr(1:neg_previous,ik) = n2_wk(1:neg_previous,ik)
          if(neg_previous < neg) then
             do ie = neg_previous+1, neg
                neordr(ie,ik) = ie
                nrvf_ordr(ie,ik) = ie
             end do
          end if
       end do                                              ! MPI

       ! -- eko_l, occup_l --
       if(mype == 0) read(nfcntn_bin) e1_wk                ! MPI
       if(mype == 0) read(nfcntn_bin) e2_wk                ! MPI
       if(npes > 1) then
          call mpi_bcast(e1_wk,neg_previous*kv3,mpi_double_precision,0,mpi_comm_group,ierr) ! MPI
          call mpi_bcast(e2_wk,neg_previous*kv3,mpi_double_precision,0,mpi_comm_group,ierr)! MPI
       end if
       do ik = ista_k, iend_k                              ! MPI
          do ie = 1, neg_previous                          ! MPI
             if(map_e(ie) == myrank_e) then                ! MPI
                eko_l(map_z(ie),ik) = e1_wk(ie,ik)         ! MPI
                occup_l(map_z(ie),ik) = e2_wk(ie,ik)       ! MPI
             end if
          end do                                           ! MPI
          if(neg_previous < neg) then
             do ie = neg_previous+1, neg
                if(map_e(ie) == myrank_e) then
                   eko_l(map_z(ie),ik) = 1.d+15
                   occup_l(map_z(ie),ik) = 0.d0
                end if
            end do           
          end if
       end do                                              ! MPI

       ! -- nfermi, totch --
       if(mype == 0) read(nfcntn_bin) efermi, totch        ! MPI
       if(npes > 1) then
          call mpi_bcast(efermi,1,mpi_double_precision,0,mpi_comm_group,ierr) ! MPI
          call mpi_bcast(totch,1, mpi_double_precision,0,mpi_comm_group,ierr) ! MPI
       end if

       deallocate(e2_wk,e1_wk,n2_wk,n1_wk)
    end if

    if(printable) write(nfout,'(" TOTCH (total charge) = ",f12.6 &
         & ," (= ",8d25.12,") at m_ESIO_rd_EigenValues_etc")') totch,totch

  end subroutine m_ESIO_rd_EigenValues_etc

  subroutine m_ESIO_wd_EigenValues_etc(nfcntn_bin,F_CNTN_BIN_partitioned,totch_flag)

    integer, intent(in) :: nfcntn_bin
    logical, intent(in) :: F_CNTN_BIN_partitioned
    integer, optional, intent(in) :: totch_flag

    integer  :: ik, ie
    integer, allocatable, dimension(:,:) :: n_wk, n2_mpi  ! MPI
    real(DP),allocatable, dimension(:,:) :: e_wk, e2_mpi  ! MPI
    integer  :: id_sname = -1
    call tstatc0_begin('m_ESIO_wd_EigenValues_etc ',id_sname)

!!$    write(nfcntn_bin) neordr,nrvf_ordr,eko_l,occup_l,efermi,totch

    if(F_CNTN_BIN_partitioned) then
       allocate(n_wk(neg,iend_k-ista_k+1))
       allocate(e_wk(np_e,iend_k-ista_k+1))
!!$       allocate(e_wk(neg,iend_k-ista_k+1)); allocate(e2_mpi(neg,iend_k-ista_k+1))
       n_wk = 0; e_wk = 0
       !  -- neordr --
       do ik = ista_k, iend_k
          n_wk(1:neg,ik-ista_k+1) = neordr(1:neg,ik)
       end do
       write(nfcntn_bin) n_wk

       !  -- nrvf_ordr --
       do ik = ista_k, iend_k
          n_wk(1:neg,ik-ista_k+1) = nrvf_ordr(1:neg,ik)
       end do
       write(nfcntn_bin) n_wk

       !  -- eko_l --
       e_wk = 0.d0
       do ik = ista_k, iend_k
          do ie = ista_e, iend_e
             e_wk(ie-ista_e+1,ik-ista_k+1) = eko_l(map_z(ie),ik)
!!$             e_wk(ie,ik-ista_k+1) = eko_l(map_z(ie),ik)
          end do
       end do
       write(nfcntn_bin) e_wk
!!$       if(npes >= 2) then
!!$          call mpi_allreduce(e_wk,e2_mpi,neg*(iend_k-ista_k+1),mpi_double_precision &
!!$               &               , mpi_sum, mpi_k_world)
!!$       else
!!$          e2_mpi = e_wk
!!$       end if
!!$       write(nfcntn_bin) e2_mpi

       !  -- occup_l --
       e_wk = 0.d0
       do ik = ista_k, iend_k
          do ie = ista_e, iend_e, istep_e
             e_wk(ie-ista_e+1,ik-ista_k+1) = occup_l(map_z(ie),ik)
!!$             e_wk(ie,ik-ista_k+1) = occup_l(map_z(ie),ik)
          end do
       end do
       write(nfcntn_bin) e_wk
!!$       if(npes >= 2) then
!!$          call mpi_allreduce(e_wk,e2_mpi,neg*(iend_k-ista_k+1),mpi_double_precision &
!!$               &               , mpi_sum, mpi_k_world)
!!$       else
!!$          e2_mpi = e_wk
!!$       end if
!!$       write(nfcntn_bin) e2_mpi
!!$       deallocate(e2_mpi, e_wk, n_wk)
       deallocate(e_wk, n_wk)

       if(totch_flag == OFF) then
          write(nfcntn_bin) efermi                     ! MPI
       else
          write(nfcntn_bin) efermi,totch               ! MPI
       end if
    else
       allocate(n_wk(neg,kv3)); allocate(n2_mpi(neg,kv3))! MPI
       allocate(e_wk(neg,kv3)); allocate(e2_mpi(neg,kv3))! MPI
       n_wk = 0; n2_mpi = 0
       e_wk = 0; e2_mpi = 0
       !  -- neordr --
       n_wk = 0                                          ! MPI
       do ik = 1, kv3                                     ! MPI
          if(map_k(ik) /= myrank_k) cycle                 ! MPI
          n_wk(1:neg,ik) = neordr(1:neg,ik)               ! MPI
       end do                                             ! MPI
       if(npes >= 2) then
          call mpi_allreduce(n_wk,n2_mpi,neg*kv3,mpi_integer,mpi_sum &
               &                      ,mpi_comm_group,ierr)  ! MPI
          n2_mpi = n2_mpi/nrank_e
       else
          n2_mpi = n_wk
       end if
       if(mype == 0) write(nfcntn_bin) n2_mpi             ! MPI ; writing (neordr)

       !  -- nrvf_ordr --
       n_wk = 0                                           ! MPI
       do ik = 1, kv3                                     ! MPI
          if(map_k(ik) /= myrank_k) cycle                 ! MPI
          n_wk(1:neg,ik) = nrvf_ordr(1:neg,ik)            ! MPI
       end do                                             ! MPI
       if(npes >= 2) then
          call mpi_allreduce(n_wk,n2_mpi,neg*kv3,mpi_integer,mpi_sum &
               &                      ,mpi_comm_group,ierr)  ! MPI
          n2_mpi = n2_mpi/nrank_e
       else
          n2_mpi = n_wk
       end if
       if(mype == 0) write(nfcntn_bin) n2_mpi             ! MPI ; writing (nrvf_ordr)

       !  -- eko_l --
       e_wk = 0.d0                                        ! MPI
       do ik = 1, kv3                                     ! MPI
          if(map_k(ik) /= myrank_k) cycle                 ! MPI
          do ie = 1, neg                                  ! MPI
             if(map_e(ie) /= myrank_e) cycle              ! MPI
             e_wk(ie,ik) = eko_l(map_z(ie),ik)            ! MPI
          end do
       end do
       if(npes >= 2) then
          call mpi_allreduce(e_wk,e2_mpi,neg*kv3,mpi_double_precision &
               &               ,mpi_sum,mpi_comm_group,ierr) ! MPI
       else
          e2_mpi = e_wk
       end if
       if(mype == 0) write(nfcntn_bin) e2_mpi             ! MPI ; writing (eko_l)

       !  -- occup_l --
       e_wk = 0.d0                                        ! MPI
       do ik = 1, kv3                                     ! MPI
          if(map_k(ik) /= myrank_k) cycle                 ! MPI
          do ie = 1, neg                                  ! MPI
             if(map_e(ie) /= myrank_e) cycle              ! MPI
             e_wk(ie,ik) = occup_l(map_z(ie),ik)          ! MPI
          end do                                            ! MPI
       end do                                               ! MPI
       if(npes >= 2) then
          call mpi_allreduce(e_wk,e2_mpi,neg*kv3,mpi_double_precision &
               &                  ,mpi_sum,mpi_comm_group,ierr) ! MPI
       else
          e2_mpi = e_wk
       end if
       if(mype == 0) write(nfcntn_bin) e2_mpi             ! MPI ; writing (occup_l)
       if(mype == 0) then
          if(totch_flag == OFF) then
             write(nfcntn_bin) efermi                     ! MPI
          else
             write(nfcntn_bin) efermi,totch               ! MPI
          end if
       end if
       deallocate(n_wk); deallocate(n2_mpi)              ! MPI
       deallocate(e_wk); deallocate(e2_mpi)              ! MPI
    end if
    call tstatc0_end(id_sname)
  end subroutine m_ESIO_wd_EigenValues_etc

  subroutine m_ESIO_wd_EigenValues(nf,iprieigen,nooccupation)

    integer, intent(in)              :: nf
    integer, intent(in)              :: iprieigen
    integer, intent(in)              :: nooccupation
    integer                          :: ie,  ipri0, kv3_i, ks
    integer                          :: hconst_min, lzero_max
    integer, parameter :: NCOLUMN = 6
    integer, parameter :: EIGEN_VALUES = 1, OCCUPATIONS = 2
    integer :: writemode
    real(kind=DP),allocatable, dimension(:,:) :: e_mpi, o_mpi
#ifdef __TIMER_SUB__
  call timer_sta(1378)
#endif
    allocate(e_mpi(neg,kv3)); e_mpi = 0.d0
    allocate(o_mpi(neg,kv3)); o_mpi = 0.d0

    call set_writemode(writemode)  ! ->(writemode) = ALL_VALUES or FERMI_VICINITY
    call get_ipri0(iprieigen,ipri0)

    if(ipri0 >= 2) then
       if(ipri0 >= 3 .and. nf == 6 .and. printable) call wd_neordr()

       call set_kv3_i_and_ks() ! -> kv3_i, ks
#ifndef _DEBUG_WRITE_
       if(writemode == EFERMI_VICINITY .and. kv3_i == kv3) &
            & call cal_vicinity_range(hconst_min,lzero_max) ! -> lzero_max, hconst_min
#endif
!     --- Energy eigen values ---
       call put_kpartArray_into(eko_l,e_mpi)
       if(printable) then
          if(ks == 0 .and. nf==6) call wd_efermi()
!!$          if(ks == 0) call wd_efermi()
          call wd_k_and_values(EIGEN_VALUES)
       end if
    end if
!     --- Occupations ---
    if(ipri0 >= 2 .and. nooccupation /= YES) then
       call put_kpartArray_into(occup_l,o_mpi)
       if(printable) call wd_k_and_values(OCCUPATIONS)
    end if
    deallocate(e_mpi)
    deallocate(o_mpi)
#ifdef __TIMER_SUB__
  call timer_end(1378)
#endif
  contains
    subroutine set_writemode(writemode)
      integer, intent(out) :: writemode
      writemode = ALL_VALUES
#ifndef _DEBUG_WRITE_
      if(nf==6) then
         if((icond == FIXED_CHARGE_CONTINUATION .or. icond == FIXED_CHARGE) .and. &
              & fixed_charge_k_parallel == ONE_BY_ONE) then
            writemode = ALL_VALUES
         else
            if(neg <= NCOLUMN) then
               writemode = ALL_VALUES
            else
               writemode = EFERMI_VICINITY
            end if
         end if
      end if
#endif
    end subroutine set_writemode

    subroutine set_kv3_i_and_ks()
!!$      if(iprieigen>=2 .and. printable) then
      if((icond == FIXED_CHARGE_CONTINUATION .or. icond == FIXED_CHARGE) .and. &
           & fixed_charge_k_parallel == ONE_BY_ONE) then
         kv3_i = kv3_ek - kv3*(nkgroup-1)
         if(kv3_i > kv3) kv3_i = kv3
         ks = max(1,first_kpoint_in_this_job) - 1 + kv3*(nkgroup-1)
      else
         kv3_i = kv3
         ks = 0
      end if

      if(iprieigen>=3 .and. printable) &
           & write(nf,'(" kv3_i, kv3, ks, nkgroup = ",4i8)') kv3_i, kv3, ks, nkgroup
!!$
!!$      call mpi_bcast(kv3_i,1,mpi_integer,0,mpi_comm_group,ierr)
!!$      call mpi_bcast(ks,1,mpi_integer,0,mpi_comm_group,ierr)
    end subroutine set_kv3_i_and_ks

    subroutine wd_k_and_values(mode)
      integer, intent(in) :: mode
      integer :: ik, nb
      integer :: ie_s, ie_e, nhw, neg_t
      real(kind=DP) :: hw, hc, hv
      
#ifndef _DEBUG_WRITE_
      if(writemode == EFERMI_VICINITY) then
         hw = (lzero_max-hconst_min)*0.5d0
         hv = (lzero_max+hconst_min)*0.5d0
         hc = NCOLUMN*0.5d0
         nhw = Int(hw/hc + 1.d0)
         ie_s = max(nint(hv-nhw*hc + DELTA),1)
         ie_e = min(ie_s + nhw*NCOLUMN - 1,neg)
      end if
#endif

      if(mode == EIGEN_VALUES) then
#ifndef _DEBUG_WRITE_
         if(writemode == EFERMI_VICINITY) then
            write(nf,'(" ======  Energy Eigen Values in the vicinity of the Fermi energy level (Range=" &
                 & ,i7," :",i7,") =====")') ie_s, ie_e
         else
#endif
            if(nf==6) write(nf,'(" ======  Energy Eigen Values ======")')
#ifndef _DEBUG_WRITE_
         end if
#endif
      else
#ifndef _DEBUG_WRITE_
         if(writemode == EFERMI_VICINITY) then
            write(nf,'(" ======  Occupations in the vicinity of the Fermi energy level (Range=" &
                 & ,i7," :",i7,") =====")') ie_s, ie_e
         else
#endif
            if(nf==6) write(nf,'(" ======  Occupations ======")')
#ifndef _DEBUG_WRITE_
         end if
#endif
      end if
#ifdef __TIMER_IODO__
  call timer_sta(1463)
#endif
      do ik = 1, kv3_i, ndim_spinor
#ifndef _DEBUG_WRITE_
!!$         if(mode == OCCUPATIONS) e_mpi(:,ik) = e_mpi(:,ik)/(qwgt(ik)*kv3)
!!$         if(mode == OCCUPATIONS) o_mpi(:,ik) = o_mpi(:,ik)/(qwgt(ik)*kv3)
         if(writemode==EFERMI_VICINITY .and. kv3==kv3_i) then
            call wd_k_and_efermi_vicinities(ik,ie_s,ie_e,mode)
         else
#endif
            if(nf /= 6 .and. mode == EIGEN_VALUES) write(nf,'(" ===== energy eigen values =====")')
            if(nf /= 6 .and. mode == OCCUPATIONS)  write(nf,'(" ===== occupations =====")')
            if ( noncol ) then
               call wd_k_points_noncl(ik)
            else
               call wd_k_points(ik)
            endif
            neg_t = neg
            if(neg_is_enlarged) neg_t = neg - num_extra_bands
            if(mode == EIGEN_VALUES) then
               write(nf,'(5f16.8)') (e_mpi(nb,ik),nb = 1, neg_t) ! =eko(neordr(nb,ik),ik)
            else if(mode == OCCUPATIONS) then
               write(nf,'(5f16.8)') (o_mpi(nb,ik)/(qwgt(ik)*kv3),nb = 1, neg_t) ! =occup(neordr(nb,ik),ik)
            end if
#ifndef _DEBUG_WRITE_
         end if
#endif
      end do
#ifdef __TIMER_IODO__
  call timer_end(1463)
#endif
    end subroutine wd_k_and_values

    subroutine put_kpartArray_into(a_l,a_all)
      real(kind=DP), intent(in), dimension(np_e,ista_k:iend_k) :: a_l
      real(kind=DP), intent(out), dimension(neg,kv3) :: a_all
      integer :: ik, ierr, ie
      integer :: ito

#ifdef __TIMER_IODO__
  call timer_sta(1461)
#endif
      a_all = 0.d0
      do ik = 1, kv3
         if(map_k(ik) /= myrank_k) cycle
         do ie = 1, neg
            if(map_e(ie) /= myrank_e) cycle
            ito = nrvf_ordr(ie,ik)
            a_all(ito,ik) = a_l(map_z(ie),ik)
         end do
      end do
#ifdef __TIMER_IODO__
  call timer_end(1461)
#endif
      if(npes >= 2) then
         call mpi_allreduce(MPI_IN_PLACE,a_all,neg*kv3,mpi_double_precision &
              &                      ,mpi_sum, mpi_comm_group,ierr)
      end if
     end subroutine put_kpartArray_into

    subroutine wd_neordr()
      integer :: ik
      write(nf,'(" kv3 = ",i8, " neg = ",i8)') kv3,neg
      do ik= 1,kv3
         write(nf,'(" map_k(",i3,") = ",i8)') ik,map_k(ik)
         if(map_k(ik) /= myrank_k) cycle
         write(nf,'(" neordr ik=",i8)') ik
         write(nf,'(10i8)') neordr(1:neg,ik)
      end do
    end subroutine wd_neordr

    subroutine get_ipri0(ipri_in, ipri_out)
      integer, intent(in)  :: ipri_in
      integer, intent(out) :: ipri_out
      if(npes > 1) then
         if(mype == 0) ipri_out = ipri_in
         call mpi_bcast(ipri_out,1,mpi_integer,0,mpi_comm_group,ierr)
      else
         ipri_out = ipri_in
      end if
    end subroutine get_ipri0

    subroutine wd_k_points(ik)
      integer, intent(in) :: ik
       if(nspin == 1) then
#ifdef _EIGENVALUES_IN_OLD_FORMAT_
          write(nf,'(i6,3f16.8)') ik+ks,(vkxyz(ik,1:3,BUCS))
#else
          write(nf,'(" ik = ",i4," (",3f10.6," )")') ik+ks,(vkxyz(ik,1:3,BUCS))
#endif
       else
#ifdef _EIGENVALUES_IN_OLD_FORMAT_
          if(mod(ik,2) == 1) then
             write(nf,'(i6,"    UP ",3f16.8)') ik+ks,(vkxyz(ik,1:3,BUCS))
          else
             write(nf,'(i6,"  DOWN ",3f16.8)') ik+ks,(vkxyz(ik,1:3,BUCS))
          end if
#else
          if(mod(ik,2) == 1) then
             write(nf,'(" ik = ",i4," (",3f10.6,")    UP ")') ik+ks,(vkxyz(ik,1:3,BUCS))
          else
             write(nf,'(" ik = ",i4," (",3f10.6,")  DOWN ")') ik+ks,(vkxyz(ik,1:3,BUCS))
          end if
#endif
       end if
     end subroutine wd_k_points

! ============================== added by K. Tagami ==================== 11.0
     subroutine wd_k_points_noncl(ik)
       integer, intent(in) :: ik
#ifdef _EIGENVALUES_IN_OLD_FORMAT_
       write(nf,'(i6,3f16.8)') ik+ks,(vkxyz(ik,1:3,BUCS))
#else
       write(nf,'(" ik = ",i4," (",3f10.6," )")') ik+ks,(vkxyz(ik,1:3,BUCS))
#endif
     end subroutine wd_k_points_noncl
! ====================================================================== 11.0

     subroutine cal_vicinity_range(hconst_min, lzero_max)
       integer, intent(out) :: hconst_min, lzero_max
       integer :: hconst,lzero
       integer :: ik, ie, nb
       integer :: ito

       e_mpi = 0.d0
       do ik = 1, kv3
          if(map_k(ik) /= myrank_k) cycle
          do ie = 1, neg
             if(map_e(ie) /= myrank_e) cycle
             ito = nrvf_ordr(ie,ik)
             e_mpi(ito,ik) = occup_l(map_z(ie),ik)
          end do
       end do
       if(npes >= 2) then
          call mpi_allreduce(MPI_IN_PLACE,e_mpi,neg*kv3,mpi_double_precision &
               &                  ,mpi_sum,mpi_comm_group,ierr) ! MPI
       end if
       hconst_min = neg
       lzero_max = 0
       do ik = 1, kv3, ndim_spinor
          hconst = neg
          lzero  = 1
          do nb = neg,1,-1
             if(e_mpi(nb,ik)<DELTA) lzero = nb
             if(e_mpi(nb,ik)>=qwgt(ik)*kv3-DELTA ) then
                hconst = nb
                exit
             end if
          end do
          if(hconst < hconst_min) hconst_min = hconst
          if(lzero_max < lzero)   lzero_max = lzero
       end do
       if(printable) write(nf,'(" hconst_min,lzero_max = ",2i8)') hconst_min,lzero_max
     end subroutine cal_vicinity_range

     subroutine wd_k_and_efermi_vicinities(ik,ie_s,ie_e,mode)
       integer, intent(in) :: ik, ie_s,ie_e,mode
       integer :: nb, nbloop, ie, ie1, ie2
       if(hconst_min >= 1) then
!!$          nb = lzero_max-hconst_min+1
          nb = ie_e - ie_s + 1
          nbloop = Int((nb-1)/NCOLUMN+1)
          do ie = 1, nbloop
!!$             ie1 = hconst_min+(ie-1)*NCOLUMN
!!$             ie2 = min(hconst_min+ie*NCOLUMN-1,neg)
             ie1 = max(ie_s+(ie-1)*NCOLUMN,1)
             ie2 = min(ie_s+ie*NCOLUMN-1,neg)
             if(ie == 1) then
                if(mode == EIGEN_VALUES) then
                   write(nf,'(" ik = ",i4,"  ",8f12.6)') ik, (e_mpi(nb,ik),nb=ie1,ie2)
                else if(mode == OCCUPATIONS) then
                   write(nf,'(" ik = ",i4,"  ",8f12.6)') ik, (o_mpi(nb,ik)/(qwgt(ik)*kv3),nb=ie1,ie2)
                end if
             else
                if(mode == EIGEN_VALUES) then
                   write(nf,'(12x,8f12.6)') (e_mpi(nb,ik),nb=ie1,ie2)
                else if(mode == OCCUPATIONS) then
                   write(nf,'(12x,8f12.6)') (o_mpi(nb,ik)/(qwgt(ik)*kv3),nb=ie1,ie2)
                end if
             end if
          end do
       end if
     end subroutine wd_k_and_efermi_vicinities

     subroutine wd_efermi()
       if(nf == 6) write(nf,'(" **** Eigen Values and Occupations ****")')
       write(nf,'(" ** iteration_ionic = ",i8, ", iteration_electronic = ",i8," **")') &
            & iteration_ionic, iteration_electronic
       write(nf,'(" EFermi = ",f16.8)') efermi
       if(sw_fix_total_spin == YES .and. nspin == 2) then
          write(nf,'(" Efermi_spin(1) = ",f16.8, ",  Efermi_spin(2) = ",f16.8)') &
               & efermi_spin(1), efermi_spin(2)
       end if
     end subroutine wd_efermi
  end subroutine m_ESIO_wd_EigenValues

  subroutine m_ESIO_wd_EigenValues_ek(nf,mode)
    integer, intent(in)              :: nf, mode

    real(kind=DP), parameter :: delta = 1.d-12
    real(kind=DP), allocatable, dimension(:) :: eko_t
    integer, allocatable, dimension(:)       :: neordr_t
    integer                     :: ik, ib,jb,ibo,jbo, neg_t

! =========================== added by K. Tagami ================ 11.0
    integer :: ikskip
! =============================================================== 11.0

    allocate(eko_t(neg))
    allocate(neordr_t(neg))
    eko_t = 0; neordr_t = 0

    if(mode == SCF .and. printable) write(nf,'(" ======  Energy Eigen Values ======")')
!!$    do ik = 1, kv3_ek
!!$    do ik = 1, nk_in_the_process

    if(printable) then
! ========================= modified by K. Tagami ============ 11.0
!       write(nf,'(" nk_converged = ",i8)') min(kv3_ek,nk_converged)
!       do ik = 1, kv3_ek
!          call wd_k_points
!       end do
       if ( noncol ) then
          write(nf,'(" nk_converged = ",i8)') min(kv3_ek,nk_converged) /ndim_spinor
          do ik = 1, kv3_ek, ndim_spinor
             call wd_k_points_noncl
          end do
       else
          write(nf,'(" nk_converged = ",i8)') min(kv3_ek,nk_converged)
          do ik = 1, kv3_ek
             call wd_k_points
          end do
       endif
! ============================================================= 11.0

       write(nf,'(" -----")')
    end if

! ====================== added by K. Tagami =================== 11.0
    if ( noncol ) then
       ikskip = ndim_spinor
    else
       ikskip = 1
    endif
! ============================================================ 11.0

! ============================ modified by K. Tagami ============ 11.0
!    do ik = 1, nk_converged
    do ik = 1, nk_converged, ikskip
! =============================================================== 11.0

!       if(sw_ekzaj == OFF .and. ik <= first_kpoint_in_this_job) cycle
       if(ik > kv3_ek) cycle
       if(mode == EK .and. printable) write(nf,'("=== energy_eigen_values ===")')
       eko_t = eko_ek(:,ik)
       if(nspin == 1 .or. (nspin == 2 .and. mod(ik,2) == 1)) &
            & neordr_t(1:neg) = (/(ib,ib=1,neg)/)
       do ib = 1, neg-1
          do jb = ib+1, neg
             ibo = neordr_t(ib)
             jbo = neordr_t(jb)
             if(eko_t(jbo)  < eko_t(ibo)-delta) then        ! MPI
                neordr_t(jb) = ibo
                neordr_t(ib) = jbo
             end if
          end do
       end do
       if(printable) then
! ================================ modified by K. Tagami ========== 11.0
!          call wd_k_points
          if ( noncol ) then
             call wd_k_points_noncl
          else
             call wd_k_points
          endif
! ================================================================= 11.0
          neg_t = neg

          if(neg_is_enlarged) neg_t = neg - num_extra_bands
          if(mode == SCF) then
             write(nf,'(5f16.8)') (eko_t(neordr_t(ib)),ib=1,neg_t)
          else
             write(nf,'(4f18.10)') (eko_t(neordr_t(ib)),ib=1,neg_t)
          end if
       end if
    end do
    deallocate(neordr_t)
    deallocate(eko_t)
  contains
    subroutine wd_k_points
      if(mode == SCF) then
         if(nspin == 1) then
            write(nf,'(i6,3f18.10)') ik,(vkxyz_ek(ik,1:3,BUCS))
         else
            if(mod(ik,2) == 1) then
               write(nf,'(i6,"    UP ",3f18.10)') ik,(vkxyz_ek(ik,1:3,BUCS))
            else
               write(nf,'(i6,"  DOWN ",3f18.10)') ik,(vkxyz_ek(ik,1:3,BUCS))
            end if
         end if
      else
         if(nspin == 1) then
            write(nf,'(" ik = ",i4," (",3f10.6," )")') ik,(vkxyz_ek(ik,1:3,BUCS))
         else
            if(mod(ik,2) == 1) then
               write(nf,'(" ik = ",i4," (",3f10.6,")    UP ")') ik,(vkxyz_ek(ik,1:3,BUCS))
            else
               write(nf,'(" ik = ",i4," (",3f10.6,")  DOWN ")') ik,(vkxyz_ek(ik,1:3,BUCS))
            end if
         end if
      end if
    end subroutine wd_k_points

! ============================== added by K. Tagami ==================== 11.0
    subroutine wd_k_points_noncl
      if (mode == SCF) then
         write(nf,'(i6,3f18.10)') ik,(vkxyz_ek(ik,1:3,BUCS))
      else
         write(nf,'(" ik = ",i4," (",3f10.6," )")') ik,(vkxyz_ek(ik,1:3,BUCS))
      endif
    end subroutine wd_k_points_noncl
! ====================================================================== 11.0

  end subroutine m_ESIO_wd_EigenValues_ek

! ======================================= modified by K. Tagami ========== 11.0
!  subroutine m_ESIO_wd_vlhxc(nfvlc)
!
  subroutine m_ESIO_wd_vlhxc( nfvlc, ismax )
    integer, intent(in)              :: ismax
! ======================================================================= 11.0

    integer, intent(in)              :: nfvlc
    integer                          :: is, ik, i
    real(DP),allocatable, dimension(:,:,:):: vlhxc_mpi,vlhxc_mpi2

    if(npes >= 2) then

! ========================== modiifed by K. Tagami ============= 11.0
!       allocate(vlhxc_mpi(kgp,kimg,nspin)); vlhxc_mpi = 0.d0  ! MPI
!       allocate(vlhxc_mpi2(kgp,kimg,nspin))

       allocate(vlhxc_mpi(kgp,kimg,ismax));
       allocate(vlhxc_mpi2(kgp,kimg,ismax))
! ============================================================= 11.0
       vlhxc_mpi = 0.0d0;       vlhxc_mpi2 = 0.0d0

! ========================== modiifed by K. Tagami ============= 11.0
!       do is = 1, nspin
       do is = 1, ismax
! ============================================================== 11.0
          do ik = 1, kimg
             do i = ista_kngp, iend_kngp
                vlhxc_mpi(i,ik,is) = vlhxc_l(i,ik,is)
             end do
          end do
       end do

! ========================== modiifed by K. Tagami ====================== 11.0
!       call mpi_allreduce(vlhxc_mpi,vlhxc_mpi2,kgp*kimg*nspin &
!            &     , mpi_double_precision, mpi_sum, mpi_comm_group,ierr)
       call mpi_allreduce( vlhxc_mpi, vlhxc_mpi2, kgp*kimg*ismax, &
            &              mpi_double_precision, mpi_sum, mpi_comm_group, ierr )
! ====================================================================== 11.0

       if (mype == 0) write(nfvlc) vlhxc_mpi2

       deallocate(vlhxc_mpi); deallocate(vlhxc_mpi2)
    else
       write(nfvlc) vlhxc_l
    end if
  end subroutine m_ESIO_wd_vlhxc

  subroutine m_ESIO_rd_WFs(nfout,nfzaj, F_ZAJ_partitioned)
    integer, intent(in) :: nfout, nfzaj
    logical, intent(in) :: F_ZAJ_partitioned
    integer    :: ik,ib,ri, i
    integer    :: id_sname = -1
    integer    :: ierror
    call tstatc0_begin('m_ESIO_rd_WFs ',id_sname)

    allocate(wf_l(kg1,kimg)); wf_l = 0.d0
    rewind nfzaj
    if(ipri >= 1) write(nfout,*) ' !D Reading zaj'
    if(F_ZAJ_partitioned) then
       do ik = ista_k, iend_k, af+1        ! MPI
          do ib = ista_e, iend_e, istep_e  ! MPI
             if(ib > neg_previous) cycle
             read(nfzaj) wf_l
             if(kimg == 1) then
                do i = 1, kg1
                   zaj_l(i,map_z(ib),ik,1) = wf_l(i,1)
                end do
             else if(kimg==2) then
                do i = 1, kg1
                   zaj_l(i,map_z(ib),ik,1) = wf_l(i,1)
                   zaj_l(i,map_z(ib),ik,2) = wf_l(i,2)
                end do
             end if
          end do
       end do
    else
       do ik = 1, kv3, af+1
          do ib = 1, neg_previous

             if(mype == 0) read(nfzaj, end = 9999, err = 9999) wf_l  ! MPI
             if(mype == 0 .and. map_ek(ib,ik) /= 0) then ! MPI
                call mpi_send(wf_l,kg1*kimg,mpi_real,map_ek(ib,ik),1,mpi_comm_group,ierr) ! MPI
             else if(map_ek(ib,ik) == mype .and. map_ek(ib,ik) /= 0) then                  ! MPI
                call mpi_recv(wf_l,kg1*kimg,mpi_real,0,1,mpi_comm_group,istatus,ierr)     ! MPI
             end if
             if(map_ek(ib,ik) == mype) then              ! MPI
                do ri = 1, kimg
                   zaj_l(1:kg1,map_z(ib),ik,ri) = wf_l(1:kg1,ri)  ! MPI
                end do
             end if
          end do
       end do
    end if
    deallocate(wf_l)

    call tstatc0_end(id_sname)                      
    return
9999 continue
    ierror = EOF_REACHED
    call phase_error_wo_filename(ierror, nfout, nfzaj, __LINE__, __FILE__)
  end subroutine m_ESIO_rd_WFs

! ==================================== added by K. Tagami =============== 11.0
  subroutine m_ESIO_rd_WFs_import_frm_collin(nfout,nfzaj, F_ZAJ_partitioned)
    integer, intent(in) :: nfout, nfzaj
    logical, intent(in) :: F_ZAJ_partitioned

    integer  neg_to_be_read

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

    allocate(wf_l(kg1,kimg))
    wf_l = 0
    rewind nfzaj
    if(ipri >= 1) write(nfout,*) ' !D Reading zaj'

    if(F_ZAJ_partitioned) then
       write(*,*) &
            & 'Not supported : importing collinear Wfns  when F_ZAJ_partitioned = true'

    else
       neg_to_be_read = neg / 2

       write(nfout,*) '******************************** '
       write(nfout,*) '!! Collinear wavefunctions are used. '
       write(nfout,*) '!! neg_to_be_read is assumed to be ', neg_to_be_read
       write(nfout,*) '******************************** '

       if ( previous_nspin_collinear == 1 ) then
          call case_previous_nspin_eq_1
       else if ( previous_nspin_collinear == 2 ) then
          call case_previous_nspin_eq_2
       endif

    end if

    deallocate(wf_l)
    call tstatc0_end(id_sname)

  contains

    subroutine case_previous_nspin_eq_2
      integer :: ik, ib, ri, i
      integer :: ib_0, is

      do ik = 1, kv3, ndim_spinor
         Do is=1, ndim_spinor
            do ib_0 = 1, previous_nband_collinear
               ib = ( ib_0 -1 )*ndim_spinor + is
               if(mype == 0) read(nfzaj) wf_l              ! MPI

               if(mype == 0 .and. map_ek(ib,ik) /= 0) then ! MPI
                  call mpi_send( wf_l, kg1*kimg, mpi_real, map_ek(ib,ik), 1, &
                       &         mpi_comm_group, ierr ) ! MPI
               else if(map_ek(ib,ik) == mype .and. map_ek(ib,ik) /= 0 ) then     ! MPI
                  call mpi_recv( wf_l, kg1*kimg, mpi_real, 0, 1, &
                       &         mpi_comm_group, istatus, ierr )     ! MPI
               end if

               if ( ib_0 > neg_to_be_read ) cycle

               if(map_ek(ib,ik) == mype) then              ! MPI
                  do ri = 1, kimg
                     zaj_l(1:kg1,map_z(ib),ik+is-1,ri) = wf_l(1:kg1,ri)  ! MPI
                  end do
               end if

            end do
         End Do
      end do
    end subroutine case_previous_nspin_eq_2

    subroutine case_previous_nspin_eq_1
      integer :: ik, ib, ri, i
      integer :: ib_0, is

      do ik = 1, kv3, ndim_spinor
         do ib_0 = 1, previous_nband_collinear
            if(mype == 0) read(nfzaj) wf_l              ! MPI

            Do is=1, ndim_spinor
               ib = ( ib_0 -1 )*ndim_spinor + is
               if(mype == 0 .and. map_ek(ib,ik) /= 0) then ! MPI
                  call mpi_send( wf_l, kg1*kimg, mpi_real, map_ek(ib,ik), 1, &
                       &         mpi_comm_group, ierr ) ! MPI
               else if(map_ek(ib,ik) == mype .and. map_ek(ib,ik) /= 0 ) then     ! MPI
                  call mpi_recv( wf_l, kg1*kimg, mpi_real, 0, 1, &
                       &         mpi_comm_group, istatus, ierr )     ! MPI
               end if

               if ( ib_0 > neg_to_be_read ) cycle

               if(map_ek(ib,ik) == mype) then              ! MPI
                  do ri = 1, kimg
                     zaj_l(1:kg1,map_z(ib),ik+is-1,ri) = wf_l(1:kg1,ri)  ! MPI
                  end do
               end if

            end do
         End Do
      end do
    end subroutine case_previous_nspin_eq_1

  end subroutine m_ESIO_rd_WFs_import_frm_collin
!===================================================================== 11.0

  subroutine m_ESIO_wd_WFs(nfout,nfzaj,F_ZAJ_partitioned)
    integer, intent(in) :: nfout,nfzaj
    logical, intent(in) :: F_ZAJ_partitioned
    integer :: ik,ib,ri
    integer :: id_sname = -1
    call tstatc0_begin('m_ESIO_wd_WFs ',id_sname)

    allocate(wf_l(kg1,kimg));    wf_l = 0
    call mpi_barrier(mpi_comm_group,ierr)
    !!$ print *, ' !D Writing zaj '
    if(ipri >= 1) write(nfout,*) ' !D Writing zaj '
    rewind nfzaj
    if(F_ZAJ_partitioned) then
       do ik = ista_k, iend_k, af+1        ! MPI
          do ib = ista_e, iend_e, istep_e  ! MPI
             do ri = 1, kimg
                wf_l(1:kg1,ri) = zaj_l(1:kg1,map_z(ib),ik,ri)
             end do
             write(nfzaj) wf_l
          end do
       end do
    else
       do ik = 1, kv3, af+1
          do ib = 1, neg
             if(map_ek(ib,ik) == mype) then                          ! MPI
                do ri = 1, kimg
                   wf_l(1:kg1,ri) = zaj_l(1:kg1,map_z(ib),ik,ri)
                end do
                if(map_ek(ib,ik) /= 0) &                             ! MPI
                     &   call mpi_send(wf_l,kg1*kimg,mpi_real,0,1,mpi_comm_group,ierr) ! MPI
             else if(mype == 0 .and. map_ek(ib,ik) /= 0) then
                call mpi_recv(wf_l,kg1*kimg,mpi_real,map_ek(ib,ik),1,mpi_comm_group,istatus,ierr)!MPI
             end if
             if(mype == 0) write(nfzaj)  wf_l                        ! MPI
          end do
       end do
    end if
    deallocate(wf_l)
    call tstatc0_end(id_sname)
  end subroutine m_ESIO_wd_WFs

  subroutine m_ESIO_wd_WFs_standardout(nfout,ipriwf)
    integer, intent(in) :: nfout,ipriwf
    integer :: ik,ib,ri, i, ic, ipriwf0, icycle, icolumn, max_elements, istart, iend
    integer :: id_sname = -1
    real(kind=DP) :: phase2r, phase2i, phaser,phasei
    complex(kind=CMPLDP) :: exp2theta, exptheta
    call tstatc0_begin('m_ESIO_wd_WFs_stndout ',id_sname)
    
    ipriwf0 = ipriwf
    if(npes > 1) call mpi_bcast(ipriwf0,1,mpi_integer,0,mpi_comm_group,ierr)

    if(ipriwf0 >= 2) then
       icolumn = 10
       allocate(wf_l(kg1,kimg+3)); wf_l = 0.d0
       call mpi_barrier(mpi_comm_group,ierr)
       if(mype == 0)  write(nfout,*) ' !wf Writing zaj '

       do ik = 1, kv3, af+1
          max_elements = iba(ik)
          if(mype == 0) write(nfout,'(" !wf   ik = ",i5)') ik
          do ib = 1, neg
             if(mype == 0) write(nfout,'(" !wf   ib = ",i5)') ib
             if(map_ek(ib,ik) == mype) then                          ! MPI
                do ri = 1, kimg
                   wf_l(1:kg1,ri) = zaj_l(1:kg1,map_z(ib),ik,ri)
                end do
                if(map_ek(ib,ik) /= 0) &                             ! MPI
                     &   call mpi_send(wf_l,kg1*kimg,mpi_real,0,1,mpi_comm_group,ierr) ! MPI
             else if(mype == 0 .and. map_ek(ib,ik) /= 0) then
                call mpi_recv(wf_l,kg1*kimg,mpi_real,map_ek(ib,ik),1,mpi_comm_group,istatus,ierr)!MPI
             end if
             if(mype == 0) then
                if(kimg == 2) then
                   do i = 1, iba(ik)
                      wf_l(i,3) = wf_l(i,1)**2 + wf_l(i,2)**2
                   end do
                   if(k_symmetry(ik) == GAMMA .or. k_symmetry(ik) == GAMMA_base_symmetrization) then
                      phase2r = (wf_l(1,1)**2 - wf_l(1,2)**2)/wf_l(1,3)
                      phase2i = -2.d0*wf_l(1,1)*wf_l(1,2)/wf_l(1,3)
                      exp2theta = cmplx(phase2r, phase2i)
                      exptheta = sqrt(exp2theta)
                      phaser = real(exptheta)
                      phasei = imag(exptheta)
                      write(nfout,'(" !wf exp2theta = ",2d20.8)') exp2theta
                      write(nfout,'(" !wf           = ",2d20.8)') phase2r, phase2i
                      write(nfout,'(" !wf |exp2theta|**2 = ",d20.8)') dsqrt(phase2r**2 + phase2i**2)
                      write(nfout,'(" !wf exptheta  = ",2d20.8)') exptheta
                      write(nfout,'(" !wf |exptheta| = ",d20.8)') abs(exptheta)
                      do i = 1, iba(ik)
!!$                      wf_l(i,4) = real(exptheta*cmplx(wf_l(i,1),wf_l(i,2)))
!!$                      wf_l(i,5) = imag(exptheta*cmplx(wf_l(i,1),wf_l(i,2)))
                         wf_l(i,4) = phaser*wf_l(i,1) - phasei*wf_l(i,2)
                         wf_l(i,5) = phaser*wf_l(i,2) + phasei*wf_l(i,1)
                      end do
                   end if
                else
                   do i = 1, iba(ik)
                      wf_l(i,2) = wf_l(i,1)**2
                   end do
                   exp2theta = 1.d0
                   exptheta = 1.d0
                end if
                icycle = ceiling(dble(min(max_elements,iba(ik)))/icolumn)
                istart = 1
                do ic = 1, icycle
                   iend = min(istart+icolumn-1,max_elements,iba(ik))
                   write(nfout,'(" !wf (nx)    ",10i10)') (ngabc(nbase(i,ik),1),i=istart,iend)
                   write(nfout,'(" !wf (ny)    ",10i10)') (ngabc(nbase(i,ik),2),i=istart,iend)
                   write(nfout,'(" !wf (nz)    ",10i10)') (ngabc(nbase(i,ik),3),i=istart,iend)
                   write(nfout,'(" !wf (zaj-r) ",10d10.2)') (wf_l(i,1),i=istart,iend)
                   if(kimg == 2) write(nfout,'(" !wf (zaj-i) ",10d10.2)') (wf_l(i,2),i=istart,iend)
                   write(nfout,'(" !wf abs     ",10d10.2)') (wf_l(i,kimg+1),i=istart,iend)
                   if(kimg == 2) then
                      if(k_symmetry(ik) == GAMMA .or. k_symmetry(ik) == GAMMA_base_symmetrization) then
                         write(nfout,'(" !wf (zaj-r)d",10d10.2)') (wf_l(i,4),i=istart,iend)
                         write(nfout,'(" !wf (zaj-i)d",10d10.2)') (wf_l(i,5),i=istart,iend)
                      end if
                   end if
                   istart = iend+1
                end do
             end if
          end do
       end do
       deallocate(wf_l)
    end if
    call tstatc0_end(id_sname)
  end subroutine m_ESIO_wd_WFs_standardout

  subroutine m_ESIO_rd_WFs_and_EVs_ek(nfout,nf)
    integer, intent(in) :: nfout,nf
    integer  :: ik, ie, iks, ri, ikg, ikt, ike, ike2
    integer, allocatable, dimension(:,:) :: n_mpi, n2_mpi  ! MPI
    real(DP),allocatable, dimension(:,:) :: e_mpi, e2_mpi  ! MPI
!!$    read(nf) neordr,nrvf_ordr,eko_l,occup_l,efermi,totch

    allocate(n_mpi(neg,nspin)); allocate(n2_mpi(neg,nspin)) ! MPI
    allocate(e_mpi(neg,nspin)); allocate(e2_mpi(neg,nspin)) ! MPI
    allocate(wf_l(kg1,kimg))

    n_mpi =0; n2_mpi = 0
    e_mpi =0; e2_mpi = 0; wf_l = 0
    if(ipri >= 1) write(nfout,*) ' !D Reading zaj'

    rewind nf

    eko_ek = 0.d0
!!$    do ik = 1, nk_in_the_process-kv3, kv3
    do ik = 1, nk_in_the_process - nspin, nspin
       if(ipri >= 1) write(nfout,*) ' !D     skipping ik = ', ik
!!$       do iks = 1, kv3, af+1
       do iks = 1, nspin, af+1
          do ie = 1, neg
             if(mype == 0) read(nf) wf_l
          end do
       end do
       if(mype == 0) read(nf) n_mpi
       if(mype == 0) read(nf) n2_mpi
       if(mype == 0) read(nf) e_mpi

       if(mype == 0) then
!!$          do iks = 1, kv3
          do iks = 1, nspin
             do ie = 1, neg
                eko_ek(ie,ik+iks-1) = e_mpi(n_mpi(ie,iks),iks)
             end do
          end do
          if(ipri >= 3) then
!!$             do iks=1,kv3
             do iks=1,nspin
                write(nfout,'(" ik = ",i5)') ik+iks-1
                write(nfout,'(8f8.4)') (e_mpi(n_mpi(ie,iks),iks),ie=1,neg)
             end do
          end if
       end if
    end do
       
    if(nk_in_the_process > kv3_ek) goto 1001

!!$    do ik = 1, kv3, af+1
    KPOINT_LOOP: do ikg = 1, nrank_k
       do ikt = 1, nspin, af+1
          ik = (ikg-1)*nspin+ikt
          if(nk_in_the_process -1 + ik > kv3_ek) exit KPOINT_LOOP
          if(nk_in_the_process -1 + ik > numk_zajsaved) exit KPOINT_LOOP
          if(ipri>=1) write(nfout,*) ' !D     reading  ik = ', ik+first_kpoint_in_this_job-1

          do ie = 1, neg
             if(ipri>=2) write(nfout,*) ' !D     ie = ', ie
             if(mype == 0) read(nf,err=2,end=2) wf_l     ! MPI
             if(mype == 0 .and. map_ek(ie,ik) /= 0) then ! MPI
                call mpi_send(wf_l,kg1*kimg,mpi_real,map_ek(ie,ik),1,mpi_comm_group,ierr) ! MPI
             else if(map_ek(ie,ik) == mype .and. map_ek(ie,ik) /= 0) then                  ! MPI
                call mpi_recv(wf_l,kg1*kimg,mpi_real,0,1,mpi_comm_group,istatus,ierr)     ! MPI
             end if
             if(map_ek(ie,ik) == mype) then              ! MPI
                do ri = 1, kimg
                   zaj_l(1:kg1,map_z(ie),ik,ri) = wf_l(1:kg1,ri)  ! MPI
                end do
             end if
          end do
       end do

       if(mype == 0) read(nf) n_mpi                ! MPI
       if(mype == 0) read(nf) n2_mpi               ! MPI
       call mpi_bcast(n_mpi,neg*nspin,mpi_integer,0,mpi_comm_group,ierr) ! MPI
       call mpi_bcast(n2_mpi,neg*nspin,mpi_integer,0,mpi_comm_group,ierr)! MPI

       do ikt = 1, nspin                             ! MPI
          ik = (ikg-1)*nspin + ikt
          if(map_k(ik) == myrank_k) then
             neordr(1:neg,ik) = n_mpi(1:neg,ikt)     ! MPI
             nrvf_ordr(1:neg,ik) = n2_mpi(1:neg,ikt) ! MPI
          end if
       end do                                        ! MPI

       if(mype == 0) read(nf) e_mpi                ! MPI
       call mpi_bcast(e_mpi,neg*nspin,mpi_double_precision,0,mpi_comm_group,ierr) ! MPI

       do ikt = 1, nspin                                   ! MPI
          ik = (ikg-1)*nspin + ikt
          do ie = 1, neg                                   ! MPI
             if(map_ek(ie,ik) == mype) then                ! MPI
                eko_l(map_z(ie),ik) = e_mpi(ie,ikt)        ! MPI
             end if                                        ! MPI
          end do                                           ! MPI
          do ie = 1, neg
             eko_ek(ie,nk_in_the_process+ik-1) = e_mpi(n_mpi(ie,ikt),ikt)
          end do
       end do                                              ! MPI
       goto 3
2      continue
       stop ' eof from nf <<m_ESIO_rd_WFs_and_EVs_ek>>'
3      continue
    end do KPOINT_LOOP

    if(ipri>=2) write(nfout,*) ' !D     ikg  = ', ikg
!!$    if(ikg <= 1) stop ' ikg <= 1 <<m_ESIO_rd_WFs_and_EVs_ek>>'
    if(ikg < nrank_k .and. ikg > 1 ) then
       do ike = ikg, nrank_k
          if(ipri>=2) write(nfout,*) ' !D     ike  = ', ike
          if(ipri>=2) write(nfout,*) ' !D     zaj_l'
          do ikt = 1, nspin, af+1
             ik   = (ikg-2)*nspin+ikt
             ike2 = (ike-1)*nspin+ikt
             if(ipri>=2) write(nfout,*) ' !D     ik, ike2 = ',ik,ike2
             do ie = 1, neg
                if(map_ek(ie,ik) == mype) then
                   do ri = 1, kimg
                      wf_l(1:kg1,ri) = zaj_l(1:kg1,map_z(ie),ik,ri)
                   end do
                end if

                if(map_ek(ie,ik) == mype) then
                   call mpi_send(wf_l,kg1*kimg,mpi_real,map_ek(ie,ike2),1,mpi_comm_group,ierr)
                else if(map_ek(ie,ike2) == mype) then
                   call mpi_recv(wf_l,kg1*kimg,mpi_real,map_ek(ie,ik),1,mpi_comm_group,istatus,ierr)
                end if
                if(map_ek(ie,ike2) == mype) then
                   do ri = 1, kimg
                      zaj_l(1:kg1,map_z(ie),ike2,ri) = wf_l(1:kg1,ri)
                   end do
                end if
             end do
          end do

          ! ---> neordr, nrvf_ordr
          do ikt = 1, nspin
             ik = (ikg-2)*nspin+ikt
             if(map_k(ik) == myrank_k) then
                n_mpi(1:neg,ikt) = neordr(1:neg,ik)
                n2_mpi(1:neg,ikt) = nrvf_ordr(1:neg,ik)
             end if
          end do
          call mpi_bcast(n_mpi,neg*nspin,mpi_integer,map_k(ik),mpi_comm_group,ierr)
          call mpi_bcast(n2_mpi,neg*nspin,mpi_integer,map_k(ik),mpi_comm_group,ierr)

          if(ipri>=2) write(nfout,*) ' !D     neordr and nrvf_ordr'
          do ikt = 1, nspin
             ike2 = (ike-1)*nspin+ikt
             if(map_k(ike2) == myrank_k) then
                neordr(1:neg,ike2) = n_mpi(1:neg,ikt)     ! MPI
                nrvf_ordr(1:neg,ike2) = n2_mpi(1:neg,ikt) ! MPI
             end if
          end do

          ! ---> eko_l
          if(ipri>=2) write(nfout,*) ' !D     eko_l'
          e_mpi = 0.d0
          do ikt = 1, nspin
             ik = (ikg-2)*nspin+ikt
             if(ipri>=2) write(nfout,'(" !D eko_l ik = ",i6)') ik
             do ie = 1, neg
                if(map_ek(ie,ik) == mype) then
                   e_mpi(ie,ikt) = eko_l(map_z(ie),ik)
                end if
             end do
          end do
          if(npes >= 2) then
             call mpi_allreduce(e_mpi,e2_mpi,neg*nspin,mpi_double_precision &
                  & ,mpi_sum,mpi_comm_group,ierr)
          else
             e2_mpi  = e_mpi
          end if

          if(ipri>=2) then
             write(nfout,'(" <<m_ESIO_rd_WFs_and_EVs_ek>>")')
             do ikt = 1, nspin
                ik = (ikg-2)*nspin+ikt
                write(nfout,'(" ik = ",i5)') ik
                write(nfout,'(10f8.4)') (e2_mpi(ie,ikt),ie=1,neg)
             end do
          end if

          do ikt = 1, nspin
             ike2 = (ike-1)*nspin+ikt
             if(ipri>=2) write(nfout,'(" !D eko_l ike2 = ",i6)') ike2
             do ie = 1, neg
                if(map_ek(ie,ike2) == mype) then
                   eko_l(map_z(ie),ike2) = e2_mpi(ie,ikt)
                end if
             end do
          end do

       end do
    end if

1001 continue

    if(npes >= 2) &
         & call mpi_bcast(eko_ek,neg*kv3_ek,mpi_double_precision,0,mpi_comm_group,ierr)

    if(nk_in_the_process > kv3_ek) goto 1002
    call m_ESIO_wd_EigenValues(nfout,2,nooccupation=YES)

1002 continue

!!$    ik = nk_in_the_process
!!$    do iks = 1, kv3
!!$          do ie = 1, neg
!!$             eko_ek(ie,ik+iks-1) = e_mpi(n_mpi(ie,iks),iks)
!!$          end do
!!$       end do
!!$    end if
!!$
    if(ipri >= 1) then
       write(nfout,'(" <<m_ESIO_rd_WFs_and_EVs_ek>>")')
       do iks = 1, kv3_ek
          if(iks > numk_zajsaved) cycle
          write(nfout,'(" ik = ",i5)') iks
          write(nfout,'(10f8.4)') (eko_ek(ie,iks),ie=1,neg)
       end do
    end if


    rewind nf

    do ik = 1, nk_in_the_process-nspin, nspin
       do iks = 1, nspin, af+1
          do ie = 1, neg
             if(mype == 0) read(nf) wf_l                 ! MPI
          end do
       end do
       if(mype == 0) read(nf) n_mpi                   ! MPI
       if(mype == 0) read(nf) n2_mpi                  ! MPI
       if(mype == 0) read(nf) e_mpi                   ! MPI
    end do

    deallocate(wf_l)                                    ! MPI
    deallocate(n_mpi); deallocate(n2_mpi)               ! MPI
    deallocate(e_mpi); deallocate(e2_mpi)               ! MPI

!!$    write(nfout,'(" ---<< m_ESIO_rd_WFs_and_EVs_ek>>---")')
  end subroutine m_ESIO_rd_WFs_and_EVs_ek

  subroutine m_ESIO_rd_EVs_ek(nfout,nf)
    integer, intent(in) :: nfout,nf
    integer  :: ik, ie, iks
    integer, allocatable, dimension(:,:) :: n_mpi, n2_mpi  ! MPI
    real(DP),allocatable, dimension(:,:) :: e_mpi, e2_mpi  ! MPI

    allocate(n_mpi(neg,nspin)); allocate(n2_mpi(neg,nspin)) ! MPI
    allocate(e_mpi(neg,nspin)); allocate(e2_mpi(neg,nspin)) ! MPI
    allocate(wf_l(kg1,kimg))
    n_mpi =0; n2_mpi = 0
    e_mpi =0; e2_mpi = 0; wf_l = 0

    if(ipri >= 1) write(nfout,*) ' !D Reading zaj <<m_ESIO_rd_EVs_ek>>'

    rewind nf

    eko_ek = 0.d0
!!$    do ik = 1, nk_in_the_process-kv3, kv3
    do ik = 1, nk_in_the_process - nspin, nspin
       if(ipri >= 1) write(nfout,*) ' !D     skipping ik = ', ik
!!$       do iks = 1, kv3, af+1
       do iks = 1, nspin, af+1
          do ie = 1, neg
             if(mype == 0) read(nf) wf_l
          end do
       end do
       if(mype == 0) read(nf) n_mpi
       if(mype == 0) read(nf) n2_mpi
       if(mype == 0) read(nf) e_mpi

       if(mype == 0) then
          do iks = 1, nspin
             do ie = 1, neg
                eko_ek(ie,ik+iks-1) = e_mpi(n_mpi(ie,iks),iks)
             end do
          end do
          if(ipri >= 3) then
             do iks=1,nspin
                write(nfout,'(" ik = ",i5)') ik+iks-1
                write(nfout,'(8f8.4)') (e_mpi(n_mpi(ie,iks),iks),ie=1,neg)
             end do
          end if
       end if
    end do
       
    write(nfout,'(" ---<< m_ESIO_rd_EVs_ek>>---")')
  end subroutine m_ESIO_rd_EVs_ek

  subroutine m_ESIO_wd_Psicoef(ipri,nfout,nf)
    integer, intent(in) :: ipri,nfout, nf

    integer, parameter :: Ncol = 5
    integer :: ik, ie, ri,  nel, ig, ib,ib1,ib2,ibt,ibsize
    integer, allocatable, dimension(:) :: n_mpi
    real(DP),allocatable, dimension(:) :: e_mpi
    real(DP),allocatable, dimension(:,:,:) :: wf

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

    allocate(e_mpi(neg)); e_mpi = 0.d0
    allocate(n_mpi(neg)); n_mpi = 0

    if(mype == 0) write(nf,'(" !!COEFFICIENTS of WAVE functions")')

    KPOINT: do ik = 1, kv3, af+1
       nel = min(Nw_Psicoef,iba(ik))
       allocate(wf_l(nel,kimg)); wf_l = 0.d0
       call wd_k_points()
       e_mpi = 0.d0
       n_mpi = 0
       if(map_k(ik) == myrank_k) then
          if(ipri>=1) then
             write(nfout,'(" ik = ", i4, " neordr ")') ik
             write(nfout,'(8i8)') (neordr(ie,ik),ie=1,neg)
          end if
          do ie = 1, neg
!!$             if(map_ek(ie,ik) == mype) n_mpi(ie) = neordr(ie,ik)
             n_mpi(ie) = neordr(ie,ik)
             if(map_e(ie) /= myrank_e) cycle
             e_mpi(ie) = eko_l(map_z(ie),ik)
          end do
       end if
       if(npes>=2) call mpi_allreduce(MPI_IN_PLACE,e_mpi,neg,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
       if(nrank_k>=2) then
          if(map_ek(1,ik) == mype .and. map_ek(1,ik) /= 0) then
             call mpi_send(n_mpi,neg,mpi_integer,0,1,mpi_comm_group,ierr)
          else if(mype == 0 .and. map_ek(1,ik) /= 0) then
             call mpi_recv(n_mpi,neg,mpi_integer,map_ek(1,ik),1,mpi_comm_group,istatus,ierr)
          end if
!!$          call mpi_allreduce(MPI_IN_PLACE,n_mpi,neg,mpi_integer,mpi_sum,mpi_comm_group,ierr)
       end if
       do ie = 1, neg, Ncol
          ib1 = ie; ib2 = min(ie+Ncol-1,neg)
          ibsize = ib2-ib1+1
          if(mype == 0) then
             allocate(wf(nel,kimg,ibsize)); wf=0.d0
          end if
          do ib = ib1, ib2
!!$             ibt = n_mpi(ib)
             ibt = ib
             if(map_ek(ibt,ik) == mype) then                          ! MPI
                do ri = 1, kimg
                   wf_l(1:nel,ri) = zaj_l(1:nel,map_z(ibt),ik,ri)
                end do
                if(map_ek(ibt,ik) /= 0) &                             ! MPI
                     &   call mpi_send(wf_l,nel*kimg,mpi_real,0,1,mpi_comm_group,ierr) ! MPI
             else if(mype == 0 .and. map_ek(ibt,ik) /= 0) then
                call mpi_recv(wf_l,nel*kimg,mpi_real,map_ek(ibt,ik),1,mpi_comm_group,istatus,ierr)!MPI
             end if
             if(mype == 0) wf(:,:,ib-ib1+1) = wf_l(:,:)
          end do
          call wd_eko(ib1,ib2)
!!$          if(ik <= 2) then
             do ig = 1, nel
                call wd_coef(ibsize,ig)
             end do
!!$          end if
          if(mype == 0) deallocate(wf)
       end do
       deallocate(wf_l)
    end do KPOINT

    call tstatc0_end(id_sname)
  contains
    subroutine wd_coef(ibsize,ig)
      integer, intent(in) :: ibsize,ig
      integer :: ib
!!$      character(3) :: nan
      if(mype == 0) then
         if(kimg==2) then
            write(nf,'(i4," ( ",3i4," )", 5(" (",2f11.5," )"))') &
                 & ig, ngabc(nbase(ig,ik),1:3),(wf(ig,1,ib),wf(ig,2,ib),ib=1,ibsize)
!!$                 & ig, ngabc(nbase(ig,ik),1:3),(wf(ig,1,ie),wf(ig,2,ie),ie=1,3)
         else
!!$            nan="---"
            write(nf,'(i4," ( ",3i4," )", 5(" (",f11.5,4x,"---",4x," )"))') &
                 & ig, ngabc(nbase(ig,ik),1:3),(wf(ig,1,ib),ib=1,ibsize)
!!$            write(nf,'(i4," ( ",3i4," )", 5f11.5)') &
!!$                 & ig, ngabc(nbase(ig,ik),1:3),(wf(ig,1,ie),ie=1,ibsize)
         end if
      end if
    end subroutine wd_coef

    subroutine wd_eko(ib1,ib2)
      integer, intent(in) :: ib1,ib2
      integer :: ie
      if(mype == 0) then
         write(nf,'(a12,5x,a5,5(i7,2x,f10.5,7x))') "ig", "\ e: ", (ie,e_mpi(n_mpi(ie)),ie=ib1,ib2)
      end if
    end subroutine wd_eko

    subroutine wd_k_points()
      if(mype == 0) then
         if(nspin == 1) then
            write(nf,'(" ik = ",i6,"    ( ",3f14.6," )")') ik,(vkxyz(ik,1:3,BUCS))
         else
            if(mod(ik,2) == 1) then
               write(nf,'(" ik = ",i6,"    UP ","    ( ",3f14.6," )")') ik,(vkxyz(ik,1:3,BUCS))
            else
               write(nf,'(" ik = ",i6,"  DOWN ","    ( ",3f14.6," )")') ik,(vkxyz(ik,1:3,BUCS))
            end if
         end if
      end if
    end subroutine wd_k_points
  end subroutine m_ESIO_wd_Psicoef

  subroutine m_ESIO_wd_WFs_and_EVs_ek(nfout,nf)
    integer, intent(in) :: nfout, nf
    integer  :: ik, ie, ri, ikg, ikt
    integer, allocatable, dimension(:,:) :: n_mpi
    real(DP),allocatable, dimension(:,:) :: e_mpi
    integer :: id_sname = -1
    call tstatc0_begin('m_ESIO_wd_WFs_and_EVs_ek ',id_sname)

    allocate(wf_l(kg1,kimg));    wf_l = 0
    call mpi_barrier(mpi_comm_group,ierr)
    if(ipri>=2) write(nfout,'(" !D Writing WaveFunctions ")')

    allocate(n_mpi(neg,nspin)); n_mpi = 0
    allocate(e_mpi(neg,nspin)); e_mpi = 0.d0

    KPOINT: do ikg = 1, nrank_k
       ! ---> zaj_l
       if((ikg-1)*nspin + 1 > kv3) then
          if(ipri >= 1) write(nfout,'(" !D ik > kv3")')
          exit KPOINT
       end if

       do ikt = 1, nspin, af+1
          ik = (ikg-1)*nspin + ikt
          if(ipri>=1) write(nfout,'(" !D Writing WaveFunctions ik = ",i5)') ik
          do ie = 1, neg
             if(map_ek(ie,ik) == mype) then                          ! MPI
                do ri = 1, kimg
                   wf_l(1:kg1,ri) = zaj_l(1:kg1,map_z(ie),ik,ri)
                end do
                if(map_ek(ie,ik) /= 0) &                             ! MPI
                     &   call mpi_send(wf_l,kg1*kimg,mpi_real,0,1,mpi_comm_group,ierr) ! MPI
             else if(mype == 0 .and. map_ek(ie,ik) /= 0) then
                call mpi_recv(wf_l,kg1*kimg,mpi_real,map_ek(ie,ik),1,mpi_comm_group,istatus,ierr)!MPI
             end if
             if(mype == 0) write(nf)  wf_l                        ! MPI
          end do
       end do

       ! --->  neordr
       n_mpi = 0                                          ! MPI
       do ikt = 1, nspin                                  ! MPI
          ik = (ikg-1)*nspin + ikt
          if(map_k(ik) /= myrank_k) cycle                 ! MPI
          n_mpi(1:neg,ikt) = neordr(1:neg,ik)             ! MPI
       end do                                             ! MPI
       if(npes >= 2) then
          call mpi_allreduce(MPI_IN_PLACE,n_mpi,neg*nspin,mpi_integer,mpi_sum &
               &                      ,mpi_comm_group,ierr)  ! MPI
          n_mpi = n_mpi/nrank_e
       end if
       if(ipri>=2) write(nfout,'(" !D Writing neordr ik = ",i5)') ik
       if(mype == 0) write(nf) n_mpi             ! MPI ; writing (neordr)

       ! --->  nrvf_ordr
       n_mpi = 0                                          ! MPI
       do ikt = 1, nspin                                  ! MPI
          ik = (ikg-1)*nspin + ikt
          if(map_k(ik) /= myrank_k) cycle                 ! MPI
          n_mpi(1:neg,ikt) = nrvf_ordr(1:neg,ik)          ! MPI
       end do                                             ! MPI
       if(npes >= 2) then
          call mpi_allreduce(MPI_IN_PLACE,n_mpi,neg*nspin,mpi_integer,mpi_sum &
               &                      ,mpi_comm_group,ierr)  ! MPI
          n_mpi = n_mpi/nrank_e
       end if
       if(ipri>=2) write(nfout,'(" !D Writing nrvf_ordr ik = ",i5)') ik
       if(mype == 0) write(nf) n_mpi             ! MPI ; writing (nrvf_ordr)

       e_mpi = 0.d0                                       ! MPI
       do ikt = 1, nspin                                  ! MPI
          ik = (ikg-1)*nspin + ikt
          if(map_k(ik) /= myrank_k) cycle                 ! MPI
          do ie = 1, neg                                  ! MPI
             if(map_e(ie) /= myrank_e) cycle              ! MPI
             e_mpi(ie,ikt) = eko_l(map_z(ie),ik)           ! MPI
          end do
       end do
       if(npes >= 2) then
          call mpi_allreduce(MPI_IN_PLACE,e_mpi,neg*nspin,mpi_double_precision &
               &               ,mpi_sum,mpi_comm_group,ierr) ! MPI
       end if
       if(ipri>=2) write(nfout,'(" !D Writing eko_l ik = ",i5)') ik
       if(mype == 0) write(nf) e_mpi             ! MPI ; writing (eko_l)
    end do KPOINT

!!$    do ik = 1, kv3, af+1
!!$       do ie = 1, neg
!!$          if(map_ek(ie,ik) == mype) then                          ! MPI
!!$             do ri = 1, kimg
!!$                wf_l(1:kg1,ri) = zaj_l(1:kg1,map_z(ie),ik,ri)
!!$             end do
!!$             if(map_ek(ie,ik) /= 0) &                             ! MPI
!!$            &   call mpi_send(wf_l,kg1*kimg,mpi_real,0,1,mpi_comm_group,ierr) ! MPI
!!$          else if(mype == 0 .and. map_ek(ie,ik) /= 0) then
!!$             call mpi_recv(wf_l,kg1*kimg,mpi_real,map_ek(ie,ik),1,mpi_comm_group,istatus,ierr)!MPI
!!$          end if
!!$          if(mype == 0) write(nf)  wf_l                        ! MPI
!!$       end do
!!$    end do
!!$    deallocate(wf_l)
!!$
!!$    allocate(n_mpi(neg,kv3)); allocate(n2_mpi(neg,kv3))! MPI
!!$    allocate(e_mpi(neg,kv3)); allocate(e2_mpi(neg,kv3))! MPI
!!$
!!$    n_mpi = 0                                          ! MPI
!!$    do ik = 1, kv3                                     ! MPI
!!$       if(map_k(ik) /= myrank_k) cycle                 ! MPI
!!$       n_mpi(1:neg,ik) = neordr(1:neg,ik)              ! MPI
!!$    end do                                             ! MPI
!!$    if(npes >= 2) then
!!$       call mpi_allreduce(n_mpi,n2_mpi,neg*kv3,mpi_integer,mpi_sum &
!!$            &                      ,mpi_comm_group,ierr)  ! MPI
!!$       n2_mpi = n2_mpi/nrank_e
!!$    else
!!$       n2_mpi = n_mpi
!!$    end if
!!$    if(mype == 0) write(nf) n2_mpi             ! MPI ; writing (neordr)
!!$
!!$    n_mpi = 0                                          ! MPI
!!$    do ik = 1, kv3                                     ! MPI
!!$       if(map_k(ik) /= myrank_k) cycle                 ! MPI
!!$       n_mpi(1:neg,ik) = nrvf_ordr(1:neg,ik)           ! MPI
!!$    end do                                             ! MPI
!!$    if(npes >= 2) then
!!$       call mpi_allreduce(n_mpi,n2_mpi,neg*kv3,mpi_integer,mpi_sum &
!!$            &                      ,mpi_comm_group,ierr)  ! MPI
!!$       n2_mpi = n2_mpi/nrank_e
!!$    else
!!$       n2_mpi = n_mpi
!!$    end if
!!$    if(mype == 0) write(nf) n2_mpi             ! MPI ; writing (nrvf_ordr)
!!$
!!$    e_mpi = 0.d0                                       ! MPI
!!$    do ik = 1, kv3                                     ! MPI
!!$       if(map_k(ik) /= myrank_k) cycle                 ! MPI
!!$       do ie = 1, neg                                  ! MPI
!!$          if(map_e(ie) /= myrank_e) cycle              ! MPI
!!$          e_mpi(ie,ik) = eko_l(map_z(ie),ik)           ! MPI
!!$       end do
!!$    end do
!!$    if(npes >= 2) then
!!$       call mpi_allreduce(e_mpi,e2_mpi,neg*kv3,mpi_double_precision &
!!$            &               ,mpi_sum,mpi_comm_group,ierr) ! MPI
!!$    else
!!$       e2_mpi = e_mpi
!!$    end if
!!$    if(mype == 0) write(nf) e2_mpi             ! MPI ; writing (eko_l)

!!$    e_mpi = 0.d0                                       ! MPI
!!$    do ik = 1, kv3                                     ! MPI
!!$       if(map_k(ik) /= myrank_k) cycle                 ! MPI
!!$       do ie = 1, neg                                  ! MPI
!!$          if(map_e(ie) /= myrank_e) cycle              ! MPI
!!$          e_mpi(ie,ik) = occup_l(map_z(ie),ik)         ! MPI
!!$       end do                                          ! MPI
!!$    end do                                             ! MPI
!!$    if(npes >= 2) then
!!$       call mpi_allreduce(e_mpi,e2_mpi,neg*kv3,mpi_double_precision &
!!$            &                  ,mpi_sum,mpi_comm_group,ierr) ! MPI
!!$    else
!!$       e2_mpi = e_mpi
!!$    end if
!!$    if(mype == 0) write(nf) e2_mpi             ! MPI ; writing (occup_l)

    deallocate(wf_l)
    deallocate(n_mpi)
    deallocate(e_mpi)

    call tstatc0_end(id_sname)

  end subroutine m_ESIO_wd_WFs_and_EVs_ek

  subroutine m_ESIO_wd_WFn(nfout,nfwfk,ik,ib)
    integer, intent(in) :: nfout,nfwfk
    integer, intent(in) :: ik,ib
    integer :: jb,ri
    real(kind=DP), allocatable :: bfft(:)
    real(kind=DP) :: eig
    integer :: id_sname = -1
    call tstatc0_begin('m_ESIO_wd_WFn ',id_sname)

    allocate(bfft(nfft));    bfft = 0
    call mpi_barrier(mpi_comm_group,ierr)
    if(ipri >= 1) write(nfout,*) ' !D Writing Wavefunctions '
    rewind nfwfk
    jb = neordr(ib,ik)
    if(map_ek(jb,ik) == mype) then                          ! MPI
       call m_ES_WF_in_Rspace(ik,jb,bfft)
       eig = eko_l(map_z(jb),ik)
       if(map_ek(jb,ik) /= 0) then                             ! MPI
          call mpi_send(bfft,nfft,mpi_double_precision,0,1,mpi_comm_group,ierr) ! MPI
          call mpi_send(eig,1,mpi_double_precision,0,1,mpi_comm_group,ierr) ! MPI
       end if
    else if(mype == 0 .and. map_ek(jb,ik) /= 0) then
       call mpi_recv(bfft,nfft,mpi_double_precision,map_ek(jb,ik),1,mpi_comm_group,istatus,ierr)!MPI
       call mpi_recv(eig,1,mpi_double_precision,map_ek(jb,ik),1,mpi_comm_group,istatus,ierr)!MPI
    end if
    if(mype == 0) then                     ! MPI
       call wd_wf(nfout,nfwfk,ik,ib,eig)
    end if
    deallocate(bfft)
    call tstatc0_end(id_sname)
  contains
    subroutine wd_wf(nfout,nfwfk,ik,ib,eig)
      integer, intent(in) :: nfout,nfwfk,ik,ib
      real(kind=DP), intent(in) :: eig
      integer :: i,j,k, id, nl, nm, nn, nlhf,inew,jnew,knew,ip,mm
      real(kind=DP),allocatable,dimension(:,:,:,:) :: wkwf
      real(kind=DP) ::      x,y,z
      integer, parameter :: UP = 1 , DOWN = 2
      integer ::            up_down
      real(kind=DP),allocatable,dimension(:,:) :: cps_full
      integer, allocatable,dimension(:) :: ityp_full
      integer :: m, nk
      real(kind=DP) :: norm
      real(kind=DP) :: normr,normi
      integer :: n1,n2,n3
      real(kind=DP) :: dn1,dn2,dn3
      integer :: icomp

      id = fft_box_size_WF(1,0)
      mm = fft_box_size_WF(2,0)
      nl = fft_box_size_WF(1,1)
      nm = fft_box_size_WF(2,1)
      nn = fft_box_size_WF(3,1)

      if(kimg == 1) then
         nlhf = id/2
      else
         nlhf = id
      end if

      if(wf_filetype == DENSITY_ONLY &
      & .or. wf_filetype == VTK &
      & .or. wf_filetype == BINARY) then
         allocate(wkwf(nl,nm,nn,2)); wkwf = 0.d0
      else if(wf_filetype == CUBE) then
         allocate(wkwf(nn,nm,nl,2)); wkwf = 0.d0
      end if

      if(nspin==2) then
         if(mod(ik/nspin,2) == 1) then
            up_down = UP
         else
            up_down = DOWN
         end if
      end if
      nk = (ik-1)/nspin+1

      if(ipri >= 2) write(nfout,9001) nl*nm*nn, nl, nm, nn
9001  format(' Wavefunction ',i8,'(',3i5,')')

      if(ipri >= 2) write(nfout,*) ' !D FFT cube mapping start'
      do i = 1, nm
         do j = 1, nn
            do k = 1, nl
               if(kimg == 1 .and. k > nlhf) then
                  knew = id - k
                  jnew = nn+2 - j
                  inew = nm+2 - i
                  if(jnew > nn) then
                     jnew = jnew - nn
                  end if
                  if(inew > nm) then
                     inew = inew - nm
                  end if
               else
                  knew = k; jnew = j; inew = i
               end if
               ip = nlhf*mm*(jnew-1) + nlhf*(inew-1) + knew
               if(wf_filetype == DENSITY_ONLY &
               & .or. wf_filetype == VTK &
               & .or. wf_filetype == BINARY) then
                  wkwf(k,i,j,1) = bfft(ip*2-1)
                  wkwf(k,i,j,2) = bfft(ip*2)
               else if(wf_filetype == CUBE) then
                  wkwf(j,i,k,1) = bfft(ip*2-1)
                  wkwf(j,i,k,2) = bfft(ip*2)
               end if
            end do
         end do
      end do
! Normalization
      normr = 0.d0
      normi = 0.d0
      do i = 1, nm
         do j = 1, nn
            do k = 1, nl
               if(wf_filetype == DENSITY_ONLY &
               & .or. wf_filetype == VTK &
               & .or. wf_filetype == BINARY) then
                  normr = normr + wkwf(k,i,j,1)*wkwf(k,i,j,1)
                  normi = normi + wkwf(k,i,j,2)*wkwf(k,i,j,2)
               else if(wf_filetype == CUBE) then
                  normr = normr + wkwf(j,i,k,1)*wkwf(j,i,k,1)
                  normi = normi + wkwf(j,i,k,2)*wkwf(j,i,k,2)
               end if
            end do
         end do
      end do
      norm = normr + normi
      write(nfout,*) 'Real and imaginary parts of wf = ',normr/norm,normi/norm
      if(wf_filetype == VTK .or. wf_filetype == BINARY) then
         if(normr>normi) then
            norm = normr
            icomp = 1
            write(nfout,*) 'Real part of wf will be outputed.'
         else
            norm = normi
            icomp = 2
            write(nfout,*) 'Imaginary part of wf will be outputed.'
         end if
      end if
      norm = univol*norm/dble(nm*nn*nl)
      norm = 1.d0/dsqrt(norm)
      do i = 1, nm
         do j = 1, nn
            do k = 1, nl
               if(wf_filetype == DENSITY_ONLY &
               & .or. wf_filetype == VTK &
               & .or. wf_filetype == BINARY) then
                  wkwf(k,i,j,1) = norm*wkwf(k,i,j,1)
                  wkwf(k,i,j,2) = norm*wkwf(k,i,j,2)
               else if(wf_filetype == CUBE) then
                  wkwf(j,i,k,1) = norm*wkwf(j,i,k,1)
                  wkwf(j,i,k,2) = norm*wkwf(j,i,k,2)
               end if
            end do
         end do
      end do

      if(wf_filetype == DENSITY_ONLY) then
         write(nfwfk,9001) nl*nm*nn, nl, nm, nn
         write(nfwfk,'(6e13.5)') wkwf
      else if(wf_filetype == BINARY) then
         write(nfwfk) nl*nm*nn, nl, nm, nn
         write(nfwfk) altv, nspin, up_down, nk, ib, eig
         write(nfwfk) wkwf(:,:,:,icomp)
      else if(wf_filetype == VTK) then
         write(nfwfk,'("# vtk DataFile Version 2.0")')
         if(nspin == 2) then
            if(up_down == 1) then
               write(nfwfk,'(" SCF Wavefunction UP : k=",i7," n=",i7," eig=",f20.5)') nk,ib,eig
            else
               write(nfwfk,'(" SCF Wavefunction DOWN : k=",i7," n=",i7," eig=",f20.5)') nk,ib,eig
            end if
         else
            write(nfwfk,'(" SCF Wavefunction : k=",i7," n=",i7," eig=",f20.5)') nk, ib, eig
         end if
         write(nfwfk,'("ASCII")')
         write(nfwfk,'("DATASET STRUCTURED_GRID")')
         write(nfwfk,'("DIMENSIONS",3(1x,i5))') nl+1,nm+1,nn+1
         write(nfwfk,'("POINTS",1x,i10,1x,"float")') (nl+1)*(nm+1)*(nn+1)
         do n1=0,nl
            do n2=0,nm
               do n3=0,nn
                  dn1 = n1/dble(nl)
                  dn2 = n2/dble(nm)
                  dn3 = n3/dble(nn)
                  x = altv(1,1)*dn1 + altv(1,2)*dn2 + altv(1,3)*dn3
                  y = altv(2,1)*dn1 + altv(2,2)*dn2 + altv(2,3)*dn3
                  z = altv(3,1)*dn1 + altv(3,2)*dn2 + altv(3,3)*dn3
                  write(nfwfk,'(3(1x,e13.5))') x,y,z
               end do
            end do
         end do
         write(nfwfk,'("")')
         write(nfwfk,'("POINT_DATA",1x,i10)') (nl+1)*(nm+1)*(nn+1)
         write(nfwfk,'("SCALARS scalars float")')
         write(nfwfk,'("LOOKUP_TABLE default")')
         do n1=0,nl
            i=n1+1
             if(n1==nl) i=1
            do n2=0,nm
               j=n2+1
               if(n2==nm) j=1
               do n3=0,nn
                  k=n3+1
                  if(n3==nn) k=1
                  write(nfwfk,'(e13.5)') wkwf(i,j,k,icomp)
               end do
            end do
         end do
      else if(wf_filetype == CUBE) then
         if(len_trim(wf_title) >= 1) then
            write(nfwfk,*) trim(wf_title)
         else
            write(nfwfk,'(" Calculated by phase")')
         end if
         if(nspin == 2) then
            if(up_down == 1) then
               write(nfwfk,'(" SCF Wavefunction UP : k=",i7," n=",i7," eig=",f20.5)') nk,ib,eig
            else
               write(nfwfk,'(" SCF Wavefunction DOWN : k=",i7," n=",i7," eig=",f20.5)') nk,ib,eig
            end if
         else
            write(nfwfk,'(" SCF Wavefunction : k=",i7," n=",i7," eig=",f20.5)') nk, ib, eig
         end if
         x = 0.d0; y = 0.d0; z = 0.d0
         write(nfwfk,'(i6,3f10.4)') -natm2, x,y,z
         do i = 1, 3
            write(nfwfk,'(i6,3f10.6)') fft_box_size_WF(i,1), altv(1:3,i)/dble(fft_box_size_WF(i,1))
         end do

         allocate(cps_full(natm2,3))
         allocate(ityp_full(natm2))
         cps_full = 0; ityp_full = 0
         call m_IS_pack_all_ions_in_uc(ityp_full,cps_full)
         do i = 1, natm2
            m = ityp_full(i)
            write(nfwfk,'(f8.4,4f10.6)') iatomn(m), ival(m), cps_full(i,1:3)
         end do
         deallocate(ityp_full,cps_full)

         write(nfwfk,'(10i5)') 2,1,2
         write(nfwfk,'(6e13.5)') wkwf(:,:,:,1)
         write(nfwfk,'(6e13.5)') wkwf(:,:,:,2)
  
      end if
      if(allocated(wkwf)) deallocate(wkwf)
    end subroutine wd_wf
  end subroutine m_ESIO_wd_WFn

  logical function m_ESIO_check_energy(ik,ib)
    integer, intent(in) :: ik,ib
    integer :: jb
    real(kind=DP) :: eig
    jb = neordr(ib,ik)
    if(map_ek(jb,ik) == mype) then
       eig = eko_l(map_z(jb),ik)
       if(eig >= eigmin_wf .and. eig <= eigmax_wf) then
          m_ESIO_check_energy = .true.
       else
          m_ESIO_check_energy = .false.
       end if
    end if
    call mpi_bcast(m_ESIO_check_energy,1,mpi_logical,map_ek(jb,ik),mpi_comm_group,ierr) ! MPI
  end function m_ESIO_check_energy

  subroutine m_ESIO_wd_efermi(nfout,nfefermi)
    integer, intent(in) :: nfout, nfefermi
#ifdef __TIMER_SUB__
  call timer_sta(1377)
#endif

    if(mype == 0) then
#ifdef __TIMER_IODO__
  call timer_sta(1460)
#endif
       write(nfefermi,'(f16.8," : Efermi")') efermi
       if(sw_fix_total_spin == YES .and. nspin == 2) then
          write(nfefermi,'(2f16.8," : Ffermi_spin(1), Efermi_spin(2)")') &
               & efermi_spin(1),efermi_spin(2)
       end if
#ifdef __TIMER_IODO__
  call timer_end(1460)
#endif
    end if
#ifdef __TIMER_SUB__
  call timer_end(1377)
#endif
  end subroutine m_ESIO_wd_efermi

  subroutine m_ESIO_rd_Efermi(nfout,nfefermi)
    integer, intent(in) :: nfout, nfefermi
#ifdef __TIMER_SUB__
  call timer_sta(1376)
#endif
    if(mype == 0) then
#ifdef __TIMER_IODO__
  call timer_sta(1458)
#endif
       read(nfefermi,*,err=1001,end=1001) efermi
       write(nfout,'(" ! efermi = ",f16.8," : this is read from nfefermi")') efermi
       if(sw_fix_total_spin == YES .and. nspin == 2) then
          read(nfefermi,*,err=1002,end=1002) efermi_spin(1),efermi_spin(2)
          write(nfout,'(" ! efermi_spin = ",2f16.8," : these are read from nfefermi")') efermi_spin(1:2)
       end if
#ifdef __TIMER_IODO__
  call timer_end(1458)
#endif
       goto 1010
1001   continue
       efermi = 0.d0
1002   continue
       if(sw_fix_total_spin == YES .and. nspin == 2) then
          efermi_spin(1) = 0.d0; efermi_spin(2) = 0.d0
       end if
1010   continue
    end if
    if(npes > 1) then
#ifdef __TIMER_IOCOMM__
  call timer_barrier(mpi_comm_group)
  call timer_sta(1459)
#endif
       call mpi_bcast(efermi,1,mpi_double_precision,0,mpi_comm_group,ierr)
       if(sw_fix_total_spin == YES .and. nspin == 2) then
          call mpi_bcast(efermi_spin,2,mpi_double_precision,0,mpi_comm_group,ierr)
       end if
#ifdef __TIMER_IOCOMM__
  call timer_end(1459)
#endif
    end if
#ifdef __TIMER_SUB__
  call timer_end(1376)
#endif
  end subroutine m_ESIO_rd_Efermi


end module m_ES_IO
