9
1
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-10-04 15:15:58 +02:00

added fci_tc and cipsi_tc_bi_ortho

This commit is contained in:
eginer 2023-02-07 17:28:11 +01:00
parent 80b66dee79
commit b258a2f154
40 changed files with 8201 additions and 0 deletions

View File

@ -0,0 +1,36 @@
[save_wf_after_selection]
type: logical
doc: If true, saves the wave function after the selection, before the diagonalization
interface: ezfio,provider,ocaml
default: False
[seniority_max]
type: integer
doc: Maximum number of allowed open shells. Using -1 selects all determinants
interface: ezfio,ocaml,provider
default: -1
[excitation_ref]
type: integer
doc: 1: Hartree-Fock determinant, 2:All determinants of the dominant configuration
interface: ezfio,ocaml,provider
default: 1
[excitation_max]
type: integer
doc: Maximum number of excitation with respect to the Hartree-Fock determinant. Using -1 selects all determinants
interface: ezfio,ocaml,provider
default: -1
[excitation_alpha_max]
type: integer
doc: Maximum number of excitation for alpha determinants with respect to the Hartree-Fock determinant. Using -1 selects all determinants
interface: ezfio,ocaml,provider
default: -1
[excitation_beta_max]
type: integer
doc: Maximum number of excitation for beta determinants with respect to the Hartree-Fock determinant. Using -1 selects all determinants
interface: ezfio,ocaml,provider
default: -1

View File

@ -0,0 +1,6 @@
mpi
perturbation
zmq
iterations_tc
csf
tc_bi_ortho

View File

@ -0,0 +1,136 @@
subroutine run_cipsi
BEGIN_DOC
! Selected Full Configuration Interaction with deterministic selection and
! stochastic PT2.
END_DOC
use selection_types
implicit none
integer :: i,j,k,ndet
type(pt2_type) :: pt2_data, pt2_data_err
double precision, allocatable :: zeros(:)
integer :: to_select
logical, external :: qp_stop
double precision :: threshold_generators_save
double precision :: rss
double precision, external :: memory_of_double
double precision :: correlation_energy_ratio,E_denom,E_tc,norm
PROVIDE H_apply_buffer_allocated distributed_davidson
print*,'Diagonal elements of the Fock matrix '
do i = 1, mo_num
write(*,*)i,Fock_matrix_tc_mo_tot(i,i)
enddo
N_iter = 1
threshold_generators = 1.d0
SOFT_TOUCH threshold_generators
rss = memory_of_double(N_states)*4.d0
call check_mem(rss,irp_here)
allocate (zeros(N_states))
call pt2_alloc(pt2_data, N_states)
call pt2_alloc(pt2_data_err, N_states)
double precision :: hf_energy_ref
logical :: has, print_pt2
double precision :: relative_error
relative_error=PT2_relative_error
zeros = 0.d0
pt2_data % pt2 = -huge(1.e0)
pt2_data % rpt2 = -huge(1.e0)
pt2_data % overlap(:,:) = 0.d0
pt2_data % variance = huge(1.e0)
if (s2_eig) then
call make_s2_eigenfunction
endif
print_pt2 = .False.
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
call ezfio_has_hartree_fock_energy(has)
if (has) then
call ezfio_get_hartree_fock_energy(hf_energy_ref)
else
hf_energy_ref = ref_bitmask_energy
endif
if (N_det > N_det_max) then
psi_det(1:N_int,1:2,1:N_det) = psi_det_sorted_tc_gen(1:N_int,1:2,1:N_det)
psi_coef(1:N_det,1:N_states) = psi_coef_sorted_tc_gen(1:N_det,1:N_states)
N_det = N_det_max
soft_touch N_det psi_det psi_coef
if (s2_eig) then
call make_s2_eigenfunction
endif
print_pt2 = .False.
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
! call routine_save_right
endif
correlation_energy_ratio = 0.d0
print_pt2 = .True.
do while ( &
(N_det < N_det_max) .and. &
(maxval(abs(pt2_data % pt2(1:N_states))) > pt2_max) &
)
write(*,'(A)') '--------------------------------------------------------------------------------'
to_select = int(sqrt(dble(N_states))*dble(N_det)*selection_factor)
to_select = max(N_states_diag, to_select)
E_denom = E_tc ! TC Energy of the current wave function
if (do_pt2) then
call pt2_dealloc(pt2_data)
call pt2_dealloc(pt2_data_err)
call pt2_alloc(pt2_data, N_states)
call pt2_alloc(pt2_data_err, N_states)
threshold_generators_save = threshold_generators
threshold_generators = 1.d0
SOFT_TOUCH threshold_generators
call ZMQ_pt2(E_denom, pt2_data, pt2_data_err, relative_error,to_select) ! Stochastic PT2 and selection
threshold_generators = threshold_generators_save
SOFT_TOUCH threshold_generators
else
call pt2_dealloc(pt2_data)
call pt2_alloc(pt2_data, N_states)
call ZMQ_selection(to_select, pt2_data)
endif
N_iter += 1
if (qp_stop()) exit
! Add selected determinants
call copy_H_apply_buffer_to_wf()
if (save_wf_after_selection) then
call save_wavefunction
endif
PROVIDE psi_coef
PROVIDE psi_det
PROVIDE psi_det_sorted_tc
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
if (qp_stop()) exit
enddo
call pt2_dealloc(pt2_data)
call pt2_dealloc(pt2_data_err)
call pt2_alloc(pt2_data, N_states)
call pt2_alloc(pt2_data_err, N_states)
call ZMQ_pt2(E_tc, pt2_data, pt2_data_err, relative_error,0) ! Stochastic PT2 and selection
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
end

View File

@ -0,0 +1,51 @@
BEGIN_PROVIDER [ logical, initialize_pt2_E0_denominator ]
implicit none
BEGIN_DOC
! If true, initialize pt2_E0_denominator
END_DOC
initialize_pt2_E0_denominator = .True.
END_PROVIDER
BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ]
implicit none
BEGIN_DOC
! E0 in the denominator of the PT2
END_DOC
integer :: i,j
pt2_E0_denominator = eigval_right_tc_bi_orth
! if (initialize_pt2_E0_denominator) then
! if (h0_type == "EN") then
! pt2_E0_denominator(1:N_states) = psi_energy(1:N_states)
! else if (h0_type == "HF") then
! do i=1,N_states
! j = maxloc(abs(psi_coef(:,i)),1)
! pt2_E0_denominator(i) = psi_det_hii(j)
! enddo
! else if (h0_type == "Barycentric") then
! pt2_E0_denominator(1:N_states) = barycentric_electronic_energy(1:N_states)
! else if (h0_type == "CFG") then
! pt2_E0_denominator(1:N_states) = psi_energy(1:N_states)
! else
! print *, h0_type, ' not implemented'
! stop
! endif
! do i=1,N_states
! call write_double(6,pt2_E0_denominator(i)+nuclear_repulsion, 'PT2 Energy denominator')
! enddo
! else
! pt2_E0_denominator = -huge(1.d0)
! endif
END_PROVIDER
BEGIN_PROVIDER [ double precision, pt2_overlap, (N_states, N_states) ]
implicit none
BEGIN_DOC
! Overlap between the perturbed wave functions
END_DOC
pt2_overlap(1:N_states,1:N_states) = 0.d0
END_PROVIDER

View File

@ -0,0 +1,14 @@
BEGIN_PROVIDER [ integer, nthreads_pt2 ]
implicit none
BEGIN_DOC
! Number of threads for Davidson
END_DOC
nthreads_pt2 = nproc
character*(32) :: env
call getenv('QP_NTHREADS_PT2',env)
if (trim(env) /= '') then
read(env,*) nthreads_pt2
call write_int(6,nthreads_pt2,'Target number of threads for PT2')
endif
END_PROVIDER

View File

@ -0,0 +1,95 @@
subroutine build_fock_tmp_tc(fock_diag_tmp,det_ref,Nint)
use bitmasks
implicit none
BEGIN_DOC
! Build the diagonal of the Fock matrix corresponding to a generator
! determinant. $F_{00}$ is $\langle i|H|i \rangle = E_0$.
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: det_ref(Nint,2)
double precision, intent(out) :: fock_diag_tmp(2,mo_num+1)
integer :: occ(Nint*bit_kind_size,2)
integer :: ne(2), i, j, ii, jj
double precision :: E0
! Compute Fock matrix diagonal elements
call bitstring_to_list_ab(det_ref,occ,Ne,Nint)
fock_diag_tmp = 0.d0
E0 = 0.d0
if (Ne(1) /= elec_alpha_num) then
print *, 'Error in build_fock_tmp_tc (alpha)', Ne(1), Ne(2)
call debug_det(det_ref,N_int)
stop -1
endif
if (Ne(2) /= elec_beta_num) then
print *, 'Error in build_fock_tmp_tc (beta)', Ne(1), Ne(2)
call debug_det(det_ref,N_int)
stop -1
endif
! Occupied MOs
do ii=1,elec_alpha_num
i = occ(ii,1)
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_one_e_integrals(i,i)
E0 = E0 + mo_one_e_integrals(i,i)
do jj=1,elec_alpha_num
j = occ(jj,1)
if (i==j) cycle
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_two_e_integrals_jj_anti(i,j)
E0 = E0 + 0.5d0*mo_two_e_integrals_jj_anti(i,j)
enddo
do jj=1,elec_beta_num
j = occ(jj,2)
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_two_e_integrals_jj(i,j)
E0 = E0 + mo_two_e_integrals_jj(i,j)
enddo
enddo
do ii=1,elec_beta_num
i = occ(ii,2)
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_one_e_integrals(i,i)
E0 = E0 + mo_one_e_integrals(i,i)
do jj=1,elec_beta_num
j = occ(jj,2)
if (i==j) cycle
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_two_e_integrals_jj_anti(i,j)
E0 = E0 + 0.5d0*mo_two_e_integrals_jj_anti(i,j)
enddo
do jj=1,elec_alpha_num
j = occ(jj,1)
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_two_e_integrals_jj(i,j)
enddo
enddo
! Virtual MOs
do i=1,mo_num
if (fock_diag_tmp(1,i) /= 0.d0) cycle
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_one_e_integrals(i,i)
do jj=1,elec_alpha_num
j = occ(jj,1)
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_two_e_integrals_jj_anti(i,j)
enddo
do jj=1,elec_beta_num
j = occ(jj,2)
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_two_e_integrals_jj(i,j)
enddo
enddo
do i=1,mo_num
if (fock_diag_tmp(2,i) /= 0.d0) cycle
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_one_e_integrals(i,i)
do jj=1,elec_beta_num
j = occ(jj,2)
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_two_e_integrals_jj_anti(i,j)
enddo
do jj=1,elec_alpha_num
j = occ(jj,1)
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_two_e_integrals_jj(i,j)
enddo
enddo
fock_diag_tmp(1,mo_num+1) = E0
fock_diag_tmp(2,mo_num+1) = E0
end

File diff suppressed because it is too large Load Diff

View File

@ -0,0 +1,139 @@
subroutine get_d0_new(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs)
!todo: indices/conjg should be okay for complex
use bitmasks
implicit none
integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
integer(bit_kind), intent(in) :: phasemask(N_int,2)
logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
integer(bit_kind) :: det(N_int, 2)
double precision, intent(in) :: coefs(N_states,2)
double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num)
double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num)
integer, intent(in) :: h(0:2,2), p(0:4,2), sp
integer :: i, j, k, s, h1, h2, p1, p2, puti, putj, mm
double precision :: phase
double precision :: hij,hji
double precision, external :: get_phase_bi
logical :: ok
integer, parameter :: bant=1
double precision, allocatable :: hij_cache1(:), hij_cache2(:)
allocate (hij_cache1(mo_num),hij_cache2(mo_num))
double precision, allocatable :: hji_cache1(:), hji_cache2(:)
allocate (hji_cache1(mo_num),hji_cache2(mo_num))
! print*,'in get_d0_new'
! call debug_det(gen,N_int)
! print*,'coefs',coefs(1,:)
if(sp == 3) then ! AB
h1 = p(1,1)
h2 = p(1,2)
do p1=1, mo_num
if(bannedOrb(p1, 1)) cycle
! call get_mo_two_e_integrals_complex(p1,h2,h1,mo_num,hij_cache1,mo_integrals_map)
do mm = 1, mo_num
hij_cache1(mm) = mo_bi_ortho_tc_two_e(mm,p1,h2,h1)
hji_cache1(mm) = mo_bi_ortho_tc_two_e(h2,h1,mm,p1)
enddo
!!!!!!!!!! <alpha|H|psi>
do p2=1, mo_num
if(bannedOrb(p2,2)) cycle
if(banned(p1, p2, bant)) cycle ! rentable?
if(p1 == h1 .or. p2 == h2) then
call apply_particles(mask, 1,p1,2,p2, det, ok, N_int)
! call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this
! call i_h_j_complex(det, gen, N_int, hij)
call htilde_mu_mat_opt_bi_ortho_no_3e(det,gen,N_int, hij)
else
phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
hij = hij_cache1(p2) * phase
end if
if (hij == (0.d0,0.d0)) cycle
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,1) * hij ! HOTSPOT
enddo
end do
!!!!!!!!!! <phi|H|alpha>
do p2=1, mo_num
if(bannedOrb(p2,2)) cycle
if(banned(p1, p2, bant)) cycle ! rentable?
if(p1 == h1 .or. p2 == h2) then
call apply_particles(mask, 1,p1,2,p2, det, ok, N_int)
! call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this
! call i_h_j_complex(det, gen, N_int, hij)
call htilde_mu_mat_opt_bi_ortho_no_3e(gen,det,N_int, hji)
else
phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
hji = hji_cache1(p2) * phase
end if
if (hji == (0.d0,0.d0)) cycle
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_l(k, p1, p2) = mat_l(k, p1, p2) + coefs(k,2) * hji ! HOTSPOT
enddo
end do
end do
else ! AA BB
p1 = p(1,sp)
p2 = p(2,sp)
do puti=1, mo_num
if(bannedOrb(puti, sp)) cycle
! call get_mo_two_e_integrals_complex(puti,p2,p1,mo_num,hij_cache1,mo_integrals_map,mo_integrals_map_2)
! call get_mo_two_e_integrals_complex(puti,p1,p2,mo_num,hij_cache2,mo_integrals_map,mo_integrals_map_2)
do mm = 1, mo_num
hij_cache1(mm) = mo_bi_ortho_tc_two_e(mm,puti,p2,p1)
hij_cache2(mm) = mo_bi_ortho_tc_two_e(mm,puti,p1,p2)
hji_cache1(mm) = mo_bi_ortho_tc_two_e(p2,p1,mm,puti)
hji_cache2(mm) = mo_bi_ortho_tc_two_e(p1,p2,mm,puti)
enddo
!!!!!!!!!! <alpha|H|psi>
do putj=puti+1, mo_num
if(bannedOrb(putj, sp)) cycle
if(banned(puti, putj, bant)) cycle ! rentable?
if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then
call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int)
!call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this
! call i_h_j_complex(det, gen, N_int, hij)
call htilde_mu_mat_opt_bi_ortho_no_3e(det,gen,N_int, hij)
if (hij == 0.d0) cycle
else
! hij = (mo_two_e_integral_complex(p1, p2, puti, putj) - mo_two_e_integral_complex(p2, p1, puti, putj))
! hij = (mo_bi_ortho_tc_two_e(p1, p2, puti, putj) - mo_bi_ortho_tc_two_e(p2, p1, puti, putj))
hij = (mo_bi_ortho_tc_two_e(puti, putj, p1, p2) - mo_bi_ortho_tc_two_e(puti, putj, p2, p1))
if (hij == 0.d0) cycle
hij = (hij) * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int)
end if
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,1) * hij
enddo
end do
!!!!!!!!!! <phi|H|alpha>
do putj=puti+1, mo_num
if(bannedOrb(putj, sp)) cycle
if(banned(puti, putj, bant)) cycle ! rentable?
if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then
call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int)
call htilde_mu_mat_opt_bi_ortho_no_3e(gen,det,N_int, hji)
if (hji == 0.d0) cycle
else
hji = (mo_bi_ortho_tc_two_e( p1, p2, puti, putj) - mo_bi_ortho_tc_two_e( p2, p1, puti, putj))
if (hji == 0.d0) cycle
hji = (hji) * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int)
end if
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,2) * hji
enddo
end do
end do
end if
deallocate(hij_cache1,hij_cache2)
end

View File

@ -0,0 +1,454 @@
subroutine get_d1_new(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs)
!todo: indices should be okay for complex?
use bitmasks
implicit none
integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2)
integer(bit_kind), intent(in) :: phasemask(N_int,2)
logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
integer(bit_kind) :: det(N_int, 2)
double precision, intent(in) :: coefs(N_states,2)
double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num)
double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num)
integer, intent(in) :: h(0:2,2), p(0:4,2), sp
double precision, external :: get_phase_bi
double precision, external :: mo_two_e_integral_complex
logical :: ok
logical, allocatable :: lbanned(:,:)
integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j
integer :: hfix, pfix, h1, h2, p1, p2, ib, k, l, mm
integer, parameter :: turn2(2) = (/2,1/)
integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
integer :: bant
double precision, allocatable :: hij_cache(:,:)
double precision :: hij, tmp_rowij(N_states, mo_num), tmp_rowij2(N_states, mo_num)
double precision, allocatable :: hji_cache(:,:)
double precision :: hji, tmp_rowji(N_states, mo_num), tmp_rowji2(N_states, mo_num)
! PROVIDE mo_integrals_map N_int
! print*,'in get_d1_new'
! call debug_det(gen,N_int)
! print*,'coefs',coefs(1,:)
allocate (lbanned(mo_num, 2))
allocate (hij_cache(mo_num,2))
allocate (hji_cache(mo_num,2))
lbanned = bannedOrb
do i=1, p(0,1)
lbanned(p(i,1), 1) = .true.
end do
do i=1, p(0,2)
lbanned(p(i,2), 2) = .true.
end do
ma = 1
if(p(0,2) >= 2) ma = 2
mi = turn2(ma)
bant = 1
if(sp == 3) then
!move MA
if(ma == 2) bant = 2
puti = p(1,mi)
hfix = h(1,ma)
p1 = p(1,ma)
p2 = p(2,ma)
if(.not. bannedOrb(puti, mi)) then
! call get_mo_two_e_integrals_complex(hfix,p1,p2,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
! call get_mo_two_e_integrals_complex(hfix,p2,p1,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
do mm = 1, mo_num
hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,p2)
hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,p1)
hji_cache(mm,1) = mo_bi_ortho_tc_two_e(p1,p2,mm,hfix)
hji_cache(mm,2) = mo_bi_ortho_tc_two_e(p2,p1,mm,hfix)
enddo
!! <alpha|H|psi>
tmp_rowij = 0.d0
do putj=1, hfix-1
if(lbanned(putj, ma)) cycle
if(banned(putj, puti,bant)) cycle
hij = hij_cache(putj,1) - hij_cache(putj,2)
if (hij /= 0.d0) then
hij = hij * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
tmp_rowij(k,putj) = tmp_rowij(k,putj) + hij * coefs(k,1)
enddo
endif
end do
do putj=hfix+1, mo_num
if(lbanned(putj, ma)) cycle
if(banned(putj, puti,bant)) cycle
hij = hij_cache(putj,2) - hij_cache(putj,1)
if (hij /= 0.d0) then
hij = hij * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
tmp_rowij(k,putj) = tmp_rowij(k,putj) + hij * coefs(k,1)
enddo
endif
end do
if(ma == 1) then
mat_r(1:N_states,1:mo_num,puti) = mat_r(1:N_states,1:mo_num,puti) + tmp_rowij(1:N_states,1:mo_num)
else
do l=1,mo_num
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_r(k,puti,l) = mat_r(k,puti,l) + tmp_rowij(k,l)
enddo
enddo
end if
!! <phi|H|alpha>
tmp_rowji = 0.d0
do putj=1, hfix-1
if(lbanned(putj, ma)) cycle
if(banned(putj, puti,bant)) cycle
hji = hji_cache(putj,1) - hji_cache(putj,2)
if (hji /= 0.d0) then
hji = hji * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
tmp_rowji(k,putj) = tmp_rowji(k,putj) + hji * coefs(k,2)
enddo
endif
end do
do putj=hfix+1, mo_num
if(lbanned(putj, ma)) cycle
if(banned(putj, puti,bant)) cycle
hji = hji_cache(putj,2) - hji_cache(putj,1)
if (hji /= 0.d0) then
hji = hji * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
tmp_rowji(k,putj) = tmp_rowji(k,putj) + hji * coefs(k,2)
enddo
endif
end do
if(ma == 1) then
mat_l(1:N_states,1:mo_num,puti) = mat_l(1:N_states,1:mo_num,puti) + tmp_rowji(1:N_states,1:mo_num)
else
do l=1,mo_num
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_l(k,puti,l) = mat_l(k,puti,l) + tmp_rowji(k,l)
enddo
enddo
end if
end if
!MOVE MI
pfix = p(1,mi)
tmp_rowij = 0.d0
tmp_rowij2 = 0.d0
tmp_rowji = 0.d0
tmp_rowji2 = 0.d0
! call get_mo_two_e_integrals_complex(hfix,pfix,p1,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
! call get_mo_two_e_integrals_complex(hfix,pfix,p2,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
do mm = 1, mo_num
hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,pfix,p1)
hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,pfix,p2)
hji_cache(mm,1) = mo_bi_ortho_tc_two_e(pfix,p1,mm,hfix)
hji_cache(mm,2) = mo_bi_ortho_tc_two_e(pfix,p2,mm,hfix)
enddo
putj = p1
!! <alpha|H|psi>
do puti=1,mo_num !HOT
if(lbanned(puti,mi)) cycle
!p1 fixed
putj = p1
if(.not. banned(putj,puti,bant)) then
hij = hij_cache(puti,2)
if (hij /= 0.d0) then
hij = hij * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix, N_int)
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
tmp_rowij(k,puti) = tmp_rowij(k,puti) + hij * coefs(k,1)
enddo
endif
end if
!
putj = p2
if(.not. banned(putj,puti,bant)) then
hij = hij_cache(puti,1)
if (hij /= 0.d0) then
hij = hij * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix, N_int)
do k=1,N_states
tmp_rowij2(k,puti) = tmp_rowij2(k,puti) + hij * coefs(k,1)
enddo
endif
end if
end do
if(mi == 1) then
mat_r(:,:,p1) = mat_r(:,:,p1) + tmp_rowij(:,:)
mat_r(:,:,p2) = mat_r(:,:,p2) + tmp_rowij2(:,:)
else
do l=1,mo_num
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_r(k,p1,l) = mat_r(k,p1,l) + tmp_rowij(k,l)
mat_r(k,p2,l) = mat_r(k,p2,l) + tmp_rowij2(k,l)
enddo
enddo
end if
putj = p1
!! <phi|H|alpha>
do puti=1,mo_num !HOT
if(lbanned(puti,mi)) cycle
!p1 fixed
putj = p1
if(.not. banned(putj,puti,bant)) then
hji = hji_cache(puti,2)
if (hji /= 0.d0) then
hji = hji * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix, N_int)
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
tmp_rowji(k,puti) = tmp_rowji(k,puti) + hji * coefs(k,2)
enddo
endif
end if
!
putj = p2
if(.not. banned(putj,puti,bant)) then
hji = hji_cache(puti,1)
if (hji /= 0.d0) then
hji = hji * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix, N_int)
do k=1,N_states
tmp_rowji2(k,puti) = tmp_rowji2(k,puti) + hji * coefs(k,2)
enddo
endif
end if
end do
if(mi == 1) then
mat_l(:,:,p1) = mat_l(:,:,p1) + tmp_rowji(:,:)
mat_l(:,:,p2) = mat_l(:,:,p2) + tmp_rowji2(:,:)
else
do l=1,mo_num
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_l(k,p1,l) = mat_l(k,p1,l) + tmp_rowji(k,l)
mat_l(k,p2,l) = mat_l(k,p2,l) + tmp_rowji2(k,l)
enddo
enddo
end if
else ! sp /= 3
if(p(0,ma) == 3) then
do i=1,3
hfix = h(1,ma)
puti = p(i, ma)
p1 = p(turn3(1,i), ma)
p2 = p(turn3(2,i), ma)
! call get_mo_two_e_integrals_complex(hfix,p1,p2,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
! call get_mo_two_e_integrals_complex(hfix,p2,p1,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
do mm = 1, mo_num
hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,p2)
hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,p1)
hji_cache(mm,1) = mo_bi_ortho_tc_two_e(p1,p2,mm,hfix)
hji_cache(mm,2) = mo_bi_ortho_tc_two_e(p2,p1,mm,hfix)
enddo
!! <alpha|H|psi>
tmp_rowij = 0.d0
do putj=1,hfix-1
if(banned(putj,puti,1)) cycle
if(lbanned(putj,ma)) cycle
hij = hij_cache(putj,1) - hij_cache(putj,2)
if (hij /= 0.d0) then
hij = hij * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
tmp_rowij(:,putj) = tmp_rowij(:,putj) + hij * coefs(:,1)
endif
end do
do putj=hfix+1,mo_num
if(banned(putj,puti,1)) cycle
if(lbanned(putj,ma)) cycle
hij = hij_cache(putj,2) - hij_cache(putj,1)
if (hij /= 0.d0) then
hij = hij * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
tmp_rowij(:,putj) = tmp_rowij(:,putj) + hij * coefs(:,1)
endif
end do
mat_r(:, :puti-1, puti) = mat_r(:, :puti-1, puti) + tmp_rowij(:,:puti-1)
do l=puti,mo_num
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_r(k, puti, l) = mat_r(k, puti,l) + tmp_rowij(k,l)
enddo
enddo
!! <phi|H|alpha>
tmp_rowji = 0.d0
do putj=1,hfix-1
if(banned(putj,puti,1)) cycle
if(lbanned(putj,ma)) cycle
hji = hji_cache(putj,1) - hji_cache(putj,2)
if (hji /= 0.d0) then
hji = hji * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
tmp_rowji(:,putj) = tmp_rowji(:,putj) + hji * coefs(:,2)
endif
end do
do putj=hfix+1,mo_num
if(banned(putj,puti,1)) cycle
if(lbanned(putj,ma)) cycle
hji = hji_cache(putj,2) - hji_cache(putj,1)
if (hji /= 0.d0) then
hji = hji * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
tmp_rowji(:,putj) = tmp_rowji(:,putj) + hji * coefs(:,2)
endif
end do
mat_l(:, :puti-1, puti) = mat_l(:, :puti-1, puti) + tmp_rowji(:,:puti-1)
do l=puti,mo_num
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_l(k, puti, l) = mat_l(k, puti,l) + tmp_rowji(k,l)
enddo
enddo
end do
else
hfix = h(1,mi)
pfix = p(1,mi)
p1 = p(1,ma)
p2 = p(2,ma)
tmp_rowij = 0.d0
tmp_rowij2 = 0.d0
tmp_rowji = 0.d0
tmp_rowji2 = 0.d0
! call get_mo_two_e_integrals_complex(hfix,p1,pfix,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
! call get_mo_two_e_integrals_complex(hfix,p2,pfix,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
do mm = 1, mo_num
hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,pfix)
hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,pfix)
hji_cache(mm,1) = mo_bi_ortho_tc_two_e(p1,pfix,mm,hfix)
hji_cache(mm,2) = mo_bi_ortho_tc_two_e(p2,pfix,mm,hfix)
enddo
putj = p2
!! <alpha|H|psi>
do puti=1,mo_num
if(lbanned(puti,ma)) cycle
putj = p2
if(.not. banned(puti,putj,1)) then
hij = hij_cache(puti,1)
if (hij /= 0.d0) then
hij = hij * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1, N_int)
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
tmp_rowij(k,puti) = tmp_rowij(k,puti) + hij * coefs(k,1)
enddo
endif
end if
putj = p1
if(.not. banned(puti,putj,1)) then
hij = hij_cache(puti,2)
if (hij /= 0.d0) then
hij = hij * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2, N_int)
do k=1,N_states
tmp_rowij2(k,puti) = tmp_rowij2(k,puti) + hij * coefs(k,1)
enddo
endif
end if
end do
mat_r(:,:p2-1,p2) = mat_r(:,:p2-1,p2) + tmp_rowij(:,:p2-1)
do l=p2,mo_num
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_r(k,p2,l) = mat_r(k,p2,l) + tmp_rowij(k,l)
enddo
enddo
mat_r(:,:p1-1,p1) = mat_r(:,:p1-1,p1) + tmp_rowij2(:,:p1-1)
do l=p1,mo_num
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_r(k,p1,l) = mat_r(k,p1,l) + tmp_rowij2(k,l)
enddo
enddo
!! <phi|H|alpha>
putj = p2
do puti=1,mo_num
if(lbanned(puti,ma)) cycle
putj = p2
if(.not. banned(puti,putj,1)) then
hji = hji_cache(puti,1)
if (hji /= 0.d0) then
hji = hji * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1, N_int)
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
tmp_rowji(k,puti) = tmp_rowji(k,puti) + hji * coefs(k,2)
enddo
endif
end if
putj = p1
if(.not. banned(puti,putj,1)) then
hji = hji_cache(puti,2)
if (hji /= 0.d0) then
hji = hji * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2, N_int)
do k=1,N_states
tmp_rowji2(k,puti) = tmp_rowji2(k,puti) + hji * coefs(k,2)
enddo
endif
end if
end do
mat_l(:,:p2-1,p2) = mat_l(:,:p2-1,p2) + tmp_rowji(:,:p2-1)
do l=p2,mo_num
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_l(k,p2,l) = mat_l(k,p2,l) + tmp_rowji(k,l)
enddo
enddo
mat_l(:,:p1-1,p1) = mat_l(:,:p1-1,p1) + tmp_rowji2(:,:p1-1)
do l=p1,mo_num
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_l(k,p1,l) = mat_l(k,p1,l) + tmp_rowji2(k,l)
enddo
enddo
end if
end if
deallocate(lbanned,hij_cache, hji_cache)
!! MONO
if(sp == 3) then
s1 = 1
s2 = 2
else
s1 = sp
s2 = sp
end if
do i1=1,p(0,s1)
ib = 1
if(s1 == s2) ib = i1+1
do i2=ib,p(0,s2)
p1 = p(i1,s1)
p2 = p(i2,s2)
if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle
call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
! gen is a selector; mask is ionized generator; det is alpha
! hij is contribution to <psi|H|alpha>
! call i_h_j_complex(gen, det, N_int, hij)
call htilde_mu_mat_opt_bi_ortho_no_3e(det, gen, N_int, hij)
call htilde_mu_mat_opt_bi_ortho_no_3e(gen, det, N_int, hji)
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
! take conjugate to get contribution to <alpha|H|psi> instead of <psi|H|alpha>
! mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,1) * dconjg(hij)
mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,1) * hij
mat_l(k, p1, p2) = mat_l(k, p1, p2) + coefs(k,2) * hji
enddo
end do
end do
end

View File

@ -0,0 +1,308 @@
subroutine get_d2_new(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs)
!todo: indices/conjg should be correct for complex
use bitmasks
implicit none
integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2)
integer(bit_kind), intent(in) :: phasemask(N_int,2)
logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
double precision, intent(in) :: coefs(N_states,2)
double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num)
double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num)
integer, intent(in) :: h(0:2,2), p(0:4,2), sp
double precision, external :: get_phase_bi
integer :: i, j, k, tip, ma, mi, puti, putj
integer :: h1, h2, p1, p2, i1, i2
double precision :: phase
double precision :: hij,hji
integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/))
integer, parameter :: turn2(2) = (/2, 1/)
integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
integer :: bant
bant = 1
! print*, 'in get_d2_new'
! call debug_det(gen,N_int)
! print*,'coefs',coefs(1,:)
tip = p(0,1) * p(0,2) ! number of alpha particles times number of beta particles
ma = sp !1:(alpha,alpha); 2:(b,b); 3:(a,b)
if(p(0,1) > p(0,2)) ma = 1 ! more alpha particles than beta particles
if(p(0,1) < p(0,2)) ma = 2 ! fewer alpha particles than beta particles
mi = mod(ma, 2) + 1
if(sp == 3) then ! if one alpha and one beta xhole
!(where xholes refer to the ionizations from the generator, not the holes occupied in the ionized generator)
if(ma == 2) bant = 2 ! if more beta particles than alpha particles
if(tip == 3) then ! if 3 of one particle spin and 1 of the other particle spin
puti = p(1, mi)
if(bannedOrb(puti, mi)) return
h1 = h(1, ma)
h2 = h(2, ma)
!! <alpha|H|psi>
do i = 1, 3 ! loop over all 3 combinations of 2 particles with spin ma
putj = p(i, ma)
if(banned(putj,puti,bant)) cycle
i1 = turn3(1,i)
i2 = turn3(2,i)
p1 = p(i1, ma)
p2 = p(i2, ma)
! |G> = |psi_{gen,i}>
! |G'> = a_{x1} a_{x2} |G>
! |alpha> = a_{puti}^{\dagger} a_{putj}^{\dagger} |G'>
! |alpha> = t_{x1,x2}^{puti,putj} |G>
! hij = <psi_{selectors,i}|H|alpha>
! |alpha> = t_{p1,p2}^{h1,h2}|psi_{selectors,i}>
!todo: <i|H|j> = (<h1,h2|p1,p2> - <h1,h2|p2,p1>) * phase
! <psi|H|j> += dconjg(c_i) * <i|H|j>
! <j|H|i> = (<p1,p2|h1,h2> - <p2,p1|h1,h2>) * phase
! <j|H|psi> += <j|H|i> * c_i
! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2, p1, h1, h2)
!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
! take the transpose of what's written above because later use the complex conjugate
hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2) - mo_bi_ortho_tc_two_e( h1, h2, p2, p1)
if (hij == 0.d0) cycle
! take conjugate to get contribution to <alpha|H|psi> instead of <psi|H|alpha>
! hij = dconjg(hij) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
hij = hij * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
if(ma == 1) then ! if particle spins are (alpha,alpha,alpha,beta), then puti is beta and putj is alpha
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_r(k, putj, puti) = mat_r(k, putj, puti) + coefs(k,1) * hij
enddo
else ! if particle spins are (beta,beta,beta,alpha), then puti is alpha and putj is beta
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,1) * hij
enddo
end if
end do
!! <phi|H|alpha>
do i = 1, 3 ! loop over all 3 combinations of 2 particles with spin ma
putj = p(i, ma)
if(banned(putj,puti,bant)) cycle
i1 = turn3(1,i)
i2 = turn3(2,i)
p1 = p(i1, ma)
p2 = p(i2, ma)
hji = mo_bi_ortho_tc_two_e(p1, p2,h1, h2) - mo_bi_ortho_tc_two_e( p2, p1, h1, h2)
if (hji == 0.d0) cycle
hji = hji * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
if(ma == 1) then ! if particle spins are (alpha,alpha,alpha,beta), then puti is beta and putj is alpha
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_l(k, putj, puti) = mat_l(k, putj, puti) + coefs(k,2) * hji
enddo
else ! if particle spins are (beta,beta,beta,alpha), then puti is alpha and putj is beta
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,2) * hji
enddo
end if
end do
else ! if 2 alpha and 2 beta particles
h1 = h(1,1)
h2 = h(1,2)
!! <alpha|H|psi>
do j = 1,2 ! loop over all 4 combinations of one alpha and one beta particle
putj = p(j, 2)
if(bannedOrb(putj, 2)) cycle
p2 = p(turn2(j), 2)
do i = 1,2
puti = p(i, 1)
if(banned(puti,putj,bant) .or. bannedOrb(puti,1)) cycle
p1 = p(turn2(i), 1)
! hij = <psi_{selectors,i}|H|alpha>
! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2)
!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
! take the transpose of what's written above because later use the complex conjugate
hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2 )
if (hij /= 0.d0) then
! take conjugate to get contribution to <alpha|H|psi> instead of <psi|H|alpha>
! hij = dconjg(hij) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
hij = hij * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,1) * hij
enddo
endif
end do
end do
!! <phi|H|alpha>
do j = 1,2 ! loop over all 4 combinations of one alpha and one beta particle
putj = p(j, 2)
if(bannedOrb(putj, 2)) cycle
p2 = p(turn2(j), 2)
do i = 1,2
puti = p(i, 1)
if(banned(puti,putj,bant) .or. bannedOrb(puti,1)) cycle
p1 = p(turn2(i), 1)
hji = mo_bi_ortho_tc_two_e( p1, p2, h1, h2)
if (hji /= 0.d0) then
hji = hji * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,2) * hji
enddo
endif
end do
end do
end if
else ! if holes are (a,a) or (b,b)
if(tip == 0) then ! if particles are (a,a,a,a) or (b,b,b,b)
h1 = h(1, ma)
h2 = h(2, ma)
!! <alpha|H|psi>
do i=1,3
puti = p(i, ma)
if(bannedOrb(puti,ma)) cycle
do j=i+1,4
putj = p(j, ma)
if(bannedOrb(putj,ma)) cycle
if(banned(puti,putj,1)) cycle
i1 = turn2d(1, i, j)
i2 = turn2d(2, i, j)
p1 = p(i1, ma)
p2 = p(i2, ma)
! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1, h1, h2)
!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
! take the transpose of what's written above because later use the complex conjugate
hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2) - mo_bi_ortho_tc_two_e(h1, h2, p2,p1 )
if (hij == 0.d0) cycle
! take conjugate to get contribution to <alpha|H|psi> instead of <psi|H|alpha>
! hij = dconjg(hij) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
hij = hij * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_r(k, puti, putj) = mat_r(k, puti, putj) +coefs(k,1) * hij
enddo
end do
end do
!! <phi|H|alpha>
do i=1,3
puti = p(i, ma)
if(bannedOrb(puti,ma)) cycle
do j=i+1,4
putj = p(j, ma)
if(bannedOrb(putj,ma)) cycle
if(banned(puti,putj,1)) cycle
i1 = turn2d(1, i, j)
i2 = turn2d(2, i, j)
p1 = p(i1, ma)
p2 = p(i2, ma)
hji = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1,h1, h2 )
if (hji == 0.d0) cycle
hji = hji * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_l(k, puti, putj) = mat_l(k, puti, putj) +coefs(k,2) * hji
enddo
end do
end do
else if(tip == 3) then ! if particles are (a,a,a,b) (ma=1,mi=2) or (a,b,b,b) (ma=2,mi=1)
h1 = h(1, mi)
h2 = h(1, ma)
p1 = p(1, mi)
!! <alpha|H|psi>
do i=1,3
puti = p(turn3(1,i), ma)
if(bannedOrb(puti,ma)) cycle
putj = p(turn3(2,i), ma)
if(bannedOrb(putj,ma)) cycle
if(banned(puti,putj,1)) cycle
p2 = p(i, ma)
! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2)
!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
! take the transpose of what's written above because later use the complex conjugate
hij = mo_bi_ortho_tc_two_e(h1, h2,p1, p2 )
if (hij == 0.d0) cycle
! take conjugate to get contribution to <alpha|H|psi> instead of <psi|H|alpha>
! hij = dconjg(hij) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int)
hij = hij * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int)
if (puti < putj) then
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,1) * hij
enddo
else
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_r(k, putj, puti) = mat_r(k, putj, puti) + coefs(k,1) * hij
enddo
endif
end do
!! <phi|H|alpha>
do i=1,3
puti = p(turn3(1,i), ma)