LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-07-23 11:17:33 +02:00
Code Issues Releases Wiki Activity

Merge pull request #21 from scemama/master

Browse Source 
merge with Anthony MPI
This commit is contained in:
garniron 2017-12-06 16:18:04 +01:00 committed by GitHub
commit 107c47218e
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
189 changed files with 9268 additions and 4955 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
config/gfortran_debug.cfg
View File

@ -13,7 +13,7 @@
FC : gfortran -g -ffree-line-length-none -I .
LAPACK_LIB : -lblas -llapack
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 --assert
IRPF90_FLAGS : --ninja --align=32 --assert
# Global options
################

62
config/gfortran_mpi.cfg Normal file
View File

@ -0,0 +1,62 @@
# Common flags
##############
#
# -ffree-line-length-none : Needed for IRPF90 which produces long lines
# -lblas -llapack : Link with libblas and liblapack libraries provided by the system
# -I . : Include the curent directory (Mandatory)
#
# --ninja : Allow the utilisation of ninja. (Mandatory)
# --align=32 : Align all provided arrays on a 32-byte boundary
#
#
[COMMON]
FC : mpif90 -ffree-line-length-none -I . -g
LAPACK_LIB : -lblas -llapack
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 -DMPI
# Global options
################
#
# 1 : Activate
# 0 : Deactivate
#
[OPTION]
MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below
CACHE : 1 ; Enable cache_compile.py
OPENMP : 1 ; Append OpenMP flags
# Optimization flags
####################
#
# -Ofast : Disregard strict standards compliance. Enables all -O3 optimizations.
# It also enables optimizations that are not valid
# for all standard-compliant programs. It turns on
# -ffast-math and the Fortran-specific
# -fno-protect-parens and -fstack-arrays.
[OPT]
FCFLAGS : -Ofast -msse4.2
# Profiling flags
#################
#
[PROFILE]
FC : -p -g
FCFLAGS : -Ofast -msse4.2
# Debugging flags
#################
#
# -fcheck=all : Checks uninitialized variables, array subscripts, etc...
# -g : Extra debugging information
#
[DEBUG]
FCFLAGS : -fcheck=all -g
# OpenMP flags
#################
#
[OPENMP]
FC : -fopenmp
IRPF90_FLAGS : --openmp

2
config/ifort.cfg
View File

@ -9,7 +9,7 @@
FC : ifort
LAPACK_LIB : -mkl=parallel
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32
IRPF90_FLAGS : --ninja --align=32 -DZMQ_PUSH
# Global options
################

11
config/ifort_mpi.cfg
View File

@ -6,10 +6,10 @@
# --align=32 : Align all provided arrays on a 32-byte boundary
#
[COMMON]
FC : mpif90
FC : mpiifort
LAPACK_LIB : -mkl=parallel
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 -DMPI
IRPF90_FLAGS : --ninja --align=32 -DMPI
# Global options
################
@ -31,7 +31,7 @@ OPENMP : 1 ; Append OpenMP flags
# -ftz : Flushes denormal results to zero
#
[OPT]
FCFLAGS : -xAVX -O2 -ip -ftz -g -traceback
FCFLAGS : -xAVX -O2 -ip -ftz -g -traceback
# Profiling flags
#################
@ -51,13 +51,12 @@ FCFLAGS : -xSSE4.2 -O2 -ip -ftz
#
[DEBUG]
FC : -g -traceback
FCFLAGS : -xSSE2 -C -fpe0
IRPF90_FLAGS : --openmp
FCFLAGS : -xSSE2 -C -fpe0
# OpenMP flags
#################
#
[OPENMP]
FC : -openmp
FC : -qopenmp
IRPF90_FLAGS : --openmp

2
config/travis.cfg
View File

@ -13,7 +13,7 @@
FC : gfortran -ffree-line-length-none -I . -g
LAPACK_LIB : -llapack -lrefblas -ltmglib
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 --assert
IRPF90_FLAGS : --ninja --align=32 --assert -DZMQ_PUSH
# Global options
################

14
configure vendored
View File

@ -66,7 +66,6 @@ d_dependency = {
"python": [],
"ninja": ["g++", "python"],
"make": [],
"gpi2": ["g++", "make"],
"p_graphviz": ["python"],
"bats": []
}
@ -142,11 +141,6 @@ f77zmq = Info(
description=' F77-ZeroMQ',
default_path=join(QP_ROOT_LIB, "libf77zmq.a") )
gpi2 = Info(
url='https://github.com/cc-hpc-itwm/GPI-2/archive/v1.3.0.tar.gz',
description=' GPI-2',
default_path=join(QP_ROOT_LIB64, "libGPI2.a") )
p_graphviz = Info(
url='https://github.com/xflr6/graphviz/archive/master.tar.gz',
description=' Python library for graphviz',
@ -161,7 +155,7 @@ d_info = dict()
for m in ["ocaml", "m4", "curl", "zlib", "patch", "irpf90", "docopt",
"resultsFile", "ninja", "emsl", "ezfio", "p_graphviz",
"zeromq", "f77zmq", "bats", "gpi2"]:
"zeromq", "f77zmq", "bats"]:
exec ("d_info['{0}']={0}".format(m))
@ -497,6 +491,9 @@ def create_ninja_and_rc(l_installed):
'# Choose the correct network interface',
'# export QP_NIC=ib0',
'# export QP_NIC=eth0',
'',
'# Choose how to start MPI processes',
'# export QP_MPIRUN="mpirun"',
''
]
@ -528,11 +525,12 @@ def create_ninja_and_rc(l_installed):
try:
with open('/dev/null', 'w') as dnull:
subprocess.check_call(" ".join(l), shell=True,stderr=dnull)
subprocess.check_call(" ".join(l), shell=True, stderr=dnull)
except:
print "[ FAIL ]"
print "Check the validity of the config file provided ({0})".format(sys.argv[1])
print "Exit..."
raise
sys.exit(1)
else:

15
install/scripts/install_gpi2.sh
View File

@ -1,15 +0,0 @@
#!/bin/bash -x
TARGET=gpi2
#GPI_OPTIONS=--with-infiniband
GPI_OPTIONS=--with-ethernet
function _install()
{
cd gpi2
./install.sh -p $QP_ROOT $GPI_OPTIONS
cp src/GASPI.f90 $QP_ROOT/src/plugins/GPI2/
return 0
}
source scripts/build.sh

1
install/scripts/install_ocaml.sh
View File

@ -51,6 +51,7 @@ check_version 4.6 $i
if [[ $? == 1 ]]
then
echo "GCC version $(gcc -dumpversion) too old. GCC >= 4.6 required."
rm ${QP_ROOT}/bin/opam
exit 1
fi

2
ocaml/GaussianPrimitive.ml
View File

@ -8,7 +8,7 @@ type t =
let to_string p =
let { sym = s ; expo = e } = p in
Printf.sprintf "(%s, %f)"
Printf.sprintf "(%s, %22e)"
(Symmetry.to_string s)
(AO_expo.to_float e)

421
ocaml/Message.ml
View File

@ -264,304 +264,128 @@ end = struct
Printf.sprintf "get_task_reply 0"
end
(** GetPsi : get the current variational wave function *)
module GetPsi_msg : sig
(** GetTasks : get a new task to do *)
module GetTasks_msg : sig
type t =
{ client_id: Id.Client.t ;
state: State.t ;
n_tasks: Strictly_positive_int.t ;
}
val create : client_id:int -> t
val create : state:string -> client_id:int -> n_tasks:int -> t
val to_string : t -> string
end = struct
type t =
{ client_id: Id.Client.t ;
state: State.t ;
n_tasks: Strictly_positive_int.t;
}
let create ~client_id =
{ client_id = Id.Client.of_int client_id }
let create ~state ~client_id ~n_tasks =
{ client_id = Id.Client.of_int client_id ; state = State.of_string state ;
n_tasks = Strictly_positive_int.of_int n_tasks }
let to_string x =
Printf.sprintf "get_psi %d"
Printf.sprintf "get_tasks %s %d %d"
(State.to_string x.state)
(Id.Client.to_int x.client_id)
(Strictly_positive_int.to_int x.n_tasks)
end
module Psi : sig
type t =
{
n_state : Strictly_positive_int.t ;
n_det : Strictly_positive_int.t ;
psi_det_size : Strictly_positive_int.t ;
n_det_generators : Strictly_positive_int.t option;
n_det_selectors : Strictly_positive_int.t option;
psi_det : string ;
psi_coef : string ;
energy : string;
}
val create : n_state:Strictly_positive_int.t
-> n_det:Strictly_positive_int.t
-> psi_det_size:Strictly_positive_int.t
-> n_det_generators:Strictly_positive_int.t option
-> n_det_selectors:Strictly_positive_int.t option
-> psi_det:string -> psi_coef:string -> energy:string -> t
end = struct
type t =
{
n_state : Strictly_positive_int.t ;
n_det : Strictly_positive_int.t ;
psi_det_size : Strictly_positive_int.t ;
n_det_generators : Strictly_positive_int.t option;
n_det_selectors : Strictly_positive_int.t option;
psi_det : string ;
psi_coef : string ;
energy : string ;
}
let create ~n_state ~n_det ~psi_det_size
~n_det_generators ~n_det_selectors ~psi_det ~psi_coef
~energy =
assert (Strictly_positive_int.to_int n_det <=
Strictly_positive_int.to_int psi_det_size );
{ n_state; n_det ; psi_det_size ;
n_det_generators ; n_det_selectors ;
psi_det ; psi_coef ; energy }
end
(** GetPsiReply_msg : Reply to the GetPsi message *)
module GetPsiReply_msg : sig
type t = string list
val create : psi:Psi.t -> t
(** GetTasksReply : Reply to the GetTasks message *)
module GetTasksReply_msg : sig
type t = (Id.Task.t option * string) list
val create : t -> t
val to_string : t -> string
end = struct
type t = string list
let create ~psi =
let g, s =
match psi.Psi.n_det_generators, psi.Psi.n_det_selectors with
| Some g, Some s -> Strictly_positive_int.to_int g, Strictly_positive_int.to_int s
| _ -> -1, -1
in
let head =
Printf.sprintf "get_psi_reply %d %d %d %d %d"
(Strictly_positive_int.to_int psi.Psi.n_state)
(Strictly_positive_int.to_int psi.Psi.n_det)
(Strictly_positive_int.to_int psi.Psi.psi_det_size)
g s
in
[ head ; psi.Psi.psi_det ; psi.Psi.psi_coef ; psi.Psi.energy ]
let to_string = function
| head :: _ :: _ :: _ :: [] -> head
| _ -> raise (Invalid_argument "Bad wave function message")
end
(** PutPsi : put the current variational wave function *)
module PutPsi_msg : sig
type t =
{ client_id : Id.Client.t ;
n_state : Strictly_positive_int.t ;
n_det : Strictly_positive_int.t ;
psi_det_size : Strictly_positive_int.t ;
n_det_generators : Strictly_positive_int.t option;
n_det_selectors : Strictly_positive_int.t option;
psi : Psi.t option }
val create :
client_id:int ->
n_state:int ->
n_det:int ->
psi_det_size:int ->
psi_det:string option ->
psi_coef:string option ->
n_det_generators: int option ->
n_det_selectors:int option ->
energy:string option -> t
val to_string_list : t -> string list
val to_string : t -> string
end = struct
type t =
{ client_id : Id.Client.t ;
n_state : Strictly_positive_int.t ;
n_det : Strictly_positive_int.t ;
psi_det_size : Strictly_positive_int.t ;
n_det_generators : Strictly_positive_int.t option;
n_det_selectors : Strictly_positive_int.t option;
psi : Psi.t option }
let create ~client_id ~n_state ~n_det ~psi_det_size ~psi_det ~psi_coef
~n_det_generators ~n_det_selectors ~energy =
let n_state, n_det, psi_det_size =
Strictly_positive_int.of_int n_state,
Strictly_positive_int.of_int n_det,
Strictly_positive_int.of_int psi_det_size
in
assert (Strictly_positive_int.to_int psi_det_size >=
Strictly_positive_int.to_int n_det);
let n_det_generators, n_det_selectors =
match n_det_generators, n_det_selectors with
| Some x, Some y ->
Some (Strictly_positive_int.of_int x),
Some (Strictly_positive_int.of_int y)
| _ -> None, None
in
let psi =
match (psi_det, psi_coef, energy) with
| (Some psi_det, Some psi_coef, Some energy) ->
Some (Psi.create ~n_state ~n_det ~psi_det_size ~psi_det
~psi_coef ~n_det_generators ~n_det_selectors ~energy)
| _ -> None
in
{ client_id = Id.Client.of_int client_id ;
n_state ; n_det ; psi_det_size ; n_det_generators ;
n_det_selectors ; psi }
let to_string x =
match x.n_det_generators, x.n_det_selectors with
| Some g, Some s ->
Printf.sprintf "put_psi %d %d %d %d %d %d"
(Id.Client.to_int x.client_id)
(Strictly_positive_int.to_int x.n_state)
(Strictly_positive_int.to_int x.n_det)
(Strictly_positive_int.to_int x.psi_det_size)
(Strictly_positive_int.to_int g)
(Strictly_positive_int.to_int s)
| _, _ ->
Printf.sprintf "put_psi %d %d %d %d %d %d"
(Id.Client.to_int x.client_id)
(Strictly_positive_int.to_int x.n_state)
(Strictly_positive_int.to_int x.n_det)
(Strictly_positive_int.to_int x.psi_det_size)
(-1) (-1)
let to_string_list x =
match x.psi with
| Some psi ->
[ to_string x ; psi.Psi.psi_det ; psi.Psi.psi_coef ; psi.Psi.energy ]
| None ->
[ to_string x ; "None" ; "None" ; "None" ]
end
(** PutPsiReply_msg : Reply to the PutPsi message *)
module PutPsiReply_msg : sig
type t
val create : client_id:Id.Client.t -> t
val to_string : t -> string
end = struct
type t =
{ client_id : Id.Client.t ;
}
let create ~client_id =
{ client_id; }
let to_string x =
Printf.sprintf "put_psi_reply %d"
(Id.Client.to_int x.client_id)
type t = (Id.Task.t option * string) list
let create l = l
let to_string _ =
"get_tasks_reply ok"
let to_string_list x =
"get_tasks_reply ok" :: (
List.map x ~f:(fun (task_id, task) ->
match task_id with
| Some task_id -> Printf.sprintf "%d %s" (Id.Task.to_int task_id) task
| None -> Printf.sprintf "0 terminate"
) )
end
(** GetVector : get the current vector (Davidson) *)
module GetVector_msg : sig
type t =
{ client_id: Id.Client.t ;
}
val create : client_id:int -> t
val to_string : t -> string
end = struct
type t =
{ client_id: Id.Client.t ;
}
let create ~client_id =
{ client_id = Id.Client.of_int client_id }
let to_string x =
Printf.sprintf "get_vector %d"
(Id.Client.to_int x.client_id)
end
module Vector : sig
type t =
{
size : Strictly_positive_int.t;
data : string;
}
val create : size:Strictly_positive_int.t -> data:string -> t
end = struct
type t =
{
size : Strictly_positive_int.t;
data : string;
}
let create ~size ~data =
{ size ; data }
end
(** GetVectorReply_msg : Reply to the GetVector message *)
module GetVectorReply_msg : sig
(** PutData: put some data in the hash table *)
module PutData_msg : sig
type t =
{ client_id : Id.Client.t ;
vector : Vector.t }
val create : client_id:Id.Client.t -> vector:Vector.t -> t
{ client_id : Id.Client.t ;
state : State.t ;
key : string; }
val create : client_id: int -> state: string -> key: string -> t
val to_string : t -> string
val to_string_list : t -> string list
end = struct
type t =
{ client_id : Id.Client.t ;
vector : Vector.t }
let create ~client_id ~vector =
{ client_id ; vector }
let to_string x =
Printf.sprintf "get_vector_reply %d %d"
(Id.Client.to_int x.client_id)
(Strictly_positive_int.to_int x.vector.Vector.size)
let to_string_list x =
[ to_string x ; x.vector.Vector.data ]
end
(** PutVector : put the current variational wave function *)
module PutVector_msg : sig
type t =
{ client_id : Id.Client.t ;
size : Strictly_positive_int.t ;
vector : Vector.t option;
}
val create :
client_id:int -> size:int -> data:string option -> t
val to_string_list : t -> string list
val to_string : t -> string
end = struct
type t =
{ client_id : Id.Client.t ;
size : Strictly_positive_int.t ;
vector : Vector.t option;
}
let create ~client_id ~size ~data =
let size =
Strictly_positive_int.of_int size
in
let vector =
match data with
| None -> None
| Some s -> Some (Vector.create ~size ~data:s)
in
type t =
{ client_id : Id.Client.t ;
state : State.t ;
key : string; }
let create ~client_id ~state ~key =
{ client_id = Id.Client.of_int client_id ;
vector ; size
}
state = State.of_string state;
key ; }
let to_string x =
Printf.sprintf "put_vector %d %d"
(Id.Client.to_int x.client_id)
(Strictly_positive_int.to_int x.size)
let to_string_list x =
match x.vector with
| Some v -> [ to_string x ; v.Vector.data ]
| None -> failwith "Empty vector"
Printf.sprintf "put_data %s %d %s" (State.to_string x.state)
(Id.Client.to_int x.client_id) x.key
end
(** PutVectorReply_msg : Reply to the PutVector message *)
module PutVectorReply_msg : sig
(** PutDataReply_msg : Reply to the PutData message *)
module PutDataReply_msg : sig
type t
val create : client_id:Id.Client.t -> t
val create : unit -> t
val to_string : t -> string
end = struct
type t =
{ client_id : Id.Client.t ;
}
let create ~client_id =
{ client_id; }
type t = unit
let create () = ()
let to_string () = "put_data_reply ok"
end
(** GetData: put some data in the hash table *)
module GetData_msg : sig
type t =
{ client_id : Id.Client.t ;
state : State.t ;
key : string; }
val create : client_id: int -> state: string -> key: string -> t
val to_string : t -> string
end = struct
type t =
{ client_id : Id.Client.t ;
state : State.t ;
key : string }
let create ~client_id ~state ~key =
{ client_id = Id.Client.of_int client_id ;
state = State.of_string state;
key }
let to_string x =
Printf.sprintf "put_vector_reply %d"
(Id.Client.to_int x.client_id)
Printf.sprintf "get_data %s %d %s" (State.to_string x.state)
(Id.Client.to_int x.client_id) x.key
end
(** GetDataReply_msg : Reply to the GetData message *)
module GetDataReply_msg : sig
type t
val create : value:string -> t
val to_string : t -> string
val to_string_list : t -> string list
end = struct
type t = string
let create ~value = value
let to_string x =
Printf.sprintf "get_data_reply %d %s"
(String.length x) x
let to_string_list x = [
Printf.sprintf "get_data_reply %d"
(String.length x); x ]
end
@ -644,14 +468,10 @@ end
(** Message *)
type t =
| GetPsi of GetPsi_msg.t
| PutPsi of PutPsi_msg.t
| GetPsiReply of GetPsiReply_msg.t
| PutPsiReply of PutPsiReply_msg.t
| GetVector of GetVector_msg.t
| PutVector of PutVector_msg.t
| GetVectorReply of GetVectorReply_msg.t
| PutVectorReply of PutVectorReply_msg.t
| GetData of GetData_msg.t
| PutData of PutData_msg.t
| GetDataReply of GetDataReply_msg.t
| PutDataReply of PutDataReply_msg.t
| Newjob of Newjob_msg.t
| Endjob of Endjob_msg.t
| Connect of Connect_msg.t
@ -659,7 +479,9 @@ type t =
| Disconnect of Disconnect_msg.t
| DisconnectReply of DisconnectReply_msg.t
| GetTask of GetTask_msg.t
| GetTasks of GetTasks_msg.t
| GetTaskReply of GetTaskReply_msg.t
| GetTasksReply of GetTasksReply_msg.t
| DelTask of DelTask_msg.t
| DelTaskReply of DelTaskReply_msg.t
| AddTask of AddTask_msg.t
@ -683,6 +505,8 @@ let of_string s =
DelTask (DelTask_msg.create ~state ~task_ids)
| GetTask_ { state ; client_id } ->
GetTask (GetTask_msg.create ~state ~client_id)
| GetTasks_ { state ; client_id ; n_tasks } ->
GetTasks (GetTasks_msg.create ~state ~client_id ~n_tasks)
| TaskDone_ { state ; task_ids ; client_id } ->
TaskDone (TaskDone_msg.create ~state ~client_id ~task_ids)
| Disconnect_ { state ; client_id } ->
@ -693,24 +517,10 @@ let of_string s =
Newjob (Newjob_msg.create push_address_tcp push_address_inproc state)
| EndJob_ state ->
Endjob (Endjob_msg.create state)
| GetPsi_ client_id ->
GetPsi (GetPsi_msg.create ~client_id)
| PutPsi_ { client_id ; n_state ; n_det ; psi_det_size ; n_det_generators ; n_det_selectors } ->
begin
match n_det_selectors, n_det_generators with
| Some s, Some g ->
PutPsi (PutPsi_msg.create ~client_id ~n_state ~n_det ~psi_det_size
~n_det_generators:(Some g) ~n_det_selectors:(Some s)
~psi_det:None ~psi_coef:None ~energy:None )
| _ ->
PutPsi (PutPsi_msg.create ~client_id ~n_state ~n_det ~psi_det_size
~n_det_generators:None ~n_det_selectors:None
~psi_det:None ~psi_coef:None ~energy:None )
end
| GetVector_ client_id ->
GetVector (GetVector_msg.create ~client_id)
| PutVector_ { client_id ; size } ->
PutVector (PutVector_msg.create ~client_id ~size ~data:None )
| GetData_ { state ; client_id ; key } ->
GetData (GetData_msg.create ~client_id ~state ~key)
| PutData_ { state ; client_id ; key } ->
PutData (PutData_msg.create ~client_id ~state ~key)
| Terminate_ -> Terminate (Terminate_msg.create )
| Abort_ -> Abort (Abort_msg.create )
| SetWaiting_ -> SetWaiting
@ -722,10 +532,10 @@ let of_string s =
let to_string = function
| GetPsi x -> GetPsi_msg.to_string x
| PutPsiReply x -> PutPsiReply_msg.to_string x
| GetVector x -> GetVector_msg.to_string x
| PutVectorReply x -> PutVectorReply_msg.to_string x
| GetData x -> GetData_msg.to_string x
| PutData x -> PutData_msg.to_string x
| PutDataReply x -> PutDataReply_msg.to_string x
| GetDataReply x -> GetDataReply_msg.to_string x
| Newjob x -> Newjob_msg.to_string x
| Endjob x -> Endjob_msg.to_string x
| Connect x -> Connect_msg.to_string x
@ -733,28 +543,25 @@ let to_string = function
| Disconnect x -> Disconnect_msg.to_string x
| DisconnectReply x -> DisconnectReply_msg.to_string x
| GetTask x -> GetTask_msg.to_string x
| GetTasks x -> GetTasks_msg.to_string x
| GetTaskReply x -> GetTaskReply_msg.to_string x
| GetTasksReply x -> GetTasksReply_msg.to_string x
| DelTask x -> DelTask_msg.to_string x
| DelTaskReply x -> DelTaskReply_msg.to_string x
| AddTask x -> AddTask_msg.to_string x
| AddTaskReply x -> AddTaskReply_msg.to_string x
| TaskDone x -> TaskDone_msg.to_string x
| Terminate x -> Terminate_msg.to_string x
| Abort x -> Abort_msg.to_string x
| Abort x -> Abort_msg.to_string x
| Ok x -> Ok_msg.to_string x
| Error x -> Error_msg.to_string x
| PutPsi x -> PutPsi_msg.to_string x
| GetPsiReply x -> GetPsiReply_msg.to_string x
| PutVector x -> PutVector_msg.to_string x
| GetVectorReply x -> GetVectorReply_msg.to_string x
| SetStopped -> "set_stopped"
| SetRunning -> "set_running"
| SetWaiting -> "set_waiting"
let to_string_list = function
| PutPsi x -> PutPsi_msg.to_string_list x
| PutVector x -> PutVector_msg.to_string_list x
| GetVectorReply x -> GetVectorReply_msg.to_string_list x
| GetDataReply x -> GetDataReply_msg.to_string_list x
| GetTasksReply x -> GetTasksReply_msg.to_string_list x
| _ -> assert false

73
ocaml/Message_lexer.mll
View File

@ -9,6 +9,7 @@ type kw_type =
| ADD_TASK
| DEL_TASK
| GET_TASK
| GET_TASKS
| TASK_DONE
| DISCONNECT
| CONNECT
@ -16,10 +17,8 @@ type kw_type =
| END_JOB
| TERMINATE
| ABORT
| GET_PSI
| PUT_PSI
| GET_VECTOR
| PUT_VECTOR
| GET_DATA
| PUT_DATA
| OK
| ERROR
| SET_STOPPED
@ -30,15 +29,17 @@ 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_clientid_ntasks = { state : string ; client_id : int ; n_tasks : int}
type state_tcp_inproc = { state : string ; push_address_tcp : string ; push_address_inproc : string ; }
type psi = { client_id: int ; n_state: int ; n_det: int ; psi_det_size: int ;
n_det_generators: int option ; n_det_selectors: int option ; }
type vector = { client_id: int ; size: int }
type state_client_id_key = { state: string ; client_id: int ; key: string }
type msg =
| AddTask_ of state_tasks
| DelTask_ of state_taskids
| GetTask_ of state_clientid
| GetTasks_ of state_clientid_ntasks
| TaskDone_ of state_taskids_clientid
| Disconnect_ of state_clientid
| Connect_ of string
@ -46,10 +47,8 @@ type msg =
| EndJob_ of string
| Terminate_
| Abort_
| GetPsi_ of int
| PutPsi_ of psi
| GetVector_ of int
| PutVector_ of vector
| GetData_ of state_client_id_key
| PutData_ of state_client_id_key
| Ok_
| Error_ of string
| SetStopped_
@ -84,17 +83,16 @@ and kw = parse
| "add_task" { ADD_TASK }
| "del_task" { DEL_TASK }
| "get_task" { GET_TASK }
| "get_tasks" { GET_TASKS }
| "task_done" { TASK_DONE }
| "disconnect" { DISCONNECT }
| "connect" { CONNECT }
| "new_job" { NEW_JOB }
| "end_job" { END_JOB }
| "put_data" { PUT_DATA }
| "get_data" { GET_DATA }
| "terminate" { TERMINATE }
| "abort" { ABORT }
| "get_psi" { GET_PSI }
| "put_psi" { PUT_PSI }
| "get_vector" { GET_PSI }
| "put_vector" { PUT_PSI }
| "ok" { OK }
| "error" { ERROR }
| "set_stopped" { SET_STOPPED }
@ -161,6 +159,12 @@ and kw = parse
let state = read_word lexbuf in
let client_id = read_int lexbuf in
GetTask_ { state ; client_id }
| GET_TASKS ->
let state = read_word lexbuf in
let client_id = read_int lexbuf in
let n_tasks = read_int lexbuf in
GetTasks_ { state ; client_id ; n_tasks }
| TASK_DONE ->
let state = read_word lexbuf in
@ -173,30 +177,17 @@ and kw = parse
let client_id = read_int lexbuf in
Disconnect_ { state ; client_id }
| GET_PSI ->
| GET_DATA ->
let state = read_word lexbuf in
let client_id = read_int lexbuf in
GetPsi_ client_id
let key = read_word lexbuf in
GetData_ { state ; client_id ; key }
| 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 }
| GET_VECTOR ->
| PUT_DATA ->
let state = read_word lexbuf in
let client_id = read_int lexbuf in
GetVector_ client_id
| PUT_VECTOR ->
let client_id = read_int lexbuf in
let size = read_int lexbuf in
PutVector_ { client_id ; size }
let key = read_word lexbuf in
PutData_ { state ; client_id ; key }
| CONNECT ->
let socket = read_word lexbuf in
@ -239,6 +230,7 @@ and kw = parse
"del_task state_pouet 12345" ;
"del_task state_pouet 12345 | 6789 | 10 | 11" ;
"get_task state_pouet 12" ;
"get_tasks state_pouet 12 23" ;
"task_done state_pouet 12 12345";
"task_done state_pouet 12 12345 | 678 | 91011";
"connect tcp";
@ -262,21 +254,14 @@ and kw = parse
| 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
| GetTasks_ { state ; client_id ; n_tasks } -> Printf.sprintf "GET_TASKS state:\"%s\" task_id:%d n_tasks:%d" state client_id n_tasks
| 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
| GetVector_ client_id -> Printf.sprintf "GET_VECTOR client_id:%d" client_id
| PutVector_ { client_id ; size } ->
Printf.sprintf "PUT_VECTOR client_id:%d size:%d" client_id size
| GetData_ { state ; client_id; key } -> Printf.sprintf "GET_DATA state:%s client_id:%d key:%s" state client_id key
| PutData_ { state ; client_id ; key } -> Printf.sprintf "PUT_DATA state:%s client_id:%d key:%s" state client_id key
| Terminate_ -> "TERMINATE"
| Abort_ -> "ABORT"
| SetWaiting_ -> "SET_WAITING"

4
ocaml/Pseudo.ml
View File

@ -23,7 +23,7 @@ end = struct
{ expo = dz ; r_power = n }
let to_string p =
Printf.sprintf "(%d, %f)"
Printf.sprintf "(%d, %22e)"
(R_power.to_int p.r_power)
(AO_expo.to_float p.expo)
end
@ -52,7 +52,7 @@ end = struct
{ expo = dz ; r_power = n ; proj = p }
let to_string p =
Printf.sprintf "(%d, %f, %d)"
Printf.sprintf "(%d, %22e, %d)"
(R_power.to_int p.r_power)
(AO_expo.to_float p.expo)
(Positive_int.to_int p.proj)

395
ocaml/TaskServer.ml
View File

@ -21,14 +21,14 @@ let string_of_pub_state = function
type t =
{
queue : Queuing_system.t ;
state : Message.State.t option ;
address_tcp : Address.Tcp.t option ;
address_inproc : Address.Inproc.t option ;
psi : Message.GetPsiReply_msg.t option;
vector : Message.Vector.t option;
progress_bar : Progress_bar.t option ;
running : bool;
queue : Queuing_system.t ;
state : Message.State.t option ;
address_tcp : Address.Tcp.t option ;
address_inproc : Address.Inproc.t option ;
progress_bar : Progress_bar.t option ;
running : bool;
accepting_clients : bool;
data : (string, string) Hashtbl.t;
}
@ -41,7 +41,7 @@ let debug_env =
let debug str =
if debug_env then
Printf.printf "TASK : %s%!" str
Printf.eprintf "TASK : %s%!" str
@ -107,7 +107,6 @@ let reply_ok rep_socket =
|> ZMQ.Socket.send rep_socket
let reply_wrong_state rep_socket =
Printf.printf "WRONG STATE\n%!";
Message.Error_msg.create "Wrong state"
|> Message.Error_msg.to_string
|> ZMQ.Socket.send rep_socket
@ -161,6 +160,7 @@ let new_job msg program_state rep_socket pair_socket =
progress_bar = Some progress_bar ;
address_tcp = Some msg.Message.Newjob_msg.address_tcp;
address_inproc = Some msg.Message.Newjob_msg.address_inproc;
accepting_clients = true;
}
in
reply_ok rep_socket;
@ -189,29 +189,54 @@ let change_pub_state msg program_state rep_socket pair_socket =
program_state
let force_state =
Message.State.of_string "force"
let end_job msg program_state rep_socket pair_socket =
let failure () =
reply_wrong_state rep_socket;
program_state
and success state =
and success () =
reply_ok rep_socket;
{ program_state with
state = None ;
progress_bar = Progress_bar.clear ();
{
queue = Queuing_system.create ();
state = None ;
progress_bar = Progress_bar.clear ();
address_tcp = None;
address_inproc = None;
running = true;
accepting_clients = false;
data = Hashtbl.create ~hashable:String.hashable ();
}
and wait n =
Printf.sprintf "waiting for %d slaves..." n
|> Message.Error_msg.create
|> Message.Error_msg.to_string
|> ZMQ.Socket.send rep_socket ;
program_state
in
match program_state.state with
| None -> failure ()
| Some state ->
begin
if (msg.Message.Endjob_msg.state = state) then
if (msg.Message.Endjob_msg.state = force_state) then
begin
string_of_pub_state Waiting
|> ZMQ.Socket.send pair_socket ;
success state
success ()
end
else if (msg.Message.Endjob_msg.state = state) then
begin
string_of_pub_state Waiting
|> ZMQ.Socket.send pair_socket ;
if (Queuing_system.number_of_clients program_state.queue = 0) then
success ()
else
wait (Queuing_system.number_of_clients program_state.queue)
end
else
failure ()
@ -220,39 +245,44 @@ let end_job msg program_state rep_socket pair_socket =
let connect msg program_state rep_socket =
let state =
match program_state.state with
| Some state -> state
| None -> assert false
let failure () =
reply_wrong_state rep_socket;
program_state
in
let push_address =
match msg with
| Message.Connect_msg.Tcp ->
begin
match program_state.address_tcp with
| Some address -> Address.Tcp address
| None -> failwith "Error: No TCP address"
end
| Message.Connect_msg.Inproc ->
begin
match program_state.address_inproc with
| Some address -> Address.Inproc address
| None -> failwith "Error: No inproc address"
end
| Message.Connect_msg.Ipc -> assert false
in
let new_queue, client_id =
Queuing_system.add_client program_state.queue
in
Message.ConnectReply (Message.ConnectReply_msg.create
~state:state ~client_id ~push_address)
|> Message.to_string
|> ZMQ.Socket.send rep_socket ;
{ program_state with
queue = new_queue
}
if (not program_state.accepting_clients) then
failure ()
else
match program_state.state with
| None -> failure ()
| Some state ->
let push_address =
match msg with
| Message.Connect_msg.Tcp ->
begin
match program_state.address_tcp with
| Some address -> Address.Tcp address
| None -> failwith "Error: No TCP address"
end
| Message.Connect_msg.Inproc ->
begin
match program_state.address_inproc with
| Some address -> Address.Inproc address
| None -> failwith "Error: No inproc address"
end
| Message.Connect_msg.Ipc -> assert false
in
let new_queue, client_id =
Queuing_system.add_client program_state.queue
in
Message.ConnectReply (Message.ConnectReply_msg.create
~state:state ~client_id ~push_address)
|> Message.to_string
|> ZMQ.Socket.send rep_socket ;
{ program_state with
queue = new_queue
}
let disconnect msg program_state rep_socket =
@ -303,14 +333,21 @@ let del_task msg program_state rep_socket =
and success () =
let queue =
List.fold ~f:(fun queue task_id -> Queuing_system.del_task ~task_id queue)
~init:program_state.queue task_ids
in
let accepting_clients =
(Queuing_system.number_of_queued queue > Queuing_system.number_of_clients queue)
in
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
accepting_clients ;
queue ;
}
in
let more =
(Queuing_system.number_of_tasks new_program_state.queue > 0)
(Queuing_system.number_of_tasks queue > 0)
in
Message.DelTaskReply (Message.DelTaskReply_msg.create ~task_ids ~more)
|> Message.to_string
@ -373,12 +410,17 @@ let get_task msg program_state rep_socket pair_socket =
and success () =
let new_queue, task_id, task =
let queue, task_id, task =
Queuing_system.pop_task ~client_id program_state.queue
in
let accepting_clients =
(Queuing_system.number_of_queued queue >
Queuing_system.number_of_clients queue)
in
let no_task =
Queuing_system.number_of_queued new_queue = 0
Queuing_system.number_of_queued queue = 0
in
if no_task then
@ -390,7 +432,8 @@ let get_task msg program_state rep_socket pair_socket =
let new_program_state =
{ program_state with
queue = new_queue
queue ;
accepting_clients;
}
in
@ -413,6 +456,77 @@ let get_task msg program_state rep_socket pair_socket =
let get_tasks msg program_state rep_socket pair_socket =
let state, client_id, n_tasks =
msg.Message.GetTasks_msg.state,
msg.Message.GetTasks_msg.client_id,
Strictly_positive_int.to_int msg.Message.GetTasks_msg.n_tasks
in
let failure () =
reply_wrong_state rep_socket;
program_state
and success () =
let rec build_list accu queue = function
| 0 -> queue, (List.rev accu)
| n ->
let new_queue, task_id, task =
Queuing_system.pop_task ~client_id queue
in
match (task_id, task) with
| Some task_id, Some task ->
build_list ( (Some task_id, task)::accu ) new_queue (n-1)
| _ -> build_list ( (None, "terminate")::accu ) queue 0
in
let new_queue, result =
build_list [] program_state.queue (n_tasks)
in
let no_task =
Queuing_system.number_of_queued new_queue = 0
in
let accepting_clients =
(Queuing_system.number_of_queued new_queue >
Queuing_system.number_of_clients new_queue)
in
if no_task then
string_of_pub_state Waiting
|> ZMQ.Socket.send pair_socket
else
string_of_pub_state (Running (Message.State.to_string state))
|> ZMQ.Socket.send pair_socket;
let new_program_state =
{ program_state with
queue = new_queue;
accepting_clients;
}
in
Message.GetTasksReply (Message.GetTasksReply_msg.create result)
|> Message.to_string_list
|> ZMQ.Socket.send_all rep_socket ;
new_program_state
in
match program_state.state with
| None -> assert false
| Some state' ->
begin
if (state = state') then
success ()
else
failure ()
end
let task_done msg program_state rep_socket =
let state, client_id, task_ids =
@ -437,10 +551,17 @@ let task_done msg program_state rep_socket =
increment_progress_bar bar)
~init:(program_state.queue, program_state.progress_bar) task_ids
in
let accepting_clients =
(Queuing_system.number_of_queued new_queue >
Queuing_system.number_of_clients new_queue)
in
let result =
{ program_state with
queue = new_queue;
progress_bar = new_bar
progress_bar = new_bar;
accepting_clients
}
in
reply_ok rep_socket;
@ -458,104 +579,75 @@ let task_done msg program_state rep_socket =
end
let put_psi msg rest_of_msg program_state rep_socket =
let psi_local =
match msg.Message.PutPsi_msg.psi with
| Some x -> x
| None ->
begin
let psi_det, psi_coef, energy =
match rest_of_msg with
| [ x ; y ; e ] -> x, y, e
| _ -> failwith "Badly formed put_psi message"
in
Message.Psi.create
~n_state:msg.Message.PutPsi_msg.n_state
~n_det:msg.Message.PutPsi_msg.n_det
~psi_det_size:msg.Message.PutPsi_msg.psi_det_size
~n_det_generators:msg.Message.PutPsi_msg.n_det_generators
~n_det_selectors:msg.Message.PutPsi_msg.n_det_selectors
~psi_det
~psi_coef
~energy
end
let put_data msg rest_of_msg program_state rep_socket =
debug (Message.PutData_msg.to_string msg);
let state, key, value =
msg.Message.PutData_msg.state,
msg.Message.PutData_msg.key,
match rest_of_msg with
| [ x ] -> x
| _ -> failwith "Badly formed put_data message"
in
let new_program_state =
{ program_state with
psi = Some (Message.GetPsiReply_msg.create ~psi:psi_local)
}
and client_id =
msg.Message.PutPsi_msg.client_id
in
Message.PutPsiReply (Message.PutPsiReply_msg.create ~client_id)
|> Message.to_string
|> ZMQ.Socket.send rep_socket;
new_program_state
let get_psi msg program_state rep_socket =
begin
match program_state.psi with
| None -> failwith "No wave function saved in TaskServer"
| Some psi_message -> ZMQ.Socket.send_all rep_socket psi_message
end;
program_state
let put_vector msg rest_of_msg program_state rep_socket =
let vector_local =
match msg.Message.PutVector_msg.vector with
| Some x -> x
| None ->
begin
let data =
match rest_of_msg with
| [ x ] -> x
| _ -> failwith "Badly formed put_vector message"
in
Message.Vector.create
~size:msg.Message.PutVector_msg.size
~data
end
in
let new_program_state =
{ program_state with
vector = Some vector_local
}
and client_id =
msg.Message.PutVector_msg.client_id
in
Message.PutVectorReply (Message.PutVectorReply_msg.create ~client_id)
|> Message.to_string
|> ZMQ.Socket.send rep_socket;
new_program_state
let get_vector msg program_state rep_socket =
let client_id =
msg.Message.GetVector_msg.client_id
in
match program_state.vector with
| None -> failwith "No wave function saved in TaskServer"
| Some vector ->
Message.GetVectorReply (Message.GetVectorReply_msg.create ~client_id ~vector)
|> Message.to_string_list
|> ZMQ.Socket.send_all rep_socket;
let success () =
Hashtbl.set program_state.data ~key ~data:value ;
Message.PutDataReply (Message.PutDataReply_msg.create ())
|> Message.to_string
|> ZMQ.Socket.send rep_socket;
program_state
and failure () =
reply_wrong_state rep_socket;
program_state
in
match program_state.state with
| None -> assert false
| Some state' ->
if (state = state') then
success ()
else
failure ()
let get_data msg program_state rep_socket =
debug (Message.GetData_msg.to_string msg);
let state, key =
msg.Message.GetData_msg.state,
msg.Message.GetData_msg.key
in
let success () =
let value =
match Hashtbl.find program_state.data key with
| Some value -> value
| None -> ""
in
Message.GetDataReply (Message.GetDataReply_msg.create ~value)
|> Message.to_string_list
|> ZMQ.Socket.send_all rep_socket;
program_state
and failure () =
reply_wrong_state rep_socket;
program_state
in
match program_state.state with
| None -> assert false
| Some state' ->
if (state = state') then
success ()
else
failure ()
let terminate program_state rep_socket =
reply_ok rep_socket;
{ program_state with
psi = None;
vector = None;
address_tcp = None;
address_inproc = None;
running = false
@ -592,10 +684,14 @@ let abort program_state rep_socket =
List.fold ~f:(fun queue task_id -> Queuing_system.del_task ~task_id queue)
~init:queue tasks
in
let queue =
Queuing_system.del_client ~client_id queue
in
reply_ok rep_socket;
{ program_state with
queue
queue ;
accepting_clients = false;
}
@ -675,12 +771,12 @@ let run ~port =
let initial_program_state =
{ queue = Queuing_system.create () ;
running = true ;
psi = None;
vector = None;
state = None;
address_tcp = None;
address_inproc = None;
progress_bar = None ;
accepting_clients = false;
data = Hashtbl.create ~hashable:String.hashable ();
}
in
@ -747,10 +843,8 @@ let run ~port =
match program_state.state, message with
| _ , Message.Terminate _ -> terminate program_state rep_socket
| _ , Message.Abort _ -> abort program_state rep_socket
| _ , Message.PutVector x -> put_vector x rest program_state rep_socket
| _ , Message.GetVector x -> get_vector x program_state rep_socket
| _ , Message.PutPsi x -> put_psi x rest program_state rep_socket
| _ , Message.GetPsi x -> get_psi x program_state rep_socket
| _ , Message.PutData x -> put_data x rest program_state rep_socket
| _ , Message.GetData x -> get_data x program_state rep_socket
| None , Message.Newjob x -> new_job x program_state rep_socket pair_socket
| _ , Message.Newjob _ -> error "A job is already running" program_state rep_socket
| Some _, Message.Endjob x -> end_job x program_state rep_socket pair_socket
@ -763,6 +857,7 @@ let run ~port =
| Some _, Message.AddTask x -> add_task x program_state rep_socket
| Some _, Message.DelTask x -> del_task x program_state rep_socket
| Some _, Message.GetTask x -> get_task x program_state rep_socket pair_socket
| Some _, Message.GetTasks x -> get_tasks x program_state rep_socket pair_socket
| Some _, Message.TaskDone x -> task_done x program_state rep_socket
| _ , _ ->
error ("Invalid message : "^(Message.to_string message)) program_state rep_socket

23
ocaml/TaskServer.mli
View File

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

16
ocaml/qp_create_ezfio_from_xyz.ml
View File

@ -9,6 +9,8 @@ let spec =
~doc:"file Name of the created EZFIO file."
+> flag "b" (required string)
~doc:"string Name of basis set."
+> flag "au" no_arg
~doc:"Input geometry is in atomic units."
+> flag "c" (optional_with_default 0 int)
~doc:"int Total charge of the molecule. Default is 0."
+> flag "d" (optional_with_default 0. float)
@ -92,12 +94,16 @@ let list_basis () =
(** Run the program *)
let run ?o b c d m p cart xyz_file =
let run ?o b au c d m p cart xyz_file =
(* Read molecule *)
let molecule =
(Molecule.of_file xyz_file ~charge:(Charge.of_int c)
~multiplicity:(Multiplicity.of_int m) )
if au then
(Molecule.of_file xyz_file ~charge:(Charge.of_int c)
~multiplicity:(Multiplicity.of_int m) ~units:Units.Bohr)
else
(Molecule.of_file xyz_file ~charge:(Charge.of_int c)
~multiplicity:(Multiplicity.of_int m) )
in
let dummy =
dummy_centers ~threshold:d ~molecule ~nuclei:molecule.Molecule.nuclei
@ -682,8 +688,8 @@ Otherwise, the basis set is obtained from the database.
" )
spec
(fun o b c d m p cart xyz_file () ->
run ?o b c d m p cart xyz_file )
(fun o b au c d m p cart xyz_file () ->
run ?o b au c d m p cart xyz_file )
let () =

42
ocaml/qp_overlap_of_wf.ml
View File

@ -16,7 +16,8 @@ let () =
"Syntax : %s EZFIO1 EZFIO2" Sys.argv.(0)))
in
let fetch_wf filename =
let fetch_wf ~state filename =
(* State 0 is the ground state *)
Ezfio.set_file filename;
let mo_tot_num =
Ezfio.get_mo_basis_mo_tot_num ()
@ -28,6 +29,9 @@ let () =
let n_det =
Det_number.to_int d.Determinants_by_hand.n_det
in
let state_shift =
state*n_det
in
let keys =
Array.map (Determinant.to_string ~mo_tot_num)
d.Determinants_by_hand.psi_det
@ -40,7 +44,7 @@ let () =
in
for i=0 to n_det-1
do
Hashtbl.add hash keys.(i) values.(i);
Hashtbl.add hash keys.(i) values.(state_shift+i);
done;
hash
in
@ -60,14 +64,30 @@ let () =
result /. (sqrt (norm *. norm'))
in
let wf, wf' =
fetch_wf ezfio,
fetch_wf ezfio'
let n_st1 =
Ezfio.set_file ezfio;
Ezfio.get_determinants_n_states ()
and n_st2 =
Ezfio.set_file ezfio';
Ezfio.get_determinants_n_states ()
in
Array.init n_st2 (fun i -> i)
|> Array.iter (fun state_j ->
Printf.printf "%d " (state_j+1);
let wf' =
fetch_wf ~state:state_j ezfio'
in
Array.init n_st1 (fun i -> i)
|> Array.iter (fun state_i ->
let wf =
fetch_wf ~state:state_i ezfio
in
let o =
overlap wf wf'
in
Printf.printf "%f %!" (abs_float o)
);
Printf.printf "\n%!"
)
let o =
overlap wf wf'
in
print_float (abs_float o) ;
print_newline ()

15
ocaml/qp_run.ml
View File

@ -17,7 +17,6 @@ let () =
let run slave exe ezfio_file =
(** Check availability of the ports *)
let port_number =
let zmq_context =
@ -46,6 +45,7 @@ let run slave exe ezfio_file =
ZMQ.Context.terminate zmq_context;
result
in
let time_start =
Time.now ()
in
@ -70,11 +70,12 @@ let run slave exe ezfio_file =
(** Check input *)
begin
match (Sys.command ("qp_edit -c "^ezfio_file)) with
| 0 -> ()
| i -> failwith "Error: Input inconsistent\n"
end;
if (not slave) then
begin
match (Sys.command ("qp_edit -c "^ezfio_file)) with
| 0 -> ()
| i -> failwith "Error: Input inconsistent\n"
end;
let qp_run_address_filename =
Filename.concat (Qpackage.ezfio_work ezfio_file) "qp_run_address"
@ -141,7 +142,7 @@ let spec =
let open Command.Spec in
empty
+> flag "slave" no_arg
~doc:(" Needed for slave tasks")
~doc:(" Required for slave tasks")
+> anon ("executable" %: string)
+> anon ("ezfio_file" %: string)
;;

14
ocaml/qp_set_mo_class.ml
View File

@ -203,6 +203,18 @@ let set ~core ~inact ~act ~virt ~del =
let get () =
let data =
match Input.Electrons.read () with
| None -> failwith "Unable to read electrons"
| Some x -> x
in
let elec_alpha_num =
Elec_alpha_number.to_int data.Input.Electrons.elec_alpha_num
and elec_beta_num =
Elec_beta_number.to_int data.Input.Electrons.elec_beta_num
in
let data =
match Input.Mo_basis.read () with
| None -> failwith "Unable to read MOs"
@ -213,11 +225,13 @@ let get () =
MO_number.to_int data.Input.Mo_basis.mo_tot_num
in
let n_int =
try N_int_number.of_int (Ezfio.get_determinants_n_int ())
with _ -> Bitlist.n_int_of_mo_tot_num mo_tot_num
in
Printf.printf "Electrons: %d %d\n" elec_alpha_num elec_beta_num;
Printf.printf "MO : %d\n" mo_tot_num;
Printf.printf "n_int: %d\n" (N_int_number.to_int n_int);

16
plugins/All_singles/H_apply.irp.f
View File

@ -8,6 +8,22 @@ s.unset_skip()
s.filter_only_1h1p()
print s
s = H_apply("just_2p")
s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_skip()
s.filter_only_2p()
print s
s = H_apply("just_1p")
s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_skip()
s.filter_only_1p()
print s
s = H_apply("just_1h_1p_singles",do_double_exc=False)
s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_skip()

2
plugins/All_singles/all_singles.irp.f
View File

@ -15,7 +15,7 @@ subroutine routine
integer :: N_st, degree
double precision,allocatable :: E_before(:)
integer :: n_det_before
N_st = N_states_diag
N_st = N_states
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
i = 0
print*,'N_det = ',N_det

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

@ -22,21 +22,25 @@ subroutine run_selection_slave(thread,iproc,energy)
double precision :: pt2(N_states)
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 disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
integer, external :: connect_to_taskserver
if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread)
return
end if
endif
zmq_socket_push = new_zmq_push_socket(thread)
buf%N = 0
ctask = 1
pt2 = 0d0
do
call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task)
integer, external :: get_task_from_taskserver
if (get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task) == -1) then
exit
endif
done = task_id(ctask) == 0
if (done) then
ctask = ctask - 1
@ -53,10 +57,18 @@ subroutine run_selection_slave(thread,iproc,energy)
call select_connected(i_generator,energy,pt2,buf)
endif
integer, external :: task_done_to_taskserver
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))
if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) == -1) then
call sleep(1)
if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) == -1) then
done = .True.
ctask = 0
exit
endif
endif
end do
if(ctask > 0) then
call push_selection_results(zmq_socket_push, pt2, buf, task_id(1), ctask)
@ -74,7 +86,12 @@ subroutine run_selection_slave(thread,iproc,energy)
if(done) exit
ctask = ctask + 1
end do
call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
integer, external :: disconnect_from_taskserver
if (disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) == -1) then
continue
endif
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread)
end subroutine

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

@ -646,7 +646,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
do p2=ib,mo_tot_num
if(bannedOrb(p2, s2)) cycle
if(banned(p1,p2)) cycle
if(mat(1, p1, p2) == 0d0) cycle
if(sum(dabs(mat(:, p1, p2))) == 0d0) cycle
call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
logical, external :: is_in_wavefunction
@ -1193,21 +1193,40 @@ subroutine ZMQ_selection(N_in, pt2)
implicit none
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
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
integer, external :: zmq_put_psi
integer, external :: zmq_put_N_det_generators
integer, external :: zmq_put_N_det_selectors
integer, external :: zmq_put_dvector
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))
PROVIDE pt2_e0_denominator nproc
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
PROVIDE psi_bilinear_matrix_transp_order
call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'selection')
if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then
stop 'Unable to put psi'
endif
if (zmq_put_N_det_generators(zmq_to_qp_run_socket, 1) == -1) then
stop 'Unable to put N_det_generators'
endif
if (zmq_put_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) then
stop 'Unable to put N_det_selectors'
endif
if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) == -1) then
stop 'Unable to put energy'
endif
call create_selection_buffer(N, N*2, b)
endif
@ -1215,37 +1234,50 @@ subroutine ZMQ_selection(N_in, pt2)
task = ' '
integer :: k
integer, external :: add_task_to_taskserver
k=0
do i= 1, N_det_generators
k = k+1
write(task(20*(k-1)+1:20*k),'(I9,1X,I9,''|'')') i, N
if (k>=maxtasks) then
k=0
call add_task_to_taskserver(zmq_to_qp_run_socket,task)
if (add_task_to_taskserver(zmq_to_qp_run_socket,task) == -1) then
stop 'Unable to add task to task server'
endif
endif
enddo
if (k > 0) then
call add_task_to_taskserver(zmq_to_qp_run_socket,task)
if (add_task_to_taskserver(zmq_to_qp_run_socket,task) == -1) then
stop 'Unable to add task to task server'
endif
endif
integer, external :: zmq_set_running
if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
print *, irp_here, ': Failed in zmq_set_running'
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)
call selection_collector(zmq_socket_pull, b, pt2)
else
call selection_slave_inproc(i)
endif
!$OMP END PARALLEL
call end_parallel_job(zmq_to_qp_run_socket, 'selection')
call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'selection')
do i=N_det+1,N_states
pt2(i) = 0.d0
enddo
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
if (s2_eig .or. (N_states > 1) ) then
call make_s2_eigenfunction
endif
call save_wavefunction
endif
call delete_selection_buffer(b)
end subroutine
@ -1256,7 +1288,7 @@ subroutine selection_slave_inproc(i)
call run_selection_slave(1,i,pt2_e0_denominator)
end
subroutine selection_collector(b, pt2)
subroutine selection_collector(zmq_socket_pull, b, pt2)
use f77_zmq
use selection_types
use bitmasks
@ -1270,7 +1302,7 @@ subroutine selection_collector(b, pt2)
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
integer(ZMQ_PTR), external :: new_zmq_pull_socket
integer(ZMQ_PTR) :: zmq_socket_pull
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
integer :: msg_size, rc, more
integer :: acc, i, j, robin, N, ntask
@ -1280,7 +1312,6 @@ subroutine selection_collector(b, pt2)
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
@ -1297,16 +1328,17 @@ subroutine selection_collector(b, pt2)
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)
integer, external :: zmq_delete_task
if (zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more) == -1) then
stop 'Unable to delete task'
endif
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)
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
end subroutine

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

@ -15,6 +15,18 @@ subroutine create_selection_buffer(N, siz, res)
res%cur = 0
end subroutine
subroutine delete_selection_buffer(b)
use selection_types
implicit none
type(selection_buffer), intent(inout) :: b
if (allocated(b%det)) then
deallocate(b%det)
endif
if (allocated(b%val)) then
deallocate(b%val)
endif
end
subroutine add_to_selection_buffer(b, det, val)
use selection_types

7
plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f
View File

@ -27,6 +27,7 @@ subroutine run_wf
character*(64) :: states(4)
integer :: rc, i
integer, external :: zmq_get_psi
call provide_everything
zmq_context = f77_zmq_ctx_new ()
@ -50,7 +51,7 @@ subroutine run_wf
! ---------
print *, 'Selection'
call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
if (zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) == -1) cycle
!$OMP PARALLEL PRIVATE(i)
i = omp_get_thread_num()
@ -64,7 +65,7 @@ subroutine run_wf
! --------
print *, 'Davidson'
call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
if (zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) == -1) cycle
call omp_set_nested(.True.)
call davidson_slave_tcp(0)
call omp_set_nested(.False.)
@ -76,7 +77,7 @@ subroutine run_wf
! ---
print *, 'PT2'
call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
if (zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) == -1) cycle
!$OMP PARALLEL PRIVATE(i)
i = omp_get_thread_num()

2
plugins/CIS/cis.irp.f
View File

@ -2,8 +2,6 @@ program cis
implicit none
integer :: i
! print *, 'HF = ', HF_energy
! print *, 'N_states = ', N_states
call H_apply_cis
print *, 'N_det = ', N_det
do i = 1,N_states

8
plugins/CISD/cisd.irp.f
View File

@ -13,10 +13,8 @@ program cisd
print *, 'E_corr = ',CI_electronic_energy(i) - ref_bitmask_energy
enddo
call save_wavefunction
call ezfio_set_cisd_energy(CI_energy(1))
! call CISD_SC2(psi_det,psi_coef,eigvalues,size(psi_coef,1),N_det,N_states,N_int)
! do i = 1, N_states
! print*,'eigvalues(i) = ',eigvalues(i)
! enddo
psi_coef = ci_eigenvectors
SOFT_TOUCH psi_coef
call save_wavefunction
end

6
plugins/DensityMatrix/density_matrix.irp.f
View File

@ -167,9 +167,9 @@ END_PROVIDER
END_TEMPLATE
BEGIN_PROVIDER [ double precision, two_body_dm_diag_aa, (mo_tot_num_align,mo_tot_num)]
&BEGIN_PROVIDER [ double precision, two_body_dm_diag_bb, (mo_tot_num_align,mo_tot_num)]
&BEGIN_PROVIDER [ double precision, two_body_dm_diag_ab, (mo_tot_num_align,mo_tot_num)]
BEGIN_PROVIDER [ double precision, two_body_dm_diag_aa, (mo_tot_num,mo_tot_num)]
&BEGIN_PROVIDER [ double precision, two_body_dm_diag_bb, (mo_tot_num,mo_tot_num)]
&BEGIN_PROVIDER [ double precision, two_body_dm_diag_ab, (mo_tot_num,mo_tot_num)]
implicit none
use bitmasks
BEGIN_DOC

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

@ -725,8 +725,8 @@ subroutine density_matrix_1h1p(dets_in,u_in,density_matrix_alpha,density_matrix_
integer, intent(in) :: dim_in, sze, N_st, Nint
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
double precision, intent(inout) :: u_in(dim_in,N_st)
double precision, intent(inout) :: density_matrix_alpha(mo_tot_num_align,mo_tot_num)
double precision, intent(inout) :: density_matrix_beta(mo_tot_num_align,mo_tot_num)
double precision, intent(inout) :: density_matrix_alpha(mo_tot_num,mo_tot_num)
double precision, intent(inout) :: density_matrix_beta(mo_tot_num,mo_tot_num)
double precision, intent(inout) :: norm
integer :: i,j,k,l

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

@ -1,5 +1,5 @@
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, one_body_dm_mo_alpha_generators_restart, (mo_tot_num,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_generators_restart, (mo_tot_num,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, norm_generators_restart]
implicit none
BEGIN_DOC
@ -40,9 +40,9 @@
!$OMP PRIVATE(j,k,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc, &
!$OMP tmp_a, tmp_b, n_occ_alpha)&
!$OMP SHARED(psi_det_generators_restart,psi_coef_generators_restart,N_int,elec_alpha_num,&
!$OMP elec_beta_num,one_body_dm_mo_alpha_generators_restart,one_body_dm_mo_beta_generators_restart,N_det_generators_restart,mo_tot_num_align,&
!$OMP elec_beta_num,one_body_dm_mo_alpha_generators_restart,one_body_dm_mo_beta_generators_restart,N_det_generators_restart,&
!$OMP mo_tot_num,N_states, state_average_weight)
allocate(tmp_a(mo_tot_num_align,mo_tot_num), tmp_b(mo_tot_num_align,mo_tot_num) )
allocate(tmp_a(mo_tot_num,mo_tot_num), tmp_b(mo_tot_num,mo_tot_num) )
tmp_a = 0.d0
tmp_b = 0.d0
!$OMP DO SCHEDULE(dynamic)
@ -98,7 +98,7 @@ END_PROVIDER
BEGIN_PROVIDER [ double precision, one_body_dm_mo_generators_restart, (mo_tot_num_align,mo_tot_num) ]
BEGIN_PROVIDER [ double precision, one_body_dm_mo_generators_restart, (mo_tot_num,mo_tot_num) ]
implicit none
BEGIN_DOC
! One-body density matrix for the generators_restart
@ -106,7 +106,7 @@ BEGIN_PROVIDER [ double precision, one_body_dm_mo_generators_restart, (mo_tot_nu
one_body_dm_mo_generators_restart = one_body_dm_mo_alpha_generators_restart + one_body_dm_mo_beta_generators_restart
END_PROVIDER
BEGIN_PROVIDER [ double precision, one_body_spin_density_mo_generators_restart, (mo_tot_num_align,mo_tot_num) ]
BEGIN_PROVIDER [ double precision, one_body_spin_density_mo_generators_restart, (mo_tot_num,mo_tot_num) ]
implicit none
BEGIN_DOC
! rho(alpha) - rho(beta)
@ -115,16 +115,16 @@ BEGIN_PROVIDER [ double precision, one_body_spin_density_mo_generators_restart,
END_PROVIDER
BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_osoci, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_osoci, (mo_tot_num_align,mo_tot_num) ]
BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_osoci, (mo_tot_num,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_osoci, (mo_tot_num,mo_tot_num) ]
implicit none
BEGIN_DOC
! Alpha and beta one-body density matrix that will be used for the OSOCI approach
END_DOC
END_PROVIDER
BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_1h1p, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_1h1p, (mo_tot_num_align,mo_tot_num) ]
BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_1h1p, (mo_tot_num,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_1h1p, (mo_tot_num,mo_tot_num) ]
implicit none
BEGIN_DOC
! Alpha and beta one-body density matrix that will be used for the 1h1p approach

4
plugins/FOBOCI/diag_fock_inactiv_virt.irp.f
View File

@ -1,7 +1,7 @@
subroutine diag_inactive_virt_and_update_mos
implicit none
integer :: i,j,i_inact,j_inact,i_virt,j_virt
double precision :: tmp(mo_tot_num_align,mo_tot_num)
double precision :: tmp(mo_tot_num,mo_tot_num)
character*(64) :: label
print*,'Diagonalizing the occ and virt Fock operator'
tmp = 0.d0
@ -38,7 +38,7 @@ end
subroutine diag_inactive_virt_new_and_update_mos
implicit none
integer :: i,j,i_inact,j_inact,i_virt,j_virt,k,k_act
double precision :: tmp(mo_tot_num_align,mo_tot_num),accu,get_mo_bielec_integral
double precision :: tmp(mo_tot_num,mo_tot_num),accu,get_mo_bielec_integral
character*(64) :: label
tmp = 0.d0
do i = 1, mo_tot_num

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

@ -110,7 +110,7 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
call update_density_matrix_osoci
enddo
if(.True.)then
if(.False.)then
print*,''
print*,'DOING THEN THE MLCT !!'
print*,'Threshold_mlct = ',threshold_mlct

180
plugins/FourIdx/four_index.irp.f Normal file
View File

@ -0,0 +1,180 @@
subroutine four_index_transform(map_a,map_c,matrix_B,LDB, &
i_start, j_start, k_start, l_start, &
i_end , j_end , k_end , l_end , &
a_start, b_start, c_start, d_start, &
a_end , b_end , c_end , d_end )
implicit none
use map_module
use mmap_module
BEGIN_DOC
! Performs a four-index transformation of map_a(N^4) into map_c(M^4) using b(NxM)
! C_{abcd} = \sum_{ijkl} A_{ijkl}.B_{ia}.B_{jb}.B_{kc}.B_{ld}
! Loops run over *_start->*_end
END_DOC
type(map_type), intent(in) :: map_a
type(map_type), intent(inout) :: map_c
integer, intent(in) :: LDB
double precision, intent(in) :: matrix_B(LDB,*)
integer, intent(in) :: i_start, j_start, k_start, l_start
integer, intent(in) :: i_end , j_end , k_end , l_end
integer, intent(in) :: a_start, b_start, c_start, d_start
integer, intent(in) :: a_end , b_end , c_end , d_end
double precision, allocatable :: T(:,:,:), U(:,:,:), V(:,:,:)
integer :: i_max, j_max, k_max, l_max
integer :: i_min, j_min, k_min, l_min
integer :: i, j, k, l
integer :: a, b, c, d
double precision, external :: get_ao_bielec_integral
integer(key_kind) :: idx
real(integral_kind) :: tmp
integer(key_kind), allocatable :: key(:)
real(integral_kind), allocatable :: value(:)
ASSERT (k_start == i_start)
ASSERT (l_start == j_start)
ASSERT (a_start == c_start)
ASSERT (b_start == d_start)
i_min = min(i_start,a_start)
i_max = max(i_end ,a_end )
j_min = min(j_start,b_start)
j_max = max(j_end ,b_end )
k_min = min(k_start,c_start)
k_max = max(k_end ,c_end )
l_min = min(l_start,d_start)
l_max = max(l_end ,d_end )
ASSERT (0 < i_max)
ASSERT (0 < j_max)
ASSERT (0 < k_max)
ASSERT (0 < l_max)
ASSERT (LDB >= i_max)
ASSERT (LDB >= j_max)
ASSERT (LDB >= k_max)
ASSERT (LDB >= l_max)
! Create a temporary memory-mapped file
integer :: fd
type(c_ptr) :: c_pointer
integer*8, pointer :: a_array(:,:,:)
call mmap(trim(ezfio_filename)//'/work/four_idx', &
(/ 4_8,int(i_end-i_start+1,8),int(j_end-j_start+1,8),int(k_end-k_start+1,8), int(l_end-l_start+1,8) /), 8, fd, .False., c_pointer)
call c_f_pointer(c_pointer, a_array, (/ 4, (i_end-i_start+1)*(j_end-j_start+1)*(k_end-k_start+1), l_end-l_start+1 /))
!$OMP PARALLEL DEFAULT(NONE) SHARED(a_array,c_pointer,fd, &
!$OMP a_start,a_end,b_start,b_end,c_start,c_end,d_start,d_end,&
!$OMP i_start,i_end,j_start,j_end,k_start,k_end,l_start,l_end,&
!$OMP i_min,i_max,j_min,j_max,k_min,k_max,l_min,l_max, &
!$OMP map_a,map_c,matrix_B) &
!$OMP PRIVATE(key,value,T,U,V,i,j,k,l,idx, &
!$OMP a,b,c,d,tmp)
allocate( key(i_max*j_max*k_max), value(i_max*j_max*k_max) )
allocate( U(a_start:a_end, c_start:c_end, b_start:b_end) )
!$OMP DO SCHEDULE(dynamic,4)
do l=l_start,l_end
a = 1
do j=j_start,j_end
do k=k_start,k_end
do i=i_start,i_end
call bielec_integrals_index(i,j,k,l,idx)
call map_get(map_a,idx,tmp)
if (tmp /= 0.d0) then
a = a+1
a_array(1,a,l-l_start+1) = i
a_array(2,a,l-l_start+1) = j
a_array(3,a,l-l_start+1) = k
a_array(4,a,l-l_start+1) = transfer(dble(tmp), 1_8)
endif
enddo
enddo
enddo
a_array(1,1,l-l_start+1) = a
print *, l
enddo
!$OMP END DO
!$OMP DO SCHEDULE(dynamic)
do d=d_start,d_end
U = 0.d0
do l=l_start,l_end
if (dabs(matrix_B(l,d)) < 1.d-10) then
cycle
endif
print *, d, l
allocate( T(i_start:i_end, k_start:k_end, j_start:j_end), &
V(a_start:a_end, k_start:k_end, j_start:j_end) )
T = 0.d0
do a=2,a_array(1,1,l-l_start+1)
i = a_array(1,a,l-l_start+1)
j = a_array(2,a,l-l_start+1)
k = a_array(3,a,l-l_start+1)
T(i, k,j) = transfer(a_array(4,a,l-l_start+1), 1.d0)
enddo
call DGEMM('T','N', (a_end-a_start+1), &
(k_end-k_start+1)*(j_end-j_start+1), &
(i_end-i_start+1), 1.d0, &
matrix_B(i_start,a_start), size(matrix_B,1), &
T(i_start,k_start,j_start), size(T,1), 0.d0, &
V(a_start,k_start,j_start), size(V, 1) )
deallocate(T)
allocate( T(a_start:a_end, k_start:k_end, b_start:d) )
call DGEMM('N','N', (a_end-a_start+1)*(k_end-k_start+1), &
(b_end-b_start+1), &
(j_end-j_start+1), 1.d0, &
V(a_start,k_start,j_start), size(V,1)*size(V,2), &
matrix_B(j_start,b_start), size(matrix_B,1),0.d0, &
T(a_start,k_start,b_start), size(T,1)*size(T,2) )
deallocate(V)
do b=b_start,b_end
call DGEMM('N','N', (a_end-a_start+1), (c_end-c_start+1), &
(k_end-k_start+1), matrix_B(l, d), &
T(a_start,k_start,b), size(T,1), &
matrix_B(k_start,c_start), size(matrix_B,1), 1.d0, &
U(a_start,c_start,b), size(U,1) )
enddo
deallocate(T)
enddo
idx = 0_8
do b=b_start,b_end
do c=c_start,c_end
do a=a_start,a_end
if (dabs(U(a,c,b)) < 1.d-15) then
cycle
endif
idx = idx+1_8
call bielec_integrals_index(a,b,c,d,key(idx))
value(idx) = U(a,c,b)
enddo
enddo
enddo
!$OMP CRITICAL
call map_append(map_c, key, value, idx)
call map_sort(map_c)
!$OMP END CRITICAL
enddo
!$OMP END DO
deallocate(key,value)
!$OMP END PARALLEL
call munmap( &
(/ 4_8,int(i_end-i_start+1,8),int(j_end-j_start+1,8),int(k_end-k_start+1,8), int(l_end-l_start+1,8) /), 8, fd, c_pointer)
end

277
plugins/FourIdx/four_index_sym.irp.f Normal file
View File

@ -0,0 +1,277 @@
subroutine four_index_transform_sym(map_a,map_c,matrix_B,LDB, &
i_start, j_start, k_start, l_start, &
i_end , j_end , k_end , l_end , &
a_start, b_start, c_start, d_start, &
a_end , b_end , c_end , d_end )
implicit none
use map_module
use mmap_module
BEGIN_DOC
! Performs a four-index transformation of map_a(N^4) into map_c(M^4) using b(NxM)
! C_{abcd} = \sum_{ijkl} A_{ijkl}.B_{ia}.B_{jb}.B_{kc}.B_{ld}
! Loops run over *_start->*_end
END_DOC
type(map_type), intent(in) :: map_a
type(map_type), intent(inout) :: map_c
integer, intent(in) :: LDB
double precision, intent(in) :: matrix_B(LDB,*)
integer, intent(in) :: i_start, j_start, k_start, l_start
integer, intent(in) :: i_end , j_end , k_end , l_end
integer, intent(in) :: a_start, b_start, c_start, d_start
integer, intent(in) :: a_end , b_end , c_end , d_end
double precision, allocatable :: T(:,:), U(:,:,:), V(:,:)
double precision, allocatable :: T2d(:,:), V2d(:,:)
integer :: i_max, j_max, k_max, l_max
integer :: i_min, j_min, k_min, l_min
integer :: i, j, k, l, ik, ll
integer :: a, b, c, d
double precision, external :: get_ao_bielec_integral
integer*8 :: ii
integer(key_kind) :: idx
real(integral_kind) :: tmp
integer(key_kind), allocatable :: key(:)
real(integral_kind), allocatable :: value(:)
integer*8, allocatable :: l_pointer(:)
ASSERT (k_start == i_start)
ASSERT (l_start == j_start)
ASSERT (a_start == c_start)
ASSERT (b_start == d_start)
i_min = min(i_start,a_start)
i_max = max(i_end ,a_end )
j_min = min(j_start,b_start)
j_max = max(j_end ,b_end )
k_min = min(k_start,c_start)
k_max = max(k_end ,c_end )
l_min = min(l_start,d_start)
l_max = max(l_end ,d_end )
ASSERT (0 < i_max)
ASSERT (0 < j_max)
ASSERT (0 < k_max)
ASSERT (0 < l_max)
ASSERT (LDB >= i_max)
ASSERT (LDB >= j_max)
ASSERT (LDB >= k_max)
ASSERT (LDB >= l_max)
! Create a temporary memory-mapped file
integer :: fd
type(c_ptr) :: c_pointer
integer*8, pointer :: a_array(:)
call mmap(trim(ezfio_filename)//'/work/four_idx', &
(/ 12_8 * map_a % n_elements /), 8, fd, .False., c_pointer)
call c_f_pointer(c_pointer, a_array, (/ 12_8 * map_a % n_elements /))
allocate(l_pointer(l_start:l_end+1), value((i_max*k_max)) )
ii = 1_8
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l,ik,idx)
do l=l_start,l_end
!$OMP SINGLE
l_pointer(l) = ii
!$OMP END SINGLE
do j=j_start,j_end
!$OMP DO SCHEDULE(static,1)
do k=k_start,k_end
do i=i_start,k
ik = (i-i_start+1) + ishft( (k-k_start)*(k-k_start+1), -1 )
call bielec_integrals_index(i,j,k,l,idx)
call map_get(map_a,idx,value(ik))
enddo
enddo
!$OMP END DO
!$OMP SINGLE
ik=0
do k=k_start,k_end
do i=i_start,k
ik = ik+1
tmp=value(ik)
if (tmp /= 0.d0) then
a_array(ii) = ik
ii = ii+1_8
a_array(ii) = j
ii = ii+1_8
a_array(ii) = transfer(dble(tmp), 1_8)
ii = ii+1_8
endif
enddo
enddo
!$OMP END SINGLE
enddo
enddo
!$OMP SINGLE
l_pointer(l_end+1) = ii
!$OMP END SINGLE
!$OMP END PARALLEL
deallocate(value)
!INPUT DATA
!open(unit=10,file='INPUT',form='UNFORMATTED')
!write(10) i_start, j_start, i_end, j_end
!write(10) a_start, b_start, a_end, b_end
!write(10) LDB, mo_tot_num
!write(10) matrix_B(1:LDB,1:mo_tot_num)
!idx=size(a_array)
!write(10) idx
!write(10) a_array
!write(10) l_pointer
!close(10)
!open(unit=10,file='OUTPUT',form='FORMATTED')
! END INPUT DATA
!$OMP PARALLEL DEFAULT(NONE) SHARED(a_array,c_pointer,fd, &
!$OMP a_start,a_end,b_start,b_end,c_start,c_end,d_start,d_end,&
!$OMP i_start,i_end,j_start,j_end,k_start,k_end,l_start,l_end,&
!$OMP i_min,i_max,j_min,j_max,k_min,k_max,l_min,l_max, &
!$OMP map_c,matrix_B,l_pointer) &
!$OMP PRIVATE(key,value,T,U,V,i,j,k,l,idx,ik,ll, &
!$OMP a,b,c,d,tmp,T2d,V2d,ii)
allocate( key(i_max*j_max*k_max), value(i_max*j_max*k_max) )
allocate( U(a_start:a_end, c_start:c_end, b_start:b_end) )
allocate( T2d((i_end-i_start+1)*(k_end-k_start+2)/2, j_start:j_end), &
V2d((i_end-i_start+1)*(k_end-k_start+2)/2, b_start:b_end), &
V(i_start:i_end, k_start:k_end), &
T(k_start:k_end, a_start:a_end))
!$OMP DO SCHEDULE(dynamic)
do d=d_start,d_end
U = 0.d0
do l=l_start,l_end
if (dabs(matrix_B(l,d)) < 1.d-10) then
cycle
endif
ii=l_pointer(l)
do j=j_start,j_end
ik=0
do k=k_start,k_end
do i=i_start,k
ik = ik+1
if ( (ik /= a_array(ii)).or.(j /= a_array(ii+1_8)) &
.or.(ii >= l_pointer(l+1)) ) then
T2d(ik,j) = 0.d0
else
T2d(ik,j) = transfer(a_array(ii+2_8), 1.d0)
ii=ii+3_8
endif
enddo
enddo
enddo
call DGEMM('N','N', ishft( (i_end-i_start+1)*(i_end-i_start+2), -1),&
(d-b_start+1), &
(j_end-j_start+1), 1.d0, &
T2d(1,j_start), size(T2d,1), &
matrix_B(j_start,b_start), size(matrix_B,1),0.d0, &
V2d(1,b_start), size(V2d,1) )
do b=b_start,d
ik = 0
do k=k_start,k_end
do i=i_start,k
ik = ik+1
V(i,k) = V2d(ik,b)
enddo
enddo
! T = 0.d0
! do a=a_start,b
! do k=k_start,k_end
! do i=i_start,k
! T(k,a) = T(k,a) + V(i,k)*matrix_B(i,a)
! enddo
! do i=k+1,i_end
! T(k,a) = T(k,a) + V(k,i)*matrix_B(i,a)
! enddo
! enddo
! enddo
call DSYMM('L','U', (k_end-k_start+1), (b-a_start+1), &
1.d0, &
V(i_start,k_start), size(V,1), &
matrix_B(i_start,a_start), size(matrix_B,1),0.d0, &
T(k_start,a_start), size(T,1) )
! do c=c_start,b
! do a=a_start,c
! do k=k_start,k_end
! U(a,c,b) = U(a,c,b) + T(k,a)*matrix_B(k,c)*matrix_B(l,d)
! enddo
! enddo
! enddo
call DGEMM('T','N', (b-a_start+1), (b-c_start+1), &
(k_end-k_start+1), matrix_B(l, d), &
T(k_start,a_start), size(T,1), &
matrix_B(k_start,c_start), size(matrix_B,1), 1.d0, &
U(a_start,c_start,b), size(U,1) )
! do c=b+1,c_end
! do a=a_start,b
! do k=k_start,k_end
! U(a,c,b) = U(a,c,b) + T(k,a)*matrix_B(k,c)*matrix_B(l,d)
! enddo
! enddo
! enddo
if (b < b_end) then
call DGEMM('T','N', (b-a_start+1), (c_end-b), &
(k_end-k_start+1), matrix_B(l, d), &
T(k_start,a_start), size(T,1), &
matrix_B(k_start,b+1), size(matrix_B,1), 1.d0, &
U(a_start,b+1,b), size(U,1) )
endif
enddo
enddo
idx = 0_8
do b=b_start,d
do c=c_start,c_end
do a=a_start,min(b,c)
if (dabs(U(a,c,b)) < 1.d-15) then
cycle
endif
idx = idx+1_8
call bielec_integrals_index(a,b,c,d,key(idx))
value(idx) = U(a,c,b)
enddo
enddo
enddo
!$OMP CRITICAL
call map_append(map_c, key, value, idx)
!$OMP END CRITICAL
!WRITE OUTPUT
! OMP CRITICAL
!print *, d
!do b=b_start,d
! do c=c_start,c_end
! do a=a_start,min(b,c)
! if (dabs(U(a,c,b)) < 1.d-15) then
! cycle
! endif
! write(10,*) d,c,b,a,U(a,c,b)
! enddo
! enddo
!enddo
! OMP END CRITICAL
!END WRITE OUTPUT
enddo
!$OMP END DO
deallocate(key,value,V,T)
!$OMP END PARALLEL
call map_sort(map_c)
call munmap( &
(/ 12_8 * map_a % n_elements /), 8, fd, c_pointer)
deallocate(l_pointer)
end

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

@ -4,11 +4,13 @@ from generate_h_apply import *
s = H_apply("FCI")
s.set_selection_pt2("epstein_nesbet_2x2")
#s.set_selection_pt2("qdpt")
s.unset_skip()
print s
s = H_apply("FCI_PT2")
s.set_perturbation("epstein_nesbet_2x2")
#s.set_perturbation("qdpt")
s.unset_skip()
s.unset_openmp()
print s

6
plugins/Full_CI_ZMQ/EZFIO.cfg
View File

@ -12,7 +12,7 @@ interface: ezfio
type: integer
doc: Save data at each iteration : 1(Append) | 2(Overwrite) | 3(NoSave)
interface: ezfio,ocaml
default: 3
default: 2
[n_iter]
interface: ezfio
@ -29,10 +29,10 @@ size: (full_ci_zmq.n_iter)
interface: ezfio
doc: The energy without a pt2 correction for n_det
type: double precision
size: (full_ci_zmq.n_iter)
size: (full_ci_zmq.n_iter,determinants.n_states)
[pt2_iter]
interface: ezfio
doc: The pt2 correction for n_det
type: double precision
size: (full_ci_zmq.n_iter)
size: (full_ci_zmq.n_iter,determinants.n_states)

2
plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Perturbation Selectors_full Generators_full ZMQ
Perturbation Selectors_full Generators_full ZMQ FourIdx MPI

421
plugins/Full_CI_ZMQ/README.rst
View File

@ -10,7 +10,6 @@ Needed Modules
* `Selectors_full <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full>`_
* `Generators_full <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full>`_
* `ZMQ <http://github.com/LCPQ/quantum_package/tree/master/src/ZMQ>`_
* `Full_CI <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI>`_
Documentation
=============
@ -18,19 +17,43 @@ Documentation
.. by the `update_README.py` script.
`add_task_to_taskserver <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L677>`_
`add_comb <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f#L410>`_
Undocumented
`add_task_to_taskserver <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L704>`_
Get a task from the task server
`add_to_selection_buffer <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_buffer.irp.f#L19>`_
`add_task_to_taskserver_recv <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L761>`_
Get a task from the task server
`add_task_to_taskserver_send <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L736>`_
Get a task from the task server
`add_to_selection_buffer <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_buffer.irp.f#L31>`_
Undocumented
`assert <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L25>`_
`assert <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L35>`_
Undocumented
`connect_to_taskserver <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L594>`_
`bitstring_to_list_in_selection <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L1150>`_
Gives the inidices(+1) of the bits set to 1 in the bit string
`comb_step <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f#L438>`_
Undocumented
`comb_teeth <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f#L322>`_
Undocumented
`connect_to_taskserver <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L621>`_
Connect to the task server and obtain the worker ID
@ -38,241 +61,135 @@ Documentation
Undocumented
`disconnect_from_taskserver <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L637>`_
`delete_selection_buffer <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_buffer.irp.f#L18>`_
Undocumented
`disconnect_from_taskserver <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L664>`_
Disconnect from the task server
`end_parallel_job <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L559>`_
`do_carlo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f#L112>`_
Undocumented
`end_parallel_job <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L583>`_
End a new parallel job with name 'name'. The slave tasks execute subroutine 'slave'
`end_zmq_pair_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L419>`_
`end_zmq_pair_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L424>`_
Terminate socket on which the results are sent.
`end_zmq_pull_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L437>`_
`end_zmq_pull_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L444>`_
Terminate socket on which the results are sent.
`end_zmq_push_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L456>`_
`end_zmq_push_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L470>`_
Terminate socket on which the results are sent.
`end_zmq_sub_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L401>`_
`end_zmq_sub_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L404>`_
Terminate socket on which the results are sent.
`end_zmq_to_qp_run_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L790>`_
`end_zmq_to_qp_run_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L890>`_
Terminate the socket from the application to qp_run
`fci_zmq <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/fci_zmq.irp.f#L1>`_
`fci_zmq <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/target_pt2_zmq.irp.f#L1>`_
Undocumented
`fill_buffer_double <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_double.irp.f#L156>`_
`fill_buffer_double <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L558>`_
Undocumented
`fill_buffer_single <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_single.irp.f#L60>`_
`first_det_of_comb <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f#L440>`_
Undocumented
`full_ci <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/full_ci_no_skip.irp.f#L1>`_
`first_det_of_teeth <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f#L439>`_
Undocumented
`get_d0 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_double.irp.f#L582>`_
`fragment_count <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L3>`_
Number of fragments for the deterministic part
`fragment_first <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f#L1>`_
Undocumented
`get_d1 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_double.irp.f#L413>`_
`get_carlo_workbatch <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f#L362>`_
Undocumented
`get_d2 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_double.irp.f#L295>`_
`get_comb <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f#L392>`_
Undocumented
`get_m0 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_single.irp.f#L279>`_
`get_d0 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L1004>`_
Undocumented
`get_m1 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_single.irp.f#L217>`_
`get_d1 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L832>`_
Undocumented
`get_m2 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_single.irp.f#L158>`_
`get_d2 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L714>`_
Undocumented
`get_mask_phase <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L36>`_
`get_first_tooth <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f#L329>`_
Undocumented
`get_phase_bi <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L87>`_
`get_m0 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L251>`_
Undocumented
`get_task_from_taskserver <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L737>`_
`get_m1 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L185>`_
Undocumented
`get_m2 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L126>`_
Undocumented
`get_mask_phase <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L46>`_
Undocumented
`get_phase_bi <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L104>`_
Undocumented
`get_task_from_taskserver <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L836>`_
Get a task from the task server
h_apply_fci
Calls H_apply on the HF determinant and selects all connected single and double
excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
`initialize_pt2_e0_denominator <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/energy.irp.f#L1>`_
If true, initialize pt2_E0_denominator
h_apply_fci_diexc
`integral8 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L12>`_
Undocumented
h_apply_fci_diexcorg
Generate all double excitations of key_in using the bit masks of holes and
particles.
Assume N_int is already provided.
`merge_selection_buffers <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_buffer.irp.f#L50>`_
Merges the selection buffers b1 and b2 into b2
h_apply_fci_diexcp
Undocumented
h_apply_fci_mono
Calls H_apply on the HF determinant and selects all connected single and double
excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
h_apply_fci_mono_diexc
Undocumented
h_apply_fci_mono_diexcorg
Generate all double excitations of key_in using the bit masks of holes and
particles.
Assume N_int is already provided.
h_apply_fci_mono_diexcp
Undocumented
h_apply_fci_mono_monoexc
Generate all single excitations of key_in using the bit masks of holes and
particles.
Assume N_int is already provided.
h_apply_fci_monoexc
Generate all single excitations of key_in using the bit masks of holes and
particles.
Assume N_int is already provided.
h_apply_fci_no_selection
Calls H_apply on the HF determinant and selects all connected single and double
excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
h_apply_fci_no_selection_diexc
Undocumented
h_apply_fci_no_selection_diexcorg
Generate all double excitations of key_in using the bit masks of holes and
particles.
Assume N_int is already provided.
h_apply_fci_no_selection_diexcp
Undocumented
h_apply_fci_no_selection_monoexc
Generate all single excitations of key_in using the bit masks of holes and
particles.
Assume N_int is already provided.
h_apply_fci_no_skip
Calls H_apply on the HF determinant and selects all connected single and double
excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
h_apply_fci_no_skip_diexc
Undocumented
h_apply_fci_no_skip_diexcorg
Generate all double excitations of key_in using the bit masks of holes and
particles.
Assume N_int is already provided.
h_apply_fci_no_skip_diexcp
Undocumented
h_apply_fci_no_skip_monoexc
Generate all single excitations of key_in using the bit masks of holes and
particles.
Assume N_int is already provided.
h_apply_fci_pt2
Calls H_apply on the HF determinant and selects all connected single and double
excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
h_apply_fci_pt2_collector
Collects results from the selection in an array of generators
h_apply_fci_pt2_diexc
Undocumented
h_apply_fci_pt2_diexcorg
Generate all double excitations of key_in using the bit masks of holes and
particles.
Assume N_int is already provided.
h_apply_fci_pt2_diexcp
Undocumented
h_apply_fci_pt2_monoexc
Generate all single excitations of key_in using the bit masks of holes and
particles.
Assume N_int is already provided.
h_apply_fci_pt2_slave
Calls H_apply on the HF determinant and selects all connected single and double
excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
h_apply_fci_pt2_slave_inproc
Computes a buffer using threads
h_apply_fci_pt2_slave_tcp
Computes a buffer over the network
`integral8 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L4>`_
Undocumented
`new_parallel_job <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L490>`_
`new_parallel_job <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L506>`_
Start a new parallel job with name 'name'. The slave tasks execute subroutine 'slave'
`new_zmq_pair_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L164>`_
`new_zmq_pair_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L161>`_
Socket on which the collector and the main communicate
`new_zmq_pull_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L224>`_
`new_zmq_pull_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L221>`_
Socket on which the results are sent. If thread is 1, use inproc
@ -280,68 +197,120 @@ h_apply_fci_pt2_slave_tcp
Socket on which the results are sent. If thread is 1, use inproc
`new_zmq_sub_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L360>`_
`new_zmq_sub_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L363>`_
Socket to read the state published by the Task server
`new_zmq_to_qp_run_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L126>`_
`new_zmq_to_qp_run_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L123>`_
Socket on which the qp_run process replies
`past_d1 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_double.irp.f#L642>`_
`past_d1 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L1064>`_
Undocumented
`past_d2 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_double.irp.f#L658>`_
`past_d2 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L1080>`_
Undocumented
`provide_everything <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_slave.irp.f#L14>`_
`provide_everything <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_slave.irp.f#L15>`_
Undocumented
`psi_phasemask <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L14>`_
`pt2_collector <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f#L147>`_
Undocumented
`pull_selection_results <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/run_selection_slave.irp.f#L122>`_
`pt2_cweight <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f#L436>`_
Undocumented
`push_selection_results <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/run_selection_slave.irp.f#L87>`_
`pt2_cweight_cache <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f#L437>`_
Undocumented
`qp_run_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L19>`_
`pt2_e0_denominator <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/energy.irp.f#L9>`_
E0 in the denominator of the PT2
`pt2_find <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f#L295>`_
Undocumented
`pt2_slave <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_slave.irp.f#L1>`_
Helper program to compute the PT2 in distributed mode.
`pt2_slave_inproc <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f#L140>`_
Undocumented
`pt2_slave_tcp <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_slave.irp.f#L68>`_
Undocumented
`pt2_stoch <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_stoch.irp.f#L1>`_
Undocumented
`pt2_weight <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f#L435>`_
Undocumented
`pt2_weight_inv <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f#L502>`_
Inverse of pt2_weight array
`pt2_workload <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f#L159>`_
Undocumented
`pull_pt2_results <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f#L125>`_
Undocumented
`pull_selection_results <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/run_selection_slave.irp.f#L142>`_
Undocumented
`push_pt2_results <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f#L88>`_
Undocumented
`push_selection_results <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/run_selection_slave.irp.f#L88>`_
Undocumented
`qp_run_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L16>`_
Address of the qp_run socket
Example : tcp://130.120.229.139:12345
`reset_zmq_addresses <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L67>`_
`reset_zmq_addresses <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L64>`_
Socket which pulls the results (2)
`run_pt2_slave <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f#L2>`_
Undocumented
`run_selection_slave <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/run_selection_slave.irp.f#L2>`_
Undocumented
`run_wf <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_slave.irp.f#L19>`_
`run_wf <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_slave.irp.f#L20>`_
Undocumented
`select_connected <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L58>`_
`select_connected <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L72>`_
Undocumented
`select_doubles <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_double.irp.f#L2>`_
Undocumented
`select_singles_and_doubles <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L280>`_
WARNING /!\ : It is assumed that the generators and selectors are psi_det_sorted
`select_singles <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_single.irp.f#L3>`_
Select determinants connected to i_det by H
`selection_collector <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/fci_zmq.irp.f#L167>`_
`selection_collector <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/zmq_selection.irp.f#L78>`_
Undocumented
@ -349,113 +318,109 @@ h_apply_fci_pt2_slave_tcp
Helper program to compute the PT2 in distributed mode.
`selection_slave_inproc <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/fci_zmq.irp.f#L160>`_
`selection_slave_inproc <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/zmq_selection.irp.f#L71>`_
Undocumented
`selection_slave_tcp <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_slave.irp.f#L86>`_
`size_tbc <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f#L354>`_
Size of the tbc array
`sort_selection_buffer <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_buffer.irp.f#L107>`_
Undocumented
`sort_selection_buffer <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_buffer.irp.f#L39>`_
`splash_pq <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L623>`_
Undocumented
`splash_p <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_single.irp.f#L107>`_
`spot_isinwf <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L1106>`_
Undocumented
`splash_pq <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_double.irp.f#L221>`_
Undocumented
`spot_hasbeen <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_single.irp.f#L305>`_
Undocumented
`spot_isinwf <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_double.irp.f#L684>`_
Undocumented
`switch_qp_run_to_master <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L84>`_
`switch_qp_run_to_master <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L81>`_
Address of the master qp_run socket
Example : tcp://130.120.229.139:12345
`task_done_to_taskserver <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L708>`_
`task_done_to_taskserver <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L807>`_
Get a task from the task server
`update_energy <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_slave.irp.f#L63>`_
Update energy when it is received from ZMQ
`var_pt2_ratio_run <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/var_pt2_ratio.irp.f#L1>`_
`wait_for_next_state <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L955>`_
Undocumented
`wait_for_next_state <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L855>`_
Undocumented
`wait_for_state <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L879>`_
`wait_for_state <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L979>`_
Wait for the ZMQ state to be ready
`wait_for_states <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L907>`_
`wait_for_states <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L1007>`_
Wait for the ZMQ state to be ready
`zmq_context <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L8>`_
`zmq_abort <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L780>`_
Aborts a running parallel computation
`zmq_context <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L4>`_
Context for the ZeroMQ library
`zmq_delete_task <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L813>`_
`zmq_delete_task <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L913>`_
When a task is done, it has to be removed from the list of tasks on the qp_run
queue. This guarantees that the results have been received in the pull.
`zmq_port <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L113>`_
`zmq_lock <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L5>`_
Context for the ZeroMQ library
`zmq_port <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L110>`_
Return the value of the ZMQ port from the corresponding integer
`zmq_port_start <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L20>`_
`zmq_port_start <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L17>`_
Address of the qp_run socket
Example : tcp://130.120.229.139:12345
`zmq_selection <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/fci_zmq.irp.f#L109>`_
`zmq_pt2 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f#L6>`_
Undocumented
`zmq_set_running <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L530>`_
`zmq_selection <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/zmq_selection.irp.f#L1>`_
Undocumented
`zmq_set_running <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L553>`_
Set the job to Running in QP-run
`zmq_socket_pair_inproc_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L45>`_
`zmq_socket_pair_inproc_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L42>`_
Socket which pulls the results (2)
`zmq_socket_pull_inproc_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L47>`_
`zmq_socket_pull_inproc_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L44>`_
Socket which pulls the results (2)
`zmq_socket_pull_tcp_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L44>`_
`zmq_socket_pull_tcp_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L41>`_
Socket which pulls the results (2)
`zmq_socket_push_inproc_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L48>`_
`zmq_socket_push_inproc_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L45>`_
Socket which pulls the results (2)
`zmq_socket_push_tcp_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L46>`_
`zmq_socket_push_tcp_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L43>`_
Socket which pulls the results (2)
`zmq_socket_sub_tcp_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L49>`_
`zmq_socket_sub_tcp_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L46>`_
Socket which pulls the results (2)
`zmq_state <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L482>`_
`zmq_state <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L498>`_
Threads executing work through the ZeroMQ interface

71
plugins/Full_CI_ZMQ/dump_fci_iterations_value.f90 → plugins/Full_CI_ZMQ/dump_fci_iterations_value.irp.f
View File

@ -6,18 +6,23 @@ subroutine dump_fci_iterations_value(n_determinants,energy,pt2)
! BEGIN_DOC
!! Output the number of determinants, energy, and pt2 correction at each iteration
! END_DOC
integer :: n_determinants
double precision :: energy, pt2
integer, intent(in) :: n_determinants
double precision, intent(in) :: energy(N_states), pt2(N_states)
integer :: N_iterations
integer, allocatable :: n_determinants_list(:)
double precision, allocatable :: energy_list(:)
double precision, allocatable :: pt2_list(:)
double precision, allocatable :: energy_list(:,:)
double precision, allocatable :: pt2_list(:,:)
integer :: saveMethod
logical :: hasIter
logical,save :: firstAccess=.TRUE. !! every update of firstAccess will be saved
double precision, allocatable :: extrapolated_energy(:,:)
integer :: i,k
!!! Check to ensure that we should save iterations (default is Append)
! saveMethod: 1==Append, 2==Overwrite, 3==NoSave
if (N_det < N_states) then
return
endif
call ezfio_get_full_ci_zmq_iterative_save(saveMethod)
!!! Check we are saving data
@ -42,16 +47,17 @@ subroutine dump_fci_iterations_value(n_determinants,energy,pt2)
endif
!! Now allocate the array for entire size needed
allocate(extrapolated_energy(N_iterations+1,N_states))
allocate(n_determinants_list(N_iterations+1))
allocate(energy_list(N_iterations+1))
allocate(pt2_list(N_iterations+1))
allocate(energy_list(N_states,N_iterations+1))
allocate(pt2_list(N_states,N_iterations+1))
!!! Pull previously written data
!!! Unless it is at the beginning of a new/restarted calculation
if((hasIter).AND.(N_iterations>0)) then
call ezfio_get_full_ci_zmq_n_det_iter(n_determinants_list(1:N_iterations))
call ezfio_get_full_ci_zmq_energy_iter(energy_list(1:N_iterations))
call ezfio_get_full_ci_zmq_pt2_iter(pt2_list(1:N_iterations))
call ezfio_get_full_ci_zmq_n_det_iter(n_determinants_list)
call ezfio_get_full_ci_zmq_energy_iter(energy_list)
call ezfio_get_full_ci_zmq_pt2_iter(pt2_list)
endif
!! Now increment to the current iteration
@ -59,8 +65,48 @@ subroutine dump_fci_iterations_value(n_determinants,energy,pt2)
!! Add the data from latest iteration
n_determinants_list(N_iterations) = n_determinants
energy_list(N_iterations) = energy
pt2_list(N_iterations) = pt2
energy_list(:,N_iterations) = energy(:)
pt2_list(:,N_iterations) = pt2(:)
if (N_iterations > 2) then
write(*,'(A)') ''
write(*,'(A)') 'Extrapolated energies'
write(*,'(A)') '------------------------'
write(*,'(A)') ''
do i=1, min(N_states,N_det)
call extrapolate_data(N_iterations, energy_list(i,1:N_iterations), pt2_list(i,1:N_iterations), extrapolated_energy(1:N_iterations,i))
enddo
print *, ''
print *, 'State ', 1
print *, ''
write(*,*) '=========== ', '==================='
write(*,*) 'minimum PT2 ', 'Extrapolated energy'
write(*,*) '=========== ', '==================='
do k=2,min(N_iterations,8)
write(*,'(F11.4,2X,F18.8)') pt2_list(1,N_iterations+1-k), extrapolated_energy(k,1)
enddo
write(*,*) '=========== ', '==================='
do i=2, min(N_states,N_det)
print *, ''
print *, 'State ', i
print *, ''
write(*,*) '=========== ', '=================== ', '=================== ', '==================='
write(*,*) 'minimum PT2 ', 'Extrapolated energy ', ' Excitation (a.u) ', ' Excitation (eV) '
write(*,*) '=========== ', '=================== ', '=================== ', '==================='
do k=2,min(N_iterations,8)
write(*,'(F11.4,X,3(X,F18.8))') pt2_list(i,N_iterations+1-k), extrapolated_energy(k,i), &
extrapolated_energy(k,i) - extrapolated_energy(k,1), &
(extrapolated_energy(k,i) - extrapolated_energy(k,1) ) * 27.211396641308d0
enddo
write(*,*) '=========== ', '=================== ', '=================== ', '==================='
enddo
print *, ''
endif
! Reset the iteration number
call ezfio_set_full_ci_zmq_n_iter(N_iterations)
@ -74,10 +120,11 @@ subroutine dump_fci_iterations_value(n_determinants,energy,pt2)
deallocate(n_determinants_list)
deallocate(energy_list)
deallocate(pt2_list)
endif
!!! set first access to false
!!! it will be saved
firstAccess=.FALSE.
end subroutine

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

@ -13,6 +13,8 @@ BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ]
END_DOC
if (initialize_pt2_E0_denominator) then
pt2_E0_denominator(1:N_states) = psi_energy(1:N_states)
! call ezfio_get_full_ci_zmq_energy(pt2_E0_denominator(1))
! pt2_E0_denominator(1) -= nuclear_repulsion
! 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')

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

@ -10,10 +10,14 @@ program fci_zmq
double precision :: hf_energy_ref
logical :: has
double precision :: relative_error
relative_error=1.d-3
double precision :: relative_error, absolute_error
integer :: N_states_p
character*(512) :: fmt
pt2 = -huge(1.d0)
relative_error=PT2_relative_error
absolute_error=PT2_absolute_error
pt2 = -huge(1.e0)
threshold_davidson_in = threshold_davidson
threshold_davidson = threshold_davidson_in * 100.d0
SOFT_TOUCH threshold_davidson
@ -35,20 +39,9 @@ program fci_zmq
soft_touch N_det psi_det psi_coef
call diagonalize_CI
call save_wavefunction
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+PT2 = ', CI_energy(k) + pt2(k)
print *, '-----'
enddo
call dump_fci_iterations_value(N_det,CI_energy(1),pt2(1)) ! This call automatically appends data
N_states_p = min(N_det,N_states)
endif
print*,'Beginning the selection ...'
n_det_before = 0
character*(8) :: pt2_string
@ -56,6 +49,7 @@ program fci_zmq
double precision :: threshold_selectors_save, threshold_generators_save
threshold_selectors_save = threshold_selectors
threshold_generators_save = threshold_generators
double precision :: error(N_states)
correlation_energy_ratio = 0.d0
@ -65,25 +59,19 @@ program fci_zmq
(maxval(abs(pt2(1:N_states))) > pt2_max) .and. &
(correlation_energy_ratio <= correlation_energy_ratio_max) &
)
write(*,'(A)') '--------------------------------------------------------------------------------'
if (do_pt2) then
pt2_string = ' '
pt2 = 0.d0
if (N_states == 1) then
threshold_selectors = 1.d0
threshold_generators = 1d0
SOFT_TOUCH threshold_selectors threshold_generators
call ZMQ_pt2(CI_energy, pt2,relative_error) ! Stochastic PT2
threshold_selectors = threshold_selectors_save
threshold_generators = threshold_generators_save
SOFT_TOUCH threshold_selectors threshold_generators
else
threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
threshold_generators = max(threshold_generators,threshold_generators_pt2)
SOFT_TOUCH threshold_selectors threshold_generators
call ZMQ_selection(0, pt2) ! Deterministic PT2
endif
threshold_selectors = 1.d0
threshold_generators = 1d0
SOFT_TOUCH threshold_selectors threshold_generators
call ZMQ_pt2(CI_energy, pt2,relative_error,absolute_error,error) ! Stochastic PT2
threshold_selectors = threshold_selectors_save
threshold_generators = threshold_generators_save
SOFT_TOUCH threshold_selectors threshold_generators
else
pt2_string = '(approx)'
endif
@ -93,36 +81,77 @@ program fci_zmq
(CI_energy(1) + pt2(1) - hf_energy_ref)
correlation_energy_ratio = min(1.d0,correlation_energy_ratio)
N_states_p = min(N_det,N_states)
print *, ''
print '(A,I12)', 'Summary at N_det = ', N_det
print '(A)', '-----------------------------------'
print *, ''
call write_double(6,correlation_energy_ratio, 'Correlation ratio')
print *, ''
write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
write(*,fmt)
write(fmt,*) '(12X,', N_states_p, '(6X,A7,1X,I6,10X))'
write(*,fmt) ('State',k, k=1,N_states_p)
write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
write(*,fmt)
write(fmt,*) '(A12,', N_states_p, '(1X,F14.8,15X))'
write(*,fmt) '# E ', CI_energy(1:N_states_p)
if (N_states_p > 1) then
write(*,fmt) '# Excit. (au)', CI_energy(1:N_states_p)-CI_energy(1)
write(*,fmt) '# Excit. (eV)', (CI_energy(1:N_states_p)-CI_energy(1))*27.211396641308d0
endif
write(fmt,*) '(A12,', 2*N_states_p, '(1X,F14.8))'
write(*,fmt) '# PT2'//pt2_string, (pt2(k), error(k), k=1,N_states_p)
write(*,'(A)') '#'
write(*,fmt) '# E+PT2 ', (CI_energy(k)+pt2(k),error(k), k=1,N_states_p)
if (N_states_p > 1) then
write(*,fmt) '# Excit. (au)', ( (CI_energy(k)+pt2(k)-CI_energy(1)-pt2(1)), &
dsqrt(error(k)*error(k)+error(1)*error(1)), k=1,N_states_p)
write(*,fmt) '# Excit. (eV)', ( (CI_energy(k)+pt2(k)-CI_energy(1)-pt2(1))*27.211396641308d0, &
dsqrt(error(k)*error(k)+error(1)*error(1))*27.211396641308d0, k=1,N_states_p)
endif
print *, ''
print *, 'N_det = ', N_det
print *, 'N_states = ', N_states
print*, 'correlation_ratio = ', correlation_energy_ratio
do k=1, N_states
do k=1, N_states_p
print*,'State ',k
print *, 'PT2 = ', pt2(k)
print *, 'E = ', CI_energy(k)
print *, 'E+PT2'//pt2_string//' = ', CI_energy(k)+pt2(k)
print *, 'E+PT2'//pt2_string//' = ', CI_energy(k)+pt2(k), ' +/- ', error(k)
enddo
print *, '-----'
if(N_states.gt.1)then
print*,'Variational Energy difference'
do i = 2, N_states
print*,'Delta E = ',CI_energy(i) - CI_energy(1)
enddo
endif
if(N_states.gt.1)then
print*,'Variational + perturbative Energy difference'
do i = 2, N_states
print*,'Delta E = ',CI_energy(i)+ pt2(i) - (CI_energy(1) + pt2(1))
print *, 'Variational Energy difference (au | eV)'
do i=2, N_states_p
print*,'Delta E = ', (CI_energy(i) - CI_energy(1)), &
(CI_energy(i) - CI_energy(1)) * 27.211396641308d0
enddo
print *, '-----'
print*, 'Variational + perturbative Energy difference (au | eV)'
do i=2, N_states_p
print*,'Delta E = ', (CI_energy(i)+ pt2(i) - (CI_energy(1) + pt2(1))), &
(CI_energy(i)+ pt2(i) - (CI_energy(1) + pt2(1))) * 27.211396641308d0
enddo
endif
call ezfio_set_full_ci_zmq_energy_pt2(CI_energy(1)+pt2(1))
call dump_fci_iterations_value(N_det,CI_energy,pt2)
n_det_before = N_det
to_select = N_det
to_select = max(N_det, to_select)
to_select = min(to_select, N_det_max-n_det_before)
if (s2_eig) then
to_select = N_det/2+1
to_select = max(N_det/2+1, to_select)
to_select = min(to_select, N_det_max-n_det_before)
else
to_select = N_det
to_select = max(N_det, to_select)
to_select = min(to_select, N_det_max-n_det_before)
endif
call ZMQ_selection(to_select, pt2)
PROVIDE psi_coef
@ -135,8 +164,6 @@ program fci_zmq
call diagonalize_CI
call save_wavefunction
call ezfio_set_full_ci_zmq_energy(CI_energy(1))
call ezfio_set_full_ci_zmq_energy_pt2(CI_energy(1)+pt2(1))
call dump_fci_iterations_value(N_det,CI_energy(1),pt2(1)) ! This call automatically appends data
enddo
endif
@ -145,28 +172,64 @@ program fci_zmq
call diagonalize_CI
call save_wavefunction
call ezfio_set_full_ci_zmq_energy(CI_energy(1))
call dump_fci_iterations_value(N_det,CI_energy(1),pt2(1)) ! This call automatically appends data
call ezfio_set_full_ci_zmq_energy_pt2(CI_energy(1)+pt2(1))
endif
if (do_pt2) then
pt2 = 0.d0
if (N_states == 1) then
threshold_selectors = 1.d0
threshold_generators = 1d0
SOFT_TOUCH threshold_selectors threshold_generators
call ZMQ_pt2(CI_energy, pt2, relative_error) ! Stochastic PT2
threshold_selectors = threshold_selectors_save
threshold_generators = threshold_generators_save
SOFT_TOUCH threshold_selectors threshold_generators
else
threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
threshold_generators = max(threshold_generators,threshold_generators_pt2)
SOFT_TOUCH threshold_selectors threshold_generators
call ZMQ_selection(0, pt2) ! Deterministic PT2
endif
threshold_selectors = 1.d0
threshold_generators = 1d0
SOFT_TOUCH threshold_selectors threshold_generators
call ZMQ_pt2(CI_energy, pt2,relative_error,absolute_error,error) ! Stochastic PT2
threshold_selectors = threshold_selectors_save
threshold_generators = threshold_generators_save
SOFT_TOUCH threshold_selectors threshold_generators
call ezfio_set_full_ci_zmq_energy(CI_energy(1))
call ezfio_set_full_ci_zmq_energy_pt2(CI_energy(1)+pt2(1))
call dump_fci_iterations_value(N_det,CI_energy(1),pt2(1)) ! This call automatically appends data
endif
print *, 'N_det = ', N_det
print *, 'N_states = ', N_states
print*, 'correlation_ratio = ', correlation_energy_ratio
call dump_fci_iterations_value(N_det,CI_energy,pt2)
print *, ''
print '(A,I12)', 'Summary at N_det = ', N_det
print '(A)', '-----------------------------------'
print *, ''
call write_double(6,correlation_energy_ratio, 'Correlation ratio')
print *, ''
N_states_p = min(N_det,N_states)
print *, ''
write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
write(*,fmt)
write(fmt,*) '(12X,', N_states_p, '(6X,A7,1X,I6,10X))'
write(*,fmt) ('State',k, k=1,N_states_p)
write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
write(*,fmt)
write(fmt,*) '(A12,', N_states_p, '(1X,F14.8,15X))'
write(*,fmt) '# E ', CI_energy(1:N_states_p)
if (N_states_p > 1) then
write(*,fmt) '# Excit. (au)', CI_energy(1:N_states_p)-CI_energy(1)
write(*,fmt) '# Excit. (eV)', (CI_energy(1:N_states_p)-CI_energy(1))*27.211396641308d0
endif
write(fmt,*) '(A12,', 2*N_states_p, '(1X,F14.8))'
write(*,fmt) '# PT2'//pt2_string, (pt2(k), error(k), k=1,N_states_p)
write(*,'(A)') '#'
write(*,fmt) '# E+PT2 ', (CI_energy(k)+pt2(k),error(k), k=1,N_states_p)
if (N_states_p > 1) then
write(*,fmt) '# Excit. (au)', ( (CI_energy(k)+pt2(k)-CI_energy(1)-pt2(1)), &
dsqrt(error(k)*error(k)+error(1)*error(1)), k=1,N_states_p)
write(*,fmt) '# Excit. (eV)', ( (CI_energy(k)+pt2(k)-CI_energy(1)-pt2(1))*27.211396641308d0, &
dsqrt(error(k)*error(k)+error(1)*error(1))*27.211396641308d0, k=1,N_states_p)
endif
write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
write(*,fmt)
print *, ''
end

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

@ -25,6 +25,9 @@ subroutine run_wf
double precision :: energy(N_states_diag)
character*(64) :: states(1)
integer :: rc, i
integer, external :: zmq_get_dvector
integer, external :: zmq_get_psi
call provide_everything
@ -47,7 +50,8 @@ subroutine run_wf
! ---------
print *, 'PT2'
call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
if (zmq_get_psi(zmq_to_qp_run_socket,1) == -1) cycle
if (zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states) == -1) cycle
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order

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

@ -16,7 +16,7 @@ subroutine run
integer :: n_det_before, to_select
double precision :: threshold_davidson_in
double precision :: E_CI_before, relative_error
double precision :: E_CI_before, relative_error, absolute_error, eqt
allocate (pt2(N_states))
pt2 = 0.d0
@ -24,13 +24,14 @@ subroutine run
E_CI_before = pt2_E0_denominator(1) + nuclear_repulsion
threshold_selectors = 1.d0
threshold_generators = 1d0
relative_error = -1.d-3
call ZMQ_pt2(E_CI_before, pt2, relative_error)
relative_error = 1.d-9
absolute_error = 1.d-9
call ZMQ_pt2(E_CI_before, pt2, relative_error, absolute_error, eqt)
print *, 'Final step'
print *, 'N_det = ', N_det
print *, 'PT2 = ', pt2
print *, 'E = ', E_CI_before
print *, 'E+PT2 = ', E_CI_before+pt2
print *, 'E+PT2 = ', E_CI_before+pt2, ' +/- ', eqt
print *, '-----'
call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before+pt2(1))
end

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

@ -3,108 +3,152 @@ BEGIN_PROVIDER [ integer, fragment_first ]
fragment_first = first_det_of_teeth(1)
END_PROVIDER
subroutine ZMQ_pt2(E, pt2,relative_error)
subroutine ZMQ_pt2(E, pt2,relative_error, absolute_error, 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
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
type(selection_buffer) :: b
integer, external :: omp_get_thread_num
double precision, intent(in) :: relative_error, E
double precision, intent(out) :: pt2(N_states)
double precision, intent(in) :: relative_error, absolute_error, E(N_states)
double precision, intent(out) :: pt2(N_states),error(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 :: i, j, k, Ncomb, 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 :: time
double precision :: w(N_states)
integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
if (N_det < 10) then
if (N_det < max(10,N_states)) then
pt2=0.d0
call ZMQ_selection(0, pt2)
return
error(:) = 0.d0
else
allocate(pt2_detail(N_states, N_det_generators+1), comb(N_det_generators), 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 psi_selectors
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
generator_per_task = 1
print *, '========== ================= ================= ================='
print *, ' Samples Energy Stat. Error Seconds '
print *, '========== ================= ================= ================='
call new_parallel_job(zmq_to_qp_run_socket,'pt2')
call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator))
call create_selection_buffer(1, 1*2, b)
Ncomb=size(comb)
call get_carlo_workbatch(computed, comb, Ncomb, tbc)
integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
integer :: ipos
ipos=1
do i=1,tbc(0)
if(tbc(i) > fragment_first) then
write(task(ipos:ipos+20),'(I9,1X,I9,''|'')') 0, tbc(i)
ipos += 20
if (ipos > 63980) then
call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos)))
ipos=1
endif
else
do j=1,fragment_count
write(task(ipos:ipos+20),'(I9,1X,I9,''|'')') j, tbc(i)
do pt2_stoch_istate=1,N_states
SOFT_TOUCH pt2_stoch_istate
w(:) = 0.d0
w(pt2_stoch_istate) = 1.d0
call update_psi_average_norm_contrib(w)
allocate(pt2_detail(N_states,N_det_generators+1), comb(N_det_generators), 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 psi_selectors
computed = .false.
tbc(0) = first_det_of_comb - 1
do i=1, tbc(0)
tbc(i) = i
computed(i) = .true.
end do
Ncomb=size(comb)
call get_carlo_workbatch(computed, comb, Ncomb, tbc)
pt2_detail = 0d0
print *, '========== ================= ================= ================='
print *, ' Samples Energy Stat. Error Seconds '
print *, '========== ================= ================= ================='
call new_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
integer, external :: zmq_put_psi
integer, external :: zmq_put_N_det_generators
integer, external :: zmq_put_N_det_selectors
integer, external :: zmq_put_dvector
if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then
stop 'Unable to put psi on ZMQ server'
endif
if (zmq_put_N_det_generators(zmq_to_qp_run_socket, 1) == -1) then
stop 'Unable to put N_det_generators on ZMQ server'
endif
if (zmq_put_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) then
stop 'Unable to put N_det_selectors on ZMQ server'
endif
if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) == -1) then
stop 'Unable to put energy on ZMQ server'
endif
call create_selection_buffer(1, 1*2, b)
integer :: ipos
ipos=1
integer, external :: add_task_to_taskserver
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)))
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
stop 'Unable to add task to task server'
endif
ipos=1
endif
end do
end if
end do
if (ipos > 1) then
call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos)))
endif
call zmq_set_running(zmq_to_qp_run_socket)
!$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc+1) &
!$OMP PRIVATE(i)
i = omp_get_thread_num()
if (i==0) then
call pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, sum2above, Nabove, relative_error, pt2)
else
call pt2_slave_inproc(i)
endif
!$OMP END PARALLEL
call delete_selection_buffer(b)
call end_parallel_job(zmq_to_qp_run_socket, 'pt2')
print *, '========== ================= ================= ================='
deallocate(pt2_detail, comb, computed, tbc)
else
do j=1,fragment_count
write(task(ipos:ipos+20),'(I9,1X,I9,''|'')') j, tbc(i)
ipos += 20
if (ipos > 63980) then
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
stop 'Unable to add task to task server'
endif
ipos=1
endif
end do
end if
end do
if (ipos > 1) then
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
stop 'Unable to add task to task server'
endif
endif
integer, external :: zmq_set_running
if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
print *, irp_here, ': Failed in zmq_set_running'
endif
!$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc+1) &
!$OMP PRIVATE(i)
i = omp_get_thread_num()
if (i==0) then
call pt2_collector(zmq_socket_pull,E(pt2_stoch_istate), b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, sum2above, Nabove, relative_error, absolute_error, w, error)
pt2(pt2_stoch_istate) = w(pt2_stoch_istate)
else
call pt2_slave_inproc(i)
endif
!$OMP END PARALLEL
call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
call delete_selection_buffer(b)
print *, '========== ================= ================= ================='
deallocate(pt2_detail, comb, computed, tbc)
enddo
pt2_stoch_istate = 1
w(:) = 1.d0/N_states
call update_psi_average_norm_contrib(w)
SOFT_TOUCH psi_average_norm_contrib
endif
do k=N_det+1,N_states
pt2(k) = 0.d0
enddo
end subroutine
@ -112,7 +156,7 @@ 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(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
@ -128,7 +172,7 @@ subroutine do_carlo(tbc, Ncomb, comb, pt2_detail, computed, sumabove, sum2above,
myVal = 0d0
myVal2 = 0d0
do j=comb_teeth,1,-1
myVal += pt2_detail(1, dets(j)) * pt2_weight_inv(dets(j)) * comb_step
myVal += pt2_detail(pt2_stoch_istate,dets(j)) * pt2_weight_inv(dets(j)) * comb_step
sumabove(j) += myVal
sum2above(j) += myVal*myVal
Nabove(j) += 1
@ -144,7 +188,7 @@ subroutine pt2_slave_inproc(i)
call run_pt2_slave(1,i,pt2_e0_denominator)
end
subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, sum2above, Nabove, relative_error, pt2)
subroutine pt2_collector(zmq_socket_pull, E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, sum2above, Nabove, relative_error, absolute_error, pt2,error)
use f77_zmq
use selection_types
use bitmasks
@ -152,12 +196,13 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove,
integer, intent(in) :: Ncomb
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
double precision, intent(inout) :: pt2_detail(N_states, N_det_generators)
double precision, intent(in) :: comb(Ncomb), relative_error, E
double precision, intent(in) :: comb(Ncomb), relative_error, absolute_error, E
logical, intent(inout) :: computed(N_det_generators)
integer, intent(in) :: tbc(0:size_tbc)
double precision, intent(inout) :: sumabove(comb_teeth), sum2above(comb_teeth), Nabove(comb_teeth)
double precision, intent(out) :: pt2(N_states)
double precision, intent(out) :: pt2(N_states),error(N_states)
type(selection_buffer), intent(inout) :: b
@ -165,28 +210,28 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove,
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
integer :: acc, i, j, robin, N, n_tasks
double precision, allocatable :: val(:)
integer(bit_kind), allocatable :: det(:,:,:)
integer, allocatable :: task_id(:)
integer :: Nindex
integer, allocatable :: index(:)
double precision, save :: time0 = -1.d0
double precision :: time0
double precision :: time, timeLast, Nabove_old
double precision, external :: omp_get_wtime
integer :: tooth, firstTBDcomb, orgTBDcomb
integer :: tooth, firstTBDcomb, orgTBDcomb, n_tasks_max
integer, allocatable :: parts_to_get(:)
logical, allocatable :: actually_computed(:)
double precision :: eqt
character*(512) :: task
Nabove_old = -1.d0
n_tasks_max = N_det_generators/100+1
allocate(actually_computed(N_det_generators), parts_to_get(N_det_generators), &
pt2_mwen(N_states, N_det_generators) )
pt2_mwen(1:N_states, 1:N_det_generators) =0.d0
pt2_mwen(N_states, n_tasks_max) )
pt2_mwen(1:N_states, 1:n_tasks_max) = 0.d0
do i=1,N_det_generators
actually_computed(i) = computed(i)
enddo
@ -206,42 +251,42 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove,
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))
allocate(val(b%N), det(N_int, 2, b%N), task_id(n_tasks_max), index(n_tasks_max))
more = 1
if (time0 < 0.d0) then
call wall_time(time0)
endif
call wall_time(time0)
timeLast = time0
call get_first_tooth(actually_computed, tooth)
Nabove_old = Nabove(tooth)
pullLoop : do while (more == 1)
logical :: loop
loop = .True.
pullLoop : do while (loop)
call pull_pt2_results(zmq_socket_pull, Nindex, index, pt2_mwen, task_id, ntask)
do i=1,Nindex
call pull_pt2_results(zmq_socket_pull, index, pt2_mwen, task_id, n_tasks)
do i=1,n_tasks
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 *, i, index(i), parts_to_get(index(i))
print *, "PARTS ??"
print *, parts_to_get
stop "PARTS ??"
end if
if(parts_to_get(index(i)) == 0) actually_computed(index(i)) = .true.
end do
enddo
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
integer, external :: zmq_delete_tasks
if (zmq_delete_tasks(zmq_to_qp_run_socket,zmq_socket_pull,task_id,n_tasks,more) == -1) then
stop 'Unable to delete tasks'
endif
if (more == 0) then
loop = .False.
endif
time = omp_get_wtime()
if(time - timeLast > 10d0 .or. more /= 1) then
if(time - timeLast > 10d0 .or. (.not.loop)) then
timeLast = time
do i=1, first_det_of_teeth(1)-1
if(.not.(actually_computed(i))) then
@ -249,28 +294,46 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove,
end if
end do
double precision :: E0, avg, eqt, prop
integer, external :: zmq_abort
if (firstTBDcomb > Ncomb) then
if (zmq_abort(zmq_to_qp_run_socket) == -1) then
call sleep(1)
if (zmq_abort(zmq_to_qp_run_socket) == -1) then
print *, irp_here, ': Error in sending abort signal (1)'
endif
endif
exit pullLoop
endif
double precision :: E0, avg, prop
call do_carlo(tbc, Ncomb+1-firstTBDcomb, comb(firstTBDcomb), pt2_detail, actually_computed, sumabove, sum2above, Nabove)
firstTBDcomb = int(Nabove(1)) - orgTBDcomb + 1
if(Nabove(1) < 5d0) cycle
call get_first_tooth(actually_computed, tooth)
E0 = sum(pt2_detail(1,:first_det_of_teeth(tooth)-1))
E0 = sum(pt2_detail(pt2_stoch_istate,:first_det_of_teeth(tooth)-1))
if (tooth <= comb_teeth) then
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
E0 += pt2_detail(pt2_stoch_istate,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))
else
eqt = 0.d0
endif
call wall_time(time)
if (dabs(eqt/avg) < relative_error) then
if ( (dabs(eqt/avg) < relative_error) .or. (dabs(eqt) < absolute_error) ) then
! Termination
pt2(1) = avg
pt2(pt2_stoch_istate) = avg
error(pt2_stoch_istate) = eqt
print '(G10.3, 2X, F16.10, 2X, G16.3, 2X, F16.4, A20)', Nabove(tooth), avg+E, eqt, time-time0, ''
call zmq_abort(zmq_to_qp_run_socket)
if (zmq_abort(zmq_to_qp_run_socket) == -1) then
call sleep(1)
if (zmq_abort(zmq_to_qp_run_socket) == -1) then
print *, irp_here, ': Error in sending abort signal (2)'
endif
endif
else
if (Nabove(tooth) > Nabove_old) then
print '(G10.3, 2X, F16.10, 2X, G16.3, 2X, F16.4, A20)', Nabove(tooth), avg+E, eqt, time-time0, ''
@ -280,14 +343,13 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove,
end if
end do pullLoop
E0 = sum(pt2_detail(1,:first_det_of_teeth(tooth)-1))
E0 = sum(pt2_detail(pt2_stoch_istate,:first_det_of_teeth(tooth)-1))
prop = ((1d0 - dfloat(comb_teeth - tooth + 1) * comb_step) - pt2_cweight(first_det_of_teeth(tooth)-1))
prop = prop * pt2_weight_inv(first_det_of_teeth(tooth))
E0 += pt2_detail(1,first_det_of_teeth(tooth)) * prop
pt2(1) = E0 + (sumabove(tooth) / Nabove(tooth))
E0 += pt2_detail(pt2_stoch_istate,first_det_of_teeth(tooth)) * prop
pt2(pt2_stoch_istate) = E0 + (sumabove(tooth) / Nabove(tooth))
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
@ -350,12 +412,12 @@ subroutine get_first_tooth(computed, first_teeth)
end subroutine
BEGIN_PROVIDER [ integer, size_tbc ]
BEGIN_PROVIDER [ integer*8, size_tbc ]
implicit none
BEGIN_DOC
! Size of the tbc array
END_DOC
size_tbc = (comb_teeth+1)*N_det_generators + fragment_count*fragment_first
size_tbc = int((comb_teeth+1),8)*int(N_det_generators,8) + fragment_count*fragment_first
END_PROVIDER
subroutine get_carlo_workbatch(computed, comb, Ncomb, tbc)
@ -408,7 +470,8 @@ end subroutine
subroutine add_comb(comb, computed, tbc, stbc, ct)
implicit none
integer, intent(in) :: stbc, ct
integer*8, intent(in) :: stbc
integer, intent(in) :: ct
double precision, intent(in) :: comb
logical, intent(inout) :: computed(N_det_generators)
integer, intent(inout) :: tbc(0:stbc)
@ -430,6 +493,14 @@ subroutine add_comb(comb, computed, tbc, stbc, ct)
end subroutine
BEGIN_PROVIDER [ integer, pt2_stoch_istate ]
implicit none
BEGIN_DOC
! State for stochatsic PT2
END_DOC
pt2_stoch_istate = 1
END_PROVIDER
BEGIN_PROVIDER [ double precision, pt2_weight, (N_det_generators) ]
&BEGIN_PROVIDER [ double precision, pt2_cweight, (N_det_generators) ]
@ -442,11 +513,11 @@ end subroutine
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
pt2_weight(1) = psi_coef_generators(1,pt2_stoch_istate)**2
pt2_cweight(1) = psi_coef_generators(1,pt2_stoch_istate)**2
do i=1,N_det_generators
pt2_weight(i) = psi_coef_generators(i,1)**2
pt2_weight(i) = psi_coef_generators(i,pt2_stoch_istate)**2
enddo
! Important to loop backwards for numerical precision

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

@ -8,8 +8,9 @@ subroutine run_pt2_slave(thread,iproc,energy)
integer, intent(in) :: thread, iproc
integer :: rc, i
integer :: worker_id, task_id(1), ctask, ltask
character*(512) :: task
integer :: worker_id, ctask, ltask
character*(512), allocatable :: task(:)
integer, allocatable :: task_id(:)
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
@ -20,137 +21,171 @@ subroutine run_pt2_slave(thread,iproc,energy)
type(selection_buffer) :: buf
logical :: done
double precision :: pt2(N_states)
double precision,allocatable :: pt2_detail(:,:)
integer :: index
integer :: Nindex
double precision,allocatable :: pt2(:,:)
integer :: n_tasks, k, n_tasks_max
integer, allocatable :: i_generator(:), subset(:)
n_tasks_max = N_det_generators/100+1
allocate(task_id(n_tasks_max), task(n_tasks_max))
allocate(pt2(N_states,n_tasks_max), i_generator(n_tasks_max), subset(n_tasks_max))
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"
integer, external :: connect_to_taskserver
if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread)
return
end if
endif
zmq_socket_push = new_zmq_push_socket(thread)
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)
n_tasks = 0
call create_selection_buffer(1, 2, buf)
done = task_id(ctask) == 0
if (done) then
ctask = ctask - 1
else
integer :: i_generator, i_i_generator, subset
read (task,*) subset, index
if(buf%N == 0) then
! Only first time
call create_selection_buffer(1, 2, buf)
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
done = .False.
do while (.not.done)
n_tasks = min(n_tasks+1,n_tasks_max)
integer, external :: get_tasks_from_taskserver
if (get_tasks_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task, n_tasks) == -1) then
exit
endif
done = task_id(n_tasks) == 0
if (done) n_tasks = n_tasks-1
if (n_tasks == 0) exit
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)
pt2 = 0d0
pt2_detail(:,:Nindex) = 0d0
do k=1,n_tasks
read (task(k),*) subset(k), i_generator(k)
enddo
do k=1,n_tasks
pt2(:,k) = 0.d0
buf%cur = 0
end if
ctask = 0
end if
if(done) exit
ctask = ctask + 1
call select_connected(i_generator(k),energy,pt2(1,k),buf,subset(k))
enddo
integer, external :: tasks_done_to_taskserver
if (tasks_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_tasks) == -1) then
done = .true.
endif
call push_pt2_results(zmq_socket_push, i_generator, pt2, task_id, n_tasks)
end do
call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
integer, external :: disconnect_from_taskserver
if (disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) == -1) then
continue
endif
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread)
call delete_selection_buffer(buf)
end subroutine
subroutine push_pt2_results(zmq_socket_push, N, index, pt2_detail, task_id, ntask)
subroutine push_pt2_results(zmq_socket_push, index, pt2, task_id, n_tasks)
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(*)
double precision, intent(in) :: pt2(N_states,n_tasks)
integer, intent(in) :: n_tasks, index(n_tasks), task_id(n_tasks)
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, n_tasks, 4, ZMQ_SNDMORE)
if (rc == -1) then
return
endif
if(rc /= 4) 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, index, 4*n_tasks, ZMQ_SNDMORE)
if (rc == -1) then
return
endif
if(rc /= 4*n_tasks) 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"
rc = f77_zmq_send( zmq_socket_push, pt2, 8*N_states*n_tasks, ZMQ_SNDMORE)
if (rc == -1) then
return
endif
if(rc /= 8*N_states*n_tasks) stop 'push'
rc = f77_zmq_send( zmq_socket_push, task_id, n_tasks*4, 0)
if (rc == -1) then
return
endif
if(rc /= 4*n_tasks) stop 'push'
! Activate is zmq_socket_push is a REQ
IRP_IF ZMQ_PUSH
IRP_ELSE
character*(2) :: ok
rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
if (rc == -1) then
return
endif
if ((rc /= 2).and.(ok(1:2) /= 'ok')) then
print *, irp_here//': error in receiving ok'
stop -1
endif
IRP_ENDIF
end subroutine
subroutine pull_pt2_results(zmq_socket_pull, N, index, pt2_detail, task_id, ntask)
subroutine pull_pt2_results(zmq_socket_pull, index, pt2, task_id, n_tasks)
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(*)
double precision, intent(inout) :: pt2(N_states,*)
integer, intent(out) :: index(*)
integer, intent(out) :: n_tasks, 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, n_tasks, 4, 0)
if (rc == -1) then
n_tasks = 1
task_id(1) = 0
endif
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, index, 4*n_tasks, 0)
if (rc == -1) then
n_tasks = 1
task_id(1) = 0
endif
if(rc /= 4*n_tasks) 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, pt2, N_states*8*n_tasks, 0)
if (rc == -1) then
n_tasks = 1
task_id(1) = 0
endif
if(rc /= 8*N_states*n_tasks) 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"
rc = f77_zmq_recv( zmq_socket_pull, task_id, n_tasks*4, 0)
if (rc == -1) then
n_tasks = 1
task_id(1) = 0
endif
if(rc /= 4*n_tasks) stop 'pull'
! Activate is zmq_socket_pull is a REP
IRP_IF ZMQ_PUSH
IRP_ELSE
rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0)
if (rc == -1) then
n_tasks = 1
task_id(1) = 0
endif
if (rc /= 2) then
print *, irp_here//': error in sending ok'
stop -1
endif
IRP_ENDIF
end subroutine

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

@ -18,7 +18,7 @@ subroutine run_selection_slave(thread,iproc,energy)
integer(ZMQ_PTR) :: zmq_socket_push
type(selection_buffer) :: buf, buf2
logical :: done
logical :: done, buffer_ready
double precision :: pt2(N_states)
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
@ -27,19 +27,25 @@ subroutine run_selection_slave(thread,iproc,energy)
PROVIDE psi_bilinear_matrix_transp_order
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
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread)
integer, external :: connect_to_taskserver
if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
return
end if
endif
zmq_socket_push = new_zmq_push_socket(thread)
buf%N = 0
buffer_ready = .False.
ctask = 1
pt2 = 0d0
pt2(:) = 0d0
do
call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task)
integer, external :: get_task_from_taskserver
if (get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task) == -1) then
exit
endif
done = task_id(ctask) == 0
if (done) then
ctask = ctask - 1
@ -50,23 +56,32 @@ subroutine run_selection_slave(thread,iproc,energy)
! Only first time
call create_selection_buffer(N, N*2, buf)
call create_selection_buffer(N, N*2, buf2)
buffer_ready = .True.
else
ASSERT (N == buf%N)
end if
call select_connected(i_generator,energy,pt2,buf,0)
endif
integer, external :: task_done_to_taskserver
if(done .or. ctask == size(task_id)) then
ASSERT (.not.(buf%N == 0 .and. ctask > 0))
do i=1, ctask
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i))
if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) == -1) then
call sleep(1)
if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) == -1) then
ctask = 0
done = .true.
exit
endif
endif
end do
if(ctask > 0) then
call sort_selection_buffer(buf)
call merge_selection_buffers(buf,buf2)
call push_selection_results(zmq_socket_push, pt2, buf, task_id(1), ctask)
buf%mini = buf2%mini
pt2 = 0d0
pt2(:) = 0d0
buf%cur = 0
end if
ctask = 0
@ -75,10 +90,16 @@ subroutine run_selection_slave(thread,iproc,energy)
if(done) exit
ctask = ctask + 1
end do
call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
integer, external :: disconnect_from_taskserver
if (disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) == -1) then
continue
endif
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread)
if (buf%N > 0) then
if (buffer_ready) then
call delete_selection_buffer(buf)
call delete_selection_buffer(buf2)
endif
@ -133,7 +154,12 @@ subroutine push_selection_results(zmq_socket_push, pt2, b, task_id, ntask)
! Activate is zmq_socket_push is a REQ
IRP_IF ZMQ_PUSH
IRP_ELSE
rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0)
character*(2) :: ok
rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
if ((rc /= 2).and.(ok(1:2) /= 'ok')) then
print *, irp_here//': error in receiving ok'
stop -1
endif
IRP_ENDIF
end subroutine
@ -187,9 +213,12 @@ subroutine pull_selection_results(zmq_socket_pull, pt2, val, det, N, task_id, nt
! Activate is zmq_socket_pull is a REP
IRP_IF ZMQ_PUSH
IRP_ELSE
rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0)
rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0)
if (rc /= 2) then
print *, irp_here//': error in sending ok'
stop -1
endif
IRP_ENDIF
end subroutine

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

@ -5,6 +5,7 @@ BEGIN_PROVIDER [ integer, fragment_count ]
BEGIN_DOC
! Number of fragments for the deterministic part
END_DOC
! fragment_count = (elec_alpha_num-n_core_orb)*mo_tot_num
fragment_count = (elec_alpha_num-n_core_orb)**2
END_PROVIDER
@ -563,7 +564,6 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting)
if(fullMatch) cycle
mat = 0d0
call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting)
call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf)
@ -617,7 +617,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
do p2=ib,mo_tot_num
if(bannedOrb(p2, s2)) cycle
if(banned(p1,p2)) cycle
if(mat(1, p1, p2) == 0d0) cycle
if( sum(abs(mat(1:N_states, p1, p2))) == 0d0) cycle
call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int)
@ -783,9 +783,9 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
hij = (mo_bielec_integral(p1, p2, h1, h2) - mo_bielec_integral(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2)
if(ma == 1) then
mat(:, putj, puti) += coefs * hij
mat(:, putj, puti) += coefs(:) * hij
else
mat(:, puti, putj) += coefs * hij
mat(:, puti, putj) += coefs(:) * hij
end if
end do
else
@ -801,7 +801,7 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
p1 = p(turn2(i), 1)
hij = mo_bielec_integral(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2)
mat(:, puti, putj) += coefs * hij
mat(:, puti, putj) += coefs(:) * hij
end do
end do
end if
@ -821,7 +821,7 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
p1 = p(i1, ma)
p2 = p(i2, ma)
hij = (mo_bielec_integral(p1, p2, h1, h2) - mo_bielec_integral(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2)
mat(:, puti, putj) += coefs * hij
mat(:, puti, putj) += coefs(:) * hij
end do
end do
else if(tip == 3) then
@ -835,7 +835,7 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
p2 = p(i, ma)
hij = mo_bielec_integral(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2)
mat(:, min(puti, putj), max(puti, putj)) += coefs * hij
mat(:, min(puti, putj), max(puti, putj)) += coefs(:) * hij
end do
else ! tip == 4
puti = p(1, sp)
@ -846,7 +846,7 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
h1 = h(1, mi)
h2 = h(2, mi)
hij = (mo_bielec_integral(p1, p2, h1, h2) - mo_bielec_integral(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2)
mat(:, puti, putj) += coefs * hij
mat(:, puti, putj) += coefs(:) * hij
end if
end if
end if
@ -931,13 +931,13 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
putj = p1
if(.not. banned(putj,puti,bant)) then
hij = mo_bielec_integral(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix)
tmp_row(:,puti) += hij * coefs
tmp_row(:,puti) += hij * coefs(:)
end if
putj = p2
if(.not. banned(putj,puti,bant)) then
hij = mo_bielec_integral(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix)
tmp_row2(:,puti) += hij * coefs
tmp_row2(:,puti) += hij * coefs(:)
end if
end do
@ -959,12 +959,12 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
do putj=1,hfix-1
if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle
hij = (mo_bielec_integral(p1, p2, putj, hfix)-mo_bielec_integral(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2)
tmp_row(:,putj) += hij * coefs
tmp_row(:,putj) += hij * coefs(:)
end do
do putj=hfix+1,mo_tot_num
if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle
hij = (mo_bielec_integral(p1, p2, hfix, putj)-mo_bielec_integral(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2)
tmp_row(:,putj) += hij * coefs
tmp_row(:,putj) += hij * coefs(:)
end do
mat(:, :puti-1, puti) += tmp_row(:,:puti-1)
@ -982,13 +982,13 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
putj = p2
if(.not. banned(puti,putj,1)) then
hij = mo_bielec_integral(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1)
tmp_row(:,puti) += hij * coefs
tmp_row(:,puti) += hij * coefs(:)
end if
putj = p1
if(.not. banned(puti,putj,1)) then
hij = mo_bielec_integral(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2)
tmp_row2(:,puti) += hij * coefs
tmp_row2(:,puti) += hij * coefs(:)
end if
end do
mat(:,:p2-1,p2) += tmp_row(:,:p2-1)
@ -1017,7 +1017,7 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle
call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
call i_h_j(gen, det, N_int, hij)
mat(:, p1, p2) += coefs * hij
mat(:, p1, p2) += coefs(:) * hij
end do
end do
end

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

@ -1,15 +1,17 @@
subroutine create_selection_buffer(N, siz, res)
subroutine create_selection_buffer(N, siz_, res)
use selection_types
implicit none
integer, intent(in) :: N, siz
integer, intent(in) :: N, siz_
type(selection_buffer), intent(out) :: res
integer :: siz
siz = max(siz_,1)
allocate(res%det(N_int, 2, siz), res%val(siz))
res%val = 0d0
res%det = 0_8
res%val(:) = 0d0
res%det(:,:,:) = 0_8
res%N = N
res%mini = 0d0
res%cur = 0
@ -97,6 +99,10 @@ subroutine merge_selection_buffers(b1, b2)
endif
enddo
deallocate(b2%det, b2%val)
do i=nmwen+1,b2%N
val(i) = 0.d0
detmp(1:N_int,1:2,i) = 0_bit_kind
enddo
b2%det => detmp
b2%val => val
b2%mini = min(b2%mini,b2%val(b2%N))

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

@ -13,21 +13,30 @@ 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 n_states_diag
PROVIDE pt2_e0_denominator mo_tot_num N_int fragment_count ci_energy mpi_master zmq_state zmq_context
PROVIDE psi_det psi_coef
end
subroutine run_wf
use f77_zmq
implicit none
IRP_IF MPI
include 'mpif.h'
IRP_ENDIF
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(3)
integer :: rc, i, ierr
double precision :: t0, t1
integer, external :: zmq_get_dvector, zmq_get_N_det_generators
integer, external :: zmq_get_psi, zmq_get_N_det_selectors
integer, external :: zmq_get_N_states_diag
call provide_everything
zmq_context = f77_zmq_ctx_new ()
@ -39,19 +48,26 @@ subroutine run_wf
do
call wait_for_states(states,zmq_state,3)
call wait_for_states(states,zmq_state,size(states))
print *, trim(zmq_state)
if(trim(zmq_state) == 'Stopped') then
if(zmq_state(1:7) == 'Stopped') then
exit
else if (trim(zmq_state) == 'selection') then
else if (zmq_state(1:9) == 'selection') then
! Selection
! ---------
print *, 'Selection'
call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
call wall_time(t0)
if (zmq_get_psi(zmq_to_qp_run_socket,1) == -1) cycle
if (zmq_get_N_det_generators (zmq_to_qp_run_socket, 1) == -1) cycle
if (zmq_get_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) cycle
if (zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states) == -1) cycle
call wall_time(t1)
call write_double(6,(t1-t0),'Broadcast time')
!$OMP PARALLEL PRIVATE(i)
i = omp_get_thread_num()
@ -59,26 +75,40 @@ subroutine run_wf
!$OMP END PARALLEL
print *, 'Selection done'
else if (trim(zmq_state) == 'davidson') then
else if (zmq_state(1:8) == 'davidson') then
! Davidson
! --------
print *, 'Davidson'
call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
call wall_time(t0)
if (zmq_get_psi(zmq_to_qp_run_socket,1) == -1) cycle
if (zmq_get_N_states_diag(zmq_to_qp_run_socket,1) == -1) cycle
if (zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states_diag) == -1) cycle
call wall_time(t1)
call write_double(6,(t1-t0),'Broadcast time')
call omp_set_nested(.True.)
call davidson_slave_tcp(0)
call omp_set_nested(.False.)
print *, 'Davidson done'
else if (trim(zmq_state) == 'pt2') then
else if (zmq_state(1:3) == 'pt2') then
! PT2
! ---
print *, 'PT2'
call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
call wall_time(t0)
if (zmq_get_psi(zmq_to_qp_run_socket,1) == -1) cycle
if (zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states) == -1) cycle
if (zmq_get_N_det_generators (zmq_to_qp_run_socket, 1) == -1) cycle
if (zmq_get_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) cycle
call wall_time(t1)
call write_double(6,(t1-t0),'Broadcast time')
logical :: lstop
lstop = .False.
!$OMP PARALLEL PRIVATE(i)
@ -89,7 +119,17 @@ subroutine run_wf
endif
IRP_IF MPI
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
print *, irp_here, 'error in barrier'
endif
IRP_ENDIF
end do
IRP_IF MPI
call MPI_finalize(i)
IRP_ENDIF
end

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

@ -27,6 +27,9 @@ subroutine run_wf
double precision :: energy(N_states)
character*(64) :: states(4)
integer :: rc, i, ierr
integer, external :: zmq_get_dvector
integer, external :: zmq_get_psi
call provide_everything
@ -51,7 +54,8 @@ subroutine run_wf
! ---------
print *, 'Selection'
call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
if (zmq_get_psi(zmq_to_qp_run_socket,1) == -1) cycle
if (zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states) == -1) cycle
!$OMP PARALLEL PRIVATE(i)
i = omp_get_thread_num()
@ -65,7 +69,8 @@ subroutine run_wf
! ---
print *, 'PT2'
call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
if (zmq_get_psi(zmq_to_qp_run_socket,1) == -1) cycle
if (zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states) == -1) cycle
logical :: lstop
lstop = .False.

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

@ -4,7 +4,7 @@ subroutine ZMQ_selection(N_in, pt2)
implicit none
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket , zmq_socket_pull
integer, intent(in) :: N_in
type(selection_buffer) :: b
integer :: i, N
@ -23,11 +23,29 @@ subroutine ZMQ_selection(N_in, pt2)
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
PROVIDE psi_bilinear_matrix_transp_order
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 new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'selection')
integer, external :: zmq_put_psi
integer, external :: zmq_put_N_det_generators
integer, external :: zmq_put_N_det_selectors
integer, external :: zmq_put_dvector
if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then
stop 'Unable to put psi on ZMQ server'
endif
if (zmq_put_N_det_generators(zmq_to_qp_run_socket, 1) == -1) then
stop 'Unable to put N_det_generators on ZMQ server'
endif
if (zmq_put_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) then
stop 'Unable to put N_det_selectors on ZMQ server'
endif
if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) == -1) then
stop 'Unable to put energy on ZMQ server'
endif
call create_selection_buffer(N, N*2, b)
endif
integer, external :: add_task_to_taskserver
character*(20*maxtasks) :: task
task = ' '
@ -38,27 +56,41 @@ subroutine ZMQ_selection(N_in, pt2)
write(task(20*(k-1)+1:20*k),'(I9,1X,I9,''|'')') i, N
if (k>=maxtasks) then
k=0
call add_task_to_taskserver(zmq_to_qp_run_socket,task)
if (add_task_to_taskserver(zmq_to_qp_run_socket,task) == -1) then
stop 'Unable to add task to task server'
endif
endif
end do
if (k > 0) then
call add_task_to_taskserver(zmq_to_qp_run_socket,task)
if (add_task_to_taskserver(zmq_to_qp_run_socket,task) == -1) then
stop 'Unable to add task to task server'
endif
endif
ASSERT (associated(b%det))
ASSERT (associated(b%val))
integer, external :: zmq_set_running
if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
print *, irp_here, ': Failed in zmq_set_running'
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, N, pt2)
call selection_collector(zmq_socket_pull, b, N, pt2)
else
call selection_slave_inproc(i)
endif
!$OMP END PARALLEL
call end_parallel_job(zmq_to_qp_run_socket, 'selection')
call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'selection')
do i=N_det+1,N_states
pt2(i) = 0.d0
enddo
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
if (s2_eig.or.(N_states > 1) ) then
call make_s2_eigenfunction
endif
call save_wavefunction
@ -75,13 +107,14 @@ subroutine selection_slave_inproc(i)
call run_selection_slave(1,i,pt2_e0_denominator)
end
subroutine selection_collector(b, N, pt2)
subroutine selection_collector(zmq_socket_pull, b, N, pt2)
use f77_zmq
use selection_types
use bitmasks
implicit none
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
type(selection_buffer), intent(inout) :: b
integer, intent(in) :: N
double precision, intent(out) :: pt2(N_states)
@ -90,27 +123,24 @@ subroutine selection_collector(b, N, pt2)
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, ntask
double precision, pointer :: val(:)
integer(bit_kind), pointer :: det(:,:,:)
integer, allocatable :: task_id(:)
real :: time, time0
type(selection_buffer) :: b2
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
zmq_socket_pull = new_zmq_pull_socket()
call create_selection_buffer(N, N*2, b2)
allocate(task_id(N_det_generators))
more = 1
pt2(:) = 0d0
call CPU_TIME(time0)
pt2_mwen(:) = 0.d0
do while (more == 1)
call pull_selection_results(zmq_socket_pull, pt2_mwen, b2%val(1), b2%det(1,1,1), b2%cur, task_id, ntask)
pt2 += pt2_mwen
pt2(:) += pt2_mwen(:)
do i=1, b2%cur
call add_to_selection_buffer(b, b2%det(1,1,i), b2%val(i))
if (b2%val(i) > b%mini) exit
@ -120,15 +150,16 @@ subroutine selection_collector(b, N, pt2)
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)
integer, external :: zmq_delete_task
if (zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more) == -1) then
stop 'Unable to delete task'
endif
end do
call CPU_TIME(time)
end do
call delete_selection_buffer(b2)
call sort_selection_buffer(b)
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_pull_socket(zmq_socket_pull)
end subroutine

254
plugins/GPI2/broadcast.irp.f Normal file
View File

@ -0,0 +1,254 @@
subroutine broadcast_wf(energy)
implicit none
BEGIN_DOC
! Segment corresponding to the wave function. This is segment 0.
END_DOC
use bitmasks
use GASPI
use ISO_C_BINDING
double precision, intent(inout) :: energy(N_states)
integer(gaspi_return_t) :: res
if (is_gaspi_master) then
call broadcast_wf_put(energy)
else
call broadcast_wf_get(energy)
endif
res = gaspi_barrier(GASPI_GROUP_ALL, GASPI_BLOCK)
if(res .ne. GASPI_SUCCESS) then
write(*,*) "gaspi_barrier failed"
stop -1
end if
integer(gaspi_segment_id_t) :: seg_id
do seg_id=0,3
res = gaspi_segment_delete(seg_id)
if(res .ne. GASPI_SUCCESS) then
write(*,*) "gaspi_segment_delete failed", seg_id
stop -1
end if
end do
end
subroutine broadcast_wf_put(energy)
implicit none
BEGIN_DOC
! Initiates the broadcast of the wave function
END_DOC
use bitmasks
use GASPI
use ISO_C_BINDING
double precision, intent(in) :: energy(N_states)
integer(gaspi_segment_id_t) :: seg_id
integer(gaspi_alloc_t) :: seg_alloc_policy
integer(gaspi_size_t) :: seg_size(0:3)
type(c_ptr) :: seg_ptr(0:3)
integer, pointer :: params_int(:) ! Segment 0
double precision, pointer :: psi_coef_tmp(:,:) ! Segment 1
integer(bit_kind), pointer :: psi_det_tmp(:,:,:) ! Segment 2
double precision, pointer :: params_double(:) ! Segment 3
integer(gaspi_return_t) :: res
seg_alloc_policy = GASPI_MEM_UNINITIALIZED
seg_size(0) = 4 * 5
seg_id=0
res = gaspi_segment_create(seg_id, seg_size(seg_id), GASPI_GROUP_ALL, &
GASPI_BLOCK, seg_alloc_policy)
if(res .ne. GASPI_SUCCESS) then
write(*,*) "gaspi_create_segment failed", gaspi_rank, seg_id
stop -1
end if
res = gaspi_segment_ptr(seg_id, seg_ptr(seg_id))
if(res .ne. GASPI_SUCCESS) then
write(*,*) "gaspi_segment_ptr failed", gaspi_rank
stop -1
end if
call c_f_pointer(seg_ptr(0), params_int, shape=(/ 5 /))
params_int(1) = N_states
params_int(2) = N_det
params_int(3) = psi_det_size
res = gaspi_barrier(GASPI_GROUP_ALL, GASPI_BLOCK)
if(res .ne. GASPI_SUCCESS) then
write(*,*) "gaspi_barrier failed", gaspi_rank
stop -1
end if
seg_size(1) = 8 * psi_det_size * N_states
seg_size(2) = bit_kind * psi_det_size * 2 * N_int
seg_size(3) = 8 * N_states
do seg_id=1, 3
res = gaspi_segment_create(seg_id, seg_size(seg_id), GASPI_GROUP_ALL, &
GASPI_BLOCK, seg_alloc_policy)
if(res .ne. GASPI_SUCCESS) then
write(*,*) "gaspi_create_segment failed", gaspi_rank, seg_id
stop -1
end if
res = gaspi_segment_ptr(seg_id, seg_ptr(seg_id))
if(res .ne. GASPI_SUCCESS) then
write(*,*) "gaspi_segment_ptr failed", gaspi_rank
stop -1
end if
end do
call c_f_pointer(seg_ptr(1), psi_coef_tmp, shape=shape(psi_coef))
call c_f_pointer(seg_ptr(2), psi_det_tmp, shape=shape(psi_det))
call c_f_pointer(seg_ptr(3), params_double, shape=(/ N_states /))
psi_coef_tmp = psi_coef
psi_det_tmp = psi_det
params_double = energy
res = gaspi_barrier(GASPI_GROUP_ALL, GASPI_BLOCK)
if(res .ne. GASPI_SUCCESS) then
write(*,*) "gaspi_barrier failed", gaspi_rank
stop -1
end if
end
subroutine broadcast_wf_get(energy)
implicit none
BEGIN_DOC
! Gets the broadcasted wave function
END_DOC
use bitmasks
use GASPI
use ISO_C_BINDING
double precision, intent(out) :: energy(N_states)
integer(gaspi_segment_id_t) :: seg_id
integer(gaspi_alloc_t) :: seg_alloc_policy
integer(gaspi_size_t) :: seg_size(0:3)
type(c_ptr) :: seg_ptr(0:3)
integer, pointer :: params_int(:) ! Segment 0
double precision, pointer :: psi_coef_tmp(:,:) ! Segment 1
integer(bit_kind), pointer :: psi_det_tmp(:,:,:) ! Segment 2
double precision, pointer :: params_double(:) ! Segment 3
integer(gaspi_return_t) :: res
seg_alloc_policy = GASPI_MEM_UNINITIALIZED
seg_size(0) = 4 * 5
seg_id=0
res = gaspi_segment_create(seg_id, seg_size(seg_id), GASPI_GROUP_ALL,&
GASPI_BLOCK, seg_alloc_policy)
if(res .ne. GASPI_SUCCESS) then
write(*,*) "gaspi_create_segment failed"
stop -1
end if
res = gaspi_segment_ptr(seg_id, seg_ptr(seg_id))
if(res .ne. GASPI_SUCCESS) then
write(*,*) "gaspi_segment_ptr failed"
stop -1
end if
res = gaspi_barrier(GASPI_GROUP_ALL, GASPI_BLOCK)
if(res .ne. GASPI_SUCCESS) then
write(*,*) "gaspi_barrier failed"
stop -1
end if
integer(gaspi_offset_t) :: localOff, remoteOff
integer(gaspi_rank_t) :: remoteRank
integer(gaspi_queue_id_t) :: queue
localOff = 0
remoteRank = 0
queue = 0
res = gaspi_read(seg_id, localOff, remoteRank, &
seg_id, remoteOff, seg_size(seg_id), queue, GASPI_BLOCK)
if(res .ne. GASPI_SUCCESS) then
write(*,*) "gaspi_read failed"
stop -1
end if
res = gaspi_wait(queue, GASPI_BLOCK)
if(res .ne. GASPI_SUCCESS) then
write(*,*) "gaspi_wait failed"
stop -1
end if
call c_f_pointer(seg_ptr(0), params_int, shape=shape( (/ 5 /) ))
N_states = params_int(1)
N_det = params_int(2)
psi_det_size = params_int(3)
TOUCH N_states N_det psi_det_size
seg_size(1) = 8 * psi_det_size * N_states
seg_size(2) = bit_kind * psi_det_size * 2 * N_int
seg_size(3) = 8 * N_states
do seg_id=1, 3
res = gaspi_segment_create(seg_id, seg_size(seg_id), GASPI_GROUP_ALL, &
GASPI_BLOCK, seg_alloc_policy)
if(res .ne. GASPI_SUCCESS) then
write(*,*) "gaspi_create_segment failed"
stop -1
end if
res = gaspi_segment_ptr(seg_id, seg_ptr(seg_id))
if(res .ne. GASPI_SUCCESS) then
write(*,*) "gaspi_segment_ptr failed"
stop -1
end if
end do
res = gaspi_barrier(GASPI_GROUP_ALL, GASPI_BLOCK)
if(res .ne. GASPI_SUCCESS) then
write(*,*) "gaspi_barrier failed"
stop -1
end if
do seg_id=1, 3
res = gaspi_read(seg_id, localOff, remoteRank, &
seg_id, remoteOff, seg_size(seg_id), queue, GASPI_BLOCK)
if(res .ne. GASPI_SUCCESS) then
write(*,*) "gaspi_read failed"
stop -1
end if
res = gaspi_wait(queue, GASPI_BLOCK)
if(res .ne. GASPI_SUCCESS) then
write(*,*) "gaspi_wait failed"
stop -1
end if
end do
call c_f_pointer(seg_ptr(1), psi_coef_tmp, shape=shape(psi_coef))
call c_f_pointer(seg_ptr(2), psi_det_tmp, shape=shape(psi_det))
call c_f_pointer(seg_ptr(3), params_double, shape=shape(energy))
psi_coef = psi_coef_tmp
psi_det = psi_det_tmp
energy = params_double
end

98
plugins/Hartree_Fock/README.rst
View File

@ -33,16 +33,16 @@ Documentation
.. by the `update_README.py` script.
`ao_bi_elec_integral_alpha <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L103>`_
`ao_bi_elec_integral_alpha <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L102>`_
Alpha Fock matrix in AO basis set
`ao_bi_elec_integral_beta <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L104>`_
`ao_bi_elec_integral_beta <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L103>`_
Alpha Fock matrix in AO basis set
`create_guess <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/SCF.irp.f#L13>`_
Create an MO guess if no MOs are present in the EZFIO directory
Create a MO guess if no MOs are present in the EZFIO directory
`damping_scf <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/damping_SCF.irp.f#L1>`_
@ -53,34 +53,38 @@ Documentation
Diagonal Fock matrix in the MO basis
`diagonal_fock_matrix_mo_sum <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/diagonalize_fock.irp.f#L95>`_
`diagonal_fock_matrix_mo_sum <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/diagonalize_fock.irp.f#L105>`_
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
`eigenvalues_fock_matrix_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/DIIS.irp.f#L73>`_
Eigenvalues and eigenvectors of the Fock matrix over the AO basis
`eigenvectors_fock_matrix_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/DIIS.irp.f#L74>`_
Eigenvalues and eigenvectors of the Fock matrix over the AO basis
`eigenvectors_fock_matrix_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/diagonalize_fock.irp.f#L2>`_
Diagonal Fock matrix in the MO basis
`fock_matrix_alpha_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L84>`_
Alpha Fock matrix in AO basis set
`extrapolate_fock_matrix <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Roothaan_Hall_SCF.irp.f#L146>`_
Compute the extrapolated Fock matrix using the DIIS procedure
`fock_matrix_alpha_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L269>`_
Fock matrix on the MO basis
`fock_matrix_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L327>`_
`fock_matrix_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L317>`_
Fock matrix in AO basis set
`fock_matrix_beta_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L85>`_
`fock_matrix_ao_alpha <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L84>`_
Alpha Fock matrix in AO basis set
`fock_matrix_beta_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L289>`_
Fock matrix on the MO basis
`fock_matrix_ao_beta <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L85>`_
Alpha Fock matrix in AO basis set
`fock_matrix_diag_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L2>`_
@ -115,10 +119,26 @@ Documentation
.br
`fock_mo_to_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L389>`_
`fock_matrix_mo_alpha <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L261>`_
Fock matrix on the MO basis
`fock_matrix_mo_beta <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L280>`_
Fock matrix on the MO basis
`fock_mo_to_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L378>`_
Undocumented
`fps_spf_matrix_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/DIIS.irp.f#L15>`_
Commutator FPS - SPF
`fps_spf_matrix_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/DIIS.irp.f#L63>`_
Commutator FPS - SPF in MO basis
`guess <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Huckel_guess.irp.f#L1>`_
Undocumented
@ -135,7 +155,7 @@ Documentation
S^-1 Beta density matrix in the AO basis x S^-1
`hf_energy <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L308>`_
`hf_energy <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L298>`_
Hartree-Fock energy
@ -143,23 +163,35 @@ Documentation
Build the MOs using the extended Huckel model
`level_shift <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L25>`_
`level_shift <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L44>`_
Energy shift on the virtual MOs to improve SCF convergence
`mo_guess_type <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L6>`_
`localize_mos <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/localize_mos.irp.f#L1>`_
Undocumented
`max_dim_diis <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L6>`_
Maximum size of the DIIS extrapolation procedure
`mo_guess_type <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L82>`_
Initial MO guess. Can be [ Huckel | HCore ]
`n_it_scf_max <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L63>`_
`n_it_scf_max <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L139>`_
Maximum number of SCF iterations
`no_oa_or_av_opt <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L82>`_
`no_oa_or_av_opt <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L120>`_
If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure
`run <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/SCF.irp.f#L38>`_
`roothaan_hall_scf <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Roothaan_Hall_SCF.irp.f#L1>`_
Roothaan-Hall algorithm for SCF Hartree-Fock calculation
`run <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/SCF.irp.f#L37>`_
Run SCF calculation
@ -170,6 +202,26 @@ Documentation
optional: mo_basis.mo_coef
`thresh_scf <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L44>`_
Threshold on the convergence of the Hartree Fock energy
`scf_algorithm <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L101>`_
Type of SCF algorithm used. Possible choices are [ Simple | DIIS]
`thresh_scf <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L158>`_
Threshold on the convergence of the Hartree Fock energy.
`threshold_diis <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L63>`_
Threshold on the convergence of the DIIS error vector during a Hartree-Fock calculation. If 0. is chosen, the square root of thresh_scf will be used.
`threshold_diis_nonzero <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/DIIS.irp.f#L1>`_
If threshold_DIIS is zero, choose sqrt(thresh_scf)
`threshold_overlap_ao_eigenvalues <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L25>`_
Threshold on the magnitude of the smallest eigenvalues of the overlap matrix in the AO basis
`x_matrix_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/DIIS.irp.f#L140>`_
Matrix X = S^{-1/2} obtained by SVD

10
plugins/Hartree_Fock_SlaterDressed/dressing.irp.f
View File

@ -1,4 +1,4 @@
BEGIN_PROVIDER [ double precision, ao_ortho_mono_elec_integral_dressing, (ao_num_align,ao_num) ]
BEGIN_PROVIDER [ double precision, ao_ortho_mono_elec_integral_dressing, (ao_num,ao_num) ]
implicit none
BEGIN_DOC
! Dressing of the core hamiltonian in the orthogonal AO basis set
@ -25,7 +25,7 @@ BEGIN_PROVIDER [ double precision, ao_ortho_mono_elec_integral_dressing, (ao_num
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_ortho_mono_elec_integral, (ao_num_align, ao_num) ]
BEGIN_PROVIDER [ double precision, ao_ortho_mono_elec_integral, (ao_num, ao_num) ]
implicit none
BEGIN_DOC
! h core in orthogonal AO basis
@ -53,7 +53,7 @@ BEGIN_PROVIDER [ double precision, ao_mono_elec_integral_dressing, (ao_num,ao_nu
ao_mono_elec_integral_dressing,size(ao_mono_elec_integral_dressing,1))
END_PROVIDER
BEGIN_PROVIDER [ double precision, mo_mono_elec_integral_dressing, (mo_tot_num_align,mo_tot_num) ]
BEGIN_PROVIDER [ double precision, mo_mono_elec_integral_dressing, (mo_tot_num,mo_tot_num) ]
implicit none
BEGIN_DOC
! Dressing of the core hamiltonian in the MO basis set
@ -73,14 +73,14 @@ BEGIN_PROVIDER [ integer, idx_dressing ]
END_PROVIDER
BEGIN_PROVIDER [ double precision, cusp_corrected_mos, (ao_num_align,mo_tot_num) ]
BEGIN_PROVIDER [ double precision, cusp_corrected_mos, (ao_num,mo_tot_num) ]
implicit none
BEGIN_DOC
! Dressing core hamiltonian in the AO basis set
END_DOC
integer :: i,j
double precision, allocatable :: F(:,:), M(:,:)
allocate(F(mo_tot_num_align,mo_tot_num),M(ao_num,mo_tot_num))
allocate(F(mo_tot_num,mo_tot_num),M(ao_num,mo_tot_num))
logical :: oneshot

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

@ -85,7 +85,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s
double precision, intent(inout) :: u_in(dim_in,N_st_diag)
double precision, intent(out) :: energies(N_st_diag)
integer :: sze_8
integer :: iter
integer :: i,j,k,l,m
logical :: converged
@ -138,13 +137,10 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s
enddo
write(iunit,'(A)') trim(write_buffer)
integer, external :: align_double
sze_8 = align_double(sze)
allocate( &
W(sze_8,N_st_diag,davidson_sze_max), &
U(sze_8,N_st_diag,davidson_sze_max), &
R(sze_8,N_st_diag), &
W(sze,N_st_diag,davidson_sze_max), &
U(sze,N_st_diag,davidson_sze_max), &
R(sze,N_st_diag), &
h(N_st_diag,davidson_sze_max,N_st_diag,davidson_sze_max), &
y(N_st_diag,davidson_sze_max,N_st_diag,davidson_sze_max), &
residual_norm(N_st_diag), &
@ -199,7 +195,7 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s
! Compute |W_k> = \sum_i |i><i|H|u_k>
! -----------------------------------------
call H_u_0_mrcc_nstates(W(1,1,iter),U(1,1,iter),H_jj,sze,dets_in,Nint,istate,N_st_diag,sze_8)
call H_u_0_mrcc_nstates(W(1,1,iter),U(1,1,iter),H_jj,sze,dets_in,Nint,istate,N_st_diag,sze)
! Compute h_kl = <u_k | W_l> = <u_k| H |u_l>
@ -320,7 +316,7 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s
end
subroutine u_0_H_u_0_mrcc_nstates(e_0,u_0,n,keys_tmp,Nint,istate,N_st,sze_8)
subroutine u_0_H_u_0_mrcc_nstates(e_0,u_0,n,keys_tmp,Nint,istate,N_st,sze)
use bitmasks
implicit none
BEGIN_DOC
@ -329,16 +325,16 @@ subroutine u_0_H_u_0_mrcc_nstates(e_0,u_0,n,keys_tmp,Nint,istate,N_st,sze_8)
! n : number of determinants
!
END_DOC
integer, intent(in) :: n,Nint,N_st,sze_8
integer, intent(in) :: n,Nint,N_st,sze
double precision, intent(out) :: e_0(N_st)
double precision, intent(in) :: u_0(sze_8,N_st)
double precision, intent(in) :: u_0(sze,N_st)
integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n)
integer,intent(in) :: istate
double precision, allocatable :: v_0(:,:), H_jj(:)
double precision :: u_dot_u,u_dot_v,diag_H_mat_elem
integer :: i,j
allocate(H_jj(n), v_0(sze_8,N_st))
allocate(H_jj(n), v_0(sze,N_st))
do i = 1, n
H_jj(i) = diag_H_mat_elem(keys_tmp(1,1,i),Nint)
enddo
@ -347,7 +343,7 @@ subroutine u_0_H_u_0_mrcc_nstates(e_0,u_0,n,keys_tmp,Nint,istate,N_st,sze_8)
H_jj(idx_ref(i)) += delta_ii(istate,i)
enddo
call H_u_0_mrcc_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,istate,N_st,sze_8)
call H_u_0_mrcc_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,istate,N_st,sze)
do i=1,N_st
e_0(i) = u_dot_v(v_0(1,i),u_0(1,i),n)/u_dot_u(u_0(1,i),n)
enddo
@ -355,7 +351,7 @@ subroutine u_0_H_u_0_mrcc_nstates(e_0,u_0,n,keys_tmp,Nint,istate,N_st,sze_8)
end
subroutine H_u_0_mrcc_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,istate_in,N_st,sze_8)
subroutine H_u_0_mrcc_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,istate_in,N_st,sze)
use bitmasks
implicit none
BEGIN_DOC
@ -365,9 +361,9 @@ subroutine H_u_0_mrcc_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,istate_in,N_st,sze_8)
!
! H_jj : array of <j|H|j>
END_DOC
integer, intent(in) :: n,Nint,istate_in,N_st,sze_8
double precision, intent(out) :: v_0(sze_8,N_st)
double precision, intent(in) :: u_0(sze_8,N_st)
integer, intent(in) :: n,Nint,istate_in,N_st,sze
double precision, intent(out) :: v_0(sze,N_st)
double precision, intent(in) :: u_0(sze,N_st)
double precision, intent(in) :: H_jj(n)
integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n)
double precision :: hij
@ -396,9 +392,9 @@ subroutine H_u_0_mrcc_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,istate_in,N_st,sze_8)
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(i,hij,j,k,jj,vt,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)&
!$OMP SHARED(n,H_jj,u_0,keys_tmp,Nint,v_0,sorted,shortcut,sort_idx,version,N_st,sze_8,&
!$OMP SHARED(n,H_jj,u_0,keys_tmp,Nint,v_0,sorted,shortcut,sort_idx,version,N_st,sze,&
!$OMP istate_in,delta_ij,N_det_ref,N_det_non_ref,idx_ref,idx_non_ref)
allocate(vt(sze_8,N_st))
allocate(vt(sze,N_st))
Vt = 0.d0
!$OMP DO SCHEDULE(static,1)
@ -590,7 +586,6 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
double precision, intent(inout) :: u_in(dim_in,N_st_diag)
double precision, intent(out) :: energies(N_st_diag)
integer :: sze_8
integer :: iter
integer :: i,j,k,l,m
logical :: converged
@ -649,14 +644,11 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
enddo
write(iunit,'(A)') trim(write_buffer)
integer, external :: align_double
sze_8 = align_double(sze)
itermax = min(davidson_sze_max, sze/N_st_diag)
allocate( &
W(sze_8,N_st_diag*itermax), &
U(sze_8,N_st_diag*itermax), &
S(sze_8,N_st_diag*itermax), &
W(sze,N_st_diag*itermax), &
U(sze,N_st_diag*itermax), &
S(sze,N_st_diag*itermax), &
h(N_st_diag*itermax,N_st_diag*itermax), &
y(N_st_diag*itermax,N_st_diag*itermax), &
s_(N_st_diag*itermax,N_st_diag*itermax), &
@ -722,7 +714,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
! -----------------------------------------
call H_S2_u_0_mrcc_nstates(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,&
istate,N_st_diag,sze_8)
istate,N_st_diag,sze)
! Compute h_kl = <u_k | W_l> = <u_k| H |u_l>
@ -960,7 +952,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
end
subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_in,N_st,sze_8)
subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_in,N_st,sze)
use bitmasks
implicit none
BEGIN_DOC
@ -972,9 +964,9 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i
!
! S2_jj : array of <j|S^2|j>
END_DOC
integer, intent(in) :: N_st,n,Nint, sze_8, istate_in
double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st)
double precision, intent(in) :: u_0(sze_8,N_st)
integer, intent(in) :: N_st,n,Nint, sze, istate_in
double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st)
double precision, intent(in) :: u_0(sze,N_st)
double precision, intent(in) :: H_jj(n), S2_jj(n)
integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n)
double precision :: hij,s2
@ -987,20 +979,16 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i
integer(bit_kind) :: sorted_i(Nint)
integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate
integer :: N_st_8
integer, external :: align_double
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: vt, ut
N_st_8 = align_double(N_st)
ASSERT (Nint > 0)
ASSERT (Nint == N_int)
ASSERT (n>0)
PROVIDE ref_bitmask_energy
allocate (shortcut(0:n+1,2), sort_idx(n,2), sorted(Nint,n,2), version(Nint,n,2))
allocate(ut(N_st_8,n))
allocate(ut(N_st,n))
v_0 = 0.d0
s_0 = 0.d0
@ -1017,9 +1005,9 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i
PROVIDE delta_ij_s2
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(i,hij,s2,j,k,jj,vt,st,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)&
!$OMP SHARED(n,keys_tmp,ut,Nint,v_0,s_0,sorted,shortcut,sort_idx,version,N_st,N_st_8, &
!$OMP SHARED(n,keys_tmp,ut,Nint,v_0,s_0,sorted,shortcut,sort_idx,version,N_st, &
!$OMP N_det_ref, idx_ref, N_det_non_ref, idx_non_ref, delta_ij, delta_ij_s2,istate_in)
allocate(vt(N_st_8,n),st(N_st_8,n))
allocate(vt(N_st,n),st(N_st,n))
Vt = 0.d0
St = 0.d0
@ -1096,6 +1084,8 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i
! Begin Specific to dressing
! --------------------------
!TODO : DRESSING 1 column
!$OMP DO
do ii=1,n_det_ref
i = idx_ref(ii)

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

@ -195,34 +195,34 @@ END_PROVIDER
if (diag_algorithm == "Davidson") then
allocate (eigenvectors(size(CI_eigenvectors_dressed,1),size(CI_eigenvectors_dressed,2)), &
eigenvalues(size(CI_electronic_energy_dressed,1)))
allocate (eigenvectors(size(CI_eigenvectors_dressed,1),size(CI_eigenvectors_dressed,2)),&
eigenvalues(size(CI_electronic_energy_dressed,1)))
do j=1,min(N_states,N_det)
do i=1,N_det
eigenvectors(i,j) = psi_coef(i,j)
enddo
enddo
do mrcc_state=1,N_states
do j=mrcc_state,min(N_states,N_det)
do i=1,N_det
eigenvectors(i,j) = psi_coef(i,j)
enddo
enddo
call davidson_diag_mrcc_HS2(psi_det,eigenvectors,&
size(eigenvectors,1), &
eigenvalues,N_det,N_states,N_states_diag,N_int, &
output_determinants,mrcc_state)
CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state)
CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state)
enddo
do k=N_states+1,N_states_diag
CI_eigenvectors_dressed(1:N_det,k) = eigenvectors(1:N_det,k)
CI_electronic_energy_dressed(k) = eigenvalues(k)
enddo
call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,&
N_states_diag,size(CI_eigenvectors_dressed,1))
deallocate (eigenvectors,eigenvalues)
do j=mrcc_state,min(N_states,N_det)
do i=1,N_det
eigenvectors(i,j) = psi_coef(i,j)
enddo
enddo
call davidson_diag_mrcc_HS2(psi_det,eigenvectors, &
size(eigenvectors,1), &
eigenvalues,N_det,N_states,N_states_diag,N_int, &
output_determinants,mrcc_state)
CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state)
CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state)
enddo
do k=N_states+1,N_states_diag
CI_eigenvectors_dressed(1:N_det,k) = eigenvectors(1:N_det,k)
CI_electronic_energy_dressed(k) = eigenvalues(k)
enddo
call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,&
N_states_diag,size(CI_eigenvectors_dressed,1))
deallocate (eigenvectors,eigenvalues)
else if (diag_algorithm == "Lapack") then

171
plugins/MR_wf_analysis/analyze_one_det_connections.irp.f Normal file
View File

@ -0,0 +1,171 @@
program test_wf
implicit none
read_wf = .True.
touch read_wf
call routine
end
subroutine routine
use bitmasks
implicit none
integer :: iref
print*, 'which reference slater determinant dou you want ?'
read(5,*)iref
integer :: i
double precision :: delta_e,h0i
double precision :: accu_e, hiiref,accu_coef,hij
double precision, allocatable :: contrib(:)
integer, allocatable :: iorder(:)
integer, allocatable :: idx(:)
allocate(idx(0:N_det))
print*, '***********************'
print*, '***********************'
print*, '***********************'
print*, 'You chose that SD :'
call debug_det(psi_det(1,1,iref),N_int)
call get_excitation_degree(ref_bitmask,psi_det(1,1,iref),degree,N_int)
call i_H_j(ref_bitmask,psi_det(1,1,iref),N_int,h0i)
call i_H_j(psi_ref(1,1,iref),psi_det(1,1,iref),N_int,hii)
call get_excitation(ref_bitmask,psi_det(1,1,iref),exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
print*,'degree =',degree
print*,'phase =',phase
if(degree == 1)then
print*,'s1',s1
print*,'h1,p1 = ',h1,p1
else if (degree ==2)then
print*,'s1',s1
print*,'h1,p1 = ',h1,p1
print*,'s2',s2
print*,'h2,p2 = ',h2,p2
endif
if(degree.ne.0)then
delta_e = hii - ref_bitmask_energy
if(h0i.ne.0.d0)then
if (delta_e > 0.d0) then
coef_2_2 = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * h0i * h0i ))/ h0i
else
coef_2_2 = 0.5d0 * (delta_e + dsqrt(delta_e * delta_e + 4.d0 * h0i * h0i )) /h0i
endif
endif
endif
print*,'h0i =',h0i
print*,'delta E =',delta_e
print*,'coef 2x2 =',coef_2_2!*psi_coef(1,1)
print*,'amplitude =',psi_coef(iref,1)/psi_coef(1,1)
print*, '***********************'
print*, '***********************'
print*, '***********************'
call filter_connected_i_H_psi0(psi_det,psi_det(1,1,iref),N_int,N_det,idx)
call i_H_j(psi_det(1,1,iref),psi_det(1,1,iref),N_int,hiiref)
print*, 'passed the connection browsing'
allocate(contrib(idx(0)-1),iorder(idx(0)-1))
accu_e = 0.d0
accu_coef = 0.d0
print*, iref
print*, idx(0)
do i = 1, idx(0)
contrib(i) = 0.d0
iorder(i) = idx(i)
if(idx(i)==iref)then
cycle
else
call get_excitation_degree(psi_det(1,1,iref),psi_det(1,1,idx(i)),degree,N_int)
if(degree.gt.2)cycle
call i_H_j(psi_det(1,1,iref),psi_det(1,1,idx(i)),N_int,hij)
accu_coef += psi_coef(idx(i),1) * hij / (var_energy_mr(1) - hiiref)
contrib(i) = -dabs(psi_coef(idx(i),1) * hij / (var_energy_mr(1) - hiiref))
accu_e += psi_coef(idx(i),1) * hij
endif
enddo
print*, 'passed the contributions '
integer :: degree
integer :: exc(0:2,2,2)
double precision :: phase
integer :: h1,h2,p1,p2,s1,s2
accu_e += psi_coef(iref,1) * hiiref
accu_e = accu_e / psi_coef(iref,1)
print*, psi_coef(iref,1),accu_coef
print*, var_energy_mr(1),accu_e
call dsort(contrib,iorder,idx(0)-1)
print*, 'passed sorting the contributions'
accu_coef = 0.d0
double precision :: accu_second_order,coef_2_2, hii
accu_second_order = 0.d0
print*, ''
do i = 1, idx(0)
if (iorder(i)==iref)cycle
call get_excitation_degree(psi_det(1,1,iref),psi_det(1,1,iorder(i)),degree,N_int)
if(degree.gt.2)cycle
print*, ''
print*, '==============================================='
print*, ' i ',i,iorder(i)
call debug_det(psi_det(1,1,iorder(i)),N_int)
call i_H_j(psi_det(1,1,iorder(i)),psi_det(1,1,iorder(i)),N_int,hii)
call i_H_j(psi_det(1,1,iref),psi_det(1,1,iorder(i)),N_int,hij)
call get_excitation(psi_det(1,1,iref),psi_det(1,1,iorder(i)),exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
print*,'Info with respect to the chosen ref determinant'
print*,'degree =',degree
if(degree == 1)then
print*,'s1',s1
print*,'h1,p1 = ',h1,p1
else
print*,'s1',s1
print*,'h1,p1 = ',h1,p1
print*,'s2',s2
print*,'h2,p2 = ',h2,p2
endif
print*,'coef =',psi_coef(iorder(i),1)
print*,'phase =',phase
print*,'hij =',hij
print*,'contrib =',psi_coef(iorder(i),1) * hij / (var_energy_mr(1) - hiiref)
print*,'relative contrib =',psi_coef(iorder(i),1) * hij / (var_energy_mr(1) - hiiref)/psi_coef(iref,1)
accu_coef += psi_coef(iorder(i),1) * hij / (var_energy_mr(1) - hiiref)
print*,'Info with respect to the HF-like determinant '
call get_excitation_degree(ref_bitmask,psi_det(1,1,iorder(i)),degree,N_int)
call i_H_j(ref_bitmask,psi_det(1,1,iorder(i)),N_int,h0i)
call get_excitation(ref_bitmask,psi_det(1,1,iorder(i)),exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
print*,'degree =',degree
if(degree == 1)then
print*,'s1',s1
print*,'h1,p1 = ',h1,p1
else if (degree ==2)then
print*,'s1',s1
print*,'h1,p1 = ',h1,p1
print*,'s2',s2
print*,'h2,p2 = ',h2,p2
endif
if(degree.ne.0)then
delta_e = hii - ref_bitmask_energy
if(h0i.ne.0.d0)then
if (delta_e > 0.d0) then
coef_2_2 = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * h0i * h0i ))/ h0i
else
coef_2_2 = 0.5d0 * (delta_e + dsqrt(delta_e * delta_e + 4.d0 * h0i * h0i )) /h0i
endif
endif
print*,'h0i =',h0i
print*,'coef 2x2 =',coef_2_2*psi_coef(1,1)
print*,'delta E =',delta_e
print*,'sec order conrib =',coef_2_2 * hij/(var_energy_mr(1) - hiiref) * psi_coef(1,1)
accu_second_order += coef_2_2 * hij/(var_energy_mr(1) - hiiref) * psi_coef(1,1)
endif
enddo
print*, 'Total comparison ....'
print*, psi_coef(iref,1),accu_coef,accu_second_order
end

126
plugins/MR_wf_analysis/analyze_sr_wf.irp.f Normal file
View File

@ -0,0 +1,126 @@
program printwf
implicit none
read_wf = .True.
touch read_wf
print*,'ref_bitmask_energy = ',ref_bitmask_energy
call routine
end
subroutine routine
implicit none
integer :: i
integer :: degree
double precision :: hij,hii,coef_1,h00
integer :: exc(0:2,2,2)
double precision :: phase
integer :: h1,p1,h2,p2,s1,s2
double precision :: get_mo_bielec_integral
double precision :: norm_mono_a,norm_mono_b
double precision :: norm_mono_a_2,norm_mono_b_2
double precision :: norm_mono_a_pert_2,norm_mono_b_pert_2
double precision :: norm_mono_a_pert,norm_mono_b_pert
double precision :: delta_e,coef_2_2
norm_mono_a = 0.d0
norm_mono_b = 0.d0
norm_mono_a_2 = 0.d0
norm_mono_b_2 = 0.d0
norm_mono_a_pert = 0.d0
norm_mono_b_pert = 0.d0
norm_mono_a_pert_2 = 0.d0
norm_mono_b_pert_2 = 0.d0
integer :: number_of_holes,nh
integer :: number_of_particles,np
double precision :: accu_e_corr(0:2,0:2)
accu_e_corr = 0.d0
do i = 1, min(10000,N_det)
print*,''
print*,'i = ',i
call debug_det(psi_det(1,1,i),N_int)
nh = number_of_holes(psi_det(1,1,i))
np = number_of_particles(psi_det(1,1,i))
call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,1),degree,N_int)
print*,'degree = ',degree
if(degree == 0)then
print*,'Reference determinant '
call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,h00)
else
call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,hii)
call i_H_j(psi_det(1,1,1),psi_det(1,1,i),N_int,hij)
delta_e = hii - h00
coef_1 = hij/(h00-hii)
if(hij.ne.0.d0)then
if (delta_e > 0.d0) then
coef_2_2 = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij * hij ))/ hij
else
coef_2_2 = 0.5d0 * (delta_e + dsqrt(delta_e * delta_e + 4.d0 * hij * hij )) /hij
endif
endif
call get_excitation(psi_det(1,1,1),psi_det(1,1,i),exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
print*,'phase = ',phase
if(degree == 1)then
print*,'s1',s1
print*,'h1,p1 = ',h1,p1
if(s1 == 1)then
norm_mono_a += dabs(psi_coef(i,1)/psi_coef(1,1))
norm_mono_a_2 += dabs(psi_coef(i,1)/psi_coef(1,1))**2
norm_mono_a_pert += dabs(coef_1)
norm_mono_a_pert_2 += dabs(coef_1)**2
else
norm_mono_b += dabs(psi_coef(i,1)/psi_coef(1,1))
norm_mono_b_2 += dabs(psi_coef(i,1)/psi_coef(1,1))**2
norm_mono_b_pert += dabs(coef_1)
norm_mono_b_pert_2 += dabs(coef_1)**2
endif
! print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,list_act(1),list_act(1),p1,mo_integrals_map)
double precision :: hmono,hdouble
call i_H_j_verbose(psi_det(1,1,1),psi_det(1,1,i),N_int,hij,hmono,hdouble)
print*,'hmono = ',hmono
print*,'hdouble = ',hdouble
print*,'hmono+hdouble = ',hmono+hdouble
print*,'hij = ',hij
else
print*,'s1',s1
print*,'h1,p1 = ',h1,p1
print*,'s2',s2
print*,'h2,p2 = ',h2,p2
! print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map)
endif
print*,'nh,np = ',nh,np
print*,'<Ref| H |D_I> = ',hij
print*,'Delta E = ',h00-hii
print*,'coef pert (1) = ',coef_1
print*,'coef 2x2 = ',coef_2_2
print*,'Delta E_corr = ',psi_coef(i,1)/psi_coef(1,1) * hij
if(nh<3.and.np<3)then
accu_e_corr(nh,np) += psi_coef(i,1)/psi_coef(1,1) * hij
endif
endif
print*,'amplitude = ',psi_coef(i,1)/psi_coef(1,1)
enddo
print*,''
print*,''
do nh = 0, 2
do np = 0,2
print*, 'e_corr = ',nh,np,accu_e_corr(nh,np)
enddo
enddo
print*,''
print*,'L1 norm of mono alpha = ',norm_mono_a
print*,'L1 norm of mono beta = ',norm_mono_b
print*, '---'
print*,'L2 norm of mono alpha = ',norm_mono_a_2
print*,'L2 norm of mono beta = ',norm_mono_b_2
print*, '-- perturbative mono'
print*,''
print*,'L1 norm of pert alpha = ',norm_mono_a_pert
print*,'L1 norm of pert beta = ',norm_mono_b_pert
print*,'L2 norm of pert alpha = ',norm_mono_a_pert_2
print*,'L2 norm of pert beta = ',norm_mono_b_pert_2
end

33
plugins/Perturbation/EZFIO.cfg
View File

@ -11,6 +11,18 @@ doc: The selection process stops when the largest PT2 (for all the state) is low
interface: ezfio,provider,ocaml
default: 0.0001
[PT2_relative_error]
type: Normalized_float
doc: Stop stochastic PT2 when the relative error is smaller than PT2_relative_error
interface: ezfio,provider,ocaml
default: 0.001
[PT2_absolute_error]
type: Threshold
doc: Stop stochastic PT2 when the statistical error is smaller than PT2_absolute_error
interface: ezfio,provider,ocaml
default: 0.00001
[correlation_energy_ratio_max]
type: Normalized_float
doc: The selection process stops at a fixed correlation ratio (useful for getting same accuracy between molecules)
@ -30,3 +42,24 @@ doc: Thresholds on selectors (fraction of the norm) for final PT2 calculation
interface: ezfio,provider,ocaml
default: 1.
[correlation_energy_ratio_max]
type: Normalized_float
doc: The selection process stops at a fixed correlation ratio (useful for getting same accuracy between molecules)
Defined as (E_CI-E_HF)/ (E_CI+PT2 - E_HF). (E_HF) is not required.
interface: ezfio,provider,ocaml
default: 1.00
[threshold_generators_pt2]
type: Threshold
doc: Thresholds on generators (fraction of the norm) for final PT2 calculation
interface: ezfio,provider,ocaml
default: 0.999
[threshold_selectors_pt2]
type: Threshold
doc: Thresholds on selectors (fraction of the norm) for final PT2 calculation
interface: ezfio,provider,ocaml
default: 1.

108
plugins/Perturbation/pt2_equations.irp.f
View File

@ -45,6 +45,58 @@ subroutine pt2_epstein_nesbet ($arguments)
end
subroutine pt2_qdpt ($arguments)
use bitmasks
implicit none
$declarations
BEGIN_DOC
! compute the QDPT first order coefficient and second order energetic contribution
!
! for the various N_st states.
!
! c_pert(i) = <psi(i)|H|det_pert>/( <psi(i)|H|psi(i)> - <det_pert|H|det_pert> )
!
END_DOC
integer :: i,j
double precision :: diag_H_mat_elem_fock, h, E, diag_H_mat_elem, hij
double precision :: i_H_psi_array(N_st)
integer :: degree
double precision :: delta_E
PROVIDE selection_criterion
ASSERT (Nint == N_int)
ASSERT (Nint > 0)
!call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array)
call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array)
h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint)
c_pert = 0.d0
do j=1,N_det_selectors
call get_excitation_degree(det_ref, psi_selectors(1,1,j), degree, Nint)
if (degree > 2) then
E = diag_H_mat_elem(psi_selectors(1,1,j),Nint)
else
E = diag_H_mat_elem_fock(det_ref,det_ref,fock_diag_tmp,Nint)
endif
delta_E = E-h
! delta_E = electronic_energy(1) - h
call i_H_j(psi_selectors(1,1,j),det_pert,Nint,hij)
if (dabs(delta_e) > 1.d-3) then
do i =1,N_st
c_pert(i) += psi_selectors_coef(j,i) * hij / delta_e
enddo
endif
enddo
do i =1,N_st
e_2_pert(i) = c_pert(i)*i_H_psi_array(i)
H_pert_diag(i) = h*c_pert(i)*c_pert(i)
enddo
end
subroutine pt2_decontracted ($arguments)
use bitmasks
@ -249,6 +301,60 @@ subroutine pt2_moller_plesset ($arguments)
end
subroutine pt2_moller_plesset_general ($arguments)
use bitmasks
implicit none
$declarations
BEGIN_DOC
! compute the general Moller-Plesset perturbative first order coefficient and second order energetic contribution
!
! for the various n_st states.
!
! c_pert(i) = <psi(i)|H|det_pert>/(difference of orbital energies)
!
! e_2_pert(i) = <psi(i)|H|det_pert>^2/(difference of orbital energies)
!
END_DOC
integer :: i,j
double precision :: diag_H_mat_elem_fock
integer :: exc(0:2,2,2)
integer :: degree
double precision :: phase,delta_e,h
double precision :: i_H_psi_array(N_st)
integer :: h1,h2,p1,p2,s1,s2
ASSERT (Nint == N_int)
ASSERT (Nint > 0)
call get_excitation(det_ref,det_pert,exc,degree,phase,Nint)
if (degree == 2) then
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
delta_e = (mo_energy_expval(1,h1,s1,1) - mo_energy_expval(1,p1,s1,2)) + &
(mo_energy_expval(1,h2,s2,1) - mo_energy_expval(1,p2,s2,2))
else if (degree == 1) then
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
delta_e = mo_energy_expval(1,h1,s1,1) - mo_energy_expval(1,p1,s1,2)
else
delta_e = 0.d0
endif
if (dabs(delta_e) > 1.d-10) then
delta_e = 1.d0/delta_e
call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array)
h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint)
else
i_H_psi_array(:) = 0.d0
h = 0.d0
endif
do i =1,N_st
H_pert_diag(i) = h
c_pert(i) = i_H_psi_array(i) *delta_e
e_2_pert(i) = c_pert(i) * i_H_psi_array(i)
enddo
end
subroutine pt2_epstein_nesbet_SC2_projected ($arguments)
use bitmasks
@ -314,7 +420,7 @@ subroutine pt2_epstein_nesbet_SC2_projected ($arguments)
degree = popcnt(xor( ref_bitmask(1,1), det_pert(1,1))) + &
popcnt(xor( ref_bitmask(1,2), det_pert(1,2)))
!DEC$ NOUNROLL
!DIR$ NOUNROLL
do l=2,Nint
degree = degree+ popcnt(xor( ref_bitmask(l,1), det_pert(l,1))) + &
popcnt(xor( ref_bitmask(l,2), det_pert(l,2)))

4
plugins/Properties/average.irp.f
View File

@ -1,7 +1,7 @@
subroutine get_average(array,density,average)
implicit none
double precision, intent(in) :: array(mo_tot_num_align,mo_tot_num)
double precision, intent(in) :: density(mo_tot_num_align,mo_tot_num)
double precision, intent(in) :: array(mo_tot_num,mo_tot_num)
double precision, intent(in) :: density(mo_tot_num,mo_tot_num)
double precision, intent(out):: average
integer :: i,j
BEGIN_DOC

50
plugins/Properties/delta_rho.irp.f
View File

@ -1,14 +1,29 @@
BEGIN_PROVIDER [integer, N_z_pts]
BEGIN_PROVIDER [integer, spin_dens_coord]
implicit none
BEGIN_DOC
coordinate on which you are going to plot the spin density
and integrate over the ohters
spin_dens_coord = 1 === X
spin_dens_coord = 2 === Y
spin_dens_coord = 3 === Z
END_DOC
spin_dens_coord = 3
END_PROVIDER
BEGIN_PROVIDER [double precision, delta_z]
&BEGIN_PROVIDER [double precision, z_min]
&BEGIN_PROVIDER [double precision, z_max]
&BEGIN_PROVIDER [double precision, delta_z]
implicit none
z_min = 0.d0
z_max = 10.d0
delta_z = 0.005d0
delta_z = 0.05d0
END_PROVIDER
BEGIN_PROVIDER [integer, N_z_pts]
implicit none
N_z_pts = int( (z_max - z_min)/delta_z )
print*,'N_z_pts = ',N_z_pts
END_PROVIDER
@ -58,7 +73,7 @@ END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_integrated_delta_rho_all_points, (ao_num_align, ao_num, N_z_pts)]
BEGIN_PROVIDER [ double precision, ao_integrated_delta_rho_all_points, (ao_num, ao_num, N_z_pts)]
BEGIN_DOC
! array of the overlap in x,y between the AO function and integrated between [z,z+dz] in the z axis
! for all the z points that are given (N_z_pts)
@ -80,7 +95,7 @@ BEGIN_PROVIDER [ double precision, ao_integrated_delta_rho_all_points, (ao_num_a
!$OMP PRIVATE(i,j,n,l,A_center,power_A,B_center,power_B,accu_z, &
!$OMP overlap_x,overlap_y,overlap_z,overlap,c,alpha,beta) &
!$OMP SHARED(ao_num,nucl_coord,ao_nucl,ao_power,ao_prim_num,ao_expo_ordered_transp,ao_coef_normalized_ordered_transp, &
!$OMP ao_integrated_delta_rho_all_points,N_z_pts,dim1,i_z,z,delta_z)
!$OMP ao_integrated_delta_rho_all_points,N_z_pts,dim1,i_z,z,delta_z,spin_dens_coord)
do j=1,ao_num
A_center(1) = nucl_coord( ao_nucl(j), 1 )
A_center(2) = nucl_coord( ao_nucl(j), 2 )
@ -104,7 +119,13 @@ BEGIN_PROVIDER [ double precision, ao_integrated_delta_rho_all_points, (ao_num_a
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1)
c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i)
accu_z += c* overlap_x * overlap_y * SABpartial(z,z+delta_z,A_center,B_center,power_A,power_B,alpha,beta)
if(spin_dens_coord ==1 )then
accu_z += c* overlap_y * overlap_z * SABpartial(z,z+delta_z,A_center,B_center,power_A,power_B,alpha,beta,spin_dens_coord)
else if (spin_dens_coord ==2 )then
accu_z += c* overlap_x * overlap_z * SABpartial(z,z+delta_z,A_center,B_center,power_A,power_B,alpha,beta,spin_dens_coord)
else if (spin_dens_coord ==3 )then
accu_z += c* overlap_x * overlap_y * SABpartial(z,z+delta_z,A_center,B_center,power_A,power_B,alpha,beta,spin_dens_coord)
endif
enddo
enddo
ao_integrated_delta_rho_all_points(i,j,i_z) = accu_z
@ -127,7 +148,7 @@ BEGIN_PROVIDER [integer, i_unit_integrated_delta_rho]
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_integrated_delta_rho_one_point, (ao_num_align, ao_num )]
BEGIN_PROVIDER [ double precision, ao_integrated_delta_rho_one_point, (ao_num, ao_num )]
BEGIN_DOC
! array of the overlap in x,y between the AO function and integrated between [z,z+dz] in the z axis
! for one specific z point
@ -144,11 +165,12 @@ BEGIN_PROVIDER [ double precision, ao_integrated_delta_rho_one_point, (ao_num_al
double precision :: z,SABpartial,accu_z
dim1=100
z = z_one_point
provide delta_z
!$OMP PARALLEL DO DEFAULT(none) &
!$OMP PRIVATE(i,j,n,l,A_center,power_A,B_center,power_B,accu_z, &
!$OMP overlap_x,overlap_y,overlap_z,overlap,c,alpha,beta) &
!$OMP SHARED(ao_num,nucl_coord,ao_nucl,ao_power,ao_prim_num,ao_expo_ordered_transp,ao_coef_normalized_ordered_transp, &
!$OMP ao_integrated_delta_rho_one_point,dim1,z,delta_z)
!$OMP ao_integrated_delta_rho_one_point,dim1,z,delta_z,spin_dens_coord)
do j=1,ao_num
A_center(1) = nucl_coord( ao_nucl(j), 1 )
A_center(2) = nucl_coord( ao_nucl(j), 2 )
@ -172,7 +194,13 @@ BEGIN_PROVIDER [ double precision, ao_integrated_delta_rho_one_point, (ao_num_al
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1)
c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i)
accu_z += c* overlap_x * overlap_y * SABpartial(z,z+delta_z,A_center,B_center,power_A,power_B,alpha,beta)
if(spin_dens_coord ==1 )then
accu_z += c* overlap_y * overlap_z * SABpartial(z,z+delta_z,A_center,B_center,power_A,power_B,alpha,beta,spin_dens_coord)
else if (spin_dens_coord ==2 )then
accu_z += c* overlap_x * overlap_z * SABpartial(z,z+delta_z,A_center,B_center,power_A,power_B,alpha,beta,spin_dens_coord)
else if (spin_dens_coord ==3 )then
accu_z += c* overlap_x * overlap_y * SABpartial(z,z+delta_z,A_center,B_center,power_A,power_B,alpha,beta,spin_dens_coord)
endif
enddo
enddo
ao_integrated_delta_rho_one_point(i,j) = accu_z
@ -181,7 +209,7 @@ BEGIN_PROVIDER [ double precision, ao_integrated_delta_rho_one_point, (ao_num_al
!$OMP END PARALLEL DO
END_PROVIDER
BEGIN_PROVIDER [double precision, mo_integrated_delta_rho_one_point, (mo_tot_num_align,mo_tot_num)]
BEGIN_PROVIDER [double precision, mo_integrated_delta_rho_one_point, (mo_tot_num,mo_tot_num)]
BEGIN_DOC
!
! array of the integrals needed of integrated_rho(alpha,z) - integrated_rho(beta,z) for z = z_one_point

6
plugins/Properties/mulliken.irp.f
View File

@ -1,5 +1,5 @@
BEGIN_PROVIDER [double precision, spin_population, (ao_num_align,ao_num)]
BEGIN_PROVIDER [double precision, spin_population, (ao_num,ao_num)]
implicit none
integer :: i,j
BEGIN_DOC
@ -57,8 +57,8 @@ BEGIN_PROVIDER [double precision, mulliken_spin_densities, (nucl_num)]
END_PROVIDER
BEGIN_PROVIDER [double precision, electronic_population_alpha, (ao_num_align,ao_num)]
&BEGIN_PROVIDER [double precision, electronic_population_beta, (ao_num_align,ao_num)]
BEGIN_PROVIDER [double precision, electronic_population_alpha, (ao_num,ao_num)]
&BEGIN_PROVIDER [double precision, electronic_population_beta, (ao_num,ao_num)]
implicit none
integer :: i,j
BEGIN_DOC

6
plugins/Properties/print_spin_density.irp.f
View File

@ -14,7 +14,7 @@ subroutine routine
double precision, allocatable :: aos_array(:)
allocate(aos_array(ao_num))
r = 0.d0
r(1) = z_min
r(spin_dens_coord) = z_min
do i = 1, N_z_pts
call give_all_aos_at_r(r,aos_array)
accu = 0.d0
@ -28,8 +28,8 @@ subroutine routine
accu_beta += one_body_dm_ao_beta(k,j) * tmp
enddo
enddo
r(1) += delta_z
write(33,'(100(f16.10,X))')r(1),accu,accu_alpha,accu_beta
r(spin_dens_coord) += delta_z
write(33,'(100(f16.10,X))')r(spin_dens_coord),accu,accu_alpha,accu_beta
enddo

4
plugins/Properties/routines_test.irp.f
View File

@ -2,7 +2,7 @@
subroutine test_average_value(array,value)
implicit none
double precision, intent(in) :: array(mo_tot_num_align,mo_tot_num)
double precision, intent(in) :: array(mo_tot_num,mo_tot_num)
double precision, intent(in) :: value
double precision :: tmp,hij
integer :: i,j
@ -24,7 +24,7 @@ end
subroutine test_average_value_alpha_beta(array,value)
implicit none
double precision, intent(in) :: array(mo_tot_num_align,mo_tot_num)
double precision, intent(in) :: array(mo_tot_num,mo_tot_num)
double precision, intent(in) :: value
double precision :: tmp,hij
integer :: i,j

22
plugins/Properties/slater_rules_mono_electronic.irp.f
View File

@ -10,7 +10,7 @@ subroutine i_O1_j(array,key_i,key_j,Nint,hij)
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
double precision, intent(out) :: hij
double precision, intent(in) :: array(mo_tot_num_align,mo_tot_num)
double precision, intent(in) :: array(mo_tot_num,mo_tot_num)
integer :: exc(0:2,2,2)
integer :: degree
@ -25,7 +25,7 @@ subroutine i_O1_j(array,key_i,key_j,Nint,hij)
ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num)
hij = 0.d0
!DEC$ FORCEINLINE
!DIR$ FORCEINLINE
call get_excitation_degree(key_i,key_j,degree,Nint)
select case (degree)
case (2)
@ -53,7 +53,7 @@ subroutine i_O1_psi(array,key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array)
use bitmasks
implicit none
integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate
double precision, intent(in) :: array(mo_tot_num_align,mo_tot_num)
double precision, intent(in) :: array(mo_tot_num,mo_tot_num)
integer(bit_kind), intent(in) :: keys(Nint,2,Ndet)
integer(bit_kind), intent(in) :: key(Nint,2)
double precision, intent(in) :: coef(Ndet_max,Nstate)
@ -80,7 +80,7 @@ subroutine i_O1_psi(array,key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array)
call filter_connected_mono(keys,key,Nint,Ndet,idx)
do ii=1,idx(0)
i = idx(ii)
!DEC$ FORCEINLINE
!DIR$ FORCEINLINE
call i_O1_j(array,keys(1,1,i),key,Nint,hij)
do j = 1, Nstate
i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij
@ -96,7 +96,7 @@ double precision function diag_O1_mat_elem(array,det_in,Nint)
END_DOC
integer,intent(in) :: Nint
integer(bit_kind),intent(in) :: det_in(Nint,2)
double precision, intent(in) :: array(mo_tot_num_align,mo_tot_num)
double precision, intent(in) :: array(mo_tot_num,mo_tot_num)
integer :: i, ispin,tmp
integer :: occ_det(Nint*bit_kind_size,2)
@ -120,7 +120,7 @@ subroutine i_O1_psi_alpha_beta(array,key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H
use bitmasks
implicit none
integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate
double precision, intent(in) :: array(mo_tot_num_align,mo_tot_num)
double precision, intent(in) :: array(mo_tot_num,mo_tot_num)
integer(bit_kind), intent(in) :: keys(Nint,2,Ndet)
integer(bit_kind), intent(in) :: key(Nint,2)
double precision, intent(in) :: coef(Ndet_max,Nstate)
@ -147,7 +147,7 @@ subroutine i_O1_psi_alpha_beta(array,key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H
call filter_connected_mono(keys,key,Nint,Ndet,idx)
do ii=1,idx(0)
i = idx(ii)
!DEC$ FORCEINLINE
!DIR$ FORCEINLINE
call i_O1_j_alpha_beta(array,keys(1,1,i),key,Nint,hij)
do j = 1, Nstate
i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij
@ -167,7 +167,7 @@ subroutine i_O1_j_alpha_beta(array,key_i,key_j,Nint,hij)
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
double precision, intent(out) :: hij
double precision, intent(in) :: array(mo_tot_num_align,mo_tot_num)
double precision, intent(in) :: array(mo_tot_num,mo_tot_num)
integer :: exc(0:2,2,2)
integer :: degree
@ -182,7 +182,7 @@ subroutine i_O1_j_alpha_beta(array,key_i,key_j,Nint,hij)
ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num)
hij = 0.d0
!DEC$ FORCEINLINE
!DIR$ FORCEINLINE
call get_excitation_degree(key_i,key_j,degree,Nint)
select case (degree)
case (2)
@ -215,7 +215,7 @@ double precision function diag_O1_mat_elem_alpha_beta(array,det_in,Nint)
END_DOC
integer,intent(in) :: Nint
integer(bit_kind),intent(in) :: det_in(Nint,2)
double precision, intent(in) :: array(mo_tot_num_align,mo_tot_num)
double precision, intent(in) :: array(mo_tot_num,mo_tot_num)
integer :: i, ispin,tmp
integer :: occ_det(Nint*bit_kind_size,2)
@ -319,7 +319,7 @@ subroutine filter_connected_mono(key1,key2,Nint,sze,idx)
!DIR$ LOOP COUNT (1000)
do i=1,sze
degree_x2 = 0
!DEC$ LOOP COUNT MIN(4)
!DIR$ LOOP COUNT MIN(4)
do j=1,Nint
degree_x2 = degree_x2+ popcnt(xor( key1(j,1,i), key2(j,1))) +&
popcnt(xor( key1(j,2,i), key2(j,2)))

8
plugins/QMC/densify_coefmatrix.irp.f Normal file
View File

@ -0,0 +1,8 @@
program densify
implicit none
read_wf = .True.
touch read_wf
call generate_all_alpha_beta_det_products()
call diagonalize_ci
call save_wavefunction
end

73
plugins/QMC/dressed_dmc.irp.f
View File

@ -1,73 +0,0 @@
program dressed_dmc
implicit none
double precision :: E0, hij
double precision, allocatable :: H_jj(:), energies(:), delta_jj(:), cj(:), hj(:)
integer :: i
double precision, external :: diag_h_mat_elem
if (.not.read_wf) then
stop 'read_wf should be true'
endif
PROVIDE mo_bielec_integrals_in_map
allocate ( H_jj(N_det), delta_jj(N_det), hj(N_det), cj(N_det), energies(N_states) )
! Read <i|\Phi_0>
! -=-=-=-==-=-=-=
character*(32) :: w, w2
integer :: k
do while (.True.)
read(*,*) w
if ( trim(w) == 'Ci_h_psidet' ) then
exit
endif
enddo
do i=1,N_det
read(*,*) k, w, hj(i)
enddo
do while (.True.)
read(*,*) w
if ( trim(w) == 'Ci_overlap_psidet' ) then
exit
endif
enddo
do i=1,N_det
read(*,*) k, w, cj(i)
enddo
read(*,*)
read(*,*) w, w2, E0
print *, 'E0=', E0
print *, 'Ndet = ', N_det
! Compute delta_ii
! -=-=-=-==-=-=-=-
do i=1,N_det
call i_H_psi(psi_det(1,1,i),psi_det,cj,N_int,N_det,size(psi_coef,1),N_states,energies)
if (dabs(cj(i)) < 1.d-6) then
delta_jj(i) = 0.d0
else
delta_jj(i) = (hj(i) - energies(1))/cj(i)
endif
H_jj(i) = diag_h_mat_elem(psi_det(1,1,i),N_int) + delta_jj(i)
print *, 'Delta_jj(',i,') = ', Delta_jj(i), H_jj(i)
enddo
call davidson_diag_hjj(psi_det,psi_coef,H_jj,energies,size(psi_coef,1),N_det,N_states,N_states_diag,N_int,6)
call save_wavefunction
call write_spindeterminants
E0 = 0.d0
do i=1,N_det
call i_H_psi(psi_det(1,1,i),psi_det,psi_coef(1,1),N_int,N_det,size(psi_coef,1),N_states,energies)
E0 += psi_coef(i,1) * energies(1)
enddo
print *, 'Trial energy: ', E0 + nuclear_repulsion
deallocate (H_jj, delta_jj, energies, cj)
end

30
plugins/QMC/truncate_wf_spin.irp.f
View File

@ -39,7 +39,8 @@ subroutine run
call dsort(norm_sort(1),iorder(1),nab)
PROVIDE psi_bilinear_matrix_values nuclear_repulsion
PROVIDE psi_bilinear_matrix_values psi_bilinear_matrix_rows psi_bilinear_matrix_columns
PROVIDE nuclear_repulsion
print *, ''
do j=0,nab
i = iorder(j)
@ -47,7 +48,9 @@ subroutine run
!$OMP PARALLEL DO PRIVATE(k)
do k=1,n_det
if (psi_bilinear_matrix_columns(k) == -i) then
psi_bilinear_matrix_values(k,1) = 0.d0
do l=1,N_states
psi_bilinear_matrix_values(k,l) = 0.d0
enddo
endif
enddo
!$OMP END PARALLEL DO
@ -55,7 +58,9 @@ subroutine run
!$OMP PARALLEL DO PRIVATE(k)
do k=1,n_det
if (psi_bilinear_matrix_rows(k) == i) then
psi_bilinear_matrix_values(k,1) = 0.d0
do l=1,N_states
psi_bilinear_matrix_values(k,l) = 0.d0
enddo
endif
enddo
!$OMP END PARALLEL DO
@ -64,9 +69,11 @@ subroutine run
cycle
endif
u_0 = psi_bilinear_matrix_values(1:N_det,1:N_states)
v_t = 0.d0
s_t = 0.d0
u_0(1:N_det,1:N_states) = psi_bilinear_matrix_values(1:N_det,1:N_states)
v_0(1:N_det,1:N_states) = 0.d0
u_t(1:N_states,1:N_det) = 0.d0
v_t(1:N_states,1:N_det) = 0.d0
s_t(1:N_states,1:N_det) = 0.d0
call dtranspose( &
u_0, &
size(u_0, 1), &
@ -85,20 +92,21 @@ subroutine run
double precision, external :: u_dot_u, u_dot_v
do i=1,N_states
e_0(i) = u_dot_v(v_t(1,i),u_0(1,i),N_det)/u_dot_u(u_0(1,i),N_det)
e_0(i) = u_dot_v(u_0(1,i),v_0(1,i),N_det)/u_dot_u(u_0(1,i),N_det)
print *, 'E = ', e_0(i) + nuclear_repulsion
enddo
m = 0
do k=1,n_det
if (psi_bilinear_matrix_values(k,1) /= 0.d0) then
if (sum(psi_bilinear_matrix_values(k,1:N_states)) /= 0.d0) then
m = m+1
endif
enddo
E = E_0(1) + nuclear_repulsion
norm = u_dot_u(u_0(1,1),N_det)
do k=1,N_states
E = E_0(k) + nuclear_repulsion
enddo
print *, 'Number of determinants:', m
print *, 'Energy', E
exit
enddo
call wf_of_psi_bilinear_matrix(.True.)

2
plugins/Selectors_CASSD/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Selectors_Utils

31
plugins/Selectors_CASSD/selectors.irp.f
View File

@ -1,10 +1,5 @@
use bitmasks
BEGIN_PROVIDER [ integer, psi_selectors_size ]
implicit none
psi_selectors_size = psi_det_size
END_PROVIDER
BEGIN_PROVIDER [ integer, N_det_selectors]
implicit none
BEGIN_DOC
@ -66,30 +61,4 @@ END_PROVIDER
endif
END_PROVIDER
BEGIN_PROVIDER [ double precision, psi_selectors_coef_transp, (N_states,psi_selectors_size) ]
implicit none
BEGIN_DOC
! Transposed psi_selectors
END_DOC
integer :: i,k
do i=1,N_det_selectors
do k=1,N_states
psi_selectors_coef_transp(k,i) = psi_selectors_coef(i,k)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, psi_selectors_diag_h_mat, (psi_selectors_size) ]
implicit none
BEGIN_DOC
! Diagonal elements of the H matrix for each selectors
END_DOC
integer :: i
double precision :: diag_H_mat_elem
do i = 1, N_det_selectors
psi_selectors_diag_h_mat(i) = diag_H_mat_elem(psi_selectors(1,1,i),N_int)
enddo
END_PROVIDER

121
plugins/Selectors_CASSD/zmq.irp.f
View File

@ -1,121 +0,0 @@
subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id, energy, size_energy)
use f77_zmq
implicit none
BEGIN_DOC
! Put the wave function on the qp_run scheduler
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id
integer, intent(in) :: size_energy
double precision, intent(out) :: energy(size_energy)
integer :: rc
integer*8 :: rc8
character*(256) :: msg
write(msg,*) 'put_psi ', worker_id, N_states, N_det, psi_det_size, n_det_generators, n_det_selectors
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE)
if (rc /= len(trim(msg))) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE)'
stop 'error'
endif
rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,ZMQ_SNDMORE)
if (rc8 /= N_int*2_8*N_det*bit_kind) then
print *, 'f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,ZMQ_SNDMORE)'
stop 'error'
endif
rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,ZMQ_SNDMORE)
if (rc8 /= psi_det_size*N_states*8_8) then
print *, 'f77_zmq_send8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send(zmq_to_qp_run_socket,energy,size_energy*8,0)
if (rc /= size_energy*8) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket,energy,size_energy*8,0)'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0)
if (msg(1:rc) /= 'put_psi_reply 1') then
print *, rc, trim(msg)
print *, 'Error in put_psi_reply'
stop 'error'
endif
end
subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy)
use f77_zmq
implicit none
BEGIN_DOC
! Get the wave function from the qp_run scheduler
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id
integer, intent(in) :: size_energy
double precision, intent(out) :: energy(size_energy)
integer :: rc
integer*8 :: rc8
character*(64) :: msg
write(msg,*) 'get_psi ', worker_id
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)
if (rc /= len(trim(msg))) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0)
if (msg(1:13) /= 'get_psi_reply') then
print *, rc, trim(msg)
print *, 'Error in get_psi_reply'
stop 'error'
endif
integer :: N_states_read, N_det_read, psi_det_size_read
integer :: N_det_selectors_read, N_det_generators_read
read(msg(14:rc),*) N_states_read, N_det_read, psi_det_size_read, &
N_det_generators_read, N_det_selectors_read
N_states = N_states_read
N_det = N_det_read
psi_det_size = psi_det_size_read
TOUCH psi_det_size N_det N_states
rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,0)
if (rc8 /= N_int*2_8*N_det*bit_kind) then
print *, 'f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)'
stop 'error'
endif
rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,0)
if (rc8 /= psi_det_size*N_states*8_8) then
print *, '77_zmq_recv8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,ZMQ_SNDMORE)'
stop 'error'
endif
TOUCH psi_det psi_coef
rc = f77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)
if (rc /= size_energy*8) then
print *, '77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)'
stop 'error'
endif
if (N_det_generators_read > 0) then
N_det_generators = N_det_generators_read
TOUCH N_det_generators
endif
if (N_det_selectors_read > 0) then
N_det_selectors = N_det_selectors_read
TOUCH N_det_selectors
endif
end

1
plugins/Selectors_Utils/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
Determinants

190
plugins/Selectors_Utils/README.rst Normal file
View File

@ -0,0 +1,190 @@
=====================
Selectors_full Module
=====================
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.
`coef_hf_selector <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full/e_corr_selectors.irp.f#L28>`_
energy of correlation per determinant respect to the Hartree Fock determinant
.br
for the all the double excitations in the selectors determinants
.br
E_corr_per_selectors(i) = <D_i|H|HF> * c(D_i)/c(HF) if |D_i> is a double excitation
.br
E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation
.br
coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants
`delta_e_per_selector <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full/e_corr_selectors.irp.f#L33>`_
energy of correlation per determinant respect to the Hartree Fock determinant
.br
for the all the double excitations in the selectors determinants
.br
E_corr_per_selectors(i) = <D_i|H|HF> * c(D_i)/c(HF) if |D_i> is a double excitation
.br
E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation
.br
coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants
`double_index_selectors <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full/e_corr_selectors.irp.f#L4>`_
degree of excitation respect to Hartree Fock for the wave function
.br
for the all the selectors determinants
.br
double_index_selectors = list of the index of the double excitations
.br
n_double_selectors = number of double excitations in the selectors determinants
`e_corr_double_only <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full/e_corr_selectors.irp.f#L34>`_
energy of correlation per determinant respect to the Hartree Fock determinant
.br
for the all the double excitations in the selectors determinants
.br
E_corr_per_selectors(i) = <D_i|H|HF> * c(D_i)/c(HF) if |D_i> is a double excitation
.br
E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation
.br
coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants
`e_corr_per_selectors <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full/e_corr_selectors.irp.f#L31>`_
energy of correlation per determinant respect to the Hartree Fock determinant
.br
for the all the double excitations in the selectors determinants
.br
E_corr_per_selectors(i) = <D_i|H|HF> * c(D_i)/c(HF) if |D_i> is a double excitation
.br
E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation
.br
coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants
`e_corr_second_order <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full/e_corr_selectors.irp.f#L35>`_
energy of correlation per determinant respect to the Hartree Fock determinant
.br
for the all the double excitations in the selectors determinants
.br
E_corr_per_selectors(i) = <D_i|H|HF> * c(D_i)/c(HF) if |D_i> is a double excitation
.br
E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation
.br
coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants
`exc_degree_per_selectors <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full/e_corr_selectors.irp.f#L3>`_
degree of excitation respect to Hartree Fock for the wave function
.br
for the all the selectors determinants
.br
double_index_selectors = list of the index of the double excitations
.br
n_double_selectors = number of double excitations in the selectors determinants
`i_h_hf_per_selectors <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full/e_corr_selectors.irp.f#L32>`_
energy of correlation per determinant respect to the Hartree Fock determinant
.br
for the all the double excitations in the selectors determinants
.br
E_corr_per_selectors(i) = <D_i|H|HF> * c(D_i)/c(HF) if |D_i> is a double excitation
.br
E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation
.br
coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants
`inv_selectors_coef_hf <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full/e_corr_selectors.irp.f#L29>`_
energy of correlation per determinant respect to the Hartree Fock determinant
.br
for the all the double excitations in the selectors determinants
.br
E_corr_per_selectors(i) = <D_i|H|HF> * c(D_i)/c(HF) if |D_i> is a double excitation
.br
E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation
.br
coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants
`inv_selectors_coef_hf_squared <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full/e_corr_selectors.irp.f#L30>`_
energy of correlation per determinant respect to the Hartree Fock determinant
.br
for the all the double excitations in the selectors determinants
.br
E_corr_per_selectors(i) = <D_i|H|HF> * c(D_i)/c(HF) if |D_i> is a double excitation
.br
E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation
.br
coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants
`n_det_selectors <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full/selectors.irp.f#L8>`_
For Single reference wave functions, the number of selectors is 1 : the
Hartree-Fock determinant
`n_double_selectors <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full/e_corr_selectors.irp.f#L5>`_
degree of excitation respect to Hartree Fock for the wave function
.br
for the all the selectors determinants
.br
double_index_selectors = list of the index of the double excitations
.br
n_double_selectors = number of double excitations in the selectors determinants
`psi_selectors <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full/selectors.irp.f#L32>`_
Determinants on which we apply <i|H|psi> for perturbation.
`psi_selectors_coef <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full/selectors.irp.f#L33>`_
Determinants on which we apply <i|H|psi> for perturbation.
`psi_selectors_coef_transp <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full/selectors.irp.f#L53>`_
Transposed psi_selectors
`psi_selectors_diag_h_mat <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full/selectors.irp.f#L67>`_
Diagonal elements of the H matrix for each selectors
`psi_selectors_size <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full/selectors.irp.f#L3>`_
Undocumented
`zmq_get_psi <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full/zmq.irp.f#L51>`_
Get the wave function from the qp_run scheduler
`zmq_put_psi <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full/zmq.irp.f#L1>`_
Put the wave function on the qp_run scheduler

1
plugins/CAS_SD_ZMQ/e_corr_selectors.irp.f → plugins/Selectors_Utils/e_corr_selectors.irp.f
View File

@ -1,4 +1,3 @@
use bitmasks
BEGIN_PROVIDER [integer, exc_degree_per_selectors, (N_det_selectors)]
&BEGIN_PROVIDER [integer, double_index_selectors, (N_det_selectors)]

34
plugins/Selectors_Utils/selectors.irp.f Normal file
View File

@ -0,0 +1,34 @@
use bitmasks
BEGIN_PROVIDER [ integer, psi_selectors_size ]
implicit none
psi_selectors_size = psi_det_size
END_PROVIDER
BEGIN_PROVIDER [ double precision, psi_selectors_coef_transp, (N_states,psi_selectors_size) ]
implicit none
BEGIN_DOC
! Transposed psi_selectors
END_DOC
integer :: i,k
do i=1,N_det_selectors
do k=1,N_states
psi_selectors_coef_transp(k,i) = psi_selectors_coef(i,k)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, psi_selectors_diag_h_mat, (psi_selectors_size) ]
implicit none
BEGIN_DOC
! Diagonal elements of the H matrix for each selectors
END_DOC
integer :: i
double precision :: diag_H_mat_elem
do i = 1, N_det_selectors
psi_selectors_diag_h_mat(i) = diag_H_mat_elem(psi_selectors(1,1,i),N_int)
enddo
END_PROVIDER

98
plugins/Selectors_Utils/zmq.irp.f Normal file
View File

@ -0,0 +1,98 @@
BEGIN_TEMPLATE
integer function zmq_put_$X(zmq_to_qp_run_socket,worker_id)
use f77_zmq
implicit none
BEGIN_DOC
! Put $X on the qp_run scheduler
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id
integer :: rc
character*(256) :: msg
zmq_put_$X = 0
write(msg,'(A,1X,I8,1X,A200)') 'put_data '//trim(zmq_state), worker_id, '$X'
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE)
if (rc /= len(trim(msg))) then
zmq_put_$X = -1
return
endif
rc = f77_zmq_send(zmq_to_qp_run_socket,$X,4,0)
if (rc /= 4) then
zmq_put_$X = -1
return
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0)
if (msg(1:rc) /= 'put_data_reply ok') then
zmq_put_$X = -1
return
endif
end
integer function zmq_get_$X(zmq_to_qp_run_socket, worker_id)
use f77_zmq
implicit none
BEGIN_DOC
! Get $X from the qp_run scheduler
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id
integer :: rc
character*(256) :: msg
zmq_get_$X = 0
if (mpi_master) then
write(msg,'(A,1X,I8,1X,A200)') 'get_data '//trim(zmq_state), worker_id, '$X'
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)
if (rc /= len(trim(msg))) then
zmq_get_$X = -1
go to 10
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0)
if (msg(1:14) /= 'get_data_reply') then
zmq_get_$X = -1
go to 10
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,$X,4,0)
if (rc /= 4) then
zmq_get_$X = -1
go to 10
endif
endif
10 continue
IRP_IF MPI
include 'mpif.h'
integer :: ierr
call MPI_BCAST (zmq_get_$X, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
print *, irp_here//': Unable to broadcast N_det_generators'
stop -1
endif
call MPI_BCAST ($X, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
print *, irp_here//': Unable to broadcast N_det_generators'
stop -1
endif
IRP_ENDIF
end
SUBST [ X ]
N_det_generators ;;
N_det_selectors ;;
END_TEMPLATE

2
plugins/Selectors_full/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Determinants Hartree_Fock
Determinants Hartree_Fock Selectors_Utils

79
plugins/Selectors_full/e_corr_selectors.irp.f
View File

@ -1,79 +0,0 @@
use bitmasks
BEGIN_PROVIDER [integer, exc_degree_per_selectors, (N_det_selectors)]
&BEGIN_PROVIDER [integer, double_index_selectors, (N_det_selectors)]
&BEGIN_PROVIDER [integer, n_double_selectors]
implicit none
BEGIN_DOC
! degree of excitation respect to Hartree Fock for the wave function
!
! for the all the selectors determinants
!
! double_index_selectors = list of the index of the double excitations
!
! n_double_selectors = number of double excitations in the selectors determinants
END_DOC
integer :: i,degree
n_double_selectors = 0
do i = 1, N_det_selectors
call get_excitation_degree(psi_selectors(1,1,i),ref_bitmask,degree,N_int)
exc_degree_per_selectors(i) = degree
if(degree==2)then
n_double_selectors += 1
double_index_selectors(n_double_selectors) =i
endif
enddo
END_PROVIDER
BEGIN_PROVIDER[double precision, coef_hf_selector]
&BEGIN_PROVIDER[double precision, inv_selectors_coef_hf]
&BEGIN_PROVIDER[double precision, inv_selectors_coef_hf_squared]
&BEGIN_PROVIDER[double precision, E_corr_per_selectors, (N_det_selectors)]
&BEGIN_PROVIDER[double precision, i_H_HF_per_selectors, (N_det_selectors)]
&BEGIN_PROVIDER[double precision, Delta_E_per_selector, (N_det_selectors)]
&BEGIN_PROVIDER[double precision, E_corr_double_only ]
&BEGIN_PROVIDER[double precision, E_corr_second_order ]
implicit none
BEGIN_DOC
! energy of correlation per determinant respect to the Hartree Fock determinant
!
! for the all the double excitations in the selectors determinants
!
! E_corr_per_selectors(i) = <D_i|H|HF> * c(D_i)/c(HF) if |D_i> is a double excitation
!
! E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation
!
! coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants
END_DOC
PROVIDE ref_bitmask_energy psi_selectors ref_bitmask N_int psi_selectors
integer :: i,degree
double precision :: hij,diag_H_mat_elem
E_corr_double_only = 0.d0
E_corr_second_order = 0.d0
do i = 1, N_det_selectors
if(exc_degree_per_selectors(i)==2)then
call i_H_j(ref_bitmask,psi_selectors(1,1,i),N_int,hij)
i_H_HF_per_selectors(i) = hij
E_corr_per_selectors(i) = psi_selectors_coef(i,1) * hij
E_corr_double_only += E_corr_per_selectors(i)
! E_corr_second_order += hij * hij /(ref_bitmask_energy - diag_H_mat_elem(psi_selectors(1,1,i),N_int))
elseif(exc_degree_per_selectors(i) == 0)then
coef_hf_selector = psi_selectors_coef(i,1)
E_corr_per_selectors(i) = -1000.d0
Delta_E_per_selector(i) = 0.d0
else
E_corr_per_selectors(i) = -1000.d0
endif
enddo
if (dabs(coef_hf_selector) > 1.d-8) then
inv_selectors_coef_hf = 1.d0/coef_hf_selector
inv_selectors_coef_hf_squared = inv_selectors_coef_hf * inv_selectors_coef_hf
else
inv_selectors_coef_hf = 0.d0
inv_selectors_coef_hf_squared = 0.d0
endif
do i = 1,n_double_selectors
E_corr_per_selectors(double_index_selectors(i)) *=inv_selectors_coef_hf
enddo
E_corr_double_only = E_corr_double_only * inv_selectors_coef_hf
END_PROVIDER

31
plugins/Selectors_full/selectors.irp.f
View File

@ -1,10 +1,5 @@
use bitmasks
BEGIN_PROVIDER [ integer, psi_selectors_size ]
implicit none
psi_selectors_size = psi_det_size
END_PROVIDER
BEGIN_PROVIDER [ integer, N_det_selectors]
implicit none
BEGIN_DOC
@ -50,30 +45,4 @@ END_PROVIDER
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, psi_selectors_coef_transp, (N_states,psi_selectors_size) ]
implicit none
BEGIN_DOC
! Transposed psi_selectors
END_DOC
integer :: i,k
do i=1,N_det_selectors
do k=1,N_states
psi_selectors_coef_transp(k,i) = psi_selectors_coef(i,k)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, psi_selectors_diag_h_mat, (psi_selectors_size) ]
implicit none
BEGIN_DOC
! Diagonal elements of the H matrix for each selectors
END_DOC
integer :: i
double precision :: diag_H_mat_elem
do i = 1, N_det_selectors
psi_selectors_diag_h_mat(i) = diag_H_mat_elem(psi_selectors(1,1,i),N_int)
enddo
END_PROVIDER

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

@ -1,121 +0,0 @@
subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id, energy, size_energy)
use f77_zmq
implicit none
BEGIN_DOC
! Put the wave function on the qp_run scheduler
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id
integer, intent(in) :: size_energy
double precision, intent(out) :: energy(size_energy)
integer :: rc
integer*8 :: rc8
character*(256) :: msg
write(msg,*) 'put_psi ', worker_id, N_states, N_det, psi_det_size, n_det_generators, n_det_selectors
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE)
if (rc /= len(trim(msg))) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE)'
stop 'error'
endif
rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,ZMQ_SNDMORE)
if (rc8 /= N_int*2_8*N_det*bit_kind) then
print *, 'f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,ZMQ_SNDMORE)'
stop 'error'
endif
rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,ZMQ_SNDMORE)
if (rc8 /= psi_det_size*N_states*8_8) then
print *, 'f77_zmq_send8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send(zmq_to_qp_run_socket,energy,size_energy*8,0)
if (rc /= size_energy*8) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket,energy,size_energy*8,0)'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0)
if (msg(1:rc) /= 'put_psi_reply 1') then
print *, rc, trim(msg)
print *, 'Error in put_psi_reply'
stop 'error'
endif
end
subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy)
use f77_zmq
implicit none
BEGIN_DOC
! Get the wave function from the qp_run scheduler
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id
integer, intent(in) :: size_energy
double precision, intent(out) :: energy(size_energy)
integer :: rc
integer*8 :: rc8
character*(64) :: msg
write(msg,*) 'get_psi ', worker_id
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)
if (rc /= len(trim(msg))) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0)
if (msg(1:13) /= 'get_psi_reply') then
print *, rc, trim(msg)
print *, 'Error in get_psi_reply'
stop 'error'
endif
integer :: N_states_read, N_det_read, psi_det_size_read
integer :: N_det_selectors_read, N_det_generators_read
read(msg(14:rc),*) N_states_read, N_det_read, psi_det_size_read, &
N_det_generators_read, N_det_selectors_read
N_states = N_states_read
N_det = N_det_read
psi_det_size = psi_det_size_read
TOUCH psi_det_size N_det N_states
rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_det,int(N_int*2_8*N_det*bit_kind,8),0)
if (rc8 /= N_int*2_8*N_det*bit_kind) then
print *, 'f77_zmq_recv8(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)'
stop 'error'
endif
rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_coef,int(psi_det_size*N_states*8_8,8),0)
if (rc8 /= psi_det_size*N_states*8_8) then
print *, '77_zmq_recv8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)'
stop 'error'
endif
TOUCH psi_det psi_coef
rc = f77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)
if (rc /= size_energy*8) then
print *, '77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)'
stop 'error'
endif
if (N_det_generators_read > 0) then
N_det_generators = N_det_generators_read
TOUCH N_det_generators
endif
if (N_det_selectors_read > 0) then
N_det_selectors = N_det_selectors_read
TOUCH N_det_selectors
endif
end

2
plugins/Selectors_no_sorted/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Determinants
Determinants Selectors_Utils

79
plugins/Selectors_no_sorted/e_corr_selectors.irp.f
View File

@ -1,79 +0,0 @@
use bitmasks
BEGIN_PROVIDER [integer, exc_degree_per_selectors, (N_det_selectors)]
&BEGIN_PROVIDER [integer, double_index_selectors, (N_det_selectors)]
&BEGIN_PROVIDER [integer, n_double_selectors]
implicit none
BEGIN_DOC
! degree of excitation respect to Hartree Fock for the wave function
!
! for the all the selectors determinants
!
! double_index_selectors = list of the index of the double excitations
!
! n_double_selectors = number of double excitations in the selectors determinants
END_DOC
integer :: i,degree
n_double_selectors = 0
do i = 1, N_det_selectors
call get_excitation_degree(psi_selectors(1,1,i),ref_bitmask,degree,N_int)
exc_degree_per_selectors(i) = degree
if(degree==2)then
n_double_selectors += 1
double_index_selectors(n_double_selectors) =i
endif
enddo
END_PROVIDER
BEGIN_PROVIDER[double precision, coef_hf_selector]
&BEGIN_PROVIDER[double precision, inv_selectors_coef_hf]
&BEGIN_PROVIDER[double precision, inv_selectors_coef_hf_squared]
&BEGIN_PROVIDER[double precision, E_corr_per_selectors, (N_det_selectors)]
&BEGIN_PROVIDER[double precision, i_H_HF_per_selectors, (N_det_selectors)]
&BEGIN_PROVIDER[double precision, Delta_E_per_selector, (N_det_selectors)]
&BEGIN_PROVIDER[double precision, E_corr_double_only ]
&BEGIN_PROVIDER[double precision, E_corr_second_order ]
implicit none
BEGIN_DOC
! energy of correlation per determinant respect to the Hartree Fock determinant
!
! for the all the double excitations in the selectors determinants
!
! E_corr_per_selectors(i) = <D_i|H|HF> * c(D_i)/c(HF) if |D_i> is a double excitation
!
! E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation
!
! coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants
END_DOC
PROVIDE ref_bitmask_energy psi_selectors ref_bitmask N_int psi_selectors
integer :: i,degree
double precision :: hij,diag_H_mat_elem
E_corr_double_only = 0.d0
E_corr_second_order = 0.d0
do i = 1, N_det_selectors
if(exc_degree_per_selectors(i)==2)then
call i_H_j(ref_bitmask,psi_selectors(1,1,i),N_int,hij)
i_H_HF_per_selectors(i) = hij
E_corr_per_selectors(i) = psi_selectors_coef(i,1) * hij
E_corr_double_only += E_corr_per_selectors(i)
E_corr_second_order += hij * hij /(ref_bitmask_energy - diag_H_mat_elem(psi_selectors(1,1,i),N_int))
elseif(exc_degree_per_selectors(i) == 0)then
coef_hf_selector = psi_selectors_coef(i,1)
E_corr_per_selectors(i) = -1000.d0
Delta_E_per_selector(i) = 0.d0
else
E_corr_per_selectors(i) = -1000.d0
endif
enddo
if (dabs(coef_hf_selector) > 1.d-8) then
inv_selectors_coef_hf = 1.d0/coef_hf_selector
inv_selectors_coef_hf_squared = inv_selectors_coef_hf * inv_selectors_coef_hf
else
inv_selectors_coef_hf = 0.d0
inv_selectors_coef_hf_squared = 0.d0
endif
do i = 1,n_double_selectors
E_corr_per_selectors(double_index_selectors(i)) *=inv_selectors_coef_hf
enddo
E_corr_double_only = E_corr_double_only * inv_selectors_coef_hf
END_PROVIDER

20
plugins/Selectors_no_sorted/selectors.irp.f
View File

@ -1,12 +1,5 @@
use bitmasks
BEGIN_PROVIDER [ integer, psi_selectors_size ]
implicit none
psi_selectors_size = psi_det_size
END_PROVIDER
BEGIN_PROVIDER [ integer, N_det_selectors]
implicit none
BEGIN_DOC
@ -45,16 +38,3 @@ END_PROVIDER
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, psi_selectors_diag_h_mat, (psi_selectors_size) ]
implicit none
BEGIN_DOC
! Diagonal elements of the H matrix for each selectors
END_DOC
integer :: i
double precision :: diag_H_mat_elem
do i = 1, N_det_selectors
psi_selectors_diag_h_mat(i) = diag_H_mat_elem(psi_selectors(1,1,i),N_int)
enddo
END_PROVIDER

14
plugins/analyze_wf/analyze_wf.irp.f
View File

@ -3,6 +3,7 @@ program analyze_wf
BEGIN_DOC
! Wave function analyzis
END_DOC
PROVIDE mo_tot_num psi_det psi_coef
read_wf = .True.
SOFT_TOUCH read_wf
call run()
@ -14,15 +15,26 @@ subroutine run
integer :: class(0:mo_tot_num,5)
double precision :: occupation(mo_tot_num)
write(*,'(A)') 'Energy of 1st determinant'
write(*,'(A)') '========================='
write(*,'(A)') ''
write(*,*) 'Total', ref_bitmask_energy + nuclear_repulsion
write(*,*) 'Mono-electronic', mono_elec_ref_bitmask_energy
write(*,*) 'Kinetic', kinetic_ref_bitmask_energy
write(*,*) 'Electron-nucleus', nucl_elec_ref_bitmask_energy
write(*,*) 'Two-electron', bi_elec_ref_bitmask_energy
write(*,'(A)') ''
write(*,'(A)') ''
write(*,'(A)') 'MO Occupation'
write(*,'(A)') '============='
write(*,'(A)') ''
do istate=1,N_states
call get_occupation_from_dets(occupation,istate)
write(*,'(A)') ''
write(*,'(A,I3)'), 'State ', istate
write(*,'(A)') '---------------'
write(*,'(A)') ''
call get_occupation_from_dets(istate,occupation)
write (*,'(A)') '======== ================'
class = 0
do i=1,mo_tot_num

5
plugins/analyze_wf/occupation.irp.f
View File

@ -1,4 +1,4 @@
subroutine get_occupation_from_dets(occupation, istate)
subroutine get_occupation_from_dets(istate,occupation)
implicit none
double precision, intent(out) :: occupation(mo_tot_num)
integer, intent(in) :: istate
@ -9,6 +9,8 @@ subroutine get_occupation_from_dets(occupation, istate)
integer :: list(N_int*bit_kind_size,2)
integer :: n_elements(2)
double precision :: c
ASSERT (istate > 0)
ASSERT (istate <= N_states)
occupation = 0.d0
do i=1,N_det
@ -16,6 +18,7 @@ subroutine get_occupation_from_dets(occupation, istate)
call bitstring_to_list_ab(psi_det(1,1,i), list, n_elements, N_int)
do ispin=1,2
do j=1,n_elements(ispin)
ASSERT ( list(j,ispin) < mo_tot_num )
occupation( list(j,ispin) ) += c
enddo
enddo

2
plugins/loc_cele/loc.f
View File

@ -18,7 +18,7 @@ C
zprt=.true.
niter=1000000
conv=1.d-8
conv=1.d-10
C niter=1000000
C conv=1.d-6

42
plugins/loc_cele/loc_cele.irp.f
View File

@ -101,10 +101,12 @@ program loc_rasorb
cmoref = 0.d0
irot = 0
irot(1,1) = 11
irot(2,1) = 12
cmoref(15,1,1) = 1.d0 !
cmoref(14,2,1) = 1.d0 !
irot(1,1) = 48
irot(2,1) = 49
cmoref(21,1,1) = -0.7d0 !
cmoref(27,1,1) = -0.4d0 !
cmoref(22,2,1) = 0.7d0 !
cmoref(28,2,1) = 0.4d0 !
! ESATRIENE with 3 bonding and anti bonding orbitals
! First bonding orbital for esa
@ -147,22 +149,22 @@ program loc_rasorb
! cmoref(64,6,1) = 1.d0 !
! cmoref(83,6,1) =-1.d0 !
! ESATRIENE with 1 central bonding and anti bonding orbitals
! AND 4 radical orbitals
! First radical orbital
cmoref(7,1,1) = 1.d0 !
! Second radical orbital
cmoref(26,2,1) = 1.d0 !
! First bonding orbital
cmoref(45,3,1) = 1.d0 !
cmoref(64,3,1) = 1.d0 !
! Third radical orbital for esa
cmoref(83,4,1) = 1.d0 !
! Fourth radical orbital for esa
cmoref(102,5,1) = 1.d0 !
! First anti bonding orbital
cmoref(45,6,1) = 1.d0 !
cmoref(64,6,1) =-1.d0 !
!! ESATRIENE with 1 central bonding and anti bonding orbitals
!! AND 4 radical orbitals
!! First radical orbital
!cmoref(7,1,1) = 1.d0 !
!! Second radical orbital
!cmoref(26,2,1) = 1.d0 !
!! First bonding orbital
!cmoref(45,3,1) = 1.d0 !
!cmoref(64,3,1) = 1.d0 !
!! Third radical orbital for esa
!cmoref(83,4,1) = 1.d0 !
!! Fourth radical orbital for esa
!cmoref(102,5,1) = 1.d0 !
!! First anti bonding orbital
!cmoref(45,6,1) = 1.d0 !
!cmoref(64,6,1) =-1.d0 !
do i = 1, nrot(1)

65
plugins/mrcepa0/dressing_slave.irp.f
View File

@ -56,12 +56,18 @@ subroutine mrsc2_dressing_slave(thread,iproc)
logical, external :: is_in_wavefunction
integer,allocatable :: komon(:)
logical :: komoned
integer, external :: connect_to_taskserver, disconnect_from_taskserver
!double precision, external :: get_dij
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
zmq_socket_push = new_zmq_push_socket(thread)
integer, external :: add_task_to_taskserver
call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
return
endif
zmq_socket_push = new_zmq_push_socket(thread)
allocate (delta(N_states,0:N_det_non_ref, 2))
allocate (delta_s2(N_states,0:N_det_non_ref, 2))
@ -74,7 +80,10 @@ subroutine mrsc2_dressing_slave(thread,iproc)
do
call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task)
integer, external :: get_task_from_taskserver
if (get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) == -1) then
exit
endif
if (task_id == 0) exit
read (task,*) i_I, J, k1, k2
do i_state=1, N_states
@ -191,12 +200,17 @@ subroutine mrsc2_dressing_slave(thread,iproc)
end do ! kk
call push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id)
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id)
integer, external :: task_done_to_taskserver
if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) == -1) then
stop 'Unable to send task_done to server'
endif
enddo
deallocate(delta)
call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
if (disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) == -1) then
continue
endif
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread)
@ -389,17 +403,18 @@ end
subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2_)
subroutine mrsc2_dressing_collector(zmq_socket_pull,delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2_)
use f77_zmq
implicit none
BEGIN_DOC
! Collects results from the AO integral calculation
END_DOC
double precision,intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref)
double precision,intent(inout) :: delta_ii_(N_states,N_det_ref)
double precision,intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref)
double precision,intent(inout) :: delta_ii_s2_(N_states,N_det_ref)
double precision,intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref)
double precision,intent(inout) :: delta_ii_(N_states,N_det_ref)
double precision,intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref)
double precision,intent(inout) :: delta_ii_s2_(N_states,N_det_ref)
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
! integer :: j,l
integer :: rc
@ -410,7 +425,6 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2
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
@ -424,7 +438,6 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2
delta_ij_s2_(:,:,:) = 0d0
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
zmq_socket_pull = new_zmq_pull_socket()
allocate ( delta(N_states,0:N_det_non_ref,2), delta_s2(N_states,0:N_det_non_ref,2) )
@ -466,7 +479,10 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2
if (task_id /= 0) then
call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more)
integer, external :: zmq_delete_task
if (zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) == -1) then
stop 'Unable to delete task'
endif
endif
@ -474,7 +490,6 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2
deallocate( delta, delta_s2 )
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_pull_socket(zmq_socket_pull)
end
@ -498,12 +513,12 @@ end
integer, external :: get_index_in_psi_det_sorted_bit, searchDet, detCmp
logical, external :: is_in_wavefunction, isInCassd, detEq
character*(512) :: task
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
integer :: KKsize = 1000000
call new_parallel_job(zmq_to_qp_run_socket,'mrsc2')
call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'mrsc2')
call wall_time(iwall)
@ -573,14 +588,18 @@ end
do kk = 1 , nlink(i_I), KKsize
write(task,*) I_i, J, kk, int(min(kk+KKsize-1, nlink(i_I)))
call add_task_to_taskserver(zmq_to_qp_run_socket,task)
if (add_task_to_taskserver(zmq_to_qp_run_socket,task) == -1) then
stop 'Unable to add task to task server'
endif
end do
! do kk = 1 , nlink(i_I)
! k = linked(kk,i_I)
! blok = blokMwen(kk,i_I)
! write(task,*) I_i, J, k, blok
! call add_task_to_taskserver(zmq_to_qp_run_socket,task)
! if (add_task_to_taskserver(zmq_to_qp_run_socket,task) == -1) then
! stop 'Unable to add task to task server'
! endif
!
! enddo !kk
enddo !J
@ -593,17 +612,19 @@ end
! rc = pthread_create(collector_thread, mrsc2_dressing_collector)
print *, nzer, ntot, float(nzer) / float(ntot)
provide nproc
!$OMP PARALLEL DEFAULT(none) SHARED(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old) PRIVATE(i) NUM_THREADS(nproc+1)
!$OMP PARALLEL DEFAULT(none) &
!$OMP SHARED(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old,zmq_socket_pull)&
!$OMP PRIVATE(i) NUM_THREADS(nproc+1)
i = omp_get_thread_num()
if (i==0) then
call mrsc2_dressing_collector(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old)
call mrsc2_dressing_collector(zmq_socket_pull,delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old)
else
call mrsc2_dressing_slave_inproc(i)
endif
!$OMP END PARALLEL
! rc = pthread_join(collector_thread)
call end_parallel_job(zmq_to_qp_run_socket, 'mrsc2')
call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'mrsc2')
END_PROVIDER

103
plugins/mrcepa0/mrcc_stoch_routines.irp.f
View File

@ -11,7 +11,8 @@ subroutine ZMQ_mrcc(E, mrcc, delta, delta_s2, relative_error)
implicit none
character(len=64000) :: task
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_to_qp_run_socket2
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
integer, external :: omp_get_thread_num
double precision, intent(in) :: relative_error, E
double precision, intent(out) :: mrcc(N_states)
@ -23,10 +24,16 @@ subroutine ZMQ_mrcc(E, mrcc, delta, delta_s2, relative_error)
double precision, external :: omp_get_wtime
double precision :: time
double precision :: w(N_states)
provide nproc fragment_first fragment_count mo_bielec_integrals_in_map mo_mono_elec_integral mrcc_weight psi_selectors
w(:) = 0.d0
w(mrcc_stoch_istate) = 1.d0
call update_psi_average_norm_contrib(w)
@ -34,15 +41,30 @@ subroutine ZMQ_mrcc(E, mrcc, delta, delta_s2, relative_error)
print *, ' Samples Energy Stat. Error Seconds '
print *, '========== ================= ================= ================='
call new_parallel_job(zmq_to_qp_run_socket,'mrcc')
call zmq_put_psi(zmq_to_qp_run_socket,1,mrcc_e0_denominator,size(mrcc_e0_denominator))
! call get_carlo_workbatch(Ncp, tbc, cp, cp_at, cp_N)
do i=1,comb_teeth
print *, "TOOTH", first_det_of_teeth(i+1) - first_det_of_teeth(i)
end do
!stop
call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull, 'mrcc')
integer, external :: zmq_put_psi
integer, external :: zmq_put_N_det_generators
integer, external :: zmq_put_N_det_selectors
integer, external :: zmq_put_dvector
if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then
stop 'Unable to put psi on ZMQ server'
endif
if (zmq_put_N_det_generators(zmq_to_qp_run_socket, 1) == -1) then
stop 'Unable to put N_det_generators on ZMQ server'
endif
if (zmq_put_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) then
stop 'Unable to put N_det_selectors on ZMQ server'
endif
if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',mrcc_e0_denominator,size(mrcc_e0_denominator)) == -1) then
stop 'Unable to put energy on ZMQ server'
endif
! do i=1,comb_teeth
! print *, "TOOTH", first_det_of_teeth(i+1) - first_det_of_teeth(i)
! end do
integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
integer :: ipos
@ -52,7 +74,10 @@ subroutine ZMQ_mrcc(E, mrcc, delta, delta_s2, relative_error)
write(task(ipos:ipos+20),'(I9,1X,I9,''|'')') 0, mrcc_jobs(i)
ipos += 20
if (ipos > 63980) then
call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos)))
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
stop 'Unable to add task to task server'
endif
ipos=1
endif
else
@ -60,28 +85,35 @@ subroutine ZMQ_mrcc(E, mrcc, delta, delta_s2, relative_error)
write(task(ipos:ipos+20),'(I9,1X,I9,''|'')') j, mrcc_jobs(i)
ipos += 20
if (ipos > 63980) then
call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos)))
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
stop 'Unable to add task to task server'
endif
ipos=1
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)))
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
stop 'Unable to add task to task server'
endif
endif
call zmq_set_running(zmq_to_qp_run_socket)
!$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc+1) &
if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
print *, irp_here, ': Failed in zmq_set_running'
endif
!$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc+1) &
!$OMP PRIVATE(i)
i = omp_get_thread_num()
if (i==0) then
call mrcc_collector(E, relative_error, delta, delta_s2, mrcc)
call mrcc_collector(zmq_socket_pull,E(mrcc_stoch_istate), relative_error, delta, delta_s2, mrcc)
else
call mrcc_slave_inproc(i)
endif
!$OMP END PARALLEL
call end_parallel_job(zmq_to_qp_run_socket, 'mrcc')
call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'mrcc')
print *, '========== ================= ================= ================='
end subroutine
@ -95,13 +127,18 @@ subroutine mrcc_slave_inproc(i)
end
subroutine mrcc_collector(E, relative_error, delta, delta_s2, mrcc)
subroutine mrcc_collector(zmq_socket_pull, E, relative_error, delta, delta_s2, mrcc)
use dress_types
use f77_zmq
use bitmasks
implicit none
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
double precision, intent(in) :: relative_error, E
double precision, intent(out) :: mrcc(N_states)
double precision, allocatable :: cp(:,:,:,:)
@ -207,10 +244,13 @@ subroutine mrcc_collector(E, relative_error, delta, delta_s2, mrcc)
end if
end do
do i=1, ntask
call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more)
end do
integer, external :: zmq_delete_tasks
if (zmq_delete_tasks(zmq_to_qp_run_socket,zmq_socket_pull,task_id,ntask,more) == -1) then
stop 'Unable to delete tasks'
endif
time = omp_get_wtime()
@ -231,6 +271,8 @@ subroutine mrcc_collector(E, relative_error, delta, delta_s2, mrcc)
!!!!!!!!!!!!
double precision :: su, su2, eqt, avg, E0, val
integer, external :: zmq_abort
su = 0d0
su2 = 0d0
@ -253,12 +295,20 @@ subroutine mrcc_collector(E, relative_error, delta, delta_s2, mrcc)
if ((dabs(eqt) < relative_error .and. cps_N(cur_cp) >= 30) .or. total_computed == N_det_generators) then
! Termination
!print '(G10.3, 2X, F16.7, 2X, G16.3, 2X, F16.4, A20)', Nabove(tooth), avg+E, eqt, time-time0, ''
print *, "GREPME", cur_cp, E+E0+avg, eqt, time-time0, total_computed
call zmq_abort(zmq_to_qp_run_socket)
! print *, "GREPME", cur_cp, E+E0+avg, eqt, time-time0, total_computed
if (zmq_abort(zmq_to_qp_run_socket) == -1) then
call sleep(1)
if (zmq_abort(zmq_to_qp_run_socket) == -1) then
print *, irp_here, ': Error in sending abort signal (2)'
endif
endif
else
if (cur_cp > old_cur_cp) then
old_cur_cp = cur_cp
print *, "GREPME", cur_cp, E+E0+avg, eqt, time-time0, total_computed
! print *, "GREPME", cur_cp, E+E0+avg, eqt, time-time0, total_computed
!print '(G10.3, 2X, F16.7, 2X, G16.3, 2X, F16.4, A20)', Nabove(tooth), avg+E, eqt, time-time0, ''
endif
endif
@ -289,6 +339,7 @@ subroutine mrcc_collector(E, relative_error, delta, delta_s2, mrcc)
mrcc(1) = E
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_pull_socket(zmq_socket_pull)
end subroutine

27
plugins/mrcepa0/mrcc_zmq.irp.f Normal file
View File

@ -0,0 +1,27 @@
program mrsc2sub
implicit none
double precision, allocatable :: energy(:)
allocate (energy(N_states))
!mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc
mrmode = 5
read_wf = .True.
SOFT_TOUCH read_wf
call set_generators_bitmasks_as_holes_and_particles
if (.True.) then
integer :: i,j
do j=1,N_states
do i=1,N_det
psi_coef(i,j) = CI_eigenvectors(i,j)
enddo
enddo
SOFT_TOUCH psi_coef
endif
call run(N_states,energy)
if(do_pt2)then
call run_pt2(N_states,energy)
endif
deallocate(energy)
end

1
plugins/mrcepa0/mrcepa0_general.irp.f
View File

@ -47,6 +47,7 @@ subroutine run(N_st,energy)
enddo
call diagonalize_ci_dressed(lambda)
E_new = mrcc_e0_denominator(1) !sum(ci_energy_dressed(1:N_states))
! if (.true.) then
! provide delta_ij_mrcc_pouet
! endif

2
plugins/mrcepa0/run_mrcc_slave.irp.f
View File

@ -9,7 +9,6 @@ END_PROVIDER
subroutine run_mrcc_slave(thread,iproc,energy)
use dress_types
use f77_zmq
implicit none
@ -184,7 +183,6 @@ end subroutine
subroutine pull_mrcc_results(zmq_socket_pull, N, ind, mrcc_detail, delta_loc, task_id, ntask)
use dress_types
use f77_zmq
implicit none
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull

48
plugins/read_integral/print_integrals_ao.irp.f
View File

@ -70,23 +70,37 @@ subroutine run
call get_cache_map_n_elements_max(ao_integrals_map,n_elements_max)
allocate(keys(n_elements_max), values(n_elements_max))
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))
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)
integral = values(k1)
write (iunit,'(4(I5,X),D22.15)') k,i,l,j, integral
! 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))
! 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)
! integral = values(k1)
! write (iunit,'(4(I6,X),F20.15)') k,i,l,j, integral
! enddo
! enddo
do i=1,ao_num
do k=1,ao_num
do j=1,ao_num
do l=1,ao_num
double precision, external :: get_ao_bielec_integral
integral = get_ao_bielec_integral(i,j,k,l,ao_integrals_map)
if (dabs(integral)>=1.e-15) then
write (iunit,'(4(I6),F20.15)') i,j,k,l, integral
endif
enddo
enddo
enddo
enddo

2
plugins/read_integral/print_integrals_mo.irp.f
View File

@ -49,7 +49,7 @@ program print_integrals
double precision :: get_mo_bielec_integral
integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map)
if (dabs(integral) > mo_integrals_threshold) then
write (iunit,'(4(I5,X),D22.15)') i,j,k,l, integral
write (iunit,'(4(I6,X),F20.15)') i,j,k,l, integral
endif
!end if
enddo

1
plugins/read_integral/read_integrals_ao.irp.f
View File

@ -68,6 +68,7 @@ subroutine run
call insert_into_ao_integrals_map(n_integrals,buffer_i,buffer_values)
call map_sort(ao_integrals_map)
call map_unique(ao_integrals_map)
call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map)
call ezfio_set_integrals_bielec_disk_access_ao_integrals('Read')

9
plugins/read_integral/read_integrals_mo.irp.f
View File

@ -1,5 +1,10 @@
program read_integrals
BEGIN_DOC
! Reads the integrals from the following files:
! - kinetic_mo
! - nuclear_mo
! - bielec_mo
END_DOC
PROVIDE ezfio_filename
call ezfio_set_integrals_monoelec_disk_access_mo_one_integrals("None")
call run
@ -23,7 +28,7 @@ subroutine run
call ezfio_get_mo_basis_mo_tot_num(mo_tot_num)
allocate (A(mo_tot_num_align,mo_tot_num))
allocate (A(mo_tot_num,mo_tot_num))
A = 0.d0
iunit = getunitandopen('kinetic_mo','r')

10
scripts/compilation/qp_create_ninja.py
View File

@ -25,6 +25,7 @@ except ImportError:
"quantum_package.rc"))
print "\n".join(["", "Error:", "source %s" % f, ""])
raise
sys.exit(1)
@ -96,8 +97,7 @@ def ninja_create_env_variable(pwd_config_file):
l_string.append(str_)
lib_lapack = get_compilation_option(pwd_config_file, "LAPACK_LIB")
lib_gpi2 = get_compilation_option(pwd_config_file, "GPI2_LIB")
str_lib = " ".join([LIB, lib_lapack, lib_gpi2, EZFIO_LIB, ZMQ_LIB])
str_lib = " ".join([LIB, lib_lapack, EZFIO_LIB, ZMQ_LIB])
l_string.append("LIB = {0} ".format(str_lib))
l_string.append("")
@ -266,7 +266,7 @@ def ninja_ezfio_rule():
install_lib_ezfio = join(QP_ROOT, 'install', 'EZFIO', "lib", "libezfio_irp.a")
l_cmd = ["cd {0}".format(QP_EZFIO)] + l_flag
l_cmd += ["rm -f make.config ; ninja && ln -sf {0} {1}".format(install_lib_ezfio, EZFIO_LIB)]
l_cmd += ["rm -f make.config ; ninja && rm -f {1} ; ln -sf {0} {1}".format(install_lib_ezfio, EZFIO_LIB)]
l_string = ["rule build_ezfio",
" command = {0}".format(" ; ".join(l_cmd)),
@ -307,7 +307,7 @@ def ninja_symlink_rule():
"""
Return the command to create for the symlink
"""
return ["rule build_symlink", " command = ln -sf $in $out", ""]
return ["rule build_symlink", " command = rm -f $out ; ln -sf $in $out", ""]
def ninja_symlink_build(path_module, l_symlink):
@ -825,6 +825,7 @@ if __name__ == "__main__":
arguments = pickle.load(handle)
except IOError:
print "You need to create first my friend"
raise
sys.exit(1)
elif arguments["create"]:
@ -927,6 +928,7 @@ if __name__ == "__main__":
"- Or install a module that needs {0} with a main "]
print "\n".join(l_msg).format(module.rel)
raise
sys.exit(1)
# ~#~#~#~#~#~#~#~#~#~#~#~ #

1
scripts/compilation/read_compilation_cfg.py
View File

@ -41,4 +41,3 @@ if __name__ == '__main__':
print get_compilation_option(pwd_cfg, "FC")
print get_compilation_option(pwd_cfg, "FCFLAGS")
print get_compilation_option(pwd_cfg, "GPI2_LIB")

50
scripts/ezfio_interface/ezfio_generate_provider.py
View File

@ -22,14 +22,24 @@ BEGIN_PROVIDER [ %(type)s, %(name)s %(size)s ]
logical :: has
PROVIDE ezfio_filename
%(test_null_size)s
call ezfio_has_%(ezfio_dir)s_%(ezfio_name)s(has)
if (has) then
call ezfio_get_%(ezfio_dir)s_%(ezfio_name)s(%(name)s)
else
print *, '%(ezfio_dir)s/%(ezfio_name)s not found in EZFIO file'
stop 1
if (mpi_master) then
%(test_null_size)s
call ezfio_has_%(ezfio_dir)s_%(ezfio_name)s(has)
if (has) then
call ezfio_get_%(ezfio_dir)s_%(ezfio_name)s(%(name)s)
else
print *, '%(ezfio_dir)s/%(ezfio_name)s not found in EZFIO file'
stop 1
endif
endif
IRP_IF MPI
include 'mpif.h'
integer :: ierr
call MPI_BCAST( %(name)s, %(size_mpi)s, %(type_mpi)s, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read %(name)s with MPI'
endif
IRP_ENDIF
%(write)s
END_PROVIDER
""".strip()
@ -38,6 +48,12 @@ END_PROVIDER
"logical": "write_bool",
"double precision": "write_double"}
mpi_correspondance = {"integer": "MPI_INTEGER",
"integer*8": "MPI_INTEGER8",
"character*(32)": "MPI_CHARACTER",
"logical": "MPI_LOGICAL",
"double precision": "MPI_DOUBLE_PRECISION"}
def __init__(self):
self.values = "type doc name ezfio_dir ezfio_name write output".split()
for v in self.values:
@ -65,14 +81,22 @@ END_PROVIDER
self.test_null_size = ""
def set_write(self):
self.write = ""
output = self.output
name = self.name
l_write = ["",
" call write_time(%(output)s)",
" if (mpi_master) then",
" write(%(output)s, *) 'Read %(name)s'",
" endif",
""]
self.write = "\n".join(l_write) % locals()
self.type_mpi = self.mpi_correspondance[self.type]
if "size" in self.__dict__:
return
else:
if self.type in self.write_correspondance:
write = self.write_correspondance[self.type]
output = self.output
name = self.name
l_write = ["",
" call write_time(%(output)s)",
@ -80,8 +104,6 @@ END_PROVIDER
" '%(name)s')",
""]
self.write = "\n".join(l_write) % locals()
def set_type(self, t):
self.type = t.lower()
@ -101,7 +123,9 @@ END_PROVIDER
self.output = t
def set_size(self, t):
self.size_mpi = t.replace(',',')*(').replace('0:','1+')
if (self.type == "character*(32)"):
self.size_mpi += "*32"
if t != "1":
self.size = ", " + t
else:

1
scripts/generate_h_apply.py
View File

@ -33,7 +33,6 @@ filter_only_1h2p_double
filter_only_2h2p_single
filter_only_2h2p_double
filterhole
filter_integrals
filter_only_1h1p_double
filter_only_1h1p_single
filterparticle

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