From 5540db632c348aa58f17c51448c4a9a6be64bfd9 Mon Sep 17 00:00:00 2001
From: Anthony Scemama <scemama@irsamc.ups-tlse.fr>
Date: Sat, 2 Mar 2019 16:48:35 +0100
Subject: [PATCH] Fixed Farm

---
 Parallel_mpi/Farm.ml | 69 ++++++++++++++++++++++++++------------------
 Utils/Printing.ml    |  3 ++
 run_hartree_fock.ml  |  8 +++--
 3 files changed, 50 insertions(+), 30 deletions(-)

diff --git a/Parallel_mpi/Farm.ml b/Parallel_mpi/Farm.ml
index 15965e0..cb95481 100644
--- a/Parallel_mpi/Farm.ml
+++ b/Parallel_mpi/Farm.ml
@@ -22,18 +22,25 @@ let run_sequential f stream =
 type task_id = int
 
 let debug _s =
-  ()
-  (*
-  Printf.eprintf "%d : %s : %s\n%!" (Mpi.comm_rank Mpi.comm_world) (Unix.gettimeofday () |> string_of_float) _s
-  *)
+  if true  then
+    ()
+  else
+    Printf.eprintf "%d : %s : %s\n%!" (Mpi.comm_rank Mpi.comm_world) (Unix.gettimeofday () |> string_of_float) _s
+
+type status =
+  | Initializing
+  | Running
+  | Done
 
 let run_parallel_server ~ordered stream =
 
-  (* n_running is the number of running tasks, required for clean
-     termination. It is the number of tasks to wait for when the input stream
-     is empty.
+  (* [status.(rank)] is [Initializing] if rank has not yet obtained a task,
+     [Running] if rank is running a task and [Done] if [rank] is waiting at
+     the barrier.
   *)
-  let n_running = ref 0 in
+  let status = Array.make (Mpi.comm_size Mpi.comm_world) Initializing in
+  status.(0) <- Done;
+
 
   (** Fetches a result coming from any client. Returns the result
       as a (task_id * 'a) option and the rank of the client as an int.
@@ -44,7 +51,6 @@ let run_parallel_server ~ordered stream =
       Mpi.receive_status  Mpi.any_source  Mpi.any_tag  Mpi.comm_world
     in
     debug @@ Printf.sprintf "After receive_status %d %d" rank _tag;
-    decr n_running;
     message, rank 
   in
 
@@ -53,7 +59,7 @@ let run_parallel_server ~ordered stream =
       If no task is available, sends [None].
       The return value is a boolean telling if the stream is empty.
   *)
-  let send_task (client_rank : int) : bool =
+  let send_task (client_rank : int) : unit =
     let task =
       try
         let task_id = Stream.count stream in
@@ -64,14 +70,21 @@ let run_parallel_server ~ordered stream =
     debug @@ Printf.sprintf "Sending to %d\n" client_rank;
     Mpi.send  task  client_rank  0  Mpi.comm_world;
     debug @@ Printf.sprintf "Sent to %d : %s\n" client_rank
-        (if task = None then "None" else "Some")
-    ;
-    let running = task <> None in
-    if running then incr n_running;
-    running
+        (if task = None then "None" else "Some");
+    if task <> None then
+      status.(client_rank) <- Running
+    else
+      status.(client_rank) <- Done
   in
 
 
+  let all_done () =
+     try
+      Array.iter (fun i -> if i <> Done then raise Exit) status;
+      true
+     with Exit -> false
+  in
+
 
 
   (** Main loop.
@@ -79,23 +92,23 @@ let run_parallel_server ~ordered stream =
       and send it back a new task. If no more tasks are
       available, send [None]. If the result of the task
       is None, loop back into [get_result].
-      TODO : bug is probably here...
   *)
   let rec get_result () : (task_id * 'a ) option = 
-    let message, rank = fetch_result () in
-    let iterate = send_task rank in
-    match iterate, message with
-    | true , None -> (incr n_running ; get_result ())
-    | true , Some (task_id, result) -> Some (task_id, result)
-    | false, Some (task_id, result) -> 
-      if !n_running > 0 then
-        Some (task_id, result)
-      else
-      ( debug "Before barrier";
+    if all_done () then
+      begin
+        debug "Before barrier";
         Mpi.barrier Mpi.comm_world;
         debug "After barrier";
-        None;)
-    | false, None -> assert false
+        None
+      end
+    else
+      begin
+        let message, rank = fetch_result () in
+        send_task rank;
+        match message with
+        | None -> get_result ()
+        | Some (task_id, result) -> Some (task_id, result)
+      end
   in
   
 
diff --git a/Utils/Printing.ml b/Utils/Printing.ml
index 5ee34e4..74afb7e 100644
--- a/Utils/Printing.ml
+++ b/Utils/Printing.ml
@@ -1,4 +1,7 @@
 let line ?(c='-') n =
   String.make n c
 
+let ppf_dev_null = 
+  let oc = open_out "/dev/null" in
+  Format.formatter_of_out_channel oc
 
diff --git a/run_hartree_fock.ml b/run_hartree_fock.ml
index c2ecbef..4a81379 100644
--- a/run_hartree_fock.ml
+++ b/run_hartree_fock.ml
@@ -47,8 +47,12 @@ let () =
     HartreeFock.make s 
   in
 
-  Format.printf "@[%a@]@." HartreeFock.pp_hf hf;
+  let ppf = 
+    if Parallel.master then Format.std_formatter
+    else Printing.ppf_dev_null
+  in
+  Format.fprintf ppf "@[%a@]@." HartreeFock.pp_hf hf;
   let mos = MOBasis.of_hartree_fock hf in
-  Format.printf "@[%a@]@." (fun ppf x -> MOBasis.pp_mo ppf x) mos
+  Format.fprintf ppf "@[%a@]@." (fun ppf x -> MOBasis.pp_mo ppf x) mos