!===============================================================================
!
! 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
  integer, save :: dirac_gvol3, dirac_lvol3, dirac_svol3, locpn_dirac3, locqn_dirac3
  integer, save :: myprow_sym, mypcol_sym
  integer, save :: sym_np=1


  logical, save :: fileopen = .false.
  character(len = 14) :: filename

end module
!-------------------------------------------------------------------------------
subroutine chemical_determinant(traj)
  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
  COMPLEX :: det, det1_det3, det2, det4, detw, tr1, tr2, tr3, t(0:10, 0:3), ctmp
  COMPLEX :: tr4, tr5, tr6, tr7, tr8
  REAL    :: ex, ph, wexpre, wexpim, wexpex, wexpph, fac1, fac2
!!  COMPLEX, allocatable :: mat(:,:)
  COMPLEX, dimension(:, :), allocatable :: tmp1, tmp2, tmp3, tmp4, tmp5, tmp6
  COMPLEX, dimension(:, :), allocatable :: d222,d444,d214,d412,d234,d432, h0 ,hp, hm
  COMPLEX, external :: trace

  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")

  fid = max(input%hmc_mpf_dd_mass,input%hmc_mpf_mass)
  fid = max(input%hmc_mpf_hh_mass,fid)
  fid = max(input%hmc_mpf_rhmc_l,fid)
  fid = max(input%hmc_mpf_dd_rhmc_l,fid)
  fid = max(input%hmc_mpf_hh_rhmc_l,fid)

  if (fid <= 0 .or. fid > 5 ) call die("det_test: unexpected fid")
  mid = action%fermi(fid)%mid1

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

  fac1 = exp( chemi*dble(nt))
  fac2 = exp(-chemi*dble(nt))

!!  call checkmat(mid)
!!  det=ZERO
!!  allocate(mat(dirac_svol, dirac_svol))
!!  call make_dirac_op_sym(mat, mid, exp(chemi), exp(-chemi))
!!  det = determinant(mat, dirac_svol)
!!  deallocate(mat)

  allocate(tmp1(dirac_svol3, dirac_svol3))
  allocate(tmp2(dirac_svol3, dirac_svol3))
  allocate(tmp3(dirac_svol3, dirac_svol3))
  allocate(tmp4(dirac_svol3, dirac_svol3))
  allocate(tmp5(dirac_svol3, dirac_svol3))
  allocate(tmp6(dirac_svol3, dirac_svol3))
  allocate(d222(dirac_svol3, dirac_svol3))
  allocate(d444(dirac_svol3, dirac_svol3))
  allocate(d214(dirac_svol3, dirac_svol3))
  allocate(d234(dirac_svol3, dirac_svol3))
  allocate(d412(dirac_svol3, dirac_svol3))
  allocate(d432(dirac_svol3, dirac_svol3))
  allocate(  h0(dirac_svol3, dirac_svol3))
  allocate(  hp(dirac_svol3, dirac_svol3))
  allocate(  hm(dirac_svol3, dirac_svol3))

  call d_inv_d(d222,d444,d214,d412,d234,d432, dirac_svol3, nt, mid, det1_det3)

  call matrix_inv(d222, dirac_svol3, det2)
  call matrix_inv(d444, dirac_svol3, det4)
  call matrix_mul(tmp3, d222, d234, dirac_svol3)
  call matrix_mul(tmp4, d222, d214, dirac_svol3)
  call matrix_mul2(hp, d444,  d412, tmp3, dirac_svol3)
  call matrix_mul2(hm, d444,  d432, tmp4, dirac_svol3)
  call matrix_mul(tmp5, d432, tmp3, dirac_svol3)
  call matrix_mul(tmp6, d412, tmp4, dirac_svol3)

  !$omp parallel do private (i)
  do j = 1, dirac_svol3
     do i = 1, dirac_svol3
        tmp5(i,j) = tmp5(i,j) + tmp6(i,j)
        tmp1(i,j) = ZERO
     enddo
  enddo
  call matrix_mul(h0, d444, tmp5, dirac_svol3)

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

  !$omp parallel do private (i)
  do j = 1, dirac_svol3
     do i = 1, dirac_svol3
        tmp1(i,j)=tmp1(i,j)-h0(i,j)-fac1*hp(i,j)-fac2*hm(i,j)
        tmp2(i,j)=                 -fac1*hp(i,j)+fac2*hm(i,j) !! dK  =- e^mu Hp + e^{-mu} Hm
        tmp3(i,j)=                 -fac1*hp(i,j)-fac2*hm(i,j) !! ddK =- e^mu Hp - e^{-mu} Hm
     enddo
  enddo
  call matrix_inv(tmp1, dirac_svol3, detw)              !! K^-1=(1 - h0 - e^mu Hp - e^{-mu} Hm)^-1

!!  call stderr2_real("Dirac operator W determinant:",2,detw)
!!  call stderr2_real("Mult all factor determinants:",2,det1_det3+det2+det4+detw)
!!  call stderr2_real("Dirac operator   determinant:",2,det)

  call matrix_mul(tmp4, tmp1, tmp2, dirac_svol3)  !! tmp4=K^-1 dK =A
  tr1=trace(tmp4, dirac_svol3)
  call matrix_mul(tmp5, tmp1, tmp3, dirac_svol3)  !! tmp5=K^-1 ddK=B
  tr3=trace(tmp5, dirac_svol3)
  call matrix_mul(tmp1, tmp4, tmp4, dirac_svol3)  !! tmp1=(K^-1 dK)^2=A^2
  tr2=trace(tmp1, dirac_svol3)

  call matrix_mul(tmp2, tmp4, tmp1, dirac_svol3)  !! tmp2=A^3
  tr4=trace(tmp2, dirac_svol3)
  call matrix_mul(tmp3, tmp4, tmp2, dirac_svol3)  !! tmp3=A^4
  tr6=trace(tmp3, dirac_svol3)

  call matrix_mul(tmp2, tmp4, tmp5, dirac_svol3)  !! tmp2=AB
  tr5=trace(tmp2, dirac_svol3)
  call matrix_mul(tmp3, tmp4, tmp2, dirac_svol3)  !! tmp2=AAB
  tr7=trace(tmp3, dirac_svol3)
  call matrix_mul(tmp2, tmp5, tmp5, dirac_svol3)  !! tmp2=BB
  tr8=trace(tmp2, dirac_svol3)


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

  call matrix_mul(tmp1, h0, h0, dirac_svol3)  !! tmp1= H0^2      ---- > keep for H0^3
  call matrix_mul(tmp2, hp, hm, dirac_svol3)  !! tmp2= H+ H-        =======> keep for t(1,3) and  H+ H- H0
  t(0,2)=trace(tmp1, dirac_svol3)/TWO + trace(tmp2, dirac_svol3)

  call matrix_mul(tmp3, tmp1, h0, dirac_svol3)  !! tmp3= H0^3
  call matrix_mul(tmp4, tmp2, h0, dirac_svol3)  !! tmp4= H+ H- H0
  call matrix_mul(tmp1, hp,   h0, dirac_svol3)  !! tmp1= H+ H0      =======> keep for t(1,2) and t(1,3)
  call matrix_mul(tmp5, hm, tmp1, dirac_svol3)  !! tmp5= H- H+ H0
  t(0,3)=trace(tmp3, dirac_svol3)/THREE + trace(tmp4, dirac_svol3) + trace(tmp5, dirac_svol3)

  t(1,1)=trace(hp, dirac_svol3)
  t(1,2)=trace(tmp1, dirac_svol3)
  call matrix_mul(tmp3, hp, tmp2, dirac_svol3)  !! tmp3= H+ H+ H-
  call matrix_mul(tmp4, tmp1, h0, dirac_svol3)  !! tmp3= H+ H0 H0
  t(1,3)=trace(tmp3, dirac_svol3) + trace(tmp4, dirac_svol3)

  call matrix_copy(tmp2, hp, dirac_svol3)
  do i = 2, 10
     call matrix_mul(tmp3, hp, tmp2, dirac_svol3) !! tmp3 = H+  *  H+
     call matrix_mul(tmp4, hp, tmp1, dirac_svol3) !! tmp4 = H+  *  H+ H0
     t(i,1)=trace(tmp3, dirac_svol3)/dble(i)
     t(i,2)=trace(tmp4, dirac_svol3)
     t(i,3)=ZERO
     if( i < 10 ) then
        call matrix_copy(tmp2, tmp3, dirac_svol3)
        call matrix_copy(tmp1, tmp4, 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))
  enddo
  wexpre=exp(-ex)*cos(-ph)
  wexpim=exp(-ex)*sin(-ph)
  wexpex=exp(-ex)
  wexpph=-ph

  if (.not. fileopen) then
     if (len(trim(input%measure_chemical_file)) > 0) then
        if (my_pe()==0) open(50, file = trim(input%measure_chemical_file), action = "write")
     else
        write(filename, "(a, i6.6)" ) "dethist.", counter%job
        if (my_pe()==0) open(50, file = trim(filename), action = "write")
     endif
     fileopen = .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(det1_det3+det2+det4), aimag(det1_det3+det2+det4)
  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, tmp6)
  deallocate(d222, d444, d214, d234, d412, d432)
  deallocate(h0, hp, hm)
!!  call comm_finalize()
!!  call die("stop")
#ifdef FPCOLL
call stop_collection("chemical_determinant")
#endif
  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
  dirac_lvol3= dirac_lvol / lt

  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
        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_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 /= 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))
     call zminv_nv(n, n, matrix, n, ipiv, i, det)
     if (i/=0) call die("zminv_nv failed")
     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
     lda_x = locpn_dirac3
     lda_y = locqn_dirac3
     lwork = locpn_dirac3 * dirac_svol3
     liwork= locqn_dirac3 + dirac_svol3
     if ( n == dirac_svol3) then
        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)
     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
  i=dirac_gvol3
  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)
  COMPLEX :: one,zero

  one =(1.0d0,0.0d0)
  zero=(0.0d0,0.0d0)

  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, one  ,mat, 1, 1, descM4, &
                                   in, 1, 1, descV4, 1, &
                            zero, out, 1, 1, descV4, 1)
#else
     call die("SCALAPACK is not linked")
#endif
  endif

end

!-------------------------------------------------------------------------------
subroutine nnzgemm(fac1, in1, in2, fac2, out, n) ! out = fac2 * out + fac1* in1 * in2
  use module_det
  use module_function_decl
  implicit none
  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: nnzgemm")
  time0=sekunden()

  if (sym_np == 1) then
#ifdef CUDA
  call zgemm_nv('N','N',n,n,n,fac1,in1,n,in2,n,fac2,out,n)
#else
#ifdef LAPACK
     call zgemm('N','N', 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('N','N', 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: nnzgemm")
end

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

  one =(1.0d0,0.0d0)
  zero=(0.0d0,0.0d0)
  call nnzgemm(one, in1, in2, zero, out, n)

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, D214, D412 ! D222=D(lt/2) - d212 - d232 
!                              D234, D432 ! D444=D(lt  ) - d414 - d434
subroutine d_inv_d(out1, out2, out3, out4, out7, out8, n, nt, mid, det)
  implicit none
  integer, intent(in) :: n, nt, mid
  COMPLEX, dimension(n, n), intent(out) :: out1, out2, out3, out4, out7, out8
  COMPLEX, dimension(n, n) :: tmp1, tmp2, tmp0, tmp00, tmpp, tmp3, tmp4
  COMPLEX, dimension(n, n,2,2)::newtmp
  COMPLEX :: det, det_tmp, one, mone, zero
  integer :: it, i, j, itt

  DEBUG2S("Start: d_inv_d")
   one=( 1.0d0,0.0d0)
  mone=(-1.0d0,0.0d0)
  zero=( 0.0d0,0.0d0)
  call get_dirac_op_3d_sym(out1, mid, nt/2, 0)
  call get_dirac_op_3d_sym(out2, mid, nt  , 0)

if (nt == 4) then
  call get_dirac_op_3d_sym(tmp1, mid, 1, 0);  call matrix_inv(tmp1, n, det_tmp); det=det_tmp
  call get_dirac_op_3d_sym(tmp0, mid, 1, 1);  call matrix_mul(tmp2, tmp1, tmp0, n)
  call get_dirac_op_3d_sym(tmp0, mid, 2,-1);  call matrix_mul(tmpp, tmp0, tmp2, n)
  !$omp parallel do private (j)
  do i = 1, n
     do j = 1, n
        out1(i,j)=out1(i,j)-tmpp(i,j)
     enddo
  enddo
  call get_dirac_op_3d_sym(tmp0, mid, 4, 1);  call matrix_mul(out4, tmp0, tmp2, n)
  call get_dirac_op_3d_sym(tmp0, mid, 1,-1);  call matrix_mul(tmp2, tmp1, tmp0, n)
  call get_dirac_op_3d_sym(tmp0, mid, 2,-1);  call matrix_mul(out3, tmp0, tmp2, n)
  call get_dirac_op_3d_sym(tmp0, mid, 4, 1);  call matrix_mul(tmpp, tmp0, tmp2, n)
  !$omp parallel do private (j)
  do i = 1, n
     do j = 1, n
        out2(i,j)=out2(i,j)-tmpp(i,j)
     enddo
  enddo

  call get_dirac_op_3d_sym(tmp1, mid, 3, 0);  call matrix_inv(tmp1, n, det_tmp); det=det+det_tmp
  call get_dirac_op_3d_sym(tmp0, mid, 3,-1);  call matrix_mul(tmp2, tmp1, tmp0, n)
  call get_dirac_op_3d_sym(tmp0, mid, 2, 1);  call matrix_mul(tmpp, tmp0, tmp2, n)
  !$omp parallel do private (j)
  do i = 1, n
     do j = 1, n
        out1(i,j)=out1(i,j)-tmpp(i,j)
     enddo
  enddo

  call get_dirac_op_3d_sym(tmp0, mid, 4,-1);  call matrix_mul(out8, tmp0, tmp2, n)
  call get_dirac_op_3d_sym(tmp0, mid, 3, 1);  call matrix_mul(tmp2, tmp1, tmp0, n)
  call get_dirac_op_3d_sym(tmp0, mid, 2, 1);  call matrix_mul(out7, tmp0, tmp2, n)
  call get_dirac_op_3d_sym(tmp0, mid, 4,-1);  call matrix_mul(tmpp, tmp0, tmp2, n)
  !$omp parallel do private (j)
  do i = 1, n
     do j = 1, n
        out2(i,j)=out2(i,j)-tmpp(i,j)
     enddo
  enddo
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
     call matrix_copy(tmp3, newtmp(:,:,2,2), n)
     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
        call nnzgemm( one, newtmp(1,1,1,2), tmp3, zero, tmp00, n)
        call nnzgemm(mone, newtmp(1,1,1,1), tmp00, zero, tmp3, n)
     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, tmp3, tmp00, n)
     else
        call matrix_mul2(out8, tmp0, tmp3, 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)
     call matrix_copy(tmp3, newtmp(:,:,2,2), n)
     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)
        call nnzgemm( one, newtmp(1,1,1,2), tmp3, zero, tmp00, n)
        call nnzgemm(mone, newtmp(1,1,1,1), tmp00, zero, tmp3, n)
     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, tmp3, tmp00, n)
     else
        call matrix_mul2(out7, tmp0, tmp3, 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 make_dirac_op_sym(out, id, fac1, fac2)
  use module_det
  implicit none
  COMPLEX, intent(out):: out(dirac_svol, dirac_svol)
  integer, intent(in) :: id
  REAL, intent(in) :: fac1, fac2
  COMPLEX :: tmp(dirac_lvol, dirac_gvol)

  call make_dirac_op(tmp, id, fac1, fac2)
  if (sym_np == 1) then
     out=tmp
  else
     call dirac_matrix_redist(out, tmp)
  endif
end

!-------------------------------------------------------------------------------
subroutine get_dirac_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)
  integer, intent(in) :: id, it, fb
  COMPLEX :: tmp(dirac_lvol3, dirac_gvol3)
  REAL :: kappa

  DEBUG2S("Start: get_dirac_op_3d_sym")
  kappa=action%mtilde(id)%kappa
  if (sym_np == 1) then
     select case (fb)
        case( 0) ; call make_dirac_op_space(mat, id, it)
        case( 1) ; call hop_put_tforw(mat, kappa, it)
        case(-1) ; call hop_put_tback(mat, kappa, it)
     end select
  else
     select case (fb)
        case( 0) ; call make_dirac_op_space(tmp, id, it)
        case( 1) ; call hop_put_tforw(tmp, kappa, it)
        case(-1) ; call hop_put_tback(tmp, kappa, it)
     end select
     call dirac_matrix_redist_3d(mat, tmp)
  endif
  DEBUG2S("End: get_dirac_op_3d_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_schurcomp1(a, n, det) ! A11=in:A, out:  (A - B D^-1 C)^-1
  implicit none                      ! A12=in:B, out: -(A - B D^-1 C)^-1 B D^-1
  integer :: n                       ! A21=C, A22=D^-1
  COMPLEX :: det, a(n,n,2,2), tmp(n,n)
  COMPLEX :: fac1,fac2

  fac1=(-1.0d0,0.0d0)
  fac2=( 1.0d0,0.0d0)

  call matrix_mul(tmp, a(1,1,1,2), a(1,1,2,2), n)    !       B D^-1
  call nnzgemm(fac1,tmp,a(1,1,2,1),fac2,a(1,1,1,1),n)!   A - B D^-1 C
  call matrix_inv(a(1,1,1,1), n, det)                !  (A - B D^-1 C)^-1

!  fac1=(-1.0d0,0.0d0)
!  fac2=( 0.0d0,0.0d0)
!  call nnzgemm(fac1,a(1,1,1,1),tmp,fac2,a(1,1,1,2),n)! -(A - B D^-1 C)^-1 B D^-1

end
