PTEROSOR/QuantumPackage
10
0
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-12-22 20:34:58 +01:00
Code Releases Activity

Working on frozen core for CFG-CI.

Browse Source
This commit is contained in:
v1j4y 2022-06-17 11:05:27 +02:00
parent 4064243da3
commit a6859c072b
5 changed files with 149 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
src/csf/configuration_CI_sigma_helpers.irp.f
View File

@ -31,9 +31,9 @@ use bitmasks
integer :: ndiffDOMO integer :: ndiffDOMO
integer :: nxordiffSOMODOMO integer :: nxordiffSOMODOMO
integer :: ndiffAll integer :: ndiffAll
integer :: i integer :: i,ii
integer :: j integer :: j,jj
integer :: k integer :: k,kk
integer :: kstart integer :: kstart
integer :: kend integer :: kend
integer :: Nsomo_I integer :: Nsomo_I
@ -55,13 +55,15 @@ use bitmasks
Icfg = psi_configuration(:,:,idxI) Icfg = psi_configuration(:,:,idxI)
Isomo = iand(reunion_of_act_virt_bitmask(1,1),Icfg(1,1)) Isomo = iand(act_bitmask(1,1),Icfg(1,1))
Idomo = iand(reunion_of_act_virt_bitmask(1,1),Icfg(1,2)) Idomo = iand(act_bitmask(1,1),Icfg(1,2))
! find out all pq holes possible ! find out all pq holes possible
nholes = 0 nholes = 0
! holes in SOMO ! holes in SOMO
do i = 1,mo_num !do i = 1,mo_num
do ii = 1,n_act_orb
i = list_act(ii)
if(POPCNT(IAND(Isomo,IBSET(0_8,i-1))) .EQ. 1) then if(POPCNT(IAND(Isomo,IBSET(0_8,i-1))) .EQ. 1) then
nholes += 1 nholes += 1
listholes(nholes) = i listholes(nholes) = i
@ -69,7 +71,9 @@ use bitmasks
endif endif
end do end do
! holes in DOMO ! holes in DOMO
do i = 1,mo_num !do i = 1,mo_num
do ii = 1,n_act_orb
i = list_act(ii)
if(POPCNT(IAND(Idomo,IBSET(0_8,i-1))) .EQ. 1) then if(POPCNT(IAND(Idomo,IBSET(0_8,i-1))) .EQ. 1) then
nholes += 1 nholes += 1
listholes(nholes) = i listholes(nholes) = i
@ -81,7 +85,9 @@ use bitmasks
listvmos = -1 listvmos = -1
vmotype = -1 vmotype = -1
nvmos = 0 nvmos = 0
do i = 1,mo_num !do i = 1,mo_num
do ii = 1,n_act_orb
i = list_act(ii)
if(IAND(Idomo,(IBSET(0_8,i-1))) .EQ. 0) then if(IAND(Idomo,(IBSET(0_8,i-1))) .EQ. 0) then
if(IAND(Isomo,(IBSET(0_8,i-1))) .EQ. 0) then if(IAND(Isomo,(IBSET(0_8,i-1))) .EQ. 0) then
nvmos += 1 nvmos += 1
@ -98,8 +104,8 @@ use bitmasks
tableUniqueAlphas = .FALSE. tableUniqueAlphas = .FALSE.
! Now find the allowed (p,q) excitations ! Now find the allowed (p,q) excitations
Isomo = iand(reunion_of_act_virt_bitmask(1,1),Icfg(1,1)) Isomo = iand(act_bitmask(1,1),Icfg(1,1))
Idomo = iand(reunion_of_act_virt_bitmask(1,1),Icfg(1,2)) Idomo = iand(act_bitmask(1,1),Icfg(1,2))
Nsomo_I = POPCNT(Isomo) Nsomo_I = POPCNT(Isomo)
if(Nsomo_I .EQ. 0) then if(Nsomo_I .EQ. 0) then
kstart = 1 kstart = 1
@ -239,10 +245,10 @@ use bitmasks
Idomo = iand(reunion_of_act_virt_bitmask(1,1),Icfg(1,2)) Idomo = iand(reunion_of_act_virt_bitmask(1,1),Icfg(1,2))
kstart = max(1,cfg_seniority_index(max(0,Nsomo_I-2))) kstart = max(1,cfg_seniority_index(max(0,Nsomo_I-2)))
do k = kstart, idxI-1 do k = kstart, idxI-1
diffSOMO = IEOR(Isomo,iand(reunion_of_act_virt_bitmask(1,1),psi_configuration(1,1,k))) diffSOMO = IEOR(Isomo,iand(act_bitmask(1,1),psi_configuration(1,1,k)))
ndiffSOMO = POPCNT(diffSOMO) ndiffSOMO = POPCNT(diffSOMO)
if (ndiffSOMO /= 2) cycle if (ndiffSOMO /= 2) cycle
diffDOMO = IEOR(Idomo,iand(reunion_of_act_virt_bitmask(1,1),psi_configuration(1,2,k))) diffDOMO = IEOR(Idomo,iand(act_bitmask(1,1),psi_configuration(1,2,k)))
xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO)
ndiffDOMO = POPCNT(diffDOMO) ndiffDOMO = POPCNT(diffDOMO)
nxordiffSOMODOMO = POPCNT(xordiffSOMODOMO) nxordiffSOMODOMO = POPCNT(xordiffSOMODOMO)
@ -298,9 +304,9 @@ END_PROVIDER
integer :: ndiffDOMO integer :: ndiffDOMO
integer :: nxordiffSOMODOMO integer :: nxordiffSOMODOMO
integer :: ndiffAll integer :: ndiffAll
integer :: i integer :: i, ii
integer :: j integer :: j, jj
integer :: k integer :: k, kk
integer :: kstart integer :: kstart
integer :: kend integer :: kend
integer :: Nsomo_I integer :: Nsomo_I
@ -311,8 +317,8 @@ END_PROVIDER
logical :: pqAlreadyGenQ logical :: pqAlreadyGenQ
logical :: pqExistsQ logical :: pqExistsQ
logical :: ppExistsQ logical :: ppExistsQ
Isomo = iand(reunion_of_act_virt_bitmask(1,1),Icfg(1,1)) Isomo = iand(act_bitmask(1,1),Icfg(1,1))
Idomo = iand(reunion_of_act_virt_bitmask(1,1),Icfg(1,2)) Idomo = iand(act_bitmask(1,1),Icfg(1,2))
!print*,"Input cfg" !print*,"Input cfg"
!call debug_spindet(Isomo,1) !call debug_spindet(Isomo,1)
!call debug_spindet(Idomo,1) !call debug_spindet(Idomo,1)
@ -322,7 +328,9 @@ END_PROVIDER
! find out all pq holes possible ! find out all pq holes possible
nholes = 0 nholes = 0
! holes in SOMO ! holes in SOMO
do i = 1,mo_num !do i = 1,mo_num
do ii = 1,n_act_orb
i = list_act(ii)
if(POPCNT(IAND(Isomo,IBSET(0_8,i-1))) .EQ. 1) then if(POPCNT(IAND(Isomo,IBSET(0_8,i-1))) .EQ. 1) then
nholes += 1 nholes += 1
listholes(nholes) = i listholes(nholes) = i
@ -330,7 +338,9 @@ END_PROVIDER
endif endif
end do end do
! holes in DOMO ! holes in DOMO
do i = 1,mo_num !do i = 1,mo_num
do ii = 1,n_act_orb
i = list_act(ii)
if(POPCNT(IAND(Idomo,IBSET(0_8,i-1))) .EQ. 1) then if(POPCNT(IAND(Idomo,IBSET(0_8,i-1))) .EQ. 1) then
nholes += 1 nholes += 1
listholes(nholes) = i listholes(nholes) = i
@ -342,7 +352,9 @@ END_PROVIDER
listvmos = -1 listvmos = -1
vmotype = -1 vmotype = -1
nvmos = 0 nvmos = 0
do i = 1,mo_num !do i = 1,mo_num
do ii = 1,n_act_orb
i = list_act(ii)
!print *,i,IBSET(0,i-1),POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))), POPCNT(IAND(Idomo,(IBSET(0_8,i-1)))) !print *,i,IBSET(0,i-1),POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))), POPCNT(IAND(Idomo,(IBSET(0_8,i-1))))
if(POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))) .EQ. 0 .AND. POPCNT(IAND(Idomo,(IBSET(0_8,i-1)))) .EQ. 0) then if(POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))) .EQ. 0 .AND. POPCNT(IAND(Idomo,(IBSET(0_8,i-1)))) .EQ. 0) then
nvmos += 1 nvmos += 1
@ -363,8 +375,8 @@ END_PROVIDER
tableUniqueAlphas = .FALSE. tableUniqueAlphas = .FALSE.
! Now find the allowed (p,q) excitations ! Now find the allowed (p,q) excitations
Isomo = iand(reunion_of_act_virt_bitmask(1,1),Icfg(1,1)) Isomo = iand(act_bitmask(1,1),Icfg(1,1))
Idomo = iand(reunion_of_act_virt_bitmask(1,1),Icfg(1,2)) Idomo = iand(act_bitmask(1,1),Icfg(1,2))
Nsomo_I = POPCNT(Isomo) Nsomo_I = POPCNT(Isomo)
if(Nsomo_I .EQ. 0) then if(Nsomo_I .EQ. 0) then
kstart = 1 kstart = 1
@ -430,10 +442,10 @@ END_PROVIDER
pqAlreadyGenQ = .FALSE. pqAlreadyGenQ = .FALSE.
! First check if it can be generated before ! First check if it can be generated before
do k = kstart, kend do k = kstart, kend
diffSOMO = IEOR(Jsomo,iand(reunion_of_act_virt_bitmask(1,1),psi_configuration(1,1,k))) diffSOMO = IEOR(Jsomo,iand(act_bitmask(1,1),psi_configuration(1,1,k)))
ndiffSOMO = POPCNT(diffSOMO) ndiffSOMO = POPCNT(diffSOMO)
if((ndiffSOMO .NE. 0) .AND. (ndiffSOMO .NE. 2)) cycle if((ndiffSOMO .NE. 0) .AND. (ndiffSOMO .NE. 2)) cycle
diffDOMO = IEOR(Jdomo,iand(reunion_of_act_virt_bitmask(1,1),psi_configuration(1,2,k))) diffDOMO = IEOR(Jdomo,iand(act_bitmask(1,1),psi_configuration(1,2,k)))
xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO)
ndiffDOMO = POPCNT(diffDOMO) ndiffDOMO = POPCNT(diffDOMO)
nxordiffSOMODOMO = POPCNT(xordiffSOMODOMO) nxordiffSOMODOMO = POPCNT(xordiffSOMODOMO)
@ -534,11 +546,11 @@ END_PROVIDER
! Check if this Icfg has been previously generated as a mono ! Check if this Icfg has been previously generated as a mono
ppExistsQ = .False. ppExistsQ = .False.
Isomo = iand(reunion_of_act_virt_bitmask(1,1),Icfg(1,1)) Isomo = iand(act_bitmask(1,1),Icfg(1,1))
Idomo = iand(reunion_of_act_virt_bitmask(1,1),Icfg(1,2)) Idomo = iand(act_bitmask(1,1),Icfg(1,2))
do k = 1, idxI-1 do k = 1, idxI-1
diffSOMO = IEOR(Isomo,iand(reunion_of_act_virt_bitmask(1,1),psi_configuration(1,1,k))) diffSOMO = IEOR(Isomo,iand(act_bitmask(1,1),psi_configuration(1,1,k)))
diffDOMO = IEOR(Idomo,iand(reunion_of_act_virt_bitmask(1,1),psi_configuration(1,2,k))) diffDOMO = IEOR(Idomo,iand(act_bitmask(1,1),psi_configuration(1,2,k)))
xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO)
ndiffSOMO = POPCNT(diffSOMO) ndiffSOMO = POPCNT(diffSOMO)
ndiffDOMO = POPCNT(diffDOMO) ndiffDOMO = POPCNT(diffDOMO)

9
src/csf/create_excitations.irp.f
View File

@ -249,6 +249,7 @@ subroutine generate_all_singles_cfg_with_type(bit_tmp,cfgInp,singles,idxs_single
integer(bit_kind) :: Jdet(Nint,2) integer(bit_kind) :: Jdet(Nint,2)
integer :: i,k, n_singles_ma, i_hole, i_particle, ex_type, addcfg integer :: i,k, n_singles_ma, i_hole, i_particle, ex_type, addcfg
integer :: ii,kk
integer(bit_kind) :: single(Nint,2) integer(bit_kind) :: single(Nint,2)
logical :: i_ok logical :: i_ok
@ -257,8 +258,12 @@ subroutine generate_all_singles_cfg_with_type(bit_tmp,cfgInp,singles,idxs_single
!TODO !TODO
!Make list of Somo and Domo for holes !Make list of Somo and Domo for holes
!Make list of Unocc and Somo for particles !Make list of Unocc and Somo for particles
do i_hole = 1+n_core_orb, n_core_orb + n_act_orb !do i_hole = 1+n_core_orb, n_core_orb + n_act_orb
do i_particle = 1+n_core_orb, n_core_orb + n_act_orb do ii = 1, n_act_orb
i_hole = list_act(ii)
!do i_particle = 1+n_core_orb, n_core_orb + n_act_orb
do kk = 1, n_act_orb
i_particle = list_act(kk)
if(i_hole .EQ. i_particle) cycle if(i_hole .EQ. i_particle) cycle
addcfg = -1 addcfg = -1
call do_single_excitation_cfg_with_type(cfgInp,single,i_hole,i_particle,ex_type,i_ok) call do_single_excitation_cfg_with_type(cfgInp,single,i_hole,i_particle,ex_type,i_ok)

20
src/csf/obtain_I_foralpha.irp.f
View File

@ -33,7 +33,7 @@ subroutine obtain_connected_J_givenI(idxI, givenI, connectedI, idxs_connectedI,
integer :: ndiffSOMO integer :: ndiffSOMO
integer :: ndiffDOMO integer :: ndiffDOMO
integer :: nxordiffSOMODOMO integer :: nxordiffSOMODOMO
integer :: ii,i,j,k,l,p,q,nsomoJ,nsomoalpha,starti,endi,extyp,nholes integer :: iii,ii,i,j,k,l,p,q,nsomoJ,nsomoalpha,starti,endi,extyp,nholes
integer :: listholes(mo_num) integer :: listholes(mo_num)
integer :: holetype(mo_num) integer :: holetype(mo_num)
integer :: end_index integer :: end_index
@ -146,7 +146,9 @@ subroutine obtain_connected_J_givenI(idxI, givenI, connectedI, idxs_connectedI,
! holes in SOMO ! holes in SOMO
Isomo = psi_configuration(1,1,i) Isomo = psi_configuration(1,1,i)
Idomo = psi_configuration(1,2,i) Idomo = psi_configuration(1,2,i)
do ii = 1,mo_num !do ii = 1,mo_num
do iii = 1,n_act_orb
ii = list_act(iii)
if(POPCNT(IAND(Isomo,IBSET(0_8,ii-1))) .EQ. 1) then if(POPCNT(IAND(Isomo,IBSET(0_8,ii-1))) .EQ. 1) then
nholes += 1 nholes += 1
listholes(nholes) = ii listholes(nholes) = ii
@ -154,7 +156,9 @@ subroutine obtain_connected_J_givenI(idxI, givenI, connectedI, idxs_connectedI,
endif endif
end do end do
! holes in DOMO ! holes in DOMO
do ii = 1,mo_num !do ii = 1,mo_num
do iii = 1,n_act_orb
ii = list_act(iii)
if(POPCNT(IAND(Idomo,IBSET(0_8,ii-1))) .EQ. 1) then if(POPCNT(IAND(Idomo,IBSET(0_8,ii-1))) .EQ. 1) then
nholes += 1 nholes += 1
listholes(nholes) = ii listholes(nholes) = ii
@ -204,7 +208,7 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI
integer :: ndiffSOMO integer :: ndiffSOMO
integer :: ndiffDOMO integer :: ndiffDOMO
integer :: nxordiffSOMODOMO integer :: nxordiffSOMODOMO
integer :: ii,i,j,k,l,p,q,nsomoJ,nsomoalpha,starti,endi,extyp,nholes integer :: iii,ii,i,j,k,l,p,q,nsomoJ,nsomoalpha,starti,endi,extyp,nholes
integer :: listholes(mo_num) integer :: listholes(mo_num)
integer :: holetype(mo_num) integer :: holetype(mo_num)
integer :: end_index integer :: end_index
@ -335,7 +339,9 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI
! holes in SOMO ! holes in SOMO
Isomo = psi_configuration(1,1,i) Isomo = psi_configuration(1,1,i)
Idomo = psi_configuration(1,2,i) Idomo = psi_configuration(1,2,i)
do ii = 1,mo_num !do ii = 1,mo_num
do iii = 1,n_act_orb
ii = list_act(iii)
if(POPCNT(IAND(Isomo,IBSET(0_8,ii-1))) .EQ. 1) then if(POPCNT(IAND(Isomo,IBSET(0_8,ii-1))) .EQ. 1) then
nholes += 1 nholes += 1
listholes(nholes) = ii listholes(nholes) = ii
@ -343,7 +349,9 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI
endif endif
end do end do
! holes in DOMO ! holes in DOMO
do ii = 1,mo_num !do ii = 1,mo_num
do iii = 1,n_act_orb
ii = list_act(iii)
if(POPCNT(IAND(Idomo,IBSET(0_8,ii-1))) .EQ. 1) then if(POPCNT(IAND(Idomo,IBSET(0_8,ii-1))) .EQ. 1) then
nholes += 1 nholes += 1
listholes(nholes) = ii listholes(nholes) = ii

55
src/csf/sigma_vector.irp.f
View File

@ -810,7 +810,7 @@ subroutine calculate_preconditioner_cfg(diag_energies)
! the configurations in psi_configuration ! the configurations in psi_configuration
! returns : diag_energies : ! returns : diag_energies :
END_DOC END_DOC
integer :: i,j,k,l,p,q,noccp,noccq, ii, jj integer :: i,j,k,kk,l,p,q,noccp,noccq, ii, jj
real*8,intent(out) :: diag_energies(n_CSF) real*8,intent(out) :: diag_energies(n_CSF)
integer :: nholes integer :: nholes
integer :: nvmos integer :: nvmos
@ -838,16 +838,19 @@ subroutine calculate_preconditioner_cfg(diag_energies)
real*8 :: meCC real*8 :: meCC
real*8 :: ecore real*8 :: ecore
PROVIDE h_core_ri !PROVIDE h_core_ri
PROVIDE core_fock_operator
PROVIDE h_act_ri
! initialize energies ! initialize energies
diag_energies = 0.d0 diag_energies = 0.d0
!print *,"Core energy=",core_energy," nucler rep=",nuclear_repulsion, " n_core_orb=",n_core_orb," n_act_orb=",n_act_orb," mo_num=",mo_num
! calculate core energy ! calculate core energy
!call get_core_energy(ecore) !call get_core_energy(ecore)
!diag_energies = ecore diag_energies = core_energy - nuclear_repulsion
! calculate the core energy ! calculate the core energy
!print *,"Core energy=",ref_bitmask_energy !print *,"Core 2energy=",ref_bitmask_energy
do i=1,N_configuration do i=1,N_configuration
@ -863,8 +866,9 @@ subroutine calculate_preconditioner_cfg(diag_energies)
! find out all pq holes possible ! find out all pq holes possible
nholes = 0 nholes = 0
! holes in SOMO ! holes in SOMO
!do k = n_core_orb+1,n_core_orb + n_act_orb !do k = 1,mo_num
do k = 1,mo_num do kk = 1,n_act_orb
k = list_act(kk)
if(POPCNT(IAND(Isomo,IBSET(0_8,k-1))) .EQ. 1) then if(POPCNT(IAND(Isomo,IBSET(0_8,k-1))) .EQ. 1) then
nholes += 1 nholes += 1
listholes(nholes) = k listholes(nholes) = k
@ -874,7 +878,9 @@ subroutine calculate_preconditioner_cfg(diag_energies)
! holes in DOMO ! holes in DOMO
!do k = n_core_orb+1,n_core_orb + n_act_orb !do k = n_core_orb+1,n_core_orb + n_act_orb
!do k = 1+n_core_inact_orb,n_core_orb+n_core_inact_act_orb !do k = 1+n_core_inact_orb,n_core_orb+n_core_inact_act_orb
do k = 1,mo_num !do k = 1,mo_num
do kk = 1,n_act_orb
k = list_act(kk)
if(POPCNT(IAND(Idomo,IBSET(0_8,k-1))) .EQ. 1) then if(POPCNT(IAND(Idomo,IBSET(0_8,k-1))) .EQ. 1) then
nholes += 1 nholes += 1
listholes(nholes) = k listholes(nholes) = k
@ -887,7 +893,9 @@ subroutine calculate_preconditioner_cfg(diag_energies)
vmotype = -1 vmotype = -1
nvmos = 0 nvmos = 0
!do k = n_core_orb+1,n_core_orb + n_act_orb !do k = n_core_orb+1,n_core_orb + n_act_orb
do k = 1,mo_num !do k = 1,mo_num
do kk = 1,n_act_orb
k = list_act(kk)
!print *,i,IBSET(0,i-1),POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))), POPCNT(IAND(Idomo,(IBSET(0_8,i-1)))) !print *,i,IBSET(0,i-1),POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))), POPCNT(IAND(Idomo,(IBSET(0_8,i-1))))
if(POPCNT(IAND(Isomo,(IBSET(0_8,k-1)))) .EQ. 0 .AND. POPCNT(IAND(Idomo,(IBSET(0_8,k-1)))) .EQ. 0) then if(POPCNT(IAND(Isomo,(IBSET(0_8,k-1)))) .EQ. 0 .AND. POPCNT(IAND(Idomo,(IBSET(0_8,k-1)))) .EQ. 0) then
nvmos += 1 nvmos += 1
@ -916,7 +924,7 @@ subroutine calculate_preconditioner_cfg(diag_energies)
! one-electron term ! one-electron term
if(p.EQ.q) then if(p.EQ.q) then
hpp = noccq * h_core_ri(p,q)!mo_one_e_integrals(q,q) hpp = noccq * h_act_ri(p,q)!mo_one_e_integrals(q,q)
else else
hpp = 0.d0 hpp = 0.d0
endif endif
@ -1295,7 +1303,8 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze
real*8,intent(in) :: psi_in(n_st,sze) real*8,intent(in) :: psi_in(n_st,sze)
real*8,intent(out) :: psi_out(n_st,sze) real*8,intent(out) :: psi_out(n_st,sze)
integer(bit_kind) :: Icfg(N_INT,2) integer(bit_kind) :: Icfg(N_INT,2)
integer :: i,j,k,l,p,q,noccp,noccq, ii, jj, m, n, idxI, kk, nocck,orbk integer :: i,j,k,l,p,q,noccp,noccq, m, n, idxI, nocck,orbk
integer :: ii,jj,kk,ll,pp,qq
integer(bit_kind),dimension(:,:,:),allocatable :: listconnectedJ integer(bit_kind),dimension(:,:,:),allocatable :: listconnectedJ
integer(bit_kind),dimension(:,:,:),allocatable :: alphas_Icfg integer(bit_kind),dimension(:,:,:),allocatable :: alphas_Icfg
integer(bit_kind),dimension(:,:,:),allocatable :: singlesI integer(bit_kind),dimension(:,:,:),allocatable :: singlesI
@ -1394,10 +1403,10 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze
!$OMP colsikpq, GIJpqrs,TKIGIJ,j,l,m,TKI,CCmattmp, moi, moj, mok, mol,& !$OMP colsikpq, GIJpqrs,TKIGIJ,j,l,m,TKI,CCmattmp, moi, moj, mok, mol,&
!$OMP diagfac, tmpvar, diagfactors_0) & !$OMP diagfac, tmpvar, diagfactors_0) &
!$OMP shared(istart_cfg, iend_cfg, psi_configuration, mo_num, psi_config_data,& !$OMP shared(istart_cfg, iend_cfg, psi_configuration, mo_num, psi_config_data,&
!$OMP N_int, N_st, psi_out, psi_in, h_core_ri, AIJpqContainer,& !$OMP N_int, N_st, psi_out, psi_in, h_core_ri, core_energy, h_act_ri, AIJpqContainer,&
!$OMP sze, NalphaIcfg_list,alphasIcfg_list, bit_tmp, & !$OMP sze, NalphaIcfg_list,alphasIcfg_list, bit_tmp, &
!$OMP AIJpqMatrixDimsList, diag_energies, n_CSF, lock, NBFmax,nconnectedtotalmax, nconnectedmaxJ,maxnalphas,& !$OMP AIJpqMatrixDimsList, diag_energies, n_CSF, lock, NBFmax,nconnectedtotalmax, nconnectedmaxJ,maxnalphas,&
!$OMP num_threads_max) !$OMP n_core_orb, n_act_orb, list_act, num_threads_max)
allocate(singlesI(N_INT,2,max(sze,10000))) allocate(singlesI(N_INT,2,max(sze,10000)))
allocate(idxs_singlesI(max(sze,10000))) allocate(idxs_singlesI(max(sze,10000)))
@ -1430,8 +1439,9 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze
! list_core ! list_core
! list_core_inact ! list_core_inact
! bitmasks ! bitmasks
!do k = n_core_orb+1,n_core_orb + n_act_orb !do k = 1,mo_num
do k = 1,mo_num do kk = 1,n_act_orb
k = list_act(kk)
if(POPCNT(IAND(Isomo,IBSET(0_8,k-1))) .EQ. 1) then if(POPCNT(IAND(Isomo,IBSET(0_8,k-1))) .EQ. 1) then
nholes += 1 nholes += 1
listholes(nholes) = k listholes(nholes) = k
@ -1439,8 +1449,9 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze
endif endif
enddo enddo
! holes in DOMO ! holes in DOMO
!do k = n_core_orb+1,n_core_orb + n_act_orb !do k = 1,mo_num
do k = 1,mo_num do kk = 1,n_act_orb
k = list_act(kk)
if(POPCNT(IAND(Idomo,IBSET(0_8,k-1))) .EQ. 1) then if(POPCNT(IAND(Idomo,IBSET(0_8,k-1))) .EQ. 1) then
nholes += 1 nholes += 1
listholes(nholes) = k listholes(nholes) = k
@ -1452,8 +1463,9 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze
listvmos = -1 listvmos = -1
vmotype = -1 vmotype = -1
nvmos = 0 nvmos = 0
!do k = n_core_orb+1,n_core_orb + n_act_orb do kk = 1,n_act_orb
do k = 1,mo_num !do k = 1,mo_num
k = list_act(kk)
!print *,i,IBSET(0,i-1),POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))), POPCNT(IAND(Idomo,(IBSET(0_8,i-1)))) !print *,i,IBSET(0,i-1),POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))), POPCNT(IAND(Idomo,(IBSET(0_8,i-1))))
if(POPCNT(IAND(Isomo,(IBSET(0_8,k-1)))) .EQ. 0 .AND. POPCNT(IAND(Idomo,(IBSET(0_8,k-1)))) .EQ. 0) then if(POPCNT(IAND(Isomo,(IBSET(0_8,k-1)))) .EQ. 0 .AND. POPCNT(IAND(Idomo,(IBSET(0_8,k-1)))) .EQ. 0) then
nvmos += 1 nvmos += 1
@ -1507,7 +1519,8 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze
cnti = ii-starti+1 cnti = ii-starti+1
do jj = startj, endj do jj = startj, endj
cntj = jj-startj+1 cntj = jj-startj+1
meCC1 = AIJpqContainer(cnti,cntj,pmodel,qmodel,extype,NSOMOI)* h_core_ri(p,q) !meCC1 = AIJpqContainer(cnti,cntj,pmodel,qmodel,extype,NSOMOI)* h_core_ri(p,q)
meCC1 = AIJpqContainer(cnti,cntj,pmodel,qmodel,extype,NSOMOI)* h_act_ri(p,q)
!print *,"jj = ",jj !print *,"jj = ",jj
call omp_set_lock(lock(jj)) call omp_set_lock(lock(jj))
do kk = 1,n_st do kk = 1,n_st
@ -1532,6 +1545,8 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze
deallocate(excitationIds_single) deallocate(excitationIds_single)
deallocate(excitationTypes_single) deallocate(excitationTypes_single)
!print *," psi(60,1)=",psi_out(1,60)
allocate(listconnectedJ(N_INT,2,max(sze,10000))) allocate(listconnectedJ(N_INT,2,max(sze,10000)))
allocate(alphas_Icfg(N_INT,2,max(sze,10000))) allocate(alphas_Icfg(N_INT,2,max(sze,10000)))
allocate(connectedI_alpha(N_INT,2,max(sze,10000))) allocate(connectedI_alpha(N_INT,2,max(sze,10000)))
@ -1711,6 +1726,8 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze
!$OMP END PARALLEL !$OMP END PARALLEL
call omp_set_max_active_levels(4) call omp_set_max_active_levels(4)
!print *," psi(60,1)=",psi_out(1,60)
!print *," diag_enregy=",diag_energies(1), " psi_out(1,1)=",psi_out(1,1)
deallocate(diag_energies) deallocate(diag_energies)
deallocate(bit_tmp) deallocate(bit_tmp)

52
src/mo_two_e_ints/core_quantities.irp.f
View File

@ -13,7 +13,19 @@ BEGIN_PROVIDER [double precision, core_energy]
core_energy += 2.d0 * (2.d0 * mo_two_e_integrals_jj(j,l) - mo_two_e_integrals_jj_exchange(j,l)) core_energy += 2.d0 * (2.d0 * mo_two_e_integrals_jj(j,l) - mo_two_e_integrals_jj_exchange(j,l))
enddo enddo
enddo enddo
!print *," core no nucl=",core_energy
! core-active
do i = 1, n_core_orb
j = list_core(i)
!!! VJ
!!! TODO: Correct the loop over active electrons
do k = 1, (elec_num - 2*n_core_orb)/2
l = k + n_core_orb
core_energy += 2.d0 * (2.d0 * mo_two_e_integrals_jj(j,l) - mo_two_e_integrals_jj_exchange(j,l))
enddo
enddo
core_energy += nuclear_repulsion core_energy += nuclear_repulsion
!print *," core no nucl=",core_energy
END_PROVIDER END_PROVIDER
@ -59,3 +71,43 @@ BEGIN_PROVIDER [ double precision, h_core_ri, (mo_num, mo_num) ]
enddo enddo
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ double precision, h_act_ri, (mo_num, mo_num) ]
implicit none
BEGIN_DOC
! Active Hamiltonian with 3-index exchange integrals:
!
! $\tilde{h}{pq} = h_{pq} - \frac{1}{2}\sum_{k} g(pk,kq)$
END_DOC
integer :: i,j, k
integer :: p,q, r
! core-core contribution
h_act_ri = core_fock_operator
! act-act contribution
do p=1,n_act_orb
j=list_act(p)
do q=1,n_act_orb
i=list_act(q)
h_act_ri(i,j) = mo_one_e_integrals(i,j)
enddo
do r=1,n_act_orb
k=list_act(r)
do q=1,n_act_orb
i=list_act(q)
h_act_ri(i,j) = h_act_ri(i,j) - 0.5 * big_array_exchange_integrals(k,i,j)
enddo
enddo
enddo
! core-act contribution
do p=1,n_core_orb
j=list_core(p)
do k=1,mo_num
do q=1,n_act_orb
i=list_act(q)
h_act_ri(i,j) = h_act_ri(i,j) - 0.5 * big_array_exchange_integrals(k,i,j)
enddo
enddo
enddo
END_PROVIDER