From bf1248eb86c6394b2937f792ed1b697490d979b3 Mon Sep 17 00:00:00 2001 From: Yann Garniron Date: Tue, 19 Jul 2016 15:00:20 +0200 Subject: [PATCH] working - no pt2 --- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 140 +++++++++------ plugins/Full_CI_ZMQ/selection.irp.f | 248 +++++++++++++++++++-------- plugins/mrcepa0/dressing_slave.irp.f | 6 +- 3 files changed, 268 insertions(+), 126 deletions(-) diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index e91268d0..f5733751 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -9,7 +9,6 @@ program fci_zmq 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" @@ -32,24 +31,15 @@ program fci_zmq 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() + call ZMQ_selection(max(N_det, 1000-N_det)) PROVIDE psi_coef PROVIDE psi_det PROVIDE psi_det_sorted @@ -62,9 +52,7 @@ program fci_zmq 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 @@ -113,47 +101,101 @@ end -subroutine ZMQ_selection() - 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 +subroutine ZMQ_selection(N) + use f77_zmq + use selection_types - 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(1) - - do i=ithread,N_det_generators,nproc - print *, i, "/", N_det_generators - call select_connected(i, max(100, N_det), ci_electronic_energy,zmq_socket_push) - enddo - - 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 + implicit none + + character*(512) :: task + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + integer, intent(in) :: N + type(selection_buffer) :: b + integer :: i + integer, external :: omp_get_thread_num + call new_parallel_job(zmq_to_qp_run_socket,'selection') + + call create_selection_buffer(N, N*2, b) + + do i=1, N_det_generators + write(task,*) i, N + call add_task_to_taskserver(zmq_to_qp_run_socket,task) + end do + + provide nproc + !$OMP PARALLEL DEFAULT(none) SHARED(b) PRIVATE(i) NUM_THREADS(nproc+1) + i = omp_get_thread_num() + if (i==0) then + call selection_collector(b) + else + call selection_dressing_slave_inproc(i) endif - call end_zmq_push_socket(zmq_socket_push, 1) - endif - !$OMP END PARALLEL - call copy_H_apply_buffer_to_wf() + !$OMP END PARALLEL + call end_parallel_job(zmq_to_qp_run_socket, 'selection') + call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN + call copy_H_apply_buffer_to_wf() +end subroutine + + +subroutine selection_dressing_slave_tcp(i) + implicit none + integer, intent(in) :: i + + call selection_slave(0,i) end +subroutine selection_dressing_slave_inproc(i) + implicit none + integer, intent(in) :: i + + call selection_slave(1,i) +end + + + +! subroutine ZMQ_selection() +! 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 +! +! 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(1) +! +! do i=ithread,N_det_generators,nproc +! print *, i, "/", N_det_generators +! call select_connected(i, max(100, N_det), ci_electronic_energy,zmq_socket_push) +! enddo +! +! 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, 1) +! endif +! !$OMP END PARALLEL +! call copy_H_apply_buffer_to_wf() +! end + + diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index e725dd31..2cf259dc 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -1,28 +1,126 @@ +subroutine selection_slave(thread,iproc) + use f77_zmq + use selection_types + implicit none + + integer, intent(in) :: thread, iproc + integer :: rc, i + + integer :: worker_id, task_id(100), ctask, ltask + character*(512) :: task + + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_push_socket + integer(ZMQ_PTR) :: zmq_socket_push + + type(selection_buffer) :: buf + logical :: done + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_push = new_zmq_push_socket(thread) + call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) + + buf%N = 0 + ctask = 1 + + do + call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task) + done = task_id(ctask) == 0 + if (.not. done) then + integer :: i_generator, N + read (task,*) i_generator, N + if(buf%N == 0) call create_selection_buffer(N, N*2, buf) + call select_connected(i_generator,ci_electronic_energy,buf) !! ci_electronic_energy ?? + end if + + if(done) ctask = ctask - 1 + + if(done .or. ctask == size(task_id)) then + if(ctask > 0) call push_selection_results(zmq_socket_push, buf, task_id(1), ctask) + do i=1, ctask + call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) + end do + ctask = 0 + end if + + if(done) exit + ctask = ctask + 1 + end do + + call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_push_socket(zmq_socket_push,thread) + +end subroutine -subroutine select_connected(i_generator,N,E0,zmq_socket_push) +subroutine push_selection_results(zmq_socket_push, b, task_id, ntask) + use f77_zmq + use selection_types + implicit none + + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + type(selection_buffer), intent(inout) :: b + integer, intent(in) :: ntask, task_id(*) + integer :: rc + + call sort_selection_buffer(b) + + rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE) + + rc = f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE) + + rc = f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE) + + rc = f77_zmq_send( zmq_socket_push, ntask, 4, ZMQ_SNDMORE) + + rc = f77_zmq_send( zmq_socket_push, task_id(1), ntask*4, 0) + +end subroutine + + +subroutine pull_selection_results(zmq_socket_pull, val, det, N, task_id, ntask) + use f77_zmq + use selection_types + implicit none + integer(ZMQ_PTR), intent(in) :: zmq_socket_pull + double precision, intent(out) :: val(*) + integer(bit_kind), intent(out) :: det(N_int, 2, *) + integer, intent(out) :: N, ntask, task_id(*) + integer :: rc, rn, i + + rc = f77_zmq_recv( zmq_socket_pull, N, 4, ZMQ_SNDMORE) + + rc = f77_zmq_recv( zmq_socket_pull, val(1), 8*N, ZMQ_SNDMORE) + + rc = f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, ZMQ_SNDMORE) + + rc = f77_zmq_recv( zmq_socket_pull, ntask, 4, ZMQ_SNDMORE) + + rc = f77_zmq_recv( zmq_socket_pull, task_id(1), ntask*4, 0) +end subroutine + + +subroutine select_connected(i_generator,E0,b) use f77_zmq use bitmasks use selection_types implicit none integer, intent(in) :: i_generator - integer, intent(in) :: N + type(selection_buffer), intent(inout) :: b + integer :: k,l 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 + integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2) double precision :: fock_diag_tmp(2,mo_tot_num+1) 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)) @@ -35,22 +133,9 @@ subroutine select_connected(i_generator,N,E0,zmq_socket_push) particle_mask(k,:) = hole_mask(k,:) enddo - 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) + call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,b) + call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,b) 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 @@ -62,6 +147,7 @@ subroutine create_selection_buffer(N, siz, res) 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 @@ -102,6 +188,7 @@ subroutine sort_selection_buffer(b) 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 @@ -122,40 +209,49 @@ subroutine sort_selection_buffer(b) end subroutine -subroutine receive_selected_determinants() +subroutine selection_collector(b) use f77_zmq + use selection_types use bitmasks implicit none - 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, 10000) - integer :: msg_size, rc - integer :: acc, j, robin - acc = 0 - robin = 0 - msg_size = bit_kind*N_int*2 + type(selection_buffer), intent(inout) :: b + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_pull_socket + integer(ZMQ_PTR) :: zmq_socket_pull - zmq_socket_pull = new_zmq_pull_socket() + integer :: msg_size, rc, more + integer :: acc, i, j, robin, N, ntask + double precision, allocatable :: val(:) + integer(bit_kind), allocatable :: det(:,:,:) + integer, allocatable :: task_id(:) + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_pull = new_zmq_pull_socket() + allocate(val(b%N), det(N_int, 2, b%N), task_id(N_det)) + + more = 1 + do while (more == 1) + call pull_selection_results(zmq_socket_pull, val(1), det(1,1,1), N, task_id, ntask) + do i=1, N + call add_to_selection_buffer(b, det(1,1,i), val(i)) + end do + + do i=1, ntask + if (task_id(i) /= 0) then + call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more) + endif + end do + end do - grab : do while (f77_zmq_recv(zmq_socket_pull, received_det, msg_size, 0) == msg_size) - acc += 1 - shtak(:,:,acc) = received_det - if(acc == size(shtak, 3)) then - call fill_H_apply_buffer_no_selection(acc,shtak,N_int,robin) - acc = 0 - robin += 1 - if(robin == nproc) robin = 0 - end if - end do grab - call fill_H_apply_buffer_no_selection(acc,shtak,N_int,robin) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) call end_zmq_pull_socket(zmq_socket_pull) -end + call sort_selection_buffer(b) +end subroutine + subroutine select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,buf) use f77_zmq @@ -297,24 +393,22 @@ subroutine select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,b i_H_psi_value(:) = i_H_psi_value(:) + i_H_psi_value2(:) 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 + + double precision :: delta_E, e_pert(N_states), e_pertm + e_pert(:) = 0d0 + e_pertm = 0d0 + do k=1,N_states if (i_H_psi_value(k) == 0.d0) cycle delta_E = E0(k) - Hii if (delta_E < 0.d0) then - e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * i_H_psi_value(k) * i_H_psi_value(k)) - delta_E) + e_pert(k) = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * i_H_psi_value(k) * i_H_psi_value(k)) - delta_E) else - e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * i_H_psi_value(k) * i_H_psi_value(k)) - delta_E) + e_pert(k) = 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) >= buf%mini) then - call add_to_selection_buffer(buf, exc_det, e_pert) - endif - - + if(dabs(e_pert(k)) > dabs(e_pertm)) e_pertm = e_pert(k) enddo + call add_to_selection_buffer(buf, exc_det, e_pertm) endif ! Reset exc_det @@ -522,11 +616,16 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0, 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) - i_H_psi_value = i_H_psi_value + i_H_psi_value2 + if(ptr_tmicrolist(p1+1) /= c1) 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) + i_H_psi_value = i_H_psi_value + i_H_psi_value2 + end if + + if(ptr_tmicrolist(p2+1) /= c2) then + call i_H_psi(exc_det,tmicrolist(1,1,c2),psi_coef_tmicrolist(c2, 1),N_int, ptr_tmicrolist(p2+1)-c2 ,psi_selectors_size*4,N_states,i_H_psi_value2) + i_H_psi_value = i_H_psi_value + i_H_psi_value2 + endif - call i_H_psi(exc_det,tmicrolist(1,1,c2),psi_coef_tmicrolist(c2, 1),N_int, ptr_tmicrolist(p2+1)-c2 ,psi_selectors_size*4,N_states,i_H_psi_value2) - i_H_psi_value = i_H_psi_value + i_H_psi_value2 exit endif @@ -548,22 +647,23 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0, 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 + double precision :: delta_E, e_pert(N_states), e_pertm + e_pert(:) = 0d0 + e_pertm = 0d0 do k=1,N_states if (i_H_psi_value(k) == 0.d0) cycle delta_E = E0(k) - Hii if (delta_E < 0.d0) then - e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * i_H_psi_value(k) * i_H_psi_value(k)) - delta_E) + e_pert(k) = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * i_H_psi_value(k) * i_H_psi_value(k)) - delta_E) 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) >= buf%mini) then - if (.not. is_in_wavefunction(exc_det,N_int)) then - call add_to_selection_buffer(buf, exc_det, e_pert) - endif + e_pert(k) = 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(k)) > dabs(e_pertm)) e_pertm = e_pert(k) enddo + if(dabs(e_pertm) > dabs(buf%mini)) then + if(.not. is_in_wavefunction(exc_det, N_int)) call add_to_selection_buffer(buf, exc_det, e_pertm) + end if ! endif ! iwf diff --git a/plugins/mrcepa0/dressing_slave.irp.f b/plugins/mrcepa0/dressing_slave.irp.f index a7180c13..9e8ff0ce 100644 --- a/plugins/mrcepa0/dressing_slave.irp.f +++ b/plugins/mrcepa0/dressing_slave.irp.f @@ -221,7 +221,7 @@ subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) integer, intent(in) :: task_id integer :: rc , i_state, i, kk, li integer,allocatable :: idx(:,:) - integer ::n(2) + integer :: n(2) logical :: ok allocate(idx(N_det_non_ref,2)) @@ -510,8 +510,8 @@ end ! stop -nzer = 0 -ntot = 0 + nzer = 0 + ntot = 0 do nex = 3, 0, -1 print *, "los ",nex do I_s = N_det_ref, 1, -1