From 2454862cb0b74f767d8e90fef5ef7fe68650c9f7 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 24 Apr 2017 18:20:45 +0200 Subject: [PATCH 01/25] Working on print in pt2 stoch --- ocaml/Progress_bar.ml | 4 +-- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 9 +++-- plugins/Full_CI_ZMQ/pt2_stoch.irp.f | 2 +- plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f | 37 ++++++++++++-------- 4 files changed, 32 insertions(+), 20 deletions(-) diff --git a/ocaml/Progress_bar.ml b/ocaml/Progress_bar.ml index b8e97a59..9762153a 100644 --- a/ocaml/Progress_bar.ml +++ b/ocaml/Progress_bar.ml @@ -56,7 +56,7 @@ let display_tty bar = else Time.Span.of_float 0. in - Printf.printf "%s : [%s] %4.1f%% | %10s, ~%10s left\r%!" + Printf.eprintf "%s : [%s] %4.1f%% | %10s, ~%10s left\r%!" bar.title hashes percent @@ -83,7 +83,7 @@ let display_file bar = else Time.Span.of_float 0. in - Printf.printf "%5.2f %% in %20s, ~%20s left\n%!" + Printf.eprintf "%5.2f %% in %20s, ~%20s left\n%!" percent (Time.Span.to_string running_time) (Time.Span.to_string stop_time); diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index e12033b4..7b7c9b04 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -128,8 +128,13 @@ program fci_zmq double precision :: relative_error relative_error=1.d-3 pt2 = 0.d0 - call ZMQ_pt2(pt2,relative_error) ! Stochastic PT2 - !call ZMQ_selection(0, pt2) ! Deterministic PT2 + if (N_states > 1) then + print *, 'Stochastic PT2' + call ZMQ_pt2(E_CI_before(1), pt2,relative_error) ! Stochastic PT2 + else + print *, 'Deterministic PT2' + call ZMQ_selection(0, pt2) ! Deterministic PT2 + endif print *, 'Final step' print *, 'N_det = ', N_det print *, 'N_states = ', N_states diff --git a/plugins/Full_CI_ZMQ/pt2_stoch.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch.irp.f index 914e7138..f40fa055 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch.irp.f @@ -25,7 +25,7 @@ subroutine run threshold_selectors = 1.d0 threshold_generators = 1d0 relative_error = 1.d-3 - call ZMQ_pt2(pt2, relative_error) + call ZMQ_pt2(E_CI_before, pt2, relative_error) print *, 'Final step' print *, 'N_det = ', N_det print *, 'PT2 = ', pt2 diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f index 9a5f2fa8..facaf346 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -3,7 +3,7 @@ BEGIN_PROVIDER [ integer, fragment_first ] fragment_first = first_det_of_teeth(1) END_PROVIDER -subroutine ZMQ_pt2(pt2,relative_error) +subroutine ZMQ_pt2(E, pt2,relative_error) use f77_zmq use selection_types @@ -13,7 +13,7 @@ subroutine ZMQ_pt2(pt2,relative_error) integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_to_qp_run_socket2 type(selection_buffer) :: b integer, external :: omp_get_thread_num - double precision, intent(in) :: relative_error + double precision, intent(in) :: relative_error, E double precision, intent(out) :: pt2(N_states) @@ -46,8 +46,10 @@ subroutine ZMQ_pt2(pt2,relative_error) pt2_detail = 0d0 time0 = omp_get_wtime() - print *, "time - avg - err - n_combs" generator_per_task = 1 + print *, '========== ================ ================' + print *, ' Samples Energy Stat. Error' + print *, '========== ================ ================' do while(.true.) call write_time(6) @@ -55,7 +57,7 @@ subroutine ZMQ_pt2(pt2,relative_error) call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) call create_selection_buffer(1, 1*2, b) - Ncomb=size(comb) + Ncomb=size(comb)/100 call get_carlo_workbatch(computed, comb, Ncomb, tbc) call write_time(6) @@ -100,7 +102,7 @@ subroutine ZMQ_pt2(pt2,relative_error) !$OMP PRIVATE(i) i = omp_get_thread_num() if (i==0) then - call pt2_collector(b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, sum2above, Nabove, relative_error, pt2) + call pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, sum2above, Nabove, relative_error, pt2) else call pt2_slave_inproc(i) endif @@ -162,7 +164,7 @@ subroutine pt2_slave_inproc(i) call run_pt2_slave(1,i,pt2_e0_denominator) end -subroutine pt2_collector(b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, sum2above, Nabove, relative_error, pt2) +subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, sum2above, Nabove, relative_error, pt2) use f77_zmq use selection_types use bitmasks @@ -171,7 +173,7 @@ subroutine pt2_collector(b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, su integer, intent(in) :: Ncomb double precision, intent(inout) :: pt2_detail(N_states, N_det_generators) - double precision, intent(in) :: comb(Ncomb), relative_error + double precision, intent(in) :: comb(Ncomb), relative_error, E logical, intent(inout) :: computed(N_det_generators) integer, intent(in) :: tbc(0:size_tbc) double precision, intent(inout) :: sumabove(comb_teeth), sum2above(comb_teeth), Nabove(comb_teeth) @@ -194,11 +196,12 @@ subroutine pt2_collector(b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, su integer :: done, Nindex integer, allocatable :: index(:) double precision, save :: time0 = -1.d0 - double precision :: time, timeLast + double precision :: time, timeLast, Nabove_old double precision, external :: omp_get_wtime integer :: tooth, firstTBDcomb, orgTBDcomb integer, allocatable :: parts_to_get(:) logical, allocatable :: actually_computed(:) + Nabove_old = -1.d0 allocate(actually_computed(N_det_generators), parts_to_get(N_det_generators), & pt2_mwen(N_states, N_det_generators) ) @@ -229,7 +232,7 @@ subroutine pt2_collector(b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, su endif timeLast = time0 - print *, 'N_deterministic = ', first_det_of_teeth(1)-1 +! print *, 'N_deterministic = ', first_det_of_teeth(1)-1 pullLoop : do while (more == 1) call pull_pt2_results(zmq_socket_pull, Nindex, index, pt2_mwen, task_id, ntask) do i=1,Nindex @@ -257,7 +260,7 @@ subroutine pt2_collector(b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, su timeLast = time do i=1, first_det_of_teeth(1)-1 if(.not.(actually_computed(i))) then - print *, "PT2 : deterministic part not finished" +! print *, "PT2 : deterministic part not finished" cycle pullLoop end if end do @@ -265,7 +268,7 @@ subroutine pt2_collector(b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, su double precision :: E0, avg, eqt, prop call do_carlo(tbc, Ncomb+1-firstTBDcomb, comb(firstTBDcomb), pt2_detail, actually_computed, sumabove, sum2above, Nabove) firstTBDcomb = int(Nabove(1)) - orgTBDcomb + 1 - if(Nabove(1) < 2d0) cycle + if(Nabove(1) < 5d0) cycle call get_first_tooth(actually_computed, tooth) done = 0 @@ -273,7 +276,7 @@ subroutine pt2_collector(b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, su if(actually_computed(i)) done = done + 1 end do - E0 = sum(pt2_detail(1,:first_det_of_teeth(tooth)-1)) + E0 = sum(pt2_detail(1,:first_det_of_teeth(tooth)-1)) prop = ((1d0 - dfloat(comb_teeth - tooth + 1) * comb_step) - pt2_cweight(first_det_of_teeth(tooth)-1)) prop = prop * pt2_weight_inv(first_det_of_teeth(tooth)) E0 += pt2_detail(1,first_det_of_teeth(tooth)) * prop @@ -282,12 +285,16 @@ subroutine pt2_collector(b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, su time = omp_get_wtime() if (dabs(eqt/avg) < relative_error) then pt2(1) = avg -! exit pullLoop else - print "(4(G22.13), 4(I9))", time - time0, avg, eqt, Nabove(tooth), tooth, first_det_of_teeth(tooth)-1, done, first_det_of_teeth(tooth+1)-first_det_of_teeth(tooth) +! print "(4(G22.13), 4(I9))", time - time0, avg, eqt, Nabove(tooth), tooth, first_det_of_teeth(tooth)-1, done, first_det_of_teeth(tooth+1)-first_det_of_teeth(tooth) + if (Nabove(tooth) > Nabove_old) then + print '(E10.1, X, F16.10, E16.3,A30)', Nabove(tooth), avg+E, eqt, '' + Nabove_old = Nabove(tooth) + endif endif end if end do pullLoop + print *, '========== ================ ================' call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) call end_zmq_pull_socket(zmq_socket_pull) @@ -323,7 +330,7 @@ end function BEGIN_PROVIDER [ integer, comb_teeth ] implicit none - comb_teeth = 100 + comb_teeth = 50 END_PROVIDER From be00409eafc930abc1cca2d88a10691607dde957 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 2 May 2017 16:18:02 +0200 Subject: [PATCH 02/25] Fixed minor bugs --- ocaml/Charge.ml | 5 ++--- ocaml/Progress_bar.ml | 5 +++++ ocaml/TaskServer.ml | 2 +- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 2 +- plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f | 13 +++++++------ plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f | 2 +- src/Utils/sort.irp.f | 4 ++++ 7 files changed, 21 insertions(+), 12 deletions(-) diff --git a/ocaml/Charge.ml b/ocaml/Charge.ml index b40469d2..714a5690 100644 --- a/ocaml/Charge.ml +++ b/ocaml/Charge.ml @@ -1,6 +1,6 @@ -open Core.Std;; +open Core.Std -type t = float with sexp;; +type t = float with sexp let of_float x = x let of_int i = Float.of_int i @@ -14,5 +14,4 @@ let to_string x = Printf.sprintf "+%f" x else Printf.sprintf "%f" x -;; diff --git a/ocaml/Progress_bar.ml b/ocaml/Progress_bar.ml index 9762153a..3473ac4b 100644 --- a/ocaml/Progress_bar.ml +++ b/ocaml/Progress_bar.ml @@ -22,6 +22,11 @@ let update ~cur_value bar = let increment_end bar = { bar with end_value=(bar.end_value +. 1.) ; dirty=false } +let clear bar = + Printf.eprintf " \r%!"; + None + + let increment_cur bar = { bar with cur_value=(bar.cur_value +. 1.) ; dirty=true } diff --git a/ocaml/TaskServer.ml b/ocaml/TaskServer.ml index abc2de1d..0128c3c3 100644 --- a/ocaml/TaskServer.ml +++ b/ocaml/TaskServer.ml @@ -212,7 +212,7 @@ let end_job msg program_state rep_socket pair_socket = reply_ok rep_socket; { program_state with state = None ; - progress_bar = None ; + progress_bar = Progress_bar.clear (); } in diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index 7b7c9b04..699376a4 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -128,7 +128,7 @@ program fci_zmq double precision :: relative_error relative_error=1.d-3 pt2 = 0.d0 - if (N_states > 1) then + if (N_states == 1) then print *, 'Stochastic PT2' call ZMQ_pt2(E_CI_before(1), pt2,relative_error) ! Stochastic PT2 else diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f index facaf346..784ca8fa 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -32,7 +32,7 @@ subroutine ZMQ_pt2(E, pt2,relative_error) sum2above = 0d0 Nabove = 0d0 - provide nproc fragment_first fragment_count mo_bielec_integrals_in_map mo_mono_elec_integral pt2_weight + provide nproc fragment_first fragment_count mo_bielec_integrals_in_map mo_mono_elec_integral pt2_weight psi_selectors !call random_seed() @@ -52,15 +52,13 @@ subroutine ZMQ_pt2(E, pt2,relative_error) print *, '========== ================ ================' do while(.true.) - call write_time(6) - call new_parallel_job(zmq_to_qp_run_socket,"pt2") + call new_parallel_job(zmq_to_qp_run_socket,'pt2') call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) call create_selection_buffer(1, 1*2, b) Ncomb=size(comb)/100 call get_carlo_workbatch(computed, comb, Ncomb, tbc) - call write_time(6) integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket @@ -123,6 +121,7 @@ subroutine ZMQ_pt2(E, pt2,relative_error) exit endif end do + print *, '========== ================ ================' deallocate(pt2_detail, comb, computed, tbc) @@ -231,6 +230,9 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, time0 = omp_get_wtime() endif timeLast = time0 + + call get_first_tooth(actually_computed, tooth) + Nabove_old = Nabove(tooth) ! print *, 'N_deterministic = ', first_det_of_teeth(1)-1 pullLoop : do while (more == 1) @@ -288,13 +290,12 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, else ! print "(4(G22.13), 4(I9))", time - time0, avg, eqt, Nabove(tooth), tooth, first_det_of_teeth(tooth)-1, done, first_det_of_teeth(tooth+1)-first_det_of_teeth(tooth) if (Nabove(tooth) > Nabove_old) then - print '(E10.1, X, F16.10, E16.3,A30)', Nabove(tooth), avg+E, eqt, '' + print '(G10.3, X, F16.10, G16.3,A30)', Nabove(tooth), avg+E, eqt, '' Nabove_old = Nabove(tooth) endif endif end if end do pullLoop - print *, '========== ================ ================' call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) call end_zmq_pull_socket(zmq_socket_pull) diff --git a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f index 306320f7..46250be6 100644 --- a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f @@ -37,7 +37,7 @@ subroutine run_wf do - call wait_for_states(states,zmq_state,2) + call wait_for_states(states,zmq_state,3) if(trim(zmq_state) == 'Stopped') then diff --git a/src/Utils/sort.irp.f b/src/Utils/sort.irp.f index bb93d44f..ee1e4cca 100644 --- a/src/Utils/sort.irp.f +++ b/src/Utils/sort.irp.f @@ -359,6 +359,10 @@ BEGIN_TEMPLATE integer :: err !DIR$ ATTRIBUTES ALIGN : 128 :: iorder1,iorder2, x2, x1 + if (isize < 2) then + return + endif + if (iradix == -1) then ! Sort Positive and negative allocate(x1(isize),iorder1(isize), x2(isize),iorder2(isize),stat=err) From 592f978e62984dcd7bf4cb4eebe4a8c248fb5940 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 2 May 2017 16:46:31 +0200 Subject: [PATCH 03/25] Fixed bugs with correlation_energy_ratio --- plugins/CAS_SD_ZMQ/cassd_zmq.irp.f | 11 ++++++----- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 12 ++++++------ 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f index 0d079680..23c61511 100644 --- a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -51,17 +51,18 @@ program fci_zmq E_CI_before(1:N_states) = CI_energy(1:N_states) double precision :: correlation_energy_ratio - correlation_energy_ratio = E_CI_before(1) - hf_energy_ref - correlation_energy_ratio = correlation_energy_ratio / (correlation_energy_ratio + pt2(1)) + correlation_energy_ratio = 0.d0 do while ( & (N_det < N_det_max) .and. & (maxval(abs(pt2(1:N_states))) > pt2_max) .and. & - (correlation_energy_ratio < correlation_energy_ratio_max) & + (correlation_energy_ratio <= correlation_energy_ratio_max) & ) - correlation_energy_ratio = E_CI_before(1) - hf_energy_ref - correlation_energy_ratio = correlation_energy_ratio / (correlation_energy_ratio + pt2(1)) + correlation_energy_ratio = (CI_energy(1) - hf_energy_ref) / & + (E_CI_before(1) + pt2(1) - hf_energy_ref) + correlation_energy_ratio = min(1.d0,correlation_energy_ratio) + print *, 'N_det = ', N_det print *, 'N_states = ', N_states diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index e12033b4..f0cfe678 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -19,7 +19,7 @@ program fci_zmq hf_energy_ref = ref_bitmask_energy endif - pt2 = 1.d0 + pt2 = -huge(1.d0) threshold_davidson_in = threshold_davidson threshold_davidson = threshold_davidson_in * 100.d0 SOFT_TOUCH threshold_davidson @@ -51,17 +51,17 @@ program fci_zmq n_det_before = 0 double precision :: correlation_energy_ratio - correlation_energy_ratio = E_CI_before(1) - hf_energy_ref - correlation_energy_ratio = correlation_energy_ratio / (correlation_energy_ratio + pt2(1)) + correlation_energy_ratio = 0.d0 do while ( & (N_det < N_det_max) .and. & (maxval(abs(pt2(1:N_states))) > pt2_max) .and. & - (correlation_energy_ratio < correlation_energy_ratio_max) & + (correlation_energy_ratio <= correlation_energy_ratio_max) & ) - correlation_energy_ratio = E_CI_before(1) - hf_energy_ref - correlation_energy_ratio = correlation_energy_ratio / (correlation_energy_ratio + pt2(1)) + correlation_energy_ratio = (CI_energy(1) - hf_energy_ref) / & + (E_CI_before(1) + pt2(1) - hf_energy_ref) + correlation_energy_ratio = min(1.d0,correlation_energy_ratio) print *, 'N_det = ', N_det print *, 'N_states = ', N_states From c62302002ed005f9ce234443277325c1d468aed3 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 2 May 2017 17:41:58 +0200 Subject: [PATCH 04/25] Promela model --- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 15 ++- promela/collector.pml | 21 +++++ promela/fortran.pml | 48 ++++++++++ promela/model.pml | 35 +++++++ promela/slave.pml | 29 ++++++ promela/task_server.pml | 138 +++++++++++++++++++++++++++ src/ZMQ/utils.irp.f | 150 +++++++++++++++--------------- 7 files changed, 353 insertions(+), 83 deletions(-) create mode 100644 promela/collector.pml create mode 100644 promela/fortran.pml create mode 100644 promela/model.pml create mode 100644 promela/slave.pml create mode 100644 promela/task_server.pml diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index 0deb0ca4..e2188633 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -102,8 +102,7 @@ program fci_zmq if (N_det == N_det_max) then threshold_davidson = threshold_davidson_in - SOFT_TOUCH threshold_davidson - endif + end if call diagonalize_CI call save_wavefunction call ezfio_set_full_ci_zmq_energy(CI_energy(1)) @@ -111,7 +110,6 @@ program fci_zmq if (N_det < N_det_max) then threshold_davidson = threshold_davidson_in - SOFT_TOUCH threshold_davidson call diagonalize_CI call save_wavefunction call ezfio_set_full_ci_zmq_energy(CI_energy(1)) @@ -119,19 +117,20 @@ program fci_zmq if(do_pt2_end)then print*,'Last iteration only to compute the PT2' - !threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) - !threshold_generators = max(threshold_generators,threshold_generators_pt2) - !TOUCH threshold_selectors threshold_generators - threshold_selectors = 1.d0 - threshold_generators = 1d0 E_CI_before(1:N_states) = CI_energy(1:N_states) double precision :: relative_error relative_error=1.d-3 pt2 = 0.d0 if (N_states == 1) then + threshold_selectors = 1.d0 + threshold_generators = 1d0 + SOFT_TOUCH threshold_selectors threshold_generators print *, 'Stochastic PT2' call ZMQ_pt2(E_CI_before(1), pt2,relative_error) ! Stochastic PT2 else + threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) + threshold_generators = max(threshold_generators,threshold_generators_pt2) + SOFT_TOUCH threshold_selectors threshold_generators print *, 'Deterministic PT2' call ZMQ_selection(0, pt2) ! Deterministic PT2 endif diff --git a/promela/collector.pml b/promela/collector.pml new file mode 100644 index 00000000..85aae99c --- /dev/null +++ b/promela/collector.pml @@ -0,0 +1,21 @@ +proctype collector(byte state) { + + byte task; + req_message msg; + rep_message reply; + bit loop = 1; + xr pull_socket; + + do + :: (loop == 0) -> break + :: else -> + pull_socket ? task; + /* Handle result */ + send_req(DELTASK, task); + assert (reply.m == OK); + loop = reply.value; + od; + +} + + diff --git a/promela/fortran.pml b/promela/fortran.pml new file mode 100644 index 00000000..011eea75 --- /dev/null +++ b/promela/fortran.pml @@ -0,0 +1,48 @@ +active proctype fortran() { + req_message msg; + rep_message reply; + byte state; + byte count, wait; + + + /* New parallel job */ + state=1; + send_req( NEWJOB, state ); + assert (reply.m == OK); + + send_req( PUTPSI, state ); + assert (reply.m == PUTPSI_REPLY); + + /* Add tasks */ + count = 0; + do + :: (count == NTASKS) -> break; + :: else -> + count++; + send_req( ADDTASK, count ); + assert (reply.m == OK); + od + + wait = _nr_pr; + /* Run collector */ + run collector(state); + + /* Run slaves */ + count = 0; + do + :: (count == NPROC) -> break; + :: else -> count++; run slave(); + od + + /* Wait for collector and slaves to finish */ + (_nr_pr == wait); + + send_req( ENDJOB, state ); + assert (reply.m == OK); + state = reply.value; + + send_req( TERMINATE, 0); + assert (reply.m == OK); + +} + diff --git a/promela/model.pml b/promela/model.pml new file mode 100644 index 00000000..f55769d5 --- /dev/null +++ b/promela/model.pml @@ -0,0 +1,35 @@ +#define NPROC 3 +#define BUFSIZE 2 +#define NTASKS 4 + +mtype = { NONE, OK, WRONG_STATE, TERMINATE, GETPSI, PUTPSI, NEWJOB, ENDJOB, SETRUNNING, + SETWAITING, SETSTOPPED, CONNECT, DISCONNECT, ADDTASK, DELTASK, TASKDONE, GETTASK, + PSI, TASK, PUTPSI_REPLY, WAITING, RUNNING, STOPPED + } + +#define send_req( MESSAGE, VALUE ) atomic { msg.m=MESSAGE ; msg.value=VALUE ; msg.state=state; } ; rep_socket ! msg; msg.reply ? reply + +/* Request/Reply pattern */ + +typedef rep_message { + mtype m = NONE; + byte value = 0; +} + +typedef req_message { + mtype m = NONE; + byte state = 0; + byte value = 0; + chan reply = [BUFSIZE] of { rep_message }; +} + +/* Channels */ + +chan rep_socket = [NPROC] of { req_message }; +chan pull_socket = [NPROC] of { byte }; + + +#include "task_server.pml" +#include "fortran.pml" +#include "collector.pml" +#include "slave.pml" diff --git a/promela/slave.pml b/promela/slave.pml new file mode 100644 index 00000000..e6bfbe2b --- /dev/null +++ b/promela/slave.pml @@ -0,0 +1,29 @@ +proctype slave() { + req_message msg; + rep_message reply; + byte task; + byte state; + + send_req(CONNECT, 0); + assert (reply.m == OK); + state = reply.value; + + send_req(GETPSI, 0); + assert (reply.m == PSI); + + task=255; + do + :: (task == 0) -> break; + :: else -> + send_req( GETTASK, 0); + if + :: (reply.m == NONE) -> task = 0; + :: (reply.m == TASK) -> + task = reply.value; + /* Compute task */ + send_req( TASKDONE, task); + assert (reply.m == OK); + pull_socket ! task; + fi + od +} diff --git a/promela/task_server.pml b/promela/task_server.pml new file mode 100644 index 00000000..6f464628 --- /dev/null +++ b/promela/task_server.pml @@ -0,0 +1,138 @@ +/* State of the task server */ +typedef state_t { + chan queue = [NTASKS+2] of { byte }; + byte state = 0; + bit address_tcp = 0; + bit address_inproc = 0; + bit psi = 0; + bit running = 0; + byte ntasks; + byte nclients = 0; +} + + +active proctype task_server() { + + xr rep_socket; + state_t state; + req_message msg; + rep_message reply; + byte task; + + state.running = 1; + do + :: ( state.running + state.nclients == 0 ) -> break + :: else -> + rep_socket ? msg; + printf("req: "); printm(msg.m); printf("\t%d\n",msg.value); + + if + :: ( msg.m == TERMINATE ) -> + atomic { + assert (state.state == 0); + assert (msg.state == state.state); + state.running = 0; + reply.m = OK; + } + + :: ( msg.m == CONNECT ) -> + atomic { + assert (state.state != 0); + state.nclients++; + reply.m = OK; + reply.value = state.state; + } + +/* + :: ( msg.m == DISCONNECT ) -> + atomic { + assert (state.state != 0); + assert (msg.state == state.state); + state.nclients--; + reply.m = OK; + } +*/ + + :: ( msg.m == PUTPSI ) -> + atomic { + assert (state.state != 0); + assert (msg.state == state.state); + assert (state.psi == 0); + state.psi = 1; + reply.m = PUTPSI_REPLY; + } + + :: ( msg.m == GETPSI ) -> + atomic { + assert (state.state != 0); + assert (msg.state == state.state); + assert (state.psi == 1); + reply.m = PSI; + } + + :: ( msg.m == NEWJOB ) -> + atomic { + assert (state.state == 0); + state.state = msg.value; + reply.m = OK; + reply.value = state.state; + } + + :: ( msg.m == ENDJOB ) -> + atomic { + assert (state.state != 0); + assert (msg.state == state.state); + state.state = 0; + reply.m = OK; + } + + :: ( msg.m == TASKDONE ) -> + atomic { + assert (state.state != 0); + assert (state.ntasks > 0); + assert (msg.state == state.state); + reply.m = OK; + } + + :: ( msg.m == GETTASK ) -> + assert (state.state != 0); + assert (state.nclients > 0); + assert (msg.state == state.state); + if + :: ( state.queue ?[task] ) -> + reply.m = TASK; + state.queue ? reply.value + :: else -> + atomic { + reply.m = NONE; + reply.value = 0; + state.nclients--; + } + fi; + + :: ( msg.m == DELTASK ) -> + assert (state.state != 0); + assert (msg.state == state.state); + state.ntasks--; + if + :: (state.ntasks > 0) -> reply.value = 1; + :: else -> reply.value = 0; + fi; + reply.m = OK; + + :: ( msg.m == ADDTASK ) -> + assert (state.state != 0); + assert (msg.state == state.state); + atomic { + state.ntasks++; + reply.m = OK; + } + state.queue ! msg.value; + + fi; + msg.reply ! reply; + printf("rep: "); printm(reply.m); printf("\t%d\n",reply.value); + + od; +} + diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f index e61cf92a..5bd2fe6c 100644 --- a/src/ZMQ/utils.irp.f +++ b/src/ZMQ/utils.irp.f @@ -140,15 +140,15 @@ function new_zmq_to_qp_run_socket() stop 'Unable to create zmq req socket' endif - rc = f77_zmq_setsockopt(new_zmq_to_qp_run_socket, ZMQ_SNDTIMEO, 120000, 4) - if (rc /= 0) then - stop 'Unable to set send timeout in new_zmq_to_qp_run_socket' - endif - - rc = f77_zmq_setsockopt(new_zmq_to_qp_run_socket, ZMQ_RCVTIMEO, 120000, 4) - if (rc /= 0) then - stop 'Unable to set recv timeout in new_zmq_to_qp_run_socket' - endif +! rc = f77_zmq_setsockopt(new_zmq_to_qp_run_socket, ZMQ_SNDTIMEO, 120000, 4) +! if (rc /= 0) then +! stop 'Unable to set send timeout in new_zmq_to_qp_run_socket' +! endif +! +! rc = f77_zmq_setsockopt(new_zmq_to_qp_run_socket, ZMQ_RCVTIMEO, 120000, 4) +! if (rc /= 0) then +! stop 'Unable to set recv timeout in new_zmq_to_qp_run_socket' +! endif rc = f77_zmq_connect(new_zmq_to_qp_run_socket, trim(qp_run_address)//':'//trim(zmq_port(0))) if (rc /= 0) then @@ -180,25 +180,25 @@ function new_zmq_pair_socket(bind) endif - rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 1, 4) - if (rc /= 0) then - stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 1, 4)' - endif - - rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 1, 4) - if (rc /= 0) then - stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 1, 4)' - endif +! rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 1, 4) +! if (rc /= 0) then +! stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 1, 4)' +! endif +! +! rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 1, 4) +! if (rc /= 0) then +! stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 1, 4)' +! endif rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_IMMEDIATE, 1, 4) if (rc /= 0) then stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_IMMEDIATE, 1, 4)' endif - rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_LINGER, 600000, 4) - if (rc /= 0) then - stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_LINGER, 60000, 4)' - endif +! rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_LINGER, 600000, 4) +! if (rc /= 0) then +! stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_LINGER, 60000, 4)' +! endif if (bind) then rc = f77_zmq_bind(new_zmq_pair_socket,zmq_socket_pair_inproc_address) @@ -239,20 +239,20 @@ function new_zmq_pull_socket() stop 'Unable to create zmq pull socket' endif - rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_LINGER,300000,4) - if (rc /= 0) then - stop 'Unable to set ZMQ_LINGER on pull socket' - endif - - rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVBUF,100000000,4) - if (rc /= 0) then - stop 'Unable to set ZMQ_RCVBUF on pull socket' - endif - - rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVHWM,1,4) - if (rc /= 0) then - stop 'Unable to set ZMQ_RCVHWM on pull socket' - endif +! rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_LINGER,300000,4) +! if (rc /= 0) then +! stop 'Unable to set ZMQ_LINGER on pull socket' +! endif +! +! rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVBUF,100000000,4) +! if (rc /= 0) then +! stop 'Unable to set ZMQ_RCVBUF on pull socket' +! endif +! +! rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVHWM,1,4) +! if (rc /= 0) then +! stop 'Unable to set ZMQ_RCVHWM on pull socket' +! endif integer :: icount @@ -316,30 +316,30 @@ function new_zmq_push_socket(thread) stop 'Unable to create zmq push socket' endif - rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_LINGER,300000,4) - if (rc /= 0) then - stop 'Unable to set ZMQ_LINGER on push socket' - endif - - rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDHWM,1,4) - if (rc /= 0) then - stop 'Unable to set ZMQ_SNDHWM on push socket' - endif - - rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDBUF,100000000,4) - if (rc /= 0) then - stop 'Unable to set ZMQ_RCVBUF on push socket' - endif +! rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_LINGER,300000,4) +! if (rc /= 0) then +! stop 'Unable to set ZMQ_LINGER on push socket' +! endif +! +! rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDHWM,1,4) +! if (rc /= 0) then +! stop 'Unable to set ZMQ_SNDHWM on push socket' +! endif +! +! rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDBUF,100000000,4) +! if (rc /= 0) then +! stop 'Unable to set ZMQ_RCVBUF on push socket' +! endif rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_IMMEDIATE,1,4) if (rc /= 0) then stop 'Unable to set ZMQ_IMMEDIATE on push socket' endif - rc = f77_zmq_setsockopt(new_zmq_push_socket, ZMQ_SNDTIMEO, 100000, 4) - if (rc /= 0) then - stop 'Unable to set send timout in new_zmq_push_socket' - endif +! rc = f77_zmq_setsockopt(new_zmq_push_socket, ZMQ_SNDTIMEO, 100000, 4) +! if (rc /= 0) then +! stop 'Unable to set send timout in new_zmq_push_socket' +! endif if (thread == 1) then rc = f77_zmq_connect(new_zmq_push_socket, zmq_socket_push_inproc_address) @@ -373,10 +373,10 @@ function new_zmq_sub_socket() stop 'Unable to create zmq sub socket' endif - rc = f77_zmq_setsockopt(new_zmq_sub_socket,ZMQ_RCVTIMEO,10000,4) - if (rc /= 0) then - stop 'Unable to set timeout in new_zmq_sub_socket' - endif +! rc = f77_zmq_setsockopt(new_zmq_sub_socket,ZMQ_RCVTIMEO,10000,4) +! if (rc /= 0) then +! stop 'Unable to set timeout in new_zmq_sub_socket' +! endif rc = f77_zmq_setsockopt(new_zmq_sub_socket,ZMQ_CONFLATE,1,4) if (rc /= 0) then @@ -445,10 +445,10 @@ subroutine end_zmq_pull_socket(zmq_socket_pull) integer :: rc character*(8), external :: zmq_port - rc = f77_zmq_setsockopt(zmq_socket_pull,ZMQ_LINGER,0,4) - if (rc /= 0) then - stop 'Unable to set ZMQ_LINGER on pull socket' - endif +! rc = f77_zmq_setsockopt(zmq_socket_pull,ZMQ_LINGER,0,4) +! if (rc /= 0) then +! stop 'Unable to set ZMQ_LINGER on pull socket' +! endif call omp_set_lock(zmq_lock) rc = f77_zmq_close(zmq_socket_pull) @@ -472,10 +472,10 @@ subroutine end_zmq_push_socket(zmq_socket_push,thread) integer :: rc character*(8), external :: zmq_port - rc = f77_zmq_setsockopt(zmq_socket_push,ZMQ_LINGER,300000,4) - if (rc /= 0) then - stop 'Unable to set ZMQ_LINGER on push socket' - endif +! rc = f77_zmq_setsockopt(zmq_socket_push,ZMQ_LINGER,300000,4) +! if (rc /= 0) then +! stop 'Unable to set ZMQ_LINGER on push socket' +! endif call omp_set_lock(zmq_lock) rc = f77_zmq_close(zmq_socket_push) @@ -859,10 +859,10 @@ subroutine end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) character*(8), external :: zmq_port integer :: rc - rc = f77_zmq_setsockopt(zmq_to_qp_run_socket,ZMQ_LINGER,1000,4) - if (rc /= 0) then - stop 'Unable to set ZMQ_LINGER on zmq_to_qp_run_socket' - endif +! rc = f77_zmq_setsockopt(zmq_to_qp_run_socket,ZMQ_LINGER,1000,4) +! if (rc /= 0) then +! stop 'Unable to set ZMQ_LINGER on zmq_to_qp_run_socket' +! endif rc = f77_zmq_close(zmq_to_qp_run_socket) if (rc /= 0) then @@ -901,11 +901,11 @@ subroutine zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) more = 1 else if (reply(16:19) == 'done') then more = 0 - rc = f77_zmq_setsockopt(zmq_socket_pull, ZMQ_RCVTIMEO, 1000, 4) - if (rc /= 0) then - print *, 'f77_zmq_setsockopt(zmq_socket_pull, ZMQ_RCVTIMEO, 3000, 4)' - stop 'error' - endif +! rc = f77_zmq_setsockopt(zmq_socket_pull, ZMQ_RCVTIMEO, 1000, 4) +! if (rc /= 0) then +! print *, 'f77_zmq_setsockopt(zmq_socket_pull, ZMQ_RCVTIMEO, 3000, 4)' +! stop 'error' +! endif else print *, reply print *, 'f77_zmq_recv(zmq_to_qp_run_socket,reply,64,0)' From 8288437ae6a018836b059f50586174977144cfbe Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 3 May 2017 19:23:12 +0200 Subject: [PATCH 05/25] Improved CASSD and FCI --- ocaml/TaskServer.ml | 24 +++-- plugins/CAS_SD_ZMQ/cassd_zmq.irp.f | 150 ++++++++++++++--------------- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 139 +++++++++++++------------- src/ZMQ/utils.irp.f | 6 +- 4 files changed, 167 insertions(+), 152 deletions(-) diff --git a/ocaml/TaskServer.ml b/ocaml/TaskServer.ml index 0128c3c3..6537f579 100644 --- a/ocaml/TaskServer.ml +++ b/ocaml/TaskServer.ml @@ -389,7 +389,12 @@ let get_task msg program_state rep_socket pair_socket = let new_queue, task_id, task = Queuing_system.pop_task ~client_id program_state.queue in - if (Queuing_system.number_of_queued new_queue = 0) then + + let no_task = + Queuing_system.number_of_queued new_queue = 0 + in + + if no_task then string_of_pub_state Waiting |> ZMQ.Socket.send pair_socket else @@ -658,12 +663,17 @@ let run ~port = in (** Debug input *) - Printf.sprintf "q:%d r:%d n:%d : %s\n%!" - (Queuing_system.number_of_queued program_state.queue) - (Queuing_system.number_of_running program_state.queue) - (Queuing_system.number_of_tasks program_state.queue) - (Message.to_string message) - |> debug; + let () = + if debug_env then + begin + Printf.sprintf "q:%d r:%d n:%d : %s\n%!" + (Queuing_system.number_of_queued program_state.queue) + (Queuing_system.number_of_running program_state.queue) + (Queuing_system.number_of_tasks program_state.queue) + (Message.to_string message) + |> debug + end + in let new_program_state = try diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f index 23c61511..ffacdd8a 100644 --- a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -1,16 +1,23 @@ -program fci_zmq +program cassd_zmq implicit none integer :: i,j,k - logical, external :: detEq - double precision, allocatable :: pt2(:) integer :: degree + integer :: n_det_before, to_select double precision :: threshold_davidson_in allocate (pt2(N_states)) - + double precision :: hf_energy_ref logical :: has + pt2 = -huge(1.d0) + threshold_davidson_in = threshold_davidson + threshold_davidson = threshold_davidson_in * 100.d0 + SOFT_TOUCH threshold_davidson + + call diagonalize_CI + call save_wavefunction + call ezfio_has_hartree_fock_energy(has) if (has) then call ezfio_get_hartree_fock_energy(hf_energy_ref) @@ -18,15 +25,7 @@ program fci_zmq hf_energy_ref = ref_bitmask_energy endif - pt2 = 1.d0 - threshold_davidson_in = threshold_davidson - threshold_davidson = threshold_davidson_in * 100.d0 - SOFT_TOUCH threshold_davidson - - 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 @@ -46,75 +45,78 @@ program fci_zmq double precision :: E_CI_before(N_states) - integer :: n_det_before, to_select print*,'Beginning the selection ...' - E_CI_before(1:N_states) = CI_energy(1:N_states) - + if (.True.) then ! Avoid pre-calculation of CI_energy + E_CI_before(1:N_states) = CI_energy(1:N_states) + endif + n_det_before = 0 + double precision :: correlation_energy_ratio correlation_energy_ratio = 0.d0 - do while ( & - (N_det < N_det_max) .and. & - (maxval(abs(pt2(1:N_states))) > pt2_max) .and. & - (correlation_energy_ratio <= correlation_energy_ratio_max) & - ) + if (.True.) then ! Avoid pre-calculation of CI_energy + do while ( & + (N_det < N_det_max) .and. & + (maxval(abs(pt2(1:N_states))) > pt2_max) .and. & + (correlation_energy_ratio <= correlation_energy_ratio_max) & + ) - correlation_energy_ratio = (CI_energy(1) - hf_energy_ref) / & - (E_CI_before(1) + pt2(1) - hf_energy_ref) - correlation_energy_ratio = min(1.d0,correlation_energy_ratio) + correlation_energy_ratio = (CI_energy(1) - hf_energy_ref) / & + (E_CI_before(1) + pt2(1) - hf_energy_ref) + correlation_energy_ratio = min(1.d0,correlation_energy_ratio) - - print *, 'N_det = ', N_det - print *, 'N_states = ', N_states - print*, 'correlation_ratio = ', correlation_energy_ratio - 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) + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + print*, 'correlation_ratio = ', correlation_energy_ratio + + 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 *, '-----' + 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(1:N_states) = CI_energy(1:N_states) + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + + n_det_before = N_det + to_select = N_det + to_select = max(N_det, to_select) + to_select = min(to_select, N_det_max-n_det_before) + call ZMQ_selection(to_select, pt2) + + PROVIDE psi_coef + PROVIDE psi_det + PROVIDE psi_det_sorted + + if (N_det == N_det_max) then + threshold_davidson = threshold_davidson_in + end if + call diagonalize_CI + call save_wavefunction + call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) enddo - print *, '-----' - 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(1:N_states) = CI_energy(1:N_states) - call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) - - n_det_before = N_det - to_select = 2*N_det - to_select = max(64-to_select, to_select) - to_select = min(to_select,N_det_max-n_det_before) - call ZMQ_selection(to_select, pt2) - - PROVIDE psi_coef - PROVIDE psi_det - PROVIDE psi_det_sorted - - if (N_det == N_det_max) then - threshold_davidson = threshold_davidson_in - SOFT_TOUCH threshold_davidson - endif - call diagonalize_CI - call save_wavefunction - call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) - enddo - + endif + if (N_det < N_det_max) then - threshold_davidson = threshold_davidson_in - SOFT_TOUCH threshold_davidson - call diagonalize_CI - call save_wavefunction - call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) + threshold_davidson = threshold_davidson_in + call diagonalize_CI + call save_wavefunction + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) endif integer :: exc_max, degree_min @@ -148,10 +150,8 @@ program fci_zmq print *, 'E+PT2 = ', E_CI_before(k)+pt2(k) print *, '-----' enddo - call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before+pt2) + call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before(1)+pt2(1)) endif - call save_wavefunction - call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before(1)+pt2(1)) end diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index e2188633..0226e2e0 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -1,8 +1,6 @@ program fci_zmq implicit none integer :: i,j,k - logical, external :: detEq - double precision, allocatable :: pt2(:) integer :: degree integer :: n_det_before, to_select @@ -12,6 +10,14 @@ program fci_zmq double precision :: hf_energy_ref logical :: has + pt2 = -huge(1.d0) + threshold_davidson_in = threshold_davidson + threshold_davidson = threshold_davidson_in * 100.d0 + SOFT_TOUCH threshold_davidson + + call diagonalize_CI + call save_wavefunction + call ezfio_has_hartree_fock_energy(has) if (has) then call ezfio_get_hartree_fock_energy(hf_energy_ref) @@ -19,14 +25,7 @@ program fci_zmq hf_energy_ref = ref_bitmask_energy endif - pt2 = -huge(1.d0) - threshold_davidson_in = threshold_davidson - threshold_davidson = threshold_davidson_in * 100.d0 - SOFT_TOUCH threshold_davidson - 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 @@ -47,66 +46,71 @@ program fci_zmq print*,'Beginning the selection ...' - E_CI_before(1:N_states) = CI_energy(1:N_states) + if (.True.) then ! Avoid pre-calculation of CI_energy + E_CI_before(1:N_states) = CI_energy(1:N_states) + endif n_det_before = 0 - + double precision :: correlation_energy_ratio correlation_energy_ratio = 0.d0 - do while ( & - (N_det < N_det_max) .and. & - (maxval(abs(pt2(1:N_states))) > pt2_max) .and. & - (correlation_energy_ratio <= correlation_energy_ratio_max) & - ) + if (.True.) then ! Avoid pre-calculation of CI_energy + do while ( & + (N_det < N_det_max) .and. & + (maxval(abs(pt2(1:N_states))) > pt2_max) .and. & + (correlation_energy_ratio <= correlation_energy_ratio_max) & + ) - correlation_energy_ratio = (CI_energy(1) - hf_energy_ref) / & - (E_CI_before(1) + pt2(1) - hf_energy_ref) - correlation_energy_ratio = min(1.d0,correlation_energy_ratio) - - print *, 'N_det = ', N_det - print *, 'N_states = ', N_states - print*, 'correlation_ratio = ', correlation_energy_ratio + correlation_energy_ratio = (CI_energy(1) - hf_energy_ref) / & + (E_CI_before(1) + pt2(1) - hf_energy_ref) + correlation_energy_ratio = min(1.d0,correlation_energy_ratio) - 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) + + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + print*, 'correlation_ratio = ', correlation_energy_ratio + + 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 *, '-----' + 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(1:N_states) = CI_energy(1:N_states) + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + + n_det_before = N_det + to_select = N_det + to_select = max(N_det, to_select) + to_select = min(to_select, N_det_max-n_det_before) + call ZMQ_selection(to_select, pt2) + + PROVIDE psi_coef + PROVIDE psi_det + PROVIDE psi_det_sorted + + if (N_det == N_det_max) then + threshold_davidson = threshold_davidson_in + end if + call diagonalize_CI + call save_wavefunction + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) enddo - - print *, '-----' - 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(1:N_states) = CI_energy(1:N_states) - call ezfio_set_full_ci_zmq_energy(CI_energy(1)) - - n_det_before = N_det - to_select = N_det - to_select = max(N_det, to_select) - to_select = min(to_select, N_det_max-n_det_before) - call ZMQ_selection(to_select, pt2) - - PROVIDE psi_coef - PROVIDE psi_det - PROVIDE psi_det_sorted - - if (N_det == N_det_max) then - threshold_davidson = threshold_davidson_in - end if - call diagonalize_CI - call save_wavefunction - call ezfio_set_full_ci_zmq_energy(CI_energy(1)) - enddo + endif if (N_det < N_det_max) then threshold_davidson = threshold_davidson_in @@ -139,16 +143,13 @@ program fci_zmq print *, 'N_states = ', N_states do k=1,N_states print *, 'State', k - print *, 'PT2 = ', pt2 - print *, 'E = ', E_CI_before - print *, 'E+PT2 = ', E_CI_before+pt2 + print *, 'PT2 = ', pt2(k) + print *, 'E = ', E_CI_before(k) + print *, 'E+PT2 = ', E_CI_before(k)+pt2(k) print *, '-----' enddo call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before(1)+pt2(1)) endif - call save_wavefunction - call ezfio_set_full_ci_zmq_energy(CI_energy(1)) call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before(1)+pt2(1)) + end - - diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f index 5bd2fe6c..c180c686 100644 --- a/src/ZMQ/utils.irp.f +++ b/src/ZMQ/utils.irp.f @@ -535,7 +535,7 @@ subroutine new_parallel_job(zmq_to_qp_run_socket,name_in) rc = f77_zmq_recv(zmq_to_qp_run_socket,message,510,0) message = trim(message(1:rc)) if (message(1:2) /= 'ok') then - print *, message + print *, trim(message(1:rc)) print *, 'Unable to start parallel job : '//name stop 1 endif @@ -565,6 +565,7 @@ subroutine zmq_set_running(zmq_to_qp_run_socket) rc = f77_zmq_recv(zmq_to_qp_run_socket,message,510,0) message = trim(message(1:rc)) if (message(1:2) /= 'ok') then + print *, trim(message(1:rc)) print *, 'Unable to set qp_run to Running' stop 1 endif @@ -718,6 +719,7 @@ subroutine add_task_to_taskserver(zmq_to_qp_run_socket,task) rc = f77_zmq_recv(zmq_to_qp_run_socket, message, sze-1, 0) if (message(1:rc) /= 'ok') then + print *, trim(message(1:rc)) print *, trim(task) print *, 'Unable to add the next task' stop -1 @@ -762,6 +764,7 @@ subroutine add_task_to_taskserver_recv(zmq_to_qp_run_socket) character*(512) :: message rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0) if (message(1:rc) /= 'ok') then + print *, trim(message(1:rc)) print *, 'Unable to add the next task' stop -1 endif @@ -790,6 +793,7 @@ subroutine task_done_to_taskserver(zmq_to_qp_run_socket, worker_id, task_id) rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0) if (trim(message(1:rc)) /= 'ok') then + print *, trim(message(1:rc)) print *, 'Unable to send task_done message' stop -1 endif From ce10c5052c5dd653f49ae116d51a84e4bb8b5718 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 3 May 2017 21:15:54 +0200 Subject: [PATCH 06/25] Travis bug --- ocaml/Message.ml | 139 ++++++++++++++++++++++++++- ocaml/Message_lexer.mll | 21 +++- ocaml/TaskServer.ml | 51 ++++++++++ ocaml/TaskServer.mli | 1 + plugins/CAS_SD_ZMQ/cassd_zmq.irp.f | 4 +- src/Davidson/davidson_parallel.irp.f | 9 +- 6 files changed, 214 insertions(+), 11 deletions(-) diff --git a/ocaml/Message.ml b/ocaml/Message.ml index 2ed38864..7a1d1712 100644 --- a/ocaml/Message.ml +++ b/ocaml/Message.ml @@ -455,6 +455,122 @@ end = struct end +(** GetVector : get the current vector (Davidson) *) +module GetVector_msg : sig + type t = + { client_id: Id.Client.t ; + } + val create : client_id:int -> t + val to_string : t -> string +end = struct + type t = + { client_id: Id.Client.t ; + } + let create ~client_id = + { client_id = Id.Client.of_int client_id } + let to_string x = + Printf.sprintf "get_vector %d" + (Id.Client.to_int x.client_id) +end + +module Vector : sig + type t = + { + size : Strictly_positive_int.t; + data : string; + } + val create : size:Strictly_positive_int.t -> data:string -> t +end = struct + type t = + { + size : Strictly_positive_int.t; + data : string; + } + let create ~size ~data = + { size ; data } +end + +(** GetVectorReply_msg : Reply to the GetVector message *) +module GetVectorReply_msg : sig + type t = + { client_id : Id.Client.t ; + vector : Vector.t } + val create : client_id:Id.Client.t -> vector:Vector.t -> t + val to_string : t -> string + val to_string_list : t -> string list +end = struct + type t = + { client_id : Id.Client.t ; + vector : Vector.t } + let create ~client_id ~vector = + { client_id ; vector } + let to_string x = + Printf.sprintf "get_vector_reply %d %d" + (Id.Client.to_int x.client_id) + (Strictly_positive_int.to_int x.vector.Vector.size) + let to_string_list x = + [ to_string x ; x.vector.Vector.data ] +end + +(** PutVector : put the current variational wave function *) +module PutVector_msg : sig + type t = + { client_id : Id.Client.t ; + size : Strictly_positive_int.t ; + vector : Vector.t option; + } + val create : + client_id:int -> size:int -> data:string option -> t + val to_string_list : t -> string list + val to_string : t -> string +end = struct + type t = + { client_id : Id.Client.t ; + size : Strictly_positive_int.t ; + vector : Vector.t option; + } + let create ~client_id ~size ~data = + let size = + Strictly_positive_int.of_int size + in + let vector = + match data with + | None -> None + | Some s -> Some (Vector.create ~size ~data:s) + in + { client_id = Id.Client.of_int client_id ; + vector ; size + } + + let to_string x = + Printf.sprintf "put_vector %d %d" + (Id.Client.to_int x.client_id) + (Strictly_positive_int.to_int x.size) + + let to_string_list x = + match x.vector with + | Some v -> [ to_string x ; v.Vector.data ] + | None -> failwith "Empty vector" +end + +(** PutVectorReply_msg : Reply to the PutVector message *) +module PutVectorReply_msg : sig + type t + val create : client_id:Id.Client.t -> t + val to_string : t -> string +end = struct + type t = + { client_id : Id.Client.t ; + } + let create ~client_id = + { client_id; } + let to_string x = + Printf.sprintf "put_vector_reply %d" + (Id.Client.to_int x.client_id) +end + + + (** TaskDone : Inform the server that a task is finished *) module TaskDone_msg : sig type t = @@ -526,6 +642,10 @@ type t = | PutPsi of PutPsi_msg.t | GetPsiReply of GetPsiReply_msg.t | PutPsiReply of PutPsiReply_msg.t +| GetVector of GetVector_msg.t +| PutVector of PutVector_msg.t +| GetVectorReply of GetVectorReply_msg.t +| PutVectorReply of PutVectorReply_msg.t | Newjob of Newjob_msg.t | Endjob of Endjob_msg.t | Connect of Connect_msg.t @@ -580,6 +700,10 @@ let of_string s = ~n_det_generators:None ~n_det_selectors:None ~psi_det:None ~psi_coef:None ~energy:None ) end + | GetVector_ client_id -> + GetVector (GetVector_msg.create ~client_id) + | PutVector_ { client_id ; size } -> + PutVector (PutVector_msg.create ~client_id ~size ~data:None ) | Terminate_ -> Terminate (Terminate_msg.create ) | SetWaiting_ -> SetWaiting | SetStopped_ -> SetStopped @@ -592,6 +716,8 @@ let of_string s = let to_string = function | GetPsi x -> GetPsi_msg.to_string x | PutPsiReply x -> PutPsiReply_msg.to_string x +| GetVector x -> GetVector_msg.to_string x +| PutVectorReply x -> PutVectorReply_msg.to_string x | Newjob x -> Newjob_msg.to_string x | Endjob x -> Endjob_msg.to_string x | Connect x -> Connect_msg.to_string x @@ -600,8 +726,8 @@ let to_string = function | DisconnectReply x -> DisconnectReply_msg.to_string x | GetTask x -> GetTask_msg.to_string x | GetTaskReply x -> GetTaskReply_msg.to_string x -| DelTask x -> DelTask_msg.to_string x -| DelTaskReply x -> DelTaskReply_msg.to_string x +| DelTask x -> DelTask_msg.to_string x +| DelTaskReply x -> DelTaskReply_msg.to_string x | AddTask x -> AddTask_msg.to_string x | AddTaskReply x -> AddTaskReply_msg.to_string x | TaskDone x -> TaskDone_msg.to_string x @@ -610,12 +736,17 @@ let to_string = function | Error x -> Error_msg.to_string x | PutPsi x -> PutPsi_msg.to_string x | GetPsiReply x -> GetPsiReply_msg.to_string x +| PutVector x -> PutVector_msg.to_string x +| GetVectorReply x -> GetVectorReply_msg.to_string x | SetStopped -> "set_stopped" | SetRunning -> "set_running" | SetWaiting -> "set_waiting" let to_string_list = function -| PutPsi x -> PutPsi_msg.to_string_list x -| GetPsiReply x -> GetPsiReply_msg.to_string_list x +| PutPsi x -> PutPsi_msg.to_string_list x +| GetPsiReply x -> GetPsiReply_msg.to_string_list x +| PutVector x -> PutVector_msg.to_string_list x +| GetVectorReply x -> GetVectorReply_msg.to_string_list x | _ -> assert false + diff --git a/ocaml/Message_lexer.mll b/ocaml/Message_lexer.mll index c67f4528..b85baecf 100644 --- a/ocaml/Message_lexer.mll +++ b/ocaml/Message_lexer.mll @@ -17,6 +17,8 @@ type kw_type = | TERMINATE | GET_PSI | PUT_PSI + | GET_VECTOR + | PUT_VECTOR | OK | ERROR | SET_STOPPED @@ -29,7 +31,8 @@ type state_taskids_clientid = { state : string ; task_ids : int list ; type state_clientid = { state : string ; client_id : int ; } type state_tcp_inproc = { state : string ; push_address_tcp : string ; push_address_inproc : string ; } type psi = { client_id: int ; n_state: int ; n_det: int ; psi_det_size: int ; - n_det_generators: int option ; n_det_selectors: int option } + n_det_generators: int option ; n_det_selectors: int option ; } +type vector = { client_id: int ; size: int } type msg = | AddTask_ of state_tasks @@ -43,6 +46,8 @@ type msg = | Terminate_ | GetPsi_ of int | PutPsi_ of psi + | GetVector_ of int + | PutVector_ of vector | Ok_ | Error_ of string | SetStopped_ @@ -85,6 +90,8 @@ and kw = parse | "terminate" { TERMINATE } | "get_psi" { GET_PSI } | "put_psi" { PUT_PSI } + | "get_vector" { GET_PSI } + | "put_vector" { PUT_PSI } | "ok" { OK } | "error" { ERROR } | "set_stopped" { SET_STOPPED } @@ -179,6 +186,15 @@ and kw = parse in PutPsi_ { client_id ; n_state ; n_det ; psi_det_size ; n_det_generators ; n_det_selectors } + | GET_VECTOR -> + let client_id = read_int lexbuf in + GetVector_ client_id + + | PUT_VECTOR -> + let client_id = read_int lexbuf in + let size = read_int lexbuf in + PutVector_ { client_id ; size } + | CONNECT -> let socket = read_word lexbuf in Connect_ socket @@ -253,6 +269,9 @@ and kw = parse | Some s, Some g -> Printf.sprintf "PUT_PSI client_id:%d n_state:%d n_det:%d psi_det_size:%d n_det_generators:%d n_det_selectors:%d" client_id n_state n_det psi_det_size g s | _ -> Printf.sprintf "PUT_PSI client_id:%d n_state:%d n_det:%d psi_det_size:%d" client_id n_state n_det psi_det_size end + | GetVector_ client_id -> Printf.sprintf "GET_VECTOR client_id:%d" client_id + | PutVector_ { client_id ; size } -> + Printf.sprintf "PUT_VECTOR client_id:%d size:%d" client_id size | Terminate_ -> "TERMINATE" | SetWaiting_ -> "SET_WAITING" | SetStopped_ -> "SET_STOPPED" diff --git a/ocaml/TaskServer.ml b/ocaml/TaskServer.ml index 6537f579..887c7482 100644 --- a/ocaml/TaskServer.ml +++ b/ocaml/TaskServer.ml @@ -26,6 +26,7 @@ type t = address_tcp : Address.Tcp.t option ; address_inproc : Address.Inproc.t option ; psi : Message.Psi.t option; + vector : Message.Vector.t option; progress_bar : Progress_bar.t option ; running : bool; } @@ -523,10 +524,57 @@ let get_psi msg program_state rep_socket = +let put_vector msg rest_of_msg program_state rep_socket = + + let vector_local = + match msg.Message.PutVector_msg.vector with + | Some x -> x + | None -> + begin + let data = + match rest_of_msg with + | [ x ] -> x + | _ -> failwith "Badly formed put_vector message" + in + Message.Vector.create + ~size:msg.Message.PutVector_msg.size + ~data + end + in + let new_program_state = + { program_state with + vector = Some vector_local + } + and client_id = + msg.Message.PutVector_msg.client_id + in + Message.PutVectorReply (Message.PutVectorReply_msg.create ~client_id) + |> Message.to_string + |> ZMQ.Socket.send rep_socket; + + new_program_state + + +let get_vector msg program_state rep_socket = + + let client_id = + msg.Message.GetVector_msg.client_id + in + match program_state.vector with + | None -> failwith "No wave function saved in TaskServer" + | Some vector -> + Message.GetVectorReply (Message.GetVectorReply_msg.create ~client_id ~vector) + |> Message.to_string_list + |> ZMQ.Socket.send_all rep_socket; + program_state + + + let terminate program_state rep_socket = reply_ok rep_socket; { program_state with psi = None; + vector = None; address_tcp = None; address_inproc = None; running = false @@ -610,6 +658,7 @@ let run ~port = { queue = Queuing_system.create () ; running = true ; psi = None; + vector = None; state = None; address_tcp = None; address_inproc = None; @@ -679,6 +728,8 @@ let run ~port = try match program_state.state, message with | _ , Message.Terminate _ -> terminate program_state rep_socket + | _ , Message.PutVector x -> put_vector x rest program_state rep_socket + | _ , Message.GetVector x -> get_vector x program_state rep_socket | _ , Message.PutPsi x -> put_psi x rest program_state rep_socket | _ , Message.GetPsi x -> get_psi x program_state rep_socket | None , Message.Newjob x -> new_job x program_state rep_socket pair_socket diff --git a/ocaml/TaskServer.mli b/ocaml/TaskServer.mli index e1baab12..7098b55a 100644 --- a/ocaml/TaskServer.mli +++ b/ocaml/TaskServer.mli @@ -5,6 +5,7 @@ type t = address_tcp : Address.Tcp.t option ; address_inproc : Address.Inproc.t option ; psi : Message.Psi.t option; + vector : Message.Vector.t option ; progress_bar : Progress_bar.t option ; running : bool; } diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f index ffacdd8a..f8ee7ba2 100644 --- a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -91,7 +91,7 @@ program cassd_zmq enddo endif E_CI_before(1:N_states) = CI_energy(1:N_states) - call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) n_det_before = N_det to_select = N_det @@ -116,7 +116,7 @@ program cassd_zmq threshold_davidson = threshold_davidson_in call diagonalize_CI call save_wavefunction - call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) endif integer :: exc_max, degree_min diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index 68db35da..f4114adb 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -70,6 +70,11 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze, ! ----------------------- integer :: rc + integer :: N_states_read, N_det_read, psi_det_size_read + integer :: N_det_selectors_read, N_det_generators_read + double precision :: energy(N_st) + + write(msg, *) 'get_psi ', worker_id rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0) if (rc /= len(trim(msg))) then @@ -84,10 +89,6 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze, stop 'error' endif - integer :: N_states_read, N_det_read, psi_det_size_read - integer :: N_det_selectors_read, N_det_generators_read - double precision :: energy(N_st) - read(msg(14:rc),*) rc, N_states_read, N_det_read, psi_det_size_read, & N_det_generators_read, N_det_selectors_read From ed18b3a103ebae77dca594fff0e000b66de13510 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 3 May 2017 22:31:38 +0200 Subject: [PATCH 07/25] Fixed Travis --- plugins/CAS_SD_ZMQ/cassd_zmq.irp.f | 5 ++--- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 5 ++--- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f index f8ee7ba2..15d2bce6 100644 --- a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -91,7 +91,6 @@ program cassd_zmq enddo endif E_CI_before(1:N_states) = CI_energy(1:N_states) - call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) n_det_before = N_det to_select = N_det @@ -103,7 +102,7 @@ program cassd_zmq PROVIDE psi_det PROVIDE psi_det_sorted - if (N_det == N_det_max) then + if (N_det >= N_det_max) then threshold_davidson = threshold_davidson_in end if call diagonalize_CI @@ -150,8 +149,8 @@ program cassd_zmq print *, 'E+PT2 = ', E_CI_before(k)+pt2(k) print *, '-----' enddo + call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before(1)+pt2(1)) endif - call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before(1)+pt2(1)) end diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index 0226e2e0..3d9acf8b 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -91,7 +91,6 @@ program fci_zmq enddo endif E_CI_before(1:N_states) = CI_energy(1:N_states) - call ezfio_set_full_ci_zmq_energy(CI_energy(1)) n_det_before = N_det to_select = N_det @@ -103,7 +102,7 @@ program fci_zmq PROVIDE psi_det PROVIDE psi_det_sorted - if (N_det == N_det_max) then + if (N_det >= N_det_max) then threshold_davidson = threshold_davidson_in end if call diagonalize_CI @@ -148,8 +147,8 @@ program fci_zmq print *, 'E+PT2 = ', E_CI_before(k)+pt2(k) print *, '-----' enddo + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before(1)+pt2(1)) endif - call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before(1)+pt2(1)) end From b82bbdab73259e579fca8c9098c29b4672412975 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 4 May 2017 09:54:07 +0200 Subject: [PATCH 08/25] Added JM-MRPT2 program --- plugins/Full_CI/jmmrpt2.irp.f | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) create mode 100644 plugins/Full_CI/jmmrpt2.irp.f diff --git a/plugins/Full_CI/jmmrpt2.irp.f b/plugins/Full_CI/jmmrpt2.irp.f new file mode 100644 index 00000000..60211a3c --- /dev/null +++ b/plugins/Full_CI/jmmrpt2.irp.f @@ -0,0 +1,31 @@ +program pouet + 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 + 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) + integer :: n_det_before + threshold_generators = threshold_generators_pt2 + threshold_selectors = threshold_selectors_pt2 + SOFT_TOUCH threshold_generators threshold_selectors + call diagonalize_CI + call H_apply_FCI_PT2_new(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(1:N_states) + print *, 'E+PT2 = ', CI_energy(1:N_states)+pt2(1:N_states) + print *, '-----' + call ezfio_set_full_ci_energy_pt2(CI_energy(1)+pt2(1)) + call save_wavefunction + deallocate(pt2,norm_pert) +end + From e0812d4b41d13fab430fc857c4dc9874e4dbf5fa Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 4 May 2017 15:51:33 +0200 Subject: [PATCH 09/25] Removed IPC --- ocaml/TaskServer.ml | 13 ++----------- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 2 +- 2 files changed, 3 insertions(+), 12 deletions(-) diff --git a/ocaml/TaskServer.ml b/ocaml/TaskServer.ml index 887c7482..62de9fbd 100644 --- a/ocaml/TaskServer.ml +++ b/ocaml/TaskServer.ml @@ -70,16 +70,7 @@ let bind_socket ~socket_type ~socket ~port = with | Unix.Unix_error _ -> (Time.pause @@ Time.Span.of_float 1. ; loop (i-1) ) | other_exception -> raise other_exception - in loop 60; - let filename = - Printf.sprintf "/tmp/qp_run:%d" port - in - begin - match Sys.file_exists filename with - | `Yes -> Sys.remove filename - | _ -> () - end; - ZMQ.Socket.bind socket ("ipc://"^filename) + in loop 60 let hostname = lazy ( @@ -133,7 +124,7 @@ let stop ~port = let req_socket = ZMQ.Socket.create zmq_context ZMQ.Socket.req and address = - Printf.sprintf "ipc:///tmp/qp_run:%d" port + Printf.sprintf "tcp://localhost:%d" port in ZMQ.Socket.set_linger_period req_socket 1_000_000; ZMQ.Socket.connect req_socket address; diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index 3d9acf8b..0d883cae 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -147,7 +147,7 @@ program fci_zmq print *, 'E+PT2 = ', E_CI_before(k)+pt2(k) print *, '-----' enddo - call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + call ezfio_set_full_ci_zmq_energy(E_CI_before(1)) call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before(1)+pt2(1)) endif From f84b64bb7f53cad9a4d73d8945fdb1843cb4002f Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 4 May 2017 23:36:10 +0200 Subject: [PATCH 10/25] Adjusted send/receive buffers --- plugins/Full_CI/jmmrpt2.irp.f | 2 -- src/ZMQ/utils.irp.f | 64 +++++++++++++++++------------------ 2 files changed, 32 insertions(+), 34 deletions(-) diff --git a/plugins/Full_CI/jmmrpt2.irp.f b/plugins/Full_CI/jmmrpt2.irp.f index 60211a3c..cf5bc8be 100644 --- a/plugins/Full_CI/jmmrpt2.irp.f +++ b/plugins/Full_CI/jmmrpt2.irp.f @@ -14,7 +14,6 @@ program pouet threshold_generators = threshold_generators_pt2 threshold_selectors = threshold_selectors_pt2 SOFT_TOUCH threshold_generators threshold_selectors - call diagonalize_CI call H_apply_FCI_PT2_new(pt2, norm_pert, H_pert_diag, N_st) print *, 'Final step' @@ -25,7 +24,6 @@ program pouet print *, 'E+PT2 = ', CI_energy(1:N_states)+pt2(1:N_states) print *, '-----' call ezfio_set_full_ci_energy_pt2(CI_energy(1)+pt2(1)) - call save_wavefunction deallocate(pt2,norm_pert) end diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f index c180c686..91e458fd 100644 --- a/src/ZMQ/utils.irp.f +++ b/src/ZMQ/utils.irp.f @@ -180,25 +180,25 @@ function new_zmq_pair_socket(bind) endif -! rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 1, 4) -! if (rc /= 0) then -! stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 1, 4)' -! endif -! -! rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 1, 4) -! if (rc /= 0) then -! stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 1, 4)' -! endif + rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 4, 4) + if (rc /= 0) then + stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 4, 4)' + endif + + rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 4, 4) + if (rc /= 0) then + stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 4, 4)' + endif rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_IMMEDIATE, 1, 4) if (rc /= 0) then stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_IMMEDIATE, 1, 4)' endif -! rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_LINGER, 600000, 4) -! if (rc /= 0) then -! stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_LINGER, 60000, 4)' -! endif + rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_LINGER, 600000, 4) + if (rc /= 0) then + stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_LINGER, 60000, 4)' + endif if (bind) then rc = f77_zmq_bind(new_zmq_pair_socket,zmq_socket_pair_inproc_address) @@ -244,15 +244,15 @@ function new_zmq_pull_socket() ! stop 'Unable to set ZMQ_LINGER on pull socket' ! endif ! -! rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVBUF,100000000,4) -! if (rc /= 0) then -! stop 'Unable to set ZMQ_RCVBUF on pull socket' -! endif -! -! rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVHWM,1,4) -! if (rc /= 0) then -! stop 'Unable to set ZMQ_RCVHWM on pull socket' -! endif + rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVBUF,100000000,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_RCVBUF on pull socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVHWM,4,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_RCVHWM on pull socket' + endif integer :: icount @@ -320,16 +320,16 @@ function new_zmq_push_socket(thread) ! if (rc /= 0) then ! stop 'Unable to set ZMQ_LINGER on push socket' ! endif -! -! rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDHWM,1,4) -! if (rc /= 0) then -! stop 'Unable to set ZMQ_SNDHWM on push socket' -! endif -! -! rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDBUF,100000000,4) -! if (rc /= 0) then -! stop 'Unable to set ZMQ_RCVBUF on push socket' -! endif + + rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDHWM,4,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_SNDHWM on push socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDBUF,100000000,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_SNDBUF on push socket' + endif rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_IMMEDIATE,1,4) if (rc /= 0) then From 73ce5610b307cb05cf3103ef7f9353f4b8d52b06 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 5 May 2017 00:19:33 +0200 Subject: [PATCH 11/25] heap sort --- plugins/Full_CI_ZMQ/selection_buffer.irp.f | 2 +- src/Utils/sort.irp.f | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/plugins/Full_CI_ZMQ/selection_buffer.irp.f b/plugins/Full_CI_ZMQ/selection_buffer.irp.f index 8a067357..902e2af7 100644 --- a/plugins/Full_CI_ZMQ/selection_buffer.irp.f +++ b/plugins/Full_CI_ZMQ/selection_buffer.irp.f @@ -51,7 +51,7 @@ subroutine sort_selection_buffer(b) allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3)), absval(b%cur), vals(size(b%val))) - absval = -dabs(b%val(:b%cur)) + absval = b%val(:b%cur) do i=1,b%cur iorder(i) = i end do diff --git a/src/Utils/sort.irp.f b/src/Utils/sort.irp.f index ee1e4cca..1ebf3b17 100644 --- a/src/Utils/sort.irp.f +++ b/src/Utils/sort.irp.f @@ -202,11 +202,11 @@ BEGIN_TEMPLATE if (isize < 2) then return endif - call sorted_$Xnumber(x,isize,n) - if (isize == n) then - return - endif - if ( isize < 32+n) then +! call sorted_$Xnumber(x,isize,n) +! if (isize == n) then +! return +! endif + if ( isize < 16) then call insertion_$Xsort(x,iorder,isize) else call heap_$Xsort(x,iorder,isize) From 7f32fab829cbfd80d6fab9772c2afe0a7f78689d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 5 May 2017 10:21:31 +0200 Subject: [PATCH 12/25] Added quicksort --- plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f | 8 +-- plugins/Full_CI_ZMQ/selection.irp.f | 12 ++--- plugins/Full_CI_ZMQ/selection_buffer.irp.f | 20 +++---- src/Utils/sort.irp.f | 55 +++++++++++++++++++- 4 files changed, 69 insertions(+), 26 deletions(-) diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f index 784ca8fa..eb64fc2f 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -258,7 +258,7 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, time = omp_get_wtime() - if(time - timeLast > 1d1 .or. more /= 1) then + if(time - timeLast > 3d0 .or. more /= 1) then timeLast = time do i=1, first_det_of_teeth(1)-1 if(.not.(actually_computed(i))) then @@ -331,7 +331,7 @@ end function BEGIN_PROVIDER [ integer, comb_teeth ] implicit none - comb_teeth = 50 + comb_teeth = 100 END_PROVIDER @@ -369,7 +369,7 @@ subroutine get_last_full_tooth(computed, last_tooth) last_tooth = 0 combLoop : do i=comb_teeth, 1, -1 - missing = 1+ ishft(first_det_of_teeth(i+1)-first_det_of_teeth(i),-12) ! /4096 + missing = 1+ ishft(first_det_of_teeth(i+1)-first_det_of_teeth(i),-14) ! /16384 do j=first_det_of_teeth(i), first_det_of_teeth(i+1)-1 if(.not.computed(j)) then missing -= 1 @@ -543,7 +543,7 @@ end subroutine comb_step = 1d0/dfloat(comb_teeth) first_det_of_comb = 1 do i=1,N_det_generators - if(pt2_weight(i)/norm_left < comb_step*.5d0) then + if(pt2_weight(i)/norm_left < comb_step*.25d0) then first_det_of_comb = i exit end if diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index c277cf58..fae1e644 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -509,7 +509,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d logical :: ok integer :: s1, s2, p1, p2, ib, j, istate integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) - double precision :: e_pert, delta_E, val, Hii, max_e_pert,tmp + double precision :: e_pert, delta_E, val, Hii, min_e_pert,tmp double precision, external :: diag_H_mat_elem_fock logical, external :: detEq @@ -536,7 +536,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) - max_e_pert = 0d0 + min_e_pert = 0d0 do istate=1,N_states delta_E = E0(istate) - Hii @@ -545,14 +545,14 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d if (delta_E < 0.d0) then tmp = -tmp endif - e_pert = 0.5d0 * ( tmp - delta_E) + e_pert = 0.5d0 * (tmp - delta_E) pt2(istate) = pt2(istate) + e_pert - max_e_pert = min(e_pert,max_e_pert) + min_e_pert = min(e_pert,min_e_pert) ! ci(istate) = e_pert / mat(istate, p1, p2) end do - if(dabs(max_e_pert) > buf%mini) then - call add_to_selection_buffer(buf, det, max_e_pert) + if(min_e_pert <= buf%mini) then + call add_to_selection_buffer(buf, det, min_e_pert) end if end do end do diff --git a/plugins/Full_CI_ZMQ/selection_buffer.irp.f b/plugins/Full_CI_ZMQ/selection_buffer.irp.f index 902e2af7..d0bc05dd 100644 --- a/plugins/Full_CI_ZMQ/selection_buffer.irp.f +++ b/plugins/Full_CI_ZMQ/selection_buffer.irp.f @@ -25,7 +25,7 @@ subroutine add_to_selection_buffer(b, det, val) double precision, intent(in) :: val integer :: i - if(dabs(val) >= b%mini) then + if(val <= b%mini) then b%cur += 1 b%det(1:N_int,1:2,b%cur) = det(1:N_int,1:2) b%val(b%cur) = val @@ -41,33 +41,25 @@ subroutine sort_selection_buffer(b) implicit none type(selection_buffer), intent(inout) :: b - double precision, allocatable:: absval(:) integer, allocatable :: iorder(:) - double precision, pointer :: vals(:) integer(bit_kind), pointer :: detmp(:,:,:) integer :: i, nmwen logical, external :: detEq nmwen = min(b%N, b%cur) - - allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3)), absval(b%cur), vals(size(b%val))) - absval = b%val(:b%cur) + allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3))) do i=1,b%cur iorder(i) = i end do - call dsort(absval, iorder, b%cur) + call dsort(b%val, iorder, b%cur) do i=1, nmwen detmp(1:N_int,1,i) = b%det(1:N_int,1,iorder(i)) detmp(1:N_int,2,i) = b%det(1:N_int,2,iorder(i)) - vals(i) = b%val(iorder(i)) end do - do i=nmwen+1, size(vals) - vals(i) = 0.d0 - enddo - deallocate(b%det, b%val) + deallocate(b%det) b%det => detmp - b%val => vals - b%mini = max(b%mini,dabs(b%val(b%N))) + b%mini = min(b%mini,b%val(b%N)) b%cur = nmwen + deallocate(iorder) end subroutine diff --git a/src/Utils/sort.irp.f b/src/Utils/sort.irp.f index 1ebf3b17..a9594d6c 100644 --- a/src/Utils/sort.irp.f +++ b/src/Utils/sort.irp.f @@ -27,6 +27,56 @@ BEGIN_TEMPLATE enddo end subroutine insertion_$Xsort + subroutine quick_$Xsort(x, iorder, isize) + implicit none + BEGIN_DOC + ! Sort array x(isize) using the quicksort algorithm. + ! iorder in input should be (1,2,3,...,isize), and in output + ! contains the new order of the elements. + END_DOC + integer,intent(in) :: isize + $type,intent(inout) :: x(isize) + integer,intent(inout) :: iorder(isize) + call rec_$X_quicksort(x,iorder,isize,1,isize) + end + + recursive subroutine rec_$X_quicksort(x, iorder, isize, first, last) + implicit none + integer, intent(in) :: isize, first, last + integer,intent(inout) :: iorder(isize) + $type, intent(inout) :: x(isize) + $type :: c, tmp + integer :: itmp + integer :: i, j + + c = x( ishft(first+last,-1) ) + i = first + j = last + do + do while (x(i) < c) + i=i+1 + end do + do while (c < x(j)) + j=j-1 + end do + if (i >= j) exit + tmp = x(i) + x(i) = x(j) + x(j) = tmp + itmp = iorder(i) + iorder(i) = iorder(j) + iorder(j) = itmp + i=i+1 + j=j-1 + enddo + if (first < i-1) then + call rec_$X_quicksort(x, iorder, isize, first, i-1) + endif + if (j+1 < last) then + call rec_$X_quicksort(x, iorder, isize, j+1, last) + endif + end + subroutine heap_$Xsort(x,iorder,isize) implicit none BEGIN_DOC @@ -206,10 +256,11 @@ BEGIN_TEMPLATE ! if (isize == n) then ! return ! endif - if ( isize < 16) then + if ( isize < 32) then call insertion_$Xsort(x,iorder,isize) else - call heap_$Xsort(x,iorder,isize) +! call heap_$Xsort(x,iorder,isize) + call quick_$Xsort(x,iorder,isize) endif end subroutine $Xsort From 4a043229b7aad9f48a07bdc8275d484b97a1fec3 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 5 May 2017 11:32:17 +0200 Subject: [PATCH 13/25] Killed sort bottleneck in selection --- plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f | 1 + plugins/Full_CI_ZMQ/run_selection_slave.irp.f | 10 +-- plugins/Full_CI_ZMQ/selection_buffer.irp.f | 64 ++++++++++++++++++- plugins/Full_CI_ZMQ/zmq_selection.irp.f | 28 +++++--- 4 files changed, 83 insertions(+), 20 deletions(-) diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f index eb64fc2f..d3791832 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -105,6 +105,7 @@ subroutine ZMQ_pt2(E, pt2,relative_error) call pt2_slave_inproc(i) endif !$OMP END PARALLEL + call delete_selection_buffer(b) call end_parallel_job(zmq_to_qp_run_socket, 'pt2') else diff --git a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f index bfc099e2..82c14cc6 100644 --- a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f @@ -58,13 +58,9 @@ subroutine run_selection_slave(thread,iproc,energy) call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) end do if(ctask > 0) then + call sort_selection_buffer(buf) call push_selection_results(zmq_socket_push, pt2, buf, task_id(1), ctask) - do i=1,buf%cur - call add_to_selection_buffer(buf2, buf%det(1,1,i), buf%val(i)) - if (buf2%cur == buf2%N) then - call sort_selection_buffer(buf2) - endif - enddo + call merge_selection_buffers(buf,buf2) buf%mini = buf2%mini pt2 = 0d0 buf%cur = 0 @@ -92,8 +88,6 @@ subroutine push_selection_results(zmq_socket_push, pt2, b, task_id, ntask) 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) if(rc /= 4) stop "push" rc = f77_zmq_send( zmq_socket_push, pt2, 8*N_states, ZMQ_SNDMORE) diff --git a/plugins/Full_CI_ZMQ/selection_buffer.irp.f b/plugins/Full_CI_ZMQ/selection_buffer.irp.f index d0bc05dd..6b354cd4 100644 --- a/plugins/Full_CI_ZMQ/selection_buffer.irp.f +++ b/plugins/Full_CI_ZMQ/selection_buffer.irp.f @@ -15,6 +15,18 @@ subroutine create_selection_buffer(N, siz, res) res%cur = 0 end subroutine +subroutine delete_selection_buffer(b) + use selection_types + implicit none + type(selection_buffer), intent(inout) :: b + if (associated(b%det)) then + deallocate(b%det) + endif + if (associated(b%val)) then + deallocate(b%val) + endif +end + subroutine add_to_selection_buffer(b, det, val) use selection_types @@ -35,6 +47,55 @@ subroutine add_to_selection_buffer(b, det, val) end if end subroutine +subroutine merge_selection_buffers(b1, b2) + use selection_types + implicit none + BEGIN_DOC +! Merges the selection buffers b1 and b2 into b2 + END_DOC + type(selection_buffer), intent(in) :: b1 + type(selection_buffer), intent(inout) :: b2 + integer(bit_kind), pointer :: detmp(:,:,:) + double precision, pointer :: val(:) + integer :: i, i1, i2, k, nmwen + nmwen = min(b1%N, b1%cur+b2%cur) + allocate( val(size(b1%val)), detmp(N_int, 2, size(b1%det,3)) ) + i1=1 + i2=1 + do i=1,nmwen + if ( (i1 > b1%cur).and.(i2 > b2%cur) ) then + exit + else if (i1 > b1%cur) then + val(i) = b2%val(i2) + detmp(1:N_int,1,i) = b2%det(1:N_int,1,i2) + detmp(1:N_int,2,i) = b2%det(1:N_int,2,i2) + i2=i2+1 + else if (i2 > b2%cur) then + val(i) = b1%val(i1) + detmp(1:N_int,1,i) = b1%det(1:N_int,1,i1) + detmp(1:N_int,2,i) = b1%det(1:N_int,2,i1) + i1=i1+1 + else + if (b1%val(i1) <= b2%val(i2)) then + val(i) = b1%val(i1) + detmp(1:N_int,1,i) = b1%det(1:N_int,1,i1) + detmp(1:N_int,2,i) = b1%det(1:N_int,2,i1) + i1=i1+1 + else + val(i) = b2%val(i2) + detmp(1:N_int,1,i) = b2%det(1:N_int,1,i2) + detmp(1:N_int,2,i) = b2%det(1:N_int,2,i2) + i2=i2+1 + endif + endif + enddo + deallocate(b2%det, b2%val) + b2%det => detmp + b2%val => val + b2%mini = min(b2%mini,b2%val(b2%N)) + b2%cur = nmwen +end + subroutine sort_selection_buffer(b) use selection_types @@ -56,10 +117,9 @@ subroutine sort_selection_buffer(b) detmp(1:N_int,1,i) = b%det(1:N_int,1,iorder(i)) detmp(1:N_int,2,i) = b%det(1:N_int,2,iorder(i)) end do - deallocate(b%det) + deallocate(b%det,iorder) b%det => detmp b%mini = min(b%mini,b%val(b%N)) b%cur = nmwen - deallocate(iorder) end subroutine diff --git a/plugins/Full_CI_ZMQ/zmq_selection.irp.f b/plugins/Full_CI_ZMQ/zmq_selection.irp.f index 7ffb4a44..6b325828 100644 --- a/plugins/Full_CI_ZMQ/zmq_selection.irp.f +++ b/plugins/Full_CI_ZMQ/zmq_selection.irp.f @@ -45,7 +45,7 @@ subroutine ZMQ_selection(N_in, pt2) !$OMP PARALLEL DEFAULT(shared) SHARED(b, pt2) PRIVATE(i) NUM_THREADS(nproc+1) i = omp_get_thread_num() if (i==0) then - call selection_collector(b, pt2) + call selection_collector(b, N, pt2) else call selection_slave_inproc(i) endif @@ -59,6 +59,7 @@ subroutine ZMQ_selection(N_in, pt2) endif call save_wavefunction endif + call delete_selection_buffer(b) end subroutine @@ -70,7 +71,7 @@ subroutine selection_slave_inproc(i) call run_selection_slave(1,i,pt2_e0_denominator) end -subroutine selection_collector(b, pt2) +subroutine selection_collector(b, N, pt2) use f77_zmq use selection_types use bitmasks @@ -78,6 +79,7 @@ subroutine selection_collector(b, pt2) type(selection_buffer), intent(inout) :: b + integer, intent(in) :: N double precision, intent(out) :: pt2(N_states) double precision :: pt2_mwen(N_states) integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket @@ -87,25 +89,30 @@ subroutine selection_collector(b, pt2) integer(ZMQ_PTR) :: zmq_socket_pull integer :: msg_size, rc, more - integer :: acc, i, j, robin, N, ntask - double precision, allocatable :: val(:) - integer(bit_kind), allocatable :: det(:,:,:) + integer :: acc, i, j, robin, ntask + double precision, pointer :: val(:) + integer(bit_kind), pointer :: det(:,:,:) integer, allocatable :: task_id(:) integer :: done real :: time, time0 + type(selection_buffer) :: b2 + 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_generators)) + call create_selection_buffer(N, N*2, b2) + allocate(task_id(N_det_generators)) done = 0 more = 1 pt2(:) = 0d0 call CPU_TIME(time0) do while (more == 1) - call pull_selection_results(zmq_socket_pull, pt2_mwen, val(1), det(1,1,1), N, task_id, ntask) + call pull_selection_results(zmq_socket_pull, pt2_mwen, b2%val(1), b2%det(1,1,1), b2%cur, task_id, ntask) + pt2 += pt2_mwen - do i=1, N - call add_to_selection_buffer(b, det(1,1,i), val(i)) - end do + call merge_selection_buffers(b2,b) +! 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 @@ -119,6 +126,7 @@ subroutine selection_collector(b, pt2) end do + call delete_selection_buffer(b2) call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) call end_zmq_pull_socket(zmq_socket_pull) call sort_selection_buffer(b) From 49b413f48641aacad14f88dc51a1ac9f1a3629f6 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 5 May 2017 15:08:51 +0200 Subject: [PATCH 14/25] Fixed PT2 stoch --- plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f | 11 +++++----- plugins/Full_CI_ZMQ/run_pt2_slave.irp.f | 20 +++++-------------- plugins/Full_CI_ZMQ/run_selection_slave.irp.f | 2 ++ plugins/Full_CI_ZMQ/zmq_selection.irp.f | 8 -------- 4 files changed, 12 insertions(+), 29 deletions(-) diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f index d3791832..9940056e 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -34,8 +34,6 @@ subroutine ZMQ_pt2(E, pt2,relative_error) provide nproc fragment_first fragment_count mo_bielec_integrals_in_map mo_mono_elec_integral pt2_weight psi_selectors - !call random_seed() - computed = .false. tbc(0) = first_det_of_comb - 1 @@ -72,7 +70,7 @@ subroutine ZMQ_pt2(E, pt2,relative_error) write(task(ipos:ipos+20),'(I9,1X,I9,''|'')') 0, tbc(i) ipos += 20 if (ipos > 63980) then - call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos-20))) + call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) ipos=1 tasks = .True. endif @@ -81,7 +79,7 @@ subroutine ZMQ_pt2(E, pt2,relative_error) write(task(ipos:ipos+20),'(I9,1X,I9,''|'')') j, tbc(i) ipos += 20 if (ipos > 63980) then - call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos-20))) + call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) ipos=1 tasks = .True. endif @@ -89,7 +87,7 @@ subroutine ZMQ_pt2(E, pt2,relative_error) end if end do if (ipos > 1) then - call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos-20))) + call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) tasks = .True. endif @@ -237,6 +235,7 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, ! print *, 'N_deterministic = ', first_det_of_teeth(1)-1 pullLoop : do while (more == 1) + call pull_pt2_results(zmq_socket_pull, Nindex, index, pt2_mwen, task_id, ntask) do i=1,Nindex pt2_detail(1:N_states, index(i)) += pt2_mwen(1:N_states,i) @@ -289,12 +288,12 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, if (dabs(eqt/avg) < relative_error) then pt2(1) = avg else -! print "(4(G22.13), 4(I9))", time - time0, avg, eqt, Nabove(tooth), tooth, first_det_of_teeth(tooth)-1, done, first_det_of_teeth(tooth+1)-first_det_of_teeth(tooth) if (Nabove(tooth) > Nabove_old) then print '(G10.3, X, F16.10, G16.3,A30)', Nabove(tooth), avg+E, eqt, '' Nabove_old = Nabove(tooth) endif endif +!print "(4(G22.13), 4(I9))", time - time0, avg, eqt, Nabove(tooth), tooth, first_det_of_teeth(tooth)-1, done, first_det_of_teeth(tooth+1)-first_det_of_teeth(tooth) end if end do pullLoop diff --git a/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f b/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f index 5a246319..2e49669f 100644 --- a/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f +++ b/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f @@ -17,7 +17,7 @@ subroutine run_pt2_slave(thread,iproc,energy) integer(ZMQ_PTR), external :: new_zmq_push_socket integer(ZMQ_PTR) :: zmq_socket_push - type(selection_buffer) :: buf, buf2 + type(selection_buffer) :: buf logical :: done double precision :: pt2(N_states) @@ -47,18 +47,12 @@ subroutine run_pt2_slave(thread,iproc,energy) if (done) then ctask = ctask - 1 else - integer :: i_generator, i_i_generator, N, subset + integer :: i_generator, i_i_generator, subset read (task,*) subset, index - !!!!! - N=1 - !!!!! if(buf%N == 0) then ! Only first time - call create_selection_buffer(N, N*2, buf) - call create_selection_buffer(N, N*3, buf2) - else - if(N /= buf%N) stop "N changed... wtf man??" + call create_selection_buffer(1, 2, buf) end if do i_i_generator=1, Nindex i_generator = index @@ -67,18 +61,13 @@ subroutine run_pt2_slave(thread,iproc,energy) enddo endif - if(done .or. ctask == size(task_id)) then + if(done .or. (ctask == size(task_id)) ) then if(buf%N == 0 .and. ctask > 0) stop "uninitialized selection_buffer" do i=1, ctask call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) end do if(ctask > 0) then call push_pt2_results(zmq_socket_push, Nindex, index, pt2_detail, task_id(1), ctask) - do i=1,buf%cur - call add_to_selection_buffer(buf2, buf%det(1,1,i), buf%val(i)) - enddo - call sort_selection_buffer(buf2) - buf%mini = buf2%mini pt2 = 0d0 pt2_detail(:,:Nindex) = 0d0 buf%cur = 0 @@ -92,6 +81,7 @@ subroutine run_pt2_slave(thread,iproc,energy) 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) + call delete_selection_buffer(buf) end subroutine diff --git a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f index 82c14cc6..6e08bb2f 100644 --- a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f @@ -74,6 +74,8 @@ subroutine run_selection_slave(thread,iproc,energy) 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) + call delete_selection_buffer(buf) + call delete_selection_buffer(buf2) end subroutine diff --git a/plugins/Full_CI_ZMQ/zmq_selection.irp.f b/plugins/Full_CI_ZMQ/zmq_selection.irp.f index 6b325828..25b11b68 100644 --- a/plugins/Full_CI_ZMQ/zmq_selection.irp.f +++ b/plugins/Full_CI_ZMQ/zmq_selection.irp.f @@ -93,7 +93,6 @@ subroutine selection_collector(b, N, pt2) double precision, pointer :: val(:) integer(bit_kind), pointer :: det(:,:,:) integer, allocatable :: task_id(:) - integer :: done real :: time, time0 type(selection_buffer) :: b2 @@ -101,7 +100,6 @@ subroutine selection_collector(b, N, pt2) zmq_socket_pull = new_zmq_pull_socket() call create_selection_buffer(N, N*2, b2) allocate(task_id(N_det_generators)) - done = 0 more = 1 pt2(:) = 0d0 call CPU_TIME(time0) @@ -110,19 +108,13 @@ subroutine selection_collector(b, N, pt2) pt2 += pt2_mwen call merge_selection_buffers(b2,b) -! 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 print *, "Error in collector" endif call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more) end do - done += ntask call CPU_TIME(time) -! print *, "DONE" , done, time - time0 end do From 78fe5aeda6848dbd3013abf2bf2b5000acfb48c7 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 5 May 2017 15:24:04 +0200 Subject: [PATCH 15/25] Reduced deterministic set in pt2 stoch --- plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f index 9940056e..3ad26112 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -543,12 +543,13 @@ end subroutine comb_step = 1d0/dfloat(comb_teeth) first_det_of_comb = 1 do i=1,N_det_generators - if(pt2_weight(i)/norm_left < comb_step*.25d0) then + if(pt2_weight(i)/norm_left < comb_step) then first_det_of_comb = i exit end if norm_left -= pt2_weight(i) end do + call write_int(6, first_det_of_comb-1, 'Size of deterministic set') comb_step = (1d0 - pt2_cweight(first_det_of_comb-1)) * comb_step From f9b9b9a8769753ae31379200eb72a2cf5d1b9b9f Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 5 May 2017 15:54:08 +0200 Subject: [PATCH 16/25] Fixed tests --- plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f | 4 ++-- plugins/Full_CI_ZMQ/run_selection_slave.irp.f | 6 ++++-- plugins/Full_CI_ZMQ/zmq_selection.irp.f | 2 +- src/Bitmask/bitmasks.irp.f | 3 --- 4 files changed, 7 insertions(+), 8 deletions(-) diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f index 3ad26112..c6eb0c2a 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -258,7 +258,7 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, time = omp_get_wtime() - if(time - timeLast > 3d0 .or. more /= 1) then + if(time - timeLast > 10d0 .or. more /= 1) then timeLast = time do i=1, first_det_of_teeth(1)-1 if(.not.(actually_computed(i))) then @@ -331,7 +331,7 @@ end function BEGIN_PROVIDER [ integer, comb_teeth ] implicit none - comb_teeth = 100 + comb_teeth = 200 END_PROVIDER diff --git a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f index 6e08bb2f..eb8572f3 100644 --- a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f @@ -74,8 +74,10 @@ subroutine run_selection_slave(thread,iproc,energy) 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) - call delete_selection_buffer(buf) - call delete_selection_buffer(buf2) + if (buf%N > 0) then + call delete_selection_buffer(buf) + call delete_selection_buffer(buf2) + endif end subroutine diff --git a/plugins/Full_CI_ZMQ/zmq_selection.irp.f b/plugins/Full_CI_ZMQ/zmq_selection.irp.f index 25b11b68..f578f338 100644 --- a/plugins/Full_CI_ZMQ/zmq_selection.irp.f +++ b/plugins/Full_CI_ZMQ/zmq_selection.irp.f @@ -119,8 +119,8 @@ subroutine selection_collector(b, N, pt2) call delete_selection_buffer(b2) + call sort_selection_buffer(b) call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) call end_zmq_pull_socket(zmq_socket_pull) - call sort_selection_buffer(b) end subroutine diff --git a/src/Bitmask/bitmasks.irp.f b/src/Bitmask/bitmasks.irp.f index e50cf25a..f7b20897 100644 --- a/src/Bitmask/bitmasks.irp.f +++ b/src/Bitmask/bitmasks.irp.f @@ -315,10 +315,7 @@ BEGIN_PROVIDER [ integer(bit_kind), cas_bitmask, (N_int,2,N_cas_bitmask) ] call ezfio_has_bitmasks_cas(exists) if (exists) then - print*,'---------------------' - print*,'CAS BITMASK RESTART' call ezfio_get_bitmasks_cas(cas_bitmask) - print*,'---------------------' else if(N_generators_bitmask == 1)then do j=1, N_cas_bitmask From 172d38a04eeb98b0dd1fbfb96bc5b4de65b70af5 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 5 May 2017 16:11:11 +0200 Subject: [PATCH 17/25] Using 50 comb teeth in pt2 stoch --- plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f index c6eb0c2a..03c93649 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -331,7 +331,7 @@ end function BEGIN_PROVIDER [ integer, comb_teeth ] implicit none - comb_teeth = 200 + comb_teeth = 50 END_PROVIDER @@ -543,7 +543,7 @@ end subroutine comb_step = 1d0/dfloat(comb_teeth) first_det_of_comb = 1 do i=1,N_det_generators - if(pt2_weight(i)/norm_left < comb_step) then + if(pt2_weight(i)/norm_left < 2.*comb_step) then first_det_of_comb = i exit end if From 016402350f8f760fb4be16c87d6372f873b7c225 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 9 May 2017 15:45:13 +0200 Subject: [PATCH 18/25] Print seconds in PT2 stoch --- plugins/Full_CI_ZMQ/pt2_stoch.irp.f | 3 +- plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f | 85 ++++++++++++-------- src/ZMQ/utils.irp.f | 12 +-- 3 files changed, 60 insertions(+), 40 deletions(-) diff --git a/plugins/Full_CI_ZMQ/pt2_stoch.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch.irp.f index f40fa055..40a84705 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch.irp.f @@ -24,7 +24,8 @@ subroutine run E_CI_before = pt2_E0_denominator(1) + nuclear_repulsion threshold_selectors = 1.d0 threshold_generators = 1d0 - relative_error = 1.d-3 +! relative_error = 1.d-3 + relative_error = 1.d-8 call ZMQ_pt2(E_CI_before, pt2, relative_error) print *, 'Final step' print *, 'N_det = ', N_det diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f index 03c93649..6d6bfae0 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -25,7 +25,7 @@ subroutine ZMQ_pt2(E, pt2,relative_error) double precision :: sumabove(comb_teeth), sum2above(comb_teeth), Nabove(comb_teeth) double precision, external :: omp_get_wtime - double precision :: time0, time + double precision :: time allocate(pt2_detail(N_states, N_det_generators), comb(N_det_generators/2), computed(N_det_generators), tbc(0:size_tbc)) sumabove = 0d0 @@ -43,11 +43,10 @@ subroutine ZMQ_pt2(E, pt2,relative_error) end do pt2_detail = 0d0 - time0 = omp_get_wtime() generator_per_task = 1 - print *, '========== ================ ================' - print *, ' Samples Energy Stat. Error' - print *, '========== ================ ================' + print *, '========== ================= ================= =================' + print *, ' Samples Energy Stat. Error Seconds ' + print *, '========== ================= ================= =================' do while(.true.) call new_parallel_job(zmq_to_qp_run_socket,'pt2') @@ -120,7 +119,7 @@ subroutine ZMQ_pt2(E, pt2,relative_error) exit endif end do - print *, '========== ================ ================' + print *, '========== ================= ================= =================' deallocate(pt2_detail, comb, computed, tbc) @@ -226,7 +225,7 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, allocate(val(b%N), det(N_int, 2, b%N), task_id(N_det_generators), index(1)) more = 1 if (time0 < 0.d0) then - time0 = omp_get_wtime() + call wall_time(time0) endif timeLast = time0 @@ -278,18 +277,18 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, if(actually_computed(i)) done = done + 1 end do - E0 = sum(pt2_detail(1,:first_det_of_teeth(tooth)-1)) + E0 = sum(pt2_detail(1,:first_det_of_teeth(tooth)-1)) prop = ((1d0 - dfloat(comb_teeth - tooth + 1) * comb_step) - pt2_cweight(first_det_of_teeth(tooth)-1)) prop = prop * pt2_weight_inv(first_det_of_teeth(tooth)) E0 += pt2_detail(1,first_det_of_teeth(tooth)) * prop avg = E0 + (sumabove(tooth) / Nabove(tooth)) eqt = sqrt(1d0 / (Nabove(tooth)-1) * abs(sum2above(tooth) / Nabove(tooth) - (sumabove(tooth)/Nabove(tooth))**2)) - time = omp_get_wtime() + call wall_time(time) if (dabs(eqt/avg) < relative_error) then pt2(1) = avg else if (Nabove(tooth) > Nabove_old) then - print '(G10.3, X, F16.10, G16.3,A30)', Nabove(tooth), avg+E, eqt, '' + print '(G10.3, 2X, F16.10, 2X, G16.3, 2X, F16.4, A20)', Nabove(tooth), avg+E, eqt, time-time0, '' Nabove_old = Nabove(tooth) endif endif @@ -331,7 +330,7 @@ end function BEGIN_PROVIDER [ integer, comb_teeth ] implicit none - comb_teeth = 50 + comb_teeth = 100 END_PROVIDER @@ -369,7 +368,8 @@ subroutine get_last_full_tooth(computed, last_tooth) last_tooth = 0 combLoop : do i=comb_teeth, 1, -1 - missing = 1+ ishft(first_det_of_teeth(i+1)-first_det_of_teeth(i),-14) ! /16384 + missing = 1+ ishft(first_det_of_teeth(i+1)-first_det_of_teeth(i),-6) ! /64 +! missing = 1+ ishft(first_det_of_teeth(i+1)-first_det_of_teeth(i),-14) ! /16384 do j=first_det_of_teeth(i), first_det_of_teeth(i+1)-1 if(.not.computed(j)) then missing -= 1 @@ -398,28 +398,47 @@ subroutine get_carlo_workbatch(computed, comb, Ncomb, tbc) logical, intent(inout) :: computed(N_det_generators) integer :: i, j, last_full, dets(comb_teeth), tbc_save integer :: icount, n - n = tbc(0) - icount = 0 +! n = tbc(0) +! icount = 1 +! call RANDOM_NUMBER(comb) +! do i=1,size(comb) +! comb(i) = comb(i) * comb_step +! tbc_save = tbc(0) +! !DIR$ FORCEINLINE +! call add_comb(comb(i), computed, tbc, size_tbc, comb_teeth) +! if (tbc(0) < size(tbc)) then +! Ncomb = i +! else +! tbc(0) = tbc_save +! return +! endif +! icount = icount + tbc(0) - tbc_save +! if ((i>1000).and.(icount > n)) then +! call get_filling_teeth(computed, tbc) +! icount = 0 +! n = ishft(tbc_save,-4) +! endif +! enddo +! call get_filling_teeth(computed, tbc) + + n = int(sqrt(dble(size(comb)))) + call RANDOM_NUMBER(comb) - do i=1,size(comb) - comb(i) = comb(i) * comb_step - tbc_save = tbc(0) - !DIR$ FORCEINLINE - call add_comb(comb(i), computed, tbc, size_tbc, comb_teeth) - if (tbc(0) < size(tbc)) then - Ncomb = i - else - tbc(0) = tbc_save - return - endif - icount = icount + tbc(0) - tbc_save - if ((i>1000).and.(icount > n)) then - call get_filling_teeth(computed, tbc) - icount = 0 - n = ishft(tbc_save,-4) - endif + do j=1,size(comb),n + do i=j,min(size(comb),j+n-1) + comb(i) = comb(i) * comb_step + tbc_save = tbc(0) + !DIR$ FORCEINLINE + call add_comb(comb(i), computed, tbc, size_tbc, comb_teeth) + if (tbc(0) < size(tbc)) then + Ncomb = i + else + tbc(0) = tbc_save + return + endif + end do + call get_filling_teeth(computed, tbc) enddo - call get_filling_teeth(computed, tbc) end subroutine @@ -543,7 +562,7 @@ end subroutine comb_step = 1d0/dfloat(comb_teeth) first_det_of_comb = 1 do i=1,N_det_generators - if(pt2_weight(i)/norm_left < 2.*comb_step) then + if(pt2_weight(i)/norm_left < 0.5d0*comb_step) then first_det_of_comb = i exit end if diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f index 91e458fd..6fa9e976 100644 --- a/src/ZMQ/utils.irp.f +++ b/src/ZMQ/utils.irp.f @@ -180,14 +180,14 @@ function new_zmq_pair_socket(bind) endif - rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 4, 4) + rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 1, 4) if (rc /= 0) then - stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 4, 4)' + stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 1, 4)' endif - rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 4, 4) + rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 1, 4) if (rc /= 0) then - stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 4, 4)' + stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 1, 4)' endif rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_IMMEDIATE, 1, 4) @@ -249,7 +249,7 @@ function new_zmq_pull_socket() stop 'Unable to set ZMQ_RCVBUF on pull socket' endif - rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVHWM,4,4) + rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVHWM,1,4) if (rc /= 0) then stop 'Unable to set ZMQ_RCVHWM on pull socket' endif @@ -321,7 +321,7 @@ function new_zmq_push_socket(thread) ! stop 'Unable to set ZMQ_LINGER on push socket' ! endif - rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDHWM,4,4) + rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDHWM,1,4) if (rc /= 0) then stop 'Unable to set ZMQ_SNDHWM on push socket' endif From 3897f1f154d24f00d2e876aa5da87738b1b1cb08 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 9 May 2017 17:55:15 +0200 Subject: [PATCH 19/25] Fixed PT2 stoch --- ocaml/TaskServer.ml | 7 +------ plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f | 5 +++-- 2 files changed, 4 insertions(+), 8 deletions(-) diff --git a/ocaml/TaskServer.ml b/ocaml/TaskServer.ml index 62de9fbd..8c7e4c8a 100644 --- a/ocaml/TaskServer.ml +++ b/ocaml/TaskServer.ml @@ -49,12 +49,7 @@ let zmq_context = ZMQ.Context.create () let () = - let nproc = - match Sys.getenv "OMP_NUM_THREADS" with - | Some m -> int_of_string m - | None -> 2 - in - ZMQ.Context.set_io_threads zmq_context nproc + ZMQ.Context.set_io_threads zmq_context 2 let bind_socket ~socket_type ~socket ~port = diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f index 6d6bfae0..85059f3e 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -53,7 +53,7 @@ subroutine ZMQ_pt2(E, pt2,relative_error) call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) call create_selection_buffer(1, 1*2, b) - Ncomb=size(comb)/100 + Ncomb=size(comb) call get_carlo_workbatch(computed, comb, Ncomb, tbc) @@ -289,6 +289,7 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, else if (Nabove(tooth) > Nabove_old) then print '(G10.3, 2X, F16.10, 2X, G16.3, 2X, F16.4, A20)', Nabove(tooth), avg+E, eqt, time-time0, '' +!print "(4(G23.13), 4(I9))", time - time0, avg, eqt, Nabove(tooth), tooth, first_det_of_teeth(tooth)-1, done, first_det_of_teeth(tooth+1)-first_det_of_teeth(tooth) Nabove_old = Nabove(tooth) endif endif @@ -368,7 +369,7 @@ subroutine get_last_full_tooth(computed, last_tooth) last_tooth = 0 combLoop : do i=comb_teeth, 1, -1 - missing = 1+ ishft(first_det_of_teeth(i+1)-first_det_of_teeth(i),-6) ! /64 + missing = 1+ ishft(first_det_of_teeth(i+1)-first_det_of_teeth(i),-4) ! /16 ! missing = 1+ ishft(first_det_of_teeth(i+1)-first_det_of_teeth(i),-14) ! /16384 do j=first_det_of_teeth(i), first_det_of_teeth(i+1)-1 if(.not.computed(j)) then From 04e1a90c6addd5406a0a6b7acd4e3f6303ecc60d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 9 May 2017 19:17:07 +0200 Subject: [PATCH 20/25] PT2 stoch fixed, new algo teeth --- plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f | 91 +++++++++----------- 1 file changed, 41 insertions(+), 50 deletions(-) diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f index 85059f3e..f6170be9 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -27,7 +27,7 @@ subroutine ZMQ_pt2(E, pt2,relative_error) double precision, external :: omp_get_wtime double precision :: time - allocate(pt2_detail(N_states, N_det_generators), comb(N_det_generators/2), computed(N_det_generators), tbc(0:size_tbc)) + allocate(pt2_detail(N_states, N_det_generators), comb(N_det_generators), computed(N_det_generators), tbc(0:size_tbc)) sumabove = 0d0 sum2above = 0d0 Nabove = 0d0 @@ -54,7 +54,17 @@ subroutine ZMQ_pt2(E, pt2,relative_error) call create_selection_buffer(1, 1*2, b) Ncomb=size(comb) - call get_carlo_workbatch(computed, comb, Ncomb, tbc) +! i=N_det_generators +! do while (tbc(0) < i) + call get_carlo_workbatch(computed, comb, Ncomb, tbc) +! i=0 +! do j=1,N_det_generators +! if (.not.computed(j)) then +! i = i+1 +! endif +! enddo +! i = i/2 +! enddo @@ -370,7 +380,6 @@ subroutine get_last_full_tooth(computed, last_tooth) last_tooth = 0 combLoop : do i=comb_teeth, 1, -1 missing = 1+ ishft(first_det_of_teeth(i+1)-first_det_of_teeth(i),-4) ! /16 -! missing = 1+ ishft(first_det_of_teeth(i+1)-first_det_of_teeth(i),-14) ! /16384 do j=first_det_of_teeth(i), first_det_of_teeth(i+1)-1 if(.not.computed(j)) then missing -= 1 @@ -393,54 +402,36 @@ END_PROVIDER subroutine get_carlo_workbatch(computed, comb, Ncomb, tbc) implicit none - integer, intent(inout) :: Ncomb - double precision, intent(out) :: comb(Ncomb) - integer, intent(inout) :: tbc(0:size_tbc) - logical, intent(inout) :: computed(N_det_generators) - integer :: i, j, last_full, dets(comb_teeth), tbc_save - integer :: icount, n -! n = tbc(0) -! icount = 1 -! call RANDOM_NUMBER(comb) -! do i=1,size(comb) -! comb(i) = comb(i) * comb_step -! tbc_save = tbc(0) -! !DIR$ FORCEINLINE -! call add_comb(comb(i), computed, tbc, size_tbc, comb_teeth) -! if (tbc(0) < size(tbc)) then -! Ncomb = i -! else -! tbc(0) = tbc_save -! return -! endif -! icount = icount + tbc(0) - tbc_save -! if ((i>1000).and.(icount > n)) then -! call get_filling_teeth(computed, tbc) -! icount = 0 -! n = ishft(tbc_save,-4) -! endif -! enddo -! call get_filling_teeth(computed, tbc) - - n = int(sqrt(dble(size(comb)))) - + integer, intent(inout) :: Ncomb + double precision, intent(out) :: comb(Ncomb) + integer, intent(inout) :: tbc(0:size_tbc) + logical, intent(inout) :: computed(N_det_generators) + integer :: i, j, last_full, dets(comb_teeth), tbc_save + integer :: icount, n + integer :: k, l + l=1 call RANDOM_NUMBER(comb) - do j=1,size(comb),n - do i=j,min(size(comb),j+n-1) - comb(i) = comb(i) * comb_step - tbc_save = tbc(0) - !DIR$ FORCEINLINE - call add_comb(comb(i), computed, tbc, size_tbc, comb_teeth) - if (tbc(0) < size(tbc)) then - Ncomb = i - else - tbc(0) = tbc_save - return - endif - end do - call get_filling_teeth(computed, tbc) + do i=1,size(comb) + comb(i) = comb(i) * comb_step + tbc_save = tbc(0) + !DIR$ FORCEINLINE + call add_comb(comb(i), computed, tbc, size_tbc, comb_teeth) + if ( (tbc(0) < size(tbc)-1).and.(l < first_det_of_teeth(comb_teeth)) ) then + Ncomb = i + do while (computed(l)) + l=l+1 + if (l == size(computed)) exit + enddo + k=tbc(0)+1 + tbc(k) = l + computed(l) = .True. + tbc(0) = k + else + tbc(0) = tbc_save + return + endif enddo - + end subroutine @@ -563,7 +554,7 @@ end subroutine comb_step = 1d0/dfloat(comb_teeth) first_det_of_comb = 1 do i=1,N_det_generators - if(pt2_weight(i)/norm_left < 0.5d0*comb_step) then + if(pt2_weight(i)/norm_left < .5d0*comb_step) then first_det_of_comb = i exit end if From 92832b8ed6c4f0265bf4c7ec05951e7db2861e27 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 9 May 2017 21:21:16 +0200 Subject: [PATCH 21/25] Fixed pt2 stoch --- plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f | 2 +- plugins/Full_CI_ZMQ/run_pt2_slave.irp.f | 6 +----- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f index f6170be9..6ab7e57d 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -212,6 +212,7 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, allocate(actually_computed(N_det_generators), parts_to_get(N_det_generators), & pt2_mwen(N_states, N_det_generators) ) + pt2_mwen(1:N_states, 1:N_det_generators) =0.d0 do i=1,N_det_generators actually_computed(i) = computed(i) enddo @@ -271,7 +272,6 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, timeLast = time do i=1, first_det_of_teeth(1)-1 if(.not.(actually_computed(i))) then -! print *, "PT2 : deterministic part not finished" cycle pullLoop end if end do diff --git a/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f b/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f index 2e49669f..7589d6d8 100644 --- a/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f +++ b/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f @@ -43,7 +43,7 @@ subroutine run_pt2_slave(thread,iproc,energy) do call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task) - done = task_id(ctask) == 0 + done = task_id(ctask) == 0 if (done) then ctask = ctask - 1 else @@ -145,10 +145,6 @@ subroutine pull_pt2_results(zmq_socket_pull, N, index, pt2_detail, task_id, ntas ! Activate is zmq_socket_pull is a REP rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0) - - do i=N+1,N_det_generators - pt2_detail(1:N_states,i) = 0.d0 - enddo end subroutine From cbafcb5f55bbb0722b4a3b35f9e9bf23df241c1e Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 9 May 2017 21:34:01 +0200 Subject: [PATCH 22/25] Restored PUSH/PULL --- plugins/Full_CI_ZMQ/run_pt2_slave.irp.f | 6 ++--- plugins/Full_CI_ZMQ/run_selection_slave.irp.f | 4 ++-- src/Davidson/davidson_parallel.irp.f | 22 +++++++++---------- src/Determinants/H_apply.irp.f | 22 +++++++++---------- .../ao_bielec_integrals_in_map_slave.irp.f | 22 +++++++++---------- src/ZMQ/utils.irp.f | 20 ++++++++--------- 6 files changed, 48 insertions(+), 48 deletions(-) diff --git a/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f b/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f index 7589d6d8..f9787f6c 100644 --- a/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f +++ b/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f @@ -113,8 +113,8 @@ subroutine push_pt2_results(zmq_socket_push, N, index, pt2_detail, task_id, ntas if(rc /= 4*ntask) stop "push" ! Activate is zmq_socket_push is a REQ - character*(2) :: ok - rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0) +! character*(2) :: ok +! rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0) end subroutine @@ -144,7 +144,7 @@ subroutine pull_pt2_results(zmq_socket_pull, N, index, pt2_detail, task_id, ntas if(rc /= 4*ntask) stop "pull" ! Activate is zmq_socket_pull is a REP - rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0) +! rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0) end subroutine diff --git a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f index eb8572f3..cbc62ee4 100644 --- a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f @@ -110,7 +110,7 @@ subroutine push_selection_results(zmq_socket_push, pt2, b, task_id, ntask) if(rc /= 4*ntask) stop "push" ! Activate is zmq_socket_push is a REQ - rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0) +! rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0) end subroutine @@ -144,7 +144,7 @@ subroutine pull_selection_results(zmq_socket_pull, pt2, val, det, N, task_id, nt if(rc /= 4*ntask) stop "pull" ! Activate is zmq_socket_pull is a REP - rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0) +! rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0) end subroutine diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index f4114adb..bec6b593 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -168,12 +168,12 @@ subroutine davidson_push_results(zmq_socket_push, v_0, s_0, task_id) if(rc /= 4) stop "davidson_push_results failed to push task_id" ! Activate is zmq_socket_push is a REQ - integer :: idummy - rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) - if (rc /= 4) then - print *, irp_here, ': f77_zmq_send( zmq_socket_push, idummy, 4, 0)' - stop 'error' - endif +! integer :: idummy +! rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) +! if (rc /= 4) then +! print *, irp_here, ': f77_zmq_send( zmq_socket_push, idummy, 4, 0)' +! stop 'error' +! endif end subroutine @@ -200,11 +200,11 @@ subroutine davidson_pull_results(zmq_socket_pull, v_0, s_0, task_id) if(rc /= 4) stop "davidson_pull_results failed to pull task_id" ! Activate if zmq_socket_pull is a REP - rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0) - if (rc /= 4) then - print *, irp_here, ' : f77_zmq_send (zmq_socket_pull,...' - stop 'error' - endif +! rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0) +! if (rc /= 4) then +! print *, irp_here, ' : f77_zmq_send (zmq_socket_pull,...' +! stop 'error' +! endif end subroutine diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index a6a7310f..411fe703 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -362,12 +362,12 @@ subroutine push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,i_generator,N_st,t endif ! Activate if zmq_socket_push is a REQ - integer :: idummy - rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, idummy, 4, 0)' - stop 'error' - endif +! integer :: idummy +! rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) +! if (rc /= 4) then +! print *, irp_here, 'f77_zmq_send( zmq_socket_push, idummy, 4, 0)' +! stop 'error' +! endif end subroutine pull_pt2(zmq_socket_pull,pt2,norm_pert,H_pert_diag,i_generator,N_st,n,task_id) @@ -433,11 +433,11 @@ subroutine pull_pt2(zmq_socket_pull,pt2,norm_pert,H_pert_diag,i_generator,N_st,n endif ! Activate if zmq_socket_pull is a REP - rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_pull, 0, 4, 0)' - stop 'error' - endif +! rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0) +! if (rc /= 4) then +! print *, irp_here, 'f77_zmq_send( zmq_socket_pull, 0, 4, 0)' +! stop 'error' +! endif end diff --git a/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f b/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f index 38c78388..ce4518cf 100644 --- a/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f +++ b/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f @@ -57,12 +57,12 @@ subroutine push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, endif ! Activate is zmq_socket_push is a REQ - integer :: idummy - rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) - if (rc /= 4) then - print *, irp_here, ': f77_zmq_send( zmq_socket_push, idummy, 4, 0)' - stop 'error' - endif +! integer :: idummy +! rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) +! if (rc /= 4) then +! print *, irp_here, ': f77_zmq_send( zmq_socket_push, idummy, 4, 0)' +! stop 'error' +! endif end @@ -187,11 +187,11 @@ subroutine ao_bielec_integrals_in_map_collector rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0) ! Activate if zmq_socket_pull is a REP - rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0) - if (rc /= 4) then - print *, irp_here, ' : f77_zmq_send (zmq_socket_pull,...' - stop 'error' - endif +! rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0) +! if (rc /= 4) then +! print *, irp_here, ' : f77_zmq_send (zmq_socket_pull,...' +! stop 'error' +! endif call insert_into_ao_integrals_map(n_integrals,buffer_i,buffer_value) diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f index 6fa9e976..fbe09381 100644 --- a/src/ZMQ/utils.irp.f +++ b/src/ZMQ/utils.irp.f @@ -180,14 +180,14 @@ function new_zmq_pair_socket(bind) endif - rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 1, 4) + rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 4, 4) if (rc /= 0) then - stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 1, 4)' + stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 4, 4)' endif - rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 1, 4) + rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 4, 4) if (rc /= 0) then - stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 1, 4)' + stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 4, 4)' endif rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_IMMEDIATE, 1, 4) @@ -232,8 +232,8 @@ function new_zmq_pull_socket() if (zmq_context == 0_ZMQ_PTR) then stop 'zmq_context is uninitialized' endif -! new_zmq_pull_socket = f77_zmq_socket(zmq_context, ZMQ_PULL) - new_zmq_pull_socket = f77_zmq_socket(zmq_context, ZMQ_REP) + new_zmq_pull_socket = f77_zmq_socket(zmq_context, ZMQ_PULL) +! new_zmq_pull_socket = f77_zmq_socket(zmq_context, ZMQ_REP) call omp_unset_lock(zmq_lock) if (new_zmq_pull_socket == 0_ZMQ_PTR) then stop 'Unable to create zmq pull socket' @@ -249,7 +249,7 @@ function new_zmq_pull_socket() stop 'Unable to set ZMQ_RCVBUF on pull socket' endif - rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVHWM,1,4) + rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVHWM,4,4) if (rc /= 0) then stop 'Unable to set ZMQ_RCVHWM on pull socket' endif @@ -309,8 +309,8 @@ function new_zmq_push_socket(thread) if (zmq_context == 0_ZMQ_PTR) then stop 'zmq_context is uninitialized' endif -! new_zmq_push_socket = f77_zmq_socket(zmq_context, ZMQ_PUSH) - new_zmq_push_socket = f77_zmq_socket(zmq_context, ZMQ_REQ) + new_zmq_push_socket = f77_zmq_socket(zmq_context, ZMQ_PUSH) +! new_zmq_push_socket = f77_zmq_socket(zmq_context, ZMQ_REQ) call omp_unset_lock(zmq_lock) if (new_zmq_push_socket == 0_ZMQ_PTR) then stop 'Unable to create zmq push socket' @@ -321,7 +321,7 @@ function new_zmq_push_socket(thread) ! stop 'Unable to set ZMQ_LINGER on push socket' ! endif - rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDHWM,1,4) + rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDHWM,4,4) if (rc /= 0) then stop 'Unable to set ZMQ_SNDHWM on push socket' endif From ff20894479d06c90c39209e46756d7ca2bc3f926 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 9 May 2017 23:11:45 +0200 Subject: [PATCH 23/25] Simplified PT2 stoch --- plugins/CAS_SD_ZMQ/run_selection_slave.irp.f | 4 +- plugins/Full_CI_ZMQ/pt2_stoch.irp.f | 4 +- plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f | 154 ++++++++----------- plugins/mrcepa0/dressing_slave.irp.f | 24 +-- 4 files changed, 80 insertions(+), 106 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f b/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f index ff5dd509..f1aff98a 100644 --- a/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f +++ b/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f @@ -111,7 +111,7 @@ subroutine push_selection_results(zmq_socket_push, pt2, b, task_id, ntask) if(rc /= 4*ntask) stop "push" ! Activate is zmq_socket_push is a REQ - rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0) +! rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0) end subroutine @@ -145,7 +145,7 @@ subroutine pull_selection_results(zmq_socket_pull, pt2, val, det, N, task_id, nt if(rc /= 4*ntask) stop "pull" ! Activate is zmq_socket_pull is a REP - rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0) +! rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0) end subroutine diff --git a/plugins/Full_CI_ZMQ/pt2_stoch.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch.irp.f index 40a84705..c7add796 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch.irp.f @@ -24,8 +24,8 @@ subroutine run E_CI_before = pt2_E0_denominator(1) + nuclear_repulsion threshold_selectors = 1.d0 threshold_generators = 1d0 -! relative_error = 1.d-3 - relative_error = 1.d-8 + relative_error = 1.d-3 +! relative_error = 1.d-8 call ZMQ_pt2(E_CI_before, pt2, relative_error) print *, 'Final step' print *, 'N_det = ', N_det diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f index 6ab7e57d..34dde986 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -47,88 +47,55 @@ subroutine ZMQ_pt2(E, pt2,relative_error) print *, '========== ================= ================= =================' print *, ' Samples Energy Stat. Error Seconds ' print *, '========== ================= ================= =================' - do while(.true.) - call new_parallel_job(zmq_to_qp_run_socket,'pt2') - call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) - call create_selection_buffer(1, 1*2, b) - - Ncomb=size(comb) -! i=N_det_generators -! do while (tbc(0) < i) - call get_carlo_workbatch(computed, comb, Ncomb, tbc) -! i=0 -! do j=1,N_det_generators -! if (.not.computed(j)) then -! i = i+1 -! endif -! enddo -! i = i/2 -! enddo + call new_parallel_job(zmq_to_qp_run_socket,'pt2') + call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) + call create_selection_buffer(1, 1*2, b) + + Ncomb=size(comb) + call get_carlo_workbatch(computed, comb, Ncomb, tbc) + integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket + integer :: ipos + ipos=1 - - integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket - integer :: ipos - logical :: tasks - tasks = .False. - ipos=1 - - do i=1,tbc(0) - if(tbc(i) > fragment_first) then - write(task(ipos:ipos+20),'(I9,1X,I9,''|'')') 0, tbc(i) + do i=1,tbc(0) + if(tbc(i) > fragment_first) then + write(task(ipos:ipos+20),'(I9,1X,I9,''|'')') 0, tbc(i) + ipos += 20 + if (ipos > 63980) then + call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) + ipos=1 + endif + else + do j=1,fragment_count + write(task(ipos:ipos+20),'(I9,1X,I9,''|'')') j, tbc(i) ipos += 20 if (ipos > 63980) then call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) ipos=1 - tasks = .True. endif - else - do j=1,fragment_count - write(task(ipos:ipos+20),'(I9,1X,I9,''|'')') j, tbc(i) - ipos += 20 - if (ipos > 63980) then - call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) - ipos=1 - tasks = .True. - endif - end do - end if - end do - if (ipos > 1) then - call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) - tasks = .True. - endif - - if (tasks) then - call zmq_set_running(zmq_to_qp_run_socket) - - !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc+1) & - !$OMP PRIVATE(i) - i = omp_get_thread_num() - if (i==0) then - call pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, sum2above, Nabove, relative_error, pt2) - else - call pt2_slave_inproc(i) - endif - !$OMP END PARALLEL - call delete_selection_buffer(b) - call end_parallel_job(zmq_to_qp_run_socket, 'pt2') - - else - pt2 = 0.d0 - do i=1,N_det_generators - do k=1,N_states - pt2(k) = pt2(k) + pt2_detail(k,i) - enddo - enddo - endif - - tbc(0) = 0 - if (pt2(1) /= 0.d0) then - exit - endif + end do + end if end do + if (ipos > 1) then + call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) + endif + + call zmq_set_running(zmq_to_qp_run_socket) + + !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc+1) & + !$OMP PRIVATE(i) + i = omp_get_thread_num() + if (i==0) then + call pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, sum2above, Nabove, relative_error, pt2) + else + call pt2_slave_inproc(i) + endif + !$OMP END PARALLEL + call delete_selection_buffer(b) + call end_parallel_job(zmq_to_qp_run_socket, 'pt2') + print *, '========== ================= ================= =================' deallocate(pt2_detail, comb, computed, tbc) @@ -208,6 +175,7 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, integer :: tooth, firstTBDcomb, orgTBDcomb integer, allocatable :: parts_to_get(:) logical, allocatable :: actually_computed(:) + character*(512) :: task Nabove_old = -1.d0 allocate(actually_computed(N_det_generators), parts_to_get(N_det_generators), & @@ -295,7 +263,19 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, eqt = sqrt(1d0 / (Nabove(tooth)-1) * abs(sum2above(tooth) / Nabove(tooth) - (sumabove(tooth)/Nabove(tooth))**2)) call wall_time(time) if (dabs(eqt/avg) < relative_error) then + ! Termination pt2(1) = avg + print '(G10.3, 2X, F16.10, 2X, G16.3, 2X, F16.4, A20)', Nabove(tooth), avg+E, eqt, time-time0, '' + integer :: worker_id + call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,0) + if(worker_id /= -1) then + do + call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(1), task) + if (task_id(1) == 0) exit + call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(1)) + call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(1),more) + enddo + end if else if (Nabove(tooth) > Nabove_old) then print '(G10.3, 2X, F16.10, 2X, G16.3, 2X, F16.4, A20)', Nabove(tooth), avg+E, eqt, time-time0, '' @@ -397,7 +377,7 @@ BEGIN_PROVIDER [ integer, size_tbc ] BEGIN_DOC ! Size of the tbc array END_DOC - size_tbc = N_det_generators + fragment_count*fragment_first + size_tbc = 2*N_det_generators + fragment_count*fragment_first END_PROVIDER subroutine get_carlo_workbatch(computed, comb, Ncomb, tbc) @@ -406,30 +386,24 @@ subroutine get_carlo_workbatch(computed, comb, Ncomb, tbc) double precision, intent(out) :: comb(Ncomb) integer, intent(inout) :: tbc(0:size_tbc) logical, intent(inout) :: computed(N_det_generators) - integer :: i, j, last_full, dets(comb_teeth), tbc_save + integer :: i, j, last_full, dets(comb_teeth) integer :: icount, n integer :: k, l l=1 call RANDOM_NUMBER(comb) do i=1,size(comb) comb(i) = comb(i) * comb_step - tbc_save = tbc(0) !DIR$ FORCEINLINE call add_comb(comb(i), computed, tbc, size_tbc, comb_teeth) - if ( (tbc(0) < size(tbc)-1).and.(l < first_det_of_teeth(comb_teeth)) ) then - Ncomb = i - do while (computed(l)) - l=l+1 - if (l == size(computed)) exit - enddo - k=tbc(0)+1 - tbc(k) = l - computed(l) = .True. - tbc(0) = k - else - tbc(0) = tbc_save - return - endif + Ncomb = i + do while (computed(l)) + l=l+1 + if (l == N_det_generators+1) return + enddo + k=tbc(0)+1 + tbc(k) = l + computed(l) = .True. + tbc(0) = k enddo end subroutine diff --git a/plugins/mrcepa0/dressing_slave.irp.f b/plugins/mrcepa0/dressing_slave.irp.f index 487e6ed3..8d782bd8 100644 --- a/plugins/mrcepa0/dressing_slave.irp.f +++ b/plugins/mrcepa0/dressing_slave.irp.f @@ -316,12 +316,12 @@ subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id) endif ! Activate is zmq_socket_push is a REQ - integer :: idummy - rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, idummy, 4, 0)' - stop 'error' - endif +! integer :: idummy +! rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) +! if (rc /= 4) then +! print *, irp_here, 'f77_zmq_send( zmq_socket_push, idummy, 4, 0)' +! stop 'error' +! endif end @@ -390,12 +390,12 @@ subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, ! Activate is zmq_socket_pull is a REP - integer :: idummy - rc = f77_zmq_send( zmq_socket_pull, idummy, 4, 0) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_pull, idummy, 4, 0)' - stop 'error' - endif +! integer :: idummy +! rc = f77_zmq_send( zmq_socket_pull, idummy, 4, 0) +! if (rc /= 4) then +! print *, irp_here, 'f77_zmq_send( zmq_socket_pull, idummy, 4, 0)' +! stop 'error' +! endif end From 500bf757e33be655854d9a70fb5f19a6d3f608b4 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 10 May 2017 00:04:34 +0200 Subject: [PATCH 24/25] Introduced Abort Keyword --- ocaml/Message.ml | 14 ++++++++ ocaml/Message_lexer.mll | 6 ++++ ocaml/TaskServer.ml | 38 ++++++++++++++++++++ plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f | 11 +----- src/ZMQ/utils.irp.f | 27 ++++++++++++++ 5 files changed, 86 insertions(+), 10 deletions(-) diff --git a/ocaml/Message.ml b/ocaml/Message.ml index 7a1d1712..72fb41b5 100644 --- a/ocaml/Message.ml +++ b/ocaml/Message.ml @@ -610,6 +610,17 @@ end = struct let to_string x = "terminate" end +(** Abort *) +module Abort_msg : sig + type t + val create : t + val to_string : t -> string +end = struct + type t = Abort + let create = Abort + let to_string x = "abort" +end + (** OK *) module Ok_msg : sig type t @@ -660,6 +671,7 @@ type t = | AddTaskReply of AddTaskReply_msg.t | TaskDone of TaskDone_msg.t | Terminate of Terminate_msg.t +| Abort of Abort_msg.t | Ok of Ok_msg.t | Error of Error_msg.t | SetStopped @@ -705,6 +717,7 @@ let of_string s = | PutVector_ { client_id ; size } -> PutVector (PutVector_msg.create ~client_id ~size ~data:None ) | Terminate_ -> Terminate (Terminate_msg.create ) + | Abort_ -> Abort (Abort_msg.create ) | SetWaiting_ -> SetWaiting | SetStopped_ -> SetStopped | SetRunning_ -> SetRunning @@ -732,6 +745,7 @@ let to_string = function | AddTaskReply x -> AddTaskReply_msg.to_string x | TaskDone x -> TaskDone_msg.to_string x | Terminate x -> Terminate_msg.to_string x +| Abort x -> Abort_msg.to_string x | Ok x -> Ok_msg.to_string x | Error x -> Error_msg.to_string x | PutPsi x -> PutPsi_msg.to_string x diff --git a/ocaml/Message_lexer.mll b/ocaml/Message_lexer.mll index b85baecf..f01a3eec 100644 --- a/ocaml/Message_lexer.mll +++ b/ocaml/Message_lexer.mll @@ -15,6 +15,7 @@ type kw_type = | NEW_JOB | END_JOB | TERMINATE + | ABORT | GET_PSI | PUT_PSI | GET_VECTOR @@ -44,6 +45,7 @@ type msg = | NewJob_ of state_tcp_inproc | EndJob_ of string | Terminate_ + | Abort_ | GetPsi_ of int | PutPsi_ of psi | GetVector_ of int @@ -88,6 +90,7 @@ and kw = parse | "new_job" { NEW_JOB } | "end_job" { END_JOB } | "terminate" { TERMINATE } + | "abort" { ABORT } | "get_psi" { GET_PSI } | "put_psi" { PUT_PSI } | "get_vector" { GET_PSI } @@ -218,6 +221,7 @@ and kw = parse | SET_RUNNING -> SetRunning_ | SET_STOPPED -> SetStopped_ | TERMINATE -> Terminate_ + | ABORT -> Abort_ | NONE -> parse_rec lexbuf | _ -> failwith "Error in MessageLexer" @@ -242,6 +246,7 @@ and kw = parse "new_job state_pouet tcp://test.com:12345 ipc:///dev/shm/x.socket"; "end_job state_pouet"; "terminate" ; + "abort" ; "set_running" ; "set_stopped" ; "set_waiting" ; @@ -273,6 +278,7 @@ and kw = parse | PutVector_ { client_id ; size } -> Printf.sprintf "PUT_VECTOR client_id:%d size:%d" client_id size | Terminate_ -> "TERMINATE" + | Abort_ -> "ABORT" | SetWaiting_ -> "SET_WAITING" | SetStopped_ -> "SET_STOPPED" | SetRunning_ -> "SET_RUNNING" diff --git a/ocaml/TaskServer.ml b/ocaml/TaskServer.ml index 8c7e4c8a..1b2acdee 100644 --- a/ocaml/TaskServer.ml +++ b/ocaml/TaskServer.ml @@ -567,6 +567,43 @@ let terminate program_state rep_socket = } +let abort program_state rep_socket = + let queue, client_id = + Queuing_system.add_client program_state.queue + in + let rec aux accu queue = function + | 0 -> (queue, accu) + | rest -> + let new_queue, task_id, _ = + Queuing_system.pop_task ~client_id queue + in + let new_accu = + match task_id with + | Some task_id -> task_id::accu + | None -> accu + in + Queuing_system.number_of_queued new_queue + |> aux new_accu new_queue + in + let queue, tasks = + aux [] queue 1 + in + let queue = + List.fold ~f:(fun queue task_id -> + Queuing_system.end_task ~task_id ~client_id queue) + ~init:queue tasks + in + let queue = + List.fold ~f:(fun queue task_id -> Queuing_system.del_task ~task_id queue) + ~init:queue tasks + in + reply_ok rep_socket; + + { program_state with + queue + } + + let error msg program_state rep_socket = Message.Error (Message.Error_msg.create msg) |> Message.to_string @@ -714,6 +751,7 @@ let run ~port = try match program_state.state, message with | _ , Message.Terminate _ -> terminate program_state rep_socket + | _ , Message.Abort _ -> abort program_state rep_socket | _ , Message.PutVector x -> put_vector x rest program_state rep_socket | _ , Message.GetVector x -> get_vector x program_state rep_socket | _ , Message.PutPsi x -> put_psi x rest program_state rep_socket diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f index 34dde986..0d138493 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -266,16 +266,7 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, ! Termination pt2(1) = avg print '(G10.3, 2X, F16.10, 2X, G16.3, 2X, F16.4, A20)', Nabove(tooth), avg+E, eqt, time-time0, '' - integer :: worker_id - call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,0) - if(worker_id /= -1) then - do - call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(1), task) - if (task_id(1) == 0) exit - call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(1)) - call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(1),more) - enddo - end if + call zmq_abort(zmq_to_qp_run_socket) else if (Nabove(tooth) > Nabove_old) then print '(G10.3, 2X, F16.10, 2X, G16.3, 2X, F16.4, A20)', Nabove(tooth), avg+E, eqt, time-time0, '' diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f index fbe09381..91c46caa 100644 --- a/src/ZMQ/utils.irp.f +++ b/src/ZMQ/utils.irp.f @@ -771,6 +771,33 @@ subroutine add_task_to_taskserver_recv(zmq_to_qp_run_socket) end +subroutine zmq_abort(zmq_to_qp_run_socket) + use f77_zmq + implicit none + BEGIN_DOC + ! Aborts a running parallel computation + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer :: rc, sze + character*(512) :: message + write(message,*) 'abort ' + + sze = len(trim(message)) + rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0) + if (rc /= sze) then + print *, irp_here, 'f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0)' + stop 'error' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0) + if (trim(message(1:rc)) /= 'ok') then + print *, trim(message(1:rc)) + print *, 'Unable to send abort message' + stop -1 + endif + +end + subroutine task_done_to_taskserver(zmq_to_qp_run_socket, worker_id, task_id) use f77_zmq implicit none From ed7aeac2f6acc2917a6a1c5c5b31e6b631682813 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 10 May 2017 01:34:29 +0200 Subject: [PATCH 25/25] Cleaned PT2 stoch --- plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f index 0d138493..28a63bc9 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -278,6 +278,13 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, end if end do pullLoop + E0 = sum(pt2_detail(1,:first_det_of_teeth(tooth)-1)) + prop = ((1d0 - dfloat(comb_teeth - tooth + 1) * comb_step) - pt2_cweight(first_det_of_teeth(tooth)-1)) + prop = prop * pt2_weight_inv(first_det_of_teeth(tooth)) + E0 += pt2_detail(1,first_det_of_teeth(tooth)) * prop + pt2(1) = E0 + (sumabove(tooth) / Nabove(tooth)) + eqt = sqrt(1d0 / (Nabove(tooth)-1) * abs(sum2above(tooth) / Nabove(tooth) - (sumabove(tooth)/Nabove(tooth))**2)) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) call end_zmq_pull_socket(zmq_socket_pull) call sort_selection_buffer(b)