mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-10-04 15:15:58 +02:00
added fci_tc and cipsi_tc_bi_ortho
This commit is contained in:
eginer
parent
80b66dee79
commit
b258a2f154
36
src/cipsi_tc_bi_ortho/EZFIO.cfg
Normal file
36
src/cipsi_tc_bi_ortho/EZFIO.cfg
Normal file
@ -0,0 +1,36 @@
|
||||
[save_wf_after_selection]
|
||||
type: logical
|
||||
doc: If true, saves the wave function after the selection, before the diagonalization
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
||||
[seniority_max]
|
||||
type: integer
|
||||
doc: Maximum number of allowed open shells. Using -1 selects all determinants
|
||||
interface: ezfio,ocaml,provider
|
||||
default: -1
|
||||
|
||||
[excitation_ref]
|
||||
type: integer
|
||||
doc: 1: Hartree-Fock determinant, 2:All determinants of the dominant configuration
|
||||
interface: ezfio,ocaml,provider
|
||||
default: 1
|
||||
|
||||
[excitation_max]
|
||||
type: integer
|
||||
doc: Maximum number of excitation with respect to the Hartree-Fock determinant. Using -1 selects all determinants
|
||||
interface: ezfio,ocaml,provider
|
||||
default: -1
|
||||
|
||||
[excitation_alpha_max]
|
||||
type: integer
|
||||
doc: Maximum number of excitation for alpha determinants with respect to the Hartree-Fock determinant. Using -1 selects all determinants
|
||||
interface: ezfio,ocaml,provider
|
||||
default: -1
|
||||
|
||||
[excitation_beta_max]
|
||||
type: integer
|
||||
doc: Maximum number of excitation for beta determinants with respect to the Hartree-Fock determinant. Using -1 selects all determinants
|
||||
interface: ezfio,ocaml,provider
|
||||
default: -1
|
||||
|
||||
6
src/cipsi_tc_bi_ortho/NEED
Normal file
6
src/cipsi_tc_bi_ortho/NEED
Normal file
@ -0,0 +1,6 @@
|
||||
mpi
|
||||
perturbation
|
||||
zmq
|
||||
iterations_tc
|
||||
csf
|
||||
tc_bi_ortho
|
||||
136
src/cipsi_tc_bi_ortho/cipsi.irp.f
Normal file
136
src/cipsi_tc_bi_ortho/cipsi.irp.f
Normal file
@ -0,0 +1,136 @@
|
||||
subroutine run_cipsi
|
||||
|
||||
BEGIN_DOC
|
||||
! Selected Full Configuration Interaction with deterministic selection and
|
||||
! stochastic PT2.
|
||||
END_DOC
|
||||
|
||||
use selection_types
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: i,j,k,ndet
|
||||
type(pt2_type) :: pt2_data, pt2_data_err
|
||||
double precision, allocatable :: zeros(:)
|
||||
integer :: to_select
|
||||
logical, external :: qp_stop
|
||||
|
||||
double precision :: threshold_generators_save
|
||||
double precision :: rss
|
||||
double precision, external :: memory_of_double
|
||||
double precision :: correlation_energy_ratio,E_denom,E_tc,norm
|
||||
|
||||
PROVIDE H_apply_buffer_allocated distributed_davidson
|
||||
|
||||
print*,'Diagonal elements of the Fock matrix '
|
||||
do i = 1, mo_num
|
||||
write(*,*)i,Fock_matrix_tc_mo_tot(i,i)
|
||||
enddo
|
||||
|
||||
N_iter = 1
|
||||
threshold_generators = 1.d0
|
||||
SOFT_TOUCH threshold_generators
|
||||
|
||||
rss = memory_of_double(N_states)*4.d0
|
||||
call check_mem(rss,irp_here)
|
||||
|
||||
allocate (zeros(N_states))
|
||||
call pt2_alloc(pt2_data, N_states)
|
||||
call pt2_alloc(pt2_data_err, N_states)
|
||||
|
||||
double precision :: hf_energy_ref
|
||||
logical :: has, print_pt2
|
||||
double precision :: relative_error
|
||||
|
||||
relative_error=PT2_relative_error
|
||||
|
||||
zeros = 0.d0
|
||||
pt2_data % pt2 = -huge(1.e0)
|
||||
pt2_data % rpt2 = -huge(1.e0)
|
||||
pt2_data % overlap(:,:) = 0.d0
|
||||
pt2_data % variance = huge(1.e0)
|
||||
|
||||
if (s2_eig) then
|
||||
call make_s2_eigenfunction
|
||||
endif
|
||||
print_pt2 = .False.
|
||||
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
|
||||
|
||||
call ezfio_has_hartree_fock_energy(has)
|
||||
if (has) then
|
||||
call ezfio_get_hartree_fock_energy(hf_energy_ref)
|
||||
else
|
||||
hf_energy_ref = ref_bitmask_energy
|
||||
endif
|
||||
|
||||
if (N_det > N_det_max) then
|
||||
psi_det(1:N_int,1:2,1:N_det) = psi_det_sorted_tc_gen(1:N_int,1:2,1:N_det)
|
||||
psi_coef(1:N_det,1:N_states) = psi_coef_sorted_tc_gen(1:N_det,1:N_states)
|
||||
N_det = N_det_max
|
||||
soft_touch N_det psi_det psi_coef
|
||||
if (s2_eig) then
|
||||
call make_s2_eigenfunction
|
||||
endif
|
||||
print_pt2 = .False.
|
||||
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
|
||||
! call routine_save_right
|
||||
endif
|
||||
|
||||
correlation_energy_ratio = 0.d0
|
||||
|
||||
print_pt2 = .True.
|
||||
do while ( &
|
||||
(N_det < N_det_max) .and. &
|
||||
(maxval(abs(pt2_data % pt2(1:N_states))) > pt2_max) &
|
||||
)
|
||||
write(*,'(A)') '--------------------------------------------------------------------------------'
|
||||
|
||||
|
||||
to_select = int(sqrt(dble(N_states))*dble(N_det)*selection_factor)
|
||||
to_select = max(N_states_diag, to_select)
|
||||
|
||||
E_denom = E_tc ! TC Energy of the current wave function
|
||||
if (do_pt2) then
|
||||
call pt2_dealloc(pt2_data)
|
||||
call pt2_dealloc(pt2_data_err)
|
||||
call pt2_alloc(pt2_data, N_states)
|
||||
call pt2_alloc(pt2_data_err, N_states)
|
||||
threshold_generators_save = threshold_generators
|
||||
threshold_generators = 1.d0
|
||||
SOFT_TOUCH threshold_generators
|
||||
call ZMQ_pt2(E_denom, pt2_data, pt2_data_err, relative_error,to_select) ! Stochastic PT2 and selection
|
||||
threshold_generators = threshold_generators_save
|
||||
SOFT_TOUCH threshold_generators
|
||||
else
|
||||
call pt2_dealloc(pt2_data)
|
||||
call pt2_alloc(pt2_data, N_states)
|
||||
call ZMQ_selection(to_select, pt2_data)
|
||||
endif
|
||||
|
||||
N_iter += 1
|
||||
|
||||
if (qp_stop()) exit
|
||||
|
||||
! Add selected determinants
|
||||
call copy_H_apply_buffer_to_wf()
|
||||
|
||||
if (save_wf_after_selection) then
|
||||
call save_wavefunction
|
||||
endif
|
||||
|
||||
PROVIDE psi_coef
|
||||
PROVIDE psi_det
|
||||
PROVIDE psi_det_sorted_tc
|
||||
|
||||
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
|
||||
if (qp_stop()) exit
|
||||
enddo
|
||||
|
||||
call pt2_dealloc(pt2_data)
|
||||
call pt2_dealloc(pt2_data_err)
|
||||
call pt2_alloc(pt2_data, N_states)
|
||||
call pt2_alloc(pt2_data_err, N_states)
|
||||
call ZMQ_pt2(E_tc, pt2_data, pt2_data_err, relative_error,0) ! Stochastic PT2 and selection
|
||||
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
|
||||
|
||||
end
|
||||
51
src/cipsi_tc_bi_ortho/energy.irp.f
Normal file
51
src/cipsi_tc_bi_ortho/energy.irp.f
Normal file
@ -0,0 +1,51 @@
|
||||
BEGIN_PROVIDER [ logical, initialize_pt2_E0_denominator ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! If true, initialize pt2_E0_denominator
|
||||
END_DOC
|
||||
initialize_pt2_E0_denominator = .True.
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! E0 in the denominator of the PT2
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
|
||||
pt2_E0_denominator = eigval_right_tc_bi_orth
|
||||
|
||||
! if (initialize_pt2_E0_denominator) then
|
||||
! if (h0_type == "EN") then
|
||||
! pt2_E0_denominator(1:N_states) = psi_energy(1:N_states)
|
||||
! else if (h0_type == "HF") then
|
||||
! do i=1,N_states
|
||||
! j = maxloc(abs(psi_coef(:,i)),1)
|
||||
! pt2_E0_denominator(i) = psi_det_hii(j)
|
||||
! enddo
|
||||
! else if (h0_type == "Barycentric") then
|
||||
! pt2_E0_denominator(1:N_states) = barycentric_electronic_energy(1:N_states)
|
||||
! else if (h0_type == "CFG") then
|
||||
! pt2_E0_denominator(1:N_states) = psi_energy(1:N_states)
|
||||
! else
|
||||
! print *, h0_type, ' not implemented'
|
||||
! stop
|
||||
! endif
|
||||
! do i=1,N_states
|
||||
! call write_double(6,pt2_E0_denominator(i)+nuclear_repulsion, 'PT2 Energy denominator')
|
||||
! enddo
|
||||
! else
|
||||
! pt2_E0_denominator = -huge(1.d0)
|
||||
! endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, pt2_overlap, (N_states, N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Overlap between the perturbed wave functions
|
||||
END_DOC
|
||||
pt2_overlap(1:N_states,1:N_states) = 0.d0
|
||||
END_PROVIDER
|
||||
|
||||
14
src/cipsi_tc_bi_ortho/environment.irp.f
Normal file
14
src/cipsi_tc_bi_ortho/environment.irp.f
Normal file
@ -0,0 +1,14 @@
|
||||
BEGIN_PROVIDER [ integer, nthreads_pt2 ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Number of threads for Davidson
|
||||
END_DOC
|
||||
nthreads_pt2 = nproc
|
||||
character*(32) :: env
|
||||
call getenv('QP_NTHREADS_PT2',env)
|
||||
if (trim(env) /= '') then
|
||||
read(env,*) nthreads_pt2
|
||||
call write_int(6,nthreads_pt2,'Target number of threads for PT2')
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
95
src/cipsi_tc_bi_ortho/fock_diag.irp.f
Normal file
95
src/cipsi_tc_bi_ortho/fock_diag.irp.f
Normal file
@ -0,0 +1,95 @@
|
||||
subroutine build_fock_tmp_tc(fock_diag_tmp,det_ref,Nint)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Build the diagonal of the Fock matrix corresponding to a generator
|
||||
! determinant. $F_{00}$ is $\langle i|H|i \rangle = E_0$.
|
||||
END_DOC
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: det_ref(Nint,2)
|
||||
double precision, intent(out) :: fock_diag_tmp(2,mo_num+1)
|
||||
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: ne(2), i, j, ii, jj
|
||||
double precision :: E0
|
||||
|
||||
! Compute Fock matrix diagonal elements
|
||||
call bitstring_to_list_ab(det_ref,occ,Ne,Nint)
|
||||
|
||||
fock_diag_tmp = 0.d0
|
||||
E0 = 0.d0
|
||||
|
||||
if (Ne(1) /= elec_alpha_num) then
|
||||
print *, 'Error in build_fock_tmp_tc (alpha)', Ne(1), Ne(2)
|
||||
call debug_det(det_ref,N_int)
|
||||
stop -1
|
||||
endif
|
||||
if (Ne(2) /= elec_beta_num) then
|
||||
print *, 'Error in build_fock_tmp_tc (beta)', Ne(1), Ne(2)
|
||||
call debug_det(det_ref,N_int)
|
||||
stop -1
|
||||
endif
|
||||
|
||||
! Occupied MOs
|
||||
do ii=1,elec_alpha_num
|
||||
i = occ(ii,1)
|
||||
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_one_e_integrals(i,i)
|
||||
E0 = E0 + mo_one_e_integrals(i,i)
|
||||
do jj=1,elec_alpha_num
|
||||
j = occ(jj,1)
|
||||
if (i==j) cycle
|
||||
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_two_e_integrals_jj_anti(i,j)
|
||||
E0 = E0 + 0.5d0*mo_two_e_integrals_jj_anti(i,j)
|
||||
enddo
|
||||
do jj=1,elec_beta_num
|
||||
j = occ(jj,2)
|
||||
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_two_e_integrals_jj(i,j)
|
||||
E0 = E0 + mo_two_e_integrals_jj(i,j)
|
||||
enddo
|
||||
enddo
|
||||
do ii=1,elec_beta_num
|
||||
i = occ(ii,2)
|
||||
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_one_e_integrals(i,i)
|
||||
E0 = E0 + mo_one_e_integrals(i,i)
|
||||
do jj=1,elec_beta_num
|
||||
j = occ(jj,2)
|
||||
if (i==j) cycle
|
||||
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_two_e_integrals_jj_anti(i,j)
|
||||
E0 = E0 + 0.5d0*mo_two_e_integrals_jj_anti(i,j)
|
||||
enddo
|
||||
do jj=1,elec_alpha_num
|
||||
j = occ(jj,1)
|
||||
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_two_e_integrals_jj(i,j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! Virtual MOs
|
||||
do i=1,mo_num
|
||||
if (fock_diag_tmp(1,i) /= 0.d0) cycle
|
||||
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_one_e_integrals(i,i)
|
||||
do jj=1,elec_alpha_num
|
||||
j = occ(jj,1)
|
||||
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_two_e_integrals_jj_anti(i,j)
|
||||
enddo
|
||||
do jj=1,elec_beta_num
|
||||
j = occ(jj,2)
|
||||
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_two_e_integrals_jj(i,j)
|
||||
enddo
|
||||
enddo
|
||||
do i=1,mo_num
|
||||
if (fock_diag_tmp(2,i) /= 0.d0) cycle
|
||||
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_one_e_integrals(i,i)
|
||||
do jj=1,elec_beta_num
|
||||
j = occ(jj,2)
|
||||
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_two_e_integrals_jj_anti(i,j)
|
||||
enddo
|
||||
do jj=1,elec_alpha_num
|
||||
j = occ(jj,1)
|
||||
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_two_e_integrals_jj(i,j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
fock_diag_tmp(1,mo_num+1) = E0
|
||||
fock_diag_tmp(2,mo_num+1) = E0
|
||||
|
||||
end
|
||||
1902
src/cipsi_tc_bi_ortho/get_d.irp.f
Normal file
1902
src/cipsi_tc_bi_ortho/get_d.irp.f
Normal file
File diff suppressed because it is too large
Load Diff
139
src/cipsi_tc_bi_ortho/get_d0_good.irp.f
Normal file
139
src/cipsi_tc_bi_ortho/get_d0_good.irp.f
Normal file
@ -0,0 +1,139 @@
|
||||
subroutine get_d0_new(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs)
|
||||
!todo: indices/conjg should be okay for complex
|
||||
use bitmasks
|
||||
implicit none
|
||||
|
||||
integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
|
||||
integer(bit_kind), intent(in) :: phasemask(N_int,2)
|
||||
logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
|
||||
integer(bit_kind) :: det(N_int, 2)
|
||||
double precision, intent(in) :: coefs(N_states,2)
|
||||
double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num)
|
||||
double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num)
|
||||
integer, intent(in) :: h(0:2,2), p(0:4,2), sp
|
||||
|
||||
integer :: i, j, k, s, h1, h2, p1, p2, puti, putj, mm
|
||||
double precision :: phase
|
||||
double precision :: hij,hji
|
||||
double precision, external :: get_phase_bi
|
||||
logical :: ok
|
||||
|
||||
integer, parameter :: bant=1
|
||||
double precision, allocatable :: hij_cache1(:), hij_cache2(:)
|
||||
allocate (hij_cache1(mo_num),hij_cache2(mo_num))
|
||||
double precision, allocatable :: hji_cache1(:), hji_cache2(:)
|
||||
allocate (hji_cache1(mo_num),hji_cache2(mo_num))
|
||||
! print*,'in get_d0_new'
|
||||
! call debug_det(gen,N_int)
|
||||
! print*,'coefs',coefs(1,:)
|
||||
|
||||
if(sp == 3) then ! AB
|
||||
h1 = p(1,1)
|
||||
h2 = p(1,2)
|
||||
do p1=1, mo_num
|
||||
if(bannedOrb(p1, 1)) cycle
|
||||
! call get_mo_two_e_integrals_complex(p1,h2,h1,mo_num,hij_cache1,mo_integrals_map)
|
||||
do mm = 1, mo_num
|
||||
hij_cache1(mm) = mo_bi_ortho_tc_two_e(mm,p1,h2,h1)
|
||||
hji_cache1(mm) = mo_bi_ortho_tc_two_e(h2,h1,mm,p1)
|
||||
enddo
|
||||
!!!!!!!!!! <alpha|H|psi>
|
||||
do p2=1, mo_num
|
||||
if(bannedOrb(p2,2)) cycle
|
||||
if(banned(p1, p2, bant)) cycle ! rentable?
|
||||
if(p1 == h1 .or. p2 == h2) then
|
||||
call apply_particles(mask, 1,p1,2,p2, det, ok, N_int)
|
||||
! call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this
|
||||
! call i_h_j_complex(det, gen, N_int, hij)
|
||||
call htilde_mu_mat_opt_bi_ortho_no_3e(det,gen,N_int, hij)
|
||||
else
|
||||
phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
|
||||
hij = hij_cache1(p2) * phase
|
||||
end if
|
||||
if (hij == (0.d0,0.d0)) cycle
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,1) * hij ! HOTSPOT
|
||||
enddo
|
||||
end do
|
||||
!!!!!!!!!! <phi|H|alpha>
|
||||
do p2=1, mo_num
|
||||
if(bannedOrb(p2,2)) cycle
|
||||
if(banned(p1, p2, bant)) cycle ! rentable?
|
||||
if(p1 == h1 .or. p2 == h2) then
|
||||
call apply_particles(mask, 1,p1,2,p2, det, ok, N_int)
|
||||
! call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this
|
||||
! call i_h_j_complex(det, gen, N_int, hij)
|
||||
call htilde_mu_mat_opt_bi_ortho_no_3e(gen,det,N_int, hji)
|
||||
else
|
||||
phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
|
||||
hji = hji_cache1(p2) * phase
|
||||
end if
|
||||
if (hji == (0.d0,0.d0)) cycle
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_l(k, p1, p2) = mat_l(k, p1, p2) + coefs(k,2) * hji ! HOTSPOT
|
||||
enddo
|
||||
end do
|
||||
end do
|
||||
|
||||
else ! AA BB
|
||||
p1 = p(1,sp)
|
||||
p2 = p(2,sp)
|
||||
do puti=1, mo_num
|
||||
if(bannedOrb(puti, sp)) cycle
|
||||
! call get_mo_two_e_integrals_complex(puti,p2,p1,mo_num,hij_cache1,mo_integrals_map,mo_integrals_map_2)
|
||||
! call get_mo_two_e_integrals_complex(puti,p1,p2,mo_num,hij_cache2,mo_integrals_map,mo_integrals_map_2)
|
||||
do mm = 1, mo_num
|
||||
hij_cache1(mm) = mo_bi_ortho_tc_two_e(mm,puti,p2,p1)
|
||||
hij_cache2(mm) = mo_bi_ortho_tc_two_e(mm,puti,p1,p2)
|
||||
hji_cache1(mm) = mo_bi_ortho_tc_two_e(p2,p1,mm,puti)
|
||||
hji_cache2(mm) = mo_bi_ortho_tc_two_e(p1,p2,mm,puti)
|
||||
enddo
|
||||
!!!!!!!!!! <alpha|H|psi>
|
||||
do putj=puti+1, mo_num
|
||||
if(bannedOrb(putj, sp)) cycle
|
||||
if(banned(puti, putj, bant)) cycle ! rentable?
|
||||
if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then
|
||||
call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int)
|
||||
!call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this
|
||||
! call i_h_j_complex(det, gen, N_int, hij)
|
||||
call htilde_mu_mat_opt_bi_ortho_no_3e(det,gen,N_int, hij)
|
||||
if (hij == 0.d0) cycle
|
||||
else
|
||||
! hij = (mo_two_e_integral_complex(p1, p2, puti, putj) - mo_two_e_integral_complex(p2, p1, puti, putj))
|
||||
! hij = (mo_bi_ortho_tc_two_e(p1, p2, puti, putj) - mo_bi_ortho_tc_two_e(p2, p1, puti, putj))
|
||||
hij = (mo_bi_ortho_tc_two_e(puti, putj, p1, p2) - mo_bi_ortho_tc_two_e(puti, putj, p2, p1))
|
||||
if (hij == 0.d0) cycle
|
||||
hij = (hij) * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int)
|
||||
end if
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,1) * hij
|
||||
enddo
|
||||
end do
|
||||
|
||||
!!!!!!!!!! <phi|H|alpha>
|
||||
do putj=puti+1, mo_num
|
||||
if(bannedOrb(putj, sp)) cycle
|
||||
if(banned(puti, putj, bant)) cycle ! rentable?
|
||||
if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then
|
||||
call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int)
|
||||
call htilde_mu_mat_opt_bi_ortho_no_3e(gen,det,N_int, hji)
|
||||
if (hji == 0.d0) cycle
|
||||
else
|
||||
hji = (mo_bi_ortho_tc_two_e( p1, p2, puti, putj) - mo_bi_ortho_tc_two_e( p2, p1, puti, putj))
|
||||
if (hji == 0.d0) cycle
|
||||
hji = (hji) * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int)
|
||||
end if
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,2) * hji
|
||||
enddo
|
||||
end do
|
||||
end do
|
||||
end if
|
||||
|
||||
deallocate(hij_cache1,hij_cache2)
|
||||
end
|
||||
|
||||
454
src/cipsi_tc_bi_ortho/get_d1_good.irp.f
Normal file
454
src/cipsi_tc_bi_ortho/get_d1_good.irp.f
Normal file
@ -0,0 +1,454 @@
|
||||
subroutine get_d1_new(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs)
|
||||
!todo: indices should be okay for complex?
|
||||
use bitmasks
|
||||
implicit none
|
||||
|
||||
integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2)
|
||||
integer(bit_kind), intent(in) :: phasemask(N_int,2)
|
||||
logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
|
||||
integer(bit_kind) :: det(N_int, 2)
|
||||
double precision, intent(in) :: coefs(N_states,2)
|
||||
double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num)
|
||||
double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num)
|
||||
integer, intent(in) :: h(0:2,2), p(0:4,2), sp
|
||||
double precision, external :: get_phase_bi
|
||||
double precision, external :: mo_two_e_integral_complex
|
||||
logical :: ok
|
||||
|
||||
logical, allocatable :: lbanned(:,:)
|
||||
integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j
|
||||
integer :: hfix, pfix, h1, h2, p1, p2, ib, k, l, mm
|
||||
|
||||
integer, parameter :: turn2(2) = (/2,1/)
|
||||
integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
|
||||
|
||||
integer :: bant
|
||||
double precision, allocatable :: hij_cache(:,:)
|
||||
double precision :: hij, tmp_rowij(N_states, mo_num), tmp_rowij2(N_states, mo_num)
|
||||
double precision, allocatable :: hji_cache(:,:)
|
||||
double precision :: hji, tmp_rowji(N_states, mo_num), tmp_rowji2(N_states, mo_num)
|
||||
! PROVIDE mo_integrals_map N_int
|
||||
! print*,'in get_d1_new'
|
||||
! call debug_det(gen,N_int)
|
||||
! print*,'coefs',coefs(1,:)
|
||||
|
||||
allocate (lbanned(mo_num, 2))
|
||||
allocate (hij_cache(mo_num,2))
|
||||
allocate (hji_cache(mo_num,2))
|
||||
lbanned = bannedOrb
|
||||
|
||||
do i=1, p(0,1)
|
||||
lbanned(p(i,1), 1) = .true.
|
||||
end do
|
||||
do i=1, p(0,2)
|
||||
lbanned(p(i,2), 2) = .true.
|
||||
end do
|
||||
|
||||
ma = 1
|
||||
if(p(0,2) >= 2) ma = 2
|
||||
mi = turn2(ma)
|
||||
|
||||
bant = 1
|
||||
|
||||
if(sp == 3) then
|
||||
!move MA
|
||||
if(ma == 2) bant = 2
|
||||
puti = p(1,mi)
|
||||
hfix = h(1,ma)
|
||||
p1 = p(1,ma)
|
||||
p2 = p(2,ma)
|
||||
if(.not. bannedOrb(puti, mi)) then
|
||||
! call get_mo_two_e_integrals_complex(hfix,p1,p2,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
|
||||
! call get_mo_two_e_integrals_complex(hfix,p2,p1,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
|
||||
do mm = 1, mo_num
|
||||
hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,p2)
|
||||
hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,p1)
|
||||
hji_cache(mm,1) = mo_bi_ortho_tc_two_e(p1,p2,mm,hfix)
|
||||
hji_cache(mm,2) = mo_bi_ortho_tc_two_e(p2,p1,mm,hfix)
|
||||
enddo
|
||||
!! <alpha|H|psi>
|
||||
tmp_rowij = 0.d0
|
||||
do putj=1, hfix-1
|
||||
if(lbanned(putj, ma)) cycle
|
||||
if(banned(putj, puti,bant)) cycle
|
||||
hij = hij_cache(putj,1) - hij_cache(putj,2)
|
||||
if (hij /= 0.d0) then
|
||||
hij = hij * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
tmp_rowij(k,putj) = tmp_rowij(k,putj) + hij * coefs(k,1)
|
||||
enddo
|
||||
endif
|
||||
end do
|
||||
do putj=hfix+1, mo_num
|
||||
if(lbanned(putj, ma)) cycle
|
||||
if(banned(putj, puti,bant)) cycle
|
||||
hij = hij_cache(putj,2) - hij_cache(putj,1)
|
||||
if (hij /= 0.d0) then
|
||||
hij = hij * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
tmp_rowij(k,putj) = tmp_rowij(k,putj) + hij * coefs(k,1)
|
||||
enddo
|
||||
endif
|
||||
end do
|
||||
|
||||
if(ma == 1) then
|
||||
mat_r(1:N_states,1:mo_num,puti) = mat_r(1:N_states,1:mo_num,puti) + tmp_rowij(1:N_states,1:mo_num)
|
||||
else
|
||||
do l=1,mo_num
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k,puti,l) = mat_r(k,puti,l) + tmp_rowij(k,l)
|
||||
enddo
|
||||
enddo
|
||||
end if
|
||||
|
||||
!! <phi|H|alpha>
|
||||
tmp_rowji = 0.d0
|
||||
do putj=1, hfix-1
|
||||
if(lbanned(putj, ma)) cycle
|
||||
if(banned(putj, puti,bant)) cycle
|
||||
hji = hji_cache(putj,1) - hji_cache(putj,2)
|
||||
if (hji /= 0.d0) then
|
||||
hji = hji * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
tmp_rowji(k,putj) = tmp_rowji(k,putj) + hji * coefs(k,2)
|
||||
enddo
|
||||
endif
|
||||
end do
|
||||
do putj=hfix+1, mo_num
|
||||
if(lbanned(putj, ma)) cycle
|
||||
if(banned(putj, puti,bant)) cycle
|
||||
hji = hji_cache(putj,2) - hji_cache(putj,1)
|
||||
if (hji /= 0.d0) then
|
||||
hji = hji * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
tmp_rowji(k,putj) = tmp_rowji(k,putj) + hji * coefs(k,2)
|
||||
enddo
|
||||
endif
|
||||
end do
|
||||
|
||||
if(ma == 1) then
|
||||
mat_l(1:N_states,1:mo_num,puti) = mat_l(1:N_states,1:mo_num,puti) + tmp_rowji(1:N_states,1:mo_num)
|
||||
else
|
||||
do l=1,mo_num
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_l(k,puti,l) = mat_l(k,puti,l) + tmp_rowji(k,l)
|
||||
enddo
|
||||
enddo
|
||||
end if
|
||||
end if
|
||||
|
||||
!MOVE MI
|
||||
pfix = p(1,mi)
|
||||
tmp_rowij = 0.d0
|
||||
tmp_rowij2 = 0.d0
|
||||
tmp_rowji = 0.d0
|
||||
tmp_rowji2 = 0.d0
|
||||
! call get_mo_two_e_integrals_complex(hfix,pfix,p1,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
|
||||
! call get_mo_two_e_integrals_complex(hfix,pfix,p2,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
|
||||
do mm = 1, mo_num
|
||||
hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,pfix,p1)
|
||||
hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,pfix,p2)
|
||||
hji_cache(mm,1) = mo_bi_ortho_tc_two_e(pfix,p1,mm,hfix)
|
||||
hji_cache(mm,2) = mo_bi_ortho_tc_two_e(pfix,p2,mm,hfix)
|
||||
enddo
|
||||
putj = p1
|
||||
!! <alpha|H|psi>
|
||||
do puti=1,mo_num !HOT
|
||||
if(lbanned(puti,mi)) cycle
|
||||
!p1 fixed
|
||||
putj = p1
|
||||
if(.not. banned(putj,puti,bant)) then
|
||||
hij = hij_cache(puti,2)
|
||||
if (hij /= 0.d0) then
|
||||
hij = hij * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix, N_int)
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
tmp_rowij(k,puti) = tmp_rowij(k,puti) + hij * coefs(k,1)
|
||||
enddo
|
||||
endif
|
||||
end if
|
||||
!
|
||||
putj = p2
|
||||
if(.not. banned(putj,puti,bant)) then
|
||||
hij = hij_cache(puti,1)
|
||||
if (hij /= 0.d0) then
|
||||
hij = hij * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix, N_int)
|
||||
do k=1,N_states
|
||||
tmp_rowij2(k,puti) = tmp_rowij2(k,puti) + hij * coefs(k,1)
|
||||
enddo
|
||||
endif
|
||||
end if
|
||||
end do
|
||||
|
||||
if(mi == 1) then
|
||||
mat_r(:,:,p1) = mat_r(:,:,p1) + tmp_rowij(:,:)
|
||||
mat_r(:,:,p2) = mat_r(:,:,p2) + tmp_rowij2(:,:)
|
||||
else
|
||||
do l=1,mo_num
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k,p1,l) = mat_r(k,p1,l) + tmp_rowij(k,l)
|
||||
mat_r(k,p2,l) = mat_r(k,p2,l) + tmp_rowij2(k,l)
|
||||
enddo
|
||||
enddo
|
||||
end if
|
||||
|
||||
putj = p1
|
||||
!! <phi|H|alpha>
|
||||
do puti=1,mo_num !HOT
|
||||
if(lbanned(puti,mi)) cycle
|
||||
!p1 fixed
|
||||
putj = p1
|
||||
if(.not. banned(putj,puti,bant)) then
|
||||
hji = hji_cache(puti,2)
|
||||
if (hji /= 0.d0) then
|
||||
hji = hji * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix, N_int)
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
tmp_rowji(k,puti) = tmp_rowji(k,puti) + hji * coefs(k,2)
|
||||
enddo
|
||||
endif
|
||||
end if
|
||||
!
|
||||
putj = p2
|
||||
if(.not. banned(putj,puti,bant)) then
|
||||
hji = hji_cache(puti,1)
|
||||
if (hji /= 0.d0) then
|
||||
hji = hji * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix, N_int)
|
||||
do k=1,N_states
|
||||
tmp_rowji2(k,puti) = tmp_rowji2(k,puti) + hji * coefs(k,2)
|
||||
enddo
|
||||
endif
|
||||
end if
|
||||
end do
|
||||
|
||||
if(mi == 1) then
|
||||
mat_l(:,:,p1) = mat_l(:,:,p1) + tmp_rowji(:,:)
|
||||
mat_l(:,:,p2) = mat_l(:,:,p2) + tmp_rowji2(:,:)
|
||||
else
|
||||
do l=1,mo_num
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_l(k,p1,l) = mat_l(k,p1,l) + tmp_rowji(k,l)
|
||||
mat_l(k,p2,l) = mat_l(k,p2,l) + tmp_rowji2(k,l)
|
||||
enddo
|
||||
enddo
|
||||
end if
|
||||
|
||||
else ! sp /= 3
|
||||
|
||||
if(p(0,ma) == 3) then
|
||||
do i=1,3
|
||||
hfix = h(1,ma)
|
||||
puti = p(i, ma)
|
||||
p1 = p(turn3(1,i), ma)
|
||||
p2 = p(turn3(2,i), ma)
|
||||
! call get_mo_two_e_integrals_complex(hfix,p1,p2,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
|
||||
! call get_mo_two_e_integrals_complex(hfix,p2,p1,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
|
||||
do mm = 1, mo_num
|
||||
hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,p2)
|
||||
hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,p1)
|
||||
hji_cache(mm,1) = mo_bi_ortho_tc_two_e(p1,p2,mm,hfix)
|
||||
hji_cache(mm,2) = mo_bi_ortho_tc_two_e(p2,p1,mm,hfix)
|
||||
enddo
|
||||
!! <alpha|H|psi>
|
||||
tmp_rowij = 0.d0
|
||||
do putj=1,hfix-1
|
||||
if(banned(putj,puti,1)) cycle
|
||||
if(lbanned(putj,ma)) cycle
|
||||
hij = hij_cache(putj,1) - hij_cache(putj,2)
|
||||
if (hij /= 0.d0) then
|
||||
hij = hij * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
|
||||
tmp_rowij(:,putj) = tmp_rowij(:,putj) + hij * coefs(:,1)
|
||||
endif
|
||||
end do
|
||||
do putj=hfix+1,mo_num
|
||||
if(banned(putj,puti,1)) cycle
|
||||
if(lbanned(putj,ma)) cycle
|
||||
hij = hij_cache(putj,2) - hij_cache(putj,1)
|
||||
if (hij /= 0.d0) then
|
||||
hij = hij * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
|
||||
tmp_rowij(:,putj) = tmp_rowij(:,putj) + hij * coefs(:,1)
|
||||
endif
|
||||
end do
|
||||
|
||||
mat_r(:, :puti-1, puti) = mat_r(:, :puti-1, puti) + tmp_rowij(:,:puti-1)
|
||||
do l=puti,mo_num
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k, puti, l) = mat_r(k, puti,l) + tmp_rowij(k,l)
|
||||
enddo
|
||||
enddo
|
||||
!! <phi|H|alpha>
|
||||
tmp_rowji = 0.d0
|
||||
do putj=1,hfix-1
|
||||
if(banned(putj,puti,1)) cycle
|
||||
if(lbanned(putj,ma)) cycle
|
||||
hji = hji_cache(putj,1) - hji_cache(putj,2)
|
||||
if (hji /= 0.d0) then
|
||||
hji = hji * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
|
||||
tmp_rowji(:,putj) = tmp_rowji(:,putj) + hji * coefs(:,2)
|
||||
endif
|
||||
end do
|
||||
do putj=hfix+1,mo_num
|
||||
if(banned(putj,puti,1)) cycle
|
||||
if(lbanned(putj,ma)) cycle
|
||||
hji = hji_cache(putj,2) - hji_cache(putj,1)
|
||||
if (hji /= 0.d0) then
|
||||
hji = hji * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
|
||||
tmp_rowji(:,putj) = tmp_rowji(:,putj) + hji * coefs(:,2)
|
||||
endif
|
||||
end do
|
||||
|
||||
mat_l(:, :puti-1, puti) = mat_l(:, :puti-1, puti) + tmp_rowji(:,:puti-1)
|
||||
do l=puti,mo_num
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_l(k, puti, l) = mat_l(k, puti,l) + tmp_rowji(k,l)
|
||||
enddo
|
||||
enddo
|
||||
end do
|
||||
else
|
||||
hfix = h(1,mi)
|
||||
pfix = p(1,mi)
|
||||
p1 = p(1,ma)
|
||||
p2 = p(2,ma)
|
||||
tmp_rowij = 0.d0
|
||||
tmp_rowij2 = 0.d0
|
||||
tmp_rowji = 0.d0
|
||||
tmp_rowji2 = 0.d0
|
||||
! call get_mo_two_e_integrals_complex(hfix,p1,pfix,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
|
||||
! call get_mo_two_e_integrals_complex(hfix,p2,pfix,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
|
||||
do mm = 1, mo_num
|
||||
hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,pfix)
|
||||
hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,pfix)
|
||||
hji_cache(mm,1) = mo_bi_ortho_tc_two_e(p1,pfix,mm,hfix)
|
||||
hji_cache(mm,2) = mo_bi_ortho_tc_two_e(p2,pfix,mm,hfix)
|
||||
enddo
|
||||
putj = p2
|
||||
!! <alpha|H|psi>
|
||||
do puti=1,mo_num
|
||||
if(lbanned(puti,ma)) cycle
|
||||
putj = p2
|
||||
if(.not. banned(puti,putj,1)) then
|
||||
hij = hij_cache(puti,1)
|
||||
if (hij /= 0.d0) then
|
||||
hij = hij * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1, N_int)
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
tmp_rowij(k,puti) = tmp_rowij(k,puti) + hij * coefs(k,1)
|
||||
enddo
|
||||
endif
|
||||
end if
|
||||
|
||||
putj = p1
|
||||
if(.not. banned(puti,putj,1)) then
|
||||
hij = hij_cache(puti,2)
|
||||
if (hij /= 0.d0) then
|
||||
hij = hij * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2, N_int)
|
||||
do k=1,N_states
|
||||
tmp_rowij2(k,puti) = tmp_rowij2(k,puti) + hij * coefs(k,1)
|
||||
enddo
|
||||
endif
|
||||
end if
|
||||
end do
|
||||
mat_r(:,:p2-1,p2) = mat_r(:,:p2-1,p2) + tmp_rowij(:,:p2-1)
|
||||
do l=p2,mo_num
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k,p2,l) = mat_r(k,p2,l) + tmp_rowij(k,l)
|
||||
enddo
|
||||
enddo
|
||||
mat_r(:,:p1-1,p1) = mat_r(:,:p1-1,p1) + tmp_rowij2(:,:p1-1)
|
||||
do l=p1,mo_num
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k,p1,l) = mat_r(k,p1,l) + tmp_rowij2(k,l)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
|
||||
!! <phi|H|alpha>
|
||||
putj = p2
|
||||
do puti=1,mo_num
|
||||
if(lbanned(puti,ma)) cycle
|
||||
putj = p2
|
||||
if(.not. banned(puti,putj,1)) then
|
||||
hji = hji_cache(puti,1)
|
||||
if (hji /= 0.d0) then
|
||||
hji = hji * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1, N_int)
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
tmp_rowji(k,puti) = tmp_rowji(k,puti) + hji * coefs(k,2)
|
||||
enddo
|
||||
endif
|
||||
end if
|
||||
|
||||
putj = p1
|
||||
if(.not. banned(puti,putj,1)) then
|
||||
hji = hji_cache(puti,2)
|
||||
if (hji /= 0.d0) then
|
||||
hji = hji * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2, N_int)
|
||||
do k=1,N_states
|
||||
tmp_rowji2(k,puti) = tmp_rowji2(k,puti) + hji * coefs(k,2)
|
||||
enddo
|
||||
endif
|
||||
end if
|
||||
end do
|
||||
mat_l(:,:p2-1,p2) = mat_l(:,:p2-1,p2) + tmp_rowji(:,:p2-1)
|
||||
do l=p2,mo_num
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_l(k,p2,l) = mat_l(k,p2,l) + tmp_rowji(k,l)
|
||||
enddo
|
||||
enddo
|
||||
mat_l(:,:p1-1,p1) = mat_l(:,:p1-1,p1) + tmp_rowji2(:,:p1-1)
|
||||
do l=p1,mo_num
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_l(k,p1,l) = mat_l(k,p1,l) + tmp_rowji2(k,l)
|
||||
enddo
|
||||
enddo
|
||||
end if
|
||||
end if
|
||||
deallocate(lbanned,hij_cache, hji_cache)
|
||||
|
||||
!! MONO
|
||||
if(sp == 3) then
|
||||
s1 = 1
|
||||
s2 = 2
|
||||
else
|
||||
s1 = sp
|
||||
s2 = sp
|
||||
end if
|
||||
|
||||
do i1=1,p(0,s1)
|
||||
ib = 1
|
||||
if(s1 == s2) ib = i1+1
|
||||
do i2=ib,p(0,s2)
|
||||
p1 = p(i1,s1)
|
||||
p2 = p(i2,s2)
|
||||
if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle
|
||||
call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
|
||||
! gen is a selector; mask is ionized generator; det is alpha
|
||||
! hij is contribution to <psi|H|alpha>
|
||||
! call i_h_j_complex(gen, det, N_int, hij)
|
||||
call htilde_mu_mat_opt_bi_ortho_no_3e(det, gen, N_int, hij)
|
||||
call htilde_mu_mat_opt_bi_ortho_no_3e(gen, det, N_int, hji)
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
! take conjugate to get contribution to <alpha|H|psi> instead of <psi|H|alpha>
|
||||
! mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,1) * dconjg(hij)
|
||||
mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,1) * hij
|
||||
mat_l(k, p1, p2) = mat_l(k, p1, p2) + coefs(k,2) * hji
|
||||
enddo
|
||||
end do
|
||||
end do
|
||||
end
|
||||
|
||||
308
src/cipsi_tc_bi_ortho/get_d2_good.irp.f
Normal file
308
src/cipsi_tc_bi_ortho/get_d2_good.irp.f
Normal file
@ -0,0 +1,308 @@
|
||||
|
||||
subroutine get_d2_new(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs)
|
||||
!todo: indices/conjg should be correct for complex
|
||||
use bitmasks
|
||||
implicit none
|
||||
|
||||
integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2)
|
||||
integer(bit_kind), intent(in) :: phasemask(N_int,2)
|
||||
logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
|
||||
double precision, intent(in) :: coefs(N_states,2)
|
||||
double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num)
|
||||
double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num)
|
||||
integer, intent(in) :: h(0:2,2), p(0:4,2), sp
|
||||
|
||||
double precision, external :: get_phase_bi
|
||||
|
||||
integer :: i, j, k, tip, ma, mi, puti, putj
|
||||
integer :: h1, h2, p1, p2, i1, i2
|
||||
double precision :: phase
|
||||
double precision :: hij,hji
|
||||
|
||||
integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/))
|
||||
integer, parameter :: turn2(2) = (/2, 1/)
|
||||
integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
|
||||
|
||||
integer :: bant
|
||||
bant = 1
|
||||
! print*, 'in get_d2_new'
|
||||
! call debug_det(gen,N_int)
|
||||
! print*,'coefs',coefs(1,:)
|
||||
|
||||
tip = p(0,1) * p(0,2) ! number of alpha particles times number of beta particles
|
||||
|
||||
ma = sp !1:(alpha,alpha); 2:(b,b); 3:(a,b)
|
||||
if(p(0,1) > p(0,2)) ma = 1 ! more alpha particles than beta particles
|
||||
if(p(0,1) < p(0,2)) ma = 2 ! fewer alpha particles than beta particles
|
||||
mi = mod(ma, 2) + 1
|
||||
|
||||
if(sp == 3) then ! if one alpha and one beta xhole
|
||||
!(where xholes refer to the ionizations from the generator, not the holes occupied in the ionized generator)
|
||||
if(ma == 2) bant = 2 ! if more beta particles than alpha particles
|
||||
|
||||
if(tip == 3) then ! if 3 of one particle spin and 1 of the other particle spin
|
||||
puti = p(1, mi)
|
||||
if(bannedOrb(puti, mi)) return
|
||||
h1 = h(1, ma)
|
||||
h2 = h(2, ma)
|
||||
|
||||
!! <alpha|H|psi>
|
||||
do i = 1, 3 ! loop over all 3 combinations of 2 particles with spin ma
|
||||
putj = p(i, ma)
|
||||
if(banned(putj,puti,bant)) cycle
|
||||
i1 = turn3(1,i)
|
||||
i2 = turn3(2,i)
|
||||
p1 = p(i1, ma)
|
||||
p2 = p(i2, ma)
|
||||
|
||||
! |G> = |psi_{gen,i}>
|
||||
! |G'> = a_{x1} a_{x2} |G>
|
||||
! |alpha> = a_{puti}^{\dagger} a_{putj}^{\dagger} |G'>
|
||||
! |alpha> = t_{x1,x2}^{puti,putj} |G>
|
||||
! hij = <psi_{selectors,i}|H|alpha>
|
||||
! |alpha> = t_{p1,p2}^{h1,h2}|psi_{selectors,i}>
|
||||
!todo: <i|H|j> = (<h1,h2|p1,p2> - <h1,h2|p2,p1>) * phase
|
||||
! <psi|H|j> += dconjg(c_i) * <i|H|j>
|
||||
! <j|H|i> = (<p1,p2|h1,h2> - <p2,p1|h1,h2>) * phase
|
||||
! <j|H|psi> += <j|H|i> * c_i
|
||||
! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2, p1, h1, h2)
|
||||
|
||||
!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
|
||||
! take the transpose of what's written above because later use the complex conjugate
|
||||
hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2) - mo_bi_ortho_tc_two_e( h1, h2, p2, p1)
|
||||
if (hij == 0.d0) cycle
|
||||
|
||||
! take conjugate to get contribution to <alpha|H|psi> instead of <psi|H|alpha>
|
||||
! hij = dconjg(hij) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
|
||||
hij = hij * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
|
||||
|
||||
if(ma == 1) then ! if particle spins are (alpha,alpha,alpha,beta), then puti is beta and putj is alpha
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k, putj, puti) = mat_r(k, putj, puti) + coefs(k,1) * hij
|
||||
enddo
|
||||
else ! if particle spins are (beta,beta,beta,alpha), then puti is alpha and putj is beta
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,1) * hij
|
||||
enddo
|
||||
end if
|
||||
end do
|
||||
!! <phi|H|alpha>
|
||||
do i = 1, 3 ! loop over all 3 combinations of 2 particles with spin ma
|
||||
putj = p(i, ma)
|
||||
if(banned(putj,puti,bant)) cycle
|
||||
i1 = turn3(1,i)
|
||||
i2 = turn3(2,i)
|
||||
p1 = p(i1, ma)
|
||||
p2 = p(i2, ma)
|
||||
hji = mo_bi_ortho_tc_two_e(p1, p2,h1, h2) - mo_bi_ortho_tc_two_e( p2, p1, h1, h2)
|
||||
if (hji == 0.d0) cycle
|
||||
hji = hji * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
|
||||
|
||||
if(ma == 1) then ! if particle spins are (alpha,alpha,alpha,beta), then puti is beta and putj is alpha
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_l(k, putj, puti) = mat_l(k, putj, puti) + coefs(k,2) * hji
|
||||
enddo
|
||||
else ! if particle spins are (beta,beta,beta,alpha), then puti is alpha and putj is beta
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,2) * hji
|
||||
enddo
|
||||
end if
|
||||
end do
|
||||
else ! if 2 alpha and 2 beta particles
|
||||
h1 = h(1,1)
|
||||
h2 = h(1,2)
|
||||
!! <alpha|H|psi>
|
||||
do j = 1,2 ! loop over all 4 combinations of one alpha and one beta particle
|
||||
putj = p(j, 2)
|
||||
if(bannedOrb(putj, 2)) cycle
|
||||
p2 = p(turn2(j), 2)
|
||||
do i = 1,2
|
||||
puti = p(i, 1)
|
||||
if(banned(puti,putj,bant) .or. bannedOrb(puti,1)) cycle
|
||||
p1 = p(turn2(i), 1)
|
||||
! hij = <psi_{selectors,i}|H|alpha>
|
||||
! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2)
|
||||
!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
|
||||
! take the transpose of what's written above because later use the complex conjugate
|
||||
hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2 )
|
||||
if (hij /= 0.d0) then
|
||||
! take conjugate to get contribution to <alpha|H|psi> instead of <psi|H|alpha>
|
||||
! hij = dconjg(hij) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
|
||||
hij = hij * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,1) * hij
|
||||
enddo
|
||||
endif
|
||||
end do
|
||||
end do
|
||||
!! <phi|H|alpha>
|
||||
do j = 1,2 ! loop over all 4 combinations of one alpha and one beta particle
|
||||
putj = p(j, 2)
|
||||
if(bannedOrb(putj, 2)) cycle
|
||||
p2 = p(turn2(j), 2)
|
||||
do i = 1,2
|
||||
puti = p(i, 1)
|
||||
if(banned(puti,putj,bant) .or. bannedOrb(puti,1)) cycle
|
||||
p1 = p(turn2(i), 1)
|
||||
hji = mo_bi_ortho_tc_two_e( p1, p2, h1, h2)
|
||||
if (hji /= 0.d0) then
|
||||
hji = hji * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,2) * hji
|
||||
enddo
|
||||
endif
|
||||
end do
|
||||
end do
|
||||
end if
|
||||
|
||||
else ! if holes are (a,a) or (b,b)
|
||||
if(tip == 0) then ! if particles are (a,a,a,a) or (b,b,b,b)
|
||||
h1 = h(1, ma)
|
||||
h2 = h(2, ma)
|
||||
!! <alpha|H|psi>
|
||||
do i=1,3
|
||||
puti = p(i, ma)
|
||||
if(bannedOrb(puti,ma)) cycle
|
||||
do j=i+1,4
|
||||
putj = p(j, ma)
|
||||
if(bannedOrb(putj,ma)) cycle
|
||||
if(banned(puti,putj,1)) cycle
|
||||
|
||||
i1 = turn2d(1, i, j)
|
||||
i2 = turn2d(2, i, j)
|
||||
p1 = p(i1, ma)
|
||||
p2 = p(i2, ma)
|
||||
! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1, h1, h2)
|
||||
!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
|
||||
! take the transpose of what's written above because later use the complex conjugate
|
||||
hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2) - mo_bi_ortho_tc_two_e(h1, h2, p2,p1 )
|
||||
if (hij == 0.d0) cycle
|
||||
|
||||
! take conjugate to get contribution to <alpha|H|psi> instead of <psi|H|alpha>
|
||||
! hij = dconjg(hij) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
|
||||
hij = hij * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k, puti, putj) = mat_r(k, puti, putj) +coefs(k,1) * hij
|
||||
enddo
|
||||
end do
|
||||
end do
|
||||
!! <phi|H|alpha>
|
||||
do i=1,3
|
||||
puti = p(i, ma)
|
||||
if(bannedOrb(puti,ma)) cycle
|
||||
do j=i+1,4
|
||||
putj = p(j, ma)
|
||||
if(bannedOrb(putj,ma)) cycle
|
||||
if(banned(puti,putj,1)) cycle
|
||||
i1 = turn2d(1, i, j)
|
||||
i2 = turn2d(2, i, j)
|
||||
p1 = p(i1, ma)
|
||||
p2 = p(i2, ma)
|
||||
hji = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1,h1, h2 )
|
||||
if (hji == 0.d0) cycle
|
||||
hji = hji * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_l(k, puti, putj) = mat_l(k, puti, putj) +coefs(k,2) * hji
|
||||
enddo
|
||||
end do
|
||||
end do
|
||||
else if(tip == 3) then ! if particles are (a,a,a,b) (ma=1,mi=2) or (a,b,b,b) (ma=2,mi=1)
|
||||
h1 = h(1, mi)
|
||||
h2 = h(1, ma)
|
||||
p1 = p(1, mi)
|
||||
!! <alpha|H|psi>
|
||||
do i=1,3
|
||||
puti = p(turn3(1,i), ma)
|
||||
if(bannedOrb(puti,ma)) cycle
|
||||
putj = p(turn3(2,i), ma)
|
||||
if(bannedOrb(putj,ma)) cycle
|
||||
if(banned(puti,putj,1)) cycle
|
||||
p2 = p(i, ma)
|
||||
|
||||
! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2)
|
||||
!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
|
||||
! take the transpose of what's written above because later use the complex conjugate
|
||||
hij = mo_bi_ortho_tc_two_e(h1, h2,p1, p2 )
|
||||
if (hij == 0.d0) cycle
|
||||
|
||||
! take conjugate to get contribution to <alpha|H|psi> instead of <psi|H|alpha>
|
||||
! hij = dconjg(hij) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int)
|
||||
hij = hij * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int)
|
||||
if (puti < putj) then
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,1) * hij
|
||||
enddo
|
||||
else
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do k=1,N_states
|
||||
mat_r(k, putj, puti) = mat_r(k, putj, puti) + coefs(k,1) * hij
|
||||
enddo
|
||||
endif
|
||||
end do
|
||||
!! <phi|H|alpha>
|
||||
do i=1,3
|
||||
puti = p(turn3(1,i), ma)
|
||||