mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-11-04 21:23:56 +01:00
1903 lines
68 KiB
Fortran
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)
|
|
|
|
! ---
|
|
|