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

Merge pull request #188 from LCPQ/revert-186-master

Browse Source 
Revert "merge with main branch"
This commit is contained in:
Anthony Scemama 2017-04-20 08:58:30 +02:00 committed by GitHub
commit 040c1b70fd
232 changed files with 4599 additions and 23391 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
README.md
View File

@ -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 $QP_ROOT/ocaml
make -C ocaml
### 5) Testing if all is ok
cd tests ; ./run_tests.sh
cd tests ; bats bats/qp.bats
@ -137,6 +137,10 @@ interface: ezfio
#FAQ
### Opam error: cryptokit
You need to install `gmp-dev`.
### Error: ezfio_* is already defined.
#### Why ?
@ -162,5 +166,5 @@ It's caused when we call the DGEMM routine of LAPACK.
##### Fix
Set `ulimit -s unlimited`, before runing `qp_run`. It seems to fix the problem.
Set `ulimit -s unlimited`, before runing `qp_run`. It seem to fix the problem.

4
config/gfortran.cfg
View File

@ -35,14 +35,14 @@ OPENMP : 1 ; Append OpenMP flags
# -ffast-math and the Fortran-specific
# -fno-protect-parens and -fstack-arrays.
[OPT]
FCFLAGS :
FCFLAGS : -Ofast
# Profiling flags
#################
#
[PROFILE]
FC : -p -g
FCFLAGS :
FCFLAGS : -Ofast
# Debugging flags
#################

2
config/gfortran_avx.cfg
View File

@ -35,7 +35,7 @@ OPENMP : 1 ; Append OpenMP flags
# -ffast-math and the Fortran-specific
# -fno-protect-parens and -fstack-arrays.
[OPT]
FCFLAGS : -Ofast -march=native
FCFLAGS : -Ofast
# Profiling flags
#################

2
config/gfortran_debug.cfg
View File

@ -51,7 +51,7 @@ FCFLAGS : -Ofast
# -g : Extra debugging information
#
[DEBUG]
FCFLAGS : -g -msse4.2 -fcheck=all -Waliasing -Wampersand -Wconversion -Wsurprising -Wintrinsics-std -Wno-tabs -Wintrinsic-shadow -Wline-truncation -Wreal-q-constant
FCFLAGS : -g -msse4.2
# OpenMP flags
#################

2
config/ifort.cfg
View File

@ -58,6 +58,6 @@ FCFLAGS : -xSSE2 -C -fpe0
#################
#
[OPENMP]
FC : -openmp
FC : -qopenmp
IRPF90_FLAGS : --openmp

2
configure vendored
View File

@ -102,7 +102,7 @@ curl = Info(
default_path=join(QP_ROOT_BIN, "curl"))
zlib = Info(
url='http://www.zlib.net/fossils/zlib-1.2.10.tar.gz',
url='http://www.zlib.net/zlib-1.2.11.tar.gz',
description=' zlib',
default_path=join(QP_ROOT_LIB, "libz.a"))

14
ocaml/Basis.ml
View File

@ -36,11 +36,9 @@ let read_element in_channel at_number element =
let to_string_general ~fmt ~atom_sep ?ele_array b =
let to_string_general ~fmt ~atom_sep b =
let new_nucleus n =
match ele_array with
| None -> Printf.sprintf "Atom %d" n
| Some x -> Printf.sprintf "%s" (Element.to_string x.(n-1))
Printf.sprintf "Atom %d" n
in
let rec do_work accu current_nucleus = function
| [] -> List.rev accu
@ -58,12 +56,12 @@ let to_string_general ~fmt ~atom_sep ?ele_array b =
do_work [new_nucleus 1] 1 b
|> String.concat ~sep:"\n"
let to_string_gamess ?ele_array =
to_string_general ?ele_array ~fmt:Gto.Gamess ~atom_sep:""
let to_string_gamess =
to_string_general ~fmt:Gto.Gamess ~atom_sep:""
let to_string_gaussian ?ele_array b =
let to_string_gaussian b =
String.concat ~sep:"\n"
[ to_string_general ?ele_array ~fmt:Gto.Gaussian ~atom_sep:"****" b ; "****" ]
[ to_string_general ~fmt:Gto.Gaussian ~atom_sep:"****" b ; "****" ]
let to_string ?(fmt=Gto.Gamess) =
match fmt with

2
ocaml/Basis.mli
View File

@ -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 -> ?ele_array:Element.t array -> (Gto.t * Nucl_number.t) list -> string
val to_string : ?fmt:Gto.fmt -> (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

86
ocaml/Input_determinants_by_hand.ml
View File

@ -7,7 +7,6 @@ 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;
@ -19,14 +18,11 @@ 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;
@ -133,12 +129,12 @@ end = struct
|> Array.map ~f:Det_coef.of_float
;;
let write_psi_coef ~n_det ~n_states c =
let write_psi_coef ~n_det 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 =
States_number.to_int n_states
read_n_states () |> States_number.to_int
in
Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| n_det ; n_states |] ~data:c
|> Ezfio.set_determinants_psi_coef
@ -204,7 +200,6 @@ 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"
@ -227,14 +222,12 @@ 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 ~n_states:n_states psi_coef ;
write_psi_coef ~n_det:n_det psi_coef ;
write_psi_det ~n_int:n_int ~n_det:n_det psi_det;
;;
@ -305,7 +298,6 @@ Determinants ::
n_int = %s
bit_kind = %s
n_det = %s
n_states = %s
expected_s2 = %s
psi_coef = %s
psi_det = %s
@ -313,7 +305,6 @@ 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:", ")
@ -442,83 +433,14 @@ 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 ; n_states ; psi_coef ; psi_det]
String.concat [ header ; bitkind ; n_int ; 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

1
ocaml/Makefile
View File

@ -13,7 +13,6 @@ 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))

161
ocaml/Message.ml
View File

@ -110,7 +110,7 @@ module Disconnect_msg : sig
{ client_id: Id.Client.t ;
state: State.t ;
}
val create : state:string -> client_id:int -> t
val create : state:string -> client_id:string -> 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_int client_id ; state = State.of_string state }
{ client_id = Id.Client.of_string 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;
tasks: string list;
task: string;
}
val create : state:string -> tasks:string list -> t
val create : state:string -> task:string -> t
val to_string : t -> string
end = struct
type t =
{ state: State.t;
tasks: string list;
task: string;
}
let create ~state ~tasks = { state = State.of_string state ; tasks }
let create ~state ~task = { state = State.of_string state ; task }
let to_string x =
Printf.sprintf "add_task %s %s" (State.to_string x.state) (String.concat ~sep:"|" x.tasks)
Printf.sprintf "add_task %s %s" (State.to_string x.state) x.task
end
@ -182,44 +182,44 @@ end
module DelTask_msg : sig
type t =
{ state: State.t;
task_ids: Id.Task.t list
task_id: Id.Task.t
}
val create : state:string -> task_ids:int list -> t
val create : state:string -> task_id:string -> t
val to_string : t -> string
end = struct
type t =
{ state: State.t;
task_ids: Id.Task.t list
task_id: Id.Task.t
}
let create ~state ~task_ids =
let create ~state ~task_id =
{ state = State.of_string state ;
task_ids = List.map ~f:Id.Task.of_int task_ids
task_id = Id.Task.of_string task_id
}
let to_string x =
Printf.sprintf "del_task %s %s"
Printf.sprintf "del_task %s %d"
(State.to_string x.state)
(String.concat ~sep:"|" @@ List.map ~f:Id.Task.to_string x.task_ids)
(Id.Task.to_int x.task_id)
end
(** DelTaskReply : Reply to the DelTask message *)
module DelTaskReply_msg : sig
type t
val create : task_ids:Id.Task.t list -> more:bool -> t
val create : task_id:Id.Task.t -> more:bool -> t
val to_string : t -> string
end = struct
type t = {
task_ids : Id.Task.t list;
task_id : Id.Task.t ;
more : bool;
}
let create ~task_ids ~more = { task_ids ; more }
let create ~task_id ~more = { task_id ; more }
let to_string x =
let more =
if x.more then "more"
else "done"
in
Printf.sprintf "del_task_reply %s %s"
more (String.concat ~sep:"|" @@ List.map ~f:Id.Task.to_string x.task_ids)
Printf.sprintf "del_task_reply %s %d"
more (Id.Task.to_int x.task_id)
end
@ -230,7 +230,7 @@ module GetTask_msg : sig
{ client_id: Id.Client.t ;
state: State.t ;
}
val create : state:string -> client_id:int -> t
val create : state:string -> client_id:string -> 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_int client_id ; state = State.of_string state }
{ client_id = Id.Client.of_string 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:int -> t
val create : client_id:string -> t
val to_string : t -> string
end = struct
type t =
{ client_id: Id.Client.t ;
}
let create ~client_id =
{ client_id = Id.Client.of_int client_id }
{ client_id = Id.Client.of_string 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:int ->
n_state:int ->
n_det:int ->
psi_det_size:int ->
client_id:string ->
n_state:string ->
n_det:string ->
psi_det_size:string ->
psi_det:string option ->
psi_coef:string option ->
n_det_generators: int option ->
n_det_selectors:int option ->
n_det_generators: string option ->
n_det_selectors:string option ->
energy:string option -> t
val to_string_list : t -> string list
val to_string : t -> string
@ -388,17 +388,20 @@ 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 =
Strictly_positive_int.of_int n_state,
Strictly_positive_int.of_int n_det,
Strictly_positive_int.of_int 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
in
assert (Strictly_positive_int.to_int psi_det_size >=
Strictly_positive_int.to_int n_det);
let n_det_generators, n_det_selectors =
match n_det_generators, n_det_selectors with
| Some x, Some y ->
Some (Strictly_positive_int.of_int x),
Some (Strictly_positive_int.of_int y)
Some (Strictly_positive_int.of_int @@ Int.of_string x),
Some (Strictly_positive_int.of_int @@ Int.of_string y)
| _ -> None, None
in
let psi =
@ -408,7 +411,7 @@ end = struct
~psi_coef ~n_det_generators ~n_det_selectors ~energy)
| _ -> None
in
{ client_id = Id.Client.of_int client_id ;
{ client_id = Id.Client.of_string client_id ;
n_state ; n_det ; psi_det_size ; n_det_generators ;
n_det_selectors ; psi }
@ -460,48 +463,48 @@ module TaskDone_msg : sig
type t =
{ client_id: Id.Client.t ;
state: State.t ;
task_ids: Id.Task.t list ;
task_id: Id.Task.t ;
}
val create : state:string -> client_id:int -> task_ids:int list -> t
val create : state:string -> client_id:string -> task_id:string -> t
val to_string : t -> string
end = struct
type t =
{ client_id: Id.Client.t ;
state: State.t ;
task_ids: Id.Task.t list;
task_id: Id.Task.t;
}
let create ~state ~client_id ~task_ids =
{ client_id = Id.Client.of_int client_id ;
let create ~state ~client_id ~task_id =
{ client_id = Id.Client.of_string client_id ;
state = State.of_string state ;
task_ids = List.map ~f:Id.Task.of_int task_ids;
task_id = Id.Task.of_string task_id;
}
let to_string x =
Printf.sprintf "task_done %s %d %s"
Printf.sprintf "task_done %s %d %d"
(State.to_string x.state)
(Id.Client.to_int x.client_id)
(String.concat ~sep:"|" @@ List.map ~f:Id.Task.to_string x.task_ids)
(Id.Task.to_int x.task_id)
end
(** Terminate *)
module Terminate_msg : sig
type t
val create : t
val create : unit -> 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 : t
val create : unit -> t
val to_string : t -> string
end = struct
type t = Ok
let create = Ok
let create () = Ok
let to_string x = "ok"
end
@ -548,45 +551,45 @@ type t =
let of_string s =
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 } ->
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)
| TaskDone_ { state ; task_ids ; client_id } ->
TaskDone (TaskDone_msg.create ~state ~client_id ~task_ids)
| Disconnect_ { 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_ socket ->
Connect (Connect_msg.create socket)
| NewJob_ { state ; push_address_tcp ; push_address_inproc } ->
| "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)
| EndJob_ state ->
| "end_job" :: state :: [] ->
Endjob (Endjob_msg.create state)
| GetPsi_ client_id ->
| "terminate" :: [] ->
Terminate (Terminate_msg.create () )
| "get_psi" :: 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 ->
| "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 g) ~n_det_selectors:(Some s)
~n_det_generators:(Some n_det_generators) ~n_det_selectors:(Some n_det_selectors)
~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)
| "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 to_string = function

265
ocaml/Message_lexer.mll
View File

@ -1,265 +0,0 @@
{
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
}

2
ocaml/Symmetry.ml
View File

@ -85,7 +85,7 @@ module Xyz = struct
let of_string s =
let flush state accu number =
let n =
if (number = "") then 1
if (number = "") then 0
else (Int.of_string number)
in
match state with

107
ocaml/TaskServer.ml
View File

@ -47,14 +47,6 @@ 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
@ -70,15 +62,7 @@ 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;
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)
ZMQ.Socket.bind socket @@ Printf.sprintf "ipc:///tmp/qp_run:%d" port
let hostname = lazy (
@ -115,7 +99,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
@ -137,7 +121,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 ;
@ -305,9 +289,9 @@ let disconnect msg program_state rep_socket =
let del_task msg program_state rep_socket =
let state, task_ids =
let state, task_id =
msg.Message.DelTask_msg.state,
msg.Message.DelTask_msg.task_ids
msg.Message.DelTask_msg.task_id
in
let failure () =
@ -318,14 +302,13 @@ let del_task msg program_state rep_socket =
let new_program_state =
{ program_state with
queue = List.fold ~f:(fun queue task_id -> Queuing_system.del_task ~task_id queue)
~init:program_state.queue task_ids
queue = Queuing_system.del_task ~task_id program_state.queue
}
in
let more =
(Queuing_system.number_of_tasks new_program_state.queue > 0)
in
Message.DelTaskReply (Message.DelTaskReply_msg.create ~task_ids ~more)
Message.DelTaskReply (Message.DelTaskReply_msg.create ~task_id ~more)
|> Message.to_string
|> ZMQ.Socket.send ~block:true rep_socket ; (** /!\ Has to be blocking *)
new_program_state
@ -346,9 +329,9 @@ let del_task msg program_state rep_socket =
let add_task msg program_state rep_socket =
let state, tasks =
let state, task =
msg.Message.AddTask_msg.state,
msg.Message.AddTask_msg.tasks
msg.Message.AddTask_msg.task
in
let increment_progress_bar = function
@ -356,18 +339,60 @@ let add_task msg program_state rep_socket =
| None -> None
in
let result =
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
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 = new_queue;
progress_bar = new_bar
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
in
reply_ok rep_socket;
result
@ -423,10 +448,10 @@ let get_task msg program_state rep_socket pair_socket =
let task_done msg program_state rep_socket =
let state, client_id, task_ids =
let state, client_id, task_id =
msg.Message.TaskDone_msg.state,
msg.Message.TaskDone_msg.client_id,
msg.Message.TaskDone_msg.task_ids
msg.Message.TaskDone_msg.task_id
in
let increment_progress_bar = function
@ -439,16 +464,10 @@ 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 = new_queue;
progress_bar = new_bar
queue = Queuing_system.end_task ~task_id ~client_id program_state.queue ;
progress_bar = increment_progress_bar program_state.progress_bar ;
}
in
reply_ok rep_socket;

51
ocaml/qp_create_ezfio_from_xyz.ml
View File

@ -21,9 +21,6 @@ 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 =
@ -118,14 +115,17 @@ let run ?o b c d m p cart xyz_file =
(* Open basis set channels *)
let basis_channel element =
let key =
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)
Element.to_string element
in
match Hashtbl.find basis_table key with
| Some in_channel ->
in_channel
| None -> raise Not_found
| None ->
let msg =
Printf.sprintf "%s is not defined in basis %s.%!"
(Element.to_long_string element) b ;
in
failwith msg
in
let temp_filename =
@ -189,21 +189,12 @@ let run ?o b c d m p cart xyz_file =
| Some (key, basis) -> (*Aux basis *)
begin
let elem =
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
Element.of_string key
and basis =
String.lowercase basis
in
let key =
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)
Element.to_string elem
in
let new_channel =
fetch_channel basis
@ -211,13 +202,7 @@ 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 ->
let e =
match elem with
| Element e -> e
| Int_elem (_,e) -> e
in
failwith ("Duplicate definition of basis for "^(Element.to_long_string e))
| `Duplicate -> failwith ("Duplicate definition of basis for "^(Element.to_long_string elem))
end
end
end;
@ -552,20 +537,7 @@ let run ?o b c d m p cart xyz_file =
| Element.X -> Element.H
| e -> e
in
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) )
Basis.read_element (basis_channel x.Atom.element) i e
with
| End_of_file -> failwith
("Element "^(Element.to_string x.Atom.element)^" not found in basis set.")
@ -675,7 +647,6 @@ 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.

8
ocaml/qptypes_generator.ml
View File

@ -42,8 +42,8 @@ let input_data = "
* Det_number_max : int
assert (x > 0) ;
if (x > 10000000000) then
warning \"More than 10 billion determinants\";
if (x > 100000000) then
warning \"More than 100 million determinants\";
* States_number : int
assert (x > 0) ;
@ -140,8 +140,8 @@ let input_ezfio = "
* Det_number : int
determinants_n_det
1 : 10000000000
More than 10 billion of determinants
1 : 100000000
More than 100 million of determinants
"
;;

9
plugins/CAS_SD_ZMQ/EZFIO.cfg
View File

@ -1,15 +1,10 @@
[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

121
plugins/CAS_SD_ZMQ/cassd_zmq.irp.f
View File

@ -132,3 +132,124 @@ 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

4
plugins/CAS_SD_ZMQ/ezfio_interface.irp.f Normal file
View File

@ -0,0 +1,4 @@
! 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

12
plugins/CAS_SD_ZMQ/run_selection_slave.irp.f
View File

@ -41,8 +41,8 @@ subroutine run_selection_slave(thread,iproc,energy)
if (done) then
ctask = ctask - 1
else
integer :: i_generator, N
read (task,*) i_generator, N
integer :: i_generator, i_generator_start, i_generator_max, step, N
read (task,*) i_generator_start, i_generator_max, step, N
if(buf%N == 0) then
! Only first time
call create_selection_buffer(N, N*2, buf)
@ -50,7 +50,11 @@ 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
endif
if(done .or. ctask == size(task_id)) then
@ -111,7 +115,7 @@ subroutine push_selection_results(zmq_socket_push, pt2, b, task_id, ntask)
if(rc /= 4*ntask) stop "push"
! Activate is zmq_socket_push is a REQ
rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0)
! rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0)
end subroutine
@ -145,7 +149,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

135
plugins/CAS_SD_ZMQ/selection.irp.f
View File

@ -112,7 +112,7 @@ double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2)
if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1_1
get_phase_bi = res(iand(np,1_1))
end subroutine
end function
@ -671,13 +671,10 @@ 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)
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
if (is_in_wavefunction(det,N_int)) 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
@ -1208,129 +1205,3 @@ subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting)
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
k = k+20
if (k>20*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

109
plugins/CAS_SD_ZMQ/target_pt2_ratio_cassd.irp.f
View File

@ -1,109 +0,0 @@
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

2
plugins/DDCI_selected/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Perturbation Selectors_full Generators_CAS Davidson Psiref_CAS
Perturbation Selectors_full Generators_CAS Davidson

2
plugins/DDCI_selected/ddci.irp.f
View File

@ -5,7 +5,7 @@ program ddci
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:),E_before(:)
integer :: N_st, degree
N_st = N_states
N_st = N_states_diag
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
character*(64) :: perturbation

4
plugins/DFT_Utils/EZFIO.cfg Normal file
View File

@ -0,0 +1,4 @@
[energy]
type: double precision
doc: Calculated energy
interface: ezfio

6951
plugins/DFT_Utils/angular.f
View File

File diff suppressed because it is too large Load Diff

54
plugins/DFT_Utils/functional.irp.f
View File

@ -1,54 +0,0 @@
subroutine ex_lda(rho_a,rho_b,ex,vx_a,vx_b)
include 'constants.include.F'
implicit none
double precision, intent(in) :: rho_a,rho_b
double precision, intent(out) :: ex,vx_a,vx_b
double precision :: tmp_a,tmp_b
tmp_a = rho_a**(c_1_3)
tmp_b = rho_b**(c_1_3)
ex = cst_lda * (tmp_a*tmp_a*tmp_a*tmp_a + tmp_b*tmp_b*tmp_b*tmp_b)
vx_a = cst_lda * c_4_3 * tmp_a
vx_b = cst_lda * c_4_3 * tmp_b
end
BEGIN_PROVIDER [double precision, lda_exchange, (N_states)]
&BEGIN_PROVIDER [double precision, lda_ex_potential_alpha_ao,(ao_num_align,ao_num,N_states)]
&BEGIN_PROVIDER [double precision, lda_ex_potential_beta_ao,(ao_num_align,ao_num,N_states)]
implicit none
integer :: i,j,k,l
integer :: m,n
double precision :: aos_array(ao_num)
double precision :: r(3)
lda_ex_potential_alpha_ao = 0.d0
lda_ex_potential_beta_ao = 0.d0
do l = 1, N_states
lda_exchange(l) = 0.d0
do j = 1, nucl_num
do i = 1, n_points_radial_grid
do k = 1, n_points_integration_angular
double precision :: rho_a,rho_b,ex
double precision :: vx_a,vx_b
rho_a = one_body_dm_mo_alpha_at_grid_points(k,i,j,l)
rho_b = one_body_dm_mo_beta_at_grid_points(k,i,j,l)
call ex_lda(rho_a,rho_b,ex,vx_a,vx_b)
lda_exchange(l) += final_weight_functions_at_grid_points(k,i,j) * ex
r(1) = grid_points_per_atom(1,k,i,j)
r(2) = grid_points_per_atom(2,k,i,j)
r(3) = grid_points_per_atom(3,k,i,j)
call give_all_aos_at_r(r,aos_array)
do m = 1, ao_num
! lda_ex_potential_ao(m,m,l) += (vx_a + vx_b) * aos_array(m)*aos_array(m)
do n = 1, ao_num
lda_ex_potential_alpha_ao(m,n,l) += (vx_a ) * aos_array(m)*aos_array(n) * final_weight_functions_at_grid_points(k,i,j)
lda_ex_potential_beta_ao(m,n,l) += (vx_b) * aos_array(m)*aos_array(n) * final_weight_functions_at_grid_points(k,i,j)
enddo
enddo
enddo
enddo
enddo
enddo
END_PROVIDER

115
plugins/DFT_Utils/grid_density.irp.f
View File

@ -1,60 +1,42 @@
BEGIN_PROVIDER [integer, n_points_integration_angular]
BEGIN_PROVIDER [integer, n_points_angular_grid]
implicit none
n_points_integration_angular = 110
n_points_angular_grid = 50
END_PROVIDER
BEGIN_PROVIDER [integer, n_points_radial_grid]
implicit none
n_points_radial_grid = 100
n_points_radial_grid = 10000
END_PROVIDER
BEGIN_PROVIDER [double precision, angular_quadrature_points, (n_points_integration_angular,3) ]
&BEGIN_PROVIDER [double precision, weights_angular_points, (n_points_integration_angular)]
BEGIN_PROVIDER [double precision, angular_quadrature_points, (n_points_angular_grid,3) ]
&BEGIN_PROVIDER [double precision, weights_angular_points, (n_points_angular_grid)]
implicit none
BEGIN_DOC
! weights and grid points for the integration on the angular variables on
! the unit sphere centered on (0,0,0)
! According to the LEBEDEV scheme
END_DOC
angular_quadrature_points = 0.d0
weights_angular_points = 0.d0
!call cal_quad(n_points_integration_angular, angular_quadrature_points,weights_angular_points)
call cal_quad(n_points_angular_grid, angular_quadrature_points,weights_angular_points)
include 'constants.include.F'
integer :: i,n
integer :: i
double precision :: accu
double precision :: degre_rad
degre_rad = pi/180.d0
accu = 0.d0
double precision :: x(n_points_integration_angular),y(n_points_integration_angular),z(n_points_integration_angular),w(n_points_integration_angular)
call LD0110(X,Y,Z,W,N)
do i = 1, n_points_integration_angular
angular_quadrature_points(i,1) = x(i)
angular_quadrature_points(i,2) = y(i)
angular_quadrature_points(i,3) = z(i)
weights_angular_points(i) = w(i) * 4.d0 * pi
accu += w(i)
enddo
!do i = 1, n_points_integration_angular
!degre_rad = 180.d0/pi
!accu = 0.d0
!do i = 1, n_points_integration_angular_lebedev
! accu += weights_angular_integration_lebedev(i)
! weights_angular_points(i) = weights_angular_integration_lebedev(i) * 4.d0 * pi
! weights_angular_points(i) = weights_angular_integration_lebedev(i) * 2.d0 * pi
! angular_quadrature_points(i,1) = dcos ( degre_rad * theta_angular_integration_lebedev(i)) &
! * dsin ( degre_rad * phi_angular_integration_lebedev(i))
! angular_quadrature_points(i,2) = dsin ( degre_rad * theta_angular_integration_lebedev(i)) &
! * dsin ( degre_rad * phi_angular_integration_lebedev(i))
! angular_quadrature_points(i,3) = dcos ( degre_rad * phi_angular_integration_lebedev(i))
!!weights_angular_points(i) = weights_angular_integration_lebedev(i)
!!angular_quadrature_points(i,1) = dcos ( degre_rad * phi_angular_integration_lebedev(i)) &
!! * dsin ( degre_rad * theta_angular_integration_lebedev(i))
!!angular_quadrature_points(i,2) = dsin ( degre_rad * phi_angular_integration_lebedev(i)) &
!! * dsin ( degre_rad * theta_angular_integration_lebedev(i))
!!angular_quadrature_points(i,3) = dcos ( degre_rad * theta_angular_integration_lebedev(i))
!enddo
print*,'ANGULAR'
print*,''
print*,'accu = ',accu
ASSERT( dabs(accu - 1.D0) < 1.d-10)
!print*,'ANGULAR'
!print*,''
!print*,'accu = ',accu
!ASSERT( dabs(accu - 1.D0) < 1.d-10)
END_PROVIDER
@ -81,7 +63,7 @@ END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_angular,n_points_radial_grid,nucl_num)]
BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_angular_grid,n_points_radial_grid,nucl_num)]
BEGIN_DOC
! points for integration over space
END_DOC
@ -97,7 +79,7 @@ BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_
double precision :: x,r
x = grid_points_radial(j) ! x value for the mapping of the [0, +\infty] to [0,1]
r = knowles_function(alpha_knowles(int(nucl_charge(i))),m_knowles,x) ! value of the radial coordinate for the integration
do k = 1, n_points_integration_angular ! explicit values of the grid points centered around each atom
do k = 1, n_points_angular_grid ! explicit values of the grid points centered around each atom
grid_points_per_atom(1,k,j,i) = x_ref + angular_quadrature_points(k,1) * r
grid_points_per_atom(2,k,j,i) = y_ref + angular_quadrature_points(k,2) * r
grid_points_per_atom(3,k,j,i) = z_ref + angular_quadrature_points(k,3) * r
@ -106,7 +88,7 @@ BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num) ]
BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ]
BEGIN_DOC
! Weight function at grid points : w_n(r) according to the equation (22) of Becke original paper (JCP, 88, 1988)
! the "n" discrete variable represents the nucleis which in this array is represented by the last dimension
@ -120,7 +102,7 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_int
! run over all points in space
do j = 1, nucl_num ! that are referred to each atom
do k = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom
do l = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom
do l = 1, n_points_angular_grid ! for each angular point attached to the "jth" atom
r(1) = grid_points_per_atom(1,l,k,j)
r(2) = grid_points_per_atom(2,l,k,j)
r(3) = grid_points_per_atom(3,l,k,j)
@ -133,6 +115,7 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_int
enddo
accu = 1.d0/accu
weight_functions_at_grid_points(l,k,j) = tmp_array(j) * accu
! print*,weight_functions_at_grid_points(l,k,j)
enddo
enddo
enddo
@ -140,65 +123,43 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_int
END_PROVIDER
BEGIN_PROVIDER [double precision, final_weight_functions_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num) ]
BEGIN_DOC
! Weight function at grid points : w_n(r) according to the equation (22) of Becke original paper (JCP, 88, 1988)
! the "n" discrete variable represents the nucleis which in this array is represented by the last dimension
! and the points are labelled by the other dimensions
END_DOC
BEGIN_PROVIDER [double precision, one_body_dm_mo_alpha_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ]
&BEGIN_PROVIDER [double precision, one_body_dm_mo_beta_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ]
implicit none
integer :: i,j,k,l,m
double precision :: r(3)
double precision :: accu,cell_function_becke
double precision :: tmp_array(nucl_num)
double precision :: contrib_integration,x
double precision :: derivative_knowles_function,knowles_function
! run over all points in space
do j = 1, nucl_num ! that are referred to each atom
do i = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom
x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1]
do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom
contrib_integration = derivative_knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x) &
*knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x)**2
final_weight_functions_at_grid_points(k,i,j) = weights_angular_points(k) * weight_functions_at_grid_points(k,i,j) * contrib_integration * dr_radial_integral
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, one_body_dm_mo_alpha_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num,N_states) ]
&BEGIN_PROVIDER [double precision, one_body_dm_mo_beta_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num,N_states) ]
implicit none
integer :: i,j,k,l,m,i_state
double precision :: contrib
double precision :: r(3)
double precision :: aos_array(ao_num),mos_array(mo_tot_num)
do i_state = 1, N_states
do j = 1, nucl_num
do k = 1, n_points_radial_grid
do l = 1, n_points_integration_angular
one_body_dm_mo_alpha_at_grid_points(l,k,j,i_state) = 0.d0
one_body_dm_mo_beta_at_grid_points(l,k,j,i_state) = 0.d0
do k = 1, n_points_radial_grid -1
do l = 1, n_points_angular_grid
one_body_dm_mo_alpha_at_grid_points(l,k,j) = 0.d0
one_body_dm_mo_beta_at_grid_points(l,k,j) = 0.d0
r(1) = grid_points_per_atom(1,l,k,j)
r(2) = grid_points_per_atom(2,l,k,j)
r(3) = grid_points_per_atom(3,l,k,j)
! call give_all_aos_at_r(r,aos_array)
! do i = 1, ao_num
! do m = 1, ao_num
! contrib = aos_array(i) * aos_array(m)
! one_body_dm_mo_alpha_at_grid_points(l,k,j) += one_body_dm_ao_alpha(i,m) * contrib
! one_body_dm_mo_beta_at_grid_points(l,k,j) += one_body_dm_ao_beta(i,m) * contrib
! enddo
! enddo
call give_all_mos_at_r(r,mos_array)
do m = 1, mo_tot_num
do i = 1, mo_tot_num
if(dabs(one_body_dm_mo_alpha(i,m,i_state)).lt.1.d-10)cycle
do m = 1, mo_tot_num
contrib = mos_array(i) * mos_array(m)
one_body_dm_mo_alpha_at_grid_points(l,k,j,i_state) += one_body_dm_mo_alpha(i,m,i_state) * contrib
one_body_dm_mo_beta_at_grid_points(l,k,j,i_state) += one_body_dm_mo_beta(i,m,i_state) * contrib
one_body_dm_mo_alpha_at_grid_points(l,k,j) += one_body_dm_mo_alpha(i,m) * contrib
one_body_dm_mo_beta_at_grid_points(l,k,j) += one_body_dm_mo_beta(i,m) * contrib
enddo
enddo
enddo
enddo
enddo
enddo
END_PROVIDER

9
plugins/DFT_Utils/integration_3d.irp.f
View File

@ -4,11 +4,18 @@ double precision function step_function_becke(x)
double precision :: f_function_becke
integer :: i,n_max_becke
!if(x.lt.-1.d0)then
! step_function_becke = 0.d0
!else if (x .gt.1)then
! step_function_becke = 0.d0
!else
step_function_becke = f_function_becke(x)
do i = 1,5
!!n_max_becke = 1
do i = 1, 4
step_function_becke = f_function_becke(step_function_becke)
enddo
step_function_becke = 0.5d0*(1.d0 - step_function_becke)
!endif
end
double precision function f_function_becke(x)

11
plugins/DFT_Utils/integration_radial.irp.f
View File

@ -4,7 +4,7 @@
double precision :: accu
integer :: i,j,k,l
double precision :: x
double precision :: integrand(n_points_integration_angular), weights(n_points_integration_angular)
double precision :: integrand(n_points_angular_grid), weights(n_points_angular_grid)
double precision :: f_average_angular_alpha,f_average_angular_beta
double precision :: derivative_knowles_function,knowles_function
@ -12,7 +12,7 @@
! according ot equation (6) of the paper of Becke (JCP, (88), 1988)
! Here the m index is referred to the w_m(r) weight functions of equation (22)
! Run over all points of integrations : there are
! n_points_radial_grid (i) * n_points_integration_angular (k)
! n_points_radial_grid (i) * n_points_angular_grid (k)
do j = 1, nucl_num
integral_density_alpha_knowles_becke_per_atom(j) = 0.d0
integral_density_beta_knowles_becke_per_atom(j) = 0.d0
@ -20,13 +20,14 @@
! Angular integration over the solid angle Omega for a FIXED angular coordinate "r"
f_average_angular_alpha = 0.d0
f_average_angular_beta = 0.d0
do k = 1, n_points_integration_angular
f_average_angular_alpha += weights_angular_points(k) * one_body_dm_mo_alpha_at_grid_points(k,i,j,1) * weight_functions_at_grid_points(k,i,j)
f_average_angular_beta += weights_angular_points(k) * one_body_dm_mo_beta_at_grid_points(k,i,j,1) * weight_functions_at_grid_points(k,i,j)
do k = 1, n_points_angular_grid
f_average_angular_alpha += weights_angular_points(k) * one_body_dm_mo_alpha_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j)
f_average_angular_beta += weights_angular_points(k) * one_body_dm_mo_beta_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j)
enddo
!
x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1]
double precision :: contrib_integration
! print*,m_knowles
contrib_integration = derivative_knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x) &
*knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x)**2
integral_density_alpha_knowles_becke_per_atom(j) += contrib_integration *f_average_angular_alpha

54
plugins/DFT_Utils/test_integration_3d_density.irp.f
View File

@ -4,55 +4,13 @@ program pouet
touch read_wf
print*,'m_knowles = ',m_knowles
call routine
call routine3
end
subroutine routine3
implicit none
integer :: i,j,k,l
double precision :: accu
accu = 0.d0
do j = 1, nucl_num ! that are referred to each atom
do i = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom
do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom
accu += final_weight_functions_at_grid_points(k,i,j) * one_body_dm_mo_alpha_at_grid_points(k,i,j,1)
enddo
enddo
enddo
print*, accu
print*, 'lda_exchange',lda_exchange
end
subroutine routine2
implicit none
integer :: i,j,k,l
double precision :: x,y,z
double precision :: r
double precision :: accu
accu = 0.d0
r = 1.d0
do k = 1, n_points_integration_angular
x = angular_quadrature_points(k,1) * r
y = angular_quadrature_points(k,2) * r
z = angular_quadrature_points(k,3) * r
accu += weights_angular_points(k) * (x**2 + y**2 + z**2)
enddo
print*, accu
end
subroutine routine
implicit none
integer :: i
double precision :: accu(2)
accu = 0.d0
do i = 1, N_det
call debug_det(psi_det(1,1,i),N_int)
enddo
do i = 1, nucl_num
accu(1) += integral_density_alpha_knowles_becke_per_atom(i)
accu(2) += integral_density_beta_knowles_becke_per_atom(i)
@ -62,17 +20,5 @@ subroutine routine
print*,'accu(2) = ',accu(2)
print*,'Nalpha = ',elec_beta_num
accu = 0.d0
do i = 1, mo_tot_num
accu(1) += one_body_dm_mo_alpha_average(i,i)
accu(2) += one_body_dm_mo_beta_average(i,i)
enddo
print*,' '
print*,' '
print*,'accu(1) = ',accu(1)
print*,'accu(2) = ',accu(2)
end

2
plugins/FCIdump/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Determinants Davidson core_integrals
Determinants Davidson

48
plugins/FCIdump/fcidump.irp.f
View File

@ -1,25 +1,21 @@
program fcidump
implicit none
character*(128) :: output
integer :: i_unit_output,getUnitAndOpen
output=trim(ezfio_filename)//'.FCIDUMP'
i_unit_output = getUnitAndOpen(output,'w')
integer :: i,j,k,l
integer :: i1,j1,k1,l1
integer :: i2,j2,k2,l2
integer :: ii(8), jj(8), kk(8),ll(8)
integer*8 :: m
character*(2), allocatable :: A(:)
write(i_unit_output,*) '&FCI NORB=', n_act_orb, ', NELEC=', elec_num-n_core_orb*2, &
print *, '&FCI NORB=', mo_tot_num, ', NELEC=', elec_num, &
', MS2=', (elec_alpha_num-elec_beta_num), ','
allocate (A(n_act_orb))
allocate (A(mo_tot_num))
A = '1,'
write(i_unit_output,*) 'ORBSYM=', (A(i), i=1,n_act_orb)
write(i_unit_output,*) 'ISYM=0,'
write(i_unit_output,*) '/'
print *, 'ORBSYM=', (A(i), i=1,mo_tot_num)
print *,'ISYM=0,'
print *,'/'
deallocate(A)
integer*8 :: i8, k1
integer(key_kind), allocatable :: keys(:)
double precision, allocatable :: values(:)
integer(cache_map_size_kind) :: n_elements, n_elements_max
@ -27,18 +23,14 @@ program fcidump
double precision :: get_mo_bielec_integral, integral
do l=1,n_act_orb
l1 = list_act(l)
do k=1,n_act_orb
k1 = list_act(k)
do j=l,n_act_orb
j1 = list_act(j)
do i=k,n_act_orb
i1 = list_act(i)
if (i1>=j1) then
integral = get_mo_bielec_integral(i1,j1,k1,l1,mo_integrals_map)
do l=1,mo_tot_num
do k=1,mo_tot_num
do j=l,mo_tot_num
do i=k,mo_tot_num
if (i>=j) then
integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map)
if (dabs(integral) > mo_integrals_threshold) then
write(i_unit_output,*) integral, i,k,j,l
print *, integral, i,k,j,l
endif
end if
enddo
@ -46,15 +38,13 @@ program fcidump
enddo
enddo
do j=1,n_act_orb
j1 = list_act(j)
do i=j,n_act_orb
i1 = list_act(i)
integral = mo_mono_elec_integral(i1,j1) + core_fock_operator(i1,j1)
do j=1,mo_tot_num
do i=j,mo_tot_num
integral = mo_mono_elec_integral(i,j)
if (dabs(integral) > mo_integrals_threshold) then
write(i_unit_output,*) integral, i,j,0,0
print *, integral, i,j,0,0
endif
enddo
enddo
write(i_unit_output,*) core_energy, 0, 0, 0, 0
print *, 0.d0, 0, 0, 0, 0
end

2
plugins/FOBOCI/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Perturbation Selectors_no_sorted SCF_density Davidson CISD
Perturbation Selectors_no_sorted Hartree_Fock Davidson CISD

2
plugins/FOBOCI/SC2_1h1p.irp.f
View File

@ -356,7 +356,7 @@ subroutine dressing_1h1p_by_2h2p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Ni
c_ref = 1.d0/u_in(index_hf,1)
do k = 1, n_singles
l = index_singles(k)
diag_H_elements(1) -= diag_H_elements(l)
diag_H_elements(0) -= diag_H_elements(l)
enddo
! do k = 1, n_doubles
! l = index_doubles(k)

1
plugins/FOBOCI/all_singles.irp.f
View File

@ -48,7 +48,6 @@ subroutine all_single(e_pt2)
print*,'-----------------------'
print*,'i = ',i
call H_apply_just_mono(pt2, norm_pert, H_pert_diag, N_st)
call make_s2_eigenfunction_first_order
call diagonalize_CI
print*,'N_det = ',N_det
print*,'E = ',CI_energy(1)

137
plugins/FOBOCI/create_1h_or_1p.irp.f
View File

@ -30,12 +30,20 @@ subroutine create_restart_and_1h(i_hole)
enddo
enddo
integer :: N_det_old
N_det_old = N_det
logical, allocatable :: duplicate(:)
allocate (new_det(N_int,2,n_new_det),duplicate(n_new_det))
N_det += n_new_det
allocate (new_det(N_int,2,n_new_det))
if (psi_det_size < N_det) then
psi_det_size = N_det
TOUCH psi_det_size
endif
do i = 1, N_det_old
do k = 1, N_int
psi_det(k,1,i) = old_psi_det(k,1,i)
psi_det(k,2,i) = old_psi_det(k,2,i)
enddo
enddo
n_new_det = 0
do j = 1, n_act_orb
@ -50,56 +58,19 @@ subroutine create_restart_and_1h(i_hole)
if(i_ok .ne. 1)cycle
n_new_det +=1
do k = 1, N_int
new_det(k,1,n_new_det) = key_tmp(k,1)
new_det(k,2,n_new_det) = key_tmp(k,2)
psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1)
psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2)
enddo
psi_coef(n_det_old+n_new_det,:) = 0.d0
enddo
enddo
enddo
enddo
integer :: i_test
duplicate = .False.
do i = 1, n_new_det
if(duplicate(i))cycle
do j = i+1, n_new_det
i_test = 0
do ispin =1 ,2
do k = 1, N_int
i_test += popcnt(xor(new_det(k,ispin,i),new_det(k,ispin,j)))
enddo
enddo
if(i_test.eq.0)then
duplicate(j) = .True.
endif
enddo
enddo
integer :: n_new_det_unique
n_new_det_unique = 0
print*, 'uniq det'
do i = 1, n_new_det
if(.not.duplicate(i))then
n_new_det_unique += 1
endif
enddo
print*, n_new_det_unique
N_det += n_new_det_unique
if (psi_det_size < N_det) then
psi_det_size = N_det
TOUCH psi_det_size
endif
do i = 1, n_new_det_unique
do ispin = 1, 2
do k = 1, N_int
psi_det(k,ispin,N_det_old+i) = new_det(k,ispin,i)
enddo
enddo
psi_coef(N_det_old+i,:) = 0.d0
enddo
SOFT_TOUCH N_det psi_det psi_coef
deallocate (new_det,duplicate)
logical :: found_duplicates
if(n_act_orb.gt.1)then
call remove_duplicates_in_psi_det(found_duplicates)
endif
end
subroutine create_restart_and_1p(i_particle)
@ -136,8 +107,18 @@ subroutine create_restart_and_1p(i_particle)
integer :: N_det_old
N_det_old = N_det
logical, allocatable :: duplicate(:)
allocate (new_det(N_int,2,n_new_det),duplicate(n_new_det))
N_det += n_new_det
allocate (new_det(N_int,2,n_new_det))
if (psi_det_size < N_det) then
psi_det_size = N_det
TOUCH psi_det_size
endif
do i = 1, N_det_old
do k = 1, N_int
psi_det(k,1,i) = old_psi_det(k,1,i)
psi_det(k,2,i) = old_psi_det(k,2,i)
enddo
enddo
n_new_det = 0
do j = 1, n_act_orb
@ -152,59 +133,17 @@ subroutine create_restart_and_1p(i_particle)
if(i_ok .ne. 1)cycle
n_new_det +=1
do k = 1, N_int
new_det(k,1,n_new_det) = key_tmp(k,1)
new_Det(k,2,n_new_det) = key_tmp(k,2)
psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1)
psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2)
enddo
psi_coef(n_det_old+n_new_det,:) = 0.d0
enddo
enddo
enddo
enddo
integer :: i_test
duplicate = .False.
do i = 1, n_new_det
if(duplicate(i))cycle
call debug_det(new_det(1,1,i),N_int)
do j = i+1, n_new_det
i_test = 0
call debug_det(new_det(1,1,j),N_int)
do ispin =1 ,2
do k = 1, N_int
i_test += popcnt(xor(new_det(k,ispin,i),new_det(k,ispin,j)))
enddo
enddo
if(i_test.eq.0)then
duplicate(j) = .True.
endif
enddo
enddo
integer :: n_new_det_unique
n_new_det_unique = 0
print*, 'uniq det'
do i = 1, n_new_det
if(.not.duplicate(i))then
n_new_det_unique += 1
endif
enddo
print*, n_new_det_unique
N_det += n_new_det_unique
if (psi_det_size < N_det) then
psi_det_size = N_det
TOUCH psi_det_size
endif
do i = 1, n_new_det_unique
do ispin = 1, 2
do k = 1, N_int
psi_det(k,ispin,N_det_old+i) = new_det(k,ispin,i)
enddo
enddo
psi_coef(N_det_old+i,:) = 0.d0
enddo
SOFT_TOUCH N_det psi_det psi_coef
deallocate (new_det,duplicate)
logical :: found_duplicates
call remove_duplicates_in_psi_det(found_duplicates)
end
subroutine create_restart_1h_1p(i_hole,i_part)

16
plugins/FOBOCI/density.irp.f
View File

@ -1,16 +0,0 @@
BEGIN_PROVIDER [double precision, mo_general_density_alpha, (mo_tot_num_align,mo_tot_num)]
implicit none
integer :: i,j,k,l
mo_general_density_alpha = one_body_dm_mo_alpha_generators_restart
END_PROVIDER
BEGIN_PROVIDER [double precision, mo_general_density_beta, (mo_tot_num_align,mo_tot_num)]
implicit none
integer :: i,j,k,l
mo_general_density_beta = one_body_dm_mo_beta_generators_restart
END_PROVIDER

32
plugins/FOBOCI/density_matrix.irp.f
View File

@ -1,12 +1,12 @@
BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_generators_restart, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_generators_restart, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, norm_generators_restart, (N_states)]
&BEGIN_PROVIDER [ double precision, norm_generators_restart]
implicit none
BEGIN_DOC
! Alpha and beta one-body density matrix for the generators restart
END_DOC
integer :: j,k,l,m,istate
integer :: j,k,l,m
integer :: occ(N_int*bit_kind_size,2)
double precision :: ck, cl, ckl
double precision :: phase
@ -14,37 +14,23 @@
integer :: exc(0:2,2,2),n_occ_alpha
double precision, allocatable :: tmp_a(:,:), tmp_b(:,:)
integer :: degree_respect_to_HF_k
integer :: degree_respect_to_HF_l,index_ref_generators_restart(N_states)
double precision :: inv_coef_ref_generators_restart(N_states)
integer :: degree_respect_to_HF_l,index_ref_generators_restart
double precision :: inv_coef_ref_generators_restart
integer :: i
print*, 'providing the one_body_dm_mo_alpha_generators_restart'
do istate = 1, N_states
do i = 1, N_det_generators_restart
! Find the reference determinant for intermediate normalization
call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det_generators_restart(1,1,i),degree,N_int)
call get_excitation_degree(ref_generators_restart,psi_det_generators_restart(1,1,i),degree,N_int)
if(degree == 0)then
index_ref_generators_restart(istate) = i
inv_coef_ref_generators_restart(istate) = 1.d0/psi_coef_generators_restart(i,istate)
index_ref_generators_restart = i
inv_coef_ref_generators_restart = 1.d0/psi_coef_generators_restart(i,1)
exit
endif
enddo
enddo
norm_generators_restart = 0.d0
do istate = 1, N_states
do i = 1, N_det_generators_restart
psi_coef_generators_restart(i,istate) = psi_coef_generators_restart(i,istate) * inv_coef_ref_generators_restart(istate)
norm_generators_restart(istate) += psi_coef_generators_restart(i,istate)**2
enddo
enddo
double precision :: inv_norm(N_States)
do istate = 1, N_states
inv_norm(istate) = 1.d0/dsqrt(norm_generators_restart(istate))
enddo
do istate = 1, N_states
do i = 1, N_det_generators_restart
psi_coef_generators_restart(i,istate) = psi_coef_generators_restart(i,istate) * inv_norm(istate)
enddo
psi_coef_generators_restart(i,1) = psi_coef_generators_restart(i,1) * inv_coef_ref_generators_restart
norm_generators_restart += psi_coef_generators_restart(i,1)**2
enddo

53
plugins/FOBOCI/dress_simple.irp.f
View File

@ -107,6 +107,7 @@ subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_per
!enddo
!soft_touch psi_selectors psi_selectors_coef
!if(do_it_perturbative)then
print*, 'is_ok_perturbative',is_ok_perturbative
if(is_ok.or.is_ok_perturbative)then
N_det = N_det_generators
do m = 1, N_states
@ -116,6 +117,7 @@ subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_per
psi_det(l,2,k) = psi_det_generators_input(l,2,k)
enddo
psi_coef(k,m) = psi_coef_diagonalized_tmp(k,m)
print*, 'psi_coef(k,m)',psi_coef(k,m)
enddo
enddo
soft_touch psi_det psi_coef N_det
@ -148,7 +150,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
double precision, intent(inout) :: dressed_H_matrix(Ndet_generators, Ndet_generators)
integer :: i,j,degree,index_ref_generators_restart(N_states),i_count,k,i_det_no_ref
integer :: i,j,degree,index_ref_generators_restart,i_count,k,i_det_no_ref
double precision :: eigvalues(Ndet_generators), eigvectors(Ndet_generators,Ndet_generators),hij
double precision :: psi_coef_ref(Ndet_generators,N_states),diag_h_mat_average,diag_h_mat_no_ref_average
logical :: is_a_ref_det(Ndet_generators)
@ -166,17 +168,11 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
enddo
integer :: istate
do istate = 1, N_states
do i = 1, Ndet_generators
call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det_generators_input(1,1,i),degree,N_int)
call get_excitation_degree(ref_generators_restart,psi_det_generators_input(1,1,i),degree,N_int)
if(degree == 0)then
index_ref_generators_restart(istate) = i
exit
index_ref_generators_restart = i
endif
enddo
enddo
do i = 1, Ndet_generators
do j = 1, Ndet_generators
call i_h_j(psi_det_generators_input(1,1,j),psi_det_generators_input(1,1,i),N_int,hij) ! Fill the zeroth order H matrix
dressed_H_matrix(i,j) = hij
@ -189,21 +185,15 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
i_det_no_ref +=1
diag_h_mat_average+=dressed_H_matrix(i,i)
enddo
double precision :: average_ref_h_mat
average_ref_h_mat = 0.d0
do istate = 1, N_states
average_ref_h_mat += dressed_H_matrix(index_ref_generators_restart(istate),index_ref_generators_restart(istate))
enddo
average_ref_h_mat = 1.d0/dble(N_states)
diag_h_mat_average = diag_h_mat_average/dble(i_det_no_ref)
print*,'diag_h_mat_average = ',diag_h_mat_average
print*,'ref h_mat average = ',average_ref_h_mat
print*,'ref h_mat = ',dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart)
integer :: number_of_particles, number_of_holes
! Filter the the MLCT that are higher than 27.2 eV in energy with respect to the reference determinant
do i = 1, Ndet_generators
if(is_a_ref_det(i))cycle
if(number_of_holes(psi_det_generators_input(1,1,i)).eq.0 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.1)then
if(diag_h_mat_average - average_ref_h_mat .gt.2.d0)then
if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then
is_ok = .False.
exit_loop = .True.
return
@ -212,7 +202,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
! Filter the the LMCT that are higher than 54.4 eV in energy with respect to the reference determinant
if(number_of_holes(psi_det_generators_input(1,1,i)).eq.1 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.0)then
if(diag_h_mat_average - average_ref_h_mat .gt.1.d0)then
if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then
is_ok = .False.
return
endif
@ -220,7 +210,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
exit
enddo
call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the naked matrix
call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the Dressed_H_matrix
double precision :: s2(N_det_generators),E_ref(N_states)
integer :: i_state(N_states)
@ -246,10 +236,15 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
E_ref(i) = eigvalues(i)
enddo
endif
do i = 1,N_states
print*,'i_state = ',i_state(i)
enddo
do k = 1, N_states
print*,'state ',k
do i = 1, Ndet_generators
psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart(k),i_state(k))
psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart,i_state(k))
psi_coef_ref(i,k) = eigvectors(i,i_state(k))
print*,'psi_coef_ref(i) = ',psi_coef_ref(i,k)
enddo
enddo
if(verbose)then
@ -262,7 +257,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
do k = 1, N_states
print*,'state ',k
do i = 1, Ndet_generators
print*,'coef, <I|H|I> = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart(k),index_ref_generators_restart(k)),is_a_ref_det(i)
print*,'coef, <I|H|I> = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart),is_a_ref_det(i)
enddo
enddo
endif
@ -283,20 +278,18 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the Dressed_H_matrix
integer :: i_good_state(0:N_states)
i_good_state(0) = 0
do k = 1, N_states
! print*,'state',k
do i = 1, Ndet_generators
! State following
do k = 1, N_states
accu = 0.d0
do j =1, Ndet_generators
print*,'',eigvectors(j,i) , psi_coef_ref(j,k)
accu += eigvectors(j,i) * psi_coef_ref(j,k)
enddo
! print*,i,accu
if(dabs(accu).ge.0.60d0)then
print*,'accu = ',accu
if(dabs(accu).ge.0.72d0)then
i_good_state(0) +=1
i_good_state(i_good_state(0)) = i
print*, 'state, ovrlap',k,i,accu
exit
endif
enddo
if(i_good_state(0)==N_states)then
@ -311,14 +304,14 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
accu = 0.d0
do k = 1, N_states
do i = 1, Ndet_generators
psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart(k),i_state(k))
psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart,i_state(k))
enddo
enddo
if(verbose)then
do k = 1, N_states
print*,'state ',k
do i = 1, Ndet_generators
print*,'coef, <I|H+Delta H|I> = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart(k),index_ref_generators_restart(k)),is_a_ref_det(i)
print*,'coef, <I|H+Delta H|I> = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart),is_a_ref_det(i)
enddo
enddo
endif
@ -340,7 +333,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
do i = 1, Ndet_generators
if(is_a_ref_det(i))cycle
do k = 1, N_states
! print*, psi_coef_diagonalized_tmp(i,k),threshold_perturbative
print*, psi_coef_diagonalized_tmp(i,k),threshold_perturbative
if(dabs(psi_coef_diagonalized_tmp(i,k)) .gt.threshold_perturbative)then
is_ok_perturbative = .False.
exit

7
plugins/FOBOCI/fobo_scf.irp.f
View File

@ -15,6 +15,8 @@ end
subroutine run_prepare
implicit none
! no_oa_or_av_opt = .False.
! touch no_oa_or_av_opt
call damping_SCF
call diag_inactive_virt_and_update_mos
end
@ -26,8 +28,7 @@ subroutine routine_fobo_scf
print*,''
character*(64) :: label
label = "Natural"
do i = 1, 10
call initialize_mo_coef_begin_iteration
do i = 1, 5
print*,'*******************************************************************************'
print*,'*******************************************************************************'
print*,'FOBO-SCF Iteration ',i
@ -55,8 +56,6 @@ subroutine routine_fobo_scf
call save_osoci_natural_mos
call damping_SCF
call diag_inactive_virt_and_update_mos
call reorder_active_orb
call save_mos
call clear_mo_map
call provide_properties
enddo

23
plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f
View File

@ -40,13 +40,11 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
logical :: lmct
double precision, allocatable :: psi_singles_coef(:,:)
logical :: exit_loop
call update_generators_restart_coef
allocate( zero_bitmask(N_int,2) )
do i = 1, n_inact_orb
lmct = .True.
integer :: i_hole_osoci
i_hole_osoci = list_inact(i)
! if(i_hole_osoci.ne.26)cycle
print*,'--------------------------'
! First set the current generators to the one of restart
call check_symetry(i_hole_osoci,thr,test_sym)
@ -56,6 +54,7 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
print*,'i_hole_osoci = ',i_hole_osoci
call create_restart_and_1h(i_hole_osoci)
call set_generators_to_psi_det
print*,'Passed set generators'
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
double precision :: e_pt2
@ -83,10 +82,10 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
call all_single(e_pt2)
! call make_s2_eigenfunction_first_order
! threshold_davidson = 1.d-6
! soft_touch threshold_davidson davidson_criterion
! call diagonalize_ci
call make_s2_eigenfunction_first_order
threshold_davidson = 1.d-6
soft_touch threshold_davidson davidson_criterion
call diagonalize_ci
double precision :: hkl
call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators)
hkl = dressing_matrix(1,1)
@ -119,7 +118,6 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
do i = 1, n_virt_orb
integer :: i_particl_osoci
i_particl_osoci = list_virt(i)
! cycle
print*,'--------------------------'
! First set the current generators to the one of restart
@ -154,11 +152,11 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
enddo
enddo
call all_single(e_pt2)
! call make_s2_eigenfunction_first_order
! threshold_davidson = 1.d-6
! soft_touch threshold_davidson davidson_criterion
!
! call diagonalize_ci
call make_s2_eigenfunction_first_order
threshold_davidson = 1.d-6
soft_touch threshold_davidson davidson_criterion
call diagonalize_ci
deallocate(dressing_matrix)
else
if(exit_loop)then
@ -543,6 +541,7 @@ subroutine FOBOCI_lmct_mlct_old_thr_restart(iter)
call print_generators_bitmasks_holes
! Impose that only the active part can be reached
call set_bitmask_hole_as_input(unpaired_bitmask)
!!! call all_single_h_core
call create_restart_and_1p(i_particl_osoci)
!!! ! Update the generators
call set_generators_to_psi_det

35
plugins/FOBOCI/generators_restart_save.irp.f
View File

@ -21,19 +21,23 @@ END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators_restart, (N_int,2,N_det_generators_restart) ]
&BEGIN_PROVIDER [ integer(bit_kind), ref_generators_restart, (N_int,2,N_states) ]
&BEGIN_PROVIDER [ integer(bit_kind), ref_generators_restart, (N_int,2) ]
&BEGIN_PROVIDER [ double precision, psi_coef_generators_restart, (N_det_generators_restart,N_states) ]
implicit none
BEGIN_DOC
! read wf
!
END_DOC
integer :: i, k,j
integer :: i, k
integer, save :: ifirst = 0
double precision, allocatable :: psi_coef_read(:,:)
print*, ' Providing psi_det_generators_restart'
if(ifirst == 0)then
call read_dets(psi_det_generators_restart,N_int,N_det_generators_restart)
do k = 1, N_int
ref_generators_restart(k,1) = psi_det_generators_restart(k,1,1)
ref_generators_restart(k,2) = psi_det_generators_restart(k,2,1)
enddo
allocate (psi_coef_read(N_det_generators_restart,N_states))
call ezfio_get_determinants_psi_coef(psi_coef_read)
do k = 1, N_states
@ -41,18 +45,6 @@ END_PROVIDER
psi_coef_generators_restart(i,k) = psi_coef_read(i,k)
enddo
enddo
do k = 1, N_states
do i = 1, N_det_generators_restart
if(dabs(psi_coef_generators_restart(i,k)).gt.0.5d0)then
do j = 1, N_int
ref_generators_restart(j,1,k) = psi_det_generators_restart(j,1,i)
ref_generators_restart(j,2,k) = psi_det_generators_restart(j,2,i)
enddo
exit
endif
enddo
call debug_det(ref_generators_restart(1,1,k),N_int)
enddo
ifirst = 1
deallocate(psi_coef_read)
else
@ -82,18 +74,3 @@ END_PROVIDER
&BEGIN_PROVIDER [ double precision, psi_coef_generators, (10000,N_states) ]
END_PROVIDER
subroutine update_generators_restart_coef
implicit none
call set_generators_to_generators_restart
call set_psi_det_to_generators
call diagonalize_CI
integer :: i,j,k,l
do i = 1, N_det_generators_restart
do j = 1, N_states
psi_coef_generators_restart(i,j) = psi_coef(i,j)
enddo
enddo
soft_touch psi_coef_generators_restart
provide one_body_dm_mo_alpha_generators_restart
end

146
plugins/FOBOCI/routines_foboci.irp.f
View File

@ -2,7 +2,7 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole)
implicit none
integer, intent(in) :: i_hole
double precision, intent(out) :: norm(N_states)
integer :: i,j,degree,index_ref_generators_restart(N_states),k
integer :: i,j,degree,index_ref_generators_restart,k
integer:: number_of_holes,n_h, number_of_particles,n_p
integer, allocatable :: index_one_hole(:),index_one_hole_one_p(:),index_two_hole_one_p(:),index_two_hole(:)
integer, allocatable :: index_one_p(:)
@ -13,8 +13,6 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole)
integer :: n_good_hole
logical,allocatable :: is_a_ref_det(:)
allocate(index_one_hole(n_det),index_one_hole_one_p(n_det),index_two_hole_one_p(N_det),index_two_hole(N_det),index_one_p(N_det),is_a_ref_det(N_det))
double precision, allocatable :: local_norm(:)
allocate(local_norm(N_states))
n_one_hole = 0
n_one_hole_one_p = 0
@ -24,18 +22,17 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole)
n_good_hole = 0
! Find the one holes and one hole one particle
is_a_ref_det = .False.
integer :: istate
do istate = 1, N_States
do i = 1, N_det
! Find the reference determinant for intermediate normalization
call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det(1,1,i),degree,N_int)
call get_excitation_degree(ref_generators_restart,psi_det(1,1,i),degree,N_int)
if(degree == 0)then
index_ref_generators_restart(istate) = i
inv_coef_ref_generators_restart(istate) = 1.d0/psi_coef(i,istate)
index_ref_generators_restart = i
do k = 1, N_states
inv_coef_ref_generators_restart(k) = 1.d0/psi_coef(i,k)
enddo
! cycle
endif
enddo
enddo
do i = 1, N_det
! Find all the determinants present in the reference wave function
do j = 1, N_det_generators_restart
call get_excitation_degree(psi_det(1,1,i),psi_det_generators_restart(1,1,j),degree,N_int)
@ -62,17 +59,20 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole)
enddo
endif
enddo
!do k = 1, N_det
! call debug_det(psi_det(1,1,k),N_int)
! print*,'k,coef = ',k,psi_coef(k,1)/psi_coef(index_ref_generators_restart,1)
!enddo
print*,''
print*,'n_good_hole = ',n_good_hole
do k = 1,N_states
print*,'state ',k
do i = 1, n_good_hole
print*,'psi_coef(index_good_hole) = ',psi_coef(index_good_hole(i),k)/psi_coef(index_ref_generators_restart(k),k)
print*,'psi_coef(index_good_hole) = ',psi_coef(index_good_hole(i),k)/psi_coef(index_ref_generators_restart,k)
enddo
print*,''
enddo
norm = 0.d0
! Set the wave function to the intermediate normalization
do k = 1, N_states
@ -80,30 +80,19 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole)
psi_coef(i,k) = psi_coef(i,k) * inv_coef_ref_generators_restart(k)
enddo
enddo
norm = 0.d0
do k = 1,N_states
print*,'state ',k
do i = 1, N_det
!! print*,'psi_coef(i_ref) = ',psi_coef(i,1)
if (is_a_ref_det(i))then
print*,'i,psi_coef_ref = ',psi_coef(i,k)
cycle
endif
norm(k) += psi_coef(i,k) * psi_coef(i,k)
enddo
print*,'norm = ',norm(k)
enddo
do k =1, N_states
local_norm(k) = 1.d0 / dsqrt(norm(k))
enddo
do k = 1,N_states
do i = 1, N_det
psi_coef(i,k) = psi_coef(i,k) * local_norm(k)
enddo
enddo
deallocate(index_one_hole,index_one_hole_one_p,index_two_hole_one_p,index_two_hole,index_one_p,is_a_ref_det)
deallocate(local_norm)
soft_touch psi_coef
end
@ -112,7 +101,7 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl)
implicit none
integer, intent(in) :: i_particl
double precision, intent(out) :: norm(N_states)
integer :: i,j,degree,index_ref_generators_restart(N_states),k
integer :: i,j,degree,index_ref_generators_restart,k
integer:: number_of_holes,n_h, number_of_particles,n_p
integer, allocatable :: index_one_hole(:),index_one_hole_one_p(:),index_two_hole_one_p(:),index_two_hole(:)
integer, allocatable :: index_one_p(:),index_one_hole_two_p(:)
@ -128,8 +117,6 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl)
integer :: i_count
allocate(index_one_hole(n_det),index_one_hole_one_p(n_det),index_two_hole_one_p(N_det),index_two_hole(N_det),index_one_p(N_det),is_a_ref_det(N_det))
allocate(index_one_hole_two_p(n_det))
double precision, allocatable :: local_norm(:)
allocate(local_norm(N_states))
n_one_hole = 0
n_one_hole_one_p = 0
@ -141,18 +128,16 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl)
! Find the one holes and one hole one particle
i_count = 0
is_a_ref_det = .False.
integer :: istate
do istate = 1, N_states
do i = 1, N_det
call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det(1,1,i),degree,N_int)
call get_excitation_degree(ref_generators_restart,psi_det(1,1,i),degree,N_int)
if(degree == 0)then
index_ref_generators_restart(istate) = i
inv_coef_ref_generators_restart(istate) = 1.d0/psi_coef(i,istate)
index_ref_generators_restart = i
do k = 1, N_states
inv_coef_ref_generators_restart(k) = 1.d0/psi_coef(i,k)
enddo
! cycle
endif
enddo
enddo
do i = 1, N_det
! Find all the determinants present in the reference wave function
do j = 1, N_det_generators_restart
call get_excitation_degree(psi_det(1,1,i),psi_det_generators_restart(1,1,j),degree,N_int)
@ -188,7 +173,7 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl)
do k = 1, N_states
print*,'state ',k
do i = 1, n_good_particl
print*,'psi_coef(index_good_particl,1) = ',psi_coef(index_good_particl(i),k)/psi_coef(index_ref_generators_restart(k),k)
print*,'psi_coef(index_good_particl,1) = ',psi_coef(index_good_particl(i),k)/psi_coef(index_ref_generators_restart,k)
enddo
print*,''
enddo
@ -200,29 +185,20 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl)
psi_coef(i,k) = psi_coef(i,k) * inv_coef_ref_generators_restart(k)
enddo
enddo
norm = 0.d0
do k = 1, N_states
print*,'state ',k
do i = 1, N_det
!! print*,'i = ',i, psi_coef(i,1)
if (is_a_ref_det(i))then
print*,'i,psi_coef_ref = ',psi_coef(i,k)
cycle
endif
norm(k) += psi_coef(i,k) * psi_coef(i,k)
enddo
print*,'norm = ',norm(k)
enddo
do k =1, N_states
local_norm(k) = 1.d0 / dsqrt(norm(k))
enddo
do k = 1,N_states
do i = 1, N_det
psi_coef(i,k) = psi_coef(i,k) * local_norm(k)
enddo
print*,'norm = ',norm
enddo
soft_touch psi_coef
deallocate(index_one_hole,index_one_hole_one_p,index_two_hole_one_p,index_two_hole,index_one_p,is_a_ref_det)
deallocate(local_norm)
end
@ -234,60 +210,12 @@ subroutine update_density_matrix_osoci
END_DOC
integer :: i,j
integer :: iorb,jorb
! active <--> inactive block
do i = 1, mo_tot_num
do j = 1, mo_tot_num
one_body_dm_mo_alpha_osoci(i,j) += one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j)
one_body_dm_mo_beta_osoci(i,j) += one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j)
one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j))
one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j))
enddo
enddo
!do i = 1, n_act_orb
! iorb = list_act(i)
! do j = 1, n_inact_orb
! jorb = list_inact(j)
! one_body_dm_mo_alpha_osoci(iorb,jorb)+= one_body_dm_mo_alpha_average(iorb,jorb)
! one_body_dm_mo_alpha_osoci(jorb,iorb)+= one_body_dm_mo_alpha_average(jorb,iorb)
! one_body_dm_mo_beta_osoci(iorb,jorb) += one_body_dm_mo_beta_average(iorb,jorb)
! one_body_dm_mo_beta_osoci(jorb,iorb) += one_body_dm_mo_beta_average(jorb,iorb)
! enddo
!enddo
!! active <--> virt block
!do i = 1, n_act_orb
! iorb = list_act(i)
! do j = 1, n_virt_orb
! jorb = list_virt(j)
! one_body_dm_mo_alpha_osoci(iorb,jorb)+= one_body_dm_mo_alpha_average(iorb,jorb)
! one_body_dm_mo_alpha_osoci(jorb,iorb)+= one_body_dm_mo_alpha_average(jorb,iorb)
! one_body_dm_mo_beta_osoci(iorb,jorb) += one_body_dm_mo_beta_average(iorb,jorb)
! one_body_dm_mo_beta_osoci(jorb,iorb) += one_body_dm_mo_beta_average(jorb,iorb)
! enddo
!enddo
!! virt <--> virt block
!do j = 1, n_virt_orb
! jorb = list_virt(j)
! one_body_dm_mo_alpha_osoci(jorb,jorb)+= one_body_dm_mo_alpha_average(jorb,jorb)
! one_body_dm_mo_beta_osoci(jorb,jorb) += one_body_dm_mo_beta_average(jorb,jorb)
!enddo
!! inact <--> inact block
!do j = 1, n_inact_orb
! jorb = list_inact(j)
! one_body_dm_mo_alpha_osoci(jorb,jorb) -= one_body_dm_mo_alpha_average(jorb,jorb)
! one_body_dm_mo_beta_osoci(jorb,jorb) -= one_body_dm_mo_beta_average(jorb,jorb)
!enddo
double precision :: accu_alpha, accu_beta
accu_alpha = 0.d0
accu_beta = 0.d0
do i = 1, mo_tot_num
accu_alpha += one_body_dm_mo_alpha_osoci(i,i)
accu_beta += one_body_dm_mo_beta_osoci(i,i)
! write(*,'(I3,X,100(F16.10,X))') i,one_body_dm_mo_alpha_osoci(i,i),one_body_dm_mo_beta_osoci(i,i),one_body_dm_mo_alpha_osoci(i,i)+one_body_dm_mo_beta_osoci(i,i)
enddo
print*, 'accu_alpha/beta',accu_alpha,accu_beta
end
@ -333,18 +261,8 @@ end
subroutine initialize_density_matrix_osoci
implicit none
call set_generators_to_generators_restart
call set_psi_det_to_generators
call diagonalize_CI
one_body_dm_mo_alpha_osoci = one_body_dm_mo_alpha_generators_restart
one_body_dm_mo_beta_osoci = one_body_dm_mo_beta_generators_restart
integer :: i
print*, '8*********************'
print*, 'initialize_density_matrix_osoci'
do i = 1, mo_tot_num
print*,one_body_dm_mo_alpha_osoci(i,i),one_body_dm_mo_alpha_generators_restart(i,i)
enddo
end
subroutine rescale_density_matrix_osoci(norm)
@ -520,10 +438,6 @@ subroutine save_osoci_natural_mos
endif
enddo
enddo
print*, 'test'
print*, 'test'
print*, 'test'
print*, 'test'
do i = 1, mo_tot_num
do j = i+1, mo_tot_num
if(dabs(tmp(i,j)).le.threshold_fobo_dm)then
@ -531,10 +445,8 @@ subroutine save_osoci_natural_mos
tmp(j,i) = 0.d0
endif
enddo
print*, tmp(i,i)
enddo
label = "Natural"
call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label,1)

57
plugins/FOBOCI/track_orb.irp.f
View File

@ -1,57 +0,0 @@
BEGIN_PROVIDER [ double precision, mo_coef_begin_iteration, (ao_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! Alpha and beta one-body density matrix that will be used for the 1h1p approach
END_DOC
END_PROVIDER
subroutine initialize_mo_coef_begin_iteration
implicit none
mo_coef_begin_iteration = mo_coef
end
subroutine reorder_active_orb
implicit none
integer :: i,j,iorb
integer :: k,l
double precision, allocatable :: accu(:)
integer, allocatable :: index_active_orb(:),iorder(:)
double precision, allocatable :: mo_coef_tmp(:,:)
allocate(accu(mo_tot_num),index_active_orb(n_act_orb),iorder(mo_tot_num))
allocate(mo_coef_tmp(ao_num_align,mo_Tot_num))
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, mo_tot_num
accu(j) = 0.d0
iorder(j) = j
do k = 1, ao_num
do l = 1, ao_num
accu(j) += mo_coef_begin_iteration(k,iorb) * mo_coef(l,j) * ao_overlap(k,l)
enddo
enddo
accu(j) = -dabs(accu(j))
enddo
call dsort(accu,iorder,mo_tot_num)
index_active_orb(i) = iorder(1)
enddo
double precision :: x
integer :: i1,i2
print*, 'swapping the active MOs'
do j = 1, n_act_orb
i1 = list_act(j)
i2 = index_active_orb(j)
print*, i1,i2
do i=1,ao_num_align
x = mo_coef(i,i1)
mo_coef(i,i1) = mo_coef(i,i2)
mo_coef(i,i2) = x
enddo
enddo
deallocate(accu,index_active_orb, iorder)
end

5
plugins/Full_CI/H_apply.irp.f
View File

@ -12,6 +12,11 @@ s.set_perturbation("epstein_nesbet_2x2")
s.unset_openmp()
print s
s = H_apply("FCI_PT2_new")
s.set_perturbation("decontracted")
s.unset_openmp()
print s
s = H_apply("FCI_no_skip")
s.set_selection_pt2("epstein_nesbet_2x2")

14
plugins/Full_CI_ZMQ/energy.irp.f
View File

@ -1,23 +1,11 @@
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
if (initialize_pt2_E0_denominator) then
pt2_E0_denominator(1:N_states) = psi_energy(1:N_states)
pt2_E0_denominator(1:N_states) = CI_electronic_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')
else
pt2_E0_denominator = -huge(1.d0)
endif
END_PROVIDER

137
plugins/Full_CI_ZMQ/fci_zmq.irp.f
View File

@ -68,8 +68,8 @@ program fci_zmq
call ezfio_set_full_ci_zmq_energy(CI_energy(1))
n_det_before = N_det
to_select = N_det
to_select = max(N_det, to_select)
to_select = 2*N_det
to_select = max(64-to_select, to_select)
to_select = min(to_select, N_det_max-n_det_before)
call ZMQ_selection(to_select, pt2)
@ -96,17 +96,11 @@ program fci_zmq
if(do_pt2_end)then
print*,'Last iteration only to compute the PT2'
!threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
!threshold_generators = max(threshold_generators,threshold_generators_pt2)
!TOUCH threshold_selectors threshold_generators
threshold_selectors = 1.d0
threshold_generators = 1d0
threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
threshold_generators = max(threshold_generators,threshold_generators_pt2)
TOUCH threshold_selectors threshold_generators
E_CI_before(1:N_states) = CI_energy(1:N_states)
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
call ZMQ_selection(0, pt2)
print *, 'Final step'
print *, 'N_det = ', N_det
print *, 'N_states = ', N_states
@ -125,3 +119,122 @@ 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

70
plugins/Full_CI_ZMQ/pt2_slave.irp.f
View File

@ -1,70 +0,0 @@
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

38
plugins/Full_CI_ZMQ/pt2_stoch.irp.f
View File

@ -1,38 +0,0 @@
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

579
plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f
View File

@ -1,579 +0,0 @@
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 = 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 = 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 (icount > n) then
call get_filling_teeth(computed, tbc)
icount = 0
n = ishft(tbc_save,-4)
endif
enddo
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

172
plugins/Full_CI_ZMQ/run_pt2_slave.irp.f
View File

@ -1,172 +0,0 @@
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

15
plugins/Full_CI_ZMQ/run_selection_slave.irp.f
View File

@ -26,6 +26,7 @@ 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
@ -40,8 +41,8 @@ subroutine run_selection_slave(thread,iproc,energy)
if (done) then
ctask = ctask - 1
else
integer :: i_generator, N
read(task,*) i_generator, N
integer :: i_generator, i_generator_start, i_generator_max, step, N
read (task,*) i_generator_start, i_generator_max, step, N
if(buf%N == 0) then
! Only first time
call create_selection_buffer(N, N*2, buf)
@ -49,7 +50,11 @@ subroutine run_selection_slave(thread,iproc,energy)
else
if(N /= buf%N) stop "N changed... wtf man??"
end if
call select_connected(i_generator,energy,pt2,buf,0)
!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
endif
if(done .or. ctask == size(task_id)) then
@ -110,7 +115,7 @@ subroutine push_selection_results(zmq_socket_push, pt2, b, task_id, ntask)
if(rc /= 4*ntask) stop "push"
! Activate is zmq_socket_push is a REQ
rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0)
! rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0)
end subroutine
@ -144,7 +149,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

1640
plugins/Full_CI_ZMQ/selection.irp.f
View File

File diff suppressed because it is too large Load Diff

26
plugins/Full_CI_ZMQ/selection_buffer.irp.f
View File

@ -27,7 +27,7 @@ subroutine add_to_selection_buffer(b, det, val)
if(dabs(val) >= b%mini) then
b%cur += 1
b%det(1:N_int,1:2,b%cur) = det(1:N_int,1:2)
b%det(:,:,b%cur) = det(:,:)
b%val(b%cur) = val
if(b%cur == size(b%val)) then
call sort_selection_buffer(b)
@ -41,33 +41,29 @@ subroutine sort_selection_buffer(b)
implicit none
type(selection_buffer), intent(inout) :: b
double precision, allocatable:: absval(:)
double precision, allocatable :: vals(:), absval(:)
integer, allocatable :: iorder(:)
double precision, pointer :: vals(:)
integer(bit_kind), pointer :: detmp(:,:,:)
integer(bit_kind), allocatable :: detmp(:,:,:)
integer :: i, nmwen
logical, external :: detEq
nmwen = min(b%N, b%cur)
allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3)), absval(b%cur), vals(size(b%val)))
allocate(iorder(b%cur), detmp(N_int, 2, nmwen), absval(b%cur), vals(nmwen))
absval = -dabs(b%val(:b%cur))
do i=1,b%cur
iorder(i) = i
end do
! Optimal for almost sorted data
call insertion_dsort(absval, iorder, b%cur)
call dsort(absval, iorder, b%cur)
do i=1, nmwen
detmp(1:N_int,1,i) = b%det(1:N_int,1,iorder(i))
detmp(1:N_int,2,i) = b%det(1:N_int,2,iorder(i))
detmp(:,:,i) = b%det(:,:,iorder(i))
vals(i) = b%val(iorder(i))
end do
do i=nmwen+1, size(vals)
vals(i) = 0.d0
enddo
deallocate(b%det, b%val)
b%det => detmp
b%val => vals
b%det(:,:,:nmwen) = detmp(:,:,:)
b%det(:,:,nmwen+1:) = 0_bit_kind
b%val(:nmwen) = vals(:)
b%val(nmwen+1:) = 0d0
b%mini = max(b%mini,dabs(b%val(b%N)))
b%cur = nmwen
end subroutine

59
plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f
View File

@ -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
PROVIDE pt2_e0_denominator mo_tot_num N_int fragment_count
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
end
subroutine run_wf
@ -23,19 +23,16 @@ 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(4)
character*(64) :: states(2)
integer :: rc, i
logical :: force_update
call provide_everything
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()
force_update = .True.
do
@ -55,7 +52,7 @@ subroutine run_wf
!$OMP PARALLEL PRIVATE(i)
i = omp_get_thread_num()
call run_selection_slave(0,i,energy)
call selection_slave_tcp(i, energy)
!$OMP END PARALLEL
print *, 'Selection done'
@ -65,34 +62,46 @@ subroutine run_wf
! --------
print *, 'Davidson'
call davidson_miniserver_get(force_update)
force_update = .False.
call davidson_miniserver_get()
!$OMP PARALLEL PRIVATE(i)
i = omp_get_thread_num()
call davidson_slave_tcp(i)
!$OMP END PARALLEL
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 run_pt2_slave(0,i,energy,lstop)
!$OMP END PARALLEL
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

24
plugins/Full_CI_ZMQ/selection_slave.irp.f
View File

@ -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 fragment_count
PROVIDE pt2_e0_denominator mo_tot_num N_int
end
subroutine run_wf
@ -60,6 +60,28 @@ 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

4
plugins/Full_CI_ZMQ/selection_types.f90
View File

@ -1,8 +1,8 @@
module selection_types
type selection_buffer
integer :: N, cur
integer(8) , pointer :: det(:,:,:)
double precision, pointer :: val(:)
integer(8), allocatable :: det(:,:,:)
double precision, allocatable :: val(:)
double precision :: mini
endtype
end module

109
plugins/Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f
View File

@ -1,109 +0,0 @@
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

95
plugins/Full_CI_ZMQ/target_pt2_zmq.irp.f
View File

@ -1,95 +0,0 @@
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

127
plugins/Full_CI_ZMQ/zmq_selection.irp.f
View File

@ -1,127 +0,0 @@
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
k = k+20
if (k>20*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

25
plugins/Generators_CAS/Generators_full/.gitignore vendored
View File

@ -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

1
plugins/Generators_CAS/Generators_full/NEEDED_CHILDREN_MODULES
View File

@ -1 +0,0 @@
Determinants Hartree_Fock

61
plugins/Generators_CAS/Generators_full/README.rst
View File

@ -1,61 +0,0 @@
======================
Generators_full Module
======================
All the determinants of the wave function are generators. In this way, the Full CI
space is explored.
Needed Modules
==============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
.. image:: tree_dependency.png
* `Determinants <http://github.com/LCPQ/quantum_package/tree/master/src/Determinants>`_
* `Hartree_Fock <http://github.com/LCPQ/quantum_package/tree/master/src/Hartree_Fock>`_
Needed Modules
==============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
.. image:: tree_dependency.png
* `Determinants <http://github.com/LCPQ/quantum_package/tree/master/src/Determinants>`_
* `Hartree_Fock <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock>`_
Documentation
=============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
`degree_max_generators <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L43>`_
Max degree of excitation (respect to HF) of the generators
`n_det_generators <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L3>`_
For Single reference wave functions, the number of generators is 1 : the
Hartree-Fock determinant
`psi_coef_generators <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L26>`_
For Single reference wave functions, the generator is the
Hartree-Fock determinant
`psi_det_generators <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L25>`_
For Single reference wave functions, the generator is the
Hartree-Fock determinant
`select_max <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L66>`_
Memo to skip useless selectors
`size_select_max <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L58>`_
Size of the select_max array

75
plugins/Generators_CAS/Generators_full/generators.irp.f
View File

@ -1,75 +0,0 @@
use bitmasks
BEGIN_PROVIDER [ integer, N_det_generators ]
implicit none
BEGIN_DOC
! For Single reference wave functions, the number of generators is 1 : the
! Hartree-Fock determinant
END_DOC
integer :: i
double precision :: norm
call write_time(output_determinants)
norm = 0.d0
N_det_generators = N_det
do i=1,N_det
norm = norm + psi_average_norm_contrib_sorted(i)
if (norm >= threshold_generators) then
N_det_generators = i
exit
endif
enddo
N_det_generators = max(N_det_generators,1)
call write_int(output_determinants,N_det_generators,'Number of generators')
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ]
&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ]
implicit none
BEGIN_DOC
! For Single reference wave functions, the generator is the
! Hartree-Fock determinant
END_DOC
integer :: i, k
psi_coef_generators = 0.d0
psi_det_generators = 0_bit_kind
do i=1,N_det_generators
do k=1,N_int
psi_det_generators(k,1,i) = psi_det_sorted(k,1,i)
psi_det_generators(k,2,i) = psi_det_sorted(k,2,i)
enddo
psi_coef_generators(i,:) = psi_coef_sorted(i,:)
enddo
END_PROVIDER
BEGIN_PROVIDER [integer, degree_max_generators]
implicit none
BEGIN_DOC
! Max degree of excitation (respect to HF) of the generators
END_DOC
integer :: i,degree
degree_max_generators = 0
do i = 1, N_det_generators
call get_excitation_degree(HF_bitmask,psi_det_generators(1,1,i),degree,N_int)
if(degree .gt. degree_max_generators)then
degree_max_generators = degree
endif
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer, size_select_max]
implicit none
BEGIN_DOC
! Size of the select_max array
END_DOC
size_select_max = 10000
END_PROVIDER
BEGIN_PROVIDER [ double precision, select_max, (size_select_max) ]
implicit none
BEGIN_DOC
! Memo to skip useless selectors
END_DOC
select_max = huge(1.d0)
END_PROVIDER

BIN
plugins/Generators_CAS/Generators_full/tree_dependency.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 81 KiB

16
plugins/Generators_CAS/generators.irp.f
View File

@ -9,14 +9,14 @@ BEGIN_PROVIDER [ integer, N_det_generators ]
logical :: good
call write_time(output_determinants)
N_det_generators = 0
do i=1,N_det_ref
do i=1,N_det
do l=1,n_cas_bitmask
good = .True.
do k=1,N_int
good = good .and. ( &
iand(not(cas_bitmask(k,1,l)), psi_ref(k,1,i)) == &
iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == &
iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) ) .and. ( &
iand(not(cas_bitmask(k,2,l)), psi_ref(k,2,i)) == &
iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == &
iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2)) )
enddo
if (good) then
@ -41,14 +41,14 @@ END_PROVIDER
integer :: i, k, l, m
logical :: good
m=0
do i=1,N_det_ref
do i=1,N_det
do l=1,n_cas_bitmask
good = .True.
do k=1,N_int
good = good .and. ( &
iand(not(cas_bitmask(k,1,l)), psi_ref(k,1,i)) == &
iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == &
iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) .and. ( &
iand(not(cas_bitmask(k,2,l)), psi_ref(k,2,i)) == &
iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == &
iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2) )) )
enddo
if (good) then
@ -58,8 +58,8 @@ END_PROVIDER
if (good) then
m = m+1
do k=1,N_int
psi_det_generators(k,1,m) = psi_ref(k,1,i)
psi_det_generators(k,2,m) = psi_ref(k,2,i)
psi_det_generators(k,1,m) = psi_det(k,1,i)
psi_det_generators(k,2,m) = psi_det(k,2,i)
enddo
psi_coef_generators(m,:) = psi_coef(m,:)
endif

75
plugins/Hartree_Fock/localize_mos.irp.f
View File

@ -1,75 +0,0 @@
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

34
plugins/Integrals_erf/EZFIO.cfg
View File

@ -1,34 +0,0 @@
[disk_access_ao_integrals_erf]
type: Disk_access
doc: Read/Write AO integrals with the long range interaction from/to disk [ Write | Read | None ]
interface: ezfio,provider,ocaml
default: None
[disk_access_mo_integrals_erf]
type: Disk_access
doc: Read/Write MO integrals with the long range interaction from/to disk [ Write | Read | None ]
interface: ezfio,provider,ocaml
default: None
[ao_integrals_threshold]
type: Threshold
doc: If |<pq|rs>| < ao_integrals_threshold then <pq|rs> is zero
interface: ezfio,provider,ocaml
default: 1.e-15
ezfio_name: threshold_ao
[mo_integrals_threshold]
type: Threshold
doc: If |<ij|kl>| < ao_integrals_threshold then <pq|rs> is zero
interface: ezfio,provider,ocaml
default: 1.e-15
ezfio_name: threshold_mo
[mu_erf]
type: double precision
doc: cutting of the interaction in the range separated model
interface: ezfio,provider,ocaml
default: 0.5
ezfio_name: mu_erf

1
plugins/Integrals_erf/NEEDED_CHILDREN_MODULES
View File

@ -1 +0,0 @@
Pseudo Bitmask ZMQ Integrals_Bielec

570
plugins/Integrals_erf/ao_bi_integrals_erf.irp.f
View File

@ -1,570 +0,0 @@
double precision function ao_bielec_integral_erf(i,j,k,l)
implicit none
BEGIN_DOC
! integral of the AO basis <ik|jl> or (ij|kl)
! i(r1) j(r1) 1/r12 k(r2) l(r2)
END_DOC
integer,intent(in) :: i,j,k,l
integer :: p,q,r,s
double precision :: I_center(3),J_center(3),K_center(3),L_center(3)
integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3)
double precision :: integral
include 'Utils/constants.include.F'
double precision :: P_new(0:max_dim,3),P_center(3),fact_p,pp
double precision :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq
integer :: iorder_p(3), iorder_q(3)
double precision :: ao_bielec_integral_schwartz_accel_erf
if (ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then
ao_bielec_integral_erf = ao_bielec_integral_schwartz_accel_erf(i,j,k,l)
return
endif
dim1 = n_pt_max_integrals
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
ao_bielec_integral_erf = 0.d0
if (num_i /= num_j .or. num_k /= num_l .or. num_j /= num_k)then
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
double precision :: coef1, coef2, coef3, coef4
double precision :: p_inv,q_inv
double precision :: general_primitive_integral_erf
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p,i)
do q = 1, ao_prim_num(j)
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,&
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), &
I_power,J_power,I_center,J_center,dim1)
p_inv = 1.d0/pp
do r = 1, ao_prim_num(k)
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
do s = 1, ao_prim_num(l)
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,&
ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), &
K_power,L_power,K_center,L_center,dim1)
q_inv = 1.d0/qq
integral = general_primitive_integral_erf(dim1, &
P_new,P_center,fact_p,pp,p_inv,iorder_p, &
Q_new,Q_center,fact_q,qq,q_inv,iorder_q)
ao_bielec_integral_erf = ao_bielec_integral_erf + coef4 * integral
enddo ! s
enddo ! r
enddo ! q
enddo ! p
else
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
enddo
double precision :: ERI_erf
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p,i)
do q = 1, ao_prim_num(j)
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
do r = 1, ao_prim_num(k)
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
do s = 1, ao_prim_num(l)
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
integral = ERI_erf( &
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),&
I_power(1),J_power(1),K_power(1),L_power(1), &
I_power(2),J_power(2),K_power(2),L_power(2), &
I_power(3),J_power(3),K_power(3),L_power(3))
ao_bielec_integral_erf = ao_bielec_integral_erf + coef4 * integral
enddo ! s
enddo ! r
enddo ! q
enddo ! p
endif
end
double precision function ao_bielec_integral_schwartz_accel_erf(i,j,k,l)
implicit none
BEGIN_DOC
! integral of the AO basis <ik|jl> or (ij|kl)
! i(r1) j(r1) 1/r12 k(r2) l(r2)
END_DOC
integer,intent(in) :: i,j,k,l
integer :: p,q,r,s
double precision :: I_center(3),J_center(3),K_center(3),L_center(3)
integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3)
double precision :: integral
include 'Utils/constants.include.F'
double precision :: P_new(0:max_dim,3),P_center(3),fact_p,pp
double precision :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq
integer :: iorder_p(3), iorder_q(3)
double precision, allocatable :: schwartz_kl(:,:)
double precision :: schwartz_ij
dim1 = n_pt_max_integrals
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
ao_bielec_integral_schwartz_accel_erf = 0.d0
double precision :: thr
thr = ao_integrals_threshold*ao_integrals_threshold
allocate(schwartz_kl(0:ao_prim_num(l),0:ao_prim_num(k)))
if (num_i /= num_j .or. num_k /= num_l .or. num_j /= num_k)then
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
schwartz_kl(0,0) = 0.d0
do r = 1, ao_prim_num(k)
coef1 = ao_coef_normalized_ordered_transp(r,k)*ao_coef_normalized_ordered_transp(r,k)
schwartz_kl(0,r) = 0.d0
do s = 1, ao_prim_num(l)
coef2 = coef1 * ao_coef_normalized_ordered_transp(s,l) * ao_coef_normalized_ordered_transp(s,l)
call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,&
ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), &
K_power,L_power,K_center,L_center,dim1)
q_inv = 1.d0/qq
schwartz_kl(s,r) = general_primitive_integral_erf(dim1, &
Q_new,Q_center,fact_q,qq,q_inv,iorder_q, &
Q_new,Q_center,fact_q,qq,q_inv,iorder_q) &
* coef2
schwartz_kl(0,r) = max(schwartz_kl(0,r),schwartz_kl(s,r))
enddo
schwartz_kl(0,0) = max(schwartz_kl(0,r),schwartz_kl(0,0))
enddo
do p = 1, ao_prim_num(i)
double precision :: coef1
coef1 = ao_coef_normalized_ordered_transp(p,i)
do q = 1, ao_prim_num(j)
double precision :: coef2
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
double precision :: p_inv,q_inv
call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,&
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), &
I_power,J_power,I_center,J_center,dim1)
p_inv = 1.d0/pp
schwartz_ij = general_primitive_integral_erf(dim1, &
P_new,P_center,fact_p,pp,p_inv,iorder_p, &
P_new,P_center,fact_p,pp,p_inv,iorder_p) * &
coef2*coef2
if (schwartz_kl(0,0)*schwartz_ij < thr) then
cycle
endif
do r = 1, ao_prim_num(k)
if (schwartz_kl(0,r)*schwartz_ij < thr) then
cycle
endif
double precision :: coef3
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
do s = 1, ao_prim_num(l)
double precision :: coef4
if (schwartz_kl(s,r)*schwartz_ij < thr) then
cycle
endif
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
double precision :: general_primitive_integral_erf
call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,&
ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), &
K_power,L_power,K_center,L_center,dim1)
q_inv = 1.d0/qq
integral = general_primitive_integral_erf(dim1, &
P_new,P_center,fact_p,pp,p_inv,iorder_p, &
Q_new,Q_center,fact_q,qq,q_inv,iorder_q)
ao_bielec_integral_schwartz_accel_erf = ao_bielec_integral_schwartz_accel_erf + coef4 * integral
enddo ! s
enddo ! r
enddo ! q
enddo ! p
else
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
enddo
double precision :: ERI_erf
schwartz_kl(0,0) = 0.d0
do r = 1, ao_prim_num(k)
coef1 = ao_coef_normalized_ordered_transp(r,k)*ao_coef_normalized_ordered_transp(r,k)
schwartz_kl(0,r) = 0.d0
do s = 1, ao_prim_num(l)
coef2 = coef1*ao_coef_normalized_ordered_transp(s,l)*ao_coef_normalized_ordered_transp(s,l)
schwartz_kl(s,r) = ERI_erf( &
ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),&
K_power(1),L_power(1),K_power(1),L_power(1), &
K_power(2),L_power(2),K_power(2),L_power(2), &
K_power(3),L_power(3),K_power(3),L_power(3)) * &
coef2
schwartz_kl(0,r) = max(schwartz_kl(0,r),schwartz_kl(s,r))
enddo
schwartz_kl(0,0) = max(schwartz_kl(0,r),schwartz_kl(0,0))
enddo
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p,i)
do q = 1, ao_prim_num(j)
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
schwartz_ij = ERI_erf( &
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),&
I_power(1),J_power(1),I_power(1),J_power(1), &
I_power(2),J_power(2),I_power(2),J_power(2), &
I_power(3),J_power(3),I_power(3),J_power(3))*coef2*coef2
if (schwartz_kl(0,0)*schwartz_ij < thr) then
cycle
endif
do r = 1, ao_prim_num(k)
if (schwartz_kl(0,r)*schwartz_ij < thr) then
cycle
endif
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
do s = 1, ao_prim_num(l)
if (schwartz_kl(s,r)*schwartz_ij < thr) then
cycle
endif
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
integral = ERI_erf( &
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),&
I_power(1),J_power(1),K_power(1),L_power(1), &
I_power(2),J_power(2),K_power(2),L_power(2), &
I_power(3),J_power(3),K_power(3),L_power(3))
ao_bielec_integral_schwartz_accel_erf = ao_bielec_integral_schwartz_accel_erf + coef4 * integral
enddo ! s
enddo ! r
enddo ! q
enddo ! p
endif
deallocate (schwartz_kl)
end
subroutine compute_ao_bielec_integrals_erf(j,k,l,sze,buffer_value)
implicit none
use map_module
BEGIN_DOC
! Compute AO 1/r12 integrals for all i and fixed j,k,l
END_DOC
include 'Utils/constants.include.F'
integer, intent(in) :: j,k,l,sze
real(integral_kind), intent(out) :: buffer_value(sze)
double precision :: ao_bielec_integral_erf
integer :: i
if (ao_overlap_abs(j,l) < thresh) then
buffer_value = 0._integral_kind
return
endif
if (ao_bielec_integral_erf_schwartz(j,l) < thresh ) then
buffer_value = 0._integral_kind
return
endif
do i = 1, ao_num
if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < thresh) then
buffer_value(i) = 0._integral_kind
cycle
endif
if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < thresh ) then
buffer_value(i) = 0._integral_kind
cycle
endif
!DIR$ FORCEINLINE
buffer_value(i) = ao_bielec_integral_erf(i,k,j,l)
enddo
end
double precision function general_primitive_integral_erf(dim, &
P_new,P_center,fact_p,p,p_inv,iorder_p, &
Q_new,Q_center,fact_q,q,q_inv,iorder_q)
implicit none
BEGIN_DOC
! Computes the integral <pq|rs> where p,q,r,s are Gaussian primitives
END_DOC
integer,intent(in) :: dim
include 'Utils/constants.include.F'
double precision, intent(in) :: P_new(0:max_dim,3),P_center(3),fact_p,p,p_inv
double precision, intent(in) :: Q_new(0:max_dim,3),Q_center(3),fact_q,q,q_inv
integer, intent(in) :: iorder_p(3)
integer, intent(in) :: iorder_q(3)
double precision :: r_cut,gama_r_cut,rho,dist
double precision :: dx(0:max_dim),Ix_pol(0:max_dim),dy(0:max_dim),Iy_pol(0:max_dim),dz(0:max_dim),Iz_pol(0:max_dim)
integer :: n_Ix,n_Iy,n_Iz,nx,ny,nz
double precision :: bla
integer :: ix,iy,iz,jx,jy,jz,i
double precision :: a,b,c,d,e,f,accu,pq,const
double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2,pq_inv_2
integer :: n_pt_tmp,n_pt_out, iorder
double precision :: d1(0:max_dim),d_poly(0:max_dim),rint,d1_screened(0:max_dim)
general_primitive_integral_erf = 0.d0
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx,Ix_pol,dy,Iy_pol,dz,Iz_pol
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly
! Gaussian Product
! ----------------
double precision :: p_plus_q
p_plus_q = (p+q) * ((p*q)/(p+q) + mu_erf*mu_erf)/(mu_erf*mu_erf)
pq = p_inv*0.5d0*q_inv
pq_inv = 0.5d0/p_plus_q
p10_1 = q*pq ! 1/(2p)
p01_1 = p*pq ! 1/(2q)
pq_inv_2 = pq_inv+pq_inv
p10_2 = pq_inv_2 * p10_1*q !0.5d0*q/(pq + p*p)
p01_2 = pq_inv_2 * p01_1*p !0.5d0*p/(q*q + pq)
accu = 0.d0
iorder = iorder_p(1)+iorder_q(1)+iorder_p(1)+iorder_q(1)
!DIR$ VECTOR ALIGNED
do ix=0,iorder
Ix_pol(ix) = 0.d0
enddo
n_Ix = 0
do ix = 0, iorder_p(1)
if (abs(P_new(ix,1)) < thresh) cycle
a = P_new(ix,1)
do jx = 0, iorder_q(1)
d = a*Q_new(jx,1)
if (abs(d) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x(P_center(1),Q_center(1),ix,jx,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dx,nx)
!DEC$ FORCEINLINE
call add_poly_multiply(dx,nx,d,Ix_pol,n_Ix)
enddo
enddo
if (n_Ix == -1) then
return
endif
iorder = iorder_p(2)+iorder_q(2)+iorder_p(2)+iorder_q(2)
!DIR$ VECTOR ALIGNED
do ix=0, iorder
Iy_pol(ix) = 0.d0
enddo
n_Iy = 0
do iy = 0, iorder_p(2)
if (abs(P_new(iy,2)) > thresh) then
b = P_new(iy,2)
do jy = 0, iorder_q(2)
e = b*Q_new(jy,2)
if (abs(e) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x(P_center(2),Q_center(2),iy,jy,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dy,ny)
!DEC$ FORCEINLINE
call add_poly_multiply(dy,ny,e,Iy_pol,n_Iy)
enddo
endif
enddo
if (n_Iy == -1) then
return
endif
iorder = iorder_p(3)+iorder_q(3)+iorder_p(3)+iorder_q(3)
do ix=0,iorder
Iz_pol(ix) = 0.d0
enddo
n_Iz = 0
do iz = 0, iorder_p(3)
if (abs(P_new(iz,3)) > thresh) then
c = P_new(iz,3)
do jz = 0, iorder_q(3)
f = c*Q_new(jz,3)
if (abs(f) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x(P_center(3),Q_center(3),iz,jz,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dz,nz)
!DEC$ FORCEINLINE
call add_poly_multiply(dz,nz,f,Iz_pol,n_Iz)
enddo
endif
enddo
if (n_Iz == -1) then
return
endif
rho = p*q *pq_inv_2 ! le rho qui va bien
dist = (P_center(1) - Q_center(1))*(P_center(1) - Q_center(1)) + &
(P_center(2) - Q_center(2))*(P_center(2) - Q_center(2)) + &
(P_center(3) - Q_center(3))*(P_center(3) - Q_center(3))
const = dist*rho
n_pt_tmp = n_Ix+n_Iy
do i=0,n_pt_tmp
d_poly(i)=0.d0
enddo
!DEC$ FORCEINLINE
call multiply_poly(Ix_pol,n_Ix,Iy_pol,n_Iy,d_poly,n_pt_tmp)
if (n_pt_tmp == -1) then
return
endif
n_pt_out = n_pt_tmp+n_Iz
do i=0,n_pt_out
d1(i)=0.d0
enddo
!DEC$ FORCEINLINE
call multiply_poly(d_poly ,n_pt_tmp ,Iz_pol,n_Iz,d1,n_pt_out)
double precision :: rint_sum
accu = accu + rint_sum(n_pt_out,const,d1)
! change p+q in dsqrt
general_primitive_integral_erf = fact_p * fact_q * accu *pi_5_2*p_inv*q_inv/dsqrt(p_plus_q)
end
double precision function ERI_erf(alpha,beta,delta,gama,a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z)
implicit none
BEGIN_DOC
! ATOMIC PRIMTIVE bielectronic integral between the 4 primitives ::
! primitive_1 = x1**(a_x) y1**(a_y) z1**(a_z) exp(-alpha * r1**2)
! primitive_2 = x1**(b_x) y1**(b_y) z1**(b_z) exp(- beta * r1**2)
! primitive_3 = x2**(c_x) y2**(c_y) z2**(c_z) exp(-delta * r2**2)
! primitive_4 = x2**(d_x) y2**(d_y) z2**(d_z) exp(- gama * r2**2)
END_DOC
double precision, intent(in) :: delta,gama,alpha,beta
integer, intent(in) :: a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z
integer :: a_x_2,b_x_2,c_x_2,d_x_2,a_y_2,b_y_2,c_y_2,d_y_2,a_z_2,b_z_2,c_z_2,d_z_2
integer :: i,j,k,l,n_pt
integer :: n_pt_sup
double precision :: p,q,denom,coeff
double precision :: I_f
integer :: nx,ny,nz
include 'Utils/constants.include.F'
nx = a_x+b_x+c_x+d_x
if(iand(nx,1) == 1) then
ERI_erf = 0.d0
return
endif
ny = a_y+b_y+c_y+d_y
if(iand(ny,1) == 1) then
ERI_erf = 0.d0
return
endif
nz = a_z+b_z+c_z+d_z
if(iand(nz,1) == 1) then
ERI_erf = 0.d0
return
endif
ASSERT (alpha >= 0.d0)
ASSERT (beta >= 0.d0)
ASSERT (delta >= 0.d0)
ASSERT (gama >= 0.d0)
p = alpha + beta
q = delta + gama
double precision :: p_plus_q
p_plus_q = (p+q) * ((p*q)/(p+q) + mu_erf*mu_erf)/(mu_erf*mu_erf)
ASSERT (p+q >= 0.d0)
n_pt = ishft( nx+ny+nz,1 )
coeff = pi_5_2 / (p * q * dsqrt(p_plus_q))
if (n_pt == 0) then
ERI_erf = coeff
return
endif
call integrale_new(I_f,a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z,p,q,n_pt)
ERI_erf = I_f * coeff
end
subroutine compute_ao_integrals_erf_jl(j,l,n_integrals,buffer_i,buffer_value)
implicit none
use map_module
BEGIN_DOC
! Parallel client for AO integrals
END_DOC
integer, intent(in) :: j,l
integer,intent(out) :: n_integrals
integer(key_kind),intent(out) :: buffer_i(ao_num*ao_num)
real(integral_kind),intent(out) :: buffer_value(ao_num*ao_num)
integer :: i,k
double precision :: ao_bielec_integral_erf,cpu_1,cpu_2, wall_1, wall_2
double precision :: integral, wall_0
double precision :: thr
integer :: kk, m, j1, i1
thr = ao_integrals_threshold
n_integrals = 0
j1 = j+ishft(l*l-l,-1)
do k = 1, ao_num ! r1
i1 = ishft(k*k-k,-1)
if (i1 > j1) then
exit
endif
do i = 1, k
i1 += 1
if (i1 > j1) then
exit
endif
if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < thr) then
cycle
endif
if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < thr ) then
cycle
endif
!DIR$ FORCEINLINE
integral = ao_bielec_integral_erf(i,k,j,l) ! i,k : r1 j,l : r2
if (abs(integral) < thr) then
cycle
endif
n_integrals += 1
!DIR$ FORCEINLINE
call bielec_integrals_index(i,j,k,l,buffer_i(n_integrals))
buffer_value(n_integrals) = integral
enddo
enddo
end

175
plugins/Integrals_erf/ao_bielec_integrals_erf_in_map_slave.irp.f
View File

@ -1,175 +0,0 @@
subroutine ao_bielec_integrals_erf_in_map_slave_tcp(i)
implicit none
integer, intent(in) :: i
BEGIN_DOC
! Computes a buffer of integrals. i is the ID of the current thread.
END_DOC
call ao_bielec_integrals_erf_in_map_slave(0,i)
end
subroutine ao_bielec_integrals_erf_in_map_slave_inproc(i)
implicit none
integer, intent(in) :: i
BEGIN_DOC
! Computes a buffer of integrals. i is the ID of the current thread.
END_DOC
call ao_bielec_integrals_erf_in_map_slave(1,i)
end
subroutine ao_bielec_integrals_erf_in_map_slave(thread,iproc)
use map_module
use f77_zmq
implicit none
BEGIN_DOC
! Computes a buffer of integrals
END_DOC
integer, intent(in) :: thread, iproc
integer :: j,l,n_integrals
integer :: rc
real(integral_kind), allocatable :: buffer_value(:)
integer(key_kind), allocatable :: buffer_i(:)
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
character*(64) :: state
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
zmq_socket_push = new_zmq_push_socket(thread)
allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) )
call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
do
call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task)
if (task_id == 0) exit
read(task,*) j, l
call compute_ao_integrals_erf_jl(j,l,n_integrals,buffer_i,buffer_value)
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id)
call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id)
enddo
call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
deallocate( buffer_i, buffer_value )
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread)
end
subroutine ao_bielec_integrals_erf_in_map_collector
use map_module
use f77_zmq
implicit none
BEGIN_DOC
! Collects results from the AO integral calculation
END_DOC
integer :: j,l,n_integrals
integer :: rc
real(integral_kind), allocatable :: buffer_value(:)
integer(key_kind), allocatable :: buffer_i(:)
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, sze
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
zmq_socket_pull = new_zmq_pull_socket()
sze = ao_num*ao_num
allocate ( buffer_i(sze), buffer_value(sze) )
accu = 0_8
more = 1
do while (more == 1)
rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)
if (rc == -1) then
n_integrals = 0
return
endif
if (rc /= 4) then
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)'
stop 'error'
endif
if (n_integrals >= 0) then
if (n_integrals > sze) then
deallocate (buffer_value, buffer_i)
sze = n_integrals
allocate (buffer_value(sze), buffer_i(sze))
endif
rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)
if (rc /= key_kind*n_integrals) then
print *, rc, key_kind, n_integrals
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)
if (rc /= integral_kind*n_integrals) then
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)'
stop 'error'
endif
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
call insert_into_ao_integrals_erf_map(n_integrals,buffer_i,buffer_value)
accu += n_integrals
if (task_id /= 0) then
call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more)
endif
endif
enddo
deallocate( buffer_i, buffer_value )
integer (map_size_kind) :: get_ao_erf_map_size
control = get_ao_erf_map_size(ao_integrals_erf_map)
if (control /= accu) then
print *, ''
print *, irp_here
print *, 'Control : ', control
print *, 'Accu : ', accu
print *, 'Some integrals were lost during the parallel computation.'
print *, 'Try to reduce the number of threads.'
stop
endif
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_pull_socket(zmq_socket_pull)
end

22
plugins/Integrals_erf/integrals_3_index_erf.irp.f
View File

@ -1,22 +0,0 @@
BEGIN_PROVIDER [double precision, big_array_coulomb_integrals_erf, (mo_tot_num_align,mo_tot_num, mo_tot_num)]
&BEGIN_PROVIDER [double precision, big_array_exchange_integrals_erf,(mo_tot_num_align,mo_tot_num, mo_tot_num)]
implicit none
integer :: i,j,k,l
double precision :: get_mo_bielec_integral_erf
double precision :: integral
do k = 1, mo_tot_num
do i = 1, mo_tot_num
do j = 1, mo_tot_num
l = j
integral = get_mo_bielec_integral_erf(i,j,k,l,mo_integrals_erf_map)
big_array_coulomb_integrals_erf(j,i,k) = integral
l = j
integral = get_mo_bielec_integral_erf(i,j,l,k,mo_integrals_erf_map)
big_array_exchange_integrals_erf(j,i,k) = integral
enddo
enddo
enddo
END_PROVIDER

626
plugins/Integrals_erf/map_integrals_erf.irp.f
View File

@ -1,626 +0,0 @@
use map_module
!! AO Map
!! ======
BEGIN_PROVIDER [ type(map_type), ao_integrals_erf_map ]
implicit none
BEGIN_DOC
! AO integrals
END_DOC
integer(key_kind) :: key_max
integer(map_size_kind) :: sze
call bielec_integrals_index(ao_num,ao_num,ao_num,ao_num,key_max)
sze = key_max
call map_init(ao_integrals_erf_map,sze)
print*, 'AO map initialized : ', sze
END_PROVIDER
BEGIN_PROVIDER [ integer, ao_integrals_erf_cache_min ]
&BEGIN_PROVIDER [ integer, ao_integrals_erf_cache_max ]
implicit none
BEGIN_DOC
! Min and max values of the AOs for which the integrals are in the cache
END_DOC
ao_integrals_erf_cache_min = max(1,ao_num - 63)
ao_integrals_erf_cache_max = ao_num
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_integrals_erf_cache, (0:64*64*64*64) ]
use map_module
implicit none
BEGIN_DOC
! Cache of AO integrals for fast access
END_DOC
PROVIDE ao_bielec_integrals_erf_in_map
integer :: i,j,k,l,ii
integer(key_kind) :: idx
real(integral_kind) :: integral
!$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral)
do l=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max
do k=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max
do j=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max
do i=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max
!DIR$ FORCEINLINE
call bielec_integrals_index(i,j,k,l,idx)
!DIR$ FORCEINLINE
call map_get(ao_integrals_erf_map,idx,integral)
ii = l-ao_integrals_erf_cache_min
ii = ior( ishft(ii,6), k-ao_integrals_erf_cache_min)
ii = ior( ishft(ii,6), j-ao_integrals_erf_cache_min)
ii = ior( ishft(ii,6), i-ao_integrals_erf_cache_min)
ao_integrals_erf_cache(ii) = integral
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
END_PROVIDER
double precision function get_ao_bielec_integral_erf(i,j,k,l,map) result(result)
use map_module
implicit none
BEGIN_DOC
! Gets one AO bi-electronic integral from the AO map
END_DOC
integer, intent(in) :: i,j,k,l
integer(key_kind) :: idx
type(map_type), intent(inout) :: map
integer :: ii
real(integral_kind) :: tmp
PROVIDE ao_bielec_integrals_erf_in_map ao_integrals_erf_cache ao_integrals_erf_cache_min
!DIR$ FORCEINLINE
if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < ao_integrals_threshold ) then
tmp = 0.d0
else if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < ao_integrals_threshold) then
tmp = 0.d0
else
ii = l-ao_integrals_erf_cache_min
ii = ior(ii, k-ao_integrals_erf_cache_min)
ii = ior(ii, j-ao_integrals_erf_cache_min)
ii = ior(ii, i-ao_integrals_erf_cache_min)
if (iand(ii, -64) /= 0) then
!DIR$ FORCEINLINE
call bielec_integrals_index(i,j,k,l,idx)
!DIR$ FORCEINLINE
call map_get(map,idx,tmp)
tmp = tmp
else
ii = l-ao_integrals_erf_cache_min
ii = ior( ishft(ii,6), k-ao_integrals_erf_cache_min)
ii = ior( ishft(ii,6), j-ao_integrals_erf_cache_min)
ii = ior( ishft(ii,6), i-ao_integrals_erf_cache_min)
tmp = ao_integrals_erf_cache(ii)
endif
endif
result = tmp
end
subroutine get_ao_bielec_integrals_erf(j,k,l,sze,out_val)
use map_module
BEGIN_DOC
! Gets multiple AO bi-electronic integral from the AO map .
! All i are retrieved for j,k,l fixed.
END_DOC
implicit none
integer, intent(in) :: j,k,l, sze
real(integral_kind), intent(out) :: out_val(sze)
integer :: i
integer(key_kind) :: hash
double precision :: thresh
PROVIDE ao_bielec_integrals_erf_in_map ao_integrals_erf_map
thresh = ao_integrals_threshold
if (ao_overlap_abs(j,l) < thresh) then
out_val = 0.d0
return
endif
double precision :: get_ao_bielec_integral_erf
do i=1,sze
out_val(i) = get_ao_bielec_integral_erf(i,j,k,l,ao_integrals_erf_map)
enddo
end
subroutine get_ao_bielec_integrals_erf_non_zero(j,k,l,sze,out_val,out_val_index,non_zero_int)
use map_module
implicit none
BEGIN_DOC
! Gets multiple AO bi-electronic integral from the AO map .
! All non-zero i are retrieved for j,k,l fixed.
END_DOC
integer, intent(in) :: j,k,l, sze
real(integral_kind), intent(out) :: out_val(sze)
integer, intent(out) :: out_val_index(sze),non_zero_int
integer :: i
integer(key_kind) :: hash
double precision :: thresh,tmp
PROVIDE ao_bielec_integrals_erf_in_map
thresh = ao_integrals_threshold
non_zero_int = 0
if (ao_overlap_abs(j,l) < thresh) then
out_val = 0.d0
return
endif
non_zero_int = 0
do i=1,sze
integer, external :: ao_l4
double precision, external :: ao_bielec_integral_erf
!DIR$ FORCEINLINE
if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < thresh) then
cycle
endif
call bielec_integrals_index(i,j,k,l,hash)
call map_get(ao_integrals_erf_map, hash,tmp)
if (dabs(tmp) < thresh ) cycle
non_zero_int = non_zero_int+1
out_val_index(non_zero_int) = i
out_val(non_zero_int) = tmp
enddo
end
function get_ao_erf_map_size()
implicit none
integer (map_size_kind) :: get_ao_erf_map_size
BEGIN_DOC
! Returns the number of elements in the AO map
END_DOC
get_ao_erf_map_size = ao_integrals_erf_map % n_elements
end
subroutine clear_ao_erf_map
implicit none
BEGIN_DOC
! Frees the memory of the AO map
END_DOC
call map_deinit(ao_integrals_erf_map)
FREE ao_integrals_erf_map
end
BEGIN_TEMPLATE
subroutine dump_$ao_integrals(filename)
use map_module
implicit none
BEGIN_DOC
! Save to disk the $ao integrals
END_DOC
character*(*), intent(in) :: filename
integer(cache_key_kind), pointer :: key(:)
real(integral_kind), pointer :: val(:)
integer*8 :: i,j, n
call ezfio_set_work_empty(.False.)
open(unit=66,file=filename,FORM='unformatted')
write(66) integral_kind, key_kind
write(66) $ao_integrals_map%sorted, $ao_integrals_map%map_size, &
$ao_integrals_map%n_elements
do i=0_8,$ao_integrals_map%map_size
write(66) $ao_integrals_map%map(i)%sorted, $ao_integrals_map%map(i)%map_size,&
$ao_integrals_map%map(i)%n_elements
enddo
do i=0_8,$ao_integrals_map%map_size
key => $ao_integrals_map%map(i)%key
val => $ao_integrals_map%map(i)%value
n = $ao_integrals_map%map(i)%n_elements
write(66) (key(j), j=1,n), (val(j), j=1,n)
enddo
close(66)
end
IRP_IF COARRAY
subroutine communicate_$ao_integrals()
use map_module
implicit none
BEGIN_DOC
! Communicate the $ao integrals with co-array
END_DOC
integer(cache_key_kind), pointer :: key(:)
real(integral_kind), pointer :: val(:)
integer*8 :: i,j, k, nmax
integer*8, save :: n[*]
integer :: copy_n
real(integral_kind), allocatable :: buffer_val(:)[:]
integer(cache_key_kind), allocatable :: buffer_key(:)[:]
real(integral_kind), allocatable :: copy_val(:)
integer(key_kind), allocatable :: copy_key(:)
n = 0_8
do i=0_8,$ao_integrals_map%map_size
n = max(n,$ao_integrals_map%map(i)%n_elements)
enddo
sync all
nmax = 0_8
do j=1,num_images()
nmax = max(nmax,n[j])
enddo
allocate( buffer_key(nmax)[*], buffer_val(nmax)[*])
allocate( copy_key(nmax), copy_val(nmax))
do i=0_8,$ao_integrals_map%map_size
key => $ao_integrals_map%map(i)%key
val => $ao_integrals_map%map(i)%value
n = $ao_integrals_map%map(i)%n_elements
do j=1,n
buffer_key(j) = key(j)
buffer_val(j) = val(j)
enddo
sync all
do j=1,num_images()
if (j /= this_image()) then
copy_n = n[j]
do k=1,copy_n
copy_val(k) = buffer_val(k)[j]
copy_key(k) = buffer_key(k)[j]
copy_key(k) = copy_key(k)+ishft(i,-map_shift)
enddo
call map_append($ao_integrals_map, copy_key, copy_val, copy_n )
endif
enddo
sync all
enddo
deallocate( buffer_key, buffer_val, copy_val, copy_key)
end
IRP_ENDIF
integer function load_$ao_integrals(filename)
implicit none
BEGIN_DOC
! Read from disk the $ao integrals
END_DOC
character*(*), intent(in) :: filename
integer*8 :: i
integer(cache_key_kind), pointer :: key(:)
real(integral_kind), pointer :: val(:)
integer :: iknd, kknd
integer*8 :: n, j
load_$ao_integrals = 1
open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN')
read(66,err=98,end=98) iknd, kknd
if (iknd /= integral_kind) then
print *, 'Wrong integrals kind in file :', iknd
stop 1
endif
if (kknd /= key_kind) then
print *, 'Wrong key kind in file :', kknd
stop 1
endif
read(66,err=98,end=98) $ao_integrals_map%sorted, $ao_integrals_map%map_size,&
$ao_integrals_map%n_elements
do i=0_8, $ao_integrals_map%map_size
read(66,err=99,end=99) $ao_integrals_map%map(i)%sorted, &
$ao_integrals_map%map(i)%map_size, $ao_integrals_map%map(i)%n_elements
call cache_map_reallocate($ao_integrals_map%map(i),$ao_integrals_map%map(i)%map_size)
enddo
do i=0_8, $ao_integrals_map%map_size
key => $ao_integrals_map%map(i)%key
val => $ao_integrals_map%map(i)%value
n = $ao_integrals_map%map(i)%n_elements
read(66,err=99,end=99) (key(j), j=1,n), (val(j), j=1,n)
enddo
call map_sort($ao_integrals_map)
load_$ao_integrals = 0
return
99 continue
call map_deinit($ao_integrals_map)
98 continue
stop 'Problem reading $ao_integrals_map file in work/'
end
SUBST [ ao_integrals_map, ao_integrals, ao_num ]
ao_integrals_erf_map ; ao_integrals_erf ; ao_num ;;
mo_integrals_erf_map ; mo_integrals_erf ; mo_tot_num;;
END_TEMPLATE
BEGIN_PROVIDER [ type(map_type), mo_integrals_erf_map ]
implicit none
BEGIN_DOC
! MO integrals
END_DOC
integer(key_kind) :: key_max
integer(map_size_kind) :: sze
call bielec_integrals_index(mo_tot_num,mo_tot_num,mo_tot_num,mo_tot_num,key_max)
sze = key_max
call map_init(mo_integrals_erf_map,sze)
print*, 'MO map initialized'
END_PROVIDER
subroutine insert_into_ao_integrals_erf_map(n_integrals,buffer_i, buffer_values)
use map_module
implicit none
BEGIN_DOC
! Create new entry into AO map
END_DOC
integer, intent(in) :: n_integrals
integer(key_kind), intent(inout) :: buffer_i(n_integrals)
real(integral_kind), intent(inout) :: buffer_values(n_integrals)
call map_append(ao_integrals_erf_map, buffer_i, buffer_values, n_integrals)
end
subroutine insert_into_mo_integrals_erf_map(n_integrals, &
buffer_i, buffer_values, thr)
use map_module
implicit none
BEGIN_DOC
! Create new entry into MO map, or accumulate in an existing entry
END_DOC
integer, intent(in) :: n_integrals
integer(key_kind), intent(inout) :: buffer_i(n_integrals)
real(integral_kind), intent(inout) :: buffer_values(n_integrals)
real(integral_kind), intent(in) :: thr
call map_update(mo_integrals_erf_map, buffer_i, buffer_values, n_integrals, thr)
end
BEGIN_PROVIDER [ integer, mo_integrals_erf_cache_min ]
&BEGIN_PROVIDER [ integer, mo_integrals_erf_cache_max ]
implicit none
BEGIN_DOC
! Min and max values of the MOs for which the integrals are in the cache
END_DOC
mo_integrals_erf_cache_min = max(1,elec_alpha_num - 31)
mo_integrals_erf_cache_max = min(mo_tot_num,mo_integrals_erf_cache_min+63)
END_PROVIDER
BEGIN_PROVIDER [ double precision, mo_integrals_erf_cache, (0:64*64*64*64) ]
implicit none
BEGIN_DOC
! Cache of MO integrals for fast access
END_DOC
PROVIDE mo_bielec_integrals_erf_in_map
integer :: i,j,k,l
integer :: ii
integer(key_kind) :: idx
real(integral_kind) :: integral
FREE ao_integrals_erf_cache
!$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral)
do l=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max
do k=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max
do j=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max
do i=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max
!DIR$ FORCEINLINE
call bielec_integrals_index(i,j,k,l,idx)
!DIR$ FORCEINLINE
call map_get(mo_integrals_erf_map,idx,integral)
ii = l-mo_integrals_erf_cache_min
ii = ior( ishft(ii,6), k-mo_integrals_erf_cache_min)
ii = ior( ishft(ii,6), j-mo_integrals_erf_cache_min)
ii = ior( ishft(ii,6), i-mo_integrals_erf_cache_min)
mo_integrals_erf_cache(ii) = integral
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
END_PROVIDER
double precision function get_mo_bielec_integral_erf(i,j,k,l,map)
use map_module
implicit none
BEGIN_DOC
! Returns one integral <ij|kl> in the MO basis
END_DOC
integer, intent(in) :: i,j,k,l
integer(key_kind) :: idx
integer :: ii
type(map_type), intent(inout) :: map
real(integral_kind) :: tmp
PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_cache
ii = l-mo_integrals_erf_cache_min
ii = ior(ii, k-mo_integrals_erf_cache_min)
ii = ior(ii, j-mo_integrals_erf_cache_min)
ii = ior(ii, i-mo_integrals_erf_cache_min)
if (iand(ii, -64) /= 0) then
!DIR$ FORCEINLINE
call bielec_integrals_index(i,j,k,l,idx)
!DIR$ FORCEINLINE
call map_get(map,idx,tmp)
get_mo_bielec_integral_erf = dble(tmp)
else
ii = l-mo_integrals_erf_cache_min
ii = ior( ishft(ii,6), k-mo_integrals_erf_cache_min)
ii = ior( ishft(ii,6), j-mo_integrals_erf_cache_min)
ii = ior( ishft(ii,6), i-mo_integrals_erf_cache_min)
get_mo_bielec_integral_erf = mo_integrals_erf_cache(ii)
endif
end
double precision function mo_bielec_integral_erf(i,j,k,l)
implicit none
BEGIN_DOC
! Returns one integral <ij|kl> in the MO basis
END_DOC
integer, intent(in) :: i,j,k,l
double precision :: get_mo_bielec_integral_erf
PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_cache
!DIR$ FORCEINLINE
PROVIDE mo_bielec_integrals_erf_in_map
mo_bielec_integral_erf = get_mo_bielec_integral_erf(i,j,k,l,mo_integrals_erf_map)
return
end
subroutine get_mo_bielec_integrals_erf(j,k,l,sze,out_val,map)
use map_module
implicit none
BEGIN_DOC
! Returns multiple integrals <ij|kl> in the MO basis, all
! i for j,k,l fixed.
END_DOC
integer, intent(in) :: j,k,l, sze
double precision, intent(out) :: out_val(sze)
type(map_type), intent(inout) :: map
integer :: i
integer(key_kind) :: hash(sze)
real(integral_kind) :: tmp_val(sze)
PROVIDE mo_bielec_integrals_erf_in_map
do i=1,sze
!DIR$ FORCEINLINE
call bielec_integrals_index(i,j,k,l,hash(i))
enddo
if (key_kind == 8) then
call map_get_many(map, hash, out_val, sze)
else
call map_get_many(map, hash, tmp_val, sze)
! Conversion to double precision
do i=1,sze
out_val(i) = dble(tmp_val(i))
enddo
endif
end
subroutine get_mo_bielec_integrals_erf_ij(k,l,sze,out_array,map)
use map_module
implicit none
BEGIN_DOC
! Returns multiple integrals <ij|kl> in the MO basis, all
! i(1)j(2) 1/r12 k(1)l(2)
! i, j for k,l fixed.
END_DOC
integer, intent(in) :: k,l, sze
double precision, intent(out) :: out_array(sze,sze)
type(map_type), intent(inout) :: map
integer :: i,j,kk,ll,m
integer(key_kind),allocatable :: hash(:)
integer ,allocatable :: pairs(:,:), iorder(:)
real(integral_kind), allocatable :: tmp_val(:)
PROVIDE mo_bielec_integrals_erf_in_map
allocate (hash(sze*sze), pairs(2,sze*sze),iorder(sze*sze), &
tmp_val(sze*sze))
kk=0
out_array = 0.d0
do j=1,sze
do i=1,sze
kk += 1
!DIR$ FORCEINLINE
call bielec_integrals_index(i,j,k,l,hash(kk))
pairs(1,kk) = i
pairs(2,kk) = j
iorder(kk) = kk
enddo
enddo
logical :: integral_is_in_map
if (key_kind == 8) then
call i8radix_sort(hash,iorder,kk,-1)
else if (key_kind == 4) then
call iradix_sort(hash,iorder,kk,-1)
else if (key_kind == 2) then
call i2radix_sort(hash,iorder,kk,-1)
endif
call map_get_many(mo_integrals_erf_map, hash, tmp_val, kk)
do ll=1,kk
m = iorder(ll)
i=pairs(1,m)
j=pairs(2,m)
out_array(i,j) = tmp_val(ll)
enddo
deallocate(pairs,hash,iorder,tmp_val)
end
subroutine get_mo_bielec_integrals_erf_coulomb_ii(k,l,sze,out_val,map)
use map_module
implicit none
BEGIN_DOC
! Returns multiple integrals <ki|li>
! k(1)i(2) 1/r12 l(1)i(2) :: out_val(i1)
! for k,l fixed.
END_DOC
integer, intent(in) :: k,l, sze
double precision, intent(out) :: out_val(sze)
type(map_type), intent(inout) :: map
integer :: i
integer(key_kind) :: hash(sze)
real(integral_kind) :: tmp_val(sze)
PROVIDE mo_bielec_integrals_erf_in_map
integer :: kk
do i=1,sze
!DIR$ FORCEINLINE
call bielec_integrals_index(k,i,l,i,hash(i))
enddo
if (key_kind == 8) then
call map_get_many(map, hash, out_val, sze)
else
call map_get_many(map, hash, tmp_val, sze)
! Conversion to double precision
do i=1,sze
out_val(i) = dble(tmp_val(i))
enddo
endif
end
subroutine get_mo_bielec_integrals_erf_exch_ii(k,l,sze,out_val,map)
use map_module
implicit none
BEGIN_DOC
! Returns multiple integrals <ki|il>
! k(1)i(2) 1/r12 i(1)l(2) :: out_val(i1)
! for k,l fixed.
END_DOC
integer, intent(in) :: k,l, sze
double precision, intent(out) :: out_val(sze)
type(map_type), intent(inout) :: map
integer :: i
integer(key_kind) :: hash(sze)
real(integral_kind) :: tmp_val(sze)
PROVIDE mo_bielec_integrals_erf_in_map
integer :: kk
do i=1,sze
!DIR$ FORCEINLINE
call bielec_integrals_index(k,i,i,l,hash(i))
enddo
if (key_kind == 8) then
call map_get_many(map, hash, out_val, sze)
else
call map_get_many(map, hash, tmp_val, sze)
! Conversion to double precision
do i=1,sze
out_val(i) = dble(tmp_val(i))
enddo
endif
end
integer*8 function get_mo_erf_map_size()
implicit none
BEGIN_DOC
! Return the number of elements in the MO map
END_DOC
get_mo_erf_map_size = mo_integrals_erf_map % n_elements
end

616
plugins/Integrals_erf/mo_bi_integrals_erf.irp.f
View File

@ -1,616 +0,0 @@
subroutine mo_bielec_integrals_erf_index(i,j,k,l,i1)
use map_module
implicit none
BEGIN_DOC
! Computes an unique index for i,j,k,l integrals
END_DOC
integer, intent(in) :: i,j,k,l
integer(key_kind), intent(out) :: i1
integer(key_kind) :: p,q,r,s,i2
p = min(i,k)
r = max(i,k)
p = p+ishft(r*r-r,-1)
q = min(j,l)
s = max(j,l)
q = q+ishft(s*s-s,-1)
i1 = min(p,q)
i2 = max(p,q)
i1 = i1+ishft(i2*i2-i2,-1)
end
BEGIN_PROVIDER [ logical, mo_bielec_integrals_erf_in_map ]
use map_module
implicit none
integer(bit_kind) :: mask_ijkl(N_int,4)
integer(bit_kind) :: mask_ijk(N_int,3)
BEGIN_DOC
! If True, the map of MO bielectronic integrals is provided
END_DOC
mo_bielec_integrals_erf_in_map = .True.
if (read_mo_integrals_erf) then
print*,'Reading the MO integrals_erf'
call map_load_from_disk(trim(ezfio_filename)//'/work/mo_ints_erf',mo_integrals_erf_map)
print*, 'MO integrals_erf provided'
return
else
PROVIDE ao_bielec_integrals_erf_in_map
endif
!if(no_vvvv_integrals)then
! integer :: i,j,k,l
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I I !!!!!!!!!!!!!!!!!!!!
! ! (core+inact+act) ^ 4
! ! <ii|ii>
! print*, ''
! print*, '<ii|ii>'
! do i = 1,N_int
! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,4) = core_inact_act_bitmask_4(i,1)
! enddo
! call add_integrals_to_map(mask_ijkl)
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I V V !!!!!!!!!!!!!!!!!!!!
! ! (core+inact+act) ^ 2 (virt) ^2
! ! <iv|iv> = J_iv
! print*, ''
! print*, '<iv|iv>'
! do i = 1,N_int
! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,2) = virt_bitmask(i,1)
! mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,4) = virt_bitmask(i,1)
! enddo
! call add_integrals_to_map(mask_ijkl)
!
! ! (core+inact+act) ^ 2 (virt) ^2
! ! <ii|vv> = (iv|iv)
! print*, ''
! print*, '<ii|vv>'
! do i = 1,N_int
! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,3) = virt_bitmask(i,1)
! mask_ijkl(i,4) = virt_bitmask(i,1)
! enddo
! call add_integrals_to_map(mask_ijkl)
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! V V V !!!!!!!!!!!!!!!!!!!!!!!
! if(.not.no_vvv_integrals)then
! print*, ''
! print*, '<rv|sv> and <rv|vs>'
! do i = 1,N_int
! mask_ijk(i,1) = virt_bitmask(i,1)
! mask_ijk(i,2) = virt_bitmask(i,1)
! mask_ijk(i,3) = virt_bitmask(i,1)
! enddo
! call add_integrals_to_map_three_indices(mask_ijk)
! endif
!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I V !!!!!!!!!!!!!!!!!!!!
! ! (core+inact+act) ^ 3 (virt) ^1
! ! <iv|ii>
! print*, ''
! print*, '<iv|ii>'
! do i = 1,N_int
! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,4) = virt_bitmask(i,1)
! enddo
! call add_integrals_to_map(mask_ijkl)
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I V V V !!!!!!!!!!!!!!!!!!!!
! ! (core+inact+act) ^ 1 (virt) ^3
! ! <iv|vv>
! if(.not.no_ivvv_integrals)then
! print*, ''
! print*, '<iv|vv>'
! do i = 1,N_int
! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,2) = virt_bitmask(i,1)
! mask_ijkl(i,3) = virt_bitmask(i,1)
! mask_ijkl(i,4) = virt_bitmask(i,1)
! enddo
! call add_integrals_to_map_no_exit_34(mask_ijkl)
! endif
!
!else
call add_integrals_erf_to_map(full_ijkl_bitmask_4)
!endif
if (write_mo_integrals_erf) then
call ezfio_set_work_empty(.False.)
call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints_erf',mo_integrals_erf_map)
call ezfio_set_integrals_erf_disk_access_mo_integrals_erf("Read")
endif
END_PROVIDER
subroutine add_integrals_erf_to_map(mask_ijkl)
use bitmasks
implicit none
BEGIN_DOC
! Adds integrals to tha MO map according to some bitmask
END_DOC
integer(bit_kind), intent(in) :: mask_ijkl(N_int,4)
integer :: i,j,k,l
integer :: i0,j0,k0,l0
double precision :: c, cpu_1, cpu_2, wall_1, wall_2, wall_0
integer, allocatable :: list_ijkl(:,:)
integer :: n_i, n_j, n_k, n_l
integer, allocatable :: bielec_tmp_0_idx(:)
real(integral_kind), allocatable :: bielec_tmp_0(:,:)
double precision, allocatable :: bielec_tmp_1(:)
double precision, allocatable :: bielec_tmp_2(:,:)
double precision, allocatable :: bielec_tmp_3(:,:,:)
!DEC$ ATTRIBUTES ALIGN : 64 :: bielec_tmp_1, bielec_tmp_2, bielec_tmp_3
integer :: n_integrals
integer :: size_buffer
integer(key_kind),allocatable :: buffer_i(:)
real(integral_kind),allocatable :: buffer_value(:)
real :: map_mb
integer :: i1,j1,k1,l1, ii1, kmax, thread_num
integer :: i2,i3,i4
double precision,parameter :: thr_coef = 1.d-10
PROVIDE ao_bielec_integrals_erf_in_map mo_coef
!Get list of MOs for i,j,k and l
!-------------------------------
allocate(list_ijkl(mo_tot_num,4))
call bitstring_to_list( mask_ijkl(1,1), list_ijkl(1,1), n_i, N_int )
call bitstring_to_list( mask_ijkl(1,2), list_ijkl(1,2), n_j, N_int )
call bitstring_to_list( mask_ijkl(1,3), list_ijkl(1,3), n_k, N_int )
call bitstring_to_list( mask_ijkl(1,4), list_ijkl(1,4), n_l, N_int )
character*(2048) :: output(1)
print*, 'i'
call bitstring_to_str( output(1), mask_ijkl(1,1), N_int )
print *, trim(output(1))
j = 0
do i = 1, N_int
j += popcnt(mask_ijkl(i,1))
enddo
if(j==0)then
return
endif
print*, 'j'
call bitstring_to_str( output(1), mask_ijkl(1,2), N_int )
print *, trim(output(1))
j = 0
do i = 1, N_int
j += popcnt(mask_ijkl(i,2))
enddo
if(j==0)then
return
endif
print*, 'k'
call bitstring_to_str( output(1), mask_ijkl(1,3), N_int )
print *, trim(output(1))
j = 0
do i = 1, N_int
j += popcnt(mask_ijkl(i,3))
enddo
if(j==0)then
return
endif
print*, 'l'
call bitstring_to_str( output(1), mask_ijkl(1,4), N_int )
print *, trim(output(1))
j = 0
do i = 1, N_int
j += popcnt(mask_ijkl(i,4))
enddo
if(j==0)then
return
endif
size_buffer = min(ao_num*ao_num*ao_num,16000000)
print*, 'Providing the molecular integrals '
print*, 'Buffers : ', 8.*(mo_tot_num_align*(n_j)*(n_k+1) + mo_tot_num_align +&
ao_num+ao_num*ao_num+ size_buffer*3)/(1024*1024), 'MB / core'
call wall_time(wall_1)
call cpu_time(cpu_1)
double precision :: accu_bis
accu_bis = 0.d0
!$OMP PARALLEL PRIVATE(l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, &
!$OMP bielec_tmp_0_idx, bielec_tmp_0, bielec_tmp_1,bielec_tmp_2,bielec_tmp_3,&
!$OMP buffer_i,buffer_value,n_integrals,wall_2,i0,j0,k0,l0, &
!$OMP wall_0,thread_num,accu_bis) &
!$OMP DEFAULT(NONE) &
!$OMP SHARED(size_buffer,ao_num,mo_tot_num,n_i,n_j,n_k,n_l,mo_tot_num_align,&
!$OMP mo_coef_transp, &
!$OMP mo_coef_transp_is_built, list_ijkl, &
!$OMP mo_coef_is_built, wall_1, &
!$OMP mo_coef,mo_integrals_threshold,mo_integrals_erf_map)
n_integrals = 0
wall_0 = wall_1
allocate(bielec_tmp_3(mo_tot_num_align, n_j, n_k), &
bielec_tmp_1(mo_tot_num_align), &
bielec_tmp_0(ao_num,ao_num), &
bielec_tmp_0_idx(ao_num), &
bielec_tmp_2(mo_tot_num_align, n_j), &
buffer_i(size_buffer), &
buffer_value(size_buffer) )
thread_num = 0
!$ thread_num = omp_get_thread_num()
!$OMP DO SCHEDULE(guided)
do l1 = 1,ao_num
!DEC$ VECTOR ALIGNED
bielec_tmp_3 = 0.d0
do k1 = 1,ao_num
!DEC$ VECTOR ALIGNED
bielec_tmp_2 = 0.d0
do j1 = 1,ao_num
call get_ao_bielec_integrals_erf(j1,k1,l1,ao_num,bielec_tmp_0(1,j1))
! call compute_ao_bielec_integrals(j1,k1,l1,ao_num,bielec_tmp_0(1,j1))
enddo
do j1 = 1,ao_num
kmax = 0
do i1 = 1,ao_num
c = bielec_tmp_0(i1,j1)
if (c == 0.d0) then
cycle
endif
kmax += 1
bielec_tmp_0(kmax,j1) = c
bielec_tmp_0_idx(kmax) = i1
enddo
if (kmax==0) then
cycle
endif
!DEC$ VECTOR ALIGNED
bielec_tmp_1 = 0.d0
ii1=1
do ii1 = 1,kmax-4,4
i1 = bielec_tmp_0_idx(ii1)
i2 = bielec_tmp_0_idx(ii1+1)
i3 = bielec_tmp_0_idx(ii1+2)
i4 = bielec_tmp_0_idx(ii1+3)
do i = list_ijkl(1,1), list_ijkl(n_i,1)
bielec_tmp_1(i) = bielec_tmp_1(i) + &
mo_coef_transp(i,i1) * bielec_tmp_0(ii1,j1) + &
mo_coef_transp(i,i2) * bielec_tmp_0(ii1+1,j1) + &
mo_coef_transp(i,i3) * bielec_tmp_0(ii1+2,j1) + &
mo_coef_transp(i,i4) * bielec_tmp_0(ii1+3,j1)
enddo ! i
enddo ! ii1
i2 = ii1
do ii1 = i2,kmax
i1 = bielec_tmp_0_idx(ii1)
do i = list_ijkl(1,1), list_ijkl(n_i,1)
bielec_tmp_1(i) = bielec_tmp_1(i) + mo_coef_transp(i,i1) * bielec_tmp_0(ii1,j1)
enddo ! i
enddo ! ii1
c = 0.d0
do i = list_ijkl(1,1), list_ijkl(n_i,1)
c = max(c,abs(bielec_tmp_1(i)))
if (c>mo_integrals_threshold) exit
enddo
if ( c < mo_integrals_threshold ) then
cycle
endif
do j0 = 1, n_j
j = list_ijkl(j0,2)
c = mo_coef_transp(j,j1)
if (abs(c) < thr_coef) then
cycle
endif
do i = list_ijkl(1,1), list_ijkl(n_i,1)
bielec_tmp_2(i,j0) = bielec_tmp_2(i,j0) + c * bielec_tmp_1(i)
enddo ! i
enddo ! j
enddo !j1
if ( maxval(abs(bielec_tmp_2)) < mo_integrals_threshold ) then
cycle
endif
do k0 = 1, n_k
k = list_ijkl(k0,3)
c = mo_coef_transp(k,k1)
if (abs(c) < thr_coef) then
cycle
endif
do j0 = 1, n_j
j = list_ijkl(j0,2)
do i = list_ijkl(1,1), k
bielec_tmp_3(i,j0,k0) = bielec_tmp_3(i,j0,k0) + c* bielec_tmp_2(i,j0)
enddo!i
enddo !j
enddo !k
enddo !k1
do l0 = 1,n_l
l = list_ijkl(l0,4)
c = mo_coef_transp(l,l1)
if (abs(c) < thr_coef) then
cycle
endif
j1 = ishft((l*l-l),-1)
do j0 = 1, n_j
j = list_ijkl(j0,2)
if (j > l) then
exit
endif
j1 += 1
do k0 = 1, n_k
k = list_ijkl(k0,3)
i1 = ishft((k*k-k),-1)
if (i1<=j1) then
continue
else
exit
endif
bielec_tmp_1 = 0.d0
do i0 = 1, n_i
i = list_ijkl(i0,1)
if (i>k) then
exit
endif
bielec_tmp_1(i) = c*bielec_tmp_3(i,j0,k0)
! i1+=1
enddo
do i0 = 1, n_i
i = list_ijkl(i0,1)
if(i> min(k,j1-i1+list_ijkl(1,1)-1))then
exit
endif
if (abs(bielec_tmp_1(i)) < mo_integrals_threshold) then
cycle
endif
n_integrals += 1
buffer_value(n_integrals) = bielec_tmp_1(i)
!DEC$ FORCEINLINE
call mo_bielec_integrals_erf_index(i,j,k,l,buffer_i(n_integrals))
if (n_integrals == size_buffer) then
call insert_into_mo_integrals_erf_map(n_integrals,buffer_i,buffer_value,&
real(mo_integrals_threshold,integral_kind))
n_integrals = 0
endif
enddo
enddo
enddo
enddo
call wall_time(wall_2)
if (thread_num == 0) then
if (wall_2 - wall_0 > 1.d0) then
wall_0 = wall_2
print*, 100.*float(l1)/float(ao_num), '% in ', &
wall_2-wall_1, 's', map_mb(mo_integrals_erf_map) ,'MB'
endif
endif
enddo
!$OMP END DO NOWAIT
deallocate (bielec_tmp_1,bielec_tmp_2,bielec_tmp_3)
integer :: index_needed
call insert_into_mo_integrals_erf_map(n_integrals,buffer_i,buffer_value,&
real(mo_integrals_threshold,integral_kind))
deallocate(buffer_i, buffer_value)
!$OMP END PARALLEL
call map_unique(mo_integrals_erf_map)
call wall_time(wall_2)
call cpu_time(cpu_2)
integer*8 :: get_mo_erf_map_size, mo_erf_map_size
mo_erf_map_size = get_mo_erf_map_size()
deallocate(list_ijkl)
print*,'Molecular integrals provided:'
print*,' Size of MO map ', map_mb(mo_integrals_erf_map) ,'MB'
print*,' Number of MO integrals: ', mo_erf_map_size
print*,' cpu time :',cpu_2 - cpu_1, 's'
print*,' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1), ')'
end
BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_from_ao, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_exchange_from_ao, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_anti_from_ao, (mo_tot_num_align,mo_tot_num) ]
BEGIN_DOC
! mo_bielec_integral_jj_from_ao(i,j) = J_ij
! mo_bielec_integral_jj_exchange_from_ao(i,j) = J_ij
! mo_bielec_integral_jj_anti_from_ao(i,j) = J_ij - K_ij
END_DOC
implicit none
integer :: i,j,p,q,r,s
double precision :: c
real(integral_kind) :: integral
integer :: n, pp
real(integral_kind), allocatable :: int_value(:)
integer, allocatable :: int_idx(:)
double precision, allocatable :: iqrs(:,:), iqsr(:,:), iqis(:), iqri(:)
if (.not.do_direct_integrals) then
PROVIDE ao_bielec_integrals_erf_in_map mo_coef
endif
mo_bielec_integral_erf_jj_from_ao = 0.d0
mo_bielec_integral_erf_jj_exchange_from_ao = 0.d0
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: iqrs, iqsr
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE (i,j,p,q,r,s,integral,c,n,pp,int_value,int_idx, &
!$OMP iqrs, iqsr,iqri,iqis) &
!$OMP SHARED(mo_tot_num,mo_coef_transp,mo_tot_num_align,ao_num,&
!$OMP ao_integrals_threshold,do_direct_integrals) &
!$OMP REDUCTION(+:mo_bielec_integral_erf_jj_from_ao,mo_bielec_integral_erf_jj_exchange_from_ao)
allocate( int_value(ao_num), int_idx(ao_num), &
iqrs(mo_tot_num_align,ao_num), iqis(mo_tot_num), iqri(mo_tot_num),&
iqsr(mo_tot_num_align,ao_num) )
!$OMP DO SCHEDULE (guided)
do s=1,ao_num
do q=1,ao_num
do j=1,ao_num
!DIR$ VECTOR ALIGNED
do i=1,mo_tot_num
iqrs(i,j) = 0.d0
iqsr(i,j) = 0.d0
enddo
enddo
if (do_direct_integrals) then
double precision :: ao_bielec_integral_erf
do r=1,ao_num
call compute_ao_bielec_integrals_erf(q,r,s,ao_num,int_value)
do p=1,ao_num
integral = int_value(p)
if (abs(integral) > ao_integrals_threshold) then
!DIR$ VECTOR ALIGNED
do i=1,mo_tot_num
iqrs(i,r) += mo_coef_transp(i,p) * integral
enddo
endif
enddo
call compute_ao_bielec_integrals_erf(q,s,r,ao_num,int_value)
do p=1,ao_num
integral = int_value(p)
if (abs(integral) > ao_integrals_threshold) then
!DIR$ VECTOR ALIGNED
do i=1,mo_tot_num
iqsr(i,r) += mo_coef_transp(i,p) * integral
enddo
endif
enddo
enddo
else
do r=1,ao_num
call get_ao_bielec_integrals_erf_non_zero(q,r,s,ao_num,int_value,int_idx,n)
do pp=1,n
p = int_idx(pp)
integral = int_value(pp)
if (abs(integral) > ao_integrals_threshold) then
!DIR$ VECTOR ALIGNED
do i=1,mo_tot_num
iqrs(i,r) += mo_coef_transp(i,p) * integral
enddo
endif
enddo
call get_ao_bielec_integrals_erf_non_zero(q,s,r,ao_num,int_value,int_idx,n)
do pp=1,n
p = int_idx(pp)
integral = int_value(pp)
if (abs(integral) > ao_integrals_threshold) then
!DIR$ VECTOR ALIGNED
do i=1,mo_tot_num
iqsr(i,r) += mo_coef_transp(i,p) * integral
enddo
endif
enddo
enddo
endif
iqis = 0.d0
iqri = 0.d0
do r=1,ao_num
!DIR$ VECTOR ALIGNED
do i=1,mo_tot_num
iqis(i) += mo_coef_transp(i,r) * iqrs(i,r)
iqri(i) += mo_coef_transp(i,r) * iqsr(i,r)
enddo
enddo
do i=1,mo_tot_num
!DIR$ VECTOR ALIGNED
do j=1,mo_tot_num
c = mo_coef_transp(j,q)*mo_coef_transp(j,s)
mo_bielec_integral_erf_jj_from_ao(j,i) += c * iqis(i)
mo_bielec_integral_erf_jj_exchange_from_ao(j,i) += c * iqri(i)
enddo
enddo
enddo
enddo
!$OMP END DO NOWAIT
deallocate(iqrs,iqsr,int_value,int_idx)
!$OMP END PARALLEL
mo_bielec_integral_erf_jj_anti_from_ao = mo_bielec_integral_erf_jj_from_ao - mo_bielec_integral_erf_jj_exchange_from_ao
! end
END_PROVIDER
BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_exchange, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_anti, (mo_tot_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! mo_bielec_integral_jj(i,j) = J_ij
! mo_bielec_integral_jj_exchange(i,j) = K_ij
! mo_bielec_integral_jj_anti(i,j) = J_ij - K_ij
END_DOC
integer :: i,j
double precision :: get_mo_bielec_integral_erf
PROVIDE mo_bielec_integrals_erf_in_map
mo_bielec_integral_erf_jj = 0.d0
mo_bielec_integral_erf_jj_exchange = 0.d0
do j=1,mo_tot_num
do i=1,mo_tot_num
mo_bielec_integral_erf_jj(i,j) = get_mo_bielec_integral_erf(i,j,i,j,mo_integrals_erf_map)
mo_bielec_integral_erf_jj_exchange(i,j) = get_mo_bielec_integral_erf(i,j,j,i,mo_integrals_erf_map)
mo_bielec_integral_erf_jj_anti(i,j) = mo_bielec_integral_erf_jj(i,j) - mo_bielec_integral_erf_jj_exchange(i,j)
enddo
enddo
END_PROVIDER
subroutine clear_mo_erf_map
implicit none
BEGIN_DOC
! Frees the memory of the MO map
END_DOC
call map_deinit(mo_integrals_erf_map)
FREE mo_integrals_erf_map mo_bielec_integral_erf_jj mo_bielec_integral_erf_jj_anti
FREE mo_bielec_integral_Erf_jj_exchange mo_bielec_integrals_erf_in_map
end
subroutine provide_all_mo_integrals_erf
implicit none
provide mo_integrals_erf_map mo_bielec_integral_erf_jj mo_bielec_integral_erf_jj_anti
provide mo_bielec_integral_erf_jj_exchange mo_bielec_integrals_erf_in_map
end

119
plugins/Integrals_erf/providers_ao_erf.irp.f
View File

@ -1,119 +0,0 @@
BEGIN_PROVIDER [ logical, ao_bielec_integrals_erf_in_map ]
implicit none
use f77_zmq
use map_module
BEGIN_DOC
! Map of Atomic integrals
! i(r1) j(r2) 1/r12 k(r1) l(r2)
END_DOC
integer :: i,j,k,l
double precision :: ao_bielec_integral_erf,cpu_1,cpu_2, wall_1, wall_2
double precision :: integral, wall_0
include 'Utils/constants.include.F'
! For integrals file
integer(key_kind),allocatable :: buffer_i(:)
integer,parameter :: size_buffer = 1024*64
real(integral_kind),allocatable :: buffer_value(:)
integer :: n_integrals, rc
integer :: kk, m, j1, i1, lmax
character*(64) :: fmt
integral = ao_bielec_integral_erf(1,1,1,1)
real :: map_mb
PROVIDE read_ao_integrals_erf disk_access_ao_integrals_erf
if (read_ao_integrals_erf) then
print*,'Reading the AO integrals_erf'
call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints_erf',ao_integrals_erf_map)
print*, 'AO integrals_erf provided'
ao_bielec_integrals_erf_in_map = .True.
return
endif
print*, 'Providing the AO integrals_erf'
call wall_time(wall_0)
call wall_time(wall_1)
call cpu_time(cpu_1)
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
call new_parallel_job(zmq_to_qp_run_socket,'ao_integrals_erf')
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)
PROVIDE nproc
!$OMP PARALLEL DEFAULT(private) num_threads(nproc+1)
i = omp_get_thread_num()
if (i==0) then
call ao_bielec_integrals_erf_in_map_collector(i)
else
call ao_bielec_integrals_erf_in_map_slave_inproc(i)
endif
!$OMP END PARALLEL
call end_parallel_job(zmq_to_qp_run_socket, 'ao_integrals_erf')
print*, 'Sorting the map'
call map_sort(ao_integrals_erf_map)
call cpu_time(cpu_2)
call wall_time(wall_2)
integer(map_size_kind) :: get_ao_erf_map_size, ao_erf_map_size
ao_erf_map_size = get_ao_erf_map_size()
print*, 'AO integrals provided:'
print*, ' Size of AO map : ', map_mb(ao_integrals_erf_map) ,'MB'
print*, ' Number of AO integrals :', ao_erf_map_size
print*, ' cpu time :',cpu_2 - cpu_1, 's'
print*, ' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1+tiny(1.d0)), ' )'
ao_bielec_integrals_erf_in_map = .True.
if (write_ao_integrals_erf) then
call ezfio_set_work_empty(.False.)
call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints_erf',ao_integrals_erf_map)
call ezfio_set_integrals_erf_disk_access_ao_integrals_erf("Read")
endif
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_bielec_integral_erf_schwartz,(ao_num,ao_num) ]
implicit none
BEGIN_DOC
! Needed to compute Schwartz inequalities
END_DOC
integer :: i,k
double precision :: ao_bielec_integral_erf,cpu_1,cpu_2, wall_1, wall_2
ao_bielec_integral_erf_schwartz(1,1) = ao_bielec_integral_erf(1,1,1,1)
!$OMP PARALLEL DO PRIVATE(i,k) &
!$OMP DEFAULT(NONE) &
!$OMP SHARED (ao_num,ao_bielec_integral_erf_schwartz) &
!$OMP SCHEDULE(dynamic)
do i=1,ao_num
do k=1,i
ao_bielec_integral_erf_schwartz(i,k) = dsqrt(ao_bielec_integral_erf(i,k,i,k))
ao_bielec_integral_erf_schwartz(k,i) = ao_bielec_integral_erf_schwartz(i,k)
enddo
enddo
!$OMP END PARALLEL DO
END_PROVIDER

32
plugins/Integrals_erf/qp_ao_erf_ints.irp.f
View File

@ -1,32 +0,0 @@
program qp_ao_ints
use omp_lib
implicit none
BEGIN_DOC
! Increments a running calculation to compute AO integral_erfs
END_DOC
integer :: i
call switch_qp_run_to_master
zmq_context = f77_zmq_ctx_new ()
! Set the state of the ZMQ
zmq_state = 'ao_integral_erfs'
! Provide everything needed
double precision :: integral_erf, ao_bielec_integral_erf
integral_erf = ao_bielec_integral_erf(1,1,1,1)
character*(64) :: state
call wait_for_state(zmq_state,state)
do while (state /= 'Stopped')
!$OMP PARALLEL DEFAULT(PRIVATE) PRIVATE(i)
i = omp_get_thread_num()
call ao_bielec_integrals_erf_in_map_slave_tcp(i)
!$OMP END PARALLEL
call wait_for_state(zmq_state,state)
enddo
print *, 'Done'
end

47
plugins/Integrals_erf/read_write.irp.f
View File

@ -1,47 +0,0 @@
BEGIN_PROVIDER [ logical, read_ao_integrals_erf ]
&BEGIN_PROVIDER [ logical, read_mo_integrals_erf ]
&BEGIN_PROVIDER [ logical, write_ao_integrals_erf ]
&BEGIN_PROVIDER [ logical, write_mo_integrals_erf ]
BEGIN_DOC
! One level of abstraction for disk_access_ao_integrals_erf and disk_access_mo_integrals_erf
END_DOC
implicit none
if (disk_access_ao_integrals_erf.EQ.'Read') then
read_ao_integrals_erf = .True.
write_ao_integrals_erf = .False.
else if (disk_access_ao_integrals_erf.EQ.'Write') then
read_ao_integrals_erf = .False.
write_ao_integrals_erf = .True.
else if (disk_access_ao_integrals_erf.EQ.'None') then
read_ao_integrals_erf = .False.
write_ao_integrals_erf = .False.
else
print *, 'bielec_integrals_erf/disk_access_ao_integrals_erf has a wrong type'
stop 1
endif
if (disk_access_mo_integrals_erf.EQ.'Read') then
read_mo_integrals_erf = .True.
write_mo_integrals_erf = .False.
else if (disk_access_mo_integrals_erf.EQ.'Write') then
read_mo_integrals_erf = .False.
write_mo_integrals_erf = .True.
else if (disk_access_mo_integrals_erf.EQ.'None') then
read_mo_integrals_erf = .False.
write_mo_integrals_erf = .False.
else
print *, 'bielec_integrals_erf/disk_access_mo_integrals_erf has a wrong type'
stop 1
endif
END_PROVIDER

1
plugins/Integrals_restart_DFT/NEEDED_CHILDREN_MODULES
View File

@ -1 +0,0 @@
Integrals_Monoelec Integrals_erf Determinants DFT_Utils

12
plugins/Integrals_restart_DFT/README.rst
View File

@ -1,12 +0,0 @@
==============
core_integrals
==============
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.

79
plugins/Integrals_restart_DFT/short_range_coulomb.irp.f
View File

@ -1,79 +0,0 @@
BEGIN_PROVIDER [double precision, density_matrix_read, (mo_tot_num, mo_tot_num)]
implicit none
integer :: i,j,k,l
logical :: exists
call ezfio_has_determinants_density_matrix_mo_disk(exists)
if(exists)then
print*, 'reading the density matrix from input'
call ezfio_get_determinants_density_matrix_mo_disk(exists)
print*, 'reading done'
else
print*, 'no density matrix found in EZFIO file ...'
print*, 'stopping ..'
stop
endif
END_PROVIDER
BEGIN_PROVIDER [double precision, effective_short_range_operator, (mo_tot_num,mo_tot_num)]
implicit none
integer :: i,j,k,l,m,n
double precision :: get_mo_bielec_integral,get_mo_bielec_integral_erf
double precision :: integral, integral_erf
effective_short_range_operator = 0.d0
do i = 1, mo_tot_num
do j = 1, mo_tot_num
if(dabs(one_body_dm_mo(i,j)).le.1.d-10)cycle
do k = 1, mo_tot_num
do l = 1, mo_tot_num
integral = get_mo_bielec_integral(i,k,j,l,mo_integrals_map)
! integral_erf = get_mo_bielec_integral_erf(i,k,j,l,mo_integrals_erf_map)
effective_short_range_operator(l,k) += one_body_dm_mo(i,j) * integral
enddo
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, effective_one_e_potential, (mo_tot_num_align, mo_tot_num,N_states)]
implicit none
integer :: i,j,i_state
effective_one_e_potential = 0.d0
do i_state = 1, N_states
do i = 1, mo_tot_num
do j = 1, mo_tot_num
effective_one_e_potential(i,j,i_state) = effective_short_range_operator(i,j) + mo_nucl_elec_integral(i,j) + mo_kinetic_integral(i,j) &
+ 0.5d0 * (lda_ex_potential_alpha_ao(i,j,i_state) + lda_ex_potential_beta_ao(i,j,i_state))
enddo
enddo
enddo
END_PROVIDER
subroutine save_one_e_effective_potential
implicit none
double precision, allocatable :: tmp(:,:)
allocate(tmp(size(effective_one_e_potential,1),size(effective_one_e_potential,2)))
integer :: i,j
do i = 1, mo_tot_num
do j = 1, mo_tot_num
tmp(i,j) = effective_one_e_potential(i,j,1)
enddo
enddo
call write_one_e_integrals('mo_one_integral', tmp, &
size(tmp,1), size(tmp,2))
call ezfio_set_integrals_monoelec_disk_access_only_mo_one_integrals("Read")
deallocate(tmp)
end
subroutine save_erf_bi_elec_integrals
implicit none
integer :: i,j,k,l
PROVIDE mo_bielec_integrals_erf_in_map
call ezfio_set_work_empty(.False.)
call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints',mo_integrals_erf_map)
call ezfio_set_integrals_bielec_disk_access_mo_integrals("Read")
end

18
plugins/Integrals_restart_DFT/write_integrals_restart_dft.irp.f
View File

@ -1,18 +0,0 @@
program write_integrals
implicit none
read_wf = .true.
touch read_wf
disk_access_only_mo_one_integrals = "None"
touch disk_access_only_mo_one_integrals
disk_access_mo_integrals = "None"
touch disk_access_mo_integrals
call routine
end
subroutine routine
implicit none
call save_one_e_effective_potential
call save_erf_bi_elec_integrals
end

54
plugins/Kohn_Sham/EZFIO.cfg
View File

@ -1,54 +0,0 @@
[thresh_scf]
type: Threshold
doc: Threshold on the convergence of the Hartree Fock energy
interface: ezfio,provider,ocaml
default: 1.e-10
[exchange_functional]
type: character*(256)
doc: name of the exchange functional
interface: ezfio, provider, ocaml
default: "LDA"
[correlation_functional]
type: character*(256)
doc: name of the correlation functional
interface: ezfio, provider, ocaml
default: "LDA"
[HF_exchange]
type: double precision
doc: Percentage of HF exchange in the DFT model
interface: ezfio,provider,ocaml
default: 0.
[n_it_scf_max]
type: Strictly_positive_int
doc: Maximum number of SCF iterations
interface: ezfio,provider,ocaml
default: 200
[level_shift]
type: Positive_float
doc: Energy shift on the virtual MOs to improve SCF convergence
interface: ezfio,provider,ocaml
default: 0.5
[mo_guess_type]
type: MO_guess
doc: Initial MO guess. Can be [ Huckel | HCore ]
interface: ezfio,provider,ocaml
default: Huckel
[energy]
type: double precision
doc: Calculated HF energy
interface: ezfio
[no_oa_or_av_opt]
type: logical
doc: If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure
interface: ezfio,provider,ocaml
default: False

468
plugins/Kohn_Sham/Fock_matrix.irp.f
View File

@ -1,468 +0,0 @@
BEGIN_PROVIDER [ double precision, Fock_matrix_mo, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, Fock_matrix_diag_mo, (mo_tot_num)]
implicit none
BEGIN_DOC
! Fock matrix on the MO basis.
! For open shells, the ROHF Fock Matrix is
!
! | F-K | F + K/2 | F |
! |---------------------------------|
! | F + K/2 | F | F - K/2 |
! |---------------------------------|
! | F | F - K/2 | F + K |
!
! F = 1/2 (Fa + Fb)
!
! K = Fb - Fa
!
END_DOC
integer :: i,j,n
if (elec_alpha_num == elec_beta_num) then
Fock_matrix_mo = Fock_matrix_alpha_mo
else
do j=1,elec_beta_num
! F-K
do i=1,elec_beta_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
- (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
! F+K/2
do i=elec_beta_num+1,elec_alpha_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
+ 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
! F
do i=elec_alpha_num+1, mo_tot_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))
enddo
enddo
do j=elec_beta_num+1,elec_alpha_num
! F+K/2
do i=1,elec_beta_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
+ 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
! F
do i=elec_beta_num+1,elec_alpha_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))
enddo
! F-K/2
do i=elec_alpha_num+1, mo_tot_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
- 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
enddo
do j=elec_alpha_num+1, mo_tot_num
! F
do i=1,elec_beta_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))
enddo
! F-K/2
do i=elec_beta_num+1,elec_alpha_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
- 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
! F+K
do i=elec_alpha_num+1,mo_tot_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) &
+ (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
enddo
endif
do i = 1, mo_tot_num
Fock_matrix_diag_mo(i) = Fock_matrix_mo(i,i)
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_ao, (ao_num_align, ao_num) ]
&BEGIN_PROVIDER [ double precision, Fock_matrix_beta_ao, (ao_num_align, ao_num) ]
implicit none
BEGIN_DOC
! Alpha Fock matrix in AO basis set
END_DOC
integer :: i,j
do j=1,ao_num
!DIR$ VECTOR ALIGNED
do i=1,ao_num
Fock_matrix_alpha_ao(i,j) = Fock_matrix_alpha_no_xc_ao(i,j) + ao_potential_alpha_xc(i,j)
Fock_matrix_beta_ao (i,j) = Fock_matrix_beta_no_xc_ao(i,j) + ao_potential_beta_xc(i,j)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_no_xc_ao, (ao_num_align, ao_num) ]
&BEGIN_PROVIDER [ double precision, Fock_matrix_beta_no_xc_ao, (ao_num_align, ao_num) ]
implicit none
BEGIN_DOC
! Mono electronic an Coulomb matrix in AO basis set
END_DOC
integer :: i,j
do j=1,ao_num
!DIR$ VECTOR ALIGNED
do i=1,ao_num
Fock_matrix_alpha_no_xc_ao(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_alpha(i,j)
Fock_matrix_beta_no_xc_ao(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_beta (i,j)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_alpha, (ao_num_align, ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_beta , (ao_num_align, ao_num) ]
use map_module
implicit none
BEGIN_DOC
! Alpha Fock matrix in AO basis set
END_DOC
integer :: i,j,k,l,k1,r,s
integer :: i0,j0,k0,l0
integer*8 :: p,q
double precision :: integral, c0, c1, c2
double precision :: ao_bielec_integral, local_threshold
double precision, allocatable :: ao_bi_elec_integral_alpha_tmp(:,:)
double precision, allocatable :: ao_bi_elec_integral_beta_tmp(:,:)
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_beta_tmp
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_alpha_tmp
ao_bi_elec_integral_alpha = 0.d0
ao_bi_elec_integral_beta = 0.d0
if (do_direct_integrals) then
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,p,q,r,s,i0,j0,k0,l0, &
!$OMP ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp, c0, c1, c2, &
!$OMP local_threshold)&
!$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,&
!$OMP ao_integrals_map,ao_integrals_threshold, ao_bielec_integral_schwartz, &
!$OMP ao_overlap_abs, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta)
allocate(keys(1), values(1))
allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), &
ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num))
ao_bi_elec_integral_alpha_tmp = 0.d0
ao_bi_elec_integral_beta_tmp = 0.d0
q = ao_num*ao_num*ao_num*ao_num
!$OMP DO SCHEDULE(dynamic)
do p=1_8,q
call bielec_integrals_index_reverse(kk,ii,ll,jj,p)
if ( (kk(1)>ao_num).or. &
(ii(1)>ao_num).or. &
(jj(1)>ao_num).or. &
(ll(1)>ao_num) ) then
cycle
endif
k = kk(1)
i = ii(1)
l = ll(1)
j = jj(1)
if (ao_overlap_abs(k,l)*ao_overlap_abs(i,j) &
< ao_integrals_threshold) then
cycle
endif
local_threshold = ao_bielec_integral_schwartz(k,l)*ao_bielec_integral_schwartz(i,j)
if (local_threshold < ao_integrals_threshold) then
cycle
endif
i0 = i
j0 = j
k0 = k
l0 = l
values(1) = 0.d0
local_threshold = ao_integrals_threshold/local_threshold
do k2=1,8
if (kk(k2)==0) then
cycle
endif
i = ii(k2)
j = jj(k2)
k = kk(k2)
l = ll(k2)
c0 = HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l)
c1 = HF_density_matrix_ao_alpha(k,i)
c2 = HF_density_matrix_ao_beta(k,i)
if ( dabs(c0)+dabs(c1)+dabs(c2) < local_threshold) then
cycle
endif
if (values(1) == 0.d0) then
values(1) = ao_bielec_integral(k0,l0,i0,j0)
endif
integral = c0 * values(1)
ao_bi_elec_integral_alpha_tmp(i,j) += integral
ao_bi_elec_integral_beta_tmp (i,j) += integral
integral = values(1)
ao_bi_elec_integral_alpha_tmp(l,j) -= c1 * integral
ao_bi_elec_integral_beta_tmp (l,j) -= c2 * integral
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp
!$OMP END CRITICAL
!$OMP CRITICAL
ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp
!$OMP END CRITICAL
deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)
!$OMP END PARALLEL
else
PROVIDE ao_bielec_integrals_in_map
integer(omp_lock_kind) :: lck(ao_num)
integer*8 :: i8
integer :: ii(8), jj(8), kk(8), ll(8), k2
integer(cache_map_size_kind) :: n_elements_max, n_elements
integer(key_kind), allocatable :: keys(:)
double precision, allocatable :: values(:)
! !$OMP PARALLEL DEFAULT(NONE) &
! !$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,n_elements_max, &
! !$OMP n_elements,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)&
! !$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,&
! !$OMP ao_integrals_map, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta,HF_exchange)
call get_cache_map_n_elements_max(ao_integrals_map,n_elements_max)
allocate(keys(n_elements_max), values(n_elements_max))
allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), &
ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num))
ao_bi_elec_integral_alpha_tmp = 0.d0
ao_bi_elec_integral_beta_tmp = 0.d0
! !OMP DO SCHEDULE(dynamic)
! !DIR$ NOVECTOR
do i8=0_8,ao_integrals_map%map_size
n_elements = n_elements_max
call get_cache_map(ao_integrals_map,i8,keys,values,n_elements)
do k1=1,n_elements
call bielec_integrals_index_reverse(kk,ii,ll,jj,keys(k1))
do k2=1,8
if (kk(k2)==0) then
cycle
endif
i = ii(k2)
j = jj(k2)
k = kk(k2)
l = ll(k2)
integral = (HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l)) * values(k1)
ao_bi_elec_integral_alpha_tmp(i,j) += integral
ao_bi_elec_integral_beta_tmp (i,j) += integral
integral = values(k1)
ao_bi_elec_integral_alpha_tmp(l,j) -= HF_exchange * (HF_density_matrix_ao_alpha(k,i) * integral)
ao_bi_elec_integral_beta_tmp (l,j) -= HF_exchange * (HF_density_matrix_ao_beta (k,i) * integral)
enddo
enddo
enddo
! !$OMP END DO NOWAIT
! !$OMP CRITICAL
ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp
! !$OMP END CRITICAL
! !$OMP CRITICAL
ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp
! !$OMP END CRITICAL
deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)
! !$OMP END PARALLEL
endif
END_PROVIDER
BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_mo, (mo_tot_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! Fock matrix on the MO basis
END_DOC
double precision, allocatable :: T(:,:)
allocate ( T(ao_num_align,mo_tot_num) )
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
call dgemm('N','N', ao_num, mo_tot_num, ao_num, &
1.d0, Fock_matrix_alpha_ao,size(Fock_matrix_alpha_ao,1), &
mo_coef, size(mo_coef,1), &
0.d0, T, ao_num_align)
call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, &
1.d0, mo_coef,size(mo_coef,1), &
T, size(T,1), &
0.d0, Fock_matrix_alpha_mo, mo_tot_num_align)
deallocate(T)
END_PROVIDER
BEGIN_PROVIDER [ double precision, Fock_matrix_beta_mo, (mo_tot_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! Fock matrix on the MO basis
END_DOC
double precision, allocatable :: T(:,:)
allocate ( T(ao_num_align,mo_tot_num) )
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
call dgemm('N','N', ao_num, mo_tot_num, ao_num, &
1.d0, Fock_matrix_beta_ao,size(Fock_matrix_beta_ao,1), &
mo_coef, size(mo_coef,1), &
0.d0, T, ao_num_align)
call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, &
1.d0, mo_coef,size(mo_coef,1), &
T, size(T,1), &
0.d0, Fock_matrix_beta_mo, mo_tot_num_align)
deallocate(T)
END_PROVIDER
BEGIN_PROVIDER [ double precision, HF_energy ]
&BEGIN_PROVIDER [ double precision, two_electron_energy]
&BEGIN_PROVIDER [ double precision, one_electron_energy]
implicit none
BEGIN_DOC
! Hartree-Fock energy
END_DOC
HF_energy = nuclear_repulsion
integer :: i,j
double precision :: accu_mono,accu_fock
one_electron_energy = 0.d0
two_electron_energy = 0.d0
do j=1,ao_num
do i=1,ao_num
two_electron_energy += 0.5d0 * ( ao_bi_elec_integral_alpha(i,j) * HF_density_matrix_ao_alpha(i,j) &
+ao_bi_elec_integral_beta(i,j) * HF_density_matrix_ao_beta(i,j) )
one_electron_energy += ao_mono_elec_integral(i,j) * (HF_density_matrix_ao_alpha(i,j) + HF_density_matrix_ao_beta (i,j) )
enddo
enddo
print*, 'one_electron_energy = ',one_electron_energy
print*, 'two_electron_energy = ',two_electron_energy
print*, 'e_exchange_dft = ',(1.d0 - HF_exchange) * e_exchange_dft
!print*, 'accu_cor = ',e_correlation_dft
HF_energy += (1.d0 - HF_exchange) * e_exchange_dft + e_correlation_dft + one_electron_energy + two_electron_energy
!print*, 'HF_energy '
END_PROVIDER
BEGIN_PROVIDER [ double precision, Fock_matrix_ao, (ao_num_align, ao_num) ]
implicit none
BEGIN_DOC
! Fock matrix in AO basis set
END_DOC
if ( (elec_alpha_num == elec_beta_num).and. &
(level_shift == 0.) ) &
then
integer :: i,j
do j=1,ao_num
!DIR$ VECTOR ALIGNED
do i=1,ao_num_align
Fock_matrix_ao(i,j) = Fock_matrix_alpha_ao(i,j)
enddo
enddo
else
double precision, allocatable :: T(:,:), M(:,:)
integer :: ierr
! F_ao = S C F_mo C^t S
allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr)
if (ierr /=0 ) then
print *, irp_here, ' : allocation failed'
endif
! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num)
! -> M(ao_num,mo_tot_num)
call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, &
ao_overlap, size(ao_overlap,1), &
mo_coef, size(mo_coef,1), &
0.d0, &
M, size(M,1))
! M(ao_num,mo_tot_num) . Fock_matrix_mo (mo_tot_num,mo_tot_num)
! -> T(ao_num,mo_tot_num)
call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, &
M, size(M,1), &
Fock_matrix_mo, size(Fock_matrix_mo,1), &
0.d0, &
T, size(T,1))
! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num)
! -> M(ao_num,ao_num)
call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, &
T, size(T,1), &
mo_coef, size(mo_coef,1), &
0.d0, &
M, size(M,1))
! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num)
! -> Fock_matrix_ao(ao_num,ao_num)
call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, &
M, size(M,1), &
ao_overlap, size(ao_overlap,1), &
0.d0, &
Fock_matrix_ao, size(Fock_matrix_ao,1))
deallocate(T)
endif
END_PROVIDER
subroutine Fock_mo_to_ao(FMO,LDFMO,FAO,LDFAO)
implicit none
integer, intent(in) :: LDFMO ! size(FMO,1)
integer, intent(in) :: LDFAO ! size(FAO,1)
double precision, intent(in) :: FMO(LDFMO,*)
double precision, intent(out) :: FAO(LDFAO,*)
double precision, allocatable :: T(:,:), M(:,:)
integer :: ierr
! F_ao = S C F_mo C^t S
allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr)
if (ierr /=0 ) then
print *, irp_here, ' : allocation failed'
endif
! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num)
! -> M(ao_num,mo_tot_num)
call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, &
ao_overlap, size(ao_overlap,1), &
mo_coef, size(mo_coef,1), &
0.d0, &
M, size(M,1))
! M(ao_num,mo_tot_num) . FMO (mo_tot_num,mo_tot_num)
! -> T(ao_num,mo_tot_num)
call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, &
M, size(M,1), &
FMO, size(FMO,1), &
0.d0, &
T, size(T,1))
! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num)
! -> M(ao_num,ao_num)
call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, &
T, size(T,1), &
mo_coef, size(mo_coef,1), &
0.d0, &
M, size(M,1))
! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num)
! -> Fock_matrix_ao(ao_num,ao_num)
call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, &
M, size(M,1), &
ao_overlap, size(ao_overlap,1), &
0.d0, &
FAO, size(FAO,1))
deallocate(T,M)
end

41
plugins/Kohn_Sham/HF_density_matrix_ao.irp.f
View File

@ -1,41 +0,0 @@
BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_alpha, (ao_num_align,ao_num) ]
implicit none
BEGIN_DOC
! S^-1 x Alpha density matrix in the AO basis x S^-1
END_DOC
call dgemm('N','T',ao_num,ao_num,elec_alpha_num,1.d0, &
mo_coef, size(mo_coef,1), &
mo_coef, size(mo_coef,1), 0.d0, &
HF_density_matrix_ao_alpha, size(HF_density_matrix_ao_alpha,1))
END_PROVIDER
BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_beta, (ao_num_align,ao_num) ]
implicit none
BEGIN_DOC
! S^-1 Beta density matrix in the AO basis x S^-1
END_DOC
call dgemm('N','T',ao_num,ao_num,elec_beta_num,1.d0, &
mo_coef, size(mo_coef,1), &
mo_coef, size(mo_coef,1), 0.d0, &
HF_density_matrix_ao_beta, size(HF_density_matrix_ao_beta,1))
END_PROVIDER
BEGIN_PROVIDER [ double precision, HF_density_matrix_ao, (ao_num_align,ao_num) ]
implicit none
BEGIN_DOC
! S^-1 Density matrix in the AO basis S^-1
END_DOC
ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_alpha,1))
if (elec_alpha_num== elec_beta_num) then
HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_alpha
else
ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_beta ,1))
HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_beta
endif
END_PROVIDER

54
plugins/Kohn_Sham/KS_SCF.irp.f
View File

@ -1,54 +0,0 @@
program scf
BEGIN_DOC
! Produce `Hartree_Fock` MO orbital
! output: mo_basis.mo_tot_num mo_basis.mo_label mo_basis.ao_md5 mo_basis.mo_coef mo_basis.mo_occ
! output: hartree_fock.energy
! optional: mo_basis.mo_coef
END_DOC
call create_guess
call orthonormalize_mos
call run
end
subroutine create_guess
implicit none
BEGIN_DOC
! Create an MO guess if no MOs are present in the EZFIO directory
END_DOC
logical :: exists
PROVIDE ezfio_filename
call ezfio_has_mo_basis_mo_coef(exists)
if (.not.exists) then
if (mo_guess_type == "HCore") then
mo_coef = ao_ortho_lowdin_coef
TOUCH mo_coef
mo_label = 'Guess'
call mo_as_eigvectors_of_mo_matrix(mo_mono_elec_integral,size(mo_mono_elec_integral,1),size(mo_mono_elec_integral,2),mo_label)
SOFT_TOUCH mo_coef mo_label
else if (mo_guess_type == "Huckel") then
call huckel_guess
else
print *, 'Unrecognized MO guess type : '//mo_guess_type
stop 1
endif
endif
end
subroutine run
use bitmasks
implicit none
BEGIN_DOC
! Run SCF calculation
END_DOC
double precision :: SCF_energy_before,SCF_energy_after,diag_H_mat_elem
double precision :: E0
integer :: i_it, i, j, k
E0 = HF_energy
mo_label = "Canonical"
call damping_SCF
end

1
plugins/Kohn_Sham/NEEDED_CHILDREN_MODULES
View File

@ -1 +0,0 @@
Integrals_Bielec MOGuess Bitmask DFT_Utils

132
plugins/Kohn_Sham/damping_SCF.irp.f
View File

@ -1,132 +0,0 @@
subroutine damping_SCF
implicit none
double precision :: E
double precision, allocatable :: D_alpha(:,:), D_beta(:,:)
double precision :: E_new
double precision, allocatable :: D_new_alpha(:,:), D_new_beta(:,:), F_new(:,:)
double precision, allocatable :: delta_alpha(:,:), delta_beta(:,:)
double precision :: lambda, E_half, a, b, delta_D, delta_E, E_min
integer :: i,j,k
logical :: saving
character :: save_char
allocate( &
D_alpha( ao_num_align, ao_num ), &
D_beta( ao_num_align, ao_num ), &
F_new( ao_num_align, ao_num ), &
D_new_alpha( ao_num_align, ao_num ), &
D_new_beta( ao_num_align, ao_num ), &
delta_alpha( ao_num_align, ao_num ), &
delta_beta( ao_num_align, ao_num ))
do j=1,ao_num
do i=1,ao_num
D_alpha(i,j) = HF_density_matrix_ao_alpha(i,j)
D_beta (i,j) = HF_density_matrix_ao_beta (i,j)
enddo
enddo
call write_time(output_hartree_fock)
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') &
'====','================','================','================', '===='
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') &
' N ', 'Energy ', 'Energy diff ', 'Density diff ', 'Save'
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') &
'====','================','================','================', '===='
E = HF_energy + 1.d0
E_min = HF_energy
delta_D = 0.d0
do k=1,n_it_scf_max
delta_E = HF_energy - E
E = HF_energy
if ( (delta_E < 0.d0).and.(dabs(delta_E) < thresh_scf) ) then
exit
endif
saving = E < E_min
if (saving) then
call save_mos
save_char = 'X'
E_min = E
else
save_char = ' '
endif
write(output_hartree_fock,'(I4,1X,F16.10, 1X, F16.10, 1X, F16.10, 3X, A )') &
k, E, delta_E, delta_D, save_char
D_alpha = HF_density_matrix_ao_alpha
D_beta = HF_density_matrix_ao_beta
mo_coef = eigenvectors_fock_matrix_mo
TOUCH mo_coef
D_new_alpha = HF_density_matrix_ao_alpha
D_new_beta = HF_density_matrix_ao_beta
F_new = Fock_matrix_ao
E_new = HF_energy
delta_alpha = D_new_alpha - D_alpha
delta_beta = D_new_beta - D_beta
lambda = .5d0
E_half = 0.d0
do while (E_half > E)
HF_density_matrix_ao_alpha = D_alpha + lambda * delta_alpha
HF_density_matrix_ao_beta = D_beta + lambda * delta_beta
TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta
mo_coef = eigenvectors_fock_matrix_mo
TOUCH mo_coef
E_half = HF_energy
if ((E_half > E).and.(E_new < E)) then
lambda = 1.d0
exit
else if ((E_half > E).and.(lambda > 5.d-4)) then
lambda = 0.5d0 * lambda
E_new = E_half
else
exit
endif
enddo
a = (E_new + E - 2.d0*E_half)*2.d0
b = -E_new - 3.d0*E + 4.d0*E_half
lambda = -lambda*b/(a+1.d-16)
D_alpha = (1.d0-lambda) * D_alpha + lambda * D_new_alpha
D_beta = (1.d0-lambda) * D_beta + lambda * D_new_beta
delta_E = HF_energy - E
do j=1,ao_num
do i=1,ao_num
delta_D = delta_D + &
(D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j))*(D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j)) + &
(D_beta (i,j) - HF_density_matrix_ao_beta (i,j))*(D_beta (i,j) - HF_density_matrix_ao_beta (i,j))
enddo
enddo
delta_D = dsqrt(delta_D/dble(ao_num)**2)
HF_density_matrix_ao_alpha = D_alpha
HF_density_matrix_ao_beta = D_beta
TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta
mo_coef = eigenvectors_fock_matrix_mo
TOUCH mo_coef
enddo
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') '====','================','================','================', '===='
write(output_hartree_fock,*)
if(.not.no_oa_or_av_opt)then
call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1),size(Fock_matrix_mo,2),mo_label,1)
endif
call write_double(output_hartree_fock, E_min, 'Hartree-Fock energy')
call ezfio_set_hartree_fock_energy(E_min)
call write_time(output_hartree_fock)
deallocate(D_alpha,D_beta,F_new,D_new_alpha,D_new_beta,delta_alpha,delta_beta)
end

119
plugins/Kohn_Sham/diagonalize_fock.irp.f
View File

@ -1,119 +0,0 @@
BEGIN_PROVIDER [ double precision, diagonal_Fock_matrix_mo, (ao_num) ]
&BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! Diagonal Fock matrix in the MO basis
END_DOC
integer :: i,j
integer :: liwork, lwork, n, info
integer, allocatable :: iwork(:)
double precision, allocatable :: work(:), F(:,:), S(:,:)
allocate( F(mo_tot_num_align,mo_tot_num) )
do j=1,mo_tot_num
do i=1,mo_tot_num
F(i,j) = Fock_matrix_mo(i,j)
enddo
enddo
if(no_oa_or_av_opt)then
integer :: iorb,jorb
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_inact_orb
jorb = list_inact(j)
F(iorb,jorb) = 0.d0
F(jorb,iorb) = 0.d0
enddo
do j = 1, n_virt_orb
jorb = list_virt(j)
F(iorb,jorb) = 0.d0
F(jorb,iorb) = 0.d0
enddo
do j = 1, n_core_orb
jorb = list_core(j)
F(iorb,jorb) = 0.d0
F(jorb,iorb) = 0.d0
enddo
enddo
endif
! Insert level shift here
do i = elec_beta_num+1, elec_alpha_num
F(i,i) += 0.5d0*level_shift
enddo
do i = elec_alpha_num+1, mo_tot_num
F(i,i) += level_shift
enddo
n = mo_tot_num
lwork = 1+6*n + 2*n*n
liwork = 3 + 5*n
allocate(work(lwork), iwork(liwork) )
lwork = -1
liwork = -1
call dsyevd( 'V', 'U', mo_tot_num, F, &
size(F,1), diagonal_Fock_matrix_mo, &
work, lwork, iwork, liwork, info)
if (info /= 0) then
print *, irp_here//' failed : ', info
stop 1
endif
lwork = int(work(1))
liwork = iwork(1)
deallocate(work,iwork)
allocate(work(lwork), iwork(liwork) )
call dsyevd( 'V', 'U', mo_tot_num, F, &
size(F,1), diagonal_Fock_matrix_mo, &
work, lwork, iwork, liwork, info)
if (info /= 0) then
print *, irp_here//' failed : ', info
stop 1
endif
call dgemm('N','N',ao_num,mo_tot_num,mo_tot_num, 1.d0, &
mo_coef, size(mo_coef,1), F, size(F,1), &
0.d0, eigenvectors_Fock_matrix_mo, size(eigenvectors_Fock_matrix_mo,1))
deallocate(work, iwork, F)
! endif
END_PROVIDER
BEGIN_PROVIDER [double precision, diagonal_Fock_matrix_mo_sum, (mo_tot_num)]
implicit none
BEGIN_DOC
! diagonal element of the fock matrix calculated as the sum over all the interactions
! with all the electrons in the RHF determinant
! diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij
END_DOC
integer :: i,j
double precision :: accu
do j = 1,elec_alpha_num
accu = 0.d0
do i = 1, elec_alpha_num
accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j)
enddo
diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j)
enddo
do j = elec_alpha_num+1,mo_tot_num
accu = 0.d0
do i = 1, elec_alpha_num
accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j)
enddo
diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j)
enddo
END_PROVIDER

31
plugins/Kohn_Sham/potential_functional.irp.f
View File

@ -1,31 +0,0 @@
BEGIN_PROVIDER [double precision, ao_potential_alpha_xc, (ao_num_align, ao_num)]
&BEGIN_PROVIDER [double precision, ao_potential_beta_xc, (ao_num_align, ao_num)]
implicit none
integer :: i,j,k,l
ao_potential_alpha_xc = 0.d0
ao_potential_beta_xc = 0.d0
!if(exchange_functional == "LDA")then
do i = 1, ao_num
do j = 1, ao_num
ao_potential_alpha_xc(i,j) = (1.d0 - HF_exchange) * lda_ex_potential_alpha_ao(i,j,1)
ao_potential_beta_xc(i,j) = (1.d0 - HF_exchange) * lda_ex_potential_beta_ao(i,j,1)
enddo
enddo
!endif
END_PROVIDER
BEGIN_PROVIDER [double precision, e_exchange_dft]
implicit none
!if(exchange_functional == "LDA")then
e_exchange_dft = lda_exchange(1)
!endif
END_PROVIDER
BEGIN_PROVIDER [double precision, e_correlation_dft]
implicit none
!if(correlation_functional == "LDA")then
e_correlation_dft = 0.d0
!endif
END_PROVIDER

2
plugins/MRCC_Utils/H_apply.irp.f
View File

@ -31,7 +31,7 @@ s.set_perturbation("epstein_nesbet_2x2")
s.unset_openmp()
print s
s = H_apply("mrcepa_PT2")
s = H_apply_zmq("mrcepa_PT2")
s.energy = "psi_energy"
s.set_perturbation("epstein_nesbet_2x2")
s.unset_openmp()

2
plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Perturbation Selectors_full Generators_full Psiref_Utils Psiref_CAS MRPT_Utils
Perturbation Selectors_full Generators_full Psiref_Utils Psiref_CAS

78
plugins/MRCC_Utils/amplitudes.irp.f
View File

@ -23,39 +23,33 @@
allocate(pathTo(N_det_non_ref))
pathTo(:) = 0
is_active_exc(:) = .True.
is_active_exc(:) = .false.
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
!
! 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
do hh = 1, hh_shortcut(0)
do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
do II = 1, N_det_ref
! 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_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int)
if(.not. ok) cycle
! end do
! end do
! end do
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
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
@ -72,32 +66,6 @@
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
@ -128,7 +96,7 @@ END_PROVIDER
!$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(active_hh_idx, active_pp_idx, n_exc_active)&
!$OMP shared(is_active_exc, 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)

69
plugins/MRCC_Utils/davidson.irp.f
View File

@ -35,20 +35,21 @@ 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
do i=2,sze
!$OMP DO SCHEDULE(guided)
do i=1,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
@ -223,6 +224,17 @@ 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))
@ -264,11 +276,27 @@ 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), &
@ -401,7 +429,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(static,1)
!$OMP DO SCHEDULE(dynamic)
do sh=1,shortcut(0,1)
do sh2=sh,shortcut(0,1)
exa = 0
@ -440,9 +468,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
!$OMP END DO NOWAIT
!$OMP DO SCHEDULE(static,1)
!$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)
@ -462,7 +490,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
!$OMP END DO NOWAIT
!$OMP DO
do ii=1,n_det_ref
@ -477,12 +505,13 @@ 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
@ -533,23 +562,22 @@ subroutine davidson_diag_mrcc_hs2(dets_in,u_in,dim_in,energies,sze,N_st,N_st_dia
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
do i=2,sze
!$OMP DO SCHEDULE(guided)
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))
enddo
!$OMP END DO
!$OMP END PARALLEL
!$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
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)
@ -1066,7 +1094,6 @@ 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
@ -1115,14 +1142,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

382
plugins/MRCC_Utils/mrcc_utils.irp.f
View File

@ -5,7 +5,6 @@ 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) ]
@ -63,65 +62,6 @@ 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/<Psi_0|H|D_m> 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) ]
@ -351,11 +291,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 :: h1, h2, p1, p2, s1, s2
integer*2 :: h1, h2, p1, p2, s1, s2
integer, external :: searchExc
logical, external :: excEq
double precision :: phase
integer :: tmp_array(4)
integer*2 :: tmp_array(4)
is_generable = .false.
call get_excitation(det1, det2, exc, degree, phase, Nint)
@ -366,7 +306,7 @@ logical function is_generable(det1, det2, Nint)
end if
if(degree > 2) stop "?22??"
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
call decode_exc_int2(exc,degree,h1,p1,h2,p2,s1,s2)
if(degree == 1) then
h2 = h1
@ -454,7 +394,7 @@ integer function searchExc(excs, exc, n)
use bitmasks
integer, intent(in) :: n
integer,intent(in) :: excs(4,n), exc(4)
integer*2,intent(in) :: excs(4,n), exc(4)
integer :: l, h, c
integer, external :: excCmp
logical, external :: excEq
@ -519,8 +459,8 @@ subroutine sort_exc(key, N_key)
integer, intent(in) :: N_key
integer,intent(inout) :: key(4,N_key)
integer :: tmp(4)
integer*2,intent(inout) :: key(4,N_key)
integer*2 :: tmp(4)
integer :: i,ni
@ -542,7 +482,7 @@ end subroutine
logical function exc_inf(exc1, exc2)
implicit none
integer,intent(in) :: exc1(4), exc2(4)
integer*2,intent(in) :: exc1(4), exc2(4)
integer :: i
exc_inf = .false.
do i=1,4
@ -564,9 +504,9 @@ subroutine tamise_exc(key, no, n, N_key)
! Uncodumented : TODO
END_DOC
integer,intent(in) :: no, n, N_key
integer,intent(inout) :: key(4, N_key)
integer*2,intent(inout) :: key(4, N_key)
integer :: k,j
integer :: tmp(4)
integer*2 :: tmp(4)
logical :: exc_inf
integer :: ni
@ -595,9 +535,8 @@ end subroutine
subroutine dec_exc(exc, h1, h2, p1, p2)
implicit none
integer, intent(in) :: exc(0:2,2,2)
integer, intent(out) :: h1, h2, p1, p2
integer :: degree, s1, s2
integer :: exc(0:2,2,2), s1, s2, degree
integer*2, intent(out) :: h1, h2, p1, p2
degree = exc(0,1,1) + exc(0,1,2)
@ -608,7 +547,7 @@ subroutine dec_exc(exc, h1, h2, p1, p2)
if(degree == 0) return
call decode_exc(exc, degree, h1, p1, h2, p2, s1, s2)
call decode_exc_int2(exc, degree, h1, p1, h2, p2, s1, s2)
h1 += mo_tot_num * (s1-1)
p1 += mo_tot_num * (s1-1)
@ -640,7 +579,7 @@ end subroutine
&BEGIN_PROVIDER [ integer, N_ex_exists ]
implicit none
integer :: exc(0:2, 2, 2), degree, n, on, s, l, i
integer :: h1, h2, p1, p2
integer*2 :: h1, h2, p1, p2
double precision :: phase
logical,allocatable :: hh(:,:) , pp(:,:)
@ -678,53 +617,6 @@ END_PROVIDER
call sort_det(psi_non_ref_sorted, psi_non_ref_sorted_idx, N_det_non_ref, N_int)
END_PROVIDER
BEGIN_PROVIDER [ double precision, rho_mrpt, (N_det_non_ref, N_states) ]
implicit none
integer :: i, j, k
double precision :: coef_mrpt(N_States),coef_array(N_states),hij,delta_e(N_states)
double precision :: hij_array(N_det_Ref),delta_e_array(N_det_ref,N_states)
integer :: number_of_holes, number_of_particles,nh,np
do i = 1, N_det_non_ref
print*,'i',i
nh = number_of_holes(psi_non_ref(1,1,i))
np = number_of_particles(psi_non_ref(1,1,i))
do j = 1, N_det_ref
do k = 1, N_States
coef_array(k) = psi_ref_coef(j,k)
enddo
call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,i), N_int, Hij_array(j))
call get_delta_e_dyall(psi_ref(1,1,j),psi_non_ref(1,1,i),coef_array,hij_array(j),delta_e)
! write(*,'(A7,x,100(F16.10,x))')'delta_e',delta_e(:)
do k = 1, N_states
delta_e_Array(j,k) = delta_e(k)
enddo
enddo
coef_mrpt = 0.d0
do k = 1, N_states
do j = 1, N_det_Ref
coef_mrpt(k) += psi_ref_coef(j,k) * hij_array(j) / delta_e_array(j,k)
enddo
enddo
write(*,'(A7,X,100(F16.10,x))')'coef ',psi_non_ref_coef(i,1) , coef_mrpt(1),psi_non_ref_coef(i,2) , coef_mrpt(2)
print*, nh,np
do k = 1, N_States
if(dabs(coef_mrpt(k)) .le.1.d-10)then
rho_mrpt(i,k) = 0.d0
exit
endif
if(psi_non_ref_coef(i,k) / coef_mrpt(k) .lt.0d0)then
rho_mrpt(i,k) = 1.d0
else
rho_mrpt(i,k) = psi_non_ref_coef(i,k) / coef_mrpt(k)
endif
enddo
print*,'rho',rho_mrpt(i,:)
write(33,*)i,rho_mrpt(i,:)
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, dIj_unique, (hh_nex, N_states) ]
&BEGIN_PROVIDER [ double precision, rho_mrcc, (N_det_non_ref, N_states) ]
@ -740,12 +632,12 @@ END_PROVIDER
double precision :: phase
double precision, allocatable :: rho_mrcc_inact(:)
double precision, allocatable :: rho_mrcc_init(:)
integer :: a_coll, at_roww
print *, "TI", hh_nex, N_det_non_ref
allocate(rho_mrcc_inact(N_det_non_ref))
allocate(rho_mrcc_init(N_det_non_ref))
allocate(x_new(hh_nex))
allocate(x(hh_nex), AtB(hh_nex))
@ -757,7 +649,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(static, 100)
!$OMP DO schedule(dynamic, 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)
@ -776,7 +668,7 @@ END_PROVIDER
X(a_col) = AtB(a_col)
end do
rho_mrcc_inact(:) = 0d0
rho_mrcc_init = 0d0
allocate(lref(N_det_ref))
do hh = 1, hh_shortcut(0)
@ -800,23 +692,29 @@ END_PROVIDER
X(pp) = AtB(pp)
do II=1,N_det_ref
if(lref(II) > 0) then
rho_mrcc_inact(lref(II)) = psi_ref_coef(II,s) * X(pp)
rho_mrcc_init(lref(II)) = psi_ref_coef(II,s) * X(pp)
else if(lref(II) < 0) then
rho_mrcc_inact(-lref(II)) = -psi_ref_coef(II,s) * X(pp)
rho_mrcc_init(-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,hh_nex/4
do k=0,10*hh_nex
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
@ -827,108 +725,102 @@ 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
do i=1,N_det_non_ref
rho_mrcc(i,s) = 0.d0
enddo
do s=1,N_states
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
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
norm2_ref = norm2_ref + psi_ref_coef(i,s)*psi_ref_coef(i,s)
enddo
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)
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
norm = 0.d0
double precision :: f, g, gmax
gmax = maxval(dabs(psi_non_ref_coef(:,s)))
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
do i=1,N_det_ref
norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s)
enddo
! Norm now contains the norm of Psi + A.X
print *, "norm : ", sqrt(norm)
enddo
do s=1,N_states
norm = 0.d0
double precision :: f
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
g = 2.d0+100.d0*exp(-20.d0*dabs(psi_non_ref_coef(i,s)/gmax))
f = min(f, g)
f = max(f,-g)
f = min(f,2.d0)
f = max(f,-2.d0)
endif
norm = norm + (rho_mrcc(i,s)*f)**2
norm = norm + f*f *rho_mrcc(i,s)*rho_mrcc(i,s)
rho_mrcc(i,s) = f
enddo
! rho_mrcc now contains the mu_i factors
! norm now contains the norm of |T.Psi_0>
! rho_mrcc now contains the f factors
f = 1.d0/norm
! f now contains 1/ <T.Psi_0|T.Psi_0>
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 <Psi_SD|Psi_SD>
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 (norm > 1.d0) then
if (dsqrt(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
@ -953,58 +845,11 @@ 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
double precision, external :: get_dij
double precision :: HIi, phase,delta_e_final(N_states)
double precision :: HIi, phase
if(lambda_type == 0) then
call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int)
@ -1016,11 +861,7 @@ double precision function get_dij_index(II, i, s, Nint)
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
else if(lambda_type == 3) then
call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi)
call get_delta_e_dyall(psi_ref(1,1,II),psi_non_ref(1,1,i),delta_e_final)
get_dij_index = HIi * rho_mrpt(i, s) / delta_e_final(s)
get_dij_index = get_dij_index * rho_mrcc(i,s)
end if
end function
@ -1031,11 +872,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 :: h1, h2, p1, p2, s1, s2
integer*2 :: h1, h2, p1, p2, s1, s2
integer, external :: searchExc
logical, external :: excEq
double precision :: phase
integer :: tmp_array(4)
integer*2 :: tmp_array(4)
get_dij = 0d0
call get_excitation(det1, det2, exc, degree, phase, Nint)
@ -1044,7 +885,7 @@ double precision function get_dij(det1, det2, s, Nint)
stop "get_dij"
end if
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
call decode_exc_int2(exc,degree,h1,p1,h2,p2,s1,s2)
if(degree == 1) then
h2 = h1
@ -1077,8 +918,8 @@ double precision function get_dij(det1, det2, s, Nint)
end function
BEGIN_PROVIDER [ integer, hh_exists, (4, N_hh_exists) ]
&BEGIN_PROVIDER [ integer, pp_exists, (4, N_pp_exists) ]
BEGIN_PROVIDER [ integer*2, hh_exists, (4, N_hh_exists) ]
&BEGIN_PROVIDER [ integer*2, pp_exists, (4, N_pp_exists) ]
&BEGIN_PROVIDER [ integer, hh_shortcut, (0:N_hh_exists + 1) ]
&BEGIN_PROVIDER [ integer, hh_nex ]
implicit none
@ -1093,9 +934,9 @@ end function
! hh_nex : Total number of excitation operators
!
END_DOC
integer,allocatable :: num(:,:)
integer*2,allocatable :: num(:,:)
integer :: exc(0:2, 2, 2), degree, n, on, s, l, i
integer :: h1, h2, p1, p2
integer*2 :: h1, h2, p1, p2
double precision :: phase
logical, external :: excEq
@ -1121,40 +962,24 @@ end function
hh_shortcut(0) = 1
hh_shortcut(1) = 1
hh_exists(:,1) = (/1, num(1,1), 1, num(2,1)/)
pp_exists(:,1) = (/1, num(3,1), 1, num(4,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)/)
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, num(3,s), 1, num(4,s)/)
pp_exists(:,s) = (/1_2, num(3,s), 1_2, 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, num(1,s), 1, num(2,s)/)
hh_exists(:,hh_shortcut(0)) = (/1_2, num(1,s), 1_2, 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
@ -1165,7 +990,6 @@ 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
@ -1181,7 +1005,7 @@ END_PROVIDER
logical function excEq(exc1, exc2)
implicit none
integer, intent(in) :: exc1(4), exc2(4)
integer*2, intent(in) :: exc1(4), exc2(4)
integer :: i
excEq = .false.
do i=1, 4
@ -1193,7 +1017,7 @@ end function
integer function excCmp(exc1, exc2)
implicit none
integer, intent(in) :: exc1(4), exc2(4)
integer*2, intent(in) :: exc1(4), exc2(4)
integer :: i
excCmp = 0
do i=1, 4
@ -1212,8 +1036,8 @@ subroutine apply_hole_local(det, exc, res, ok, Nint)
use bitmasks
implicit none
integer, intent(in) :: Nint
integer, intent(in) :: exc(4)
integer :: s1, s2, h1, h2
integer*2, intent(in) :: exc(4)
integer*2 :: s1, s2, h1, h2
integer(bit_kind),intent(in) :: det(Nint, 2)
integer(bit_kind),intent(out) :: res(Nint, 2)
logical, intent(out) :: ok
@ -1249,8 +1073,8 @@ subroutine apply_particle_local(det, exc, res, ok, Nint)
use bitmasks
implicit none
integer, intent(in) :: Nint
integer, intent(in) :: exc(4)
integer :: s1, s2, p1, p2
integer*2, intent(in) :: exc(4)
integer*2 :: s1, s2, p1, p2
integer(bit_kind),intent(in) :: det(Nint, 2)
integer(bit_kind),intent(out) :: res(Nint, 2)
logical, intent(out) :: ok

46
plugins/MRPT/MRPT_Utils.main.irp.f
View File

@ -10,42 +10,34 @@ end
subroutine routine_3
implicit none
integer :: i,j
!provide fock_virt_total_spin_trace
provide delta_ij
print *, 'N_det = ', N_det
print *, 'N_states = ', N_states
do i = 1, N_States
print*,'State',i
write(*,'(A12,X,I3,A3,XX,F20.16)') ' PT2 ', i,' = ', second_order_pt_new(i)
write(*,'(A12,X,I3,A3,XX,F22.16)') ' E ', i,' = ', psi_ref_average_value(i)
write(*,'(A12,X,I3,A3,XX,F22.16)') ' E+PT2 ', i,' = ', psi_ref_average_value(i)+second_order_pt_new(i)
write(*,'(A12,X,I3,A3,XX,F22.16)') ' E dressed ', i,' = ', CI_dressed_pt2_new_energy(i)
write(*,'(A12,X,I3,A3,XX,F20.16)') ' S^2 ', i,' = ', CI_dressed_pt2_new_eigenvectors_s2(i)
print*,'coef before and after'
do j = 1, N_det_ref
print*,psi_ref_coef(j,i),CI_dressed_pt2_new_eigenvectors(j,i)
enddo
enddo
if(save_heff_eigenvectors)then
call save_wavefunction_general(N_det_ref,N_states,psi_ref,N_det_ref,CI_dressed_pt2_new_eigenvectors)
endif
if(N_states.gt.1)then
print*, 'Energy differences : E(i) - E(0)'
do i = 2, N_States
print*,'State',i
write(*,'(A12,X,I3,A3,XX,F20.16)') ' S^2 ', i,' = ', CI_dressed_pt2_new_eigenvectors_s2(i)
write(*,'(A12,X,I3,A3,XX,F20.16)') 'Variational ', i,' = ', -(psi_ref_average_value(1) - psi_ref_average_value(i))
write(*,'(A12,X,I3,A3,XX,F20.16)') 'Perturbative', i,' = ', -(psi_ref_average_value(1)+second_order_pt_new(1) - (psi_ref_average_value(i)+second_order_pt_new(i)))
write(*,'(A12,X,I3,A3,XX,F20.16)') 'Dressed ', i,' = ', -( CI_dressed_pt2_new_energy(1) - CI_dressed_pt2_new_energy(i) )
enddo
endif
print *, 'PT2 = ', second_order_pt_new(1)
print *, 'E = ', CI_energy(1)
print *, 'E+PT2 = ', CI_energy(1)+second_order_pt_new(1)
print *,'****** DIAGONALIZATION OF DRESSED MATRIX ******'
print *, 'E dressed= ', CI_dressed_pt2_new_energy(1)
end
subroutine routine_2
implicit none
provide electronic_psi_ref_average_value
integer :: i
do i = 1, n_core_inact_orb
print*,fock_core_inactive_total(i,1,1),fock_core_inactive(i)
enddo
double precision :: accu
accu = 0.d0
do i = 1, n_act_orb
integer :: j_act_orb
j_act_orb = list_act(i)
accu += one_body_dm_mo_alpha(j_act_orb,j_act_orb,1)
print*,one_body_dm_mo_alpha(j_act_orb,j_act_orb,1),one_body_dm_mo_beta(j_act_orb,j_act_orb,1)
enddo
print*,'accu = ',accu
end

2
plugins/MRPT/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
MRPT_Utils Selectors_full Psiref_CAS Generators_CAS
MRPT_Utils Selectors_full Generators_full

71
plugins/MRPT/print_1h2p.irp.f
View File

@ -6,53 +6,46 @@ program print_1h2p
end
subroutine routine
implicit none
provide one_anhil_one_creat_inact_virt
end
subroutine routine_2
implicit none
integer :: i,j,degree
double precision :: hij
do i =1, n_core_inact_orb
write(*,'(I3,x,100(F16.10,X))')list_core_inact(i),fock_core_inactive_total_spin_trace(list_core_inact(i),1)
enddo
print*,''
do i =1, n_virt_orb
write(*,'(I3,x,100(F16.10,X))')list_virt(i),fock_virt_total_spin_trace(list_virt(i),1)
enddo
stop
do i = 1, n_virt_orb
do j = 1, n_inact_orb
if(dabs(one_anhil_one_creat_inact_virt(j,i,1)) .lt. 1.d-10)cycle
write(*,'(I3,x,I3,X,100(F16.10,X))')list_virt(i),list_inact(j),one_anhil_one_creat_inact_virt(j,i,1)
enddo
enddo
end
subroutine routine_3
implicit none
double precision,allocatable :: matrix_1h2p(:,:,:)
double precision :: accu(2)
allocate (matrix_1h2p(N_det_ref,N_det_ref,N_states))
allocate (matrix_1h2p(N_det,N_det,N_states))
integer :: i,j,istate
accu = 0.d0
matrix_1h2p = 0.d0
!call H_apply_mrpt_1h2p(matrix_1h2p,N_det_ref)
call give_1h2p_contrib(matrix_1h2p)
do istate = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(istate) += matrix_1h2p(i,j,istate) * psi_coef(i,istate) * psi_coef(j,istate)
do istate = 1, N_states
matrix_1h2p(i,j,istate) = 0.d0
enddo
enddo
print*,accu(istate)
enddo
call contrib_1h2p_dm_based(accu)
print*,accu(:)
if(.False.)then
call give_1h2p_contrib(matrix_1h2p)
double precision :: accu
accu = 0.d0
do i = 1, N_det
do j = 1, N_det
accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1)
enddo
enddo
print*, 'second order ', accu
endif
if(.True.)then
do i = 1, N_det
do j = 1, N_det
do istate = 1, N_states
matrix_1h2p(i,j,istate) = 0.d0
enddo
enddo
enddo
call give_1h2p_new(matrix_1h2p)
accu = 0.d0
do i = 1, N_det
do j = 1, N_det
accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1)
enddo
enddo
endif
print*, 'third order ', accu
deallocate (matrix_1h2p)
end

7
plugins/MRPT_Utils/EZFIO.cfg
View File

@ -5,10 +5,3 @@ interface: ezfio,provider,ocaml
default: True
[save_heff_eigenvectors]
type: logical
doc: If true, save the eigenvectors of the dressed matrix at the end of the MRPT calculation
interface: ezfio,provider,ocaml
default: False

8
plugins/MRPT_Utils/H_apply.irp.f
View File

@ -23,7 +23,6 @@ print s
s = H_apply("mrpt_1h")
s.filter_only_1h()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -44,7 +43,6 @@ print s
s = H_apply("mrpt_1p")
s.filter_only_1p()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -65,7 +63,6 @@ print s
s = H_apply("mrpt_1h1p")
s.filter_only_1h1p()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -86,7 +83,6 @@ print s
s = H_apply("mrpt_2p")
s.filter_only_2p()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -107,7 +103,6 @@ print s
s = H_apply("mrpt_2h")
s.filter_only_2h()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -129,7 +124,6 @@ print s
s = H_apply("mrpt_1h2p")
s.filter_only_1h2p()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -150,7 +144,6 @@ print s
s = H_apply("mrpt_2h1p")
s.filter_only_2h1p()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -171,7 +164,6 @@ print s
s = H_apply("mrpt_2h2p")
s.filter_only_2h2p()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet

Some files were not shown because too many files have changed in this diff Show More