LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-11-04 21:24:02 +01: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

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

5
config/ifort_mpi.cfg
View File

@ -6,7 +6,7 @@
# --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
@ -52,12 +52,11 @@ FCFLAGS : -xSSE4.2 -O2 -ip -ftz
[DEBUG]
FC : -g -traceback
FCFLAGS : -xSSE2 -C -fpe0
IRPF90_FLAGS : --openmp
# 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)

407
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
end = struct
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
(** PutData: put some data in the hash table *)
module PutData_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 ;
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
state : State.t ;
key : string; }
let create ~client_id ~state ~key =
{ client_id = Id.Client.of_int client_id ;
n_state ; n_det ; psi_det_size ; n_det_generators ;
n_det_selectors ; psi }
state = State.of_string state;
key ; }
let to_string x =
match x.n_det_generators, x.n_det_selectors with
| Some g, Some s ->
Printf.sprintf "put_psi %d %d %d %d %d %d"
(Id.Client.to_int x.client_id)
(Strictly_positive_int.to_int x.n_state)
(Strictly_positive_int.to_int x.n_det)
(Strictly_positive_int.to_int x.psi_det_size)
(Strictly_positive_int.to_int g)
(Strictly_positive_int.to_int s)
| _, _ ->
Printf.sprintf "put_psi %d %d %d %d %d %d"
(Id.Client.to_int x.client_id)
(Strictly_positive_int.to_int x.n_state)
(Strictly_positive_int.to_int x.n_det)
(Strictly_positive_int.to_int x.psi_det_size)
(-1) (-1)
let to_string_list x =
match x.psi with
| Some psi ->
[ to_string x ; psi.Psi.psi_det ; psi.Psi.psi_coef ; psi.Psi.energy ]
| None ->
[ to_string x ; "None" ; "None" ; "None" ]
Printf.sprintf "put_data %s %d %s" (State.to_string x.state)
(Id.Client.to_int x.client_id) x.key
end
(** PutPsiReply_msg : Reply to the PutPsi message *)
module PutPsiReply_msg : sig
(** PutDataReply_msg : Reply to the PutData message *)
module PutDataReply_msg : sig
type t
val create : client_id:Id.Client.t -> t
val create : unit -> t
val to_string : t -> string
end = struct
type t = unit
let create () = ()
let to_string () = "put_data_reply ok"
end
(** GetData: put some data in the hash table *)
module GetData_msg : sig
type t =
{ client_id : Id.Client.t ;
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 ;
}
let create ~client_id =
{ client_id; }
let to_string x =
Printf.sprintf "put_psi_reply %d"
(Id.Client.to_int x.client_id)
end
(** GetVector : get the current vector (Davidson) *)
module GetVector_msg : sig
type t =
{ client_id: Id.Client.t ;
}
val create : client_id:int -> t
val to_string : t -> string
end = struct
type t =
{ client_id: Id.Client.t ;
}
let create ~client_id =
{ client_id = Id.Client.of_int client_id }
let to_string x =
Printf.sprintf "get_vector %d"
(Id.Client.to_int x.client_id)
end
module Vector : sig
type t =
{
size : Strictly_positive_int.t;
data : string;
}
val create : size:Strictly_positive_int.t -> data:string -> t
end = struct
type t =
{
size : Strictly_positive_int.t;
data : string;
}
let create ~size ~data =
{ size ; data }
end
(** GetVectorReply_msg : Reply to the GetVector message *)
module GetVectorReply_msg : sig
type t =
{ client_id : Id.Client.t ;
vector : Vector.t }
val create : client_id:Id.Client.t -> vector:Vector.t -> t
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
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 "get_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
(** GetDataReply_msg : Reply to the GetData message *)
module GetDataReply_msg : sig
type t
val create : client_id:Id.Client.t -> t
val create : value:string -> t
val to_string : t -> string
val to_string_list : t -> string list
end = struct
type t =
{ client_id : Id.Client.t ;
}
let create ~client_id =
{ client_id; }
type t = string
let create ~value = value
let to_string x =
Printf.sprintf "put_vector_reply %d"
(Id.Client.to_int x.client_id)
Printf.sprintf "get_data_reply %d %s"
(String.length x) x
let to_string_list x = [
Printf.sprintf "get_data_reply %d"
(String.length x); x ]
end
@ -644,14 +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,7 +543,9 @@ 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
@ -743,18 +555,13 @@ let to_string = function
| Abort x -> Abort_msg.to_string x
| Ok x -> Ok_msg.to_string x
| Error x -> Error_msg.to_string x
| PutPsi x -> PutPsi_msg.to_string x
| GetPsiReply x -> GetPsiReply_msg.to_string x
| PutVector x -> PutVector_msg.to_string x
| GetVectorReply x -> GetVectorReply_msg.to_string x
| SetStopped -> "set_stopped"
| SetRunning -> "set_running"
| SetWaiting -> "set_waiting"
let to_string_list = function
| PutPsi x -> PutPsi_msg.to_string_list x
| PutVector x -> PutVector_msg.to_string_list x
| GetVectorReply x -> GetVectorReply_msg.to_string_list x
| GetDataReply x -> GetDataReply_msg.to_string_list x
| 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 }
@ -162,6 +160,12 @@ and kw = parse
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
let client_id = read_int 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 ->
| PUT_DATA ->
let state = read_word lexbuf in
let client_id = read_int lexbuf in
let n_state = read_int lexbuf in
let n_det = read_int lexbuf in
let psi_det_size = read_int lexbuf in
let n_det_generators, n_det_selectors =
try
(Some (read_int lexbuf), Some (read_int lexbuf))
with (Failure _) -> (None, None)
in
PutPsi_ { client_id ; n_state ; n_det ; psi_det_size ; n_det_generators ; n_det_selectors }
| GET_VECTOR ->
let client_id = read_int lexbuf in
GetVector_ client_id
| PUT_VECTOR ->
let client_id = read_int lexbuf in
let size = read_int lexbuf in
PutVector_ { client_id ; size }
let key = read_word lexbuf in
PutData_ { 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)

307
ocaml/TaskServer.ml
View File

@ -25,10 +25,10 @@ type t =
state : Message.State.t option ;
address_tcp : Address.Tcp.t option ;
address_inproc : Address.Inproc.t option ;
psi : Message.GetPsiReply_msg.t option;
vector : Message.Vector.t option;
progress_bar : Progress_bar.t option ;
running : bool;
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
{
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,12 +245,17 @@ 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
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 ->
@ -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
in
let new_program_state =
{ program_state with
psi = Some (Message.GetPsiReply_msg.create ~psi:psi_local)
}
and client_id =
msg.Message.PutPsi_msg.client_id
in
Message.PutPsiReply (Message.PutPsiReply_msg.create ~client_id)
|> Message.to_string
|> ZMQ.Socket.send rep_socket;
let put_data msg rest_of_msg program_state rep_socket =
new_program_state
let get_psi msg program_state rep_socket =
begin
match program_state.psi with
| None -> failwith "No wave function saved in TaskServer"
| Some psi_message -> ZMQ.Socket.send_all rep_socket psi_message
end;
program_state
let put_vector msg rest_of_msg program_state rep_socket =
let vector_local =
match msg.Message.PutVector_msg.vector with
| Some x -> x
| None ->
begin
let data =
debug (Message.PutData_msg.to_string msg);
let state, key, value =
msg.Message.PutData_msg.state,
msg.Message.PutData_msg.key,
match rest_of_msg with
| [ x ] -> x
| _ -> failwith "Badly formed put_vector message"
| _ -> failwith "Badly formed put_data message"
in
Message.Vector.create
~size:msg.Message.PutVector_msg.size
~data
end
in
let new_program_state =
{ program_state with
vector = Some vector_local
}
and client_id =
msg.Message.PutVector_msg.client_id
in
Message.PutVectorReply (Message.PutVectorReply_msg.create ~client_id)
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
new_program_state
let get_vector msg program_state rep_socket =
let client_id =
msg.Message.GetVector_msg.client_id
and failure () =
reply_wrong_state rep_socket;
program_state
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)
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

11
ocaml/TaskServer.mli
View File

@ -4,10 +4,10 @@ type t =
state : Message.State.t option ;
address_tcp : Address.Tcp.t option ;
address_inproc : Address.Inproc.t option ;
psi : Message.GetPsiReply_msg.t option;
vector : Message.Vector.t option ;
progress_bar : Progress_bar.t option ;
running : bool;
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

12
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,10 +94,14 @@ 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 =
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
@ -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 () =

36
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
print_float (abs_float o) ;
print_newline ()
Printf.printf "%f %!" (abs_float o)
);
Printf.printf "\n%!"
)

5
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,6 +70,7 @@ let run slave exe ezfio_file =
(** Check input *)
if (not slave) then
begin
match (Sys.command ("qp_edit -c "^ezfio_file)) with
| 0 -> ()
@ -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

69
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)
@ -81,3 +127,4 @@ subroutine dump_fci_iterations_value(n_determinants,energy,pt2)
!!! 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')

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

@ -26,6 +26,9 @@ subroutine run_wf
character*(64) :: states(1)
integer :: rc, i
integer, external :: zmq_get_dvector
integer, external :: zmq_get_psi
call provide_everything
zmq_context = f77_zmq_ctx_new ()
@ -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

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

@ -3,36 +3,45 @@ 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))
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
@ -47,29 +56,47 @@ subroutine ZMQ_pt2(E, pt2,relative_error)
computed(i) = .true.
end do
Ncomb=size(comb)
call get_carlo_workbatch(computed, comb, Ncomb, tbc)
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 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)
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
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
else
@ -77,34 +104,51 @@ subroutine ZMQ_pt2(E, pt2,relative_error)
write(task(ipos:ipos+20),'(I9,1X,I9,''|'')') j, tbc(i)
ipos += 20
if (ipos > 63980) then
call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos)))
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
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) 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)
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)
call end_parallel_job(zmq_to_qp_run_socket, 'pt2')
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
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"
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
call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more)
end do
time = omp_get_wtime()
if(time - timeLast > 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

201
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
buf%N = 0
ctask = 1
Nindex=1
pt2 = 0d0
pt2_detail = 0d0
do
call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task)
done = task_id(ctask) == 0
if (done) then
ctask = ctask - 1
else
integer :: i_generator, i_i_generator, 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
endif
if(done .or. (ctask == size(task_id)) ) then
if(buf%N == 0 .and. ctask > 0) stop "uninitialized selection_buffer"
do i=1, ctask
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i))
end do
if(ctask > 0) then
call push_pt2_results(zmq_socket_push, Nindex, index, pt2_detail, task_id(1), ctask)
pt2 = 0d0
pt2_detail(:,:Nindex) = 0d0
buf%cur = 0
end if
ctask = 0
end if
zmq_socket_push = new_zmq_push_socket(thread)
if(done) exit
ctask = ctask + 1
buf%N = 0
n_tasks = 0
call create_selection_buffer(1, 2, buf)
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
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
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

61
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
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
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))

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

@ -13,20 +13,29 @@ 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
@ -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,25 +75,39 @@ 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.
@ -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

@ -28,6 +28,9 @@ subroutine run_wf
character*(64) :: states(4)
integer :: rc, i, ierr
integer, external :: zmq_get_dvector
integer, external :: zmq_get_psi
call provide_everything
zmq_context = f77_zmq_ctx_new ()
@ -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)

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

@ -195,7 +195,7 @@ END_PROVIDER
if (diag_algorithm == "Davidson") then
allocate (eigenvectors(size(CI_eigenvectors_dressed,1),size(CI_eigenvectors_dressed,2)), &
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
@ -208,7 +208,7 @@ END_PROVIDER
eigenvectors(i,j) = psi_coef(i,j)
enddo
enddo
call davidson_diag_mrcc_HS2(psi_det,eigenvectors,&
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)

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)

57
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,7 +403,7 @@ 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
@ -400,6 +414,7 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2
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

93
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,26 +24,47 @@ 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)
print *, '========== ================= ================= ================='
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)
call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull, 'mrcc')
do i=1,comb_teeth
print *, "TOOTH", first_det_of_teeth(i+1) - first_det_of_teeth(i)
end do
!stop
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)
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,9 +244,12 @@ 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

46
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
! 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
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
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")

36
scripts/ezfio_interface/ezfio_generate_provider.py
View File

@ -22,6 +22,7 @@ BEGIN_PROVIDER [ %(type)s, %(name)s %(size)s ]
logical :: has
PROVIDE ezfio_filename
if (mpi_master) then
%(test_null_size)s
call ezfio_has_%(ezfio_dir)s_%(ezfio_name)s(has)
if (has) then
@ -30,6 +31,15 @@ BEGIN_PROVIDER [ %(type)s, %(name)s %(size)s ]
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

24
src/AO_Basis/README.rst
View File

@ -96,19 +96,19 @@ Documentation
Transposed ao_expo_ordered
`ao_l <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L182>`_
`ao_l <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L146>`_
ao_l = l value of the AO: a+b+c in x^a y^b z^c
`ao_l_char <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L184>`_
`ao_l_char <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L148>`_
ao_l = l value of the AO: a+b+c in x^a y^b z^c
`ao_l_char_space <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L291>`_
`ao_l_char_space <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L282>`_
Undocumented
`ao_l_max <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L183>`_
`ao_l_max <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L147>`_
ao_l = l value of the AO: a+b+c in x^a y^b z^c
@ -157,7 +157,7 @@ Documentation
Powers of x, y and z for each AO
`ao_power_index <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L169>`_
`ao_power_index <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L171>`_
Unique index given to a triplet of powers:
.br
1/2 (l-n_x)*(l-n_x+1) + n_z + 1
@ -171,7 +171,7 @@ Documentation
Undocumented
`ao_prim_num_max_align <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L159>`_
`ao_prim_num_max_align <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L161>`_
Number of primitives per atomic orbital aligned
@ -223,11 +223,11 @@ Documentation
gives the values of aos at a given point r
`l_to_charater <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L197>`_
`l_to_charater <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L185>`_
character corresponding to the "L" value of an AO orbital
`n_aos_max <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L211>`_
`n_aos_max <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L202>`_
Number of AOs per atom
@ -239,21 +239,21 @@ Documentation
Undocumented
`nucl_aos <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L224>`_
`nucl_aos <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L215>`_
List of AOs attached on each atom
`nucl_list_shell_aos <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L242>`_
`nucl_list_shell_aos <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L233>`_
Index of the shell type Aos and of the corresponding Aos
Per convention, for P,D,F and G AOs, we take the index
of the AO with the the corresponding power in the "X" axis
`nucl_n_aos <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L210>`_
`nucl_n_aos <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L201>`_
Number of AOs per atom
`nucl_num_shell_aos <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L243>`_
`nucl_num_shell_aos <http://github.com/LCPQ/quantum_package/tree/master/src/AO_Basis/aos.irp.f#L234>`_
Index of the shell type Aos and of the corresponding Aos
Per convention, for P,D,F and G AOs, we take the index
of the AO with the the corresponding power in the "X" axis

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