!===============================================================================
!
! determinant.F90
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 2011 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 module_det
  implicit none
#include "desc.h"
  integer, save :: descM4(DLEN_), descV4(DLEN_), descM3(DLEN_)
  integer, save :: descS4(DLEN_), descS3(DLEN_)
  logical, save :: blacs_ready=.false.

  integer, save :: dirac_gvol,  dirac_lvol,  dirac_svol, locpn_dirac, locqn_dirac
  integer, save :: dirac_gvol3, dirac_lvol3, dirac_svol3, locpn_dirac3, locqn_dirac3
  integer, save :: myprow_sym, mypcol_sym
  integer, save :: sym_np=1

  COMPLEX, parameter :: zzero =  ( 0.0d0, 0.0d0)
  COMPLEX, parameter :: zpone =  ( 1.0d0, 0.0d0)
  COMPLEX, parameter :: zmone =  (-1.0d0, 0.0d0)

  logical, pointer, save :: fileopen(:)
  character(len = 255) :: filename

end module
!-------------------------------------------------------------------------------
subroutine chemical_determinant(traj)
  use module_input
  use module_action
  use typedef_hmc
  use module_input
  use module_function_decl
  use module_vol
  use module_lattice
  use module_det
  use module_counter
  implicit none

  integer, intent(in)  :: traj
  integer :: fid, mid, i, j, k, nev
  COMPLEX :: det, det1_det3, det2, det4, det0, detw, tr1, tr2, tr3, t(0:10, 0:3), ctmp, ctmp1
  COMPLEX :: tr4, tr5, tr6, tr7, tr8
  REAL    :: ex, ph, wexpre, wexpim, wexpex, wexpph
  COMPLEX :: fac1, fac2
  COMPLEX, allocatable :: mat(:,:), evals(:)
  COMPLEX, dimension(:, :), allocatable :: tmp1, tmp2, tmp3, tmp4, tmp5
  COMPLEX, dimension(:, :,:,:), allocatable :: d222,d444, h0 ,h1, k0, k1, k2, t4_0, t4_1, t4_2, t4_3, t4_4
  COMPLEX, dimension(:, :), allocatable :: d412,d234
  COMPLEX, external :: trace
  logical :: action_mtilde(n_mtilde)

  TIMING_START(timing_bin_chemical_determinant)
#ifdef FPCOLL
call start_collection("chemical_determinant")
#endif
!!call read_phmc_config()

  if (lt /= nt) call die("det_test : lt /= nt is not supported")

  if (.not. associated(fileopen)) then
     allocate(fileopen(n_mtilde))
     fileopen = .false.
     action_mtilde = .false.
     do mid = 1, n_mtilde
        do i =1, 6
           if (action%mtilde(mid)%kappa == input%nf2_kappa(i) .and. &
               action%mtilde(mid)%rho   == ZERO ) then
              action_mtilde(mid) = .true.
              cycle
           endif
        enddo
        do i =1, 6
           if (action%mtilde(mid)%kappa == input%nf1_kappa(i) .and. &
               action%mtilde(mid)%rho   == ZERO ) then
              action_mtilde(mid) = .true.
              cycle
           endif
        enddo
     enddo
  endif

  call init_imp_all(.true.)
  call init_blacs()
#ifdef CUDA
#ifdef MAGMA
  call init_magma(dirac_svol3, dirac_svol3, i);  if (i/=0) call die("init_magma failed")
#else
  call init_cublas(dirac_svol3, dirac_svol3, i); if (i/=0) call die("init_cublas failed")
#endif
#endif

  fac1 = exp(cmplx( chemi, chemi_i)*dble(nt))
  fac2 = exp(cmplx(-chemi,-chemi_i)*dble(nt))

do mid = 1, n_mtilde
  if (.not. action_mtilde(mid))cycle

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !! check, matrix dump, determinat
!!  call checkmat(mid)
!!  call qcd_matrix_dump(mid)
!!  det=ZERO
!!  nev=4
!!  allocate(mat(12*vol, 12*volume), evals(nev))
!!  call make_dirac_op(mat, mid,  fac1,  fac2)
!!  call eig_qcdmat(mat, nev, evals, 'SM')
!!  call eig_qcdmat(mat, nev, evals, 'LM')
!!  call matrix_inv(mat, 12*vol, det)
!!  deallocate(mat, evals)
!!  write(*,*)"det=",det
!!  stop
  if (input%measure_chemical == -1)call det_dirac(mid, det)
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  TIMING_START(timing_bin_chemidet_dirac3)
#ifdef FPCOLL
call start_collection("det_hdirac")
#endif

  allocate(d222(dirac_svol3, dirac_svol3, 2, 2))
  allocate(d444(dirac_svol3, dirac_svol3, 2, 2))
  allocate(d412(dirac_svol3, dirac_svol3))
  allocate(d234(dirac_svol3, dirac_svol3))
  call d_inv_d(d222,d444,d412,d234, dirac_svol3, nt, mid, det1_det3)

  call inv_schurcomp2(d222, dirac_svol3, det2)
  call inv_schurcomp2(d444, dirac_svol3, det4)

  det0=cmplx( real(det1_det3+det2+det4), &
             aimag(det1_det3+det2+det4)-dble(nint(aimag(det1_det3+det2+det4)/(TWO*PI)))*TWO*PI)

  allocate(tmp1(dirac_svol3, dirac_svol3))
  allocate(tmp2(dirac_svol3, dirac_svol3))
  allocate(h0(dirac_svol3, dirac_svol3, 2, 2))
  allocate(h1(dirac_svol3, dirac_svol3, 2, 2))
  call zgemm_common('N','C',zpone, d222(1,1,2,2), d412, zzero, tmp1, dirac_svol3)
  call zgemm_common('N','N',zpone, d412,          tmp1, zzero, tmp2, dirac_svol3)

  call zgemm_common('N','N',zpone, d444(1,1,1,1), tmp2, zzero, h0(1,1,1,1), dirac_svol3)
  call zgemm_common('C','N',zpone, d444(1,1,1,2), tmp2, zzero, h0(1,1,2,1), dirac_svol3)

  call zgemm_common('N','N',zpone, d222(1,1,1,1), d234, zzero, tmp1, dirac_svol3)
  call zgemm_common('C','N',zpone, d234,          tmp1, zzero, tmp2, dirac_svol3)

  call zgemm_common('N','N',zpone, d444(1,1,1,2), tmp2, zzero, h0(1,1,1,2), dirac_svol3)
  call zgemm_common('N','N',zpone, d444(1,1,2,2), tmp2, zzero, h0(1,1,2,2), dirac_svol3)


  call zgemm_common('C','N',zpone, d222(1,1,1,2), d234, zzero, tmp1, dirac_svol3)
  call zgemm_common('N','N',zpone, d412,          tmp1, zzero, tmp2, dirac_svol3)

  call zgemm_common('N','N',zpone, d444(1,1,1,1), tmp2, zzero, h1(1,1,1,2), dirac_svol3)
  call zgemm_common('C','N',zpone, d444(1,1,1,2), tmp2, zzero, h1(1,1,2,2), dirac_svol3)

  call zgemm_common('N','C',zpone, d222(1,1,1,2), d412, zzero, tmp1, dirac_svol3)
  call zgemm_common('C','N',zpone, d234,          tmp1, zzero, tmp2, dirac_svol3)

  call zgemm_common('N','N',zpone, d444(1,1,1,2), tmp2, zzero, h1(1,1,1,1), dirac_svol3)
  call zgemm_common('N','N',zpone, d444(1,1,2,2), tmp2, zzero, h1(1,1,2,1), dirac_svol3)


  !$omp parallel do private (i)
  do j = 1, dirac_svol3
     do i = 1, dirac_svol3
        tmp1(i,j) = ZERO
     enddo
  enddo

  if (myprow_sym == mypcol_sym) then
     !$omp parallel do
     do i=1, dirac_svol3
        tmp1(i,i) = ONE
     enddo
  endif


  deallocate(d222,d444,d412,d234)
  allocate(k0(dirac_svol3, dirac_svol3, 2, 2))
  allocate(k1(dirac_svol3, dirac_svol3, 2, 2))
  allocate(k2(dirac_svol3, dirac_svol3, 2, 2))

  !$omp parallel do private (i)
  do j = 1, dirac_svol3
     do i = 1, dirac_svol3
        k0(i,j,1,1)=tmp1(i,j)-h0(i,j,1,1)-fac2*h1(i,j,1,1)
        k1(i,j,1,1)=                     +fac2*h1(i,j,1,1) !! dK  =- e^mu Hp + e^{-mu} Hm
        k2(i,j,1,1)=                     -fac2*h1(i,j,1,1) !! ddK =- e^mu Hp - e^{-mu} Hm
        k0(i,j,2,1)=         -h0(i,j,2,1)-fac2*h1(i,j,2,1)
        k1(i,j,2,1)=                     +fac2*h1(i,j,2,1) !! dK  =- e^mu Hp + e^{-mu} Hm
        k2(i,j,2,1)=                     -fac2*h1(i,j,2,1) !! ddK =- e^mu Hp - e^{-mu} Hm
        k0(i,j,1,2)=         -h0(i,j,1,2)-fac1*h1(i,j,1,2)
        k1(i,j,1,2)=                     -fac1*h1(i,j,1,2) !! dK  =- e^mu Hp + e^{-mu} Hm
        k2(i,j,1,2)=                     -fac1*h1(i,j,1,2) !! ddK =- e^mu Hp - e^{-mu} Hm
        k0(i,j,2,2)=tmp1(i,j)-h0(i,j,2,2)-fac1*h1(i,j,2,2)
        k1(i,j,2,2)=                     -fac1*h1(i,j,2,2) !! dK  =- e^mu Hp + e^{-mu} Hm
        k2(i,j,2,2)=                     -fac1*h1(i,j,2,2) !! ddK =- e^mu Hp - e^{-mu} Hm
     enddo
  enddo


  call inv_schurcomp4(k0, dirac_svol3, detw)

  call      stderr2("chemical_determinant          : log(|det|), arg(det)")
  call stderr2_real("chemical_determinant detW     :",2,detw)
  call stderr2_real("chemical_determinant detA*detW:",2,det0+detw)
  call stderr2_real("chemical_determinant detD     :",2,det)


#ifdef FPCOLL
call stop_collection("det_hdirac")
#endif
  TIMING_STOP(timing_bin_chemidet_dirac3)

  TIMING_START(timing_bin_chemidet_moment)
#ifdef FPCOLL
call start_collection("cal_moments")
#endif

  allocate(t4_0(dirac_svol3, dirac_svol3, 2, 2))
  allocate(t4_1(dirac_svol3, dirac_svol3, 2, 2))
  allocate(t4_2(dirac_svol3, dirac_svol3, 2, 2))
  allocate(t4_3(dirac_svol3, dirac_svol3, 2, 2))
  allocate(t4_4(dirac_svol3, dirac_svol3, 2, 2))


  call zgemm22(k0,   k1,   t4_0, dirac_svol3, .true.)  !! t4_0=K^-1 dK =A
  tr1=trace(t4_0(1,1,1,1), dirac_svol3)&
     +trace(t4_0(1,1,2,2), dirac_svol3)
  call zgemm22(k0,   k2,   t4_1, dirac_svol3, .true.)  !! t4_1=K^-1 ddK=B
  tr3=trace(t4_1(1,1,1,1), dirac_svol3)&
     +trace(t4_1(1,1,2,2), dirac_svol3)
  call zgemm22(t4_0, t4_0, t4_2, dirac_svol3, .true.)  !! t4_2=(K^-1 dK)^2=A^2
  tr2=trace(t4_2(1,1,1,1), dirac_svol3)&
     +trace(t4_2(1,1,2,2), dirac_svol3)

  call zgemm22(t4_2, t4_0, t4_3, dirac_svol3, .true.)  !! t4_3=A^3
  tr4=trace(t4_3(1,1,1,1), dirac_svol3)&
     +trace(t4_3(1,1,2,2), dirac_svol3)

  call zgemm22(t4_3, t4_0, t4_4, dirac_svol3, .false.) !! A^4
  tr6=trace(t4_4(1,1,1,1), dirac_svol3)&
     +trace(t4_4(1,1,2,2), dirac_svol3)

  call zgemm22(t4_0, t4_1, t4_4, dirac_svol3, .false.) !! AB
  tr5=trace(t4_4(1,1,1,1), dirac_svol3)&
     +trace(t4_4(1,1,2,2), dirac_svol3)

  call zgemm22(t4_2, t4_1, t4_4, dirac_svol3, .false.) !! AAB
  tr7=trace(t4_4(1,1,1,1), dirac_svol3)&
     +trace(t4_4(1,1,2,2), dirac_svol3)

  call zgemm22(t4_1, t4_1, t4_4, dirac_svol3, .false.) !! BB
  tr8=trace(t4_4(1,1,1,1), dirac_svol3)&
     +trace(t4_4(1,1,2,2), dirac_svol3)

  deallocate(k0,k1,k2)

  !!
  !! calculate T(q)
  !!
  t(0,1)=trace(h0(1,1,1,1), dirac_svol3) + trace(h0(1,1,2,2), dirac_svol3)

  call zgemm22(h0, h0, t4_1, dirac_svol3, .true.)  !! t4_1= H0^2      ---- > keep for H0^3
  call matrix_mul(tmp1, h1(1,1,1,2), t4_1(1,1,2,1), dirac_svol3)  !!  H+ H0 H0
  call matrix_mul(tmp2, h1(1,1,2,2), t4_1(1,1,2,2), dirac_svol3)  !! 
  t(1,3)= trace(tmp1, dirac_svol3) + trace(tmp2, dirac_svol3)
  call matrix_mul(t4_2(1,1,1,1), h1(1,1,1,2), h1(1,1,2,1), dirac_svol3)  !! t4_2= H+ H-        =======> keep for t(1,3) and  H+ H- H0
  call matrix_mul(t4_2(1,1,2,1), h1(1,1,2,2), h1(1,1,2,1), dirac_svol3)  !! t4_2= H+ H-        =======> keep for t(1,3) and  H+ H- H0
  call matrix_mul(tmp1, h1(1,1,1,2), t4_2(1,1,2,1), dirac_svol3)  !! tmp3= H+ H+ H-
  t(1,3)=t(1,3)+trace(tmp1, dirac_svol3)

  t(0,2)=(trace(t4_1(1,1,1,1), dirac_svol3)+trace(t4_1(1,1,2,2), dirac_svol3))/TWO + trace(t4_2(1,1,1,1), dirac_svol3)
  call matrix_mul(tmp1, t4_2(1,1,1,1), h0(1,1,1,1), dirac_svol3)  !! tmp1= (H+ H- H0)_{++}
  call matrix_mul(tmp2, t4_2(1,1,2,1), h0(1,1,1,2), dirac_svol3)  !! tmp2= (H+ H- H0)_{--}
  t(0,3)= trace(tmp1, dirac_svol3) + trace(tmp2, dirac_svol3)
  call zgemm22(h0, t4_1, t4_3, dirac_svol3, .false.)  !! t4_3= H0^3
  t(0,3)=t(0,3)+(trace(t4_3(1,1,1,1), dirac_svol3)+trace(t4_3(1,1,2,2), dirac_svol3))/THREE

  call matrix_mul(t4_3(1,1,1,1), h1(1,1,1,2),   h0(1,1,2,1), dirac_svol3)  !! t4_3= H+ H0      =======> keep for t(1,2) and t(1,3)
  call matrix_mul(t4_3(1,1,1,2), h1(1,1,1,2),   h0(1,1,2,2), dirac_svol3)  !! t4_3= H+ H0      =======> keep for t(1,2) and t(1,3)
!!  call matrix_mul(t4_3(1,1,2,1), h1(1,1,2,2),   h0(1,1,2,1), dirac_svol3)  !! t4_3= H+ H0      =======> keep for t(1,2) and t(1,3)
  call matrix_mul(t4_3(1,1,2,2), h1(1,1,2,2),   h0(1,1,2,2), dirac_svol3)  !! t4_3= H+ H0      =======> keep for t(1,2) and t(1,3)
  call matrix_mul(tmp1, h1(1,1,1,1), t4_3(1,1,1,1), dirac_svol3)  !! H- H+ H0
  call matrix_mul(tmp2, h1(1,1,2,1), t4_3(1,1,1,2), dirac_svol3)  !! H- H+ H0
  t(0,3)=t(0,3) + trace(tmp1, dirac_svol3) + trace(tmp2, dirac_svol3)

  t(1,1)=trace(h1(1,1,2,2), dirac_svol3)
  t(1,2)=trace(t4_3(1,1,1,1), dirac_svol3)+trace(t4_3(1,1,2,2), dirac_svol3)

  deallocate(t4_0,t4_1,t4_2,t4_3,t4_4)
  allocate(tmp3(dirac_svol3, dirac_svol3))
  allocate(tmp4(dirac_svol3, dirac_svol3))
  allocate(tmp5(dirac_svol3, dirac_svol3))

  call matrix_copy(tmp1, h1(1,1,2,2), dirac_svol3)
  do i = 2, 10
     call matrix_mul(tmp2, h1(1,1,2,2), tmp1, dirac_svol3)
     call matrix_mul(tmp3, h1(1,1,1,2), tmp1, dirac_svol3)
     call matrix_mul(tmp4, tmp2, h0(1,1,2,2), dirac_svol3)
     call matrix_mul(tmp5, tmp3, h0(1,1,2,1), dirac_svol3)

     t(i,1)=trace(tmp2, dirac_svol3)/dble(i)
     t(i,2)=trace(tmp4, dirac_svol3)+trace(tmp5, dirac_svol3)
     t(i,3)=ZERO
     if( i < 10 ) then
        call matrix_copy(tmp1, tmp2, dirac_svol3)
     endif
  enddo

  do i = 0, 10
     t(i, 0) = t(i, 1) + t(i, 2) + t(i, 3)
  enddo



  !
  ! calculate detw by winding number expansion
  !
  ex=t(0,0)
  ph=ZERO
  do i=1,10
!!     ex=ex+2*cosh(chemi*dble(nt*i))* real(t(i,0))
!!     ph=ph+2*sinh(chemi*dble(nt*i))*aimag(t(i,0))
       ctmp = cmplx(chemi*dble(nt*i), chemi_i*dble(nt*i))
       ctmp1= exp(ctmp)*t(i,0) + exp(-ctmp)* dconjg(t(i,0))
     ex=ex+ real(ctmp1)
     ph=ph+aimag(ctmp1) 
  enddo
  wexpre=exp(-ex)*cos(-ph)
  wexpim=exp(-ex)*sin(-ph)
  wexpex=exp(-ex)
  wexpph=-ph

  if (.not. fileopen(mid)) then
     if (len(trim(input%measure_chemical_file)) > 0) then
        write(filename, "(a,a,i1)" ) input%measure_chemical_file,".mid",mid
     else
        write(filename, "(a, i1, a, i6.6)" ) "dethist.mid", mid, ".",counter%job
     endif
     if (my_pe()==0) open(50, file = trim(filename), action = "write")
     fileopen(mid) = .true.
  endif
  ctmp=detw
  detw=dcmplx( cos(aimag(ctmp)), sin(aimag(ctmp)) )
  detw=detw*exp(real(ctmp))
  if (my_pe()==0) then
  write(50,'(I9,1x,20E20.12)') traj, real(detw),aimag(detw), real(tr1),aimag(tr1), real(tr2),aimag(tr2), real(tr3),aimag(tr3), &
                                                            real(tr4),aimag(tr4), real(tr5),aimag(tr5), real(tr6),aimag(tr6), &
                                                            real(tr7),aimag(tr7), real(tr8),aimag(tr8), &
                                                            real(det0), aimag(det0)
!!                                                            real(det1_det3+det2+det4), &
!!                                                            aimag(det1_det3+det2+det4)-dble(nint(aimag(det1_det3+det2+det4)/(TWO*PI)))*TWO*PI
  write(50,'(I9,1x,4E20.12)') traj, wexpre, wexpim, wexpex, wexpph
  do i = 0, 10
  write(50,'(I9,1x,I3,8E20.12)') traj, i, real(t(i,0)), aimag(t(i,0)), real(t(i,1)),aimag(t(i,1)), real(t(i,2)),aimag(t(i,2)),real(t(i,3)),aimag(t(i,3))
  enddo
  endif

  deallocate(tmp1,tmp2,tmp3,tmp4,tmp5)
  deallocate(h0,h1)

#ifdef FPCOLL
call stop_collection("cal_moments")
#endif
  TIMING_STOP(timing_bin_chemidet_moment)
#ifdef FPCOLL
call stop_collection("chemical_determinant")
#endif
enddo

  TIMING_STOP(timing_bin_chemical_determinant)
end

!-------------------------------------------------------------------------------
subroutine init_blacs()
  use module_det
  use module_function_decl
  use module_lattice
  use module_vol
  implicit none
  integer :: icontext, nprow,npcol, myprow,mypcol, info

#ifdef SCALAPACK
  integer, external :: numroc
#endif

  if ( blacs_ready ) return

  nprow = num_pes()
  npcol = 1
  dirac_gvol = 12*volume
  dirac_lvol = 12*volume/nprow
  dirac_gvol3= dirac_gvol / lt / 2 ! "/2" by spin reduction
  dirac_lvol3= dirac_lvol / lt / 2 ! "/2" by spin reduction

  if (num_pes() > 1 ) then
#ifdef SCALAPACK
     call blacs_get(-1,0,icontext)
     call blacs_gridinit( icontext, 'Col-major', nprow,npcol)
     !
     !                     ful          ful          blk          ful                          blk
     call descinit(descM4, dirac_gvol , dirac_gvol , dirac_lvol , dirac_gvol , 0, 0, icontext, dirac_lvol , info) ! mat
     call descinit(descV4, dirac_gvol ,          1 , dirac_lvol ,          1 , 0, 0, icontext, dirac_lvol , info) ! vec
     call descinit(descM3, dirac_gvol3, dirac_gvol3, dirac_lvol3, dirac_gvol3, 0, 0, icontext, dirac_lvol3, info) ! mat
     !
     sym_np= sqrt( dble(nprow) )
     if ( sym_np**2 == num_pes() ) then
        dirac_svol = dirac_gvol / sym_np
        dirac_svol3= dirac_svol / lt / 2 ! "/2" by spin reduction
        call blacs_get(-1,0,icontext)
        call blacs_gridinit( icontext, 'Col-major', sym_np, sym_np)
        call blacs_gridinfo( icontext, sym_np, sym_np, myprow, mypcol )
        myprow_sym = myprow
        mypcol_sym = mypcol
        !                     ful          ful          blk          blk                          blk
        call descinit(descS4, dirac_gvol , dirac_gvol , dirac_svol , dirac_svol , 0, 0, icontext, dirac_svol , info) ! mat
        call descinit(descS3, dirac_gvol3, dirac_gvol3, dirac_svol3, dirac_svol3, 0, 0, icontext, dirac_svol3, info) ! mat
        locpn_dirac  = numroc(dirac_gvol, dirac_svol, myprow,0, sym_np)
        locqn_dirac  = numroc(dirac_gvol, dirac_svol, mypcol,0, sym_np)
        locpn_dirac3 = numroc(dirac_gvol3, dirac_svol3, myprow,0, sym_np)
        locqn_dirac3 = numroc(dirac_gvol3, dirac_svol3, mypcol,0, sym_np)
     else
        call die("init_blacs: sqrt of number PEs is not integer")
     endif
#endif
  else
     dirac_svol = dirac_gvol
     dirac_svol3= dirac_gvol3
  endif

  blacs_ready = .true.

end

!-------------------------------------------------------------------------------
COMPLEX function trace(mat, n)
  use module_det
  use module_function_decl
  implicit none
#ifndef NONMPI
  include 'mpif.h'
#endif
  integer, intent(in) :: n
  COMPLEX, intent(in) :: mat(n, n)
  COMPLEX :: diag(sym_np)
  integer :: i, ierror

  DEBUG2S("Start: function trace")
  trace=ZERO
  do i = 1, n
     trace = trace + mat(i,i)
  enddo
#ifndef NONMPI
  if ( num_pes() > 1 ) then
     do i = 0, sym_np -1
        diag(i+1) = trace
        call mpi_bcast(diag(i+1), 1, MPI_DOUBLE_COMPLEX, i+i*sym_np, MPI_COMM_WORLD, ierror)
     enddo
     trace = diag(1)
     do i = 2, sym_np
        trace = trace + diag(i)
     enddo
  endif
#endif
  DEBUG2S("End: function trace")
end

!-------------------------------------------------------------------------------
COMPLEX function diag_prod(mat, n, ipiv, m)
  use module_det
  use module_function_decl
  implicit none
#ifndef NONMPI
  include 'mpif.h'
#endif
  integer, intent(in) :: n, m, ipiv(m)
  COMPLEX, intent(in) :: mat(n, n)
  COMPLEX :: diag(sym_np)
  integer :: i, ierror, count

  DEBUG2S("Start: function diag_prod")

  diag_prod = ZERO
  count = 0
  do i = 1, n
     diag_prod = diag_prod + dcmplx( log(abs(mat(i,i))), atan2(aimag(mat(i,i)),real(mat(i,i))) )
     if(i +n*int(my_pe()/sym_np) /= ipiv(i)) count = count + 1
  enddo
  if (mod(count, 2) == 1) diag_prod = diag_prod + dcmplx(ZERO,PI)

#ifndef NONMPI
  if ( num_pes() > 1 ) then
     do i = 0, sym_np -1
        diag(i+1) = diag_prod
        call mpi_bcast(diag(i+1), 1, MPI_DOUBLE_COMPLEX, i+i*sym_np, MPI_COMM_WORLD, ierror)
     enddo
     diag_prod = diag(1)
     do i = 2, sym_np
        diag_prod = diag_prod + diag(i)
     enddo
  endif
#endif

  DEBUG2S("End: function diag_prod")
end

!-------------------------------------------------------------------------------
subroutine matrix_inv(matrix, n, det)
  use module_det
  use module_function_decl
  implicit none
  integer, intent(in) :: n
  COMPLEX, intent(inout) :: matrix(n,n), det
  COMPLEX, allocatable :: work(:), iwork(:)
  integer, allocatable :: ipiv(:)
  integer :: i, lwork, liwork, lda_x, lda_y
  COMPLEX, external :: diag_prod
  REAL :: time0, time1, flop
  SECONDS  sekunden

  DEBUG2S("Start: matrix_inv")
  time0=sekunden()

  if (sym_np == 1) then
#ifdef CUDA
     allocate(ipiv(n))
#ifdef MAGMA
     call wrap_magma_zgetrf_mgpu(n, n, matrix, n, ipiv, i)
     det = diag_prod(matrix, n, ipiv, n)
     call wrap_magma_zgetri_gpu(n,    matrix, n, ipiv, i)
#else
     call zminv_nv(n, n, matrix, n, ipiv, i, det)
     if (i/=0) call die("zminv_nv failed")
#endif
     deallocate(ipiv)
#else
#ifdef LAPACK
     lwork=2*n
     allocate(work(lwork), ipiv(n))
     call zgetrf(n, n, matrix, n, ipiv, i)
     det = diag_prod(matrix, n, ipiv, n)
     call zgetri(n, matrix, n, ipiv, work, n ,i)
     deallocate(work, ipiv)
#else
     call die("matrix_inv: requires LAPACK")
#endif
#endif
  else
#ifdef SCALAPACK
     if ( n == dirac_svol) then

#ifdef FPCOLL
call start_collection("matrix_inv4")
#endif
        lda_x = locpn_dirac
        lda_y = locqn_dirac
        lwork = locpn_dirac * dirac_svol
        liwork= locqn_dirac + dirac_svol
        allocate(work(lwork), iwork(liwork), ipiv(lda_x+dirac_svol))
        call pzgetrf(dirac_gvol, dirac_gvol, matrix,1,1,descS4,ipiv,i)
        det = diag_prod(matrix, n, ipiv, lda_x+dirac_svol)
        call pzgetri(dirac_gvol,             matrix,1,1,descS4,ipiv,work,lwork,iwork,liwork,i)
        deallocate(work, iwork, ipiv)
#ifdef FPCOLL
call stop_collection("matrix_inv4")
#endif

     elseif ( n == dirac_svol3) then
#ifdef FPCOLL
call start_collection("matrix_inv3")
#endif
        lda_x = locpn_dirac3
        lda_y = locqn_dirac3
        lwork = locpn_dirac3 * dirac_svol3
        liwork= locqn_dirac3 + dirac_svol3
        allocate(work(lwork), iwork(liwork), ipiv(lda_x+dirac_svol3))
        call pzgetrf(dirac_gvol3, dirac_gvol3, matrix,1,1,descS3,ipiv,i)
        det = diag_prod(matrix, n, ipiv, lda_x+dirac_svol3)
        call pzgetri(dirac_gvol3,              matrix,1,1,descS3,ipiv,work,lwork,iwork,liwork,i)
        deallocate(work, iwork, ipiv)
#ifdef FPCOLL
call stop_collection("matrix_inv3")
#endif
     else
        call die("matrix_inv: unsupported volume")
     endif
#else
     call die("SCALAPACK is not linked")
#endif
  endif
  if ( i /= 0) call die("matrix_inv failed to invert")

  time1 = sekunden()-time0
  if ( n == dirac_svol ) then
     i = dirac_gvol
  elseif ( n == dirac_svol3 ) then
     i = dirac_gvol3
  else
     i = n
  endif

  flop=6* (dble(i)/2 * (dble(i) * (dble(i) - dble(i)/3 - 1) + dble(i)) + 2*dble(i)/3) + &  !getrt mul
       2* (dble(i)/2 * (dble(i) * (dble(i) - dble(i)/3    ) - dble(i)) +   dble(i)/6) + &  !getrt add
       6*  dble(i) * ( 5/6 + dble(i) * (2*dble(i)/3+0.5) ) + & ! getri mul
       2*  dble(i) * ( 5/6 + dble(i) * (2*dble(i)/3-1.5) )     ! getrt add
  if(my_pe()==0 )write(0,'(1x,"matrix_inv done: FLOP=",e12.5 , 1x, "Time=", e12.5, 1x, "TFLOPS=", e12.5)') &
  flop, time1, flop/time1 /dble(1024)**4

  DEBUG2S("End: matrix_inv")
end

!-------------------------------------------------------------------------------
subroutine matvec_mul(mat, out, in, m, n) ! out = mat * in
  use module_det
  implicit none
  integer, intent(in) :: m, n
  COMPLEX, intent(in) :: mat(m,n), in(m)
  COMPLEX, intent(out):: out(m)

  if (m == n .and. sym_np == 1) then
     call matvecmult(mat, out, in, n)
  else
#ifdef SCALAPACK
     call init_blacs()
     call pzgemv('N', n, n, zpone ,mat, 1, 1, descM4, &
                                    in, 1, 1, descV4, 1, &
                            zzero, out, 1, 1, descV4, 1)
#else
     call die("SCALAPACK is not linked")
#endif
  endif

end

!-------------------------------------------------------------------------------
subroutine zgemm_common(char1, char2, fac1, in1, in2, fac2, out, n) ! out = fac2 * out + fac1* in1 * in2
  use module_det
  use module_function_decl
  implicit none
  character (len=1) :: char1, char2
  integer, intent(in) :: n
  COMPLEX, intent(in) :: in1(n,n), in2(n,n)
  COMPLEX, intent(out):: out(n,n)
  COMPLEX :: fac1, fac2
  integer :: info
  REAL :: time0, time1, flop
  SECONDS  sekunden

  DEBUG2S("Start: zgemm_common")
  time0=sekunden()

  if (sym_np == 1) then
#ifdef CUDA
#ifdef MAGMA
  call wrap_magma_zgemm_gpu(char1,char2,n,n,n,fac1,in1,n,in2,n,fac2,out,n)
#else
  call zgemm_nv(char1,char2,n,n,n,fac1,in1,n,in2,n,fac2,out,n)
#endif
#else
#ifdef LAPACK
     call zgemm(char1,char2, n, n, n, fac1, in1, n, in2, n, fac2, out, n)
#else
     call die("matrix_mul: requires LAPACK")
#endif
#endif
  elseif ( n == dirac_svol3) then
#ifdef SCALAPACK
     call pzgemm(char1,char2, dirac_gvol3, dirac_gvol3, dirac_gvol3, fac1, &
                  in1, 1,1,descS3, &
                  in2, 1,1,descS3, fac2, &
                  out, 1,1,descS3)
#else
     call die("SCALAPACK is not linked")
#endif
  else
     call die("matrix_mul: unsupported volume")
  endif

  time1 = sekunden()-time0
  flop=8 * dble(dirac_gvol3)**3
  if(my_pe()==0 )write(0,'(1x,"matrix_mul done: FLOP=",e12.5 , 1x, "Time=", e12.5, 1x, "TFLOPS=", e12.5)') &
  flop, time1, flop/time1 /dble(1024)**4

  DEBUG2S("End: zgemm_common")
end

!-------------------------------------------------------------------------------
subroutine matrix_mul(out, in1, in2, n) ! out = in1 * in2
  use module_det
  implicit none
  integer, intent(in) :: n
  COMPLEX, intent(in) :: in1(n,n), in2(n,n)
  COMPLEX, intent(out):: out(n,n)

#ifdef FPCOLL
call start_collection("matrix_mul")
#endif

  call zgemm_common('N', 'N', zpone, in1, in2, zzero, out, n)

#ifdef FPCOLL
call stop_collection("matrix_mul")
#endif

end

!-------------------------------------------------------------------------------
subroutine matrix_mul2(out, in1, in2, in3, n) ! out = in1 * in2 * in3
  implicit none
  integer, intent(in) :: n
  COMPLEX, intent(in) :: in1(n,n), in2(n,n), in3(n,n)
  COMPLEX, intent(out):: out(n,n)
  COMPLEX :: tmp(n,n)

  call matrix_mul(tmp, in1, in2, n)
  call matrix_mul(out, tmp, in3, n)

end

!-------------------------------------------------------------------------------
subroutine matrix_copy(out, in, n) ! out = in
  implicit none
  integer, intent(in) :: n
  COMPLEX, intent(in) :: in(n,n)
  COMPLEX, intent(out):: out(n,n)
  integer :: i, j

  !$omp parallel do private(i)
  do j = 1, n
     do i = 1, n
        out(i, j)= in(i, j)
     enddo
  enddo

end

!-------------------------------------------------------------------------------
!                  D222, D444, D412 ! D222=D(lt/2) - d212 - d232 
!                              D234 ! D444=D(lt  ) - d414 - d434
subroutine d_inv_d(out1, out2, out3, out8, n, nt, mid, det)
  implicit none
  integer, intent(in) :: n, nt, mid
  COMPLEX, dimension(n, n, 2, 2), intent(out) :: out1, out2
  COMPLEX, dimension(n, n),       intent(out) :: out3, out8
  COMPLEX :: newtmp(n,n,2,2), tmp(n,n)
  COMPLEX :: det, det_tmp
  integer :: it, i, j, itt
  COMPLEX, dimension(:,:,:),  pointer, save :: ut


  DEBUG2S("Start: d_inv_d")
  if (.not. associated(ut))  allocate(ut(n, n, nt))
  call get_hdirac_op_t_sym(ut, mid)

  call get_hdirac_op_3d_sym(out1, mid, nt/2, 0)
  call get_hdirac_op_3d_sym(out2, mid, nt  , 0)
  call matrix_copy(out3, ut(1,1,nt/2-1), n)
  call matrix_copy(out8, ut(1,1,nt-1), n)

!!if (nt == 4) then
!!  call get_hdirac_op_3d_sym(newtmp, mid, 1, 0)
!!  call inv_schurcomp3(newtmp, n, det)
!!  call fb_update(out1(1,1,2,2), newtmp(1,1,1,1), ut(1,1,nt/2-1), n, -1)
!!  call u0_update(out3, ut(1,1,nt), newtmp(1,1,2,1), ut(1,1,1), n)
!!
!!  call get_hdirac_op_3d_sym(newtmp, mid, 1, 0)
!!  call inv_schurcomp0(newtmp, n, det_tmp)
!!  call fb_update(out2(1,1,1,1), newtmp(1,1,2,2), ut(1,1,nt  ), n,  1)
!!
!!  call get_hdirac_op_3d_sym(newtmp, mid, 3, 0)
!!  call inv_schurcomp3(newtmp, n, det_tmp) ; det=det+det_tmp
!!  call fb_update(out2(1,1,2,2), newtmp(1,1,1,1), ut(1,1,nt-1), n, -1)
!!  call u0_update(out8, ut(1,1,nt/2), newtmp(1,1,2,1), ut(1,1,nt/2+1), n)
!!
!!  call get_hdirac_op_3d_sym(newtmp, mid, 3, 0)
!!  call inv_schurcomp0(newtmp, n, det_tmp)
!!  call fb_update(out1(1,1,1,1), newtmp(1,1,2,2), ut(1,1,nt/2), n,  1)

  call get_hdirac_op_3d_sym(newtmp, mid, 1, 0)
  call inv_schurcomp3(newtmp, n, det)
!  call u0_update(out3, newtmp(1,1,2,1), ut(1,1,1), n)
  do it = 2, nt/2-1
     call matrix_copy(tmp, newtmp(1,1,1,1), n)
     call get_hdirac_op_3d_sym(newtmp, mid, it, 0)
     call fb_update(newtmp(1,1,2,2), tmp, ut(1,1, it-1 ), n, -1)
     call inv_schurcomp3(newtmp, n, det_tmp) ; det=det+det_tmp
!     call u0_update(out3, newtmp(1,1,2,1), ut(1,1,it), n)
  enddo
  call fb_update(out1(1,1,2,2), newtmp(1,1,1,1), ut(1,1, nt/2-1 ), n, -1)


  call get_hdirac_op_3d_sym(newtmp, mid, nt/2+1, 0)
  call inv_schurcomp3(newtmp, n, det_tmp) ; det=det+det_tmp
!  call u0_update(out8, newtmp(1,1,2,1), ut(1,1,nt/2+1), n)
  do it = 2, nt/2-1
     call matrix_copy(tmp, newtmp(1,1,1,1), n)
     call get_hdirac_op_3d_sym(newtmp, mid, nt/2+ it, 0)
     call fb_update(newtmp(1,1,2,2), tmp, ut(1,1,nt/2 + it -1), n, -1)
     call inv_schurcomp3(newtmp, n, det_tmp) ; det=det+det_tmp
!     call u0_update(out8, newtmp(1,1,2,1), ut(1,1,nt/2 + it), n)
  enddo
  call fb_update(out2(1,1,2,2), newtmp(1,1,1,1), ut(1,1,nt-1), n, -1)

  do i = 0, 1
     call get_hdirac_op_3d_sym(newtmp, mid, nt/2-1 + i*nt/2, 0)
     call inv_schurcomp0(newtmp, n, det_tmp)
     if (i==0) then
        if(nt==4) then
        call u0_update(out3, newtmp(1,1,2,1), ut(1,1,nt     ), n)
        else
        call u0_update(out3, newtmp(1,1,2,1), ut(1,1,nt/2-2 ), n)
        endif
     else
        call u0_update(out8, newtmp(1,1,2,1), ut(1,1,nt  -2 ), n)
     endif
     do it = 2, nt/2-1
        call matrix_copy(tmp, newtmp(1,1,2,2), n)
        call get_hdirac_op_3d_sym(newtmp, mid, nt/2 - it + i*nt/2, 0)
        call fb_update(newtmp(1,1,1,1), tmp, ut(1,1,nt/2 - it + i*nt/2), n,  1)
        call inv_schurcomp0(newtmp, n, det_tmp)
        if (i==0) then
           if (nt/2-it-1 == 0) then
           call u0_update(out3, newtmp(1,1,2,1), ut(1,1,nt       ), n)
           else
           call u0_update(out3, newtmp(1,1,2,1), ut(1,1,nt/2-it-1), n)
           endif
        else
           call u0_update(out8, newtmp(1,1,2,1), ut(1,1,nt  -it-1), n)
        endif
     enddo
     if (i==0)call fb_update(out2(1,1,1,1), newtmp(1,1,2,2), ut(1,1,nt ), n,  1)
     if (i==1)call fb_update(out1(1,1,1,1), newtmp(1,1,2,2), ut(1,1,nt/2  ), n,  1)
  enddo

!  call get_hdirac_op_3d_sym(newtmp, mid, nt  -1, 0)
!  call inv_schurcomp0(newtmp, n, det_tmp)
!  call fb_update(out1(1,1,1,1), newtmp(1,1,2,2), ut(1,1,nt/2), n,  1)



!!else
!!
!!  det=ZERO
!!  do i = 0, 1
!!     call get_dirac_op_3d_sym(newtmp(:,:,2,2), mid, i*nt/2+1, 0)
!!     call matrix_inv(newtmp(:,:,2,2), n, det_tmp) ; det=det+det_tmp
!!     do it = i*nt/2+1, i*nt/2+nt/2-2
!!        if (it /= i*nt/2+1) call matrix_copy(newtmp(:,:,2,2),newtmp(:,:,1,1),n)
!!        call get_dirac_op_3d_sym(newtmp(1,1,1,2),mid, it+1, -1)
!!        call get_dirac_op_3d_sym(newtmp(1,1,2,1),mid, it, 1)
!!        call get_dirac_op_3d_sym(newtmp(1,1,1,1),mid, it+1, 0)
!!        call inv_schurcomp1(newtmp, n, det_tmp) ; det=det+det_tmp
!!     enddo
!!     call get_dirac_op_3d_sym(tmp0, mid, nt/2+i*nt/2,  -1)
!!     call get_dirac_op_3d_sym(tmp00,mid, 1+i*nt/2,     -1)
!!     if (i==0) then
!!        call matrix_mul2(out3, tmp0, newtmp(1,1,1,2), tmp00, n)
!!     else
!!        call matrix_mul2(out8, tmp0, newtmp(1,1,1,2), tmp00, n)
!!     endif
!!     call get_dirac_op_3d_sym(tmp00,mid, nt/2+i*nt/2-1, 1)
!!     call matrix_mul(tmpp, tmp0, newtmp(1,1,1,1), n)
!!     if (i==0) then
!!        call nnzgemm(mone, tmpp, tmp00, one, out1, n)
!!     else
!!        call nnzgemm(mone, tmpp, tmp00, one, out2, n)
!!     endif
!!  enddo
!!
!!  do i = 0, 1
!!     call get_dirac_op_3d_sym(newtmp(:,:,2,2), mid, nt/2-1 + nt/2*i, 0)
!!     call matrix_inv(newtmp(:,:,2,2), n, det_tmp)
!!     do it = nt/2-1 + nt/2*i, 2+nt/2*i, 1
!!        if (it /= nt/2-1 + nt/2*i) call matrix_copy(newtmp(:,:,2,2),newtmp(:,:,1,1),n)
!!        call get_dirac_op_3d_sym(newtmp(1,1,1,2),mid, it-1, 1)
!!        call get_dirac_op_3d_sym(newtmp(1,1,2,1),mid, it, -1)
!!        call get_dirac_op_3d_sym(newtmp(1,1,1,1),mid, it-1, 0)
!!        call inv_schurcomp1(newtmp, n, det_tmp)
!!     enddo
!!
!!     call get_dirac_op_3d_sym(tmp0, mid, nt  -nt/2*i,   1)
!!     call get_dirac_op_3d_sym(tmp00,mid, nt/2+nt/2*i-1, 1)
!!     if (i==0) then
!!        call matrix_mul2(out4, tmp0, newtmp(1,1,1,2), tmp00, n)
!!     else
!!        call matrix_mul2(out7, tmp0, newtmp(1,1,1,2), tmp00, n)
!!     endif
!!     call get_dirac_op_3d_sym(tmp00,mid,      nt/2*i+1,-1)
!!     call matrix_mul(tmpp, tmp0, newtmp(1,1,1,1), n)
!!     if (i==0) then
!!        call nnzgemm(mone, tmpp, tmp00, one, out2, n)
!!     else
!!        call nnzgemm(mone, tmpp, tmp00, one, out1, n)
!!     endif
!!  enddo
!!endif

  DEBUG2S("End: d_inv_d")
end

!-------------------------------------------------------------------------------
subroutine get_hdirac_op_3d_sym(mat, id, it, fb)
  use module_det
  use module_lattice
  use module_action
  implicit none
  COMPLEX, intent(out):: mat(dirac_svol3, dirac_svol3, 2, 2)
  integer, intent(in) :: id, it, fb
  COMPLEX :: tmp(dirac_lvol3, dirac_gvol3, 2, 2)
  REAL :: kappa
  integer :: i,j

  DEBUG2S("Start: get_hdirac_op_3d_sym")
  kappa=action%mtilde(id)%kappa
  if (sym_np == 1) then
     call make_hdirac_op_space(mat, id, it)
  else
     call make_hdirac_op_space(tmp, id, it)
     do j = 1, 2
        do i = 1, 2
           call dirac_matrix_redist_3d(mat(1,1,i,j), tmp(1,1,i,j))
        enddo
     enddo
  endif
  DEBUG2S("End: get_hdirac_op_3d_sym")
end

!-------------------------------------------------------------------------------
subroutine get_hdirac_op_t_sym(mat, id)
  use module_det
  use module_lattice
  use module_action
  implicit none
  COMPLEX, intent(out):: mat(dirac_svol3, dirac_svol3, nt)
  integer, intent(in) :: id
  COMPLEX :: tmp(dirac_lvol3, dirac_gvol3)
  REAL :: kappa
  integer :: it

  DEBUG2S("Start: get_hdirac_op_t_sym")
  kappa=action%mtilde(id)%kappa
  if (sym_np == 1) then
     do it = 1, nt
        call hhop_put_tforw(mat(1,1,it), kappa, it)
     enddo
  else
     do it = 1, nt
        call hhop_put_tforw(tmp, kappa, it)
        call dirac_matrix_redist_3d(mat(1,1,it), tmp)
     enddo
  endif
  DEBUG2S("End: get_hdirac_op_t_sym")
end

!-------------------------------------------------------------------------------
subroutine dirac_matrix_redist(out, in) ! Re-distribute
  use module_det
  implicit none
  COMPLEX, intent(in) :: in(dirac_lvol, dirac_gvol)
  COMPLEX, intent(out):: out(dirac_svol, dirac_svol)
  integer :: icontext

  if (.not. blacs_ready) call die("dirac_matrix_redist: blacs is not ready")
  DEBUG2S("Start: dirac_matrix_redist")
#ifdef SCALAPACK
  call blacs_get(-1,0,icontext)
  call blacs_gridinit( icontext, 'Col-major', sym_np, sym_np)
  call pzgemr2d(dirac_gvol, dirac_gvol, in, 1, 1, descM4, out, 1, 1, descS4, icontext)
  call blacs_gridexit( icontext)
#else
  call die("SCALAPACK is not linked")
#endif
  DEBUG2S("End: dirac_matrix_redist")
end

!-------------------------------------------------------------------------------
subroutine dirac_matrix_redist_3d(out, in) ! Re-distribute
  use module_det
  implicit none
  COMPLEX, intent(in) :: in(dirac_lvol3, dirac_gvol3)
  COMPLEX, intent(out):: out(dirac_svol3, dirac_svol3)
  integer :: icontext

  if (.not. blacs_ready) call die("dirac_matrix_redist_3d: blacs is not ready")
  DEBUG2S("Start: dirac_matrix_redist_3d")
#if SCALAPACK
  call blacs_get(-1,0,icontext)
  call blacs_gridinit( icontext, 'Col-major', sym_np, sym_np)
  call pzgemr2d(dirac_gvol3, dirac_gvol3, in, 1, 1, descM3, out, 1, 1, descS3, icontext)
  call blacs_gridexit( icontext)
#else
  call die("SCALAPACK is not linked")
#endif
  DEBUG2S("End: dirac_matrix_redist_3d")
end

!-------------------------------------------------------------------------------
subroutine inv_schurcomp0(a, n, det)  ! A11=in:A, out: A^-1
  use module_det                      ! A12=in:B
  implicit none                       ! A21=in:C, out:-(D - C A^-1 B)^-1 C A^-1
  integer :: n                        ! A22=in:D, out: (D - C A^-1 B)^-1
  COMPLEX :: a(n,n,2,2), tmp(n,n)
  COMPLEX :: det, det1, det2

  call matrix_inv(a(1,1,1,1), n, det1)               !         A^-1
  call matrix_mul(tmp, a(1,1,2,1), a(1,1,1,1), n)    !       C A^-1
  call zgemm_common('N','N',zmone,tmp,a(1,1,1,2),zpone,a(1,1,2,2),n)!   D - C A^-1 B
  call matrix_inv(a(1,1,2,2), n, det2)               !  (D - C A^-1 B)^-1
  det = det1 + det2

  call zgemm_common('N','N',zmone,a(1,1,2,2),tmp,zzero,a(1,1,2,1),n)

end

!-------------------------------------------------------------------------------
subroutine inv_schurcomp1(a, n, det)  ! A11=in:A, out:  (A - B D^-1 C)^-1
  use module_det                      ! A12=in:B, out: -(A - B D^-1 C)^-1 B D^-1
  implicit none                       ! A21=in:C
  integer :: n                        ! A22=in:D, out: D^-1
  COMPLEX :: a(n,n,2,2), tmp(n,n)
  COMPLEX :: det, det1, det2

  call matrix_inv(a(1,1,2,2), n, det1)               !         D^-1
  call matrix_mul(tmp, a(1,1,1,2), a(1,1,2,2), n)    !       B D^-1
  call zgemm_common('N','N',zmone,tmp,a(1,1,2,1),zpone,a(1,1,1,1),n)!   A - B D^-1 C
  call matrix_inv(a(1,1,1,1), n, det2)               !  (A - B D^-1 C)^-1
  det = det1 + det2

  call zgemm_common('N','N',zmone,a(1,1,1,1),tmp,zzero,a(1,1,1,2),n)! -(A - B D^-1 C)^-1 B D^-1

end

!-------------------------------------------------------------------------------
subroutine inv_schurcomp2(a, n, det)  ! A11=in:A, out:  (A - B D^-1 C)^-1
  use module_det                      ! A12=in:B, out: -(A - B D^-1 C)^-1 B D^-1
  implicit none                       ! A21=in:C
  integer :: n                        ! A22=in:D, out: D^-1 + D^-1 C (A - B D^-1 C)^-1 B D^-1
  COMPLEX :: a(n,n,2,2), tmp(n,n)
  COMPLEX :: det, fac1,fac2, det1, det2

  call matrix_inv(a(1,1,2,2), n, det1)               !         D^-1
  call matrix_mul(tmp, a(1,1,1,2), a(1,1,2,2), n)    !       B D^-1
  call zgemm_common('N','N',zmone,tmp,a(1,1,2,1),zpone,a(1,1,1,1),n)!   A - B D^-1 C
  call matrix_inv(a(1,1,1,1), n, det2)               !  (A - B D^-1 C)^-1
  det = det1 + det2

  call zgemm_common('N','N',zmone,a(1,1,1,1),tmp,zzero,a(1,1,1,2),n)! -(A - B D^-1 C)^-1 B D^-1

  call matrix_mul(tmp, a(1,1,2,2), a(1,1,2,1), n)    !       D^-1 C
  call zgemm_common('N','N',zmone,tmp,a(1,1,1,2),zpone,a(1,1,2,2),n)! D^-1 + D^-1 C (A - B D^-1 C)^-1 B D^-1

end

!-------------------------------------------------------------------------------
subroutine inv_schurcomp3(a, n, det)  ! A11=in:A, out:  (A - B D^-1 C)^-1
  use module_det                      ! A12=in:B
  implicit none                       ! A21=in:C, out: -D^-1 C (A - B D^-1 C)^-1
  integer :: n                        ! A22=in:D
  COMPLEX :: a(n,n,2,2), tmp(n,n)
  COMPLEX :: det, fac1,fac2, det1, det2

  call matrix_inv(a(1,1,2,2), n, det1)               !         D^-1
  call matrix_mul(tmp, a(1,1,2,2), a(1,1,2,1), n)    !         D^-1 C
  call zgemm_common('N','N',zmone,a(1,1,1,2),tmp,zpone,a(1,1,1,1),n)!   A - B D^-1 C
  call matrix_inv(a(1,1,1,1), n, det2)               !  (A - B D^-1 C)^-1
  det = det1 + det2

  call zgemm_common('N','N',zmone,tmp,a(1,1,1,1),zzero,a(1,1,2,1),n)! -D^-1 C (A - B D^-1 C)^-1

end

!-------------------------------------------------------------------------------
subroutine inv_schurcomp4(a, n, det)  ! A11=in:A, out:  (A - B D^-1 C)^-1
  use module_det                      ! A12=in:B, out: -(A - B D^-1 C)^-1 B D^-1
  implicit none                       ! A21=in:C, out: -D^-1 C (A - B D^-1 C)^-1
  integer :: n                        ! A22=in:D, out: D^-1 + D^-1 C (A - B D^-1 C)^-1 B D^-1
  COMPLEX :: a(n,n,2,2), tmp(n,n)
  COMPLEX :: det, fac1,fac2, det1, det2

  call matrix_inv(a(1,1,2,2), n, det1)               !         D^-1
  call matrix_mul(tmp, a(1,1,1,2), a(1,1,2,2), n)    !       B D^-1
  call zgemm_common('N','N',zmone,tmp,a(1,1,2,1),zpone,a(1,1,1,1),n)!   A - B D^-1 C
  call matrix_inv(a(1,1,1,1), n, det2)               !  (A - B D^-1 C)^-1
  det = det1 + det2

  call zgemm_common('N','N',zmone,a(1,1,1,1),tmp,zzero,a(1,1,1,2),n)! -(A - B D^-1 C)^-1 B D^-1

  call matrix_mul(tmp, a(1,1,2,2), a(1,1,2,1), n)    !       D^-1 C
  call zgemm_common('N','N',zmone,tmp,a(1,1,1,2),zpone,a(1,1,2,2),n)! D^-1 + D^-1 C (A - B D^-1 C)^-1 B D^-1
  call zgemm_common('N','N',zmone,tmp,a(1,1,1,1),zzero,a(1,1,2,1),n)! - D^-1 C (A - B D^-1 C)^-1

end

!-------------------------------------------------------------------------------
subroutine fb_update(fb0, fb1, ut, n, fb)
  use module_det
  implicit none
  integer, intent(in) :: n, fb
  COMPLEX, dimension(n,n) :: fb0, fb1, ut, tmp

  select case (fb)
     case( 1)
        call zgemm_common('N','C',zpone, fb1, ut, zzero, tmp, n)
        call zgemm_common('N','N',zmone, ut, tmp, zpone, fb0, n)
     case(-1)
        call zgemm_common('N','N',zpone, fb1, ut, zzero, tmp, n)
        call zgemm_common('C','N',zmone, ut, tmp, zpone, fb0, n)
  end select

end

!-------------------------------------------------------------------------------
subroutine u0_update(u0, aa, ut, n) ! u0 = ut * aa * u0
  use module_det
  implicit none
  integer :: n
  COMPLEX, dimension(n,n) :: u0, aa, ut, tmp

  call zgemm_common('N','N',zpone, aa, u0, zzero, tmp, n)
  call zgemm_common('N','N',zpone, ut, tmp, zzero, u0, n)

end

!-------------------------------------------------------------------------------
subroutine l0_update(l0, ut, aa, l1, n, dag)
  use module_det
  implicit none
  integer :: n
  COMPLEX, dimension(n,n) :: l0, aa, l1, ut, tmp
  logical :: dag

  if (dag) then
     call zgemm_common('N','C',zpone, aa, l1, zzero, tmp, n)
  else
     call zgemm_common('N','N',zpone, aa, l1, zzero, tmp, n)
  endif

  call zgemm_common('C','N',zpone, ut, tmp, zzero, l0, n)

end

!-------------------------------------------------------------------------------
subroutine zgemm22(in1, in2, out, n, dooffdiag)
  use module_det
  implicit none
  integer :: n
  COMPLEX, dimension(n,n,2,2) :: out, in1, in2
  logical :: dooffdiag

  call zgemm_common('N','N',zpone,in1(1,1,1,1),in2(1,1,1,1),zzero,out(1,1,1,1),n)
  call zgemm_common('N','N',zpone,in1(1,1,1,2),in2(1,1,2,1),zpone,out(1,1,1,1),n)
  if (dooffdiag) then

  call zgemm_common('N','N',zpone,in1(1,1,2,1),in2(1,1,1,1),zzero,out(1,1,2,1),n)
  call zgemm_common('N','N',zpone,in1(1,1,2,2),in2(1,1,2,1),zpone,out(1,1,2,1),n)

  call zgemm_common('N','N',zpone,in1(1,1,1,1),in2(1,1,1,2),zzero,out(1,1,1,2),n)
  call zgemm_common('N','N',zpone,in1(1,1,1,2),in2(1,1,2,2),zpone,out(1,1,1,2),n)
  endif

  call zgemm_common('N','N',zpone,in1(1,1,2,1),in2(1,1,1,2),zzero,out(1,1,2,2),n)
  call zgemm_common('N','N',zpone,in1(1,1,2,2),in2(1,1,2,2),zpone,out(1,1,2,2),n)


end

!-------------------------------------------------------------------------------
subroutine det_dirac(id, det)
  use module_vol
  use module_action
  use module_det
  implicit none
  integer, intent(in) :: id
  COMPLEX :: mat(dirac_svol, dirac_svol)
  COMPLEX :: tmp(dirac_lvol, dirac_gvol)
  COMPLEX :: fac1, fac2
  COMPLEX :: det

  TIMING_START(timing_bin_chemidet_dirac4)
#ifdef FPCOLL
call start_collection("det_dirac")
#endif

  fac1 = exp(cmplx( chemi, chemi_i))
  fac2 = exp(cmplx(-chemi,-chemi_i))

  DEBUG2S("Start: get_dirac_op_sym")
  if (sym_np == 1) then
     call make_dirac_op(mat, id, fac1, fac2)
  else
     call make_dirac_op(tmp, id, fac1, fac2)
     call dirac_matrix_redist(mat, tmp)
  endif
  DEBUG2S("End: get_dirac_op_sym")

  det = ZERO
  call matrix_inv(mat, dirac_svol, det)

#ifdef FPCOLL
call stop_collection("det_dirac")
#endif
  TIMING_STOP(timing_bin_chemidet_dirac4)

end

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