LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-12-25 13:53:49 +01:00
Code Issues Releases Wiki Activity

working and less slow mrcc_sto

Browse Source
This commit is contained in:
Yann Garniron 2018-02-20 17:34:51 +01:00
parent 5150497318
commit ea99cc29b3
3 changed files with 79 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
plugins/dress_zmq/alpha_factory.irp.f
View File

@ -2,11 +2,12 @@ use bitmasks
subroutine alpha_callback(delta_ij_loc, i_generator, subset) subroutine alpha_callback(delta_ij_loc, i_generator, subset,iproc)
use bitmasks use bitmasks
implicit none implicit none
integer, intent(in) :: i_generator, subset integer, intent(in) :: i_generator, subset
double precision,intent(inout) :: delta_ij_loc(N_states,N_det,2) double precision,intent(inout) :: delta_ij_loc(N_states,N_det,2)
integer, intent(in) :: iproc
integer :: k,l integer :: k,l
@ -14,12 +15,12 @@ subroutine alpha_callback(delta_ij_loc, i_generator, subset)
do l=1,N_generators_bitmask do l=1,N_generators_bitmask
call generate_singles_and_doubles(delta_ij_loc, i_generator,l,subset) call generate_singles_and_doubles(delta_ij_loc, i_generator,l,subset,iproc)
enddo enddo
end subroutine end subroutine
subroutine generate_singles_and_doubles(delta_ij_loc, i_generator, bitmask_index, subset) subroutine generate_singles_and_doubles(delta_ij_loc, i_generator, bitmask_index, subset, iproc)
use bitmasks use bitmasks
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -28,6 +29,8 @@ subroutine generate_singles_and_doubles(delta_ij_loc, i_generator, bitmask_index
double precision,intent(inout) :: delta_ij_loc(N_states,N_det,2) double precision,intent(inout) :: delta_ij_loc(N_states,N_det,2)
integer, intent(in) :: i_generator, subset, bitmask_index integer, intent(in) :: i_generator, subset, bitmask_index
integer, intent(in) :: iproc
integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii,n integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii,n
integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2)
@ -356,7 +359,7 @@ subroutine generate_singles_and_doubles(delta_ij_loc, i_generator, bitmask_index
!print *, "IND1", indexes(1,:) !print *, "IND1", indexes(1,:)
!print *, "IND2", indexes_end(1,:) !print *, "IND2", indexes_end(1,:)
!stop !stop
call alpha_callback_mask(delta_ij_loc, sp, mask, bannedOrb, banned, indexes, indexes_end, abuf, siz) call alpha_callback_mask(delta_ij_loc, sp, mask, bannedOrb, banned, indexes, indexes_end, abuf, siz, iproc)
!call dress_with_alpha_buffer(delta_ij_loc, minilist, interesting(0), abuf, n) !call dress_with_alpha_buffer(delta_ij_loc, minilist, interesting(0), abuf, n)
end if end if
@ -368,12 +371,12 @@ subroutine generate_singles_and_doubles(delta_ij_loc, i_generator, bitmask_index
end subroutine end subroutine
subroutine alpha_callback_mask(delta_ij_loc, sp, mask, bannedOrb, banned, indexes, indexes_end, abuf, siz) subroutine alpha_callback_mask(delta_ij_loc, sp, mask, bannedOrb, banned, indexes, indexes_end, abuf, siz, iproc)
use bitmasks use bitmasks
implicit none implicit none
double precision,intent(inout) :: delta_ij_loc(N_states,N_det,2) double precision,intent(inout) :: delta_ij_loc(N_states,N_det,2)
integer, intent(in) :: sp, indexes(0:mo_tot_num, 0:mo_tot_num), siz integer, intent(in) :: sp, indexes(0:mo_tot_num, 0:mo_tot_num), siz, iproc
integer, intent(in) :: indexes_end(0:mo_tot_num, 0:mo_tot_num), abuf(*) integer, intent(in) :: indexes_end(0:mo_tot_num, 0:mo_tot_num), abuf(*)
logical, intent(in) :: bannedOrb(mo_tot_num,2), banned(mo_tot_num, mo_tot_num) logical, intent(in) :: bannedOrb(mo_tot_num,2), banned(mo_tot_num, mo_tot_num)
integer(bit_kind), intent(in) :: mask(N_int, 2) integer(bit_kind), intent(in) :: mask(N_int, 2)
@ -456,7 +459,7 @@ subroutine alpha_callback_mask(delta_ij_loc, sp, mask, bannedOrb, banned, indexe
call apply_particles(mask, s1, i, s2, j, alpha, ok, N_int) call apply_particles(mask, s1, i, s2, j, alpha, ok, N_int)
!if(.not. ok) stop "non existing alpha......" !if(.not. ok) stop "non existing alpha......"
!print *, "willcall", st4-1, size(labuf) !print *, "willcall", st4-1, size(labuf)
call dress_with_alpha_buffer(delta_ij_loc, labuf, st4-1, alpha) call dress_with_alpha_buffer(delta_ij_loc, labuf, st4-1, alpha, iproc)
!call dress_with_alpha_buffer(delta_ij_loc, abuf, siz, alpha, 1) !call dress_with_alpha_buffer(delta_ij_loc, abuf, siz, alpha, 1)
end if end if
end do end do

2
plugins/dress_zmq/run_dress_slave.irp.f
View File

@ -54,7 +54,7 @@ subroutine run_dress_slave(thread,iproc,energy)
if(task_id /= 0) then if(task_id /= 0) then
read (task,*) subset, i_generator read (task,*) subset, i_generator
delta_ij_loc = 0d0 delta_ij_loc = 0d0
call alpha_callback(delta_ij_loc, i_generator, subset) call alpha_callback(delta_ij_loc, i_generator, subset, iproc)
!!! SET DRESSING COLUMN? !!! SET DRESSING COLUMN?
!do i=1,N_det !do i=1,N_det

151
plugins/mrcc_sto/mrcc_sto.irp.f
View File

@ -24,7 +24,17 @@ end
END_PROVIDER END_PROVIDER
subroutine dress_with_alpha_buffer(delta_ij_loc, minilist, n_minilist, alpha) BEGIN_PROVIDER [ double precision, hij_cache_, (N_det,Nproc) ]
&BEGIN_PROVIDER [ double precision, sij_cache_, (N_det,Nproc) ]
&BEGIN_PROVIDER [ double precision, dIa_hla_, (N_states,N_det,Nproc) ]
&BEGIN_PROVIDER [ double precision, dIa_sla_, (N_states,N_det,Nproc) ]
&BEGIN_PROVIDER [ integer, idx_alpha_, (0:N_det,Nproc) ]
BEGIN_DOC
! temporay arrays for dress_with_alpha_buffer. Avoids realocation.
END_DOC
END_PROVIDER
subroutine dress_with_alpha_buffer(delta_ij_loc, minilist, n_minilist, alpha, iproc)
use bitmasks use bitmasks
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -35,31 +45,29 @@ subroutine dress_with_alpha_buffer(delta_ij_loc, minilist, n_minilist, alpha)
!alpha : alpha determinant !alpha : alpha determinant
END_DOC END_DOC
integer(bit_kind), intent(in) :: alpha(N_int,2) integer(bit_kind), intent(in) :: alpha(N_int,2)
integer,intent(in) :: minilist(n_minilist), n_minilist integer,intent(in) :: minilist(n_minilist), n_minilist, iproc
double precision, intent(inout) :: delta_ij_loc(N_states,N_det,2) double precision, intent(inout) :: delta_ij_loc(N_states,N_det,2)
integer :: i,j,k,l,m integer :: i,j,k,l,m
integer :: degree1, degree2, degree integer :: degree1, degree2, degree
integer, allocatable :: idx_alpha(:)
double precision :: hIk, hla, hIl, sla, dIk(N_states), dka(N_states), dIa(N_states), hka double precision :: hIk, hla, hIl, sla, dIk(N_states), dka(N_states), dIa(N_states), hka
double precision, allocatable :: dIa_hla(:,:), dIa_sla(:,:)
double precision :: phase, phase2 double precision :: phase, phase2
double precision :: ci_inv(N_states)
integer :: exc(0:2,2,2) integer :: exc(0:2,2,2)
integer :: h1,h2,p1,p2,s1,s2 integer :: h1,h2,p1,p2,s1,s2
integer(bit_kind) :: tmp_det(N_int,2), ctrl integer(bit_kind) :: tmp_det(N_int,2), ctrl
integer :: i_state, k_sd, l_sd, m_sd, ll_sd, i_I integer :: i_state, k_sd, l_sd, m_sd, ll_sd, i_I
double precision, allocatable :: hij_cache(:), sij_cache(:)
double precision :: Delta_E_inv(N_states) double precision :: Delta_E_inv(N_states)
double precision :: sdress, hdress double precision :: sdress, hdress
double precision :: c0(N_states)
logical :: ok, ok2 logical :: ok, ok2
integer :: old_ninc integer :: old_ninc
double precision :: shdress double precision :: shdress
PROVIDE mo_class
if(n_minilist == 1) return if(n_minilist == 1) return
shdress = 0d0 shdress = 0d0
@ -74,53 +82,45 @@ subroutine dress_with_alpha_buffer(delta_ij_loc, minilist, n_minilist, alpha)
if(degree1 <= 2) return if(degree1 <= 2) return
end do end do
allocate(hij_cache(N_det), sij_cache(N_det))
allocate (dIa_hla(N_states,N_det), dIa_sla(N_states,N_det))
allocate (idx_alpha(0:n_minilist))
do i_state=1,N_states
c0(i_state) = 1.d0/psi_coef(dressed_column_idx(i_state),i_state)
enddo
ll_sd = 0 ll_sd = 0
do l_sd=1,n_minilist do l_sd=1,n_minilist
ok = .true. ok = .true.
k_sd = minilist(l_sd) k_sd = minilist(l_sd)
!if(idx_non_ref_rev(k_sd) == 0) cycle !if(idx_non_ref_rev(k_sd) == 0) cycle
do i_I=1,N_det_ref !do i_I=1,N_det_ref
call get_excitation_degree(psi_det_sorted(1,1,k_sd),psi_ref(1,1,i_I),degree1,N_int) ! call get_excitation_degree(psi_det_sorted(1,1,k_sd),psi_ref(1,1,i_I),degree1,N_int)
if(degree1 == 0) then ! if(degree1 == 0) then
ok = .false. ! ok = .false.
exit ! exit
end if
end do
!if(ok) then
! call get_excitation(psi_det_sorted(1,1,k_sd),alpha,exc,degree1,phase,N_int)
! if(degree1 == 0 .or. degree1 > 2) stop "minilist error"
! call decode_exc(exc,degree1,h1,p1,h2,p2,s1,s2)
!
! if(h1 > 10 .or. p1 < 7 .or. p1 == 8 .or. p1 == 9) ok = .false.
! if(ok .and. degree1 == 2) then
! if(h2 > 10 .or. p2 < 7 .or. p2 == 8 .or. p2 == 9) ok = .false.
! end if ! end if
! !if(degree1 == 0 .or. degree1 > 2) stop "minilist error" !end do
! !iand(xor(psi_det_sorted(i,2,k_sd), alpha(i,2)), alpha(i,2)) if(idx_non_ref_from_sorted(k_sd) == 0) ok = .false.
!end if
!if(ok) then
! call get_excitation(psi_det_sorted(1,1,k_sd),alpha,exc,degree1,phase,N_int)
! if(degree1 == 0 .or. degree1 > 2) stop "minilist error"
! call decode_exc(exc,degree1,h1,p1,h2,p2,s1,s2)
!
! ok = (mo_class(h1)(1:1) == 'A' .or. mo_class(h1)(1:1) == 'I') .and. &
! (mo_class(p1)(1:1) == 'A' .or. mo_class(p1)(1:1) == 'V')
! if(ok .and. degree1 == 2) then
! ok = (mo_class(h2)(1:1) == 'A' .or. mo_class(h2)(1:1) == 'I') .and. &
! (mo_class(p2)(1:1) == 'A' .or. mo_class(p2)(1:1) == 'V')
! end if
!end if
!if( xor(ok, idx_non_ref_from_sorted(k_sd) > 0)) stop "BUGUE"
if(ok) then if(ok) then
ll_sd += 1 ll_sd += 1
idx_alpha(ll_sd) = k_sd idx_alpha_(ll_sd,iproc) = k_sd
! call i_h_j(alpha,psi_non_ref(1,1,idx_alpha(l_sd)),N_int,hij_cache(k_sd)) call i_h_j(alpha,psi_det_sorted(1,1,k_sd),N_int,hij_cache_(k_sd,iproc))
! call get_s2(alpha,psi_non_ref(1,1,idx_alpha(l_sd)),N_int,sij_cache(k_sd)) call get_s2(alpha,psi_det_sorted(1,1,k_sd),N_int,sij_cache_(k_sd,iproc))
call i_h_j(alpha,psi_det_sorted(1,1,k_sd),N_int,hij_cache(k_sd))
call get_s2(alpha,psi_det_sorted(1,1,k_sd),N_int,sij_cache(k_sd))
end if end if
enddo enddo
if(ll_sd <= 1) return if(ll_sd <= 1) return
idx_alpha(0) = ll_sd idx_alpha_(0,iproc) = ll_sd
do i_I=1,N_det_ref do i_I=1,N_det_ref
@ -133,18 +133,14 @@ subroutine dress_with_alpha_buffer(delta_ij_loc, minilist, n_minilist, alpha)
dIa(i_state) = 0.d0 dIa(i_state) = 0.d0
enddo enddo
do k_sd=1,idx_alpha(0) do k_sd=1,idx_alpha_(0,iproc)
!print *, "idx ", k_sd call get_excitation_degree(psi_ref(1,1,i_I),psi_det_sorted(1,1,idx_alpha_(k_sd,iproc)),degree,N_int)
!print *, "idx2", idx_alpha(k_sd)
!print *, "ref
!if(idx_non_ref_rev(idx_alpha(k_sd)) == 0) cycle
call get_excitation_degree(psi_ref(1,1,i_I),psi_det_sorted(1,1,idx_alpha(k_sd)),degree,N_int)
! print *, "diden" ! print *, "diden"
if (degree > 2) then if (degree > 2) then
cycle cycle
endif endif
call get_excitation(psi_det_sorted(1,1,idx_alpha(k_sd)),alpha,exc,degree2,phase,N_int) call get_excitation(psi_det_sorted(1,1,idx_alpha_(k_sd,iproc)),alpha,exc,degree2,phase,N_int)
!print *, "DEG", degree2 !print *, "DEG", degree2
call decode_exc(exc,degree2,h1,p1,h2,p2,s1,s2) call decode_exc(exc,degree2,h1,p1,h2,p2,s1,s2)
do k=1,N_int do k=1,N_int
@ -155,8 +151,11 @@ subroutine dress_with_alpha_buffer(delta_ij_loc, minilist, n_minilist, alpha)
ok2 = .false. ok2 = .false.
do i_state=1,N_states do i_state=1,N_states
dIK(i_state) = dij(i_I, idx_non_ref_from_sorted(idx_alpha(k_sd)), i_state) dIK(i_state) = dij(i_I, idx_non_ref_from_sorted(idx_alpha_(k_sd,iproc)), i_state)
if(dIK(i_state) /= 0d0) ok2 = .true. if(dIK(i_state) /= 0d0) then
ok2 = .true.
exit
endif
enddo enddo
if(.not. ok2) cycle if(.not. ok2) cycle
@ -166,18 +165,18 @@ subroutine dress_with_alpha_buffer(delta_ij_loc, minilist, n_minilist, alpha)
enddo enddo
if (ok) then if (ok) then
do l_sd=k_sd+1,idx_alpha(0) do l_sd=k_sd+1,idx_alpha_(0,iproc)
call get_excitation_degree(tmp_det,psi_det_sorted(1,1,idx_alpha(l_sd)),degree,N_int) call get_excitation_degree(tmp_det,psi_det_sorted(1,1,idx_alpha_(l_sd,iproc)),degree,N_int)
if (degree == 0) then if (degree == 0) then
call get_excitation(psi_ref(1,1,i_I),psi_det_sorted(1,1,idx_alpha(l_sd)),exc,degree,phase2,N_int) call get_excitation(psi_ref(1,1,i_I),psi_det_sorted(1,1,idx_alpha_(l_sd,iproc)),exc,degree,phase2,N_int)
do i_state=1,N_states do i_state=1,N_states
dka(i_state) = dij(i_I, idx_non_ref_from_sorted(idx_alpha(l_sd)), i_state) * phase * phase2 dka(i_state) = dij(i_I, idx_non_ref_from_sorted(idx_alpha_(l_sd,iproc)), i_state) * phase * phase2
enddo enddo
exit exit
endif endif
enddo enddo
else if (perturbative_triples) then else if (perturbative_triples) then
hka = hij_cache(idx_alpha(k_sd)) hka = hij_cache_(idx_alpha_(k_sd,iproc),iproc)
if (dabs(hka) > 1.d-12) then if (dabs(hka) > 1.d-12) then
call get_delta_e_dyall_general_mp(psi_ref(1,1,i_I),alpha,Delta_E_inv) call get_delta_e_dyall_general_mp(psi_ref(1,1,i_I),alpha,Delta_E_inv)
@ -190,7 +189,7 @@ subroutine dress_with_alpha_buffer(delta_ij_loc, minilist, n_minilist, alpha)
if (perturbative_triples.and. (degree2 == 1) ) then if (perturbative_triples.and. (degree2 == 1) ) then
call i_h_j(psi_ref(1,1,i_I),tmp_det,N_int,hka) call i_h_j(psi_ref(1,1,i_I),tmp_det,N_int,hka)
hka = hij_cache(idx_alpha(k_sd)) - hka hka = hij_cache_(idx_alpha_(k_sd,iproc),iproc) - hka
if (dabs(hka) > 1.d-12) then if (dabs(hka) > 1.d-12) then
call get_delta_e_dyall_general_mp(psi_ref(1,1,i_I),alpha,Delta_E_inv) call get_delta_e_dyall_general_mp(psi_ref(1,1,i_I),alpha,Delta_E_inv)
do i_state=1,N_states do i_state=1,N_states
@ -210,33 +209,23 @@ subroutine dress_with_alpha_buffer(delta_ij_loc, minilist, n_minilist, alpha)
enddo enddo
if(.not. ok2) cycle if(.not. ok2) cycle
do i_state=1,N_states do l_sd=1,idx_alpha_(0,iproc)
ci_inv(i_state) = psi_ref_coef_inv(i_I,i_state) k_sd = idx_alpha_(l_sd,iproc)
enddo hla = hij_cache_(k_sd,iproc)
do l_sd=1,idx_alpha(0) sla = sij_cache_(k_sd,iproc)
k_sd = idx_alpha(l_sd)
hla = hij_cache(k_sd)
sla = sij_cache(k_sd)
do i_state=1,N_states do i_state=1,N_states
dIa_hla(i_state,k_sd) = dIa(i_state) * hla ! dIa_hla_(i_state,k_sd,iproc) = dIa(i_state) * hla
dIa_sla(i_state,k_sd) = dIa(i_state) * sla ! dIa_sla_(i_state,k_sd,iproc) = dIa(i_state) * sla
enddo ! enddo
enddo ! enddo
do i_state=1,N_states ! do l_sd=1,idx_alpha_(0,iproc)
do l_sd=1,idx_alpha(0) ! do i_state=1,N_states
!print *, "DRES" k_sd = idx_alpha_(l_sd,iproc)
!print *, i_state, idx_alpha(l_sd)
k_sd = idx_alpha(l_sd)
m_sd = psi_from_sorted(k_sd) m_sd = psi_from_sorted(k_sd)
hdress = dIa_hla(i_state,k_sd) * psi_ref_coef(i_I,i_state)! * c0(i_state) hdress = dIa(i_state) * hla * psi_ref_coef(i_I,i_state)
sdress = dIa_sla(i_state,k_sd) * psi_ref_coef(i_I,i_state)! * c0(i_state) sdress = dIa(i_state) * sla * psi_ref_coef(i_I,i_state)
!!$OMP ATOMIC ! hdress = dIa_hla_(i_state,k_sd,iproc) * psi_ref_coef(i_I,i_state)
!shdress += 1d0 ! sdress = dIa_sla_(i_state,k_sd,iproc) * psi_ref_coef(i_I,i_state)
nalp += 1
if(hdress /= 0d0) then
ninc = ninc + 1
!print *, "grepme2", hdress, shdress
end if
!$OMP ATOMIC !$OMP ATOMIC
delta_ij_loc(i_state,m_sd,1) += hdress delta_ij_loc(i_state,m_sd,1) += hdress
!$OMP ATOMIC !$OMP ATOMIC
@ -246,10 +235,6 @@ subroutine dress_with_alpha_buffer(delta_ij_loc, minilist, n_minilist, alpha)
enddo enddo
enddo enddo
!if(ninc /= old_ninc) then
! nalp = nalp + 1
! !print "(A8,I20,I20,E15.5)", "grepme", alpha(1,1), alpha(1,2), shdress
!end if
end subroutine end subroutine