diff --git a/README.md b/README.md index c9e1b12d..b15654aa 100644 --- a/README.md +++ b/README.md @@ -82,11 +82,11 @@ If you have set the `--developement` flag you can go in any module directory and ### 4) Compiling the OCaml - make -C ocaml + make -C $QP_ROOT/ocaml ### 5) Testing if all is ok - cd tests ; bats bats/qp.bats + cd tests ; ./run_tests.sh @@ -137,10 +137,6 @@ interface: ezfio #FAQ -### Opam error: cryptokit - -You need to install `gmp-dev`. - ### Error: ezfio_* is already defined. #### Why ? @@ -166,5 +162,5 @@ It's caused when we call the DGEMM routine of LAPACK. ##### Fix -Set `ulimit -s unlimited`, before runing `qp_run`. It seem to fix the problem. +Set `ulimit -s unlimited`, before runing `qp_run`. It seems to fix the problem. diff --git a/config/gfortran_debug.cfg b/config/gfortran_debug.cfg index 4b06c5e9..f0c6e320 100644 --- a/config/gfortran_debug.cfg +++ b/config/gfortran_debug.cfg @@ -51,7 +51,7 @@ FCFLAGS : -Ofast # -g : Extra debugging information # [DEBUG] -FCFLAGS : -g -msse4.2 +FCFLAGS : -g -msse4.2 -fcheck=all -Waliasing -Wampersand -Wconversion -Wsurprising -Wintrinsics-std -Wno-tabs -Wintrinsic-shadow -Wline-truncation -Wreal-q-constant # OpenMP flags ################# diff --git a/ocaml/Basis.ml b/ocaml/Basis.ml index 869fb132..797d53f2 100644 --- a/ocaml/Basis.ml +++ b/ocaml/Basis.ml @@ -36,9 +36,11 @@ let read_element in_channel at_number element = -let to_string_general ~fmt ~atom_sep b = +let to_string_general ~fmt ~atom_sep ?ele_array b = let new_nucleus n = - Printf.sprintf "Atom %d" n + match ele_array with + | None -> Printf.sprintf "Atom %d" n + | Some x -> Printf.sprintf "%s" (Element.to_string x.(n-1)) in let rec do_work accu current_nucleus = function | [] -> List.rev accu @@ -56,12 +58,12 @@ let to_string_general ~fmt ~atom_sep b = do_work [new_nucleus 1] 1 b |> String.concat ~sep:"\n" -let to_string_gamess = - to_string_general ~fmt:Gto.Gamess ~atom_sep:"" +let to_string_gamess ?ele_array = + to_string_general ?ele_array ~fmt:Gto.Gamess ~atom_sep:"" -let to_string_gaussian b = +let to_string_gaussian ?ele_array b = String.concat ~sep:"\n" - [ to_string_general ~fmt:Gto.Gaussian ~atom_sep:"****" b ; "****" ] + [ to_string_general ?ele_array ~fmt:Gto.Gaussian ~atom_sep:"****" b ; "****" ] let to_string ?(fmt=Gto.Gamess) = match fmt with diff --git a/ocaml/Basis.mli b/ocaml/Basis.mli index 249c14f9..41ddc184 100644 --- a/ocaml/Basis.mli +++ b/ocaml/Basis.mli @@ -14,7 +14,7 @@ val read_element : in_channel -> Nucl_number.t -> Element.t -> (Gto.t * Nucl_number.t) list (** Convert the basis to a string *) -val to_string : ?fmt:Gto.fmt -> (Gto.t * Nucl_number.t) list -> string +val to_string : ?fmt:Gto.fmt -> ?ele_array:Element.t array -> (Gto.t * Nucl_number.t) list -> string (** Convert the basis to an MD5 hash *) val to_md5 : (Gto.t * Nucl_number.t) list -> MD5.t diff --git a/ocaml/Input_determinants_by_hand.ml b/ocaml/Input_determinants_by_hand.ml index 76080b02..6cc83745 100644 --- a/ocaml/Input_determinants_by_hand.ml +++ b/ocaml/Input_determinants_by_hand.ml @@ -7,6 +7,7 @@ module Determinants_by_hand : sig { n_int : N_int_number.t; bit_kind : Bit_kind.t; n_det : Det_number.t; + n_states : States_number.t; expected_s2 : Positive_float.t; psi_coef : Det_coef.t array; psi_det : Determinant.t array; @@ -18,11 +19,14 @@ module Determinants_by_hand : sig val to_rst : t -> Rst_string.t val of_rst : Rst_string.t -> t option val read_n_int : unit -> N_int_number.t + val update_ndet : Det_number.t -> unit + val extract_state : States_number.t -> unit end = struct type t = { n_int : N_int_number.t; bit_kind : Bit_kind.t; n_det : Det_number.t; + n_states : States_number.t; expected_s2 : Positive_float.t; psi_coef : Det_coef.t array; psi_det : Determinant.t array; @@ -129,12 +133,12 @@ end = struct |> Array.map ~f:Det_coef.of_float ;; - let write_psi_coef ~n_det c = + let write_psi_coef ~n_det ~n_states c = let n_det = Det_number.to_int n_det and c = Array.to_list c |> List.map ~f:Det_coef.to_float and n_states = - read_n_states () |> States_number.to_int + States_number.to_int n_states in Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| n_det ; n_states |] ~data:c |> Ezfio.set_determinants_psi_coef @@ -200,6 +204,7 @@ end = struct expected_s2 = read_expected_s2 () ; psi_coef = read_psi_coef () ; psi_det = read_psi_det () ; + n_states = read_n_states () ; } else failwith "No molecular orbitals, so no determinants" @@ -222,12 +227,14 @@ end = struct expected_s2 ; psi_coef ; psi_det ; + n_states ; } = write_n_int n_int ; write_bit_kind bit_kind; write_n_det n_det; + write_n_states n_states; write_expected_s2 expected_s2; - write_psi_coef ~n_det:n_det psi_coef ; + write_psi_coef ~n_det:n_det ~n_states:n_states psi_coef ; write_psi_det ~n_int:n_int ~n_det:n_det psi_det; ;; @@ -298,6 +305,7 @@ Determinants :: n_int = %s bit_kind = %s n_det = %s +n_states = %s expected_s2 = %s psi_coef = %s psi_det = %s @@ -305,6 +313,7 @@ psi_det = %s (b.n_int |> N_int_number.to_string) (b.bit_kind |> Bit_kind.to_string) (b.n_det |> Det_number.to_string) + (b.n_states |> States_number.to_string) (b.expected_s2 |> Positive_float.to_string) (b.psi_coef |> Array.to_list |> List.map ~f:Det_coef.to_string |> String.concat ~sep:", ") @@ -433,14 +442,83 @@ psi_det = %s |> Bit_kind.to_int) and n_int = Printf.sprintf "(n_int %d)" (N_int_number.get_max ()) + and n_states = + Printf.sprintf "(n_states %d)" (States_number.to_int @@ read_n_states ()) in let s = - String.concat [ header ; bitkind ; n_int ; psi_coef ; psi_det] + String.concat [ header ; bitkind ; n_int ; n_states ; psi_coef ; psi_det] in + + + Generic_input_of_rst.evaluate_sexp t_of_sexp s ;; + let update_ndet n_det_new = + Printf.printf "Reducing n_det to %d\n" (Det_number.to_int n_det_new); + let n_det_new = + Det_number.to_int n_det_new + in + let det = + read () + in + let n_det_old, n_states = + Det_number.to_int det.n_det, + States_number.to_int det.n_states + in + if n_det_new = n_det_old then + () + ; + if n_det_new > n_det_new then + failwith @@ Printf.sprintf "Requested n_det should be less than %d" n_det_old + ; + for j=0 to (n_states-1) do + let ishift_old, ishift_new = + j*n_det_old, + j*n_det_new + in + for i=0 to (n_det_new-1) do + det.psi_coef.(i+ishift_new) <- det.psi_coef.(i+ishift_old) + done + done + ; + let new_det = + { det with n_det = (Det_number.of_int n_det_new) } + in + write new_det + ;; + + let extract_state istate = + Printf.printf "Extracting state %d\n" (States_number.to_int istate); + let det = + read () + in + let n_det, n_states = + Det_number.to_int det.n_det, + States_number.to_int det.n_states + in + if (States_number.to_int istate) > n_states then + failwith "State to extract should not be greater than n_states" + ; + let j = + (States_number.to_int istate) - 1 + in + begin + if (j>0) then + let ishift = + j*n_det + in + for i=0 to (n_det-1) do + det.psi_coef.(i) <- det.psi_coef.(i+ishift) + done + end; + let new_det = + { det with n_states = (States_number.of_int 1) } + in + write new_det + ;; + end diff --git a/ocaml/Makefile b/ocaml/Makefile index 7d51986f..8519c973 100644 --- a/ocaml/Makefile +++ b/ocaml/Makefile @@ -13,6 +13,7 @@ LIBS= PKGS= OCAMLCFLAGS="-g -warn-error A" OCAMLBUILD=ocamlbuild -j 0 -syntax camlp4o -cflags $(OCAMLCFLAGS) -lflags $(OCAMLCFLAGS) +MLLFILES=$(wildcard *.mll) MLFILES=$(wildcard *.ml) ezfio.ml Qptypes.ml Input_auto_generated.ml qp_edit.ml MLIFILES=$(wildcard *.mli) git ALL_TESTS=$(patsubst %.ml,%.byte,$(wildcard test_*.ml)) diff --git a/ocaml/Message.ml b/ocaml/Message.ml index 68b866d5..2ed38864 100644 --- a/ocaml/Message.ml +++ b/ocaml/Message.ml @@ -110,7 +110,7 @@ module Disconnect_msg : sig { client_id: Id.Client.t ; state: State.t ; } - val create : state:string -> client_id:string -> t + val create : state:string -> client_id:int -> t val to_string : t -> string end = struct type t = @@ -118,7 +118,7 @@ end = struct state: State.t ; } let create ~state ~client_id = - { client_id = Id.Client.of_string client_id ; state = State.of_string state } + { client_id = Id.Client.of_int client_id ; state = State.of_string state } let to_string x = Printf.sprintf "disconnect %s %d" (State.to_string x.state) @@ -150,18 +150,18 @@ end module AddTask_msg : sig type t = { state: State.t; - task: string; + tasks: string list; } - val create : state:string -> task:string -> t + val create : state:string -> tasks:string list -> t val to_string : t -> string end = struct type t = { state: State.t; - task: string; + tasks: string list; } - let create ~state ~task = { state = State.of_string state ; task } + let create ~state ~tasks = { state = State.of_string state ; tasks } let to_string x = - Printf.sprintf "add_task %s %s" (State.to_string x.state) x.task + Printf.sprintf "add_task %s %s" (State.to_string x.state) (String.concat ~sep:"|" x.tasks) end @@ -182,44 +182,44 @@ end module DelTask_msg : sig type t = { state: State.t; - task_id: Id.Task.t + task_ids: Id.Task.t list } - val create : state:string -> task_id:string -> t + val create : state:string -> task_ids:int list -> t val to_string : t -> string end = struct type t = { state: State.t; - task_id: Id.Task.t + task_ids: Id.Task.t list } - let create ~state ~task_id = + let create ~state ~task_ids = { state = State.of_string state ; - task_id = Id.Task.of_string task_id + task_ids = List.map ~f:Id.Task.of_int task_ids } let to_string x = - Printf.sprintf "del_task %s %d" + Printf.sprintf "del_task %s %s" (State.to_string x.state) - (Id.Task.to_int x.task_id) + (String.concat ~sep:"|" @@ List.map ~f:Id.Task.to_string x.task_ids) end (** DelTaskReply : Reply to the DelTask message *) module DelTaskReply_msg : sig type t - val create : task_id:Id.Task.t -> more:bool -> t + val create : task_ids:Id.Task.t list -> more:bool -> t val to_string : t -> string end = struct type t = { - task_id : Id.Task.t ; + task_ids : Id.Task.t list; more : bool; } - let create ~task_id ~more = { task_id ; more } + let create ~task_ids ~more = { task_ids ; more } let to_string x = let more = if x.more then "more" else "done" in - Printf.sprintf "del_task_reply %s %d" - more (Id.Task.to_int x.task_id) + Printf.sprintf "del_task_reply %s %s" + more (String.concat ~sep:"|" @@ List.map ~f:Id.Task.to_string x.task_ids) end @@ -230,7 +230,7 @@ module GetTask_msg : sig { client_id: Id.Client.t ; state: State.t ; } - val create : state:string -> client_id:string -> t + val create : state:string -> client_id:int -> t val to_string : t -> string end = struct type t = @@ -238,7 +238,7 @@ end = struct state: State.t ; } let create ~state ~client_id = - { client_id = Id.Client.of_string client_id ; state = State.of_string state } + { client_id = Id.Client.of_int client_id ; state = State.of_string state } let to_string x = Printf.sprintf "get_task %s %d" (State.to_string x.state) @@ -269,14 +269,14 @@ module GetPsi_msg : sig type t = { client_id: Id.Client.t ; } - val create : client_id:string -> 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_string 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) @@ -365,14 +365,14 @@ module PutPsi_msg : sig n_det_selectors : Strictly_positive_int.t option; psi : Psi.t option } val create : - client_id:string -> - n_state:string -> - n_det:string -> - psi_det_size:string -> + client_id:int -> + n_state:int -> + n_det:int -> + psi_det_size:int -> psi_det:string option -> psi_coef:string option -> - n_det_generators: string option -> - n_det_selectors: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 @@ -388,20 +388,17 @@ end = struct 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 = - Int.of_string n_state - |> Strictly_positive_int.of_int , - Int.of_string n_det - |> Strictly_positive_int.of_int , - Int.of_string psi_det_size - |> Strictly_positive_int.of_int + 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 @@ Int.of_string x), - Some (Strictly_positive_int.of_int @@ Int.of_string y) + Some (Strictly_positive_int.of_int x), + Some (Strictly_positive_int.of_int y) | _ -> None, None in let psi = @@ -411,7 +408,7 @@ end = struct ~psi_coef ~n_det_generators ~n_det_selectors ~energy) | _ -> None in - { client_id = Id.Client.of_string client_id ; + { client_id = Id.Client.of_int client_id ; n_state ; n_det ; psi_det_size ; n_det_generators ; n_det_selectors ; psi } @@ -463,48 +460,48 @@ module TaskDone_msg : sig type t = { client_id: Id.Client.t ; state: State.t ; - task_id: Id.Task.t ; + task_ids: Id.Task.t list ; } - val create : state:string -> client_id:string -> task_id:string -> t + val create : state:string -> client_id:int -> task_ids:int list -> t val to_string : t -> string end = struct type t = { client_id: Id.Client.t ; state: State.t ; - task_id: Id.Task.t; + task_ids: Id.Task.t list; } - let create ~state ~client_id ~task_id = - { client_id = Id.Client.of_string client_id ; + let create ~state ~client_id ~task_ids = + { client_id = Id.Client.of_int client_id ; state = State.of_string state ; - task_id = Id.Task.of_string task_id; + task_ids = List.map ~f:Id.Task.of_int task_ids; } let to_string x = - Printf.sprintf "task_done %s %d %d" + Printf.sprintf "task_done %s %d %s" (State.to_string x.state) (Id.Client.to_int x.client_id) - (Id.Task.to_int x.task_id) + (String.concat ~sep:"|" @@ List.map ~f:Id.Task.to_string x.task_ids) end (** Terminate *) module Terminate_msg : sig type t - val create : unit -> t + val create : t val to_string : t -> string end = struct type t = Terminate - let create () = Terminate + let create = Terminate let to_string x = "terminate" end (** OK *) module Ok_msg : sig type t - val create : unit -> t + val create : t val to_string : t -> string end = struct type t = Ok - let create () = Ok + let create = Ok let to_string x = "ok" end @@ -551,45 +548,45 @@ type t = let of_string s = - let l = - String.split ~on:' ' s - |> List.filter ~f:(fun x -> (String.strip x) <> "") - |> List.map ~f:String.lowercase - in - match l with - | "add_task" :: state :: task -> - AddTask (AddTask_msg.create ~state ~task:(String.concat ~sep:" " task) ) - | "del_task" :: state :: task_id :: [] -> - DelTask (DelTask_msg.create ~state ~task_id) - | "get_task" :: state :: client_id :: [] -> - GetTask (GetTask_msg.create ~state ~client_id) - | "task_done" :: state :: client_id :: task_id :: [] -> - TaskDone (TaskDone_msg.create ~state ~client_id ~task_id) - | "disconnect" :: state :: client_id :: [] -> - Disconnect (Disconnect_msg.create ~state ~client_id) - | "connect" :: t :: [] -> - Connect (Connect_msg.create t) - | "new_job" :: state :: push_address_tcp :: push_address_inproc :: [] -> - Newjob (Newjob_msg.create push_address_tcp push_address_inproc state) - | "end_job" :: state :: [] -> - Endjob (Endjob_msg.create state) - | "terminate" :: [] -> - Terminate (Terminate_msg.create () ) - | "get_psi" :: client_id :: [] -> - GetPsi (GetPsi_msg.create ~client_id) - | "put_psi" :: client_id :: n_state :: n_det :: psi_det_size :: n_det_generators :: n_det_selectors :: [] -> - PutPsi (PutPsi_msg.create ~client_id ~n_state ~n_det ~psi_det_size - ~n_det_generators:(Some n_det_generators) ~n_det_selectors:(Some n_det_selectors) - ~psi_det:None ~psi_coef:None ~energy:None ) - | "put_psi" :: client_id :: n_state :: n_det :: psi_det_size :: [] -> - 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) - | "ok" :: [] -> Ok (Ok_msg.create ()) - | "error" :: rest -> Error (Error_msg.create (String.concat ~sep:" " rest)) - | "set_stopped" :: [] -> SetStopped - | "set_running" :: [] -> SetRunning - | "set_waiting" :: [] -> SetWaiting - | _ -> failwith "Message not understood" + let open Message_lexer in + match parse s with + | AddTask_ { state ; tasks } -> + AddTask (AddTask_msg.create ~state ~tasks) + | DelTask_ { state ; task_ids } -> + DelTask (DelTask_msg.create ~state ~task_ids) + | GetTask_ { state ; client_id } -> + GetTask (GetTask_msg.create ~state ~client_id) + | TaskDone_ { state ; task_ids ; client_id } -> + TaskDone (TaskDone_msg.create ~state ~client_id ~task_ids) + | Disconnect_ { state ; client_id } -> + Disconnect (Disconnect_msg.create ~state ~client_id) + | Connect_ socket -> + Connect (Connect_msg.create socket) + | NewJob_ { state ; push_address_tcp ; push_address_inproc } -> + 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 + | Terminate_ -> Terminate (Terminate_msg.create ) + | SetWaiting_ -> SetWaiting + | SetStopped_ -> SetStopped + | SetRunning_ -> SetRunning + | Ok_ -> Ok (Ok_msg.create) + | Error_ m -> Error (Error_msg.create m) + let to_string = function diff --git a/ocaml/Message_lexer.mll b/ocaml/Message_lexer.mll new file mode 100644 index 00000000..c67f4528 --- /dev/null +++ b/ocaml/Message_lexer.mll @@ -0,0 +1,265 @@ +{ + +type kw_type = + | TEXT of string + | WORD of string + | INTEGER of int + | FLOAT of float + | NONE + | ADD_TASK + | DEL_TASK + | GET_TASK + | TASK_DONE + | DISCONNECT + | CONNECT + | NEW_JOB + | END_JOB + | TERMINATE + | GET_PSI + | PUT_PSI + | OK + | ERROR + | SET_STOPPED + | SET_RUNNING + | SET_WAITING + +type state_tasks = { state : string ; tasks : string list ; } +type state_taskids = { state : string ; task_ids : int list ; } +type state_taskids_clientid = { state : string ; task_ids : int list ; client_id : int ; } +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 msg = + | AddTask_ of state_tasks + | DelTask_ of state_taskids + | GetTask_ of state_clientid + | TaskDone_ of state_taskids_clientid + | Disconnect_ of state_clientid + | Connect_ of string + | NewJob_ of state_tcp_inproc + | EndJob_ of string + | Terminate_ + | GetPsi_ of int + | PutPsi_ of psi + | Ok_ + | Error_ of string + | SetStopped_ + | SetRunning_ + | SetWaiting_ +} + +let word = [^' ' '\t' '\n']+ +let text = [^ ' ' '|']+[^ '|']+ +let integer = ['0'-'9']+ +let real = '-'? integer '.' integer (['e' 'E'] '-'? integer)? + +let white = [' ' '\t']+ + + +rule get_text = parse + | text as t { TEXT t } + | eof { TERMINATE } + | _ { NONE } + +and get_int = parse + | integer as i { INTEGER (int_of_string i) } + | eof { TERMINATE } + | _ { NONE } + +and get_word = parse + | word as w { WORD w } + | eof { TERMINATE } + | _ { NONE } + +and kw = parse + | "add_task" { ADD_TASK } + | "del_task" { DEL_TASK } + | "get_task" { GET_TASK } + | "task_done" { TASK_DONE } + | "disconnect" { DISCONNECT } + | "connect" { CONNECT } + | "new_job" { NEW_JOB } + | "end_job" { END_JOB } + | "terminate" { TERMINATE } + | "get_psi" { GET_PSI } + | "put_psi" { PUT_PSI } + | "ok" { OK } + | "error" { ERROR } + | "set_stopped" { SET_STOPPED } + | "set_running" { SET_RUNNING } + | "set_waiting" { SET_WAITING } + | _ { NONE } + + +{ + let rec read_text ?(accu=[]) lexbuf = + let token = + get_text lexbuf + in + match token with + | TEXT t -> read_text ~accu:(t::accu) lexbuf + | TERMINATE -> List.rev accu + | NONE -> read_text ~accu lexbuf + | _ -> failwith "Error in MessageLexer (2)" + + and read_word lexbuf = + let token = + get_word lexbuf + in + match token with + | WORD w -> w + | NONE -> read_word lexbuf + | _ -> failwith "Error in MessageLexer (3)" + + and read_int lexbuf = + let token = + get_int lexbuf + in + match token with + | INTEGER i -> i + | NONE -> read_int lexbuf + | _ -> failwith "Error in MessageLexer (4)" + + and read_ints ?(accu=[]) lexbuf = + let token = + get_int lexbuf + in + match token with + | INTEGER i -> read_ints ~accu:(i::accu) lexbuf + | TERMINATE -> List.rev accu + | NONE -> read_ints ~accu lexbuf + | _ -> failwith "Error in MessageLexer (4)" + + and parse_rec lexbuf = + let token = + kw lexbuf + in + match token with + | ADD_TASK -> + let state = read_word lexbuf in + let tasks = read_text lexbuf in + AddTask_ { state ; tasks } + + | DEL_TASK -> + let state = read_word lexbuf in + let task_ids = read_ints lexbuf in + DelTask_ { state ; task_ids } + + | GET_TASK -> + let state = read_word lexbuf in + let client_id = read_int lexbuf in + GetTask_ { state ; client_id } + + | TASK_DONE -> + let state = read_word lexbuf in + let client_id = read_int lexbuf in + let task_ids = read_ints lexbuf in + TaskDone_ { state ; task_ids ; client_id } + + | DISCONNECT -> + let state = read_word lexbuf in + let client_id = read_int lexbuf in + Disconnect_ { state ; client_id } + + | GET_PSI -> + let client_id = read_int lexbuf in + GetPsi_ client_id + + | PUT_PSI -> + 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 } + + | CONNECT -> + let socket = read_word lexbuf in + Connect_ socket + + | NEW_JOB -> + let state = read_word lexbuf in + let push_address_tcp = read_word lexbuf in + let push_address_inproc = read_word lexbuf in + NewJob_ { state ; push_address_tcp ; push_address_inproc } + + | END_JOB -> + let state = read_word lexbuf in + EndJob_ state + + | ERROR -> + let message = List.hd (read_text lexbuf) in + Error_ message + + | OK -> Ok_ + | SET_WAITING -> SetWaiting_ + | SET_RUNNING -> SetRunning_ + | SET_STOPPED -> SetStopped_ + | TERMINATE -> Terminate_ + | NONE -> parse_rec lexbuf + | _ -> failwith "Error in MessageLexer" + + let parse message = + let lexbuf = + Lexing.from_string message + in + parse_rec lexbuf + + + let debug () = + let l = [ + "add_task state_pouet Task pouet zob" ; + "add_task state_pouet Task pouet zob |Task2 zob | Task3 prout" ; + "del_task state_pouet 12345" ; + "del_task state_pouet 12345 | 6789 | 10 | 11" ; + "get_task state_pouet 12" ; + "task_done state_pouet 12 12345"; + "task_done state_pouet 12 12345 | 678 | 91011"; + "connect tcp"; + "disconnect state_pouet 12"; + "new_job state_pouet tcp://test.com:12345 ipc:///dev/shm/x.socket"; + "end_job state_pouet"; + "terminate" ; + "set_running" ; + "set_stopped" ; + "set_waiting" ; + "ok" ; + "error my_error" ; + "get_psi 12" ; + "put_psi 12 2 1000 10000 800 900" ; + "put_psi 12 2 1000 10000" + ] + |> List.map parse + in + List.map (function + | AddTask_ { state ; tasks } -> Printf.sprintf "ADD_TASK state:\"%s\" tasks:{\"%s\"}" state (String.concat "\"}|{\"" tasks) + | DelTask_ { state ; task_ids } -> Printf.sprintf "DEL_TASK state:\"%s\" task_ids:{%s}" state (String.concat "|" @@ List.map string_of_int task_ids) + | GetTask_ { state ; client_id } -> Printf.sprintf "GET_TASK state:\"%s\" task_id:%d" state client_id + | TaskDone_ { state ; task_ids ; client_id } -> Printf.sprintf "TASK_DONE state:\"%s\" task_ids:{%s} client_id:%d" state (String.concat "|" @@ List.map string_of_int task_ids) client_id + | Disconnect_ { state ; client_id } -> Printf.sprintf "DISCONNECT state:\"%s\" client_id:%d" state client_id + | 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 + | Terminate_ -> "TERMINATE" + | SetWaiting_ -> "SET_WAITING" + | SetStopped_ -> "SET_STOPPED" + | SetRunning_ -> "SET_RUNNING" + | Ok_ -> "OK" + | Error_ s -> Printf.sprintf "ERROR: \"%s\"" s + ) l + |> List.iter print_endline + +} diff --git a/ocaml/Symmetry.ml b/ocaml/Symmetry.ml index 5849e116..8647ae99 100644 --- a/ocaml/Symmetry.ml +++ b/ocaml/Symmetry.ml @@ -85,7 +85,7 @@ module Xyz = struct let of_string s = let flush state accu number = let n = - if (number = "") then 0 + if (number = "") then 1 else (Int.of_string number) in match state with diff --git a/ocaml/TaskServer.ml b/ocaml/TaskServer.ml index 6edc8122..abc2de1d 100644 --- a/ocaml/TaskServer.ml +++ b/ocaml/TaskServer.ml @@ -47,6 +47,14 @@ let debug str = 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 + let bind_socket ~socket_type ~socket ~port = let rec loop = function @@ -62,7 +70,15 @@ let bind_socket ~socket_type ~socket ~port = | Unix.Unix_error _ -> (Time.pause @@ Time.Span.of_float 1. ; loop (i-1) ) | other_exception -> raise other_exception in loop 60; - ZMQ.Socket.bind socket @@ Printf.sprintf "ipc:///tmp/qp_run:%d" port + 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) let hostname = lazy ( @@ -99,7 +115,7 @@ let ip_address = lazy ( let reply_ok rep_socket = - Message.Ok_msg.create () + Message.Ok_msg.create |> Message.Ok_msg.to_string |> ZMQ.Socket.send rep_socket @@ -121,7 +137,7 @@ let stop ~port = ZMQ.Socket.set_linger_period req_socket 1_000_000; ZMQ.Socket.connect req_socket address; - Message.Terminate (Message.Terminate_msg.create ()) + Message.Terminate (Message.Terminate_msg.create) |> Message.to_string |> ZMQ.Socket.send req_socket ; @@ -289,9 +305,9 @@ let disconnect msg program_state rep_socket = let del_task msg program_state rep_socket = - let state, task_id = + let state, task_ids = msg.Message.DelTask_msg.state, - msg.Message.DelTask_msg.task_id + msg.Message.DelTask_msg.task_ids in let failure () = @@ -302,13 +318,14 @@ let del_task msg program_state rep_socket = let new_program_state = { program_state with - queue = Queuing_system.del_task ~task_id program_state.queue + queue = List.fold ~f:(fun queue task_id -> Queuing_system.del_task ~task_id queue) + ~init:program_state.queue task_ids } in let more = (Queuing_system.number_of_tasks new_program_state.queue > 0) in - Message.DelTaskReply (Message.DelTaskReply_msg.create ~task_id ~more) + Message.DelTaskReply (Message.DelTaskReply_msg.create ~task_ids ~more) |> Message.to_string |> ZMQ.Socket.send ~block:true rep_socket ; (** /!\ Has to be blocking *) new_program_state @@ -329,9 +346,9 @@ let del_task msg program_state rep_socket = let add_task msg program_state rep_socket = - let state, task = + let state, tasks = msg.Message.AddTask_msg.state, - msg.Message.AddTask_msg.task + msg.Message.AddTask_msg.tasks in let increment_progress_bar = function @@ -339,59 +356,17 @@ let add_task msg program_state rep_socket = | None -> None in - let rec add_task_triangle program_state imax = function - | 0 -> program_state - | i -> - let task = - Printf.sprintf "%d %d" i imax - in - let new_program_state = - { program_state with - queue = Queuing_system.add_task ~task program_state.queue ; - progress_bar = increment_progress_bar program_state.progress_bar ; - } - in - add_task_triangle new_program_state imax (i-1) - in - - let rec add_task_range program_state i = function - | j when (j < i) -> program_state - | j -> - let task = - Printf.sprintf "%d" j - in - let new_program_state = - { program_state with - queue = Queuing_system.add_task ~task program_state.queue ; - progress_bar = increment_progress_bar program_state.progress_bar ; - } - in - add_task_range new_program_state i (j-1) - in - - let new_program_state = function - | "triangle" :: i_str :: [] -> - let imax = - Int.of_string i_str - in - add_task_triangle program_state imax imax - | "range" :: i_str :: j_str :: [] -> - let i, j = - Int.of_string i_str, - Int.of_string j_str - in - add_task_range program_state i j - | _ -> - { program_state with - queue = Queuing_system.add_task ~task program_state.queue ; - progress_bar = increment_progress_bar program_state.progress_bar ; - } - in - let result = - String.split ~on:' ' task - |> List.filter ~f:(fun x -> x <> "") - |> new_program_state + let new_queue, new_bar = + List.fold ~f:(fun (queue, bar) task -> + Queuing_system.add_task ~task queue, + increment_progress_bar bar) + ~init:(program_state.queue, program_state.progress_bar) tasks + in + { program_state with + queue = new_queue; + progress_bar = new_bar + } in reply_ok rep_socket; result @@ -448,10 +423,10 @@ let get_task msg program_state rep_socket pair_socket = let task_done msg program_state rep_socket = - let state, client_id, task_id = + let state, client_id, task_ids = msg.Message.TaskDone_msg.state, msg.Message.TaskDone_msg.client_id, - msg.Message.TaskDone_msg.task_id + msg.Message.TaskDone_msg.task_ids in let increment_progress_bar = function @@ -464,10 +439,16 @@ let task_done msg program_state rep_socket = program_state and success () = + let new_queue, new_bar = + List.fold ~f:(fun (queue, bar) task_id -> + Queuing_system.end_task ~task_id ~client_id queue, + increment_progress_bar bar) + ~init:(program_state.queue, program_state.progress_bar) task_ids + in let result = { program_state with - queue = Queuing_system.end_task ~task_id ~client_id program_state.queue ; - progress_bar = increment_progress_bar program_state.progress_bar ; + queue = new_queue; + progress_bar = new_bar } in reply_ok rep_socket; diff --git a/ocaml/create_git_sha1.sh b/ocaml/create_git_sha1.sh index 7b47e96f..f1fb7fa6 100755 --- a/ocaml/create_git_sha1.sh +++ b/ocaml/create_git_sha1.sh @@ -2,7 +2,7 @@ SHA1=$(git log -1 | head -1 | cut -d ' ' -f 2) DATE=$(git log -1 | grep Date | cut -d ':' -f 2-) -MESSAGE=$(git log -1 | tail -1) +MESSAGE=$(git log -1 | tail -1 | sed 's/"/\\"/g') cat << EOF > Git.ml open Core.Std let sha1 = "$SHA1" |> String.strip diff --git a/ocaml/qp_create_ezfio_from_xyz.ml b/ocaml/qp_create_ezfio_from_xyz.ml index c79bf550..7c07ffe5 100644 --- a/ocaml/qp_create_ezfio_from_xyz.ml +++ b/ocaml/qp_create_ezfio_from_xyz.ml @@ -21,6 +21,9 @@ let spec = ~doc:" Compute AOs in the Cartesian basis set (6d, 10f, ...)" +> anon ("(xyz_file|zmt_file)" %: file ) +type element = +| Element of Element.t +| Int_elem of (Nucl_number.t * Element.t) (** Handle dummy atoms placed on bonds *) let dummy_centers ~threshold ~molecule ~nuclei = @@ -115,17 +118,14 @@ let run ?o b c d m p cart xyz_file = (* Open basis set channels *) let basis_channel element = let key = - Element.to_string element + match element with + | Element e -> Element.to_string e + | Int_elem (i,e) -> Printf.sprintf "%d,%s" (Nucl_number.to_int i) (Element.to_string e) in match Hashtbl.find basis_table key with | Some in_channel -> in_channel - | None -> - let msg = - Printf.sprintf "%s is not defined in basis %s.%!" - (Element.to_long_string element) b ; - in - failwith msg + | None -> raise Not_found in let temp_filename = @@ -189,12 +189,21 @@ let run ?o b c d m p cart xyz_file = | Some (key, basis) -> (*Aux basis *) begin let elem = - Element.of_string key + try + Element (Element.of_string key) + with Element.ElementError _ -> + let result = + match (String.split ~on:',' key) with + | i :: k :: [] -> (Nucl_number.of_int @@ int_of_string i, Element.of_string k) + | _ -> failwith "Expected format is int,Element:basis" + in Int_elem result and basis = String.lowercase basis in let key = - Element.to_string elem + match elem with + | Element e -> Element.to_string e + | Int_elem (i,e) -> Printf.sprintf "%d,%s" (Nucl_number.to_int i) (Element.to_string e) in let new_channel = fetch_channel basis @@ -202,7 +211,13 @@ let run ?o b c d m p cart xyz_file = begin match Hashtbl.add basis_table ~key:key ~data:new_channel with | `Ok -> () - | `Duplicate -> failwith ("Duplicate definition of basis for "^(Element.to_long_string elem)) + | `Duplicate -> + let e = + match elem with + | Element e -> e + | Int_elem (_,e) -> e + in + failwith ("Duplicate definition of basis for "^(Element.to_long_string e)) end end end; @@ -537,7 +552,20 @@ let run ?o b c d m p cart xyz_file = | Element.X -> Element.H | e -> e in - Basis.read_element (basis_channel x.Atom.element) i e + let key = + Int_elem (i,x.Atom.element) + in + try + Basis.read_element (basis_channel key) i e + with Not_found -> + let key = + Element x.Atom.element + in + try + Basis.read_element (basis_channel key) i e + with Not_found -> + failwith (Printf.sprintf "Basis not found for atom %d (%s)" (Nucl_number.to_int i) + (Element.to_string x.Atom.element) ) with | End_of_file -> failwith ("Element "^(Element.to_string x.Atom.element)^" not found in basis set.") @@ -647,6 +675,7 @@ atoms are taken from the same basis set, otherwise specific elements can be defined as follows: -b \"cc-pcvdz | H:cc-pvdz | C:6-31g\" + -b \"cc-pvtz | 1,H:sto-3g | 3,H:6-31g\" If a file with the same name as the basis set exists, this file will be read. Otherwise, the basis set is obtained from the database. diff --git a/ocaml/qptypes_generator.ml b/ocaml/qptypes_generator.ml index ee988ccb..160a07d0 100644 --- a/ocaml/qptypes_generator.ml +++ b/ocaml/qptypes_generator.ml @@ -42,8 +42,8 @@ let input_data = " * Det_number_max : int assert (x > 0) ; - if (x > 100000000) then - warning \"More than 100 million determinants\"; + if (x > 10000000000) then + warning \"More than 10 billion determinants\"; * States_number : int assert (x > 0) ; @@ -140,8 +140,8 @@ let input_ezfio = " * Det_number : int determinants_n_det - 1 : 100000000 - More than 100 million of determinants + 1 : 10000000000 + More than 10 billion of determinants " ;; diff --git a/plugins/Alavi/.gitignore b/plugins/Alavi/.gitignore deleted file mode 100644 index e4e1a2ab..00000000 --- a/plugins/Alavi/.gitignore +++ /dev/null @@ -1,23 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Utils -alavi_graph -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/Alavi/README.rst b/plugins/Alavi/README.rst deleted file mode 100644 index f2194755..00000000 --- a/plugins/Alavi/README.rst +++ /dev/null @@ -1,23 +0,0 @@ -===== -alavi -===== - -Documentation -============= - -.. Do not edit this section. It was auto-generated from the -.. by the `update_README.py` script. - -`alavi_graph `_ - Undocumented - -Needed Modules -============== - -.. Do not edit this section. It was auto-generated from the -.. by the `update_README.py` script. - -.. image:: tree_dependency.png - -* `Determinants `_ - diff --git a/plugins/Alavi/alavi_graph.irp.f b/plugins/Alavi/alavi_graph.irp.f deleted file mode 100644 index 4e953add..00000000 --- a/plugins/Alavi/alavi_graph.irp.f +++ /dev/null @@ -1,28 +0,0 @@ -program alavi_graph - implicit none - integer :: exc(0:2,2,2),h1,p1,h2,p2,s1,s2 - double precision :: phase - - read_wf = .True. - touch read_wf - - integer :: k,degree - double precision :: hii - - do k=1,N_det - call get_excitation_degree(psi_det(1,1,1),psi_det(1,1,k),degree,N_int) - call i_H_j(psi_det(1,1,k),psi_det(1,1,k),N_int,hii) - print*, k,abs(psi_coef(k,1)), hii,degree - -! if (degree == 2) then -! call get_excitation(psi_det(1,1,1),psi_det(1,1,k),exc,degree,phase,N_int) -! call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) -! print*, h1,h2,hii, abs(psi_coef(k,1)) -! endif -! - - - enddo -end - -!plot "test.dat" u (abs($2)):(abs($3)):4 w p palette \ No newline at end of file diff --git a/plugins/Alavi/tree_dependency.png b/plugins/Alavi/tree_dependency.png deleted file mode 100644 index b4f0df8b..00000000 Binary files a/plugins/Alavi/tree_dependency.png and /dev/null differ diff --git a/plugins/All_singles/.gitignore b/plugins/All_singles/.gitignore deleted file mode 100644 index 7ac9fbf6..00000000 --- a/plugins/All_singles/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -IRPF90_temp/ -IRPF90_man/ -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/CAS_SD/.gitignore b/plugins/CAS_SD/.gitignore deleted file mode 100644 index 57b1926f..00000000 --- a/plugins/CAS_SD/.gitignore +++ /dev/null @@ -1,34 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Davidson -Determinants -Electrons -Ezfio_files -Generators_CAS -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_full -Utils -ZMQ -cas_s -cas_s_selected -cas_sd -cas_sd_selected -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/CAS_SD_ZMQ/EZFIO.cfg b/plugins/CAS_SD_ZMQ/EZFIO.cfg index 7425c8ba..43905f9e 100644 --- a/plugins/CAS_SD_ZMQ/EZFIO.cfg +++ b/plugins/CAS_SD_ZMQ/EZFIO.cfg @@ -1,10 +1,15 @@ [energy] type: double precision -doc: "Calculated CAS-SD energy" +doc: Calculated CAS-SD energy interface: ezfio [energy_pt2] type: double precision -doc: "Calculated selected CAS-SD energy with PT2 correction" +doc: Calculated selected CAS-SD energy with PT2 correction interface: ezfio +[do_ddci] +type: logical +doc: If true, remove purely inactive double excitations +interface: ezfio,provider,ocaml +default: False diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f index 881f74c3..5b364400 100644 --- a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -132,124 +132,3 @@ program fci_zmq call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before(1)+pt2(1)) end - - - - -subroutine ZMQ_selection(N_in, pt2) - use f77_zmq - use selection_types - - implicit none - - character*(512) :: task - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - integer, intent(in) :: N_in - type(selection_buffer) :: b - integer :: i, N - integer, external :: omp_get_thread_num - double precision, intent(out) :: pt2(N_states) - - - if (.True.) then - PROVIDE pt2_e0_denominator - N = max(N_in,1) - provide nproc - call new_parallel_job(zmq_to_qp_run_socket,"selection") - call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) - call zmq_set_running(zmq_to_qp_run_socket) - call create_selection_buffer(N, N*2, b) - endif - - integer :: i_generator, i_generator_start, i_generator_max, step -! step = int(max(1.,10*elec_num/mo_tot_num) - - step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num )) - step = max(1,step) - do i= 1, N_det_generators,step - i_generator_start = i - i_generator_max = min(i+step-1,N_det_generators) - write(task,*) i_generator_start, i_generator_max, 1, N - call add_task_to_taskserver(zmq_to_qp_run_socket,task) - end do - - !$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) - else - call selection_slave_inproc(i) - endif - !$OMP END PARALLEL - call end_parallel_job(zmq_to_qp_run_socket, 'selection') - if (N_in > 0) then - call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN - call copy_H_apply_buffer_to_wf() - if (s2_eig) then - call make_s2_eigenfunction - endif - endif -end subroutine - - -subroutine selection_slave_inproc(i) - implicit none - integer, intent(in) :: i - - call run_selection_slave(1,i,pt2_e0_denominator) -end - -subroutine selection_collector(b, pt2) - use f77_zmq - use selection_types - use bitmasks - implicit none - - - type(selection_buffer), intent(inout) :: b - double precision, intent(out) :: pt2(N_states) - double precision :: pt2_mwen(N_states) - integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - - integer(ZMQ_PTR), external :: new_zmq_pull_socket - integer(ZMQ_PTR) :: zmq_socket_pull - - integer :: msg_size, rc, more - integer :: acc, i, j, robin, N, ntask - double precision, allocatable :: val(:) - integer(bit_kind), allocatable :: det(:,:,:) - integer, allocatable :: task_id(:) - integer :: done - real :: time, time0 - 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)) - 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) - pt2 += pt2_mwen - 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 - - - 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/plugins/CAS_SD_ZMQ/ezfio_interface.irp.f b/plugins/CAS_SD_ZMQ/ezfio_interface.irp.f deleted file mode 100644 index 8adab518..00000000 --- a/plugins/CAS_SD_ZMQ/ezfio_interface.irp.f +++ /dev/null @@ -1,4 +0,0 @@ -! DO NOT MODIFY BY HAND -! Created by $QP_ROOT/scripts/ezfio_interface/ei_handler.py -! from file /home/scemama/quantum_package/src/CAS_SD_ZMQ/EZFIO.cfg - diff --git a/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f b/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f index dfaee629..ff5dd509 100644 --- a/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f +++ b/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f @@ -41,8 +41,8 @@ subroutine run_selection_slave(thread,iproc,energy) if (done) then ctask = ctask - 1 else - integer :: i_generator, i_generator_start, i_generator_max, step, N - read (task,*) i_generator_start, i_generator_max, step, N + integer :: i_generator, N + read (task,*) i_generator, N if(buf%N == 0) then ! Only first time call create_selection_buffer(N, N*2, buf) @@ -50,11 +50,7 @@ subroutine run_selection_slave(thread,iproc,energy) else if(N /= buf%N) stop "N changed... wtf man??" end if - !print *, "psi_selectors_coef ", psi_selectors_coef(N_det_selectors-5:N_det_selectors, 1) - !call debug_det(psi_selectors(1,1,N_det_selectors), N_int) - do i_generator=i_generator_start,i_generator_max,step - call select_connected(i_generator,energy,pt2,buf) - enddo + call select_connected(i_generator,energy,pt2,buf) endif if(done .or. ctask == size(task_id)) then @@ -115,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 @@ -149,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/CAS_SD_ZMQ/selection.irp.f b/plugins/CAS_SD_ZMQ/selection.irp.f index 33aab57d..3692710d 100644 --- a/plugins/CAS_SD_ZMQ/selection.irp.f +++ b/plugins/CAS_SD_ZMQ/selection.irp.f @@ -1,1207 +1,1334 @@ -use bitmasks - - -double precision function integral8(i,j,k,l) - implicit none - - integer, intent(in) :: i,j,k,l - double precision, external :: get_mo_bielec_integral - integer :: ii - ii = l-mo_integrals_cache_min - ii = ior(ii, k-mo_integrals_cache_min) - ii = ior(ii, j-mo_integrals_cache_min) - ii = ior(ii, i-mo_integrals_cache_min) - if (iand(ii, -64) /= 0) then - integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) - else - ii = l-mo_integrals_cache_min - ii = ior( ishft(ii,6), k-mo_integrals_cache_min) - ii = ior( ishft(ii,6), j-mo_integrals_cache_min) - ii = ior( ishft(ii,6), i-mo_integrals_cache_min) - integral8 = mo_integrals_cache(ii) - endif -end function - - -BEGIN_PROVIDER [ integer(1), psi_phasemask, (N_int*bit_kind_size, 2, N_det)] - use bitmasks - implicit none - - integer :: i - do i=1, N_det - call get_mask_phase(psi_selectors(1,1,i), psi_phasemask(1,1,i)) - end do -END_PROVIDER - - -subroutine assert(cond, msg) - character(*), intent(in) :: msg - logical, intent(in) :: cond - - if(.not. cond) then - print *, "assert fail: "//msg - stop - end if -end subroutine - - -subroutine get_mask_phase(det, phasemask) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: det(N_int, 2) - integer(1), intent(out) :: phasemask(N_int*bit_kind_size, 2) - integer :: s, ni, i - logical :: change - - phasemask = 0_1 - do s=1,2 - change = .false. - do ni=1,N_int - do i=0,bit_kind_size-1 - if(BTEST(det(ni, s), i)) change = .not. change - if(change) phasemask((ni-1)*bit_kind_size + i + 1, s) = 1_1 - end do - end do - end do -end subroutine - - -subroutine select_connected(i_generator,E0,pt2,b) - use bitmasks - use selection_types - implicit none - integer, intent(in) :: i_generator - type(selection_buffer), intent(inout) :: b - double precision, intent(inout) :: pt2(N_states) - integer :: k,l - double precision, intent(in) :: E0(N_states) - - integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision :: fock_diag_tmp(2,mo_tot_num+1) - - call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) - - do l=1,N_generators_bitmask - do k=1,N_int - hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole,l), psi_det_generators(k,1,i_generator)) - hole_mask(k,2) = iand(generators_bitmask(k,2,s_hole,l), psi_det_generators(k,2,i_generator)) - particle_mask(k,1) = iand(generators_bitmask(k,1,s_part,l), not(psi_det_generators(k,1,i_generator)) ) - particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) ) - - enddo - call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) - call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) - enddo -end subroutine - - -double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) - use bitmasks - implicit none - - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - integer, intent(in) :: s1, s2, h1, h2, p1, p2 - logical :: change - integer(1) :: np - double precision, parameter :: res(0:1) = (/1d0, -1d0/) - - np = phasemask(h1,s1) + phasemask(p1,s1) + phasemask(h2,s2) + phasemask(p2,s2) - if(p1 < h1) np = np + 1_1 - if(p2 < h2) np = np + 1_1 - - if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1_1 - get_phase_bi = res(iand(np,1_1)) -end function - - - -! Selection single -! ---------------- - -subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) - use bitmasks - use selection_types - implicit none - BEGIN_DOC -! Select determinants connected to i_det by H - END_DOC - integer, intent(in) :: i_gen - integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - - double precision :: vect(N_states, mo_tot_num) - logical :: bannedOrb(mo_tot_num) - integer :: i, j, k - integer :: h1,h2,s1,s2,i1,i2,ib,sp - integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2) - logical :: fullMatch, ok - - - do k=1,N_int - hole (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1)) - hole (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2)) - particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1)) - particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2)) - enddo - - ! Create lists of holes and particles - ! ----------------------------------- - - integer :: N_holes(2), N_particles(2) - integer :: hole_list(N_int*bit_kind_size,2) - integer :: particle_list(N_int*bit_kind_size,2) - - call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) - call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) - - do sp=1,2 - do i=1, N_holes(sp) - h1 = hole_list(i,sp) - call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int) - bannedOrb = .true. - do j=1,N_particles(sp) - bannedOrb(particle_list(j, sp)) = .false. - end do - call spot_hasBeen(mask, sp, psi_selectors, i_gen, N_det, bannedOrb, fullMatch) - if(fullMatch) cycle - vect = 0d0 - call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect) - call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) - end do - enddo -end subroutine - - -subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator, sp, h1 - double precision, intent(in) :: vect(N_states, mo_tot_num) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - logical :: ok - integer :: s1, s2, p1, p2, ib, 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, external :: diag_H_mat_elem_fock - - - call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int) - - do p1=1,mo_tot_num - if(bannedOrb(p1)) cycle - if(vect(1, p1) == 0d0) cycle - call apply_particle(mask, sp, p1, 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 - - do istate=1,N_states - val = vect(istate, p1) + vect(istate, p1) - delta_E = E0(istate) - Hii - tmp = dsqrt(delta_E * delta_E + val * val) - if (delta_E < 0.d0) then - tmp = -tmp - endif - e_pert = 0.5d0 * ( tmp - delta_E) - pt2(istate) += e_pert - if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert - end do - - if(dabs(max_e_pert) > buf%mini) then - call add_to_selection_buffer(buf, det, max_e_pert) - endif - end do -end subroutine - - -subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect) - use bitmasks - implicit none - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2, N_sel) - double precision, intent(in) :: coefs(N_states, N_sel) - integer, intent(in) :: sp, N_sel - logical, intent(inout) :: bannedOrb(mo_tot_num) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - - integer :: i, j, h(0:2,2), p(0:3,2), nt - integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - do i=1, N_sel - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt > 3) cycle - - do j=1,N_int - perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) - perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) - end do - - call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) - call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) - - call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) - call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) - - if(nt == 3) then - call get_m2(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - else if(nt == 2) then - call get_m1(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - else - call get_m0(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - end if - end do -end subroutine - - -subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti - double precision :: hij - double precision, external :: get_phase_bi, integral8 - - integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - integer, parameter :: turn2(2) = (/2,1/) - - if(h(0,sp) == 2) then - h1 = h(1, sp) - h2 = h(2, sp) - do i=1,3 - puti = p(i, sp) - if(bannedOrb(puti)) cycle - p1 = p(turn3_2(1,i), sp) - p2 = p(turn3_2(2,i), sp) - hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) - hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) - vect(:, puti) += hij * coefs - end do - else if(h(0,sp) == 1) then - sfix = turn2(sp) - hfix = h(1,sfix) - pfix = p(1,sfix) - hmob = h(1,sp) - do j=1,2 - puti = p(j, sp) - if(bannedOrb(puti)) cycle - pmob = p(turn2(j), sp) - hij = integral8(pfix, pmob, hfix, hmob) - hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) - vect(:, puti) += hij * coefs - end do - else - puti = p(1,sp) - if(.not. bannedOrb(puti)) then - sfix = turn2(sp) - p1 = p(1,sfix) - p2 = p(2,sfix) - h1 = h(1,sfix) - h2 = h(2,sfix) - hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) - hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) - vect(:, puti) += hij * coefs - end if - end if -end subroutine - - - -subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i, hole, p1, p2, sh - logical :: ok, lbanned(mo_tot_num) - integer(bit_kind) :: det(N_int, 2) - double precision :: hij - double precision, external :: get_phase_bi, integral8 - - lbanned = bannedOrb - sh = 1 - if(h(0,2) == 1) sh = 2 - hole = h(1, sh) - lbanned(p(1,sp)) = .true. - if(p(0,sp) == 2) lbanned(p(2,sp)) = .true. - !print *, "SPm1", sp, sh - - p1 = p(1, sp) - - if(sp == sh) then - p2 = p(2, sp) - lbanned(p2) = .true. - - do i=1,hole-1 - if(lbanned(i)) cycle - hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) - hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) - vect(:,i) += hij * coefs - end do - do i=hole+1,mo_tot_num - if(lbanned(i)) cycle - hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) - hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) - vect(:,i) += hij * coefs - end do - - call apply_particle(mask, sp, p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, p2) += hij * coefs - else - p2 = p(1, sh) - do i=1,mo_tot_num - if(lbanned(i)) cycle - hij = integral8(p1, p2, i, hole) - hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) - vect(:,i) += hij * coefs - end do - end if - - call apply_particle(mask, sp, p1, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, p1) += hij * coefs -end subroutine - - -subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i - logical :: ok, lbanned(mo_tot_num) - integer(bit_kind) :: det(N_int, 2) - double precision :: hij - - lbanned = bannedOrb - lbanned(p(1,sp)) = .true. - do i=1,mo_tot_num - if(lbanned(i)) cycle - call apply_particle(mask, sp, i, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, i) += hij * coefs - end do -end subroutine - - -subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch) - use bitmasks - implicit none - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) - integer, intent(in) :: i_gen, N, sp - logical, intent(inout) :: banned(mo_tot_num) - logical, intent(out) :: fullMatch - - - integer :: i, j, na, nb, list(3), nt - integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) - - fullMatch = .false. - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - do i=1, N - nt = 0 - - do j=1, N_int - myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) - myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) - nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2)) - end do - - if(nt > 3) cycle - - if(nt <= 2 .and. i < i_gen) then - fullMatch = .true. - return - end if - - call bitstring_to_list(myMask(1,sp), list(1), na, N_int) - - if(nt == 3 .and. i < i_gen) then - do j=1,na - banned(list(j)) = .true. - end do - else if(nt == 1 .and. na == 1) then - banned(list(1)) = .true. - end if - end do -end subroutine - - - - -! Selection double -! ---------------- - -subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator - integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - - double precision :: mat(N_states, mo_tot_num, mo_tot_num) - integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii - integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) - logical :: fullMatch, ok - - integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) - integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) - integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) - - allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) - allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) - - do k=1,N_int - hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) - hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) - particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) - particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) - enddo - - integer :: N_holes(2), N_particles(2) - integer :: hole_list(N_int*bit_kind_size,2) - integer :: particle_list(N_int*bit_kind_size,2) - - call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) - call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) - - - preinteresting(0) = 0 - prefullinteresting(0) = 0 - - do i=1,N_int - negMask(i,1) = not(psi_det_generators(i,1,i_generator)) - negMask(i,2) = not(psi_det_generators(i,2,i_generator)) - end do - - do i=1,N_det - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 4) then - if(i <= N_det_selectors) then - preinteresting(0) += 1 - preinteresting(preinteresting(0)) = i - else if(nt <= 2) then - prefullinteresting(0) += 1 - prefullinteresting(prefullinteresting(0)) = i - end if - end if - end do - - - do s1=1,2 - do i1=N_holes(s1),1,-1 ! Generate low excitations first - h1 = hole_list(i1,s1) - call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) - - do i=1,N_int - negMask(i,1) = not(pmask(i,1)) - negMask(i,2) = not(pmask(i,2)) - end do - - interesting(0) = 0 - fullinteresting(0) = 0 - - do ii=1,preinteresting(0) - i = preinteresting(ii) - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 4) then - interesting(0) += 1 - interesting(interesting(0)) = i - minilist(:,:,interesting(0)) = psi_selectors(:,:,i) - if(nt <= 2) then - fullinteresting(0) += 1 - fullinteresting(fullinteresting(0)) = i - fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i) - end if - end if - end do - - do ii=1,prefullinteresting(0) - i = prefullinteresting(ii) - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 2) then - fullinteresting(0) += 1 - fullinteresting(fullinteresting(0)) = i - fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i) - end if - end do - - do s2=s1,2 - sp = s1 - if(s1 /= s2) sp = 3 - - ib = 1 - if(s1 == s2) ib = i1+1 - do i2=N_holes(s2),ib,-1 ! Generate low excitations first - - h2 = hole_list(i2,s2) - call apply_hole(pmask, s2,h2, mask, ok, N_int) - - logical :: banned(mo_tot_num, mo_tot_num,2) - logical :: bannedOrb(mo_tot_num, 2) - - banned = .false. - - call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) - - if(fullMatch) cycle - - bannedOrb(1:mo_tot_num, 1:2) = .true. - do s3=1,2 - do i=1,N_particles(s3) - bannedOrb(particle_list(i,s3), s3) = .false. - enddo - enddo - - mat = 0d0 - call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) - call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) - enddo - enddo - enddo - enddo -end subroutine - - -subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator, sp, h1, h2 - double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - 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, external :: diag_H_mat_elem_fock - - logical, external :: detEq - - - if(sp == 3) then - s1 = 1 - s2 = 2 - else - s1 = sp - s2 = sp - end if - - call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) - - do p1=1,mo_tot_num - if(bannedOrb(p1, s1)) cycle - ib = 1 - if(sp /= 3) ib = p1+1 - do p2=ib,mo_tot_num - if(bannedOrb(p2, s2)) cycle - if(banned(p1,p2)) cycle - if(mat(1, p1, p2) == 0d0) cycle - call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) -logical, external :: is_in_wavefunction -if (is_in_wavefunction(det,N_int)) then - cycle -endif - - - Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) - max_e_pert = 0d0 - - do istate=1,N_states - delta_E = E0(istate) - Hii - val = mat(istate, p1, p2) + mat(istate, p1, p2) - tmp = dsqrt(delta_E * delta_E + val * val) - if (delta_E < 0.d0) then - tmp = -tmp - endif - e_pert = 0.5d0 * ( tmp - delta_E) - pt2(istate) = pt2(istate) + e_pert - max_e_pert = min(e_pert,max_e_pert) - end do - - if(dabs(max_e_pert) > buf%mini) then - call add_to_selection_buffer(buf, det, max_e_pert) - end if - end do - end do -end subroutine - - -subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) - use bitmasks - implicit none - - integer, intent(in) :: interesting(0:N_sel) - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) - integer, intent(in) :: sp, i_gen, N_sel - logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - - integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt - integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) -! logical :: bandon -! -! bandon = .false. - mat = 0d0 - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - do i=1, N_sel ! interesting(0) - !i = interesting(ii) - - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt > 4) cycle - - do j=1,N_int - perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) - perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) - end do - - call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) - call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) - - call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) - call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) - - if(interesting(i) < i_gen) then - if(nt == 4) call past_d2(banned, p, sp) - if(nt == 3) call past_d1(bannedOrb, p) - else - if(interesting(i) == i_gen) then -! bandon = .true. - if(sp == 3) then - banned(:,:,2) = transpose(banned(:,:,1)) - else - do k=1,mo_tot_num - do l=k+1,mo_tot_num - banned(l,k,1) = banned(k,l,1) - end do - end do - end if - end if - if(nt == 4) then - call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - else if(nt == 3) then - call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - else - call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - end if - end if - end do -end subroutine - - -subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - double precision, external :: get_phase_bi, integral8 - - integer :: i, j, tip, ma, mi, puti, putj - integer :: h1, h2, p1, p2, i1, i2 - double precision :: hij, phase - - integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) - integer, parameter :: turn2(2) = (/2, 1/) - integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - - integer :: bant - bant = 1 - - tip = p(0,1) * p(0,2) - - ma = sp - if(p(0,1) > p(0,2)) ma = 1 - if(p(0,1) < p(0,2)) ma = 2 - mi = mod(ma, 2) + 1 - - if(sp == 3) then - if(ma == 2) bant = 2 - - if(tip == 3) then - puti = p(1, mi) - do i = 1, 3 - putj = p(i, ma) - if(banned(putj,puti,bant)) cycle - i1 = turn3(1,i) - i2 = turn3(2,i) - p1 = p(i1, ma) - p2 = p(i2, ma) - h1 = h(1, ma) - h2 = h(2, ma) - - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - if(ma == 1) then - mat(:, putj, puti) += coefs * hij - else - mat(:, puti, putj) += coefs * hij - end if - end do - else - do i = 1,2 - do j = 1,2 - puti = p(i, 1) - putj = p(j, 2) - - if(banned(puti,putj,bant)) cycle - p1 = p(turn2(i), 1) - p2 = p(turn2(j), 2) - h1 = h(1,1) - h2 = h(1,2) - - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end do - end do - end if - - else - if(tip == 0) then - h1 = h(1, ma) - h2 = h(2, ma) - do i=1,3 - puti = p(i, ma) - do j=i+1,4 - putj = p(j, ma) - if(banned(puti,putj,1)) cycle - - i1 = turn2d(1, i, j) - i2 = turn2d(2, i, j) - p1 = p(i1, ma) - p2 = p(i2, ma) - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end do - end do - else if(tip == 3) then - h1 = h(1, mi) - h2 = h(1, ma) - p1 = p(1, mi) - do i=1,3 - puti = p(turn3(1,i), ma) - putj = p(turn3(2,i), ma) - if(banned(puti,putj,1)) cycle - p2 = p(i, ma) - - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) - mat(:, min(puti, putj), max(puti, putj)) += coefs * hij - end do - else ! tip == 4 - puti = p(1, sp) - putj = p(2, sp) - if(.not. banned(puti,putj,1)) then - p1 = p(1, mi) - p2 = p(2, mi) - h1 = h(1, mi) - h2 = h(2, mi) - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end if - end if - end if -end subroutine - - -subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1),intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - integer(bit_kind) :: det(N_int, 2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) - double precision, external :: get_phase_bi, integral8 - - logical :: lbanned(mo_tot_num, 2), ok - integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib - - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - integer, parameter :: turn2(2) = (/2,1/) - integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - - integer :: bant - - - lbanned = bannedOrb - - do i=1, p(0,1) - lbanned(p(i,1), 1) = .true. - end do - do i=1, p(0,2) - lbanned(p(i,2), 2) = .true. - end do - - ma = 1 - if(p(0,2) >= 2) ma = 2 - mi = turn2(ma) - - bant = 1 - - if(sp == 3) then - !move MA - if(ma == 2) bant = 2 - puti = p(1,mi) - hfix = h(1,ma) - p1 = p(1,ma) - p2 = p(2,ma) - if(.not. bannedOrb(puti, mi)) then - tmp_row = 0d0 - do putj=1, hfix-1 - if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle - hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) - tmp_row(1:N_states,putj) += hij * coefs(1:N_states) - end do - do putj=hfix+1, mo_tot_num - if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle - hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) - tmp_row(1:N_states,putj) += hij * coefs(1:N_states) - end do - - if(ma == 1) then - mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) - else - mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) - end if - end if - - !MOVE MI - pfix = p(1,mi) - tmp_row = 0d0 - tmp_row2 = 0d0 - do puti=1,mo_tot_num - if(lbanned(puti,mi)) cycle - !p1 fixed - putj = p1 - if(.not. banned(putj,puti,bant)) then - hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) - tmp_row(:,puti) += hij * coefs - end if - - putj = p2 - if(.not. banned(putj,puti,bant)) then - hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) - tmp_row2(:,puti) += hij * coefs - end if - end do - - if(mi == 1) then - mat(:,:,p1) += tmp_row(:,:) - mat(:,:,p2) += tmp_row2(:,:) - else - mat(:,p1,:) += tmp_row(:,:) - mat(:,p2,:) += tmp_row2(:,:) - end if - else - if(p(0,ma) == 3) then - do i=1,3 - hfix = h(1,ma) - puti = p(i, ma) - p1 = p(turn3(1,i), ma) - p2 = p(turn3(2,i), ma) - tmp_row = 0d0 - do putj=1,hfix-1 - if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle - hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) - tmp_row(:,putj) += hij * coefs - end do - do putj=hfix+1,mo_tot_num - if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle - hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) - tmp_row(:,putj) += hij * coefs - end do - - mat(:, :puti-1, puti) += tmp_row(:,:puti-1) - mat(:, puti, puti:) += tmp_row(:,puti:) - end do - else - hfix = h(1,mi) - pfix = p(1,mi) - p1 = p(1,ma) - p2 = p(2,ma) - tmp_row = 0d0 - tmp_row2 = 0d0 - do puti=1,mo_tot_num - if(lbanned(puti,ma)) cycle - putj = p2 - if(.not. banned(puti,putj,1)) then - hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) - tmp_row(:,puti) += hij * coefs - end if - - putj = p1 - if(.not. banned(puti,putj,1)) then - hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) - tmp_row2(:,puti) += hij * coefs - end if - end do - mat(:,:p2-1,p2) += tmp_row(:,:p2-1) - mat(:,p2,p2:) += tmp_row(:,p2:) - mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) - mat(:,p1,p1:) += tmp_row2(:,p1:) - end if - end if - - !! MONO - if(sp == 3) then - s1 = 1 - s2 = 2 - else - s1 = sp - s2 = sp - end if - - do i1=1,p(0,s1) - ib = 1 - if(s1 == s2) ib = i1+1 - do i2=ib,p(0,s2) - p1 = p(i1,s1) - p2 = p(i2,s2) - if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle - call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - mat(:, p1, p2) += coefs * hij - end do - end do -end subroutine - - - - -subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - integer(bit_kind) :: det(N_int, 2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - integer :: i, j, s, h1, h2, p1, p2, puti, putj - double precision :: hij, phase - double precision, external :: get_phase_bi, integral8 - logical :: ok - - integer :: bant - bant = 1 - - - if(sp == 3) then ! AB - h1 = p(1,1) - h2 = p(1,2) - do p1=1, mo_tot_num - if(bannedOrb(p1, 1)) cycle - do p2=1, mo_tot_num - if(bannedOrb(p2,2)) cycle - if(banned(p1, p2, bant)) cycle ! rentable? - if(p1 == h1 .or. p2 == h2) then - call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - else - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - end if - mat(:, p1, p2) += coefs(:) * hij - end do - end do - else ! AA BB - p1 = p(1,sp) - p2 = p(2,sp) - do puti=1, mo_tot_num - if(bannedOrb(puti, sp)) cycle - do putj=puti+1, mo_tot_num - if(bannedOrb(putj, sp)) cycle - if(banned(puti, putj, bant)) cycle ! rentable? - if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then - call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - else - hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) - end if - mat(:, puti, putj) += coefs(:) * hij - end do - end do - end if -end subroutine - - -subroutine past_d1(bannedOrb, p) - use bitmasks - implicit none - - logical, intent(inout) :: bannedOrb(mo_tot_num, 2) - integer, intent(in) :: p(0:4, 2) - integer :: i,s - - do s = 1, 2 - do i = 1, p(0, s) - bannedOrb(p(i, s), s) = .true. - end do - end do -end subroutine - - -subroutine past_d2(banned, p, sp) - use bitmasks - implicit none - - logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) - integer, intent(in) :: p(0:4, 2), sp - integer :: i,j - - if(sp == 3) then - do i=1,p(0,1) - do j=1,p(0,2) - banned(p(i,1), p(j,2)) = .true. - end do - end do - else - do i=1,p(0, sp) - do j=1,i-1 - banned(p(j,sp), p(i,sp)) = .true. - banned(p(i,sp), p(j,sp)) = .true. - end do - end do - end if -end subroutine - - - -subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) - use bitmasks - implicit none - - integer, intent(in) :: interesting(0:N) - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) - integer, intent(in) :: i_gen, N - logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) - logical, intent(out) :: fullMatch - - - integer :: i, j, na, nb, list(3) - integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) - - fullMatch = .false. - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - genl : do i=1, N - do j=1, N_int - if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl - if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl - end do - - if(interesting(i) < i_gen) then - fullMatch = .true. - return - end if - - do j=1, N_int - myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) - myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) - end do - - call bitstring_to_list(myMask(1,1), list(1), na, N_int) - call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) - banned(list(1), list(2)) = .true. - end do genl -end subroutine - +use bitmasks + + +double precision function integral8(i,j,k,l) + implicit none + + integer, intent(in) :: i,j,k,l + double precision, external :: get_mo_bielec_integral + integer :: ii + ii = l-mo_integrals_cache_min + ii = ior(ii, k-mo_integrals_cache_min) + ii = ior(ii, j-mo_integrals_cache_min) + ii = ior(ii, i-mo_integrals_cache_min) + if (iand(ii, -64) /= 0) then + integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + else + ii = l-mo_integrals_cache_min + ii = ior( ishft(ii,6), k-mo_integrals_cache_min) + ii = ior( ishft(ii,6), j-mo_integrals_cache_min) + ii = ior( ishft(ii,6), i-mo_integrals_cache_min) + integral8 = mo_integrals_cache(ii) + endif +end function + + +BEGIN_PROVIDER [ integer(1), psi_phasemask, (N_int*bit_kind_size, 2, N_det)] + use bitmasks + implicit none + + integer :: i + do i=1, N_det + call get_mask_phase(psi_selectors(1,1,i), psi_phasemask(1,1,i)) + end do +END_PROVIDER + + +subroutine assert(cond, msg) + character(*), intent(in) :: msg + logical, intent(in) :: cond + + if(.not. cond) then + print *, "assert fail: "//msg + stop + end if +end subroutine + + +subroutine get_mask_phase(det, phasemask) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: det(N_int, 2) + integer(1), intent(out) :: phasemask(N_int*bit_kind_size, 2) + integer :: s, ni, i + logical :: change + + phasemask = 0_1 + do s=1,2 + change = .false. + do ni=1,N_int + do i=0,bit_kind_size-1 + if(BTEST(det(ni, s), i)) change = .not. change + if(change) phasemask((ni-1)*bit_kind_size + i + 1, s) = 1_1 + end do + end do + end do +end subroutine + + +subroutine select_connected(i_generator,E0,pt2,b) + use bitmasks + use selection_types + implicit none + integer, intent(in) :: i_generator + type(selection_buffer), intent(inout) :: b + double precision, intent(inout) :: pt2(N_states) + integer :: k,l + double precision, intent(in) :: E0(N_states) + + integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision :: fock_diag_tmp(2,mo_tot_num+1) + + call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) + + do l=1,N_generators_bitmask + do k=1,N_int + hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole,l), psi_det_generators(k,1,i_generator)) + hole_mask(k,2) = iand(generators_bitmask(k,2,s_hole,l), psi_det_generators(k,2,i_generator)) + particle_mask(k,1) = iand(generators_bitmask(k,1,s_part,l), not(psi_det_generators(k,1,i_generator)) ) + particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) ) + + enddo + call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) + call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) + enddo +end subroutine + + +double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) + use bitmasks + implicit none + + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + integer, intent(in) :: s1, s2, h1, h2, p1, p2 + logical :: change + integer(1) :: np + double precision, parameter :: res(0:1) = (/1d0, -1d0/) + + np = phasemask(h1,s1) + phasemask(p1,s1) + phasemask(h2,s2) + phasemask(p2,s2) + if(p1 < h1) np = np + 1_1 + if(p2 < h2) np = np + 1_1 + + if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1_1 + get_phase_bi = res(iand(np,1_1)) +end subroutine + + + +! Selection single +! ---------------- + +subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) + use bitmasks + use selection_types + implicit none + BEGIN_DOC +! Select determinants connected to i_det by H + END_DOC + integer, intent(in) :: i_gen + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + + double precision :: vect(N_states, mo_tot_num) + logical :: bannedOrb(mo_tot_num) + integer :: i, j, k + integer :: h1,h2,s1,s2,i1,i2,ib,sp + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2) + logical :: fullMatch, ok + + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2)) + enddo + + ! Create lists of holes and particles + ! ----------------------------------- + + integer :: N_holes(2), N_particles(2) + integer :: hole_list(N_int*bit_kind_size,2) + integer :: particle_list(N_int*bit_kind_size,2) + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + + do sp=1,2 + do i=1, N_holes(sp) + h1 = hole_list(i,sp) + call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int) + bannedOrb = .true. + do j=1,N_particles(sp) + bannedOrb(particle_list(j, sp)) = .false. + end do + call spot_hasBeen(mask, sp, psi_selectors, i_gen, N_det, bannedOrb, fullMatch) + if(fullMatch) cycle + vect = 0d0 + call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect) + call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) + end do + enddo +end subroutine + + +subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1 + double precision, intent(in) :: vect(N_states, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, 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, external :: diag_H_mat_elem_fock + + + call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1)) cycle + if(vect(1, p1) == 0d0) cycle + call apply_particle(mask, sp, p1, 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 + + do istate=1,N_states + val = vect(istate, p1) + vect(istate, p1) + delta_E = E0(istate) - Hii + tmp = dsqrt(delta_E * delta_E + val * val) + if (delta_E < 0.d0) then + tmp = -tmp + endif + e_pert = 0.5d0 * ( tmp - delta_E) + pt2(istate) += e_pert + if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert + end do + + if(dabs(max_e_pert) > buf%mini) then + call add_to_selection_buffer(buf, det, max_e_pert) + endif + end do +end subroutine + + +subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2, N_sel) + double precision, intent(in) :: coefs(N_states, N_sel) + integer, intent(in) :: sp, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + + integer :: i, j, h(0:2,2), p(0:3,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N_sel + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt > 3) cycle + + do j=1,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) + + call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) + + if(nt == 3) then + call get_m2(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + else if(nt == 2) then + call get_m1(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + else + call get_m0(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + end if + end do +end subroutine + + +subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti + double precision :: hij + double precision, external :: get_phase_bi, integral8 + + integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + integer, parameter :: turn2(2) = (/2,1/) + + if(h(0,sp) == 2) then + h1 = h(1, sp) + h2 = h(2, sp) + do i=1,3 + puti = p(i, sp) + if(bannedOrb(puti)) cycle + p1 = p(turn3_2(1,i), sp) + p2 = p(turn3_2(2,i), sp) + hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) + hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) + vect(:, puti) += hij * coefs + end do + else if(h(0,sp) == 1) then + sfix = turn2(sp) + hfix = h(1,sfix) + pfix = p(1,sfix) + hmob = h(1,sp) + do j=1,2 + puti = p(j, sp) + if(bannedOrb(puti)) cycle + pmob = p(turn2(j), sp) + hij = integral8(pfix, pmob, hfix, hmob) + hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) + vect(:, puti) += hij * coefs + end do + else + puti = p(1,sp) + if(.not. bannedOrb(puti)) then + sfix = turn2(sp) + p1 = p(1,sfix) + p2 = p(2,sfix) + h1 = h(1,sfix) + h2 = h(2,sfix) + hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) + hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) + vect(:, puti) += hij * coefs + end if + end if +end subroutine + + + +subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, hole, p1, p2, sh + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + double precision, external :: get_phase_bi, integral8 + + lbanned = bannedOrb + sh = 1 + if(h(0,2) == 1) sh = 2 + hole = h(1, sh) + lbanned(p(1,sp)) = .true. + if(p(0,sp) == 2) lbanned(p(2,sp)) = .true. + !print *, "SPm1", sp, sh + + p1 = p(1, sp) + + if(sp == sh) then + p2 = p(2, sp) + lbanned(p2) = .true. + + do i=1,hole-1 + if(lbanned(i)) cycle + hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) + hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + do i=hole+1,mo_tot_num + if(lbanned(i)) cycle + hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) + hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) + vect(:,i) += hij * coefs + end do + + call apply_particle(mask, sp, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p2) += hij * coefs + else + p2 = p(1, sh) + do i=1,mo_tot_num + if(lbanned(i)) cycle + hij = integral8(p1, p2, i, hole) + hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + end if + + call apply_particle(mask, sp, p1, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p1) += hij * coefs +end subroutine + + +subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + + lbanned = bannedOrb + lbanned(p(1,sp)) = .true. + do i=1,mo_tot_num + if(lbanned(i)) cycle + call apply_particle(mask, sp, i, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, i) += hij * coefs + end do +end subroutine + + +subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N, sp + logical, intent(inout) :: banned(mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3), nt + integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) + + fullMatch = .false. + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N + nt = 0 + + do j=1, N_int + myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) + myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) + nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2)) + end do + + if(nt > 3) cycle + + if(nt <= 2 .and. i < i_gen) then + fullMatch = .true. + return + end if + + call bitstring_to_list(myMask(1,sp), list(1), na, N_int) + + if(nt == 3 .and. i < i_gen) then + do j=1,na + banned(list(j)) = .true. + end do + else if(nt == 1 .and. na == 1) then + banned(list(1)) = .true. + end if + end do +end subroutine + + + + +! Selection double +! ---------------- + +subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + + double precision :: mat(N_states, mo_tot_num, mo_tot_num) + integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) + logical :: fullMatch, ok + + integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) + integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) + integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) + + allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) + allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) + enddo + + integer :: N_holes(2), N_particles(2) + integer :: hole_list(N_int*bit_kind_size,2) + integer :: particle_list(N_int*bit_kind_size,2) + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + + + preinteresting(0) = 0 + prefullinteresting(0) = 0 + + do i=1,N_int + negMask(i,1) = not(psi_det_generators(i,1,i_generator)) + negMask(i,2) = not(psi_det_generators(i,2,i_generator)) + end do + + do i=1,N_det + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + if(i <= N_det_selectors) then + preinteresting(0) += 1 + preinteresting(preinteresting(0)) = i + else if(nt <= 2) then + prefullinteresting(0) += 1 + prefullinteresting(prefullinteresting(0)) = i + end if + end if + end do + + + do s1=1,2 + do i1=N_holes(s1),1,-1 ! Generate low excitations first + h1 = hole_list(i1,s1) + call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) + + do i=1,N_int + negMask(i,1) = not(pmask(i,1)) + negMask(i,2) = not(pmask(i,2)) + end do + + interesting(0) = 0 + fullinteresting(0) = 0 + + do ii=1,preinteresting(0) + i = preinteresting(ii) + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + interesting(0) += 1 + interesting(interesting(0)) = i + minilist(:,:,interesting(0)) = psi_selectors(:,:,i) + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i) + end if + end if + end do + + do ii=1,prefullinteresting(0) + i = prefullinteresting(ii) + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i) + end if + end do + + do s2=s1,2 + sp = s1 + if(s1 /= s2) sp = 3 + + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=N_holes(s2),ib,-1 ! Generate low excitations first + + h2 = hole_list(i2,s2) + call apply_hole(pmask, s2,h2, mask, ok, N_int) + + logical :: banned(mo_tot_num, mo_tot_num,2) + logical :: bannedOrb(mo_tot_num, 2) + + banned = .false. + + call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) + + if(fullMatch) cycle + + bannedOrb(1:mo_tot_num, 1:2) = .true. + do s3=1,2 + do i=1,N_particles(s3) + bannedOrb(particle_list(i,s3), s3) = .false. + enddo + enddo + + mat = 0d0 + call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) + call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + enddo + enddo + enddo + enddo +end subroutine + + +subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1, h2 + double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + 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, external :: diag_H_mat_elem_fock + + logical, external :: detEq + + + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1, s1)) cycle + ib = 1 + if(sp /= 3) ib = p1+1 + do p2=ib,mo_tot_num + if(bannedOrb(p2, s2)) cycle + if(banned(p1,p2)) cycle + if(mat(1, p1, p2) == 0d0) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + logical, external :: is_in_wavefunction + + if (do_ddci) then + logical, external :: is_a_two_holes_two_particles + if (is_a_two_holes_two_particles(det)) then + cycle + endif + endif + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + max_e_pert = 0d0 + + do istate=1,N_states + delta_E = E0(istate) - Hii + val = mat(istate, p1, p2) + mat(istate, p1, p2) + tmp = dsqrt(delta_E * delta_E + val * val) + if (delta_E < 0.d0) then + tmp = -tmp + endif + e_pert = 0.5d0 * ( tmp - delta_E) + pt2(istate) = pt2(istate) + e_pert + max_e_pert = min(e_pert,max_e_pert) + end do + + if(dabs(max_e_pert) > buf%mini) then + call add_to_selection_buffer(buf, det, max_e_pert) + end if + end do + end do +end subroutine + + +subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N_sel) + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) + integer, intent(in) :: sp, i_gen, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + + integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) +! logical :: bandon +! +! bandon = .false. + mat = 0d0 + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N_sel ! interesting(0) + !i = interesting(ii) + + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt > 4) cycle + + do j=1,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) + + call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) + + if(interesting(i) < i_gen) then + if(nt == 4) call past_d2(banned, p, sp) + if(nt == 3) call past_d1(bannedOrb, p) + else + if(interesting(i) == i_gen) then +! bandon = .true. + if(sp == 3) then + banned(:,:,2) = transpose(banned(:,:,1)) + else + do k=1,mo_tot_num + do l=k+1,mo_tot_num + banned(l,k,1) = banned(k,l,1) + end do + end do + end if + end if + if(nt == 4) then + call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else if(nt == 3) then + call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else + call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + end if + end if + end do +end subroutine + + +subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + double precision, external :: get_phase_bi, integral8 + + integer :: i, j, tip, ma, mi, puti, putj + integer :: h1, h2, p1, p2, i1, i2 + double precision :: hij, phase + + integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) + integer, parameter :: turn2(2) = (/2, 1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + bant = 1 + + tip = p(0,1) * p(0,2) + + ma = sp + if(p(0,1) > p(0,2)) ma = 1 + if(p(0,1) < p(0,2)) ma = 2 + mi = mod(ma, 2) + 1 + + if(sp == 3) then + if(ma == 2) bant = 2 + + if(tip == 3) then + puti = p(1, mi) + do i = 1, 3 + putj = p(i, ma) + if(banned(putj,puti,bant)) cycle + i1 = turn3(1,i) + i2 = turn3(2,i) + p1 = p(i1, ma) + p2 = p(i2, ma) + h1 = h(1, ma) + h2 = h(2, ma) + + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + if(ma == 1) then + mat(:, putj, puti) += coefs * hij + else + mat(:, puti, putj) += coefs * hij + end if + end do + else + do i = 1,2 + do j = 1,2 + puti = p(i, 1) + putj = p(j, 2) + + if(banned(puti,putj,bant)) cycle + p1 = p(turn2(i), 1) + p2 = p(turn2(j), 2) + h1 = h(1,1) + h2 = h(1,2) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + end if + + else + if(tip == 0) then + h1 = h(1, ma) + h2 = h(2, ma) + do i=1,3 + puti = p(i, ma) + do j=i+1,4 + putj = p(j, ma) + if(banned(puti,putj,1)) cycle + + i1 = turn2d(1, i, j) + i2 = turn2d(2, i, j) + p1 = p(i1, ma) + p2 = p(i2, ma) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + else if(tip == 3) then + h1 = h(1, mi) + h2 = h(1, ma) + p1 = p(1, mi) + do i=1,3 + puti = p(turn3(1,i), ma) + putj = p(turn3(2,i), ma) + if(banned(puti,putj,1)) cycle + p2 = p(i, ma) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) + mat(:, min(puti, putj), max(puti, putj)) += coefs * hij + end do + else ! tip == 4 + puti = p(1, sp) + putj = p(2, sp) + if(.not. banned(puti,putj,1)) then + p1 = p(1, mi) + p2 = p(2, mi) + h1 = h(1, mi) + h2 = h(2, mi) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end if + end if + end if +end subroutine + + +subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1),intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) + double precision, external :: get_phase_bi, integral8 + + logical :: lbanned(mo_tot_num, 2), ok + integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib + + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer, parameter :: turn2(2) = (/2,1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + + + lbanned = bannedOrb + + do i=1, p(0,1) + lbanned(p(i,1), 1) = .true. + end do + do i=1, p(0,2) + lbanned(p(i,2), 2) = .true. + end do + + ma = 1 + if(p(0,2) >= 2) ma = 2 + mi = turn2(ma) + + bant = 1 + + if(sp == 3) then + !move MA + if(ma == 2) bant = 2 + puti = p(1,mi) + hfix = h(1,ma) + p1 = p(1,ma) + p2 = p(2,ma) + if(.not. bannedOrb(puti, mi)) then + tmp_row = 0d0 + do putj=1, hfix-1 + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + do putj=hfix+1, mo_tot_num + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + + if(ma == 1) then + mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) + else + mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) + end if + end if + + !MOVE MI + pfix = p(1,mi) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,mi)) cycle + !p1 fixed + putj = p1 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) + tmp_row(:,puti) += hij * coefs + end if + + putj = p2 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) + tmp_row2(:,puti) += hij * coefs + end if + end do + + if(mi == 1) then + mat(:,:,p1) += tmp_row(:,:) + mat(:,:,p2) += tmp_row2(:,:) + else + mat(:,p1,:) += tmp_row(:,:) + mat(:,p2,:) += tmp_row2(:,:) + end if + else + if(p(0,ma) == 3) then + do i=1,3 + hfix = h(1,ma) + puti = p(i, ma) + p1 = p(turn3(1,i), ma) + p2 = p(turn3(2,i), ma) + tmp_row = 0d0 + do putj=1,hfix-1 + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(:,putj) += hij * coefs + end do + do putj=hfix+1,mo_tot_num + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(:,putj) += hij * coefs + end do + + mat(:, :puti-1, puti) += tmp_row(:,:puti-1) + mat(:, puti, puti:) += tmp_row(:,puti:) + end do + else + hfix = h(1,mi) + pfix = p(1,mi) + p1 = p(1,ma) + p2 = p(2,ma) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,ma)) cycle + putj = p2 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) + tmp_row(:,puti) += hij * coefs + end if + + putj = p1 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) + tmp_row2(:,puti) += hij * coefs + end if + end do + mat(:,:p2-1,p2) += tmp_row(:,:p2-1) + mat(:,p2,p2:) += tmp_row(:,p2:) + mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) + mat(:,p1,p1:) += tmp_row2(:,p1:) + end if + end if + + !! MONO + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + do i1=1,p(0,s1) + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=ib,p(0,s2) + p1 = p(i1,s1) + p2 = p(i2,s2) + if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + mat(:, p1, p2) += coefs * hij + end do + end do +end subroutine + + + + +subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer :: i, j, s, h1, h2, p1, p2, puti, putj + double precision :: hij, phase + double precision, external :: get_phase_bi, integral8 + logical :: ok + + integer :: bant + bant = 1 + + + if(sp == 3) then ! AB + h1 = p(1,1) + h2 = p(1,2) + do p1=1, mo_tot_num + if(bannedOrb(p1, 1)) cycle + do p2=1, mo_tot_num + if(bannedOrb(p2,2)) cycle + if(banned(p1, p2, bant)) cycle ! rentable? + if(p1 == h1 .or. p2 == h2) then + call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + else + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + end if + mat(:, p1, p2) += coefs(:) * hij + end do + end do + else ! AA BB + p1 = p(1,sp) + p2 = p(2,sp) + do puti=1, mo_tot_num + if(bannedOrb(puti, sp)) cycle + do putj=puti+1, mo_tot_num + if(bannedOrb(putj, sp)) cycle + if(banned(puti, putj, bant)) cycle ! rentable? + if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then + call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + else + hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) + end if + mat(:, puti, putj) += coefs(:) * hij + end do + end do + end if +end subroutine + + +subroutine past_d1(bannedOrb, p) + use bitmasks + implicit none + + logical, intent(inout) :: bannedOrb(mo_tot_num, 2) + integer, intent(in) :: p(0:4, 2) + integer :: i,s + + do s = 1, 2 + do i = 1, p(0, s) + bannedOrb(p(i, s), s) = .true. + end do + end do +end subroutine + + +subroutine past_d2(banned, p, sp) + use bitmasks + implicit none + + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + integer, intent(in) :: p(0:4, 2), sp + integer :: i,j + + if(sp == 3) then + do i=1,p(0,1) + do j=1,p(0,2) + banned(p(i,1), p(j,2)) = .true. + end do + end do + else + do i=1,p(0, sp) + do j=1,i-1 + banned(p(j,sp), p(i,sp)) = .true. + banned(p(i,sp), p(j,sp)) = .true. + end do + end do + end if +end subroutine + + + +subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N) + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3) + integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) + + fullMatch = .false. + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + genl : do i=1, N + do j=1, N_int + if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl + if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl + end do + + if(interesting(i) < i_gen) then + fullMatch = .true. + return + end if + + do j=1, N_int + myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) + myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) + end do + + call bitstring_to_list(myMask(1,1), list(1), na, N_int) + call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) + banned(list(1), list(2)) = .true. + end do genl +end subroutine + + +subroutine ZMQ_selection(N_in, pt2) + use f77_zmq + use selection_types + + implicit none + + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + integer, intent(in) :: N_in + type(selection_buffer) :: b + integer :: i, N + integer, external :: omp_get_thread_num + double precision, intent(out) :: pt2(N_states) + integer, parameter :: maxtasks=10000 + + + N = max(N_in,1) + if (.True.) then + PROVIDE pt2_e0_denominator + provide nproc + call new_parallel_job(zmq_to_qp_run_socket,"selection") + call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) + call create_selection_buffer(N, N*2, b) + endif + + character*(20*maxtasks) :: task + task = ' ' + + integer :: k + k=0 + do i= 1, N_det_generators + k = k+1 + write(task(20*(k-1)+1:20*k),'(I9,1X,I9,''|'')') i, N + if (k>=maxtasks) then + k=0 + call add_task_to_taskserver(zmq_to_qp_run_socket,task) + endif + enddo + if (k > 0) then + call add_task_to_taskserver(zmq_to_qp_run_socket,task) + endif + call zmq_set_running(zmq_to_qp_run_socket) + + !$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) + else + call selection_slave_inproc(i) + endif + !$OMP END PARALLEL + call end_parallel_job(zmq_to_qp_run_socket, 'selection') + if (N_in > 0) then + call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN + call copy_H_apply_buffer_to_wf() + if (s2_eig) then + call make_s2_eigenfunction + endif + call save_wavefunction + endif +end subroutine + + +subroutine selection_slave_inproc(i) + implicit none + integer, intent(in) :: i + + call run_selection_slave(1,i,pt2_e0_denominator) +end + +subroutine selection_collector(b, pt2) + use f77_zmq + use selection_types + use bitmasks + implicit none + + + type(selection_buffer), intent(inout) :: b + double precision, intent(out) :: pt2(N_states) + double precision :: pt2_mwen(N_states) + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_pull_socket + integer(ZMQ_PTR) :: zmq_socket_pull + + integer :: msg_size, rc, more + integer :: acc, i, j, robin, N, ntask + double precision, allocatable :: val(:) + integer(bit_kind), allocatable :: det(:,:,:) + integer, allocatable :: task_id(:) + integer :: done + real :: time, time0 + 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)) + 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) + pt2 += pt2_mwen + 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 + + + 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/plugins/CAS_SD_ZMQ/target_pt2_ratio_cassd.irp.f b/plugins/CAS_SD_ZMQ/target_pt2_ratio_cassd.irp.f new file mode 100644 index 00000000..cf934a46 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/target_pt2_ratio_cassd.irp.f @@ -0,0 +1,109 @@ +program fci_zmq + implicit none + integer :: i,j,k + logical, external :: detEq + + double precision, allocatable :: pt2(:) + integer :: Nmin, Nmax + integer :: n_det_before, to_select + double precision :: threshold_davidson_in, ratio, E_ref + + double precision, allocatable :: psi_coef_ref(:,:) + integer(bit_kind), allocatable :: psi_det_ref(:,:,:) + + + allocate (pt2(N_states)) + + pt2 = 1.d0 + threshold_davidson_in = threshold_davidson + threshold_davidson = threshold_davidson_in * 100.d0 + SOFT_TOUCH threshold_davidson + + ! Stopping criterion is the PT2max + + double precision :: E_CI_before(N_states) + do while (dabs(pt2(1)) > pt2_max) + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + 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 *, '-----' + 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 + to_select = max(64-to_select, to_select) + call ZMQ_selection(to_select, pt2) + + PROVIDE psi_coef + PROVIDE psi_det + PROVIDE psi_det_sorted + + call diagonalize_CI + call save_wavefunction + call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) + enddo + + threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) + threshold_generators = max(threshold_generators,threshold_generators_pt2) + threshold_davidson = threshold_davidson_in + TOUCH threshold_selectors threshold_generators threshold_davidson + call diagonalize_CI + call ZMQ_selection(0, pt2) + + E_ref = CI_energy(1) + pt2(1) + print *, 'Est FCI = ', E_ref + + Nmax = N_det + Nmin = 2 + allocate (psi_coef_ref(size(psi_coef_sorted,1),size(psi_coef_sorted,2))) + allocate (psi_det_ref(N_int,2,size(psi_det_sorted,3))) + psi_coef_ref = psi_coef_sorted + psi_det_ref = psi_det_sorted + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + TOUCH psi_coef psi_det + do while (Nmax-Nmin > 1) + psi_coef = psi_coef_ref + psi_det = psi_det_ref + TOUCH psi_det psi_coef + call diagonalize_CI + ratio = (CI_energy(1) - HF_energy) / (E_ref - HF_energy) + if (ratio < var_pt2_ratio) then + Nmin = N_det + else + Nmax = N_det + psi_coef_ref = psi_coef + psi_det_ref = psi_det + TOUCH psi_det psi_coef + endif + N_det = Nmin + (Nmax-Nmin)/2 + print *, '-----' + print *, 'Det min, Det max: ', Nmin, Nmax + print *, 'Ratio : ', ratio, ' ~ ', var_pt2_ratio + print *, 'N_det = ', N_det + print *, 'E = ', CI_energy(1) + call save_wavefunction + enddo + call ZMQ_selection(0, pt2) + print *, '------' + print *, 'HF_energy = ', HF_energy + print *, 'Est FCI = ', E_ref + print *, 'E = ', CI_energy(1) + print *, 'PT2 = ', pt2(1) + print *, 'E+PT2 = ', CI_energy(1)+pt2(1) + + E_CI_before(1:N_states) = CI_energy(1:N_states) + 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/CID/.gitignore b/plugins/CID/.gitignore deleted file mode 100644 index 62ef7631..00000000 --- a/plugins/CID/.gitignore +++ /dev/null @@ -1,28 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Selectors_full -SingleRefMethod -Utils -cid -cid_lapack -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/CID_SC2_selected/.gitignore b/plugins/CID_SC2_selected/.gitignore deleted file mode 100644 index 5761c0d3..00000000 --- a/plugins/CID_SC2_selected/.gitignore +++ /dev/null @@ -1,31 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -CID -CID_selected -Determinants -Electrons -Ezfio_files -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_full -SingleRefMethod -Utils -cid_sc2_selection -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/CID_selected/.gitignore b/plugins/CID_selected/.gitignore deleted file mode 100644 index 0da32ffe..00000000 --- a/plugins/CID_selected/.gitignore +++ /dev/null @@ -1,30 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -CID -Determinants -Electrons -Ezfio_files -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_full -SingleRefMethod -Utils -cid_selection -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/CIS/.gitignore b/plugins/CIS/.gitignore deleted file mode 100644 index 9b9257d3..00000000 --- a/plugins/CIS/.gitignore +++ /dev/null @@ -1,28 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Selectors_full -SingleRefMethod -Utils -cis -ezfio_interface.irp.f -irpf90.make -irpf90_entities -super_ci -tags \ No newline at end of file diff --git a/plugins/CISD/.gitignore b/plugins/CISD/.gitignore deleted file mode 100644 index 2630f994..00000000 --- a/plugins/CISD/.gitignore +++ /dev/null @@ -1,29 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Selectors_full -SingleRefMethod -Utils -ZMQ -cisd -cisd_lapack -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/CISD_SC2_selected/.gitignore b/plugins/CISD_SC2_selected/.gitignore deleted file mode 100644 index 2f0e8bdd..00000000 --- a/plugins/CISD_SC2_selected/.gitignore +++ /dev/null @@ -1,31 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -CISD -CISD_selected -Determinants -Electrons -Ezfio_files -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_full -SingleRefMethod -Utils -cisd_sc2_selection -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/CISD_selected/.gitignore b/plugins/CISD_selected/.gitignore deleted file mode 100644 index 6145158a..00000000 --- a/plugins/CISD_selected/.gitignore +++ /dev/null @@ -1,31 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -CISD -Determinants -Electrons -Ezfio_files -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_full -SingleRefMethod -Utils -ZMQ -cisd_selection -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/Casino/.gitignore b/plugins/Casino/.gitignore deleted file mode 100644 index 14f48469..00000000 --- a/plugins/Casino/.gitignore +++ /dev/null @@ -1,23 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Utils -ezfio_interface.irp.f -irpf90.make -irpf90_entities -save_for_casino -tags \ No newline at end of file diff --git a/plugins/Casino/save_for_casino.irp.f b/plugins/Casino/save_for_casino.irp.f index 35c0c3a7..5522e578 100644 --- a/plugins/Casino/save_for_casino.irp.f +++ b/plugins/Casino/save_for_casino.irp.f @@ -5,7 +5,7 @@ subroutine save_casino integer :: getUnitAndOpen, iunit integer, allocatable :: itmp(:) integer :: n_ao_new - real, allocatable :: rtmp(:) + double precision, allocatable :: rtmp(:) PROVIDE ezfio_filename iunit = getUnitAndOpen('gwfn.data','w') diff --git a/plugins/DDCI_selected/.gitignore b/plugins/DDCI_selected/.gitignore deleted file mode 100644 index d114cb7b..00000000 --- a/plugins/DDCI_selected/.gitignore +++ /dev/null @@ -1,29 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -Generators_CAS -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_full -Utils -ddci -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/DensityMatrix/.gitignore b/plugins/DensityMatrix/.gitignore deleted file mode 100644 index 955ad80c..00000000 --- a/plugins/DensityMatrix/.gitignore +++ /dev/null @@ -1,13 +0,0 @@ -# -# Do not modify this file. Add your ignored files to the gitignore -# (without the dot at the beginning) file. -# -IRPF90_temp -IRPF90_man -irpf90.make -tags -Makefile.depend -irpf90_entities -build.ninja -.ninja_log -.ninja_deps diff --git a/plugins/FCIdump/.gitignore b/plugins/FCIdump/.gitignore deleted file mode 100644 index ec4d9d34..00000000 --- a/plugins/FCIdump/.gitignore +++ /dev/null @@ -1,24 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Utils -ZMQ -ezfio_interface.irp.f -fcidump -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/Full_CI/.gitignore b/plugins/Full_CI/.gitignore deleted file mode 100644 index 70d637ea..00000000 --- a/plugins/Full_CI/.gitignore +++ /dev/null @@ -1,34 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Davidson -Determinants -Electrons -Ezfio_files -Generators_full -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_full -Utils -ZMQ -ezfio_interface.irp.f -full_ci -full_ci_no_skip -irpf90.make -irpf90_entities -tags -target_pt2 -var_pt2_ratio \ No newline at end of file diff --git a/plugins/Full_CI/full_ci.irp.f b/plugins/Full_CI/full_ci.irp.f index a53064b4..0d816f3e 100644 --- a/plugins/Full_CI/full_ci.irp.f +++ b/plugins/Full_CI/full_ci.irp.f @@ -3,6 +3,11 @@ program full_ci integer :: i,k + print *, '====================================================================' + print *, 'This program is slow. Consider using the Full_CI_ZMQ module instead.' + print *, '====================================================================' + call sleep(2) + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) integer :: N_st, degree N_st = N_states diff --git a/plugins/Full_CI_ZMQ/.gitignore b/plugins/Full_CI_ZMQ/.gitignore deleted file mode 100644 index 7ac9fbf6..00000000 --- a/plugins/Full_CI_ZMQ/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -IRPF90_temp/ -IRPF90_man/ -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/Full_CI_ZMQ/energy.irp.f b/plugins/Full_CI_ZMQ/energy.irp.f index db1e7d1a..5f9baf46 100644 --- a/plugins/Full_CI_ZMQ/energy.irp.f +++ b/plugins/Full_CI_ZMQ/energy.irp.f @@ -1,11 +1,23 @@ +BEGIN_PROVIDER [ logical, initialize_pt2_E0_denominator ] + implicit none + BEGIN_DOC + ! If true, initialize pt2_E0_denominator + END_DOC + initialize_pt2_E0_denominator = .True. +END_PROVIDER + BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ] implicit none BEGIN_DOC ! E0 in the denominator of the PT2 END_DOC - pt2_E0_denominator(1:N_states) = CI_electronic_energy(1:N_states) + if (initialize_pt2_E0_denominator) then + pt2_E0_denominator(1:N_states) = psi_energy(1:N_states) ! pt2_E0_denominator(1:N_states) = HF_energy - nuclear_repulsion ! pt2_E0_denominator(1:N_states) = barycentric_electronic_energy(1:N_states) - call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator') + call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator') + else + pt2_E0_denominator = -huge(1.d0) + endif END_PROVIDER diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index ae0d7989..fcc38954 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -68,8 +68,8 @@ program fci_zmq call ezfio_set_full_ci_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 = 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) @@ -96,11 +96,17 @@ 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 = 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) - call ZMQ_selection(0, pt2) + double precision :: relative_error + relative_error=1.d-3 + pt2 = 0.d0 + call ZMQ_pt2(pt2,relative_error) + !call ZMQ_selection(0, pt2)! pour non-stochastic print *, 'Final step' print *, 'N_det = ', N_det print *, 'N_states = ', N_states @@ -119,122 +125,3 @@ program fci_zmq end - - -subroutine ZMQ_selection(N_in, pt2) - use f77_zmq - use selection_types - - implicit none - - character*(512) :: task - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - integer, intent(in) :: N_in - type(selection_buffer) :: b - integer :: i, N - integer, external :: omp_get_thread_num - double precision, intent(out) :: pt2(N_states) - - - if (.True.) then - PROVIDE pt2_e0_denominator - N = max(N_in,1) - provide nproc - call new_parallel_job(zmq_to_qp_run_socket,"selection") - call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) - call zmq_set_running(zmq_to_qp_run_socket) - call create_selection_buffer(N, N*2, b) - endif - - integer :: i_generator, i_generator_start, i_generator_max, step -! step = int(max(1.,10*elec_num/mo_tot_num) - - step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num )) - step = max(1,step) - do i= 1, N_det_generators,step - i_generator_start = i - i_generator_max = min(i+step-1,N_det_generators) - write(task,*) i_generator_start, i_generator_max, 1, N - call add_task_to_taskserver(zmq_to_qp_run_socket,task) - end do - - !$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) - else - call selection_slave_inproc(i) - endif - !$OMP END PARALLEL - call end_parallel_job(zmq_to_qp_run_socket, 'selection') - if (N_in > 0) then - call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN - call copy_H_apply_buffer_to_wf() - if (s2_eig) then - call make_s2_eigenfunction - endif - endif -end subroutine - - -subroutine selection_slave_inproc(i) - implicit none - integer, intent(in) :: i - - call run_selection_slave(1,i,pt2_e0_denominator) -end - -subroutine selection_collector(b, pt2) - use f77_zmq - use selection_types - use bitmasks - implicit none - - - type(selection_buffer), intent(inout) :: b - double precision, intent(out) :: pt2(N_states) - double precision :: pt2_mwen(N_states) - integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - - integer(ZMQ_PTR), external :: new_zmq_pull_socket - integer(ZMQ_PTR) :: zmq_socket_pull - - integer :: msg_size, rc, more - integer :: acc, i, j, robin, N, ntask - double precision, allocatable :: val(:) - integer(bit_kind), allocatable :: det(:,:,:) - integer, allocatable :: task_id(:) - integer :: done - real :: time, time0 - 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)) - 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) - pt2 += pt2_mwen - 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 - - - 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/plugins/Full_CI_ZMQ/pt2_slave.irp.f b/plugins/Full_CI_ZMQ/pt2_slave.irp.f new file mode 100644 index 00000000..c112e040 --- /dev/null +++ b/plugins/Full_CI_ZMQ/pt2_slave.irp.f @@ -0,0 +1,70 @@ +program pt2_slave + implicit none + BEGIN_DOC +! Helper program to compute the PT2 in distributed mode. + END_DOC + + read_wf = .False. + SOFT_TOUCH read_wf + call provide_everything + call switch_qp_run_to_master + call run_wf +end + +subroutine provide_everything + PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context +end + +subroutine run_wf + use f77_zmq + implicit none + + integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + double precision :: energy(N_states_diag) + character*(64) :: states(1) + integer :: rc, i + + call provide_everything + + zmq_context = f77_zmq_ctx_new () + states(1) = 'pt2' + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + + do + + call wait_for_states(states,zmq_state,1) + + if(trim(zmq_state) == 'Stopped') then + + exit + + else if (trim(zmq_state) == 'pt2') then + + ! Selection + ! --------- + + print *, 'PT2' + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) + + !$OMP PARALLEL PRIVATE(i) + i = omp_get_thread_num() + call pt2_slave_tcp(i, energy) + !$OMP END PARALLEL + print *, 'PT2 done' + + endif + + end do +end + +subroutine pt2_slave_tcp(i,energy) + implicit none + double precision, intent(in) :: energy(N_states_diag) + integer, intent(in) :: i + logical :: lstop + lstop = .False. + call run_pt2_slave(0,i,energy,lstop) +end + diff --git a/plugins/Full_CI_ZMQ/pt2_stoch.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch.irp.f new file mode 100644 index 00000000..914e7138 --- /dev/null +++ b/plugins/Full_CI_ZMQ/pt2_stoch.irp.f @@ -0,0 +1,38 @@ +program pt2_stoch + implicit none + read_wf = .True. + SOFT_TOUCH read_wf + PROVIDE mo_bielec_integrals_in_map + call run +end + +subroutine run + 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 + + double precision :: E_CI_before, relative_error + + allocate (pt2(N_states)) + pt2 = 0.d0 + + E_CI_before = pt2_E0_denominator(1) + nuclear_repulsion + threshold_selectors = 1.d0 + threshold_generators = 1d0 + relative_error = 1.d-3 + call ZMQ_pt2(pt2, relative_error) + print *, 'Final step' + print *, 'N_det = ', N_det + print *, 'PT2 = ', pt2 + print *, 'E = ', E_CI_before + print *, 'E+PT2 = ', E_CI_before+pt2 + print *, '-----' + call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before+pt2(1)) +end + + diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f new file mode 100644 index 00000000..9a5f2fa8 --- /dev/null +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -0,0 +1,580 @@ +BEGIN_PROVIDER [ integer, fragment_first ] + implicit none + fragment_first = first_det_of_teeth(1) +END_PROVIDER + +subroutine ZMQ_pt2(pt2,relative_error) + use f77_zmq + use selection_types + + implicit none + + character(len=64000) :: task + 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(out) :: pt2(N_states) + + + double precision, allocatable :: pt2_detail(:,:), comb(:) + logical, allocatable :: computed(:) + integer, allocatable :: tbc(:) + integer :: i, j, k, Ncomb, generator_per_task, i_generator_end + integer, external :: pt2_find + + double precision :: sumabove(comb_teeth), sum2above(comb_teeth), Nabove(comb_teeth) + double precision, external :: omp_get_wtime + double precision :: time0, time + + allocate(pt2_detail(N_states, N_det_generators), comb(N_det_generators/2), computed(N_det_generators), tbc(0:size_tbc)) + sumabove = 0d0 + sum2above = 0d0 + Nabove = 0d0 + + provide nproc fragment_first fragment_count mo_bielec_integrals_in_map mo_mono_elec_integral pt2_weight + + !call random_seed() + + computed = .false. + + tbc(0) = first_det_of_comb - 1 + do i=1, tbc(0) + tbc(i) = i + computed(i) = .true. + end do + + pt2_detail = 0d0 + time0 = omp_get_wtime() + print *, "time - avg - err - n_combs" + generator_per_task = 1 + do while(.true.) + + call write_time(6) + 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) + + call write_time(6) + + + 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) + ipos += 20 + if (ipos > 63980) then + call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos-20))) + 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-20))) + 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-20))) + 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(b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, sum2above, Nabove, relative_error, pt2) + else + call pt2_slave_inproc(i) + endif + !$OMP END PARALLEL + 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 + + deallocate(pt2_detail, comb, computed, tbc) + +end subroutine + + +subroutine do_carlo(tbc, Ncomb, comb, pt2_detail, computed, sumabove, sum2above, Nabove) + integer, intent(in) :: tbc(0:size_tbc), Ncomb + logical, intent(in) :: computed(N_det_generators) + double precision, intent(in) :: comb(Ncomb), pt2_detail(N_states, N_det_generators) + double precision, intent(inout) :: sumabove(comb_teeth), sum2above(comb_teeth), Nabove(comb_teeth) + integer :: i, dets(comb_teeth) + double precision :: myVal, myVal2 + + mainLoop : do i=1,Ncomb + call get_comb(comb(i), dets, comb_teeth) + do j=1,comb_teeth + if(.not.(computed(dets(j)))) then + exit mainLoop + end if + end do + + myVal = 0d0 + myVal2 = 0d0 + do j=comb_teeth,1,-1 + myVal += pt2_detail(1, dets(j)) * pt2_weight_inv(dets(j)) * comb_step + sumabove(j) += myVal + sum2above(j) += myVal*myVal + Nabove(j) += 1 + end do + end do mainLoop +end subroutine + + +subroutine pt2_slave_inproc(i) + implicit none + integer, intent(in) :: 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) + use f77_zmq + use selection_types + use bitmasks + implicit none + + + integer, intent(in) :: Ncomb + double precision, intent(inout) :: pt2_detail(N_states, N_det_generators) + double precision, intent(in) :: comb(Ncomb), relative_error + 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) + double precision, intent(out) :: pt2(N_states) + + + type(selection_buffer), intent(inout) :: b + double precision, allocatable :: pt2_mwen(:,:) + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_pull_socket + integer(ZMQ_PTR) :: zmq_socket_pull + + integer :: msg_size, rc, more + integer :: acc, i, j, robin, N, ntask + double precision, allocatable :: val(:) + integer(bit_kind), allocatable :: det(:,:,:) + integer, allocatable :: task_id(:) + integer :: done, Nindex + integer, allocatable :: index(:) + double precision, save :: time0 = -1.d0 + double precision :: time, timeLast + double precision, external :: omp_get_wtime + integer :: tooth, firstTBDcomb, orgTBDcomb + integer, allocatable :: parts_to_get(:) + logical, allocatable :: actually_computed(:) + + allocate(actually_computed(N_det_generators), parts_to_get(N_det_generators), & + pt2_mwen(N_states, N_det_generators) ) + do i=1,N_det_generators + actually_computed(i) = computed(i) + enddo + + parts_to_get(:) = 1 + if(fragment_first > 0) then + do i=1,fragment_first + parts_to_get(i) = fragment_count + enddo + endif + + do i=1,tbc(0) + actually_computed(tbc(i)) = .false. + end do + + orgTBDcomb = int(Nabove(1)) + firstTBDcomb = 1 + + 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), index(1)) + more = 1 + if (time0 < 0.d0) then + time0 = omp_get_wtime() + endif + timeLast = time0 + + 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) + parts_to_get(index(i)) -= 1 + if(parts_to_get(index(i)) < 0) then + print *, i, index(i), parts_to_get(index(i)), Nindex + print *, "PARTS ??" + print *, parts_to_get + stop "PARTS ??" + end if + if(parts_to_get(index(i)) == 0) actually_computed(index(i)) = .true. + 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 + + time = omp_get_wtime() + + if(time - timeLast > 1d1 .or. more /= 1) then + 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 + + 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 + call get_first_tooth(actually_computed, tooth) + + done = 0 + do i=first_det_of_teeth(tooth), first_det_of_teeth(tooth+1)-1 + if(actually_computed(i)) done = done + 1 + end do + + 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() + 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) + endif + end if + end do pullLoop + + 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 + +integer function pt2_find(v, w, sze, imin, imax) + implicit none + integer, intent(in) :: sze, imin, imax + double precision, intent(in) :: v, w(sze) + integer :: i,l,h + integer, parameter :: block=64 + + l = imin + h = imax-1 + + do while(h-l >= block) + i = ishft(h+l,-1) + if(w(i+1) > v) then + h = i-1 + else + l = i+1 + end if + end do + !DIR$ LOOP COUNT (64) + do pt2_find=l,h + if(w(pt2_find) >= v) then + exit + end if + end do +end function + + +BEGIN_PROVIDER [ integer, comb_teeth ] + implicit none + comb_teeth = 100 +END_PROVIDER + + + +subroutine get_first_tooth(computed, first_teeth) + implicit none + logical, intent(in) :: computed(N_det_generators) + integer, intent(out) :: first_teeth + integer :: i, first_det + + first_det = 1 + first_teeth = 1 + do i=first_det_of_comb, N_det_generators + if(.not.(computed(i))) then + first_det = i + exit + end if + end do + + do i=comb_teeth, 1, -1 + if(first_det_of_teeth(i) < first_det) then + first_teeth = i + exit + end if + end do + +end subroutine + + +subroutine get_last_full_tooth(computed, last_tooth) + implicit none + logical, intent(in) :: computed(N_det_generators) + integer, intent(out) :: last_tooth + integer :: i, j, missing + + 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 + do j=first_det_of_teeth(i), first_det_of_teeth(i+1)-1 + if(.not.computed(j)) then + missing -= 1 + if(missing < 0) cycle combLoop + end if + end do + last_tooth = i + exit + end do combLoop +end subroutine + + +BEGIN_PROVIDER [ integer, size_tbc ] + implicit none + BEGIN_DOC +! Size of the tbc array + END_DOC + size_tbc = N_det_generators + fragment_count*fragment_first +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 = 0 + 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) + +end subroutine + + +subroutine get_filling_teeth(computed, tbc) + implicit none + integer, intent(inout) :: tbc(0:size_tbc) + logical, intent(inout) :: computed(N_det_generators) + integer :: i, j, k, last_full, dets(comb_teeth) + + call get_last_full_tooth(computed, last_full) + if(last_full /= 0) then + if (tbc(0) > size(tbc) - first_det_of_teeth(last_full+1) -2) then + return + endif + k = tbc(0)+1 + do j=1,first_det_of_teeth(last_full+1)-1 + if(.not.(computed(j))) then + tbc(k) = j + k=k+1 + computed(j) = .true. + end if + end do + tbc(0) = k-1 + end if + +end subroutine + + +subroutine reorder_tbc(tbc) + implicit none + integer, intent(inout) :: tbc(0:size_tbc) + logical, allocatable :: ltbc(:) + integer :: i, ci + + allocate(ltbc(size_tbc)) + ltbc(:) = .false. + do i=1,tbc(0) + ltbc(tbc(i)) = .true. + end do + + ci = 0 + do i=1,size_tbc + if(ltbc(i)) then + ci = ci+1 + tbc(ci) = i + end if + end do +end subroutine + + +subroutine get_comb(stato, dets, ct) + implicit none + integer, intent(in) :: ct + double precision, intent(in) :: stato + integer, intent(out) :: dets(ct) + double precision :: curs + integer :: j + integer, external :: pt2_find + + curs = 1d0 - stato + do j = comb_teeth, 1, -1 + !DIR$ FORCEINLINE + dets(j) = pt2_find(curs, pt2_cweight,size(pt2_cweight), first_det_of_teeth(j), first_det_of_teeth(j+1)) + curs -= comb_step + end do +end subroutine + + +subroutine add_comb(comb, computed, tbc, stbc, ct) + implicit none + integer, intent(in) :: stbc, ct + double precision, intent(in) :: comb + logical, intent(inout) :: computed(N_det_generators) + integer, intent(inout) :: tbc(0:stbc) + integer :: i, k, l, dets(ct) + + !DIR$ FORCEINLINE + call get_comb(comb, dets, ct) + + k=tbc(0)+1 + do i = 1, ct + l = dets(i) + if(.not.(computed(l))) then + tbc(k) = l + k = k+1 + computed(l) = .true. + end if + end do + tbc(0) = k-1 +end subroutine + + + + BEGIN_PROVIDER [ double precision, pt2_weight, (N_det_generators) ] +&BEGIN_PROVIDER [ double precision, pt2_cweight, (N_det_generators) ] +&BEGIN_PROVIDER [ double precision, pt2_cweight_cache, (N_det_generators) ] +&BEGIN_PROVIDER [ double precision, comb_step ] +&BEGIN_PROVIDER [ integer, first_det_of_teeth, (comb_teeth+1) ] +&BEGIN_PROVIDER [ integer, first_det_of_comb ] + implicit none + integer :: i + double precision :: norm_left, stato + integer, external :: pt2_find + + pt2_weight(1) = psi_coef_generators(1,1)**2 + pt2_cweight(1) = psi_coef_generators(1,1)**2 + + do i=2,N_det_generators + pt2_weight(i) = psi_coef_generators(i,1)**2 + pt2_cweight(i) = pt2_cweight(i-1) + psi_coef_generators(i,1)**2 + end do + + do i=1,N_det_generators + pt2_weight(i) = pt2_weight(i) / pt2_cweight(N_det_generators) + pt2_cweight(i) = pt2_cweight(i) / pt2_cweight(N_det_generators) + enddo + + norm_left = 1d0 + + 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 + first_det_of_comb = i + exit + end if + norm_left -= pt2_weight(i) + end do + + comb_step = (1d0 - pt2_cweight(first_det_of_comb-1)) * comb_step + + stato = 1d0 - comb_step + iloc = N_det_generators + do i=comb_teeth, 1, -1 + integer :: iloc + iloc = pt2_find(stato, pt2_cweight, N_det_generators, 1, iloc) + first_det_of_teeth(i) = iloc + stato -= comb_step + end do + first_det_of_teeth(comb_teeth+1) = N_det_generators + 1 + first_det_of_teeth(1) = first_det_of_comb + if(first_det_of_teeth(1) /= first_det_of_comb) then + print *, 'Error in ', irp_here + stop "comb provider" + endif + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, pt2_weight_inv, (N_det_generators) ] + implicit none + BEGIN_DOC +! Inverse of pt2_weight array + END_DOC + integer :: i + do i=1,N_det_generators + pt2_weight_inv(i) = 1.d0/pt2_weight(i) + enddo + +END_PROVIDER + + + + + + diff --git a/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f b/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f new file mode 100644 index 00000000..5a246319 --- /dev/null +++ b/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f @@ -0,0 +1,172 @@ + +subroutine run_pt2_slave(thread,iproc,energy) + use f77_zmq + use selection_types + implicit none + + double precision, intent(in) :: energy(N_states_diag) + integer, intent(in) :: thread, iproc + integer :: rc, i + + integer :: worker_id, task_id(1), ctask, ltask + character*(512) :: task + + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_push_socket + integer(ZMQ_PTR) :: zmq_socket_push + + type(selection_buffer) :: buf, buf2 + logical :: done + + double precision :: pt2(N_states) + double precision,allocatable :: pt2_detail(:,:) + integer :: index + integer :: Nindex + + allocate(pt2_detail(N_states, N_det_generators)) + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_push = new_zmq_push_socket(thread) + call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) + if(worker_id == -1) then + print *, "WORKER -1" + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_push_socket(zmq_socket_push,thread) + return + end if + buf%N = 0 + ctask = 1 + Nindex=1 + pt2 = 0d0 + pt2_detail = 0d0 + do + call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task) + + done = task_id(ctask) == 0 + if (done) then + ctask = ctask - 1 + else + integer :: i_generator, i_i_generator, N, 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??" + end if + do i_i_generator=1, Nindex + i_generator = index + call select_connected(i_generator,energy,pt2_detail(1, i_i_generator),buf,subset) + pt2(:) += pt2_detail(:, i_generator) + enddo + endif + + 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 + end if + ctask = 0 + end if + + if(done) exit + ctask = ctask + 1 + end do + call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_push_socket(zmq_socket_push,thread) +end subroutine + + +subroutine push_pt2_results(zmq_socket_push, N, index, pt2_detail, task_id, ntask) + use f77_zmq + use selection_types + implicit none + + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + double precision, intent(in) :: pt2_detail(N_states, N_det_generators) + integer, intent(in) :: ntask, N, index, task_id(*) + integer :: rc + + + rc = f77_zmq_send( zmq_socket_push, N, 4, ZMQ_SNDMORE) + if(rc /= 4) stop "push" + + rc = f77_zmq_send( zmq_socket_push, index, 4, ZMQ_SNDMORE) + if(rc /= 4*N) stop "push" + + + rc = f77_zmq_send( zmq_socket_push, pt2_detail, 8*N_states*N, ZMQ_SNDMORE) + if(rc /= 8*N_states*N) stop "push" + + rc = f77_zmq_send( zmq_socket_push, ntask, 4, ZMQ_SNDMORE) + if(rc /= 4) stop "push" + + rc = f77_zmq_send( zmq_socket_push, task_id, ntask*4, 0) + 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) +end subroutine + + +subroutine pull_pt2_results(zmq_socket_pull, N, index, pt2_detail, task_id, ntask) + use f77_zmq + use selection_types + implicit none + integer(ZMQ_PTR), intent(in) :: zmq_socket_pull + double precision, intent(inout) :: pt2_detail(N_states, N_det_generators) + integer, intent(out) :: index + integer, intent(out) :: N, ntask, task_id(*) + integer :: rc, rn, i + + rc = f77_zmq_recv( zmq_socket_pull, N, 4, 0) + if(rc /= 4) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, index, 4, 0) + if(rc /= 4*N) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, pt2_detail, N_states*8*N, 0) + if(rc /= 8*N_states*N) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, ntask, 4, 0) + if(rc /= 4) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, task_id, ntask*4, 0) + if(rc /= 4*ntask) stop "pull" + +! 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 + + +BEGIN_PROVIDER [ double precision, pt2_workload, (N_det_generators) ] + integer :: i + do i=1,N_det_generators + pt2_workload(i) = dfloat(N_det_generators - i + 1)**2 + end do + pt2_workload = pt2_workload / sum(pt2_workload) +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 dfaee629..bfc099e2 100644 --- a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f @@ -26,7 +26,6 @@ subroutine run_selection_slave(thread,iproc,energy) call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) if(worker_id == -1) then print *, "WORKER -1" - !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) return @@ -41,20 +40,16 @@ subroutine run_selection_slave(thread,iproc,energy) if (done) then ctask = ctask - 1 else - integer :: i_generator, i_generator_start, i_generator_max, step, N - read (task,*) i_generator_start, i_generator_max, step, N + integer :: i_generator, N + read(task,*) i_generator, N if(buf%N == 0) then ! Only first time call create_selection_buffer(N, N*2, buf) - call create_selection_buffer(N, N*3, buf2) + call create_selection_buffer(N, N*2, buf2) else if(N /= buf%N) stop "N changed... wtf man??" end if - !print *, "psi_selectors_coef ", psi_selectors_coef(N_det_selectors-5:N_det_selectors, 1) - !call debug_det(psi_selectors(1,1,N_det_selectors), N_int) - do i_generator=i_generator_start,i_generator_max,step - call select_connected(i_generator,energy,pt2,buf) - enddo + call select_connected(i_generator,energy,pt2,buf,0) endif if(done .or. ctask == size(task_id)) then @@ -66,8 +61,10 @@ subroutine run_selection_slave(thread,iproc,energy) 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 sort_selection_buffer(buf2) buf%mini = buf2%mini pt2 = 0d0 buf%cur = 0 @@ -115,7 +112,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 @@ -149,7 +146,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/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index b0078b18..c277cf58 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -1,5 +1,13 @@ use bitmasks +BEGIN_PROVIDER [ integer, fragment_count ] + implicit none + BEGIN_DOC + ! Number of fragments for the deterministic part + END_DOC + fragment_count = (elec_alpha_num-n_core_orb)**2 +END_PROVIDER + double precision function integral8(i,j,k,l) implicit none @@ -39,7 +47,7 @@ subroutine assert(cond, msg) logical, intent(in) :: cond if(.not. cond) then - print *, "assert fail: "//msg + print *, "assert failed: "//msg stop end if end subroutine @@ -50,7 +58,7 @@ subroutine get_mask_phase(det, phasemask) implicit none integer(bit_kind), intent(in) :: det(N_int, 2) - integer(1), intent(out) :: phasemask(N_int*bit_kind_size, 2) + integer(1), intent(out) :: phasemask(2,N_int*bit_kind_size) integer :: s, ni, i logical :: change @@ -60,18 +68,18 @@ subroutine get_mask_phase(det, phasemask) do ni=1,N_int do i=0,bit_kind_size-1 if(BTEST(det(ni, s), i)) change = .not. change - if(change) phasemask((ni-1)*bit_kind_size + i + 1, s) = 1_1 + if(change) phasemask(s, (ni-1)*bit_kind_size + i + 1) = 1_1 end do end do end do end subroutine -subroutine select_connected(i_generator,E0,pt2,b) +subroutine select_connected(i_generator,E0,pt2,b,subset) use bitmasks use selection_types implicit none - integer, intent(in) :: i_generator + integer, intent(in) :: i_generator, subset type(selection_buffer), intent(inout) :: b double precision, intent(inout) :: pt2(N_states) integer :: k,l @@ -90,8 +98,7 @@ subroutine select_connected(i_generator,E0,pt2,b) particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) ) enddo - call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) - call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) + call select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b,subset) enddo end subroutine @@ -100,186 +107,30 @@ double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) use bitmasks implicit none - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + integer(1), intent(in) :: phasemask(2,*) integer, intent(in) :: s1, s2, h1, h2, p1, p2 logical :: change - integer(1) :: np - double precision, parameter :: res(0:1) = (/1d0, -1d0/) + integer(1) :: np1 + integer :: np + double precision, save :: res(0:1) = (/1d0, -1d0/) - np = phasemask(h1,s1) + phasemask(p1,s1) + phasemask(h2,s2) + phasemask(p2,s2) - if(p1 < h1) np = np + 1_1 - if(p2 < h2) np = np + 1_1 + np1 = phasemask(s1,h1) + phasemask(s1,p1) + phasemask(s2,h2) + phasemask(s2,p2) + np = np1 + if(p1 < h1) np = np + 1 + if(p2 < h2) np = np + 1 - if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1_1 - get_phase_bi = res(iand(np,1_1)) -end function + if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1 + get_phase_bi = res(iand(np,1)) +end -! Selection single -! ---------------- - -subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) - use bitmasks - use selection_types - implicit none - BEGIN_DOC -! Select determinants connected to i_det by H - END_DOC - integer, intent(in) :: i_gen - integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - - double precision :: vect(N_states, mo_tot_num) - logical :: bannedOrb(mo_tot_num) - integer :: i, j, k - integer :: h1,h2,s1,s2,i1,i2,ib,sp - integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2) - logical :: fullMatch, ok - - - do k=1,N_int - hole (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1)) - hole (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2)) - particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1)) - particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2)) - enddo - - ! Create lists of holes and particles - ! ----------------------------------- - - integer :: N_holes(2), N_particles(2) - integer :: hole_list(N_int*bit_kind_size,2) - integer :: particle_list(N_int*bit_kind_size,2) - - call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) - call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) - - do sp=1,2 - do i=1, N_holes(sp) - h1 = hole_list(i,sp) - call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int) - bannedOrb = .true. - do j=1,N_particles(sp) - bannedOrb(particle_list(j, sp)) = .false. - end do - call spot_hasBeen(mask, sp, psi_det_sorted, i_gen, N_det, bannedOrb, fullMatch) - if(fullMatch) cycle - vect = 0d0 - call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect) - call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) - end do - enddo -end subroutine - - -subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator, sp, h1 - double precision, intent(in) :: vect(N_states, mo_tot_num) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - logical :: ok - integer :: s1, s2, p1, p2, ib, 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, external :: diag_H_mat_elem_fock - - - call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int) - - do p1=1,mo_tot_num - if(bannedOrb(p1)) cycle - if(vect(1, p1) == 0d0) cycle - call apply_particle(mask, sp, p1, 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 - - do istate=1,N_states - val = vect(istate, p1) + vect(istate, p1) - delta_E = E0(istate) - Hii - tmp = dsqrt(delta_E * delta_E + val * val) - if (delta_E < 0.d0) then - tmp = -tmp - endif - e_pert = 0.5d0 * ( tmp - delta_E) - pt2(istate) += e_pert - if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert - end do - - if(dabs(max_e_pert) > buf%mini) call add_to_selection_buffer(buf, det, max_e_pert) - end do -end subroutine - - -subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect) - use bitmasks - implicit none - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2, N_sel) - double precision, intent(in) :: coefs(N_states, N_sel) - integer, intent(in) :: sp, N_sel - logical, intent(inout) :: bannedOrb(mo_tot_num) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - - integer :: i, j, h(0:2,2), p(0:3,2), nt - integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - do i=1, N_sel - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt > 3) cycle - - do j=1,N_int - perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) - perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) - end do - - call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) - call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) - - call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) - call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) - - if(nt == 3) then - call get_m2(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - else if(nt == 2) then - call get_m1(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - else - call get_m0(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - end if - end do -end subroutine - - subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) use bitmasks implicit none integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) logical, intent(in) :: bannedOrb(mo_tot_num) double precision, intent(in) :: coefs(N_states) double precision, intent(inout) :: vect(N_states, mo_tot_num) @@ -329,7 +180,7 @@ subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) vect(:, puti) += hij * coefs end if end if -end subroutine +end @@ -338,7 +189,7 @@ subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) implicit none integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) logical, intent(in) :: bannedOrb(mo_tot_num) double precision, intent(in) :: coefs(N_states) double precision, intent(inout) :: vect(N_states, mo_tot_num) @@ -392,7 +243,7 @@ subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) call apply_particle(mask, sp, p1, det, ok, N_int) call i_h_j(gen, det, N_int, hij) vect(:, p1) += hij * coefs -end subroutine +end subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) @@ -400,7 +251,7 @@ subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) implicit none integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) logical, intent(in) :: bannedOrb(mo_tot_num) double precision, intent(in) :: coefs(N_states) double precision, intent(inout) :: vect(N_states, mo_tot_num) @@ -418,69 +269,14 @@ subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) call i_h_j(gen, det, N_int, hij) vect(:, i) += hij * coefs end do -end subroutine +end - -subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch) - use bitmasks - implicit none - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) - integer, intent(in) :: i_gen, N, sp - logical, intent(inout) :: banned(mo_tot_num) - logical, intent(out) :: fullMatch - - - integer :: i, j, na, nb, list(3), nt - integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) - - fullMatch = .false. - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - genl : do i=1, N - nt = 0 - - do j=1, N_int - myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) - myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) - nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2)) - end do - - if(nt > 3) cycle - - if(nt <= 2 .and. i < i_gen) then - fullMatch = .true. - return - end if - - call bitstring_to_list(myMask(1,sp), list(1), na, N_int) - - if(nt == 3 .and. i < i_gen) then - do j=1,na - banned(list(j)) = .true. - end do - else if(nt == 1 .and. na == 1) then - banned(list(1)) = .true. - end if - end do genl -end subroutine - - - - -! Selection double -! ---------------- - -subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) +subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf,subset) use bitmasks use selection_types implicit none - integer, intent(in) :: i_generator + integer, intent(in) :: i_generator, subset integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) double precision, intent(in) :: fock_diag_tmp(mo_tot_num) double precision, intent(in) :: E0(N_states) @@ -496,6 +292,14 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) + logical :: monoAdo, monoBdo; + integer :: maskInd + + PROVIDE fragment_count + + monoAdo = .true. + monoBdo = .true. + allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) @@ -513,7 +317,24 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) +! ! ====== +! ! If the subset doesn't exist, return +! logical :: will_compute +! will_compute = subset == 0 +! +! if (.not.will_compute) then +! maskInd = N_holes(1)*N_holes(2) + N_holes(2)*((N_holes(2)-1)/2) + N_holes(1)*((N_holes(1)-1)/2) +! will_compute = (maskInd >= subset) +! if (.not.will_compute) then +! return +! endif +! endif +! ! ====== + + integer(bit_kind), allocatable:: preinteresting_det(:,:,:) + allocate (preinteresting_det(N_int,2,N_det)) + preinteresting(0) = 0 prefullinteresting(0) = 0 @@ -523,17 +344,23 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p end do do i=1,N_det - nt = 0 - do j=1,N_int + mobMask(1,1) = iand(negMask(1,1), psi_det_sorted(1,1,i)) + mobMask(1,2) = iand(negMask(1,2), psi_det_sorted(1,2,i)) + nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) + do j=2,N_int mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + nt = nt + popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) end do if(nt <= 4) then if(i <= N_det_selectors) then preinteresting(0) += 1 preinteresting(preinteresting(0)) = i + do j=1,N_int + preinteresting_det(j,1,preinteresting(0)) = psi_det_sorted(j,1,i) + preinteresting_det(j,2,preinteresting(0)) = psi_det_sorted(j,2,i) + enddo else if(nt <= 2) then prefullinteresting(0) += 1 prefullinteresting(prefullinteresting(0)) = i @@ -541,37 +368,48 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p end if end do - + + maskInd = -1 + integer :: nb_count do s1=1,2 do i1=N_holes(s1),1,-1 ! Generate low excitations first h1 = hole_list(i1,s1) call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) - do i=1,N_int - negMask(i,1) = not(pmask(i,1)) - negMask(i,2) = not(pmask(i,2)) - end do + negMask = not(pmask) interesting(0) = 0 fullinteresting(0) = 0 do ii=1,preinteresting(0) i = preinteresting(ii) - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + mobMask(1,1) = iand(negMask(1,1), preinteresting_det(1,1,ii)) + mobMask(1,2) = iand(negMask(1,2), preinteresting_det(1,2,ii)) + nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) + do j=2,N_int + mobMask(j,1) = iand(negMask(j,1), preinteresting_det(j,1,ii)) + mobMask(j,2) = iand(negMask(j,2), preinteresting_det(j,2,ii)) + nt = nt+ popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) end do if(nt <= 4) then interesting(0) += 1 interesting(interesting(0)) = i - minilist(:,:,interesting(0)) = psi_det_sorted(:,:,i) + minilist(1,1,interesting(0)) = preinteresting_det(1,1,ii) + minilist(1,2,interesting(0)) = preinteresting_det(1,2,ii) + do j=2,N_int + minilist(j,1,interesting(0)) = preinteresting_det(j,1,ii) + minilist(j,2,interesting(0)) = preinteresting_det(j,2,ii) + enddo if(nt <= 2) then fullinteresting(0) += 1 fullinteresting(fullinteresting(0)) = i - fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) + fullminilist(1,1,fullinteresting(0)) = preinteresting_det(1,1,ii) + fullminilist(1,2,fullinteresting(0)) = preinteresting_det(1,2,ii) + do j=2,N_int + fullminilist(j,1,fullinteresting(0)) = preinteresting_det(j,1,ii) + fullminilist(j,2,fullinteresting(0)) = preinteresting_det(j,2,ii) + enddo end if end if end do @@ -579,56 +417,83 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p do ii=1,prefullinteresting(0) i = prefullinteresting(ii) nt = 0 - do j=1,N_int + mobMask(1,1) = iand(negMask(1,1), psi_det_sorted(1,1,i)) + mobMask(1,2) = iand(negMask(1,2), psi_det_sorted(1,2,i)) + nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) + do j=2,N_int mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + nt = nt+ popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) end do if(nt <= 2) then fullinteresting(0) += 1 fullinteresting(fullinteresting(0)) = i - fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) + fullminilist(1,1,fullinteresting(0)) = psi_det_sorted(1,1,i) + fullminilist(1,2,fullinteresting(0)) = psi_det_sorted(1,2,i) + do j=2,N_int + fullminilist(j,1,fullinteresting(0)) = psi_det_sorted(j,1,i) + fullminilist(j,2,fullinteresting(0)) = psi_det_sorted(j,2,i) + enddo end if end do + + do s2=s1,2 sp = s1 + if(s1 /= s2) sp = 3 ib = 1 if(s1 == s2) ib = i1+1 + monoAdo = .true. do i2=N_holes(s2),ib,-1 ! Generate low excitations first - - h2 = hole_list(i2,s2) - call apply_hole(pmask, s2,h2, mask, ok, N_int) - logical :: banned(mo_tot_num, mo_tot_num,2) logical :: bannedOrb(mo_tot_num, 2) + h2 = hole_list(i2,s2) + call apply_hole(pmask, s2,h2, mask, ok, N_int) banned = .false. - - call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) - - if(fullMatch) cycle - - bannedOrb(1:mo_tot_num, 1:2) = .true. + do j=1,mo_tot_num + bannedOrb(j, 1) = .true. + bannedOrb(j, 2) = .true. + enddo do s3=1,2 do i=1,N_particles(s3) bannedOrb(particle_list(i,s3), s3) = .false. enddo enddo - - mat = 0d0 - call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) - call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + if(s1 /= s2) then + if(monoBdo) then + bannedOrb(h1,s1) = .false. + end if + if(monoAdo) then + bannedOrb(h2,s2) = .false. + monoAdo = .false. + end if + end if + + maskInd += 1 + if(subset == 0 .or. mod(maskInd, fragment_count) == (subset-1)) then + + call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) + if(fullMatch) cycle + + mat = 0d0 + call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) + + call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + end if enddo + if(s1 /= s2) monoBdo = .false. enddo enddo enddo end subroutine + subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) use bitmasks use selection_types @@ -670,7 +535,6 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d if(mat(1, p1, p2) == 0d0) cycle 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 @@ -679,11 +543,12 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d val = mat(istate, p1, p2) + mat(istate, p1, p2) tmp = dsqrt(delta_E * delta_E + val * val) if (delta_E < 0.d0) then - tmp = -tmp + tmp = -tmp endif e_pert = 0.5d0 * ( tmp - delta_E) pt2(istate) = pt2(istate) + e_pert max_e_pert = min(e_pert,max_e_pert) +! ci(istate) = e_pert / mat(istate, p1, p2) end do if(dabs(max_e_pert) > buf%mini) then @@ -691,18 +556,17 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d end if end do end do -end subroutine +end subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) use bitmasks implicit none - integer, intent(in) :: interesting(0:N_sel) - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) - integer, intent(in) :: sp, i_gen, N_sel - logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) + integer, intent(in) :: sp, i_gen, N_sel + integer, intent(in) :: interesting(0:N_sel) + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) + logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt @@ -710,6 +574,7 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere ! logical :: bandon ! ! bandon = .false. + PROVIDE psi_phasemask psi_selectors_coef_transp mat = 0d0 do i=1,N_int @@ -719,35 +584,32 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere do i=1, N_sel ! interesting(0) !i = interesting(ii) + if (interesting(i) < 0) then + stop 'prefetch interesting(i)' + endif + - nt = 0 - do j=1,N_int + mobMask(1,1) = iand(negMask(1,1), det(1,1,i)) + mobMask(1,2) = iand(negMask(1,2), det(1,2,i)) + nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) + + if(nt > 4) cycle + + do j=2,N_int mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + nt = nt + popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) end do if(nt > 4) cycle - do j=1,N_int - perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) - perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) - end do - - call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) - call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) - - call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) - call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) - - if(interesting(i) < i_gen) then - if(nt == 4) call past_d2(banned, p, sp) - if(nt == 3) call past_d1(bannedOrb, p) - else - if(interesting(i) == i_gen) then -! bandon = .true. + if (interesting(i) == i_gen) then if(sp == 3) then - banned(:,:,2) = transpose(banned(:,:,1)) + do j=1,mo_tot_num + do k=1,mo_tot_num + banned(j,k,2) = banned(k,j,1) + enddo + enddo else do k=1,mo_tot_num do l=k+1,mo_tot_num @@ -755,17 +617,35 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere end do end do end if - end if - if(nt == 4) then - call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - else if(nt == 3) then - call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - else - call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - end if + end if + + call bitstring_to_list_in_selection(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list_in_selection(mobMask(1,2), p(1,2), p(0,2), N_int) + + perMask(1,1) = iand(mask(1,1), not(det(1,1,i))) + perMask(1,2) = iand(mask(1,2), not(det(1,2,i))) + do j=2,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list_in_selection(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list_in_selection(perMask(1,2), h(1,2), h(0,2), N_int) + + if (interesting(i) >= i_gen) then + if(nt == 4) then + call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else if(nt == 3) then + call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else + call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + end if + else + if(nt == 4) call past_d2(banned, p, sp) + if(nt == 3) call past_d1(bannedOrb, p) end if end do -end subroutine +end subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) @@ -773,7 +653,7 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) implicit none integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) double precision, intent(in) :: coefs(N_states) double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) @@ -822,20 +702,20 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) end if end do else - do i = 1,2 + h1 = h(1,1) + h2 = h(1,2) do j = 1,2 - puti = p(i, 1) putj = p(j, 2) - - if(banned(puti,putj,bant)) cycle - p1 = p(turn2(i), 1) p2 = p(turn2(j), 2) - h1 = h(1,1) - h2 = h(1,2) - - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end do + do i = 1,2 + puti = p(i, 1) + + if(banned(puti,putj,bant)) cycle + p1 = p(turn2(i), 1) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do end do end if @@ -883,7 +763,7 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) end if end if end if -end subroutine +end subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) @@ -891,7 +771,7 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) implicit none integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1),intent(in) :: phasemask(N_int*bit_kind_size, 2) + integer(1),intent(in) :: phasemask(2,N_int*bit_kind_size) logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) integer(bit_kind) :: det(N_int, 2) double precision, intent(in) :: coefs(N_states) @@ -1050,7 +930,7 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) mat(:, p1, p2) += coefs * hij end do end do -end subroutine +end @@ -1060,7 +940,7 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) implicit none integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) integer(bit_kind) :: det(N_int, 2) double precision, intent(in) :: coefs(N_states) @@ -1088,8 +968,8 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) call i_h_j(gen, det, N_int, hij) else - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + hij = integral8(p1, p2, h1, h2) * phase end if mat(:, p1, p2) += coefs(:) * hij end do @@ -1112,7 +992,7 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) end do end do end if -end subroutine +end subroutine past_d1(bannedOrb, p) @@ -1128,7 +1008,7 @@ subroutine past_d1(bannedOrb, p) bannedOrb(p(i, s), s) = .true. end do end do -end subroutine +end subroutine past_d2(banned, p, sp) @@ -1153,7 +1033,7 @@ subroutine past_d2(banned, p, sp) end do end do end if -end subroutine +end @@ -1161,9 +1041,9 @@ subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) use bitmasks implicit none + integer, intent(in) :: i_gen, N integer, intent(in) :: interesting(0:N) integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) - integer, intent(in) :: i_gen, N logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) logical, intent(out) :: fullMatch @@ -1194,9 +1074,37 @@ subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) end do - call bitstring_to_list(myMask(1,1), list(1), na, N_int) - call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) + call bitstring_to_list_in_selection(myMask(1,1), list(1), na, N_int) + call bitstring_to_list_in_selection(myMask(1,2), list(na+1), nb, N_int) banned(list(1), list(2)) = .true. end do genl -end subroutine +end + +subroutine bitstring_to_list_in_selection( string, list, n_elements, Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Gives the inidices(+1) of the bits set to 1 in the bit string + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: string(Nint) + integer, intent(out) :: list(Nint*bit_kind_size) + integer, intent(out) :: n_elements + + integer :: i, ishift + integer(bit_kind) :: l + + n_elements = 0 + ishift = 2 + do i=1,Nint + l = string(i) + do while (l /= 0_bit_kind) + n_elements = n_elements+1 + list(n_elements) = ishift+popcnt(l-1_bit_kind) - popcnt(l) + l = iand(l,l-1_bit_kind) + enddo + ishift = ishift + bit_kind_size + enddo + +end diff --git a/plugins/Full_CI_ZMQ/selection_buffer.irp.f b/plugins/Full_CI_ZMQ/selection_buffer.irp.f index 2bcb11d3..8a067357 100644 --- a/plugins/Full_CI_ZMQ/selection_buffer.irp.f +++ b/plugins/Full_CI_ZMQ/selection_buffer.irp.f @@ -27,7 +27,7 @@ subroutine add_to_selection_buffer(b, det, val) if(dabs(val) >= b%mini) then b%cur += 1 - b%det(:,:,b%cur) = det(:,:) + b%det(1:N_int,1:2,b%cur) = det(1:N_int,1:2) b%val(b%cur) = val if(b%cur == size(b%val)) then call sort_selection_buffer(b) @@ -41,29 +41,32 @@ subroutine sort_selection_buffer(b) implicit none type(selection_buffer), intent(inout) :: b - double precision, allocatable :: vals(:), absval(:) + double precision, allocatable:: absval(:) integer, allocatable :: iorder(:) - integer(bit_kind), allocatable :: detmp(:,:,:) + 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, nmwen), absval(b%cur), vals(nmwen)) + 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)) do i=1,b%cur iorder(i) = i end do call dsort(absval, iorder, b%cur) - do i=1, nmwen - detmp(:,:,i) = b%det(:,:,iorder(i)) + 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 - b%det(:,:,:nmwen) = detmp(:,:,:) - b%det(:,:,nmwen+1:) = 0_bit_kind - b%val(:nmwen) = vals(:) - b%val(nmwen+1:) = 0d0 + do i=nmwen+1, size(vals) + vals(i) = 0.d0 + enddo + deallocate(b%det, b%val) + b%det => detmp + b%val => vals b%mini = max(b%mini,dabs(b%val(b%N))) b%cur = nmwen end subroutine diff --git a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f index d6204cc3..306320f7 100644 --- a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f @@ -12,8 +12,8 @@ program selection_slave end subroutine provide_everything - PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context mo_mono_elec_integral -! PROVIDE pt2_e0_denominator mo_tot_num N_int + PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context + PROVIDE pt2_e0_denominator mo_tot_num N_int fragment_count end subroutine run_wf @@ -23,7 +23,7 @@ subroutine run_wf integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket double precision :: energy(N_states) - character*(64) :: states(2) + character*(64) :: states(4) integer :: rc, i call provide_everything @@ -31,6 +31,7 @@ subroutine run_wf zmq_context = f77_zmq_ctx_new () states(1) = 'selection' states(2) = 'davidson' + states(3) = 'pt2' zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() @@ -52,7 +53,7 @@ subroutine run_wf !$OMP PARALLEL PRIVATE(i) i = omp_get_thread_num() - call selection_slave_tcp(i, energy) + call run_selection_slave(0,i,energy) !$OMP END PARALLEL print *, 'Selection done' @@ -62,46 +63,29 @@ subroutine run_wf ! -------- print *, 'Davidson' - call davidson_miniserver_get() + call davidson_slave_tcp(i) + print *, 'Davidson done' + + else if (trim(zmq_state) == 'pt2') then + + ! PT2 + ! --- + + print *, 'PT2' + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) + + logical :: lstop + lstop = .False. !$OMP PARALLEL PRIVATE(i) i = omp_get_thread_num() - call davidson_slave_tcp(i) + call run_pt2_slave(0,i,energy,lstop) !$OMP END PARALLEL - print *, 'Davidson done' + print *, 'PT2 done' endif end do end -subroutine update_energy(energy) - implicit none - double precision, intent(in) :: energy(N_states) - BEGIN_DOC -! Update energy when it is received from ZMQ - END_DOC - integer :: j,k - do j=1,N_states - do k=1,N_det - CI_eigenvectors(k,j) = psi_coef(k,j) - enddo - enddo - call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int) - if (.True.) then - do k=1,N_states - ci_electronic_energy(k) = energy(k) - enddo - TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors - endif - call write_double(6,ci_energy,'Energy') -end - -subroutine selection_slave_tcp(i,energy) - implicit none - double precision, intent(in) :: energy(N_states) - integer, intent(in) :: i - - call run_selection_slave(0,i,energy) -end diff --git a/plugins/Full_CI_ZMQ/selection_slave.irp.f b/plugins/Full_CI_ZMQ/selection_slave.irp.f index 657ad63c..92c6b775 100644 --- a/plugins/Full_CI_ZMQ/selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_slave.irp.f @@ -13,7 +13,7 @@ end subroutine provide_everything PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context - PROVIDE pt2_e0_denominator mo_tot_num N_int + PROVIDE pt2_e0_denominator mo_tot_num N_int fragment_count end subroutine run_wf @@ -60,28 +60,6 @@ subroutine run_wf end do end -subroutine update_energy(energy) - implicit none - double precision, intent(in) :: energy(N_states) - BEGIN_DOC -! Update energy when it is received from ZMQ - END_DOC - integer :: j,k - do j=1,N_states - do k=1,N_det - CI_eigenvectors(k,j) = psi_coef(k,j) - enddo - enddo - call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int) - if (.True.) then - do k=1,N_states - ci_electronic_energy(k) = energy(k) - enddo - TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors - endif - - call write_double(6,ci_energy,'Energy') -end subroutine selection_slave_tcp(i,energy) implicit none diff --git a/plugins/Full_CI_ZMQ/selection_types.f90 b/plugins/Full_CI_ZMQ/selection_types.f90 index 9506629c..29e48524 100644 --- a/plugins/Full_CI_ZMQ/selection_types.f90 +++ b/plugins/Full_CI_ZMQ/selection_types.f90 @@ -1,9 +1,9 @@ module selection_types type selection_buffer integer :: N, cur - integer(8), allocatable :: det(:,:,:) - double precision, allocatable :: val(:) - double precision :: mini + integer(8) , pointer :: det(:,:,:) + double precision, pointer :: val(:) + double precision :: mini endtype end module diff --git a/plugins/Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f b/plugins/Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f new file mode 100644 index 00000000..04a1d9d4 --- /dev/null +++ b/plugins/Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f @@ -0,0 +1,109 @@ +program fci_zmq + implicit none + integer :: i,j,k + logical, external :: detEq + + double precision, allocatable :: pt2(:) + integer :: Nmin, Nmax + integer :: n_det_before, to_select + double precision :: threshold_davidson_in, ratio, E_ref + + double precision, allocatable :: psi_coef_ref(:,:) + integer(bit_kind), allocatable :: psi_det_ref(:,:,:) + + + allocate (pt2(N_states)) + + pt2 = 1.d0 + threshold_davidson_in = threshold_davidson + threshold_davidson = threshold_davidson_in * 100.d0 + SOFT_TOUCH threshold_davidson + + ! Stopping criterion is the PT2max + + double precision :: E_CI_before(N_states) + do while (dabs(pt2(1)) > pt2_max) + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + 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 *, '-----' + 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(64-to_select, to_select) + call ZMQ_selection(to_select, pt2) + + PROVIDE psi_coef + PROVIDE psi_det + PROVIDE psi_det_sorted + + call diagonalize_CI + call save_wavefunction + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + enddo + + threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) + threshold_generators = max(threshold_generators,threshold_generators_pt2) + threshold_davidson = threshold_davidson_in + TOUCH threshold_selectors threshold_generators threshold_davidson + call diagonalize_CI + call ZMQ_selection(0, pt2) + + E_ref = CI_energy(1) + pt2(1) + print *, 'Est FCI = ', E_ref + + Nmax = N_det + Nmin = 2 + allocate (psi_coef_ref(size(psi_coef_sorted,1),size(psi_coef_sorted,2))) + allocate (psi_det_ref(N_int,2,size(psi_det_sorted,3))) + psi_coef_ref = psi_coef_sorted + psi_det_ref = psi_det_sorted + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + TOUCH psi_coef psi_det + do while (Nmax-Nmin > 1) + psi_coef = psi_coef_ref + psi_det = psi_det_ref + TOUCH psi_det psi_coef + call diagonalize_CI + ratio = (CI_energy(1) - HF_energy) / (E_ref - HF_energy) + if (ratio < var_pt2_ratio) then + Nmin = N_det + else + Nmax = N_det + psi_coef_ref = psi_coef + psi_det_ref = psi_det + TOUCH psi_det psi_coef + endif + N_det = Nmin + (Nmax-Nmin)/2 + print *, '-----' + print *, 'Det min, Det max: ', Nmin, Nmax + print *, 'Ratio : ', ratio, ' ~ ', var_pt2_ratio + print *, 'N_det = ', N_det + print *, 'E = ', CI_energy(1) + call save_wavefunction + enddo + call ZMQ_selection(0, pt2) + print *, '------' + print *, 'HF_energy = ', HF_energy + print *, 'Est FCI = ', E_ref + print *, 'E = ', CI_energy(1) + print *, 'PT2 = ', pt2(1) + print *, 'E+PT2 = ', CI_energy(1)+pt2(1) + + E_CI_before(1:N_states) = CI_energy(1:N_states) + 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/plugins/Full_CI_ZMQ/target_pt2_zmq.irp.f b/plugins/Full_CI_ZMQ/target_pt2_zmq.irp.f new file mode 100644 index 00000000..52f825f1 --- /dev/null +++ b/plugins/Full_CI_ZMQ/target_pt2_zmq.irp.f @@ -0,0 +1,95 @@ +program fci_zmq + implicit none + integer :: i,j,k + logical, external :: detEq + + double precision, allocatable :: pt2(:) + integer :: Nmin, Nmax + integer :: n_det_before, to_select + double precision :: threshold_davidson_in, ratio, E_ref, pt2_ratio + + allocate (pt2(N_states)) + + pt2 = 1.d0 + threshold_davidson_in = threshold_davidson + threshold_davidson = threshold_davidson_in * 100.d0 + SOFT_TOUCH threshold_davidson + + double precision :: E_CI_before(N_states) + do while (dabs(pt2(1)) > pt2_max) + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + 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 *, '-----' + 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(64-to_select, to_select) + call ZMQ_selection(to_select, pt2) + + PROVIDE psi_coef + PROVIDE psi_det + PROVIDE psi_det_sorted + + call diagonalize_CI + call save_wavefunction + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + enddo + + threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) + threshold_generators = max(threshold_generators,threshold_generators_pt2) + threshold_davidson = threshold_davidson_in + TOUCH threshold_selectors threshold_generators threshold_davidson + call diagonalize_CI + call ZMQ_selection(0, pt2) + + E_ref = CI_energy(1) + pt2(1) + pt2_ratio = (E_ref + pt2_max - HF_energy) / (E_ref - HF_energy) + print *, 'Est FCI = ', E_ref + + Nmax = N_det + Nmin = N_det/8 + do while (Nmax-Nmin > 1) + call diagonalize_CI + ratio = (CI_energy(1) - HF_energy) / (E_ref - HF_energy) + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + TOUCH psi_coef psi_det + if (ratio < pt2_ratio) then + Nmin = N_det + to_select = (Nmax-Nmin)/2 + call ZMQ_selection(to_select, pt2) + else + Nmax = N_det + N_det = Nmin + (Nmax-Nmin)/2 + endif + print *, '-----' + print *, 'Det min, Det max: ', Nmin, Nmax + print *, 'Ratio : ', ratio, ' ~ ', pt2_ratio + print *, 'HF_energy = ', HF_energy + print *, 'Est FCI = ', E_ref + print *, 'N_det = ', N_det + print *, 'E = ', CI_energy(1) + print *, 'PT2 = ', pt2(1) + enddo + call ZMQ_selection(0, pt2) + print *, '------' + print *, 'E = ', CI_energy(1) + print *, 'PT2 = ', pt2(1) + + E_CI_before(1:N_states) = CI_energy(1:N_states) + 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/plugins/Full_CI_ZMQ/zmq_selection.irp.f b/plugins/Full_CI_ZMQ/zmq_selection.irp.f new file mode 100644 index 00000000..7ffb4a44 --- /dev/null +++ b/plugins/Full_CI_ZMQ/zmq_selection.irp.f @@ -0,0 +1,126 @@ +subroutine ZMQ_selection(N_in, pt2) + use f77_zmq + use selection_types + + implicit none + + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + integer, intent(in) :: N_in + type(selection_buffer) :: b + integer :: i, N + integer, external :: omp_get_thread_num + double precision, intent(out) :: pt2(N_states) + integer, parameter :: maxtasks=10000 + + + PROVIDE fragment_count + + N = max(N_in,1) + if (.True.) then + PROVIDE pt2_e0_denominator + provide nproc + call new_parallel_job(zmq_to_qp_run_socket,"selection") + call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) + call create_selection_buffer(N, N*2, b) + endif + + character*(20*maxtasks) :: task + task = ' ' + + integer :: k + k=0 + do i= 1, N_det_generators + k = k+1 + write(task(20*(k-1)+1:20*k),'(I9,1X,I9,''|'')') i, N + if (k>=maxtasks) then + k=0 + call add_task_to_taskserver(zmq_to_qp_run_socket,task) + endif + end do + if (k > 0) then + call add_task_to_taskserver(zmq_to_qp_run_socket,task) + endif + call zmq_set_running(zmq_to_qp_run_socket) + + !$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) + else + call selection_slave_inproc(i) + endif + !$OMP END PARALLEL + call end_parallel_job(zmq_to_qp_run_socket, 'selection') + if (N_in > 0) then + call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) + call copy_H_apply_buffer_to_wf() + if (s2_eig) then + call make_s2_eigenfunction + endif + call save_wavefunction + endif + +end subroutine + + +subroutine selection_slave_inproc(i) + implicit none + integer, intent(in) :: i + + call run_selection_slave(1,i,pt2_e0_denominator) +end + +subroutine selection_collector(b, pt2) + use f77_zmq + use selection_types + use bitmasks + implicit none + + + type(selection_buffer), intent(inout) :: b + double precision, intent(out) :: pt2(N_states) + double precision :: pt2_mwen(N_states) + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_pull_socket + integer(ZMQ_PTR) :: zmq_socket_pull + + integer :: msg_size, rc, more + integer :: acc, i, j, robin, N, ntask + double precision, allocatable :: val(:) + integer(bit_kind), allocatable :: det(:,:,:) + integer, allocatable :: task_id(:) + integer :: done + real :: time, time0 + 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)) + 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) + pt2 += pt2_mwen + 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 + + + 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/plugins/Generators_CAS/.gitignore b/plugins/Generators_CAS/.gitignore deleted file mode 100644 index 1b17a42a..00000000 --- a/plugins/Generators_CAS/.gitignore +++ /dev/null @@ -1,23 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Ezfio_files -Determinants -Integrals_Monoelec -MO_Basis -Utils -Pseudo -Bitmask -AO_Basis -Electrons -Nuclei -Integrals_Bielec \ No newline at end of file diff --git a/plugins/Generators_full/.gitignore b/plugins/Generators_full/.gitignore deleted file mode 100644 index 8d85dede..00000000 --- a/plugins/Generators_full/.gitignore +++ /dev/null @@ -1,25 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Ezfio_files -Determinants -Integrals_Monoelec -MO_Basis -Utils -Pseudo -Bitmask -AO_Basis -Electrons -MOGuess -Nuclei -Hartree_Fock -Integrals_Bielec \ No newline at end of file diff --git a/plugins/Generators_restart/.gitignore b/plugins/Generators_restart/.gitignore deleted file mode 100644 index 955ad80c..00000000 --- a/plugins/Generators_restart/.gitignore +++ /dev/null @@ -1,13 +0,0 @@ -# -# Do not modify this file. Add your ignored files to the gitignore -# (without the dot at the beginning) file. -# -IRPF90_temp -IRPF90_man -irpf90.make -tags -Makefile.depend -irpf90_entities -build.ninja -.ninja_log -.ninja_deps diff --git a/plugins/Hartree_Fock/.gitignore b/plugins/Hartree_Fock/.gitignore deleted file mode 100644 index 9f1c0929..00000000 --- a/plugins/Hartree_Fock/.gitignore +++ /dev/null @@ -1,25 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Electrons -Ezfio_files -Huckel_guess -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -SCF -Utils -ZMQ -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/Hartree_Fock/localize_mos.irp.f b/plugins/Hartree_Fock/localize_mos.irp.f new file mode 100644 index 00000000..8a665c64 --- /dev/null +++ b/plugins/Hartree_Fock/localize_mos.irp.f @@ -0,0 +1,75 @@ +program localize_mos + implicit none + integer :: rank, i,j,k + double precision, allocatable :: W(:,:) + double precision :: f, f_incr + + allocate (W(ao_num,ao_num)) + + W = 0.d0 + do k=1,elec_beta_num + do j=1,ao_num + do i=1,ao_num + W(i,j) = W(i,j) + mo_coef(i,k) * mo_coef(j,k) + enddo + enddo + enddo + +! call svd_mo(ao_num,elec_beta_num,W, size(W,1), & +! mo_coef(1,1),size(mo_coef,1)) + call cholesky_mo(ao_num,elec_beta_num,W, size(W,1), & + mo_coef(1,1),size(mo_coef,1),1.d-6,rank) + print *, rank + + if (elec_alpha_num>elec_alpha_num) then + W = 0.d0 + do k=elec_beta_num+1,elec_alpha_num + do j=1,ao_num + do i=1,ao_num + W(i,j) = W(i,j) + mo_coef(i,k) * mo_coef(j,k) + enddo + enddo + enddo + +! call svd_mo(ao_num,elec_alpha_num-elec_beta_num,W, size(W,1), & +! mo_coef(1,1),size(mo_coef,1)) + call cholesky_mo(ao_num,elec_alpha_num-elec_beta_num,W, size(W,1), & + mo_coef(1,elec_beta_num+1),size(mo_coef,1),1.d-6,rank) + print *, rank + endif + + W = 0.d0 + do k=elec_alpha_num+1,mo_tot_num + do j=1,ao_num + do i=1,ao_num + W(i,j) = W(i,j) + mo_coef(i,k) * mo_coef(j,k) + enddo + enddo + enddo + +! call svd_mo(ao_num,mo_tot_num-elec_alpha_num,W, size(W,1), & +! mo_coef(1,1),size(mo_coef,1)) + call cholesky_mo(ao_num,mo_tot_num-elec_alpha_num,W, size(W,1), & + mo_coef(1,elec_alpha_num+1),size(mo_coef,1),1.d-6,rank) + print *, rank + mo_label = "Localized" + + TOUCH mo_coef + + W(1:ao_num,1:mo_tot_num) = mo_coef(1:ao_num,1:mo_tot_num) + integer :: iorder(mo_tot_num) + double precision :: s(mo_tot_num), swap(ao_num) + do k=1,mo_tot_num + iorder(k) = k + s(k) = Fock_matrix_diag_mo(k) + enddo + call dsort(s(1),iorder(1),elec_beta_num) + call dsort(s(elec_beta_num+1),iorder(elec_beta_num+1),elec_alpha_num-elec_beta_num) + call dsort(s(elec_alpha_num+1),iorder(elec_alpha_num+1),mo_tot_num-elec_alpha_num) + do k=1,mo_tot_num + mo_coef(1:ao_num,k) = W(1:ao_num,iorder(k)) + print *, k, s(k) + enddo + call save_mos + +end diff --git a/plugins/MP2/.gitignore b/plugins/MP2/.gitignore deleted file mode 100644 index 82d50427..00000000 --- a/plugins/MP2/.gitignore +++ /dev/null @@ -1,31 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_full -SingleRefMethod -Utils -ZMQ -ezfio_interface.irp.f -irpf90.make -irpf90_entities -mp2 -mp2_wf -tags \ No newline at end of file diff --git a/plugins/MRCC_Utils/.gitignore b/plugins/MRCC_Utils/.gitignore deleted file mode 100644 index 7a0dd517..00000000 --- a/plugins/MRCC_Utils/.gitignore +++ /dev/null @@ -1,33 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Davidson -Determinants -Electrons -Ezfio_files -Generators_full -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Psiref_CAS -Psiref_Utils -Selectors_full -Utils -ZMQ -ezfio_interface.irp.f -irpf90.make -irpf90_entities -mrcc_dummy -tags \ No newline at end of file diff --git a/plugins/MRCC_Utils/H_apply.irp.f b/plugins/MRCC_Utils/H_apply.irp.f index 4d8964bf..d8dfb62d 100644 --- a/plugins/MRCC_Utils/H_apply.irp.f +++ b/plugins/MRCC_Utils/H_apply.irp.f @@ -31,7 +31,7 @@ s.set_perturbation("epstein_nesbet_2x2") s.unset_openmp() print s -s = H_apply_zmq("mrcepa_PT2") +s = H_apply("mrcepa_PT2") s.energy = "psi_energy" s.set_perturbation("epstein_nesbet_2x2") s.unset_openmp() diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index f9cb51ad..1dcf2a2b 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -23,33 +23,39 @@ allocate(pathTo(N_det_non_ref)) pathTo(:) = 0 - is_active_exc(:) = .false. + is_active_exc(:) = .True. n_exc_active = 0 - do hh = 1, hh_shortcut(0) - do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 - do II = 1, N_det_ref +! do hh = 1, hh_shortcut(0) +! do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 +! do II = 1, N_det_ref +! +! call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) +! if(.not. ok) cycle +! +! call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) +! if(.not. ok) cycle +! +! ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) +! if(ind == -1) cycle +! +! logical, external :: is_a_two_holes_two_particles +! if (is_a_two_holes_two_particles(myDet)) then +! is_active_exc(pp) = .False. +! endif - call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) - if(.not. ok) cycle +! ind = psi_non_ref_sorted_idx(ind) +! if(pathTo(ind) == 0) then +! pathTo(ind) = pp +! else +! is_active_exc(pp) = .true. +! is_active_exc(pathTo(ind)) = .true. +! end if - call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) - if(.not. ok) cycle +! end do +! end do +! end do - ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) - if(ind == -1) cycle - - ind = psi_non_ref_sorted_idx(ind) - if(pathTo(ind) == 0) then - pathTo(ind) = pp - else - is_active_exc(pp) = .true. - is_active_exc(pathTo(ind)) = .true. - end if - end do - end do - end do -!is_active_exc=.true. do hh = 1, hh_shortcut(0) do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 if(is_active_exc(pp)) then @@ -66,6 +72,32 @@ END_PROVIDER +BEGIN_PROVIDER [ logical, has_a_unique_parent, (N_det_non_ref) ] + implicit none + BEGIN_DOC + ! True if the determinant in the non-reference has a unique parent + END_DOC + integer :: i,j,n + integer :: degree + do j=1,N_det_non_ref + has_a_unique_parent(j) = .True. + n=0 + do i=1,N_det_ref + call get_excitation_degree(psi_ref(1,1,i), psi_non_ref(1,1,j), degree, N_int) + if (degree < 2) then + n = n+1 + if (n > 1) then + has_a_unique_parent(j) = .False. + exit + endif + endif + enddo + enddo + +END_PROVIDER + + + BEGIN_PROVIDER [ integer, n_exc_active_sze ] implicit none BEGIN_DOC @@ -89,14 +121,13 @@ END_PROVIDER double precision :: phase logical :: ok integer, external :: searchDet - - PROVIDE psi_non_ref_sorted_idx psi_ref_coef + !$OMP PARALLEL default(none) shared(psi_non_ref, hh_exists, pp_exists, N_int,& !$OMP active_excitation_to_determinants_val, active_excitation_to_determinants_idx)& !$OMP shared(hh_shortcut, psi_ref_coef, N_det_non_ref, psi_non_ref_sorted, & !$OMP psi_non_ref_sorted_idx, psi_ref, N_det_ref, N_states)& - !$OMP shared(is_active_exc, active_hh_idx, active_pp_idx, n_exc_active)& + !$OMP shared(active_hh_idx, active_pp_idx, n_exc_active)& !$OMP private(lref, pp, II, ok, myMask, myDet, ind, phase, wk, ppp, hh, s) allocate(lref(N_det_non_ref)) !$OMP DO schedule(dynamic) @@ -127,7 +158,6 @@ END_PROVIDER wk += 1 do s=1,N_states active_excitation_to_determinants_val(s,wk, ppp) = psi_ref_coef(lref(i), s) - enddo active_excitation_to_determinants_idx(wk, ppp) = i else if(lref(i) < 0) then @@ -160,7 +190,7 @@ END_PROVIDER double precision, allocatable :: t(:), A_val_mwen(:,:), As2_val_mwen(:,:) integer, allocatable :: A_ind_mwen(:) double precision :: sij - PROVIDE psi_non_ref active_excitation_to_determinants_val + PROVIDE psi_non_ref mrcc_AtA_ind(:) = 0 mrcc_AtA_val(:,:) = 0.d0 @@ -168,6 +198,7 @@ END_PROVIDER mrcc_N_col(:) = 0 AtA_size = 0 + !$OMP PARALLEL default(none) shared(k, active_excitation_to_determinants_idx,& !$OMP active_excitation_to_determinants_val, hh_nex) & !$OMP private(at_row, a_col, t, i, r1, r2, wk, A_ind_mwen, A_val_mwen,& diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 6bdadb24..436b89a4 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -35,21 +35,20 @@ subroutine davidson_diag_mrcc(dets_in,u_in,energies,dim_in,sze,N_st,N_st_diag,Ni PROVIDE mo_bielec_integrals_in_map allocate(H_jj(sze)) + H_jj(1) = diag_h_mat_elem(dets_in(1,1,1),Nint) !$OMP PARALLEL DEFAULT(NONE) & !$OMP SHARED(sze,H_jj,N_det_ref,dets_in,Nint,istate,delta_ii,idx_ref) & !$OMP PRIVATE(i) - !$OMP DO SCHEDULE(guided) - do i=1,sze + !$OMP DO + do i=2,sze H_jj(i) = diag_h_mat_elem(dets_in(1,1,i),Nint) enddo !$OMP END DO - !$OMP DO SCHEDULE(guided) - do i=1,N_det_ref - H_jj(idx_ref(i)) += delta_ii(istate,i) - enddo - !$OMP END DO !$OMP END PARALLEL + do i=1,N_det_ref + H_jj(idx_ref(i)) += delta_ii(istate,i) + enddo call davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit,istate) deallocate (H_jj) end @@ -224,17 +223,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s W(i,k,iter+1) = 0.d0 enddo enddo -! do k=1,N_st_diag -! do iter2=1,iter -! do l=1,N_st_diag -! do i=1,sze -! U(i,k,iter+1) = U(i,k,iter+1) + U(i,l,iter2)*y(l,iter2,k,1) -! W(i,k,iter+1) = W(i,k,iter+1) + W(i,l,iter2)*y(l,iter2,k,1) -! enddo -! enddo -! enddo -! enddo -! ! call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, & 1.d0, U, size(U,1), y, size(y,1)*size(y,2), 0.d0, U(1,1,iter+1), size(U,1)) @@ -276,27 +264,11 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s do k=1,N_st_diag -! do iter2=1,iter -! do l=1,N_st_diag -! c(1) = u_dot_v(U(1,k,iter+1),U(1,l,iter2),sze) -! do i=1,sze -! U(i,k,iter+1) = U(i,k,iter+1) - c(1) * U(i,l,iter2) -! enddo -! enddo -! enddo -! call dgemv('T',sze,N_st_diag*iter,1.d0,U,size(U,1), & U(1,k,iter+1),1,0.d0,c,1) call dgemv('N',sze,N_st_diag*iter,-1.d0,U,size(U,1), & c,1,1.d0,U(1,k,iter+1),1) -! -! do l=1,k-1 -! c(1) = u_dot_v(U(1,k,iter+1),U(1,l,iter+1),sze) -! do i=1,sze -! U(i,k,iter+1) = U(i,k,iter+1) - c(1) * U(i,l,iter+1) -! enddo -! enddo -! + call dgemv('T',sze,k-1,1.d0,U(1,1,iter+1),size(U,1), & U(1,k,iter+1),1,0.d0,c,1) call dgemv('N',sze,k-1,-1.d0,U(1,1,iter+1),size(U,1), & @@ -429,7 +401,7 @@ subroutine H_u_0_mrcc_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,istate_in,N_st,sze_8) allocate(vt(sze_8,N_st)) Vt = 0.d0 - !$OMP DO SCHEDULE(dynamic) + !$OMP DO SCHEDULE(static,1) do sh=1,shortcut(0,1) do sh2=sh,shortcut(0,1) exa = 0 @@ -468,9 +440,9 @@ subroutine H_u_0_mrcc_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,istate_in,N_st,sze_8) enddo enddo enddo - !$OMP END DO NOWAIT + !$OMP END DO - !$OMP DO SCHEDULE(dynamic) + !$OMP DO SCHEDULE(static,1) do sh=1,shortcut(0,2) do i=shortcut(sh,2),shortcut(sh+1,2)-1 org_i = sort_idx(i,2) @@ -490,7 +462,7 @@ subroutine H_u_0_mrcc_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,istate_in,N_st,sze_8) end do end do enddo - !$OMP END DO NOWAIT + !$OMP END DO !$OMP DO do ii=1,n_det_ref @@ -505,13 +477,12 @@ subroutine H_u_0_mrcc_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,istate_in,N_st,sze_8) enddo !$OMP END DO - !$OMP CRITICAL do istate=1,N_st do i=n,1,-1 + !$OMP ATOMIC v_0(i,istate) = v_0(i,istate) + vt(i,istate) enddo enddo - !$OMP END CRITICAL deallocate(vt) !$OMP END PARALLEL @@ -559,25 +530,26 @@ subroutine davidson_diag_mrcc_hs2(dets_in,u_in,dim_in,energies,sze,N_st,N_st_dia ASSERT (sze > 0) ASSERT (Nint > 0) ASSERT (Nint == N_int) - PROVIDE mo_bielec_integrals_in_map + PROVIDE mo_bielec_integrals_in_map allocate(H_jj(sze), S2_jj(sze)) + H_jj(1) = diag_h_mat_elem(dets_in(1,1,1),Nint) + call get_s2(dets_in(1,1,1),dets_in(1,1,1),Nint,S2_jj(1)) !$OMP PARALLEL DEFAULT(NONE) & !$OMP SHARED(sze,H_jj,S2_jj, dets_in,Nint,N_det_ref,delta_ii, & !$OMP idx_ref, istate) & !$OMP PRIVATE(i) - !$OMP DO SCHEDULE(guided) - do i=1,sze + !$OMP DO + do i=2,sze H_jj(i) = diag_h_mat_elem(dets_in(1,1,i),Nint) call get_s2(dets_in(1,1,i),dets_in(1,1,i),Nint,S2_jj(i)) enddo !$OMP END DO - !$OMP DO SCHEDULE(guided) + !$OMP END PARALLEL + do i=1,N_det_ref H_jj(idx_ref(i)) += delta_ii(istate,i) enddo - !$OMP END DO - !$OMP END PARALLEL call davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit,istate) deallocate (H_jj,S2_jj) @@ -1094,6 +1066,7 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i enddo enddo !$OMP END DO + !$OMP DO SCHEDULE(guided) do sh=1,shortcut(0,2) do i=shortcut(sh,2),shortcut(sh+1,2)-1 @@ -1142,14 +1115,14 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i ! End Specific to dressing ! ------------------------ - !$OMP CRITICAL do istate=1,N_st do i=n,1,-1 + !$OMP ATOMIC v_0(i,istate) = v_0(i,istate) + vt(istate,i) + !$OMP ATOMIC s_0(i,istate) = s_0(i,istate) + st(istate,i) enddo enddo - !$OMP END CRITICAL deallocate(vt,st) !$OMP END PARALLEL diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index d6b9cc79..41435688 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -5,6 +5,7 @@ use bitmasks END_PROVIDER + BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states, N_det_non_ref) ] &BEGIN_PROVIDER [ integer, lambda_mrcc_pt2, (0:psi_det_size) ] &BEGIN_PROVIDER [ integer, lambda_mrcc_kept, (0:psi_det_size) ] @@ -62,6 +63,65 @@ END_PROVIDER END_PROVIDER +! BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states, N_det_non_ref) ] +!&BEGIN_PROVIDER [ integer, lambda_mrcc_pt2, (0:psi_det_size) ] +!&BEGIN_PROVIDER [ integer, lambda_mrcc_kept, (0:psi_det_size) ] +!&BEGIN_PROVIDER [ double precision, lambda_pert, (N_states, N_det_non_ref) ] +! implicit none +! BEGIN_DOC +! ! cm/ or perturbative 1/Delta_E(m) +! END_DOC +! integer :: i,k +! double precision :: ihpsi_current(N_states) +! integer :: i_pert_count +! double precision :: hii, E2(N_states), E2var(N_states) +! integer :: N_lambda_mrcc_pt2, N_lambda_mrcc_pt3 +! +! i_pert_count = 0 +! lambda_mrcc = 0.d0 +! N_lambda_mrcc_pt2 = 0 +! N_lambda_mrcc_pt3 = 0 +! lambda_mrcc_pt2(0) = 0 +! lambda_mrcc_kept(0) = 0 +! +! E2 = 0.d0 +! E2var = 0.d0 +! do i=1,N_det_non_ref +! call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref,& +! size(psi_ref_coef,1), N_states,ihpsi_current) +! call i_H_j(psi_non_ref(1,1,i),psi_non_ref(1,1,i),N_int,hii) +! do k=1,N_states +! if (ihpsi_current(k) == 0.d0) then +! ihpsi_current(k) = 1.d-32 +! endif +! lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k) +! lambda_pert(k,i) = 1.d0 / (psi_ref_energy_diagonalized(k)-hii) +! E2(k) += ihpsi_current(k)*ihpsi_current(k) / (psi_ref_energy_diagonalized(k)-hii) +! E2var(k) += ihpsi_current(k) * psi_non_ref_coef(i,k) +! enddo +! enddo +! +! do i=1,N_det_non_ref +! call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref,& +! size(psi_ref_coef,1), N_states,ihpsi_current) +! call i_H_j(psi_non_ref(1,1,i),psi_non_ref(1,1,i),N_int,hii) +! do k=1,N_states +! if (ihpsi_current(k) == 0.d0) then +! ihpsi_current(k) = 1.d-32 +! endif +! lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k) +! lambda_pert(k,i) = 1.d0 / (psi_ref_energy_diagonalized(k)-hii) * E2var(k)/E2(k) +! enddo +! enddo +! lambda_mrcc_pt2(0) = N_lambda_mrcc_pt2 +! lambda_mrcc_kept(0) = N_lambda_mrcc_pt3 +! print*,'N_det_non_ref = ',N_det_non_ref +! print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1) +! print*,'lambda max = ',maxval(dabs(lambda_mrcc)) +! print*,'Number of ignored determinants = ',i_pert_count +! +!END_PROVIDER + BEGIN_PROVIDER [ double precision, hij_mrcc, (N_det_non_ref,N_det_ref) ] @@ -291,11 +351,11 @@ logical function is_generable(det1, det2, Nint) integer, intent(in) :: Nint integer(bit_kind) :: det1(Nint, 2), det2(Nint, 2) integer :: degree, f, exc(0:2, 2, 2), t - integer*2 :: h1, h2, p1, p2, s1, s2 + integer :: h1, h2, p1, p2, s1, s2 integer, external :: searchExc logical, external :: excEq double precision :: phase - integer*2 :: tmp_array(4) + integer :: tmp_array(4) is_generable = .false. call get_excitation(det1, det2, exc, degree, phase, Nint) @@ -306,7 +366,7 @@ logical function is_generable(det1, det2, Nint) end if if(degree > 2) stop "?22??" - call decode_exc_int2(exc,degree,h1,p1,h2,p2,s1,s2) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) if(degree == 1) then h2 = h1 @@ -394,7 +454,7 @@ integer function searchExc(excs, exc, n) use bitmasks integer, intent(in) :: n - integer*2,intent(in) :: excs(4,n), exc(4) + integer,intent(in) :: excs(4,n), exc(4) integer :: l, h, c integer, external :: excCmp logical, external :: excEq @@ -459,8 +519,8 @@ subroutine sort_exc(key, N_key) integer, intent(in) :: N_key - integer*2,intent(inout) :: key(4,N_key) - integer*2 :: tmp(4) + integer,intent(inout) :: key(4,N_key) + integer :: tmp(4) integer :: i,ni @@ -482,7 +542,7 @@ end subroutine logical function exc_inf(exc1, exc2) implicit none - integer*2,intent(in) :: exc1(4), exc2(4) + integer,intent(in) :: exc1(4), exc2(4) integer :: i exc_inf = .false. do i=1,4 @@ -504,9 +564,9 @@ subroutine tamise_exc(key, no, n, N_key) ! Uncodumented : TODO END_DOC integer,intent(in) :: no, n, N_key - integer*2,intent(inout) :: key(4, N_key) + integer,intent(inout) :: key(4, N_key) integer :: k,j - integer*2 :: tmp(4) + integer :: tmp(4) logical :: exc_inf integer :: ni @@ -535,8 +595,9 @@ end subroutine subroutine dec_exc(exc, h1, h2, p1, p2) implicit none - integer :: exc(0:2,2,2), s1, s2, degree - integer*2, intent(out) :: h1, h2, p1, p2 + integer, intent(in) :: exc(0:2,2,2) + integer, intent(out) :: h1, h2, p1, p2 + integer :: degree, s1, s2 degree = exc(0,1,1) + exc(0,1,2) @@ -547,7 +608,7 @@ subroutine dec_exc(exc, h1, h2, p1, p2) if(degree == 0) return - call decode_exc_int2(exc, degree, h1, p1, h2, p2, s1, s2) + call decode_exc(exc, degree, h1, p1, h2, p2, s1, s2) h1 += mo_tot_num * (s1-1) p1 += mo_tot_num * (s1-1) @@ -579,7 +640,7 @@ end subroutine &BEGIN_PROVIDER [ integer, N_ex_exists ] implicit none integer :: exc(0:2, 2, 2), degree, n, on, s, l, i - integer*2 :: h1, h2, p1, p2 + integer :: h1, h2, p1, p2 double precision :: phase logical,allocatable :: hh(:,:) , pp(:,:) @@ -632,12 +693,12 @@ END_PROVIDER double precision :: phase - double precision, allocatable :: rho_mrcc_init(:) + double precision, allocatable :: rho_mrcc_inact(:) integer :: a_coll, at_roww print *, "TI", hh_nex, N_det_non_ref - allocate(rho_mrcc_init(N_det_non_ref)) + allocate(rho_mrcc_inact(N_det_non_ref)) allocate(x_new(hh_nex)) allocate(x(hh_nex), AtB(hh_nex)) @@ -649,7 +710,7 @@ END_PROVIDER !$OMP private(at_row, a_col, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)& !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtB, mrcc_AtA_val, mrcc_AtA_ind, s, n_exc_active, active_pp_idx) - !$OMP DO schedule(dynamic, 100) + !$OMP DO schedule(static, 100) do at_roww = 1, n_exc_active ! hh_nex at_row = active_pp_idx(at_roww) do i=1,active_excitation_to_determinants_idx(0,at_roww) @@ -668,7 +729,7 @@ END_PROVIDER X(a_col) = AtB(a_col) end do - rho_mrcc_init = 0d0 + rho_mrcc_inact(:) = 0d0 allocate(lref(N_det_ref)) do hh = 1, hh_shortcut(0) @@ -692,29 +753,23 @@ END_PROVIDER X(pp) = AtB(pp) do II=1,N_det_ref if(lref(II) > 0) then - rho_mrcc_init(lref(II)) = psi_ref_coef(II,s) * X(pp) + rho_mrcc_inact(lref(II)) = psi_ref_coef(II,s) * X(pp) else if(lref(II) < 0) then - rho_mrcc_init(-lref(II)) = -psi_ref_coef(II,s) * X(pp) + rho_mrcc_inact(-lref(II)) = -psi_ref_coef(II,s) * X(pp) end if end do end do end do deallocate(lref) - do i=1,N_det_non_ref - rho_mrcc(i,s) = rho_mrcc_init(i) - enddo - x_new = x double precision :: factor, resold factor = 1.d0 resold = huge(1.d0) - do k=0,10*hh_nex + do k=0,hh_nex/4 res = 0.d0 - !$OMP PARALLEL default(shared) private(cx, i, a_col, a_coll) reduction(+:res) - !$OMP DO do a_coll = 1, n_exc_active a_col = active_pp_idx(a_coll) cx = 0.d0 @@ -725,102 +780,108 @@ END_PROVIDER res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col)) X(a_col) = X_new(a_col) end do - !$OMP END DO - !$OMP END PARALLEL if (res > resold) then factor = factor * 0.5d0 endif + + if(iand(k, 127) == 0) then + print *, k, res, 1.d0 - res/resold + endif + + if ( res < 1d-10 ) then + exit + endif + if ( (res/resold > 0.99d0) ) then + exit + endif resold = res - - if(iand(k, 4095) == 0) then - print *, "res ", k, res - end if - - if(res < 1d-10) exit + end do dIj_unique(1:size(X), s) = X(1:size(X)) + print *, k, res, 1.d0 - res/resold - enddo - do s=1,N_states + do i=1,N_det_non_ref + rho_mrcc(i,s) = 0.d0 + enddo do a_coll=1,n_exc_active a_col = active_pp_idx(a_coll) do j=1,N_det_non_ref i = active_excitation_to_determinants_idx(j,a_coll) if (i==0) exit + if (rho_mrcc_inact(i) /= 0.d0) then + call debug_det(psi_non_ref(1,1,i),N_int) + stop + endif rho_mrcc(i,s) = rho_mrcc(i,s) + active_excitation_to_determinants_val(s,j,a_coll) * dIj_unique(a_col,s) enddo end do - norm = 0.d0 - do i=1,N_det_non_ref - norm = norm + rho_mrcc(i,s)*rho_mrcc(i,s) - enddo - ! Norm now contains the norm of A.X - + double precision :: norm2_ref, norm2_inact, a, b, c, Delta + ! Psi = Psi_ref + Psi_inactive + f*Psi_active + ! Find f to normalize Psi + + norm2_ref = 0.d0 do i=1,N_det_ref - norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s) + norm2_ref = norm2_ref + psi_ref_coef(i,s)*psi_ref_coef(i,s) enddo - ! Norm now contains the norm of Psi + A.X - + + a = 0.d0 + do i=1,N_det_non_ref + a = a + rho_mrcc(i,s)*rho_mrcc(i,s) + enddo + + norm = a + norm2_ref print *, "norm : ", sqrt(norm) - enddo + + norm = sqrt((1.d0-norm2_ref)/a) + + ! Renormalize Psi+A.X + do i=1,N_det_non_ref + rho_mrcc(i,s) = rho_mrcc(i,s) * norm + enddo + +!norm = norm2_ref +!do i=1,N_det_non_ref +! norm = norm + rho_mrcc(i,s)**2 +!enddo +!print *, 'check', norm +!stop + - do s=1,N_states norm = 0.d0 - double precision :: f + double precision :: f, g, gmax + gmax = maxval(dabs(psi_non_ref_coef(:,s))) do i=1,N_det_non_ref - if (rho_mrcc(i,s) == 0.d0) then - rho_mrcc(i,s) = 1.d-32 - endif - if (lambda_type == 2) then f = 1.d0 else + if (rho_mrcc(i,s) == 0.d0) then + cycle + endif ! f is such that f.\tilde{c_i} = c_i f = psi_non_ref_coef(i,s) / rho_mrcc(i,s) ! Avoid numerical instabilities - f = min(f,2.d0) - f = max(f,-2.d0) + g = 2.d0+100.d0*exp(-20.d0*dabs(psi_non_ref_coef(i,s)/gmax)) + f = min(f, g) + f = max(f,-g) + endif - norm = norm + f*f *rho_mrcc(i,s)*rho_mrcc(i,s) + norm = norm + (rho_mrcc(i,s)*f)**2 rho_mrcc(i,s) = f enddo - ! norm now contains the norm of |T.Psi_0> - ! rho_mrcc now contains the f factors + ! rho_mrcc now contains the mu_i factors - f = 1.d0/norm - ! f now contains 1/ - - norm = 1.d0 - do i=1,N_det_ref - norm = norm - psi_ref_coef(i,s)*psi_ref_coef(i,s) - enddo - ! norm now contains - f = dsqrt(f*norm) - ! f normalises T.Psi_0 such that (1+T)|Psi> is normalized - - norm = norm*f print *, 'norm of |T Psi_0> = ', dsqrt(norm) - if (dsqrt(norm) > 1.d0) then + if (norm > 1.d0) then stop 'Error : Norm of the SD larger than the norm of the reference.' endif - do i=1,N_det_ref - norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s) - enddo - - do i=1,N_det_non_ref - rho_mrcc(i,s) = rho_mrcc(i,s) * f - enddo - ! rho_mrcc now contains the product of the scaling factors and the - ! normalization constant - end do END_PROVIDER @@ -845,6 +906,53 @@ END_PROVIDER +!double precision function f_fit(x) +! implicit none +! double precision :: x +! f_fit = 0.d0 +! return +! if (x < 0.d0) then +! f_fit = 0.d0 +! else if (x < 1.d0) then +! f_fit = 1.d0/0.367879441171442 * ( x**2 * exp(-x**2)) +! else +! f_fit = 1.d0 +! endif +!end +! +!double precision function get_dij_index(II, i, s, Nint) +! integer, intent(in) :: II, i, s, Nint +! double precision, external :: get_dij +! double precision :: HIi, phase, c, a, b, d +! +! call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi) +! call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) +! +! a = lambda_pert(s,i) +! b = lambda_mrcc(s,i) +! c = f_fit(a/b) +! +! d = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase* rho_mrcc(i,s) +! +! c = f_fit(a*HIi/d) +! +! get_dij_index = HIi * a * c + (1.d0 - c) * d +! get_dij_index = d +! return +! +! if(lambda_type == 0) then +! call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) +! get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase +! get_dij_index = get_dij_index * rho_mrcc(i,s) +! else if(lambda_type == 1) then +! call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi) +! get_dij_index = HIi * lambda_mrcc(s, i) +! else if(lambda_type == 2) then +! call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) +! get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase +! get_dij_index = get_dij_index * rho_mrcc(i,s) +! end if +!end function double precision function get_dij_index(II, i, s, Nint) integer, intent(in) :: II, i, s, Nint @@ -872,11 +980,11 @@ double precision function get_dij(det1, det2, s, Nint) integer, intent(in) :: s, Nint integer(bit_kind) :: det1(Nint, 2), det2(Nint, 2) integer :: degree, f, exc(0:2, 2, 2), t - integer*2 :: h1, h2, p1, p2, s1, s2 + integer :: h1, h2, p1, p2, s1, s2 integer, external :: searchExc logical, external :: excEq double precision :: phase - integer*2 :: tmp_array(4) + integer :: tmp_array(4) get_dij = 0d0 call get_excitation(det1, det2, exc, degree, phase, Nint) @@ -885,7 +993,7 @@ double precision function get_dij(det1, det2, s, Nint) stop "get_dij" end if - call decode_exc_int2(exc,degree,h1,p1,h2,p2,s1,s2) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) if(degree == 1) then h2 = h1 @@ -918,8 +1026,8 @@ double precision function get_dij(det1, det2, s, Nint) end function - BEGIN_PROVIDER [ integer*2, hh_exists, (4, N_hh_exists) ] -&BEGIN_PROVIDER [ integer*2, pp_exists, (4, N_pp_exists) ] + BEGIN_PROVIDER [ integer, hh_exists, (4, N_hh_exists) ] +&BEGIN_PROVIDER [ integer, pp_exists, (4, N_pp_exists) ] &BEGIN_PROVIDER [ integer, hh_shortcut, (0:N_hh_exists + 1) ] &BEGIN_PROVIDER [ integer, hh_nex ] implicit none @@ -934,9 +1042,9 @@ end function ! hh_nex : Total number of excitation operators ! END_DOC - integer*2,allocatable :: num(:,:) + integer,allocatable :: num(:,:) integer :: exc(0:2, 2, 2), degree, n, on, s, l, i - integer*2 :: h1, h2, p1, p2 + integer :: h1, h2, p1, p2 double precision :: phase logical, external :: excEq @@ -962,24 +1070,40 @@ end function hh_shortcut(0) = 1 hh_shortcut(1) = 1 - hh_exists(:,1) = (/1_2, num(1,1), 1_2, num(2,1)/) - pp_exists(:,1) = (/1_2, num(3,1), 1_2, num(4,1)/) + hh_exists(:,1) = (/1, num(1,1), 1, num(2,1)/) + pp_exists(:,1) = (/1, num(3,1), 1, num(4,1)/) s = 1 do i=2,n if(.not. excEq(num(1,i), num(1,s))) then s += 1 num(:, s) = num(:, i) - pp_exists(:,s) = (/1_2, num(3,s), 1_2, num(4,s)/) + pp_exists(:,s) = (/1, num(3,s), 1, num(4,s)/) if(hh_exists(2, hh_shortcut(0)) /= num(1,s) .or. & hh_exists(4, hh_shortcut(0)) /= num(2,s)) then hh_shortcut(0) += 1 hh_shortcut(hh_shortcut(0)) = s - hh_exists(:,hh_shortcut(0)) = (/1_2, num(1,s), 1_2, num(2,s)/) + hh_exists(:,hh_shortcut(0)) = (/1, num(1,s), 1, num(2,s)/) end if end if end do hh_shortcut(hh_shortcut(0)+1) = s+1 + if (hh_shortcut(0) > N_hh_exists) then + print *, 'Error in ', irp_here + print *, 'hh_shortcut(0) :', hh_shortcut(0) + print *, 'N_hh_exists : ', N_hh_exists + print *, 'Is your active space defined?' + stop + endif + + if (hh_shortcut(hh_shortcut(0)+1)-1 > N_pp_exists) then + print *, 'Error 1 in ', irp_here + print *, 'hh_shortcut(hh_shortcut(0)+1)-1 :', hh_shortcut(hh_shortcut(0)+1)-1 + print *, 'N_pp_exists : ', N_pp_exists + print *, 'Is your active space defined?' + stop + endif + do s=2,4,2 do i=1,hh_shortcut(0) if(hh_exists(s, i) == 0) then @@ -990,6 +1114,7 @@ end function end if end do + do i=1,hh_shortcut(hh_shortcut(0)+1)-1 if(pp_exists(s, i) == 0) then pp_exists(s-1, i) = 0 @@ -1005,7 +1130,7 @@ END_PROVIDER logical function excEq(exc1, exc2) implicit none - integer*2, intent(in) :: exc1(4), exc2(4) + integer, intent(in) :: exc1(4), exc2(4) integer :: i excEq = .false. do i=1, 4 @@ -1017,7 +1142,7 @@ end function integer function excCmp(exc1, exc2) implicit none - integer*2, intent(in) :: exc1(4), exc2(4) + integer, intent(in) :: exc1(4), exc2(4) integer :: i excCmp = 0 do i=1, 4 @@ -1036,8 +1161,8 @@ subroutine apply_hole_local(det, exc, res, ok, Nint) use bitmasks implicit none integer, intent(in) :: Nint - integer*2, intent(in) :: exc(4) - integer*2 :: s1, s2, h1, h2 + integer, intent(in) :: exc(4) + integer :: s1, s2, h1, h2 integer(bit_kind),intent(in) :: det(Nint, 2) integer(bit_kind),intent(out) :: res(Nint, 2) logical, intent(out) :: ok @@ -1073,8 +1198,8 @@ subroutine apply_particle_local(det, exc, res, ok, Nint) use bitmasks implicit none integer, intent(in) :: Nint - integer*2, intent(in) :: exc(4) - integer*2 :: s1, s2, p1, p2 + integer, intent(in) :: exc(4) + integer :: s1, s2, p1, p2 integer(bit_kind),intent(in) :: det(Nint, 2) integer(bit_kind),intent(out) :: res(Nint, 2) logical, intent(out) :: ok diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f index ac399ce7..dd79edbe 100644 --- a/plugins/MRPT_Utils/energies_cas.irp.f +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -898,7 +898,7 @@ END_PROVIDER enddo print*, '***' do i = 1, N_det+1 - write(*,'(100(F16.10,X))')H_matrix(i,:) + write(*,'(100(F16.10,1X))')H_matrix(i,:) enddo call lapack_diag(eigenvalues,eigenvectors,H_matrix,size(H_matrix,1),N_det+1) corr_e_from_1h1p(state_target) += eigenvalues(1) - energy_cas_dyall(state_target) @@ -919,15 +919,15 @@ END_PROVIDER norm += psi_in_out_coef(i,state_target) * psi_in_out_coef(i,state_target) enddo print*, 'Coef ' - write(*,'(100(X,F16.10))')psi_coef(1:N_det,state_target) - write(*,'(100(X,F16.10))')psi_in_out_coef(:,state_target) + write(*,'(100(1X,F16.10))')psi_coef(1:N_det,state_target) + write(*,'(100(1X,F16.10))')psi_in_out_coef(:,state_target) double precision :: coef_tmp(N_det) do i = 1, N_det coef_tmp(i) = psi_coef(i,1) * interact_psi0(i) / delta_e_alpha_beta(i,ispin) enddo - write(*,'(100(X,F16.10))')coef_tmp(:) + write(*,'(100(1X,F16.10))')coef_tmp(:) print*, 'naked interactions' - write(*,'(100(X,F16.10))')interact_psi0(:) + write(*,'(100(1X,F16.10))')interact_psi0(:) print*, '' print*, 'norm ',norm @@ -953,10 +953,10 @@ END_PROVIDER enddo enddo print*, '***' - write(*,'(100(X,F16.10))') - write(*,'(100(X,F16.10))')delta_e_alpha_beta(:,2) - ! write(*,'(100(X,F16.10))')one_anhil_one_creat_inact_virt_bis(iorb,vorb,:,1,:) - ! write(*,'(100(X,F16.10))')one_anhil_one_creat_inact_virt_bis(iorb,vorb,:,2,:) + write(*,'(100(1X,F16.10))') + write(*,'(100(1X,F16.10))')delta_e_alpha_beta(:,2) + ! write(*,'(100(1X,F16.10))')one_anhil_one_creat_inact_virt_bis(iorb,vorb,:,1,:) + ! write(*,'(100(1X,F16.10))')one_anhil_one_creat_inact_virt_bis(iorb,vorb,:,2,:) print*, '---------------------------------------------------------------------------' enddo enddo @@ -1089,11 +1089,11 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from print*, 'e corr perturb EN',accu(state_target) print*, '' print*, 'coef diagonalized' - write(*,'(100(F16.10,X))')psi_in_out_coef(:,state_target) + write(*,'(100(F16.10,1X))')psi_in_out_coef(:,state_target) print*, 'coef_perturb' - write(*,'(100(F16.10,X))')coef_perturb(:) + write(*,'(100(F16.10,1X))')coef_perturb(:) print*, 'coef_perturb EN' - write(*,'(100(F16.10,X))')coef_perturb_bis(:) + write(*,'(100(F16.10,1X))')coef_perturb_bis(:) endif integer :: k do k = 1, N_det diff --git a/plugins/MRPT_Utils/excitations_cas.irp.f b/plugins/MRPT_Utils/excitations_cas.irp.f index 10cfe7c0..491cda58 100644 --- a/plugins/MRPT_Utils/excitations_cas.irp.f +++ b/plugins/MRPT_Utils/excitations_cas.irp.f @@ -22,7 +22,7 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & integer :: elec_num_tab_local(2) integer :: i,j,accu_elec,k - integer :: det_tmp(N_int), det_tmp_bis(N_int) + integer(bit_kind) :: det_tmp(N_int), det_tmp_bis(N_int) double precision :: phase double precision :: norm_factor diff --git a/plugins/MRPT_Utils/ezfio_interface.irp.f b/plugins/MRPT_Utils/ezfio_interface.irp.f deleted file mode 100644 index 6bd8931d..00000000 --- a/plugins/MRPT_Utils/ezfio_interface.irp.f +++ /dev/null @@ -1,23 +0,0 @@ -! DO NOT MODIFY BY HAND -! Created by $QP_ROOT/scripts/ezfio_interface/ei_handler.py -! from file /home/scemama/quantum_package/src/MRPT_Utils/EZFIO.cfg - - -BEGIN_PROVIDER [ logical, do_third_order_1h1p ] - implicit none - BEGIN_DOC -! If true, compute the third order contribution for the 1h1p - END_DOC - - logical :: has - PROVIDE ezfio_filename - - call ezfio_has_mrpt_utils_do_third_order_1h1p(has) - if (has) then - call ezfio_get_mrpt_utils_do_third_order_1h1p(do_third_order_1h1p) - else - print *, 'mrpt_utils/do_third_order_1h1p not found in EZFIO file' - stop 1 - endif - -END_PROVIDER diff --git a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f index 4c12dbe1..ce3a74c8 100644 --- a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f +++ b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f @@ -210,7 +210,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} hab = (fock_operator_local(aorb,borb,kspin) ) * phase - if(isnan(hab))then + if(hab /= hab)then ! check NaN print*, '1' stop endif @@ -255,7 +255,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) ! ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} hab = fock_operator_local(aorb,borb,kspin) * phase - if(isnan(hab))then + if(hab /= hab)then ! check NaN print*, '2' stop endif diff --git a/plugins/Molden/.gitignore b/plugins/Molden/.gitignore deleted file mode 100644 index dad27c9b..00000000 --- a/plugins/Molden/.gitignore +++ /dev/null @@ -1,18 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -MO_Basis -Makefile -Makefile.depend -Nuclei -Utils -ezfio_interface.irp.f -irpf90.make -irpf90_entities -print_mo -tags \ No newline at end of file diff --git a/plugins/Perturbation/.gitignore b/plugins/Perturbation/.gitignore deleted file mode 100644 index effe9ffc..00000000 --- a/plugins/Perturbation/.gitignore +++ /dev/null @@ -1,26 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Ezfio_files -Determinants -Integrals_Monoelec -MO_Basis -Utils -Pseudo -Properties -Bitmask -AO_Basis -Electrons -MOGuess -Nuclei -Hartree_Fock -Integrals_Bielec \ No newline at end of file diff --git a/plugins/Properties/.gitignore b/plugins/Properties/.gitignore deleted file mode 100644 index b2f0a113..00000000 --- a/plugins/Properties/.gitignore +++ /dev/null @@ -1,25 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Utils -ZMQ -ezfio_interface.irp.f -irpf90.make -irpf90_entities -print_hcc -print_mulliken -tags \ No newline at end of file diff --git a/plugins/Properties/delta_rho.irp.f b/plugins/Properties/delta_rho.irp.f index 7803ba3d..8fd08246 100644 --- a/plugins/Properties/delta_rho.irp.f +++ b/plugins/Properties/delta_rho.irp.f @@ -6,7 +6,7 @@ z_min = 0.d0 z_max = 10.d0 delta_z = 0.005d0 - N_z_pts = (z_max - z_min)/delta_z + N_z_pts = int( (z_max - z_min)/delta_z ) print*,'N_z_pts = ',N_z_pts END_PROVIDER diff --git a/plugins/Properties/hyperfine_constants.irp.f b/plugins/Properties/hyperfine_constants.irp.f index 6fa39278..91b26dc8 100644 --- a/plugins/Properties/hyperfine_constants.irp.f +++ b/plugins/Properties/hyperfine_constants.irp.f @@ -151,7 +151,7 @@ subroutine print_hcc integer :: i,j print*,'Z AU GAUSS MHZ cm^-1' do i = 1, nucl_num - write(*,'(I2,X,F4.1,X,4(F16.6,X))')i,nucl_charge(i),spin_density_at_nucleous(i),iso_hcc_gauss(i),iso_hcc_mhz(i),iso_hcc_cm_1(i) + write(*,'(I2,1X,F4.1,1X,4(F16.6,1X))')i,nucl_charge(i),spin_density_at_nucleous(i),iso_hcc_gauss(i),iso_hcc_mhz(i),iso_hcc_cm_1(i) enddo end diff --git a/plugins/Properties/mulliken.irp.f b/plugins/Properties/mulliken.irp.f index deeb90bf..68b620c5 100644 --- a/plugins/Properties/mulliken.irp.f +++ b/plugins/Properties/mulliken.irp.f @@ -126,7 +126,7 @@ subroutine print_mulliken_sd accu = 0.d0 do i = 1, ao_num accu += spin_gross_orbital_product(i) - write(*,'(X,I3,X,A4,X,I2,X,A4,X,F10.7)')i,trim(element_name(int(nucl_charge(ao_nucl(i))))),ao_nucl(i),trim(l_to_charater(ao_l(i))),spin_gross_orbital_product(i) + write(*,'(1X,I3,1X,A4,1X,I2,1X,A4,1X,F10.7)')i,trim(element_name(int(nucl_charge(ao_nucl(i))))),ao_nucl(i),trim(l_to_charater(ao_l(i))),spin_gross_orbital_product(i) enddo print*,'sum = ',accu accu = 0.d0 @@ -142,7 +142,7 @@ subroutine print_mulliken_sd accu = 0.d0 do i = 0, ao_l_max accu += spin_population_angular_momentum_per_atom(i,j) - write(*,'(XX,I3,XX,A4,X,A4,X,F10.7)')j,trim(element_name(int(nucl_charge(j)))),trim(l_to_charater(i)),spin_population_angular_momentum_per_atom(i,j) + write(*,'(1X,I3,1X,A4,1X,A4,1X,F10.7)')j,trim(element_name(int(nucl_charge(j)))),trim(l_to_charater(i)),spin_population_angular_momentum_per_atom(i,j) print*,'sum = ',accu enddo enddo diff --git a/plugins/Psiref_CAS/.gitignore b/plugins/Psiref_CAS/.gitignore deleted file mode 100644 index d79d94d9..00000000 --- a/plugins/Psiref_CAS/.gitignore +++ /dev/null @@ -1,26 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Davidson -Determinants -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Psiref_Utils -Utils -ZMQ -ezfio_interface.irp.f -irpf90.make -irpf90_entities -overwrite_with_cas -tags \ No newline at end of file diff --git a/plugins/Psiref_CAS/psi_ref.irp.f b/plugins/Psiref_CAS/psi_ref.irp.f index d3b6c28f..87439764 100644 --- a/plugins/Psiref_CAS/psi_ref.irp.f +++ b/plugins/Psiref_CAS/psi_ref.irp.f @@ -67,3 +67,37 @@ END_PROVIDER END_PROVIDER + BEGIN_PROVIDER [double precision, norm_psi_ref, (N_states)] +&BEGIN_PROVIDER [double precision, inv_norm_psi_ref, (N_states)] + implicit none + integer :: i,j + norm_psi_ref = 0.d0 + do j = 1, N_states + do i = 1, N_det_ref + norm_psi_ref(j) += psi_ref_coef(i,j) * psi_ref_coef(i,j) + enddo + inv_norm_psi_ref(j) = 1.d0/(dsqrt(norm_psi_Ref(j))) + print *, inv_norm_psi_ref(j) + enddo + + END_PROVIDER + + BEGIN_PROVIDER [double precision, psi_ref_coef_interm_norm, (N_det_ref,N_states)] + implicit none + integer :: i,j + do j = 1, N_states + do i = 1, N_det_ref + psi_ref_coef_interm_norm(i,j) = inv_norm_psi_ref(j) * psi_ref_coef(i,j) + enddo + enddo + END_PROVIDER + + BEGIN_PROVIDER [double precision, psi_non_ref_coef_interm_norm, (N_det_non_ref,N_states)] + implicit none + integer :: i,j + do j = 1, N_states + do i = 1, N_det_non_ref + psi_non_ref_coef_interm_norm(i,j) = psi_non_ref_coef(i,j) * inv_norm_psi_ref(j) + enddo + enddo + END_PROVIDER diff --git a/plugins/Psiref_Utils/.gitignore b/plugins/Psiref_Utils/.gitignore deleted file mode 100644 index d98a4abc..00000000 --- a/plugins/Psiref_Utils/.gitignore +++ /dev/null @@ -1,29 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -Generators_full -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_full -Utils -ezfio_interface.irp.f -irpf90.make -irpf90_entities -mrcc_general -tags \ No newline at end of file diff --git a/plugins/Psiref_Utils/psi_ref_utils.irp.f b/plugins/Psiref_Utils/psi_ref_utils.irp.f index c4147ebc..95c993f0 100644 --- a/plugins/Psiref_Utils/psi_ref_utils.irp.f +++ b/plugins/Psiref_Utils/psi_ref_utils.irp.f @@ -98,8 +98,7 @@ END_PROVIDER enddo N_det_non_ref = i_non_ref if (N_det_non_ref < 1) then - print *, 'Error : All determinants are in the reference' - stop -1 + print *, 'Warning : All determinants are in the reference' endif END_PROVIDER diff --git a/plugins/Psiref_threshold/.gitignore b/plugins/Psiref_threshold/.gitignore deleted file mode 100644 index d98a4abc..00000000 --- a/plugins/Psiref_threshold/.gitignore +++ /dev/null @@ -1,29 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -Generators_full -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_full -Utils -ezfio_interface.irp.f -irpf90.make -irpf90_entities -mrcc_general -tags \ No newline at end of file diff --git a/plugins/Psiref_threshold/NEEDED_CHILDREN_MODULES b/plugins/Psiref_threshold/NEEDED_CHILDREN_MODULES deleted file mode 100644 index 7e790003..00000000 --- a/plugins/Psiref_threshold/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Psiref_Utils diff --git a/plugins/Psiref_threshold/README.rst b/plugins/Psiref_threshold/README.rst deleted file mode 100644 index 3d4726e1..00000000 --- a/plugins/Psiref_threshold/README.rst +++ /dev/null @@ -1,24 +0,0 @@ -======================= -Psiref_threshold Module -======================= - - -Reference wave function is defined as all determinants with coefficients -such that | c_i/c_max | > threshold. - -Documentation -============= - -.. Do not edit this section. It was auto-generated from the -.. by the `update_README.py` script. - -Needed Modules -============== - -.. Do not edit this section. It was auto-generated from the -.. by the `update_README.py` script. - -.. image:: tree_dependency.png - -* `Psiref_Utils `_ - diff --git a/plugins/Psiref_threshold/psi_ref.irp.f b/plugins/Psiref_threshold/psi_ref.irp.f deleted file mode 100644 index ee69ef5c..00000000 --- a/plugins/Psiref_threshold/psi_ref.irp.f +++ /dev/null @@ -1,41 +0,0 @@ -use bitmasks - - BEGIN_PROVIDER [ integer(bit_kind), psi_ref, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_ref_coef, (psi_det_size,n_states) ] -&BEGIN_PROVIDER [ integer, idx_ref, (psi_det_size) ] -&BEGIN_PROVIDER [ integer, N_det_ref ] - implicit none - BEGIN_DOC - ! Reference wave function, defined as determinants with amplitudes > 0.05 - ! idx_ref gives the indice of the ref determinant in psi_det. - END_DOC - integer :: i, k, l - logical :: good - double precision, parameter :: threshold=0.05d0 - double precision :: t(N_states) - N_det_ref = 0 - do l = 1, N_states - t(l) = threshold * abs_psi_coef_max(l) - enddo - do i=1,N_det - good = .False. - do l=1, N_states - psi_ref_coef(i,l) = 0.d0 - good = good.or.(dabs(psi_coef(i,l)) > t(l)) - enddo - if (good) then - N_det_ref = N_det_ref+1 - do k=1,N_int - psi_ref(k,1,N_det_ref) = psi_det(k,1,i) - psi_ref(k,2,N_det_ref) = psi_det(k,2,i) - enddo - idx_ref(N_det_ref) = i - do k=1,N_states - psi_ref_coef(N_det_ref,k) = psi_coef(i,k) - enddo - endif - enddo - call write_int(output_determinants,N_det_ref, 'Number of determinants in the reference') - -END_PROVIDER - diff --git a/plugins/Psiref_threshold/tree_dependency.png b/plugins/Psiref_threshold/tree_dependency.png deleted file mode 100644 index 9c2088e1..00000000 Binary files a/plugins/Psiref_threshold/tree_dependency.png and /dev/null differ diff --git a/plugins/QmcChem/.gitignore b/plugins/QmcChem/.gitignore deleted file mode 100644 index 5f364702..00000000 --- a/plugins/QmcChem/.gitignore +++ /dev/null @@ -1,25 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Utils -ZMQ -ezfio_interface.irp.f -irpf90.make -irpf90_entities -save_for_qmcchem -tags -target_pt2_qmc \ No newline at end of file diff --git a/plugins/Selectors_full/.gitignore b/plugins/Selectors_full/.gitignore deleted file mode 100644 index 8d85dede..00000000 --- a/plugins/Selectors_full/.gitignore +++ /dev/null @@ -1,25 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Ezfio_files -Determinants -Integrals_Monoelec -MO_Basis -Utils -Pseudo -Bitmask -AO_Basis -Electrons -MOGuess -Nuclei -Hartree_Fock -Integrals_Bielec \ No newline at end of file diff --git a/plugins/Selectors_full/zmq.irp.f b/plugins/Selectors_full/zmq.irp.f index 8046212b..59f40daf 100644 --- a/plugins/Selectors_full/zmq.irp.f +++ b/plugins/Selectors_full/zmq.irp.f @@ -90,13 +90,13 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy) psi_det_size = psi_det_size_read TOUCH psi_det_size N_det N_states - rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE) + rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,0) if (rc /= N_int*2*N_det*bit_kind) then print *, 'f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)' stop 'error' endif - rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE) + rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,0) if (rc /= psi_det_size*N_states*8) then print *, '77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)' stop 'error' diff --git a/plugins/Selectors_no_sorted/.gitignore b/plugins/Selectors_no_sorted/.gitignore deleted file mode 100644 index 955ad80c..00000000 --- a/plugins/Selectors_no_sorted/.gitignore +++ /dev/null @@ -1,13 +0,0 @@ -# -# Do not modify this file. Add your ignored files to the gitignore -# (without the dot at the beginning) file. -# -IRPF90_temp -IRPF90_man -irpf90.make -tags -Makefile.depend -irpf90_entities -build.ninja -.ninja_log -.ninja_deps diff --git a/plugins/SingleRefMethod/.gitignore b/plugins/SingleRefMethod/.gitignore deleted file mode 100644 index d85c570a..00000000 --- a/plugins/SingleRefMethod/.gitignore +++ /dev/null @@ -1,19 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Ezfio_files -MO_Basis -Utils -Bitmask -AO_Basis -Electrons -Nuclei \ No newline at end of file diff --git a/plugins/Alavi/NEEDED_CHILDREN_MODULES b/plugins/analyze_wf/NEEDED_CHILDREN_MODULES similarity index 100% rename from plugins/Alavi/NEEDED_CHILDREN_MODULES rename to plugins/analyze_wf/NEEDED_CHILDREN_MODULES diff --git a/plugins/analyze_wf/README.rst b/plugins/analyze_wf/README.rst new file mode 100644 index 00000000..179e407d --- /dev/null +++ b/plugins/analyze_wf/README.rst @@ -0,0 +1,12 @@ +========== +analyze_wf +========== + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. diff --git a/plugins/analyze_wf/analyze_wf.irp.f b/plugins/analyze_wf/analyze_wf.irp.f new file mode 100644 index 00000000..7d005a05 --- /dev/null +++ b/plugins/analyze_wf/analyze_wf.irp.f @@ -0,0 +1,70 @@ +program analyze_wf + implicit none + BEGIN_DOC +! Wave function analyzis + END_DOC + read_wf = .True. + SOFT_TOUCH read_wf + call run() +end + +subroutine run + implicit none + integer :: istate, i + integer :: class(0:mo_tot_num,5) + double precision :: occupation(mo_tot_num) + + write(*,'(A)') 'MO Occupation' + write(*,'(A)') '=============' + write(*,'(A)') '' + do istate=1,N_states + call get_occupation_from_dets(occupation,istate) + write(*,'(A)') '' + write(*,'(A,I3)'), 'State ', istate + write(*,'(A)') '---------------' + write(*,'(A)') '' + write (*,'(A)') '======== ================' + class = 0 + do i=1,mo_tot_num + write (*,'(I8,X,F16.10)') i, occupation(i) + if (occupation(i) > 1.999d0) then + class(0,1) += 1 + class( class(0,1), 1) = i + else if (occupation(i) > 1.97d0) then + class(0,2) += 1 + class( class(0,2), 2) = i + else if (occupation(i) < 0.001d0) then + class(0,5) += 1 + class( class(0,5), 5) = i + else if (occupation(i) < 0.03d0) then + class(0,4) += 1 + class( class(0,4), 4) = i + else + class(0,3) += 1 + class( class(0,3), 3) = i + endif + enddo + write (*,'(A)') '======== ================' + write (*,'(A)') '' + + write (*,'(A)') 'Suggested classes' + write (*,'(A)') '-----------------' + write (*,'(A)') '' + write (*,'(A)') 'Core :' + write (*,*) (class(i,1), ',', i=1,class(0,1)) + write (*,*) '' + write (*,'(A)') 'Inactive :' + write (*,*) (class(i,2), ',', i=1,class(0,2)) + write (*,'(A)') '' + write (*,'(A)') 'Active :' + write (*,*) (class(i,3), ',', i=1,class(0,3)) + write (*,'(A)') '' + write (*,'(A)') 'Virtual :' + write (*,*) (class(i,4), ',', i=1,class(0,4)) + write (*,'(A)') '' + write (*,'(A)') 'Deleted :' + write (*,*) (class(i,5), ',', i=1,class(0,5)) + write (*,'(A)') '' + enddo + +end diff --git a/plugins/analyze_wf/occupation.irp.f b/plugins/analyze_wf/occupation.irp.f new file mode 100644 index 00000000..d426dc14 --- /dev/null +++ b/plugins/analyze_wf/occupation.irp.f @@ -0,0 +1,23 @@ +subroutine get_occupation_from_dets(occupation, istate) + implicit none + double precision, intent(out) :: occupation(mo_tot_num) + integer, intent(in) :: istate + BEGIN_DOC + ! Returns the average occupation of the MOs + END_DOC + integer :: i,j, ispin + integer :: list(N_int*bit_kind_size,2) + integer :: n_elements(2) + double precision :: c + + occupation = 0.d0 + do i=1,N_det + c = psi_coef(i,istate)*psi_coef(i,istate) + call bitstring_to_list_ab(psi_det(1,1,i), list, n_elements, N_int) + do ispin=1,2 + do j=1,n_elements(ispin) + occupation( list(j,ispin) ) += c + enddo + enddo + enddo +end diff --git a/plugins/loc_cele/.gitignore b/plugins/loc_cele/.gitignore deleted file mode 100644 index 6c8b96df..00000000 --- a/plugins/loc_cele/.gitignore +++ /dev/null @@ -1,18 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -MO_Basis -Makefile -Makefile.depend -Nuclei -Utils -ezfio_interface.irp.f -irpf90.make -irpf90_entities -loc_cele -tags \ No newline at end of file diff --git a/plugins/mrcc_selected/dressing.irp.f b/plugins/mrcc_selected/dressing.irp.f deleted file mode 100644 index c772e2aa..00000000 --- a/plugins/mrcc_selected/dressing.irp.f +++ /dev/null @@ -1,1076 +0,0 @@ -use bitmasks - - - - BEGIN_PROVIDER [ double precision, delta_ij_mrcc, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_mrcc, (N_states, N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ij_s2_mrcc, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_s2_mrcc, (N_states, N_det_ref) ] - use bitmasks - implicit none - integer :: gen, h, p, n, t, i, h1, h2, p1, p2, s1, s2, iproc - integer(bit_kind) :: mask(N_int, 2), omask(N_int, 2) - integer(bit_kind),allocatable :: buf(:,:,:) - logical :: ok - logical, external :: detEq - - delta_ij_mrcc = 0d0 - delta_ii_mrcc = 0d0 - delta_ij_s2_mrcc = 0d0 - delta_ii_s2_mrcc = 0d0 - PROVIDE dij - provide hh_shortcut psi_det_size! lambda_mrcc - !$OMP PARALLEL DO default(none) schedule(dynamic) & - !$OMP shared(psi_det_generators, N_det_generators, hh_exists, pp_exists, N_int, hh_shortcut) & - !$OMP shared(N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc, delta_ii_s2_mrcc, delta_ij_s2_mrcc) & - !$OMP private(h, n, mask, omask, buf, ok, iproc) - do gen= 1, N_det_generators - allocate(buf(N_int, 2, N_det_non_ref)) - iproc = omp_get_thread_num() + 1 - if(mod(gen, 1000) == 0) print *, "mrcc ", gen, "/", N_det_generators - do h=1, hh_shortcut(0) - call apply_hole_local(psi_det_generators(1,1,gen), hh_exists(1, h), mask, ok, N_int) - if(.not. ok) cycle - omask = 0_bit_kind - if(hh_exists(1, h) /= 0) omask = mask - n = 1 - do p=hh_shortcut(h), hh_shortcut(h+1)-1 - call apply_particle_local(mask, pp_exists(1, p), buf(1,1,n), ok, N_int) - if(ok) n = n + 1 - if(n > N_det_non_ref) stop "MRCC..." - end do - n = n - 1 - - if(n /= 0) then - call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc, delta_ij_s2_mrcc, delta_ii_s2_mrcc, gen,n,buf,N_int,omask) - endif - - end do - deallocate(buf) - end do - !$OMP END PARALLEL DO -END_PROVIDER - - -! subroutine blit(b1, b2) -! double precision :: b1(N_states,N_det_non_ref,N_det_ref), b2(N_states,N_det_non_ref,N_det_ref) -! b1 = b1 + b2 -! end subroutine - - -subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_generator,n_selected,det_buffer,Nint,key_mask) - use bitmasks - implicit none - - integer, intent(in) :: i_generator,n_selected, Nint - double precision, intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref) - double precision, intent(inout) :: delta_ii_(N_states,N_det_ref) - double precision, intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref) - double precision, intent(inout) :: delta_ii_s2_(N_states,N_det_ref) - - integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) - integer :: i,j,k,l,m - integer,allocatable :: idx_alpha(:), degree_alpha(:) - logical :: good, fullMatch - - integer(bit_kind),allocatable :: tq(:,:,:) - integer :: N_tq, c_ref ,degree - - double precision :: hIk, hla, hIl, sla, dIk(N_states), dka(N_states), dIa(N_states) - double precision, allocatable :: dIa_hla(:,:), dIa_sla(:,:) - double precision :: haj, phase, phase2 - double precision :: f(N_states), ci_inv(N_states) - integer :: exc(0:2,2,2) - integer :: h1,h2,p1,p2,s1,s2 - integer(bit_kind) :: tmp_det(Nint,2) - integer :: iint, ipos - integer :: i_state, k_sd, l_sd, i_I, i_alpha - - integer(bit_kind),allocatable :: miniList(:,:,:) - integer(bit_kind),intent(in) :: key_mask(Nint, 2) - integer,allocatable :: idx_miniList(:) - integer :: N_miniList, ni, leng - double precision, allocatable :: hij_cache(:), sij_cache(:) - - integer(bit_kind), allocatable :: microlist(:,:,:), microlist_zero(:,:,:) - integer, allocatable :: idx_microlist(:), N_microlist(:), ptr_microlist(:), idx_microlist_zero(:) - integer :: mobiles(2), smallerlist - logical, external :: detEq, is_generable - !double precision, external :: get_dij, get_dij_index - - - leng = max(N_det_generators, N_det_non_ref) - allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref), sij_cache(N_det_non_ref)) - allocate(idx_alpha(0:psi_det_size), degree_alpha(psi_det_size)) - !create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint) - call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint) - -! if(fullMatch) then -! return -! end if - - allocate(ptr_microlist(0:mo_tot_num*2+1), & - N_microlist(0:mo_tot_num*2) ) - allocate( microlist(Nint,2,N_minilist*4), & - idx_microlist(N_minilist*4)) - - if(key_mask(1,1) /= 0) then - call create_microlist(miniList, N_minilist, key_mask, microlist, idx_microlist, N_microlist, ptr_microlist, Nint) - call filter_tq_micro(i_generator,n_selected,det_buffer,Nint,tq,N_tq,microlist,ptr_microlist,N_microlist,key_mask) - else - call filter_tq(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) - end if - - - - deallocate(microlist, idx_microlist) - - allocate (dIa_hla(N_states,N_det_non_ref), dIa_sla(N_states,N_det_non_ref)) - - ! |I> - - ! |alpha> - - if(N_tq > 0) then - call create_minilist(key_mask, psi_non_ref, miniList, idx_minilist, N_det_non_ref, N_minilist, Nint) - if(N_minilist == 0) return - - - if(key_mask(1,1) /= 0) then !!!!!!!!!!! PAS GENERAL !!!!!!!!! - allocate(microlist_zero(Nint,2,N_minilist), idx_microlist_zero(N_minilist)) - - allocate( microlist(Nint,2,N_minilist*4), & - idx_microlist(N_minilist*4)) - call create_microlist(miniList, N_minilist, key_mask, microlist, idx_microlist, N_microlist, ptr_microlist, Nint) - - - do i=0,mo_tot_num*2 - do k=ptr_microlist(i),ptr_microlist(i+1)-1 - idx_microlist(k) = idx_minilist(idx_microlist(k)) - end do - end do - - do l=1,N_microlist(0) - do k=1,Nint - microlist_zero(k,1,l) = microlist(k,1,l) - microlist_zero(k,2,l) = microlist(k,2,l) - enddo - idx_microlist_zero(l) = idx_microlist(l) - enddo - end if - end if - - - do i_alpha=1,N_tq - if(key_mask(1,1) /= 0) then - call getMobiles(tq(1,1,i_alpha), key_mask, mobiles, Nint) - - if(N_microlist(mobiles(1)) < N_microlist(mobiles(2))) then - smallerlist = mobiles(1) - else - smallerlist = mobiles(2) - end if - - - do l=0,N_microlist(smallerlist)-1 - microlist_zero(:,:,ptr_microlist(1) + l) = microlist(:,:,ptr_microlist(smallerlist) + l) - idx_microlist_zero(ptr_microlist(1) + l) = idx_microlist(ptr_microlist(smallerlist) + l) - end do - - call get_excitation_degree_vector(microlist_zero,tq(1,1,i_alpha),degree_alpha,Nint,N_microlist(smallerlist)+N_microlist(0),idx_alpha) - do j=1,idx_alpha(0) - idx_alpha(j) = idx_microlist_zero(idx_alpha(j)) - end do - - else - call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha) - do j=1,idx_alpha(0) - idx_alpha(j) = idx_miniList(idx_alpha(j)) - end do - end if - - - do l_sd=1,idx_alpha(0) - k_sd = idx_alpha(l_sd) - call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd)) - call get_s2(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,sij_cache(k_sd)) - enddo - ! |I> - do i_I=1,N_det_ref - ! Find triples and quadruple grand parents - call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree,Nint) - if (degree > 4) then - cycle - endif - - do i_state=1,N_states - dIa(i_state) = 0.d0 - enddo - - ! |alpha> - do k_sd=1,idx_alpha(0) - ! Loop if lambda == 0 - logical :: loop -! loop = .True. -! do i_state=1,N_states -! if (lambda_mrcc(i_state,idx_alpha(k_sd)) /= 0.d0) then -! loop = .False. -! exit -! endif -! enddo -! if (loop) then -! cycle -! endif - - call get_excitation_degree(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),degree,Nint) - if (degree > 2) then - cycle - endif - - ! - ! - !hIk = hij_mrcc(idx_alpha(k_sd),i_I) - ! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk) - - do i_state=1,N_states - dIK(i_state) = dij(i_I, idx_alpha(k_sd), i_state) - !dIk(i_state) = get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,idx_alpha(k_sd)), N_int) !!hIk * lambda_mrcc(i_state,idx_alpha(k_sd)) - !dIk(i_state) = psi_non_ref_coef(idx_alpha(k_sd), i_state) / psi_ref_coef(i_I, i_state) - enddo - - - ! |l> = Exc(k -> alpha) |I> - call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - do k=1,N_int - tmp_det(k,1) = psi_ref(k,1,i_I) - tmp_det(k,2) = psi_ref(k,2,i_I) - enddo - logical :: ok - call apply_excitation(psi_ref(1,1,i_I), exc, tmp_det, ok, Nint) - if(.not. ok) cycle - - ! - do i_state=1,N_states - dka(i_state) = 0.d0 - enddo - do l_sd=k_sd+1,idx_alpha(0) - call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint) - if (degree == 0) then - -! loop = .True. -! do i_state=1,N_states -! if (lambda_mrcc(i_state,idx_alpha(l_sd)) /= 0.d0) then -! loop = .False. -! exit -! endif -! enddo - loop = .false. - if (.not.loop) then - call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint) - hIl = hij_mrcc(idx_alpha(l_sd),i_I) -! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl) - do i_state=1,N_states - dka(i_state) = dij(i_I, idx_alpha(l_sd), i_state) * phase * phase2 - !dka(i_state) = get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,idx_alpha(l_sd)), N_int) * phase * phase2 !hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2 - !dka(i_state) = psi_non_ref_coef(idx_alpha(l_sd), i_state) / psi_ref_coef(i_I, i_state) * phase * phase2 - enddo - endif - - exit - endif - enddo - do i_state=1,N_states - dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state) - enddo - enddo - - do i_state=1,N_states - ci_inv(i_state) = psi_ref_coef_inv(i_I,i_state) - enddo - do l_sd=1,idx_alpha(0) - k_sd = idx_alpha(l_sd) - hla = hij_cache(k_sd) - sla = sij_cache(k_sd) -! call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla) - do i_state=1,N_states - dIa_hla(i_state,k_sd) = dIa(i_state) * hla - dIa_sla(i_state,k_sd) = dIa(i_state) * sla - enddo - enddo - call omp_set_lock( psi_ref_lock(i_I) ) - do i_state=1,N_states - if(dabs(psi_ref_coef(i_I,i_state)).ge.1.d-3)then - do l_sd=1,idx_alpha(0) - k_sd = idx_alpha(l_sd) - delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) - delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) - delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + dIa_sla(i_state,k_sd) - delta_ii_s2_(i_state,i_I) = delta_ii_s2_(i_state,i_I) - dIa_sla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) - enddo - else - delta_ii_(i_state,i_I) = 0.d0 - do l_sd=1,idx_alpha(0) - k_sd = idx_alpha(l_sd) - delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + 0.5d0*dIa_hla(i_state,k_sd) - delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + 0.5d0*dIa_sla(i_state,k_sd) - enddo - endif - enddo - call omp_unset_lock( psi_ref_lock(i_I) ) - enddo - enddo - deallocate (dIa_hla,dIa_sla,hij_cache,sij_cache) - deallocate(miniList, idx_miniList) -end - - - - - BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii, (N_states, N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ij_s2, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_s2, (N_states, N_det_ref) ] - use bitmasks - implicit none - integer :: i, j, i_state - - !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc - - if(mrmode == 3) then - do i = 1, N_det_ref - do i_state = 1, N_states - delta_ii(i_state,i)= delta_ii_mrcc(i_state,i) - delta_ii_s2(i_state,i)= delta_ii_s2_mrcc(i_state,i) - enddo - do j = 1, N_det_non_ref - do i_state = 1, N_states - delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i) - delta_ij_s2(i_state,j,i) = delta_ij_s2_mrcc(i_state,j,i) - enddo - end do - end do - - ! =-=-= BEGIN STATE AVERAGE -! do i = 1, N_det_ref -! delta_ii(:,i)= delta_ii_mrcc(1,i) -! delta_ii_s2(:,i)= delta_ii_s2_mrcc(1,i) -! do i_state = 2, N_states -! delta_ii(:,i) += delta_ii_mrcc(i_state,i) -! delta_ii_s2(:,i) += delta_ii_s2_mrcc(i_state,i) -! enddo -! do j = 1, N_det_non_ref -! delta_ij(:,j,i) = delta_ij_mrcc(1,j,i) -! delta_ij_s2(:,j,i) = delta_ij_s2_mrcc(1,j,i) -! do i_state = 2, N_states -! delta_ij(:,j,i) += delta_ij_mrcc(i_state,j,i) -! delta_ij_s2(:,j,i) += delta_ij_s2_mrcc(i_state,j,i) -! enddo -! end do -! end do -! delta_ij = delta_ij * (1.d0/dble(N_states)) -! delta_ii = delta_ii * (1.d0/dble(N_states)) - ! =-=-= END STATE AVERAGE - ! - ! do i = 1, N_det_ref - ! delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state) - ! do j = 1, N_det_non_ref - ! delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_sub_ij(i,j,i_state) - ! end do - ! end do - else if(mrmode == 2) then - do i = 1, N_det_ref - do i_state = 1, N_states - delta_ii(i_state,i)= delta_ii_old(i_state,i) - delta_ii_s2(i_state,i)= delta_ii_s2_old(i_state,i) - enddo - do j = 1, N_det_non_ref - do i_state = 1, N_states - delta_ij(i_state,j,i) = delta_ij_old(i_state,j,i) - delta_ij_s2(i_state,j,i) = delta_ij_s2_old(i_state,j,i) - enddo - end do - end do - else if(mrmode == 1) then - do i = 1, N_det_ref - do i_state = 1, N_states - delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_ii_s2(i_state,i)= delta_mrcepa0_ii_s2(i,i_state) - enddo - do j = 1, N_det_non_ref - do i_state = 1, N_states - delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_ij_s2(i_state,j,i) = delta_mrcepa0_ij_s2(i,j,i_state) - enddo - end do - end do - else - stop "invalid mrmode" - end if -END_PROVIDER - - -BEGIN_PROVIDER [ integer, HP, (2,N_det_non_ref) ] - integer :: i - do i=1,N_det_non_ref - call getHP(psi_non_ref(1,1,i), HP(1,i), HP(2,i), N_int) - end do -END_PROVIDER - - BEGIN_PROVIDER [ integer, cepa0_shortcut, (0:N_det_non_ref+1) ] -&BEGIN_PROVIDER [ integer, det_cepa0_idx, (N_det_non_ref) ] -&BEGIN_PROVIDER [ integer(bit_kind), det_cepa0_active, (N_int,2,N_det_non_ref) ] -&BEGIN_PROVIDER [ integer(bit_kind), det_ref_active, (N_int,2,N_det_ref) ] -&BEGIN_PROVIDER [ integer(bit_kind), active_sorb, (N_int,2) ] -&BEGIN_PROVIDER [ integer(bit_kind), det_cepa0, (N_int,2,N_det_non_ref) ] -&BEGIN_PROVIDER [ integer, nlink, (N_det_ref) ] -&BEGIN_PROVIDER [ integer, linked, (N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ integer, blokMwen, (N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, searchance, (N_det_ref) ] -&BEGIN_PROVIDER [ integer, child_num, (N_det_non_ref,N_det_ref) ] - - use bitmasks - implicit none - - integer(bit_kind),allocatable :: det_noactive(:,:,:) - integer, allocatable :: shortcut(:), idx(:) - integer(bit_kind) :: nonactive_sorb(N_int,2), det(N_int, 2) - integer i, II, j, k, n, ni, blok, degree - logical, external :: detEq - - allocate(det_noactive(N_int, 2, N_det_non_ref)) - allocate(idx(N_det_non_ref), shortcut(0:N_det_non_ref+1)) - print *, "pre start" - active_sorb(:,:) = 0_8 - nonactive_sorb(:,:) = not(0_8) - - if(N_det_ref > 1) then - do i=1, N_det_ref - do k=1, N_int - active_sorb(k,1) = ior(psi_ref(k,1,i), active_sorb(k,1)) - active_sorb(k,2) = ior(psi_ref(k,2,i), active_sorb(k,2)) - nonactive_sorb(k,1) = iand(psi_ref(k,1,i), nonactive_sorb(k,1)) - nonactive_sorb(k,2) = iand(psi_ref(k,2,i), nonactive_sorb(k,2)) - end do - end do - do k=1, N_int - active_sorb(k,1) = iand(active_sorb(k,1), not(nonactive_sorb(k,1))) - active_sorb(k,2) = iand(active_sorb(k,2), not(nonactive_sorb(k,2))) - end do - end if - - - do i=1, N_det_non_ref - do k=1, N_int - det_noactive(k,1,i) = iand(psi_non_ref(k,1,i), not(active_sorb(k,1))) - det_noactive(k,2,i) = iand(psi_non_ref(k,2,i), not(active_sorb(k,2))) - end do - end do - - call sort_dets_ab(det_noactive, det_cepa0_idx, cepa0_shortcut, N_det_non_ref, N_int) - - do i=1,N_det_non_ref - det_cepa0(:,:,i) = psi_non_ref(:,:,det_cepa0_idx(i)) - end do - - cepa0_shortcut(0) = 1 - cepa0_shortcut(1) = 1 - do i=2,N_det_non_ref - if(.not. detEq(det_noactive(1,1,i), det_noactive(1,1,i-1), N_int)) then - cepa0_shortcut(0) += 1 - cepa0_shortcut(cepa0_shortcut(0)) = i - end if - end do - cepa0_shortcut(cepa0_shortcut(0)+1) = N_det_non_ref+1 - - if(.true.) then - do i=1,cepa0_shortcut(0) - n = cepa0_shortcut(i+1) - cepa0_shortcut(i) - call sort_dets_ab(det_cepa0(1,1,cepa0_shortcut(i)), idx, shortcut, n, N_int) - do k=1,n - idx(k) = det_cepa0_idx(cepa0_shortcut(i)-1+idx(k)) - end do - det_cepa0_idx(cepa0_shortcut(i):cepa0_shortcut(i)+n-1) = idx(:n) - end do - end if - - - do i=1,N_det_ref - do k=1, N_int - det_ref_active(k,1,i) = iand(psi_ref(k,1,i), active_sorb(k,1)) - det_ref_active(k,2,i) = iand(psi_ref(k,2,i), active_sorb(k,2)) - end do - end do - - do i=1,N_det_non_ref - do k=1, N_int - det_cepa0_active(k,1,i) = iand(psi_non_ref(k,1,det_cepa0_idx(i)), active_sorb(k,1)) - det_cepa0_active(k,2,i) = iand(psi_non_ref(k,2,det_cepa0_idx(i)), active_sorb(k,2)) - end do - end do - - do i=1,N_det_non_ref - if(.not. detEq(psi_non_ref(1,1,det_cepa0_idx(i)), det_cepa0(1,1,i),N_int)) stop "STOOOP" - end do - - searchance = 0d0 - child_num = 0 - do J = 1, N_det_ref - nlink(J) = 0 - do blok=1,cepa0_shortcut(0) - do k=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 - call get_excitation_degree(psi_ref(1,1,J),det_cepa0(1,1,k),degree,N_int) - if(degree <= 2) then - nlink(J) += 1 - linked(nlink(J),J) = k - child_num(k, J) = nlink(J) - blokMwen(nlink(J),J) = blok - searchance(J) += 1d0 + log(dfloat(cepa0_shortcut(blok+1) - cepa0_shortcut(blok))) - end if - end do - end do - end do - print *, "pre done" -END_PROVIDER - - -! BEGIN_PROVIDER [ double precision, delta_cas, (N_det_ref, N_det_ref, N_states) ] -! use bitmasks -! implicit none -! integer :: i,j,k -! double precision :: Hjk, Hki, Hij, pre(N_det_ref), wall -! integer :: i_state, degree, npre, ipre(N_det_ref), npres(N_det_ref) -! -! ! provide lambda_mrcc -! npres = 0 -! delta_cas = 0d0 -! call wall_time(wall) -! print *, "dcas ", wall -! do i_state = 1, N_states -! !!$OMP PARALLEL DO default(none) schedule(dynamic) private(pre,npre,ipre,j,k,Hjk,Hki,degree) shared(npres,lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,N_det_ref) -! do k=1,N_det_non_ref -! if(lambda_mrcc(i_state, k) == 0d0) cycle -! npre = 0 -! do i=1,N_det_ref -! call i_h_j(psi_non_ref(1,1,k),psi_ref(1,1,i), N_int,Hki) -! if(Hki /= 0d0) then -! !!$OMP ATOMIC -! npres(i) += 1 -! npre += 1 -! ipre(npre) = i -! pre(npre) = Hki -! end if -! end do -! -! -! do i=1,npre -! do j=1,i -! !!$OMP ATOMIC -! delta_cas(ipre(i),ipre(j),i_state) += pre(i) * pre(j) * lambda_mrcc(i_state, k) -! end do -! end do -! end do -! !!$OMP END PARALLEL DO -! npre=0 -! do i=1,N_det_ref -! npre += npres(i) -! end do -! !stop -! do i=1,N_det_ref -! do j=1,i -! delta_cas(j,i,i_state) = delta_cas(i,j,i_state) -! end do -! end do -! end do -! -! call wall_time(wall) -! print *, "dcas", wall -! ! stop -! END_PROVIDER - - - BEGIN_PROVIDER [ double precision, delta_cas, (N_det_ref, N_det_ref, N_states) ] -&BEGIN_PROVIDER [ double precision, delta_cas_s2, (N_det_ref, N_det_ref, N_states) ] - use bitmasks - implicit none - integer :: i,j,k - double precision :: Sjk,Hjk, Hki, Hij - !double precision, external :: get_dij - integer i_state, degree - - provide lambda_mrcc dIj - do i_state = 1, N_states - !$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Sjk,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,delta_cas_s2,N_det_ref,dij) - do i=1,N_det_ref - do j=1,i - call get_excitation_degree(psi_ref(1,1,i), psi_ref(1,1,j), degree, N_int) - delta_cas(i,j,i_state) = 0d0 - delta_cas_s2(i,j,i_state) = 0d0 - do k=1,N_det_non_ref - - call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Hjk) - call get_s2(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Sjk) - - delta_cas(i,j,i_state) += Hjk * dij(i, k, i_state) ! * Hki * lambda_mrcc(i_state, k) - delta_cas_s2(i,j,i_state) += Sjk * dij(i, k, i_state) ! * Ski * lambda_mrcc(i_state, k) - end do - delta_cas(j,i,i_state) = delta_cas(i,j,i_state) - delta_cas_s2(j,i,i_state) = delta_cas_s2(i,j,i_state) - end do - end do - !$OMP END PARALLEL DO - end do - END_PROVIDER - - - - -logical function isInCassd(a,Nint) - use bitmasks - implicit none - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: a(Nint,2) - integer(bit_kind) :: inac, virt - integer :: ni, i, deg - - - isInCassd = .false. - - deg = 0 - do i=1,2 - do ni=1,Nint - virt = iand(not(HF_bitmask(ni,i)), not(active_sorb(ni,i))) - deg += popcnt(iand(virt, a(ni,i))) - if(deg > 2) return - end do - end do - - deg = 0 - do i=1,2 - do ni=1,Nint - inac = iand(HF_bitmask(ni,i), not(active_sorb(ni,i))) - deg += popcnt(xor(iand(inac,a(ni,i)), inac)) - if(deg > 2) return - end do - end do - isInCassd = .true. -end function - - -subroutine getHP(a,h,p,Nint) - use bitmasks - implicit none - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: a(Nint,2) - integer, intent(out) :: h, p - integer(bit_kind) :: inac, virt - integer :: ni, i, deg - - - !isInCassd = .false. - h = 0 - p = 0 - - deg = 0 - lp : do i=1,2 - do ni=1,Nint - virt = iand(not(HF_bitmask(ni,i)), not(active_sorb(ni,i))) - deg += popcnt(iand(virt, a(ni,i))) - if(deg > 2) exit lp - end do - end do lp - p = deg - - deg = 0 - lh : do i=1,2 - do ni=1,Nint - inac = iand(HF_bitmask(ni,i), not(active_sorb(ni,i))) - deg += popcnt(xor(iand(inac,a(ni,i)), inac)) - if(deg > 2) exit lh - end do - end do lh - h = deg - !isInCassd = .true. -end function - - - BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij, (N_det_ref,N_det_non_ref,N_states) ] -&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii, (N_det_ref,N_states) ] -&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij_s2, (N_det_ref,N_det_non_ref,N_states) ] -&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii_s2, (N_det_ref,N_states) ] - use bitmasks - implicit none - - integer :: i_state, i, i_I, J, k, degree, degree2, m, l, deg, ni - integer :: p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_, sortRefIdx(N_det_ref) - logical :: ok - double precision :: phase_iI, phase_Ik, phase_Jl, phase_IJ, phase_al, diI, hIi, hJi, delta_JI, dkI(1), HkI, ci_inv(1), dia_hla(1) - double precision :: contrib, contrib2, contrib_s2, contrib2_s2, HIIi, HJk, wall - integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ - integer(bit_kind) :: det_tmp(N_int, 2), made_hole(N_int,2), made_particle(N_int,2), myActive(N_int,2) - integer(bit_kind),allocatable :: sortRef(:,:,:) - integer, allocatable :: idx_sorted_bit(:) - integer, external :: get_index_in_psi_det_sorted_bit, searchDet - logical, external :: is_in_wavefunction, detEq - !double precision, external :: get_dij - integer :: II, blok - integer*8, save :: notf = 0 - - call wall_time(wall) - allocate(idx_sorted_bit(N_det), sortRef(N_int,2,N_det_ref)) - - sortRef(:,:,:) = det_ref_active(:,:,:) - call sort_det(sortRef, sortRefIdx, N_det_ref, N_int) - - idx_sorted_bit(:) = -1 - do i=1,N_det_non_ref - idx_sorted_bit(get_index_in_psi_det_sorted_bit(psi_non_ref(1,1,i), N_int)) = i - enddo - - ! To provide everything - contrib = dij(1, 1, 1) - - delta_mrcepa0_ii(:,:) = 0d0 - delta_mrcepa0_ij(:,:,:) = 0d0 - delta_mrcepa0_ii_s2(:,:) = 0d0 - delta_mrcepa0_ij_s2(:,:,:) = 0d0 - - do i_state = 1, N_states - !$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii, delta_mrcepa0_ij_s2, delta_mrcepa0_ii_s2) & - !$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2,contrib_s2,contrib2_s2) & - !$OMP shared(active_sorb, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef, cepa0_shortcut, det_cepa0_active) & - !$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_cas, delta_cas_s2) & - !$OMP shared(notf,i_state, sortRef, sortRefIdx, dij) - do blok=1,cepa0_shortcut(0) - do i=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 - do II=1,N_det_ref - call get_excitation_degree(psi_ref(1,1,II),psi_non_ref(1,1,det_cepa0_idx(i)),degree,N_int) - if (degree > 2 ) cycle - - do ni=1,N_int - made_hole(ni,1) = iand(det_ref_active(ni,1,II), xor(det_cepa0_active(ni,1,i), det_ref_active(ni,1,II))) - made_hole(ni,2) = iand(det_ref_active(ni,2,II), xor(det_cepa0_active(ni,2,i), det_ref_active(ni,2,II))) - - made_particle(ni,1) = iand(det_cepa0_active(ni,1,i), xor(det_cepa0_active(ni,1,i), det_ref_active(ni,1,II))) - made_particle(ni,2) = iand(det_cepa0_active(ni,2,i), xor(det_cepa0_active(ni,2,i), det_ref_active(ni,2,II))) - end do - - - kloop: do k=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 !i - !if(lambda_mrcc(i_state, det_cepa0_idx(k)) == 0d0) cycle - - do ni=1,N_int - if(iand(made_hole(ni,1), det_cepa0_active(ni,1,k)) /= 0) cycle kloop - if(iand(made_particle(ni,1), det_cepa0_active(ni,1,k)) /= made_particle(ni,1)) cycle kloop - if(iand(made_hole(ni,2), det_cepa0_active(ni,2,k)) /= 0) cycle kloop - if(iand(made_particle(ni,2), det_cepa0_active(ni,2,k)) /= made_particle(ni,2)) cycle kloop - end do - do ni=1,N_int - myActive(ni,1) = xor(det_cepa0_active(ni,1,k), made_hole(ni,1)) - myActive(ni,1) = xor(myActive(ni,1), made_particle(ni,1)) - myActive(ni,2) = xor(det_cepa0_active(ni,2,k), made_hole(ni,2)) - myActive(ni,2) = xor(myActive(ni,2), made_particle(ni,2)) - end do - - j = searchDet(sortRef, myActive, N_det_ref, N_int) - if(j == -1) then - cycle - end if - j = sortRefIdx(j) - !$OMP ATOMIC - notf = notf+1 - -! call i_h_j(psi_non_ref(1,1,det_cepa0_idx(k)),psi_ref(1,1,J),N_int,HJk) - contrib = delta_cas(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) - contrib_s2 = delta_cas_s2(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) - - if(dabs(psi_ref_coef(J,i_state)).ge.1.d-3) then - contrib2 = contrib / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) - contrib2_s2 = contrib_s2 / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) - !$OMP ATOMIC - delta_mrcepa0_ii(J,i_state) -= contrib2 - delta_mrcepa0_ii_s2(J,i_state) -= contrib2_s2 - else - contrib = contrib * 0.5d0 - contrib_s2 = contrib_s2 * 0.5d0 - end if - !$OMP ATOMIC - delta_mrcepa0_ij(J, det_cepa0_idx(i), i_state) += contrib - delta_mrcepa0_ij_s2(J, det_cepa0_idx(i), i_state) += contrib_s2 - - end do kloop - end do - end do - end do - !$OMP END PARALLEL DO - end do - deallocate(idx_sorted_bit) - call wall_time(wall) - print *, "cepa0", wall, notf - -END_PROVIDER - - - BEGIN_PROVIDER [ double precision, delta_sub_ij, (N_det_ref,N_det_non_ref,N_states) ] -&BEGIN_PROVIDER [ double precision, delta_sub_ii, (N_det_ref, N_states) ] - use bitmasks - implicit none - - integer :: i_state, i, i_I, J, k, degree, degree2, l, deg, ni - integer :: p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_ - logical :: ok - double precision :: phase_Ji, phase_Ik, phase_Ii - double precision :: contrib, contrib2, delta_IJk, HJk, HIk, HIl - integer, dimension(0:2,2,2) :: exc_Ik, exc_Ji, exc_Ii - integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2) - integer, allocatable :: idx_sorted_bit(:) - integer, external :: get_index_in_psi_det_sorted_bit - - integer :: II, blok - - provide delta_cas lambda_mrcc - allocate(idx_sorted_bit(N_det)) - idx_sorted_bit(:) = -1 - do i=1,N_det_non_ref - idx_sorted_bit(get_index_in_psi_det_sorted_bit(psi_non_ref(1,1,i), N_int)) = i - enddo - - do i_state = 1, N_states - delta_sub_ij(:,:,:) = 0d0 - delta_sub_ii(:,:) = 0d0 - - provide mo_bielec_integrals_in_map - - - !$OMP PARALLEL DO default(none) schedule(dynamic,10) shared(delta_sub_ij, delta_sub_ii) & - !$OMP private(i, J, k, degree, degree2, l, deg, ni) & - !$OMP private(p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_) & - !$OMP private(ok, phase_Ji, phase_Ik, phase_Ii, contrib2, contrib, delta_IJk, HJk, HIk, HIl, exc_Ik, exc_Ji, exc_Ii) & - !$OMP private(det_tmp, det_tmp2, II, blok) & - !$OMP shared(idx_sorted_bit, N_det_non_ref, N_det_ref, N_int, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef) & - !$OMP shared(i_state,lambda_mrcc, hf_bitmask, active_sorb) - do i=1,N_det_non_ref - if(mod(i,1000) == 0) print *, i, "/", N_det_non_ref - do J=1,N_det_ref - call get_excitation(psi_ref(1,1,J),psi_non_ref(1,1,i),exc_Ji,degree,phase_Ji,N_int) - if(degree == -1) cycle - - - do II=1,N_det_ref - call apply_excitation(psi_ref(1,1,II),exc_Ji,det_tmp,ok,N_int) - - if(.not. ok) cycle - l = get_index_in_psi_det_sorted_bit(det_tmp, N_int) - if(l == 0) cycle - l = idx_sorted_bit(l) - - call i_h_j(psi_ref(1,1,II), det_tmp, N_int, HIl) - - do k=1,N_det_non_ref - if(lambda_mrcc(i_state, k) == 0d0) cycle - call get_excitation(psi_ref(1,1,II),psi_non_ref(1,1,k),exc_Ik,degree2,phase_Ik,N_int) - - det_tmp(:,:) = 0_bit_kind - det_tmp2(:,:) = 0_bit_kind - - ok = .true. - do ni=1,N_int - det_tmp(ni,1) = iand(xor(HF_bitmask(ni,1), psi_non_ref(ni,1,k)), not(active_sorb(ni,1))) - det_tmp(ni,2) = iand(xor(HF_bitmask(ni,1), psi_non_ref(ni,1,i)), not(active_sorb(ni,1))) - ok = ok .and. (popcnt(det_tmp(ni,1)) + popcnt(det_tmp(ni,2)) == popcnt(xor(det_tmp(ni,1), det_tmp(ni,2)))) - - det_tmp(ni,1) = iand(xor(HF_bitmask(ni,2), psi_non_ref(ni,2,k)), not(active_sorb(ni,2))) - det_tmp(ni,2) = iand(xor(HF_bitmask(ni,2), psi_non_ref(ni,2,i)), not(active_sorb(ni,2))) - ok = ok .and. (popcnt(det_tmp(ni,1)) + popcnt(det_tmp(ni,2)) == popcnt(xor(det_tmp(ni,1), det_tmp(ni,2)))) - end do - - if(ok) cycle - - - call i_h_j(psi_ref(1,1,J), psi_non_ref(1,1,k), N_int, HJk) - call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,k), N_int, HIk) - if(HJk == 0) cycle - !assert HIk == 0 - delta_IJk = HJk * HIk * lambda_mrcc(i_state, k) - call apply_excitation(psi_non_ref(1,1,i),exc_Ik,det_tmp,ok,N_int) - if(ok) cycle - contrib = delta_IJk * HIl * lambda_mrcc(i_state,l) - if(dabs(psi_ref_coef(II,i_state)).ge.1.d-3) then - contrib2 = contrib / psi_ref_coef(II, i_state) * psi_non_ref_coef(l,i_state) - !$OMP ATOMIC - delta_sub_ii(II,i_state) -= contrib2 - else - contrib = contrib * 0.5d0 - endif - !$OMP ATOMIC - delta_sub_ij(II, i, i_state) += contrib - end do - end do - end do - end do - !$OMP END PARALLEL DO - end do - deallocate(idx_sorted_bit) -END_PROVIDER - - -subroutine set_det_bit(det, p, s) - implicit none - integer(bit_kind),intent(inout) :: det(N_int, 2) - integer, intent(in) :: p, s - integer :: ni, pos - - ni = (p-1)/bit_kind_size + 1 - pos = mod(p-1, bit_kind_size) - det(ni,s) = ibset(det(ni,s), pos) -end subroutine - - - BEGIN_PROVIDER [ double precision, h_cache, (N_det_ref,N_det_non_ref) ] -&BEGIN_PROVIDER [ double precision, s2_cache, (N_det_ref,N_det_non_ref) ] - implicit none - integer :: i,j - do i=1,N_det_ref - do j=1,N_det_non_ref - call i_h_j(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, h_cache(i,j)) - call get_s2(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, s2_cache(i,j)) - end do - end do -END_PROVIDER - - - -subroutine filter_tq(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList) - - use bitmasks - implicit none - - integer, intent(in) :: i_generator,n_selected, Nint - - integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) - integer :: i,j,k,m - logical :: is_in_wavefunction - integer,allocatable :: degree(:) - integer,allocatable :: idx(:) - logical :: good - - integer(bit_kind), intent(inout) :: tq(Nint,2,n_selected) !! intent(out) - integer, intent(out) :: N_tq - - integer :: nt,ni - logical, external :: is_connected_to, is_generable - - integer(bit_kind),intent(in) :: miniList(Nint,2,N_det_generators) - integer,intent(in) :: N_miniList - - allocate(degree(psi_det_size)) - allocate(idx(0:psi_det_size)) - N_tq = 0 - - i_loop : do i=1,N_selected - do k=1, N_minilist - if(is_generable(miniList(1,1,k), det_buffer(1,1,i), Nint)) cycle i_loop - end do - - ! Select determinants that are triple or quadruple excitations - ! from the ref - good = .True. - call get_excitation_degree_vector(psi_ref,det_buffer(1,1,i),degree,Nint,N_det_ref,idx) - !good=(idx(0) == 0) tant que degree > 2 pas retourné par get_excitation_degree_vector - do k=1,idx(0) - if (degree(k) < 3) then - good = .False. - exit - endif - enddo - if (good) then - if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint)) then - N_tq += 1 - do k=1,N_int - tq(k,1,N_tq) = det_buffer(k,1,i) - tq(k,2,N_tq) = det_buffer(k,2,i) - enddo - endif - endif - enddo i_loop -end - - -subroutine filter_tq_micro(i_generator,n_selected,det_buffer,Nint,tq,N_tq,microlist,ptr_microlist,N_microlist,key_mask) - - use bitmasks - implicit none - - integer, intent(in) :: i_generator,n_selected, Nint - - integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) - integer :: i,j,k,m - logical :: is_in_wavefunction - integer,allocatable :: degree(:) - integer,allocatable :: idx(:) - logical :: good - - integer(bit_kind), intent(inout) :: tq(Nint,2,n_selected) !! intent(out) - integer, intent(out) :: N_tq - - integer :: nt,ni - logical, external :: is_connected_to, is_generable - - integer(bit_kind),intent(in) :: microlist(Nint,2,*) - integer,intent(in) :: ptr_microlist(0:*) - integer,intent(in) :: N_microlist(0:*) - integer(bit_kind),intent(in) :: key_mask(Nint, 2) - - integer :: mobiles(2), smallerlist - - - allocate(degree(psi_det_size)) - allocate(idx(0:psi_det_size)) - N_tq = 0 - - i_loop : do i=1,N_selected - call getMobiles(det_buffer(1,1,i), key_mask, mobiles, Nint) - if(N_microlist(mobiles(1)) < N_microlist(mobiles(2))) then - smallerlist = mobiles(1) - else - smallerlist = mobiles(2) - end if - - if(N_microlist(smallerlist) > 0) then - do k=ptr_microlist(smallerlist), ptr_microlist(smallerlist)+N_microlist(smallerlist)-1 - if(is_generable(microlist(1,1,k), det_buffer(1,1,i), Nint)) cycle i_loop - end do - end if - - if(N_microlist(0) > 0) then - do k=1, N_microlist(0) - if(is_generable(microlist(1,1,k), det_buffer(1,1,i), Nint)) cycle i_loop - end do - end if - - ! Select determinants that are triple or quadruple excitations - ! from the ref - good = .True. - call get_excitation_degree_vector(psi_ref,det_buffer(1,1,i),degree,Nint,N_det_ref,idx) - !good=(idx(0) == 0) tant que degree > 2 pas retourné par get_excitation_degree_vector - do k=1,idx(0) - if (degree(k) < 3) then - good = .False. - exit - endif - enddo - if (good) then - if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint)) then - N_tq += 1 - do k=1,N_int - tq(k,1,N_tq) = det_buffer(k,1,i) - tq(k,2,N_tq) = det_buffer(k,2,i) - enddo - endif - endif - enddo i_loop -end - - - - diff --git a/plugins/mrcc_selected/dressing_slave.irp.f b/plugins/mrcc_selected/dressing_slave.irp.f deleted file mode 100644 index c2e5dd55..00000000 --- a/plugins/mrcc_selected/dressing_slave.irp.f +++ /dev/null @@ -1,601 +0,0 @@ -subroutine mrsc2_dressing_slave_tcp(i) - implicit none - integer, intent(in) :: i - BEGIN_DOC -! Task for parallel MR-SC2 - END_DOC - call mrsc2_dressing_slave(0,i) -end - - -subroutine mrsc2_dressing_slave_inproc(i) - implicit none - integer, intent(in) :: i - BEGIN_DOC -! Task for parallel MR-SC2 - END_DOC - call mrsc2_dressing_slave(1,i) -end - -subroutine mrsc2_dressing_slave(thread,iproc) - use f77_zmq - - implicit none - BEGIN_DOC -! Task for parallel MR-SC2 - END_DOC - integer, intent(in) :: thread, iproc -! integer :: j,l - integer :: rc - - integer :: worker_id, task_id - character*(512) :: task - - integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - - integer(ZMQ_PTR), external :: new_zmq_push_socket - integer(ZMQ_PTR) :: zmq_socket_push - - double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:) - - - - integer :: i_state, i, i_I, J, k, k2, k1, kk, ll, degree, degree2, m, l, deg, ni, m2 - integer :: n(2) - integer :: p1,p2,h1,h2,s1,s2, blok, I_s, J_s, kn - logical :: ok - double precision :: phase_iI, phase_Ik, phase_Jl, phase_Ji, phase_al - double precision :: diI, hIi, hJi, delta_JI, dkI, HkI, ci_inv(N_states), cj_inv(N_states) - double precision :: contrib, contrib_s2, wall, iwall - double precision, allocatable :: dleat(:,:,:), dleat_s2(:,:,:) - integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ - integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2), inac, virt - integer, external :: get_index_in_psi_det_sorted_bit, searchDet, detCmp - logical, external :: is_in_wavefunction, isInCassd, detEq - integer,allocatable :: komon(:) - logical :: komoned - !double precision, external :: get_dij - - zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - zmq_socket_push = new_zmq_push_socket(thread) - - call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) - - allocate (dleat(N_states, N_det_non_ref, 2), delta(N_states,0:N_det_non_ref, 2)) - allocate (dleat_s2(N_states, N_det_non_ref, 2), delta_s2(N_states,0:N_det_non_ref, 2)) - allocate(komon(0:N_det_non_ref)) - - do - call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) - if (task_id == 0) exit - read (task,*) i_I, J, k1, k2 - do i_state=1, N_states - ci_inv(i_state) = 1.d0 / psi_ref_coef(i_I,i_state) - cj_inv(i_state) = 1.d0 / psi_ref_coef(J,i_state) - end do - n = 0 - delta(:,0,:) = 0d0 - delta(:,:nlink(J),1) = 0d0 - delta(:,:nlink(i_I),2) = 0d0 - delta_s2(:,0,:) = 0d0 - delta_s2(:,:nlink(J),1) = 0d0 - delta_s2(:,:nlink(i_I),2) = 0d0 - komon(0) = 0 - komoned = .false. - - - - - do kk = k1, k2 - k = det_cepa0_idx(linked(kk, i_I)) - blok = blokMwen(kk, i_I) - - call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,k),exc_Ik,degree,phase_Ik,N_int) - - if(J /= i_I) then - call apply_excitation(psi_ref(1,1,J),exc_Ik,det_tmp2,ok,N_int) - if(.not. ok) cycle - - l = searchDet(det_cepa0(1,1,cepa0_shortcut(blok)), det_tmp2, cepa0_shortcut(blok+1)-cepa0_shortcut(blok), N_int) - if(l == -1) cycle - ll = cepa0_shortcut(blok)-1+l - l = det_cepa0_idx(ll) - ll = child_num(ll, J) - else - l = k - ll = kk - end if - - - if(.not. komoned) then - m = 0 - m2 = 0 - - do while(m < nlink(i_I) .and. m2 < nlink(J)) - m += 1 - m2 += 1 - if(linked(m, i_I) < linked(m2, J)) then - m2 -= 1 - cycle - else if(linked(m, i_I) > linked(m2, J)) then - m -= 1 - cycle - end if - i = det_cepa0_idx(linked(m, i_I)) - - if(h_cache(J,i) == 0.d0) cycle - if(h_cache(i_I,i) == 0.d0) cycle - - komon(0) += 1 - kn = komon(0) - komon(kn) = i - - do i_state = 1,N_states - dkI = h_cache(J,i) * dij(i_I, i, i_state) - dleat(i_state, kn, 1) = dkI - dleat(i_state, kn, 2) = dkI - - dkI = s2_cache(J,i) * dij(i_I, i, i_state) - dleat_s2(i_state, kn, 1) = dkI - dleat_s2(i_state, kn, 2) = dkI - end do - - end do - - komoned = .true. - end if - - integer :: hpmin(2) - hpmin(1) = 2 - HP(1,k) - hpmin(2) = 2 - HP(2,k) - - do m = 1, komon(0) - - i = komon(m) - if(HP(1,i) <= hpmin(1) .and. HP(2,i) <= hpmin(2) ) then - cycle - end if - - call apply_excitation(psi_non_ref(1,1,i),exc_Ik,det_tmp,ok,N_int) - if(.not. ok) cycle - - do i_state = 1, N_states - contrib = dij(i_I, k, i_state) * dleat(i_state, m, 2) - contrib_s2 = dij(i_I, k, i_state) * dleat_s2(i_state, m, 2) - delta(i_state,ll,1) += contrib - delta_s2(i_state,ll,1) += contrib_s2 - if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5) then - delta(i_state,0,1) -= contrib * ci_inv(i_state) * psi_non_ref_coef(l,i_state) - delta_s2(i_state,0,1) -= contrib_s2 * ci_inv(i_state) * psi_non_ref_coef(l,i_state) - endif - - if(I_i == J) cycle - contrib = dij(J, l, i_state) * dleat(i_state, m, 1) - contrib_s2 = dij(J, l, i_state) * dleat_s2(i_state, m, 1) - delta(i_state,kk,2) += contrib - delta_s2(i_state,kk,2) += contrib_s2 - if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then - delta(i_state,0,2) -= contrib * cj_inv(i_state) * psi_non_ref_coef(k,i_state) - delta_s2(i_state,0,2) -= contrib_s2 * cj_inv(i_state) * psi_non_ref_coef(k,i_state) - end if - enddo !i_state - end do ! while - end do ! kk - - - call push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id) - call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) - -! end if - - enddo - - deallocate(delta) - - call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) - call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) - call end_zmq_push_socket(zmq_socket_push,thread) - -end - - -subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id) - use f77_zmq - implicit none - BEGIN_DOC -! Push integrals in the push socket - END_DOC - - integer, intent(in) :: i_I, J - integer(ZMQ_PTR), intent(in) :: zmq_socket_push - double precision,intent(inout) :: delta(N_states, 0:N_det_non_ref, 2) - double precision,intent(inout) :: delta_s2(N_states, 0:N_det_non_ref, 2) - integer, intent(in) :: task_id - integer :: rc , i_state, i, kk, li - integer,allocatable :: idx(:,:) - integer :: n(2) - logical :: ok - - allocate(idx(N_det_non_ref,2)) - rc = f77_zmq_send( zmq_socket_push, i_I, 4, ZMQ_SNDMORE) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, i_I, 4, ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_send( zmq_socket_push, J, 4, ZMQ_SNDMORE) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, J, 4, ZMQ_SNDMORE)' - stop 'error' - endif - - - do kk=1,2 - n(kk)=0 - if(kk == 1) li = nlink(j) - if(kk == 2) li = nlink(i_I) - do i=1, li - ok = .false. - do i_state=1,N_states - if(delta(i_state, i, kk) /= 0d0) then - ok = .true. - exit - end if - end do - - if(ok) then - n(kk) += 1 -! idx(n,kk) = i - if(kk == 1) then - idx(n(1),1) = det_cepa0_idx(linked(i, J)) - else - idx(n(2),2) = det_cepa0_idx(linked(i, i_I)) - end if - - do i_state=1, N_states - delta(i_state, n(kk), kk) = delta(i_state, i, kk) - end do - end if - end do - - rc = f77_zmq_send( zmq_socket_push, n(kk), 4, ZMQ_SNDMORE) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, n, 4, ZMQ_SNDMORE)' - stop 'error' - endif - - if(n(kk) /= 0) then - rc = f77_zmq_send( zmq_socket_push, delta(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) ! delta(1,0,1) = delta_I delta(1,0,2) = delta_J - if (rc /= (n(kk)+1)*8*N_states) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_send( zmq_socket_push, delta_s2(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) ! delta_s2(1,0,1) = delta_I delta_s2(1,0,2) = delta_J - if (rc /= (n(kk)+1)*8*N_states) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta_s2, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_send( zmq_socket_push, idx(1,kk), n(kk)*4, ZMQ_SNDMORE) - if (rc /= n(kk)*4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta, 8*n(kk), ZMQ_SNDMORE)' - stop 'error' - endif - end if - end do - - - rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, task_id, 4, 0)' - stop 'error' - 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 -end - - - -subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, task_id) - use f77_zmq - implicit none - BEGIN_DOC -! Push integrals in the push socket - END_DOC - - integer(ZMQ_PTR), intent(in) :: zmq_socket_pull - integer, intent(out) :: i_I, J, n(2) - double precision, intent(inout) :: delta(N_states, 0:N_det_non_ref, 2) - double precision, intent(inout) :: delta_s2(N_states, 0:N_det_non_ref, 2) - integer, intent(out) :: task_id - integer :: rc , i, kk - integer,intent(inout) :: idx(N_det_non_ref,2) - logical :: ok - - rc = f77_zmq_recv( zmq_socket_pull, i_I, 4, ZMQ_SNDMORE) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, i_I, 4, ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_recv( zmq_socket_pull, J, 4, ZMQ_SNDMORE) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, J, 4, ZMQ_SNDMORE)' - stop 'error' - endif - - do kk = 1, 2 - rc = f77_zmq_recv( zmq_socket_pull, n(kk), 4, ZMQ_SNDMORE) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, n, 4, ZMQ_SNDMORE)' - stop 'error' - endif - - if(n(kk) /= 0) then - rc = f77_zmq_recv( zmq_socket_pull, delta(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) - if (rc /= (n(kk)+1)*8*N_states) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_recv( zmq_socket_pull, delta_s2(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) - if (rc /= (n(kk)+1)*8*N_states) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta_s2, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE) - if (rc /= n(kk)*4) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE)' - stop 'error' - endif - end if - end do - - rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)' - stop 'error' - endif - - -! ! 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 -end - - - -subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2_) - use f77_zmq - implicit none - BEGIN_DOC -! Collects results from the AO integral calculation - END_DOC - - double precision,intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref) - double precision,intent(inout) :: delta_ii_(N_states,N_det_ref) - double precision,intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref) - double precision,intent(inout) :: delta_ii_s2_(N_states,N_det_ref) - -! integer :: j,l - integer :: rc - - double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:) - - integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - - integer(ZMQ_PTR), external :: new_zmq_pull_socket - integer(ZMQ_PTR) :: zmq_socket_pull - - integer*8 :: control, accu - integer :: task_id, more - - integer :: I_i, J, l, i_state, n(2), kk - integer,allocatable :: idx(:,:) - - delta_ii_(:,:) = 0d0 - delta_ij_(:,:,:) = 0d0 - delta_ii_s2_(:,:) = 0d0 - delta_ij_s2_(:,:,:) = 0d0 - - zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - zmq_socket_pull = new_zmq_pull_socket() - - allocate ( delta(N_states,0:N_det_non_ref,2), delta_s2(N_states,0:N_det_non_ref,2) ) - - allocate(idx(N_det_non_ref,2)) - more = 1 - do while (more == 1) - - call pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, task_id) - - - do l=1, n(1) - do i_state=1,N_states - delta_ij_(i_state,idx(l,1),i_I) += delta(i_state,l,1) - delta_ij_s2_(i_state,idx(l,1),i_I) += delta_s2(i_state,l,1) - end do - end do - - do l=1, n(2) - do i_state=1,N_states - delta_ij_(i_state,idx(l,2),J) += delta(i_state,l,2) - delta_ij_s2_(i_state,idx(l,2),J) += delta_s2(i_state,l,2) - end do - end do - - - if(n(1) /= 0) then - do i_state=1,N_states - delta_ii_(i_state,i_I) += delta(i_state,0,1) - delta_ii_s2_(i_state,i_I) += delta_s2(i_state,0,1) - end do - end if - - if(n(2) /= 0) then - do i_state=1,N_states - delta_ii_(i_state,J) += delta(i_state,0,2) - delta_ii_s2_(i_state,J) += delta_s2(i_state,0,2) - end do - end if - - - if (task_id /= 0) then - call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) - endif - - - enddo - deallocate( delta, delta_s2 ) - - call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) - call end_zmq_pull_socket(zmq_socket_pull) - -end - - - - - BEGIN_PROVIDER [ double precision, delta_ij_old, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_old, (N_states,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ij_s2_old, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_s2_old, (N_states,N_det_ref) ] - implicit none - - integer :: i_state, i, i_I, J, k, kk, degree, degree2, m, l, deg, ni, m2 - integer :: p1,p2,h1,h2,s1,s2, blok, I_s, J_s, nex, nzer, ntot -! integer, allocatable :: linked(:,:), blokMwen(:, :), nlink(:) - logical :: ok - double precision :: phase_iI, phase_Ik, phase_Jl, phase_Ji, phase_al, diI, hIi, hJi, delta_JI, dkI(N_states), HkI, ci_inv(N_states), dia_hla(N_states) - double precision :: contrib, wall, iwall ! , searchance(N_det_ref) - integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ - integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2), inac, virt - integer, external :: get_index_in_psi_det_sorted_bit, searchDet, detCmp - logical, external :: is_in_wavefunction, isInCassd, detEq - character*(512) :: task - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - - integer :: KKsize = 1000000 - - - call new_parallel_job(zmq_to_qp_run_socket,'mrsc2') - - - call wall_time(iwall) -! allocate(linked(N_det_non_ref, N_det_ref), blokMwen(N_det_non_ref, N_det_ref), nlink(N_det_ref)) - - -! searchance = 0d0 -! do J = 1, N_det_ref -! nlink(J) = 0 -! do blok=1,cepa0_shortcut(0) -! do k=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 -! call get_excitation_degree(psi_ref(1,1,J),det_cepa0(1,1,k),degree,N_int) -! if(degree <= 2) then -! nlink(J) += 1 -! linked(nlink(J),J) = k -! blokMwen(nlink(J),J) = blok -! searchance(J) += 1d0 + log(dfloat(cepa0_shortcut(blok+1) - cepa0_shortcut(blok))) -! end if -! end do -! end do -! end do - - - -! stop - nzer = 0 - ntot = 0 - do nex = 3, 0, -1 - print *, "los ",nex - do I_s = N_det_ref, 1, -1 -! if(mod(I_s,1) == 0) then -! call wall_time(wall) -! wall = wall-iwall -! print *, I_s, "/", N_det_ref, wall * (dfloat(N_det_ref) / dfloat(I_s)), wall, wall * (dfloat(N_det_ref) / dfloat(I_s))-wall -! end if - - - do J_s = 1, I_s - - call get_excitation_degree(psi_ref(1,1,J_s), psi_ref(1,1,I_s), degree, N_int) - if(degree /= nex) cycle - if(nex == 3) nzer = nzer + 1 - ntot += 1 -! if(degree > 3) then -! deg += 1 -! cycle -! else if(degree == -10) then -! KKsize = 100000 -! else -! KKsize = 1000000 -! end if - - - - if(searchance(I_s) < searchance(J_s)) then - i_I = I_s - J = J_s - else - i_I = J_s - J = I_s - end if - - KKsize = nlink(1) - if(nex == 0) KKsize = int(float(nlink(1)) / float(nlink(i_I)) * (float(nlink(1)) / 64d0)) - - !if(KKsize == 0) stop "ZZEO" - - do kk = 1 , nlink(i_I), KKsize - write(task,*) I_i, J, kk, int(min(kk+KKsize-1, nlink(i_I))) - call add_task_to_taskserver(zmq_to_qp_run_socket,task) - end do - - ! do kk = 1 , nlink(i_I) - ! k = linked(kk,i_I) - ! blok = blokMwen(kk,i_I) - ! write(task,*) I_i, J, k, blok - ! call add_task_to_taskserver(zmq_to_qp_run_socket,task) - ! - ! enddo !kk - enddo !J - - enddo !I - end do ! nex - print *, "tasked" -! integer(ZMQ_PTR) ∷ collector_thread -! external ∷ ao_bielec_integrals_in_map_collector -! rc = pthread_create(collector_thread, mrsc2_dressing_collector) - print *, nzer, ntot, float(nzer) / float(ntot) - provide nproc - !$OMP PARALLEL DEFAULT(none) SHARED(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old) PRIVATE(i) NUM_THREADS(nproc+1) - i = omp_get_thread_num() - if (i==0) then - call mrsc2_dressing_collector(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old) - else - call mrsc2_dressing_slave_inproc(i) - endif - !$OMP END PARALLEL - -! rc = pthread_join(collector_thread) - call end_parallel_job(zmq_to_qp_run_socket, 'mrsc2') - - -END_PROVIDER - - - diff --git a/plugins/mrcc_selected/ezfio_interface.irp.f b/plugins/mrcc_selected/ezfio_interface.irp.f deleted file mode 100644 index 062af449..00000000 --- a/plugins/mrcc_selected/ezfio_interface.irp.f +++ /dev/null @@ -1,61 +0,0 @@ -! DO NOT MODIFY BY HAND -! Created by $QP_ROOT/scripts/ezfio_interface/ei_handler.py -! from file /home/scemama/quantum_package/src/mrcc_selected/EZFIO.cfg - - -BEGIN_PROVIDER [ double precision, thresh_dressed_ci ] - implicit none - BEGIN_DOC -! Threshold on the convergence of the dressed CI energy - END_DOC - - logical :: has - PROVIDE ezfio_filename - - call ezfio_has_mrcc_selected_thresh_dressed_ci(has) - if (has) then - call ezfio_get_mrcc_selected_thresh_dressed_ci(thresh_dressed_ci) - else - print *, 'mrcc_selected/thresh_dressed_ci not found in EZFIO file' - stop 1 - endif - -END_PROVIDER - -BEGIN_PROVIDER [ integer, n_it_max_dressed_ci ] - implicit none - BEGIN_DOC -! Maximum number of dressed CI iterations - END_DOC - - logical :: has - PROVIDE ezfio_filename - - call ezfio_has_mrcc_selected_n_it_max_dressed_ci(has) - if (has) then - call ezfio_get_mrcc_selected_n_it_max_dressed_ci(n_it_max_dressed_ci) - else - print *, 'mrcc_selected/n_it_max_dressed_ci not found in EZFIO file' - stop 1 - endif - -END_PROVIDER - -BEGIN_PROVIDER [ integer, lambda_type ] - implicit none - BEGIN_DOC -! lambda type - END_DOC - - logical :: has - PROVIDE ezfio_filename - - call ezfio_has_mrcc_selected_lambda_type(has) - if (has) then - call ezfio_get_mrcc_selected_lambda_type(lambda_type) - else - print *, 'mrcc_selected/lambda_type not found in EZFIO file' - stop 1 - endif - -END_PROVIDER diff --git a/plugins/mrcc_selected/mrcc_selected.irp.f b/plugins/mrcc_selected/mrcc_selected.irp.f deleted file mode 100644 index 91592e62..00000000 --- a/plugins/mrcc_selected/mrcc_selected.irp.f +++ /dev/null @@ -1,19 +0,0 @@ -program mrsc2sub - implicit none - double precision, allocatable :: energy(:) - allocate (energy(N_states)) - - !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc - mrmode = 3 - - read_wf = .True. - SOFT_TOUCH read_wf - call print_cas_coefs - call set_generators_bitmasks_as_holes_and_particles - call run(N_states,energy) - if(do_pt2_end)then - call run_pt2(N_states,energy) - endif - deallocate(energy) -end - diff --git a/plugins/mrcc_selected/mrcepa0_general.irp.f b/plugins/mrcc_selected/mrcepa0_general.irp.f deleted file mode 100644 index e3a2d1f5..00000000 --- a/plugins/mrcc_selected/mrcepa0_general.irp.f +++ /dev/null @@ -1,245 +0,0 @@ - - -subroutine run(N_st,energy) - implicit none - - integer, intent(in) :: N_st - double precision, intent(out) :: energy(N_st) - - integer :: i,j - - double precision :: E_new, E_old, delta_e - integer :: iteration - double precision :: E_past(4) - - integer :: n_it_mrcc_max - double precision :: thresh_mrcc - double precision, allocatable :: lambda(:) - allocate (lambda(N_states)) - - - thresh_mrcc = thresh_dressed_ci - n_it_mrcc_max = n_it_max_dressed_ci - - if(n_it_mrcc_max == 1) then - do j=1,N_states_diag - do i=1,N_det - psi_coef(i,j) = CI_eigenvectors_dressed(i,j) - enddo - enddo - SOFT_TOUCH psi_coef ci_energy_dressed - call write_double(6,ci_energy_dressed(1),"Final MRCC energy") - call ezfio_set_mrcepa0_energy(ci_energy_dressed(1)) - call save_wavefunction - energy(:) = ci_energy_dressed(:) - else - E_new = 0.d0 - delta_E = 1.d0 - iteration = 0 - lambda = 1.d0 - do while (delta_E > thresh_mrcc) - iteration += 1 - print *, '===========================' - print *, 'MRCEPA0 Iteration', iteration - print *, '===========================' - print *, '' - E_old = sum(ci_energy_dressed) - call write_double(6,ci_energy_dressed(1),"MRCEPA0 energy") - call diagonalize_ci_dressed(lambda) - E_new = sum(ci_energy_dressed) - delta_E = dabs(E_new - E_old) - call save_wavefunction - call ezfio_set_mrcepa0_energy(ci_energy_dressed(1)) - if (iteration >= n_it_mrcc_max) then - exit - endif - enddo - call write_double(6,ci_energy_dressed(1),"Final MRCEPA0 energy") - energy(:) = ci_energy_dressed(:) - endif -end - - -subroutine print_cas_coefs - implicit none - - integer :: i,j - print *, 'CAS' - print *, '===' - do i=1,N_det_cas - print *, (psi_cas_coef(i,j), j=1,N_states) - call debug_det(psi_cas(1,1,i),N_int) - enddo - call write_double(6,ci_energy(1),"Initial CI energy") - -end - - - - -subroutine run_pt2_old(N_st,energy) - implicit none - integer :: i,j,k - integer, intent(in) :: N_st - double precision, intent(in) :: energy(N_st) - double precision :: pt2_redundant(N_st), pt2(N_st) - double precision :: norm_pert(N_st),H_pert_diag(N_st) - - pt2_redundant = 0.d0 - pt2 = 0d0 - !if(lambda_mrcc_pt2(0) == 0) return - - print*,'Last iteration only to compute the PT2' - - print * ,'Computing the redundant PT2 contribution' - - if (mrmode == 1) then - - N_det_generators = lambda_mrcc_kept(0) - N_det_selectors = lambda_mrcc_kept(0) - - do i=1,N_det_generators - j = lambda_mrcc_kept(i) - do k=1,N_int - psi_det_generators(k,1,i) = psi_non_ref(k,1,j) - psi_det_generators(k,2,i) = psi_non_ref(k,2,j) - psi_selectors(k,1,i) = psi_non_ref(k,1,j) - psi_selectors(k,2,i) = psi_non_ref(k,2,j) - enddo - do k=1,N_st - psi_coef_generators(i,k) = psi_non_ref_coef(j,k) - psi_selectors_coef(i,k) = psi_non_ref_coef(j,k) - enddo - enddo - - else - - N_det_generators = N_det_non_ref - N_det_selectors = N_det_non_ref - - do i=1,N_det_generators - j = i - do k=1,N_int - psi_det_generators(k,1,i) = psi_non_ref(k,1,j) - psi_det_generators(k,2,i) = psi_non_ref(k,2,j) - psi_selectors(k,1,i) = psi_non_ref(k,1,j) - psi_selectors(k,2,i) = psi_non_ref(k,2,j) - enddo - do k=1,N_st - psi_coef_generators(i,k) = psi_non_ref_coef(j,k) - psi_selectors_coef(i,k) = psi_non_ref_coef(j,k) - enddo - enddo - - endif - - SOFT_TOUCH N_det_selectors psi_selectors_coef psi_selectors N_det_generators psi_det_generators psi_coef_generators ci_eigenvectors_dressed ci_eigenvectors_s2_dressed ci_electronic_energy_dressed - SOFT_TOUCH psi_ref_coef_diagonalized psi_ref_energy_diagonalized - - call H_apply_mrcepa_PT2(pt2_redundant, norm_pert, H_pert_diag, N_st) - - print * ,'Computing the remaining contribution' - - threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) - threshold_generators = max(threshold_generators,threshold_generators_pt2) - - N_det_generators = N_det_non_ref + N_det_ref - N_det_selectors = N_det_non_ref + N_det_ref - - psi_det_generators(:,:,:N_det_ref) = psi_ref(:,:,:N_det_ref) - psi_selectors(:,:,:N_det_ref) = psi_ref(:,:,:N_det_ref) - psi_coef_generators(:N_det_ref,:) = psi_ref_coef(:N_det_ref,:) - psi_selectors_coef(:N_det_ref,:) = psi_ref_coef(:N_det_ref,:) - - do i=N_det_ref+1,N_det_generators - j = i-N_det_ref - do k=1,N_int - psi_det_generators(k,1,i) = psi_non_ref(k,1,j) - psi_det_generators(k,2,i) = psi_non_ref(k,2,j) - psi_selectors(k,1,i) = psi_non_ref(k,1,j) - psi_selectors(k,2,i) = psi_non_ref(k,2,j) - enddo - do k=1,N_st - psi_coef_generators(i,k) = psi_non_ref_coef(j,k) - psi_selectors_coef(i,k) = psi_non_ref_coef(j,k) - enddo - enddo - - SOFT_TOUCH N_det_selectors psi_selectors_coef psi_selectors N_det_generators psi_det_generators psi_coef_generators ci_eigenvectors_dressed ci_eigenvectors_s2_dressed ci_electronic_energy_dressed - SOFT_TOUCH psi_ref_coef_diagonalized psi_ref_energy_diagonalized - - call H_apply_mrcepa_PT2(pt2, norm_pert, H_pert_diag, N_st) - - - print *, "Redundant PT2 :",pt2_redundant - print *, "Full PT2 :",pt2 - print *, lambda_mrcc_kept(0), N_det, N_det_ref, psi_coef(1,1), psi_ref_coef(1,1) - pt2 = pt2 - pt2_redundant - - print *, 'Final step' - print *, 'N_det = ', N_det - print *, 'N_states = ', N_states - print *, 'PT2 = ', pt2 - print *, 'E = ', energy - print *, 'E+PT2 = ', energy+pt2 - print *, '-----' - - - call ezfio_set_mrcepa0_energy_pt2(energy(1)+pt2(1)) - -end - -subroutine run_pt2(N_st,energy) - implicit none - integer :: i,j,k - integer, intent(in) :: N_st - double precision, intent(in) :: energy(N_st) - double precision :: pt2(N_st) - double precision :: norm_pert(N_st),H_pert_diag(N_st) - - pt2 = 0d0 - !if(lambda_mrcc_pt2(0) == 0) return - - print*,'Last iteration only to compute the PT2' - - N_det_generators = N_det_cas - N_det_selectors = N_det_non_ref - - do i=1,N_det_generators - do k=1,N_int - psi_det_generators(k,1,i) = psi_ref(k,1,i) - psi_det_generators(k,2,i) = psi_ref(k,2,i) - enddo - do k=1,N_st - psi_coef_generators(i,k) = psi_ref_coef(i,k) - enddo - enddo - do i=1,N_det - do k=1,N_int - psi_selectors(k,1,i) = psi_det_sorted(k,1,i) - psi_selectors(k,2,i) = psi_det_sorted(k,2,i) - enddo - do k=1,N_st - psi_selectors_coef(i,k) = psi_coef_sorted(i,k) - enddo - enddo - - SOFT_TOUCH N_det_selectors psi_selectors_coef psi_selectors N_det_generators psi_det_generators psi_coef_generators ci_eigenvectors_dressed ci_eigenvectors_s2_dressed ci_electronic_energy_dressed - SOFT_TOUCH psi_ref_coef_diagonalized psi_ref_energy_diagonalized - - call H_apply_mrcepa_PT2(pt2, norm_pert, H_pert_diag, N_st) - -! call ezfio_set_full_ci_energy_pt2(energy+pt2) - - print *, 'Final step' - print *, 'N_det = ', N_det - print *, 'N_states = ', N_states - print *, 'PT2 = ', pt2 - print *, 'E = ', energy - print *, 'E+PT2 = ', energy+pt2 - print *, '-----' - - call ezfio_set_mrcepa0_energy_pt2(energy(1)+pt2(1)) - -end - diff --git a/plugins/mrcepa0/.gitignore b/plugins/mrcepa0/.gitignore deleted file mode 100644 index 7ac9fbf6..00000000 --- a/plugins/mrcepa0/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -IRPF90_temp/ -IRPF90_man/ -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/mrcepa0/EZFIO.cfg b/plugins/mrcepa0/EZFIO.cfg index b64637e6..53519ec7 100644 --- a/plugins/mrcepa0/EZFIO.cfg +++ b/plugins/mrcepa0/EZFIO.cfg @@ -14,6 +14,12 @@ type: double precision doc: Calculated energy with PT2 contribution interface: ezfio +[perturbative_triples] +type: logical +doc: Compute perturbative contribution of the Triples +interface: ezfio,provider,ocaml +default: false + [energy] type: double precision doc: Calculated energy diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index 3579e3c8..2820750f 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -13,6 +13,7 @@ use bitmasks integer(bit_kind),allocatable :: buf(:,:,:) logical :: ok logical, external :: detEq + integer, external :: omp_get_thread_num delta_ij_mrcc = 0d0 delta_ii_mrcc = 0d0 @@ -23,7 +24,7 @@ use bitmasks !$OMP PARALLEL DO default(none) schedule(dynamic) & !$OMP shared(psi_det_generators, N_det_generators, hh_exists, pp_exists, N_int, hh_shortcut) & !$OMP shared(N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc, delta_ii_s2_mrcc, delta_ij_s2_mrcc) & - !$OMP private(h, n, mask, omask, buf, ok, iproc) + !$OMP private(h, n, mask, omask, buf, ok, iproc) do gen= 1, N_det_generators allocate(buf(N_int, 2, N_det_non_ref)) iproc = omp_get_thread_num() + 1 @@ -37,7 +38,7 @@ use bitmasks do p=hh_shortcut(h), hh_shortcut(h+1)-1 call apply_particle_local(mask, pp_exists(1, p), buf(1,1,n), ok, N_int) if(ok) n = n + 1 - if(n > N_det_non_ref) stop "MRCC..." + if(n > N_det_non_ref) stop "Buffer too small in MRCC..." end do n = n - 1 @@ -74,9 +75,9 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen logical :: good, fullMatch integer(bit_kind),allocatable :: tq(:,:,:) - integer :: N_tq, c_ref ,degree + integer :: N_tq, c_ref ,degree1, degree2, degree - double precision :: hIk, hla, hIl, sla, dIk(N_states), dka(N_states), dIa(N_states) + double precision :: hIk, hla, hIl, sla, dIk(N_states), dka(N_states), dIa(N_states), hka double precision, allocatable :: dIa_hla(:,:), dIa_sla(:,:) double precision :: haj, phase, phase2 double precision :: f(N_states), ci_inv(N_states) @@ -99,6 +100,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen !double precision, external :: get_dij, get_dij_index + leng = max(N_det_generators, N_det_non_ref) allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref), sij_cache(N_det_non_ref)) allocate(idx_alpha(0:psi_det_size), degree_alpha(psi_det_size)) @@ -189,17 +191,25 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen end do end if + if (perturbative_triples) then + double precision :: Delta_E_inv(N_states) + double precision, external :: diag_H_mat_elem + do i_state=1,N_states + Delta_E_inv(i_state) = 1.d0 / (psi_ref_energy_diagonalized(i_state) - diag_H_mat_elem(tq(1,1,i_alpha),N_int) ) + enddo + endif do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd)) call get_s2(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,sij_cache(k_sd)) enddo + ! |I> do i_I=1,N_det_ref ! Find triples and quadruple grand parents - call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree,Nint) - if (degree > 4) then + call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree1,Nint) + if (degree1 > 4) then cycle endif @@ -209,77 +219,57 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen ! |alpha> do k_sd=1,idx_alpha(0) - ! Loop if lambda == 0 - logical :: loop -! loop = .True. -! do i_state=1,N_states -! if (lambda_mrcc(i_state,idx_alpha(k_sd)) /= 0.d0) then -! loop = .False. -! exit -! endif -! enddo -! if (loop) then -! cycle -! endif - + call get_excitation_degree(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),degree,Nint) if (degree > 2) then cycle endif - + ! - ! - !hIk = hij_mrcc(idx_alpha(k_sd),i_I) - ! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk) - - do i_state=1,N_states - dIK(i_state) = dij(i_I, idx_alpha(k_sd), i_state) - !dIk(i_state) = get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,idx_alpha(k_sd)), N_int) !!hIk * lambda_mrcc(i_state,idx_alpha(k_sd)) - !dIk(i_state) = psi_non_ref_coef(idx_alpha(k_sd), i_state) / psi_ref_coef(i_I, i_state) - enddo - ! |l> = Exc(k -> alpha) |I> - call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree2,phase,Nint) + call decode_exc(exc,degree2,h1,p1,h2,p2,s1,s2) do k=1,N_int tmp_det(k,1) = psi_ref(k,1,i_I) tmp_det(k,2) = psi_ref(k,2,i_I) enddo logical :: ok call apply_excitation(psi_ref(1,1,i_I), exc, tmp_det, ok, Nint) - if(.not. ok) cycle + if (perturbative_triples) then + ok = ok .and. ( (degree2 /= 1).and.(degree /=1) ) + endif + + do i_state=1,N_states + dIK(i_state) = dij(i_I, idx_alpha(k_sd), i_state) + enddo ! do i_state=1,N_states dka(i_state) = 0.d0 enddo - do l_sd=k_sd+1,idx_alpha(0) - call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint) - if (degree == 0) then - -! loop = .True. -! do i_state=1,N_states -! if (lambda_mrcc(i_state,idx_alpha(l_sd)) /= 0.d0) then -! loop = .False. -! exit -! endif -! enddo - loop = .false. - if (.not.loop) then + + if (ok) then + do l_sd=k_sd+1,idx_alpha(0) + call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint) + if (degree == 0) then call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint) - hIl = hij_mrcc(idx_alpha(l_sd),i_I) -! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl) do i_state=1,N_states dka(i_state) = dij(i_I, idx_alpha(l_sd), i_state) * phase * phase2 - !dka(i_state) = get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,idx_alpha(l_sd)), N_int) * phase * phase2 !hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2 - !dka(i_state) = psi_non_ref_coef(idx_alpha(l_sd), i_state) / psi_ref_coef(i_I, i_state) * phase * phase2 enddo + exit endif + enddo + + else if (perturbative_triples) then + + hka = hij_cache(idx_alpha(k_sd)) + do i_state=1,N_states + dka(i_state) = hka * Delta_E_inv(i_state) + enddo + + endif - exit - endif - enddo do i_state=1,N_states dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state) enddo @@ -292,32 +282,35 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen k_sd = idx_alpha(l_sd) hla = hij_cache(k_sd) sla = sij_cache(k_sd) -! call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla) do i_state=1,N_states dIa_hla(i_state,k_sd) = dIa(i_state) * hla dIa_sla(i_state,k_sd) = dIa(i_state) * sla enddo enddo - call omp_set_lock( psi_ref_lock(i_I) ) do i_state=1,N_states if(dabs(psi_ref_coef(i_I,i_state)).ge.1.d-3)then do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) + !$OMP ATOMIC delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) + !$OMP ATOMIC delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) + !$OMP ATOMIC delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + dIa_sla(i_state,k_sd) + !$OMP ATOMIC delta_ii_s2_(i_state,i_I) = delta_ii_s2_(i_state,i_I) - dIa_sla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) enddo else delta_ii_(i_state,i_I) = 0.d0 do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) + !$OMP ATOMIC delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + 0.5d0*dIa_hla(i_state,k_sd) + !$OMP ATOMIC delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + 0.5d0*dIa_sla(i_state,k_sd) enddo endif enddo - call omp_unset_lock( psi_ref_lock(i_I) ) enddo enddo deallocate (dIa_hla,dIa_sla,hij_cache,sij_cache) @@ -691,7 +684,7 @@ subroutine getHP(a,h,p,Nint) end do lh h = deg !isInCassd = .true. -end subroutine +end function BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij, (N_det_ref,N_det_non_ref,N_states) ] @@ -716,9 +709,6 @@ end subroutine integer :: II, blok integer*8, save :: notf = 0 - - PROVIDE psi_ref_coef psi_non_ref_coef - call wall_time(wall) allocate(idx_sorted_bit(N_det), sortRef(N_int,2,N_det_ref)) @@ -842,7 +832,8 @@ END_PROVIDER delta_sub_ij(:,:,:) = 0d0 delta_sub_ii(:,:) = 0d0 - provide mo_bielec_integrals_in_map N_det_non_ref psi_ref_coef psi_non_ref_coef + provide mo_bielec_integrals_in_map + !$OMP PARALLEL DO default(none) schedule(dynamic,10) shared(delta_sub_ij, delta_sub_ii) & !$OMP private(i, J, k, degree, degree2, l, deg, ni) & diff --git a/plugins/mrcepa0/dressing_slave.irp.f b/plugins/mrcepa0/dressing_slave.irp.f index 9e9fa65a..487e6ed3 100644 --- a/plugins/mrcepa0/dressing_slave.irp.f +++ b/plugins/mrcepa0/dressing_slave.irp.f @@ -315,13 +315,13 @@ subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id) stop 'error' 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 + ! 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 end @@ -389,13 +389,13 @@ subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, endif -! ! 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 + ! 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 end diff --git a/plugins/mrcepa0/mrcc.irp.f b/plugins/mrcepa0/mrcc.irp.f index a5614942..bb184761 100644 --- a/plugins/mrcepa0/mrcc.irp.f +++ b/plugins/mrcepa0/mrcc.irp.f @@ -5,7 +5,7 @@ program mrsc2sub !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc mrmode = 3 - + read_wf = .True. SOFT_TOUCH read_wf call set_generators_bitmasks_as_holes_and_particles diff --git a/promela/integrals.pml b/promela/integrals.pml new file mode 100644 index 00000000..7b05156f --- /dev/null +++ b/promela/integrals.pml @@ -0,0 +1,272 @@ +#define NPROC 1 +#define BUFSIZE 2 +#define NTASKS 3 + +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 + } + +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 }; +} + +#define send_req( MESSAGE, VALUE ) msg.m=MESSAGE ; msg.value=VALUE ; msg.state=state; rep_socket ! msg; msg.reply ? reply + +chan rep_socket = [NPROC] of { req_message }; +chan pull_socket = [NPROC] of { byte }; +chan pair_socket = [NPROC] of { req_message }; +chan task_queue = [NTASKS+2] of { byte }; +chan pub_socket = [NTASKS+2] of { mtype }; + +bit socket_up = 0; +mtype global_state; /* Sent by pub */ + +active proctype qp_run() { + + bit psi = 0; + bit address_tcp = 0; + bit address_inproc = 0; + bit running = 0; + byte status = 0; + byte state = 0; + byte ntasks = 0; + req_message msg; + rep_message reply; + byte nclients = 0; + byte task; + + socket_up = 1; + running = 1; + do +// :: ( (running == 0) && (nclients == 0) && (ntasks == 0) ) -> break + :: ( running == 0 ) -> break + :: else -> + + rep_socket ? msg; + printf("req: "); printm(msg.m); printf("\t%d\n",msg.value); + + if + :: ( msg.m == TERMINATE ) -> + assert (state != 0); + assert (msg.state == state); + running = 0; + reply.m = OK; + + :: ( msg.m == PUTPSI ) -> + assert (state != 0); + assert (msg.state == state); + assert (psi == 0); + psi = 1; + reply.m = PUTPSI_REPLY; + + :: ( msg.m == GETPSI ) -> + assert (state != 0); + assert (msg.state == state); + assert (psi == 1); + reply.m = PSI; + + :: ( msg.m == NEWJOB ) -> + assert (state == 0); + state = msg.value; + pair_socket ! WAITING; + reply.m = OK; + reply.value = state; + + :: ( msg.m == ENDJOB ) -> + assert (state != 0); + assert (msg.state == state); + state = 0; + pair_socket ! WAITING; + reply.m = OK; + + :: ( msg.m == ADDTASK ) -> + assert (state != 0); + assert (msg.state == state); + task_queue ! msg.value; + ntasks++; + reply.m = OK; + + :: ( msg.m == GETTASK ) -> + assert (nclients > 0); + assert (state != 0); + assert (msg.state == state); + if + :: ( task_queue ?[task] ) -> + pair_socket ! WAITING; + reply.m = TASK; + task_queue ? reply.value + :: else -> + pair_socket ! RUNNING; + reply.m = NONE; + reply.value = 255; + fi; + + :: ( msg.m == TASKDONE) -> + assert (state != 0); + assert (msg.state == state); + assert (nclients > 0); + assert (ntasks > 0); + reply.m = OK; + + :: ( msg.m == DELTASK ) -> + assert (state != 0); + assert (msg.state == state); + ntasks--; + if + :: (ntasks > 0) -> reply.value = 1; + :: else -> reply.value = 0; + fi; + reply.m = OK; + + :: ( msg.m == CONNECT ) -> + assert ( state != 0 ) + nclients++; + reply.m = OK; + reply.value = state; + + :: ( msg.m == DISCONNECT ) -> + assert ( msg.state == state ) + nclients--; + reply.m = OK; + + :: ( msg.m == STOPPED ) -> + pair_socket ! STOPPED; + reply.m = OK; + + :: ( msg.m == WAITING ) -> + pair_socket ! WAITING; + reply.m = OK; + + :: ( msg.m == RUNNING ) -> + assert ( state != 0 ); + pair_socket ! RUNNING; + reply.m = OK; + + fi + msg.reply ! reply + od + pair_socket ! STOPPED; + socket_up = 0; + +} + + +active proctype master() { + + req_message msg; + rep_message reply; + byte state = 0; + byte count; + + run pub_thread(); + + /* New parallel job */ + state=1; + send_req( NEWJOB, state ); + assert (reply.m == OK); + + /* Add tasks */ + count = 0; + do + :: (count == NTASKS) -> break; + :: else -> + count++; + send_req( ADDTASK, count ); + assert (reply.m == OK); + od + + /* Run collector */ + run collector(state); + + /* Run slaves */ + count = 0; + do + :: (count == NPROC) -> break; + :: else -> count++; run slave(); + od + +} + +proctype slave() { + + req_message msg; + rep_message reply; + byte task; + byte state; + + msg.m=CONNECT; + msg.state = 0; + + if + :: (!socket_up) -> goto exit; + :: else -> skip; + fi + rep_socket ! msg; + + if + :: (!socket_up) -> goto exit; + :: else -> skip; + fi + msg.reply ? reply; + + state = reply.value; + + + task = 1; + do + :: (task == 255) -> break; + :: else -> + send_req( GETTASK, 0); + if + :: (reply.m == NONE) -> + task = 255; + :: (reply.m == TASK) -> + /* Compute task */ + task = reply.value; + send_req( TASKDONE, task); + assert (reply.m == OK); + pull_socket ! task; + fi + od + send_req( DISCONNECT, 0); + assert (reply.m == OK); + +exit: skip; +} + +proctype collector(byte state) { + byte task; + req_message msg; + rep_message reply; + bit loop = 1; + do + :: (loop == 0) -> break + :: else -> + pull_socket ? task; + /* Handle result */ + send_req(DELTASK, task); + assert (reply.m == OK); + loop = reply.value; + od + send_req( TERMINATE, 0); + assert (reply.m == OK); +} + +proctype pub_thread() { + mtype state = WAITING; + do + :: (state == STOPPED) -> break; + :: (pair_socket ? [state]) -> + pair_socket ? state; + global_state = state; + od +} diff --git a/scripts/ezfio_interface/qp_edit_template b/scripts/ezfio_interface/qp_edit_template index 9c7a1386..af9b295c 100644 --- a/scripts/ezfio_interface/qp_edit_template +++ b/scripts/ezfio_interface/qp_edit_template @@ -1,6 +1,10 @@ -open Qputils;; -open Qptypes;; -open Core.Std;; +(* + vim::syntax=ocaml + *) + +open Qputils +open Qptypes +open Core.Std (** Interactive editing of the input. @@ -18,7 +22,7 @@ type keyword = | Mo_basis | Nuclei {keywords} -;; + let keyword_to_string = function @@ -28,7 +32,7 @@ let keyword_to_string = function | Mo_basis -> "MO basis" | Nuclei -> "Molecule" {keywords_to_string} -;; + @@ -42,7 +46,7 @@ let file_header filename = Editing file `%s` " filename -;; + (** Creates the header of a section *) @@ -50,7 +54,7 @@ let make_header kw = let s = keyword_to_string kw in let l = String.length s in "\n\n"^s^"\n"^(String.init l ~f:(fun _ -> '='))^"\n\n" -;; + (** Returns the rst string of section [s] *) @@ -82,7 +86,7 @@ let get s = | Sys_error msg -> (Printf.eprintf "Info: %s\n%!" msg ; "") in rst -;; + (** Applies the changes from the string [str] corresponding to section [s] *) @@ -121,7 +125,7 @@ let set str s = | Ao_basis -> () (* TODO *) | Mo_basis -> () (* TODO *) end -;; + (** Creates the temporary file for interactive editing *) @@ -135,11 +139,19 @@ let create_temp_file ezfio_filename fields = ) end ; temp_filename -;; + -let run check_only ezfio_filename = + +let run check_only ?ndet ?state ezfio_filename = + + (* Set check_only if the arguments are not empty *) + let check_only = + match ndet, state with + | None, None -> check_only + | _ -> true + in (* Open EZFIO *) if (not (Sys.file_exists_exn ezfio_filename)) then @@ -147,6 +159,19 @@ let run check_only ezfio_filename = Ezfio.set_file ezfio_filename; + begin + match ndet with + | None -> () + | Some n -> Input.Determinants_by_hand.update_ndet (Det_number.of_int n) + end; + + begin + match state with + | None -> () + | Some n -> Input.Determinants_by_hand.extract_state (States_number.of_int n) + end; + + (* let output = (file_header ezfio_filename) :: ( List.map ~f:get [ @@ -196,7 +221,7 @@ let run check_only ezfio_filename = (* Remove temp_file *) Sys.remove temp_filename -;; + (** Create a backup file in case of an exception *) @@ -207,7 +232,7 @@ let create_backup ezfio_filename = " ezfio_filename ezfio_filename ezfio_filename |> Sys.command_exn -;; + (** Restore the backup file when an exception occuprs *) @@ -215,7 +240,7 @@ let restore_backup ezfio_filename = Printf.sprintf "tar -zxf %s/backup.tgz" ezfio_filename |> Sys.command_exn -;; + let spec = @@ -223,12 +248,12 @@ let spec = empty +> flag "-c" no_arg ~doc:"Checks the input data" -(* - +> flag "o" (optional string) - ~doc:"Prints output data" -*) + +> flag "ndet" (optional int) + ~doc:"int Truncate the wavefunction to the target number of determinants" + +> flag "state" (optional int) + ~doc:"int Pick the state as a new wavefunction." +> anon ("ezfio_file" %: string) -;; + let command = Command.basic @@ -245,9 +270,9 @@ Edit input data with | _ msg -> print_string ("\n\nError\n\n"^msg^"\n\n") *) - (fun c ezfio_file () -> + (fun c ndet state ezfio_file () -> try - run c ezfio_file ; + run c ?ndet ?state ezfio_file ; (* create_backup ezfio_file; *) with | Failure exc @@ -268,12 +293,12 @@ Edit input data raise e end ) -;; + let () = Command.run command; exit 0 -;; + diff --git a/scripts/module/module_handler.py b/scripts/module/module_handler.py index 7c729827..e6a13441 100755 --- a/scripts/module/module_handler.py +++ b/scripts/module/module_handler.py @@ -254,7 +254,7 @@ if __name__ == '__main__': except RuntimeError: pass except SyntaxError: - print "Warning: The graphviz API drop support of python 2.6." + print "Warning: The graphviz API dropped support for python 2.6." pass if arguments["clean"] or arguments["create_git_ignore"]: @@ -302,7 +302,7 @@ if __name__ == '__main__': from is_master_repository import is_master_repository if not is_master_repository: print >> sys.stderr, 'Not in the master repo' - sys.exit() + sys.exit(0) path = os.path.join(module_abs, ".gitignore") diff --git a/src/.gitignore b/src/.gitignore deleted file mode 100644 index 535e4bd5..00000000 --- a/src/.gitignore +++ /dev/null @@ -1,28 +0,0 @@ -CAS_SD -CID -CID_SC2_selected -CID_selected -CIS -CISD -CISD_SC2_selected -CISD_selected -DDCI_selected -DensityMatrix -FCIdump -Full_CI -Generators_CAS -Generators_full -Generators_restart -Hartree_Fock -Molden -MP2 -MRCC -Perturbation -Properties -QmcChem -Selectors_full -Selectors_no_sorted -SingleRefMethod -Casino -loc_cele -Alavi \ No newline at end of file diff --git a/src/AO_Basis/.gitignore b/src/AO_Basis/.gitignore deleted file mode 100644 index 7305be49..00000000 --- a/src/AO_Basis/.gitignore +++ /dev/null @@ -1,15 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Nuclei -Ezfio_files -Utils \ No newline at end of file diff --git a/src/AO_Basis/aos.irp.f b/src/AO_Basis/aos.irp.f index 0938d3bd..f0f03fab 100644 --- a/src/AO_Basis/aos.irp.f +++ b/src/AO_Basis/aos.irp.f @@ -182,7 +182,7 @@ integer function ao_power_index(nx,ny,nz) end -BEGIN_PROVIDER [ character*(128), l_to_charater, (0:4)] +BEGIN_PROVIDER [ character*(128), l_to_charater, (0:7)] BEGIN_DOC ! character corresponding to the "L" value of an AO orbital END_DOC @@ -192,6 +192,9 @@ BEGIN_PROVIDER [ character*(128), l_to_charater, (0:4)] l_to_charater(2)='D' l_to_charater(3)='F' l_to_charater(4)='G' + l_to_charater(5)='H' + l_to_charater(6)='I' + l_to_charater(7)='J' END_PROVIDER diff --git a/src/Bitmask/.gitignore b/src/Bitmask/.gitignore deleted file mode 100644 index 2b7b2272..00000000 --- a/src/Bitmask/.gitignore +++ /dev/null @@ -1,18 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Ezfio_files -MO_Basis -Utils -AO_Basis -Electrons -Nuclei \ No newline at end of file diff --git a/src/Bitmask/bitmasks.irp.f b/src/Bitmask/bitmasks.irp.f index 964c4ed8..e50cf25a 100644 --- a/src/Bitmask/bitmasks.irp.f +++ b/src/Bitmask/bitmasks.irp.f @@ -2,10 +2,16 @@ use bitmasks BEGIN_PROVIDER [ integer, N_int ] implicit none + include 'Utils/constants.include.F' BEGIN_DOC ! Number of 64-bit integers needed to represent determinants as binary strings END_DOC N_int = (mo_tot_num-1)/bit_kind_size + 1 + call write_int(6,N_int, 'N_int') + if (N_int > N_int_max) then + stop 'N_int > N_int_max' + endif + END_PROVIDER @@ -386,6 +392,8 @@ END_PROVIDER n_virt_orb += popcnt(virt_bitmask(i,1)) enddo endif + call write_int(6,n_inact_orb, 'Number of inactive MOs') + call write_int(6,n_virt_orb, 'Number of virtual MOs') END_PROVIDER @@ -554,7 +562,7 @@ END_PROVIDER &BEGIN_PROVIDER [ integer, n_core_orb] implicit none BEGIN_DOC - ! Core orbitals bitmask + ! Core + deleted orbitals bitmask END_DOC integer :: i,j n_core_orb = 0 @@ -563,7 +571,7 @@ END_PROVIDER core_bitmask(i,2) = xor(full_ijkl_bitmask(i),ior(reunion_of_cas_inact_bitmask(i,2),virt_bitmask(i,1))) n_core_orb += popcnt(core_bitmask(i,1)) enddo - print*,'n_core_orb = ',n_core_orb + call write_int(6,n_core_orb,'Number of core MOs') END_PROVIDER @@ -598,7 +606,7 @@ BEGIN_PROVIDER [ integer, n_act_orb] do i = 1, N_int n_act_orb += popcnt(cas_bitmask(i,1,1)) enddo - print*,'n_act_orb = ',n_act_orb + call write_int(6,n_act_orb, 'Number of active MOs') END_PROVIDER BEGIN_PROVIDER [integer, list_act, (n_act_orb)] diff --git a/src/Davidson/EZFIO.cfg b/src/Davidson/EZFIO.cfg index 7724400f..49a0f778 100644 --- a/src/Davidson/EZFIO.cfg +++ b/src/Davidson/EZFIO.cfg @@ -7,13 +7,13 @@ default: 1.e-12 [n_states_diag] type: States_number doc: Number of states to consider during the Davdison diagonalization -default: 10 +default: 4 interface: ezfio,provider,ocaml [davidson_sze_max] type: Strictly_positive_int doc: Number of micro-iterations before re-contracting -default: 10 +default: 8 interface: ezfio,provider,ocaml [state_following] @@ -28,3 +28,9 @@ doc: If true, disk space is used to store the vectors default: False interface: ezfio,provider,ocaml +[distributed_davidson] +type: logical +doc: If true, use the distributed algorithm +default: False +interface: ezfio,provider,ocaml + diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index cede52c9..68db35da 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -1,191 +1,6 @@ - -!brought to you by garniroy inc. - use bitmasks use f77_zmq -subroutine davidson_process(blockb, blockb2, N, idx, vt, st, bs, istep) - - implicit none - - - integer , intent(in) :: blockb, bs, blockb2, istep - integer , intent(inout) :: N - integer , intent(inout) :: idx(bs) - double precision , intent(inout) :: vt(N_states_diag, bs) - double precision , intent(inout) :: st(N_states_diag, bs) - - integer :: i,ii, j, sh, sh2, exa, ext, org_i, org_j, istate, ni, endi - integer(bit_kind) :: sorted_i(N_int) - double precision :: s2, hij - logical, allocatable :: wrotten(:) - - allocate(wrotten(bs)) - wrotten = .false. - PROVIDE dav_det - - ii=0 - sh = blockb - do sh2=1,shortcut_(0,1) - exa = 0 - do ni=1,N_int - exa = exa + popcnt(xor(version_(ni,sh,1), version_(ni,sh2,1))) - end do - if(exa > 2) cycle - - do i=blockb2+shortcut_(sh,1),shortcut_(sh+1,1)-1, istep - ii = i - shortcut_(blockb,1) + 1 - - org_i = sort_idx_(i,1) - do ni=1,N_int - sorted_i(ni) = sorted_(ni,i,1) - enddo - - do j=shortcut_(sh2,1), shortcut_(sh2+1,1)-1 - if(i == j) cycle - org_j = sort_idx_(j,1) - ext = exa - do ni=1,N_int - ext = ext + popcnt(xor(sorted_i(ni), sorted_(ni,j,1))) - end do - if(ext <= 4) then - call get_s2(dav_det(1,1,org_j),dav_det(1,1,org_i),n_int,s2) - call i_h_j (dav_det(1,1,org_j),dav_det(1,1,org_i),n_int,hij) - if(.not. wrotten(ii)) then - wrotten(ii) = .true. - idx(ii) = org_i - vt (:,ii) = 0d0 - st (:,ii) = 0d0 - end if - do istate=1,N_states_diag - vt (istate,ii) += hij*dav_ut(istate,org_j) - st (istate,ii) += s2*dav_ut(istate,org_j) - enddo - endif - enddo - enddo - enddo - - - if (blockb <= shortcut_(0,2)) then - sh=blockb - do sh2=sh, shortcut_(0,2), shortcut_(0,1) - do i=blockb2+shortcut_(sh2,2),shortcut_(sh2+1,2)-1, istep - ii += 1 - org_i = sort_idx_(i,2) - do j=shortcut_(sh2,2),shortcut_(sh2+1,2)-1 - if(i == j) cycle - org_j = sort_idx_(j,2) - ext = 0 - do ni=1,N_int - ext = ext + popcnt(xor(sorted_(ni,i,2), sorted_(ni,j,2))) - end do - if(ext == 4) then - call i_h_j (dav_det(1,1,org_j),dav_det(1,1,org_i),n_int,hij) - call get_s2(dav_det(1,1,org_j),dav_det(1,1,org_i),n_int,s2) - if(.not. wrotten(ii)) then - wrotten(ii) = .true. - idx(ii) = org_i - vt (:,ii) = 0d0 - st (:,ii) = 0d0 - end if - do istate=1,N_states_diag - vt (istate,ii) += hij*dav_ut(istate,org_j) - st (istate,ii) += s2*dav_ut(istate,org_j) - enddo - end if - end do - end do - enddo - endif - - N=0 - do i=1,bs - if(wrotten(i)) then - N += 1 - idx(N) = idx(i) - vt(:,N) = vt(:,i) - st(:,N) = st(:,i) - end if - end do - - -end subroutine - - - - -subroutine davidson_collect(N, idx, vt, st , v0t, s0t) - implicit none - - - integer , intent(in) :: N - integer , intent(in) :: idx(N) - double precision , intent(in) :: vt(N_states_diag, N) - double precision , intent(in) :: st(N_states_diag, N) - double precision , intent(inout) :: v0t(N_states_diag,dav_size) - double precision , intent(inout) :: s0t(N_states_diag,dav_size) - - integer :: i, j, k - - !DIR$ IVDEP - do i=1,N - k = idx(i) - !DIR$ IVDEP - do j=1,N_states_diag - v0t(j,k) = v0t(j,k) + vt(j,i) - s0t(j,k) = s0t(j,k) + st(j,i) - enddo - end do -end subroutine - - -subroutine davidson_init(zmq_to_qp_run_socket,n,n_st_8,ut) - use f77_zmq - implicit none - - integer(ZMQ_PTR), intent(out) :: zmq_to_qp_run_socket - integer, intent(in) :: n, n_st_8 - double precision, intent(in) :: ut(n_st_8,n) - integer :: i,k - - - dav_size = n - touch dav_size - - do i=1,n - do k=1,N_int - dav_det(k,1,i) = psi_det(k,1,i) - dav_det(k,2,i) = psi_det(k,2,i) - enddo - enddo - do i=1,n - do k=1,N_states_diag - dav_ut(k,i) = ut(k,i) - enddo - enddo - - touch dav_det dav_ut - - call new_parallel_job(zmq_to_qp_run_socket,"davidson") -end subroutine - - - -subroutine davidson_add_task(zmq_to_qp_run_socket, blockb, blockb2, istep) - use f77_zmq - implicit none - - integer(ZMQ_PTR) ,intent(in) :: zmq_to_qp_run_socket - integer ,intent(in) :: blockb, blockb2, istep - character*(512) :: task - - - write(task,*) blockb, blockb2, istep - call add_task_to_taskserver(zmq_to_qp_run_socket, task) -end subroutine - - subroutine davidson_slave_inproc(i) implicit none @@ -211,8 +26,6 @@ subroutine davidson_run_slave(thread,iproc) integer, intent(in) :: thread, iproc integer :: worker_id, task_id, blockb - character*(512) :: task - integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket @@ -231,7 +44,7 @@ subroutine davidson_run_slave(thread,iproc) return end if - call davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, worker_id) + call davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_states_diag, N_det, worker_id) 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) @@ -239,338 +52,345 @@ end subroutine -subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, worker_id) +subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze, worker_id) use f77_zmq implicit none integer(ZMQ_PTR),intent(in) :: zmq_to_qp_run_socket integer(ZMQ_PTR),intent(in) :: zmq_socket_push - integer,intent(in) :: worker_id - integer :: task_id - character*(512) :: task + integer,intent(in) :: worker_id, N_st, sze + integer :: task_id + character*(512) :: msg + integer :: imin, imax, ishift, istep + double precision, allocatable :: v_0(:,:), s_0(:,:), u_t(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t, v_0, s_0 - integer :: blockb, blockb2, istep - integer :: N - integer , allocatable :: idx(:) - double precision , allocatable :: vt(:,:) - double precision , allocatable :: st(:,:) + ! Get wave function (u_t) + ! ----------------------- + + integer :: rc + 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 + + 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 + + if (rc /= worker_id) then + print *, 'Wrong worker ID' + stop 'error' + endif - integer :: bs, i, j - - allocate(idx(1), vt(1,1), st(1,1)) + if (N_states_read /= N_st) then + print *, N_st + stop 'error : N_st' + endif + + if (N_det_read /= N_det) then + N_det = N_det_read + TOUCH N_det + endif + + + allocate(v_0(sze,N_st), s_0(sze,N_st),u_t(N_st,N_det)) + + rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,0) + if (rc /= N_int*2*N_det*bit_kind) then + print *, 'f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,0)' + stop 'error' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,u_t,size(u_t)*8,0) + if (rc /= size(u_t)*8) then + print *, rc, size(u_t)*8 + print *, 'f77_zmq_recv(zmq_to_qp_run_socket,u_t,size(u_t)×8,0)' + stop 'error' + endif + + 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 + + ! Run tasks + ! --------- do - call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) + v_0 = 0.d0 + s_0 = 0.d0 + call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, msg) if(task_id == 0) exit - read (task,*) blockb, blockb2, istep - bs = shortcut_(blockb+1,1) - shortcut_(blockb, 1) - do i=blockb, shortcut_(0,2), shortcut_(0,1) - do j=i, min(i, shortcut_(0,2)) - bs += shortcut_(j+1,2) - shortcut_(j, 2) - end do - end do - if(bs > size(idx)) then - deallocate(idx, vt, st) - allocate(idx(bs)) - allocate(vt(N_states_diag, bs)) - allocate(st(N_states_diag, bs)) - end if - - call davidson_process(blockb, blockb2, N, idx, vt, st, bs, istep) + read (msg,*) imin, imax, ishift, istep + call H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,N_det,imin,imax,ishift,istep) call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) - call davidson_push_results(zmq_socket_push, blockb, blockb2, N, idx, vt, st, task_id) + call davidson_push_results(zmq_socket_push, v_0, s_0, task_id) end do + deallocate(v_0, s_0, u_t) end subroutine -subroutine davidson_push_results(zmq_socket_push, blockb, blocke, N, idx, vt, st, task_id) +subroutine davidson_push_results(zmq_socket_push, v_0, s_0, task_id) use f77_zmq implicit none integer(ZMQ_PTR) ,intent(in) :: zmq_socket_push integer ,intent(in) :: task_id - - integer ,intent(in) :: blockb, blocke - integer ,intent(in) :: N - integer ,intent(in) :: idx(N) - double precision ,intent(in) :: vt(N_states_diag, N) - double precision ,intent(in) :: st(N_states_diag, N) + double precision ,intent(in) :: v_0(N_det,N_states_diag) + double precision ,intent(in) :: s_0(N_det,N_states_diag) integer :: rc - rc = f77_zmq_send( zmq_socket_push, blockb, 4, ZMQ_SNDMORE) - if(rc /= 4) stop "davidson_push_results failed to push blockb" + rc = f77_zmq_send( zmq_socket_push, v_0, 8*N_states_diag*N_det, ZMQ_SNDMORE) + if(rc /= 8*N_states_diag* N_det) stop "davidson_push_results failed to push vt" - rc = f77_zmq_send( zmq_socket_push, blocke, 4, ZMQ_SNDMORE) - if(rc /= 4) stop "davidson_push_results failed to push blocke" - - rc = f77_zmq_send( zmq_socket_push, N, 4, ZMQ_SNDMORE) - if(rc /= 4) stop "davidson_push_results failed to push N" - - rc = f77_zmq_send( zmq_socket_push, idx, 4*N, ZMQ_SNDMORE) - if(rc /= 4*N) stop "davidson_push_results failed to push idx" - - rc = f77_zmq_send( zmq_socket_push, vt, 8*N_states_diag* N, ZMQ_SNDMORE) - if(rc /= 8*N_states_diag* N) stop "davidson_push_results failed to push vt" - - rc = f77_zmq_send( zmq_socket_push, st, 8*N_states_diag* N, ZMQ_SNDMORE) - if(rc /= 8*N_states_diag* N) stop "davidson_push_results failed to push st" + rc = f77_zmq_send( zmq_socket_push, s_0, 8*N_states_diag*N_det, ZMQ_SNDMORE) + if(rc /= 8*N_states_diag* N_det) stop "davidson_push_results failed to push st" rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0) 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 + end subroutine -subroutine davidson_pull_results(zmq_socket_pull, blockb, blocke, N, idx, vt, st, task_id) +subroutine davidson_pull_results(zmq_socket_pull, v_0, s_0, task_id) use f77_zmq implicit none integer(ZMQ_PTR) ,intent(in) :: zmq_socket_pull integer ,intent(out) :: task_id - integer ,intent(out) :: blockb, blocke - integer ,intent(out) :: N - integer ,intent(out) :: idx(*) - double precision ,intent(out) :: vt(N_states_diag, *) - double precision ,intent(out) :: st(N_states_diag, *) + double precision ,intent(out) :: v_0(N_det,N_states_diag) + double precision ,intent(out) :: s_0(N_det,N_states_diag) integer :: rc - rc = f77_zmq_recv( zmq_socket_pull, blockb, 4, 0) - if(rc /= 4) stop "davidson_push_results failed to pull blockb" - - rc = f77_zmq_recv( zmq_socket_pull, blocke, 4, 0) - if(rc /= 4) stop "davidson_push_results failed to pull blocke" - - rc = f77_zmq_recv( zmq_socket_pull, N, 4, 0) - if(rc /= 4) stop "davidson_push_results failed to pull N" - - rc = f77_zmq_recv( zmq_socket_pull, idx, 4*N, 0) - if(rc /= 4*N) stop "davidson_push_results failed to pull idx" + rc = f77_zmq_recv( zmq_socket_pull, v_0, 8*N_det*N_states_diag, 0) + if(rc /= 8*N_det*N_states_diag) stop "davidson_push_results failed to pull v_0" - rc = f77_zmq_recv( zmq_socket_pull, vt, 8*N_states_diag* N, 0) - if(rc /= 8*N_states_diag* N) stop "davidson_push_results failed to pull vt" - - rc = f77_zmq_recv( zmq_socket_pull, st, 8*N_states_diag* N, 0) - if(rc /= 8*N_states_diag* N) stop "davidson_push_results failed to pull st" + rc = f77_zmq_recv( zmq_socket_pull, s_0, 8*N_det*N_states_diag, 0) + if(rc /= 8*N_det*N_states_diag) stop "davidson_push_results failed to pull s_0" rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0) 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 + end subroutine -subroutine davidson_collector(zmq_to_qp_run_socket, zmq_socket_pull , v0, s0, LDA) +subroutine davidson_collector(zmq_to_qp_run_socket, v0, s0, sze, N_st) use f77_zmq implicit none - integer :: LDA + integer, intent(in) :: sze, N_st integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket - integer(ZMQ_PTR), intent(in) :: zmq_socket_pull - double precision ,intent(inout) :: v0(LDA, N_states_diag) - double precision ,intent(inout) :: s0(LDA, N_states_diag) + double precision ,intent(inout) :: v0(sze, N_st) + double precision ,intent(inout) :: s0(sze, N_st) - integer :: more, task_id, taskn + integer :: more, task_id - integer :: blockb, blocke - integer :: N - integer , allocatable :: idx(:) - double precision , allocatable :: vt(:,:), v0t(:,:), s0t(:,:) - double precision , allocatable :: st(:,:) - - integer :: msize - - msize = (1 + max_blocksize)*2 - allocate(idx(msize)) - allocate(vt(N_states_diag, msize)) - allocate(st(N_states_diag, msize)) - allocate(v0t(N_states_diag, dav_size)) - allocate(s0t(N_states_diag, dav_size)) - - v0t = 00.d0 - s0t = 00.d0 - - more = 1 - - do while (more == 1) - call davidson_pull_results(zmq_socket_pull, blockb, blocke, N, idx, vt, st, task_id) - !DIR$ FORCEINLINE - call davidson_collect(N, idx, vt, st , v0t, s0t) - call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) - end do - deallocate(idx,vt,st) - + double precision, allocatable :: v_0(:,:), s_0(:,:) integer :: i,j - !DIR$ IVDEP - do j=1,N_states_diag - !DIR$ IVDEP - do i=1,dav_size - v0(i,j) = v0t(j,i) - s0(i,j) = s0t(j,i) - enddo - enddo - - deallocate(v0t,s0t) -end subroutine - - -subroutine davidson_run(zmq_to_qp_run_socket , v0, s0, LDA) - use f77_zmq - implicit none - - integer :: LDA - integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket - integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_collector integer(ZMQ_PTR), external :: new_zmq_pull_socket integer(ZMQ_PTR) :: zmq_socket_pull - - integer :: i - integer, external :: omp_get_thread_num - double precision , intent(inout) :: v0(LDA, N_states_diag) - double precision , intent(inout) :: s0(LDA, N_states_diag) - - call zmq_set_running(zmq_to_qp_run_socket) - - zmq_collector = new_zmq_to_qp_run_socket() + allocate(v_0(N_det,N_st), s_0(N_det,N_st)) + v0 = 0.d0 + s0 = 0.d0 + more = 1 zmq_socket_pull = new_zmq_pull_socket() - i = omp_get_thread_num() - - - PROVIDE nproc - - !$OMP PARALLEL NUM_THREADS(nproc+2) PRIVATE(i) - i = omp_get_thread_num() - if (i == 0 ) then - call davidson_collector(zmq_collector, zmq_socket_pull , v0, s0, LDA) - call end_zmq_to_qp_run_socket(zmq_collector) - call end_zmq_pull_socket(zmq_socket_pull) - call davidson_miniserver_end() - else if (i == 1 ) then - call davidson_miniserver_run () - else - call davidson_slave_inproc(i) - endif - !$OMP END PARALLEL + do while (more == 1) + call davidson_pull_results(zmq_socket_pull, v_0, s_0, task_id) + do j=1,N_st + do i=1,N_det + v0(i,j) = v0(i,j) + v_0(i,j) + s0(i,j) = s0(i,j) + s_0(i,j) + enddo + enddo + call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) + end do + deallocate(v_0,s_0) + call end_zmq_pull_socket(zmq_socket_pull) - call end_parallel_job(zmq_to_qp_run_socket, 'davidson') end subroutine -subroutine davidson_miniserver_run() + +subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze) + use omp_lib + use bitmasks use f77_zmq implicit none - integer(ZMQ_PTR) responder - character*(64) address - character(len=:), allocatable :: buffer - integer rc + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! n : number of determinants + ! + ! H_jj : array of + ! + ! S2_jj : array of + END_DOC + integer, intent(in) :: N_st, sze + double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) + double precision, intent(inout):: u_0(sze,N_st) + integer :: i,j,k + integer :: ithread + double precision, allocatable :: u_t(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t - allocate (character(len=20) :: buffer) - address = 'tcp://*:11223' + PROVIDE psi_det_beta_unique psi_bilinear_matrix_order_transp_reverse psi_det_alpha_unique + PROVIDE psi_bilinear_matrix_transp_values psi_bilinear_matrix_values psi_bilinear_matrix_columns_loc + PROVIDE ref_bitmask_energy nproc + + + allocate(u_t(N_st,N_det)) + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det) + enddo + call dtranspose( & + u_0, & + size(u_0, 1), & + u_t, & + size(u_t, 1), & + N_det, N_st) + + + integer(ZMQ_PTR) :: zmq_to_qp_run_socket - responder = f77_zmq_socket(zmq_context, ZMQ_REP) - rc = f77_zmq_bind(responder,address) + if(N_st /= N_states_diag .or. sze < N_det) stop "assert fail in H_S2_u_0_nstates" + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (n>0) + + call new_parallel_job(zmq_to_qp_run_socket,'davidson') - do - rc = f77_zmq_recv(responder, buffer, 5, 0) - if (buffer(1:rc) /= 'end') then - rc = f77_zmq_send (responder, dav_size, 4, ZMQ_SNDMORE) - rc = f77_zmq_send (responder, dav_det, 16*N_int*dav_size, ZMQ_SNDMORE) - rc = f77_zmq_send (responder, dav_ut, 8*dav_size*N_states_diag, 0) - else - rc = f77_zmq_send (responder, "end", 3, 0) - exit + character*(512) :: task + integer :: rc + 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_send(zmq_to_qp_run_socket,trim(task),len(trim(task)),ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE) + if (rc /= N_int*2*N_det*bit_kind) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send(zmq_to_qp_run_socket,u_t,size(u_t)*8,ZMQ_SNDMORE) + if (rc /= size(u_t)*8) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket,u_t,size(u_t)*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_send(zmq_to_qp_run_socket,energy,size_energy*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 + + deallocate(u_t) + + + ! Create tasks + ! ============ + + integer :: istep, imin, imax, ishift + double precision :: w, max_workload, N_det_inv, di + max_workload = 1000000.d0 + w = 0.d0 + istep=8 + ishift=0 + imin=1 + N_det_inv = 1.d0/dble(N_det) + di = dble(N_det) + do imax=1,N_det + di = di-1.d0 + w = w + di*N_det_inv + if (w > max_workload) then + do ishift=0,istep-1 + write(task,'(4(I9,1X),1A)') imin, imax, ishift, istep, '|' + call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) + enddo + imin = imax+1 + w = 0.d0 endif enddo + if (w > 0.d0) then + imax = N_det + do ishift=0,istep-1 + write(task,'(4(I9,1X),1A)') imin, imax, ishift, istep, '|' + call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) + enddo + endif + - rc = f77_zmq_close(responder) -end subroutine + v_0 = 0.d0 + s_0 = 0.d0 + call omp_set_nested(.True.) + call zmq_set_running(zmq_to_qp_run_socket) + !$OMP PARALLEL NUM_THREADS(2) PRIVATE(ithread) + ithread = omp_get_thread_num() + if (ithread == 0 ) then + call davidson_collector(zmq_to_qp_run_socket, v_0, s_0, N_det, N_st) + else + call davidson_slave_inproc(1) + endif + !$OMP END PARALLEL + call end_parallel_job(zmq_to_qp_run_socket, 'davidson') -subroutine davidson_miniserver_end() - implicit none - use f77_zmq - - integer(ZMQ_PTR) requester - character*(64) address - integer rc - character*(64) buf - - address = trim(qp_run_address)//':11223' - requester = f77_zmq_socket(zmq_context, ZMQ_REQ) - rc = f77_zmq_connect(requester,address) - - rc = f77_zmq_send(requester, "end", 3, 0) - rc = f77_zmq_recv(requester, buf, 3, 0) - rc = f77_zmq_close(requester) -end subroutine - - -subroutine davidson_miniserver_get() - implicit none - use f77_zmq - - integer(ZMQ_PTR) requester - character*(64) address - character*(20) buffer - integer rc - - address = trim(qp_run_address)//':11223' - - requester = f77_zmq_socket(zmq_context, ZMQ_REQ) - rc = f77_zmq_connect(requester,address) - - rc = f77_zmq_send(requester, "Hello", 5, 0) - rc = f77_zmq_recv(requester, dav_size, 4, 0) - TOUCH dav_size - rc = f77_zmq_recv(requester, dav_det, 16*N_int*dav_size, 0) - rc = f77_zmq_recv(requester, dav_ut, 8*dav_size*N_states_diag, 0) - TOUCH dav_det dav_ut - - -end subroutine - - - - BEGIN_PROVIDER [ integer(bit_kind), dav_det, (N_int, 2, dav_size) ] -&BEGIN_PROVIDER [ double precision, dav_ut, (N_states_diag, dav_size) ] - use bitmasks - implicit none - BEGIN_DOC -! Temporary arrays for parallel davidson -! -! Touched in davidson_miniserver_get - END_DOC - dav_det = 0_bit_kind - dav_ut = -huge(1.d0) -END_PROVIDER - - -BEGIN_PROVIDER [ integer, dav_size ] - implicit none - BEGIN_DOC -! Size of the arrays for Davidson -! -! Touched in davidson_miniserver_get - END_DOC - dav_size = 1 -END_PROVIDER - - - BEGIN_PROVIDER [ integer, shortcut_, (0:dav_size+1, 2) ] -&BEGIN_PROVIDER [ integer(bit_kind), version_, (N_int, dav_size, 2) ] -&BEGIN_PROVIDER [ integer(bit_kind), sorted_, (N_int, dav_size, 2) ] -&BEGIN_PROVIDER [ integer, sort_idx_, (dav_size, 2) ] -&BEGIN_PROVIDER [ integer, max_blocksize ] -implicit none - call sort_dets_ab_v(dav_det, sorted_(1,1,1), sort_idx_(1,1), shortcut_(0,1), version_(1,1,1), dav_size, N_int) - call sort_dets_ba_v(dav_det, sorted_(1,1,2), sort_idx_(1,2), shortcut_(0,2), version_(1,1,2), dav_size, N_int) - max_blocksize = max(shortcut_(0,1), shortcut_(0,2)) -END_PROVIDER - + do k=1,N_st + call dset_order(v_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + call dset_order(s_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + enddo +end diff --git a/src/Davidson/davidson_slave.irp.f b/src/Davidson/davidson_slave.irp.f index e28712e2..e917c664 100644 --- a/src/Davidson/davidson_slave.irp.f +++ b/src/Davidson/davidson_slave.irp.f @@ -16,24 +16,16 @@ program davidson_slave state = 'Waiting' zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - do call wait_for_state(zmq_state,state) if(trim(state) /= "davidson") exit - call davidson_miniserver_get() - integer :: rc, i - print *, 'Davidson slave running' - - !$OMP PARALLEL PRIVATE(i) - i = omp_get_thread_num() call davidson_slave_tcp(i) - !$OMP END PARALLEL end do end subroutine provide_everything - PROVIDE mo_bielec_integrals_in_map psi_det_sorted_bit N_states_diag zmq_context + PROVIDE mo_bielec_integrals_in_map psi_det_sorted_bit N_states_diag zmq_context ref_bitmask_energy end subroutine diff --git a/src/Davidson/diagonalization.irp.f b/src/Davidson/diagonalization.irp.f index 9bbd00f5..e4d51198 100644 --- a/src/Davidson/diagonalization.irp.f +++ b/src/Davidson/diagonalization.irp.f @@ -302,7 +302,6 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_dia double precision, intent(inout) :: u_in(dim_in,N_st_diag) double precision, intent(out) :: energies(N_st_diag) - integer :: sze_8 integer :: iter integer :: i,j,k,l,m logical :: converged @@ -355,7 +354,7 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_dia write(iunit,'(A)') trim(write_buffer) write_buffer = ' Iter' do i=1,N_st - write_buffer = trim(write_buffer)//' Energy Residual' + write_buffer = trim(write_buffer)//' Energy Residual' enddo write(iunit,'(A)') trim(write_buffer) write_buffer = '===== ' @@ -365,13 +364,12 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_dia write(iunit,'(A)') trim(write_buffer) integer, external :: align_double - sze_8 = align_double(sze) allocate( & kl_pairs(2,N_st_diag*(N_st_diag+1)/2), & - W(sze_8,N_st_diag,davidson_sze_max), & - U(sze_8,N_st_diag,davidson_sze_max), & - R(sze_8,N_st_diag), & + W(sze,N_st_diag,davidson_sze_max), & + U(sze,N_st_diag,davidson_sze_max), & + R(sze,N_st_diag), & h(N_st_diag,davidson_sze_max,N_st_diag,davidson_sze_max), & y(N_st_diag,davidson_sze_max,N_st_diag,davidson_sze_max), & residual_norm(N_st_diag), & @@ -426,7 +424,7 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_dia ! Compute |W_k> = \sum_i |i> ! ----------------------------------------- - call H_u_0_nstates(W(1,1,iter),U(1,1,iter),H_jj,sze,dets_in,Nint,N_st_diag,sze_8) + call H_u_0_nstates(W(1,1,iter),U(1,1,iter),H_jj,sze,dets_in,Nint,N_st_diag,sze) ! do k=1,N_st ! if(store_full_H_mat.and.sze.le.n_det_max_stored)then ! call H_u_0_stored(W(1,k,iter),U(1,k,iter),H_matrix_all_dets,sze) @@ -502,7 +500,7 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_dia endif enddo - write(iunit,'(X,I3,X,100(X,F16.10,X,E16.6))') iter, to_print(:,1:N_st) + write(iunit,'(1X,I3,1X,100(1X,F16.10,1X,E16.6))') iter, to_print(:,1:N_st) call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged) if (converged) then exit diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index dccc8ee5..54672609 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -23,41 +23,33 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) double precision, intent(inout) :: u_in(dim_in,N_st_diag) double precision, intent(out) :: energies(N_st_diag), s2_out(N_st_diag) - double precision, allocatable :: H_jj(:), S2_jj(:) + double precision, allocatable :: H_jj(:) - double precision :: diag_h_mat_elem + double precision :: diag_H_mat_elem, diag_S_mat_elem integer :: i ASSERT (N_st > 0) ASSERT (sze > 0) ASSERT (Nint > 0) ASSERT (Nint == N_int) PROVIDE mo_bielec_integrals_in_map - allocate(H_jj(sze), S2_jj(sze)) + allocate(H_jj(sze) ) !$OMP PARALLEL DEFAULT(NONE) & - !$OMP SHARED(sze,H_jj,S2_jj, dets_in,Nint) & + !$OMP SHARED(sze,H_jj, dets_in,Nint) & !$OMP PRIVATE(i) - !$OMP DO SCHEDULE(guided) + !$OMP DO SCHEDULE(static) do i=1,sze - H_jj(i) = diag_h_mat_elem(dets_in(1,1,i),Nint) - call get_s2(dets_in(1,1,i),dets_in(1,1,i),Nint,S2_jj(i)) + H_jj(i) = diag_H_mat_elem(dets_in(1,1,i),Nint) enddo !$OMP END DO !$OMP END PARALLEL - if (disk_based_davidson) then - call davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) - else - call davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) - endif - do i=1,N_st_diag - s2_out(i) = S2_jj(i) - enddo - deallocate (H_jj,S2_jj) + call davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_out,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) + deallocate (H_jj) end -subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) +subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) use bitmasks implicit none BEGIN_DOC @@ -65,7 +57,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ! ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson ! - ! S2_jj : specific diagonal S^2 matrix elements + ! S2_out : Output : s^2 ! ! dets_in : bitmasks corresponding to determinants ! @@ -87,12 +79,11 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) double precision, intent(in) :: H_jj(sze) - double precision, intent(inout) :: S2_jj(sze) + double precision, intent(inout) :: s2_out(N_st_diag) integer, intent(in) :: iunit double precision, intent(inout) :: u_in(dim_in,N_st_diag) double precision, intent(out) :: energies(N_st_diag) - integer :: sze_8 integer :: iter integer :: i,j,k,l,m logical :: converged @@ -122,7 +113,10 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s stop -1 endif - PROVIDE nuclear_repulsion expected_s2 + integer, external :: align_double + itermax = max(3,min(davidson_sze_max, sze/N_st_diag)) + + PROVIDE nuclear_repulsion expected_s2 psi_bilinear_matrix_order psi_bilinear_matrix_order_reverse call write_time(iunit) call wall_time(wall) @@ -134,6 +128,9 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s call write_int(iunit,N_st,'Number of states') call write_int(iunit,N_st_diag,'Number of states in diagonalization') call write_int(iunit,sze,'Number of determinants') + r1 = 8.d0*(3.d0*dble(sze*N_st_diag*itermax+5.d0*(N_st_diag*itermax)**2 & + + 4.d0*(N_st_diag*itermax)+nproc*(4.d0*N_det_alpha_unique+2.d0*N_st_diag*sze)))/(1024.d0**3) + call write_double(iunit, r1, 'Memory(Gb)') write(iunit,'(A)') '' write_buffer = '===== ' do i=1,N_st @@ -151,14 +148,14 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s enddo write(iunit,'(A)') trim(write_buffer) - integer, external :: align_double - sze_8 = align_double(sze) - - itermax = max(3,min(davidson_sze_max, sze/N_st_diag)) + allocate( & - W(sze_8,N_st_diag*itermax), & - U(sze_8,N_st_diag*itermax), & - S(sze_8,N_st_diag*itermax), & + ! Large + W(sze,N_st_diag*itermax), & + U(sze,N_st_diag*itermax), & + S(sze,N_st_diag*itermax), & + + ! Small h(N_st_diag*itermax,N_st_diag*itermax), & y(N_st_diag*itermax,N_st_diag*itermax), & s_(N_st_diag*itermax,N_st_diag*itermax), & @@ -202,7 +199,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s do k=1,N_st_diag call normalize(u_in(1,k),sze) enddo - + do while (.not.converged) @@ -223,8 +220,11 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ! ----------------------------------------- -! call H_S2_u_0_nstates_zmq(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8) - call H_S2_u_0_nstates(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8) + if (distributed_davidson) then + call H_S2_u_0_nstates_zmq (W(1,shift+1),S(1,shift+1),U(1,shift+1),N_st_diag,sze) + else + call H_S2_u_0_nstates_openmp(W(1,shift+1),S(1,shift+1),U(1,shift+1),N_st_diag,sze) + endif ! Compute h_kl = = @@ -400,7 +400,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s endif enddo - write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3))') iter, to_print(1:3,1:N_st) + write(iunit,'(1X,I3,1X,100(1X,F16.10,1X,F11.6,1X,E11.3))') iter, to_print(1:3,1:N_st) call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged) do k=1,N_st if (residual_norm(k) > 1.e8) then @@ -424,7 +424,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s do k=1,N_st_diag energies(k) = lambda(k) - S2_jj(k) = s2(k) + s2_out(k) = s2(k) enddo write_buffer = '===== ' do i=1,N_st @@ -444,439 +444,3 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ) end -subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) - use bitmasks - use mmap_module - implicit none - BEGIN_DOC - ! Davidson diagonalization with specific diagonal elements of the H matrix - ! - ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson - ! - ! S2_jj : specific diagonal S^2 matrix elements - ! - ! dets_in : bitmasks corresponding to determinants - ! - ! u_in : guess coefficients on the various states. Overwritten - ! on exit - ! - ! dim_in : leftmost dimension of u_in - ! - ! sze : Number of determinants - ! - ! N_st : Number of eigenstates - ! - ! N_st_diag : Number of states in which H is diagonalized. Assumed > sze - ! - ! iunit : Unit for the I/O - ! - ! Initial guess vectors are not necessarily orthonormal - END_DOC - integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint - integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) - double precision, intent(in) :: H_jj(sze) - double precision, intent(inout) :: S2_jj(sze) - integer, intent(in) :: iunit - double precision, intent(inout) :: u_in(dim_in,N_st_diag) - double precision, intent(out) :: energies(N_st_diag) - - integer :: sze_8 - integer :: iter - integer :: i,j,k,l,m - logical :: converged - - double precision :: u_dot_v, u_dot_u - - integer :: k_pairs, kl - - integer :: iter2 - double precision, pointer :: W(:,:), U(:,:), S(:,:), overlap(:,:) - double precision, allocatable :: y(:,:), h(:,:), lambda(:), s2(:) - double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:) - double precision :: diag_h_mat_elem - double precision, allocatable :: residual_norm(:) - character*(16384) :: write_buffer - double precision :: to_print(3,N_st) - double precision :: cpu, wall - logical :: state_ok(N_st_diag*davidson_sze_max) - integer :: shift, shift2, itermax - include 'constants.include.F' - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda - if (N_st_diag*3 > sze) then - print *, 'error in Davidson :' - print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 - stop -1 - endif - - PROVIDE nuclear_repulsion expected_s2 - - call write_time(iunit) - call wall_time(wall) - call cpu_time(cpu) - write(iunit,'(A)') '' - write(iunit,'(A)') 'Davidson Diagonalization' - write(iunit,'(A)') '------------------------' - write(iunit,'(A)') '' - call write_int(iunit,N_st,'Number of states') - call write_int(iunit,N_st_diag,'Number of states in diagonalization') - call write_int(iunit,sze,'Number of determinants') - write(iunit,'(A)') '' - write_buffer = '===== ' - do i=1,N_st - write_buffer = trim(write_buffer)//' ================ =========== ===========' - enddo - write(iunit,'(A)') trim(write_buffer) - write_buffer = ' Iter' - do i=1,N_st - write_buffer = trim(write_buffer)//' Energy S^2 Residual ' - enddo - write(iunit,'(A)') trim(write_buffer) - write_buffer = '===== ' - do i=1,N_st - write_buffer = trim(write_buffer)//' ================ =========== ===========' - enddo - write(iunit,'(A)') trim(write_buffer) - - integer, external :: align_double - integer :: fd(3) - type(c_ptr) :: c_pointer(3) - sze_8 = align_double(sze) - - itermax = min(davidson_sze_max, sze/N_st_diag) - - call mmap( & - trim(ezfio_work_dir)//'U', & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & - 8, fd(1), .False., c_pointer(1)) - call c_f_pointer(c_pointer(1), W, (/ sze_8,N_st_diag*itermax /) ) - - call mmap( & - trim(ezfio_work_dir)//'W', & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & - 8, fd(2), .False., c_pointer(2)) - call c_f_pointer(c_pointer(2), U, (/ sze_8,N_st_diag*itermax /) ) - - call mmap( & - trim(ezfio_work_dir)//'S', & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & - 8, fd(3), .False., c_pointer(3)) - call c_f_pointer(c_pointer(3), S, (/ sze_8,N_st_diag*itermax /) ) - - allocate( & - h(N_st_diag*itermax,N_st_diag*itermax), & - y(N_st_diag*itermax,N_st_diag*itermax), & - s_(N_st_diag*itermax,N_st_diag*itermax), & - s_tmp(N_st_diag*itermax,N_st_diag*itermax), & - overlap(N_st_diag*itermax, N_st_diag*itermax), & - residual_norm(N_st_diag), & - c(N_st_diag*itermax), & - s2(N_st_diag*itermax), & - lambda(N_st_diag*itermax)) - - h = 0.d0 - U = 0.d0 - W = 0.d0 - S = 0.d0 - y = 0.d0 - s_ = 0.d0 - s_tmp = 0.d0 - - - ASSERT (N_st > 0) - ASSERT (N_st_diag >= N_st) - ASSERT (sze > 0) - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - - ! Davidson iterations - ! =================== - - converged = .False. - - double precision :: r1, r2 - do k=N_st+1,N_st_diag - u_in(k,k) = 10.d0 - do i=1,sze - call random_number(r1) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - u_in(i,k) = r1*dcos(r2) - enddo - enddo - do k=1,N_st_diag - call normalize(u_in(1,k),sze) - enddo - - - do while (.not.converged) - - do k=1,N_st_diag - do i=1,sze - U(i,k) = u_in(i,k) - enddo - enddo - - do iter=1,itermax-1 - - shift = N_st_diag*(iter-1) - shift2 = N_st_diag*iter - - call ortho_qr(U,size(U,1),sze,shift2) - - ! Compute |W_k> = \sum_i |i> - ! ----------------------------------------- - - -! call H_S2_u_0_nstates_zmq(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8) - call H_S2_u_0_nstates(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8) - - - ! Compute h_kl = = - ! ------------------------------------------- - - do k=1,iter - shift = N_st_diag*(k-1) - call dgemm('T','N', N_st_diag, shift2, sze, & - 1.d0, U(1,shift+1), size(U,1), W, size(W,1), & - 0.d0, h(shift+1,1), size(h,1)) - - call dgemm('T','N', N_st_diag, shift2, sze, & - 1.d0, U(1,shift+1), size(U,1), S, size(S,1), & - 0.d0, s_(shift+1,1), size(s_,1)) - enddo - -! ! Diagonalize S^2 -! ! --------------- -! -! call lapack_diag(s2,y,s_,size(s_,1),shift2) -! -! -! ! Rotate H in the basis of eigenfunctions of s2 -! ! --------------------------------------------- -! -! call dgemm('N','N',shift2,shift2,shift2, & -! 1.d0, h, size(h,1), y, size(y,1), & -! 0.d0, s_tmp, size(s_tmp,1)) -! -! call dgemm('T','N',shift2,shift2,shift2, & -! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & -! 0.d0, h, size(h,1)) -! -! ! Damp interaction between different spin states -! ! ------------------------------------------------ -! -! do k=1,shift2 -! do l=1,shift2 -! if (dabs(s2(k) - s2(l)) > 1.d0) then -! h(k,l) = h(k,l)*(max(0.d0,1.d0 - dabs(s2(k) - s2(l)))) -! endif -! enddo -! enddo -! -! ! Rotate back H -! ! ------------- -! -! call dgemm('N','T',shift2,shift2,shift2, & -! 1.d0, h, size(h,1), y, size(y,1), & -! 0.d0, s_tmp, size(s_tmp,1)) -! -! call dgemm('N','N',shift2,shift2,shift2, & -! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & -! 0.d0, h, size(h,1)) - - - ! Diagonalize h - ! ------------- - call lapack_diag(lambda,y,h,size(h,1),shift2) - - ! Compute S2 for each eigenvector - ! ------------------------------- - - call dgemm('N','N',shift2,shift2,shift2, & - 1.d0, s_, size(s_,1), y, size(y,1), & - 0.d0, s_tmp, size(s_tmp,1)) - - call dgemm('T','N',shift2,shift2,shift2, & - 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & - 0.d0, s_, size(s_,1)) - - - - do k=1,shift2 - s2(k) = s_(k,k) + S_z2_Sz - enddo - - - if (s2_eig) then - do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) - enddo - else - state_ok(k) = .True. - endif - - do k=1,shift2 - if (.not. state_ok(k)) then - do l=k+1,shift2 - if (state_ok(l)) then - call dswap(shift2, y(1,k), 1, y(1,l), 1) - call dswap(1, s2(k), 1, s2(l), 1) - call dswap(1, lambda(k), 1, lambda(l), 1) - state_ok(k) = .True. - state_ok(l) = .False. - exit - endif - enddo - endif - enddo - - if (state_following) then - - ! Compute overlap with U_in - ! ------------------------- - - integer :: order(N_st_diag) - double precision :: cmax - overlap = -1.d0 - do k=1,shift2 - do i=1,shift2 - overlap(k,i) = dabs(y(k,i)) - enddo - enddo - do k=1,N_st - cmax = -1.d0 - do i=1,shift2 - if (overlap(i,k) > cmax) then - cmax = overlap(i,k) - order(k) = i - endif - enddo - do i=1,shift2 - overlap(order(k),i) = -1.d0 - enddo - enddo - overlap = y - do k=1,N_st - l = order(k) - if (k /= l) then - y(1:shift2,k) = overlap(1:shift2,l) - endif - enddo - do k=1,N_st - overlap(k,1) = lambda(k) - overlap(k,2) = s2(k) - enddo - do k=1,N_st - l = order(k) - if (k /= l) then - lambda(k) = overlap(l,1) - s2(k) = overlap(l,2) - endif - enddo - - endif - - - ! Express eigenvectors of h in the determinant basis - ! -------------------------------------------------- - - call dgemm('N','N', sze, N_st_diag, shift2, & - 1.d0, U, size(U,1), y, size(y,1), 0.d0, U(1,shift2+1), size(U,1)) - call dgemm('N','N', sze, N_st_diag, shift2, & - 1.d0, W, size(W,1), y, size(y,1), 0.d0, W(1,shift2+1), size(W,1)) - call dgemm('N','N', sze, N_st_diag, shift2, & - 1.d0, S, size(S,1), y, size(y,1), 0.d0, S(1,shift2+1), size(S,1)) - - ! Compute residual vector and davidson step - ! ----------------------------------------- - - do k=1,N_st_diag - if (state_ok(k)) then - do i=1,sze - U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & - * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & - )/max(H_jj(i) - lambda (k),1.d-2) - enddo - else - ! Randomize components with bad - do i=1,sze-2,2 - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - U(i,shift2+k) = r1*dcos(r2) - U(i+1,shift2+k) = r1*dsin(r2) - enddo - do i=sze-2+1,sze - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - U(i,shift2+k) = r1*dcos(r2) - enddo - endif - - if (k <= N_st) then - residual_norm(k) = u_dot_u(U(1,shift2+k),sze) - to_print(1,k) = lambda(k) + nuclear_repulsion - to_print(2,k) = s2(k) - to_print(3,k) = residual_norm(k) - endif - enddo - - write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3))') iter, to_print(1:3,1:N_st) - call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged) - do k=1,N_st - if (residual_norm(k) > 1.e8) then - print *, '' - stop 'Davidson failed' - endif - enddo - if (converged) then - exit - endif - - enddo - - ! Re-contract to u_in - ! ----------- - - call dgemm('N','N', sze, N_st_diag, shift2, 1.d0, & - U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) - - enddo - - do k=1,N_st_diag - energies(k) = lambda(k) - S2_jj(k) = s2(k) - enddo - write_buffer = '===== ' - do i=1,N_st - write_buffer = trim(write_buffer)//' ================ =========== ===========' - enddo - write(iunit,'(A)') trim(write_buffer) - write(iunit,'(A)') '' - call write_time(iunit) - - call munmap( & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & - 8, fd(1), c_pointer(1)) - - call munmap( & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & - 8, fd(2), c_pointer(2)) - - call munmap( & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & - 8, fd(3), c_pointer(3)) - - deallocate ( & - residual_norm, & - c, overlap, & - h, & - y, s_, s_tmp, & - lambda & - ) -end - diff --git a/src/Davidson/diagonalize_CI.irp.f b/src/Davidson/diagonalize_CI.irp.f index e1b67438..9b98ea91 100644 --- a/src/Davidson/diagonalize_CI.irp.f +++ b/src/Davidson/diagonalize_CI.irp.f @@ -66,7 +66,6 @@ END_PROVIDER call davidson_diag_HS2(psi_det,CI_eigenvectors, CI_eigenvectors_s2, & size(CI_eigenvectors,1),CI_electronic_energy, & N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,output_determinants) - else if (diag_algorithm == "Lapack") then diff --git a/src/Davidson/find_reference.irp.f b/src/Davidson/find_reference.irp.f new file mode 100644 index 00000000..0cafd739 --- /dev/null +++ b/src/Davidson/find_reference.irp.f @@ -0,0 +1,41 @@ +subroutine find_reference(thresh,n_ref,result) + implicit none + double precision, intent(in) :: thresh + integer, intent(out) :: result(N_det),n_ref + integer :: i,j,istate + double precision :: i_H_psi_array(1), E0, hii, norm + double precision :: de + integer(bit_kind), allocatable :: psi_ref_(:,:,:) + double precision, allocatable :: psi_ref_coef_(:,:) + + allocate(psi_ref_coef_(N_det,1), psi_ref_(N_int,2,N_det)) + n_ref = 1 + result(1) = 1 + istate = 1 + psi_ref_coef_(1,1) = psi_coef(1,istate) + psi_ref_(:,:,1) = psi_det(:,:,1) + norm = psi_ref_coef_(1,1) * psi_ref_coef_(1,1) + call u_0_H_u_0(E0,psi_ref_coef_,n_ref,psi_ref_,N_int,1,size(psi_ref_coef_,1)) + print *, '' + print *, 'Reference determinants' + print *, '======================' + print *, '' + print *, n_ref, ': E0 = ', E0 + nuclear_repulsion + call debug_det(psi_ref_(1,1,n_ref),N_int) + do i=2,N_det + call i_h_psi(psi_det(1,1,i),psi_ref_(1,1,1),psi_ref_coef_(1,istate),N_int, & + n_ref,size(psi_ref_coef_,1),1,i_H_psi_array) + call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,hii) + de = i_H_psi_array(istate)**2 / (E0 - hii) + if (dabs(de) > thresh) then + n_ref += 1 + result(n_ref) = i + psi_ref_(:,:,n_ref) = psi_det(:,:,i) + psi_ref_coef_(n_ref,1) = psi_coef(i,istate) + call u_0_H_u_0(E0,psi_ref_coef_,n_ref,psi_ref_,N_int,1,size(psi_ref_coef_,1)) + print *, n_ref, ': E0 = ', E0 + nuclear_repulsion + call debug_det(psi_ref_(1,1,n_ref),N_int) + endif + enddo +end + diff --git a/src/Davidson/parameters.irp.f b/src/Davidson/parameters.irp.f index ae8babaa..7d383192 100644 --- a/src/Davidson/parameters.irp.f +++ b/src/Davidson/parameters.irp.f @@ -18,6 +18,11 @@ subroutine davidson_converged(energy,residual,wall,iterations,cpu,N_st,converged double precision :: E(N_st), time double precision, allocatable, save :: energy_old(:) + if (iterations < 2) then + converged = .False. + return + endif + if (.not.allocated(energy_old)) then allocate(energy_old(N_st)) energy_old = 0.d0 diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 117e704e..4f68f85a 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -1,4 +1,4 @@ -subroutine u_0_H_u_0(e_0,u_0,n,keys_tmp,Nint,N_st,sze_8) +subroutine u_0_H_u_0(e_0,u_0,n,keys_tmp,Nint,N_st,sze) use bitmasks implicit none BEGIN_DOC @@ -7,166 +7,20 @@ subroutine u_0_H_u_0(e_0,u_0,n,keys_tmp,Nint,N_st,sze_8) ! n : number of determinants ! END_DOC - integer, intent(in) :: n,Nint, N_st, sze_8 + integer, intent(in) :: n,Nint, N_st, sze double precision, intent(out) :: e_0(N_st) - double precision, intent(in) :: u_0(sze_8,N_st) + double precision, intent(inout):: u_0(sze,N_st) integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) - double precision, allocatable :: H_jj(:), v_0(:,:) + double precision, allocatable :: v_0(:,:), s_0(:,:) double precision :: u_dot_u,u_dot_v,diag_H_mat_elem integer :: i,j - allocate (H_jj(n), v_0(sze_8,N_st)) - do i = 1, n - H_jj(i) = diag_H_mat_elem(keys_tmp(1,1,i),Nint) - enddo - - call H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) + allocate (v_0(sze,N_st),s_0(sze,N_st)) + call H_S2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze) do i=1,N_st e_0(i) = u_dot_v(v_0(1,i),u_0(1,i),n)/u_dot_u(u_0(1,i),n) enddo - deallocate (H_jj, v_0) -end - - -subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) - use bitmasks - implicit none - BEGIN_DOC - ! Computes v_0 = H|u_0> - ! - ! n : number of determinants - ! - ! H_jj : array of - END_DOC - integer, intent(in) :: N_st,n,Nint, sze_8 - double precision, intent(out) :: v_0(sze_8,N_st) - double precision, intent(in) :: u_0(sze_8,N_st) - double precision, intent(in) :: H_jj(n) - integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) - double precision :: hij - double precision, allocatable :: vt(:,:) - double precision, allocatable :: ut(:,:) - integer :: i,j,k,l, jj,ii - integer :: i0, j0 - - integer, allocatable :: shortcut(:,:), sort_idx(:,:) - integer(bit_kind), allocatable :: sorted(:,:,:), version(:,:,:) - integer(bit_kind) :: sorted_i(Nint) - - integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate - integer :: N_st_8 - - integer, external :: align_double - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: vt, ut - - N_st_8 = align_double(N_st) - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (n>0) - PROVIDE ref_bitmask_energy - - allocate (shortcut(0:n+1,2), sort_idx(n,2), sorted(Nint,n,2), version(Nint,n,2)) - allocate(ut(N_st_8,n)) - - v_0 = 0.d0 - - do i=1,n - do istate=1,N_st - ut(istate,i) = u_0(i,istate) - enddo - enddo - - call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint) - call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint) - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,hij,j,k,jj,vt,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& - !$OMP SHARED(n,H_jj,keys_tmp,ut,Nint,v_0,sorted,shortcut,sort_idx,version,N_st,N_st_8) - allocate(vt(N_st_8,n)) - Vt = 0.d0 - - !$OMP DO SCHEDULE(dynamic) - do sh=1,shortcut(0,1) - do sh2=1,shortcut(0,1) - exa = popcnt(xor(version(1,sh,1), version(1,sh2,1))) - if(exa > 2) then - cycle - end if - do ni=2,Nint - exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) - end do - if(exa > 2) then - cycle - end if - - do i=shortcut(sh,1),shortcut(sh+1,1)-1 - org_i = sort_idx(i,1) - do ni=1,Nint - sorted_i(ni) = sorted(ni,i,1) - enddo - - jloop: do j=shortcut(sh2,1),shortcut(sh2+1,1)-1 - org_j = sort_idx(j,1) - ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) - if(ext > 4) then - cycle jloop - endif - do ni=2,Nint - ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) - if(ext > 4) then - cycle jloop - endif - end do - call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) - do istate=1,N_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) - enddo - enddo jloop - enddo - enddo - enddo - !$OMP END DO NOWAIT - - !$OMP DO SCHEDULE(dynamic) - do sh=1,shortcut(0,2) - do i=shortcut(sh,2),shortcut(sh+1,2)-1 - org_i = sort_idx(i,2) - do j=shortcut(sh,2),shortcut(sh+1,2)-1 - org_j = sort_idx(j,2) - ext = popcnt(xor(sorted(1,i,2), sorted(1,j,2))) - do ni=2,Nint - ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2))) - end do - if(ext /= 4) then - cycle - endif - call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) - do istate=1,N_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) - enddo - end do - end do - enddo - !$OMP END DO NOWAIT - - !$OMP CRITICAL - do istate=1,N_st - do i=n,1,-1 - v_0(i,istate) = v_0(i,istate) + vt(istate,i) - enddo - enddo - !$OMP END CRITICAL - - deallocate(vt) - !$OMP END PARALLEL - - do istate=1,N_st - do i=1,n - v_0(i,istate) += H_jj(i) * u_0(i,istate) - enddo - enddo - deallocate (shortcut, sort_idx, sorted, version, ut) + deallocate (s_0, v_0) end BEGIN_PROVIDER [ double precision, psi_energy, (N_states) ] @@ -178,338 +32,411 @@ BEGIN_PROVIDER [ double precision, psi_energy, (N_states) ] END_PROVIDER -subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) + +subroutine H_S2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze) use bitmasks - use f77_zmq implicit none BEGIN_DOC ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> ! - ! n : number of determinants + ! Assumes that the determinants are in psi_det ! - ! H_jj : array of - ! - ! S2_jj : array of + ! istart, iend, ishift, istep are used in ZMQ parallelization. END_DOC - integer, intent(in) :: N_st,n,Nint, sze_8 - double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st) - double precision, intent(in) :: u_0(sze_8,N_st) - double precision, intent(in) :: H_jj(n), S2_jj(n) - integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) - double precision :: hij,s2 - double precision, allocatable :: ut(:,:) - integer :: i,j,k,l, jj,ii - integer :: i0, j0 - - integer, allocatable :: shortcut(:,:), sort_idx(:) - integer(bit_kind), allocatable :: sorted(:,:), version(:,:) - integer(bit_kind) :: sorted_i(Nint) - - integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate - integer :: N_st_8 - - integer, external :: align_double - integer :: blockb, blockb2, istep - double precision :: ave_workload, workload, target_workload_inv - - integer(ZMQ_PTR) :: handler - - if(N_st /= N_states_diag .or. sze_8 < N_det) stop "assert fail in H_S2_u_0_nstates" - N_st_8 = N_st ! align_double(N_st) - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (n>0) - PROVIDE ref_bitmask_energy - - allocate (shortcut(0:n+1,2), sort_idx(n), sorted(Nint,n), version(Nint,n)) - allocate(ut(N_st_8,n)) - + integer, intent(in) :: N_st,sze + double precision, intent(inout) :: v_0(sze,N_st), s_0(sze,N_st), u_0(sze,N_st) + integer :: k + double precision, allocatable :: u_t(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t + allocate(u_t(N_st,N_det)) + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det) + enddo v_0 = 0.d0 s_0 = 0.d0 - - do i=1,n - do istate=1,N_st - ut(istate,i) = u_0(i,istate) - enddo + call dtranspose( & + u_0, & + size(u_0, 1), & + u_t, & + size(u_t, 1), & + N_det, N_st) + + call H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,1,N_det,0,1) + deallocate(u_t) + + do k=1,N_st + call dset_order(v_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + call dset_order(s_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) enddo - call sort_dets_ab_v(keys_tmp, sorted, sort_idx, shortcut(0,1), version, n, Nint) - call sort_dets_ba_v(keys_tmp, sorted, sort_idx, shortcut(0,2), version, n, Nint) - - blockb = shortcut(0,1) - call davidson_init(handler,n,N_st_8,ut) - - ave_workload = 0.d0 - do sh=1,shortcut(0,1) - ave_workload += shortcut(0,1) - ave_workload += (shortcut(sh+1,1) - shortcut(sh,1))**2 - do i=sh, shortcut(0,2), shortcut(0,1) - do j=i, min(i, shortcut(0,2)) - ave_workload += (shortcut(j+1,2) - shortcut(j, 2))**2 - end do - end do - enddo - ave_workload = ave_workload/dble(shortcut(0,1)) - target_workload_inv = 0.001d0/ave_workload - - - do sh=1,shortcut(0,1),1 - workload = shortcut(0,1)+dble(shortcut(sh+1,1) - shortcut(sh,1))**2 - do i=sh, shortcut(0,2), shortcut(0,1) - do j=i, min(i, shortcut(0,2)) - workload += (shortcut(j+1,2) - shortcut(j, 2))**2 - end do - end do - istep = 1+ int(workload*target_workload_inv) - do blockb2=0, istep-1 - call davidson_add_task(handler, sh, blockb2, istep) - enddo - enddo - - call davidson_run(handler, v_0, s_0, size(v_0,1)) - - do istate=1,N_st - do i=1,n - v_0(i,istate) = v_0(i,istate) + H_jj(i) * u_0(i,istate) - s_0(i,istate) = s_0(i,istate) + s2_jj(i)* u_0(i,istate) - enddo - enddo - deallocate(shortcut, sort_idx, sorted, version) - deallocate(ut) end - -subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) +subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks implicit none BEGIN_DOC ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> ! - ! n : number of determinants - ! - ! H_jj : array of - ! - ! S2_jj : array of + ! Default should be 1,N_det,0,1 END_DOC - integer, intent(in) :: N_st,n,Nint, sze_8 - double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st) - double precision, intent(in) :: u_0(sze_8,N_st) - double precision, intent(in) :: H_jj(n), S2_jj(n) - integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) - double precision :: hij,s2 - double precision, allocatable :: vt(:,:), ut(:,:), st(:,:) - integer :: i,j,k,l, jj,ii - integer :: i0, j0 + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + double precision, intent(in) :: u_t(N_st,N_det) + double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) + - integer, allocatable :: shortcut(:,:), sort_idx(:,:) - integer(bit_kind), allocatable :: sorted(:,:,:), version(:,:,:) - integer(bit_kind) :: sorted_i(Nint) + PROVIDE ref_bitmask_energy N_int + + select case (N_int) + case (1) + call H_S2_u_0_nstates_openmp_work_1(v_0,s_0,u_t,N_st,sze,istart,iend,ishift,istep) + case (2) + call H_S2_u_0_nstates_openmp_work_2(v_0,s_0,u_t,N_st,sze,istart,iend,ishift,istep) + case (3) + call H_S2_u_0_nstates_openmp_work_3(v_0,s_0,u_t,N_st,sze,istart,iend,ishift,istep) + case (4) + call H_S2_u_0_nstates_openmp_work_4(v_0,s_0,u_t,N_st,sze,istart,iend,ishift,istep) + case default + call H_S2_u_0_nstates_openmp_work_N_int(v_0,s_0,u_t,N_st,sze,istart,iend,ishift,istep) + end select +end +BEGIN_TEMPLATE + +subroutine H_S2_u_0_nstates_openmp_work_$N_int(v_0,s_0,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! Default should be 1,N_det,0,1 + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + double precision, intent(in) :: u_t(N_st,N_det) + double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) + + double precision :: hij, sij + integer :: i,j,k,l + integer :: k_a, k_b, l_a, l_b, m_a, m_b + integer :: istate + integer :: krow, kcol, krow_b, kcol_b + integer :: lrow, lcol + integer :: mrow, mcol + integer(bit_kind) :: spindet($N_int) + integer(bit_kind) :: tmp_det($N_int,2) + integer(bit_kind) :: tmp_det2($N_int,2) + integer(bit_kind) :: tmp_det3($N_int,2) + integer(bit_kind), allocatable :: buffer(:,:) + integer :: n_doubles + integer, allocatable :: doubles(:) + integer, allocatable :: singles_a(:) + integer, allocatable :: singles_b(:) + integer, allocatable :: idx(:), idx0(:) + integer :: maxab, n_singles_a, n_singles_b, kcol_prev, nmax + integer*8 :: k8 + double precision, allocatable :: v_t(:,:), s_t(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: v_t, s_t + + maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 + allocate(idx0(maxab)) - integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate - integer :: N_st_8 - - integer, external :: align_double - integer :: blockb, blockb2, istep - double precision :: ave_workload, workload, target_workload_inv - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: vt, ut, st + do i=1,maxab + idx0(i) = i + enddo - N_st_8 = align_double(N_st) - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (n>0) - PROVIDE ref_bitmask_energy - - allocate (shortcut(0:n+1,2), sort_idx(n,2), sorted(Nint,n,2), version(Nint,n,2)) - allocate(ut(N_st_8,n)) - - v_0 = 0.d0 - s_0 = 0.d0 - - call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint) - call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint) + ! Prepare the array of all alpha single excitations + ! ------------------------------------------------- + PROVIDE N_int !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,hij,s2,j,k,jj,vt,st,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& - !$OMP SHARED(n,keys_tmp,ut,Nint,u_0,v_0,s_0,sorted,shortcut,sort_idx,version,N_st,N_st_8) - allocate(vt(N_st_8,n),st(N_st_8,n)) - Vt = 0.d0 - St = 0.d0 + !$OMP SHARED(psi_bilinear_matrix_rows, N_det, & + !$OMP psi_bilinear_matrix_columns, & + !$OMP psi_det_alpha_unique, psi_det_beta_unique, & + !$OMP n_det_alpha_unique, n_det_beta_unique, N_int, & + !$OMP psi_bilinear_matrix_transp_rows, & + !$OMP psi_bilinear_matrix_transp_columns, & + !$OMP psi_bilinear_matrix_transp_order, N_st, & + !$OMP psi_bilinear_matrix_order_transp_reverse, & + !$OMP psi_bilinear_matrix_columns_loc, & + !$OMP istart, iend, istep, & + !$OMP ishift, idx0, u_t, maxab, v_0, s_0) & + !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, & + !$OMP lcol, lrow, l_a, l_b, nmax, & + !$OMP buffer, doubles, n_doubles, & + !$OMP tmp_det2, hij, sij, idx, l, kcol_prev, v_t, & + !$OMP singles_a, n_singles_a, singles_b, & + !$OMP n_singles_b, s_t, k8) + + ! Alpha/Beta double excitations + ! ============================= + + allocate( buffer($N_int,maxab), & + singles_a(maxab), & + singles_b(maxab), & + doubles(maxab), & + idx(maxab), & + v_t(N_st,N_det), s_t(N_st,N_det)) + kcol_prev=-1 - !$OMP DO - do i=1,n - do istate=1,N_st - ut(istate,i) = u_0(sort_idx(i,2),istate) - enddo - enddo - !$OMP END DO + v_t = 0.d0 + s_t = 0.d0 - !$OMP DO SCHEDULE(dynamic) - do sh=1,shortcut(0,2) - do i=shortcut(sh,2),shortcut(sh+1,2)-1 - org_i = sort_idx(i,2) - do j=shortcut(sh,2),shortcut(sh+1,2)-1 - org_j = sort_idx(j,2) - ext = popcnt(xor(sorted(1,i,2), sorted(1,j,2))) - if (ext > 4) cycle - do ni=2,Nint - ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2))) - if (ext > 4) exit - end do - if(ext == 4) then - call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) - call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) - do istate=1,n_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) - st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) - enddo - end if - end do - end do - enddo - !$OMP END DO - !$OMP DO - do i=1,n - do istate=1,N_st - ut(istate,i) = u_0(sort_idx(i,1),istate) - enddo - enddo - !$OMP END DO + !$OMP DO SCHEDULE(dynamic,64) + do k_a=istart+ishift,iend,istep - !$OMP DO SCHEDULE(dynamic) - do sh=1,shortcut(0,1) - do sh2=1,shortcut(0,1) - if (sh==sh2) cycle + krow = psi_bilinear_matrix_rows(k_a) + kcol = psi_bilinear_matrix_columns(k_a) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + if (kcol /= kcol_prev) then + call get_all_spin_singles_$N_int( & + psi_det_beta_unique(1,kcol+1), idx0(kcol+1), & + tmp_det(1,2), N_det_beta_unique-kcol, & + singles_b, n_singles_b) + endif + kcol_prev = kcol - exa = 0 - do ni=1,Nint - exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) - end do - if(exa > 2) then - cycle - end if + ! Loop over singly excited beta columns > current column + ! ------------------------------------------------------ - do i=shortcut(sh,1),shortcut(sh+1,1)-1 - org_i = sort_idx(i,1) - do ni=1,Nint - sorted_i(ni) = sorted(ni,i,1) - enddo + do i=1,n_singles_b + lcol = singles_b(i) - do j=shortcut(sh2,1),shortcut(sh2+1,1)-1 - ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) - if (ext > 4) cycle - do ni=2,Nint - ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) - if (ext > 4) exit - end do - if(ext <= 4) then - org_j = sort_idx(j,1) - call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) - if (hij /= 0.d0) then - do istate=1,n_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) - enddo - endif - if (ext /= 2) then - call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) - if (s2 /= 0.d0) then - do istate=1,n_st - st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) - enddo - endif - endif - endif - enddo - - enddo - enddo - - exa = 0 - - do i=shortcut(sh,1),shortcut(sh+1,1)-1 - org_i = sort_idx(i,1) - do ni=1,Nint - sorted_i(ni) = sorted(ni,i,1) - enddo - - do j=shortcut(sh,1),i-1 - ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) - if (ext > 4) cycle - do ni=2,Nint - ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) - if (ext > 4) exit - end do - if(ext <= 4) then - org_j = sort_idx(j,1) - call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) - if (hij /= 0.d0) then - do istate=1,n_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) - enddo - endif - if (ext /= 2) then - call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) - if (s2 /= 0.d0) then - do istate=1,n_st - st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) - enddo - endif - endif - endif + tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) + + l_a = psi_bilinear_matrix_columns_loc(lcol) + + nmax = psi_bilinear_matrix_columns_loc(lcol+1) - l_a + do j=1,nmax + lrow = psi_bilinear_matrix_rows(l_a) + buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) + idx(j) = l_a + l_a = l_a+1 enddo + j = j-1 - do j=i+1,shortcut(sh+1,1)-1 - if (i==j) cycle - ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) - if (ext > 4) cycle - do ni=2,Nint - ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) - if (ext > 4) exit - end do - if(ext <= 4) then - org_j = sort_idx(j,1) - call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) - if (hij /= 0.d0) then - do istate=1,n_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) - enddo - endif - if (ext /= 2) then - call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) - if (s2 /= 0.d0) then - do istate=1,n_st - st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) - enddo - endif - endif - endif + call get_all_spin_singles_$N_int( & + buffer, idx, tmp_det(1,1), j, & + singles_a, n_singles_a ) + + ! Loop over alpha singles + ! ----------------------- + + do k = 1,n_singles_a + l_a = singles_a(k) + lrow = psi_bilinear_matrix_rows(l_a) + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + call i_H_j_double_alpha_beta(tmp_det,tmp_det2,$N_int,hij) + call get_s2(tmp_det,tmp_det2,$N_int,sij) + do l=1,N_st + v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a) + v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + s_t(l,l_a) = s_t(l,l_a) + sij * u_t(l,k_a) + enddo enddo + enddo + enddo !$OMP END DO - !$OMP CRITICAL (u0Hu0) - do istate=1,N_st - do i=1,n - v_0(i,istate) = v_0(i,istate) + vt(istate,i) - s_0(i,istate) = s_0(i,istate) + st(istate,i) + !$OMP DO SCHEDULE(dynamic,64) + do k_a=istart+ishift,iend,istep + + + ! Single and double alpha excitations + ! =================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + kcol = psi_bilinear_matrix_columns(k_a) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + ! Initial determinant is at k_b in beta-major representation + ! ---------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + + spindet(1:$N_int) = tmp_det(1:$N_int,1) + + ! Loop inside the beta column to gather all the connected alphas + l_a = k_a+1 + nmax = min(N_det_alpha_unique, N_det - l_a) + do i=1,nmax + lcol = psi_bilinear_matrix_columns(l_a) + if (lcol /= kcol) exit + lrow = psi_bilinear_matrix_rows(l_a) + buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow) + idx(i) = l_a + l_a = l_a+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_a, doubles, n_singles_a, n_doubles ) + + ! Compute Hij for all alpha singles + ! ---------------------------------- + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + do i=1,n_singles_a + l_a = singles_a(i) + lrow = psi_bilinear_matrix_rows(l_a) + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + call i_H_j_mono_spin( tmp_det, tmp_det2, $N_int, 1, hij) + do l=1,N_st + v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + ! single => sij = 0 + enddo + enddo + + + ! Compute Hij for all alpha doubles + ! ---------------------------------- + + do i=1,n_doubles + l_a = doubles(i) + lrow = psi_bilinear_matrix_rows(l_a) + call i_H_j_double_spin( tmp_det(1,1), psi_det_alpha_unique(1, lrow), $N_int, hij) + do l=1,N_st + v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + ! same spin => sij = 0 + enddo + enddo + + + + ! Single and double beta excitations + ! ================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + kcol = psi_bilinear_matrix_columns(k_a) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + spindet(1:$N_int) = tmp_det(1:$N_int,2) + + ! Initial determinant is at k_b in beta-major representation + ! ----------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + + ! Loop inside the alpha row to gather all the connected betas + l_b = k_b+1 + nmax = min(N_det_beta_unique, N_det - l_b) + do i=1,nmax + lrow = psi_bilinear_matrix_transp_rows(l_b) + if (lrow /= krow) exit + lcol = psi_bilinear_matrix_transp_columns(l_b) + buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol) + idx(i) = l_b + l_b = l_b+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_b, doubles, n_singles_b, n_doubles ) + + ! Compute Hij for all beta singles + ! ---------------------------------- + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + do i=1,n_singles_b + l_b = singles_b(i) + lcol = psi_bilinear_matrix_transp_columns(l_b) + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol) + call i_H_j_mono_spin( tmp_det, tmp_det2, $N_int, 2, hij) + l_a = psi_bilinear_matrix_transp_order(l_b) + do l=1,N_st + v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + ! single => sij = 0 + enddo + enddo + + ! Compute Hij for all beta doubles + ! ---------------------------------- + + do i=1,n_doubles + l_b = doubles(i) + lcol = psi_bilinear_matrix_transp_columns(l_b) + call i_H_j_double_spin( tmp_det(1,2), psi_det_beta_unique(1, lcol), $N_int, hij) + l_a = psi_bilinear_matrix_transp_order(l_b) + do l=1,N_st + v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + ! same spin => sij = 0 + enddo + enddo + + + ! Diagonal contribution + ! ===================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + kcol = psi_bilinear_matrix_columns(k_a) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + double precision, external :: diag_H_mat_elem, diag_S_mat_elem + + hij = diag_H_mat_elem(tmp_det,$N_int) + sij = diag_S_mat_elem(tmp_det,$N_int) + do l=1,N_st + v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,k_a) + s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,k_a) + enddo + + end do + !$OMP END DO NOWAIT + deallocate(buffer, singles_a, singles_b, doubles, idx) + + !$OMP CRITICAL + do l=1,N_st + do i=1, N_det + v_0(i,l) = v_0(i,l) + v_t(l,i) + s_0(i,l) = s_0(i,l) + s_t(l,i) enddo enddo - !$OMP END CRITICAL (u0Hu0) + !$OMP END CRITICAL + deallocate(v_t, s_t) - deallocate(vt,st) + !$OMP BARRIER !$OMP END PARALLEL - do istate=1,N_st - do i=1,n - v_0(i,istate) = v_0(i,istate) + H_jj(i) * u_0(i,istate) - s_0(i,istate) = s_0(i,istate) + s2_jj(i)* u_0(i,istate) - enddo - enddo - deallocate (shortcut, sort_idx, sorted, version, ut) end +SUBST [ N_int ] + +1;; +2;; +3;; +4;; +N_int;; + +END_TEMPLATE + + diff --git a/src/Davidson/u0Hu0_old.irp.f b/src/Davidson/u0Hu0_old.irp.f new file mode 100644 index 00000000..70aea449 --- /dev/null +++ b/src/Davidson/u0Hu0_old.irp.f @@ -0,0 +1,517 @@ + +subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> + ! + ! n : number of determinants + ! + ! H_jj : array of + ! + END_DOC + integer, intent(in) :: N_st,n,Nint, sze + double precision, intent(out) :: v_0(sze,N_st) + double precision, intent(in) :: u_0(sze,N_st) + double precision, intent(in) :: H_jj(n) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) + double precision :: hij,s2 + double precision, allocatable :: vt(:,:), ut(:,:), st(:,:) + integer :: i,j,k,l, jj,ii + integer :: i0, j0 + + integer, allocatable :: shortcut(:,:), sort_idx(:,:) + integer(bit_kind), allocatable :: sorted(:,:,:), version(:,:,:) + integer(bit_kind) :: sorted_i(Nint) + + integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate + integer :: N_st_8 + + integer, external :: align_double + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: vt, ut, st + + N_st_8 = align_double(N_st) + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (n>0) + PROVIDE ref_bitmask_energy + + allocate (shortcut(0:n+1,2), sort_idx(n,2), sorted(Nint,n,2), version(Nint,n,2)) + allocate( ut(N_st_8,n)) + + v_0 = 0.d0 + + call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint) + call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,hij,s2,j,k,jj,vt,st,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& + !$OMP SHARED(n,keys_tmp,ut,Nint,u_0,v_0,sorted,shortcut,sort_idx,version,N_st,N_st_8) + allocate(vt(N_st_8,n),st(N_st_8,n)) + Vt = 0.d0 + St = 0.d0 + + !$OMP DO + do i=1,n + do istate=1,N_st + ut(istate,i) = u_0(sort_idx(i,2),istate) + enddo + enddo + !$OMP END DO + + !$OMP DO SCHEDULE(static,1) + do sh=1,shortcut(0,2) + do i=shortcut(sh,2),shortcut(sh+1,2)-1 + org_i = sort_idx(i,2) + do j=shortcut(sh,2),shortcut(sh+1,2)-1 + org_j = sort_idx(j,2) + ext = popcnt(xor(sorted(1,i,2), sorted(1,j,2))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2))) + if (ext > 4) exit + end do + if(ext == 4) then + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + end if + end do + end do + enddo + !$OMP END DO + + !$OMP DO + do i=1,n + do istate=1,N_st + ut(istate,i) = u_0(sort_idx(i,1),istate) + enddo + enddo + !$OMP END DO + + !$OMP DO SCHEDULE(static,1) + do sh=1,shortcut(0,1) + do sh2=1,shortcut(0,1) + if (sh==sh2) cycle + + exa = 0 + do ni=1,Nint + exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) + end do + if(exa > 2) then + cycle + end if + + do i=shortcut(sh,1),shortcut(sh+1,1)-1 + org_i = sort_idx(i,1) + do ni=1,Nint + sorted_i(ni) = sorted(ni,i,1) + enddo + + do j=shortcut(sh2,1),shortcut(sh2+1,1)-1 + ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + if (ext > 4) exit + end do + if(ext <= 4) then + org_j = sort_idx(j,1) + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + if (hij /= 0.d0) then + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + enddo + endif + if (ext /= 2) then + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + if (s2 /= 0.d0) then + do istate=1,n_st + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + endif + endif + endif + enddo + + enddo + enddo + + exa = 0 + + do i=shortcut(sh,1),shortcut(sh+1,1)-1 + org_i = sort_idx(i,1) + do ni=1,Nint + sorted_i(ni) = sorted(ni,i,1) + enddo + + do j=shortcut(sh,1),i-1 + ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + if (ext > 4) exit + end do + if(ext <= 4) then + org_j = sort_idx(j,1) + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + if (hij /= 0.d0) then + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + enddo + endif + if (ext /= 2) then + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + if (s2 /= 0.d0) then + do istate=1,n_st + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + endif + endif + endif + enddo + + do j=i+1,shortcut(sh+1,1)-1 + if (i==j) cycle + ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + if (ext > 4) exit + end do + if(ext <= 4) then + org_j = sort_idx(j,1) + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + if (hij /= 0.d0) then + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + enddo + endif + if (ext /= 2) then + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + if (s2 /= 0.d0) then + do istate=1,n_st + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + endif + endif + endif + enddo + enddo + enddo + !$OMP END DO + + do istate=1,N_st + do i=1,n + !$OMP ATOMIC + v_0(i,istate) = v_0(i,istate) + vt(istate,i) + enddo + enddo + + deallocate(vt,st) + !$OMP END PARALLEL + + do istate=1,N_st + do i=1,n + v_0(i,istate) = v_0(i,istate) + H_jj(i) * u_0(i,istate) + enddo + enddo + deallocate (shortcut, sort_idx, sorted, version, ut) +end + + + + + +subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! n : number of determinants + ! + ! H_jj : array of + ! + ! S2_jj : array of + END_DOC + integer, intent(in) :: N_st,n,Nint, sze + double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) + double precision, intent(in) :: u_0(sze,N_st) + double precision, intent(in) :: H_jj(n), S2_jj(n) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) + double precision :: hij,s2 + double precision, allocatable :: vt(:,:), ut(:,:), st(:,:) + integer :: i,j,k,l, jj,ii + integer :: i0, j0 + + integer, allocatable :: shortcut(:,:), sort_idx(:,:) + integer(bit_kind), allocatable :: sorted(:,:,:), version(:,:,:) + integer(bit_kind) :: sorted_i(Nint) + + integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate + integer :: N_st_8 + + integer, external :: align_double + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: vt, ut, st + + N_st_8 = align_double(N_st) + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (n>0) + PROVIDE ref_bitmask_energy + + allocate (shortcut(0:n+1,2), sort_idx(n,2), sorted(Nint,n,2), version(Nint,n,2)) + allocate( ut(N_st_8,n)) + + v_0 = 0.d0 + s_0 = 0.d0 + + call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint) + call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,hij,s2,j,k,jj,vt,st,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& + !$OMP SHARED(n,keys_tmp,ut,Nint,u_0,v_0,s_0,sorted,shortcut,sort_idx,version,N_st,N_st_8) + allocate(vt(N_st_8,n),st(N_st_8,n)) + Vt = 0.d0 + St = 0.d0 + + !$OMP DO + do i=1,n + do istate=1,N_st + ut(istate,i) = u_0(sort_idx(i,2),istate) + enddo + enddo + !$OMP END DO + + !$OMP DO SCHEDULE(static,4) + do sh=1,shortcut(0,2) + do i=shortcut(sh,2),shortcut(sh+1,2)-1 + org_i = sort_idx(i,2) + do j=shortcut(sh,2),shortcut(sh+1,2)-1 + org_j = sort_idx(j,2) + ext = popcnt(xor(sorted(1,i,2), sorted(1,j,2))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2))) + if (ext > 4) exit + end do + if(ext == 4) then + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + end if + end do + end do + enddo + !$OMP END DO + + !$OMP DO + do i=1,n + do istate=1,N_st + ut(istate,i) = u_0(sort_idx(i,1),istate) + enddo + enddo + !$OMP END DO + + !$OMP DO SCHEDULE(static,4) + do sh=1,shortcut(0,1) + do sh2=1,shortcut(0,1) + if (sh==sh2) cycle + + exa = 0 + do ni=1,Nint + exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) + end do + if(exa > 2) then + cycle + end if + + do i=shortcut(sh,1),shortcut(sh+1,1)-1 + org_i = sort_idx(i,1) + do ni=1,Nint + sorted_i(ni) = sorted(ni,i,1) + enddo + + do j=shortcut(sh2,1),shortcut(sh2+1,1)-1 + ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + if (ext > 4) exit + end do + if(ext <= 4) then + org_j = sort_idx(j,1) + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + if (hij /= 0.d0) then + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + enddo + endif + if (ext /= 2) then + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + if (s2 /= 0.d0) then + do istate=1,n_st + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + endif + endif + endif + enddo + + enddo + enddo + + exa = 0 + + do i=shortcut(sh,1),shortcut(sh+1,1)-1 + org_i = sort_idx(i,1) + do ni=1,Nint + sorted_i(ni) = sorted(ni,i,1) + enddo + + do j=shortcut(sh,1),i-1 + ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + if (ext > 4) exit + end do + if(ext <= 4) then + org_j = sort_idx(j,1) + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + if (hij /= 0.d0) then + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + enddo + endif + if (ext /= 2) then + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + if (s2 /= 0.d0) then + do istate=1,n_st + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + endif + endif + endif + enddo + + do j=i+1,shortcut(sh+1,1)-1 + ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + if (ext > 4) exit + end do + if(ext <= 4) then + org_j = sort_idx(j,1) + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + if (hij /= 0.d0) then + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + enddo + endif + if (ext /= 2) then + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + if (s2 /= 0.d0) then + do istate=1,n_st + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + endif + endif + endif + enddo + enddo + enddo + !$OMP END DO + + do istate=1,N_st + do i=1,n + !$OMP ATOMIC + v_0(i,istate) = v_0(i,istate) + vt(istate,i) + !$OMP ATOMIC + s_0(i,istate) = s_0(i,istate) + st(istate,i) + enddo + enddo + + deallocate(vt,st) + !$OMP END PARALLEL + + do istate=1,N_st + do i=1,n + v_0(i,istate) = v_0(i,istate) + H_jj(i) * u_0(i,istate) + s_0(i,istate) = s_0(i,istate) + s2_jj(i)* u_0(i,istate) + enddo + enddo + deallocate (shortcut, sort_idx, sorted, version, ut) +end + +subroutine H_S2_u_0_nstates_test(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze) + use bitmasks + implicit none + integer, intent(in) :: N_st,n,Nint, sze + integer(bit_kind), intent(in) :: keys_tmp(Nint,2,n) + double precision, intent(inout) :: v_0(sze,N_st), s_0(sze,N_st) + double precision, intent(in) :: u_0(sze,N_st) + double precision, intent(in) :: H_jj(n), S2_jj(n) + + PROVIDE ref_bitmask_energy + + double precision, allocatable :: vt(:,:) + integer, allocatable :: idx(:) + integer :: i,j, jj, l + double precision :: hij + + do i=1,n + v_0(i,:) = H_jj(i) * u_0(i,:) + enddo + + allocate(idx(0:n), vt(N_st,n)) + Vt = 0.d0 + !$OMP PARALLEL DO DEFAULT(shared) PRIVATE(i,idx,jj,j,degree,exc,phase,hij,l) SCHEDULE(static,1) + do i=2,n + idx(0) = i + call filter_connected(keys_tmp,keys_tmp(1,1,i),Nint,i-1,idx) + do jj=1,idx(0) + j = idx(jj) + double precision :: phase + integer :: degree + integer :: exc(0:2,2,2) + call get_excitation(keys_tmp(1,1,j),keys_tmp(1,1,i),exc,degree,phase,Nint) +! if ((degree == 2).and.(exc(0,1,1)==1)) then +! continue +! else +! cycle +! endif +! if ((degree == 2).and.(exc(0,1,1)==1)) cycle +! if ((degree > 1)) cycle +! if (exc(0,1,2) /= 0) cycle +! if (exc(0,1,1) == 2) cycle +! if (exc(0,1,2) == 2) cycle +! if ((degree==1).and.(exc(0,1,2) == 1)) cycle + call i_H_j(keys_tmp(1,1,j),keys_tmp(1,1,i),Nint,hij) + do l=1,N_st + !$OMP ATOMIC + vt (l,i) = vt (l,i) + hij*u_0(j,l) + !$OMP ATOMIC + vt (l,j) = vt (l,j) + hij*u_0(i,l) + enddo + enddo + enddo + !$OMP END PARALLEL DO + do i=1,n + v_0(i,:) = v_0(i,:) + vt(:,i) + enddo +end + diff --git a/src/Determinants/EZFIO.cfg b/src/Determinants/EZFIO.cfg index 0676649e..a68a61a5 100644 --- a/src/Determinants/EZFIO.cfg +++ b/src/Determinants/EZFIO.cfg @@ -38,7 +38,7 @@ default: False type: logical doc: Force the wave function to be an eigenfunction of S^2 interface: ezfio,provider,ocaml -default: False +default: True [threshold_generators] type: Threshold diff --git a/src/Determinants/Fock_diag.irp.f b/src/Determinants/Fock_diag.irp.f index a99bbcad..01393fe1 100644 --- a/src/Determinants/Fock_diag.irp.f +++ b/src/Determinants/Fock_diag.irp.f @@ -19,6 +19,15 @@ subroutine build_fock_tmp(fock_diag_tmp,det_ref,Nint) fock_diag_tmp = 0.d0 E0 = 0.d0 + if (Ne(1) /= elec_alpha_num) then + print *, 'Error in build_fock_tmp (alpha)', Ne(1), Ne(2) + stop -1 + endif + if (Ne(2) /= elec_beta_num) then + print *, 'Error in build_fock_tmp (beta)', Ne(1), Ne(2) + stop -1 + endif + ! Occupied MOs do ii=1,elec_alpha_num i = occ(ii,1) diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index 411fe703..a6a7310f 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/Determinants/H_apply_zmq.template.f b/src/Determinants/H_apply_zmq.template.f index 59544b79..ddedc5a2 100644 --- a/src/Determinants/H_apply_zmq.template.f +++ b/src/Determinants/H_apply_zmq.template.f @@ -38,7 +38,7 @@ subroutine $subroutine($params_main) do i_generator=1,N_det_generators $skip write(task,*) i_generator - call add_task_to_taskserver(zmq_to_qp_run_socket,task) + call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) enddo allocate ( pt2_generators(N_states,N_det_generators), & diff --git a/src/Determinants/density_matrix.irp.f b/src/Determinants/density_matrix.irp.f index 118bbdf7..923318bc 100644 --- a/src/Determinants/density_matrix.irp.f +++ b/src/Determinants/density_matrix.irp.f @@ -27,62 +27,101 @@ END_PROVIDER double precision :: ck, cl, ckl double precision :: phase integer :: h1,h2,p1,p2,s1,s2, degree - integer :: exc(0:2,2,2),n_occ(2) + integer(bit_kind) :: tmp_det(N_int,2), tmp_det2(N_int) + integer :: exc(0:2,2),n_occ(2) double precision, allocatable :: tmp_a(:,:,:), tmp_b(:,:,:) + integer :: krow, kcol, lrow, lcol - one_body_dm_mo_alpha = 0.d0 - one_body_dm_mo_beta = 0.d0 - !$OMP PARALLEL DEFAULT(NONE) & - !$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,one_body_dm_mo_beta,N_det,mo_tot_num_align,& - !$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) ) - tmp_a = 0.d0 - tmp_b = 0.d0 - !$OMP DO SCHEDULE(dynamic) - do k=1,N_det - call bitstring_to_list_ab(psi_det(1,1,k), occ, n_occ, N_int) - do m=1,N_states - ck = psi_coef(k,m)*psi_coef(k,m) - do l=1,elec_alpha_num - j = occ(l,1) - tmp_a(j,j,m) += ck - enddo - do l=1,elec_beta_num - j = occ(l,2) - tmp_b(j,j,m) += ck - enddo - enddo - do l=1,k-1 - call get_excitation_degree(psi_det(1,1,k),psi_det(1,1,l),degree,N_int) - if (degree /= 1) then - cycle - endif - call get_mono_excitation(psi_det(1,1,k),psi_det(1,1,l),exc,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - do m=1,N_states - ckl = psi_coef(k,m) * psi_coef(l,m) * phase - if (s1==1) then - tmp_a(h1,p1,m) += ckl - tmp_a(p1,h1,m) += ckl - else - tmp_b(h1,p1,m) += ckl - tmp_b(p1,h1,m) += ckl - endif - enddo - enddo - enddo - !$OMP END DO NOWAIT - !$OMP CRITICAL - one_body_dm_mo_alpha(:,:,:) = one_body_dm_mo_alpha(:,:,:) + tmp_a(:,:,:) - !$OMP END CRITICAL - !$OMP CRITICAL - one_body_dm_mo_beta(:,:,:) = one_body_dm_mo_beta(:,:,:) + tmp_b(:,:,:) - !$OMP END CRITICAL - deallocate(tmp_a,tmp_b) - !$OMP END PARALLEL + PROVIDE psi_det + + one_body_dm_mo_alpha = 0.d0 + one_body_dm_mo_beta = 0.d0 + !$OMP PARALLEL DEFAULT(NONE) & + !$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 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) ) + tmp_a = 0.d0 + tmp_b = 0.d0 + !$OMP DO SCHEDULE(guided) + do k=1,N_det + krow = psi_bilinear_matrix_rows(k) + kcol = psi_bilinear_matrix_columns(k) + tmp_det(:,1) = psi_det_alpha_unique(:,krow) + tmp_det(:,2) = psi_det_beta_unique (:,kcol) + call bitstring_to_list_ab(tmp_det, occ, n_occ, N_int) + do m=1,N_states + ck = psi_bilinear_matrix_values(k,m)*psi_bilinear_matrix_values(k,m) + do l=1,elec_alpha_num + j = occ(l,1) + tmp_a(j,j,m) += ck + enddo + do l=1,elec_beta_num + j = occ(l,2) + tmp_b(j,j,m) += ck + enddo + enddo + + l = k+1 + lrow = psi_bilinear_matrix_rows(l) + lcol = psi_bilinear_matrix_columns(l) + ! Fix beta determinant, loop over alphas + do while ( lcol == kcol ) + tmp_det2(:) = psi_det_alpha_unique(:, lrow) + call get_excitation_degree_spin(tmp_det(1,1),tmp_det2,degree,N_int) + if (degree == 1) then + exc = 0 + call get_mono_excitation_spin(tmp_det(1,1),tmp_det2,exc,phase,N_int) + call decode_exc_spin(exc,h1,p1,h2,p2) + do m=1,N_states + ckl = psi_bilinear_matrix_values(k,m)*psi_bilinear_matrix_values(l,m) * phase + tmp_a(h1,p1,m) += ckl + tmp_a(p1,h1,m) += ckl + enddo + endif + l = l+1 + if (l>N_det) exit + lrow = psi_bilinear_matrix_rows(l) + lcol = psi_bilinear_matrix_columns(l) + enddo + + l = psi_bilinear_matrix_order_reverse(k)+1 + ! Fix alpha determinant, loop over betas + lrow = psi_bilinear_matrix_transp_rows(l) + lcol = psi_bilinear_matrix_transp_columns(l) + do while ( lrow == krow ) + tmp_det2(:) = psi_det_beta_unique (:, lcol) + call get_excitation_degree_spin(tmp_det(1,2),tmp_det2,degree,N_int) + if (degree == 1) then + call get_mono_excitation_spin(tmp_det(1,2),tmp_det2,exc,phase,N_int) + call decode_exc_spin(exc,h1,p1,h2,p2) + do m=1,N_states + ckl = psi_bilinear_matrix_values(k,m)*psi_bilinear_matrix_transp_values(l,m) * phase + tmp_b(h1,p1,m) += ckl + tmp_b(p1,h1,m) += ckl + enddo + endif + l = l+1 + if (l>N_det) exit + lrow = psi_bilinear_matrix_transp_rows(l) + lcol = psi_bilinear_matrix_transp_columns(l) + enddo + + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + one_body_dm_mo_alpha(:,:,:) = one_body_dm_mo_alpha(:,:,:) + tmp_a(:,:,:) + !$OMP END CRITICAL + !$OMP CRITICAL + one_body_dm_mo_beta(:,:,:) = one_body_dm_mo_beta(:,:,:) + tmp_b(:,:,:) + !$OMP END CRITICAL + deallocate(tmp_a,tmp_b) + !$OMP END PARALLEL END_PROVIDER @@ -194,7 +233,6 @@ subroutine set_natural_mos double precision, allocatable :: tmp(:,:) label = "Natural" -! call mo_as_eigvectors_of_mo_matrix(one_body_dm_mo,size(one_body_dm_mo,1),mo_tot_num,label,-1) call mo_as_svd_vectors_of_mo_matrix(one_body_dm_mo,size(one_body_dm_mo,1),mo_tot_num,mo_tot_num,label) end @@ -270,3 +308,74 @@ END_PROVIDER 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) ] + implicit none + BEGIN_DOC + ! Alpha and beta one-body density matrix for each state + END_DOC + + integer :: j,k,l,m + integer :: occ(N_int*bit_kind_size,2) + double precision :: ck, cl, ckl + double precision :: phase + integer :: h1,h2,p1,p2,s1,s2, degree + integer :: exc(0:2,2,2),n_occ(2) + double precision, allocatable :: tmp_a(:,:,:), tmp_b(:,:,:) + + one_body_dm_mo_alpha_old = 0.d0 + one_body_dm_mo_beta_old = 0.d0 + !$OMP PARALLEL DEFAULT(NONE) & + !$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 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) ) + tmp_a = 0.d0 + tmp_b = 0.d0 + !$OMP DO SCHEDULE(dynamic) + do k=1,N_det + call bitstring_to_list_ab(psi_det(1,1,k), occ, n_occ, N_int) + do m=1,N_states + ck = psi_coef(k,m)*psi_coef(k,m) + do l=1,elec_alpha_num + j = occ(l,1) + tmp_a(j,j,m) += ck + enddo + do l=1,elec_beta_num + j = occ(l,2) + tmp_b(j,j,m) += ck + enddo + enddo + do l=1,k-1 + call get_excitation_degree(psi_det(1,1,k),psi_det(1,1,l),degree,N_int) + if (degree /= 1) then + cycle + endif + call get_mono_excitation(psi_det(1,1,k),psi_det(1,1,l),exc,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + do m=1,N_states + ckl = psi_coef(k,m) * psi_coef(l,m) * phase + if (s1==1) then + tmp_a(h1,p1,m) += ckl + tmp_a(p1,h1,m) += ckl + else + tmp_b(h1,p1,m) += ckl + tmp_b(p1,h1,m) += ckl + endif + enddo + enddo + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + one_body_dm_mo_alpha_old(:,:,:) = one_body_dm_mo_alpha_old(:,:,:) + tmp_a(:,:,:) + !$OMP END CRITICAL + !$OMP CRITICAL + one_body_dm_mo_beta_old(:,:,:) = one_body_dm_mo_beta_old(:,:,:) + tmp_b(:,:,:) + !$OMP END CRITICAL + deallocate(tmp_a,tmp_b) + !$OMP END PARALLEL + +END_PROVIDER diff --git a/src/Determinants/determinants.irp.f b/src/Determinants/determinants.irp.f index bed3327d..2644801e 100644 --- a/src/Determinants/determinants.irp.f +++ b/src/Determinants/determinants.irp.f @@ -23,7 +23,7 @@ BEGIN_PROVIDER [ integer, N_det ] ! Number of determinants in the wave function END_DOC logical :: exists - character*64 :: label + character*(64) :: label PROVIDE ezfio_filename PROVIDE nproc if (read_wf) then @@ -88,7 +88,7 @@ BEGIN_PROVIDER [ integer(bit_kind), psi_det, (N_int,2,psi_det_size) ] END_DOC integer :: i logical :: exists - character*64 :: label + character*(64) :: label psi_det = 0_bit_kind if (read_wf) then diff --git a/src/Determinants/filter_connected.irp.f b/src/Determinants/filter_connected.irp.f index da333b1e..b76540f7 100644 --- a/src/Determinants/filter_connected.irp.f +++ b/src/Determinants/filter_connected.irp.f @@ -1,4 +1,102 @@ +subroutine filter_not_connected(key1,key2,Nint,sze,idx) + use bitmasks + implicit none + BEGIN_DOC + ! Returns the array idx which contains the index of the + ! + ! determinants in the array key1 that DO NOT interact + ! + ! via the H operator with key2. + ! + ! idx(0) is the number of determinants that DO NOT interact with key1 + END_DOC + integer, intent(in) :: Nint, sze + integer(bit_kind), intent(in) :: key1(Nint,2,sze) + integer(bit_kind), intent(in) :: key2(Nint,2) + integer, intent(out) :: idx(0:sze) + + integer :: i,j,l + integer :: degree_x2 + + + ASSERT (Nint > 0) + ASSERT (sze >= 0) + + l=1 + + if (Nint==1) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt( xor( key1(1,1,i), key2(1,1))) & + + popcnt( xor( key1(1,2,i), key2(1,2))) + if (degree_x2 > 4) then + idx(l) = i + l = l+1 + else + cycle + endif + enddo + + else if (Nint==2) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + if (degree_x2 > 4) then + idx(l) = i + l = l+1 + else + cycle + endif + enddo + + else if (Nint==3) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + & + popcnt(xor( key1(3,1,i), key2(3,1))) + & + popcnt(xor( key1(3,2,i), key2(3,2))) + if (degree_x2 > 4) then + idx(l) = i + l = l+1 + else + cycle + endif + enddo + + else + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = 0 + !DEC$ LOOP COUNT MIN(4) + do j=1,Nint + degree_x2 = degree_x2+ popcnt(xor( key1(j,1,i), key2(j,1))) +& + popcnt(xor( key1(j,2,i), key2(j,2))) + if (degree_x2 > 4) then + idx(l) = i + l = l+1 + endif + enddo + if (degree_x2 <= 5) then + exit + endif + enddo + + endif + idx(0) = l-1 +end + + subroutine filter_connected(key1,key2,Nint,sze,idx) use bitmasks implicit none diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f index 42bca8eb..38460f87 100644 --- a/src/Determinants/occ_pattern.irp.f +++ b/src/Determinants/occ_pattern.irp.f @@ -36,7 +36,7 @@ subroutine occ_pattern_to_dets_size(o,sze,n_alpha,Nint) amax -= popcnt( o(k,2) ) enddo sze = int( min(binom_func(bmax, amax), 1.d8) ) - sze = sze*sze + sze = 2*sze*sze + 16 end @@ -246,14 +246,22 @@ subroutine make_s2_eigenfunction integer :: i,j,k integer :: smax, s integer(bit_kind), allocatable :: d(:,:,:), det_buffer(:,:,:) - integer :: N_det_new + integer :: N_det_new, ithread, omp_get_thread_num integer, parameter :: bufsze = 1000 logical, external :: is_in_wavefunction - allocate (d(N_int,2,1), det_buffer(N_int,2,bufsze) ) - smax = 1 - N_det_new = 0 + call write_int(6,N_occ_pattern,'Number of occupation patterns') + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(N_occ_pattern, psi_occ_pattern, elec_alpha_num,N_int) & + !$OMP PRIVATE(s,ithread, d, det_buffer, smax, N_det_new,i,j,k) + N_det_new = 0 + call occ_pattern_to_dets_size(psi_occ_pattern(1,1,1),s,elec_alpha_num,N_int) + allocate (d(N_int,2,s), det_buffer(N_int,2,bufsze) ) + smax = s + ithread=0 + !$ ithread = omp_get_thread_num() + !$OMP DO do i=1,N_occ_pattern call occ_pattern_to_dets_size(psi_occ_pattern(1,1,i),s,elec_alpha_num,N_int) s += 1 @@ -270,40 +278,26 @@ subroutine make_s2_eigenfunction det_buffer(k,1,N_det_new) = d(k,1,j) det_buffer(k,2,N_det_new) = d(k,2,j) enddo -! integer :: ne(2) -! ne(:) = 0 -! do k=1,N_int -! ne(1) += popcnt(d(k,1,j)) -! ne(2) += popcnt(d(k,2,j)) -! enddo -! if (ne(1) /= elec_alpha_num) then -! call debug_det(d(1,1,j),N_int) -! stop "ALPHA" -! endif -! if (ne(2) /= elec_beta_num) then -! call debug_det(d(1,1,j),N_int) -! stop "BETA" -! endif if (N_det_new == bufsze) then - call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,0) + call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,ithread) N_det_new = 0 endif endif enddo enddo + !$OMP END DO NOWAIT if (N_det_new > 0) then - call fill_H_apply_buffer_no_selection(N_det_new,det_buffer,N_int,0) -! call fill_H_apply_buffer_no_selection_first_order_coef(N_det_new,det_buffer,N_int,0) + call fill_H_apply_buffer_no_selection(N_det_new,det_buffer,N_int,ithread) endif - + !$OMP BARRIER deallocate(d,det_buffer) + !$OMP END PARALLEL call copy_H_apply_buffer_to_wf SOFT_TOUCH N_det psi_coef psi_det print *, 'Added determinants for S^2' -! logical :: found -! call remove_duplicates_in_psi_det(found) + call write_time(6) end diff --git a/src/Determinants/print_wf.irp.f b/src/Determinants/print_wf.irp.f index af109e2d..737e4d3e 100644 --- a/src/Determinants/print_wf.irp.f +++ b/src/Determinants/print_wf.irp.f @@ -28,32 +28,32 @@ subroutine routine if(degree == 0)then print*,'Reference determinant ' else - call i_H_j(psi_det(1,1,i),psi_det(1,1,1),N_int,hij) + call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,hij) call get_excitation(psi_det(1,1,1),psi_det(1,1,i),exc,degree,phase,N_int) call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) print*,'phase = ',phase - if(degree == 1)then - print*,'s1',s1 - print*,'h1,p1 = ',h1,p1 - if(s1 == 1)then - norm_mono_a += dabs(psi_coef(i,1)/psi_coef(1,1)) - else - norm_mono_b += dabs(psi_coef(i,1)/psi_coef(1,1)) - endif - print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,list_act(1),list_act(1),p1,mo_integrals_map) - double precision :: hmono,hdouble - call i_H_j_verbose(psi_det(1,1,1),psi_det(1,1,i),N_int,hij,hmono,hdouble) - print*,'hmono = ',hmono - print*,'hdouble = ',hdouble - print*,'hmono+hdouble = ',hmono+hdouble - print*,'hij = ',hij - else - print*,'s1',s1 - print*,'h1,p1 = ',h1,p1 - print*,'s2',s2 - print*,'h2,p2 = ',h2,p2 - print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map) - endif +! if(degree == 1)then +! print*,'s1',s1 +! print*,'h1,p1 = ',h1,p1 +! if(s1 == 1)then +! norm_mono_a += dabs(psi_coef(i,1)/psi_coef(1,1)) +! else +! norm_mono_b += dabs(psi_coef(i,1)/psi_coef(1,1)) +! endif +! print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,list_act(1),list_act(1),p1,mo_integrals_map) +! double precision :: hmono,hdouble +! call i_H_j_verbose(psi_det(1,1,1),psi_det(1,1,i),N_int,hij,hmono,hdouble) +! print*,'hmono = ',hmono +! print*,'hdouble = ',hdouble +! print*,'hmono+hdouble = ',hmono+hdouble +! print*,'hij = ',hij +! else +! print*,'s1',s1 +! print*,'h1,p1 = ',h1,p1 +! print*,'s2',s2 +! print*,'h2,p2 = ',h2,p2 +! print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map) +! endif print*,' = ',hij endif diff --git a/src/Determinants/s2.irp.f b/src/Determinants/s2.irp.f index 7e62befb..0340361d 100644 --- a/src/Determinants/s2.irp.f +++ b/src/Determinants/s2.irp.f @@ -1,3 +1,35 @@ +double precision function diag_S_mat_elem(key_i,Nint) + implicit none + use bitmasks + include 'Utils/constants.include.F' + + integer :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2) + BEGIN_DOC +! Returns + 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)) + enddo + + do i=1,Nint + xorvec(i) = iand(xorvec(i),key_i(i,1)) + enddo + + nup = 0 + do i=1,Nint + if (xorvec(i) /= 0_bit_kind) then + nup += popcnt(xorvec(i)) + endif + enddo + diag_S_mat_elem = dble(nup) + +end + subroutine get_s2(key_i,key_j,Nint,s2) implicit none use bitmasks @@ -25,11 +57,9 @@ subroutine get_s2(key_i,key_j,Nint,s2) endif endif case(0) - nup = 0 - do i=1,Nint - nup += popcnt(iand(xor(key_i(i,1),key_i(i,2)),key_i(i,1))) - enddo - s2 = dble(nup) + double precision, external :: diag_S_mat_elem + !DIR$ FORCEINLINE + s2 = diag_S_mat_elem(key_i,Nint) end select end @@ -223,13 +253,12 @@ subroutine S2_u_0_nstates(v_0,u_0,n,keys_tmp,Nint,N_st,sze_8) enddo !$OMP END DO NOWAIT - !$OMP CRITICAL do istate=1,N_st do i=n,1,-1 + !$OMP ATOMIC v_0(i,istate) = v_0(i,istate) + vt(i,istate) enddo enddo - !$OMP END CRITICAL deallocate(vt) !$OMP END PARALLEL @@ -253,8 +282,8 @@ end subroutine get_uJ_s2_uI(psi_keys_tmp,psi_coefs_tmp,n,nmax_coefs,nmax_keys,s2,nstates) implicit none use bitmasks - integer(bit_kind), intent(in) :: psi_keys_tmp(N_int,2,nmax_keys) integer, intent(in) :: n,nmax_coefs,nmax_keys,nstates + integer(bit_kind), intent(in) :: psi_keys_tmp(N_int,2,nmax_keys) double precision, intent(in) :: psi_coefs_tmp(nmax_coefs,nstates) double precision, intent(out) :: s2(nstates,nstates) double precision :: s2_tmp,accu @@ -345,7 +374,7 @@ subroutine diagonalize_s2_betweenstates(keys_tmp,u_0,n,nmax_keys,nmax_coefs,nsta print*,'S^2 matrix in the basis of the states considered' do i = 1, nstates - write(*,'(100(F5.2,X))')s2(i,:) + write(*,'(100(F5.2,1X))')s2(i,:) enddo double precision :: accu_precision_diag,accu_precision_of_diag @@ -371,7 +400,7 @@ subroutine diagonalize_s2_betweenstates(keys_tmp,u_0,n,nmax_keys,nmax_coefs,nsta print*,'Modified S^2 matrix that will be diagonalized' do i = 1, nstates - write(*,'(10(F5.2,X))')s2(i,:) + write(*,'(10(F5.2,1X))')s2(i,:) s2(i,i) = s2(i,i) enddo diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 789dc93c..4d5b1bd3 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -1,32 +1,60 @@ subroutine get_excitation_degree(key1,key2,degree,Nint) use bitmasks + include 'Utils/constants.include.F' implicit none BEGIN_DOC ! Returns the excitation degree between two determinants END_DOC integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key1(Nint,2) - integer(bit_kind), intent(in) :: key2(Nint,2) + integer(bit_kind), intent(in) :: key1(Nint*2) + integer(bit_kind), intent(in) :: key2(Nint*2) integer, intent(out) :: degree + integer(bit_kind) :: xorvec(2*N_int_max) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec integer :: l ASSERT (Nint > 0) - degree = popcnt(xor( key1(1,1), key2(1,1))) + & - popcnt(xor( key1(1,2), key2(1,2))) - !DIR$ NOUNROLL - do l=2,Nint - degree = degree+ popcnt(xor( key1(l,1), key2(l,1))) + & - popcnt(xor( key1(l,2), key2(l,2))) - enddo - ASSERT (degree >= 0) + select case (Nint) + + case (1) + xorvec(1) = xor( key1(1), key2(1)) + xorvec(2) = xor( key1(2), key2(2)) + degree = sum(popcnt(xorvec(1:2))) + + case (2) + xorvec(1) = xor( key1(1), key2(1)) + xorvec(2) = xor( key1(2), key2(2)) + xorvec(3) = xor( key1(3), key2(3)) + xorvec(4) = xor( key1(4), key2(4)) + degree = sum(popcnt(xorvec(1:4))) + + case (3) + do l=1,6 + xorvec(l) = xor( key1(l), key2(l)) + enddo + degree = sum(popcnt(xorvec(1:6))) + + case (4) + do l=1,8 + xorvec(l) = xor( key1(l), key2(l)) + enddo + degree = sum(popcnt(xorvec(1:8))) + + case default + do l=1,ishft(Nint,1) + xorvec(l) = xor( key1(l), key2(l)) + enddo + degree = sum(popcnt(xorvec(1:l))) + + end select + degree = ishft(degree,-1) end - subroutine get_excitation(det1,det2,exc,degree,phase,Nint) use bitmasks implicit none @@ -139,72 +167,6 @@ subroutine decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) end -subroutine decode_exc_int2(exc,degree,h1,p1,h2,p2,s1,s2) - use bitmasks - implicit none - BEGIN_DOC - ! Decodes the exc arrays returned by get_excitation. - ! h1,h2 : Holes - ! p1,p2 : Particles - ! s1,s2 : Spins (1:alpha, 2:beta) - ! degree : Degree of excitation - END_DOC - integer, intent(in) :: exc(0:2,2,2),degree - integer*2, intent(out) :: h1,h2,p1,p2,s1,s2 - ASSERT (degree > 0) - ASSERT (degree < 3) - - select case(degree) - case(2) - if (exc(0,1,1) == 2) then - h1 = exc(1,1,1) - h2 = exc(2,1,1) - p1 = exc(1,2,1) - p2 = exc(2,2,1) - s1 = 1 - s2 = 1 - else if (exc(0,1,2) == 2) then - h1 = exc(1,1,2) - h2 = exc(2,1,2) - p1 = exc(1,2,2) - p2 = exc(2,2,2) - s1 = 2 - s2 = 2 - else - h1 = exc(1,1,1) - h2 = exc(1,1,2) - p1 = exc(1,2,1) - p2 = exc(1,2,2) - s1 = 1 - s2 = 2 - endif - case(1) - if (exc(0,1,1) == 1) then - h1 = exc(1,1,1) - h2 = 0 - p1 = exc(1,2,1) - p2 = 0 - s1 = 1 - s2 = 0 - else - h1 = exc(1,1,2) - h2 = 0 - p1 = exc(1,2,2) - p2 = 0 - s1 = 2 - s2 = 0 - endif - case(0) - h1 = 0 - p1 = 0 - h2 = 0 - p2 = 0 - s1 = 0 - s2 = 0 - end select -end - - subroutine get_double_excitation(det1,det2,exc,phase,Nint) use bitmasks implicit none @@ -925,22 +887,29 @@ subroutine create_minilist(key_mask, fullList, miniList, idx_miniList, N_fullLis N_miniList = 0 + integer :: e_ab + e_ab = n_a+n_b do i=1,N_fullList - e_a = n_a - popcnt(iand(fullList(1, 1, i), key_mask(1, 1))) - e_b = n_b - popcnt(iand(fullList(1, 2, i), key_mask(1, 2))) + e_a = e_ab - popcnt(iand(fullList(1, 1, i), key_mask(1, 1))) & + - popcnt(iand(fullList(1, 2, i), key_mask(1, 2))) do ni=2,nint - e_a -= popcnt(iand(fullList(ni, 1, i), key_mask(ni, 1))) - e_b -= popcnt(iand(fullList(ni, 2, i), key_mask(ni, 2))) + e_a = e_a - popcnt(iand(fullList(ni, 1, i), key_mask(ni, 1))) & + - popcnt(iand(fullList(ni, 2, i), key_mask(ni, 2))) end do - if(e_a + e_b <= 2) then - N_miniList = N_miniList + 1 - do ni=1,Nint - miniList(ni,1,N_miniList) = fullList(ni,1,i) - miniList(ni,2,N_miniList) = fullList(ni,2,i) - enddo - idx_miniList(N_miniList) = i - end if + if(e_a > 2) then + cycle + endif + + N_miniList = N_miniList + 1 + miniList(1,1,N_miniList) = fullList(1,1,i) + miniList(1,2,N_miniList) = fullList(1,2,i) + do ni=2,Nint + miniList(ni,1,N_miniList) = fullList(ni,1,i) + miniList(ni,2,N_miniList) = fullList(ni,2,i) + enddo + idx_miniList(N_miniList) = i + end do end subroutine @@ -1041,13 +1010,15 @@ subroutine i_H_psi(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array) double precision :: phase integer :: exc(0:2,2,2) double precision :: hij - integer :: idx(0:Ndet) + integer, allocatable :: idx(:) ASSERT (Nint > 0) ASSERT (N_int == Nint) ASSERT (Nstate > 0) ASSERT (Ndet > 0) ASSERT (Ndet_max >= Ndet) + allocate(idx(0:Ndet)) + i_H_psi_array = 0.d0 call filter_connected_i_H_psi0(keys,key,Nint,Ndet,idx) @@ -1089,7 +1060,7 @@ subroutine i_H_psi_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max, double precision :: phase integer :: exc(0:2,2,2) double precision :: hij - integer :: idx(0:Ndet) + integer, allocatable :: idx(:) BEGIN_DOC ! Computes = \sum_J c_J . ! @@ -1102,6 +1073,7 @@ subroutine i_H_psi_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max, ASSERT (Nstate > 0) ASSERT (Ndet > 0) ASSERT (Ndet_max >= Ndet) + allocate(idx(0:Ndet)) i_H_psi_array = 0.d0 call filter_connected_i_H_psi0(keys,key,Nint,N_minilist,idx) @@ -1148,7 +1120,8 @@ subroutine i_H_psi_sec_ord(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array double precision :: phase integer :: exc(0:2,2,2) double precision :: hij - integer :: idx(0:Ndet),n_interact + integer,allocatable :: idx(:) + integer :: n_interact BEGIN_DOC ! for the various Nstates END_DOC @@ -1158,6 +1131,7 @@ subroutine i_H_psi_sec_ord(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array ASSERT (Nstate > 0) ASSERT (Ndet > 0) ASSERT (Ndet_max >= Ndet) + allocate(idx(0:Ndet)) i_H_psi_array = 0.d0 call filter_connected_i_H_psi0(keys,key,Nint,Ndet,idx) n_interact = 0 @@ -1207,7 +1181,7 @@ subroutine i_H_psi_SC2(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,idx double precision :: phase integer :: exc(0:2,2,2) double precision :: hij - integer :: idx(0:Ndet) + integer,allocatable :: idx(:) ASSERT (Nint > 0) ASSERT (N_int == Nint) @@ -1215,6 +1189,7 @@ subroutine i_H_psi_SC2(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,idx ASSERT (Ndet > 0) ASSERT (Ndet_max >= Ndet) i_H_psi_array = 0.d0 + allocate(idx(0:Ndet)) call filter_connected_i_H_psi0_SC2(keys,key,Nint,Ndet,idx,idx_repeat) do ii=1,idx(0) i = idx(ii) @@ -1254,7 +1229,7 @@ subroutine i_H_psi_SC2_verbose(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_a double precision :: phase integer :: exc(0:2,2,2) double precision :: hij - integer :: idx(0:Ndet) + integer,allocatable :: idx(:) ASSERT (Nint > 0) ASSERT (N_int == Nint) @@ -1262,6 +1237,7 @@ subroutine i_H_psi_SC2_verbose(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_a ASSERT (Ndet > 0) ASSERT (Ndet_max >= Ndet) i_H_psi_array = 0.d0 + allocate(idx(0:Ndet)) call filter_connected_i_H_psi0_SC2(keys,key,Nint,Ndet,idx,idx_repeat) print*,'--------' do ii=1,idx(0) @@ -2140,8 +2116,8 @@ end subroutine get_phase(key1,key2,phase,Nint) use bitmasks implicit none - integer(bit_kind), intent(in) :: key1(Nint,2), key2(Nint,2) integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key1(Nint,2), key2(Nint,2) double precision, intent(out) :: phase BEGIN_DOC ! Returns the phase between key1 and key2 @@ -2192,3 +2168,424 @@ subroutine u_0_H_u_0_stored(e_0,u_0,hmatrix,sze) call matrix_vector_product(u_0,v_0,hmatrix,sze,sze) e_0 = u_dot_v(v_0,u_0,sze) end + + + +! Spin-determinant routines +! ------------------------- + +subroutine get_excitation_degree_spin(key1,key2,degree,Nint) + use bitmasks + include 'Utils/constants.include.F' + implicit none + BEGIN_DOC + ! Returns the excitation degree between two determinants + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key1(Nint) + integer(bit_kind), intent(in) :: key2(Nint) + integer, intent(out) :: degree + + integer(bit_kind) :: xorvec(N_int_max) + integer :: l + + ASSERT (Nint > 0) + + select case (Nint) + + case (1) + xorvec(1) = xor( key1(1), key2(1)) + degree = popcnt(xorvec(1)) + + case (2) + xorvec(1) = xor( key1(1), key2(1)) + xorvec(2) = xor( key1(2), key2(2)) + degree = popcnt(xorvec(1))+popcnt(xorvec(2)) + + case (3) + xorvec(1) = xor( key1(1), key2(1)) + xorvec(2) = xor( key1(2), key2(2)) + xorvec(3) = xor( key1(3), key2(3)) + degree = sum(popcnt(xorvec(1:3))) + + case (4) + xorvec(1) = xor( key1(1), key2(1)) + xorvec(2) = xor( key1(2), key2(2)) + xorvec(3) = xor( key1(3), key2(3)) + xorvec(4) = xor( key1(4), key2(4)) + degree = sum(popcnt(xorvec(1:4))) + + case default + do l=1,N_int + xorvec(l) = xor( key1(l), key2(l)) + enddo + degree = sum(popcnt(xorvec(1:Nint))) + + end select + + degree = ishft(degree,-1) + +end + + +subroutine get_excitation_spin(det1,det2,exc,degree,phase,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Returns the excitation operators between two determinants and the phase + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det1(Nint) + integer(bit_kind), intent(in) :: det2(Nint) + integer, intent(out) :: exc(0:2,2) + integer, intent(out) :: degree + double precision, intent(out) :: phase + ! exc(number,hole/particle) + ! ex : + ! exc(0,1) = number of holes + ! exc(0,2) = number of particles + ! exc(1,2) = first particle + ! exc(1,1) = first hole + + ASSERT (Nint > 0) + + !DIR$ FORCEINLINE + call get_excitation_degree_spin(det1,det2,degree,Nint) + select case (degree) + + case (3:) + degree = -1 + return + + case (2) + call get_double_excitation_spin(det1,det2,exc,phase,Nint) + return + + case (1) + call get_mono_excitation_spin(det1,det2,exc,phase,Nint) + return + + case(0) + return + + end select +end + +subroutine decode_exc_spin(exc,h1,p1,h2,p2) + use bitmasks + implicit none + BEGIN_DOC + ! Decodes the exc arrays returned by get_excitation. + ! h1,h2 : Holes + ! p1,p2 : Particles + END_DOC + integer, intent(in) :: exc(0:2,2) + integer, intent(out) :: h1,h2,p1,p2 + + select case (exc(0,1)) + case(2) + h1 = exc(1,1) + h2 = exc(2,1) + p1 = exc(1,2) + p2 = exc(2,2) + case(1) + h1 = exc(1,1) + h2 = 0 + p1 = exc(1,2) + p2 = 0 + case default + h1 = 0 + p1 = 0 + h2 = 0 + p2 = 0 + end select +end + + +subroutine get_double_excitation_spin(det1,det2,exc,phase,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Returns the two excitation operators between two doubly excited spin-determinants + ! and the phase + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det1(Nint) + integer(bit_kind), intent(in) :: det2(Nint) + integer, intent(out) :: exc(0:2,2) + double precision, intent(out) :: phase + integer :: tz + integer :: l, idx_hole, idx_particle, ishift + integer :: nperm + integer :: i,j,k,m,n + integer :: high, low + integer :: a,b,c,d + integer(bit_kind) :: hole, particle, tmp + double precision, parameter :: phase_dble(0:1) = (/ 1.d0, -1.d0 /) + + ASSERT (Nint > 0) + nperm = 0 + exc(0,1) = 0 + exc(0,2) = 0 + + idx_particle = 0 + idx_hole = 0 + ishift = 1-bit_kind_size + do l=1,Nint + ishift = ishift + bit_kind_size + if (det1(l) == det2(l)) then + cycle + endif + tmp = xor( det1(l), det2(l) ) + particle = iand(tmp, det2(l)) + hole = iand(tmp, det1(l)) + do while (particle /= 0_bit_kind) + tz = trailz(particle) + idx_particle = idx_particle + 1 + exc(0,2) = exc(0,2) + 1 + exc(idx_particle,2) = tz+ishift + particle = iand(particle,particle-1_bit_kind) + enddo + if (iand(exc(0,1),exc(0,2))==2) then ! exc(0,1)==2 or exc(0,2)==2 + exit + endif + do while (hole /= 0_bit_kind) + tz = trailz(hole) + idx_hole = idx_hole + 1 + exc(0,1) = exc(0,1) + 1 + exc(idx_hole,1) = tz+ishift + hole = iand(hole,hole-1_bit_kind) + enddo + if (iand(exc(0,1),exc(0,2))==2) then ! exc(0,1)==2 or exc(0,2)==2 + exit + endif + enddo + + select case (exc(0,1)) + + case(1) + low = min(exc(1,1), exc(1,2)) + high = max(exc(1,1), exc(1,2)) + + ASSERT (low > 0) + j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint) + n = iand(low-1,bit_kind_size-1)+1 ! mod(low,bit_kind_size) + ASSERT (high > 0) + k = ishft(high-1,-bit_kind_shift)+1 + m = iand(high-1,bit_kind_size-1)+1 + + if (j==k) then + nperm = nperm + popcnt(iand(det1(j), & + iand( ibset(0_bit_kind,m-1)-1_bit_kind, & + ibclr(-1_bit_kind,n)+1_bit_kind ) )) + else + nperm = nperm + popcnt(iand(det1(k), & + ibset(0_bit_kind,m-1)-1_bit_kind)) + if (n < bit_kind_size) then + nperm = nperm + popcnt(iand(det1(j), ibclr(-1_bit_kind,n) +1_bit_kind)) + endif + do i=j+1,k-1 + nperm = nperm + popcnt(det1(i)) + end do + endif + + case (2) + + do i=1,2 + low = min(exc(i,1), exc(i,2)) + high = max(exc(i,1), exc(i,2)) + + ASSERT (low > 0) + j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint) + n = iand(low-1,bit_kind_size-1)+1 ! mod(low,bit_kind_size) + ASSERT (high > 0) + k = ishft(high-1,-bit_kind_shift)+1 + m = iand(high-1,bit_kind_size-1)+1 + + if (j==k) then + nperm = nperm + popcnt(iand(det1(j), & + iand( ibset(0_bit_kind,m-1)-1_bit_kind, & + ibclr(-1_bit_kind,n)+1_bit_kind ) )) + else + nperm = nperm + popcnt(iand(det1(k), & + ibset(0_bit_kind,m-1)-1_bit_kind)) + if (n < bit_kind_size) then + nperm = nperm + popcnt(iand(det1(j), ibclr(-1_bit_kind,n) +1_bit_kind)) + endif + do l=j+1,k-1 + nperm = nperm + popcnt(det1(l)) + end do + endif + + enddo + + a = min(exc(1,1), exc(1,2)) + b = max(exc(1,1), exc(1,2)) + c = min(exc(2,1), exc(2,2)) + d = max(exc(2,1), exc(2,2)) + if (c>a .and. cb) then + nperm = nperm + 1 + endif + end select + + phase = phase_dble(iand(nperm,1)) + +end + +subroutine get_mono_excitation_spin(det1,det2,exc,phase,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Returns the excitation operator between two singly excited determinants and the phase + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det1(Nint) + integer(bit_kind), intent(in) :: det2(Nint) + integer, intent(out) :: exc(0:2,2) + double precision, intent(out) :: phase + integer :: tz + integer :: l, idx_hole, idx_particle, ishift + integer :: nperm + integer :: i,j,k,m,n + integer :: high, low + integer :: a,b,c,d + integer(bit_kind) :: hole, particle, tmp + double precision, parameter :: phase_dble(0:1) = (/ 1.d0, -1.d0 /) + + ASSERT (Nint > 0) + nperm = 0 + exc(0,1) = 0 + exc(0,2) = 0 + + ishift = 1-bit_kind_size + do l=1,Nint + ishift = ishift + bit_kind_size + if (det1(l) == det2(l)) then + cycle + endif + tmp = xor( det1(l), det2(l) ) + particle = iand(tmp, det2(l)) + hole = iand(tmp, det1(l)) + if (particle /= 0_bit_kind) then + tz = trailz(particle) + exc(0,2) = 1 + exc(1,2) = tz+ishift + endif + if (hole /= 0_bit_kind) then + tz = trailz(hole) + exc(0,1) = 1 + exc(1,1) = tz+ishift + endif + + if ( iand(exc(0,1),exc(0,2)) /= 1) then ! exc(0,1)/=1 and exc(0,2) /= 1 + cycle + endif + + low = min(exc(1,1),exc(1,2)) + high = max(exc(1,1),exc(1,2)) + + ASSERT (low > 0) + j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint) + n = iand(low-1,bit_kind_size-1)+1 ! mod(low,bit_kind_size) + ASSERT (high > 0) + k = ishft(high-1,-bit_kind_shift)+1 + m = iand(high-1,bit_kind_size-1)+1 + if (j==k) then + nperm = popcnt(iand(det1(j), & + iand(ibset(0_bit_kind,m-1)-1_bit_kind,ibclr(-1_bit_kind,n)+1_bit_kind))) + else + nperm = nperm + popcnt(iand(det1(k),ibset(0_bit_kind,m-1)-1_bit_kind)) + if (n < bit_kind_size) then + nperm = nperm + popcnt(iand(det1(j),ibclr(-1_bit_kind,n)+1_bit_kind)) + endif + do i=j+1,k-1 + nperm = nperm + popcnt(det1(i)) + end do + endif + phase = phase_dble(iand(nperm,1)) + return + + enddo +end + +subroutine i_H_j_mono_spin(key_i,key_j,Nint,spin,hij) + use bitmasks + implicit none + BEGIN_DOC + ! Returns where i and j are determinants differing by a single excitation + END_DOC + integer, intent(in) :: Nint, spin + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: hij + + integer :: exc(0:2,2) + double precision :: phase + + PROVIDE big_array_exchange_integrals mo_bielec_integrals_in_map + + call get_mono_excitation_spin(key_i(1,spin),key_j(1,spin),exc,phase,Nint) + call get_mono_excitation_from_fock(key_i,key_j,exc(1,1),exc(1,2),spin,phase,hij) +end + +subroutine i_H_j_double_spin(key_i,key_j,Nint,hij) + use bitmasks + implicit none + BEGIN_DOC + ! Returns where i and j are determinants differing by a same-spin double excitation + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint), key_j(Nint) + double precision, intent(out) :: hij + + integer :: exc(0:2,2) + double precision :: phase + double precision, external :: get_mo_bielec_integral + + PROVIDE big_array_exchange_integrals mo_bielec_integrals_in_map + + call get_double_excitation_spin(key_i,key_j,exc,phase,Nint) + hij = phase*(get_mo_bielec_integral( & + exc(1,1), & + exc(2,1), & + exc(1,2), & + exc(2,2), mo_integrals_map) - & + get_mo_bielec_integral( & + exc(1,1), & + exc(2,1), & + exc(2,2), & + exc(1,2), mo_integrals_map) ) +end + +subroutine i_H_j_double_alpha_beta(key_i,key_j,Nint,hij) + use bitmasks + implicit none + BEGIN_DOC + ! Returns where i and j are determinants differing by an opposite-spin double excitation + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: hij + + integer :: exc(0:2,2,2) + double precision :: phase, phase2 + double precision, external :: get_mo_bielec_integral + + PROVIDE big_array_exchange_integrals mo_bielec_integrals_in_map + + call get_mono_excitation_spin(key_i(1,1),key_j(1,1),exc(0,1,1),phase,Nint) + call get_mono_excitation_spin(key_i(1,2),key_j(1,2),exc(0,1,2),phase2,Nint) + phase = phase*phase2 + if (exc(1,1,1) == exc(1,2,2)) then + hij = phase * big_array_exchange_integrals(exc(1,1,1),exc(1,1,2),exc(1,2,1)) + else if (exc(1,2,1) == exc(1,1,2)) then + hij = phase * big_array_exchange_integrals(exc(1,2,1),exc(1,1,1),exc(1,2,2)) + else + hij = phase*get_mo_bielec_integral( & + exc(1,1,1), & + exc(1,1,2), & + exc(1,2,1), & + exc(1,2,2) ,mo_integrals_map) + endif +end + + diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index 2eec0dea..aa7fde29 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -64,9 +64,9 @@ BEGIN_TEMPLATE integer :: i,j,k integer, allocatable :: iorder(:) - integer(8), allocatable :: bit_tmp(:) - integer(8) :: last_key - integer(8), external :: spin_det_search_key + integer*8, allocatable :: bit_tmp(:) + integer*8 :: last_key + integer*8, external :: spin_det_search_key logical,allocatable :: duplicate(:) allocate ( iorder(N_det), bit_tmp(N_det), duplicate(N_det) ) @@ -386,26 +386,31 @@ END_PROVIDER !==============================================================================! BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_values, (N_det,N_states) ] -&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_rows, (N_det) ] +&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_rows , (N_det) ] &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_columns, (N_det) ] +&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_order , (N_det) ] use bitmasks implicit none BEGIN_DOC ! Sparse coefficient matrix if the wave function is expressed in a bilinear form : ! D_a^t C D_b +! +! Rows are alpha determinants and columns are beta. +! +! Order refers to psi_det END_DOC integer :: i,j,k, l integer(bit_kind) :: tmp_det(N_int,2) - integer :: idx integer, external :: get_index_in_psi_det_sorted_bit PROVIDE psi_coef_sorted_bit - integer, allocatable :: iorder(:), to_sort(:) + integer*8, allocatable :: to_sort(:) integer, external :: get_index_in_psi_det_alpha_unique integer, external :: get_index_in_psi_det_beta_unique - allocate(iorder(N_det), to_sort(N_det)) + allocate(to_sort(N_det)) + !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,j,k,l) do k=1,N_det i = get_index_in_psi_det_alpha_unique(psi_det(1,1,k),N_int) j = get_index_in_psi_det_beta_unique (psi_det(1,2,k),N_int) @@ -415,16 +420,146 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_values, (N_det,N_states) enddo psi_bilinear_matrix_rows(k) = i psi_bilinear_matrix_columns(k) = j - to_sort(k) = N_det_alpha_unique * (j-1) + i - iorder(k) = k + to_sort(k) = int(N_det_alpha_unique,8) * int(j-1,8) + int(i,8) + psi_bilinear_matrix_order(k) = k enddo - call isort(to_sort, iorder, N_det) - call iset_order(psi_bilinear_matrix_rows,iorder,N_det) - call iset_order(psi_bilinear_matrix_columns,iorder,N_det) - call dset_order(psi_bilinear_matrix_values,iorder,N_det) - deallocate(iorder,to_sort) + !$OMP END PARALLEL DO + call i8sort(to_sort, psi_bilinear_matrix_order, N_det) + call iset_order(psi_bilinear_matrix_rows,psi_bilinear_matrix_order,N_det) + call iset_order(psi_bilinear_matrix_columns,psi_bilinear_matrix_order,N_det) + do l=1,N_states + call dset_order(psi_bilinear_matrix_values(1,l),psi_bilinear_matrix_order,N_det) + enddo + deallocate(to_sort) END_PROVIDER + +BEGIN_PROVIDER [ integer, psi_bilinear_matrix_order_reverse , (N_det) ] + use bitmasks + implicit none + BEGIN_DOC +! Order which allors to go from psi_bilinear_matrix to psi_det + END_DOC + integer :: k + !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(k) + do k=1,N_det + psi_bilinear_matrix_order_reverse(psi_bilinear_matrix_order(k)) = k + enddo + !$OMP END PARALLEL DO +END_PROVIDER + + +BEGIN_PROVIDER [ integer, psi_bilinear_matrix_columns_loc, (N_det_beta_unique+1) ] + use bitmasks + implicit none + BEGIN_DOC +! Sparse coefficient matrix if the wave function is expressed in a bilinear form : +! D_a^t C D_b +! +! Rows are alpha determinants and columns are beta. +! +! Order refers to psi_det + END_DOC + integer :: i,j,k, l + + l = psi_bilinear_matrix_columns(1) + psi_bilinear_matrix_columns_loc(l) = 1 + do k=2,N_det + if (psi_bilinear_matrix_columns(k) == psi_bilinear_matrix_columns(k-1)) then + cycle + else + l = psi_bilinear_matrix_columns(k) + psi_bilinear_matrix_columns_loc(l) = k + endif + enddo + psi_bilinear_matrix_columns_loc(N_det_beta_unique+1) = N_det+1 +END_PROVIDER + +BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_transp_values, (N_det,N_states) ] +&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_transp_rows , (N_det) ] +&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_transp_columns, (N_det) ] +&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_transp_order , (N_det) ] + use bitmasks + implicit none + BEGIN_DOC +! Transpose of psi_bilinear_matrix +! D_b^t C^t D_a +! +! Rows are Alpha determinants and columns are beta, but the matrix is stored in row major +! format + END_DOC + integer :: i,j,k,l + + + PROVIDE psi_coef_sorted_bit + + integer*8, allocatable :: to_sort(:) + allocate(to_sort(N_det)) + !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l) + !$OMP DO COLLAPSE(2) + do l=1,N_states + do k=1,N_det + psi_bilinear_matrix_transp_values (k,l) = psi_bilinear_matrix_values (k,l) + enddo + enddo + !$OMP ENDDO + !$OMP DO + do k=1,N_det + psi_bilinear_matrix_transp_columns(k) = psi_bilinear_matrix_columns(k) + psi_bilinear_matrix_transp_rows (k) = psi_bilinear_matrix_rows (k) + i = psi_bilinear_matrix_transp_columns(k) + j = psi_bilinear_matrix_transp_rows (k) + to_sort(k) = int(N_det_beta_unique,8) * int(j-1,8) + int(i,8) + psi_bilinear_matrix_transp_order(k) = k + enddo + !$OMP ENDDO + !$OMP END PARALLEL + call i8radix_sort(to_sort, psi_bilinear_matrix_transp_order, N_det,-1) + call iset_order(psi_bilinear_matrix_transp_rows,psi_bilinear_matrix_transp_order,N_det) + call iset_order(psi_bilinear_matrix_transp_columns,psi_bilinear_matrix_transp_order,N_det) + do l=1,N_states + call dset_order(psi_bilinear_matrix_transp_values(1,l),psi_bilinear_matrix_transp_order,N_det) + enddo + deallocate(to_sort) +END_PROVIDER + +BEGIN_PROVIDER [ integer, psi_bilinear_matrix_transp_rows_loc, (N_det_alpha_unique+1) ] + use bitmasks + implicit none + BEGIN_DOC +! Location of the columns in the psi_bilinear_matrix + END_DOC + integer :: i,j,k, l + + l = psi_bilinear_matrix_transp_rows(1) + psi_bilinear_matrix_transp_rows_loc(l) = 1 + do k=2,N_det + if (psi_bilinear_matrix_transp_rows(k) == psi_bilinear_matrix_transp_rows(k-1)) then + cycle + else + l = psi_bilinear_matrix_transp_rows(k) + psi_bilinear_matrix_transp_rows_loc(l) = k + endif + enddo + psi_bilinear_matrix_transp_rows_loc(N_det_alpha_unique+1) = N_det+1 +END_PROVIDER + +BEGIN_PROVIDER [ integer, psi_bilinear_matrix_order_transp_reverse , (N_det) ] + use bitmasks + implicit none + BEGIN_DOC +! Order which allows to go from psi_bilinear_matrix_order_transp to psi_bilinear_matrix + END_DOC + integer :: k + + !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(k) + do k=1,N_det + psi_bilinear_matrix_order_transp_reverse(psi_bilinear_matrix_transp_order(k)) = k + enddo + !$OMP END PARALLEL DO +END_PROVIDER + + BEGIN_PROVIDER [ double precision, psi_bilinear_matrix, (N_det_alpha_unique,N_det_beta_unique,N_states) ] implicit none BEGIN_DOC @@ -506,7 +641,7 @@ subroutine generate_all_alpha_beta_det_products ! Create a wave function from all possible alpha x beta determinants END_DOC integer :: i,j,k,l - integer :: idx, iproc + integer :: iproc integer, external :: get_index_in_psi_det_sorted_bit integer(bit_kind), allocatable :: tmp_det(:,:,:) logical, external :: is_in_wavefunction @@ -515,7 +650,7 @@ subroutine generate_all_alpha_beta_det_products !$OMP PARALLEL DEFAULT(NONE) SHARED(psi_coef_sorted_bit,N_det_beta_unique,& !$OMP N_det_alpha_unique, N_int, psi_det_alpha_unique, psi_det_beta_unique,& !$OMP N_det) & - !$OMP PRIVATE(i,j,k,l,tmp_det,idx,iproc) + !$OMP PRIVATE(i,j,k,l,tmp_det,iproc) !$ iproc = omp_get_thread_num() allocate (tmp_det(N_int,2,N_det_alpha_unique)) !$OMP DO @@ -540,3 +675,487 @@ subroutine generate_all_alpha_beta_det_products end + + +subroutine get_all_spin_singles_and_doubles(buffer, idx, spindet, Nint, size_buffer, singles, doubles, n_singles, n_doubles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the single and double excitations in the list of +! unique alpha determinants. +! +! /!\ : The buffer is transposed ! +! + END_DOC + integer, intent(in) :: Nint, size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer(Nint,size_buffer) + integer(bit_kind), intent(in) :: spindet(Nint) + integer, intent(out) :: singles(size_buffer) + integer, intent(out) :: doubles(size_buffer) + integer, intent(out) :: n_singles + integer, intent(out) :: n_doubles + + select case (Nint) + case (1) + call get_all_spin_singles_and_doubles_1(buffer, idx, spindet(1), size_buffer, singles, doubles, n_singles, n_doubles) + case (2) + call get_all_spin_singles_and_doubles_2(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) + case (3) + call get_all_spin_singles_and_doubles_3(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) + case (4) + call get_all_spin_singles_and_doubles_4(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) + case default + call get_all_spin_singles_and_doubles_N_int(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) + end select + +end + + +subroutine get_all_spin_singles(buffer, idx, spindet, Nint, size_buffer, singles, n_singles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the single excitations in the list of +! unique alpha determinants. +! + END_DOC + integer, intent(in) :: Nint, size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer(Nint,size_buffer) + integer(bit_kind), intent(in) :: spindet(Nint) + integer, intent(out) :: singles(size_buffer) + integer, intent(out) :: n_singles + + select case (N_int) + case (1) + call get_all_spin_singles_1(buffer, idx, spindet(1), size_buffer, singles, n_singles) + return + case (2) + call get_all_spin_singles_2(buffer, idx, spindet, size_buffer, singles, n_singles) + case (3) + call get_all_spin_singles_3(buffer, idx, spindet, size_buffer, singles, n_singles) + case (4) + call get_all_spin_singles_4(buffer, idx, spindet, size_buffer, singles, n_singles) + case default + call get_all_spin_singles_N_int(buffer, idx, spindet, size_buffer, singles, n_singles) + end select + +end + + +subroutine get_all_spin_doubles(buffer, idx, spindet, Nint, size_buffer, doubles, n_doubles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the double excitations in the list of +! unique alpha determinants. +! + END_DOC + integer, intent(in) :: Nint, size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer(Nint,size_buffer) + integer(bit_kind), intent(in) :: spindet(Nint) + integer, intent(out) :: doubles(size_buffer) + integer, intent(out) :: n_doubles + + select case (N_int) + case (1) + call get_all_spin_doubles_1(buffer, idx, spindet(1), size_buffer, doubles, n_doubles) + case (2) + call get_all_spin_doubles_2(buffer, idx, spindet, size_buffer, doubles, n_doubles) + case (3) + call get_all_spin_doubles_3(buffer, idx, spindet, size_buffer, doubles, n_doubles) + case (4) + call get_all_spin_doubles_4(buffer, idx, spindet, size_buffer, doubles, n_doubles) + case default + call get_all_spin_doubles_N_int(buffer, idx, spindet, size_buffer, doubles, n_doubles) + end select + +end + + + + + +subroutine copy_psi_bilinear_to_psi(psi, isize) + implicit none + BEGIN_DOC +! Overwrites psi_det and psi_coef with the wf in bilinear order + END_DOC + integer, intent(in) :: isize + integer(bit_kind), intent(out) :: psi(N_int,2,isize) + integer :: i,j,k,l + do k=1,isize + i = psi_bilinear_matrix_rows(k) + j = psi_bilinear_matrix_columns(k) + psi(1:N_int,1,k) = psi_det_alpha_unique(1:N_int,i) + psi(1:N_int,2,k) = psi_det_beta_unique(1:N_int,j) + enddo +end + +BEGIN_PROVIDER [ integer, singles_alpha_size ] + implicit none + BEGIN_DOC + ! Dimension of the singles_alpha array + END_DOC + singles_alpha_size = elec_alpha_num * (mo_tot_num - elec_alpha_num) +END_PROVIDER + + BEGIN_PROVIDER [ integer*8, singles_alpha_csc_idx, (N_det_alpha_unique+1) ] +&BEGIN_PROVIDER [ integer*8, singles_alpha_csc_size ] + implicit none + BEGIN_DOC + ! Dimension of the singles_alpha array + END_DOC + integer :: i,j + integer, allocatable :: idx0(:), s(:) + allocate (idx0(N_det_alpha_unique)) + do i=1, N_det_alpha_unique + idx0(i) = i + enddo + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(N_det_alpha_unique, psi_det_alpha_unique, & + !$OMP idx0, N_int, singles_alpha_csc, & + !$OMP singles_alpha_size, singles_alpha_csc_idx) & + !$OMP PRIVATE(i,s,j) + allocate (s(singles_alpha_size)) + !$OMP DO SCHEDULE(static,1) + do i=1, N_det_alpha_unique + call get_all_spin_singles( & + psi_det_alpha_unique, idx0, psi_det_alpha_unique(1,i), N_int, & + N_det_alpha_unique, s, j) + singles_alpha_csc_idx(i+1) = int(j,8) + enddo + !$OMP END DO + deallocate(s) + !$OMP END PARALLEL + deallocate(idx0) + + singles_alpha_csc_idx(1) = 1_8 + do i=2, N_det_alpha_unique+1 + singles_alpha_csc_idx(i) = singles_alpha_csc_idx(i) + singles_alpha_csc_idx(i-1) + enddo + singles_alpha_csc_size = singles_alpha_csc_idx(N_det_alpha_unique+1) +END_PROVIDER + + +BEGIN_PROVIDER [ integer, singles_alpha_csc, (singles_alpha_csc_size) ] + implicit none + BEGIN_DOC + ! Dimension of the singles_alpha array + END_DOC + integer :: i, k + integer, allocatable :: idx0(:) + allocate (idx0(N_det_alpha_unique)) + do i=1, N_det_alpha_unique + idx0(i) = i + enddo + + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(N_det_alpha_unique, psi_det_alpha_unique, & + !$OMP idx0, N_int, singles_alpha_csc, singles_alpha_csc_idx) & + !$OMP PRIVATE(i,k) SCHEDULE(static,1) + do i=1, N_det_alpha_unique + call get_all_spin_singles( & + psi_det_alpha_unique, idx0, psi_det_alpha_unique(1,i), N_int, & + N_det_alpha_unique, singles_alpha_csc(singles_alpha_csc_idx(i)), & + k) + enddo + !$OMP END PARALLEL DO + deallocate(idx0) + +END_PROVIDER + + + + +subroutine get_all_spin_singles_and_doubles_1(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the single and double excitations in the list of +! unique alpha determinants. +! +! /!\ : The buffer is transposed ! +! + END_DOC + integer, intent(in) :: size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer(size_buffer) + integer(bit_kind), intent(in) :: spindet + integer, intent(out) :: singles(size_buffer) + integer, intent(out) :: doubles(size_buffer) + integer, intent(out) :: n_singles + integer, intent(out) :: n_doubles + + integer :: i + include 'Utils/constants.include.F' + integer :: degree + + + n_singles = 1 + n_doubles = 1 + !DIR$ VECTOR ALIGNED + do i=1,size_buffer + degree = popcnt( xor( spindet, buffer(i) ) ) + if ( degree == 4 ) then + doubles(n_doubles) = idx(i) + n_doubles = n_doubles+1 + else if ( degree == 2 ) then + singles(n_singles) = idx(i) + n_singles = n_singles+1 + endif + enddo + n_singles = n_singles-1 + n_doubles = n_doubles-1 + +end + + + +subroutine get_all_spin_singles_1(buffer, idx, spindet, size_buffer, singles, n_singles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the single excitations in the list of +! unique alpha determinants. +! + END_DOC + integer, intent(in) :: size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer(size_buffer) + integer(bit_kind), intent(in) :: spindet + integer, intent(out) :: singles(size_buffer) + integer, intent(out) :: n_singles + integer :: i + integer :: degree + include 'Utils/constants.include.F' + + n_singles = 1 + do i=1,size_buffer + degree = popcnt(xor( spindet, buffer(i) )) + singles(n_singles) = idx(i) + if (degree == 2) then + n_singles = n_singles+1 + endif + enddo + n_singles = n_singles-1 + +end + + +subroutine get_all_spin_doubles_1(buffer, idx, spindet, size_buffer, doubles, n_doubles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the double excitations in the list of +! unique alpha determinants. +! + END_DOC + integer, intent(in) :: size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer(size_buffer) + integer(bit_kind), intent(in) :: spindet + integer, intent(out) :: doubles(size_buffer) + integer, intent(out) :: n_doubles + integer :: i + include 'Utils/constants.include.F' + integer :: degree + + n_doubles = 1 + !DIR$ VECTOR ALIGNED + do i=1,size_buffer + degree = popcnt(xor( spindet, buffer(i) )) + if ( degree == 4 ) then + doubles(n_doubles) = idx(i) + n_doubles = n_doubles+1 + endif + enddo + n_doubles = n_doubles-1 + +end + + + +BEGIN_TEMPLATE + +subroutine get_all_spin_singles_and_doubles_$N_int(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the single and double excitations in the list of +! unique alpha determinants. +! +! /!\ : The buffer is transposed ! +! + END_DOC + integer, intent(in) :: size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer($N_int,size_buffer) + integer(bit_kind), intent(in) :: spindet($N_int) + integer, intent(out) :: singles(size_buffer) + integer, intent(out) :: doubles(size_buffer) + integer, intent(out) :: n_singles + integer, intent(out) :: n_doubles + + integer :: i,k + 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 + xorvec(k) = xor( spindet(k), buffer(k,i) ) + enddo + + if (xorvec(1) /= 0_8) then + degree = popcnt(xorvec(1)) + else + degree = 0 + endif + + do k=2,$N_int + !DIR$ VECTOR ALIGNED + if ( (degree <= 4).and.(xorvec(k) /= 0_8) ) then + degree = degree + popcnt(xorvec(k)) + endif + enddo + + if ( degree == 4 ) then + doubles(n_doubles) = idx(i) + n_doubles = n_doubles+1 + else if ( degree == 2 ) then + singles(n_singles) = idx(i) + n_singles = n_singles+1 + endif + + enddo + n_singles = n_singles-1 + n_doubles = n_doubles-1 + +end + + +subroutine get_all_spin_singles_$N_int(buffer, idx, spindet, size_buffer, singles, n_singles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the single excitations in the list of +! unique alpha determinants. +! + END_DOC + integer, intent(in) :: size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer($N_int,size_buffer) + integer(bit_kind), intent(in) :: spindet($N_int) + integer, intent(out) :: singles(size_buffer) + integer, intent(out) :: n_singles + + integer :: i,k + include 'Utils/constants.include.F' + 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 + xorvec(k) = xor( spindet(k), buffer(k,i) ) + enddo + + if (xorvec(1) /= 0_8) then + degree = popcnt(xorvec(1)) + else + degree = 0 + endif + + do k=2,$N_int + if ( (degree <= 2).and.(xorvec(k) /= 0_8) ) then + degree = degree + popcnt(xorvec(k)) + endif + enddo + + if ( degree == 2 ) then + singles(n_singles) = idx(i) + n_singles = n_singles+1 + endif + + enddo + n_singles = n_singles-1 + +end + + +subroutine get_all_spin_doubles_$N_int(buffer, idx, spindet, size_buffer, doubles, n_doubles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the double excitations in the list of +! unique alpha determinants. +! + END_DOC + integer, intent(in) :: size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer($N_int,size_buffer) + integer(bit_kind), intent(in) :: spindet($N_int) + integer, intent(out) :: doubles(size_buffer) + integer, intent(out) :: n_doubles + + integer :: i,k, degree + include 'Utils/constants.include.F' + integer(bit_kind) :: xorvec($N_int) + + n_doubles = 1 + !DIR$ VECTOR ALIGNED + do i=1,size_buffer + + do k=1,$N_int + xorvec(k) = xor( spindet(k), buffer(k,i) ) + enddo + + if (xorvec(1) /= 0_8) then + degree = popcnt(xorvec(1)) + else + degree = 0 + endif + + do k=2,$N_int + !DIR$ VECTOR ALIGNED + if ( (degree <= 4).and.(xorvec(k) /= 0_8) ) then + degree = degree + popcnt(xorvec(k)) + endif + enddo + + if ( degree == 4 ) then + doubles(n_doubles) = idx(i) + n_doubles = n_doubles+1 + endif + + enddo + + n_doubles = n_doubles-1 + +end + +SUBST [ N_int ] +2;; +3;; +4;; +N_int;; + +END_TEMPLATE + + diff --git a/src/Determinants/usefull_for_ovb.irp.f b/src/Determinants/useful_for_ovb.irp.f similarity index 97% rename from src/Determinants/usefull_for_ovb.irp.f rename to src/Determinants/useful_for_ovb.irp.f index 7b89897b..25bdb03a 100644 --- a/src/Determinants/usefull_for_ovb.irp.f +++ b/src/Determinants/useful_for_ovb.irp.f @@ -2,7 +2,8 @@ integer function n_open_shell(det_in,nint) implicit none use bitmasks - integer(bit_kind), intent(in) :: det_in(nint,2),nint + integer, intent(in) :: nint + integer(bit_kind), intent(in) :: det_in(nint,2) integer :: i n_open_shell = 0 do i=1,Nint @@ -13,7 +14,8 @@ end integer function n_closed_shell(det_in,nint) implicit none use bitmasks - integer(bit_kind), intent(in) :: det_in(nint,2),nint + integer, intent(in) :: nint + integer(bit_kind), intent(in) :: det_in(nint,2) integer :: i n_closed_shell = 0 do i=1,Nint @@ -24,7 +26,8 @@ end integer function n_closed_shell_cas(det_in,nint) implicit none use bitmasks - integer(bit_kind), intent(in) :: det_in(nint,2),nint + integer, intent(in) :: nint + integer(bit_kind), intent(in) :: det_in(nint,2) integer(bit_kind) :: det_tmp(nint,2) integer :: i n_closed_shell_cas = 0 diff --git a/src/Electrons/.gitignore b/src/Electrons/.gitignore deleted file mode 100644 index b2bd2f7f..00000000 --- a/src/Electrons/.gitignore +++ /dev/null @@ -1,13 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Ezfio_files \ No newline at end of file diff --git a/src/Ezfio_files/.gitignore b/src/Ezfio_files/.gitignore deleted file mode 100644 index 24230463..00000000 --- a/src/Ezfio_files/.gitignore +++ /dev/null @@ -1,13 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -README.rst \ No newline at end of file diff --git a/src/Integrals_Bielec/.gitignore b/src/Integrals_Bielec/.gitignore deleted file mode 100644 index aaf8a3d5..00000000 --- a/src/Integrals_Bielec/.gitignore +++ /dev/null @@ -1,22 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Utils -ZMQ -ezfio_interface.irp.f -irpf90.make -irpf90_entities -qp_ao_ints -tags -test_integrals \ No newline at end of file diff --git a/src/Integrals_Bielec/ao_bi_integrals.irp.f b/src/Integrals_Bielec/ao_bi_integrals.irp.f index 68a7a050..4750d5a0 100644 --- a/src/Integrals_Bielec/ao_bi_integrals.irp.f +++ b/src/Integrals_Bielec/ao_bi_integrals.irp.f @@ -346,10 +346,11 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ] integer :: n_integrals, rc integer :: kk, m, j1, i1, lmax + character*(64) :: fmt integral = ao_bielec_integral(1,1,1,1) - real :: map_mb + double precision :: map_mb PROVIDE read_ao_integrals disk_access_ao_integrals if (read_ao_integrals) then print*,'Reading the AO integrals' @@ -365,14 +366,16 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ] call cpu_time(cpu_1) integer(ZMQ_PTR) :: zmq_to_qp_run_socket - character*(32) :: task - call new_parallel_job(zmq_to_qp_run_socket,'ao_integrals') - do l=ao_num,1,-1 - write(task,*) "triangle ", l - call add_task_to_taskserver(zmq_to_qp_run_socket,task) + character(len=:), allocatable :: task + allocate(character(len=ao_num*12) :: task) + write(fmt,*) '(', ao_num, '(I5,X,I5,''|''))' + do l=1,ao_num + write(task,fmt) (i,l, i=1,l) + call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) enddo + deallocate(task) call zmq_set_running(zmq_to_qp_run_socket) 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 ce4518cf..38c78388 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/Integrals_Bielec/map_integrals.irp.f b/src/Integrals_Bielec/map_integrals.irp.f index 1f2a7a1b..82b89f22 100644 --- a/src/Integrals_Bielec/map_integrals.irp.f +++ b/src/Integrals_Bielec/map_integrals.irp.f @@ -44,8 +44,8 @@ subroutine bielec_integrals_index_reverse(i,j,k,l,i1) l(1) = ceiling(0.5d0*(dsqrt(8.d0*dble(i2)+1.d0)-1.d0)) i3 = i1 - ishft(i2*i2-i2,-1) k(1) = ceiling(0.5d0*(dsqrt(8.d0*dble(i3)+1.d0)-1.d0)) - j(1) = i2 - ishft(l(1)*l(1)-l(1),-1) - i(1) = i3 - ishft(k(1)*k(1)-k(1),-1) + j(1) = int(i2 - ishft(l(1)*l(1)-l(1),-1),4) + i(1) = int(i3 - ishft(k(1)*k(1)-k(1),-1),4) !ijkl i(2) = i(1) !ilkj diff --git a/src/Integrals_Bielec/mo_bi_integrals.irp.f b/src/Integrals_Bielec/mo_bi_integrals.irp.f index b56f3518..05eb8dff 100644 --- a/src/Integrals_Bielec/mo_bi_integrals.irp.f +++ b/src/Integrals_Bielec/mo_bi_integrals.irp.f @@ -35,6 +35,8 @@ BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ] call map_load_from_disk(trim(ezfio_filename)//'/work/mo_ints',mo_integrals_map) print*, 'MO integrals provided' return + else + PROVIDE ao_bielec_integrals_in_map endif if(no_vvvv_integrals)then @@ -196,7 +198,7 @@ subroutine add_integrals_to_map(mask_ijkl) integer :: size_buffer integer(key_kind),allocatable :: buffer_i(:) real(integral_kind),allocatable :: buffer_value(:) - real :: map_mb + double precision :: map_mb integer :: i1,j1,k1,l1, ii1, kmax, thread_num integer :: i2,i3,i4 @@ -503,7 +505,7 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) integer :: size_buffer integer(key_kind),allocatable :: buffer_i(:) real(integral_kind),allocatable :: buffer_value(:) - real :: map_mb + double precision :: map_mb integer :: i1,j1,k1,l1, ii1, kmax, thread_num integer :: i2,i3,i4 @@ -817,7 +819,7 @@ subroutine add_integrals_to_map_no_exit_34(mask_ijkl) integer :: size_buffer integer(key_kind),allocatable :: buffer_i(:) real(integral_kind),allocatable :: buffer_value(:) - real :: map_mb + double precision :: map_mb integer :: i1,j1,k1,l1, ii1, kmax, thread_num integer :: i2,i3,i4 diff --git a/src/Integrals_Monoelec/.gitignore b/src/Integrals_Monoelec/.gitignore deleted file mode 100644 index 577068de..00000000 --- a/src/Integrals_Monoelec/.gitignore +++ /dev/null @@ -1,20 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Utils -check_orthonormality -ezfio_interface.irp.f -irpf90.make -irpf90_entities -save_ortho_mos -tags \ No newline at end of file diff --git a/src/Integrals_Monoelec/check_orthonormality.irp.f b/src/Integrals_Monoelec/check_orthonormality.irp.f index 749e74f0..44294023 100644 --- a/src/Integrals_Monoelec/check_orthonormality.irp.f +++ b/src/Integrals_Monoelec/check_orthonormality.irp.f @@ -11,10 +11,10 @@ end subroutine do_print implicit none integer :: i,j - real :: off_diag, diag + double precision :: off_diag, diag - off_diag = 0. - diag = 0. + off_diag = 0.d0 + diag = 0.d0 do j=1,mo_tot_num do i=1,mo_tot_num off_diag += abs(mo_overlap(i,j)) diff --git a/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f b/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f index 6f1fd905..22cceab9 100644 --- a/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f +++ b/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f @@ -3,7 +3,7 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral, (ao_num_align,ao_num)] BEGIN_DOC ! Pseudo-potential integrals END_DOC - + if (read_ao_one_integrals) then call read_one_e_integrals('ao_pseudo_integral', ao_pseudo_integral,& size(ao_pseudo_integral,1), size(ao_pseudo_integral,2)) @@ -53,6 +53,7 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu call wall_time(wall_1) call cpu_time(cpu_1) + thread_num = 0 !$OMP PARALLEL & !$OMP DEFAULT (NONE) & @@ -65,6 +66,8 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu !$OMP wall_1) !$ thread_num = omp_get_thread_num() + + wall_0 = wall_1 !$OMP DO SCHEDULE (guided) do j = 1, ao_num @@ -102,7 +105,6 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu pseudo_n_k_transp (1,k), & pseudo_dz_k_transp(1,k), & A_center,power_A,alpha,B_center,power_B,beta,C_center) - enddo ao_pseudo_integral_local(i,j) = ao_pseudo_integral_local(i,j) +& ao_coef_normalized_ordered_transp(l,j)*ao_coef_normalized_ordered_transp(m,i)*c @@ -150,12 +152,6 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu call wall_time(wall_1) call cpu_time(cpu_1) thread_num = 0 -!write(34,*) 'xxxNONLOCxxx' -!write(34,*) ' pseudo_lmax,pseudo_kmax', pseudo_lmax,pseudo_kmax -!write(34,*) ' pseudo_v_kl_transp(1,0,k)', pseudo_v_kl_transp -!write(34,*) ' pseudo_n_kl_transp(1,0,k)', pseudo_n_kl_transp -!write(34,*) ' pseudo_dz_kl_transp(1,0,k)', pseudo_dz_kl_transp -!write(34,*) 'xxxNONLOCxxx' !$OMP PARALLEL & !$OMP DEFAULT (NONE) & @@ -169,8 +165,9 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu !$ thread_num = omp_get_thread_num() + wall_0 = wall_1 !$OMP DO SCHEDULE (guided) - +! do j = 1, ao_num num_A = ao_nucl(j) @@ -207,15 +204,6 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu pseudo_n_kl_transp(1,0,k), & pseudo_dz_kl_transp(1,0,k), & A_center,power_A,alpha,B_center,power_B,beta,C_center) -! write(34,*) i,j,k -! write(34,*) & -! A_center,power_A,alpha,B_center,power_B,beta,C_center, & -! Vpseudo(pseudo_lmax,pseudo_kmax, & -! pseudo_v_kl_transp(1,0,k), & -! pseudo_n_kl_transp(1,0,k), & -! pseudo_dz_kl_transp(1,0,k), & -! A_center,power_A,alpha,B_center,power_B,beta,C_center) -! write(34,*) '' enddo ao_pseudo_integral_non_local(i,j) = ao_pseudo_integral_non_local(i,j) +& ao_coef_normalized_ordered_transp(l,j)*ao_coef_normalized_ordered_transp(m,i)*c @@ -232,12 +220,12 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu endif endif enddo - + !$OMP END DO - + !$OMP END PARALLEL - - + + END_PROVIDER BEGIN_PROVIDER [ double precision, pseudo_v_k_transp, (pseudo_klocmax,nucl_num) ] diff --git a/src/Integrals_Monoelec/pseudopot.f90 b/src/Integrals_Monoelec/pseudopot.f90 index d77b3ca0..a69aa42d 100644 --- a/src/Integrals_Monoelec/pseudopot.f90 +++ b/src/Integrals_Monoelec/pseudopot.f90 @@ -15,14 +15,10 @@ double precision function Vps & implicit none integer n_a(3),n_b(3) double precision g_a,g_b,a(3),b(3),c(3) -integer kmax_max,lmax_max -parameter (kmax_max=2,lmax_max=2) -integer lmax,kmax,n_kl(kmax_max,0:lmax_max) -double precision v_kl(kmax_max,0:lmax_max),dz_kl(kmax_max,0:lmax_max) -integer klocmax_max -parameter (klocmax_max=10) -integer klocmax,n_k(klocmax_max) -double precision v_k(klocmax_max),dz_k(klocmax_max) +integer lmax,kmax,n_kl(kmax,0:lmax) +double precision v_kl(kmax,0:lmax),dz_kl(kmax,0:lmax) +integer klocmax,n_k(klocmax) +double precision v_k(klocmax),dz_k(klocmax) double precision Vloc,Vpseudo Vps=Vloc(klocmax,v_k,n_k,dz_k,a,n_a,g_a,b,n_b,g_b,c) & @@ -36,13 +32,10 @@ double precision function Vps_num & implicit none integer n_a(3),n_b(3) double precision g_a,g_b,a(3),b(3),c(3),rmax -integer kmax_max,lmax_max -parameter (kmax_max=2,lmax_max=2) -integer lmax,kmax,n_kl(kmax_max,0:lmax_max) -double precision v_kl(kmax_max,0:lmax_max),dz_kl(kmax_max,0:lmax_max) -integer klocmax_max;parameter (klocmax_max=10) -integer klocmax,n_k(klocmax_max) -double precision v_k(klocmax_max),dz_k(klocmax_max) +integer lmax,kmax,n_kl(kmax,0:lmax) +double precision v_kl(kmax,0:lmax),dz_kl(kmax,0:lmax) +integer klocmax,n_k(klocmax) +double precision v_k(klocmax),dz_k(klocmax) double precision Vloc_num,Vpseudo_num,v1,v2 integer npts,nptsgrid nptsgrid=50 @@ -54,11 +47,9 @@ end double precision function Vloc_num(npts_over,xmax,klocmax,v_k,n_k,dz_k,a,n_a,g_a,b,n_b,g_b,c) implicit none -integer klocmax_max -parameter (klocmax_max=10) integer klocmax -double precision v_k(klocmax_max),dz_k(klocmax_max) -integer n_k(klocmax_max) +double precision v_k(klocmax),dz_k(klocmax) +integer n_k(klocmax) integer npts_over,ix,iy,iz double precision xmax,dx,x,y,z double precision a(3),b(3),c(3),term,r,orb_phi,g_a,g_b,ac(3),bc(3) @@ -705,12 +696,9 @@ end double precision function Vloc(klocmax,v_k,n_k,dz_k,a,n_a,g_a,b,n_b,g_b,c) implicit none -integer klocmax_max,lmax_max,ntot_max -parameter (klocmax_max=10,lmax_max=2) -parameter (ntot_max=10) integer klocmax -double precision v_k(klocmax_max),dz_k(klocmax_max),crochet,bigA -integer n_k(klocmax_max) +double precision v_k(klocmax),dz_k(klocmax),crochet,bigA +integer n_k(klocmax) double precision a(3),g_a,b(3),g_b,c(3),d(3) integer n_a(3),n_b(3),ntotA,ntotB,ntot,m integer i,l,k,ktot,k1,k2,k3,k1p,k2p,k3p @@ -719,6 +707,7 @@ double precision,allocatable :: array_R_loc(:,:,:) double precision,allocatable :: array_coefs(:,:,:,:,:,:) double precision int_prod_bessel_loc,binom_func,accu,prod,ylm,bigI,arg + fourpi=4.d0*dacos(-1.d0) f=fourpi**1.5d0 ac=dsqrt((a(1)-c(1))**2+(a(2)-c(2))**2+(a(3)-c(3))**2) @@ -755,8 +744,8 @@ double precision int_prod_bessel_loc,binom_func,accu,prod,ylm,bigI,arg dreal=2.d0*d2 - allocate (array_R_loc(-2:ntot_max+klocmax_max,klocmax_max,0:ntot_max)) - allocate (array_coefs(0:ntot_max,0:ntot_max,0:ntot_max,0:ntot_max,0:ntot_max,0:ntot_max)) + allocate (array_R_loc(-2:ntot+klocmax,klocmax,0:ntot)) + allocate (array_coefs(0:ntot,0:ntot,0:ntot,0:ntot,0:ntot,0:ntot)) do ktot=-2,ntotA+ntotB+klocmax do l=0,ntot @@ -2111,9 +2100,7 @@ end ! r : Distance between the Atomic Orbital center and the considered point double precision function ylm_orb(l,m,c,a,n_a,g_a,r) implicit none -integer lmax_max,ntot_max -parameter (lmax_max=2) -parameter (ntot_max=14) +integer lmax_max integer l,m double precision a(3),g_a,c(3) double precision prod,binom_func,accu,bigI,ylm,bessel_mod @@ -2131,7 +2118,6 @@ factor=fourpi*dexp(-arg) areal=2.d0*g_a*ac ntotA=n_a(1)+n_a(2)+n_a(3) -if(ntotA.gt.ntot_max)stop 'increase ntot_max' if(ac.eq.0.d0)then ylm_orb=dsqrt(fourpi)*r**ntotA*dexp(-g_a*r**2)*bigI(0,0,l,m,n_a(1),n_a(2),n_a(3)) diff --git a/src/MOGuess/.gitignore b/src/MOGuess/.gitignore deleted file mode 100644 index a912636d..00000000 --- a/src/MOGuess/.gitignore +++ /dev/null @@ -1,20 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Electrons -Ezfio_files -H_CORE_guess -IRPF90_man -IRPF90_temp -Integrals_Monoelec -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Utils -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/src/MO_Basis/.gitignore b/src/MO_Basis/.gitignore deleted file mode 100644 index 110e93f9..00000000 --- a/src/MO_Basis/.gitignore +++ /dev/null @@ -1,17 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -Makefile -Makefile.depend -Nuclei -Utils -ezfio_interface.irp.f -irpf90.make -irpf90_entities -swap_mos -tags \ No newline at end of file diff --git a/src/MO_Basis/EZFIO.cfg b/src/MO_Basis/EZFIO.cfg index 5aec39e0..368b70a0 100644 --- a/src/MO_Basis/EZFIO.cfg +++ b/src/MO_Basis/EZFIO.cfg @@ -20,7 +20,13 @@ doc: MO occupation numbers interface: ezfio size: (mo_basis.mo_tot_num) +[mo_class] +type: character*(32) +doc: c: core, i: inactive, a: active, v: virtual, d: deleted +interface: ezfio, provider +size: (mo_basis.mo_tot_num) + [ao_md5] type: character*(32) doc: Ao_md5 -interface: ezfio \ No newline at end of file +interface: ezfio diff --git a/src/MO_Basis/ao_ortho_canonical.irp.f b/src/MO_Basis/ao_ortho_canonical.irp.f index 95a771b0..48341129 100644 --- a/src/MO_Basis/ao_ortho_canonical.irp.f +++ b/src/MO_Basis/ao_ortho_canonical.irp.f @@ -42,7 +42,7 @@ 9;; END_TEMPLATE case default - stop 'Error in ao_cart_to_sphe' + stop 'Error in ao_cart_to_sphe : angular momentum too high' end select enddo diff --git a/src/MO_Basis/cholesky_mo.irp.f b/src/MO_Basis/cholesky_mo.irp.f index 97b6abd2..65184c1e 100644 --- a/src/MO_Basis/cholesky_mo.irp.f +++ b/src/MO_Basis/cholesky_mo.irp.f @@ -1,8 +1,20 @@ subroutine cholesky_mo(n,m,P,LDP,C,LDC,tol_in,rank) implicit none BEGIN_DOC -! Cholesky decomposition of AO Density matrix to -! generate MOs +! Cholesky decomposition of AO Density matrix +! +! n : Number of AOs + +! m : Number of MOs +! +! P(LDP,n) : Density matrix in AO basis +! +! C(LDC,m) : MOs +! +! tol_in : tolerance +! +! rank : Nomber of local MOs (output) +! END_DOC integer, intent(in) :: n,m, LDC, LDP double precision, intent(in) :: P(LDP,n) @@ -15,9 +27,6 @@ subroutine cholesky_mo(n,m,P,LDP,C,LDC,tol_in,rank) integer :: ipiv(n) double precision:: tol double precision, allocatable :: W(:,:), work(:) - !DEC$ ATTRIBUTES ALIGN: 32 :: W - !DEC$ ATTRIBUTES ALIGN: 32 :: work - !DEC$ ATTRIBUTES ALIGN: 32 :: ipiv allocate(W(LDC,n),work(2*n)) tol=tol_in @@ -41,40 +50,37 @@ subroutine cholesky_mo(n,m,P,LDP,C,LDC,tol_in,rank) deallocate(W,work) end -BEGIN_PROVIDER [ double precision, mo_density_matrix, (mo_tot_num_align, mo_tot_num) ] +subroutine svd_mo(n,m,P,LDP,C,LDC) implicit none BEGIN_DOC - ! Density matrix in MO basis - END_DOC - integer :: i,j,k - mo_density_matrix = 0.d0 - do k=1,mo_tot_num - if (mo_occ(k) == 0.d0) then - cycle - endif - do j=1,ao_num - do i=1,ao_num - mo_density_matrix(i,j) = mo_density_matrix(i,j) + & - mo_occ(k) * mo_coef(i,k) * mo_coef(j,k) - enddo - enddo - enddo -END_PROVIDER +! Singular value decomposition of the AO Density matrix +! +! n : Number of AOs -BEGIN_PROVIDER [ double precision, mo_density_matrix_virtual, (mo_tot_num_align, mo_tot_num) ] - implicit none - BEGIN_DOC - ! Density matrix in MO basis (virtual MOs) +! m : Number of MOs +! +! P(LDP,n) : Density matrix in AO basis +! +! C(LDC,m) : MOs +! +! tol_in : tolerance +! +! rank : Nomber of local MOs (output) +! END_DOC - integer :: i,j,k - mo_density_matrix_virtual = 0.d0 - do k=1,mo_tot_num - do j=1,ao_num - do i=1,ao_num - mo_density_matrix_virtual(i,j) = mo_density_matrix_virtual(i,j) + & - (2.d0-mo_occ(k)) * mo_coef(i,k) * mo_coef(j,k) - enddo - enddo - enddo -END_PROVIDER + integer, intent(in) :: n,m, LDC, LDP + double precision, intent(in) :: P(LDP,n) + double precision, intent(out) :: C(LDC,m) + + integer :: info + integer :: i,k + integer :: ipiv(n) + double precision:: tol + double precision, allocatable :: W(:,:), work(:) + + allocate(W(LDC,n),work(2*n)) + call svd(P,LDP,C,LDC,W,size(W,1),m,n) + + deallocate(W,work) +end diff --git a/src/MO_Basis/mos.irp.f b/src/MO_Basis/mos.irp.f index 69abf7b3..19835395 100644 --- a/src/MO_Basis/mos.irp.f +++ b/src/MO_Basis/mos.irp.f @@ -258,3 +258,4 @@ subroutine mix_mo_jk(j,k) enddo end + diff --git a/src/MO_Basis/utils.irp.f b/src/MO_Basis/utils.irp.f index 0f338877..750e3420 100644 --- a/src/MO_Basis/utils.irp.f +++ b/src/MO_Basis/utils.irp.f @@ -88,7 +88,7 @@ subroutine mo_as_eigvectors_of_mo_matrix(matrix,n,m,label,sign) enddo endif do i=1,m - write (output_mo_basis,'(I8,X,F16.10)') i,eigvalues(i) + write (output_mo_basis,'(I8,1X,F16.10)') i,eigvalues(i) enddo write (output_mo_basis,'(A)') '======== ================' write (output_mo_basis,'(A)') '' @@ -135,7 +135,7 @@ subroutine mo_as_svd_vectors_of_mo_matrix(matrix,lda,m,n,label) write (output_mo_basis,'(A)') '======== ================' do i=1,m - write (output_mo_basis,'(I8,X,F16.10)') i,D(i) + write (output_mo_basis,'(I8,1X,F16.10)') i,D(i) enddo write (output_mo_basis,'(A)') '======== ================' write (output_mo_basis,'(A)') '' @@ -215,7 +215,7 @@ subroutine mo_as_eigvectors_of_mo_matrix_sort_by_observable(matrix,observable,n, write (output_mo_basis,'(A)') '' write (output_mo_basis,'(A)') '======== ================' do i = 1, m - write (output_mo_basis,'(I8,X,F16.10)') i,eigvalues(i) + write (output_mo_basis,'(I8,1X,F16.10)') i,eigvalues(i) enddo write (output_mo_basis,'(A)') '======== ================' write (output_mo_basis,'(A)') '' diff --git a/src/Nuclei/.gitignore b/src/Nuclei/.gitignore deleted file mode 100644 index f09c71f7..00000000 --- a/src/Nuclei/.gitignore +++ /dev/null @@ -1,14 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Ezfio_files -Utils \ No newline at end of file diff --git a/src/Nuclei/nuclei.irp.f b/src/Nuclei/nuclei.irp.f index a8def602..34fae989 100644 --- a/src/Nuclei/nuclei.irp.f +++ b/src/Nuclei/nuclei.irp.f @@ -37,8 +37,8 @@ BEGIN_PROVIDER [ double precision, nucl_coord, (nucl_num_aligned,3) ] enddo deallocate(buffer) - character*(64), parameter :: f = '(A16, 4(X,F12.6))' - character*(64), parameter :: ft= '(A16, 4(X,A12 ))' + character*(64), parameter :: f = '(A16, 4(1X,F12.6))' + character*(64), parameter :: ft= '(A16, 4(1X,A12 ))' double precision, parameter :: a0= 0.529177249d0 call write_time(output_Nuclei) write(output_Nuclei,'(A)') '' @@ -169,7 +169,7 @@ END_PROVIDER 'Nuclear repulsion energy') END_PROVIDER -BEGIN_PROVIDER [ character*(128), element_name, (36)] +BEGIN_PROVIDER [ character*(128), element_name, (78)] BEGIN_DOC ! Array of the name of element, sorted by nuclear charge (integer) END_DOC @@ -209,4 +209,47 @@ BEGIN_PROVIDER [ character*(128), element_name, (36)] element_name(34) = 'Se' element_name(35) = 'Br' element_name(36) = 'Kr' + element_name(37) = 'Rb' + element_name(38) = 'Sr' + element_name(39) = 'Y' + element_name(40) = 'Zr' + element_name(41) = 'Nb' + element_name(42) = 'Mo' + element_name(43) = 'Tc' + element_name(44) = 'Ru' + element_name(45) = 'Rh' + element_name(46) = 'Pd' + element_name(47) = 'Ag' + element_name(48) = 'Cd' + element_name(49) = 'In' + element_name(50) = 'Sn' + element_name(51) = 'Sb' + element_name(52) = 'Te' + element_name(53) = 'I' + element_name(54) = 'Xe' + element_name(55) = 'Cs' + element_name(56) = 'Ba' + element_name(57) = 'La' + element_name(58) = 'Ce' + element_name(59) = 'Pr' + element_name(60) = 'Nd' + element_name(61) = 'Pm' + element_name(62) = 'Sm' + element_name(63) = 'Eu' + element_name(64) = 'Gd' + element_name(65) = 'Tb' + element_name(66) = 'Dy' + element_name(67) = 'Ho' + element_name(68) = 'Er' + element_name(69) = 'Tm' + element_name(70) = 'Yb' + element_name(71) = 'Lu' + element_name(72) = 'Hf' + element_name(73) = 'Ta' + element_name(74) = 'W' + element_name(75) = 'Re' + element_name(76) = 'Os' + element_name(77) = 'Ir' + element_name(78) = 'Pt' + END_PROVIDER diff --git a/src/Pseudo/.gitignore b/src/Pseudo/.gitignore deleted file mode 100644 index 7305be49..00000000 --- a/src/Pseudo/.gitignore +++ /dev/null @@ -1,15 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Nuclei -Ezfio_files -Utils \ No newline at end of file diff --git a/src/Pseudo/EZFIO.cfg b/src/Pseudo/EZFIO.cfg index 04eea7c6..fc23b678 100644 --- a/src/Pseudo/EZFIO.cfg +++ b/src/Pseudo/EZFIO.cfg @@ -86,16 +86,4 @@ doc: QMC grid interface: ezfio size: (ao_basis.ao_num,-pseudo.pseudo_lmax:pseudo.pseudo_lmax,0:pseudo.pseudo_lmax,nuclei.nucl_num,pseudo.pseudo_grid_size) -[disk_access_pseudo_local_integrals] -type: Disk_access -doc: Read/Write the local ntegrals from/to disk [ Write | Read | None ] -interface: ezfio,provider,ocaml -default: None - -[disk_access_pseudo_no_local_integrals] -type: Disk_access -doc: Read/Write the no-local ntegrals from/to disk [ Write | Read | None ] -interface: ezfio,provider,ocaml -default: None - diff --git a/src/Utils/.gitignore b/src/Utils/.gitignore deleted file mode 100644 index 85ad9d4e..00000000 --- a/src/Utils/.gitignore +++ /dev/null @@ -1,12 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f \ No newline at end of file diff --git a/src/Utils/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index 44a15ddf..9f94bb62 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -26,7 +26,7 @@ subroutine svd(A,LDA,U,LDU,D,Vt,LDVt,m,n) lwork = -1 call dgesvd('A','A', m, n, A_tmp, LDA, & D, U, LDU, Vt, LDVt, work, lwork, info) - lwork = work(1) + lwork = int(work(1)) deallocate(work) allocate(work(lwork)) @@ -149,11 +149,11 @@ subroutine ortho_qr(A,LDA,m,n) allocate (jpvt(n), tau(n), work(1)) LWORK=-1 call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) - LWORK=2*WORK(1) + LWORK=2*int(WORK(1)) deallocate(WORK) allocate(WORK(LWORK)) - call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) - call dorgqr(m, n, n, A, LDA, tau, WORK, LWORK, INFO) + call dgeqrf(m, n, A, LDA, TAU, WORK, LWORK, INFO ) + call dorgqr(m, n, n, A, LDA, tau, WORK, LWORK, INFO) deallocate(WORK,jpvt,tau) end @@ -293,7 +293,7 @@ subroutine get_pseudo_inverse(A,m,n,C,LDA) print *, info, ': SVD failed' stop endif - lwork = work(1) + lwork = int(work(1)) deallocate(work) allocate(work(lwork)) call dgesvd('S','A', m, n, A_tmp, m,D,U,m,Vt,n,work,lwork,info) diff --git a/src/Utils/constants.include.F b/src/Utils/constants.include.F index 991ef80a..4974fd8e 100644 --- a/src/Utils/constants.include.F +++ b/src/Utils/constants.include.F @@ -1,5 +1,6 @@ integer, parameter :: max_dim = 511 integer, parameter :: SIMD_vector = 32 +integer, parameter :: N_int_max = 16 double precision, parameter :: pi = dacos(-1.d0) double precision, parameter :: sqpi = dsqrt(dacos(-1.d0)) diff --git a/src/Utils/map_functions.irp.f b/src/Utils/map_functions.irp.f index 68ba342c..0378c253 100644 --- a/src/Utils/map_functions.irp.f +++ b/src/Utils/map_functions.irp.f @@ -73,10 +73,11 @@ subroutine map_load_from_disk(filename,map) implicit none character*(*), intent(in) :: filename type(map_type), intent(inout) :: map + double precision :: x type(c_ptr) :: c_pointer(3) integer :: fd(3) - integer*8 :: i,k - integer :: n_elements + integer*8 :: i,k,l + integer*4 :: j,n_elements @@ -95,20 +96,34 @@ subroutine map_load_from_disk(filename,map) call mmap(trim(filename)//'_consolidated_value', (/ map % n_elements /), integral_kind, fd(3), .True., c_pointer(3)) call c_f_pointer(c_pointer(3),map % consolidated_value, (/ map % n_elements /)) + l = 0_8 k = 1_8 + x = 0.d0 do i=0_8, map % map_size deallocate(map % map(i) % value) deallocate(map % map(i) % key) map % map(i) % value => map % consolidated_value ( map % consolidated_idx (i+1) :) map % map(i) % key => map % consolidated_key ( map % consolidated_idx (i+1) :) map % map(i) % sorted = .True. - n_elements = map % consolidated_idx (i+2) - k + n_elements = int( map % consolidated_idx (i+2) - k, 4) k = map % consolidated_idx (i+2) map % map(i) % map_size = n_elements map % map(i) % n_elements = n_elements + ! Load memory from disk + do j=1,n_elements + x = x + map % map(i) % value(j) + l = iand(l,int(map % map(i) % key(j),8)) + if (map % map(i) % value(j) > 1.e30) then + stop 'Error in integrals file' + endif + if (map % map(i) % key(j) < 0) then + stop 'Error in integrals file' + endif + enddo enddo + map % sorted = x>0 .or. l == 0_8 map % n_elements = k-1 - map % sorted = .True. + map % sorted = map % sorted .or. .True. map % consolidated = .True. end diff --git a/src/Utils/map_module.f90 b/src/Utils/map_module.f90 index 80260233..ac16f97e 100644 --- a/src/Utils/map_module.f90 +++ b/src/Utils/map_module.f90 @@ -53,17 +53,17 @@ module map_module end module map_module -real function map_mb(map) +double precision function map_mb(map) use map_module use omp_lib implicit none type (map_type), intent(in) :: map integer(map_size_kind) :: i - map_mb = 8+map_size_kind+map_size_kind+omp_lock_kind+4 + map_mb = dble(8+map_size_kind+map_size_kind+omp_lock_kind+4) do i=0,map%map_size - map_mb = map_mb + map%map(i)%map_size*(cache_key_kind+integral_kind) +& - 8+8+4+cache_map_size_kind+cache_map_size_kind+omp_lock_kind + map_mb = map_mb + dble(map%map(i)%map_size*(cache_key_kind+integral_kind) +& + 8+8+4+cache_map_size_kind+cache_map_size_kind+omp_lock_kind) enddo map_mb = map_mb / (1024.d0*1024.d0) end @@ -406,8 +406,8 @@ subroutine map_update(map, key, value, sze, thr) call cache_map_reallocate(local_map, local_map%n_elements + local_map%n_elements) call cache_map_shrink(local_map,thr) endif - cache_key = iand(key(i),map_mask) - local_map%n_elements = local_map%n_elements + 1_8 + cache_key = int(iand(key(i),map_mask),2) + local_map%n_elements = local_map%n_elements + 1 local_map%value(local_map%n_elements) = value(i) local_map%key(local_map%n_elements) = cache_key local_map%sorted = .False. @@ -464,7 +464,7 @@ subroutine map_append(map, key, value, sze) if (n_elements == map%map(idx_cache)%map_size) then call cache_map_reallocate(map%map(idx_cache), n_elements+ ishft(n_elements,-1)) endif - cache_key = iand(key(i),map_mask) + cache_key = int(iand(key(i),map_mask),2) map%map(idx_cache)%value(n_elements) = value(i) map%map(idx_cache)%key(n_elements) = cache_key map%map(idx_cache)%n_elements = n_elements @@ -615,7 +615,7 @@ subroutine search_key_big_interval(key,X,sze,idx,ibegin_in,iend_in) idx = -1 return endif - cache_key = iand(key,map_mask) + cache_key = int(iand(key,map_mask),2) ibegin = min(ibegin_in,sze) iend = min(iend_in,sze) if ((cache_key > X(ibegin)) .and. (cache_key < X(iend))) then @@ -723,7 +723,7 @@ subroutine search_key_value_big_interval(key,value,X,Y,sze,idx,ibegin_in,iend_in value = 0.d0 return endif - cache_key = iand(key,map_mask) + cache_key = int(iand(key,map_mask),2) ibegin = min(ibegin_in,sze) iend = min(iend_in,sze) if ((cache_key > X(ibegin)) .and. (cache_key < X(iend))) then diff --git a/src/Utils/sort.irp.f b/src/Utils/sort.irp.f index dd7fbc33..bb93d44f 100644 --- a/src/Utils/sort.irp.f +++ b/src/Utils/sort.irp.f @@ -12,17 +12,15 @@ BEGIN_TEMPLATE $type :: xtmp integer :: i, i0, j, jmax - do i=1,isize + do i=2,isize xtmp = x(i) i0 = iorder(i) - j = i-1 - do j=i-1,1,-1 - if ( x(j) > xtmp ) then - x(j+1) = x(j) - iorder(j+1) = iorder(j) - else - exit - endif + j=i-1 + do while (j>0) + if ((x(j) <= xtmp)) exit + x(j+1) = x(j) + iorder(j+1) = iorder(j) + j=j-1 enddo x(j+1) = xtmp iorder(j+1) = i0 @@ -158,6 +156,38 @@ BEGIN_TEMPLATE end subroutine heap_$Xsort_big + subroutine sorted_$Xnumber(x,isize,n) + implicit none + BEGIN_DOC +! Returns the number of sorted elements + END_DOC + integer, intent(in) :: isize + $type, intent(in) :: x(isize) + integer, intent(out) :: n + integer :: i + n=1 + + if (isize < 2) then + return + endif + + do i=2,isize + if (x(i-1) <= x(i)) then + n=n+1 + endif + enddo + + end + +SUBST [ X, type ] + ; real ;; + d ; double precision ;; + i ; integer ;; + i8 ; integer*8 ;; + i2 ; integer*2 ;; +END_TEMPLATE + +BEGIN_TEMPLATE subroutine $Xsort(x,iorder,isize) implicit none BEGIN_DOC @@ -168,16 +198,42 @@ BEGIN_TEMPLATE integer,intent(in) :: isize $type,intent(inout) :: x(isize) integer,intent(inout) :: iorder(isize) - if (isize < 32) then + integer :: n + if (isize < 2) then + return + endif + call sorted_$Xnumber(x,isize,n) + if (isize == n) then + return + endif + if ( isize < 32+n) then call insertion_$Xsort(x,iorder,isize) else call heap_$Xsort(x,iorder,isize) endif end subroutine $Xsort +SUBST [ X, type, Y ] + ; real ; i ;; + d ; double precision ; i8 ;; +END_TEMPLATE + +BEGIN_TEMPLATE + subroutine $Xsort(x,iorder,isize) + implicit none + BEGIN_DOC + ! Sort array x(isize). + ! 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) + integer :: n + call $Xradix_sort(x,iorder,isize,-1) + end subroutine $Xsort + SUBST [ X, type ] - ; real ;; - d ; double precision ;; i ; integer ;; i8 ; integer*8 ;; i2 ; integer*2 ;; @@ -232,17 +288,15 @@ BEGIN_TEMPLATE $type :: xtmp integer*8 :: i, i0, j, jmax - do i=1_8,isize + do i=2_8,isize xtmp = x(i) i0 = iorder(i) j = i-1_8 - do j=i-1_8,1_8,-1_8 - if ( x(j) > xtmp ) then - x(j+1_8) = x(j) - iorder(j+1_8) = iorder(j) - else - exit - endif + do while (j>0_8) + if (x(j)<=xtmp) exit + x(j+1_8) = x(j) + iorder(j+1_8) = iorder(j) + j = j-1_8 enddo x(j+1_8) = xtmp iorder(j+1_8) = i0 @@ -292,63 +346,107 @@ BEGIN_TEMPLATE ! contains the new order of the elements. ! iradix should be -1 in input. END_DOC - $int_type, intent(in) :: isize - $int_type, intent(inout) :: iorder(isize) - $type, intent(inout) :: x(isize) + integer*$int_type, intent(in) :: isize + integer*$int_type, intent(inout) :: iorder(isize) + integer*$type, intent(inout) :: x(isize) integer, intent(in) :: iradix integer :: iradix_new - $type, allocatable :: x2(:), x1(:) - $type :: i4 - $int_type, allocatable :: iorder1(:),iorder2(:) - $int_type :: i0, i1, i2, i3, i - integer, parameter :: integer_size=$octets - $type, parameter :: zero=$zero - $type :: mask - integer :: nthreads, omp_get_num_threads + integer*$type, allocatable :: x2(:), x1(:) + integer*$type :: i4 ! data type + integer*$int_type, allocatable :: iorder1(:),iorder2(:) + integer*$int_type :: i0, i1, i2, i3, i ! index type + integer*$type :: mask + integer :: err !DIR$ ATTRIBUTES ALIGN : 128 :: iorder1,iorder2, x2, x1 - if (iradix == -1) then - - ! Find most significant bit - - i0 = 0_8 - i4 = -1_8 - - do i=1,isize - i4 = max(i4,x(i)) - enddo - i3 = i4 ! Type conversion - - iradix_new = integer_size-1-leadz(i3) - mask = ibset(zero,iradix_new) - nthreads = 1 - ! nthreads = 1+ishft(omp_get_num_threads(),-1) - - integer :: err - allocate(x1(isize/nthreads+1),iorder1(isize/nthreads+1),x2(isize/nthreads+1),iorder2(isize/nthreads+1),stat=err) + if (iradix == -1) then ! Sort Positive and negative + + allocate(x1(isize),iorder1(isize), x2(isize),iorder2(isize),stat=err) if (err /= 0) then print *, irp_here, ': Unable to allocate arrays' stop endif - i1=1_8 - i2=1_8 - - do i=1,isize - if (iand(mask,x(i)) == zero) then + i1=1_$int_type + i2=1_$int_type + do i=1_$int_type,isize + if (x(i) < 0_$type) then iorder1(i1) = iorder(i) - x1(i1) = x(i) - i1 = i1+1_8 + x1(i1) = -x(i) + i1 = i1+1_$int_type else iorder2(i2) = iorder(i) x2(i2) = x(i) - i2 = i2+1_8 + i2 = i2+1_$int_type endif enddo - i1=i1-1_8 - i2=i2-1_8 + i1=i1-1_$int_type + i2=i2-1_$int_type + + do i=1_$int_type,i2 + iorder(i1+i) = iorder2(i) + x(i1+i) = x2(i) + enddo + deallocate(x2,iorder2,stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to deallocate arrays x2, iorder2' + stop + endif - do i=1,i1 + + if (i1 > 1_$int_type) then + call $Xradix_sort$big(x1,iorder1,i1,-2) + do i=1_$int_type,i1 + x(i) = -x1(1_$int_type+i1-i) + iorder(i) = iorder1(1_$int_type+i1-i) + enddo + endif + deallocate(x1,iorder1,stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to deallocate arrays x1, iorder1' + stop + endif + + if (i2>1_$int_type) then + call $Xradix_sort$big(x(i1+1_$int_type),iorder(i1+1_$int_type),i2,-2) + endif + + return + + else if (iradix == -2) then ! Positive + + ! Find most significant bit + + i0 = 0_$int_type + i4 = maxval(x) + + iradix_new = max($integer_size-1-leadz(i4),1) + mask = ibset(0_$type,iradix_new) + + allocate(x1(isize),iorder1(isize), x2(isize),iorder2(isize),stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to allocate arrays' + stop + endif + + i1=1_$int_type + i2=1_$int_type + + do i=1_$int_type,isize + if (iand(mask,x(i)) == 0_$type) then + iorder1(i1) = iorder(i) + x1(i1) = x(i) + i1 = i1+1_$int_type + else + iorder2(i2) = iorder(i) + x2(i2) = x(i) + i2 = i2+1_$int_type + endif + enddo + i1=i1-1_$int_type + i2=i2-1_$int_type + + do i=1_$int_type,i1 iorder(i0+i) = iorder1(i) x(i0+i) = x1(i) enddo @@ -361,7 +459,7 @@ BEGIN_TEMPLATE endif - do i=1,i2 + do i=1_$int_type,i2 iorder(i0+i) = iorder2(i) x(i0+i) = x2(i) enddo @@ -373,12 +471,12 @@ BEGIN_TEMPLATE endif - if (i3>1) then + if (i3>1_$int_type) then call $Xradix_sort$big(x,iorder,i3,iradix_new-1) endif - if (isize-i3>1) then - call $Xradix_sort$big(x(i3+1),iorder(i3+1),isize-i3,iradix_new-1) + if (isize-i3>1_$int_type) then + call $Xradix_sort$big(x(i3+1_$int_type),iorder(i3+1_$int_type),isize-i3,iradix_new-1) endif return @@ -399,25 +497,25 @@ BEGIN_TEMPLATE endif - mask = ibset(zero,iradix) - i0=1 - i1=1 + mask = ibset(0_$type,iradix) + i0=1_$int_type + i1=1_$int_type - do i=1,isize - if (iand(mask,x(i)) == zero) then + do i=1_$int_type,isize + if (iand(mask,x(i)) == 0_$type) then iorder(i0) = iorder(i) x(i0) = x(i) - i0 = i0+1 + i0 = i0+1_$int_type else iorder2(i1) = iorder(i) x2(i1) = x(i) - i1 = i1+1 + i1 = i1+1_$int_type endif enddo - i0=i0-1 - i1=i1-1 + i0=i0-1_$int_type + i1=i1-1_$int_type - do i=1,i1 + do i=1_$int_type,i1 iorder(i0+i) = iorder2(i) x(i0+i) = x2(i) enddo @@ -434,8 +532,8 @@ BEGIN_TEMPLATE endif - if (i1>1) then - call $Xradix_sort$big(x(i0+1),iorder(i0+1),i1,iradix-1) + if (i1>1_$int_type) then + call $Xradix_sort$big(x(i0+1_$int_type),iorder(i0+1_$int_type),i1,iradix-1) endif if (i0>1) then call $Xradix_sort$big(x,iorder,i0,iradix-1) @@ -443,12 +541,12 @@ BEGIN_TEMPLATE end -SUBST [ X, type, octets, is_big, big, int_type, zero ] - i ; integer ; 32 ; .False. ; ; integer ; 0;; - i8 ; integer*8 ; 32 ; .False. ; ; integer ; 0_8;; - i2 ; integer*2 ; 32 ; .False. ; ; integer ; 0;; - i ; integer ; 64 ; .True. ; _big ; integer*8 ; 0 ;; - i8 ; integer*8 ; 64 ; .True. ; _big ; integer*8 ; 0_8 ;; +SUBST [ X, type, integer_size, is_big, big, int_type ] + i ; 4 ; 32 ; .False. ; ; 4 ;; + i8 ; 8 ; 64 ; .False. ; ; 4 ;; + i2 ; 2 ; 16 ; .False. ; ; 4 ;; + i ; 4 ; 32 ; .True. ; _big ; 8 ;; + i8 ; 8 ; 64 ; .True. ; _big ; 8 ;; END_TEMPLATE diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f index 3177d3e3..e61cf92a 100644 --- a/src/ZMQ/utils.irp.f +++ b/src/ZMQ/utils.irp.f @@ -1,11 +1,8 @@ use f77_zmq use omp_lib -integer, pointer :: thread_id -integer(omp_lock_kind) :: zmq_lock - - -BEGIN_PROVIDER [ integer(ZMQ_PTR), zmq_context ] + BEGIN_PROVIDER [ integer(ZMQ_PTR), zmq_context ] +&BEGIN_PROVIDER [ integer(omp_lock_kind), zmq_lock ] use f77_zmq implicit none BEGIN_DOC @@ -94,7 +91,7 @@ subroutine switch_qp_run_to_master print *, 'This run should be started with the qp_run command' stop -1 endif - qp_run_address = trim(buffer) + qp_run_address = adjustl(buffer) print *, 'Switched to qp_run master : ', trim(qp_run_address) integer :: i @@ -235,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' @@ -312,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' @@ -407,7 +404,9 @@ subroutine end_zmq_sub_socket(zmq_socket_sub) integer(ZMQ_PTR), intent(in) :: zmq_socket_sub integer :: rc + call omp_set_lock(zmq_lock) rc = f77_zmq_close(zmq_socket_sub) + call omp_unset_lock(zmq_lock) if (rc /= 0) then print *, 'f77_zmq_close(zmq_socket_sub)' stop 'error' @@ -426,7 +425,9 @@ subroutine end_zmq_pair_socket(zmq_socket_pair) integer :: rc character*(8), external :: zmq_port + call omp_set_lock(zmq_lock) rc = f77_zmq_close(zmq_socket_pair) + call omp_unset_lock(zmq_lock) if (rc /= 0) then print *, 'f77_zmq_close(zmq_socket_pair)' stop 'error' @@ -444,7 +445,14 @@ 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 + + call omp_set_lock(zmq_lock) rc = f77_zmq_close(zmq_socket_pull) + call omp_unset_lock(zmq_lock) if (rc /= 0) then print *, 'f77_zmq_close(zmq_socket_pull)' stop 'error' @@ -469,7 +477,9 @@ subroutine end_zmq_push_socket(zmq_socket_push,thread) stop 'Unable to set ZMQ_LINGER on push socket' endif + call omp_set_lock(zmq_lock) rc = f77_zmq_close(zmq_socket_push) + call omp_unset_lock(zmq_lock) if (rc /= 0) then print *, 'f77_zmq_close(zmq_socket_push)' stop 'error' @@ -500,10 +510,17 @@ subroutine new_parallel_job(zmq_to_qp_run_socket,name_in) integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR), intent(out) :: zmq_to_qp_run_socket + call omp_set_lock(zmq_lock) zmq_context = f77_zmq_ctx_new () + call omp_unset_lock(zmq_lock) if (zmq_context == 0_ZMQ_PTR) then stop 'ZMQ_PTR is null' endif +! rc = f77_zmq_ctx_set(zmq_context, ZMQ_IO_THREADS, nproc) +! if (rc /= 0) then +! print *, 'Unable to set the number of ZMQ IO threads to', nproc +! endif + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() name = name_in sze = len(trim(name)) @@ -584,7 +601,10 @@ subroutine end_parallel_job(zmq_to_qp_run_socket,name_in) zmq_state = 'No_state' call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call omp_set_lock(zmq_lock) rc = f77_zmq_ctx_term(zmq_context) + zmq_context = 0_ZMQ_PTR + call omp_unset_lock(zmq_lock) if (rc /= 0) then print *, 'Unable to terminate ZMQ context' stop 'error' @@ -684,10 +704,43 @@ subroutine add_task_to_taskserver(zmq_to_qp_run_socket,task) character*(*), intent(in) :: task integer :: rc, sze - character*(512) :: message + character(len=:), allocatable :: message + + message='add_task '//trim(zmq_state)//' '//trim(task) + sze = len(message) + rc = f77_zmq_send(zmq_to_qp_run_socket, message, sze, 0) + + if (rc /= sze) then + print *, rc, sze + 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, sze-1, 0) + if (message(1:rc) /= 'ok') then + print *, trim(task) + print *, 'Unable to add the next task' + stop -1 + endif + +end + +subroutine add_task_to_taskserver_send(zmq_to_qp_run_socket,task) + use f77_zmq + implicit none + BEGIN_DOC + ! Get a task from the task server + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + character*(*), intent(in) :: task + + integer :: rc, sze + character(len=:), allocatable :: message + + sze = len(trim(task))+12+len(trim(zmq_state)) + message = repeat(' ',sze) write(message,*) 'add_task '//trim(zmq_state)//' '//trim(task) - sze = len(trim(message)) rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0) if (rc /= sze) then print *, rc, sze @@ -695,10 +748,20 @@ subroutine add_task_to_taskserver(zmq_to_qp_run_socket,task) stop 'error' endif +end + +subroutine add_task_to_taskserver_recv(zmq_to_qp_run_socket) + use f77_zmq + implicit none + BEGIN_DOC + ! Get a task from the task server + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + + integer :: rc, sze + character*(512) :: message rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0) - message = trim(message(1:rc)) - if (trim(message) /= 'ok') then - print *, trim(task) + if (message(1:rc) /= 'ok') then print *, 'Unable to add the next task' stop -1 endif @@ -726,8 +789,7 @@ subroutine task_done_to_taskserver(zmq_to_qp_run_socket, worker_id, task_id) endif rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0) - message = trim(message(1:rc)) - if (trim(message) /= 'ok') then + if (trim(message(1:rc)) /= 'ok') then print *, 'Unable to send task_done message' stop -1 endif @@ -752,17 +814,17 @@ subroutine get_task_from_taskserver(zmq_to_qp_run_socket,worker_id,task_id,task) write(message,*) 'get_task '//trim(zmq_state), worker_id sze = len(trim(message)) - rc = f77_zmq_send(zmq_to_qp_run_socket, trim(message), sze, 0) + rc = f77_zmq_send(zmq_to_qp_run_socket, 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 + message = repeat(' ',512) rc = f77_zmq_recv(zmq_to_qp_run_socket, message, 510, 0) - message = trim(message(1:rc)) - read(message,*) reply + read(message(1:rc),*) reply if (trim(reply) == 'get_task_reply') then - read(message,*) reply, task_id + read(message(1:rc),*) reply, task_id rc = 15 do while (message(rc:rc) == ' ') rc += 1 diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index 2a8fabc2..67c35235 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -13,14 +13,14 @@ source $QP_ROOT/tests/bats/common.bats.sh qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" qp_run cassd_zmq $INPUT energy="$(ezfio get cas_sd_zmq energy_pt2)" - eq $energy -76.231084536315 5.E-5 + eq $energy -76.231248286858 5.E-5 - ezfio set determinants n_det_max 2048 + ezfio set determinants n_det_max 1024 ezfio set determinants read_wf True ezfio set perturbation do_pt2_end True qp_run cassd_zmq $INPUT ezfio set determinants read_wf False energy="$(ezfio get cas_sd_zmq energy)" - eq $energy -76.2300887947446 2.E-5 + eq $energy -76.2225678834779 2.E-5 } diff --git a/tests/bats/fci.bats b/tests/bats/fci.bats index 79ff91ab..6cded581 100644 --- a/tests/bats/fci.bats +++ b/tests/bats/fci.bats @@ -42,11 +42,13 @@ function run_FCI_ZMQ() { qp_set_mo_class h2o.ezfio -core "[1]" -act "[2-12]" -del "[13-24]" } @test "FCI H2O cc-pVDZ" { - run_FCI h2o.ezfio 2000 -0.761255633582109E+02 -0.761258377850042E+02 + run_FCI h2o.ezfio 2000 -76.1253758241716 -76.1258130146102 } + + @test "FCI-ZMQ H2O cc-pVDZ" { - run_FCI_ZMQ h2o.ezfio 2000 -0.761255633582109E+02 -0.761258377850042E+02 + run_FCI_ZMQ h2o.ezfio 2000 -76.1250552686394 -76.1258817228809 } diff --git a/tests/bats/mrcepa0.bats b/tests/bats/mrcepa0.bats index dc9e0bb4..9a62885e 100644 --- a/tests/bats/mrcepa0.bats +++ b/tests/bats/mrcepa0.bats @@ -16,7 +16,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.23752746236 1.e-4 + eq $energy -76.2382106224545 1.e-4 } @test "MRCC H2O cc-pVDZ" { @@ -32,7 +32,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.237469267705 2.e-4 + eq $energy -76.2381754078899 1.e-4 } @test "MRSC2 H2O cc-pVDZ" { @@ -48,7 +48,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.2347764009137 2.e-4 + eq $energy -76.235786994991 2.e-4 } @test "MRCEPA0 H2O cc-pVDZ" { @@ -64,6 +64,6 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.2406942855164 2.e-4 + eq $energy -76.2411829210128 2.e-4 } diff --git a/tests/input/h2o.xyz b/tests/input/h2o.xyz index 99268e5d..e8cd039b 100644 --- a/tests/input/h2o.xyz +++ b/tests/input/h2o.xyz @@ -1,6 +1,6 @@ 3 XYZ file: coordinates in Angstrom -O 0.0000000000 -0.3880000000 0.0000000000 H 0.7510000000 0.1940000000 0.0000000000 +O 0.0000000000 -0.3880000000 0.0000000000 H -0.7510000000 0.1940000000 0.0000000000