!===============================================================================
!
! mc.F90 - Monte Carlo loop (not including tempering)
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 1998-2005 Hinnerk Stueben
!               2006-2017 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"

!-------------------------------------------------------------------------------
module typedef_mc_temper

  type temper_out
     REAL    :: delta_h
     integer :: pair
     integer :: swapped
  end type temper_out

end module typedef_mc_temper

!-------------------------------------------------------------------------------
subroutine mc(para, conf)

  use typedef_mc_temper
  use typedef_para
  use module_counter
  use module_function_decl
  use module_switches
  use module_input
  use module_vol
  use module_field
  implicit none

  type(type_para),                         intent(inout) :: para
  type(hmc_conf),   dimension(MAX_TEMPER), intent(inout) :: conf

  type(hmc_out),    dimension(MAX_TEMPER)  :: out
  type(temper_out), dimension(MAX_TEMPER)  :: tmpr
  integer                                  :: i, j
  integer                                  :: iforce, itraj
  integer                                  :: force_accept = 0
  character(len = *), parameter            :: key_fa   = "%fa"
  character(len = *), parameter            :: key_mc   = "%mc"
  character(len = *), parameter            :: key_swap = "%sw"
  character(len = *), parameter            :: key_pr   = "%pr"
  character(len = *), parameter            :: key_ax   = "%ax"
  REAL                                     :: dummy, dummy0(3), dummy1(3)
  REAL, external                           :: sg, sig
  FILENAME, external :: conf_info_file

  DEBUG2S("Start: MC")
  if (switches%tempering) call die("mc(): bqcd4: n_ensemble has to be 1")

  if (switches%hmc_test) then
     if (para%n_temper /= 1) call die("mc(): HMC-test: n_ensemble has to be 1")
     call hmc_test(para%hmc(1), conf(1))
     return
  endif

  force_accept = 1
  iforce = 0
  do while (counter%traj < 0 .and. counter%j_traj < para%ntraj)
  DEBUG2S("Start: one ForceAcceptance")
     iforce = iforce + 1
     counter%traj = counter%traj + 1
     counter%j_traj = counter%j_traj + 1

     if (iforce == 1 .and. my_pe() == 0) then
        call begin(UREC, "ForceAcceptance")
        if (switches%qed .and. switches%axion) write(UREC, 407) "T", key_fa, "i_fa", "e", &
             "PlaqEnergy", "exp(-Delta_H)", "CGcalls", "CGitTot", "CGitMax", &
                                            "CGMcalls", "CGMitTot", "CGMitMax", "Plaquette", "PlaquetteQED", "AxionEnergy"

        if (switches%qed .and. .not. switches%axion) write(UREC, 406) "T", key_fa, "i_fa", "e", &
             "PlaqEnergy", "exp(-Delta_H)", "CGcalls", "CGitTot", "CGitMax", &
                                            "CGMcalls", "CGMitTot", "CGMitMax", "Plaquette", "PlaquetteQED"

        if (.not. switches%qed .and. switches%axion) write(UREC, 406) "T", key_fa, "i_fa", "e", &
             "PlaqEnergy", "exp(-Delta_H)", "CGcalls", "CGitTot", "CGitMax", &
                                            "CGMcalls", "CGMitTot", "CGMitMax", "Plaquette", "AxionEnergy"

        if (.not. switches%qed .and. .not. switches%axion) write(UREC, 405) "T", key_fa, "i_fa", "e", &
             "PlaqEnergy", "exp(-Delta_H)", "CGcalls", "CGitTot", "CGitMax", &
                                            "CGMcalls", "CGMitTot", "CGMitMax", "Plaquette"
     endif

     do i = 1, para%n_temper
        call hmc(para%hmc(i), conf(i), out(i), force_accept, HMC_TEST_NONE)
        if (my_pe() == 0) then
           if (switches%qed .and. switches%axion) write(UREC, 417) key_fa, counter%traj, i, &
           out(i)%sg / (SIX * volume), out(i)%exp_dh, out(i)%cg_ncall, &
           out(i)%cg_niter_tot, out(i)%cg_niter_max, out(i)%cgm_ncall, &
           out(i)%cgm_niter_tot, out(i)%cgm_niter_max, &
           ONE -out(i)%sg / dble(SIX * volume), &
           out(i)%plaq_qed, out(i)%axion_energy

           if (switches%qed .and. .not. switches%axion) write(UREC, 416) key_fa, counter%traj, i, &
           out(i)%sg / (SIX * volume), out(i)%exp_dh, out(i)%cg_ncall, &
           out(i)%cg_niter_tot, out(i)%cg_niter_max, out(i)%cgm_ncall, &
           out(i)%cgm_niter_tot, out(i)%cgm_niter_max, &
           ONE -out(i)%sg / dble(SIX * volume), &
           out(i)%plaq_qed

           if (.not. switches%qed .and. switches%axion) write(UREC, 416) key_fa, counter%traj, i, &
           out(i)%sg / (SIX * volume), out(i)%exp_dh, out(i)%cg_ncall, &
           out(i)%cg_niter_tot, out(i)%cg_niter_max, out(i)%cgm_ncall, &
           out(i)%cgm_niter_tot, out(i)%cgm_niter_max, &
           ONE -out(i)%sg / dble(SIX * volume), &
           out(i)%axion_energy

           if (.not. switches%qed .and. .not. switches%axion) write(UREC, 415) key_fa, counter%traj, i, &
           out(i)%sg / (SIX * volume), out(i)%exp_dh, out(i)%cg_ncall, &
           out(i)%cg_niter_tot, out(i)%cg_niter_max, out(i)%cgm_ncall, &
           out(i)%cgm_niter_tot, out(i)%cgm_niter_max, &
           ONE -out(i)%sg / dble(SIX * volume)
        endif
        call minmax(AFTER_HMC)
     enddo
  DEBUG2S("End: one ForceAcceptance")
  enddo

  if (iforce > 0) call end(UREC, "ForceAcceptance")

  force_accept = 0
  itraj = 0
  do while (counter%traj >= 0 .and. counter%traj < para%maxtraj  &
            .and. counter%j_traj < para%ntraj)

     itraj = itraj + 1
     counter%traj = counter%traj + 1
     counter%j_traj = counter%j_traj + 1

     if (switches%measure_only) then
        counter%traj = input%measure_start_traj + para%nsave * (itraj - 1)
        if (input%io_conf_format == "bqcd" .or. input%io_conf_format == "bqcd2") then
           para%info_file = conf_info_file(1, 1)
        elseif (input%io_conf_format == "ildg") then
           call ildg_set_prefix()
           call ildg_set_middle()
           call ildg_lime_file(input%start_ildg_file, "write", .false.)
        else
           call die("unknown io_conf_format, it must be [bqcd|bqcd2|ildg]")
        endif
        call conf_read(.false., para, conf)
        if (switches%boundary_sf) call schr_boundary_gauge(gauge(1)%u)
        call init_gaugelink_flag()
     endif

     if (itraj == 1 .and. my_pe() == 0) then
        call begin(UREC, "MC")

        if (para%n_temper > 1) write(UREC, 450)  &
                "T", key_swap, "traj", "ie", "e1", "e2", "Delta_H", "Acc"

        if (switches%qed .and. switches%axion)write(UREC, 402) "T", key_mc, "traj", "e", "f", &
             "PlaqEnergy", "exp(-Delta_H)", "Acc", "CGcalls", "CGitTot", "CGitMax", &
             "CGMcalls", "CGMitTot", "CGMitMax", "Plaquette", "PlaquetteQED", "AxionEnergy"

        if (switches%qed .and. .not. switches%axion)write(UREC, 401) "T", key_mc, "traj", "e", "f", &
             "PlaqEnergy", "exp(-Delta_H)", "Acc", "CGcalls", "CGitTot", "CGitMax", &
             "CGMcalls", "CGMitTot", "CGMitMax", "Plaquette", "PlaquetteQED"

        if (.not. switches%qed .and. switches%axion)write(UREC, 401) "T", key_mc, "traj", "e", "f", &
             "PlaqEnergy", "exp(-Delta_H)", "Acc", "CGcalls", "CGitTot", "CGitMax", &
             "CGMcalls", "CGMitTot", "CGMitMax", "Plaquette", "AxionEnergy"

        if (.not. switches%qed .and. .not. switches%axion)write(UREC, 400) "T", key_mc, "traj", "e", "f", &
             "PlaqEnergy", "exp(-Delta_H)", "Acc", "CGcalls", "CGitTot", "CGitMax", &
             "CGMcalls", "CGMitTot", "CGMitMax", "Plaquette"

        write(UREC, 500) "T", key_pr, "traj", &
        "Plaquette","PlaquetteS","PlaquetteT","Rectangle","RectangleS","RectangleT"             
        if (switches%axion) &
        write(UREC, 600) "T", key_ax, "traj", "AxionEnergy","AxionAverage"
     endif

     do i = 1, para%n_temper
        if (itraj == 1) then
           if (switches%tempering .and. switches%dynamical) then
!!!              out(i)%sf = sf(para%hmc(i), conf(i)) ! Yoshifumi
                 if (my_pe() == 0) write(UREC,*)"%%%%%%%%%%%%%%%%%%%%%   sf() dose not work"
           else
              out(i)%sf = ZERO
           endif
           dummy = sig(out(i)%sg,dummy0, dummy1)
        endif
        call hmc(para%hmc(i), conf(i), out(i), force_accept, HMC_TEST_NONE)
     enddo
     
     if (para%n_temper > 1 .and. counter%traj > para%nstd) then
        call temper(para%n_temper, para%swap_seq, para%hmc, conf, out, tmpr)
        do i = 1, para%n_temper - 1
           if (my_pe() == 0) write(UREC, 460) key_swap, counter%traj, i, &
                tmpr(i)%pair, tmpr(i)%pair + 1, tmpr(i)%delta_h, tmpr(i)%swapped
        enddo
     endif
     
     do i = 1, para%n_temper
        j = conf(i)%former

        DEBUG2S("Write: %mc")
        if (my_pe() == 0) then
           if (switches%qed .and. switches%axion)write(UREC,412) key_mc, counter%traj, i, j, &
           out(i)%sg / (SIX * volume), out(i)%exp_dh, out(i)%accepted, &
           out(i)%cg_ncall, out(i)%cg_niter_tot, out(i)%cg_niter_max, &
           out(i)%cgm_ncall, out(i)%cgm_niter_tot, out(i)%cgm_niter_max, &
           ONE -out(i)%sg / dble(SIX * volume), &
           out(i)%plaq_qed, out(i)%axion_energy

           if (switches%qed .and. .not. switches%axion)write(UREC,411) key_mc, counter%traj, i, j, &
           out(i)%sg / (SIX * volume), out(i)%exp_dh, out(i)%accepted, &
           out(i)%cg_ncall, out(i)%cg_niter_tot, out(i)%cg_niter_max, &
           out(i)%cgm_ncall, out(i)%cgm_niter_tot, out(i)%cgm_niter_max, &
           ONE -out(i)%sg / dble(SIX * volume), &
           out(i)%plaq_qed

           if (.not. switches%qed .and. switches%axion)write(UREC,411) key_mc, counter%traj, i, j, &
           out(i)%sg / (SIX * volume), out(i)%exp_dh, out(i)%accepted, &
           out(i)%cg_ncall, out(i)%cg_niter_tot, out(i)%cg_niter_max, &
           out(i)%cgm_ncall, out(i)%cgm_niter_tot, out(i)%cgm_niter_max, &
           ONE -out(i)%sg / dble(SIX * volume), &
           out(i)%axion_energy

           if (.not. switches%qed .and. .not. switches%axion)write(UREC,410) key_mc, counter%traj, i, j, &
           out(i)%sg / (SIX * volume), out(i)%exp_dh, out(i)%accepted, &
           out(i)%cg_ncall, out(i)%cg_niter_tot, out(i)%cg_niter_max, &
           out(i)%cgm_ncall, out(i)%cgm_niter_tot, out(i)%cgm_niter_max, &
           ONE -out(i)%sg / dble(SIX * volume)


           write(UREC,510) key_pr, counter%traj, out(i)%plaq(1),out(i)%plaq(2),out(i)%plaq(3), &
                                                 out(i)%rect(1),out(i)%rect(2),out(i)%rect(3)
           if (switches%axion) &
           write(UREC,610) key_ax, counter%traj, out(i)%axion_energy, out(i)%axion_average
        endif

        DEBUG2S("Start: measurements")
        call minmax(AFTER_HMC)
        if (switches%measure_traces) then
            call traces(counter%traj)
        endif

        if (switches%measure_chemical) then
            if(mod(counter%traj,input%measure_chemical)==0) then
               call chemical_determinant(counter%traj)
           endif
        endif
        if (switches%measure_schrpcac) then
            if(mod(counter%traj,input%measure_schrpcac)==0) then
               call schr_pcac(counter%job, counter%traj)
            endif
        endif

        if (switches%measure_polyakov_loop) call polyakov_loop(conf(i), counter%traj, i, j)
        if (switches%measure_wilson_flow) call wilson_flow(conf(i)%u, counter%traj, i, j)
        if (switches%measure_wilson_flow_qed) call wilson_flow_qed(conf(i)%a_qed, counter%traj, i, j)
        call cooling(conf(i)%u, counter%traj, i, j)
        call hadspec(counter%traj)
        if (switches%axion) call axion_sliced_av(counter%traj)
        DEBUG2S("End: measurements")
     enddo

     if (para%nsave > 0 .and. (.not. switches%measure_only)) then
        if (mod(counter%traj, para%nsave) == 0) then
           DEBUG2S("MC: conf_write")
           call conf_write(.false., para, conf)
        endif
     endif

  enddo

  if (itraj > 0) then
     call end(UREC, "MC")
  endif

400 format (1x, 2a, a12, 2a3,    2a15,    a4, 2(a9,a10,a9),  a20)
401 format (1x, 2a, a12, 2a3,    2a15,    a4, 2(a9,a10,a9), 2a20)
402 format (1x, 2a, a12, 2a3,    2a15,    a4, 2(a9,a10,a9), 3a20)
405 format (1x, 2a, a12, a3, 3x, 2a15,    4x, 2(a9,a10,a9),  a20)
406 format (1x, 2a, a12, a3, 3x, 2a15,    4x, 2(a9,a10,a9), 2a20)
407 format (1x, 2a, a12, a3, 3x, 2a15,    4x, 2(a9,a10,a9), 3a20)
410 format (1x, a4, i12, 2i3,    2f15.10, i4, 2(i9,i10,i9),  f20.15)
411 format (1x, a4, i12, 2i3,    2f15.10, i4, 2(i9,i10,i9), 2f20.15)
412 format (1x, a4, i12, 2i3,    2f15.10, i4, 2(i9,i10,i9), 3f20.15)
415 format (1x, a4, i12, i3, 3x, 2f15.10, 4x, 2(i9,i10,i9),  f20.15)
416 format (1x, a4, i12, i3, 3x, 2f15.10, 4x, 2(i9,i10,i9), 2f20.15)
417 format (1x, a4, i12, i3, 3x, 2f15.10, 4x, 2(i9,i10,i9), 3f20.15)

500 format (1x, 2a, a12, 6a18)
510 format (1x, a4, i12, 6f18.13)
600 format (1x, 2a, a12, 2a18)
610 format (1x, a4, i12, 2f18.13)

450 format (1x, 2a, a12, 3a3, a18,    a4)
460 format (1x, a4, i12, 3i3, f18.10, i4)

  DEBUG2S("End: MC")

end

!-------------------------------------------------------------------------------
subroutine temper(n_temper, swap_seq, para, conf, action, tmpr)

  use typedef_hmc
  use typedef_mc_temper
  use module_function_decl
  use module_p_interface
  implicit none

  integer,                               intent(in)    :: n_temper, swap_seq
  type(hmc_para),   dimension(n_temper), intent(in)    :: para
  type(hmc_conf),   dimension(n_temper), intent(inout) :: conf
  type(hmc_out),    dimension(n_temper), intent(inout) :: action
  type(temper_out), dimension(n_temper), intent(out)   :: tmpr

  integer,          dimension(n_temper)                :: pair
  integer                                              :: i_pair, n_pair, i, j
  integer                                              :: swapped
  REAL,             dimension(2, 2)                    :: hf, hg
!  REAL,             external                           :: sf, sg
  REAL                                                 :: h_old, h_new, delta_h

  if (n_temper == 1) return

  do i = 1, n_temper
     conf(i)%former = i
  enddo

  n_pair = n_temper - 1

  call swap_sequence(swap_seq, pair, n_pair)

  do i_pair = 1, n_pair
     i = pair(i_pair)
     j = pair(i_pair) + 1

     hg(1, 1) = para(i)%beta * action(i)%sg
     hg(2, 2) = para(j)%beta * action(j)%sg

     hg(1, 2) = para(i)%beta * action(j)%sg
     hg(2, 1) = para(j)%beta * action(i)%sg

     hf(1, 1) = action(i)%sf
     hf(2, 2) = action(j)%sf
!     hf(1, 2) = sf(para(i), conf(j))
!     hf(2, 1) = sf(para(j), conf(i))

     if (para(i)%kappa == ZERO) then
        if (hf(1, 1) /= ZERO) call die("temper(): hf(1, 1) /= 0 ")
        if (hf(2, 1) /= ZERO) call die("temper(): hf(2, 1) /= 0 ")
        if (hf(1, 2) /= ZERO) call die("temper(): hf(1, 2) /= 0 ")
        if (hf(2, 2) /= ZERO) call die("temper(): hf(2, 2) /= 0 ")
     endif

     h_old = hg(1, 1) + hf(1, 1) + hg(2, 2) + hf(2, 2)
     h_new = hg(1, 2) + hf(1, 2) + hg(2, 1) + hf(2, 1)

     delta_h = h_new - h_old

     if (ran_number() < exp(-delta_h)) then
        swapped = 1
     else
        swapped = 0
     endif

     if (swapped /= 0) then
        call swap_p_g_field(conf(i)%u, conf(j)%u)
        call swap_p_sc_field(conf(i)%phi, conf(j)%phi)
        call swap_integer(conf(i)%former, conf(j)%former)
        call swap_real(action(i)%sg, action(j)%sg)
        action(i)%sf = hf(1, 2)
        action(j)%sf = hf(2, 1)
     endif

     tmpr(i_pair)%pair    = i
     tmpr(i_pair)%swapped = swapped
     tmpr(i_pair)%delta_h = delta_h
  enddo

  call check_former(n_temper, conf)

end

!-------------------------------------------------------------------------------
subroutine check_former(n_temper, conf)

  use typedef_hmc
  use module_function_decl
  implicit none

  integer,        intent(in)    :: n_temper
  type(hmc_conf), intent(inout) :: conf(n_temper)
  integer                       :: count(n_temper), i

  count = 0
  do i = 1, n_temper
     count(conf(i)%former) = count(conf(i)%former) + 1
  enddo

  do i = 1, n_temper
     if (count(i) /= 1) call die("check_former(): error")
  enddo
end

!-------------------------------------------------------------------------------
subroutine swap_sequence(type, s, n)

  implicit none
  integer, intent(in) :: type, n
  integer, intent(out) :: s(n)
  integer :: i

  select case (type)
     case (SWAP_UP)
        do i = 1, n
           s(i) = i
        enddo
     case (SWAP_DOWN)
        do i = 1, n
           s(i) = n - i + 1
        enddo
     case (SWAP_RANDOM)
        call random_sequence(s, n)
     case default
        call die("swap_sequence(): don't know how to build the sequence")
  end select

end

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