!
! =========== Contributions ===================================
!
! Through the courtesy of contributors, the following functions are added.
!
! Company:  ASMS Co.,Ltd.
! Functions:  [Identifier: 13.0D]
!                     NEB works with PAW
!
! =============================================================

subroutine do_neb()
  use m_Files,                only : nfneb
  use m_Const_Parameters, only : OFF,ON
  use m_IterationNumbers, only : iteration,iteration_electronic,iteration_ionic
  use m_Replica
  use m_Parallelization, only : mpi_comm_group, mype

! ======================== KT_add ================= 13.0D
  use m_Files,         only :  m_Files_open_nfcntn_bin_paw, nfout, nfcntn_bin_paw
  use m_PseudoPotential,  only : flg_paw, m_PP_rd_PAW_parameters
  use m_Charge_Density,    only :  m_CD_alloc_chgsoft
! ================================================= 13.0D

  use m_Control_Parameters, only : sw_fcp
  use m_Fcp, only :  m_Fcp_set_neb_replica_totch, &
     m_Fcp_set_neb_replica_force, m_Fcp_update_neb, m_Fcp_set_neb_parameter, &
     m_Fcp_allreduce_neb_force, m_Fcp_initialize_neb_totch

  implicit none
  logical  :: ChargeDensity_is_Converged, TotalEnergy_is_Divergent
  logical  :: Already_Converged, Positron_bulk
  logical  :: Hubbard_model
  logical  :: Forces_are_Converged, Ending_Time, Ending_Time2, Force_errors_are_tolerable
  logical  :: replica_converged

  integer i, j, itr
  integer mpi_err
  logical all_conv_flag

  integer prepare_communicator
  logical :: pp_generated

  include 'mpif.h'

  call initialize_neb

  !call Initialization(OFF)
  !call InputData_Analysis(OFF) ! rd_cntn_data = ON

  call set_neb_condition
  call create_replica

  itr = 0
  all_conv_flag = all(neb%image(:)%scf_convergence)  ! for restart
  prepare_communicator = ON
  pp_generated=.false.

  NEBIteration: do

     itr = itr + 1
     if(all(neb%image(:)%scf_convergence)) then
        neb%step = neb%step + 1
     end if
     call set_neb_parameter(itr)
     if( sw_fcp == ON ) call m_Fcp_set_neb_parameter(itr)

     MultiReplica: do i = 1, neb%number_of_images

        if(mod(i-1,nrank_r) /= mype_r) then
           neb%image(i)%scf_convergence = .true. 
           cycle
        end if

        if(neb%cond%condition == 1) then
           if(itr == 1 .and. (.not. all_conv_flag)) then
              if(neb%image(i)%scf_convergence) then
                 !neb%image(i)%energy = neb%image(i)%energy0
                 !neb%image(i)%force = neb%image(i)%force0
                 !neb%image(i)%force_org = neb%image(i)%force0
                 cycle
              end if
           end if
        end if

        if(itr > 1 .and. (i==1 .or. i==neb%number_of_images)) then
           neb%image(i)%energy = neb%image(i)%energy0
           neb%image(i)%force = neb%image(i)%force0
           neb%image(i)%force_org = neb%image(i)%force0
           cycle
        end if

!        write(nfneb,*) 'neb: ', neb%step, i, mype
        if (mype==0) write(nfneb,*) 'neb: ', neb%step, i

        call set_neb_replica_parameter(i)
        call set_neb_replica_coordinate(i)

        if(.not.neb%image(i)%scf_convergence) then
           call InputData_Analysis_neb()
        end if

        call Preparation                   ! Basis set, symmetry check etc.
        call Preparation_for_mpi(prepare_communicator)           ! mpi

! ======================== KT_mod ================= 13.0D
!        if (.not.pp_generated) then
!          call PseudoPotential_Construction
!          pp_generated = .true.
!        endif

        if (.not.pp_generated) then
           call PseudoPotential_Construction
           pp_generated = .true.
#ifdef ENABLE_ESM_PACK
           call Preparation_for_ESM()
#endif
        else
           if ( flg_paw ) then
              if ( itr > 1 .or. neb%cond%condition == 1 ) then
                 call m_PP_rd_PAW_parameters(nfout,nfcntn_bin_paw)
              endif
              call m_CD_alloc_chgsoft
           endif
        endif
! ================================================= 13.0D

        call Ewald_and_Structure_Factor
        call Initial_Electronic_Structure
        call Initial_MD_Condition

        if( sw_fcp == ON ) then
           call m_Fcp_initialize_neb_totch()
           call m_Fcp_set_neb_replica_totch(i)
        end if

        if(neb%cond%condition == 1 .and. neb%image(i)%scf_convergence) then 
           iteration = 0
           iteration_electronic = 0
           iteration_ionic = 0
        end if
        neb%image(i)%scf_convergence = .true.

        if(.not.Already_Converged()) then
           AtomicConfiguration: do
              ChargeDensity:    do
                 call IterationNumber_Setting
                 call Renewal_of_WaveFunctions
                 call ChargeDensity_Construction(1)
                 call ChargeDensity_Mixing
                 call Renewal_of_Potential
                 if(Hubbard_model()) then
                    call Renewal_of_Hubbard_Potential
                 end if
!                 if(Ending_Time())                 exit ChargeDensity
                 if(Ending_Time()) then
                    neb%image(i)%scf_convergence = .false.
                    exit AtomicConfiguration
                 end if
                 if(TotalEnergy_is_Divergent())    exit ChargeDensity                    
                 if(ChargeDensity_is_Converged())  exit ChargeDensity
              enddo ChargeDensity
              call Forces
!              if(Forces_are_Converged()) exit AtomicConfiguration
              exit AtomicConfiguration
!!$              if(Force_errors_are_tolerable()) then
!!$                 call Move_Ions
!!$                 call Ewald_and_Structure_Factor
!!$                 call MDIterationNumber_Setting
!!$              end if

           enddo AtomicConfiguration

        end if

!        if(.not.Ending_Time2()) call set_neb_replica_energy_force(i)
        call set_neb_replica_energy_force(i)
        if( sw_fcp == ON ) call m_Fcp_set_neb_replica_force(i)

!!$        if(Positron_bulk()) then
!!$           call Renewal_of_pPotential()
!!$           call Solve_pWaveFunctions()
!!$        end if

!!$        call Postprocessing
        call WriteDownData_onto_Files(.true.)

        call deallocate_array

        if (mype==0) write(nfneb,*) 'scf convergence: ', i, neb%image(i)%scf_convergence

!!        prepare_communicator=OFF
        first_replica_done = .true.
     end do MultiReplica

     call allreduce_scf_convergence
     call allreduce_neb_energy_force
     if( sw_fcp == ON ) call m_Fcp_allreduce_neb_force(nrank_r)

     if(.not. all(neb%image(:)%scf_convergence)) then
        if( mype==0) write(nfneb,*) 'scf not convergence...'
        exit NEBIteration
     end if

!     call allreduce_neb_energy_force

     call force_neb
     call atom_update_neb
     if( sw_fcp == ON ) call m_Fcp_update_neb(neb%dt, neb%cond%time_integral)
!     call atom_update_pos_neb

     if(replica_converged()) then
        exit NEBIteration
     end if
     if(neb%step >= neb%max_iteration) then
        exit NEBIteration
     end if
        
  end do NEBIteration

  call write_down_data_replica

  call finalize_neb()
  call mpi_finalize(mpi_err)
end subroutine do_neb

!   Nudged Elastic Band Method
!   Nobutaka Nishikawa

subroutine initialize_neb

  use m_Parallelization,      only : mpi_comm_group, nrank_e, nrank_k, nrank_conf, mype_conf
  use m_Files,                only : nfneb, F_NEB_OUT
  use m_Replica

  implicit none
  integer i, j
  integer npes,mype,icolor,ikey,mpi_err
  integer, allocatable ::  new_comm_world(:)
!  integer nrank_r, mype_r
  integer mype_e, npes_e
  integer iargc
  character(100) arg
  character(4) image_name

  include 'mpif.h'

  nrank_r = nrank_conf
  mype_r  = mype_conf
  neb%step = 0

!  write(6,*) 'program start...'
!  write(6,*)
!
!  call mpi_init(mpi_err)
!
!  call mpi_comm_size(mpi_comm_world,npes,mpi_err)
!!  call mpi_comm_rank(mpi_comm_world,mype,mpi_err)
!
!  nrank_r = 0
!  if(mype==0) then
!     do i = 1, iargc()
!        call getarg(i,arg)
!        if( arg(1:3) == 'nr=' ) then
!           read(arg(4:),*) nrank_r
!        end if
!     end do
!  end if
!  if(nrank_r == 0) nrank_r = npes
!  call mpi_bcast(nrank_r,1,mpi_integer,0,mpi_comm_world,mpi_err)
!
!  allocate(new_comm_world(0:nrank_r-1))
!  do i=0,nrank_r-1
!     icolor = 0
!     ikey = 0
!     do j=0, npes/nrank_r-1
!        if(mype == j + (npes/nrank_r)*i ) then
!           icolor = 1
!           ikey = i
!        end if
!     end do
!     call mpi_comm_split( mpi_comm_world, icolor, ikey, new_comm_world(i), mpi_err )
!  end do
!
!  mype_r = mype/(npes/nrank_r)
!  mpi_comm_group = new_comm_world(mype_r)
!
!  call mpi_comm_size(mpi_comm_group,npes_e,mpi_err)
!  call mpi_comm_rank(mpi_comm_group,mype_e,mpi_err)
!
!  write(6,'("mpi: pe=",i4,",  npes=",i4,",  comm=",i20)') mype, npes, mpi_comm_world
!  write(6,'("   neb: ",i4,",  nr=",i4,"    energy: ",i4,",  ne*nk=",i4,",  comm=",i20)') &
!       mype_r, nrank_r, mype_e, npes_e, mpi_comm_group
!  write(6,*)
!
!  neb%step = 0

end subroutine initialize_neb

subroutine initialize_neb_ep

  use m_Parallelization,      only : mpi_comm_group
  use m_Files,                only : nfneb, F_NEB_OUT
  use m_Replica

  implicit none

  integer mype, npes, mpi_err

  include 'mpif.h'

  call mpi_init(mpi_err)

  call mpi_comm_size(mpi_comm_world,npes,mpi_err)
  call mpi_comm_rank(mpi_comm_world,mype,mpi_err)

  mpi_comm_group = mpi_comm_world

  neb%step = 0

  write(6,'(a6,4i5)') ' mpi: ', mype, npes, mpi_comm_world, mpi_comm_group

end subroutine initialize_neb_ep

subroutine set_neb_condition

  use m_Control_Parameters, only : icond, multiple_replica_max_iteration
  use m_Ionic_System,  only : neb_max_iteration, neb_dt, ci_neb &
                            , sp_k_init, sp_k_min, sp_k_max, sp_k_variable &
                            , penalty_function &
                            , neb_convergence_condition, neb_convergence_threshold &
                            , neb_time_integral
  use m_Files,         only : F_OUT, F_DYNM, F_ENF, F_CHGT, F_CNTN, F_CNTN_BIN &
                            , F_ZAJ, F_CHR, nfneb, F_NEB_OUT &
                            , nfnebenf, F_NEB_ENF, nfnebdynm, F_NEB_DYNM &
                            , nfdynm, nfenf, nfout
  use m_Parallelization,      only : mpi_comm_group
  use m_Replica

! ======================== KT_add ================= 13.0D
  use m_PseudoPotential,  only : flg_paw
  use m_Files,         only : F_CNTN_BIN_PAW
! ================================================= 13.0D

! ====== KT_add === 2014/07/20
  use m_Control_parameters, only : ipriparadeb, reuse_nfout_for_nfneb
  use m_Files,         only : F_OUT_BASE, F_CONF_EXTENSION, F_Para_EXTENSION
! ================= 2014/07/20

  implicit none

  integer mype, npes, mpi_err
  integer mype_e, npes_e
  character(4) image_name

  logical :: existence

  include 'mpif.h'

  call mpi_comm_size(mpi_comm_world,npes,mpi_err)
  call mpi_comm_rank(mpi_comm_world,mype,mpi_err)
  call mpi_comm_size(mpi_comm_group,npes_e,mpi_err)
  call mpi_comm_rank(mpi_comm_group,mype_e,mpi_err)

! ====== KT_add ======== 2014/07/20
  if ( mype_e == 0 ) then
     close(nfout)
  else if(ipriparadeb == 0) then
     close(nfout, status='delete')
  else
     close(nfout, status='keep')
  end if
! ===================== 2014/07/20

! === KT_mod ========== 2014/07/20
#ifdef NEB_NEW_FILENAMES
  if ( reuse_nfout_for_nfneb == 1 ) then
     neb%file%F_NEB_OUT = trim(F_OUT_BASE) // trim(adjustl(F_CONF_EXTENSION)) &
          &                                // trim(adjustl(F_PARA_EXTENSION))
     if (mype_e==0) then
        open(nfneb,file=neb%file%F_NEB_OUT,status='unknown',position='append')
     endif
  else
!     neb%file%F_NEB_OUT = trim(F_NEB_OUT) // trim(adjustl(F_CONF_EXTENSION)) &
!          &                               // trim(adjustl(F_PARA_EXTENSION))
     neb%file%F_NEB_OUT = trim(F_OUT_BASE) // '_neb' &
          &                                // trim(adjustl(F_CONF_EXTENSION)) &
          &                                // trim(adjustl(F_PARA_EXTENSION))
     if (mype_e==0) open(nfneb,file=neb%file%F_NEB_OUT)
  endif
#else
  if(npes > 1) then
     write(image_name,'(a1,i3.3)') 'p', mype
     neb%file%F_NEB_OUT = trim(F_NEB_OUT)//'_'//image_name
  else
     neb%file%F_NEB_OUT = trim(F_NEB_OUT)
  end if
  open(nfneb,file=neb%file%F_NEB_OUT)
#endif
! ===================== 2014/07/20

  !write(nfneb,'(a6,4i5)') ' mpi: ', mype, npes, mpi_comm_world, mpi_comm_group
  !write(nfneb,'(a6,8i8)') ' mpi: ', mype, npes, mpi_comm_world, &
  !     mype_r, nrank_r, &
  !     mype_e, npes_e, mpi_comm_group

  neb%cond%condition = icond
  if (mype_e==0) write(nfneb,*) 'neb_condition: ', neb%cond%condition

  !neb%max_iteration = neb_max_iteration
  neb%max_iteration = multiple_replica_max_iteration
  if (mype_e==0) write(nfneb,*) 'max_iteration: ', neb%max_iteration

  neb%dt = neb_dt
  if (mype_e==0) write(nfneb,*) 'dt: ', neb%dt

  neb%cond%k_spring_init = sp_k_init
  neb%cond%k_spring_min = sp_k_min
  neb%cond%k_spring_max = sp_k_max
  if (mype_e==0) write(nfneb,'(a11,3f10.5)') 'k_spring: ', &
       neb%cond%k_spring_init,neb%cond%k_spring_min,neb%cond%k_spring_max

  select case(sp_k_variable)
  case(0)
     neb%cond%k_variable = .false.
  case(1)
     neb%cond%k_variable = .true.
  end select
  if (mype_e==0) write(nfneb,*) 'sp_k_variable: ', neb%cond%k_variable

  select case(ci_neb)
  case(0)
     neb%cond%climbing_image = .false.
  case(1)
     neb%cond%climbing_image = .true.
  end select
  if (mype_e==0) write(nfneb,*) 'ci_neb: ', neb%cond%climbing_image

  neb%cond%ci_neb_start = 0
  neb%cond%ci_neb_end = 0

  select case(penalty_function)
  case(0)
     neb%cond%penalty_function = .false.
  case(1)
     neb%cond%penalty_function = .true.
  end select
  if (mype_e==0) write(nfneb,*) 'penalty_function: ', neb%cond%penalty_function

  neb%cond%k_damping = .false.
  neb%cond%k_damping_factor = 1.0d0

  neb%cond%convergence_condition = neb_convergence_condition
  if (mype_e==0) write(nfneb,*) 'convergence_condition: ', neb%cond%convergence_condition
  neb%cond%convergence_threshold = neb_convergence_threshold
  if (mype_e==0) write(nfneb,*) 'convergence_threshold: ', neb%cond%convergence_threshold
  
  !neb%cond%time_integral = 'verlet'
  !neb%cond%time_integral = 'velocity_verlet'
  neb%cond%time_integral = 'steepest_descent'
  select case(neb_time_integral)
  case(2)
     neb%cond%time_integral = 'velocity_verlet'
  case(12)
     neb%cond%time_integral = 'steepest_descent'
  end select
  if (mype_e==0) write(nfneb,*) 'time_integral: ', neb%cond%time_integral

  neb%file%F_OUT = F_OUT
  !neb%file%F_DYNM = F_DYNM
  !neb%file%F_ENF = F_ENF
  neb%file%F_CHGT = F_CHGT
  neb%file%F_CNTN = F_CNTN
  neb%file%F_CNTN_BIN = F_CNTN_BIN
  neb%file%F_ZAJ = F_ZAJ
  neb%file%F_CHR = F_CHR

! ======================== KT_add ================= 13.0D
  neb%file%F_CNTN_BIN_PAW = F_CNTN_BIN_PAW
! ================================================= 13.0D

  if (mype_e==0) then
     write(nfneb,*) 'F_OUT: ', trim(neb%file%F_OUT)
  !write(nfneb,*) 'F_DYNM: ', trim(neb%file%F_DYNM)
  !write(nfneb,*) 'F_ENF: ', trim(neb%file%F_ENF)
     write(nfneb,*) 'F_CHGT: ', trim(neb%file%F_CHGT)
     write(nfneb,*) 'F_CNTN: ', trim(neb%file%F_CNTN)
     write(nfneb,*) 'F_CNTN_BIN: ', trim(neb%file%F_CNTN_BIN)
     write(nfneb,*) 'F_ZAJ: ', trim(neb%file%F_ZAJ)
     write(nfneb,*) 'F_CHR: ', trim(neb%file%F_CHR)

! ======================== KT_add ================= 13.0D
     if ( flg_paw ) then
        write(nfneb,*) 'F_CNTN_BIN_PAW: ', trim(neb%file%F_CNTN_BIN_PAW)
     endif
! ================================================= 13.0D
  end if

  if(mype == 0) then
     if(neb%cond%condition==1)then
       open(nfnebenf, file=F_NEB_ENF,access='append')
       open(nfnebdynm, file=F_NEB_DYNM,access='append')
     else
       open(nfnebenf, file=F_NEB_ENF)
       open(nfnebdynm, file=F_NEB_DYNM)

       write(nfnebenf,*) '#step  image  image_distance  energy   force_org  force_neb  force_normal'
       write(nfnebdynm,*) '#step  image  atom  cps'
     endif

  end if

end subroutine set_neb_condition

subroutine set_neb_parameter(itr)

  use m_Replica
  use m_Files, only : nfneb

  implicit none
  integer, intent(in) :: itr
  integer i

  do i = 1, neb%number_of_images
     if(itr==1.and.neb%image(i)%scf_convergence.and.neb%cond%condition==1) cycle
     neb%image(i)%energy0 = neb%image(i)%energy
     neb%image(i)%energy = 0.0d0
     neb%image(i)%force0 = neb%image(i)%force
     neb%image(i)%force = 0.0d0
     neb%image(i)%force_org = 0.0d0
!     neb%image(i)%scf_convergence = .true.
  end do

end subroutine set_neb_parameter

subroutine set_neb_replica_parameter(image_id)

  use m_Control_parameters, only : icond, ipriparadeb
  use m_IterationNumbers, only : iteration,iteration_electronic,iteration_ionic
  use m_Replica
  use m_Files
  use m_Parallelization,  only : mype

! ======================== KT_add ================= 13.0D
  use m_PseudoPotential,  only : flg_paw
! ================================================= 13.0D

  implicit none

  integer image_id
  character(4) image_name

  character(100) :: F_OUT_NEW

  if( neb%step > 1 .and. icond == 0) then
     icond = 1
  end if

  write(image_name,'(a1,i3.3)') 'r', image_id
  
  F_OUT = trim(neb%file%F_OUT)//'_'//image_name

! ===== KT_add === 2014/07/20
#ifdef NEB_NEW_FILENAMES
!  F_OUT = trim(F_OUT_BASE)//'_'//image_name &
!       &              //trim(F_CONF_EXTENSION)//trim(F_PARA_EXTENSION)
  F_OUT = trim(adjustl(F_OUT_BASE)) // '_' //image_name &
       &                             // trim(adjustl(F_PARA_EXTENSION))
! ================ 2014/07/20
#endif

  !F_DYNM = trim(neb%file%F_DYNM)//'_'//image_name
  !F_ENF = trim(neb%file%F_ENF)//'_'//image_name
  F_CHGT = trim(neb%file%F_CHGT)//'_'//image_name
  F_CNTN = trim(neb%file%F_CNTN)//'_'//image_name
  F_CNTN_BIN = trim(neb%file%F_CNTN_BIN)//'_'//image_name
  F_ZAJ = trim(neb%file%F_ZAJ)//'_'//image_name
  F_CHR = trim(neb%file%F_CHR)//'_'//image_name

! ======================== KT_add ================= 13.0D
  F_CNTN_BIN_PAW = trim(neb%file%F_CNTN_BIN_PAW)//'_'//image_name
! ================================================= 13.0D

  F_ZAJ_in      = F_ZAJ
  F_CHGT_in     = F_CHGT
  F_CNTN_BIN_in = F_CNTN_BIN
  F_CNTN_in     = F_CNTN

! ======================== KT_add ================= 13.0D
  F_CNTN_BIN_PAW_in = F_CNTN_BIN_PAW
! ================================================= 13.0D

  if ( mype == 0 ) then
     write(nfneb,*) 'F_OUT: ', trim(F_OUT)
  !write(nfneb,*) 'F_DYNM: ', trim(F_DYNM)
  !write(nfneb,*) 'F_ENF: ', trim(F_ENF)
     write(nfneb,*) 'F_CHGT: ', trim(F_CHGT)
     write(nfneb,*) 'F_CNTN: ', trim(F_CNTN)
     write(nfneb,*) 'F_CNTN_BIN: ', trim(F_CNTN_BIN)
     write(nfneb,*) 'F_ZAJ: ', trim(F_ZAJ)
     write(nfneb,*) 'F_CHR: ', trim(F_CHR)
     
! ======================== KT_add ================= 13.0D
     if ( flg_paw ) write(nfneb,*) 'F_CNTN_BIN_PAW: ', trim(F_CNTN_BIN_PAW)
! ================================================= 13.0D
  endif

  if( neb%step == 1) then
     close(nfout)
     !close(nfdynm)
     !close(nfenf)
     open(nfout,file=trim(F_OUT))
     !open(nfdynm,file=trim(F_DYNM))
     !open(nfenf,file=trim(F_ENF))
  else
     close(nfout)
     !close(nfdynm)
     !close(nfenf)
     open(nfout,file=trim(F_OUT),position='append')
     !open(nfdynm,file=trim(F_DYNM),position='append')
     !open(nfenf,file=trim(F_ENF),position='append')
  end if

  close(nfcntn)
  close(nfcntn_bin)
  open(nfcntn,file=trim(F_CNTN))
  open(nfcntn_bin,file=trim(F_CNTN_BIN),form='unformatted')

! ======================== KT_add ================= 13.0D
  if ( flg_paw ) then
!     close(nfcntn_bin_paw)
!     open(nfcntn_bin_paw,file=trim(F_CNTN_BIN_PAW),form='unformatted')

     call m_Files_close_nfcntn_bin_paw()
     call m_Files_open_nfcntn_bin_paw()
  endif
! ================================================= 13.0D

  iteration = 0
  iteration_electronic = 0
  iteration_ionic = 0

end subroutine set_neb_replica_parameter

subroutine create_replica

  use m_Ionic_System,  only : number_of_replicas, natm &
                            , pos_end0, pos_end1, cps_end0, cps_end1 &
                            , replica_howtogive_coordinates, replica_endpoints &
                            , pos_image, cps_image &
                            , imdtyp
  use m_Files,         only : nfneb, nfnebcntn, F_NEB_CNTN
  use m_Const_Parameters,  only : FILE, PROPORTIONAL, ON
  use m_Replica
  use m_Parallelization,  only : mype
  use m_Control_Parameters, only : sw_fcp
  use m_Fcp,                only : m_Fcp_create_replica, m_Fcp_read_totch_replica

  implicit none

  integer i, j
  integer end0, end1
  character token

  neb%number_of_images = number_of_replicas + 2
  if (mype==0) write(nfneb,*) 'number_of_images: ', neb%number_of_images

  ! temporary
  allocate(neb%energy(neb%max_iteration,neb%number_of_images))  
  neb%energy = 0.0d0

  allocate(neb%image(neb%number_of_images))
  do i = 1, neb%number_of_images
     neb%image(i)%num_atom = natm

     neb%image(i)%energy = 0.0d0
     neb%image(i)%energy0 = 0.0d0

     allocate(neb%image(i)%pos(neb%image(i)%num_atom,3))
     allocate(neb%image(i)%pos0(neb%image(i)%num_atom,3))
     allocate(neb%image(i)%cps(neb%image(i)%num_atom,3))
     allocate(neb%image(i)%cps0(neb%image(i)%num_atom,3))
     allocate(neb%image(i)%tau(neb%image(i)%num_atom,3))
     allocate(neb%image(i)%force(neb%image(i)%num_atom,3))
     allocate(neb%image(i)%force0(neb%image(i)%num_atom,3))
     allocate(neb%image(i)%force_org(neb%image(i)%num_atom,3))
     allocate(neb%image(i)%spring_force(neb%image(i)%num_atom,3))
     allocate(neb%image(i)%true_force(neb%image(i)%num_atom,3))
     allocate(neb%image(i)%fix_flag(neb%image(i)%num_atom))
     allocate(neb%image(i)%velocity(neb%image(i)%num_atom,3))
     allocate(neb%image(i)%velocity0(neb%image(i)%num_atom,3))
     neb%image(i)%pos = 0.0d0
     neb%image(i)%pos0 = 0.0d0
     neb%image(i)%cps = 0.0d0
     neb%image(i)%cps0 = 0.0d0
     neb%image(i)%tau = 0.0d0
     neb%image(i)%force = 0.0d0
     neb%image(i)%force0 = 0.0d0
     neb%image(i)%force_org = 0.0d0
     neb%image(i)%spring_force = 0.0d0
     neb%image(i)%true_force = 0.0d0
     neb%image(i)%fix_flag = 0
     neb%image(i)%velocity = 0.0d0
     neb%image(i)%velocity0 = 0.0d0

     neb%image(i)%scf_convergence = .true.
  end do

  end0 = 1
  end1 = neb%number_of_images

  neb%image(end0)%pos = pos_end0
  neb%image(end0)%cps = cps_end0
  neb%image(end1)%pos = pos_end1
  neb%image(end1)%cps = cps_end1

  do i = 2, neb%number_of_images-1
     do j = 1, neb%image(i)%num_atom
        neb%image(i)%cps(j,:) = neb%image(end0)%cps(j,:) &
             + real(i-1) * (neb%image(end1)%cps(j,:) - neb%image(end0)%cps(j,:)) &
             / real(end1-end0)
        neb%image(i)%pos(j,:) = neb%image(end0)%pos(j,:) &
             + real(i-1) * (neb%image(end1)%pos(j,:) - neb%image(end0)%pos(j,:)) &
             / real(end1-end0)
     end do
  end do
        
  do i = 2, neb%number_of_images-1
     if(replica_howtogive_coordinates(i-1) == FILE) then
        neb%image(i)%pos = pos_image(i-1,:,:)
        neb%image(i)%cps = cps_image(i-1,:,:)
     end if
  end do

  neb%image(1)%fix_flag(:) = 0
  neb%image(neb%number_of_images)%fix_flag(:) = 0
  do i = 2, neb%number_of_images-1
        neb%image(i)%fix_flag(:) = imdtyp(:)
  end do
  imdtyp = 0

  if( sw_fcp == ON ) call m_Fcp_create_replica(neb%number_of_images)

  if(neb%cond%condition == 1) then
     if (mype==0) write(nfneb,*) 'read data replica...'

     open(nfnebcntn,file=F_NEB_CNTN)
     read(nfnebcntn,*) 
     read(nfnebcntn,*) neb%step
     read(nfnebcntn,*) 
     read(nfnebcntn,*) 

     do i = 1, neb%number_of_images
        read(nfnebcntn,*) 
        read(nfnebcntn,*)
        read(nfnebcntn,*) 
        read(nfnebcntn,*)
        read(nfnebcntn,*)
        do j = 1, neb%image(i)%num_atom
           read(nfnebcntn,*) neb%image(i)%pos(j,1:3)
        end do
        read(nfnebcntn,*) 
        do j = 1, neb%image(i)%num_atom
           read(nfnebcntn,*) neb%image(i)%cps(j,1:3)
        end do
        read(nfnebcntn,*) 
        read(nfnebcntn,*) neb%image(i)%energy
        read(nfnebcntn,*) 
        do j = 1, neb%image(i)%num_atom
           read(nfnebcntn,*) neb%image(i)%force_org(j,1:3)
        end do
        read(nfnebcntn,*) 
        read(nfnebcntn,*) token
        select case(token)
        case('0')
           if (mype==0) write(nfneb,*) 'image: ', i, '  scf not convegence'
           neb%image(i)%scf_convergence = .false.
        case('1')
           if (mype==0) write(nfneb,*) 'image: ', i, '  scf convegence'
           neb%image(i)%scf_convergence = .true.
        end select
        if( sw_fcp == ON ) call m_Fcp_read_totch_replica(i)
     end do

     close(nfnebcntn)
  end if

  if (mype==0) then
     write(nfneb,*) 'create replica...'
     do i = 1, neb%number_of_images
        write(nfneb,*) 'image: ', i, ' pos, cps'
        do j = 1, neb%image(i)%num_atom
           write(nfneb,'(6f10.5,i3)') neb%image(i)%pos(j,1:3), neb%image(i)%cps(j,1:3), &
                neb%image(i)%fix_flag(j)
        end do
     end do
  endif

  if(neb%cond%condition==0) call write_result(.false.)

end subroutine create_replica

subroutine set_neb_replica_coordinate(image_id)

  use m_Ionic_System, only : pos, cps
  use m_Replica

  implicit none
  integer image_id

  cps = neb%image(image_id)%cps
  pos = neb%image(image_id)%pos

end subroutine set_neb_replica_coordinate

subroutine allreduce_neb_energy_force

  use m_Replica
  use m_Parallelization,      only : mpi_comm_group

  implicit none

  integer i
  integer mype, npes, mpi_err
  real(8),allocatable :: work1(:)
  real(8),allocatable :: work2(:,:)

  include 'mpif.h'

  if (nrank_r.lt.1) return

!  call mpi_comm_rank(mpi_comm_world,mype,mpi_err)
  call mpi_comm_size(mpi_comm_group,npes,mpi_err)

!  write(220+mype,'(i5,5e20.10)') mype, neb%image(:)%energy

  allocate(work1(neb%number_of_images));work1=0.d0
  call mpi_allreduce(neb%image(:)%energy,work1,neb%number_of_images, &
       mpi_double_precision,mpi_sum,mpi_comm_world,mpi_err)
  neb%image(:)%energy = work1
  deallocate(work1)
  do i=1, neb%number_of_images
    allocate(work2(neb%image(i)%num_atom,3))
     work2=0.d0
     call mpi_allreduce(neb%image(i)%force,work2,neb%image(i)%num_atom*3, &
          mpi_double_precision,mpi_sum,mpi_comm_world,mpi_err)
     neb%image(i)%force = work2
     work2=0.d0
     call mpi_allreduce(neb%image(i)%force_org,work2,neb%image(i)%num_atom*3, &
          mpi_double_precision,mpi_sum,mpi_comm_world,mpi_err)
     neb%image(i)%force_org = work2
     deallocate(work2)
  end do

  ! temporary    npes = ne*nk
  neb%image(:)%energy = neb%image(:)%energy/npes
  do i=1, neb%number_of_images
     neb%image(i)%force = neb%image(i)%force/npes
     neb%image(i)%force_org = neb%image(i)%force_org/npes
  end do
  
!  write(230+mype,'(i5,5e20.10)') mype, neb%image(:)%energy
  
end subroutine allreduce_neb_energy_force

subroutine set_neb_replica_energy_force(image_id)

  use m_Force, only : forc_l
  use m_Total_Energy, only : etotal
  use m_Replica
  use m_Files, only : nfneb

  implicit none

  integer image_id

  integer :: i

  neb%image(image_id)%energy = etotal
  neb%image(image_id)%force = forc_l
  neb%image(image_id)%force_org = forc_l

end subroutine set_neb_replica_energy_force

subroutine force_neb

  use m_Files,                only : nfneb
  use m_Replica
  use m_Parallelization,  only : mype

  implicit none

  integer i, j

  if ( mype==0 ) then
     write(nfneb,*) 'force neb...'

     do i = 1, neb%number_of_images
        write(nfneb,*) 'image: ', i, neb%image(i)%energy, &
             neb%image(i)%energy-neb%image(i)%energy0
        write(nfneb,*) ' cps, force '
        do j = 1, neb%image(i)%num_atom
           write(nfneb,'(3f10.5,3e11.3)') neb%image(i)%cps(j,1:3), neb%image(i)%force(j,1:3)
        end do
     end do
  endif

!  do i = 1, neb%number_of_images
!     neb%image(i)%force_org = neb%image(i)%force
!  end do
  
  call elastic_constant
  call local_tangent
  call neb_force

  if ( mype==0 ) then
     do i = 1, neb%number_of_images
        write(nfneb,*) 'image: ', i, neb%image(i)%energy, &
             neb%image(i)%energy-neb%image(i)%energy0
!     write(nfneb,*) ' cps, pos '
!     do j = 1, neb%image(i)%num_atom
!        write(nfneb,'(6f10.5)') neb%image(i)%cps(j,1:3), neb%image(i)%pos(j,1:3)
!     end do
        write(nfneb,*) ' force(neb), force(org), force(neb-org) '
        do j = 1, neb%image(i)%num_atom
           write(nfneb,'(9e11.3)') neb%image(i)%force(j,1:3), neb%image(i)%force_org(j,1:3), &
                neb%image(i)%force(j,1:3)-neb%image(i)%force_org(j,1:3)
        end do
     end do
  endif
end subroutine force_neb

subroutine elastic_constant

  ! elastic constant between images

  use m_Files,                only : nfneb
  use m_Replica
  use m_Parallelization,     only : mype

  implicit none

  integer  i

  real(8)  max_energy, ref_energy, energy

  real(8)  k_spring, k_spring0
  real(8)  k_spring_init, k_spring_max, k_spring_min, k_spring_delta

  if (mype==0) write(nfneb,*) 'elastic constant...'

  max_energy = maxval( neb%image(:)%energy )
  ref_energy = max( neb%image(1)%energy, neb%image(neb%number_of_images)%energy )

  do i = 2, neb%number_of_images

    if( .not. neb%cond%k_variable ) then
       k_spring = neb%cond%k_spring_init
       k_spring0= neb%cond%k_spring_init
    elseif( neb%cond%k_variable ) then
       k_spring_max = neb%cond%k_spring_max
       k_spring_min = neb%cond%k_spring_min
       energy = max( neb%image(i-1)%energy, neb%image(i)%energy )
       k_spring_delta = k_spring_max - k_spring_min
       if( energy > ref_energy ) then
          k_spring = k_spring_max - k_spring_delta &
               * ( max_energy - energy ) / ( max_energy - ref_energy )
          k_spring0 = k_spring
       elseif( energy <= ref_energy ) then
          k_spring = k_spring_max - k_spring_delta
          k_spring0 = k_spring
       end if
    end if

    if( neb%cond%k_damping ) then
       k_spring0 = k_spring
       k_spring = k_spring * neb%cond%k_damping_factor ** ( ( neb%step-1) )
    end if

    neb%image(i-1)%k_spring = k_spring
    neb%image(i-1)%k_spring0= k_spring0

    if (mype==0) write(nfneb,'(i5,a10,2e20.12)') i, '-th spring',  k_spring, k_spring0

 end do
 
 return
end subroutine elastic_constant

subroutine local_tangent

  ! local tangent of minimum energy path

  use m_Files,                only : nfneb
  use m_Replica
  use m_Parallelization,     only : mype

  implicit none

  integer i, j
  integer num_atom
  real(8) distance21
  real(8) distance01, distance20
  real(8) abs_tau2, abs_tau3
  real(8) angle12, angle23, angle31
  real(8) energy0, energy1, energy2
  real(8),allocatable :: tau(:,:)
  real(8),allocatable :: tau1(:,:), tau2(:,:), tau3(:,:)
  real(8) phi
  real(8),allocatable ::  rx0(:), ry0(:), rz0(:)
  real(8),allocatable ::  rx1(:), ry1(:), rz1(:)
  real(8),allocatable ::  rx2(:), ry2(:), rz2(:)
  real(8) :: eps

  if (mype==0) write(nfneb,*) 'local tangent...'

  eps = 1.d-10
  do j = 2, neb%number_of_images-1

     num_atom = neb%image(j)%num_atom

     allocate( tau(num_atom,3) )
     allocate( tau1(num_atom,3) )
     allocate( tau2(num_atom,3) )
     allocate( tau3(num_atom,3) )

     allocate( rx0(num_atom) )
     allocate( ry0(num_atom) )
     allocate( rz0(num_atom) )
     allocate( rx1(num_atom) )
     allocate( ry1(num_atom) )
     allocate( rz1(num_atom) )
     allocate( rx2(num_atom) )
     allocate( ry2(num_atom) )
     allocate( rz2(num_atom) )

     tau1(:,:) = 0.0d0
     tau2(:,:) = 0.0d0
     tau3(:,:) = 0.0d0

     rx0 = neb%image(j)%cps(:,1)
     ry0 = neb%image(j)%cps(:,2)
     rz0 = neb%image(j)%cps(:,3)
     rx1 = neb%image(j-1)%cps(:,1)
     ry1 = neb%image(j-1)%cps(:,2)
     rz1 = neb%image(j-1)%cps(:,3)
     rx2 = neb%image(j+1)%cps(:,1)
     ry2 = neb%image(j+1)%cps(:,2)
     rz2 = neb%image(j+1)%cps(:,3)

     energy0 = neb%image(j)%energy
     energy1 = neb%image(j-1)%energy
     energy2 = neb%image(j+1)%energy

     distance21 = sqrt ( dot_product( rx2 - rx1, rx2 - rx1 ) &
          + dot_product( ry2 - ry1, ry2 - ry1 ) &
          + dot_product( rz2 - rz1, rz2 - rz1 ) )
     distance01 = sqrt ( dot_product( rx0 - rx1, rx0 - rx1 ) &
          + dot_product( ry0 - ry1, ry0 - ry1 ) &
          + dot_product( rz0 - rz1, rz0 - rz1 ) )
     distance20 = sqrt ( dot_product( rx2 - rx0, rx2 - rx0 ) &
          + dot_product( ry2 - ry0, ry2 - ry0 ) &
          + dot_product( rz2 - rz0, rz2 - rz0 ) )

     if( distance21.lt.eps .or. distance01.lt.eps .or. distance20.lt.eps ) cycle

     phi = ( dot_product( rx2 - rx0, rx0 - rx1 ) &
          + dot_product( ry2 - ry0, ry0 - ry1 ) &
          + dot_product( rz2 - rz0, rz0 - rz1 ) ) / ( distance20 * distance01 )

     ! for regure NEB

     do i = 1, num_atom
        tau1(i, 1) = ( rx2(i) - rx1(i)) / distance21
        tau1(i, 2) = ( ry2(i) - ry1(i)) / distance21
        tau1(i, 3) = ( rz2(i) - rz1(i)) / distance21
        tau2(i, 1) = ( rx0(i) - rx1(i)) / distance01 &
             + ( rx2(i) - rx0(i) ) / distance20
        tau2(i, 2) = ( ry0(i) - ry1(i)) / distance01 &
             + ( ry2(i) - ry0(i) ) / distance20
        tau2(i, 3) = ( rz0(i) - rz1(i)) / distance01 &
             + ( rz2(i) - rz0(i) ) / distance20
     end do

     abs_tau2 = sqrt( dot_product(tau2(:,1), tau2(:,1)) &
          + dot_product(tau2(:,2), tau2(:,2)) &
          + dot_product(tau2(:,3), tau2(:,3)))
     if( abs_tau2 /= 0.0d0 ) then
        tau2(:, 1) = tau2(:, 1) /  abs_tau2
        tau2(:, 2) = tau2(:, 2) /  abs_tau2
        tau2(:, 3) = tau2(:, 3) /  abs_tau2
     end if

!       tau(:,:) = tau1(:,:)
!       tau(:,:) = tau2(:,:)

     ! for CI-NEB  ( method of python )

     if( energy2 > energy0 ) then
        if( energy0 > energy1 ) then
           do i = 1, num_atom
              tau3(i, 1) = ( rx2(i) - rx0(i) )
              tau3(i, 2) = ( ry2(i) - ry0(i) )
              tau3(i, 3) = ( rz2(i) - rz0(i) )
           end do
        elseif ( energy0 <= energy1 ) then
           if( energy2 > energy1 ) then
              do i = 1, num_atom
                 tau3(i, 1) = ( rx2(i) - rx0(i) ) &
                      * max( abs( energy2-energy0 ), abs( energy1 -energy0 ) ) &
                      + ( rx0(i) - rx1(i) ) &
                      * min( abs( energy2-energy0 ), abs( energy1 -energy0 ) )
                 tau3(i, 2) = ( ry2(i) - ry0(i) ) &
                      * max( abs( energy2-energy0 ), abs( energy1 -energy0 ) ) &
                      + ( ry0(i) - ry1(i) ) &
                      * min( abs( energy2-energy0 ), abs( energy1 -energy0 ) )
                 tau3(i, 3) = ( rz2(i) - rz0(i) ) &
                      * max( abs( energy2-energy0 ), abs( energy1 -energy0 ) ) &
                      + ( rz0(i) - rz1(i) ) &
                      * min( abs( energy2-energy0 ), abs( energy1 -energy0 ) )
              end do
           else if( energy2 <= energy1 ) then
              do i = 1, num_atom
                 tau3(i, 1) = ( rx2(i) - rx0(i) ) &
                      * min( abs( energy2-energy0 ), abs( energy1 -energy0 ) ) &
                      + ( rx0(i) - rx1(i) ) &
                      * max( abs( energy2-energy0 ), abs( energy1 -energy0 ) )
                 tau3(i, 2) = ( ry2(i) - ry0(i) ) &
                      * min( abs( energy2-energy0 ), abs( energy1 -energy0 ) ) &
                      + ( ry0(i) - ry1(i) ) &
                      * max( abs( energy2-energy0 ), abs( energy1 -energy0 ) )
                 tau3(i, 3) = ( rz2(i) - rz0(i) ) &
                      * min( abs( energy2-energy0 ), abs( energy1 -energy0 ) ) &
                      + ( rz0(i) - rz1(i) ) &
                      * max( abs( energy2-energy0 ), abs( energy1 -energy0 ) )
              end do
           end if
        end if
     elseif( energy2 <= energy0 ) then
        if( energy0 < energy1 ) then
           do i = 1, num_atom
              tau3(i, 1) = ( rx0(i) - rx1(i) )
              tau3(i, 2) = ( ry0(i) - ry1(i) )
              tau3(i, 3) = ( rz0(i) - rz1(i) )
           end do
        elseif( energy0 >= energy1 ) then
           if( energy2 > energy1 ) then
              do i = 1, num_atom
                 tau3(i, 1) = ( rx2(i) - rx0(i) ) &
                      * max( abs( energy2-energy0 ), abs( energy1 -energy0 ) ) &
                      + ( rx0(i) - rx1(i) ) &
                      * min( abs( energy2-energy0 ), abs( energy1 -energy0 ) )
                 tau3(i, 2) = ( ry2(i) - ry0(i) ) &
                      * max( abs( energy2-energy0 ), abs( energy1 -energy0 ) ) &
                      + ( ry0(i) - ry1(i) ) &
                      * min( abs( energy2-energy0 ), abs( energy1 -energy0 ) )
                 tau3(i, 3) = ( rz2(i) - rz0(i) ) &
                      * max( abs( energy2-energy0 ), abs( energy1 -energy0 ) ) &
                      + ( rz0(i) - rz1(i) ) &
                      * min( abs( energy2-energy0 ), abs( energy1 -energy0 ) )
              end do
           elseif( energy2 <= energy1 ) then
              do i = 1, num_atom
                 tau3(i, 1) = ( rx2(i) - rx0(i) ) &
                      * min( abs( energy2-energy0 ), abs( energy1 -energy0 ) ) &
                      + ( rx0(i) - rx1(i) ) &
                      * max( abs( energy2-energy0 ), abs( energy1 -energy0 ) )
                 tau3(i, 2) = ( ry2(i) - ry0(i) ) &
                      * min( abs( energy2-energy0 ), abs( energy1 -energy0 ) ) &
                      + ( ry0(i) - ry1(i) ) &
                      * max( abs( energy2-energy0 ), abs( energy1 -energy0 ) )
                 tau3(i, 3) = ( rz2(i) - rz0(i) ) &
                      * min( abs( energy2-energy0 ), abs( energy1 -energy0 ) ) &
                      + ( rz0(i) - rz1(i) ) &
                      * max( abs( energy2-energy0 ), abs( energy1 -energy0 ) )
              end do
           end if
        end if
     end if
       
     abs_tau3 = sqrt( dot_product(tau3(:,1), tau3(:,1)) &
          + dot_product(tau3(:,2), tau3(:,2)) &
          + dot_product(tau3(:,3), tau3(:,3)))
     if( abs_tau3 /= 0.0d0 ) then
        tau3(:, 1) = tau3(:, 1) /  abs_tau3
        tau3(:, 2) = tau3(:, 2) /  abs_tau3
        tau3(:, 3) = tau3(:, 3) /  abs_tau3
     end if

     tau(:,:) = tau3(:,:)

     angle12 = ( dot_product( tau1(:,1), tau2(:,1) ) &
          + dot_product( tau1(:,2), tau2(:,2) ) &
          + dot_product( tau1(:,3), tau2(:,3) ) )
     angle23 = ( dot_product( tau2(:,1), tau3(:,1) ) &
          + dot_product( tau2(:,2), tau3(:,2) ) &
          + dot_product( tau2(:,3), tau3(:,3) ) )

     angle31 = ( dot_product( tau3(:,1), tau1(:,1) ) &
          + dot_product( tau3(:,2), tau1(:,2) ) &
          + dot_product( tau3(:,3), tau1(:,3) ) )

     ! output coordinate and local tangent
    
     if (mype==0) then
        write(nfneb,*) 'image : ', j
        write(nfneb,*) 'angle between local tangent'
        write(nfneb,'(a11,e12.5)') ' angle12 : ', angle12
        write(nfneb,'(a11,e12.5)') ' angle23 : ', angle23
        write(nfneb,'(a11,e12.5)') ' angle31 : ', angle31
        write(nfneb,*) ' cps '
        do i = 1, num_atom
           write(nfneb,'(3f10.5)') rx0(i), ry0(i), rz0(i)
        end do
        write(nfneb,*) ' local tangent : tau1, tau2, tau3'
        do i = 1, num_atom
           write(nfneb,'(9e11.3)') tau1(i,1), tau1(i,2), tau1(i,3), &
                tau2(i,1), tau2(i,2), tau2(i,3), &
                tau3(i,1), tau3(i,2), tau3(i,3)
        end do
!     write(nfneb,'(a19,3f15.5)') ' phi, dis01, dis20 ', phi, distance01, distance20
        write(nfneb,*) ''
     endif

     do i = 1, num_atom
        neb%image(j)%tau(i,:) = tau(i,:)
     end do

     deallocate( tau, tau1, tau2, tau3 )
     deallocate( rx0, ry0, rz0, rx1, ry1, rz1, rx2, ry2, rz2 )

  end do

  return
end subroutine local_tangent

subroutine neb_force

  ! constrain force of atoms of CI-NEB method

  use m_Files,                only : nfneb
  use m_Replica
  use m_Const_Parameters, only : PAI
  use m_Parallelization,     only : mype

  implicit none

  integer  num_atom
!  integer, intent(in) :: num_image
  integer  image_id

  real(8) energy
  real(8) max_energy

  real(8),allocatable :: tau(:,:)
  real(8),allocatable :: k_spring(:), k_spring0(:)

  integer i, k, iat

!  integer :: mype
!  integer :: energy_index(num_image)
  integer,allocatable :: update_id(:)
  real(8) :: distance01, distance20
  real(8) :: dot_product_f0_tau
  real(8) :: f_spring_abs
  real(8) :: f_spring_para_sum = 0.0d0
  real(8) :: f_spring_perp_sum = 0.0d0
  real(8) :: f_true_perp_sum = 0.0d0
  real(8) :: f0_perp_sum = 0.0d0, f0_para_sum = 0.0d0, f_sum = 0.0d0
  real(8) :: cosphi, switch = 0.0d0
  real(8), allocatable :: fx_spring(:), fy_spring(:), fz_spring(:)
  real(8), allocatable :: fx0_para(:), fy0_para(:), fz0_para(:)
  real(8), allocatable :: fx0_perp(:), fy0_perp(:), fz0_perp(:)
  real(8), allocatable :: fx_spring_para(:), fy_spring_para(:), fz_spring_para(:)
  real(8), allocatable :: fx_spring_perp(:), fy_spring_perp(:), fz_spring_perp(:)
  real(8), allocatable :: rx0(:), ry0(:), rz0(:)
  real(8), allocatable :: rx1(:), ry1(:), rz1(:)
  real(8), allocatable :: rx2(:), ry2(:), rz2(:)
  real(8), allocatable :: fx0(:), fy0(:), fz0(:)
  real(8), allocatable :: fx1(:), fy1(:), fz1(:)

  integer :: ci_target

  if (mype==0) write(nfneb,*) 'neb force...'

  allocate( k_spring(neb%number_of_images-1) )
  allocate( k_spring0(neb%number_of_images-1) )

  do k = 1, neb%number_of_images-1
     k_spring(k) = neb%image(k)%k_spring
     k_spring0(k) = neb%image(k)%k_spring0
  end do

  max_energy = maxval( neb%image(:)%energy )
  ci_target=0
  if( ( neb%step >= neb%cond%ci_neb_start) .and. ( neb%cond%climbing_image ) ) then
     do k=2,neb%number_of_images-1
        if (neb%image(k)%energy==max_energy) then
           ci_target=k
           if(mype==0) write(nfneb,*) 'climbing image : ',ci_target
           exit
        endif
     enddo
  endif



  do k = 2, neb%number_of_images-1

     num_atom = neb%image(k)%num_atom
     image_id = k

     allocate( tau(num_atom,3) )
     allocate( update_id(num_atom) )

     allocate( rx0(num_atom) )
     allocate( ry0(num_atom) )
     allocate( rz0(num_atom) )
     allocate( rx1(num_atom) )
     allocate( ry1(num_atom) )
     allocate( rz1(num_atom) )
     allocate( rx2(num_atom) )
     allocate( ry2(num_atom) )
     allocate( rz2(num_atom) )
     allocate( fx0(num_atom) )
     allocate( fy0(num_atom) )
     allocate( fz0(num_atom) )
     allocate( fx1(num_atom) )
     allocate( fy1(num_atom) )
     allocate( fz1(num_atom) )
     allocate( fx_spring(num_atom) )
     allocate( fy_spring(num_atom) )
     allocate( fz_spring(num_atom) )
     allocate( fx0_para(num_atom) )
     allocate( fy0_para(num_atom) )
     allocate( fz0_para(num_atom) )

     allocate( fx0_perp(num_atom) )
     allocate( fy0_perp(num_atom) )
     allocate( fz0_perp(num_atom) )

     allocate( fx_spring_para(num_atom) )
     allocate( fy_spring_para(num_atom) )
     allocate( fz_spring_para(num_atom) )

     allocate( fx_spring_perp(num_atom) )
     allocate( fy_spring_perp(num_atom) )
     allocate( fz_spring_perp(num_atom) )

     rx0 = neb%image(image_id)%cps(:,1)
     ry0 = neb%image(image_id)%cps(:,2)
     rz0 = neb%image(image_id)%cps(:,3)
     rx1 = neb%image(image_id-1)%cps(:,1)
     ry1 = neb%image(image_id-1)%cps(:,2)
     rz1 = neb%image(image_id-1)%cps(:,3)
     rx2 = neb%image(image_id+1)%cps(:,1)
     ry2 = neb%image(image_id+1)%cps(:,2)
     rz2 = neb%image(image_id+1)%cps(:,3)

     fx0 = neb%image(image_id)%force(:,1)
     fy0 = neb%image(image_id)%force(:,2)
     fz0 = neb%image(image_id)%force(:,3)
     
     tau(:,1) = neb%image(image_id)%tau(:,1)
     tau(:,2) = neb%image(image_id)%tau(:,2)
     tau(:,3) = neb%image(image_id)%tau(:,3)

     update_id = neb%image(image_id)%fix_flag(:)

!    call get_energy_index( energy_index, num_image )

     ! spring force for penalty function

     fx_spring(:) = k_spring0(image_id) * ( rx2(:) - rx0(:) ) &
          + k_spring0(image_id - 1 ) * ( rx1(:) - rx0(:) )
     fy_spring(:) = k_spring0(image_id) * ( ry2(:) - ry0(:) ) &
          + k_spring0(image_id - 1 ) * ( ry1(:) - ry0(:) )
     fz_spring(:) = k_spring0(image_id) * ( rz2(:) - rz0(:) ) &
          + k_spring0(image_id - 1 ) * ( rz1(:) - rz0(:) )

     if(k/=ci_target)then

        ! get true force perpendicular to local tangent 
          
        dot_product_f0_tau &
             = dot_product( fx0(:),  tau(:,1) ) &
             + dot_product( fy0(:),  tau(:,2) ) &
             + dot_product( fz0(:),  tau(:,3) ) 
       
        fx0_perp(:) = fx0(:) - dot_product_f0_tau * tau(:,1)
        fy0_perp(:) = fy0(:) - dot_product_f0_tau * tau(:,2)
        fz0_perp(:) = fz0(:) - dot_product_f0_tau * tau(:,3)

        ! get spring force along local tangent 
          
        distance20 = sqrt( dot_product( rx2 - rx0, rx2 - rx0 ) &
             + dot_product( ry2 - ry0, ry2 - ry0 ) &
             + dot_product( rz2 - rz0, rz2 - rz0 ) )
        distance01 = sqrt( dot_product( rx0 - rx1, rx0 - rx1 ) &
             + dot_product( ry0 - ry1, ry0 - ry1 ) &
             + dot_product( rz0 - rz1, rz0 - rz1 ) )
        f_spring_abs = k_spring0(image_id) *  distance20 &
             - k_spring0(image_id - 1) * distance01 

        fx_spring_para(:) = ( dot_product(fx_spring, tau(:,1)) &
             + dot_product(fy_spring, tau(:,2)) &
             + dot_product(fz_spring, tau(:,3)) ) * tau(:,1)
        fy_spring_para(:) = ( dot_product(fx_spring, tau(:,1)) &
             + dot_product(fy_spring, tau(:,2)) &
             + dot_product(fz_spring, tau(:,3)) ) * tau(:,2)
        fz_spring_para(:) = ( dot_product(fx_spring, tau(:,1)) &
             + dot_product(fy_spring, tau(:,2)) &
             + dot_product(fz_spring, tau(:,3)) ) * tau(:,3)
       
        ! penalty function

        switch=0.d0
        fx_spring_perp=0;fy_spring_perp=0;fz_spring_perp=0;cosphi=0
        if( neb%cond%penalty_function )  then
           fx_spring_perp(:) = ( fx_spring(:) - ( dot_product(fx_spring, tau(:,1)) &
                + dot_product(fy_spring, tau(:,2)) &
                + dot_product(fz_spring, tau(:,3)) ) * tau(:,1) ) &
                * k_spring(image_id-1) / k_spring0(image_id-1)
           fy_spring_perp(:) = ( fy_spring(:) - ( dot_product(fx_spring, tau(:,1)) &
                + dot_product(fy_spring, tau(:,2)) &
                + dot_product(fz_spring, tau(:,3)) ) * tau(:,2) ) &
                * k_spring(image_id-1) / k_spring0(image_id-1)
           fz_spring_perp(:) = ( fz_spring(:) - ( dot_product(fx_spring, tau(:,1)) &
                + dot_product(fy_spring, tau(:,2)) &
                + dot_product(fz_spring, tau(:,3)) ) * tau(:,3) ) &
                * k_spring(image_id-1) / k_spring0(image_id-1)
           cosphi = ( dot_product( rx2 - rx0, rx0 - rx1 ) &
                + dot_product( ry2 - ry0, ry0 - ry1 ) &
                + dot_product( rz2 - rz0, rz0 - rz1 ) ) &
                / ( distance20 * distance01 )

           if( cosphi > 0.0d0 ) then
              switch =  0.5d0 * ( 1.0d0 + cos(PAI*cosphi) )
           else
              switch = 1.0d0
           end if
        end if

        ! for debug 
        f_spring_para_sum = 0.0d0
        f_spring_perp_sum = 0.0d0
        f_true_perp_sum = 0.0d0
        do i = 1, num_atom
           if( update_id(i) ==  1 ) then
              f_spring_para_sum = f_spring_para_sum + fx_spring_para(i) * fx_spring_para(i) & 
                   + fy_spring_para(i) * fy_spring_para(i) + fz_spring_para(i) * fz_spring_para(i)
              f_spring_perp_sum = f_spring_perp_sum + fx_spring_perp(i) * fx_spring_perp(i) &
                   + fy_spring_perp(i) * fy_spring_perp(i) + fz_spring_perp(i) * fz_spring_perp(i)
              f_true_perp_sum = f_true_perp_sum + fx0_perp(i) * fx0_perp(i) &
                   + fy0_perp(i) * fy0_perp(i) + fz0_perp(i) * fz0_perp(i)
           end if
        end do

        ! get constained force

        fx1(:) = fx_spring_para(:) + fx0_perp(:) + switch * fx_spring_perp(:)
        fy1(:) = fy_spring_para(:) + fy0_perp(:) + switch * fy_spring_perp(:)
        fz1(:) = fz_spring_para(:) + fz0_perp(:) + switch * fz_spring_perp(:)

        do i = 1, num_atom
           neb%image(image_id)%spring_force(i,1) = fx_spring_para(i)
           neb%image(image_id)%spring_force(i,2) = fy_spring_para(i)
           neb%image(image_id)%spring_force(i,3) = fz_spring_para(i)

           neb%image(image_id)%true_force(i,1) = fx0_perp(i)
           neb%image(image_id)%true_force(i,2) = fy0_perp(i)
           neb%image(image_id)%true_force(i,3) = fz0_perp(i)
        end do

        f0_perp_sum = 0.0d0
        f_sum = 0.0d0
        do i = 1, num_atom
           if( update_id(i) == 1  ) then
              f0_perp_sum = f0_perp_sum &
                   +  ( fx0_perp(i)+switch*fx_spring_perp(i) ) ** 2 &
                   +  ( fy0_perp(i)+switch*fy_spring_perp(i) ) ** 2 &
                   +  ( fz0_perp(i)+switch*fz_spring_perp(i) ) ** 2 
              f_sum = f_sum +  fx1(i)*fx1(i) +  fy1(i)*fy1(i) + fz1(i)*fz1(i)
           end if
        end do

        f_sum = sqrt( f_sum )
        f_spring_para_sum = sqrt( f_spring_para_sum )
        f_spring_perp_sum = sqrt( f_spring_perp_sum )
        f_true_perp_sum = sqrt( f_true_perp_sum )
        f0_perp_sum = sqrt( f0_perp_sum )


        energy = neb%image(image_id)%energy

        if ( mype==0 ) then
           write(nfneb,*) 'image: ', image_id
           write(nfneb,*) ' energy: ', neb%step, energy
           write(nfneb,'(a31,e20.12)') ' sum of force (neb)         : ', f_sum
           write(nfneb,'(a31,e20.12)') ' sum of spring force (para) : ', f_spring_para_sum
           write(nfneb,'(a31,e20.12)') ' sum of true force (perp)   : ', f0_perp_sum
           write(nfneb,'(a31,3e11.3)') ' max force                  : ', &
                maxval( abs( fx1 ) ), maxval( abs( fy1 ) ), maxval( abs( fz1 ) )
        endif
     else
           
        ! get true force along local tangent 
          
        dot_product_f0_tau &
             = dot_product(fx0(:), tau(:,1)) + dot_product(fy0(:), tau(:,2))&
             + dot_product(fz0(:), tau(:,3))
          
        fx0_para(:) = dot_product_f0_tau * tau(:,1)
        fy0_para(:) = dot_product_f0_tau * tau(:,2)
        fz0_para(:) = dot_product_f0_tau * tau(:,3)
       
        ! get true force perpendicular to local tangent 
       
        fx0_perp(:) = fx0(:) - dot_product_f0_tau * tau(:,1)
        fy0_perp(:) = fy0(:) - dot_product_f0_tau * tau(:,2)
        fz0_perp(:) = fz0(:) - dot_product_f0_tau * tau(:,3)
       
        ! get constained force
       
        fx1(:) = fx0_perp(:) - fx0_para(:)
        fy1(:) = fy0_perp(:) - fy0_para(:)
        fz1(:) = fz0_perp(:) - fz0_para(:)
       
        do i = 1, num_atom
           neb%image(image_id)%spring_force(i,1) = fx0_para(i)
           neb%image(image_id)%spring_force(i,2) = fy0_para(i)
           neb%image(image_id)%spring_force(i,3) = fz0_para(i)

           neb%image(image_id)%true_force(i,1) = fx0_perp(i)
           neb%image(image_id)%true_force(i,2) = fy0_perp(i)
           neb%image(image_id)%true_force(i,3) = fz0_perp(i)
        end do

        f0_para_sum = 0.0d0
        f0_perp_sum = 0.0d0
        f_sum = 0.0d0
        do i = 1, num_atom
           if( update_id(i) == 1 ) then
              f0_para_sum = f0_para_sum +  fx0_para(i) * fx0_para(i) &
                   + fy0_para(i) * fy0_para(i) + fz0_para(i) * fz0_para(i)
              f0_perp_sum = f0_perp_sum +  fx0_perp(i) * fx0_perp(i) &
                   + fy0_perp(i) * fy0_perp(i) + fz0_perp(i) * fz0_perp(i)
              f_sum = fx1(i) * fx1(i) + fy1(i) * fy1(i) + fz1(i) * fz1(i) 
           end if
        end do

        f_sum = sqrt( f_sum )
        f0_para_sum = sqrt( f0_para_sum )
        f0_perp_sum = sqrt( f0_perp_sum )

        energy = neb%image(image_id)%energy

        if ( mype==0 ) then
           write(nfneb,*) 'image: ', image_id
           write(nfneb,*) ' energy: ', neb%step, energy
           write(nfneb,'(a31,e20.12)') ' sum of force (neb)         : ', f_sum
           write(nfneb,'(a31,e20.12)') ' sum of true force (para)   : ', f0_para_sum
           write(nfneb,'(a31,e20.12)') ' sum of true force (perp)   : ', f0_perp_sum
           write(nfneb,'(a31,3e11.3)') ' max force                  : ', &
                maxval( abs( fx1 ) ), maxval( abs( fy1 ) ), maxval( abs( fz1 ) )
        endif
     end if

     ! set force to module

     do i = 1, num_atom
        neb%image(image_id)%force(i,1) = fx1(i)
        neb%image(image_id)%force(i,2) = fy1(i)
        neb%image(image_id)%force(i,3) = fz1(i)
     end do

     deallocate( tau )
     deallocate( update_id )
     deallocate( rx0, ry0, rz0, rx1, ry1, rz1, rx2, ry2, rz2, &
          fx0, fy0, fz0, fx1, fy1, fz1, fx_spring, fy_spring, fz_spring, &
          fx0_para, fy0_para, fz0_para, fx0_perp, fy0_perp, fz0_perp, &
          fx_spring_para, fy_spring_para, fz_spring_para, &
          fx_spring_perp, fy_spring_perp, fz_spring_perp)

  end do

  deallocate( k_spring, k_spring0 )

  return

end subroutine neb_force

subroutine atom_update_neb

  use m_Crystal_Structure,  only : altv, rltv
  use m_Ionic_System,  only : ionic_mass
  use m_Files,                only : nfneb
  use m_Const_Parameters,      only : PAI2

  use m_Replica
  use m_Parallelization,  only : mype

  implicit none

  integer i, j, k
  real(8) mass
  real(8) dt
  real(8) r(3), r0(3), r1(3), v(3), v1(3), f(3), f0(3) , unitf(3)
  real(8), allocatable ::  rltv_t(:,:)

  if (mype==0) write(nfneb,*) 'atom coordinate update...'

  dt = neb%dt

  allocate(rltv_t(3,3))
  rltv_t = transpose(rltv)/PAI2

  do i = 2, neb%number_of_images-1

     neb%image(i)%pos0 = neb%image(i)%pos
     neb%image(i)%cps0 = neb%image(i)%cps

     do j = 1, neb%image(i)%num_atom

        if(neb%image(i)%fix_flag(j) == 1) then

           r = neb%image(i)%cps(j,:)
           r0 = neb%image(i)%cps0(j,:)
           v = neb%image(i)%velocity(j,:)
           f = neb%image(i)%force(j,:)
           f0 = neb%image(i)%force0(j,:)
           mass = ionic_mass(j)

           select case(neb%cond%time_integral)
           case('steepest_descent')
              r1 = r + dt*f
              v = 0.0d0
           case('verlet')
              r1 = 2.0d0*r - r0 + dt*dt*f/mass
              v1 = (r1-r)/(2.0d0*dt)
              v = 0.0d0
              if( dot_product(v1,f) >= 0.0d0) then
                 if( dot_product(f,f) /= 0.0d0 ) then
                    v = f * dot_product(v1,f)/dot_product(f,f)
                 end if
              end if
           case('velocity_verlet')
              v1 = v + 0.5d0*dt*(f0+f)/mass
              v = 0.0d0
              unitf=0.d0
              if(dot_product(f,f)/=0) unitf=f/dsqrt(dot_product(f,f))
              if( dot_product(v1,unitf) >= 0.0d0) then
                v = unitf * dot_product(v1,unitf)
              else
                 if (mype==0) write(nfneb,'(a,i6)') 'quenched velocity of atom : ',j
              end if
              r1 = r + v*dt + f*dt**2/mass
           end select

           neb%image(i)%cps(j,:) = r1
           neb%image(i)%velocity(j,:) = v

        end if

        ! cps -> pos
        do k = 1, 3
           neb%image(i)%pos(j,k) = rltv_t(k,1)*neb%image(i)%cps(j,1) &
                + rltv_t(k,2)*neb%image(i)%cps(j,2) &
                + rltv_t(k,3)*neb%image(i)%cps(j,3)
        enddo

        ! periodic tranformation
        !do k = 1, 3
        !   if( neb%image(i)%pos(j,k) < 0 ) then
        !      neb%image(i)%pos(j,k) = neb%image(i)%pos(j,k) + 1.d0
        !   else if( neb%image(i)%pos(j,k) > 1.d0 ) then
        !      neb%image(i)%pos(j,k) = neb%image(i)%pos(j,k) - 1.d0
        !   end if
        !enddo

        ! pos -> cps
        !do k = 1, 3
        !   neb%image(i)%cps(j,k) = altv(k,1)*neb%image(i)%pos(j,1) &
        !        + altv(k,2)*neb%image(i)%pos(j,2) &
        !        + altv(k,3)*neb%image(i)%pos(j,3)
        !enddo

     end do

     if ( mype==0 ) then
        write(nfneb,*) ' image: ', i
        write(nfneb,*) '  cps, cps0, cps-cps0 '
        do j = 1, neb%image(i)%num_atom
           write(nfneb,'(6f10.5,3e11.3)') neb%image(i)%cps(j,1:3), neb%image(i)%cps0(j,1:3), &
                neb%image(i)%cps(j,1:3)-neb%image(i)%cps0(j,1:3)
        end do
     endif

  end do

  deallocate(rltv_t)

end subroutine atom_update_neb

subroutine atom_update_pos_neb

  use m_Crystal_Structure,  only : altv, rltv
  use m_Ionic_System,  only : ionic_mass
  use m_Files,                only : nfneb
  use m_Const_Parameters,      only : PAI2
  use m_Parallelization,     only : mype

  use m_Replica

  implicit none

  integer i, j, k
  real(8) mass
  real(8) dt
  real(8) r(3), r0(3), r1(3), v(3), v1(3), f(3), f0(3) 

  if (mype==0) write(nfneb,*) 'atom coordinate update... (pos)'

  dt = neb%dt

  do i = 2, neb%number_of_images-1

     neb%image(i)%pos0 = neb%image(i)%pos
     neb%image(i)%cps0 = neb%image(i)%cps

     do j = 1, neb%image(i)%num_atom

        if(neb%image(i)%fix_flag(j) == 1) then

           r = neb%image(i)%pos(j,:)
           r0 = neb%image(i)%pos0(j,:)
           v = neb%image(i)%velocity(j,:)
           f = neb%image(i)%force(j,:)
           f0 = neb%image(i)%force0(j,:)
           mass = ionic_mass(j)

           select case(neb%cond%time_integral)
           case('steepest_descent')
              r1 = r + dt*f
              v = 0.0d0
           case('verlet')
              r1 = 2.0d0*r - r0 + dt*dt*f/mass
              v1 = (r1-r)/(2.0d0*dt)
              v = 0.0d0
              if( dot_product(v1,f) >= 0.0d0) then
                 if( dot_product(f,f) /= 0.0d0 ) then
                    v = f * dot_product(v1,f)/dot_product(f,f)
                 end if
              end if
           case('velocity_verlet')
              v1 = v + 0.5d0*dt*(f0+f)/mass
              v = 0.0d0
              if( dot_product(v1,f) >= 0.0d0) then
                 if( dot_product(f,f) /= 0.0d0 ) then
                    v = f * dot_product(v1,f)/dot_product(f,f)
                 end if
              end if
              r1 = r + v*dt + f*dt**2/mass
           end select

           neb%image(i)%pos(j,:) = r1
           neb%image(i)%velocity(j,:) = v

        end if

        ! periodic tranformation
        !do k = 1, 3
        !   if( neb%image(i)%pos(j,k) < 0 ) then
        !      neb%image(i)%pos(j,k) = neb%image(i)%pos(j,k) + 1.d0
        !   else if( neb%image(i)%pos(j,k) > 1.d0 ) then
        !      neb%image(i)%pos(j,k) = neb%image(i)%pos(j,k) - 1.d0
        !   end if
        !enddo

        ! pos -> cps
        do k = 1, 3
           neb%image(i)%cps(j,k) = altv(k,1)*neb%image(i)%pos(j,1) &
                + altv(k,2)*neb%image(i)%pos(j,2) &
                + altv(k,3)*neb%image(i)%pos(j,3)
        enddo

     end do

     if ( mype==0 ) then
        write(nfneb,*) ' image: ', i
        write(nfneb,*) '  cps, cps0, cps-cps0, velocity '
        do j = 1, neb%image(i)%num_atom
           write(nfneb,'(6f10.5,3e11.3,3f10.5)') neb%image(i)%cps(j,1:3), neb%image(i)%cps0(j,1:3), &
                neb%image(i)%cps(j,1:3)-neb%image(i)%cps0(j,1:3), &
                neb%image(i)%velocity(j,1:3)
        end do
     endif

  end do

end subroutine atom_update_pos_neb

subroutine write_down_data_replica

  use m_Files,                only : nfneb, nfnebcntn, F_NEB_CNTN, nfstop, F_STOP
  use m_Replica
  use m_Parallelization,    only : mype
  use m_Control_Parameters, only : sw_fcp
  use m_Const_Parameters,   only : ON
  use m_Fcp,                only : m_Fcp_write_down_totch_replica

  implicit none
  integer i,j

  if (mype==0) write(nfneb,*) 'write down data replica...'

!  if(mype_r == 0) then
  if(mype == 0) then

  open(nfnebcntn,file=F_NEB_CNTN)
  write(nfnebcntn,*) 'iteration_neb'
  write(nfnebcntn,*) neb%step
  write(nfnebcntn,*) 'number_of_images'
  write(nfnebcntn,*) neb%number_of_images

  do i = 1, neb%number_of_images
     write(nfnebcntn,*) 'image'
     write(nfnebcntn,*) i
     write(nfnebcntn,*) '(natm)'
     write(nfnebcntn,*) neb%image(i)%num_atom
     write(nfnebcntn,*) '(pos)'
     do j = 1, neb%image(i)%num_atom
        write(nfnebcntn,'(3d24.16)') neb%image(i)%pos(j,1:3)
     end do
     write(nfnebcntn,*) '(cps)'
     do j = 1, neb%image(i)%num_atom
        write(nfnebcntn,'(3d24.16)') neb%image(i)%cps(j,1:3)
     end do
     write(nfnebcntn,*) '(energy)'
     write(nfnebcntn,'(d24.16)') neb%image(i)%energy
     write(nfnebcntn,*) '(force_org)'
     do j = 1, neb%image(i)%num_atom
        write(nfnebcntn,'(3d24.16)') neb%image(i)%force_org(j,1:3)
     end do
     write(nfnebcntn,*) '(convergence)'
     if(neb%image(i)%scf_convergence) then
        write(nfnebcntn,'(i3)')  1
     else 
        write(nfnebcntn,'(i3)')  0
     end if
     if( sw_fcp == ON ) call m_Fcp_write_down_totch_replica(i)
  end do
  
  close(nfnebcntn)

  open(nfstop, file=F_STOP, status='replace', form='formatted')
  close(nfstop, status='keep')

  end if
end subroutine write_down_data_replica

subroutine allreduce_scf_convergence

  use m_Files,   only : nfneb
  use m_Replica
  use m_Parallelization,  only : mype

  implicit none

  integer i, mpi_err
  logical,allocatable :: work(:)

  include 'mpif.h'

  if(nrank_r.ge.1)then
    allocate(work(neb%number_of_images))
    call mpi_allreduce(neb%image(:)%scf_convergence,work,neb%number_of_images, &
         mpi_logical,mpi_land,mpi_comm_world,mpi_err)
    neb%image(:)%scf_convergence = work
    deallocate(work)
  endif

  if ( mype==0 ) then
     write(nfneb,*) 'neb: ', neb%step
     do i=1, neb%number_of_images
        write(nfneb,*) ' image: ', i, ' scf convergence: ', neb%image(i)%scf_convergence
     end do
  endif
end subroutine allreduce_scf_convergence

logical function replica_converged()

  use m_Files,                only : nfneb, nfnebstop, F_NEB_STOP
  use m_Replica
  use m_Parallelization, only : mype
  use m_Control_Parameters, only : sw_fcp
  use m_Const_Parameters, only : ON
  use m_Fcp, only : m_Fcp_replica_Converged

  implicit none

  logical conv
  real(8), allocatable :: force(:)
  integer i, j, istop, id(1)
  real(8) :: fmax, ftmp

  if ( mype==0 ) write(nfneb,*) 'convergence check...', neb%step

  conv = .false.
  select case(neb%cond%convergence_condition)
  
  case(1) ! energy
     if( maxval(abs(neb%image(:)%energy-neb%image(:)%energy0)) &
          < neb%cond%convergence_threshold ) then
        conv = .true.
     end if
     if ( mype==0) then
        write(nfneb,*) ' energy: ', maxval(abs(neb%image(:)%energy-neb%image(:)%energy0)), &
             neb%cond%convergence_threshold, conv
     endif
  case(2) ! force(org)
     fmax = 0
     do i=2,neb%number_of_images-1
       do j=1,neb%image(i)%num_atom
         if(neb%image(i)%fix_flag(j)==0)cycle
         ftmp = dsqrt(dot_product(neb%image(i)%force_org(j,:),neb%image(i)%force_org(j,:)))
         if(ftmp<fmax) fmax=ftmp
       enddo
     enddo
     if(fmax<neb%cond%convergence_threshold) conv = .true.
     if ( mype==0 ) then
        write(nfneb,*) ' force (org): ', fmax, neb%cond%convergence_threshold, conv
     endif
  case(3) ! force(neb)
     fmax = 0
     do i=2, neb%number_of_images-1
       do j=1, neb%image(i)%num_atom
         if(neb%image(i)%fix_flag(j)==0)cycle
         ftmp = dsqrt(dot_product(neb%image(i)%force(j,:),neb%image(i)%force(j,:)))
         if(fmax < ftmp) fmax=ftmp
       enddo
     enddo
     if( fmax < neb%cond%convergence_threshold ) conv = .true.
     if ( mype==0 ) then
        write(nfneb,*) ' force (neb): ', fmax, neb%cond%convergence_threshold, conv
     endif
  case(4) ! force(org) of max energy image
     id = maxloc(neb%image(:)%energy);
     fmax = 0
     do i=1,neb%image(id(1))%num_atom
       if(neb%image(id(1))%fix_flag(i)==0)cycle
       ftmp = dsqrt(dot_product(neb%image(id(1))%force(i,:),neb%image(id(1))%force(i,:)))
       if(fmax<ftmp)fmax=ftmp
     enddo
     if(fmax<neb%cond%convergence_threshold) conv=.true.
     if ( mype==0 ) then
        write(nfneb,*) ' force (transition state): ', fmax, &
             neb%cond%convergence_threshold, conv
     endif
  case(5) ! true force (normal force)
     fmax=0
     do i=2,neb%number_of_images-1
       do j=1,neb%image(i)%num_atom
         if(neb%image(i)%fix_flag(j)==0)cycle
         ftmp=dsqrt(dot_product(neb%image(i)%true_force(j,:),neb%image(i)%true_force(j,:)))
         if(fmax<ftmp)fmax=ftmp
       enddo
     enddo
     if(fmax<neb%cond%convergence_threshold) conv=.true.
     if ( mype==0 ) then
        write(nfneb,*) ' force (normal): ', fmax, neb%cond%convergence_threshold, conv
     endif
  end select

  ! check nfnebstop.data
  istop = -1
  open(nfnebstop,file=F_NEB_STOP)
  rewind(nfnebstop)
  read(nfnebstop,*,end=1,err=1) istop
1 continue
  close(nfnebstop,status='keep')
  if(0 <= istop .and. neb%step >= istop) then
     conv = .true.
     if (mype==0) write(nfneb,*) ' nfnebstop.data: ', istop     
  end if

  if( (sw_fcp == ON) .and. .not. m_Fcp_replica_Converged() ) then
     conv = .false.
  end if

  replica_converged = conv

  call write_result(.true.)

end function replica_converged

subroutine write_result(inc_energy)

  use m_Files,                only : nfnebenf, nfnebdynm, nfenf, nfdynm, F_DYNM, F_ENF
  use m_Replica
  use m_Ionic_System,         only : m_IS_wd_speciesname_etc
  use m_IterationNumbers,     only : iteration

  implicit none

  logical, intent(in) :: inc_energy
  integer i, j
  character(20) form
  real(8) d, sum_d
  integer npes,mype,mpi_err

  include 'mpif.h'

  call mpi_comm_rank(mpi_comm_world,mype,mpi_err)

  if(mype /= 0) return

  ! write energy, force, cps

  open(nfdynm,file=F_DYNM)
  open(nfenf,file=F_ENF)
  call m_IS_wd_speciesname_etc(nfdynm)
  call m_IS_wd_speciesname_etc(nfnebdynm)
  write(nfenf,*) '#step  image  image_distance  energy   force_org  force_neb  force_normal'
  sum_d = 0.0d0
  do i=1, neb%number_of_images
     if(inc_energy)then
     d = 0.0d0
     if(i>1) then
        d = 0.0d0
        do j=1, neb%image(i)%num_atom
           d = d + dot_product(neb%image(i-1)%cps(j,:)-neb%image(i)%cps(j,:), &
                neb%image(i-1)%cps(j,:)-neb%image(i)%cps(j,:))
        end do
        d = sqrt(d)
     end if
     sum_d = sum_d + d
     write(nfnebenf,'(2i5,5e20.10)')  neb%step, i, sum_d, neb%image(i)%energy, &
          maxval(abs(neb%image(i)%force_org(:,:))), &
          maxval(abs(neb%image(i)%force(:,:))), &
          maxval(abs(neb%image(i)%true_force(:,:)))
     write(nfenf,'(2i5,5e20.10)')  neb%step, i, sum_d, neb%image(i)%energy, &
          maxval(abs(neb%image(i)%force_org(:,:))), &
          maxval(abs(neb%image(i)%force(:,:))), &
          maxval(abs(neb%image(i)%true_force(:,:)))
     endif
     write(nfnebdynm,'(a,i5,i8,a)') ' cps and forc at (nebstep, iter_total=',neb%step,iteration,')'
     write(nfdynm,'(a,i5,i8,a)') ' cps and forc at (nebstep, iter_total=',neb%step,iteration,')'
     do j = 1, neb%image(i)%num_atom
!        write(nfnebdynm,'(3i5,3f20.10)') neb%step, i, j, neb%image(i)%cps(j,1:3)
        write(nfnebdynm,'(" ",i4,3f15.9,3f12.6)') j &
        &, neb%image(i)%cps(j,1),neb%image(i)%cps(j,2),neb%image(i)%cps(j,3) &
        &, neb%image(i)%force(j,1), neb%image(i)%force(j,2), neb%image(i)%force(j,3)
        write(nfdynm,'(" ",i4,3f15.9,3f12.6)') j &
        &, neb%image(i)%cps(j,1),neb%image(i)%cps(j,2),neb%image(i)%cps(j,3) &
        &, neb%image(i)%force(j,1), neb%image(i)%force(j,2), neb%image(i)%force(j,3)
     end do
  end do

  if(inc_energy) write(nfnebenf,*)

  close(nfdynm)
  close(nfenf)
  ! temporary
  !!write(form,'(a4,i5,a7)') '(i5,',neb%number_of_images,'e20.10)'
  !!write(212,form) neb%step, neb%image(:)%energy

  !!neb%energy(neb%step,:) = neb%image(:)%energy
  !!open(213)
  !!write(form,'(a4,i5,a7)') '(i5,',neb%step,'e20.10)'
  !!do i=1, neb%number_of_images
  !!   write(213,form) i, neb%energy(1:neb%step,i)
  !!end do
  !!close(213)

end subroutine write_result

subroutine finalize_neb()
  use m_Replica, only : m_Replica_finalize, nrank_r
  use m_Files, only : nfnebstop, F_NEB_STOP, nfneb, m_Files_close_and_clear_nfstop
  use m_Control_Parameters,  only : ipriparadeb
  use m_Parallelization, only : mype

  implicit none
  include 'mpif.h'

  integer :: mpi_err
  call m_Replica_finalize()

  if(nrank_r.gt.1) call mpi_barrier(mpi_comm_world, mpi_err)
  open(nfnebstop, file=F_NEB_STOP, status='replace', form='formatted')
  close(nfnebstop, status='keep')

! ==== KT_add ===== 2014/07/20
#ifdef NEB_NEW_FILENAMES
  if ( mype == 0 ) close(nfneb)
#else
  if ( mype == 0 ) then
     close(nfneb)
  else if(ipriparadeb == 0) then
     close(nfneb, status='delete')
  else
     close(nfneb, status='keep')
  end if
#endif
! ================= 2014/07/20

  call m_Files_close_and_clear_nfstop()
end subroutine finalize_neb

subroutine deallocate_array

  use m_Control_Parameters
  use m_Crystal_Structure
  use m_Ionic_System
  use m_PlaneWaveBasisSet
  use m_Parallelization
  use m_Kpoints
  use m_Force
  use m_Charge_Density
  use m_XC_Potential
  use m_PseudoPotential
  use m_NonLocal_Potential
  use m_Electronic_Structure
  use m_ES_WF_by_SDorCG
  use m_ES_wf_extrpl

!  call m_CtrlP_dealloc

  call m_CS_dealloc(neb_mode=.true.)
  call m_IS_dealloc(neb_mode=.true.)
  call m_pwBS_dealloc
  call m_Parallel_dealloc(neb_mode=.true.)
  call m_Kp_dealloc
  call m_Force_dealloc
  call m_CD_dealloc
  call m_XC_dealloc_vxc
  !call m_PP_dealloc
  !call m_NLP_dealloc
  call m_ES_dealloc
  call m_ESsd_dealloc
  call m_ES_wf_extrpl_dealloc()
  call m_CtrlP_set_init_status(.true.)

end subroutine deallocate_array
