!===============================================================================
!
! init_confs2.F90 - operations on gauge field and
!                   pseudo fermion field configurations
!                      -- rhmc
!                      -- multiple pseudofermions
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 2006-2013 Yoshifumi Nakamura
!               2013-2016 Hinnerk Stueben
!
! 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/>.
!
!-------------------------------------------------------------------------------
! Includes modifications for PFHMC, PF-MP, PF-RHMC and tRHMC
!
! Editor: Taylor Haar
! Last modified: 01/05/2017
!-------------------------------------------------------------------------------
# include "defs.h"

!-------------------------------------------------------------------------------
subroutine init_confs2(para, conf)
  use module_stout_field
  use module_field
  use module_action
  use typedef_para
  use module_p_interface
  use module_p_interface_r4
  use module_switches
#ifdef BQCD_DDHMC
  use module_dd
#endif
  implicit none

  type(type_para)                       :: para
  type(hmc_conf), dimension(MAX_TEMPER) :: conf
  integer                               :: i, count
!!  REAL :: time0, time1
!!  SECONDS sekunden

  DEBUG2S("Start: init_confs")

  do i = 1, para%n_temper
     nullify(conf(i)%u)
     call allocate_g_field(conf(i)%u)
     call allocate_u1gen_field(conf(i)%a_qed)
     call allocate_axion_field(conf(i)%axion)
     if (para%start == START_HOT .or. para%start == START_COLD) then
        call init_u(conf(i)%u, para%start)
        call init_a_qed(conf(i)%a_qed, para%start)
        call init_axion(conf(i)%axion, para%start)
        conf(i)%former = i
     endif
  enddo

  if (para%start == START_CONT) call conf_read(.true., para, conf)
  if (para%start == START_FILE) call conf_read(.false., para, conf)

  if (switches%convert_to_ildg) return

  do i = 1, para%n_temper
     if (switches%boundary_sf) call schr_boundary_gauge(conf(i)%u)
  enddo

!--------------------------------------------------------------------------
  count = 1
  if (switches%dynamical) then
     count = count + 1
     if (switches%clover) call init_logdet(para%hmc(1))
     call init_fermi_field(para%hmc(1))
     if (switches%clover) then
        count = count + 1
        call init_clover_field(n_clover)
     endif
#ifdef BQCD_DDHMC
     call init_usc_dd(ld%lat%volh, ld%lat%volh_tot, ld%lat%num_ip)
#endif
  endif
  allocate(gauge(count)) ! for u ds cl
  allocate(gauge_r4(count)) ! for u ds cl
  gauge(1:count)%init = .true.
  do i = 2, count
     nullify(gauge(i)%u)
     call allocate_g_field(gauge(i)%u)
  enddo
  if (switches%dynamical) then
     nullify(gauge_r4(2)%u)
     call allocate_g_field_r4(gauge_r4(2)%u)
     if (switches%stout_ds) then
        gauge(2)%sid = 1
     else
        gauge(2)%sid = 0
     endif
#ifdef BAGEL
     call allocate_bagel_d()
#endif
  endif
  if (switches%clover) then
     if (switches%stout_cl) then
        gauge(3)%sid = 1
     else
        gauge(3)%sid = 0
     endif
  endif
  gauge(1)%u => conf(1)%u                        !!! conf(1)%u must have "target" attribution
  if (switches%qed) a_qed_ptr => conf(1)%a_qed
  if (switches%axion) axion_ptr => conf(1)%axion
  if (switches%boundary_sf) call schr_boundary_gauge(gauge(1)%u)

  if (switches%stout) then
     allocate(stout(1))
     stout(1)%n = para%hmc(1)%n_stout
     stout(1)%alpha = para%hmc(1)%alpha
     nullify(stout(1)%iter)
     stout(1:size(stout))%init = .true.

     if (switches%smearing_only) then
        !! time0=sekunden()
        call stout_link_smearing(1)
        call conf_copy(gauge(1)%u, stout(1)%iter(stout(1)%n)%u)
        !! time1 = sekunden()-time0
        !! write(0,'(1x,"Smearing: nstep=",i6,1x, "Time=", g12.5)') stout(1)%n, time1
        !! stop
     endif
  endif

!!  call read_plaq(para)

  DEBUG2S("End: init_confs")

end

!-------------------------------------------------------------------------------
subroutine init_logdet(para)
  use module_action
  use module_input
  use typedef_para
  implicit none
  type(hmc_para) :: para
  integer        :: i, id, nf
  integer, external :: clover_id

  if (para%csw == ZERO) return
  do i = 1, 6
     id = clover_id(para%nf2_kappa(i), para%csw, para%nf2_lambda(i), 2, .true.)

     nf = input%nf1_kpnpf(i) / (input%nf1_kpnth(i) / 2)
     id = clover_id(para%nf1_kappa(i), para%csw, para%nf1_lambda(i),nf, .true.)
  enddo

  n_logdet = n_clover

  action%logdet(1:n_logdet)%aid = 3
  action%logdet(1:n_logdet)%fid = 3
  do i = 1, n_logdet
  action%logdet(i)%cid = i
  enddo

end

!-------------------------------------------------------------------------------
subroutine init_clover_field(nclv)
  use module_vol
  use module_field
  use module_action
  use module_switches
  use module_p_interface
  use module_p_interface_r4
  implicit none
  integer :: i, nclv


  if (.not. associated(clover)) then
     nullify(clover)
     allocate(clover(nclv))
     do i = 1, nclv
        clover(i)%init = .true.
        nullify(clover(i)%cfield%a)
        nullify(clover(i)%cfield%i)
        nullify(clover(i)%cfield%b)
        call allocate_clover_field_a(clover(i)%cfield%a)
        call allocate_clover_field_a(clover(i)%cfield%i)
        call allocate_clover_field_b(clover(i)%cfield%b)
        nullify(clover(i)%cfield_r4%a)
        nullify(clover(i)%cfield_r4%i)
        nullify(clover(i)%cfield_r4%b)
        call allocate_clover_field_a_r4(clover(i)%cfield_r4%a)
        call allocate_clover_field_a_r4(clover(i)%cfield_r4%i)
        call allocate_clover_field_b_r4(clover(i)%cfield_r4%b)
!        if (switches%feynman_hellmann) then
           nullify(clover(i)%cfield12%a)
           nullify(clover(i)%cfield12%i)
           nullify(clover(i)%cfield12%det)
!           call allocate_clover_field12(clover(i)%cfield12%a)
!           call allocate_clover_field12(clover(i)%cfield12%i)
!           allocate(clover(i)%cfield12%det(volh,EVEN:ODD))
           nullify(clover(i)%cfield12_r4%a)
           nullify(clover(i)%cfield12_r4%i)
!           call allocate_clover_field12_r4(clover(i)%cfield12_r4%a)
!           call allocate_clover_field12_r4(clover(i)%cfield12_r4%i)
!        endif
     enddo
  endif

end

!-------------------------------------------------------------------------------
subroutine init_fermi_field(para)
  use typedef_para
  use module_input
  use module_switches
  use module_poly, only : n_poly_id, P_NORMAL, P_CORRECTION, P_RATIONAL
  use module_vol
  use module_action
  use module_field
  implicit none
  type(hmc_para) :: para
  real(8) :: rho(6,4)
  integer :: i, j, nf, n_rho, n_poly, nf_trunc
  logical :: poly_fromfile

  DEBUG2S("Start: init_fermi_field")

  ! First, initialize the 2-flavour fermion fields

  if (input%hmc_hkappa /= 0) then
     rho(:,1)= para%nf2_kappa(:) ! light quark   D(kp)
     rho(:,2)= para%nf2_rho(:,1) !               D(rho1), rho2 < rho1 <kp
     rho(:,3)= para%nf2_rho(:,2) !               D(rho2), rho3 < rho2 <rho1
     rho(:,4)= para%nf2_rho(:,3) !               D(rho3), 0    < rho3 <rho2
  else
!! In dispute...
!    rho(:,4)= ZERO              ! light quark   D(kp) + 0
!    rho(:,3)= para%nf2_rho(:,3) !               D(kp) + rho3
!    rho(:,2)= para%nf2_rho(:,2) !               D(kp) + rho2
!    rho(:,1)= para%nf2_rho(:,1) ! heavy quark   D(kp) + rho1
     rho(:,1)= ZERO              ! light quark   D(kp) + 0
     rho(:,2)= para%nf2_rho(:,3) !               D(kp) + rho3
     rho(:,3)= para%nf2_rho(:,2) !               D(kp) + rho2
     rho(:,4)= para%nf2_rho(:,1) ! heavy quark   D(kp) + rho1
  endif

  do i = 1, 6
     ! Find out how many 'rho's there are (noting that rho(i,1) = true mass)
     n_rho = 0
     do while (rho(i,n_rho+2) /= ZERO)
        n_rho = n_rho + 1
        if (n_rho >= 3) exit
     enddo

     ! Determine if PFs are specified via files or just numbers
     poly_fromfile = (trim(input%nf2_polyfile(i,1)) /= "")
     if (poly_fromfile) then
        ! Found one file = assume ALL polyfiles
        n_poly = 1
        do while (input%nf2_polyfile(i,n_poly+1) /= "")
           n_poly = n_poly + 1
           if (n_poly >= 3) exit
        enddo
     else
        ! Just numbers
        ! Find out how many polynomial filters (PFs) there are
        n_poly = 0
        do while (input%nf2_porder(i,n_poly+1) /= ZERO)
           n_poly = n_poly + 1
           if (n_poly >= 3) exit
        enddo
     endif

     ! Apply the PFs onto the heaviest mass filter
     ! In the plain PF case, this will be the true mass

     ! Do first (= lowest order) separately to avoid OOB error
     if (n_poly > 0) then
        call fermi_id(rho(i,n_rho+1), ZERO, ZERO, para%csw, para%h, &
             para%nf2_lambda(i), 2, para%nf2_em_charge(i), EO_NORMAL, &
             F_POLY, 1, 1, input%nf2_dsfp(i,n_poly), i, n_poly)
        if (poly_fromfile) then
           call poly_id_from_file(action%pfermi(n_pfermi), P_NORMAL, &
                input%nf2_polyfile(i,n_poly))
        else
           call poly_id(action%pfermi(n_pfermi), input%nf2_porder(i,n_poly), &
                0, input%nf2_mu(i), input%nf2_nu(i))
        endif
     endif

     do j = n_poly-1,1,-1
        ! Go in reverse order as filters are specified from fine to coarse
        call fermi_id(rho(i,n_rho+1), ZERO, ZERO, para%csw, para%h, &
             para%nf2_lambda(i), 2, para%nf2_em_charge(i), EO_NORMAL, &
             F_POLY, 1, 1, input%nf2_dsfp(i,j), i, j)

        if (poly_fromfile) then
           call poly_id_from_file(action%pfermi(n_pfermi), P_NORMAL, &
                input%nf2_polyfile(i,j))
        else
           call poly_id(action%pfermi(n_pfermi), input%nf2_porder(i,j), &
                input%nf2_porder(i,j+1), input%nf2_mu(i), input%nf2_nu(i))

        endif
     enddo

     ! Add the PF correction term: a special case
     if (n_poly > 0) then
        call fermi_id(rho(i,n_rho+1), ZERO, ZERO, para%csw, para%h, &
             para%nf2_lambda(i), 2, para%nf2_em_charge(i), EO_NORMAL, &
             F_POLY, 1, 1, input%nf2_dsf(i,n_rho+1), i, 1)

        if (poly_fromfile) then
           ! Construct the required correction term from the other polys
           call construct_combined_poly(action%pfermi(n_pfermi), &
                n_poly, P_CORRECTION)
        else
           call poly_id(action%pfermi(n_pfermi), 0, input%nf2_porder(i,1), &
                input%nf2_mu(i), input%nf2_nu(i))
        endif
     endif

     ! If no PF, we need to add the heaviest Hasenbusch term
     if (n_poly == 0) then
        call fermi_id(para%nf2_kappa(i),rho(i,n_rho+1),ZERO,para%csw, &
             para%h,para%nf2_lambda(i),2, para%nf2_em_charge(i), &
             EO_NORMAL,F_HASEN,1,1,input%nf2_dsf(i,n_rho+1),i,n_rho+1)
     endif

     ! Construct all the other Hasenbusch terms
     do j = n_rho,1,-1
        ! Go in reverse order as filters are specified from fine to coarse
        call fermi_id(para%nf2_kappa(i),rho(i,j),rho(i,j+1),para%csw, &
             para%h,para%nf2_lambda(i),2, para%nf2_em_charge(i), &
             EO_NORMAL,F_HASEN,1,1,input%nf2_dsf(i,j),i,j)
     enddo
  enddo


  ! Then, initialize the 1-flavour fermion fields

  ! RHMC
  do i = 1, 6
     nf = input%nf1_kpnpf(i) / (input%nf1_kpnth(i) / 2)

     ! Add PF-RMMC poly filters from file if present
     if (trim(input%nf1_polyfile(i,1)) /= "") then
        if (input%nf1_porder(i,1) /= 0) then
           call warn("init_fermi_field(): polynomial doubly defined")
        endif

        ! Find out how many polynomial filters (PFs) there are
        n_poly = 1
        do while (trim(input%nf1_polyfile(i,n_poly+1)) /= "")
           n_poly = n_poly + 1
           if (n_poly >= 3) exit
        enddo

        do j = n_poly,1,-1
           ! Go in reverse order as filters are specified from fine to coarse
           call fermi_id(para%nf1_kappa(i), ZERO, ZERO, para%csw, para%h, &
                para%nf1_lambda(i), nf, para%nf1_em_charge(i), EO_RATIONAL, &
                F_POLY, input%nf1_kpnth(i), input%nf1_kpnpf(i), &
                input%nf1_dsfp(i,j), i, j)

           call poly_id_from_file(action%pfermi(n_pfermi), P_RATIONAL, &
                input%nf1_polyfile(i,j))
        enddo

     endif

     ! Add PF-RHMC polynomial filters by porder if present
     ! -- only available for one-filter in this case
     if (input%nf1_porder(i,1) /= 0) then
        call fermi_id(para%nf1_kappa(i), ZERO, ZERO, para%csw, para%h, &
             para%nf1_lambda(i), nf, para%nf1_em_charge(i), EO_RATIONAL, &
             F_POLY, input%nf1_kpnth(i), input%nf1_kpnpf(i), &
             input%nf1_dsfp(i,1), i, 1)
        call poly_id(action%pfermi(n_pfermi), input%nf1_porder(i,1), 0, &
             -1, -1)
     endif

     ! Add truncated RMMC filters if present
     if (input%nf1_trunc(i,1) /= 0) then
        ! First, check that we are using the Zolotarev approx, nth=2
        if (.not. (switches%zolotarev .and. input%nf1_kpnth(i) == 2)) then
           call die("init_fermi_field(): tRHMC only implemented for Zolotarev approx, nth=2")
        endif
        
        ! Find out how many truncations there are
        nf_trunc = 1
        do while (input%nf1_trunc(i,nf_trunc+1) /= 0)
           nf_trunc = nf_trunc + 1
           if (nf_trunc >= 3) exit
        enddo

        ! Do coarsest truncation (lowest index) separately to avoid
        ! array indexing errors
        call fermi_id(para%nf1_kappa(i), ZERO, ZERO, para%csw, para%h, &
             para%nf1_lambda(i), nf, para%nf1_em_charge(i), &
             EO_RATIONAL, F_TRUNC, &
             input%nf1_kpnth(i), input%nf1_kpnpf(i), &
             input%nf1_dsft(i,nf_trunc), i, nf_trunc)
        call trunc_id(action%pfermi(n_pfermi), &
             0, input%nf1_trunc(i,nf_trunc))

        ! Add the correct polynomial to the PF-RHMC correction term,
        ! if present
        if (input%nf1_porder(i,1) /= 0 &
             .or. trim(input%nf1_polyfile(i,1)) /= "") then
           if (trim(input%nf1_polyfile(i,2)) /= "") then
              ! Multiple polynomial terms: need to construct combined
              ! polynomial for the correction term
              call construct_combined_poly(action%pfermi(n_pfermi), &
                   n_poly, P_RATIONAL)
           else
              ! Only one polynomial term
              ! Just add a reference to this polynomial
              action%pfermi(n_pfermi)%polyid = n_poly_id
           endif
        endif

        ! Then add the other truncated filters
        do j = nf_trunc-1,1,-1
           ! Go in reverse order as filters are specified
           ! from fine to coarse = highest index to lowest
           call fermi_id(para%nf1_kappa(i), ZERO, ZERO, para%csw, para%h, &
                para%nf1_lambda(i), nf, para%nf1_em_charge(i), &
                EO_RATIONAL, F_TRUNC, &
                input%nf1_kpnth(i), input%nf1_kpnpf(i), &
                input%nf1_dsft(i,j), i, j)
           call trunc_id(action%pfermi(n_pfermi), &
                input%nf1_trunc(i,j+1)+1, input%nf1_trunc(i,j))
        enddo

        ! Final term = highest index truncation, includes all smaller shifts
        ! Uses the base RHMC time-scale specifier
        call fermi_id(para%nf1_kappa(i), ZERO, ZERO, para%csw, para%h, &
             para%nf1_lambda(i), nf, para%nf1_em_charge(i), &
             EO_RATIONAL, F_TRUNC, &
             input%nf1_kpnth(i), input%nf1_kpnpf(i), &
             input%nf1_dsf(i),i,0)
        call trunc_id(action%pfermi(n_pfermi), &
             input%nf1_trunc(i,1)+1, 0)

     else
        ! No truncations, so we need to construct the base RHMC term
        call fermi_id(para%nf1_kappa(i),ZERO    ,ZERO    ,para%csw,para%h, &
             para%nf1_lambda(i),nf, para%nf1_em_charge(i), EO_RATIONAL, &
             F_NONE, input%nf1_kpnth(i),input%nf1_kpnpf(i), &
             input%nf1_dsf(i),i,0)

        ! Add the correct polynomial to the PF-RHMC correction term,
        ! if PF-RHMC
        if (input%nf1_porder(i,1) /= 0 &
             .or. trim(input%nf1_polyfile(i,1)) /= "") then
           if (trim(input%nf1_polyfile(i,2)) /= "") then
              ! Multiple polynomial terms: need to construct combined
              ! polynomial for the correction term
              call construct_combined_poly(action%pfermi(n_pfermi), &
                   n_poly, P_RATIONAL)
           else
              ! Only one polynomial term
              ! Just add a reference to this polynomial
              action%pfermi(n_pfermi)%polyid = n_poly_id
           endif
        endif
     endif

  enddo

  DEBUG2S("End: init_fermi_field")

end subroutine init_fermi_field

!-------------------------------------------------------------------------------
integer function mtilde_id(kappa, csw, rho, h, lambda, nf, em_charge)   !update   n_mtilde
  use module_input
  use module_action
  use module_switches
  implicit none
  REAL,intent(in) :: rho, kappa, csw, h, lambda, em_charge
  REAL ::  a11r, a11i, a12r, a12i, a13r, a13i, a14r, a14i
  REAL ::  a21r, a21i, a22r, a22i, a23r, a23i, a24r, a24i
  REAL ::  a31r, a31i, a32r, a32i, a33r, a33i, a34r, a34i
  REAL ::  a41r, a41i, a42r, a42i, a43r, a43i, a44r, a44i
  integer,intent(in) :: nf
  integer, external :: clover_id, dslash_id
  integer :: i, tmp_cid, tmp_did
  logical, save :: breaking=.false.

  if (kappa == ZERO) then
     mtilde_id = 0
     return
  endif

  DEBUG2S("Start: mtilde_id")

  tmp_cid = clover_id(kappa, csw, lambda, nf, .false.)
  tmp_did = dslash_id(1)

  DEBUG2I("mtilde_id: cid",tmp_cid)

  do i = 1, n_mtilde
     if ( action%mtilde(i)%cid == tmp_cid .and. &
          action%mtilde(i)%did == tmp_did .and. &
          abs(action%mtilde(i)%rho - rho)< 1e-10     .and. &
          abs(action%mtilde(i)%kappa -kappa) <1e-10  .and. &
          abs(action%mtilde(i)%cswkappa - csw * kappa)<1e-10 .and. &
          abs(action%mtilde(i)%h - h)<1e-10 .and. &
          abs(action%mtilde(i)%lambda - lambda)<1e-10 .and. &
          abs(action%mtilde(i)%em_charge - em_charge)<1e-10 ) then
        mtilde_id = i
        DEBUG2S("End: mtilde_id")
        return
     endif
  enddo

  n_mtilde = n_mtilde + 1

!write(0,*)"mid:",n_mtilde,tmp_cid  ,(action%mtilde(1)%cid == tmp_cid)
!write(0,*)"mid:",n_mtilde,tmp_did  ,(action%mtilde(1)%did == tmp_did)
!write(0,*)"mid:",n_mtilde,rho      ,(action%mtilde(1)%rho == rho  )
!write(0,*)"mid:",n_mtilde,kappa    ,(action%mtilde(1)%kappa == kappa)
!write(0,*)"mid:",n_mtilde,csw*kappa,(action%mtilde(1)%cswkappa  == csw * kappa )
!write(0,*)"mid:",n_mtilde,lambda   ,(action%mtilde(1)%lambda  == lambda )

  if(n_mtilde > size(action%mtilde)) then
     write(0,*) "n_mtilde > size(action%mtilde) :: size is",size(action%mtilde)
     stop
  endif

  action%mtilde(n_mtilde)%cid   = tmp_cid
  action%mtilde(n_mtilde)%did   = tmp_did
  action%mtilde(n_mtilde)%rho   = rho
  action%mtilde(n_mtilde)%kappa = kappa
  action%mtilde(n_mtilde)%cswkappa   = csw * kappa
  action%mtilde(n_mtilde)%h     = h
  action%mtilde(n_mtilde)%lambda= lambda
  action%mtilde(n_mtilde)%em_charge = em_charge
  action%mtilde(n_mtilde)%b     = - kappa**2 / (ONE + action%mtilde(n_mtilde)%h**2)
  mtilde_id = n_mtilde

  if (.not. breaking .and. (lambda/=ZERO .or. finv_axion/=ZERO)) then
     if (input%breaking_term /= " ") then
        open(ULIST, file = trim(input%breaking_term), action = "read", status = "old")
        read(ULIST, *) a11r, a11i, a12r, a12i, a13r, a13i, a14r, a14i
        read(ULIST, *) a21r, a21i, a22r, a22i, a23r, a23i, a24r, a24i
        read(ULIST, *) a31r, a31i, a32r, a32i, a33r, a33i, a34r, a34i
        read(ULIST, *) a41r, a41i, a42r, a42i, a43r, a43i, a44r, a44i
        breaking_term(1,1) = dcmplx(a11r, a11i)
        breaking_term(2,1) = dcmplx(a21r, a21i)
        breaking_term(3,1) = dcmplx(a31r, a31i)
        breaking_term(4,1) = dcmplx(a41r, a41i)
        breaking_term(1,2) = dcmplx(a12r, a12i)
        breaking_term(2,2) = dcmplx(a22r, a22i)
        breaking_term(3,2) = dcmplx(a32r, a32i)
        breaking_term(4,2) = dcmplx(a42r, a42i)

        breaking_term(1,3) = dcmplx(a13r, a13i)
        breaking_term(2,3) = dcmplx(a23r, a23i)
        breaking_term(3,3) = dcmplx(a33r, a33i)
        breaking_term(4,3) = dcmplx(a43r, a43i)

        breaking_term(1,4) = dcmplx(a14r, a14i)
        breaking_term(2,4) = dcmplx(a24r, a24i)
        breaking_term(3,4) = dcmplx(a34r, a34i)
        breaking_term(4,4) = dcmplx(a44r, a44i)
!! in following implementation, one needs to treat sign problem even action is CPT even!!
!!        read(ULIST, *) a11
!!        read(ULIST, *) a21r, a21i, a22
!!        read(ULIST, *) a31r, a31i, a32r, a32i, a33
!!        read(ULIST, *) a41r, a41i, a42r, a42i, a43r, a43i, a44
!!        close(ULIST)
!!        breaking_term(1,1) = a11
!!        breaking_term(2,1) = dcmplx(a21r, a21i)
!!        breaking_term(3,1) = dcmplx(a31r, a31i)
!!        breaking_term(4,1) = dcmplx(a41r, a41i)
!!
!!        breaking_term(1,2) = dconjg(breaking_term(2,1))
!!        breaking_term(2,2) = a22
!!        breaking_term(3,2) = dcmplx(a32r, a32i)
!!        breaking_term(4,2) = dcmplx(a42r, a42i)
!!
!!        breaking_term(1,3) = dconjg(breaking_term(3,1))
!!        breaking_term(2,3) = dconjg(breaking_term(3,2))
!!        breaking_term(3,3) = a33
!!        breaking_term(4,3) = dcmplx(a43r, a43i)
!!
!!        breaking_term(1,4) = dconjg(breaking_term(4,1))
!!        breaking_term(2,4) = dconjg(breaking_term(4,2))
!!        breaking_term(3,4) = dconjg(breaking_term(4,3))
!!        breaking_term(4,4) = a44
     else
        call die("mtilde_id(): breaking_term file is missing")
     endif
     breaking = .true.
  endif

  DEBUG2S("End: mtilde_id")
end

!-------------------------------------------------------------------------------
integer function clover_id(kappa, csw, lambda, nf, care_nf)   !update n_clover
!!  use module_field
  use module_action
  implicit none
  logical,intent(in) :: care_nf
  integer,intent(in) :: nf
  REAL,intent(in) :: kappa, csw, lambda
  integer :: i

  if (csw == ZERO .or. kappa == ZERO) then
     clover_id = 0
     return
  endif

  do i = 1, n_clover
     if ( clvpar(i)%csw == csw .and. &
          clvpar(i)%kappa == kappa .and. &
          clvpar(i)%lambda == lambda) then
        if (care_nf) clvpar(i)%nf = clvpar(i)%nf + nf
        clover_id = i
        return
     endif
  enddo

  n_clover = n_clover + 1
!write(0,*)"clover_id:",csw, kappa, lambda

  if (n_clover > 30) then
     write(0,*)"n_clover > 30 :: allocatable clover is < or = 30"
     stop
  endif

  clvpar(n_clover)%csw   = csw
  clvpar(n_clover)%kappa = kappa
  clvpar(n_clover)%cswkappa = csw * kappa
  clvpar(n_clover)%lambda = lambda
  clvpar(n_clover)%lambdakappa = lambda * kappa
  clvpar(n_clover)%nf    = nf
  clover_id = n_clover

end

!-------------------------------------------------------------------------------
integer function dslash_id(n)   !update n_dslash_id
  use module_action
  implicit none
  integer,intent(in) :: n

  n_dslash = 1
  dslash_id = 1

end

!!!-------------------------------------------------------------------------------
!!integer function action_id(c)   !update n_dslash
!!  use module_action
!!  implicit none
!!  character(len=*),intent(in) :: c
!!
!!action_id = 4
!!
!!end
!-------------------------------------------------------------------------------
integer function force_id(type, mid)   !update n_dslash_id
  use module_action
  implicit none
  integer, save :: fid = 3, lasttype=-1, lastmid=-1
  integer, intent(in) :: type, mid

  if (lasttype /= type ) then
     fid = fid + 1
  elseif (type <= 4 .or. (lastmid/=mid)) then
     fid = fid + 1
  endif
  lasttype = type
  lastmid  = mid
  force_id = fid
end

!-------------------------------------------------------------------------------
subroutine fermi_id(kp, rh1, rh2, csw, h, lambda, nf, em_charge, type, filter_type, nth, npf, mts, i,j) ! update n_pfermi
  use module_action
  use module_input
  use module_vol
  use module_switches, only : switches
  implicit none
  integer, intent(in) :: nf, type, filter_type, nth, npf, mts, i, j
  REAL, intent(in) :: kp, rh1, rh2, csw, h, lambda, em_charge
  integer, external :: force_id, mtilde_id
  integer :: ipf, tmp_aid, tmp_fid, tmp_mid1, tmp_mid2
  character (len=256) :: msg

  if (kp == ZERO) return
  if (nth == 1) then
     ! Two-flavour case
     if (filter_type == F_POLY) then
        ! Initalize a plain pseudofermion for PFHMC
        tmp_mid1 = mtilde_id(kp, csw, ZERO, h, lambda, nf, em_charge)
        tmp_mid2 = 0
     elseif (filter_type == F_HASEN .or. filter_type == F_NONE) then
        ! Initialize a Hasenbusch-like pseudofermion
        if (input%hmc_hkappa /= 0) then
           if (rh1 == rh2 ) return
           tmp_mid1 = mtilde_id(rh1,csw,ZERO, h, lambda, nf, em_charge)
           tmp_mid2 = mtilde_id(rh2,csw,ZERO, h, lambda, nf, em_charge)
        else
           tmp_mid1 = mtilde_id(kp, csw, rh1, h, lambda, nf, em_charge)
           if (rh1 == rh2 ) then
              tmp_mid2 = 0
           else
              tmp_mid2 = mtilde_id(kp, csw, rh2, h, lambda, nf, em_charge)
           endif
        endif
     else
        ! ERROR: Bad filter type
        write(msg, '(a, i1)') "Unknown filter_type: ", filter_type
        call die(trim(msg))
     endif
  else
     ! Single-flavour case
     tmp_mid1 = mtilde_id(kp, csw,ZERO, h, lambda, nf, em_charge)
     tmp_mid2 = 0
  endif

  tmp_aid = 4
  tmp_fid = force_id(type, tmp_mid1)

  n_pfermi = n_pfermi + 1
  num_mpf = num_mpf + npf

  allocate(action%pfermi(n_pfermi)%mpf(npf))
  do ipf = 1, npf
     allocate(action%pfermi(n_pfermi)%mpf(ipf)%sc(4,3,volh))
  enddo

  if(n_pfermi > size(action%pfermi)) then
     write(msg,"(a, i2)") "n_pfermi > size(action%pfermi) :: size is " &
          , size(action%pfermi)
     call die(trim(msg))
  endif

  action%pfermi(n_pfermi)%pid   = n_pfermi
  action%pfermi(n_pfermi)%aid   = tmp_aid
  action%pfermi(n_pfermi)%fid   = tmp_fid
  action%pfermi(n_pfermi)%mid1  = tmp_mid1
  action%pfermi(n_pfermi)%mid2  = tmp_mid2
  action%pfermi(n_pfermi)%type  = type
  action%pfermi(n_pfermi)%nth   = nth
  action%pfermi(n_pfermi)%npf   = npf
  action%pfermi(n_pfermi)%mts   = mts

  if (mts == 0) then
     if (nf == 2) then
        write(msg, '(a,i1,i1,a)')"hmc_dsf_k",i,j," must be > 0"
     else
        write(msg, '(a,i1,a)')"hmc_dsfr_k",i," must be > 0"
     endif
     call die(trim(msg))
  endif

  if (nth==1) then
     action%pfermi(n_pfermi)%rid = -999
  else
     select case (nth)
        case(2);action%pfermi(n_pfermi)%rid = 1
        case(4);action%pfermi(n_pfermi)%rid = 2
        case(8);action%pfermi(n_pfermi)%rid = 3
        case default; call die("wrong rhmc")
     end select
  endif
  action%pfermi(n_pfermi)%sf = 0

  ! Set polyid to a sentinel value
  ! -- will be initialized by poly_id() if needed
  action%pfermi(n_pfermi)%polyid = -999

  DEBUG2S("End: fermi_id")

end subroutine fermi_id

!-------------------------------------------------------------------------------
subroutine poly_id(pf, poly1, poly2, mu, nu)
  ! Initialize the polynomial P_1/P_2
  ! where P_1 has order poly1, P_2 order poly2
  ! * If poly1 = 0, take the poly to be P_2 K
  ! * If poly2 = 0, take the poly to be P_1

  use module_action
  use module_poly
  use module_input
  implicit none

  type(type_pfermi)    :: pf
  integer, intent(in)  :: poly1, poly2
  REAL, intent(in)     :: mu, nu

  integer              :: n, i, ptype
  REAL                 :: c
  COMPLEX, allocatable :: z_k(:)

  if (poly1 == 0 .and. poly2 == 0) then
     return
  endif

  DEBUG2S("Begin: poly_id()")

  ! Increment external poly id counter
  n_poly_id = n_poly_id + 1

  ! Generate required polynomial
  if (pf%type == EO_NORMAL) then
     ! Standard PFHMC
     if (mod(poly1,2) == 1 .or. mod(poly2,2) == 1) then
        call die("poly_id(): Odd polynomial filters not supported.")
     elseif (poly1 < 0 .or. poly2 < 0) then
        call die("poly_id(): Negative polynomial order.")
     endif

     ! Create the polynomial
     if (poly1 == 0) then
        if (poly2 == 0) then
           call die("poly_id(): Can't initialize a 0th order polynomial")
        else
           ! Just poly2 - do the special P_2 K case
           n = poly2 + 1
           allocate(z_k(n))
           ! Construct P_2 K
           call chebyshev_k(poly2, mu, nu, c, z_k)
           ptype = P_CORRECTION
        endif
     else
        if (poly2 == 0) then
           ! Just poly1 - simple as pie
           n = poly1
           allocate(z_k(n))
           ! Construct P_1
           call chebyshev(poly1, mu, nu, c, z_k)
           ptype = P_NORMAL
        else
           ! Both poly1 and poly2
           if (poly1 < poly2) then
              call die("poly_id(): numerator poly order < denominator.")
           endif
           n = poly1 - poly2
           allocate(z_k(n))
           ! Construct P_1/P_2
           call chebyshev_rat(poly1, poly2, mu, nu, c, z_k)
           ptype = P_NORMAL
        endif
     endif

  else if (pf%type == EO_RATIONAL) then
     ! PFRHMC - construct relevant polynomial filter ~ 1/sqrt(K)
     n = poly1
     allocate(z_k(n))
     call cheby_sqrt(poly1, c, z_k)
     ptype = P_RATIONAL

  else
     call die("poly_id(): unsupported pf type")
  endif

  ! Allocate storage for z_k, knowing the order n
  nullify(poly(n_poly_id)%z_k)
  allocate(poly(n_poly_id)%z_k(n))

  ! Assign the resulting polynomial (c, z_n) to 'poly(pid)'
  poly(n_poly_id)%type = ptype
  poly(n_poly_id)%n = n
  poly(n_poly_id)%c = c
  do i = 1, n
     poly(n_poly_id)%z_k(i) = z_k(i)
  enddo

  ! Have the fermi action point to this poly
  pf%polyid = n_poly_id

  ! As this is a polynomial filter (no RHMC), set 'rid' to the sentinel value
  pf%rid = -999

  deallocate(z_k)

  DEBUG2S("End: poly_id()")

end subroutine poly_id

!-------------------------------------------------------------------------------
subroutine poly_id_from_file(pf, ptype, file)
  ! Initialize a polynomial for pseudofermion `pf' from file

  use module_action
  use module_poly
  use module_input
  implicit none

  type(type_pfermi)    :: pf
  integer, intent(in)  :: ptype
  FILENAME             :: file

  integer              :: ioerr

  DEBUG2S("Start: poly_id_from_file")

  ! Increment external poly id counter
  n_poly_id = n_poly_id + 1

  call read_poly(n_poly_id, file, ioerr)
  poly(n_poly_id)%type = ptype

  if (ioerr /= 0) then
     call die("Failed to read polynomial for pf.")
  endif

  ! Have the fermi action point to this poly
  pf%polyid = n_poly_id
  ! As this is a polynomial filter (no RHMC),
  ! set 'rid' to the sentinel value
  pf%rid = -999

  DEBUG2S("End: poly_id_from_file")

end subroutine poly_id_from_file

!-------------------------------------------------------------------------------
subroutine construct_combined_poly(pf, npoly, ptype)
  ! Construct a new polynomial as the product of the last `npoly' ones
  !
  ! If the ptype is P_CORRECTION, we add a zero root to construct
  ! a correction term of the form 'P(K)K', suitable for double-flavour
  ! polynomial correction terms.

  use module_action
  use module_poly
  use module_input
  implicit none

  type(type_pfermi)    :: pf
  integer, intent(in)  :: npoly
  integer, intent(in)  :: ptype

  integer :: n_comb, n(npoly), i, j
  REAL :: c
  COMPLEX, allocatable :: z_k(:)

  ! Increment external poly id counter
  n_poly_id = n_poly_id + 1

  ! Calculate parameters for combined poly
  n = poly(n_poly_id-npoly : n_poly_id-1)%n
  n_comb = sum(n)
  c = product(poly(n_poly_id-npoly : n_poly_id-1)%c)

  ! In the correction term case, we have an extra zero root
  if (ptype == P_CORRECTION) n_comb = n_comb + 1

  ! Sort combined set of roots s.t. conj(z_i) = z_(n-i+1)
  allocate(z_k(n_comb))
  j = 1
  do i=1,npoly
     z_k(j:j+n(i)/2-1) = poly(n_poly_id - npoly - 1 + i)%z_k(:n(i)/2)
     j = j + n(i)/2
  enddo

  ! Insert zero root here for correction term
  if (ptype == P_CORRECTION) then
     z_k(j) = 0
     j = j + 1
  endif

  do i=npoly,1,-1
     z_k(j:j+n(i)/2-1) = poly(n_poly_id - npoly - 1 + i)%z_k(n(i)/2+1:)
     j = j + n(i)/2
  enddo

  ! Put constructed polynomial into main structure
  nullify(poly(n_poly_id)%z_k)
  allocate(poly(n_poly_id)%z_k(n_comb))

  poly(n_poly_id)%n = n_comb
  poly(n_poly_id)%c = c
  poly(n_poly_id)%z_k = z_k
  poly(n_poly_id)%type = ptype

  ! Have the fermi action point to this poly
  pf%polyid = n_poly_id

  deallocate(z_k)

end subroutine construct_combined_poly

!-------------------------------------------------------------------------------
subroutine trunc_id(pf, low, high)
  ! Initialize the truncated ratapp metadata
  !
  ! low = lower bound = LARGER shifts
  ! high = higher bound = SMALLER shifts
  !
  ! low = 0 => include ALL larger shifts
  ! high = 0 => include ALL smaller shifts
  !
  ! However, the size of the ratapp will only be known
  ! after calling init_rhmc() later on, when we ACTUALLY create the ratapp.
  !
  ! BQCD orders the shifts from smallest to largest, so a reversal
  ! must be taken into account.

  use module_action
  use module_truncrat, only: truncrat, n_trunc_id
  implicit none

  type(type_pfermi)    :: pf
  integer, intent(in)  :: low, high

  integer :: n_low, n_high

  if (low == 0 .and. high == 0) then
     return
  endif

  n_low = low
  n_high = high

  if (n_low == 0) then
     ! Intepret 0 as missing lower bound -> include all larger shifts
     n_low = 1
  endif

  ! If, after correcting for missing bounds, high < low, abort!
  ! But if n_high = 0, we can't be sure yet.
  if (n_high < n_low .and. n_high /= 0) then
     call die("trunc_id(): upper bound < lower bound")
  endif

  ! Increment external trunc_id counter
  n_trunc_id = n_trunc_id + 1

  truncrat(n_trunc_id)%n_low = n_low
  truncrat(n_trunc_id)%n_high = n_high
  truncrat(n_trunc_id)%rid = pf%rid

  pf%truncid = n_trunc_id

end subroutine trunc_id

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