9
1
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-10-15 20:21:34 +02:00
qp2/plugins/local/cipsi_tc_bi_ortho/get_d.irp.f

1903 lines
68 KiB
Fortran

! ---
double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2, Nint)
use bitmasks
implicit none
integer, intent(in) :: Nint
integer, intent(in) :: s1, s2, h1, h2, p1, p2
integer(bit_kind), intent(in) :: phasemask(Nint,2)
double precision, save :: res(0:1) = (/1d0, -1d0/)
integer :: np
integer :: h1_int, h2_int
integer :: p1_int, p2_int
integer :: h1_bit, h2_bit
integer :: p1_bit, p2_bit
logical :: change
h1_int = shiftr(h1-1,bit_kind_shift)+1
h1_bit = h1 - shiftl(h1_int-1,bit_kind_shift)-1
h2_int = shiftr(h2-1,bit_kind_shift)+1
h2_bit = h2 - shiftl(h2_int-1,bit_kind_shift)-1
p1_int = shiftr(p1-1,bit_kind_shift)+1
p1_bit = p1 - shiftl(p1_int-1,bit_kind_shift)-1
p2_int = shiftr(p2-1,bit_kind_shift)+1
p2_bit = p2 - shiftl(p2_int-1,bit_kind_shift)-1
! Put the phasemask bits at position 0, and add them all
h1_bit = int( shiftr( phasemask(h1_int,s1), h1_bit ) )
p1_bit = int( shiftr( phasemask(p1_int,s1), p1_bit ) )
h2_bit = int( shiftr( phasemask(h2_int,s2), h2_bit ) )
p2_bit = int( shiftr( phasemask(p2_int,s2), p2_bit ) )
np = h1_bit + p1_bit + h2_bit + p2_bit
if(p1 < h1) np = np + 1
if(p2 < h2) np = np + 1
if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1
get_phase_bi = res(iand(np,1))
end function get_phase_bi
! ---
subroutine get_d3_htc(gen, bannedOrb, banned, mat_m, mat_p, mask, p, sp, rcoefs, lcoefs)
use bitmasks
implicit none
integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
integer, intent(in) :: p(0:4,2), sp
logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
double precision, intent(in) :: rcoefs(N_states), lcoefs(N_states)
double precision, intent(inout) :: mat_m(N_states, mo_num, mo_num), mat_p(N_states, mo_num, mo_num)
integer(bit_kind) :: det(N_int, 2)
integer :: k, h1, h2, p1, p2, puti, putj
double precision :: i_h_alpha, alpha_h_i
logical :: ok
if(sp == 3) then ! AB
h1 = p(1,1)
h2 = p(1,2)
do p1 = 1, mo_num
if(bannedOrb(p1, 1)) cycle
do p2 = 1, mo_num
if(bannedOrb(p2,2)) cycle
if(banned(p1, p2, 1)) cycle ! rentable?
call apply_particles(mask, 1, p1, 2, p2, det, ok, N_int)
call htilde_mu_mat_bi_ortho_tot(gen, det, N_int, i_h_alpha)
call htilde_mu_mat_bi_ortho_tot(det,gen, N_int, alpha_h_i)
! call hji_hij_mu_mat_tot(gen, det, N_int,i_h_alpha , alpha_h_i)
if( dabs(alpha_h_i) .gt. 0.d0) then
!DIR$ LOOP COUNT AVG(4)
do k = 1, N_states
mat_p(k, p1, p2) = mat_p(k, p1, p2) + rcoefs(k) * alpha_h_i
enddo
endif
if( dabs(i_h_alpha) .gt. 0.d0) then
!DIR$ LOOP COUNT AVG(4)
do k = 1, N_states
mat_m(k, p1, p2) = mat_m(k, p1, p2) + lcoefs(k) * i_h_alpha
enddo
endif
enddo
enddo
else ! AA BB
p1 = p(1,sp)
p2 = p(2,sp)
do puti = 1, mo_num
if(bannedOrb(puti, sp)) cycle
do putj = puti+1, mo_num
if(bannedOrb(putj, sp)) cycle
if(banned(puti, putj, 1)) cycle ! rentable?
call apply_particles(mask, sp, puti, sp, putj, det, ok, N_int)
! call hji_hij_mu_mat_tot(gen, det, N_int, i_h_alpha, alpha_h_i)
call htilde_mu_mat_bi_ortho_tot(gen, det, N_int, i_h_alpha)
call htilde_mu_mat_bi_ortho_tot( det,gen, N_int, alpha_h_i)
if( dabs(alpha_h_i) .gt. 0.d0) then
!DIR$ LOOP COUNT AVG(4)
do k = 1, N_states
mat_p(k, puti, putj) = mat_p(k, puti, putj) + rcoefs(k) * alpha_h_i
enddo
endif
if( dabs(i_h_alpha) .gt. 0.d0) then
!DIR$ LOOP COUNT AVG(4)
do k = 1, N_states
mat_m(k, puti, putj) = mat_m(k, puti, putj) + lcoefs(k) * i_h_alpha
enddo
endif
enddo
enddo
endif
end subroutine get_d3_htc
! ---
subroutine get_d3_h(gen, bannedOrb, banned, mat, mask, p, sp, coefs)
use bitmasks
implicit none
integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
integer, intent(in) :: p(0:4,2), sp
logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
double precision, intent(in) :: coefs(N_states)
double precision, intent(inout) :: mat(N_states, mo_num, mo_num)
integer(bit_kind) :: det(N_int, 2)
integer :: k, h1, h2, p1, p2, puti, putj
double precision :: hij
logical :: ok
if(sp == 3) then ! AB
h1 = p(1,1)
h2 = p(1,2)
do p1 = 1, mo_num
if(bannedOrb(p1, 1)) cycle
do p2 = 1, mo_num
if(bannedOrb(p2,2)) cycle
if(banned(p1, p2, 1)) cycle ! rentable?
call apply_particles(mask, 1, p1, 2, p2, det, ok, N_int)
call i_h_j(gen, det, N_int, hij)
if (hij == 0.d0) cycle
!DIR$ LOOP COUNT AVG(4)
do k = 1, N_states
mat(k, p1, p2) = mat(k, p1, p2) + coefs(k) * hij
enddo
enddo
enddo
else ! AA BB
p1 = p(1,sp)
p2 = p(2,sp)
do puti = 1, mo_num
if(bannedOrb(puti, sp)) cycle
do putj = puti+1, mo_num
if(bannedOrb(putj, sp)) cycle
if(banned(puti, putj, 1)) cycle ! rentable?
call apply_particles(mask, sp, puti, sp, putj, det, ok, N_int)
call i_h_j(gen, det, N_int, hij)
!DIR$ LOOP COUNT AVG(4)
do k = 1, N_states
mat(k, puti, putj) = mat(k, puti, putj) + coefs(k) * hij
enddo
enddo
enddo
endif
end subroutine get_d3_h
! ---
subroutine get_d2(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs)
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_l(N_states, mo_num, mo_num), 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
integer :: i, j, k, tip, ma, mi, puti, putj
integer :: h1, h2, p1, p2, i1, i2
double precision :: hij, hji, phase
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
tip = p(0,1) * p(0,2)
ma = sp
print*,'in get_d2'
stop
if(p(0,1) > p(0,2)) ma = 1
if(p(0,1) < p(0,2)) ma = 2
mi = mod(ma, 2) + 1
if(sp == 3) then
print*,'in sp == 3'
if(ma == 2) bant = 2
if(tip == 3) then
puti = p(1, mi)
if(bannedOrb(puti, mi)) return
h1 = h(1, ma)
h2 = h(2, ma)
do i = 1, 3
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)
! <p1 p2|1/r12|h1 h2> --> <p1 p2| w_ee^h + t^nh | h1 h2> --> < p2 p1 | H^tilde| h1 h2 >
!
! <p1 p2 | h1 h2> - <p2 p1 | h1 h2 >
! < p2 p1 | H^tilde^dag| h1 h2 > = < h1 h2 | w_ee^h + t^nh | p1 p2 >
hji = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2, p1, h1, h2)
hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2) - mo_bi_ortho_tc_two_e(h2, h1, p1, p2)
if (hij == 0.d0) cycle
hij = hij * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
hji = hji * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
if(ma == 1) then
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_l(k, putj, puti) = mat_l(k, putj, puti) + coefs(k,1) * hij
mat_r(k, putj, puti) = mat_r(k, putj, puti) + coefs(k,2) * hji
enddo
else
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hij
mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hji
enddo
end if
end do
else
h1 = h(1,1)
h2 = h(1,2)
do j = 1,2
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)
hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2)
if (hij /= 0.d0) then
hij = hij * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
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,1) * hij
mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hji
enddo
endif
end do
end do
end if
else
print*,'NOT in sp == 3'
if(tip == 0) then
h1 = h(1, ma)
h2 = h(2, ma)
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)
hji = mo_bi_ortho_tc_two_e(h1, h2, p1, p2) - mo_bi_ortho_tc_two_e(h2,h1, p1, p2)
if (hij == 0.d0) cycle
hij = hij * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
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,1) * hij
mat_r(k, puti, putj) = mat_r(k, puti, putj) +coefs(k,2) * hji
enddo
end do
end do
else if(tip == 3) then
h1 = h(1, mi)
h2 = h(1, ma)
p1 = p(1, mi)
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)
hji = mo_bi_ortho_tc_two_e(h1, h2, p1, p2)
if (hij == 0.d0) cycle
hij = hij * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int)
hji = hji * 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_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hij
mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hji
enddo
else
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_l(k, putj, puti) = mat_l(k, putj, puti) + coefs(k,1) * hij
mat_r(k, putj, puti) = mat_r(k, putj, puti) + coefs(k,2) * hji
enddo
endif
end do
else ! tip == 4
puti = p(1, sp)
putj = p(2, sp)
if(.not. banned(puti,putj,1)) then
p1 = p(1, mi)
p2 = p(2, mi)
h1 = h(1, mi)
h2 = h(2, mi)
hij = (mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1, h1, h2))
hji = (mo_bi_ortho_tc_two_e(h1, h2, p1, p2) - mo_bi_ortho_tc_two_e(h2,h1, p1, p2))
if (hij /= 0.d0) then
hij = hij * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2, N_int)
hji = hji * get_phase_bi(phasemask, mi, mi, 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,1) * hij
mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hji
enddo
end if
end if
end if
end if
end subroutine get_d2
! ---
subroutine get_d1(gen, phasemask, bannedOrb, banned, mat_p, mat_m, mask, h, p, sp, coefs)
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_p(N_states, mo_num, mo_num), mat_m(N_states, mo_num, mo_num)
integer, intent(in) :: h(0:2,2), p(0:4,2), sp
double precision, external :: get_phase_bi
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
integer :: 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_row_ij(N_states, mo_num), tmp_row_ij2(N_states, mo_num)
double precision, allocatable :: hji_cache(:,:)
double precision :: hji, tmp_row_ji(N_states, mo_num), tmp_row_ji2(N_states, mo_num)
PROVIDE mo_integrals_map N_int
allocate (lbanned(mo_num, 2))
allocate (hij_cache(mo_num,2))
allocate (hji_cache(mo_num,2))
lbanned = bannedOrb
print*,'in get d1'
call debug_det(gen, N_int)
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
print*,'in sp == 3'
!move MA
if(ma == 2) bant = 2
puti = p(1,mi)
hfix = h(1,ma)
p1 = p(1,ma)
p2 = p(2,ma)
print*,puti, hfix,p1,p2
if(.not. bannedOrb(puti, mi)) then
! print*,'not banned'
do mm = 1, mo_num
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)
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)
enddo
! call get_mo_bi_ortho_tc_two_es(hfix,p1,p2,mo_num,hij_cache(1,1),mo_integrals_map)
! call get_mo_bi_ortho_tc_two_es(hfix,p2,p1,mo_num,hij_cache(1,2),mo_integrals_map)
tmp_row_ij = 0d0
tmp_row_ji = 0d0
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_row_ij(k,putj) = tmp_row_ij(k,putj) + hij * coefs(k,2)
enddo
endif
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_row_ji(k,putj) = tmp_row_ji(k,putj) + hji * 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_row_ij(k,putj) = tmp_row_ij(k,putj) + hij * coefs(k,2)
enddo
endif
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_row_ji(k,putj) = tmp_row_ji(k,putj) + hji * coefs(k,1)
enddo
endif
end do
if(ma == 1) then
mat_p(1:N_states,1:mo_num,puti) = mat_p(1:N_states,1:mo_num,puti) + tmp_row_ij(1:N_states,1:mo_num)
mat_m(1:N_states,1:mo_num,puti) = mat_m(1:N_states,1:mo_num,puti) + tmp_row_ji(1:N_states,1:mo_num)
else
do l=1,mo_num
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_p(k,puti,l) = mat_p(k,puti,l) + tmp_row_ij(k,l)
mat_m(k,puti,l) = mat_m(k,puti,l) + tmp_row_ji(k,l)
enddo
enddo
end if
end if
!MOVE MI
pfix = p(1,mi)
tmp_row_ij = 0d0
tmp_row_ij2 = 0d0
tmp_row_ji = 0d0
tmp_row_ji2 = 0d0
! call get_mo_bi_ortho_tc_two_es(hfix,pfix,p1,mo_num,hij_cache(1,1),mo_integrals_map)
! call get_mo_bi_ortho_tc_two_es(hfix,pfix,p2,mo_num,hij_cache(1,2),mo_integrals_map)
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
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_row_ij(k,puti) = tmp_row_ij(k,puti) + hij * coefs(k,2)
enddo
endif
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_row_ji(k,puti) = tmp_row_ji(k,puti) + hji * coefs(k,1)
enddo
endif
endif
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_row_ij2(k,puti) = tmp_row_ij2(k,puti) + hij * coefs(k,2)
enddo
endif
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_row_ji2(k,puti) = tmp_row_ji2(k,puti) + hji * coefs(k,1)
enddo
endif
endif
enddo
if(mi == 1) then
mat_p(:,:,p1) = mat_p(:,:,p1) + tmp_row_ij(:,:)
mat_p(:,:,p2) = mat_p(:,:,p2) + tmp_row_ij2(:,:)
mat_m(:,:,p1) = mat_m(:,:,p1) + tmp_row_ji(:,:)
mat_m(:,:,p2) = mat_m(:,:,p2) + tmp_row_ji2(:,:)
else
do l=1,mo_num
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_p(k,p1,l) = mat_p(k,p1,l) + tmp_row_ij(k,l)
mat_p(k,p2,l) = mat_p(k,p2,l) + tmp_row_ij2(k,l)
mat_m(k,p1,l) = mat_m(k,p1,l) + tmp_row_ji(k,l)
mat_m(k,p2,l) = mat_m(k,p2,l) + tmp_row_ji2(k,l)
enddo
enddo
end if
else ! sp /= 3
print*,'not in 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_bi_ortho_tc_two_es(hfix,p1,p2,mo_num,hij_cache(1,1),mo_integrals_map)
! call get_mo_bi_ortho_tc_two_es(hfix,p2,p1,mo_num,hij_cache(1,2),mo_integrals_map)
do mm = 1, mo_num
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)
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)
enddo
tmp_row_ij = 0d0
tmp_row_ji = 0d0
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_row_ij(:,putj) = tmp_row_ij(:,putj) + hij * coefs(:,1)
endif
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_row_ji(:,putj) = tmp_row_ji(:,putj) + hji * coefs(:,2)
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_row_ij(:,putj) = tmp_row_ij(:,putj) + hij * coefs(:,1)
endif
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_row_ji(:,putj) = tmp_row_ji(:,putj) + hji * coefs(:,2)
endif
end do
mat_p(:, :puti-1, puti) = mat_p(:, :puti-1, puti) + tmp_row_ij(:,:puti-1)
mat_m(:, :puti-1, puti) = mat_m(:, :puti-1, puti) + tmp_row_ji(:,:puti-1)
do l=puti,mo_num
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_p(k, puti, l) = mat_p(k, puti,l) + tmp_row_ij(k,l)
mat_m(k, puti, l) = mat_m(k, puti,l) + tmp_row_ji(k,l)
enddo
enddo
end do
else
hfix = h(1,mi)
pfix = p(1,mi)
p1 = p(1,ma)
p2 = p(2,ma)
tmp_row_ij = 0d0
tmp_row_ij2 = 0d0
tmp_row_ji = 0d0
tmp_row_ji2 = 0d0
! call get_mo_bi_ortho_tc_two_es(hfix,p1,pfix,mo_num,hij_cache(1,1),mo_integrals_map)
! call get_mo_bi_ortho_tc_two_es(hfix,p2,pfix,mo_num,hij_cache(1,2),mo_integrals_map)
do mm = 1, mo_num
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)
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)
enddo
putj = p2
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_row_ij(k,puti) = tmp_row_ij(k,puti) + hij * coefs(k,1)
enddo
endif
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_row_ji(k,puti) = tmp_row_ji(k,puti) + hji * coefs(k,2)
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_row_ij2(k,puti) = tmp_row_ij2(k,puti) + hij * coefs(k,1)
enddo
endif
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_row_ji2(k,puti) = tmp_row_ji2(k,puti) + hji * coefs(k,2)
enddo
endif
end if
end do
mat_p(:,:p2-1,p2) = mat_p(:,:p2-1,p2) + tmp_row_ij(:,:p2-1)
mat_m(:,:p2-1,p2) = mat_m(:,:p2-1,p2) + tmp_row_ji(:,:p2-1)
do l=p2,mo_num
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_p(k,p2,l) = mat_p(k,p2,l) + tmp_row_ij(k,l)
mat_m(k,p2,l) = mat_m(k,p2,l) + tmp_row_ji(k,l)
enddo
enddo
mat_p(:,:p1-1,p1) = mat_p(:,:p1-1,p1) + tmp_row_ij2(:,:p1-1)
mat_m(:,:p1-1,p1) = mat_m(:,:p1-1,p1) + tmp_row_ji2(:,:p1-1)
do l=p1,mo_num
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_p(k,p1,l) = mat_p(k,p1,l) + tmp_row_ij2(k,l)
mat_m(k,p1,l) = mat_m(k,p1,l) + tmp_row_ji2(k,l)
enddo
enddo
end if
end if
deallocate(lbanned,hij_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)
! call i_h_j(gen, det, N_int, hij)
!!!! GUESS ON THE ORDER OF DETS
print*,'compute hij'
! hij = 0.d0
! hji = 0.d0
call htilde_mu_mat_opt_bi_ortho_no_3e(gen,det,N_int, hji)
call htilde_mu_mat_opt_bi_ortho_no_3e(det,gen,N_int, hij)
!DIR$ LOOP COUNT AVG(4)
do k = 1, N_states
mat_p(k, p1, p2) = mat_p(k, p1, p2) + coefs(k,1) * hij
mat_m(k, p1, p2) = mat_m(k, p1, p2) + coefs(k,2) * hji
enddo
enddo
enddo
end subroutine get_d1
! ---
subroutine get_d0(gen, phasemask, bannedOrb, banned, mat_p, mat_m, mask, h, p, sp, coefs)
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_m(N_states, mo_num, mo_num)
double precision, intent(inout) :: mat_p(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 :: hij, phase, 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'
! call debug_det(gen, N_int)
if(sp == 3) then ! AB
h1 = p(1,1)
h2 = p(1,2)
! print*,'in AB'
do p1=1, mo_num
if(bannedOrb(p1, 1)) cycle
! call get_mo_bi_ortho_tc_two_es(p1,h2,h1,mo_num,hij_cache1,mo_integrals_map)
do mm =1, mo_num
hji_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
do p2=1, mo_num
if(bannedOrb(p2,2)) cycle
if(banned(p1, p2, bant)) cycle ! rentable?
if(p1 == h1 .or. p2 == h2) then
! print*,'in p1 == h1 or p2 == h2'
call apply_particles(mask, 1,p1,2,p2, det, ok, N_int)
! call i_h_j(gen, det, N_int, hij)
!!! GUESS ON THE ORDER
call htilde_mu_mat_opt_bi_ortho_no_3e(det,gen,N_int, hji)
call htilde_mu_mat_opt_bi_ortho_no_3e(gen,det,N_int, hij)
else
! print*,'ELSE '
phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
hij = hij_cache1(p2) * phase
hji = hji_cache1(p2) * phase
end if
if (hij == 0.d0) cycle
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_p(k, p1, p2) = mat_p(k, p1, p2) + coefs(k,1) * hij ! HOTSPOT
mat_m(k, p1, p2) = mat_m(k, p1, p2) + coefs(k,2) * hji ! HOTSPOT
enddo
end do
end do
else ! AA BB
! print*, 'in AA BB'
p1 = p(1,sp)
p2 = p(2,sp)
do puti=1, mo_num
if(bannedOrb(puti, sp)) cycle
do mm = 1, mo_num
hij_cache1(mm) = mo_bi_ortho_tc_two_e(p2,p1,mm,puti)
hij_cache2(mm) = mo_bi_ortho_tc_two_e(p1,p2,mm,puti)
hji_cache1(mm) = mo_bi_ortho_tc_two_e(mm,puti,p2,p1)
hji_cache2(mm) = mo_bi_ortho_tc_two_e(mm,puti,p1,p2)
enddo
! call get_mo_bi_ortho_tc_two_es(puti,p2,p1,mo_num,hij_cache1,mo_integrals_map)
! call get_mo_bi_ortho_tc_two_es(puti,p1,p2,mo_num,hij_cache2,mo_integrals_map)
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(gen, det, N_int, hij)
!!! GUESS
call htilde_mu_mat_opt_bi_ortho_no_3e(gen,det,N_int, hij)
call htilde_mu_mat_opt_bi_ortho_no_3e(det,gen,N_int, hji)
if (hij == 0.d0.or.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))
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.or.hji==0.d0) cycle
hij = hij * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int)
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_p(k, puti, putj) = mat_p(k, puti, putj) + coefs(k,1) * hij
mat_m(k, puti, putj) = mat_m(k, puti, putj) + coefs(k,2) * hji
enddo
end do
end do
end if
! deallocate(hij_cache1,hij_cache2)
! deallocate(hji_cache1,hji_cache2)
end subroutine get_d0
! ---
! ___________________________________________________________________________________________________________________________________________________
! ___________________________________________________________________________________________________________________________________________________
!subroutine get_pm2(gen, phasemask, bannedOrb, banned, mat_p, mat_m, mask, h, p, sp, coefs)
!
! use bitmasks
!
! implicit none
!
! integer, intent(in) :: h(0:2,2), p(0:4,2), sp
! integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2), phasemask(N_int,2)
! logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
! double precision, intent(in) :: coefs(N_states)
! double precision, intent(inout) :: mat_p(N_states, mo_num, mo_num), mat_m(N_states, mo_num, mo_num)
!
! 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 :: i, j, k, tip, ma, mi, puti, putj
! integer :: h1, h2, p1, p2, i1, i2
! integer :: bant
! double precision :: hij_p, hij_m, phase
!
! double precision, external :: get_phase_bi
! double precision, external :: get_mo_bi_ortho_tc_two_e_tc_int, get_mo_bi_ortho_tc_two_e_tcdag_int
!
! PROVIDE mo_integrals_tc_int_map mo_integrals_tcdag_int_map
!
! bant = 1
!
! tip = p(0,1) * p(0,2)
!
! ma = sp
! if(p(0,1) > p(0,2)) ma = 1
! if(p(0,1) < p(0,2)) ma = 2
! mi = mod(ma, 2) + 1
!
! if(sp == 3) then
! if(ma == 2) bant = 2
! if(tip == 3) then
! puti = p(1, mi)
! if(bannedOrb(puti, mi)) return
! h1 = h(1, ma)
! h2 = h(2, ma)
!
! do i = 1, 3
! 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)
!
! hij_p = get_mo_bi_ortho_tc_two_e_tc_int (p1, p2, h1, h2, mo_integrals_tc_int_map ) &
! - get_mo_bi_ortho_tc_two_e_tc_int (p2, p1, h1, h2, mo_integrals_tc_int_map )
! hij_m = get_mo_bi_ortho_tc_two_e_tcdag_int(p1, p2, h1, h2, mo_integrals_tcdag_int_map) &
! - get_mo_bi_ortho_tc_two_e_tcdag_int(p2, p1, h1, h2, mo_integrals_tcdag_int_map)
!
! if( (hij_p.eq.0.d0) .and. (hij_m.eq.0.d0) ) cycle
!
! hij_p = hij_p * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
! hij_m = hij_m * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
!
! if(ma == 1) then
! !DIR$ LOOP COUNT AVG(4)
! do k = 1, N_states
! mat_p(k, putj, puti) = mat_p(k, putj, puti) + coefs(k) * hij_p
! mat_m(k, putj, puti) = mat_m(k, putj, puti) + coefs(k) * hij_m
! enddo
! else
! !DIR$ LOOP COUNT AVG(4)
! do k = 1, N_states
! mat_p(k, puti, putj) = mat_p(k, puti, putj) + coefs(k) * hij_p
! mat_m(k, puti, putj) = mat_m(k, puti, putj) + coefs(k) * hij_m
! enddo
! end if
! end do
!
! else
!
! h1 = h(1,1)
! h2 = h(1,2)
! do j = 1,2
! 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_p = get_mo_bi_ortho_tc_two_e_tc_int (p1, p2, h1, h2, mo_integrals_tc_int_map )
! hij_m = get_mo_bi_ortho_tc_two_e_tcdag_int(p1, p2, h1, h2, mo_integrals_tcdag_int_map)
!
! if( (hij_p.ne.0.d0) .and. (hij_m.ne.0.d0) ) then
! hij_p = hij_p * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
! hij_m = hij_m * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
! !DIR$ LOOP COUNT AVG(4)
! do k = 1, N_states
! mat_p(k, puti, putj) = mat_p(k, puti, putj) + coefs(k) * hij_p
! mat_m(k, puti, putj) = mat_m(k, puti, putj) + coefs(k) * hij_m
! enddo
! endif
! end do
! end do
! end if
!
! else
! if(tip == 0) then
! h1 = h(1, ma)
! h2 = h(2, ma)
! 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_p = get_mo_bi_ortho_tc_two_e_tc_int (p1, p2, h1, h2, mo_integrals_tc_int_map ) &
! - get_mo_bi_ortho_tc_two_e_tc_int (p2, p1, h1, h2, mo_integrals_tc_int_map )
! hij_m = get_mo_bi_ortho_tc_two_e_tcdag_int(p1, p2, h1, h2, mo_integrals_tcdag_int_map) &
! - get_mo_bi_ortho_tc_two_e_tcdag_int(p2, p1, h1, h2, mo_integrals_tcdag_int_map)
!
! if( (hij_p.eq.0.d0) .and. (hij_m.eq.0.d0) ) cycle
!
! hij_p = hij_p * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
! hij_m = hij_m * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
!
! !DIR$ LOOP COUNT AVG(4)
! do k=1,N_states
! mat_p(k, puti, putj) = mat_p(k, puti, putj) + coefs(k) * hij_p
! mat_m(k, puti, putj) = mat_m(k, puti, putj) + coefs(k) * hij_m
! enddo
! end do
! end do
!
! else if(tip == 3) then
! h1 = h(1, mi)
! h2 = h(1, ma)
! p1 = p(1, mi)
! 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_p = get_mo_bi_ortho_tc_two_e_tc_int (p1, p2, h1, h2, mo_integrals_tc_int_map )
! hij_m = get_mo_bi_ortho_tc_two_e_tcdag_int(p1, p2, h1, h2, mo_integrals_tcdag_int_map)
!
! if( (hij_p.eq.0.d0) .and. (hij_m.eq.0.d0) ) cycle
!
! hij_p = hij_p * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int)
! hij_m = hij_m * 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_p(k, puti, putj) = mat_p(k, puti, putj) + coefs(k) * hij_p
! mat_m(k, puti, putj) = mat_m(k, puti, putj) + coefs(k) * hij_m
! enddo
! else
! !DIR$ LOOP COUNT AVG(4)
! do k=1,N_states
! mat_p(k, putj, puti) = mat_p(k, putj, puti) + coefs(k) * hij_p
! mat_m(k, putj, puti) = mat_m(k, putj, puti) + coefs(k) * hij_m
! enddo
! endif
! end do
! else ! tip == 4
! puti = p(1, sp)
! putj = p(2, sp)
! if(.not. banned(puti,putj,1)) then
! p1 = p(1, mi)
! p2 = p(2, mi)
! h1 = h(1, mi)
! h2 = h(2, mi)
!
! hij_p = get_mo_bi_ortho_tc_two_e_tc_int (p1, p2, h1, h2, mo_integrals_tc_int_map ) &
! - get_mo_bi_ortho_tc_two_e_tc_int (p2, p1, h1, h2, mo_integrals_tc_int_map )
! hij_m = get_mo_bi_ortho_tc_two_e_tcdag_int(p1, p2, h1, h2, mo_integrals_tcdag_int_map) &
! - get_mo_bi_ortho_tc_two_e_tcdag_int(p2, p1, h1, h2, mo_integrals_tcdag_int_map)
!
! if( (hij_p.ne.0.d0) .and. (hij_m.ne.0.d0) ) then
! hij_p = hij_p * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2, N_int)
! hij_m = hij_m * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2, N_int)
! !DIR$ LOOP COUNT AVG(4)
! do k=1,N_states
! mat_p(k, puti, putj) = mat_p(k, puti, putj) + coefs(k) * hij_p
! mat_m(k, puti, putj) = mat_m(k, puti, putj) + coefs(k) * hij_m
! enddo
! end if
! end if
! end if
! end if
!
!end subroutine get_pm2
! ___________________________________________________________________________________________________________________________________________________
! ___________________________________________________________________________________________________________________________________________________
! ___________________________________________________________________________________________________________________________________________________
! ___________________________________________________________________________________________________________________________________________________
! ___________________________________________________________________________________________________________________________________________________
!subroutine get_pm1(gen, phasemask, bannedOrb, banned, mat_p, mat_m, mask, h, p, sp, coefs)
!
! use bitmasks
!
! implicit none
!
! integer(bit_kind) :: det(N_int, 2)
! 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)
! integer, intent(in) :: h(0:2,2), p(0:4,2), sp
! double precision, intent(inout) :: mat_p(N_states, mo_num, mo_num), mat_m(N_states, mo_num, mo_num)
!
! double precision, external :: get_phase_bi
! double precision, external :: get_mo_bi_ortho_tc_two_e_tc_int, get_mo_bi_ortho_tc_two_e_tcdag_int
!
! logical :: ok
! logical, allocatable :: lbanned(:,:)
! integer :: bant
! integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j
! integer :: hfix, pfix, h1, h2, p1, p2, ib, k, l
! double precision :: tmp_row_ij_p (N_states, mo_num), tmp_row_ij_m (N_states, mo_num)
! double precision :: hij_p, hij_m, tmp_row_ij2_p(N_states, mo_num), tmp_row_ij2_m(N_states, mo_num)
! double precision, allocatable :: hijp_cache(:,:), hijm_cache(:,:)
!
! integer, parameter :: turn2(2) = (/2,1/)
! integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
!
! PROVIDE mo_integrals_tc_int_map mo_integrals_tcdag_int_map
!
! allocate( lbanned(mo_num, 2) )
! allocate( hijp_cache(mo_num,2), hijm_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_bi_ortho_tc_two_es_tc_int (hfix, p1, p2, mo_num, hijp_cache(1,1), mo_integrals_tc_int_map )
! call get_mo_bi_ortho_tc_two_es_tc_int (hfix, p2, p1, mo_num, hijp_cache(1,2), mo_integrals_tc_int_map )
! call get_mo_bi_ortho_tc_two_es_tcdag_int(hfix, p1, p2, mo_num, hijm_cache(1,1), mo_integrals_tcdag_int_map)
! call get_mo_bi_ortho_tc_two_es_tcdag_int(hfix, p2, p1, mo_num, hijm_cache(1,2), mo_integrals_tcdag_int_map)
!
! tmp_row_ij_p = 0d0
! tmp_row_ij_m = 0d0
! do putj=1, hfix-1
! if(lbanned(putj, ma)) cycle
! if(banned(putj, puti,bant)) cycle
!
! hij_p = hijp_cache(putj,1) - hijp_cache(putj,2)
! hij_m = hijm_cache(putj,1) - hijm_cache(putj,2)
!
! if( (hij_p.ne.0.d0) .and. (hij_m.ne.0.d0) ) then
! hij_p = hij_p * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
! hij_m = hij_m * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
! !DIR$ LOOP COUNT AVG(4)
! do k=1,N_states
! tmp_row_ij_p(k,putj) = tmp_row_ij_p(k,putj) + hij_p * coefs(k)
! tmp_row_ij_m(k,putj) = tmp_row_ij_m(k,putj) + hij_m * coefs(k)
! enddo
! endif
! end do
! do putj=hfix+1, mo_num
! if(lbanned(putj, ma)) cycle
! if(banned(putj, puti,bant)) cycle
!
! hij_p = hijp_cache(putj,2) - hijp_cache(putj,1)
! hij_m = hijm_cache(putj,2) - hijm_cache(putj,1)
!
! if( (hij_p.ne.0.d0) .and. (hij_m.ne.0.d0) ) then
! hij_p = hij_p * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
! hij_m = hij_m * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
! !DIR$ LOOP COUNT AVG(4)
! do k=1,N_states
! tmp_row_ij_p(k,putj) = tmp_row_ij_p(k,putj) + hij_p * coefs(k)
! tmp_row_ij_m(k,putj) = tmp_row_ij_m(k,putj) + hij_m * coefs(k)
! enddo
! endif
! end do
!
! if(ma == 1) then
! mat_p(1:N_states,1:mo_num,puti) = mat_p(1:N_states,1:mo_num,puti) + tmp_row_ij_p(1:N_states,1:mo_num)
! mat_m(1:N_states,1:mo_num,puti) = mat_m(1:N_states,1:mo_num,puti) + tmp_row_ij_m(1:N_states,1:mo_num)
! else
! do l=1,mo_num
! !DIR$ LOOP COUNT AVG(4)
! do k=1,N_states
! mat_p(k,puti,l) = mat_p(k,puti,l) + tmp_row_ij_p(k,l)
! mat_m(k,puti,l) = mat_m(k,puti,l) + tmp_row_ij_m(k,l)
! enddo
! enddo
! end if
! end if
!
! !MOVE MI
! pfix = p(1,mi)
! tmp_row_ij_p = 0d0
! tmp_row_ij_m = 0d0
! tmp_row_ij2_p = 0d0
! tmp_row_ij2_m = 0d0
!
! call get_mo_bi_ortho_tc_two_es_tc_int (hfix, pfix, p1, mo_num, hijp_cache(1,1), mo_integrals_tc_int_map )
! call get_mo_bi_ortho_tc_two_es_tc_int (hfix, pfix, p2, mo_num, hijp_cache(1,2), mo_integrals_tc_int_map )
! call get_mo_bi_ortho_tc_two_es_tcdag_int(hfix, pfix, p1, mo_num, hijm_cache(1,1), mo_integrals_tcdag_int_map)
! call get_mo_bi_ortho_tc_two_es_tcdag_int(hfix, pfix, p2, mo_num, hijm_cache(1,2), mo_integrals_tcdag_int_map)
!
! putj = p1
! do puti=1,mo_num !HOT
! if(lbanned(puti,mi)) cycle
! !p1 fixed
! putj = p1
! if(.not. banned(putj,puti,bant)) then
!
! hij_p = hijp_cache(puti,2)
! hij_m = hijm_cache(puti,2)
!
! if( (hij_p.ne.0.d0) .and. (hij_m.ne.0.d0) ) then
! hij_p = hij_p * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix, N_int)
! hij_m = hij_m * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix, N_int)
! !DIR$ LOOP COUNT AVG(4)
! do k=1,N_states
! tmp_row_ij_p(k,puti) = tmp_row_ij_p(k,puti) + hij_p * coefs(k)
! tmp_row_ij_m(k,puti) = tmp_row_ij_m(k,puti) + hij_m * coefs(k)
! enddo
! endif
! end if
!
! putj = p2
! if(.not. banned(putj,puti,bant)) then
!
! hij_p = hijp_cache(puti,1)
! hij_m = hijm_cache(puti,1)
!
! if( (hij_p.ne.0.d0) .and. (hij_m.ne.0.d0) ) then
! hij_p = hij_p * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix, N_int)
! hij_m = hij_m * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix, N_int)
! do k=1,N_states
! tmp_row_ij2_p(k,puti) = tmp_row_ij2_p(k,puti) + hij_p * coefs(k)
! tmp_row_ij2_m(k,puti) = tmp_row_ij2_m(k,puti) + hij_m * coefs(k)
! enddo
! endif
! end if
! end do
!
! if(mi == 1) then
! mat_p(:,:,p1) = mat_p(:,:,p1) + tmp_row_ij_p (:,:)
! mat_p(:,:,p2) = mat_p(:,:,p2) + tmp_row_ij2_p(:,:)
! mat_m(:,:,p1) = mat_m(:,:,p1) + tmp_row_ij_m (:,:)
! mat_m(:,:,p2) = mat_m(:,:,p2) + tmp_row_ij2_m(:,:)
! else
! do l=1,mo_num
! !DIR$ LOOP COUNT AVG(4)
! do k=1,N_states
! mat_p(k,p1,l) = mat_p(k,p1,l) + tmp_row_ij_p (k,l)
! mat_p(k,p2,l) = mat_p(k,p2,l) + tmp_row_ij2_p(k,l)
! mat_m(k,p1,l) = mat_m(k,p1,l) + tmp_row_ij_m (k,l)
! mat_m(k,p2,l) = mat_m(k,p2,l) + tmp_row_ij2_m(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_bi_ortho_tc_two_es_tc_int (hfix, p1, p2, mo_num, hijp_cache(1,1), mo_integrals_tc_int_map )
! call get_mo_bi_ortho_tc_two_es_tc_int (hfix, p2, p1, mo_num, hijp_cache(1,2), mo_integrals_tc_int_map )
! call get_mo_bi_ortho_tc_two_es_tcdag_int(hfix, p1, p2, mo_num, hijm_cache(1,1), mo_integrals_tcdag_int_map)
! call get_mo_bi_ortho_tc_two_es_tcdag_int(hfix, p2, p1, mo_num, hijm_cache(1,2), mo_integrals_tcdag_int_map)
!
! tmp_row_ij_p = 0d0
! tmp_row_ij_m = 0d0
! do putj=1,hfix-1
! if(banned(putj,puti,1)) cycle
! if(lbanned(putj,ma)) cycle
!
! hij_p = hijp_cache(putj,1) - hijp_cache(putj,2)
! hij_m = hijm_cache(putj,1) - hijm_cache(putj,2)
!
! if( (hij_p.ne.0.d0) .and. (hij_m.ne.0.d0) ) then
! hij_p = hij_p * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
! hij_m = hij_m * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
! tmp_row_ij_p(:,putj) = tmp_row_ij_p(:,putj) + hij_p * coefs(:)
! tmp_row_ij_m(:,putj) = tmp_row_ij_m(:,putj) + hij_m * coefs(:)
! endif
! end do
! do putj=hfix+1,mo_num
! if(banned(putj,puti,1)) cycle
! if(lbanned(putj,ma)) cycle
!
! hij_p = hijp_cache(putj,2) - hijp_cache(putj,1)
! hij_m = hijm_cache(putj,2) - hijm_cache(putj,1)
!
! if( (hij_p.ne.0.d0) .and. (hij_m.ne.0.d0) ) then
! hij_p = hij_p * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
! hij_m = hij_m * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
! tmp_row_ij_p(:,putj) = tmp_row_ij_p(:,putj) + hij_p * coefs(:)
! tmp_row_ij_m(:,putj) = tmp_row_ij_m(:,putj) + hij_m * coefs(:)
! endif
! end do
!
! mat_p(:, :puti-1, puti) = mat_p(:, :puti-1, puti) + tmp_row_ij_p(:,:puti-1)
! mat_m(:, :puti-1, puti) = mat_m(:, :puti-1, puti) + tmp_row_ij_m(:,:puti-1)
! do l=puti,mo_num
! !DIR$ LOOP COUNT AVG(4)
! do k=1,N_states
! mat_p(k, puti, l) = mat_p(k, puti,l) + tmp_row_ij_p(k,l)
! mat_m(k, puti, l) = mat_m(k, puti,l) + tmp_row_ij_m(k,l)
! enddo
! enddo
! end do
! else
! hfix = h(1,mi)
! pfix = p(1,mi)
! p1 = p(1,ma)
! p2 = p(2,ma)
! tmp_row_ij_p = 0d0
! tmp_row_ij_m = 0d0
! tmp_row_ij2_p = 0d0
! tmp_row_ij2_m = 0d0
!
! call get_mo_bi_ortho_tc_two_es_tc_int (hfix, p1, pfix, mo_num, hijp_cache(1,1), mo_integrals_tc_int_map )
! call get_mo_bi_ortho_tc_two_es_tc_int (hfix, p2, pfix, mo_num, hijp_cache(1,2), mo_integrals_tc_int_map )
! call get_mo_bi_ortho_tc_two_es_tcdag_int(hfix, p1, pfix, mo_num, hijp_cache(1,1), mo_integrals_tcdag_int_map)
! call get_mo_bi_ortho_tc_two_es_tcdag_int(hfix, p2, pfix, mo_num, hijp_cache(1,2), mo_integrals_tcdag_int_map)
!
! putj = p2
! do puti=1,mo_num
! if(lbanned(puti,ma)) cycle
! putj = p2
! if(.not. banned(puti,putj,1)) then
!
! hij_p = hijp_cache(puti,1)
! hij_m = hijm_cache(puti,1)
!
! if( (hij_p.ne.0.d0) .and. (hij_m.ne.0.d0) ) then
! hij_p = hij_p * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1, N_int)
! hij_m = hij_m * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1, N_int)
! !DIR$ LOOP COUNT AVG(4)
! do k=1,N_states
! tmp_row_ij_p(k,puti) = tmp_row_ij_p(k,puti) + hij_p * coefs(k)
! tmp_row_ij_m(k,puti) = tmp_row_ij_m(k,puti) + hij_m * coefs(k)
! enddo
! endif
! end if
!
! putj = p1
! if(.not. banned(puti,putj,1)) then
! hij_p = hijp_cache(puti,2)
! hij_m = hijm_cache(puti,2)
! if( (hij_p.ne.0.d0) .and. (hij_m.ne.0.d0) ) then
! hij_p = hij_p * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2, N_int)
! hij_m = hij_m * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2, N_int)
! do k=1,N_states
! tmp_row_ij2_p(k,puti) = tmp_row_ij2_p(k,puti) + hij_p * coefs(k)
! tmp_row_ij2_m(k,puti) = tmp_row_ij2_m(k,puti) + hij_m * coefs(k)
! enddo
! endif
! end if
! end do
! mat_p(:,:p2-1,p2) = mat_p(:,:p2-1,p2) + tmp_row_ij_p(:,:p2-1)
! mat_m(:,:p2-1,p2) = mat_m(:,:p2-1,p2) + tmp_row_ij_m(:,:p2-1)
! do l=p2,mo_num
! !DIR$ LOOP COUNT AVG(4)
! do k=1,N_states
! mat_p(k,p2,l) = mat_p(k,p2,l) + tmp_row_ij_p(k,l)
! mat_m(k,p2,l) = mat_m(k,p2,l) + tmp_row_ij_m(k,l)
! enddo
! enddo
! mat_p(:,:p1-1,p1) = mat_p(:,:p1-1,p1) + tmp_row_ij2_p(:,:p1-1)
! mat_m(:,:p1-1,p1) = mat_m(:,:p1-1,p1) + tmp_row_ij2_m(:,:p1-1)
! do l=p1,mo_num
! !DIR$ LOOP COUNT AVG(4)
! do k=1,N_states
! mat_p(k,p1,l) = mat_p(k,p1,l) + tmp_row_ij2_p(k,l)
! mat_m(k,p1,l) = mat_m(k,p1,l) + tmp_row_ij2_m(k,l)
! enddo
! enddo
! end if
! end if
! deallocate(lbanned,hijp_cache, hijm_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)
!
! call htilde_mu_mat_tot (gen, det, N_int, hij_p)
! call htildedag_mu_mat_tot(gen, det, N_int, hij_m)
!
! !DIR$ LOOP COUNT AVG(4)
! do k = 1, N_states
! mat_p(k, p1, p2) = mat_p(k, p1, p2) + coefs(k) * hij_p
! mat_m(k, p1, p2) = mat_m(k, p1, p2) + coefs(k) * hij_m
! enddo
! enddo
! enddo
!
!end subroutine get_pm1
! ___________________________________________________________________________________________________________________________________________________
! ___________________________________________________________________________________________________________________________________________________
! ___________________________________________________________________________________________________________________________________________________
! ___________________________________________________________________________________________________________________________________________________
! ___________________________________________________________________________________________________________________________________________________
!subroutine get_pm0(gen, phasemask, bannedOrb, banned, mat_p, mat_m, mask, h, p, sp, coefs)
!
! use bitmasks
! implicit none
!
! integer(bit_kind) :: det(N_int, 2)
! integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
! integer(bit_kind), intent(in) :: phasemask(N_int,2)
! integer, intent(in) :: h(0:2,2), p(0:4,2), sp
! logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
! double precision, intent(in) :: coefs(N_states)
! double precision, intent(inout) :: mat_p(N_states, mo_num, mo_num), mat_m(N_states, mo_num, mo_num)
!
! double precision, external :: get_phase_bi
! double precision, external :: get_mo_bi_ortho_tc_two_e_tc_int, get_mo_bi_ortho_tc_two_e_tcdag_int
! integer, parameter :: bant=1
! integer :: i, j, k, s, h1, h2, p1, p2, puti, putj
! logical :: ok
! double precision :: hij_p, hij_m, phase
! double precision, allocatable :: hijp_cache1(:), hijp_cache2(:), hijm_cache1(:), hijm_cache2(:)
!
! PROVIDE mo_integrals_tc_int_map mo_integrals_tcdag_int_map
!
! allocate( hijp_cache1(mo_num) , hijp_cache2(mo_num) )
! allocate( hijm_cache1(mo_num) , hijm_cache2(mo_num) )
!
! 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_bi_ortho_tc_two_es_tc_int (p1, h2, h1, mo_num, hijp_cache1, mo_integrals_tc_int_map )
! call get_mo_bi_ortho_tc_two_es_tcdag_int(p1, h2, h1, mo_num, hijm_cache1, mo_integrals_tcdag_int_map)
!
! 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 htilde_mu_mat_tot (gen, det, N_int, hij_p)
! call htildedag_mu_mat_tot(gen, det, N_int, hij_m)
! else
! phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
! hij_p = hijp_cache1(p2) * phase
! hij_m = hijm_cache1(p2) * phase
! end if
! if( (hij_p.eq.0.d0).and.(hij_m.eq.0.d0) ) cycle
! !DIR$ LOOP COUNT AVG(4)
! do k = 1, N_states
! mat_p(k, p1, p2) = mat_p(k, p1, p2) + coefs(k) * hij_p ! HOTSPOT
! mat_m(k, p1, p2) = mat_m(k, p1, p2) + coefs(k) * hij_m ! 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_bi_ortho_tc_two_es_tc_int (puti, p2, p1, mo_num, hijp_cache1, mo_integrals_tc_int_map )
! call get_mo_bi_ortho_tc_two_es_tc_int (puti, p1, p2, mo_num, hijp_cache2, mo_integrals_tc_int_map )
! call get_mo_bi_ortho_tc_two_es_tcdag_int(puti, p2, p1, mo_num, hijm_cache1, mo_integrals_tcdag_int_map)
! call get_mo_bi_ortho_tc_two_es_tcdag_int(puti, p1, p2, mo_num, hijm_cache2, mo_integrals_tcdag_int_map)
!
! 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_tot (gen, det, N_int, hij_p)
! call htildedag_mu_mat_tot(gen, det, N_int, hij_m)
! if( (hij_p.eq.0.d0).and.(hij_m.eq.0.d0) ) cycle
! else
!
! hij_p = get_mo_bi_ortho_tc_two_e_tc_int (p1, p2, puti, putj, mo_integrals_tc_int_map ) &
! - get_mo_bi_ortho_tc_two_e_tc_int (p2, p1, puti, putj, mo_integrals_tc_int_map )
! hij_m = get_mo_bi_ortho_tc_two_e_tcdag_int(p1, p2, puti, putj, mo_integrals_tcdag_int_map) &
! - get_mo_bi_ortho_tc_two_e_tcdag_int(p2, p1, puti, putj, mo_integrals_tcdag_int_map)
!
! if( (hij_p.eq.0.d0).and.(hij_m.eq.0.d0) ) cycle
!
! hij_p = hij_p * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int)
! hij_m = hij_m * 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_p(k, puti, putj) = mat_p(k, puti, putj) + coefs(k) * hij_p
! mat_m(k, puti, putj) = mat_m(k, puti, putj) + coefs(k) * hij_m
! enddo
! end do
! end do
! end if
!
! deallocate( hijp_cache1 , hijp_cache2 )
! deallocate( hijm_cache1 , hijm_cache2 )
!
!end subroutine get_pm0
! ___________________________________________________________________________________________________________________________________________________
! ___________________________________________________________________________________________________________________________________________________
! ___________________________________________________________________________________________________________________________________________________
! OLD unoptimized routines for debugging
! ======================================
subroutine get_d0_reference(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
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)
double precision, intent(inout) :: mat(N_states, mo_num, mo_num)
integer, intent(in) :: h(0:2,2), p(0:4,2), sp
integer :: i, j, s, h1, h2, p1, p2, puti, putj
double precision :: hij, phase
double precision, external :: get_phase_bi
logical :: ok
integer :: bant
bant = 1
if(sp == 3) then ! AB
h1 = p(1,1)
h2 = p(1,2)
do p1=1, mo_num
if(bannedOrb(p1, 1)) cycle
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(gen, det, N_int, hij)
else
phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) * phase
end if
mat(:, p1, p2) = mat(:, p1, p2) + coefs(:) * hij
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
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(gen, det, N_int, hij)
else
hij = (mo_bi_ortho_tc_two_e(p1, p2, puti, putj) - mo_bi_ortho_tc_two_e(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int)
end if
mat(:, puti, putj) = mat(:, puti, putj) + coefs(:) * hij
end do
end do
end if
end subroutine get_d0_reference
! ---
subroutine get_d1_reference(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
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)
double precision, intent(inout) :: mat(N_states, mo_num, mo_num)
integer, intent(in) :: h(0:2,2), p(0:4,2), sp
double precision :: hij, tmp_row_ij(N_states, mo_num), tmp_row_ij2(N_states, mo_num), hji
double precision, external :: get_phase_bi
logical :: ok
logical, allocatable :: lbanned(:,:)
integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j
integer :: hfix, pfix, h1, h2, p1, p2, ib
integer, parameter :: turn2(2) = (/2,1/)
integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
integer :: bant
allocate (lbanned(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
tmp_row_ij = 0d0
do putj=1, hfix-1
if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle
hij = (mo_bi_ortho_tc_two_e(p1, p2, putj, hfix)-mo_bi_ortho_tc_two_e(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
tmp_row_ij(1:N_states,putj) = tmp_row_ij(1:N_states,putj) + hij * coefs(1:N_states)
end do
do putj=hfix+1, mo_num
if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle
hij = (mo_bi_ortho_tc_two_e(p1, p2, hfix, putj)-mo_bi_ortho_tc_two_e(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
tmp_row_ij(1:N_states,putj) = tmp_row_ij(1:N_states,putj) + hij * coefs(1:N_states)
end do
if(ma == 1) then
mat(1:N_states,1:mo_num,puti) = mat(1:N_states,1:mo_num,puti) + tmp_row_ij(1:N_states,1:mo_num)
else
mat(1:N_states,puti,1:mo_num) = mat(1:N_states,puti,1:mo_num) + tmp_row_ij(1:N_states,1:mo_num)
end if
end if
!MOVE MI
pfix = p(1,mi)
tmp_row_ij = 0d0
tmp_row_ij2 = 0d0
do puti=1,mo_num
if(lbanned(puti,mi)) cycle
!p1 fixed
putj = p1
if(.not. banned(putj,puti,bant)) then
hij = mo_bi_ortho_tc_two_e(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix, N_int)
tmp_row_ij(:,puti) = tmp_row_ij(:,puti) + hij * coefs(:)
end if
putj = p2
if(.not. banned(putj,puti,bant)) then
hij = mo_bi_ortho_tc_two_e(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix, N_int)
tmp_row_ij2(:,puti) = tmp_row_ij2(:,puti) + hij * coefs(:)
end if
end do
if(mi == 1) then
mat(:,:,p1) = mat(:,:,p1) + tmp_row_ij(:,:)
mat(:,:,p2) = mat(:,:,p2) + tmp_row_ij2(:,:)
else
mat(:,p1,:) = mat(:,p1,:) + tmp_row_ij(:,:)
mat(:,p2,:) = mat(:,p2,:) + tmp_row_ij2(:,:)
end if
else
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)
tmp_row_ij = 0d0
do putj=1,hfix-1
if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle
hij = (mo_bi_ortho_tc_two_e(p1, p2, putj, hfix)-mo_bi_ortho_tc_two_e(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
tmp_row_ij(:,putj) = tmp_row_ij(:,putj) + hij * coefs(:)
end do
do putj=hfix+1,mo_num
if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle
hij = (mo_bi_ortho_tc_two_e(p1, p2, hfix, putj)-mo_bi_ortho_tc_two_e(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
tmp_row_ij(:,putj) = tmp_row_ij(:,putj) + hij * coefs(:)
end do
mat(:, :puti-1, puti) = mat(:, :puti-1, puti) + tmp_row_ij(:,:puti-1)
mat(:, puti, puti:) = mat(:, puti, puti:) + tmp_row_ij(:,puti:)
end do
else
hfix = h(1,mi)
pfix = p(1,mi)
p1 = p(1,ma)
p2 = p(2,ma)
tmp_row_ij = 0d0
tmp_row_ij2 = 0d0
do puti=1,mo_num
if(lbanned(puti,ma)) cycle
putj = p2
if(.not. banned(puti,putj,1)) then
hij = mo_bi_ortho_tc_two_e(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1, N_int)
tmp_row_ij(:,puti) = tmp_row_ij(:,puti) + hij * coefs(:)
end if
putj = p1
if(.not. banned(puti,putj,1)) then
hij = mo_bi_ortho_tc_two_e(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2, N_int)
tmp_row_ij2(:,puti) = tmp_row_ij2(:,puti) + hij * coefs(:)
end if
end do
mat(:,:p2-1,p2) = mat(:,:p2-1,p2) + tmp_row_ij(:,:p2-1)
mat(:,p2,p2:) = mat(:,p2,p2:) + tmp_row_ij(:,p2:)
mat(:,:p1-1,p1) = mat(:,:p1-1,p1) + tmp_row_ij2(:,:p1-1)
mat(:,p1,p1:) = mat(:,p1,p1:) + tmp_row_ij2(:,p1:)
end if
end if
deallocate(lbanned)
!! 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)
call i_h_j(gen, det, N_int, hij)
mat(:, p1, p2) = mat(:, p1, p2) + coefs(:) * hij
end do
end do
end subroutine get_d1_reference
! ---
subroutine get_d2_reference(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
use bitmasks
implicit none
integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2)
integer(bit_kind), intent(in) :: phasemask(2,N_int)
logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
double precision, intent(in) :: coefs(N_states)
double precision, intent(inout) :: mat(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, tip, ma, mi, puti, putj
integer :: h1, h2, p1, p2, i1, i2, mm
double precision :: hij, phase, 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
tip = p(0,1) * p(0,2)
ma = sp
if(p(0,1) > p(0,2)) ma = 1
if(p(0,1) < p(0,2)) ma = 2
mi = mod(ma, 2) + 1
if(sp == 3) then
if(ma == 2) bant = 2
if(tip == 3) then
puti = p(1, mi)
do i = 1, 3
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)
h1 = h(1, ma)
h2 = h(2, ma)
hij = (mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
if(ma == 1) then
mat(:, putj, puti) = mat(:, putj, puti) + coefs(:) * hij
else
mat(:, puti, putj) = mat(:, puti, putj) + coefs(:) * hij
end if
end do
else
h1 = h(1,1)
h2 = h(1,2)
do j = 1,2
putj = p(j, 2)
p2 = p(turn2(j), 2)
do i = 1,2
puti = p(i, 1)
if(banned(puti,putj,bant)) cycle
p1 = p(turn2(i), 1)
hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2,N_int)
mat(:, puti, putj) = mat(:, puti, putj) + coefs(:) * hij
end do
end do
end if
else
if(tip == 0) then
h1 = h(1, ma)
h2 = h(2, ma)
do i=1,3
puti = p(i, ma)
do j=i+1,4
putj = p(j, ma)
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)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2,N_int)
mat(:, puti, putj) = mat(:, puti, putj) + coefs(:) * hij
end do
end do
else if(tip == 3) then
h1 = h(1, mi)
h2 = h(1, ma)
p1 = p(1, mi)
do i=1,3
puti = p(turn3(1,i), ma)
putj = p(turn3(2,i), ma)
if(banned(puti,putj,1)) cycle
p2 = p(i, ma)
hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2,N_int)
mat(:, min(puti, putj), max(puti, putj)) = mat(:, min(puti, putj), max(puti, putj)) + coefs(:) * hij
end do
else ! tip == 4
puti = p(1, sp)
putj = p(2, sp)
if(.not. banned(puti,putj,1)) then
p1 = p(1, mi)
p2 = p(2, mi)
h1 = h(1, mi)
h2 = h(2, mi)
hij = (mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2,N_int)
mat(:, puti, putj) = mat(:, puti, putj) + coefs(:) * hij
end if
end if
end if
end subroutine get_d2_reference(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
! ---