!===============================================================================
!
! hmc.F90
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 1998-2013 Hinnerk Stueben
!               2007-2013 Yoshifumi Nakamura 
!
! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
!
! BQCD is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! BQCD is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with BQCD.  If not, see <http://www.gnu.org/licenses/>.
!
!-------------------------------------------------------------------------------
# include "defs.h"

!-------------------------------------------------------------------------------
subroutine hmc(para, conf, out, force_accept, test)

  use module_action
  use module_stout_field
  use module_field
  use module_cg
  use typedef_hmc
  use module_counter
  use module_function_decl
  use module_p_interface
  use module_switches
  use module_vol
  use module_input
  implicit none

  type(hmc_para), intent(inout) :: para
  type(hmc_conf), intent(inout) :: conf
  type(hmc_out),  intent(out)   :: out
  integer,        intent(in)    :: force_accept
  integer,        intent(in)    :: test

  P_GAUGE_FIELD, save         :: u_bck
!!P_SPINCOL_FIELD,  save      :: phi_bck
  P_GENERATOR_FIELD, save     :: p, p_bck
  P_U1_GENERATOR_FIELD, save  :: a_qed_bck
  P_U1_GENERATOR_FIELD, save  :: p_qed, p_qed_bck
  P_AXION_FIELD, save           :: axion_bck
  P_AXION_MOMENTUM_FIELD, save  :: p_axion, p_axion_bck

  integer :: i

  REAL ::  sd_old,   sd_new,   sd_dif
  REAL :: sf1_old,  sf1_new,  sf1_dif
  REAL :: sf2_old,  sf2_new,  sf2_dif
  REAL :: sf3_old,  sf3_new,  sf3_dif
  REAL ::  sg_old,   sg_new,   sg_dif
  REAL ::  sp_old,   sp_new,   sp_dif
  REAL ::  hg_old,   hg_new,   hg_dif
  REAL ::   h_old,    h_new,    h_dif
  REAL ::  sd_old1,  sd_new1,  sd_dif1
  REAL :: sf1_old1, sf1_new1, sf1_dif1
  REAL :: sf2_old1, sf2_new1, sf2_dif1
  REAL :: sf3_old1, sf3_new1, sf3_dif1
  REAL ::  sg_old1,  sg_new1,  sg_dif1
  REAL ::  sp_old1,  sp_new1,  sp_dif1
  REAL ::  hg_old1,  hg_new1,  hg_dif1
  REAL ::   h_old1,   h_new1,   h_dif1
  REAL :: plaq, plaq_old(3), plaq_new(3), rect_old(3), rect_new(3)
  REAL :: plaq_new1(3), rect_new1(3)

  REAL :: sp_qed_old,  sp_qed_new,  sp_qed_dif
  REAL :: sg_qed_old,  sg_qed_new,  sg_qed_dif
  REAL :: hg_qed_old,  hg_qed_new,  hg_qed_dif
  REAL :: sp_qed_old1, sp_qed_new1, sp_qed_dif1
  REAL :: sg_qed_old1, sg_qed_new1, sg_qed_dif1
  REAL :: hg_qed_old1, hg_qed_new1, hg_qed_dif1
  REAL :: plaq_qed_old, plaq_qed_new
  REAL :: plaq_qed_new1

  REAL :: sp_axion_old,  sp_axion_new,  sp_axion_dif
  REAL :: sk_axion_old,  sk_axion_new,  sk_axion_dif
  REAL :: hk_axion_old,  hk_axion_new,  hk_axion_dif
  REAL :: sp_axion_old1, sp_axion_new1, sp_axion_dif1
  REAL :: sk_axion_old1, sk_axion_new1, sk_axion_dif1
  REAL :: hk_axion_old1, hk_axion_new1, hk_axion_dif1
  REAL :: axion_energy_old, axion_energy_new, axion_energy_new1
  REAL :: axion_average_old, axion_average_new, axion_average_new1

  REAL, save :: replay_threshold
  REAL, external :: sp, sig, sg, sp_qed, sg_qed, sk_axion, sp_axion
  logical :: replayed

  DEBUG2S("Start HMC")
  TIMING_START(timing_bin_hmc)
  TIMING_START(timing_bin_hmc_init)

   hg_old = ZERO;   hg_new = ZERO
   sg_old = ZERO;   sg_new = ZERO
   sp_old = ZERO;   sp_new = ZERO
   sd_old = ZERO;   sd_new = ZERO
  sf1_old = ZERO;  sf1_new = ZERO
  sf2_old = ZERO;  sf2_new = ZERO
  sf3_old = ZERO;  sf3_new = ZERO
 
  sp_qed_old = ZERO; sp_qed_new = ZERO
  sg_qed_old = ZERO; sg_qed_new = ZERO
  hg_qed_old = ZERO; hg_qed_new = ZERO

  sp_axion_old = ZERO; sp_axion_new = ZERO
  sk_axion_old = ZERO; sk_axion_new = ZERO
  hk_axion_old = ZERO; hk_axion_new = ZERO

  call init_cg_stat(cg_stat)
  call init_cg_stat(cgm_stat)
  call init_cg_stat(cg_ritz_stat)
  call init_cg_stat2(dd_stat)
  call init_cg_stat2(hh_stat)
  call iteration_count_init()

  if (switches%measure_only .or. switches%smearing_only) then
     if (switches%smearing_only) out%sg = ran_number()    !!!     roll random number counter 
     hg_new = sig(out%sg, out%plaq, out%rect)
     out%sg_qed = sg_qed(conf%a_qed, out%plaq_qed)
     out%sk_axion = sk_axion(conf%axion, out%axion_energy, out%axion_average)
     call get_cg_stat(cg_stat,  out%cg_ncall, out%cg_niter_max, out%cg_niter_tot)
     call get_cg_stat(cgm_stat, out%cgm_ncall, out%cgm_niter_max, out%cgm_niter_tot)
     out%accepted = 0
     return
  endif

  ! initialize clover terms and stout links
  call coefficient_sig(para)
  call init_imp_all(.false.)

  call init_hmc(para)
  call init_rhmc(para)

  ! Need sco for storage of multi-shift cg solutions
  call init_sco()


  if (.not. associated(p)) then
     nullify(p);         ALLOCATE_GEN_FIELD(p)
     nullify(u_bck);     ALLOCATE_G_FIELD(u_bck)
     nullify(p_qed);     ALLOCATE_U1GEN_FIELD(p_qed)
     nullify(a_qed_bck); ALLOCATE_U1GEN_FIELD(a_qed_bck)
     nullify(p_axion);   ALLOCATE_AXION_MOMENTUM_FIELD(p_axion)
     nullify(axion_bck); ALLOCATE_AXION_FIELD(axion_bck)
!!   nullify(phi_bck);   ALLOCATE_SC_FIELD(phi_bck)
                          
    if (switches%replay) then
       read(input%replay_trick_threshold,*) replay_threshold
       nullify(p_bck);     ALLOCATE_GEN_FIELD(p_bck)
       nullify(p_qed_bck); ALLOCATE_U1GEN_FIELD(p_qed_bck)
       nullify(p_axion_bck); ALLOCATE_AXION_MOMENTUM_FIELD(p_axion_bck)
    endif
  endif

  TIMING_STOP(timing_bin_hmc_init)

  if (test /= HMC_TEST_BACKWARDS) then  ! ie normally do:

     ! initialize momenta p, p_qed, p_axion:
     call hmc_init_p(p)
     call hmc_init_p_qed(p_qed, a_qed_bck)  ! use a_qed_bck as scratch array
     call hmc_init_p_axion(p_axion, axion_bck)  ! use axion_bck as scratch array

     ! backups:
     TIMING_START(timing_bin_hmc_backup)
!!   if (input%hmc_mpf_mass /= 0 )call swap_p_sc_field(phi_bck, mpf(1)%sc)

     DEBUG2S("HMC: u_bck")
     call conf_copy(u_bck, gauge(1)%u)
     call qed_conf_copy(a_qed_bck, conf%a_qed)
     call axion_conf_copy(axion_bck, conf%axion)
     DEBUG2S("HMC: u_bck done")

     TIMING_STOP(timing_bin_hmc_backup)

     TIMING_START(timing_bin_hmc_h_old)

     ! initialize phi, phi2 and old action:

#ifdef BQCD_DDHMC
     call nonactive(p) !! for ddhmc
#endif
     if (switches%boundary_sf) call schr_boundary_p(p)
     if (switches%replay) p_bck=p
     if (switches%replay .and. switches%qed) p_qed_bck = p_qed
     if (switches%replay .and. switches%axion) p_axion_bck = p_axion

     call hmc_init_phi(sf1_old, sf2_old, sf3_old)

     sp_old = sp(p)
     hg_old = sig(sg_old, plaq_old, rect_old)
     sp_qed_old = sp_qed(p_qed)
     sg_qed_old = sg_qed(conf%a_qed, plaq_qed_old)
     hg_qed_old = sg_qed_old * para%beta_qed

     sp_axion_old = sp_axion(p_axion)
     sk_axion_old = sk_axion(conf%axion, axion_energy_old, axion_average_old)
     hk_axion_old = sk_axion_old * para%kappa_axion

     call clover_action_sum(sd_old)
     h_old = sd_old + sp_old + hg_old + sf1_old + sf2_old + sf3_old + sp_qed_old + hg_qed_old + sp_axion_old + hk_axion_old
     TIMING_STOP(timing_bin_hmc_h_old)
  endif
  if (test == HMC_TEST_FORWARDS) then
     call hmc_test_report(test, p, gauge(1)%u, &
                          sp_old, hg_old, sf1_old, sf2_old+sf3_old, sd_old)
  endif


!--------------------------------------------------------------------- MD step:
  call integrate(p, p_qed, p_axion, para, conf, sf1_new, sf2_new, sf3_new)
!------------------------------------------------------- calculate Hamiltonian:
  DEBUG2S("Start calculate Hamiltonian")
  TIMING_START(timing_bin_hmc_h_new)

  if (switches%boundary_sf) call schr_boundary_p(p)
  sp_new = sp(p)
  hg_new = sig(sg_new, plaq_new, rect_new)
  sp_qed_new = sp_qed(p_qed)
  sg_qed_new = sg_qed(conf%a_qed, plaq_qed_new)
  hg_qed_new = sg_qed_new * para%beta_qed
  sp_axion_new = sp_axion(p_axion)
  sk_axion_new = sk_axion(conf%axion, axion_energy_new, axion_average_new)
  hk_axion_new = sk_axion_new * para%kappa_axion

  call clover_action_sum(sd_new)
  h_new = sd_new + sp_new + hg_new + sf1_new + sf2_new + sf3_new + sp_qed_new + hg_qed_new + sp_axion_new + hk_axion_new
  TIMING_STOP(timing_bin_hmc_h_new)
  DEBUG2S("End calculate Hamiltonian")
!------------------------------------------------------------- accept new U ? :

  TIMING_START(timing_bin_hmc_rest)
  DEBUG2S("Start MC check")
  hg_dif =   hg_new  -  hg_old
  sp_dif =   sp_new  -  sp_old
  sd_dif =   sd_new  -  sd_old
  sf1_dif =  sf1_new -  sf1_old
  sf2_dif =  sf2_new -  sf2_old
  sf3_dif =  sf3_new -  sf3_old
  sp_qed_dif = sp_qed_new - sp_qed_old
  hg_qed_dif = hg_qed_new - hg_qed_old
  sp_axion_dif = sp_axion_new - sp_axion_old
  hk_axion_dif = hk_axion_new - hk_axion_old

  h_dif = sd_dif + sp_dif + hg_dif + sf1_dif + sf2_dif + sf3_dif + sp_qed_dif + hg_qed_dif + sp_axion_dif + hk_axion_dif

!!  out%exp_dh = exp(h_old - h_new)
  out%exp_dh = exp( - h_dif)

  if (force_accept /= 0) then
     out%accepted = 1
  elseif (switches%replay) then
     replayed = .false.
     if (abs(h_dif) > replay_threshold) then
        if (my_pe()==0) then
        write(*,*)"replay_trick: start replay mode"
        write(*,*)"replay_trick: h_dif before replaying =",h_dif
        endif

        !
        ! reset integrator
        !
        call swap_integer(para%ntau, input%replay_trick_ntau)
        call delete_integrator()
        call init_hmc(para)

        !
        ! copy back gauge field and initialization
        !
        call conf_copy(gauge(1)%u, u_bck)
        call qed_conf_copy(conf%a_qed, a_qed_bck)
        call axion_conf_copy(conf%axion, axion_bck)
        gauge(1:size(gauge))%init = .true.
        if(associated(stout)) stout(1:size(stout))%init = .true.
        if(associated(clover))clover(1:n_clover)%init = .true.

         hg_new = ZERO
         sg_new = ZERO
         sp_new = ZERO
         sd_new = ZERO
        sf1_new = ZERO
        sf2_new = ZERO
        sf3_new = ZERO

        hg_qed_new = ZERO
        sg_qed_new = ZERO
        sp_qed_new = ZERO

        hk_axion_new = ZERO
        sk_axion_new = ZERO
        sp_axion_new = ZERO

        !
        ! replay with new ntau
        !
        call integrate(p_bck, p_qed_bck, p_axion_bck, para, conf, sf1_new, sf2_new, sf3_new)

        sp_new = sp(p_bck)
        hg_new = sig(sg_new, plaq_new, rect_new)
        sp_qed_new = sp_qed(p_qed_bck)
        sg_qed_new = sg_qed(conf%a_qed, plaq_qed_new)
        hg_qed_new = sg_qed_new * para%beta_qed
        sp_axion_new = sp_axion(p_axion_bck)
        sk_axion_new = sk_axion(conf%axion, axion_energy_new, axion_average_new)
        hk_axion_new = sk_axion_new * para%kappa_axion

        call clover_action_sum(sd_new)
        h_new = sd_new + sp_new + hg_new + sf1_new + sf2_new + sf3_new + sp_qed_new + hg_qed_new + sp_axion_new + hk_axion_new

         hg_dif =  hg_new -  hg_old
         sp_dif =  sp_new -  sp_old
         sd_dif =  sd_new -  sd_old
        sf1_dif = sf1_new - sf1_old
        sf2_dif = sf2_new - sf2_old
        sf3_dif = sf3_new - sf3_old

        hg_qed_dif = hg_qed_new - hg_qed_old
        sp_qed_dif = sp_qed_new - sp_qed_old

        sp_axion_dif = sp_axion_new - sp_axion_old
        hk_axion_dif = hk_axion_new - hk_axion_old

        h_dif = sd_dif + sp_dif + hg_dif + sf1_dif + sf2_dif + sf3_dif + sp_qed_dif +  hg_qed_dif + sp_axion_dif + hk_axion_dif

        out%exp_dh = exp( - h_dif)
        if (my_pe()==0) then
        write(*,*)"replay_trcik: replayed h_dif         =",h_dif
        endif

        !
        ! reconstruct integrator with normal parameters
        !
        call swap_integer(para%ntau, input%replay_trick_ntau)
        call delete_integrator()
        call init_hmc(para)

        replayed = .true.
     endif

     if (ran_number() < out%exp_dh) then
        out%accepted = 1
     else
        out%accepted = 0
     endif

     if ( replayed ) then
     if (out%accepted == 1) then
         hg_old1 =  hg_new
         sp_old1 =  sp_new
         sd_old1 =  sd_new
        sf1_old1 =  sf1_new
        sf2_old1 =  sf2_new
        sf3_old1 =  sf3_new

        hg_qed_old1 = hg_qed_new
        sg_qed_old1 = sg_qed_new
        sp_qed_old1 = sp_qed_new

        hk_axion_old1 = hk_axion_new
        sk_axion_old1 = sk_axion_new
        sp_axion_old1 = sp_axion_new

        p_bck = - p_bck
        p_qed_bck = - p_qed
        p_axion_bck = - p_axion

         hg_new1 = ZERO
         sg_new1 = ZERO
         sp_new1 = ZERO
         sd_new1 = ZERO
        sf1_new1 = ZERO
        sf2_new1 = ZERO
        sf3_new1 = ZERO

        hg_qed_new1 = ZERO
        sg_qed_new1 = ZERO
        sp_qed_new1 = ZERO

        hk_axion_new1 = ZERO
        sk_axion_new1 = ZERO
        sp_axion_new1 = ZERO

        call integrate(p_bck, p_qed_bck, p_axion_bck, para, conf, sf1_new1, sf2_new1, sf3_new1)

        sp_new1 = sp(p_bck)
        hg_new1 = sig(sg_new1, plaq_new1, rect_new1)
        sp_qed_new1 = sp_qed(p_qed_bck)
        sg_qed_new1 = sg_qed(conf%a_qed, plaq_qed_new1)
        hg_qed_new1 = sg_qed_new1 * para%beta_qed
        sp_axion_new1 = sp_axion(p_axion_bck)
        sk_axion_new1 = sk_axion(conf%axion, axion_energy_new1, axion_average_new1)
        hk_axion_new1 = sk_axion_new1 * para%kappa_axion


        call clover_action_sum(sd_new1)
        h_new1 = sd_new1 + sp_new1 + hg_new1 + sf1_new1 + sf2_new1 + sf3_new1

         hg_dif1 =   hg_new1 -  hg_old1
         sp_dif1 =   sp_new1 -  sp_old1
         sd_dif1 =   sd_new1 -  sd_old1
        sf1_dif1 =  sf1_new1 - sf1_old1
        sf2_dif1 =  sf2_new1 - sf2_old1
        sf3_dif1 =  sf3_new1 - sf3_old1

        hg_qed_dif1 = hg_qed_new1 - hg_qed_old1
        sp_qed_dif1 = sp_qed_new1 - sp_qed_old1

        hk_axion_dif1 = hk_axion_new1 - hk_axion_old1
        sp_axion_dif1 = sp_axion_new1 - sp_axion_old1

        h_dif1 = sd_dif1 + sp_dif1 + hg_dif1 + sf1_dif1 + sf2_dif1 + sf3_dif1 &
               + sp_qed_dif1 + hg_qed_dif1 + sp_axion_dif1 + hk_axion_dif1

        if (abs(h_dif1) < replay_threshold) then
           out%accepted = 0
        if (my_pe()==0) write(*,*)"replay_trick: reversibility is NOT ok"
        else
        if (my_pe()==0) write(*,*)"replay_trick: reversibility is ok"
        endif
     else
        if (my_pe()==0) write(*,*)"replay_trick, replayed but rejected"
     endif
     endif

  else
     if (ran_number() < out%exp_dh) then
        out%accepted = 1
     else
        out%accepted = 0
     endif
  endif
  DEBUG2S("End MC check")

  if (out%accepted == 1) then
     out%sg = sg_new
     out%sf = sf1_new
     out%plaq = plaq_new
     out%rect = rect_new
     out%sg_qed = sg_qed_new
     out%plaq_qed = plaq_qed_new
     out%sk_axion = sk_axion_new
     out%axion_energy = axion_energy_new
     out%axion_average = axion_average_new
  else
     out%plaq = plaq_old
     out%rect = rect_old
     out%sg_qed = sg_qed_old
     out%plaq_qed = plaq_qed_old
     out%sk_axion = sk_axion_old
     out%axion_energy = axion_energy_old
     out%axion_average = axion_average_old
     DEBUG2S("Start replace new by old fields")
!!     if (input%hmc_mpf_mass /= 0 ) call swap_p_sc_field(mpf(1)%sc, phi_bck)
  DEBUG2S("HMC: u_bck")
     call conf_copy(gauge(1)%u, u_bck)
     call qed_conf_copy(conf%a_qed, a_qed_bck)
     call axion_conf_copy(conf%axion, axion_bck)
  DEBUG2S("HMC: u_bck done")
!!     gauge(1)%u(1:3,1:3,1:volh_tot,0:1,1:4) = u_bck(1:3,1:3,1:volh_tot,0:1,1:4)
     gauge(1:size(gauge))%init = .true.
     if(associated(stout)) stout(1:size(stout))%init = .true.
     if(associated(clover))clover(1:n_clover)%init = .true.
     DEBUG2S("End replace new by old fields")
  endif
#ifdef BQCD_DDHMC
  call paratransu(gauge(1)%u) !! need for nonactive link method for DD
#endif

  DEBUG2S("Record CG stat")
  call get_cg_stat(cg_stat,  out%cg_ncall, out%cg_niter_max, out%cg_niter_tot)
  call get_cg_stat(cgm_stat, out%cgm_ncall, out%cgm_niter_max, out%cgm_niter_tot)

  DEBUG2S("Write iterCount and Force")
  call iteration_count_is_write(UREC)
  call hmc_forces_write(UREC)

  if (test == HMC_TEST_BACKWARDS) then
     call hmc_test_report(test, p, gauge(1)%u, &
                          sp_new, hg_new,sf1_new, sf2_new+sf3_new, sd_new)
  endif
  TIMING_STOP(timing_bin_hmc_rest)

  DEBUG2S("Write Action old new diff")
  call hmc_write_h(UREC, "old",  h_old, sp_old, hg_old, sd_old, &
  sf1_old, sf2_old, sf3_old, sp_qed_old, hg_qed_old, sp_axion_old, hk_axion_old)
  call hmc_write_h(UREC, "new",  h_new, sp_new, hg_new, sd_new, &
  sf1_new, sf2_new, sf3_new, sp_qed_new, hg_qed_new, sp_axion_new, hk_axion_new)
  call hmc_write_h(UREC, "diff", h_dif, sp_dif, hg_dif, sd_dif, &
  sf1_dif, sf2_dif, sf3_dif, sp_qed_dif, hg_qed_dif, sp_axion_dif, hk_axion_dif)

  TIMING_STOP(timing_bin_hmc)

  if (switches%stout .and. para%n_stout == 5) then
     DEBUG2S("Check stout")
     call check_stout(conf)
  endif

  plaq = ONE - out%sg / (SIX * volume)

  DEBUG2S("End HMC")

end

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