!===============================================================================
!
! hmc_forces.F90  -  calculation of HMC forces in Hasenbusch improvement,
!                    does not work with tempering
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 2006-2007 Hinnerk Stueben, 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_forces_old(p)

  use module_hmc_forces
  use module_p_interface
  use module_switches
  use module_vol
  implicit none

  GENERATOR_FIELD, intent(in) :: p
  integer                     :: mu, eo, i

  if (.not. associated(p_old)) then
     call allocate_gen_field(p_old)
     f_count = ZERO
     f_avg = ZERO
     f_max = ZERO
  endif

  do mu = 1, DIM
     do eo = EVEN, ODD
        !$omp parallel do
        do i = 1, volh
           p_old(1, i, eo, mu) = p(1, i, eo, mu)
           p_old(2, i, eo, mu) = p(2, i, eo, mu)
           p_old(3, i, eo, mu) = p(3, i, eo, mu)
           p_old(4, i, eo, mu) = p(4, i, eo, mu)
           p_old(5, i, eo, mu) = p(5, i, eo, mu)
           p_old(6, i, eo, mu) = p(6, i, eo, mu)
           p_old(7, i, eo, mu) = p(7, i, eo, mu)
           p_old(8, i, eo, mu) = p(8, i, eo, mu)
        enddo
     enddo
  enddo

end

!-----------------------------------------------------------------------------
subroutine hmc_forces_new(p, step, which)

  use module_hmc_forces
  use module_function_decl
  use module_switches
  use module_vol
  implicit none

  GENERATOR_FIELD, intent(in) :: p
  REAL, intent(in)            :: step
  integer, intent(in)         :: which

  integer                     :: mu, eo, i
  REAL                        :: f, fa, fm, ffaa, ffmm

!  if (.not. switches%hasenbusch) return

  ffaa = ZERO
  ffmm = ZERO
  do mu = 1, DIM
     do eo = EVEN, ODD
        fa = ZERO
        fm = ZERO
        !$omp parallel do reduction (+: fa) reduction(max: fm) private(f)
        do i = 1, volh
           f = sqrt( (p_old(1, i, eo, mu) - p(1, i, eo, mu))**2 &
                   + (p_old(2, i, eo, mu) - p(2, i, eo, mu))**2 &
                   + (p_old(3, i, eo, mu) - p(3, i, eo, mu))**2 &
                   + (p_old(4, i, eo, mu) - p(4, i, eo, mu))**2 &
                   + (p_old(5, i, eo, mu) - p(5, i, eo, mu))**2 &
                   + (p_old(6, i, eo, mu) - p(6, i, eo, mu))**2 &
                   + (p_old(7, i, eo, mu) - p(7, i, eo, mu))**2 &
                   + (p_old(8, i, eo, mu) - p(8, i, eo, mu))**2 )
           fa = fa + f
           fm = max(fm, f)
        enddo
        ffaa = ffaa + fa
        ffmm = max(ffmm, fm)
     enddo
  enddo

  ffaa = global_sum(ffaa) / (volume * DIM)
  ffmm = global_max(ffmm)

  f_count(which) = f_count(which) + ONE
  if (step /= 0) then
  f_avg(which) = f_avg(which) + ffaa / abs(step)
  f_max(which) = f_max(which) + ffmm / abs(step)
  endif
end


!-----------------------------------------------------------------------------
subroutine hmc_forces_write(unit)
  use module_hmc_forces
  use module_counter
  use module_function_decl
  use module_switches
  implicit none

  integer, intent(in)     :: unit
  integer, save           :: written = 0 
  integer                 :: i
  REAL :: f_min

  character(*), parameter :: key_avg   = "%Favg"
  character(*), parameter :: key_max   = "%Fmax"
  character(*), parameter :: key_rat   = "%Frat"
  character(len=30) :: fmt_h, fmt_b, fmt_r
  character(9) :: f_name(n_force+20)

  n_force = 12
  f_name(i_sg)  = "  F_gauge"
  f_name(i_sig) = "   F_impg"
  f_name(i_sd)  = "    F_det"
  f_name(i_sf1) = "     F_F1"
  f_name(i_sf2) = "     F_F2"
  f_name(i_sf3) = "     F_F3"
  f_name(i_sf4) = "     F_F4"
  f_name(i_sf5) = "     F_F5"
  f_name(i_sf6) = "     F_F6"
  f_name(i_sf7) = "     F_F7"
  f_name(i_sf8) = "     F_F8"
  f_name(i_sf9) = "     F_F9"
!  fmt_h = "(1x, 2a, a6, 7x, "// char(n_force+48) //"a)"
!  fmt_b = "(1x, a6, i6, 6x, "// char(n_force+48) //"g10.3)"
  fmt_h = "(1x, 2a, a10, 7x, 12a)"
!!  fmt_b = "(1x, a6, i6, 7x, 12(1pe9.2))"
  fmt_b = "(1x, a6, i10, 7x, 12(  f9.3))"
  fmt_r = "(1x, a6, i10, 7x, 12(  f9.3))"

  do i = 1, n_force
     if (f_count(i) /= ZERO) then
        f_avg(i) = f_avg(i) / f_count(i)
        f_max(i) = f_max(i) / f_count(i)
     endif
  enddo
 f_min = f_max(i_sg)
  do i = 1, n_force
     if (f_max(i) /= ZERO)f_min = min(f_min, f_max(i))
  enddo
  do i = 1, n_force
     if (f_min /= ZERO) f_rat(i) = f_max(i) / f_min
  enddo

  if (written == 0 .and. my_pe() == 0) then
     write(unit, fmt_h) "T", key_avg, "traj", (f_name(i), i = 1, n_force)
     write(unit, fmt_h) "T", key_max, "traj", (f_name(i), i = 1, n_force)
     write(unit, fmt_h) "T", key_rat, "traj", (f_name(i), i = 1, n_force)
  endif
     
  if (my_pe() == 0) then
     write(unit, fmt_b) key_avg, counter%traj, (f_avg(i), i = 1, n_force)
     write(unit, fmt_b) key_max, counter%traj, (f_max(i), i = 1, n_force)
     write(unit, fmt_r) key_rat, counter%traj, (f_rat(i), i = 1, n_force)
  endif

  written = written + 1
  f_count = ZERO
  f_avg = ZERO
  f_max = ZERO
  f_rat = ZERO
end

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