diff --git a/plugins/Full_CI/full_ci.irp.f b/plugins/Full_CI/full_ci.irp.f index e6d0f7f2..e16397fc 100644 --- a/plugins/Full_CI/full_ci.irp.f +++ b/plugins/Full_CI/full_ci.irp.f @@ -42,6 +42,7 @@ program full_ci print*,'Beginning the selection ...' E_CI_before = CI_energy do while (N_det < N_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) + print *, selection_criterion, "*******************" n_det_before = N_det call H_apply_FCI(pt2, norm_pert, H_pert_diag, N_st) diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index 1a521ed1..e91268d0 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -1,5 +1,119 @@ -program Full_CI_ZMQ + +program fci_zmq + implicit none + integer :: i,k + + + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) + integer :: N_st, degree + N_st = N_states + allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st)) + character*(64) :: perturbation + + pt2 = 1.d0 + diag_algorithm = "Lapack" + + if (N_det > N_det_max) then + call diagonalize_CI + call save_wavefunction + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + N_det = N_det_max + soft_touch N_det psi_det psi_coef + call diagonalize_CI + call save_wavefunction + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + print *, 'PT2 = ', pt2 + print *, 'E = ', CI_energy + print *, 'E+PT2 = ', CI_energy+pt2 + print *, '-----' + endif + double precision :: i_H_psi_array(N_states),diag_H_mat_elem,h,i_O1_psi_array(N_states) + double precision :: E_CI_before(N_states) + provide selection_criterion + if(read_wf)then + call i_H_psi(psi_det(1,1,N_det),psi_det,psi_coef,N_int,N_det,psi_det_size,N_states,i_H_psi_array) + h = diag_H_mat_elem(psi_det(1,1,N_det),N_int) + selection_criterion = dabs(psi_coef(N_det,1) * (i_H_psi_array(1) - h * psi_coef(N_det,1))) * 0.1d0 + soft_touch selection_criterion + endif + + + integer :: n_det_before + print*,'Beginning the selection ...' + E_CI_before = CI_energy + do while (N_det < N_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) + !selection_criterion = 1d-7 + print *, selection_criterion, "+++++++++++++++++++++++++++++++++++++++", N_det + n_det_before = N_det +! call H_apply_FCI(pt2, norm_pert, H_pert_diag, N_st) + call ZMQ_selection() + PROVIDE psi_coef + PROVIDE psi_det + PROVIDE psi_det_sorted + + if (N_det > N_det_max) then + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + N_det = N_det_max + soft_touch N_det psi_det psi_coef + endif + call diagonalize_CI + call save_wavefunction + if(n_det_before == N_det)then + selection_criterion = selection_criterion * 0.1d0 + endif + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + do k = 1, N_states + print*,'State ',k + print *, 'PT2 = ', pt2(k) + print *, 'E = ', CI_energy(k) + print *, 'E(before)+PT2 = ', E_CI_before(k)+pt2(k) + enddo + print *, '-----' + E_CI_before = CI_energy + if(N_states.gt.1)then + print*,'Variational Energy difference' + do i = 2, N_states + print*,'Delta E = ',CI_energy(i) - CI_energy(1) + enddo + endif + if(N_states.gt.1)then + print*,'Variational + perturbative Energy difference' + do i = 2, N_states + print*,'Delta E = ',E_CI_before(i)+ pt2(i) - (E_CI_before(1) + pt2(1)) + enddo + endif + E_CI_before = CI_energy + call ezfio_set_full_ci_energy(CI_energy) + enddo + N_det = min(N_det_max,N_det) + touch N_det psi_det psi_coef + call diagonalize_CI +! if(do_pt2_end)then +! print*,'Last iteration only to compute the PT2' +! threshold_selectors = 1.d0 +! threshold_generators = 0.999d0 +! call H_apply_FCI_PT2(pt2, norm_pert, H_pert_diag, N_st) +! +! print *, 'Final step' +! print *, 'N_det = ', N_det +! print *, 'N_states = ', N_states +! print *, 'PT2 = ', pt2 +! print *, 'E = ', CI_energy +! print *, 'E+PT2 = ', CI_energy+pt2 +! print *, '-----' +! call ezfio_set_full_ci_energy_pt2(CI_energy+pt2) +! endif + call save_wavefunction +end + + + +subroutine ZMQ_selection() use f77_zmq implicit none BEGIN_DOC @@ -7,14 +121,11 @@ program Full_CI_ZMQ END_DOC integer :: i,ithread - integer(ZMQ_PTR) :: zmq_socket_push integer(ZMQ_PTR), external :: new_zmq_push_socket zmq_context = f77_zmq_ctx_new () PROVIDE H_apply_buffer_allocated -! do while (N_det < N_det_max) - PROVIDE ci_electronic_energy PROVIDE nproc !$OMP PARALLEL PRIVATE(i,ithread,zmq_socket_push) num_threads(nproc+1) @@ -22,13 +133,12 @@ program Full_CI_ZMQ if (ithread == 0) then call receive_selected_determinants() else - zmq_socket_push = new_zmq_push_socket() + zmq_socket_push = new_zmq_push_socket(1) do i=ithread,N_det_generators,nproc - print *, i , "/", N_det_generators - call select_connected(i, 1.d-7, ci_electronic_energy,zmq_socket_push) + print *, i, "/", N_det_generators + call select_connected(i, max(100, N_det), ci_electronic_energy,zmq_socket_push) enddo - print *, "END .... " if (ithread == 1) then integer :: rc @@ -37,12 +147,68 @@ program Full_CI_ZMQ stop 'Error sending termination signal' endif endif - call end_zmq_push_socket(zmq_socket_push, 0) + call end_zmq_push_socket(zmq_socket_push, 1) endif !$OMP END PARALLEL call copy_H_apply_buffer_to_wf() - call diagonalize_CI - call save_wavefunction() -! end do - end + + + + + + + + + + + + + +! program Full_CI_ZMQ +! use f77_zmq +! implicit none +! BEGIN_DOC +! ! Massively parallel Full-CI +! END_DOC +! +! integer :: i,ithread +! +! integer(ZMQ_PTR) :: zmq_socket_push +! integer(ZMQ_PTR), external :: new_zmq_push_socket +! zmq_context = f77_zmq_ctx_new () +! PROVIDE H_apply_buffer_allocated +! +! do while (N_det < N_det_max) +! +! PROVIDE ci_electronic_energy +! PROVIDE nproc +! !$OMP PARALLEL PRIVATE(i,ithread,zmq_socket_push) num_threads(nproc+1) +! ithread = omp_get_thread_num() +! if (ithread == 0) then +! call receive_selected_determinants() +! else +! zmq_socket_push = new_zmq_push_socket(0) +! +! do i=ithread,N_det_generators,nproc +! print *, i , "/", N_det_generators +! call select_connected(i, 1.d-7, ci_electronic_energy,zmq_socket_push) +! enddo +! print *, "END .... " +! +! if (ithread == 1) then +! integer :: rc +! rc = f77_zmq_send(zmq_socket_push,0,1,0) +! if (rc /= 1) then +! stop 'Error sending termination signal' +! endif +! endif +! call end_zmq_push_socket(zmq_socket_push, 0) +! endif +! !$OMP END PARALLEL +! call copy_H_apply_buffer_to_wf() +! call diagonalize_CI() +! call save_wavefunction() +! end do +! +! end diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index 5d0310ed..e725dd31 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -1,30 +1,28 @@ -subroutine select_connected(i_generator,thr,E0,zmq_socket_push) + +subroutine select_connected(i_generator,N,E0,zmq_socket_push) use f77_zmq use bitmasks + use selection_types implicit none integer, intent(in) :: i_generator - double precision, intent(in) :: thr + integer, intent(in) :: N double precision, intent(in) :: E0(N_states) integer(ZMQ_PTR), intent(in) :: zmq_socket_push BEGIN_DOC ! Select determinants connected to i_det by H END_DOC - ASSERT (thr >= 0.d0) integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision :: fock_diag_tmp(2,mo_tot_num+1) -! print *, i_generator, "MM" -! return - call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) integer :: k,l - - + type(selection_buffer) :: buf + call create_selection_buffer(N, N*2, buf) + buf%mini = 1d-7 do l=1,N_generators_bitmask do k=1,N_int hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole,l), psi_det_generators(k,1,i_generator)) @@ -37,13 +35,93 @@ subroutine select_connected(i_generator,thr,E0,zmq_socket_push) particle_mask(k,:) = hole_mask(k,:) enddo - call select_singles(i_generator,thr,hole_mask,particle_mask,fock_diag_tmp,E0,zmq_socket_push) - call select_doubles(i_generator,thr,hole_mask,particle_mask,fock_diag_tmp,E0,zmq_socket_push) + call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,buf) + call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,buf) enddo - + + call sort_selection_buffer(buf) + +! integer :: rc +! rc = f77_zmq_send(zmq_socket_push, exc_det, msg_size,0) +! if (rc /= msg_size) then +! stop 'Unable to send selected determinant' +! endif +! do k=1,buf%cur +! print *, buf%val(k) +! call debug_det(buf%det(1,1,k), N_int) +! end do end + +subroutine create_selection_buffer(N, siz, res) + use selection_types + implicit none + + integer, intent(in) :: N, siz + type(selection_buffer), intent(out) :: res + + allocate(res%det(N_int, 2, siz), res%val(siz)) + res%val = 0d0 + res%det = 0_8 + res%N = N + res%mini = 0d0 + res%cur = 0 +end subroutine + + +subroutine add_to_selection_buffer(b, det, val) + use selection_types + implicit none + + type(selection_buffer), intent(inout) :: b + integer(bit_kind), intent(in) :: det(N_int, 2) + double precision, intent(in) :: val + integer :: i + + if(dabs(val) >= b%mini) then + b%cur += 1 + b%det(:,:,b%cur) = det(:,:) + b%val(b%cur) = val + if(b%cur == size(b%val)) then + call sort_selection_buffer(b) + end if + end if +end subroutine + + +subroutine sort_selection_buffer(b) + use selection_types + implicit none + + type(selection_buffer), intent(inout) :: b + double precision, allocatable :: vals(:), absval(:) + integer, allocatable :: iorder(:) + integer(bit_kind), allocatable :: detmp(:,:,:) + integer :: i, nmwen + + nmwen = min(b%N, b%cur) + + allocate(iorder(b%cur), detmp(N_int, 2, nmwen), absval(b%cur), vals(nmwen)) + absval = -dabs(b%val(:b%cur)) + do i=1,b%cur + iorder(i) = i + end do + call dsort(absval, iorder, b%cur) + + do i=1, nmwen + detmp(:,:,i) = b%det(:,:,iorder(i)) + vals(i) = b%val(iorder(i)) + end do + b%det(:,:,:nmwen) = detmp(:,:,:) + b%det(:,:,nmwen+1:) = 0_bit_kind + b%val(:nmwen) = vals(:) + b%val(nmwen+1:) = 0d0 + b%mini = dabs(b%val(nmwen)) + b%cur = nmwen +end subroutine + + subroutine receive_selected_determinants() use f77_zmq use bitmasks @@ -51,62 +129,48 @@ subroutine receive_selected_determinants() BEGIN_DOC ! Receive via ZMQ the selected determinants END_DOC + integer(ZMQ_PTR) :: zmq_socket_pull integer(ZMQ_PTR), external :: new_zmq_pull_socket - integer(bit_kind) :: received_det(N_int,2), shtak(N_int, 2, 100) + integer(bit_kind) :: received_det(N_int,2), shtak(N_int, 2, 10000) integer :: msg_size, rc - integer :: acc, tac, j, robin - logical, external :: detEq, is_in_wavefunction + integer :: acc, j, robin + acc = 0 - tac = 0 robin = 0 msg_size = bit_kind*N_int*2 zmq_socket_pull = new_zmq_pull_socket() grab : do while (f77_zmq_recv(zmq_socket_pull, received_det, msg_size, 0) == msg_size) - tac += 1 - if (is_in_wavefunction(received_det,N_int)) stop "???..." - do j=1,acc - if(detEq(received_det, shtak(1,1,j), N_int)) then - cycle grab - endif - end do acc += 1 shtak(:,:,acc) = received_det - print *, acc, size(shtak, 3) if(acc == size(shtak, 3)) then - print *, robin, nproc call fill_H_apply_buffer_no_selection(acc,shtak,N_int,robin) acc = 0 robin += 1 if(robin == nproc) robin = 0 end if - - call debug_det(received_det,N_int) - print *, "tot ", acc, tac end do grab - print *, "tot ", acc, tac call fill_H_apply_buffer_no_selection(acc,shtak,N_int,robin) call end_zmq_pull_socket(zmq_socket_pull) end -subroutine select_singles(i_generator,thr,hole_mask,particle_mask,fock_diag_tmp,E0,zmq_socket_push) +subroutine select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,buf) use f77_zmq use bitmasks + use selection_types implicit none BEGIN_DOC ! Select determinants connected to i_det by H END_DOC integer, intent(in) :: i_generator - double precision, intent(in) :: thr double precision, intent(in) :: fock_diag_tmp(mo_tot_num) integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) double precision, intent(in) :: E0(N_states) - integer(ZMQ_PTR), intent(in) :: zmq_socket_push + type(selection_buffer), intent(inout) :: buf - ASSERT (thr >= 0.d0) integer :: i,j,k,l @@ -146,7 +210,21 @@ subroutine select_singles(i_generator,thr,hole_mask,particle_mask,fock_diag_tmp, ion_det(k,1) = psi_det_generators(k,1,i_generator) ion_det(k,2) = psi_det_generators(k,2,i_generator) enddo + + + ! Create the mini wave function where = + ! -------------------------------------------------------------- +! integer(bit_kind) :: psi_det_connected(N_int,2,psi_selectors_size) +! double precision :: psi_coef_connected(psi_selectors_size,N_states) + + integer :: ptr_microlist(0:mo_tot_num * 2 + 1), N_microlist(0:mo_tot_num * 2) + integer, allocatable :: idx_microlist(:) + integer(bit_kind), allocatable :: microlist(:, :, :) + double precision, allocatable :: psi_coef_microlist(:,:) + + allocate(microlist(N_int, 2, N_det_selectors * 4), psi_coef_microlist(psi_selectors_size * 4, N_states), idx_microlist(N_det_selectors * 4)) + do ispin=1,2 ! do k=1,N_int ! ion_det(k,ispin) = psi_det_generators(k,ispin,i_generator) @@ -165,17 +243,6 @@ subroutine select_singles(i_generator,thr,hole_mask,particle_mask,fock_diag_tmp, ! ion_det(k_hole,ispin) = ibclr(psi_det_generators(k_hole,ispin,i_generator),j_hole) ion_det(k_hole,ispin) = ibclr(ion_det(k_hole,ispin),j_hole) - ! Create the mini wave function where = - ! -------------------------------------------------------------- - -! integer(bit_kind) :: psi_det_connected(N_int,2,psi_selectors_size) -! double precision :: psi_coef_connected(psi_selectors_size,N_states) - - - - integer :: idx_microlist(N_det_selectors * 4), ptr_microlist(0:mo_tot_num * 2 + 1), N_microlist(0:mo_tot_num * 2) - integer(bit_kind) :: microlist(N_int, 2, N_det_selectors * 4) - double precision :: psi_coef_microlist(psi_selectors_size * 4, N_states) call create_microlist_single(psi_selectors, i_generator, N_det_selectors, ion_det, microlist, idx_microlist, N_microlist, ptr_microlist, N_int) @@ -242,12 +309,8 @@ subroutine select_singles(i_generator,thr,hole_mask,particle_mask,fock_diag_tmp, endif - if (dabs(e_pert) > thr) then - integer :: rc - rc = f77_zmq_send(zmq_socket_push, exc_det, msg_size,0) - if (rc /= msg_size) then - stop 'Unable to send selected determinant' - endif + if (dabs(e_pert) >= buf%mini) then + call add_to_selection_buffer(buf, exc_det, e_pert) endif @@ -266,20 +329,19 @@ end -subroutine select_doubles(i_generator,thr,hole_mask,particle_mask,fock_diag_tmp,E0,zmq_socket_push) +subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0, buf) use f77_zmq use bitmasks + use selection_types implicit none BEGIN_DOC ! Select determinants connected to i_det by H END_DOC integer, intent(in) :: i_generator - double precision, intent(in) :: thr double precision, intent(in) :: fock_diag_tmp(mo_tot_num) integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) double precision, intent(in) :: E0(N_states) - integer(ZMQ_PTR), intent(in) :: zmq_socket_push - ASSERT (thr >= 0.d0) + type(selection_buffer), intent(inout) :: buf integer :: i,j,k,l,j1,j2,i1,i2,ib,jb @@ -312,7 +374,25 @@ subroutine select_doubles(i_generator,thr,hole_mask,particle_mask,fock_diag_tmp, integer :: ispin1, ispin2, other_spin integer(bit_kind) :: exc_det(N_int,2), ion_det(N_int,2) - + + + integer :: ptr_microlist(0:mo_tot_num * 2 + 1), N_microlist(0:mo_tot_num * 2) + double precision, allocatable :: psi_coef_microlist(:,:) + + integer :: ptr_tmicrolist(0:mo_tot_num * 2 + 1), N_tmicrolist(0:mo_tot_num * 2) + double precision, allocatable :: psi_coef_tmicrolist(:,:) + + integer, allocatable :: idx_tmicrolist(:), idx_microlist(:) + integer(bit_kind), allocatable :: microlist(:,:,:), tmicrolist(:,:,:) + + integer :: ptr_futur_microlist(0:mo_tot_num * 2 + 1), ptr_futur_tmicrolist(0:mo_tot_num * 2 + 1) + integer :: N_futur_microlist(0:mo_tot_num * 2), N_futur_tmicrolist(0:mo_tot_num * 2) + + + allocate(idx_tmicrolist(N_det_selectors * 4), idx_microlist(N_det_selectors * 4)) + allocate(microlist(N_int, 2, N_det_selectors * 4), tmicrolist(N_int, 2, N_det_selectors * 4)) + allocate(psi_coef_tmicrolist(psi_selectors_size * 4, N_states), psi_coef_microlist(psi_selectors_size * 4, N_states)) + do k=1,N_int exc_det(k,1) = psi_det_generators(k,1,i_generator) exc_det(k,2) = psi_det_generators(k,2,i_generator) @@ -338,29 +418,16 @@ subroutine select_doubles(i_generator,thr,hole_mask,particle_mask,fock_diag_tmp, k_hole = ishft(i_hole2-1,-bit_kind_shift)+1 ! N_int j_hole = i_hole2-ishft(k_hole-1,bit_kind_shift)-1 ! bit index ion_det(k_hole,ispin2) = ibclr(ion_det(k_hole,ispin2),j_hole) - - - ! Create the mini wave function where = - ! -------------------------------------------------------------- - -! integer(bit_kind) :: psi_det_connected(N_int,2,psi_selectors_size) -! double precision :: psi_coef_connected(psi_selectors_size,N_states) - - - - integer :: idx_microlist(N_det_selectors * 4), ptr_microlist(0:mo_tot_num * 2 + 1), N_microlist(0:mo_tot_num * 2) - integer(bit_kind) :: microlist(N_int, 2, N_det_selectors * 4) - double precision :: psi_coef_microlist(psi_selectors_size * 4, N_states) - - integer :: idx_tmicrolist(N_det_selectors * 4), ptr_tmicrolist(0:mo_tot_num * 2 + 1), N_tmicrolist(0:mo_tot_num * 2) - integer(bit_kind) :: tmicrolist(N_int, 2, N_det_selectors * 4) - double precision :: psi_coef_tmicrolist(psi_selectors_size * 4, N_states) call create_microlist_double(psi_selectors, i_generator, N_det_selectors, ion_det, & microlist, idx_microlist, N_microlist, ptr_microlist, & tmicrolist, idx_tmicrolist, N_tmicrolist, ptr_tmicrolist, & N_int) + if(N_microlist(0) > 0 .and. idx_microlist(1) < i_generator) cycle + + call create_futur_ptr(ptr_microlist, idx_microlist, ptr_futur_microlist, N_futur_microlist, i_generator) + call create_futur_ptr(ptr_tmicrolist, idx_tmicrolist, ptr_futur_tmicrolist, N_futur_tmicrolist, i_generator) do j=1, ptr_microlist(mo_tot_num * 2 + 1) - 1 @@ -388,7 +455,7 @@ subroutine select_doubles(i_generator,thr,hole_mask,particle_mask,fock_diag_tmp, exc_det = ion_det i_particle2 = particle_list(j2, ispin2) - integer :: p1, p2 + integer :: p1, p2, sporb p2 = i_particle2 + (ispin2 - 1) * mo_tot_num @@ -420,13 +487,15 @@ subroutine select_doubles(i_generator,thr,hole_mask,particle_mask,fock_diag_tmp, logical, external :: is_in_wavefunction logical :: nok ! TODO : Check connected to ref - if (.not. is_in_wavefunction(exc_det,N_int)) then +! if (.not. is_in_wavefunction(exc_det,N_int)) then + + ! Compute perturbative contribution and select determinant double precision :: i_H_psi_value(N_states), i_H_psi_value2(N_states) i_H_psi_value = 0d0 i_H_psi_value2 = 0d0 - integer :: sporb + ! call i_H_psi(exc_det,psi_selectors,psi_selectors_coef,N_int,N_det_selectors,psi_selectors_size,N_states,i_H_psi_value) @@ -435,17 +504,22 @@ subroutine select_doubles(i_generator,thr,hole_mask,particle_mask,fock_diag_tmp, ! if(nok) cycle nok = .false. - call check_past(exc_det, microlist(1,1,ptr_microlist(sporb)), idx_microlist(ptr_microlist(sporb)), N_microlist(sporb), i_generator, nok, N_int) + !call check_past(exc_det, microlist(1,1,ptr_microlist(sporb)), idx_microlist(ptr_microlist(sporb)), N_microlist(sporb), i_generator, nok, N_int) + call check_past_s(exc_det, microlist(1,1,ptr_microlist(sporb)), N_microlist(sporb) - N_futur_microlist(sporb), nok, N_int) if(nok) cycle - if(N_microlist(0) > 0) call i_H_psi(exc_det,microlist,psi_coef_microlist,N_int,N_microlist(0),psi_selectors_size*4,N_states,i_H_psi_value) - if(N_microlist(sporb) > 0) call i_H_psi(exc_det,microlist(1,1,ptr_microlist(sporb)),psi_coef_microlist(ptr_microlist(sporb), 1),N_int,N_microlist(sporb),psi_selectors_size*4,N_states,i_H_psi_value2) + if(N_futur_microlist(0) > 0) call i_H_psi(exc_det,microlist(1,1,ptr_futur_microlist(0)),psi_coef_microlist(ptr_futur_microlist(0), 1),N_int,N_futur_microlist(0),psi_selectors_size*4,N_states,i_H_psi_value) + if(N_futur_microlist(sporb) > 0) call i_H_psi(exc_det,microlist(1,1,ptr_futur_microlist(sporb)),psi_coef_microlist(ptr_futur_microlist(sporb), 1),N_int,N_futur_microlist(sporb),psi_selectors_size*4,N_states,i_H_psi_value2) + +! if(N_microlist(0) > 0) call i_H_psi(exc_det,microlist,psi_coef_microlist(ptr_microlist(0), 1),N_int,N_microlist(0),psi_selectors_size*4,N_states,i_H_psi_value) +! if(N_microlist(sporb) > 0) call i_H_psi(exc_det,microlist(1,1,ptr_microlist(sporb)),psi_coef_microlist(ptr_microlist(sporb), 1),N_int,N_microlist(sporb),psi_selectors_size*4,N_states,i_H_psi_value2) + i_H_psi_value = i_H_psi_value + i_H_psi_value2 integer :: c1, c2 double precision :: hij - c1 = ptr_tmicrolist(p1) - c2 = ptr_tmicrolist(p2) + c1 = ptr_futur_tmicrolist(p1) + c2 = ptr_futur_tmicrolist(p2) do while(.true.) if(c1 >= ptr_tmicrolist(p1+1) .or. c2 >= ptr_tmicrolist(p2+1)) then call i_H_psi(exc_det,tmicrolist(1,1,c1),psi_coef_tmicrolist(c1, 1),N_int, ptr_tmicrolist(p1+1)-c1 ,psi_selectors_size*4,N_states,i_H_psi_value2) @@ -475,6 +549,7 @@ subroutine select_doubles(i_generator,thr,hole_mask,particle_mask,fock_diag_tmp, double precision :: Hii, diag_H_mat_elem_fock Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),exc_det,fock_diag_tmp,N_int) double precision :: delta_E, e_pert + do k=1,N_states if (i_H_psi_value(k) == 0.d0) cycle delta_E = E0(k) - Hii @@ -483,16 +558,20 @@ subroutine select_doubles(i_generator,thr,hole_mask,particle_mask,fock_diag_tmp, else e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * i_H_psi_value(k) * i_H_psi_value(k)) - delta_E) endif - if (dabs(e_pert) > thr) then - integer :: rc - rc = f77_zmq_send(zmq_socket_push, exc_det, msg_size,0) - if (rc /= msg_size) then - stop 'Unable to send selected determinant' + if (dabs(e_pert) >= buf%mini) then + if (.not. is_in_wavefunction(exc_det,N_int)) then + call add_to_selection_buffer(buf, exc_det, e_pert) endif endif enddo - endif +! endif ! iwf + + + + + + ! Reset exc_det ! exc_det(k_particle,ispin) = psi_det_generators(k_particle,ispin,i_generator) enddo ! j @@ -507,6 +586,25 @@ end +subroutine create_futur_ptr(ptr_microlist, idx_microlist, ptr_futur_microlist, N_futur_microlist, i_generator) + integer, intent(in) :: ptr_microlist(0:mo_tot_num * 2 + 1), idx_microlist(*), i_generator + integer, intent(out) :: ptr_futur_microlist(0:mo_tot_num * 2 + 1), N_futur_microlist(0:mo_tot_num * 2) + integer :: i, j + + N_futur_microlist = 0 + do i=0,mo_tot_num*2 + ptr_futur_microlist(i) = ptr_microlist(i+1) + do j=ptr_microlist(i), ptr_microlist(i+1) - 1 + if(idx_microlist(j) >= i_generator) then + ptr_futur_microlist(i) = j + N_futur_microlist(i) = ptr_microlist(i+1) - j + exit + end if + end do + end do +end subroutine + + subroutine create_microlist_single(minilist, i_cur, N_minilist, key_mask, microlist, idx_microlist, N_microlist, ptr_microlist, Nint) use bitmasks integer, intent(in) :: Nint, i_cur, N_minilist @@ -644,7 +742,7 @@ subroutine create_microlist_double(minilist, i_cur, N_minilist, key_mask, microl end do if(nt > 4) then !! TOO MANY DIFFERENCES - continue + cycle else if(nt < 3) then if(i < i_cur) then N_microlist = 0 !!!! PAST LINKED TO EVERYBODY! @@ -750,5 +848,26 @@ subroutine check_past(det, list, idx, N, cur, ok, Nint) end do end subroutine - +subroutine check_past_s(det, list, N, ok, Nint) + implicit none + use bitmasks + + integer(bit_kind), intent(in) :: det(Nint, 2), list(Nint, 2, N) + integer, intent(in) :: Nint, N + logical, intent(out) :: ok + integer :: i,s,ni + + ok = .false. + do i=1,N + !if(idx(i) >= cur) exit + s = 0 + do ni=1,Nint + s += popcnt(xor(det(ni,1), list(ni,1,i))) + popcnt(xor(det(ni,2), list(ni,2,i))) + end do + if(s <= 4) then + ok = .true. + return + end if + end do +end subroutine diff --git a/plugins/mrcepa0/dressing_slave.irp.f b/plugins/mrcepa0/dressing_slave.irp.f index 7d64aa5e..a7180c13 100644 --- a/plugins/mrcepa0/dressing_slave.irp.f +++ b/plugins/mrcepa0/dressing_slave.irp.f @@ -483,9 +483,6 @@ end integer :: KKsize = 1000000 - ! -459.6346665282306 - ! -459.6346665282306 - call new_parallel_job(zmq_to_qp_run_socket,'mrsc2') diff --git a/src/Determinants/H_apply.template.f b/src/Determinants/H_apply.template.f index c46a5bb0..c0659f54 100644 --- a/src/Determinants/H_apply.template.f +++ b/src/Determinants/H_apply.template.f @@ -14,6 +14,13 @@ subroutine $subroutine_diexc(key_in, key_prev, hole_1,particl_1, hole_2, particl $declarations +! print *, "bbbbbbbbbbbbbbb" +! call debug_det(key_in, N_int) +! call debug_det(hole_1, N_int) +! call debug_det(hole_2, N_int) +! call debug_det(particl_1, N_int) +! call debug_det(particl_2, N_int) +! print *, "eeeeeeeeeeeeeeee" highest = 0 do k=1,N_int*bit_kind_size