LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2025-01-03 10:05:57 +01:00
Code Issues Releases Wiki Activity

Introduced put/get in OCaml

Browse Source
This commit is contained in:
Anthony Scemama 2017-11-26 23:47:11 +01:00
parent d6ac6e6e73
commit 514b13bc2f
11 changed files with 437 additions and 657 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

370
ocaml/Message.ml
View File

@ -264,304 +264,74 @@ end = struct
Printf.sprintf "get_task_reply 0"
end
(** GetPsi : get the current variational wave function *)
module GetPsi_msg : sig
(** PutData: put some data in the hash table *)
module PutData_msg : sig
type t =
{ client_id : Id.Client.t ;
}
val create : client_id:int -> t
key : string; }
val create : client_id: int -> key: string -> 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_psi %d"
(Id.Client.to_int x.client_id)
end
module Psi : sig
type t =
{
n_state : Strictly_positive_int.t ;
n_det : Strictly_positive_int.t ;
psi_det_size : Strictly_positive_int.t ;
n_det_generators : Strictly_positive_int.t option;
n_det_selectors : Strictly_positive_int.t option;
psi_det : string ;
psi_coef : string ;
energy : string;
}
val create : n_state:Strictly_positive_int.t
-> n_det:Strictly_positive_int.t
-> psi_det_size:Strictly_positive_int.t
-> n_det_generators:Strictly_positive_int.t option
-> n_det_selectors:Strictly_positive_int.t option
-> psi_det:string -> psi_coef:string -> energy:string -> t
end = struct
type t =
{
n_state : Strictly_positive_int.t ;
n_det : Strictly_positive_int.t ;
psi_det_size : Strictly_positive_int.t ;
n_det_generators : Strictly_positive_int.t option;
n_det_selectors : Strictly_positive_int.t option;
psi_det : string ;
psi_coef : string ;
energy : string ;
}
let create ~n_state ~n_det ~psi_det_size
~n_det_generators ~n_det_selectors ~psi_det ~psi_coef
~energy =
assert (Strictly_positive_int.to_int n_det <=
Strictly_positive_int.to_int psi_det_size );
{ n_state; n_det ; psi_det_size ;
n_det_generators ; n_det_selectors ;
psi_det ; psi_coef ; energy }
end
(** GetPsiReply_msg : Reply to the GetPsi message *)
module GetPsiReply_msg : sig
type t = string list
val create : psi:Psi.t -> t
val to_string : t -> string
end = struct
type t = string list
let create ~psi =
let g, s =
match psi.Psi.n_det_generators, psi.Psi.n_det_selectors with
| Some g, Some s -> Strictly_positive_int.to_int g, Strictly_positive_int.to_int s
| _ -> -1, -1
in
let head =
Printf.sprintf "get_psi_reply %d %d %d %d %d"
(Strictly_positive_int.to_int psi.Psi.n_state)
(Strictly_positive_int.to_int psi.Psi.n_det)
(Strictly_positive_int.to_int psi.Psi.psi_det_size)
g s
in
[ head ; psi.Psi.psi_det ; psi.Psi.psi_coef ; psi.Psi.energy ]
let to_string = function
| head :: _ :: _ :: _ :: [] -> head
| _ -> raise (Invalid_argument "Bad wave function message")
end
(** PutPsi : put the current variational wave function *)
module PutPsi_msg : sig
type t =
{ client_id : Id.Client.t ;
n_state : Strictly_positive_int.t ;
n_det : Strictly_positive_int.t ;
psi_det_size : Strictly_positive_int.t ;
n_det_generators : Strictly_positive_int.t option;
n_det_selectors : Strictly_positive_int.t option;
psi : Psi.t option }
val create :
client_id:int ->
n_state:int ->
n_det:int ->
psi_det_size:int ->
psi_det:string option ->
psi_coef:string option ->
n_det_generators: int option ->
n_det_selectors:int option ->
energy:string option -> t
val to_string_list : t -> string list
val to_string : t -> string
end = struct
type t =
{ client_id : Id.Client.t ;
n_state : Strictly_positive_int.t ;
n_det : Strictly_positive_int.t ;
psi_det_size : Strictly_positive_int.t ;
n_det_generators : Strictly_positive_int.t option;
n_det_selectors : Strictly_positive_int.t option;
psi : Psi.t option }
let create ~client_id ~n_state ~n_det ~psi_det_size ~psi_det ~psi_coef
~n_det_generators ~n_det_selectors ~energy =
let n_state, n_det, psi_det_size =
Strictly_positive_int.of_int n_state,
Strictly_positive_int.of_int n_det,
Strictly_positive_int.of_int psi_det_size
in
assert (Strictly_positive_int.to_int psi_det_size >=
Strictly_positive_int.to_int n_det);
let n_det_generators, n_det_selectors =
match n_det_generators, n_det_selectors with
| Some x, Some y ->
Some (Strictly_positive_int.of_int x),
Some (Strictly_positive_int.of_int y)
| _ -> None, None
in
let psi =
match (psi_det, psi_coef, energy) with
| (Some psi_det, Some psi_coef, Some energy) ->
Some (Psi.create ~n_state ~n_det ~psi_det_size ~psi_det
~psi_coef ~n_det_generators ~n_det_selectors ~energy)
| _ -> None
in
key : string; }
let create ~client_id ~key =
{ client_id = Id.Client.of_int client_id ;
n_state ; n_det ; psi_det_size ; n_det_generators ;
n_det_selectors ; psi }
key ; }
let to_string x =
match x.n_det_generators, x.n_det_selectors with
| Some g, Some s ->
Printf.sprintf "put_psi %d %d %d %d %d %d"
(Id.Client.to_int x.client_id)
(Strictly_positive_int.to_int x.n_state)
(Strictly_positive_int.to_int x.n_det)
(Strictly_positive_int.to_int x.psi_det_size)
(Strictly_positive_int.to_int g)
(Strictly_positive_int.to_int s)
| _, _ ->
Printf.sprintf "put_psi %d %d %d %d %d %d"
(Id.Client.to_int x.client_id)
(Strictly_positive_int.to_int x.n_state)
(Strictly_positive_int.to_int x.n_det)
(Strictly_positive_int.to_int x.psi_det_size)
(-1) (-1)
let to_string_list x =
match x.psi with
| Some psi ->
[ to_string x ; psi.Psi.psi_det ; psi.Psi.psi_coef ; psi.Psi.energy ]
| None ->
[ to_string x ; "None" ; "None" ; "None" ]
Printf.sprintf "put_data %d %s"
(Id.Client.to_int x.client_id) x.key
end
(** PutPsiReply_msg : Reply to the PutPsi message *)
module PutPsiReply_msg : sig
(** PutDataReply_msg : Reply to the PutData message *)
module PutDataReply_msg : sig
type t
val create : client_id:Id.Client.t -> t
val create : unit -> t
val to_string : t -> string
end = struct
type t = unit
let create () = ()
let to_string () = "put_data_reply ok"
end
(** GetData: put some data in the hash table *)
module GetData_msg : sig
type t =
{ client_id : Id.Client.t ;
key : string; }
val create : client_id: int -> key: string -> t
val to_string : t -> string
end = struct
type t =
{ client_id : Id.Client.t ;
}
let create ~client_id =
{ client_id; }
key : string }
let create ~client_id ~key =
{ client_id = Id.Client.of_int client_id ; key }
let to_string x =
Printf.sprintf "put_psi_reply %d"
(Id.Client.to_int x.client_id)
Printf.sprintf "get_data %d %s"
(Id.Client.to_int x.client_id) x.key
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
(** GetDataReply_msg : Reply to the GetData message *)
module GetDataReply_msg : sig
type t
val create : value:string -> 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 }
type t = string
let create ~value = value
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)
Printf.sprintf "get_data_reply %d %s"
(String.length x) x
let to_string_list x = [
Printf.sprintf "get_data_reply %d"
(String.length x); x ]
end
@ -644,14 +414,10 @@ end
(** Message *)
type t =
| GetPsi of GetPsi_msg.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
| GetData of GetData_msg.t
| PutData of PutData_msg.t
| GetDataReply of GetDataReply_msg.t
| PutDataReply of PutDataReply_msg.t
| Newjob of Newjob_msg.t
| Endjob of Endjob_msg.t
| Connect of Connect_msg.t
@ -693,24 +459,10 @@ let of_string s =
Newjob (Newjob_msg.create push_address_tcp push_address_inproc state)
| EndJob_ state ->
Endjob (Endjob_msg.create state)
| GetPsi_ client_id ->
GetPsi (GetPsi_msg.create ~client_id)
| PutPsi_ { client_id ; n_state ; n_det ; psi_det_size ; n_det_generators ; n_det_selectors } ->
begin
match n_det_selectors, n_det_generators with
| Some s, Some g ->
PutPsi (PutPsi_msg.create ~client_id ~n_state ~n_det ~psi_det_size
~n_det_generators:(Some g) ~n_det_selectors:(Some s)
~psi_det:None ~psi_coef:None ~energy:None )
| _ ->
PutPsi (PutPsi_msg.create ~client_id ~n_state ~n_det ~psi_det_size
~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 )
| GetData_ { client_id ; key } ->
GetData (GetData_msg.create ~client_id ~key)
| PutData_ { client_id ; key } ->
PutData (PutData_msg.create ~client_id ~key)
| Terminate_ -> Terminate (Terminate_msg.create )
| Abort_ -> Abort (Abort_msg.create )
| SetWaiting_ -> SetWaiting
@ -722,10 +474,10 @@ 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
| GetData x -> GetData_msg.to_string x
| PutData x -> PutData_msg.to_string x
| PutDataReply x -> PutDataReply_msg.to_string x
| GetDataReply x -> GetDataReply_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
@ -743,18 +495,12 @@ let to_string = function
| 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
| 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
| PutVector x -> PutVector_msg.to_string_list x
| GetVectorReply x -> GetVectorReply_msg.to_string_list x
| GetDataReply x -> GetDataReply_msg.to_string_list x
| _ -> assert false

59
ocaml/Message_lexer.mll
View File

@ -16,10 +16,8 @@ type kw_type =
| END_JOB
| TERMINATE
| ABORT
| GET_PSI
| PUT_PSI
| GET_VECTOR
| PUT_VECTOR
| GET_DATA
| PUT_DATA
| OK
| ERROR
| SET_STOPPED
@ -33,7 +31,7 @@ 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 ; }
type vector = { client_id: int ; size: int }
type client_id_key = { client_id: int ; key: string }
type msg =
| AddTask_ of state_tasks
@ -46,10 +44,8 @@ type msg =
| EndJob_ of string
| Terminate_
| Abort_
| GetPsi_ of int
| PutPsi_ of psi
| GetVector_ of int
| PutVector_ of vector
| GetData_ of client_id_key
| PutData_ of client_id_key
| Ok_
| Error_ of string
| SetStopped_
@ -89,12 +85,10 @@ and kw = parse
| "connect" { CONNECT }
| "new_job" { NEW_JOB }
| "end_job" { END_JOB }
| "put_data" { PUT_DATA }
| "get_data" { GET_DATA }
| "terminate" { TERMINATE }
| "abort" { ABORT }
| "get_psi" { GET_PSI }
| "put_psi" { PUT_PSI }
| "get_vector" { GET_PSI }
| "put_vector" { PUT_PSI }
| "ok" { OK }
| "error" { ERROR }
| "set_stopped" { SET_STOPPED }
@ -173,30 +167,15 @@ and kw = parse
let client_id = read_int lexbuf in
Disconnect_ { state ; client_id }
| GET_PSI ->
| GET_DATA ->
let client_id = read_int lexbuf in
GetPsi_ client_id
let key = read_word lexbuf in
GetData_ { client_id ; key }
| PUT_PSI ->
| PUT_DATA ->
let client_id = read_int lexbuf in
let n_state = read_int lexbuf in
let n_det = read_int lexbuf in
let psi_det_size = read_int lexbuf in
let n_det_generators, n_det_selectors =
try
(Some (read_int lexbuf), Some (read_int lexbuf))
with (Failure _) -> (None, None)
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 }
let key = read_word lexbuf in
PutData_ { client_id ; key }
| CONNECT ->
let socket = read_word lexbuf in
@ -267,16 +246,8 @@ and kw = parse
| Connect_ socket -> Printf.sprintf "CONNECT socket:\"%s\"" socket
| NewJob_ { state ; push_address_tcp ; push_address_inproc } -> Printf.sprintf "NEW_JOB state:\"%s\" tcp:\"%s\" inproc:\"%s\"" state push_address_tcp push_address_inproc
| EndJob_ state -> Printf.sprintf "END_JOB state:\"%s\"" state
| GetPsi_ client_id -> Printf.sprintf "GET_PSI client_id:%d" client_id
| PutPsi_ { client_id ; n_state ; n_det ; psi_det_size ; n_det_generators ; n_det_selectors } ->
begin
match n_det_selectors, n_det_generators with
| 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
| GetData_ { client_id; key } -> Printf.sprintf "GET_DATA client_id:%d key:%s" client_id key
| PutData_ { client_id ; key } -> Printf.sprintf "PUT_DATA client_id:%d key:%s" client_id key
| Terminate_ -> "TERMINATE"
| Abort_ -> "ABORT"
| SetWaiting_ -> "SET_WAITING"

122
ocaml/TaskServer.ml
View File

@ -25,10 +25,9 @@ type t =
state : Message.State.t option ;
address_tcp : Address.Tcp.t option ;
address_inproc : Address.Inproc.t option ;
psi : Message.GetPsiReply_msg.t option;
vector : Message.Vector.t option;
progress_bar : Progress_bar.t option ;
running : bool;
data : (string, string) Hashtbl.t;
}
@ -458,95 +457,41 @@ let task_done msg program_state rep_socket =
end
let put_psi msg rest_of_msg program_state rep_socket =
let psi_local =
match msg.Message.PutPsi_msg.psi with
| Some x -> x
| None ->
begin
let psi_det, psi_coef, energy =
match rest_of_msg with
| [ x ; y ; e ] -> x, y, e
| _ -> failwith "Badly formed put_psi message"
in
Message.Psi.create
~n_state:msg.Message.PutPsi_msg.n_state
~n_det:msg.Message.PutPsi_msg.n_det
~psi_det_size:msg.Message.PutPsi_msg.psi_det_size
~n_det_generators:msg.Message.PutPsi_msg.n_det_generators
~n_det_selectors:msg.Message.PutPsi_msg.n_det_selectors
~psi_det
~psi_coef
~energy
end
in
let new_program_state =
{ program_state with
psi = Some (Message.GetPsiReply_msg.create ~psi:psi_local)
}
and client_id =
msg.Message.PutPsi_msg.client_id
in
Message.PutPsiReply (Message.PutPsiReply_msg.create ~client_id)
|> Message.to_string
|> ZMQ.Socket.send rep_socket;
let put_data msg rest_of_msg program_state rep_socket =
new_program_state
let get_psi msg program_state rep_socket =
begin
match program_state.psi with
| None -> failwith "No wave function saved in TaskServer"
| Some psi_message -> ZMQ.Socket.send_all rep_socket psi_message
end;
program_state
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 =
debug (Message.PutData_msg.to_string msg);
let () =
let key, value =
msg.Message.PutData_msg.key,
match rest_of_msg with
| [ x ] -> x
| _ -> failwith "Badly formed put_vector message"
| _ -> failwith "Badly formed put_data 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)
Hashtbl.set program_state.data ~key ~data:value ;
Message.PutDataReply (Message.PutDataReply_msg.create ())
|> 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
|> ZMQ.Socket.send rep_socket
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)
program_state
let get_data msg program_state rep_socket =
debug (Message.GetData_msg.to_string msg);
let () =
let key =
msg.Message.GetData_msg.key
in
let value =
match Hashtbl.find program_state.data key with
| Some value -> value
| None -> ""
in
Message.GetDataReply (Message.GetDataReply_msg.create ~value)
|> Message.to_string_list
|> ZMQ.Socket.send_all rep_socket;
|> ZMQ.Socket.send_all rep_socket
in
program_state
@ -554,8 +499,6 @@ let get_vector msg program_state rep_socket =
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
@ -675,12 +618,11 @@ let run ~port =
let initial_program_state =
{ queue = Queuing_system.create () ;
running = true ;
psi = None;
vector = None;
state = None;
address_tcp = None;
address_inproc = None;
progress_bar = None ;
data = Hashtbl.create ~hashable:String.hashable ();
}
in
@ -747,10 +689,8 @@ let run ~port =
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
| _ , Message.GetPsi x -> get_psi x program_state rep_socket
| _ , Message.PutData x -> put_data x rest program_state rep_socket
| _ , Message.GetData x -> get_data x program_state rep_socket
| None , Message.Newjob x -> new_job x program_state rep_socket pair_socket
| _ , Message.Newjob _ -> error "A job is already running" program_state rep_socket
| Some _, Message.Endjob x -> end_job x program_state rep_socket pair_socket

10
ocaml/TaskServer.mli
View File

@ -4,10 +4,9 @@ type t =
state : Message.State.t option ;
address_tcp : Address.Tcp.t option ;
address_inproc : Address.Inproc.t option ;
psi : Message.GetPsiReply_msg.t option;
vector : Message.Vector.t option ;
progress_bar : Progress_bar.t option ;
running : bool;
data : (string, string) Core.Hashtbl.t ;
}
@ -70,13 +69,6 @@ val get_task: Message.GetTask_msg.t -> t -> [> `Req ] ZMQ.Socket.t -> [> `Pair]
(** Terminate server *)
val terminate : t -> [> `Req ] ZMQ.Socket.t -> t
(** Put a wave function in the task server *)
val put_psi :
Message.PutPsi_msg.t -> string list -> t -> [> `Req ] ZMQ.Socket.t -> t
(** Get the wave function stored in the task server *)
val get_psi : Message.GetPsi_msg.t -> t -> [> `Req ] ZMQ.Socket.t -> t
(** Reply an Error message *)
val error : string -> t -> [> `Req ] ZMQ.Socket.t -> t

334
plugins/Selectors_full/zmq.irp.f
View File

@ -12,42 +12,201 @@ subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id, energy, size_energy)
integer*8 :: rc8
character*(256) :: msg
write(msg,*) 'put_psi ', worker_id, N_states, N_det, psi_det_size, n_det_generators, n_det_selectors
call zmq_put_N_states(zmq_to_qp_run_socket, worker_id)
call zmq_put_N_det(zmq_to_qp_run_socket, worker_id)
call zmq_put_psi_det_size(zmq_to_qp_run_socket, worker_id)
call zmq_put_psi_det(zmq_to_qp_run_socket, worker_id)
call zmq_put_psi_coef(zmq_to_qp_run_socket, worker_id)
call zmq_put_N_det_generators(zmq_to_qp_run_socket, worker_id)
call zmq_put_N_det_selectors(zmq_to_qp_run_socket, worker_id)
call zmq_put_dvector(zmq_to_qp_run_socket, worker_id, 'energy', energy, size_energy)
end
subroutine zmq_put_dvector(zmq_to_qp_run_socket, worker_id, name, x, size_x)
use f77_zmq
implicit none
BEGIN_DOC
! Put the X vector on the qp_run scheduler
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id
character*(*) :: name
integer, intent(in) :: size_x
double precision, intent(out) :: x(size_x)
integer :: rc
character*(256) :: msg
write(msg,'(A,X,I,X,A)') 'put_data', worker_id, name
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE)
if (rc /= len(trim(msg))) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE)'
print *, irp_here, ': Error sending '//name
stop 'error'
endif
rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,ZMQ_SNDMORE)
if (rc8 /= N_int*2_8*N_det*bit_kind) then
print *, 'f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,ZMQ_SNDMORE)'
stop 'error'
endif
rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,ZMQ_SNDMORE)
if (rc8 /= psi_det_size*N_states*8_8) then
print *, 'f77_zmq_send8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send(zmq_to_qp_run_socket,energy,size_energy*8,0)
if (rc /= size_energy*8) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket,energy,size_energy*8,0)'
rc = f77_zmq_send(zmq_to_qp_run_socket,x,size_x*8,0)
if (rc /= size_x*8) then
print *, irp_here, ': Error sending '//name
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0)
if (msg(1:rc) /= 'put_psi_reply 1') then
if (msg(1:rc) /= 'put_data_reply ok') then
print *, rc, trim(msg)
print *, 'Error in put_psi_reply'
print *, irp_here, ': Error in put_data_reply'
stop 'error'
endif
end
BEGIN_TEMPLATE
subroutine zmq_put_$X(zmq_to_qp_run_socket,worker_id)
use f77_zmq
implicit none
BEGIN_DOC
! Put $X on the qp_run scheduler
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id
integer :: rc
character*(256) :: msg
write(msg,'(A,X,I,X,A)') 'put_data', worker_id, '$X'
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE)
if (rc /= len(trim(msg))) then
print *, irp_here, ': Error sending $X'
stop 'error'
endif
rc = f77_zmq_send(zmq_to_qp_run_socket,$X,4,0)
if (rc /= 4) then
print *, irp_here, ': Error sending $X'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0)
if (msg(1:rc) /= 'put_data_reply ok') then
print *, rc, trim(msg)
print *, irp_here, ': Error in put_data_reply'
stop 'error'
endif
end
subroutine zmq_get_$X(zmq_to_qp_run_socket, worker_id)
use f77_zmq
implicit none
BEGIN_DOC
! Get $X from the qp_run scheduler
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id
integer :: rc
character*(64) :: msg
write(msg,'(A,X,I,X,A)') 'get_data', worker_id, '$X'
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)
if (rc /= len(trim(msg))) then
print *, irp_here, ': Error getting $X'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0)
if (msg(1:14) /= 'get_data_reply') then
print *, rc, trim(msg)
print *, irp_here, ': Error in get_data_reply'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,$X,4,0)
if (rc /= 4) then
print *, rc
print *, irp_here, ': Error getting $X'
stop 'error'
endif
end
SUBST [ X ]
N_states ;;
N_det ;;
psi_det_size ;;
N_det_generators ;;
N_det_selectors ;;
N_states_diag ;;
END_TEMPLATE
subroutine zmq_put_psi_det(zmq_to_qp_run_socket,worker_id)
use f77_zmq
implicit none
BEGIN_DOC
! Put psi_det on the qp_run scheduler
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id
integer :: rc, rc8
character*(256) :: msg
write(msg,'(A,X,I,X,A)') 'put_data', worker_id, 'psi_det'
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE)
if (rc /= len(trim(msg))) then
print *, irp_here, ': Error sending psi_det'
stop 'error'
endif
rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,0)
if (rc8 /= N_int*2_8*N_det*bit_kind) then
print *, irp_here, ': Error sending psi_det'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0)
if (msg(1:rc) /= 'put_data_reply ok') then
print *, rc, trim(msg)
print *, irp_here, ': Error in put_data_reply'
stop 'error'
endif
end
subroutine zmq_put_psi_coef(zmq_to_qp_run_socket,worker_id)
use f77_zmq
implicit none
BEGIN_DOC
! Put psi_coef on the qp_run scheduler
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id
integer :: rc, rc8
character*(256) :: msg
write(msg,'(A,X,I,X,A)') 'put_data', worker_id, 'psi_coef'
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE)
if (rc /= len(trim(msg))) then
print *, irp_here, ': Error sending psi_coef'
stop 'error'
endif
rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,0)
if (rc8 /= psi_det_size*N_states*8_8) then
print *, irp_here, ': Error sending psi_coef'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0)
if (msg(1:rc) /= 'put_data_reply ok') then
print *, rc, trim(msg)
print *, irp_here, ': Error in put_data_reply'
stop 'error'
endif
end
!---------------------------------------------------------------------------
subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy)
use f77_zmq
@ -63,59 +222,132 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy)
integer*8 :: rc8
character*(64) :: msg
write(msg,*) 'get_psi ', worker_id
call zmq_get_N_states(zmq_to_qp_run_socket, worker_id)
call zmq_get_N_det(zmq_to_qp_run_socket, worker_id)
call zmq_get_psi_det_size(zmq_to_qp_run_socket, worker_id)
TOUCH psi_det_size N_det N_states
call zmq_get_psi_det(zmq_to_qp_run_socket, worker_id)
call zmq_get_psi_coef(zmq_to_qp_run_socket, worker_id)
TOUCH psi_det psi_coef
call zmq_get_N_det_generators(zmq_to_qp_run_socket, worker_id)
TOUCH N_det_generators
call zmq_get_N_det_selectors(zmq_to_qp_run_socket, worker_id)
TOUCH N_det_selectors
call zmq_get_dvector(zmq_to_qp_run_socket, worker_id, 'energy', energy, size_energy)
end
subroutine zmq_get_psi_det(zmq_to_qp_run_socket, worker_id)
use f77_zmq
implicit none
BEGIN_DOC
! Get psi_det from the qp_run scheduler
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id
integer :: rc
integer*8 :: rc8
character*(64) :: msg
write(msg,'(A,X,I,X,A)') 'get_data', worker_id, 'psi_det'
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)
if (rc /= len(trim(msg))) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)'
print *, irp_here, ': Error getting psi_det'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0)
if (msg(1:13) /= 'get_psi_reply') then
if (msg(1:14) /= 'get_data_reply') then
print *, rc, trim(msg)
print *, 'Error in get_psi_reply'
print *, irp_here, ': Error in get_data_reply'
stop 'error'
endif
integer :: N_states_read, N_det_read, psi_det_size_read
integer :: N_det_selectors_read, N_det_generators_read
read(msg(14:rc),*) N_states_read, N_det_read, psi_det_size_read, &
N_det_generators_read, N_det_selectors_read
N_states = N_states_read
N_det = N_det_read
psi_det_size = psi_det_size_read
TOUCH psi_det_size N_det N_states
rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_det,int(N_int*2_8*N_det*bit_kind,8),0)
if (rc8 /= N_int*2_8*N_det*bit_kind) then
print *, 'f77_zmq_recv8(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)'
print *, irp_here, ': Error getting psi_det'
stop 'error'
endif
end
subroutine zmq_get_psi_coef(zmq_to_qp_run_socket, worker_id)
use f77_zmq
implicit none
BEGIN_DOC
! Get psi_coef from the qp_run scheduler
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id
integer :: rc
integer*8 :: rc8
character*(64) :: msg
write(msg,'(A,X,I,X,A)') 'get_data', worker_id, 'psi_coef'
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)
if (rc /= len(trim(msg))) then
print *, irp_here, ': Error getting psi_coef'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0)
if (msg(1:14) /= 'get_data_reply') then
print *, rc, trim(msg)
print *, irp_here, ': Error in get_data_reply'
stop 'error'
endif
rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_coef,int(psi_det_size*N_states*8_8,8),0)
if (rc8 /= psi_det_size*N_states*8_8) then
print *, '77_zmq_recv8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)'
print *, irp_here, ': Error getting psi_coef'
stop 'error'
endif
TOUCH psi_det psi_coef
rc = f77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)
if (rc /= size_energy*8) then
print *, '77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)'
stop 'error'
endif
if (N_det_generators_read > 0) then
N_det_generators = N_det_generators_read
TOUCH N_det_generators
endif
if (N_det_selectors_read > 0) then
N_det_selectors = N_det_selectors_read
TOUCH N_det_selectors
endif
end
subroutine zmq_get_dvector(zmq_to_qp_run_socket, worker_id, name, x, size_x)
use f77_zmq
implicit none
BEGIN_DOC
! Get psi_coef from the qp_run scheduler
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id
integer, intent(in) :: size_x
character*(*), intent(in) :: name
double precision, intent(out) :: x(size_x)
integer :: rc
integer*8 :: rc8
character*(64) :: msg
write(msg,'(A,X,I,X,A)') 'get_data', worker_id, name
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)
if (rc /= len(trim(msg))) then
print *, irp_here, ': Error getting '//name
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0)
if (msg(1:14) /= 'get_data_reply') then
print *, rc, trim(msg)
print *, irp_here, ': Error in get_data_reply'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,x,size_x*8,0)
if (rc /= size_x*8) then
print *, irp_here, ': Error getting '//name
stop 'error'
endif
end

95
src/Davidson/davidson_parallel.irp.f
View File

@ -36,7 +36,7 @@ subroutine davidson_run_slave(thread,iproc)
zmq_socket_push = new_zmq_push_socket(thread)
call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
if(worker_id == -1) then
print *, 'WORKER -1'
print *, 'Exited'
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread)
return
@ -76,55 +76,12 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze,
allocate(u_t(N_st,N_det))
allocate (energy(N_st))
if (mpi_master) then
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
print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0)
if (msg(1:13) /= 'get_psi_reply') then
print *, rc, trim(msg)
print *, 'Error in get_psi_reply'
stop 'error'
endif
read(msg(14:rc),*) N_states_read, N_det_read, psi_det_size_read, &
N_det_generators_read, N_det_selectors_read
if (N_states_read /= N_st) then
print *, N_st
stop 'error : N_st'
endif
if (N_det_read /= N_det) then
print *, N_det
stop 'N_det /= N_det_read'
endif
rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det_read*bit_kind,0)
if (rc8 /= N_int*2_8*N_det_read*bit_kind) then
print *, 'f77_zmq_recv8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det_read*bit_kind,0)'
stop 'error'
endif
rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,u_t,size(u_t)*8_8,0)
if (rc8 /= size(u_t)*8_8) then
print *, rc, size(u_t)*8
print *, 'f77_zmq_recv8(zmq_to_qp_run_socket,u_t,size(u_t)*8_8,0)'
stop 'error'
endif
allocate (energy(N_st))
rc = f77_zmq_recv(zmq_to_qp_run_socket,energy,N_st*8,0)
if (rc /= N_st*8) then
print *, '77_zmq_recv(zmq_to_qp_run_socket,energy,N_st*8,0)'
stop 'error'
endif
call zmq_get_dvector(zmq_to_qp_run_socket, worker_id, 'u_t', u_t, size(u_t))
call zmq_get_dvector(zmq_to_qp_run_socket, worker_id, 'energy', energy, size(energy))
endif
@ -132,13 +89,6 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze,
include 'mpif.h'
integer :: ierr
call MPI_BARRIER(MPI_COMM_WORLD,ierr)
print *, mpi_rank, size(u_t)
call sleep(1)
if (ierr /= MPI_SUCCESS) then
print *, irp_here//': Unable to broadcast N_st'
stop -1
endif
call broadcast_chunks_double(u_t,size(u_t))
@ -358,40 +308,13 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze)
integer :: rc
integer*8 :: rc8
double precision :: energy(N_st)
energy = 0.d0
task = ' '
write(task,*) 'put_psi ', 1, N_st, N_det, N_det
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(task),len(trim(task)),ZMQ_SNDMORE)
if (rc /= len(trim(task))) then
print *, 'f77_zmq_send8(zmq_to_qp_run_socket,trim(task),len(trim(task)),ZMQ_SNDMORE)'
stop 'error'
endif
rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,ZMQ_SNDMORE)
if (rc8 /= N_int*2_8*N_det*bit_kind) then
print *, 'f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)'
stop 'error'
endif
rc8 = f77_zmq_send8(zmq_to_qp_run_socket,u_t,size(u_t)*8_8,ZMQ_SNDMORE)
if (rc8 /= size(u_t)*8_8) then
print *, 'f77_zmq_send8(zmq_to_qp_run_socket,u_t,int(size(u_t)*8,8),ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send(zmq_to_qp_run_socket,energy,N_st*8,0)
if (rc /= N_st*8) then
print *, 'f77_zmq_send8(zmq_to_qp_run_socket,energy,int(size_energy*8,8),0)'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,task,len(task),0)
if (task(1:rc) /= 'put_psi_reply 1') then
print *, rc, trim(task)
print *, 'Error in put_psi_reply'
stop 'error'
endif
call zmq_put_N_states_diag(zmq_to_qp_run_socket, 1)
call zmq_put_psi_det(zmq_to_qp_run_socket, 1)
call zmq_put_dvector(zmq_to_qp_run_socket, 1, 'u_t', u_t, size(u_t))
call zmq_put_dvector(zmq_to_qp_run_socket, 1, 'energy', energy, size(energy))
deallocate(u_t)

50
src/Determinants/density_matrix.irp.f
View File

@ -1,5 +1,5 @@
BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_average, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_average, (mo_tot_num_align,mo_tot_num) ]
BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_average, (mo_tot_num,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_average, (mo_tot_num,mo_tot_num) ]
implicit none
BEGIN_DOC
! Alpha and beta one-body density matrix for each state
@ -41,7 +41,7 @@ BEGIN_PROVIDER [ double precision, one_body_dm_mo_diff, (mo_tot_num,mo_tot_num,2
END_PROVIDER
BEGIN_PROVIDER [ double precision, one_body_dm_mo_spin_index, (mo_tot_num_align,mo_tot_num,N_states,2) ]
BEGIN_PROVIDER [ double precision, one_body_dm_mo_spin_index, (mo_tot_num,mo_tot_num,N_states,2) ]
implicit none
integer :: i,j,ispin,istate
ispin = 1
@ -65,7 +65,7 @@ END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER [ double precision, one_body_dm_dagger_mo_spin_index, (mo_tot_num_align,mo_tot_num,N_states,2) ]
BEGIN_PROVIDER [ double precision, one_body_dm_dagger_mo_spin_index, (mo_tot_num,mo_tot_num,N_states,2) ]
implicit none
integer :: i,j,ispin,istate
ispin = 1
@ -92,8 +92,8 @@ END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha, (mo_tot_num_align,mo_tot_num,N_states) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta, (mo_tot_num_align,mo_tot_num,N_states) ]
BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha, (mo_tot_num,mo_tot_num,N_states) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta, (mo_tot_num,mo_tot_num,N_states) ]
implicit none
BEGIN_DOC
! Alpha and beta one-body density matrix for each state
@ -117,12 +117,12 @@ END_PROVIDER
!$OMP PRIVATE(j,k,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc, &
!$OMP tmp_a, tmp_b, n_occ, krow, kcol, lrow, lcol, tmp_det, tmp_det2)&
!$OMP SHARED(psi_det,psi_coef,N_int,N_states,elec_alpha_num,&
!$OMP elec_beta_num,one_body_dm_mo_alpha,one_body_dm_mo_beta,N_det,mo_tot_num_align,&
!$OMP elec_beta_num,one_body_dm_mo_alpha,one_body_dm_mo_beta,N_det,&
!$OMP mo_tot_num,psi_bilinear_matrix_rows,psi_bilinear_matrix_columns, &
!$OMP psi_bilinear_matrix_transp_rows, psi_bilinear_matrix_transp_columns, &
!$OMP psi_bilinear_matrix_order_reverse, psi_det_alpha_unique, psi_det_beta_unique, &
!$OMP psi_bilinear_matrix_values, psi_bilinear_matrix_transp_values)
allocate(tmp_a(mo_tot_num_align,mo_tot_num,N_states), tmp_b(mo_tot_num_align,mo_tot_num,N_states) )
allocate(tmp_a(mo_tot_num,mo_tot_num,N_states), tmp_b(mo_tot_num,mo_tot_num,N_states) )
tmp_a = 0.d0
tmp_b = 0.d0
!$OMP DO SCHEDULE(guided)
@ -205,8 +205,8 @@ END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER [ double precision, one_body_single_double_dm_mo_alpha, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, one_body_single_double_dm_mo_beta, (mo_tot_num_align,mo_tot_num) ]
BEGIN_PROVIDER [ double precision, one_body_single_double_dm_mo_alpha, (mo_tot_num,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, one_body_single_double_dm_mo_beta, (mo_tot_num,mo_tot_num) ]
implicit none
BEGIN_DOC
! Alpha and beta one-body density matrix for each state
@ -230,9 +230,9 @@ END_PROVIDER
!$OMP PRIVATE(j,k,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc, &
!$OMP tmp_a, tmp_b, n_occ_alpha,degree_respect_to_HF_k,degree_respect_to_HF_l)&
!$OMP SHARED(ref_bitmask,psi_det,psi_coef,N_int,N_states,state_average_weight,elec_alpha_num,&
!$OMP elec_beta_num,one_body_single_double_dm_mo_alpha,one_body_single_double_dm_mo_beta,N_det,mo_tot_num_align,&
!$OMP elec_beta_num,one_body_single_double_dm_mo_alpha,one_body_single_double_dm_mo_beta,N_det,&
!$OMP mo_tot_num)
allocate(tmp_a(mo_tot_num_align,mo_tot_num), tmp_b(mo_tot_num_align,mo_tot_num) )
allocate(tmp_a(mo_tot_num,mo_tot_num), tmp_b(mo_tot_num,mo_tot_num) )
tmp_a = 0.d0
tmp_b = 0.d0
!$OMP DO SCHEDULE(dynamic)
@ -288,7 +288,7 @@ END_PROVIDER
!$OMP END PARALLEL
END_PROVIDER
BEGIN_PROVIDER [ double precision, one_body_dm_mo, (mo_tot_num_align,mo_tot_num) ]
BEGIN_PROVIDER [ double precision, one_body_dm_mo, (mo_tot_num,mo_tot_num) ]
implicit none
BEGIN_DOC
! One-body density matrix
@ -296,7 +296,7 @@ BEGIN_PROVIDER [ double precision, one_body_dm_mo, (mo_tot_num_align,mo_tot_num)
one_body_dm_mo = one_body_dm_mo_alpha_average + one_body_dm_mo_beta_average
END_PROVIDER
BEGIN_PROVIDER [ double precision, one_body_spin_density_mo, (mo_tot_num_align,mo_tot_num) ]
BEGIN_PROVIDER [ double precision, one_body_spin_density_mo, (mo_tot_num,mo_tot_num) ]
implicit none
BEGIN_DOC
! rho(alpha) - rho(beta)
@ -336,7 +336,7 @@ BEGIN_PROVIDER [ double precision, state_average_weight, (N_states) ]
END_PROVIDER
BEGIN_PROVIDER [ double precision, one_body_spin_density_ao, (ao_num_align,ao_num) ]
BEGIN_PROVIDER [ double precision, one_body_spin_density_ao, (ao_num,ao_num) ]
BEGIN_DOC
! one body spin density matrix on the AO basis : rho_AO(alpha) - rho_AO(beta)
END_DOC
@ -360,10 +360,8 @@ BEGIN_PROVIDER [ double precision, one_body_spin_density_ao, (ao_num_align,ao_nu
END_PROVIDER
BEGIN_PROVIDER [ double precision, one_body_dm_ao_alpha, (ao_num_align,ao_num) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_ao_beta, (ao_num_align,ao_num) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_ao_alpha_no_align, (ao_num,ao_num) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_ao_beta_no_align, (ao_num,ao_num) ]
BEGIN_PROVIDER [ double precision, one_body_dm_ao_alpha, (ao_num,ao_num) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_ao_beta, (ao_num,ao_num) ]
BEGIN_DOC
! one body density matrix on the AO basis : rho_AO(alpha) , rho_AO(beta)
END_DOC
@ -386,18 +384,12 @@ END_PROVIDER
enddo
enddo
enddo
do i = 1, ao_num
do j = 1, ao_num
one_body_dm_ao_alpha_no_align(j,i) = one_body_dm_ao_alpha(j,i)
one_body_dm_ao_beta_no_align(j,i) = one_body_dm_ao_beta(j,i)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_old, (mo_tot_num_align,mo_tot_num,N_states) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_old, (mo_tot_num_align,mo_tot_num,N_states) ]
BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_old, (mo_tot_num,mo_tot_num,N_states) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_old, (mo_tot_num,mo_tot_num,N_states) ]
implicit none
BEGIN_DOC
! Alpha and beta one-body density matrix for each state
@ -417,9 +409,9 @@ END_PROVIDER
!$OMP PRIVATE(j,k,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc, &
!$OMP tmp_a, tmp_b, n_occ)&
!$OMP SHARED(psi_det,psi_coef,N_int,N_states,elec_alpha_num,&
!$OMP elec_beta_num,one_body_dm_mo_alpha_old,one_body_dm_mo_beta_old,N_det,mo_tot_num_align,&
!$OMP elec_beta_num,one_body_dm_mo_alpha_old,one_body_dm_mo_beta_old,N_det,&
!$OMP mo_tot_num)
allocate(tmp_a(mo_tot_num_align,mo_tot_num,N_states), tmp_b(mo_tot_num_align,mo_tot_num,N_states) )
allocate(tmp_a(mo_tot_num,mo_tot_num,N_states), tmp_b(mo_tot_num,mo_tot_num,N_states) )
tmp_a = 0.d0
tmp_b = 0.d0
!$OMP DO SCHEDULE(dynamic)

2
src/Determinants/mono_excitations.irp.f
View File

@ -19,7 +19,7 @@ BEGIN_PROVIDER [integer(bit_kind), ref_closed_shell_bitmask, (N_int,2)]
END_PROVIDER
BEGIN_PROVIDER [double precision, fock_operator_closed_shell_ref_bitmask, (mo_tot_num_align, mo_tot_num) ]
BEGIN_PROVIDER [double precision, fock_operator_closed_shell_ref_bitmask, (mo_tot_num, mo_tot_num) ]
implicit none
integer :: i0,j0,i,j,k0,k
integer :: n_occ_ab(2)

1
src/Determinants/s2.irp.f
View File

@ -10,7 +10,6 @@ double precision function diag_S_mat_elem(key_i,Nint)
END_DOC
integer :: nup, i
integer(bit_kind) :: xorvec(N_int_max)
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec
do i=1,Nint
xorvec(i) = xor(key_i(i,1),key_i(i,2))

1
src/Determinants/slater_rules.irp.f
View File

@ -11,7 +11,6 @@ subroutine get_excitation_degree(key1,key2,degree,Nint)
integer, intent(out) :: degree
integer(bit_kind) :: xorvec(2*N_int_max)
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec
integer :: l
ASSERT (Nint > 0)

14
src/Determinants/spindeterminants.irp.f
View File

@ -943,7 +943,6 @@ subroutine get_all_spin_singles_and_doubles_1(buffer, idx, spindet, size_buffer,
n_singles = 1
n_doubles = 1
!DIR$ VECTOR ALIGNED
do i=1,size_buffer
degree = popcnt( xor( spindet, buffer(i) ) )
if ( degree == 4 ) then
@ -1011,7 +1010,6 @@ subroutine get_all_spin_doubles_1(buffer, idx, spindet, size_buffer, doubles, n_
integer :: degree
n_doubles = 1
!DIR$ VECTOR ALIGNED
do i=1,size_buffer
degree = popcnt(xor( spindet, buffer(i) ))
if ( degree == 4 ) then
@ -1050,12 +1048,8 @@ subroutine get_all_spin_singles_and_doubles_$N_int(buffer, idx, spindet, size_bu
integer(bit_kind) :: xorvec($N_int)
integer :: degree
integer, external :: align_double
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec, degree
n_singles = 1
n_doubles = 1
!DIR$ VECTOR ALIGNED
do i=1,size_buffer
do k=1,$N_int
@ -1069,7 +1063,6 @@ subroutine get_all_spin_singles_and_doubles_$N_int(buffer, idx, spindet, size_bu
endif
do k=2,$N_int
!DIR$ VECTOR ALIGNED
if ( (degree <= 4).and.(xorvec(k) /= 0_8) ) then
degree = degree + popcnt(xorvec(k))
endif
@ -1110,12 +1103,7 @@ subroutine get_all_spin_singles_$N_int(buffer, idx, spindet, size_buffer, single
integer(bit_kind) :: xorvec($N_int)
integer :: degree
integer, external :: align_double
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec
n_singles = 1
!DIR$ VECTOR ALIGNED
do i=1,size_buffer
do k=1,$N_int
@ -1165,7 +1153,6 @@ subroutine get_all_spin_doubles_$N_int(buffer, idx, spindet, size_buffer, double
integer(bit_kind) :: xorvec($N_int)
n_doubles = 1
!DIR$ VECTOR ALIGNED
do i=1,size_buffer
do k=1,$N_int
@ -1179,7 +1166,6 @@ subroutine get_all_spin_doubles_$N_int(buffer, idx, spindet, size_buffer, double
endif
do k=2,$N_int
!DIR$ VECTOR ALIGNED
if ( (degree <= 4).and.(xorvec(k) /= 0_8) ) then
degree = degree + popcnt(xorvec(k))
endif