9
1
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-12-14 15:43:30 +01:00

Add print_ci_vector in tools (#11)

* Fixed energies of non-expected s2

* Moved diag_algorithm in Davdison

* Fixed travis

* Added print_ci_vector

* Documentation

* Cleaned qp_set_mo_class.ml

* Removed Core in taskserver
This commit is contained in:
Anthony Scemama 2019-03-04 17:40:50 +01:00 committed by Thomas Applencourt
parent ca4f8ebdca
commit 347e918a4a
11 changed files with 213 additions and 130 deletions

View File

@ -1,8 +1,5 @@
open Core
open Qptypes
module StringHashtbl = Hashtbl.Make(String)
type pub_state =
| Waiting
| Running of string
@ -29,15 +26,15 @@ type t =
progress_bar : Progress_bar.t option ;
running : bool;
accepting_clients : bool;
data : string StringHashtbl.t;
data : (string, string) Hashtbl.t;
}
let debug_env =
match Sys.getenv "QP_TASK_DEBUG" with
| Some x -> x <> ""
| None -> false
try
Sys.getenv "QP_TASK_DEBUG"; true
with Not_found -> false
let debug str =
@ -64,7 +61,7 @@ let bind_socket ~socket_type ~socket ~port =
Zmq.Socket.bind socket @@ Printf.sprintf "tcp://*:%d" port;
loop (-1)
with
| Unix.Unix_error _ -> (Time.pause @@ Time.Span.of_sec 1. ; loop (i-1) )
| Unix.Unix_error _ -> (Unix.sleep 1 ; loop (i-1) )
| other_exception -> raise other_exception
in loop 60
@ -77,28 +74,34 @@ let hostname = lazy (
)
external get_ipv4_address_for_interface : string -> string =
"get_ipv4_address_for_interface" ;;
let ip_address = lazy (
match Sys.getenv "QP_NIC" with
let interface =
try Some (Sys.getenv "QP_NIC")
with Not_found -> None
in
match interface with
| None ->
begin
try
Lazy.force hostname
|> Unix.Inet_addr.of_string_or_getbyname
|> Unix.Inet_addr.to_string
let host =
Lazy.force hostname
|> Unix.gethostbyname
in
Unix.string_of_inet_addr host.h_addr_list.(0);
with
| Unix.Unix_error _ ->
failwith "Unable to find IP address from host name."
end
| Some interface ->
begin
try
ok_exn Linux_ext.get_ipv4_address_for_interface interface
with
| Unix.Unix_error _ ->
Lazy.force hostname
|> Unix.Inet_addr.of_string_or_getbyname
|> Unix.Inet_addr.to_string
end
let result = get_ipv4_address_for_interface interface in
if String.sub result 0 5 = "error" then
Printf.sprintf "Unable to use network interface %s" interface
|> failwith
else
result
)
@ -209,7 +212,7 @@ let end_job msg program_state rep_socket pair_socket =
address_inproc = None;
running = true;
accepting_clients = false;
data = StringHashtbl.create ();
data = Hashtbl.create 23;
}
and wait n =
@ -335,8 +338,10 @@ 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
List.fold_left
(fun queue task_id -> Queuing_system.del_task ~task_id queue)
program_state.queue
task_ids
in
let accepting_clients =
(Queuing_system.number_of_queued queue > Queuing_system.number_of_clients queue)
@ -382,11 +387,12 @@ let add_task msg program_state rep_socket =
in
let result =
let new_queue, new_bar =
List.fold ~f:(fun (queue, bar) task ->
Queuing_system.add_task ~task queue,
increment_progress_bar bar)
~init:(program_state.queue, program_state.progress_bar) tasks
let new_queue, new_bar =
List.fold_left (fun (queue, bar) task ->
Queuing_system.add_task ~task queue,
increment_progress_bar bar)
(program_state.queue, program_state.progress_bar)
tasks
in
{ program_state with
queue = new_queue;
@ -547,10 +553,11 @@ let task_done msg program_state rep_socket =
and success () =
let new_queue, new_bar =
List.fold ~f:(fun (queue, bar) task_id ->
List.fold_left (fun (queue, bar) task_id ->
Queuing_system.end_task ~task_id ~client_id queue,
increment_progress_bar bar)
~init:(program_state.queue, program_state.progress_bar) task_ids
(program_state.queue, program_state.progress_bar)
task_ids
in
let accepting_clients =
@ -593,7 +600,7 @@ let put_data msg rest_of_msg program_state rep_socket =
in
let success () =
StringHashtbl.set program_state.data ~key ~data:value ;
Hashtbl.add program_state.data key value ;
Message.PutDataReply (Message.PutDataReply_msg.create ())
|> Message.to_string
|> Zmq.Socket.send rep_socket;
@ -623,9 +630,8 @@ let get_data msg program_state rep_socket =
let success () =
let value =
match StringHashtbl.find program_state.data key with
| Some value -> value
| None -> "\000"
try Hashtbl.find program_state.data key with
| Not_found -> "\000"
in
Message.GetDataReply (Message.GetDataReply_msg.create ~value)
|> Message.to_string_list
@ -677,13 +683,16 @@ let abort program_state rep_socket =
aux [] queue 1
in
let queue =
List.fold ~f:(fun queue task_id ->
Queuing_system.end_task ~task_id ~client_id queue)
~init:queue tasks
List.fold_left
(fun queue task_id -> Queuing_system.end_task ~task_id ~client_id queue)
queue
tasks
in
let queue =
List.fold ~f:(fun queue task_id -> Queuing_system.del_task ~task_id queue)
~init:queue tasks
List.fold_left
(fun queue task_id -> Queuing_system.del_task ~task_id queue)
queue
tasks
in
let queue =
Queuing_system.del_client ~client_id queue
@ -777,7 +786,7 @@ let run ~port =
address_inproc = None;
progress_bar = None ;
accepting_clients = false;
data = StringHashtbl.create ();
data = Hashtbl.create 23;
}
in

View File

@ -7,7 +7,7 @@ type t =
progress_bar : Progress_bar.t option ;
running : bool;
accepting_clients : bool;
data : (string, string) Core.Hashtbl.t ;
data : (string, string) Hashtbl.t ;
}

View File

@ -1,3 +1,6 @@
true: package(core,cryptokit,zmq,str,ppx_sexp_conv,ppx_deriving,getopt)
true: thread
false: profile
<*byte> : linkdep(c_bindings.o), custom
<*.native>: linkdep(c_bindings.o)

69
ocaml/c_bindings.c Normal file
View File

@ -0,0 +1,69 @@
#include <caml/mlvalues.h>
#include <caml/memory.h>
#include <caml/alloc.h>
#include <caml/custom.h>
#include <caml/threads.h>
#include <string.h>
/* Adapted from
https://github.com/monadbobo/ocaml-core/blob/master/base/core/lib/linux_ext_stubs.c
*/
#include <unistd.h>
#include <sys/ioctl.h>
#include <net/if.h>
#include <sys/socket.h>
#include <netinet/in.h>
#include <arpa/inet.h>
CAMLprim value get_ipv4_address_for_interface(value v_interface)
{
CAMLparam1(v_interface);
struct ifreq ifr;
int fd = -1;
value res;
char* error = NULL;
memset(&ifr, 0, sizeof(ifr));
ifr.ifr_addr.sa_family = AF_INET;
/* [ifr] is already initialized to zero, so it doesn't matter if the
incoming string is too long, and [strncpy] fails to add a \0. */
strncpy(ifr.ifr_name, String_val(v_interface), IFNAMSIZ - 1);
caml_enter_blocking_section();
fd = socket(AF_INET, SOCK_DGRAM, 0);
if (fd == -1)
error = "error: couldn't allocate socket";
else {
if (ioctl(fd, SIOCGIFADDR, &ifr) < 0)
error = "error: ioctl(fd, SIOCGIFADDR, ...) failed";
(void) close(fd);
}
caml_leave_blocking_section();
if (error == NULL) {
/* This is weird but doing the usual casting causes errors when using
* the new gcc on CentOS 6. This solution was picked up on Red Hat's
* bugzilla or something. It also works to memcpy a sockaddr into
* a sockaddr_in. This is faster hopefully.
*/
union {
struct sockaddr sa;
struct sockaddr_in sain;
} u;
u.sa = ifr.ifr_addr;
res = caml_copy_string(inet_ntoa(u.sain.sin_addr));
}
else
res = caml_copy_string(error);
CAMLreturn(res);
}

View File

@ -7,6 +7,7 @@ dispatch begin function
| After_rules ->
begin
flag ["ocaml";"compile";"native";"gprof"] (S [ A "-p"]);
pdep ["link"] "linkdep" (fun param -> [param]);
end
| _ -> ()
end

View File

@ -1,11 +1,10 @@
open Core
open Qptypes
let basis () =
let ezfio_filename =
Sys.argv.(1)
in
if (not (Sys.file_exists_exn ezfio_filename)) then
if (not (Sys.file_exists ezfio_filename)) then
failwith "Error reading EZFIO file";
Ezfio.set_file ezfio_filename;
let basis =
@ -22,7 +21,7 @@ let mo () =
let ezfio_filename =
Sys.argv.(1)
in
if (not (Sys.file_exists_exn ezfio_filename)) then
if (not (Sys.file_exists ezfio_filename)) then
failwith "Error reading EZFIO file";
Ezfio.set_file ezfio_filename;
let mo_coef =
@ -39,7 +38,7 @@ let psi_det () =
let ezfio_filename =
Sys.argv.(1)
in
if (not (Sys.file_exists_exn ezfio_filename)) then
if (not (Sys.file_exists ezfio_filename)) then
failwith "Error reading EZFIO file";
Ezfio.set_file ezfio_filename;
let psi_det =

View File

@ -1,6 +1,5 @@
open Qputils
open Qptypes
open Core
(*
* Command-line arguments
@ -46,7 +45,7 @@ let set ~core ~inact ~act ~virt ~del =
let mo_class =
Array.init mo_num ~f:(fun i -> None)
Array.init mo_num (fun i -> None)
in
(* Check input data *)
@ -113,7 +112,8 @@ let set ~core ~inact ~act ~virt ~del =
and av = Excitation.create_single act virt
in
let single_excitations = [ ia ; aa ; av ]
|> List.map ~f:Excitation.(fun x ->
|> List.map (fun x ->
let open Excitation in
match x with
| Single (x,y) ->
( MO_class.to_bitlist n_int (Hole.to_mo_class x),
@ -128,7 +128,8 @@ let set ~core ~inact ~act ~virt ~del =
Excitation.double_of_singles aa aa ;
Excitation.double_of_singles aa av ;
Excitation.double_of_singles av av ]
|> List.map ~f:Excitation.(fun x ->
|> List.map (fun x ->
let open Excitation in
match x with
| Single _ -> assert false
| Double (x,y,z,t) ->
@ -146,19 +147,20 @@ let set ~core ~inact ~act ~virt ~del =
and extract_hole2 (_,_,h,_) = h
and extract_particle2 (_,_,_,p) = p
in
let init = Bitlist.zero n_int in
let result = [
List.map ~f:extract_hole single_excitations
|> List.fold ~init:(Bitlist.zero n_int) ~f:Bitlist.or_operator ;
List.map ~f:extract_particle single_excitations
|> List.fold ~init:(Bitlist.zero n_int) ~f:Bitlist.or_operator ;
List.map ~f:extract_hole1 double_excitations
|> List.fold ~init:(Bitlist.zero n_int) ~f:Bitlist.or_operator ;
List.map ~f:extract_particle1 double_excitations
|> List.fold ~init:(Bitlist.zero n_int) ~f:Bitlist.or_operator ;
List.map ~f:extract_hole2 double_excitations
|> List.fold ~init:(Bitlist.zero n_int) ~f:Bitlist.or_operator ;
List.map ~f:extract_particle2 double_excitations
|> List.fold ~init:(Bitlist.zero n_int) ~f:Bitlist.or_operator ;
List.map extract_hole single_excitations
|> List.fold_left Bitlist.or_operator init;
List.map extract_particle single_excitations
|> List.fold_left Bitlist.or_operator init;
List.map extract_hole1 double_excitations
|> List.fold_left Bitlist.or_operator init;
List.map extract_particle1 double_excitations
|> List.fold_left Bitlist.or_operator init;
List.map extract_hole2 double_excitations
|> List.fold_left Bitlist.or_operator init;
List.map extract_particle2 double_excitations
|> List.fold_left Bitlist.or_operator init;
]
in
@ -167,10 +169,11 @@ let set ~core ~inact ~act ~virt ~del =
*)
(* Write masks *)
let result = List.map ~f:(fun x ->
let y = Bitlist.to_int64_list x in y@y )
let result =
List.map (fun x ->
let y = Bitlist.to_int64_list x in y@y )
result
|> List.concat
|> List.concat
in
Ezfio.set_bitmasks_n_int (N_int_number.to_int n_int);
@ -194,7 +197,7 @@ let set ~core ~inact ~act ~virt ~del =
let data =
Array.to_list mo_class
|> List.map ~f:(fun x -> match x with
|> List.map (fun x -> match x with
|None -> assert false
| Some x -> MO_class.to_string x
)
@ -276,42 +279,6 @@ let run ~q ?(core="[]") ?(inact="[]") ?(act="[]") ?(virt="[]") ?(del="[]") ezfio
set ~core ~inact ~act ~virt ~del
let ezfio_file =
let failure filename =
eprintf "'%s' is not an EZFIO file.\n%!" filename;
exit 1
in
Command.Spec.Arg_type.create
(fun filename ->
match Sys.is_directory filename with
| `Yes ->
begin
match Sys.is_file (filename ^ "/.version") with
| `Yes -> filename
| _ -> failure filename
end
| _ -> failure filename
)
let default range =
let failure filename =
eprintf "'%s' is not a regular file.\n%!" filename;
exit 1
in
Command.Spec.Arg_type.create
(fun filename ->
match Sys.is_directory filename with
| `Yes ->
begin
match Sys.is_file (filename^"/.version") with
| `Yes -> filename
| _ -> failure filename
end
| _ -> failure filename
)
let () =
let open Command_line in

View File

@ -33,7 +33,7 @@ subroutine get_s2(key_i,key_j,Nint,s2)
implicit none
use bitmasks
BEGIN_DOC
! Returns <S^2>
! Returns $\langle S^2 \rangle - S_z^2 S_z$
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2)

View File

@ -24,33 +24,33 @@
do j=1,elec_beta_num
! F-K
do i=1,elec_beta_num
do i=1,elec_beta_num !CC
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))&
- (Fock_matrix_mo_beta(i,j) - Fock_matrix_mo_alpha(i,j))
enddo
! F+K/2
do i=elec_beta_num+1,elec_alpha_num
do i=elec_beta_num+1,elec_alpha_num !CA
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))&
+ 0.5d0*(Fock_matrix_mo_beta(i,j) - Fock_matrix_mo_alpha(i,j))
enddo
! F
do i=elec_alpha_num+1, mo_num
do i=elec_alpha_num+1, mo_num !CV
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))
enddo
enddo
do j=elec_beta_num+1,elec_alpha_num
! F+K/2
do i=1,elec_beta_num
do i=1,elec_beta_num !AC
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))&
+ 0.5d0*(Fock_matrix_mo_beta(i,j) - Fock_matrix_mo_alpha(i,j))
enddo
! F
do i=elec_beta_num+1,elec_alpha_num
do i=elec_beta_num+1,elec_alpha_num !AA
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))
enddo
! F-K/2
do i=elec_alpha_num+1, mo_num
do i=elec_alpha_num+1, mo_num !AV
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))&
- 0.5d0*(Fock_matrix_mo_beta(i,j) - Fock_matrix_mo_alpha(i,j))
enddo
@ -58,16 +58,16 @@
do j=elec_alpha_num+1, mo_num
! F
do i=1,elec_beta_num
do i=1,elec_beta_num !VC
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))
enddo
! F-K/2
do i=elec_beta_num+1,elec_alpha_num
do i=elec_beta_num+1,elec_alpha_num !VA
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))&
- 0.5d0*(Fock_matrix_mo_beta(i,j) - Fock_matrix_mo_alpha(i,j))
enddo
! F+K
do i=elec_alpha_num+1,mo_num
do i=elec_alpha_num+1,mo_num !VV
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j)) &
+ (Fock_matrix_mo_beta(i,j) - Fock_matrix_mo_alpha(i,j))
enddo
@ -123,22 +123,22 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_ao, (ao_num, ao_num) ]
END_DOC
if(frozen_orb_scf)then
call mo_to_ao(Fock_matrix_mo,size(Fock_matrix_mo,1), &
Fock_matrix_ao,size(Fock_matrix_ao,1))
else
if ( (elec_alpha_num == elec_beta_num).and. &
(level_shift == 0.) ) &
then
integer :: i,j
do j=1,ao_num
do i=1,ao_num
Fock_matrix_ao(i,j) = Fock_matrix_ao_alpha(i,j)
enddo
enddo
else
call mo_to_ao(Fock_matrix_mo,size(Fock_matrix_mo,1), &
call mo_to_ao(Fock_matrix_mo,size(Fock_matrix_mo,1), &
Fock_matrix_ao,size(Fock_matrix_ao,1))
endif
else
if ( (elec_alpha_num == elec_beta_num).and. &
(level_shift == 0.) ) &
then
integer :: i,j
do j=1,ao_num
do i=1,ao_num
Fock_matrix_ao(i,j) = Fock_matrix_ao_alpha(i,j)
enddo
enddo
else
call mo_to_ao(Fock_matrix_mo,size(Fock_matrix_mo,1), &
Fock_matrix_ao,size(Fock_matrix_ao,1))
endif
endif
END_PROVIDER

View File

@ -1,7 +1,7 @@
BEGIN_PROVIDER [double precision, SCF_density_matrix_ao_alpha, (ao_num,ao_num) ]
implicit none
BEGIN_DOC
! S^{-1}.P_alpha.S^{-1}
! $C.C^t$ over $\alpha$ MOs
END_DOC
call dgemm('N','T',ao_num,ao_num,elec_alpha_num,1.d0, &
@ -14,7 +14,7 @@ END_PROVIDER
BEGIN_PROVIDER [ double precision, SCF_density_matrix_ao_beta, (ao_num,ao_num) ]
implicit none
BEGIN_DOC
! S^{-1}.P_beta.S^{-1}
! $C.C^t$ over $\beta$ MOs
END_DOC
call dgemm('N','T',ao_num,ao_num,elec_beta_num,1.d0, &
@ -27,7 +27,7 @@ END_PROVIDER
BEGIN_PROVIDER [ double precision, SCF_density_matrix_ao, (ao_num,ao_num) ]
implicit none
BEGIN_DOC
! S^{-1}.P.S^{-1} where P = C.C^t
! Sum of $\alpha$ and $\beta$ density matrices
END_DOC
ASSERT (size(SCF_density_matrix_ao,1) == size(SCF_density_matrix_ao_alpha,1))
if (elec_alpha_num== elec_beta_num) then

View File

@ -0,0 +1,35 @@
program print_wf
implicit none
BEGIN_DOC
! Print the ground state wave function stored in the |EZFIO| directory
! in the intermediate normalization.
!
! It also prints a lot of information regarding the excitation
! operators from the reference determinant ! and a first-order
! perturbative analysis of the wave function.
!
! If the wave function strongly deviates from the first-order analysis,
! something funny is going on :)
END_DOC
! this has to be done in order to be sure that N_det, psi_det and
! psi_coef are the wave function stored in the |EZFIO| directory.
read_wf = .True.
touch read_wf
call routine
end
subroutine routine
implicit none
integer :: i,k
integer :: degree
do i = 1, N_det
print *, 'Determinant ', i
call debug_det(psi_det(1,1,i),N_int)
print '(4E20.12,X)', (psi_coef(i,k), k=1,N_states)
print *, ''
print *, ''
enddo
end