LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-06-25 22:52:15 +02:00
Code Issues Releases Wiki Activity

cleaning + microlisted splash_pq

Browse Source
This commit is contained in:
Yann Garniron 2016-10-04 15:08:13 +02:00
parent b49085733a
commit 71c84f78f1
3 changed files with 80 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
plugins/Full_CI_ZMQ/selection.irp.f
View File

@ -42,14 +42,12 @@ subroutine get_mask_phase(det, phasemask)
integer :: s, ni, i
logical :: change
! phasemask = 0_8
phasemask = 0_1
do s=1,2
change = .false.
do ni=1,N_int
do i=0,bit_kind_size-1
if(BTEST(det(ni, s), i)) change = .not. change
! if(change) phasemask(ni, s) = ibset(phasemask(ni, s), i)
if(change) phasemask((ni-1)*bit_kind_size + i + 1, s) = 1_1
end do
end do
@ -86,21 +84,6 @@ subroutine select_connected(i_generator,E0,pt2,b)
end subroutine
subroutine spot_occupied(mask, bannedOrb)
use bitmasks
implicit none
integer(bit_kind),intent(in) :: mask(N_int)
logical, intent(inout) :: bannedOrb(mo_tot_num)
integer :: i, ne, list(mo_tot_num)
call bitstring_to_list(mask, list, ne, N_int)
do i=1, ne
bannedOrb(list(i)) = .true.
end do
end subroutine
double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2)
use bitmasks
implicit none
@ -111,16 +94,6 @@ double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2)
integer(1) :: np
double precision, parameter :: res(0:1) = (/1d0, -1d0/)
! call assert(s1 /= s2 .or. (h1 <= h2 .and. p1 <= p2), irp_here)
! np = 0
! change = btest(phasemask(1+ishft(h1, -6), s1), iand(h1-1, 63))
! change = xor(change, btest(phasemask(1+ishft(p1, -6), s1), iand(p1-1, 63)))
! if(xor(change, p1 < h1)) np = 1
!
! change = btest(phasemask(1+ishft(h2, -6), s2), iand(h2-1, 63))
! change = xor(change, btest(phasemask(1+ishft(p2, -6), s2), iand(p2-1, 63)))
! if(xor(change, p2 < h2)) np = np + 1
np = phasemask(h1,s1) + phasemask(p1,s1) + phasemask(h2,s2) + phasemask(p2,s2)
if(p1 < h1) np = np + 1_1
if(p2 < h2) np = np + 1_1

135
plugins/Full_CI_ZMQ/selection_double.irp.f
View File

@ -12,10 +12,14 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p
type(selection_buffer), intent(inout) :: buf
double precision :: mat(N_states, mo_tot_num, mo_tot_num)
integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i
integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2)
integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii
integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2)
logical :: fullMatch, ok
integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2)
integer :: preinteresting(0:N_det_selectors), interesting(0:N_det_selectors)
integer(bit_kind) :: minilist(N_int, 2, N_det_selectors)
do k=1,N_int
hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1))
hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2))
@ -30,25 +34,72 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p
call bitstring_to_list_ab(hole , hole_list , N_holes , N_int)
call bitstring_to_list_ab(particle, particle_list, N_particles, N_int)
do i=1,N_int
negMask(i,1) = not(psi_det_generators(i,1,i_generator))
negMask(i,2) = not(psi_det_generators(i,2,i_generator))
end do
preinteresting(0) = 0
do i=1,N_det_selectors
nt = 0
do j=1,N_int
mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i))
mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i))
nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
end do
if(nt <= 4) then
preinteresting(0) += 1
preinteresting(preinteresting(0)) = i
end if
end do
do s1=1,2
do s2=s1,2
sp = s1
if(s1 /= s2) sp = 3
do i1=N_holes(s1),1,-1 ! Generate low excitations first
h1 = hole_list(i1,s1)
call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int)
do i=1,N_int
negMask(i,1) = not(pmask(i,1))
negMask(i,2) = not(pmask(i,2))
end do
interesting(0) = 0
do ii=1,preinteresting(0)
i = preinteresting(ii)
nt = 0
do j=1,N_int
mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i))
mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i))
nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
end do
if(nt <= 4) then
interesting(0) += 1
interesting(interesting(0)) = i
minilist(:,:,interesting(0)) = psi_det_sorted(:,:,i)
end if
end do
ib = 1
if(s1 == s2) ib = i1+1
do i2=N_holes(s2),ib,-1 ! Generate low excitations first
h1 = hole_list(i1,s1)
h2 = hole_list(i2,s2)
call apply_holes(psi_det_generators(1,1,i_generator), s1,h1,s2,h2, mask, ok, N_int)
call apply_hole(pmask, s2,h2, mask, ok, N_int)
! call apply_holes(psi_det_generators(1,1,i_generator), s1,h1,s2,h2, mask, ok, N_int)
logical :: banned(mo_tot_num, mo_tot_num,2)
logical :: bannedOrb(mo_tot_num, 2)
banned = .false.
bannedOrb(h1, s1) = .true.
bannedOrb(h2, s2) = .true.
call spot_isinwf(mask, psi_det_sorted, i_generator, N_det, banned, fullMatch)
if(fullMatch) cycle
bannedOrb(1:mo_tot_num, 1:2) = .true.
do s3=1,2
@ -56,15 +107,10 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p
bannedOrb(particle_list(i,s3), s3) = .false.
enddo
enddo
call spot_isinwf(mask, psi_det_sorted, i_generator, N_det, banned, fullMatch)
if(fullMatch) cycle
if(sp /= 2) call spot_occupied(mask(1,1), bannedOrb(1,1))
if(sp /= 1) call spot_occupied(mask(1,2), bannedOrb(1,2))
mat = 0d0
call splash_pq(mask, sp, psi_det_sorted, i_generator, N_det_selectors, bannedOrb, banned, mat)
! call splash_pq(mask, sp, psi_det_sorted, i_generator, N_det_selectors, bannedOrb, banned, mat, interesting)
call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting)
call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf)
enddo
enddo
@ -138,18 +184,22 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
end subroutine
subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat)
subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting)
use bitmasks
implicit none
integer, intent(in) :: interesting(0:N_sel)
integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel)
integer, intent(in) :: sp, i_gen, N_sel
logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2)
double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num)
integer :: i, j, k, l, h(0:2,2), p(0:4,2), nt
integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt
integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2)
! logical :: bandon
!
! bandon = .false.
mat = 0d0
do i=1,N_int
@ -157,7 +207,9 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat)
negMask(i,2) = not(mask(i,2))
end do
do i=1, N_sel
do i=1, N_sel ! interesting(0)
!i = interesting(ii)
nt = 0
do j=1,N_int
mobMask(j,1) = iand(negMask(j,1), det(j,1,i))
@ -166,7 +218,7 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat)
end do
if(nt > 4) cycle
do j=1,N_int
perMask(j,1) = iand(mask(j,1), not(det(j,1,i)))
perMask(j,2) = iand(mask(j,2), not(det(j,2,i)))
@ -178,11 +230,12 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat)
call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int)
call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int)
if(i < i_gen) then
if(interesting(i) < i_gen) then
if(nt == 4) call past_d2(banned, p, sp)
if(nt == 3) call past_d1(bannedOrb, p)
else
if(i == i_gen) then
if(interesting(i) == i_gen) then
! bandon = .true.
if(sp == 3) then
banned(:,:,2) = transpose(banned(:,:,1))
else
@ -194,11 +247,11 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat)
end if
end if
if(nt == 4) then
call get_d2(det(1,1,i), psi_phasemask(1,1,i), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, i))
call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i)))
else if(nt == 3) then
call get_d1(det(1,1,i), psi_phasemask(1,1,i), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, i))
call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i)))
else
call get_d0(det(1,1,i), psi_phasemask(1,1,i), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, i))
call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i)))
end if
end if
end do
@ -323,31 +376,6 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
end subroutine
subroutine debug_hij(hij, gen, mask, s1, s2, p1, p2)
use bitmasks
implicit none
integer(bit_kind), intent(in) :: gen(N_int,2), mask(N_int,2)
double precision, intent(in) :: hij
integer, intent(in) :: s1, s2, p1, p2
integer(bit_kind) :: det(N_int,2)
double precision :: hij_ref, phase_ref
logical :: ok
integer :: degree
integer :: exc(0:2,2,2)
call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
call i_H_j_phase_out(gen,det,N_int,hij_ref,phase_ref,exc,degree)
if(hij /= hij_ref) then
print *, hij, hij_ref
print *, s1, s2, p1, p2
call debug_det(gen, N_int)
call debug_det(mask, N_int)
stop
end if
end function
subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
use bitmasks
implicit none
@ -537,7 +565,6 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
integer :: bant
bant = 1
!print *, "d0 SP", sp
if(sp == 3) then ! AB
h1 = p(1,1)
@ -550,12 +577,11 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
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)
mat(:, p1, p2) += coefs(:) * hij
else
hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2)
phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2)
mat(:, p1, p2) += coefs(:) * hij
end if
mat(:, p1, p2) += coefs(:) * hij
end do
end do
else ! AA BB
@ -569,11 +595,10 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
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)
mat(:, puti, putj) += coefs(:) * hij
else
hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2)
mat(:, puti, putj) += coefs(:) * hij
end if
mat(:, puti, putj) += coefs(:) * hij
end do
end do
end if

27
plugins/Full_CI_ZMQ/selection_single.irp.f
View File

@ -49,7 +49,6 @@ subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf
end do
call spot_hasBeen(mask, sp, psi_det_sorted, i_gen, N_det, bannedOrb, fullMatch)
if(fullMatch) cycle
call spot_occupied(mask(1,sp), bannedOrb)
vect = 0d0
call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect)
call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf)
@ -353,29 +352,3 @@ end subroutine
subroutine debug_hij_mo(hij, gen, mask, s1, p1)
use bitmasks
implicit none
integer(bit_kind), intent(in) :: gen(N_int,2), mask(N_int,2)
double precision, intent(in) :: hij
integer, intent(in) :: s1, p1
integer(bit_kind) :: det(N_int,2)
double precision :: hij_ref, phase_ref
logical :: ok
integer :: degree
integer :: exc(0:2,2,2)
logical, external :: detEq
call apply_particle(mask, s1, p1, det, ok, N_int)
call i_H_j_phase_out(gen,det,N_int,hij_ref,phase_ref,exc,degree)
if(hij /= hij_ref) then
print *, hij, hij_ref
print *, s1, p1
call debug_det(gen, N_int)
call debug_det(mask, N_int)
call debug_det(det, N_int)
stop
end if
end function