diff --git a/plugins/dress_zmq/dressing.irp.f b/plugins/dress_zmq/dressing.irp.f index 1aa9c238..1736cc76 100644 --- a/plugins/dress_zmq/dressing.irp.f +++ b/plugins/dress_zmq/dressing.irp.f @@ -86,7 +86,7 @@ END_PROVIDER else errr = 1d-4 end if - relative_error = errr + relative_error = errr * 0d0 print *, "RELATIVE ERROR", relative_error call ZMQ_dress(E_CI_before, dress, del, del_s2, abs(relative_error)) diff --git a/plugins/dress_zmq/dressing_vector.irp.f b/plugins/dress_zmq/dressing_vector.irp.f index 6f5f72ad..db1f428b 100644 --- a/plugins/dress_zmq/dressing_vector.irp.f +++ b/plugins/dress_zmq/dressing_vector.irp.f @@ -10,20 +10,23 @@ integer :: i,ii,k,j,jj, l double precision :: f, tmp double precision, external :: u_dot_v - + + print *, "DELTA_IJ", delta_ij(1,:10,1) + print *, "DELTA_IJ div", delta_ij(1,:10,1) / psi_coef(dressed_column_idx(1),1) + !stop do k=1,N_states l = dressed_column_idx(k) f = 1.d0/psi_coef(l,k) do jj = 1, n_det j = jj !idx_non_ref(jj) - dressing_column_h(j,k) = delta_ij (k,jj,1) - dressing_column_s(j,k) = delta_ij (k,jj,2)!delta_ij_s2(k,jj) + dressing_column_h(j,k) = delta_ij (k,jj,1) * f + dressing_column_s(j,k) = delta_ij (k,jj,2) * f!delta_ij_s2(k,jj) enddo tmp = u_dot_v(dressing_column_h(1,k), psi_coef(1,k), N_det) dressing_column_h(l,k) -= tmp * f tmp = u_dot_v(dressing_column_s(1,k), psi_coef(1,k), N_det) dressing_column_s(l,k) -= tmp * f enddo - + !stop END_PROVIDER diff --git a/plugins/dress_zmq/run_dress_slave.irp.f b/plugins/dress_zmq/run_dress_slave.irp.f index 906bfcb3..b40de73d 100644 --- a/plugins/dress_zmq/run_dress_slave.irp.f +++ b/plugins/dress_zmq/run_dress_slave.irp.f @@ -57,12 +57,12 @@ subroutine run_dress_slave(thread,iproc,energy) call alpha_callback(delta_ij_loc, i_generator, subset) !!! SET DRESSING COLUMN? - do i=1,N_det - do i_state=1,N_states - delta_ij_loc(i_state,i,1) = delta_ij_loc(i_state,i,1) / div(i_state) - delta_ij_loc(i_state,i,2) = delta_ij_loc(i_state,i,2) / div(i_state) - end do - end do + !do i=1,N_det + ! do i_state=1,N_states + ! delta_ij_loc(i_state,i,1) = delta_ij_loc(i_state,i,1) / div(i_state) + ! delta_ij_loc(i_state,i,2) = delta_ij_loc(i_state,i,2) / div(i_state) + ! end do + !end do call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) call push_dress_results(zmq_socket_push, i_generator, delta_ij_loc, task_id) diff --git a/plugins/mrcc_sto/mrcc_sto.irp.f b/plugins/mrcc_sto/mrcc_sto.irp.f index a47b0a5b..37b40a0e 100644 --- a/plugins/mrcc_sto/mrcc_sto.irp.f +++ b/plugins/mrcc_sto/mrcc_sto.irp.f @@ -1,3 +1,4 @@ + program mrcc_sto implicit none BEGIN_DOC @@ -13,13 +14,205 @@ program mrcc_sto call dress_zmq() end + BEGIN_PROVIDER [ integer, idx_non_ref_from_sorted, (N_det) ] +&BEGIN_PROVIDER [ integer, psi_from_sorted, (N_det) ] + implicit none + integer :: i,inpsisor + + idx_non_ref_from_sorted = 0 + psi_from_sorted = 0 + + do i=1,N_det + psi_from_sorted(psi_det_sorted_order(i)) = i + inpsisor = psi_det_sorted_order(i) + if(inpsisor <= 0) stop "idx_non_ref_from_sorted" + idx_non_ref_from_sorted(inpsisor) = idx_non_ref_rev(i) + end do +END_PROVIDER + +subroutine dress_with_alpha_buffer(delta_ij_loc, minilist, n_minilist, alpha) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: alpha(N_int,2) + integer,intent(in) :: minilist(n_minilist), n_minilist + double precision, intent(inout) :: delta_ij_loc(N_states,N_det,2) + + + integer :: i,j,k,l,m + 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, allocatable :: dIa_hla(:,:), dIa_sla(:,:) + double precision :: phase, phase2 + double precision :: ci_inv(N_states) + integer :: exc(0:2,2,2) + integer :: h1,h2,p1,p2,s1,s2 + integer(bit_kind) :: tmp_det(N_int,2) + 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 :: sdress, hdress + double precision :: c0(N_states) + logical :: ok + + + if (perturbative_triples) then + PROVIDE one_anhil fock_virt_total fock_core_inactive_total one_creat + endif + 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 + do l_sd=1,n_minilist + ok = .true. + k_sd = minilist(l_sd) + !if(idx_non_ref_rev(k_sd) == 0) cycle + + 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) + if(degree1 == 0) then + ok = .false. + exit + end if + end do + + if( xor(ok, idx_non_ref_from_sorted(k_sd) > 0)) stop "BUGUE" + if(ok) then + ll_sd += 1 + idx_alpha(ll_sd) = k_sd +! call i_h_j(alpha,psi_non_ref(1,1,idx_alpha(l_sd)),N_int,hij_cache(k_sd)) +! call get_s2(alpha,psi_non_ref(1,1,idx_alpha(l_sd)),N_int,sij_cache(k_sd)) + 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 + enddo + + idx_alpha(0) = ll_sd + + + do i_I=1,N_det_ref + call get_excitation_degree(alpha,psi_ref(1,1,i_I),degree1,N_int) + if (degree1 > 4) then + cycle + endif + + do i_state=1,N_states + dIa(i_state) = 0.d0 + enddo + + do k_sd=1,idx_alpha(0) + !print *, "idx ", k_sd + !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" + if (degree > 2) then + cycle + endif + + call get_excitation(psi_det_sorted(1,1,idx_alpha(k_sd)),alpha,exc,degree2,phase,N_int) + !print *, "DEG", degree2 + call decode_exc(exc,degree2,h1,p1,h2,p2,s1,s2) + do k=1,N_int + tmp_det(k,1) = psi_ref(k,1,i_I) + tmp_det(k,2) = psi_ref(k,2,i_I) + enddo + call apply_excitation(psi_ref(1,1,i_I), exc, tmp_det, ok, N_int) + + do i_state=1,N_states + dIK(i_state) = dij(i_I, idx_non_ref_from_sorted(idx_alpha(k_sd)), i_state) + enddo + + ! + do i_state=1,N_states + dka(i_state) = 0.d0 + enddo + + if (ok) then + do l_sd=k_sd+1,idx_alpha(0) + call get_excitation_degree(tmp_det,psi_det_sorted(1,1,idx_alpha(l_sd)),degree,N_int) + 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) + 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 + enddo + exit + endif + enddo + else if (perturbative_triples) then + hka = hij_cache(idx_alpha(k_sd)) + if (dabs(hka) > 1.d-12) then + call get_delta_e_dyall_general_mp(psi_ref(1,1,i_I),alpha,Delta_E_inv) + + do i_state=1,N_states + ASSERT (Delta_E_inv(i_state) < 0.d0) + dka(i_state) = hka / Delta_E_inv(i_state) + enddo + endif + endif + + if (perturbative_triples.and. (degree2 == 1) ) then + call i_h_j(psi_ref(1,1,i_I),tmp_det,N_int,hka) + hka = hij_cache(idx_alpha(k_sd)) - hka + if (dabs(hka) > 1.d-12) then + call get_delta_e_dyall_general_mp(psi_ref(1,1,i_I),alpha,Delta_E_inv) + do i_state=1,N_states + ASSERT (Delta_E_inv(i_state) < 0.d0) + dka(i_state) = hka / Delta_E_inv(i_state) + enddo + endif + endif + do i_state=1,N_states + dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state) + enddo + enddo + + do i_state=1,N_states + ci_inv(i_state) = psi_ref_coef_inv(i_I,i_state) + enddo + do l_sd=1,idx_alpha(0) + k_sd = idx_alpha(l_sd) + hla = hij_cache(k_sd) + sla = sij_cache(k_sd) + 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 + do i_state=1,N_states + do l_sd=1,idx_alpha(0) + !print *, "DRES" + !print *, i_state, idx_alpha(l_sd) + k_sd = idx_alpha(l_sd) + m_sd = psi_from_sorted(k_sd) + if(psi_det(1,1,m_sd) /= psi_det_sorted(1,1,k_sd)) stop "psi_from_sorted foireous" + hdress = dIa_hla(i_state,k_sd) * psi_ref_coef(i_I,i_state) * c0(i_state) + sdress = dIa_sla(i_state,k_sd) * psi_ref_coef(i_I,i_state) * c0(i_state) + !$OMP ATOMIC + delta_ij_loc(i_state,m_sd,1) += hdress + !$OMP ATOMIC + delta_ij_loc(i_state,m_sd,2) += sdress + !print *, "ENDRES" + enddo + enddo + enddo +end subroutine + + + !! TESTS MINILIST -subroutine dress_with_alpha_buffer(delta_ij_loc, minilist, n_minilist, alpha) +subroutine test_minilist(minilist, n_minilist, alpha) use bitmasks implicit none - double precision,intent(inout) :: delta_ij_loc(N_states,N_det,2) integer, intent(in) :: n_minilist integer(bit_kind),intent(in) :: alpha(N_int, 2) integer, intent(in) :: minilist(n_minilist) @@ -47,8 +240,6 @@ subroutine dress_with_alpha_buffer(delta_ij_loc, minilist, n_minilist, alpha) exit end if end do - - delta_ij_loc = 0d0 end subroutine diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index 93f8edf1..884345ff 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -867,6 +867,7 @@ end else target_error = 1d-4 end if + target_error = 0d0 call ZMQ_mrcc(E_CI_before, mrcc, delta_ij_mrcc_zmq, delta_ij_s2_mrcc_zmq, abs(target_error)) mrcc_previous_E(:) = mrcc_E0_denominator(:) diff --git a/plugins/mrcepa0/dressing_vector.irp.f b/plugins/mrcepa0/dressing_vector.irp.f index 7c5809d9..145bacc8 100644 --- a/plugins/mrcepa0/dressing_vector.irp.f +++ b/plugins/mrcepa0/dressing_vector.irp.f @@ -24,6 +24,7 @@ tmp = u_dot_v(dressing_column_s(1,k), psi_coef(1,k), N_det) dressing_column_s(l,k) -= tmp * f enddo - + print *, "DRESS", dressing_column_h(:10,1) +! stop END_PROVIDER diff --git a/plugins/mrcepa0/mrcc_stoch_routines.irp.f b/plugins/mrcepa0/mrcc_stoch_routines.irp.f index cdda311b..d8537a8b 100644 --- a/plugins/mrcepa0/mrcc_stoch_routines.irp.f +++ b/plugins/mrcepa0/mrcc_stoch_routines.irp.f @@ -114,17 +114,17 @@ subroutine ZMQ_mrcc(E, mrcc, delta, delta_s2, relative_error) print *, irp_here, ': Failed in zmq_set_running' endif - !!$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc+1) & - ! !$OMP PRIVATE(i) - !i = omp_get_thread_num() - !if (i==0) then - ! call mrcc_collector(zmq_socket_pull,E, relative_error, delta, delta_s2, mrcc) + !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc+1) & + !$OMP PRIVATE(i) + i = omp_get_thread_num() + if (i==0) then + call mrcc_collector(zmq_socket_pull,E, relative_error, delta, delta_s2, mrcc) ! -! else -! call mrcc_slave_inproc(i) -! endif -! !$OMP END PARALLEL - call mrcc_collector(zmq_socket_pull,E, relative_error, delta, delta_s2, mrcc) + else + call mrcc_slave_inproc(i) + endif + !$OMP END PARALLEL +! call mrcc_collector(zmq_socket_pull,E, relative_error, delta, delta_s2, mrcc) call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'mrcc') print *, '========== ================= ================= =================' diff --git a/plugins/mrcepa0/run_mrcc_slave.irp.f b/plugins/mrcepa0/run_mrcc_slave.irp.f index d2e303a3..ee0bc133 100644 --- a/plugins/mrcepa0/run_mrcc_slave.irp.f +++ b/plugins/mrcepa0/run_mrcc_slave.irp.f @@ -69,7 +69,6 @@ subroutine run_mrcc_slave(thread,iproc,energy) else integer :: i_generator, i_i_generator, subset read (task,*) subset, ind - print *, "SLAVE RECEIVED", ind ! if(buf%N == 0) then ! ! Only first time ! call create_selection_buffer(1, 2, buf)