LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-10-31 19:23:50 +01:00
Code Issues Releases Wiki Activity

Fixed Travis

Browse Source
This commit is contained in:
Anthony Scemama 2016-11-30 18:53:13 +01:00
parent bc1e564f17
commit 222497d6ed
6 changed files with 183 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
plugins/MRCC_Utils/amplitudes.irp.f
View File

@ -170,7 +170,6 @@ END_PROVIDER
do at_roww = 1, n_exc_active ! hh_nex
at_row = active_pp_idx(at_roww)
wk = 0
if(mod(at_roww, 100) == 0) print *, "AtA", at_row, "/", hh_nex
do a_coll = 1, n_exc_active
a_col = active_pp_idx(a_coll)
@ -224,7 +223,7 @@ END_PROVIDER
deallocate (A_ind_mwen, A_val_mwen, As2_val_mwen, t)
!$OMP END PARALLEL
print *, "ATA SIZE", ata_size
print *, "At.A SIZE", ata_size
END_PROVIDER

1
plugins/MRCC_Utils/davidson.irp.f
View File

@ -1040,6 +1040,7 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i
call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint)
call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint)
PROVIDE delta_ij_s2
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(i,hij,s2,j,k,jj,vt,st,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)&
!$OMP SHARED(n,keys_tmp,ut,Nint,v_0,s_0,sorted,shortcut,sort_idx,version,N_st,N_st_8, &

168
plugins/mrcc_selected/dressing.irp.f
View File

@ -4,6 +4,8 @@ use bitmasks
BEGIN_PROVIDER [ double precision, delta_ij_mrcc, (N_states,N_det_non_ref,N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ii_mrcc, (N_states, N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ij_s2_mrcc, (N_states,N_det_non_ref,N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ii_s2_mrcc, (N_states, N_det_ref) ]
use bitmasks
implicit none
integer :: gen, h, p, n, t, i, h1, h2, p1, p2, s1, s2, iproc
@ -14,11 +16,13 @@ use bitmasks
delta_ij_mrcc = 0d0
delta_ii_mrcc = 0d0
print *, "Dij", dij(1,1,1)
delta_ij_s2_mrcc = 0d0
delta_ii_s2_mrcc = 0d0
PROVIDE dij
provide hh_shortcut psi_det_size! lambda_mrcc
!$OMP PARALLEL DO default(none) schedule(dynamic) &
!$OMP shared(psi_det_generators, N_det_generators, hh_exists, pp_exists, N_int, hh_shortcut) &
!$OMP shared(N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc) &
!$OMP shared(N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc, delta_ii_s2_mrcc, delta_ij_s2_mrcc) &
!$OMP private(h, n, mask, omask, buf, ok, iproc)
do gen= 1, N_det_generators
allocate(buf(N_int, 2, N_det_non_ref))
@ -37,7 +41,9 @@ use bitmasks
end do
n = n - 1
if(n /= 0) call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc,gen,n,buf,N_int,omask)
if(n /= 0) then
call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc, delta_ij_s2_mrcc, delta_ii_s2_mrcc, gen,n,buf,N_int,omask)
endif
end do
deallocate(buf)
@ -52,13 +58,15 @@ END_PROVIDER
! end subroutine
subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffer,Nint,key_mask)
subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_generator,n_selected,det_buffer,Nint,key_mask)
use bitmasks
implicit none
integer, intent(in) :: i_generator,n_selected, Nint
double precision, intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref)
double precision, intent(inout) :: delta_ii_(N_states,N_det_ref)
double precision, intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref)
double precision, intent(inout) :: delta_ii_s2_(N_states,N_det_ref)
integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected)
integer :: i,j,k,l,m
@ -68,8 +76,8 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
integer(bit_kind),allocatable :: tq(:,:,:)
integer :: N_tq, c_ref ,degree
double precision :: hIk, hla, hIl, dIk(N_states), dka(N_states), dIa(N_states)
double precision, allocatable :: dIa_hla(:,:)
double precision :: hIk, hla, hIl, sla, dIk(N_states), dka(N_states), dIa(N_states)
double precision, allocatable :: dIa_hla(:,:), dIa_sla(:,:)
double precision :: haj, phase, phase2
double precision :: f(N_states), ci_inv(N_states)
integer :: exc(0:2,2,2)
@ -82,7 +90,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
integer(bit_kind),intent(in) :: key_mask(Nint, 2)
integer,allocatable :: idx_miniList(:)
integer :: N_miniList, ni, leng
double precision, allocatable :: hij_cache(:)
double precision, allocatable :: hij_cache(:), sij_cache(:)
integer(bit_kind), allocatable :: microlist(:,:,:), microlist_zero(:,:,:)
integer, allocatable :: idx_microlist(:), N_microlist(:), ptr_microlist(:), idx_microlist_zero(:)
@ -92,7 +100,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
leng = max(N_det_generators, N_det_non_ref)
allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref))
allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref), sij_cache(N_det_non_ref))
allocate(idx_alpha(0:psi_det_size), degree_alpha(psi_det_size))
!create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint)
call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint)
@ -117,7 +125,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
deallocate(microlist, idx_microlist)
allocate (dIa_hla(N_states,N_det_non_ref))
allocate (dIa_hla(N_states,N_det_non_ref), dIa_sla(N_states,N_det_non_ref))
! |I>
@ -185,6 +193,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
do l_sd=1,idx_alpha(0)
k_sd = idx_alpha(l_sd)
call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd))
call get_s2(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,sij_cache(k_sd))
enddo
! |I>
do i_I=1,N_det_ref
@ -282,31 +291,36 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
do l_sd=1,idx_alpha(0)
k_sd = idx_alpha(l_sd)
hla = hij_cache(k_sd)
sla = sij_cache(k_sd)
! call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla)
do i_state=1,N_states
dIa_hla(i_state,k_sd) = dIa(i_state) * hla
dIa_sla(i_state,k_sd) = dIa(i_state) * sla
enddo
enddo
call omp_set_lock( psi_ref_lock(i_I) )
do i_state=1,N_states
if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then
if(dabs(psi_ref_coef(i_I,i_state)).ge.1.d-3)then
do l_sd=1,idx_alpha(0)
k_sd = idx_alpha(l_sd)
delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd)
delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd)
delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + dIa_sla(i_state,k_sd)
delta_ii_s2_(i_state,i_I) = delta_ii_s2_(i_state,i_I) - dIa_sla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd)
enddo
else
delta_ii_(i_state,i_I) = 0.d0
do l_sd=1,idx_alpha(0)
k_sd = idx_alpha(l_sd)
delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + 0.5d0*dIa_hla(i_state,k_sd)
delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + 0.5d0*dIa_sla(i_state,k_sd)
enddo
endif
enddo
call omp_unset_lock( psi_ref_lock(i_I) )
enddo
enddo
deallocate (dIa_hla,hij_cache)
deallocate (dIa_hla,dIa_sla,hij_cache,sij_cache)
deallocate(miniList, idx_miniList)
end
@ -315,45 +329,84 @@ end
BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ii, (N_states, N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ij_s2, (N_states,N_det_non_ref,N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ii_s2, (N_states, N_det_ref) ]
use bitmasks
implicit none
integer :: i, j, i_state
integer :: i, j, i_state
!mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc
do i_state = 1, N_states
if(mrmode == 3) then
if(mrmode == 3) then
do i = 1, N_det_ref
delta_ii(i_state,i)= delta_ii_mrcc(i_state,i)
do i_state = 1, N_states
delta_ii(i_state,i)= delta_ii_mrcc(i_state,i)
delta_ii_s2(i_state,i)= delta_ii_s2_mrcc(i_state,i)
enddo
do j = 1, N_det_non_ref
delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i)
do i_state = 1, N_states
delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i)
delta_ij_s2(i_state,j,i) = delta_ij_s2_mrcc(i_state,j,i)
enddo
end do
end do
!
! do i = 1, N_det_ref
! delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state)
! do j = 1, N_det_non_ref
! delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_sub_ij(i,j,i_state)
! end do
! end do
else if(mrmode == 2) then
do i = 1, N_det_ref
! =-=-= BEGIN STATE AVERAGE
! do i = 1, N_det_ref
! delta_ii(:,i)= delta_ii_mrcc(1,i)
! delta_ii_s2(:,i)= delta_ii_s2_mrcc(1,i)
! do i_state = 2, N_states
! delta_ii(:,i) += delta_ii_mrcc(i_state,i)
! delta_ii_s2(:,i) += delta_ii_s2_mrcc(i_state,i)
! enddo
! do j = 1, N_det_non_ref
! delta_ij(:,j,i) = delta_ij_mrcc(1,j,i)
! delta_ij_s2(:,j,i) = delta_ij_s2_mrcc(1,j,i)
! do i_state = 2, N_states
! delta_ij(:,j,i) += delta_ij_mrcc(i_state,j,i)
! delta_ij_s2(:,j,i) += delta_ij_s2_mrcc(i_state,j,i)
! enddo
! end do
! end do
! delta_ij = delta_ij * (1.d0/dble(N_states))
! delta_ii = delta_ii * (1.d0/dble(N_states))
! =-=-= END STATE AVERAGE
!
! do i = 1, N_det_ref
! delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state)
! do j = 1, N_det_non_ref
! delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_sub_ij(i,j,i_state)
! end do
! end do
else if(mrmode == 2) then
do i = 1, N_det_ref
do i_state = 1, N_states
delta_ii(i_state,i)= delta_ii_old(i_state,i)
do j = 1, N_det_non_ref
delta_ii_s2(i_state,i)= delta_ii_s2_old(i_state,i)
enddo
do j = 1, N_det_non_ref
do i_state = 1, N_states
delta_ij(i_state,j,i) = delta_ij_old(i_state,j,i)
end do
delta_ij_s2(i_state,j,i) = delta_ij_s2_old(i_state,j,i)
enddo
end do
else if(mrmode == 1) then
do i = 1, N_det_ref
end do
else if(mrmode == 1) then
do i = 1, N_det_ref
do i_state = 1, N_states
delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state)
do j = 1, N_det_non_ref
delta_ii_s2(i_state,i)= delta_mrcepa0_ii_s2(i,i_state)
enddo
do j = 1, N_det_non_ref
do i_state = 1, N_states
delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state)
end do
delta_ij_s2(i_state,j,i) = delta_mrcepa0_ij_s2(i,j,i_state)
enddo
end do
else
stop "invalid mrmode"
end if
end do
end do
else
stop "invalid mrmode"
end if
END_PROVIDER
@ -537,28 +590,32 @@ END_PROVIDER
BEGIN_PROVIDER [ double precision, delta_cas, (N_det_ref, N_det_ref, N_states) ]
&BEGIN_PROVIDER [ double precision, delta_cas_s2, (N_det_ref, N_det_ref, N_states) ]
use bitmasks
implicit none
integer :: i,j,k
double precision :: Hjk, Hki, Hij
double precision :: Sjk,Hjk, Hki, Hij
!double precision, external :: get_dij
integer i_state, degree
provide lambda_mrcc dIj
do i_state = 1, N_states
!$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,N_det_ref,dij)
!$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Sjk,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,delta_cas_s2,N_det_ref,dij)
do i=1,N_det_ref
do j=1,i
call get_excitation_degree(psi_ref(1,1,i), psi_ref(1,1,j), degree, N_int)
delta_cas(i,j,i_state) = 0d0
delta_cas_s2(i,j,i_state) = 0d0
do k=1,N_det_non_ref
call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Hjk)
call get_s2(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Sjk)
delta_cas(i,j,i_state) += Hjk * dij(i, k, i_state) ! * Hki * lambda_mrcc(i_state, k)
!print *, Hjk * get_dij(psi_ref(1,1,i), psi_non_ref(1,1,k), N_int), Hki * get_dij(psi_ref(1,1,j), psi_non_ref(1,1,k), N_int)
delta_cas_s2(i,j,i_state) += Sjk * dij(i, k, i_state) ! * Ski * lambda_mrcc(i_state, k)
end do
delta_cas(j,i,i_state) = delta_cas(i,j,i_state)
delta_cas_s2(j,i,i_state) = delta_cas_s2(i,j,i_state)
end do
end do
!$OMP END PARALLEL DO
@ -639,6 +696,8 @@ end function
BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij, (N_det_ref,N_det_non_ref,N_states) ]
&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii, (N_det_ref,N_states) ]
&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij_s2, (N_det_ref,N_det_non_ref,N_states) ]
&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii_s2, (N_det_ref,N_states) ]
use bitmasks
implicit none
@ -646,7 +705,7 @@ end function
integer :: p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_, sortRefIdx(N_det_ref)
logical :: ok
double precision :: phase_iI, phase_Ik, phase_Jl, phase_IJ, phase_al, diI, hIi, hJi, delta_JI, dkI(1), HkI, ci_inv(1), dia_hla(1)
double precision :: contrib, contrib2, HIIi, HJk, wall
double precision :: contrib, contrib2, contrib_s2, contrib2_s2, HIIi, HJk, wall
integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ
integer(bit_kind) :: det_tmp(N_int, 2), made_hole(N_int,2), made_particle(N_int,2), myActive(N_int,2)
integer(bit_kind),allocatable :: sortRef(:,:,:)
@ -671,14 +730,16 @@ end function
! To provide everything
contrib = dij(1, 1, 1)
do i_state = 1, N_states
delta_mrcepa0_ii(:,:) = 0d0
delta_mrcepa0_ij(:,:,:) = 0d0
delta_mrcepa0_ii(:,:) = 0d0
delta_mrcepa0_ij(:,:,:) = 0d0
delta_mrcepa0_ii_s2(:,:) = 0d0
delta_mrcepa0_ij_s2(:,:,:) = 0d0
!$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii) &
!$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2) &
do i_state = 1, N_states
!$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii, delta_mrcepa0_ij_s2, delta_mrcepa0_ii_s2) &
!$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2,contrib_s2,contrib2_s2) &
!$OMP shared(active_sorb, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef, cepa0_shortcut, det_cepa0_active) &
!$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_cas) &
!$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_cas, delta_cas_s2) &
!$OMP shared(notf,i_state, sortRef, sortRefIdx, dij)
do blok=1,cepa0_shortcut(0)
do i=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1
@ -721,16 +782,21 @@ end function
! call i_h_j(psi_non_ref(1,1,det_cepa0_idx(k)),psi_ref(1,1,J),N_int,HJk)
contrib = delta_cas(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state)
contrib_s2 = delta_cas_s2(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state)
if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then
if(dabs(psi_ref_coef(J,i_state)).ge.1.d-3) then
contrib2 = contrib / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state)
contrib2_s2 = contrib_s2 / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state)
!$OMP ATOMIC
delta_mrcepa0_ii(J,i_state) -= contrib2
delta_mrcepa0_ii_s2(J,i_state) -= contrib2_s2
else
contrib = contrib * 0.5d0
contrib_s2 = contrib_s2 * 0.5d0
end if
!$OMP ATOMIC
delta_mrcepa0_ij(J, det_cepa0_idx(i), i_state) += contrib
delta_mrcepa0_ij_s2(J, det_cepa0_idx(i), i_state) += contrib_s2
end do kloop
end do
@ -741,7 +807,7 @@ end function
deallocate(idx_sorted_bit)
call wall_time(wall)
print *, "cepa0", wall, notf
!stop
END_PROVIDER
@ -829,7 +895,7 @@ END_PROVIDER
call apply_excitation(psi_non_ref(1,1,i),exc_Ik,det_tmp,ok,N_int)
if(ok) cycle
contrib = delta_IJk * HIl * lambda_mrcc(i_state,l)
if(dabs(psi_ref_coef(II,i_state)).ge.5.d-5) then
if(dabs(psi_ref_coef(II,i_state)).ge.1.d-3) then
contrib2 = contrib / psi_ref_coef(II, i_state) * psi_non_ref_coef(l,i_state)
!$OMP ATOMIC
delta_sub_ii(II,i_state) -= contrib2
@ -860,12 +926,14 @@ subroutine set_det_bit(det, p, s)
end subroutine
BEGIN_PROVIDER [ double precision, h_, (N_det_ref,N_det_non_ref) ]
BEGIN_PROVIDER [ double precision, h_cache, (N_det_ref,N_det_non_ref) ]
&BEGIN_PROVIDER [ double precision, s2_cache, (N_det_ref,N_det_non_ref) ]
implicit none
integer :: i,j
do i=1,N_det_ref
do j=1,N_det_non_ref
call i_h_j(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, h_(i,j))
call i_h_j(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, h_cache(i,j))
call get_s2(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, s2_cache(i,j))
end do
end do
END_PROVIDER

86
plugins/mrcc_selected/dressing_slave.irp.f
View File

@ -37,7 +37,7 @@ subroutine mrsc2_dressing_slave(thread,iproc)
integer(ZMQ_PTR), external :: new_zmq_push_socket
integer(ZMQ_PTR) :: zmq_socket_push
double precision, allocatable :: delta(:,:,:)
double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:)
@ -47,8 +47,8 @@ subroutine mrsc2_dressing_slave(thread,iproc)
logical :: ok
double precision :: phase_iI, phase_Ik, phase_Jl, phase_Ji, phase_al
double precision :: diI, hIi, hJi, delta_JI, dkI, HkI, ci_inv(N_states), cj_inv(N_states)
double precision :: contrib, wall, iwall
double precision, allocatable :: dleat(:,:,:)
double precision :: contrib, contrib_s2, wall, iwall
double precision, allocatable :: dleat(:,:,:), dleat_s2(:,:,:)
integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ
integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2), inac, virt
integer, external :: get_index_in_psi_det_sorted_bit, searchDet, detCmp
@ -63,6 +63,7 @@ subroutine mrsc2_dressing_slave(thread,iproc)
call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
allocate (dleat(N_states, N_det_non_ref, 2), delta(N_states,0:N_det_non_ref, 2))
allocate (dleat_s2(N_states, N_det_non_ref, 2), delta_s2(N_states,0:N_det_non_ref, 2))
allocate(komon(0:N_det_non_ref))
do
@ -74,10 +75,14 @@ subroutine mrsc2_dressing_slave(thread,iproc)
cj_inv(i_state) = 1.d0 / psi_ref_coef(J,i_state)
end do
!delta = 0.d0
!delta_s2 = 0.d0
n = 0
delta(:,0,:) = 0d0
delta(:,:nlink(J),1) = 0d0
delta(:,:nlink(i_I),2) = 0d0
delta_s2(:,0,:) = 0d0
delta_s2(:,:nlink(J),1) = 0d0
delta_s2(:,:nlink(i_I),2) = 0d0
komon(0) = 0
komoned = .false.
@ -121,8 +126,8 @@ subroutine mrsc2_dressing_slave(thread,iproc)
end if
i = det_cepa0_idx(linked(m, i_I))
if(h_(J,i) == 0.d0) cycle
if(h_(i_I,i) == 0.d0) cycle
if(h_cache(J,i) == 0.d0) cycle
if(h_cache(i_I,i) == 0.d0) cycle
!ok = .false.
!do i_state=1, N_states
@ -144,10 +149,13 @@ subroutine mrsc2_dressing_slave(thread,iproc)
! if(I_i == J) phase_Ii = phase_Ji
do i_state = 1,N_states
dkI = h_(J,i) * dij(i_I, i, i_state)!get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,i), N_int)
!dkI = h_(J,i) * h_(i_I,i) * lambda_mrcc(i_state, i)
dkI = h_cache(J,i) * dij(i_I, i, i_state)
dleat(i_state, kn, 1) = dkI
dleat(i_state, kn, 2) = dkI
dkI = s2_cache(J,i) * dij(i_I, i, i_state)
dleat_s2(i_state, kn, 1) = dkI
dleat_s2(i_state, kn, 2) = dkI
end do
end do
@ -173,26 +181,32 @@ subroutine mrsc2_dressing_slave(thread,iproc)
!if(lambda_mrcc(i_state, i) == 0d0) cycle
!contrib = h_(i_I,k) * lambda_mrcc(i_state, k) * dleat(i_state, m, 2)! * phase_al
!contrib = h_cache(i_I,k) * lambda_mrcc(i_state, k) * dleat(i_state, m, 2)! * phase_al
contrib = dij(i_I, k, i_state) * dleat(i_state, m, 2)
contrib_s2 = dij(i_I, k, i_state) * dleat_s2(i_state, m, 2)
delta(i_state,ll,1) += contrib
delta_s2(i_state,ll,1) += contrib_s2
if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5) then
delta(i_state,0,1) -= contrib * ci_inv(i_state) * psi_non_ref_coef(l,i_state)
delta_s2(i_state,0,1) -= contrib_s2 * ci_inv(i_state) * psi_non_ref_coef(l,i_state)
endif
if(I_i == J) cycle
!contrib = h_(J,l) * lambda_mrcc(i_state, l) * dleat(i_state, m, 1)! * phase_al
!contrib = h_cache(J,l) * lambda_mrcc(i_state, l) * dleat(i_state, m, 1)! * phase_al
contrib = dij(J, l, i_state) * dleat(i_state, m, 1)
contrib_s2 = dij(J, l, i_state) * dleat_s2(i_state, m, 1)
delta(i_state,kk,2) += contrib
delta_s2(i_state,kk,2) += contrib_s2
if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then
delta(i_state,0,2) -= contrib * cj_inv(i_state) * psi_non_ref_coef(k,i_state)
delta_s2(i_state,0,2) -= contrib_s2 * cj_inv(i_state) * psi_non_ref_coef(k,i_state)
end if
enddo !i_state
end do ! while
end do ! kk
call push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id)
call push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id)
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id)
! end if
@ -208,7 +222,7 @@ subroutine mrsc2_dressing_slave(thread,iproc)
end
subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id)
subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id)
use f77_zmq
implicit none
BEGIN_DOC
@ -218,6 +232,7 @@ subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id)
integer, intent(in) :: i_I, J
integer(ZMQ_PTR), intent(in) :: zmq_socket_push
double precision,intent(inout) :: delta(N_states, 0:N_det_non_ref, 2)
double precision,intent(inout) :: delta_s2(N_states, 0:N_det_non_ref, 2)
integer, intent(in) :: task_id
integer :: rc , i_state, i, kk, li
integer,allocatable :: idx(:,:)
@ -278,6 +293,12 @@ subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id)
print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send( zmq_socket_push, delta_s2(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) ! delta_s2(1,0,1) = delta_I delta_s2(1,0,2) = delta_J
if (rc /= (n(kk)+1)*8*N_states) then
print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta_s2, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send( zmq_socket_push, idx(1,kk), n(kk)*4, ZMQ_SNDMORE)
if (rc /= n(kk)*4) then
@ -305,7 +326,7 @@ end
subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id)
subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, task_id)
use f77_zmq
implicit none
BEGIN_DOC
@ -315,6 +336,7 @@ subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id)
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
integer, intent(out) :: i_I, J, n(2)
double precision, intent(inout) :: delta(N_states, 0:N_det_non_ref, 2)
double precision, intent(inout) :: delta_s2(N_states, 0:N_det_non_ref, 2)
integer, intent(out) :: task_id
integer :: rc , i, kk
integer,intent(inout) :: idx(N_det_non_ref,2)
@ -346,9 +368,15 @@ subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id)
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, delta_s2(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE)
if (rc /= (n(kk)+1)*8*N_states) then
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta_s2, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE)
if (rc /= n(kk)*4) then
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta, n(kk)*4, ZMQ_SNDMORE)'
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE)'
stop 'error'
endif
end if
@ -372,7 +400,7 @@ end
subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_)
subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2_)
use f77_zmq
implicit none
BEGIN_DOC
@ -381,11 +409,13 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_)
double precision,intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref)
double precision,intent(inout) :: delta_ii_(N_states,N_det_ref)
double precision,intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref)
double precision,intent(inout) :: delta_ii_s2_(N_states,N_det_ref)
! integer :: j,l
integer :: rc
double precision, allocatable :: delta(:,:,:)
double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:)
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
@ -401,49 +431,47 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_)
delta_ii_(:,:) = 0d0
delta_ij_(:,:,:) = 0d0
delta_ii_s2_(:,:) = 0d0
delta_ij_s2_(:,:,:) = 0d0
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
zmq_socket_pull = new_zmq_pull_socket()
allocate ( delta(N_states,0:N_det_non_ref,2) )
allocate ( delta(N_states,0:N_det_non_ref,2), delta_s2(N_states,0:N_det_non_ref,2) )
allocate(idx(N_det_non_ref,2))
more = 1
do while (more == 1)
call pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id)
call pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, task_id)
do l=1, n(1)
do i_state=1,N_states
delta_ij_(i_state,idx(l,1),i_I) += delta(i_state,l,1)
delta_ij_s2_(i_state,idx(l,1),i_I) += delta_s2(i_state,l,1)
end do
end do
do l=1, n(2)
do i_state=1,N_states
delta_ij_(i_state,idx(l,2),J) += delta(i_state,l,2)
delta_ij_s2_(i_state,idx(l,2),J) += delta_s2(i_state,l,2)
end do
end do
!
! do l=1,nlink(J)
! do i_state=1,N_states
! delta_ij_(i_state,det_cepa0_idx(linked(l,J)),i_I) += delta(i_state,l,1)
! delta_ij_(i_state,det_cepa0_idx(linked(l,i_I)),j) += delta(i_state,l,2)
! end do
! end do
!
if(n(1) /= 0) then
do i_state=1,N_states
delta_ii_(i_state,i_I) += delta(i_state,0,1)
delta_ii_s2_(i_state,i_I) += delta_s2(i_state,0,1)
end do
end if
if(n(2) /= 0) then
do i_state=1,N_states
delta_ii_(i_state,J) += delta(i_state,0,2)
delta_ii_s2_(i_state,J) += delta_s2(i_state,0,2)
end do
end if
@ -454,7 +482,7 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_)
enddo
deallocate( delta )
deallocate( delta, delta_s2 )
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_pull_socket(zmq_socket_pull)
@ -466,6 +494,8 @@ end
BEGIN_PROVIDER [ double precision, delta_ij_old, (N_states,N_det_non_ref,N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ii_old, (N_states,N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ij_s2_old, (N_states,N_det_non_ref,N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ii_s2_old, (N_states,N_det_ref) ]
implicit none
integer :: i_state, i, i_I, J, k, kk, degree, degree2, m, l, deg, ni, m2
@ -574,10 +604,10 @@ end
! rc = pthread_create(collector_thread, mrsc2_dressing_collector)
print *, nzer, ntot, float(nzer) / float(ntot)
provide nproc
!$OMP PARALLEL DEFAULT(none) SHARED(delta_ii_old,delta_ij_old) PRIVATE(i) NUM_THREADS(nproc+1)
!$OMP PARALLEL DEFAULT(none) SHARED(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old) PRIVATE(i) NUM_THREADS(nproc+1)
i = omp_get_thread_num()
if (i==0) then
call mrsc2_dressing_collector(delta_ii_old,delta_ij_old)
call mrsc2_dressing_collector(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old)
else
call mrsc2_dressing_slave_inproc(i)
endif

2
tests/bats/cassd.bats
View File

@ -13,7 +13,7 @@ source $QP_ROOT/tests/bats/common.bats.sh
qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]"
qp_run cassd_zmq $INPUT
energy="$(ezfio get cas_sd_zmq energy_pt2)"
eq $energy -76.231196 2.E-5
eq $energy -76.2311122169983 2.E-5
ezfio set determinants n_det_max 2048
ezfio set determinants read_wf True

8
tests/bats/mrcepa0.bats
View File

@ -16,7 +16,7 @@ source $QP_ROOT/tests/bats/common.bats.sh
ezfio set mrcepa0 n_it_max_dressed_ci 3
qp_run $EXE $INPUT
energy="$(ezfio get mrcepa0 energy_pt2)"
eq $energy -76.238562192068 1.e-4
eq $energy -76.23857580469 1.e-4
}
@test "MRCC H2O cc-pVDZ" {
@ -33,7 +33,7 @@ source $QP_ROOT/tests/bats/common.bats.sh
ezfio set mrcepa0 n_it_max_dressed_ci 3
qp_run $EXE $INPUT
energy="$(ezfio get mrcepa0 energy_pt2)"
eq $energy -76.238527498388962 1.e-4
eq $energy -76.238618303075 1.e-4
}
@test "MRSC2 H2O cc-pVDZ" {
@ -49,7 +49,7 @@ source $QP_ROOT/tests/bats/common.bats.sh
ezfio set mrcepa0 n_it_max_dressed_ci 3
qp_run $EXE $INPUT
energy="$(ezfio get mrcepa0 energy_pt2)"
eq $energy -76.235833732594187 1.e-4
eq $energy -76.235866800716 1.e-4
}
@test "MRCEPA0 H2O cc-pVDZ" {
@ -65,6 +65,6 @@ source $QP_ROOT/tests/bats/common.bats.sh
ezfio set mrcepa0 n_it_max_dressed_ci 3
qp_run $EXE $INPUT
energy="$(ezfio get mrcepa0 energy_pt2)"
eq $energy -76.2418799284763 1.e-4
eq $energy -76.2419415001101 1.e-4
}