! ---

program tc_bi_ortho

  BEGIN_DOC
  ! TODO : Put the documentation of the program here
  END_DOC

  implicit none

  print *, 'Hello world'

  my_grid_becke = .True.
  PROVIDE tc_grid1_a tc_grid1_r
  my_n_pt_r_grid = tc_grid1_r
  my_n_pt_a_grid = tc_grid1_a
  touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid

  read_wf = .True.
  touch read_wf

! call test_h_u0
! call test_slater_tc_opt
! call timing_tot
! call timing_diag
! call timing_single
! call timing_double

  call test_no()
  !call test_no_aba()
  !call test_no_aab()
  !call test_no_aaa()
end

subroutine test_h_u0
 implicit none
 double precision, allocatable :: v_0_ref(:),v_0_new(:),u_0(:), v_0_ref_dagger(:)
 double precision :: accu 
 logical :: do_right
 integer :: i
 allocate(v_0_new(N_det),v_0_ref(N_det),u_0(N_det),v_0_ref_dagger(N_det))
 do_right = .True.
 do i = 1, N_det
  u_0(i) = psi_r_coef_bi_ortho(i,1)
 enddo
 call H_tc_u_0_nstates_openmp(v_0_new,u_0,N_states,N_det, do_right)
 call htc_bi_ortho_calc_tdav_slow (v_0_ref,u_0,N_states,N_det)
 print*,'difference right '
 accu = 0.d0
 do i = 1, N_det
  print*,dabs(v_0_new(i) - v_0_ref(i)),v_0_new(i) , v_0_ref(i)
  accu += dabs(v_0_new(i) - v_0_ref(i))
 enddo
 print*,'accu = ',accu
 do_right = .False.
 v_0_new = 0.d0
 call H_tc_u_0_nstates_openmp(v_0_new,u_0,N_states,N_det, do_right)
 call htcdag_bi_ortho_calc_tdav_slow(v_0_ref_dagger,u_0,N_states,N_det, do_right)
 print*,'difference left'
 accu = 0.d0
 do i = 1, N_det
  print*,dabs(v_0_new(i) - v_0_ref_dagger(i)),v_0_new(i) , v_0_ref_dagger(i)
  accu += dabs(v_0_new(i) - v_0_ref_dagger(i))
 enddo
 print*,'accu = ',accu
end

subroutine test_slater_tc_opt
 implicit none
 integer :: i,j,degree
 double precision :: hmono, htwoe, htot, hthree 
 double precision :: hnewmono, hnewtwoe, hnewthree, hnewtot
 double precision :: accu_d ,i_count, accu
 accu = 0.d0
 accu_d = 0.d0
 i_count = 0.d0
 do i = 1, N_det
  do j = 1,N_det
   call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
   call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hnewmono, hnewtwoe, hnewthree, hnewtot)
   if(dabs(htot).gt.1.d-15)then
     i_count += 1.D0
     accu += dabs(htot-hnewtot) 
     if(dabs(htot-hnewtot).gt.1.d-8.or.dabs(htot-hnewtot).gt.dabs(htot))then
      call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
      print*,j,i,degree
      call debug_det(psi_det(1,1,i),N_int)
      call debug_det(psi_det(1,1,j),N_int)
      print*,htot,hnewtot,dabs(htot-hnewtot)
      print*,hthree,hnewthree,dabs(hthree-hnewthree)
      stop
     endif
   endif
  enddo
 enddo
 print*,'accu   = ',accu/i_count

end

subroutine timing_tot
 implicit none
 integer :: i,j
 double precision :: wall0, wall1
 double precision, allocatable :: mat_old(:,:),mat_new(:,:)
 double precision :: hmono, htwoe, hthree, htot, i_count
 integer :: degree 
 call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,2), N_int, hmono, htwoe, hthree, htot)
 call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,2), N_int, hmono, htwoe, hthree, htot)
 call wall_time(wall0)
 i_count = 0.d0
 do i = 1, N_det
  do j = 1, N_det
!   call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
   i_count += 1.d0
   call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
  enddo
 enddo
 call wall_time(wall1)
 print*,'i_count = ',i_count
 print*,'time for old hij for total   = ',wall1 - wall0

 call wall_time(wall0)
 i_count = 0.d0
 do i = 1, N_det
  do j = 1, N_det
!   call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
   i_count += 1.d0
   call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
  enddo
 enddo
 call wall_time(wall1)
 print*,'i_count = ',i_count
 print*,'time for new hij for total   = ',wall1 - wall0
 call i_H_j(psi_det(1,1,1), psi_det(1,1,2),N_int,htot)
 call wall_time(wall0)
 i_count = 0.d0
 do i = 1, N_det
  do j = 1, N_det
   call i_H_j(psi_det(1,1,j), psi_det(1,1,i),N_int,htot)
   i_count += 1.d0
  enddo
 enddo
 call wall_time(wall1)
 print*,'i_count = ',i_count
 print*,'time for new hij STANDARD    = ',wall1 - wall0

end

subroutine timing_diag
 implicit none
 integer :: i,j
 double precision :: wall0, wall1
 double precision, allocatable :: mat_old(:,:),mat_new(:,:)
 double precision :: hmono, htwoe, hthree, htot, i_count
 integer :: degree 
 call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
 call wall_time(wall0)
 i_count = 0.d0
 do i = 1, N_det
  do j = i,i 
   i_count += 1.d0
   call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
  enddo
 enddo
 call wall_time(wall1)
 print*,'i_count = ',i_count
 print*,'time for old hij for diagonal= ',wall1 - wall0

 call wall_time(wall0)
 i_count = 0.d0
 do i = 1, N_det
  do j = i,i
   i_count += 1.d0
   call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
  enddo
 enddo
 call wall_time(wall1)
 print*,'i_count = ',i_count
 print*,'time for new hij for diagonal= ',wall1 - wall0

end

subroutine timing_single
 implicit none
 integer :: i,j
 double precision :: wall0, wall1,accu
 double precision, allocatable :: mat_old(:,:),mat_new(:,:)
 double precision :: hmono, htwoe, hthree, htot, i_count
 integer :: degree 
 call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
 i_count = 0.d0
 accu = 0.d0
 do i = 1, N_det
  do j = 1, N_det
   call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
   if(degree.ne.1)cycle
   i_count += 1.d0
   call wall_time(wall0)
   call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
   call wall_time(wall1)
   accu += wall1 - wall0
  enddo
 enddo
 print*,'i_count = ',i_count
 print*,'time for old hij for singles = ',accu

 i_count = 0.d0
 accu = 0.d0
 do i = 1, N_det
  do j = 1, N_det
   call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
   if(degree.ne.1)cycle
   i_count += 1.d0
   call wall_time(wall0)
   call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
   call wall_time(wall1)
   accu += wall1 - wall0
  enddo
 enddo
 print*,'i_count = ',i_count
 print*,'time for new hij for singles = ',accu

end

subroutine timing_double
 implicit none
 integer :: i,j
 double precision :: wall0, wall1,accu
 double precision, allocatable :: mat_old(:,:),mat_new(:,:)
 double precision :: hmono, htwoe, hthree, htot, i_count
 integer :: degree 
 call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
 i_count = 0.d0
 accu = 0.d0
 do i = 1, N_det
  do j = 1, N_det
   call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
   if(degree.ne.2)cycle
   i_count += 1.d0
   call wall_time(wall0)
   call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
   call wall_time(wall1)
   accu += wall1 - wall0
  enddo
 enddo
 print*,'i_count = ',i_count
 print*,'time for old hij for doubles = ',accu

 i_count = 0.d0
 accu = 0.d0
 do i = 1, N_det
  do j = 1, N_det
   call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
   if(degree.ne.2)cycle
   i_count += 1.d0
   call wall_time(wall0)
   call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
   call wall_time(wall1)
   accu += wall1 - wall0
  enddo
 enddo
 call wall_time(wall1)
 print*,'i_count = ',i_count
 print*,'time for new hij for doubles = ',accu

end

! ---

subroutine test_no()

  implicit none
  integer          :: i, j, k, l
  double precision :: accu, contrib, new, ref, thr

  print*, ' testing normal_two_body_bi_orth ...'

  thr = 1d-8

  PROVIDE normal_two_body_bi_orth_old
  PROVIDE normal_two_body_bi_orth

  accu = 0.d0
  do i = 1, mo_num
    do j = 1, mo_num
      do k = 1, mo_num
        do l = 1, mo_num

          new = normal_two_body_bi_orth    (l,k,j,i)
          ref = normal_two_body_bi_orth_old(l,k,j,i)
          contrib = dabs(new - ref)
          accu += contrib
          if(contrib .gt. thr) then
            print*, ' problem on normal_two_body_bi_orth'
            print*, l, k, j, i
            print*, ref, new, contrib
            stop
          endif

        enddo
      enddo
    enddo
  enddo
  print*, ' accu on normal_two_body_bi_orth = ', accu / dble(mo_num)**4

 return
end

! ---

subroutine test_no_aba()

  implicit none
  integer          :: i, j, k, l
  double precision :: accu, contrib, new, ref, thr

  print*, ' testing no_aba_contraction ...'

  thr = 1d-8

  PROVIDE no_aba_contraction_v0
  PROVIDE no_aba_contraction

  accu = 0.d0
  do i = 1, mo_num
    do j = 1, mo_num
      do k = 1, mo_num
        do l = 1, mo_num

          new = no_aba_contraction   (l,k,j,i)
          ref = no_aba_contraction_v0(l,k,j,i)
          contrib = dabs(new - ref)
          accu += contrib
          if(contrib .gt. thr) then
            print*, ' problem on no_aba_contraction'
            print*, l, k, j, i
            print*, ref, new, contrib
            stop
          endif

        enddo
      enddo
    enddo
  enddo
  print*, ' accu on no_aba_contraction = ', accu / dble(mo_num)**4

 return
end

! ---


subroutine test_no_aab()

  implicit none
  integer          :: i, j, k, l
  double precision :: accu, contrib, new, ref, thr

  print*, ' testing no_aab_contraction ...'

  thr = 1d-8

  PROVIDE no_aab_contraction_v0
  PROVIDE no_aab_contraction

  accu = 0.d0
  do i = 1, mo_num
    do j = 1, mo_num
      do k = 1, mo_num
        do l = 1, mo_num

          new = no_aab_contraction   (l,k,j,i)
          ref = no_aab_contraction_v0(l,k,j,i)
          contrib = dabs(new - ref)
          accu += contrib
          if(contrib .gt. thr) then
            print*, ' problem on no_aab_contraction'
            print*, l, k, j, i
            print*, ref, new, contrib
            stop
          endif

        enddo
      enddo
    enddo
  enddo
  print*, ' accu on no_aab_contraction = ', accu / dble(mo_num)**4

 return
end

! ---

subroutine test_no_aaa()

  implicit none
  integer          :: i, j, k, l
  double precision :: accu, contrib, new, ref, thr

  print*, ' testing no_aaa_contraction ...'

  thr = 1d-8

  PROVIDE no_aaa_contraction_v0
  PROVIDE no_aaa_contraction

  accu = 0.d0
  do i = 1, mo_num
    do j = 1, mo_num
      do k = 1, mo_num
        do l = 1, mo_num

          new = no_aaa_contraction   (l,k,j,i)
          ref = no_aaa_contraction_v0(l,k,j,i)
          contrib = dabs(new - ref)
          accu += contrib
          if(contrib .gt. thr) then
            print*, ' problem on no_aaa_contraction'
            print*, l, k, j, i
            print*, ref, new, contrib
            stop
          endif

        enddo
      enddo
    enddo
  enddo
  print*, ' accu on no_aaa_contraction = ', accu / dble(mo_num)**4

 return
end

! ---