mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-12-22 19:43:32 +01:00
Merge branch 'dev' into cleaning_dft
This commit is contained in:
eginer
commit
4f610a49d6
52
.drone.yml
Normal file
52
.drone.yml
Normal file
@ -0,0 +1,52 @@
|
||||
---
|
||||
kind: pipeline
|
||||
type: docker
|
||||
name: gfortran-debug
|
||||
|
||||
clone:
|
||||
depth: 10
|
||||
|
||||
steps:
|
||||
- name: configure debug
|
||||
image: scemama666/qp2_env
|
||||
commands:
|
||||
- ./configure -i all -c ./config/gfortran_debug.cfg
|
||||
- bash -c "source quantum_package.rc ; exec qp_plugins download https://gitlab.com/scemama/qp_plugins_scemama"
|
||||
- bash -c "source quantum_package.rc ; exec qp_plugins install champ"
|
||||
|
||||
- name: compile debug
|
||||
image: scemama666/qp2_env
|
||||
commands:
|
||||
- bash -c "source quantum_package.rc ; exec ninja"
|
||||
|
||||
- name: testing debug
|
||||
image: scemama666/qp2_env
|
||||
commands:
|
||||
- bash -c "source quantum_package.rc ; TRAVIS=1 exec qp_test -a"
|
||||
|
||||
- name: configure fast
|
||||
image: scemama666/qp2_env
|
||||
commands:
|
||||
- ./configure -c ./config/gfortran_avx.cfg
|
||||
|
||||
- name: compile fast
|
||||
image: scemama666/qp2_env
|
||||
commands:
|
||||
- bash -c "source quantum_package.rc ; exec ninja"
|
||||
|
||||
- name: testing fast
|
||||
image: scemama666/qp2_env
|
||||
commands:
|
||||
- bash -c "source quantum_package.rc ; exec qp_test -a"
|
||||
|
||||
- name: notify
|
||||
image: drillster/drone-email
|
||||
settings:
|
||||
host:
|
||||
from_secret: hostname # irsamc.ups-tlse.fr
|
||||
from:
|
||||
from_secret: from # drone@irssv7.ups-tlse.fr
|
||||
recipients:
|
||||
from_secret: recipients # scemama@irsamc.ups-tlse.fr
|
||||
when:
|
||||
status: [changed, failure]
|
||||
13
README.md
13
README.md
@ -1,6 +1,7 @@
|
||||
# Quantum Package 2.2
|
||||
|
||||
<img src="https://raw.githubusercontent.com/QuantumPackage/qp2/master/data/qp2.png" width="250">
|
||||
<!--- img src="https://raw.githubusercontent.com/QuantumPackage/qp2/master/data/qp2.png" width="250" --->
|
||||
<img src="https://trex-coe.eu/sites/default/files/styles/responsive_no_crop/public/2021-12/Risorsa%2014_0.png" width="250">
|
||||
|
||||
|
||||
[](https://zenodo.org/badge/latestdoi/167513335)
|
||||
@ -44,9 +45,19 @@ https://arxiv.org/abs/1902.08154
|
||||
|
||||
# Credits
|
||||
|
||||
* [TREX Center of Excellence](https://trex-coe.eu)
|
||||
* [ERC PTEROSOR](https://lcpq.github.io/PTEROSOR)
|
||||
* [CNRS](http://www.cnrs.fr)
|
||||
* [Laboratoire de Chimie et Physique Quantiques](http://lcpq.ups-tlse.fr)
|
||||
* [Laboratoire de Chimie Théorique](http://www.lct.jussieu.fr)
|
||||
* [Argonne Leadership Computing Facility](http://alcf.anl.gov)
|
||||
* [CALMIP](https://www.calmip.univ-toulouse.fr)
|
||||
|
||||
|
||||
------------------------------
|
||||
|
||||
<img src="https://lcpq.github.io/PTEROSOR/img/ERC.png" width="200" />
|
||||
|
||||
[TREX: Targeting Real Chemical Accuracy at the Exascale](https://trex-coe.eu) project has received funding from the European Union’s Horizon 2020 - Research and Innovation program - under grant agreement no. 952165. The content of this document does not represent the opinion of the European Union, and the European Union is not responsible for any use that might be made of such content.
|
||||
|
||||
[PTEROSOR](https://lcpq.github.io/PTEROSOR) project has received funding from the European Research Council (ERC) under the European Union’s Horizon 2020 research and innovation programme (Grant agreement No. 863481).
|
||||
|
||||
@ -146,6 +146,17 @@ def write_ezfio(res, filename):
|
||||
ezfio.set_ao_basis_ao_nucl(at)
|
||||
ezfio.set_ao_basis_ao_prim_num(num_prim)
|
||||
ezfio.set_ao_basis_ao_power(power_x + power_y + power_z)
|
||||
try:
|
||||
normf = res.normf
|
||||
if normf == 0:
|
||||
ezfio.set_ao_basis_ao_normalized(True)
|
||||
elif normf == 1:
|
||||
ezfio.set_ao_basis_ao_normalized(False)
|
||||
else:
|
||||
print("BUG in NORMF")
|
||||
sys.exit(0)
|
||||
except AttributeError:
|
||||
ezfio.set_ao_basis_ao_normalized(True)
|
||||
|
||||
# ~#~#~#~#~#~#~ #
|
||||
# P a r s i n g #
|
||||
@ -224,7 +235,7 @@ def write_ezfio(res, filename):
|
||||
exponent += [p.expo for p in b.prim]
|
||||
ang_mom.append(str.count(s, "z"))
|
||||
shell_prim_num.append(len(b.prim))
|
||||
shell_index += [nshell_tot+1] * len(b.prim)
|
||||
shell_index += [nshell_tot] * len(b.prim)
|
||||
|
||||
# ~#~#~#~#~ #
|
||||
# W r i t e #
|
||||
|
||||
@ -60,19 +60,14 @@ def main(arguments):
|
||||
print("Running tests for %s"%(bats_file))
|
||||
print("")
|
||||
if arguments["-v"]:
|
||||
p = None
|
||||
if arguments["TEST"]:
|
||||
test = "export TEST=%s ; "%arguments["TEST"]
|
||||
else:
|
||||
test = ""
|
||||
try:
|
||||
os.system(test+" python3 bats_to_sh.py "+bats_file+
|
||||
os.system(test+" python3 bats_to_sh.py "+bats_file+
|
||||
"| bash")
|
||||
except:
|
||||
if p:
|
||||
p.terminate()
|
||||
else:
|
||||
subprocess.check_call(["bats", bats_file], env=os.environ)
|
||||
subprocess.check_call(["bats", "--verbose-run", "--trace", bats_file], env=os.environ)
|
||||
|
||||
|
||||
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
#
|
||||
[COMMON]
|
||||
FC : ifort -fpic
|
||||
LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps
|
||||
LAPACK_LIB : -mkl=parallel
|
||||
IRPF90 : irpf90
|
||||
IRPF90_FLAGS : --ninja --align=32 -DINTEL -DSET_NESTED
|
||||
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
#
|
||||
[COMMON]
|
||||
FC : mpiifort -fpic
|
||||
LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps
|
||||
LAPACK_LIB : -mkl=parallel
|
||||
IRPF90 : irpf90
|
||||
IRPF90_FLAGS : --ninja --align=32 -DMPI -DINTEL -DSET_NESTED
|
||||
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
#
|
||||
[COMMON]
|
||||
FC : mpiifort -fpic
|
||||
LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps
|
||||
LAPACK_LIB : -mkl=parallel
|
||||
IRPF90 : irpf90
|
||||
IRPF90_FLAGS : --ninja --align=32 -DINTEL -DSET_NESTED
|
||||
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
#
|
||||
[COMMON]
|
||||
FC : ifort -fpic
|
||||
LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps
|
||||
LAPACK_LIB : -mkl=parallel
|
||||
IRPF90 : irpf90
|
||||
IRPF90_FLAGS : --ninja --align=32 -DINTEL -DSET_NESTED
|
||||
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
#
|
||||
[COMMON]
|
||||
FC : ifort -fpic
|
||||
LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps
|
||||
LAPACK_LIB : -mkl=parallel
|
||||
IRPF90 : irpf90
|
||||
IRPF90_FLAGS : --ninja --align=32 -DINTEL -DSET_NESTED
|
||||
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
#
|
||||
[COMMON]
|
||||
FC : mpiifort -fpic
|
||||
LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps
|
||||
LAPACK_LIB : -mkl=parallel
|
||||
IRPF90 : irpf90
|
||||
IRPF90_FLAGS : --ninja --align=32 -DMPI -DINTEL -DSET_NESTED
|
||||
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
#
|
||||
[COMMON]
|
||||
FC : ifort -fpic
|
||||
LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps
|
||||
LAPACK_LIB : -mkl=parallel
|
||||
IRPF90 : irpf90
|
||||
IRPF90_FLAGS : --ninja --align=64 -DINTEL -DSET_NESTED
|
||||
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
#
|
||||
[COMMON]
|
||||
FC : ifort -fpic
|
||||
LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps
|
||||
LAPACK_LIB : -mkl=parallel
|
||||
IRPF90 : irpf90
|
||||
IRPF90_FLAGS : --ninja --align=32 -DINTEL
|
||||
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
#
|
||||
[COMMON]
|
||||
FC : mpiifort -fpic
|
||||
LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps
|
||||
LAPACK_LIB : -mkl=parallel
|
||||
IRPF90 : irpf90
|
||||
IRPF90_FLAGS : --ninja --align=32 -DMPI -DINTEL
|
||||
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
#
|
||||
[COMMON]
|
||||
FC : mpiifort -fpic
|
||||
LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps
|
||||
LAPACK_LIB : -mkl=parallel
|
||||
IRPF90 : irpf90
|
||||
IRPF90_FLAGS : --ninja --align=32 -DINTEL
|
||||
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
#
|
||||
[COMMON]
|
||||
FC : ifort -fpic
|
||||
LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps
|
||||
LAPACK_LIB : -mkl=parallel
|
||||
IRPF90 : irpf90
|
||||
IRPF90_FLAGS : --ninja --align=32 -DINTEL
|
||||
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
#
|
||||
[COMMON]
|
||||
FC : ifort -fpic
|
||||
LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps
|
||||
LAPACK_LIB : -mkl=parallel
|
||||
IRPF90 : irpf90
|
||||
IRPF90_FLAGS : --ninja --align=32 -DINTEL
|
||||
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
#
|
||||
[COMMON]
|
||||
FC : mpiifort -fpic
|
||||
LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps
|
||||
LAPACK_LIB : -mkl=parallel
|
||||
IRPF90 : irpf90
|
||||
IRPF90_FLAGS : --ninja --align=32 -DMPI -DINTEL
|
||||
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
#
|
||||
[COMMON]
|
||||
FC : ifort -fpic
|
||||
LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps
|
||||
LAPACK_LIB : -mkl=parallel
|
||||
IRPF90 : irpf90
|
||||
IRPF90_FLAGS : --ninja --align=64 -DINTEL
|
||||
|
||||
|
||||
4
configure
vendored
4
configure
vendored
@ -281,8 +281,8 @@ EOF
|
||||
|
||||
execute << EOF
|
||||
cd "\${QP_ROOT}"/external
|
||||
tar -zxf qp2-dependencies/bats-v1.1.0.tar.gz
|
||||
( cd bats-core-1.1.0/ ; ./install.sh \${QP_ROOT})
|
||||
tar -zxf qp2-dependencies/bats-v1.7.0.tar.gz
|
||||
( cd bats-core-1.7.0/ ; ./install.sh \${QP_ROOT})
|
||||
EOF
|
||||
|
||||
else
|
||||
|
||||
@ -80,8 +80,6 @@ function qp()
|
||||
if [[ -d $NAME ]] ; then
|
||||
[[ -d $EZFIO_FILE ]] && ezfio unset_file
|
||||
ezfio set_file $NAME
|
||||
else
|
||||
qp_create_ezfio -h | more
|
||||
fi
|
||||
unset _ARGS
|
||||
;;
|
||||
|
||||
2
external/qp2-dependencies
vendored
2
external/qp2-dependencies
vendored
@ -1 +1 @@
|
||||
Subproject commit 90ee61f5041c7c94a0c605625a264860292813a0
|
||||
Subproject commit 242151e03d1d6bf042387226431d82d35845686a
|
||||
@ -1,3 +1,5 @@
|
||||
exception Error of string
|
||||
|
||||
type short_opt = char
|
||||
type long_opt = string
|
||||
type optional = Mandatory | Optional
|
||||
@ -181,15 +183,16 @@ let set_specs specs_in =
|
||||
Getopt.parse_cmdline cmd_specs (fun x -> anon_args := !anon_args @ [x]);
|
||||
|
||||
if show_help () then
|
||||
(help () ; exit 0);
|
||||
help ()
|
||||
else
|
||||
(* Check that all mandatory arguments are set *)
|
||||
List.filter (fun x -> x.short <> ' ' && x.opt = Mandatory) !specs
|
||||
|> List.iter (fun x ->
|
||||
match get x.long with
|
||||
| Some _ -> ()
|
||||
| None -> raise (Error ("--"^x.long^" option is missing."))
|
||||
)
|
||||
|
||||
(* Check that all mandatory arguments are set *)
|
||||
List.filter (fun x -> x.short <> ' ' && x.opt = Mandatory) !specs
|
||||
|> List.iter (fun x ->
|
||||
match get x.long with
|
||||
| Some _ -> ()
|
||||
| None -> failwith ("Error: --"^x.long^" option is missing.")
|
||||
)
|
||||
;;
|
||||
|
||||
|
||||
|
||||
@ -59,6 +59,8 @@ let () =
|
||||
*)
|
||||
|
||||
|
||||
exception Error of string
|
||||
|
||||
type short_opt = char
|
||||
|
||||
type long_opt = string
|
||||
|
||||
@ -101,7 +101,7 @@ let to_string_general ~f m =
|
||||
|> String.concat "\n"
|
||||
|
||||
let to_string =
|
||||
to_string_general ~f:(fun x -> Atom.to_string Units.Angstrom x)
|
||||
to_string_general ~f:(fun x -> Atom.to_string ~units:Units.Angstrom x)
|
||||
|
||||
let to_xyz =
|
||||
to_string_general ~f:Atom.to_xyz
|
||||
@ -113,7 +113,7 @@ let of_xyz_string
|
||||
s =
|
||||
let l = String_ext.split s ~on:'\n'
|
||||
|> List.filter (fun x -> x <> "")
|
||||
|> list_map (fun x -> Atom.of_string units x)
|
||||
|> list_map (fun x -> Atom.of_string ~units x)
|
||||
in
|
||||
let ne = ( get_charge {
|
||||
nuclei=l ;
|
||||
|
||||
@ -56,3 +56,7 @@ let string_of_string s = s
|
||||
let list_map f l =
|
||||
List.rev_map f l
|
||||
|> List.rev
|
||||
|
||||
let socket_convert socket =
|
||||
((Obj.magic (Obj.repr socket)) : [ `Xsub ] Zmq.Socket.t )
|
||||
|
||||
|
||||
@ -677,6 +677,7 @@ let run ?o b au c d m p cart xyz_file =
|
||||
|
||||
let () =
|
||||
|
||||
try (
|
||||
|
||||
let open Command_line in
|
||||
begin
|
||||
@ -734,7 +735,7 @@ If a file with the same name as the basis set exists, this file will be read. O
|
||||
|
||||
let basis =
|
||||
match Command_line.get "basis" with
|
||||
| None -> assert false
|
||||
| None -> ""
|
||||
| Some x -> x
|
||||
in
|
||||
|
||||
@ -773,10 +774,14 @@ If a file with the same name as the basis set exists, this file will be read. O
|
||||
|
||||
let xyz_filename =
|
||||
match Command_line.anon_args () with
|
||||
| [x] -> x
|
||||
| _ -> (Command_line.help () ; failwith "input file is missing")
|
||||
| [] -> failwith "input file is missing"
|
||||
| x::_ -> x
|
||||
in
|
||||
|
||||
run ?o:output basis au charge dummy multiplicity pseudo cart xyz_filename
|
||||
)
|
||||
with
|
||||
| Failure txt -> Printf.eprintf "Fatal error: %s\n%!" txt
|
||||
| Command_line.Error txt -> Printf.eprintf "Command line error: %s\n%!" txt
|
||||
|
||||
|
||||
|
||||
@ -110,7 +110,7 @@ let run slave ?prefix exe ezfio_file =
|
||||
let task_thread =
|
||||
let thread =
|
||||
Thread.create ( fun () ->
|
||||
TaskServer.run port_number )
|
||||
TaskServer.run ~port:port_number )
|
||||
in
|
||||
thread ();
|
||||
in
|
||||
|
||||
@ -131,37 +131,64 @@ let () =
|
||||
Sys.set_signal Sys.sigint handler;
|
||||
|
||||
|
||||
let new_thread req_or_sub addr_in addr_out =
|
||||
let new_thread_req addr_in addr_out =
|
||||
let socket_in, socket_out =
|
||||
match req_or_sub with
|
||||
| REQ ->
|
||||
create_socket Zmq.Socket.router Zmq.Socket.bind addr_in,
|
||||
create_socket Zmq.Socket.dealer Zmq.Socket.connect addr_out
|
||||
| SUB ->
|
||||
create_socket Zmq.Socket.sub Zmq.Socket.connect addr_in,
|
||||
create_socket Zmq.Socket.pub Zmq.Socket.bind addr_out
|
||||
in
|
||||
|
||||
if req_or_sub = SUB then
|
||||
Zmq.Socket.subscribe socket_in "";
|
||||
|
||||
|
||||
|
||||
let action_in =
|
||||
match req_or_sub with
|
||||
| REQ -> (fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out)
|
||||
| SUB -> (fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out)
|
||||
let action_in =
|
||||
fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out
|
||||
in
|
||||
|
||||
let action_out =
|
||||
match req_or_sub with
|
||||
| REQ -> (fun () -> Zmq.Socket.recv_all socket_out |> Zmq.Socket.send_all socket_in )
|
||||
| SUB -> (fun () -> () )
|
||||
fun () -> Zmq.Socket.recv_all socket_out |> Zmq.Socket.send_all socket_in
|
||||
in
|
||||
|
||||
let pollitem =
|
||||
Zmq.Poll.mask_of
|
||||
[| (socket_in, Zmq.Poll.In) ; (socket_out, Zmq.Poll.In) |]
|
||||
[| (socket_convert socket_in, Zmq.Poll.In) ; (socket_convert socket_out, Zmq.Poll.In) |]
|
||||
in
|
||||
|
||||
while !run_status do
|
||||
|
||||
let polling =
|
||||
Zmq.Poll.poll ~timeout:1000 pollitem
|
||||
in
|
||||
|
||||
match polling with
|
||||
| [| Some Zmq.Poll.In ; Some Zmq.Poll.In |] -> ( action_out () ; action_in () )
|
||||
| [| _ ; Some Zmq.Poll.In |] -> action_out ()
|
||||
| [| Some Zmq.Poll.In ; _ |] -> action_in ()
|
||||
| _ -> ()
|
||||
done;
|
||||
|
||||
Zmq.Socket.close socket_in;
|
||||
Zmq.Socket.close socket_out;
|
||||
in
|
||||
|
||||
let new_thread_sub addr_in addr_out =
|
||||
let socket_in, socket_out =
|
||||
create_socket Zmq.Socket.sub Zmq.Socket.connect addr_in,
|
||||
create_socket Zmq.Socket.pub Zmq.Socket.bind addr_out
|
||||
in
|
||||
|
||||
Zmq.Socket.subscribe socket_in "";
|
||||
|
||||
|
||||
|
||||
let action_in =
|
||||
fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out
|
||||
in
|
||||
|
||||
let action_out =
|
||||
fun () -> ()
|
||||
in
|
||||
|
||||
let pollitem =
|
||||
Zmq.Poll.mask_of
|
||||
[| (socket_convert socket_in, Zmq.Poll.In) ; (socket_convert socket_out, Zmq.Poll.In) |]
|
||||
in
|
||||
|
||||
|
||||
@ -194,7 +221,7 @@ let () =
|
||||
in
|
||||
|
||||
let f () =
|
||||
new_thread REQ addr_in addr_out
|
||||
new_thread_req addr_in addr_out
|
||||
in
|
||||
|
||||
(Thread.create f) ()
|
||||
@ -212,7 +239,7 @@ let () =
|
||||
in
|
||||
|
||||
let f () =
|
||||
new_thread REQ addr_in addr_out
|
||||
new_thread_req addr_in addr_out
|
||||
in
|
||||
(Thread.create f) ()
|
||||
in
|
||||
@ -228,7 +255,7 @@ let () =
|
||||
in
|
||||
|
||||
let f () =
|
||||
new_thread SUB addr_in addr_out
|
||||
new_thread_sub addr_in addr_out
|
||||
in
|
||||
(Thread.create f) ()
|
||||
in
|
||||
|
||||
27
scripts/cipsi_save.sh
Normal file
27
scripts/cipsi_save.sh
Normal file
@ -0,0 +1,27 @@
|
||||
#!/bin/bash
|
||||
#
|
||||
# This script runs a CIPSI calculation as a sequence of single CIPSI iterations.
|
||||
# After each iteration, the EZFIO directory is saved.
|
||||
#
|
||||
# Usage: cipsi_save [EZFIO_FILE] [NDET]
|
||||
#
|
||||
# Example: cipsi_save file.ezfio 10000
|
||||
|
||||
EZ=$1
|
||||
NDETMAX=$2
|
||||
|
||||
qp set_file ${EZ}
|
||||
qp reset -d
|
||||
qp set determinants read_wf true
|
||||
declare -i NDET
|
||||
NDET=1
|
||||
while [[ ${NDET} -lt ${NDETMAX} ]]
|
||||
do
|
||||
NDET=$(($NDET + $NDET))
|
||||
qp set determinants n_det_max $NDET
|
||||
qp run fci > ${EZ}.out
|
||||
NDET=$(qp get determinants n_det)
|
||||
mv ${EZ}.out ${EZ}.${NDET}.out
|
||||
cp -r ${EZ} ${EZ}.${NDET}
|
||||
done
|
||||
|
||||
@ -34,3 +34,9 @@ doc: Maximum number of excitation for beta determinants with respect to the Hart
|
||||
interface: ezfio,ocaml,provider
|
||||
default: -1
|
||||
|
||||
[twice_hierarchy_max]
|
||||
type: integer
|
||||
doc: Twice the maximum hierarchy parameter (excitation degree plus half the seniority number). Using -1 selects all determinants
|
||||
interface: ezfio,ocaml,provider
|
||||
default: -1
|
||||
|
||||
|
||||
@ -290,9 +290,13 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in)
|
||||
call set_multiple_levels_omp(.False.)
|
||||
|
||||
|
||||
print '(A)', '========== ======================= ===================== ===================== ==========='
|
||||
print '(A)', ' Samples Energy Variance Norm^2 Seconds'
|
||||
print '(A)', '========== ======================= ===================== ===================== ==========='
|
||||
! old
|
||||
!print '(A)', '========== ======================= ===================== ===================== ==========='
|
||||
!print '(A)', ' Samples Energy Variance Norm^2 Seconds'
|
||||
!print '(A)', '========== ======================= ===================== ===================== ==========='
|
||||
print '(A)', '========== ==================== ================ ================ ================ ============= ==========='
|
||||
print '(A)', ' Samples Energy PT2 Variance Norm^2 Convergence Seconds'
|
||||
print '(A)', '========== ==================== ================ ================ ================ ============= ==========='
|
||||
|
||||
PROVIDE global_selection_buffer
|
||||
|
||||
@ -316,7 +320,10 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in)
|
||||
call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
|
||||
call set_multiple_levels_omp(.True.)
|
||||
|
||||
print '(A)', '========== ======================= ===================== ===================== ==========='
|
||||
! old
|
||||
!print '(A)', '========== ======================= ===================== ===================== ==========='
|
||||
print '(A)', '========== ==================== ================ ================ ================ ============= ==========='
|
||||
|
||||
|
||||
do k=1,N_states
|
||||
pt2_overlap(pt2_stoch_istate,k) = pt2_data % overlap(k,pt2_stoch_istate)
|
||||
@ -414,6 +421,17 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_
|
||||
double precision :: rss
|
||||
double precision, external :: memory_of_double, memory_of_int
|
||||
|
||||
character(len=20) :: format_str1, str_error1, format_str2, str_error2
|
||||
character(len=20) :: format_str3, str_error3, format_str4, str_error4
|
||||
character(len=20) :: format_value1, format_value2, format_value3, format_value4
|
||||
character(len=20) :: str_value1, str_value2, str_value3, str_value4
|
||||
character(len=20) :: str_conv
|
||||
double precision :: value1, value2, value3, value4
|
||||
double precision :: error1, error2, error3, error4
|
||||
integer :: size1,size2,size3,size4
|
||||
|
||||
double precision :: conv_crit
|
||||
|
||||
sending =.False.
|
||||
|
||||
rss = memory_of_int(pt2_n_tasks_max*2+N_det_generators*2)
|
||||
@ -537,14 +555,60 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_
|
||||
|
||||
if ((time - time1 > 1.d0) .or. (n==N_det_generators)) then
|
||||
time1 = time
|
||||
print '(I10, X, F12.6, X, G10.3, X, F10.6, X, G10.3, X, F10.6, X, G10.3, X, F10.1)', c, &
|
||||
pt2_data % pt2(pt2_stoch_istate) +E, &
|
||||
pt2_data_err % pt2(pt2_stoch_istate), &
|
||||
pt2_data % variance(pt2_stoch_istate), &
|
||||
pt2_data_err % variance(pt2_stoch_istate), &
|
||||
pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate), &
|
||||
pt2_data_err % overlap(pt2_stoch_istate,pt2_stoch_istate), &
|
||||
time-time0
|
||||
|
||||
value1 = pt2_data % pt2(pt2_stoch_istate) + E
|
||||
error1 = pt2_data_err % pt2(pt2_stoch_istate)
|
||||
value2 = pt2_data % pt2(pt2_stoch_istate)
|
||||
error2 = pt2_data_err % pt2(pt2_stoch_istate)
|
||||
value3 = pt2_data % variance(pt2_stoch_istate)
|
||||
error3 = pt2_data_err % variance(pt2_stoch_istate)
|
||||
value4 = pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate)
|
||||
error4 = pt2_data_err % overlap(pt2_stoch_istate,pt2_stoch_istate)
|
||||
|
||||
! Max size of the values (FX.Y) with X=size
|
||||
size1 = 15
|
||||
size2 = 12
|
||||
size3 = 12
|
||||
size4 = 12
|
||||
|
||||
! To generate the format: number(error)
|
||||
call format_w_error(value1,error1,size1,8,format_value1,str_error1)
|
||||
call format_w_error(value2,error2,size2,8,format_value2,str_error2)
|
||||
call format_w_error(value3,error3,size3,8,format_value3,str_error3)
|
||||
call format_w_error(value4,error4,size4,8,format_value4,str_error4)
|
||||
|
||||
! value > string with the right format
|
||||
write(str_value1,'('//format_value1//')') value1
|
||||
write(str_value2,'('//format_value2//')') value2
|
||||
write(str_value3,'('//format_value3//')') value3
|
||||
write(str_value4,'('//format_value4//')') value4
|
||||
|
||||
! Convergence criterion
|
||||
conv_crit = dabs(pt2_data_err % pt2(pt2_stoch_istate)) / &
|
||||
(1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) )
|
||||
write(str_conv,'(G10.3)') conv_crit
|
||||
|
||||
write(*,'(I10,X,X,A20,X,A16,X,A16,X,A16,X,A12,X,F10.1)') c,&
|
||||
adjustl(adjustr(str_value1)//'('//str_error1(1:1)//')'),&
|
||||
adjustl(adjustr(str_value2)//'('//str_error2(1:1)//')'),&
|
||||
adjustl(adjustr(str_value3)//'('//str_error3(1:1)//')'),&
|
||||
adjustl(adjustr(str_value4)//'('//str_error4(1:1)//')'),&
|
||||
adjustl(str_conv),&
|
||||
time-time0
|
||||
|
||||
! Old print
|
||||
!print '(I10, X, F12.6, X, G10.3, X, F10.6, X, G10.3, X, F10.6, X, G10.3, X, F10.1,1pE16.6,1pE16.6)', c, &
|
||||
! pt2_data % pt2(pt2_stoch_istate) +E, &
|
||||
! pt2_data_err % pt2(pt2_stoch_istate), &
|
||||
! pt2_data % variance(pt2_stoch_istate), &
|
||||
! pt2_data_err % variance(pt2_stoch_istate), &
|
||||
! pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate), &
|
||||
! pt2_data_err % overlap(pt2_stoch_istate,pt2_stoch_istate), &
|
||||
! time-time0, &
|
||||
! pt2_data % pt2(pt2_stoch_istate), &
|
||||
! dabs(pt2_data_err % pt2(pt2_stoch_istate)) / &
|
||||
! (1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) )
|
||||
|
||||
if (stop_now .or. ( &
|
||||
(do_exit .and. (dabs(pt2_data_err % pt2(pt2_stoch_istate)) / &
|
||||
(1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) ) <= relative_error))) ) then
|
||||
|
||||
@ -61,10 +61,14 @@ subroutine run_selection_slave(thread,iproc,energy)
|
||||
if (N /= buf%N) then
|
||||
print *, 'N=', N
|
||||
print *, 'buf%N=', buf%N
|
||||
print *, 'bug in ', irp_here
|
||||
stop '-1'
|
||||
print *, 'In ', irp_here, ': N /= buf%N'
|
||||
stop -1
|
||||
end if
|
||||
end if
|
||||
if (i_generator > N_det_generators) then
|
||||
print *, 'In ', irp_here, ': i_generator > N_det_generators'
|
||||
stop -1
|
||||
endif
|
||||
call select_connected(i_generator,energy,pt2_data,buf,subset,pt2_F(i_generator))
|
||||
endif
|
||||
|
||||
|
||||
@ -195,7 +195,10 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
|
||||
|
||||
integer :: l_a, nmax, idx
|
||||
integer, allocatable :: indices(:), exc_degree(:), iorder(:)
|
||||
double precision, parameter :: norm_thr = 1.d-16
|
||||
|
||||
! Removed to avoid introducing determinants already presents in the wf
|
||||
!double precision, parameter :: norm_thr = 1.d-16
|
||||
|
||||
allocate (indices(N_det), &
|
||||
exc_degree(max(N_det_alpha_unique,N_det_beta_unique)))
|
||||
|
||||
@ -215,10 +218,11 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
|
||||
i = psi_bilinear_matrix_rows(l_a)
|
||||
if (nt + exc_degree(i) <= 4) then
|
||||
idx = psi_det_sorted_order(psi_bilinear_matrix_order(l_a))
|
||||
if (psi_average_norm_contrib_sorted(idx) > norm_thr) then
|
||||
! Removed to avoid introducing determinants already presents in the wf
|
||||
!if (psi_average_norm_contrib_sorted(idx) > norm_thr) then
|
||||
indices(k) = idx
|
||||
k=k+1
|
||||
endif
|
||||
!endif
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
@ -242,10 +246,11 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
|
||||
idx = psi_det_sorted_order( &
|
||||
psi_bilinear_matrix_order( &
|
||||
psi_bilinear_matrix_transp_order(l_a)))
|
||||
if (psi_average_norm_contrib_sorted(idx) > norm_thr) then
|
||||
! Removed to avoid introducing determinants already presents in the wf
|
||||
!if (psi_average_norm_contrib_sorted(idx) > norm_thr) then
|
||||
indices(k) = idx
|
||||
k=k+1
|
||||
endif
|
||||
!endif
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
@ -253,8 +258,6 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
|
||||
deallocate(exc_degree)
|
||||
nmax=k-1
|
||||
|
||||
call isort_noidx(indices,nmax)
|
||||
|
||||
! Start with 32 elements. Size will double along with the filtering.
|
||||
allocate(preinteresting(0:32), prefullinteresting(0:32), &
|
||||
interesting(0:32), fullinteresting(0:32))
|
||||
@ -566,6 +569,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
|
||||
double precision, external :: diag_H_mat_elem_fock
|
||||
double precision :: E_shift
|
||||
double precision :: s_weight(N_states,N_states)
|
||||
logical, external :: is_in_wavefunction
|
||||
PROVIDE dominant_dets_of_cfgs N_dominant_dets_of_cfgs
|
||||
do jstate=1,N_states
|
||||
do istate=1,N_states
|
||||
@ -707,6 +711,25 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
|
||||
if (do_cycle) cycle
|
||||
endif
|
||||
|
||||
if (twice_hierarchy_max >= 0) then
|
||||
s = 0
|
||||
do k=1,N_int
|
||||
s = s + popcnt(ieor(det(k,1),det(k,2)))
|
||||
enddo
|
||||
if ( mod(s,2)>0 ) stop 'For now, hierarchy CI is defined only for an even number of electrons'
|
||||
if (excitation_ref == 1) then
|
||||
call get_excitation_degree(HF_bitmask,det(1,1),degree,N_int)
|
||||
else if (excitation_ref == 2) then
|
||||
stop 'For now, hierarchy CI is defined only for a single reference determinant'
|
||||
! do k=1,N_dominant_dets_of_cfgs
|
||||
! call get_excitation_degree(dominant_dets_of_cfgs(1,1,k),det(1,1),degree,N_int)
|
||||
! enddo
|
||||
endif
|
||||
integer :: twice_hierarchy
|
||||
twice_hierarchy = degree + s/2
|
||||
if (twice_hierarchy > twice_hierarchy_max) cycle
|
||||
endif
|
||||
|
||||
Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int)
|
||||
|
||||
w = 0d0
|
||||
@ -777,7 +800,9 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
|
||||
|
||||
alpha_h_psi = mat(istate, p1, p2)
|
||||
|
||||
pt2_data % overlap(:,istate) = pt2_data % overlap(:,istate) + coef(:) * coef(istate)
|
||||
do k=1,N_states
|
||||
pt2_data % overlap(k,istate) = pt2_data % overlap(k,istate) + coef(k) * coef(istate)
|
||||
end do
|
||||
pt2_data % variance(istate) = pt2_data % variance(istate) + alpha_h_psi * alpha_h_psi
|
||||
pt2_data % pt2(istate) = pt2_data % pt2(istate) + e_pert(istate)
|
||||
|
||||
@ -828,8 +853,27 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
|
||||
endif
|
||||
|
||||
end select
|
||||
|
||||
! To force the inclusion of determinants with a positive pt2 contribution
|
||||
if (e_pert(istate) > 1d-8) then
|
||||
w = -huge(1.0)
|
||||
endif
|
||||
|
||||
end do
|
||||
|
||||
!!!BEGIN_DEBUG
|
||||
! ! To check if the pt2 is taking determinants already in the wf
|
||||
! if (is_in_wavefunction(det(N_int,1),N_int)) then
|
||||
! print*, 'A determinant contributing to the pt2 is already in'
|
||||
! print*, 'the wave function:'
|
||||
! call print_det(det(N_int,1),N_int)
|
||||
! print*,'contribution to the pt2 for the states:', e_pert(:)
|
||||
! print*,'error in the filtering in'
|
||||
! print*, 'cipsi/selection.irp.f sub: selecte_singles_and_doubles'
|
||||
! print*, 'abort'
|
||||
! call abort
|
||||
! endif
|
||||
!!!END_DEBUG
|
||||
|
||||
integer(bit_kind) :: occ(N_int,2), n
|
||||
if (h0_type == 'CFG') then
|
||||
|
||||
@ -74,7 +74,7 @@ subroutine run
|
||||
print*,'******************************************************'
|
||||
print*,'Excitation energies (au) (eV)'
|
||||
do i = 2, N_states
|
||||
print*, i ,CI_energy(i) - CI_energy(1), (CI_energy(i) - CI_energy(1))/0.0367502d0
|
||||
print*, i ,CI_energy(i) - CI_energy(1), (CI_energy(i) - CI_energy(1)) * ha_to_ev
|
||||
enddo
|
||||
print*,''
|
||||
endif
|
||||
|
||||
7
src/cis_read/EZFIO.cfg
Normal file
7
src/cis_read/EZFIO.cfg
Normal file
@ -0,0 +1,7 @@
|
||||
[energy]
|
||||
type: double precision
|
||||
doc: Variational |CIS| energy
|
||||
interface: ezfio
|
||||
size: (determinants.n_states)
|
||||
|
||||
|
||||
3
src/cis_read/NEED
Normal file
3
src/cis_read/NEED
Normal file
@ -0,0 +1,3 @@
|
||||
selectors_full
|
||||
generators_full
|
||||
davidson_undressed
|
||||
5
src/cis_read/README.rst
Normal file
5
src/cis_read/README.rst
Normal file
@ -0,0 +1,5 @@
|
||||
===
|
||||
cis_read
|
||||
===
|
||||
|
||||
Reads the input WF and performs all singles on top of it.
|
||||
88
src/cis_read/cis_read.irp.f
Normal file
88
src/cis_read/cis_read.irp.f
Normal file
@ -0,0 +1,88 @@
|
||||
program cis
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Configuration Interaction with Single excitations.
|
||||
!
|
||||
! This program takes a reference Slater determinant of ROHF-like
|
||||
! occupancy, and performs all single excitations on top of it.
|
||||
! Disregarding spatial symmetry, it computes the `n_states` lowest
|
||||
! eigenstates of that CI matrix. (see :option:`determinants n_states`)
|
||||
!
|
||||
! This program can be useful in many cases:
|
||||
!
|
||||
!
|
||||
! 1. Ground state calculation
|
||||
!
|
||||
! To be sure to have the lowest |SCF| solution, perform an :ref:`scf`
|
||||
! (see the :ref:`module_hartree_fock` module), then a :ref:`cis`, save the
|
||||
! natural orbitals (see :ref:`save_natorb`) and re-run an :ref:`scf`
|
||||
! optimization from this |MO| guess.
|
||||
!
|
||||
!
|
||||
! 2. Excited states calculations
|
||||
!
|
||||
! The lowest excited states are much likely to be dominated by
|
||||
! single-excitations. Therefore, running a :ref:`cis` will save the
|
||||
! `n_states` lowest states within the |CIS| space in the |EZFIO|
|
||||
! directory, which can afterwards be used as guess wave functions for
|
||||
! a further multi-state |FCI| calculation if :option:`determinants
|
||||
! read_wf` is set to |true| before running the :ref:`fci` executable.
|
||||
!
|
||||
!
|
||||
! If :option:`determinants s2_eig` is set to |true|, the |CIS|
|
||||
! will only retain states having the expected |S^2| value (see
|
||||
! :option:`determinants expected_s2`). Otherwise, the |CIS| will take
|
||||
! the lowest :option:`determinants n_states`, whatever multiplicity
|
||||
! they are.
|
||||
!
|
||||
! .. note::
|
||||
!
|
||||
! To discard some orbitals, use the :ref:`qp_set_mo_class`
|
||||
! command to specify:
|
||||
!
|
||||
! * *core* orbitals which will be always doubly occupied
|
||||
!
|
||||
! * *act* orbitals where an electron can be either excited from or to
|
||||
!
|
||||
! * *del* orbitals which will be never occupied
|
||||
!
|
||||
END_DOC
|
||||
read_wf = .True.
|
||||
TOUCH read_wf
|
||||
call run
|
||||
end
|
||||
|
||||
subroutine run
|
||||
implicit none
|
||||
integer :: i
|
||||
|
||||
|
||||
if(pseudo_sym)then
|
||||
call H_apply_cis_sym
|
||||
else
|
||||
call H_apply_cis
|
||||
endif
|
||||
print*,''
|
||||
print *, 'N_det = ', N_det
|
||||
print*,'******************************'
|
||||
print *, 'Energies of the states:'
|
||||
do i = 1,N_states
|
||||
print *, i, CI_energy(i)
|
||||
enddo
|
||||
if (N_states > 1) then
|
||||
print*,''
|
||||
print*,'******************************************************'
|
||||
print*,'Excitation energies (au) (eV)'
|
||||
do i = 2, N_states
|
||||
print*, i ,CI_energy(i) - CI_energy(1), (CI_energy(i) - CI_energy(1))/0.0367502d0
|
||||
enddo
|
||||
print*,''
|
||||
endif
|
||||
|
||||
call ezfio_set_cis_energy(CI_energy)
|
||||
psi_coef = ci_eigenvectors
|
||||
SOFT_TOUCH psi_coef
|
||||
call save_wavefunction_truncated(save_threshold)
|
||||
|
||||
end
|
||||
14
src/cis_read/h_apply.irp.f
Normal file
14
src/cis_read/h_apply.irp.f
Normal file
@ -0,0 +1,14 @@
|
||||
! Generates subroutine H_apply_cis
|
||||
! --------------------------------
|
||||
|
||||
BEGIN_SHELL [ /usr/bin/env python3 ]
|
||||
from generate_h_apply import H_apply
|
||||
H = H_apply("cis",do_double_exc=False)
|
||||
print(H)
|
||||
|
||||
H = H_apply("cis_sym",do_double_exc=False)
|
||||
H.filter_only_connected_to_hf()
|
||||
print(H)
|
||||
|
||||
END_SHELL
|
||||
|
||||
@ -77,7 +77,7 @@ function run() {
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file ch4.ezfio
|
||||
qp set_mo_class --core="[1]" --act="[2-30]" --del="[31-59]"
|
||||
run -40.2403962667047 -39.8433221754964
|
||||
run -40.2403962667047 -39.843315
|
||||
}
|
||||
|
||||
@test "SiH3" { # 20.2202s 1.38648m
|
||||
|
||||
@ -47,6 +47,37 @@ program cisd
|
||||
PROVIDE N_states
|
||||
read_wf = .False.
|
||||
SOFT_TOUCH read_wf
|
||||
|
||||
integer :: i,k
|
||||
|
||||
if(pseudo_sym)then
|
||||
call H_apply_cisd_sym
|
||||
else
|
||||
call H_apply_cisd
|
||||
endif
|
||||
double precision :: r1, r2
|
||||
double precision, allocatable :: U_csf(:,:)
|
||||
|
||||
allocate(U_csf(N_csf,N_states))
|
||||
U_csf = 0.d0
|
||||
U_csf(1,1) = 1.d0
|
||||
do k=2,N_states
|
||||
do i=1,N_csf
|
||||
call random_number(r1)
|
||||
call random_number(r2)
|
||||
r1 = dsqrt(-2.d0*dlog(r1))
|
||||
r2 = dacos(-1.d0)*2.d0*r2
|
||||
U_csf(i,k) = r1*dcos(r2)
|
||||
enddo
|
||||
U_csf(k,k) = U_csf(k,k) +100.d0
|
||||
enddo
|
||||
do k=1,N_states
|
||||
call normalize(U_csf(1,k),N_csf)
|
||||
enddo
|
||||
call convertWFfromCSFtoDET(N_states,U_csf(1,1),psi_coef(1,1))
|
||||
deallocate(U_csf)
|
||||
SOFT_TOUCH psi_coef
|
||||
|
||||
call run
|
||||
end
|
||||
|
||||
@ -56,20 +87,16 @@ subroutine run
|
||||
double precision :: cisdq(N_states), delta_e
|
||||
double precision,external :: diag_h_mat_elem
|
||||
|
||||
if(pseudo_sym)then
|
||||
call H_apply_cisd_sym
|
||||
else
|
||||
call H_apply_cisd
|
||||
endif
|
||||
psi_coef = ci_eigenvectors
|
||||
SOFT_TOUCH psi_coef
|
||||
call save_wavefunction_truncated(save_threshold)
|
||||
call ezfio_set_cisd_energy(CI_energy)
|
||||
|
||||
do i = 1,N_states
|
||||
k = maxloc(dabs(psi_coef_sorted(1:N_det,i)),dim=1)
|
||||
delta_E = CI_electronic_energy(i) - diag_h_mat_elem(psi_det_sorted(1,1,k),N_int)
|
||||
cisdq(i) = CI_energy(i) + delta_E * (1.d0 - psi_coef_sorted(k,i)**2)
|
||||
if (elec_alpha_num + elec_beta_num >= 4) then
|
||||
cisdq(i) = CI_energy(i) + delta_E * (1.d0 - psi_coef_sorted(k,i)**2)
|
||||
endif
|
||||
enddo
|
||||
print *, 'N_det = ', N_det
|
||||
print*,''
|
||||
@ -78,26 +105,43 @@ subroutine run
|
||||
do i = 1,N_states
|
||||
print *, i, CI_energy(i)
|
||||
enddo
|
||||
print*,''
|
||||
print*,'******************************'
|
||||
print *, 'CISD+Q Energies'
|
||||
do i = 1,N_states
|
||||
print *, i, cisdq(i)
|
||||
enddo
|
||||
if (elec_alpha_num + elec_beta_num >= 4) then
|
||||
print*,''
|
||||
print*,'******************************'
|
||||
print *, 'CISD+Q Energies'
|
||||
do i = 1,N_states
|
||||
print *, i, cisdq(i)
|
||||
enddo
|
||||
endif
|
||||
if (N_states > 1) then
|
||||
print*,''
|
||||
print*,'******************************'
|
||||
print*,'Excitation energies (au) (CISD+Q)'
|
||||
do i = 2, N_states
|
||||
print*, i ,CI_energy(i) - CI_energy(1), cisdq(i) - cisdq(1)
|
||||
enddo
|
||||
print*,''
|
||||
print*,'******************************'
|
||||
print*,'Excitation energies (eV) (CISD+Q)'
|
||||
do i = 2, N_states
|
||||
print*, i ,(CI_energy(i) - CI_energy(1))/0.0367502d0, &
|
||||
(cisdq(i) - cisdq(1)) / 0.0367502d0
|
||||
enddo
|
||||
if (elec_alpha_num + elec_beta_num >= 4) then
|
||||
print*,''
|
||||
print*,'******************************'
|
||||
print*,'Excitation energies (au) (CISD+Q)'
|
||||
do i = 2, N_states
|
||||
print*, i ,CI_energy(i) - CI_energy(1), cisdq(i) - cisdq(1)
|
||||
enddo
|
||||
print*,''
|
||||
print*,'******************************'
|
||||
print*,'Excitation energies (eV) (CISD+Q)'
|
||||
do i = 2, N_states
|
||||
print*, i ,(CI_energy(i) - CI_energy(1)) * ha_to_ev, &
|
||||
(cisdq(i) - cisdq(1)) * ha_to_ev
|
||||
enddo
|
||||
else
|
||||
print*,''
|
||||
print*,'******************************'
|
||||
print*,'Excitation energies (au) (CISD)'
|
||||
do i = 2, N_states
|
||||
print*, i ,CI_energy(i) - CI_energy(1)
|
||||
enddo
|
||||
print*,''
|
||||
print*,'******************************'
|
||||
print*,'Excitation energies (eV) (CISD)'
|
||||
do i = 2, N_states
|
||||
print*, i ,(CI_energy(i) - CI_energy(1)) * ha_to_ev
|
||||
enddo
|
||||
endif
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
@ -68,10 +68,16 @@ void getBFIndexList(int NSOMO, int *BF1, int *IdxListBF1){
|
||||
break;
|
||||
}
|
||||
}
|
||||
BFcopy[Iidx] = -1;
|
||||
BFcopy[Jidx] = -1;
|
||||
IdxListBF1[Jidx] = Iidx;
|
||||
IdxListBF1[Iidx] = Jidx;
|
||||
if(countN1 <= 0){
|
||||
BFcopy[Iidx] = -1;
|
||||
IdxListBF1[Iidx] = Iidx;
|
||||
}
|
||||
else{
|
||||
BFcopy[Iidx] = -1;
|
||||
BFcopy[Jidx] = -1;
|
||||
IdxListBF1[Jidx] = Iidx;
|
||||
IdxListBF1[Iidx] = Jidx;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
@ -328,10 +334,21 @@ void convertCSFtoDetBasis(int64_t Isomo, int MS, int rowsmax, int colsmax, doubl
|
||||
Get Overlap
|
||||
************************************/
|
||||
// Fill matrix
|
||||
|
||||
int rowsbftodetI, colsbftodetI;
|
||||
|
||||
/***********************************
|
||||
Get BFtoDeterminant Matrix
|
||||
************************************/
|
||||
|
||||
printf("In convertcsftodet\n");
|
||||
convertBFtoDetBasis(Isomo, MS, &bftodetmatrixI, &rowsbftodetI, &colsbftodetI);
|
||||
|
||||
int rowsI = 0;
|
||||
int colsI = 0;
|
||||
|
||||
getOverlapMatrix(Isomo, MS, &overlapMatrixI, &rowsI, &colsI, &NSOMO);
|
||||
//getOverlapMatrix(Isomo, MS, &overlapMatrixI, &rowsI, &colsI, &NSOMO);
|
||||
getOverlapMatrix_withDet(bftodetmatrixI, rowsbftodetI, colsbftodetI, Isomo, MS, &overlapMatrixI, &rowsI, &colsI, &NSOMO);
|
||||
|
||||
|
||||
/***********************************
|
||||
@ -342,14 +359,6 @@ void convertCSFtoDetBasis(int64_t Isomo, int MS, int rowsmax, int colsmax, doubl
|
||||
|
||||
gramSchmidt(overlapMatrixI, rowsI, colsI, orthoMatrixI);
|
||||
|
||||
/***********************************
|
||||
Get BFtoDeterminant Matrix
|
||||
************************************/
|
||||
|
||||
int rowsbftodetI, colsbftodetI;
|
||||
|
||||
convertBFtoDetBasis(Isomo, MS, &bftodetmatrixI, &rowsbftodetI, &colsbftodetI);
|
||||
|
||||
/***********************************
|
||||
Get Final CSF to Det Matrix
|
||||
************************************/
|
||||
@ -1297,12 +1306,16 @@ void getbftodetfunction(Tree *dettree, int NSOMO, int MS, int *BF1, double *rowv
|
||||
double fac = 1.0;
|
||||
for(int i = 0; i < NSOMO; i++)
|
||||
donepq[i] = 0.0;
|
||||
for(int i=0;i<npairs;++i){
|
||||
for(int j=0;j<NSOMO;++j)
|
||||
detslist[i*NSOMO + j]=0;
|
||||
}
|
||||
|
||||
for(int i = 0; i < NSOMO; i++){
|
||||
idxp = BF1[i];
|
||||
idxq = BF1[idxp];
|
||||
// Do one pair only once
|
||||
if(donepq[idxp] > 0.0 || donepq[idxq] > 0.0) continue;
|
||||
if(donepq[idxp] > 0.0 || donepq[idxq] > 0.0 || idxp == idxq) continue;
|
||||
fac *= 2.0;
|
||||
donepq[idxp] = 1.0;
|
||||
donepq[idxq] = 1.0;
|
||||
@ -1325,9 +1338,13 @@ void getbftodetfunction(Tree *dettree, int NSOMO, int MS, int *BF1, double *rowv
|
||||
int phase_cfg_to_qp=1;
|
||||
int addr = -1;
|
||||
for(int i = 0; i < npairs; i++){
|
||||
for(int j = 0; j < NSOMO; j++)
|
||||
for(int j = 0; j < NSOMO; j++) {
|
||||
inpdet[j] = detslist[i*NSOMO + j];
|
||||
printf(" %d ",inpdet[j]);
|
||||
}
|
||||
printf("\n");
|
||||
findAddofDetDriver(dettree, NSOMO, inpdet, &addr);
|
||||
printf("(%d) - addr = %d\n",i,addr);
|
||||
// Calculate the phase for cfg to QP2 conversion
|
||||
//get_phase_cfg_to_qp_inpList(inpdet, NSOMO, &phase_cfg_to_qp);
|
||||
//rowvec[addr] = 1.0 * phaselist[i]*phase_cfg_to_qp/sqrt(fac);
|
||||
@ -1416,7 +1433,6 @@ void convertBFtoDetBasis(int64_t Isomo, int MS, double **bftodetmatrixptr, int *
|
||||
getIthBFDriver(&bftree, NSOMO, addI, BF1);
|
||||
getBFIndexList(NSOMO, BF1, IdxListBF1);
|
||||
|
||||
|
||||
// Get ith row
|
||||
getbftodetfunction(&dettree, NSOMO, MS, IdxListBF1, rowvec);
|
||||
|
||||
@ -1425,6 +1441,11 @@ void convertBFtoDetBasis(int64_t Isomo, int MS, double **bftodetmatrixptr, int *
|
||||
|
||||
for(int k=0;k<ndets;k++)
|
||||
rowvec[k]=0.0;
|
||||
|
||||
for(int j=0;j<NSOMO;++j){
|
||||
BF1[j]=0;
|
||||
IdxListBF1[j]=0;
|
||||
}
|
||||
}
|
||||
|
||||
// Garbage collection
|
||||
@ -1680,7 +1701,6 @@ void getApqIJMatrixDriverArrayInp(int64_t Isomo, int64_t Jsomo, int32_t orbp, in
|
||||
|
||||
gramSchmidt(overlapMatrixJ, rowsJ, colsJ, orthoMatrixJ);
|
||||
|
||||
|
||||
int rowsA = 0;
|
||||
int colsA = 0;
|
||||
|
||||
|
||||
@ -17,27 +17,31 @@ void buildTree(Tree *bftree,
|
||||
if(isomo > NSOMOMax || icpl < 0 || izeros > zeromax ) return;
|
||||
|
||||
// If we find a valid BF assign its address
|
||||
if(isomo == NSOMOMax){
|
||||
if(isomo == NSOMOMax && icpl == MSmax){
|
||||
(*inode)->addr = bftree->rootNode->addr;
|
||||
bftree->rootNode->addr += 1;
|
||||
return;
|
||||
}
|
||||
|
||||
// Call 0 branch
|
||||
if(((*inode)->C0) == NULL && izeros+1 <= zeromax){
|
||||
((*inode)->C0) = malloc(sizeof(Node));
|
||||
(*(*inode)->C0) = (Node){ .C0 = NULL, .C1 = NULL, .PREV = *inode, .addr = -1, .cpl = 0, .iSOMO = isomo };
|
||||
buildTree(bftree, &(*inode)->C0, isomo+1, izeros+1, icpl+1, NSOMOMax, MSmax);
|
||||
if(izeros+1 <= zeromax){
|
||||
if(((*inode)->C0) == NULL){
|
||||
((*inode)->C0) = malloc(sizeof(Node));
|
||||
(*(*inode)->C0) = (Node){ .C0 = NULL, .C1 = NULL, .PREV = *inode, .addr = -1, .cpl = 0, .iSOMO = isomo };
|
||||
buildTree(bftree, &(*inode)->C0, isomo+1, izeros+1, icpl+1, NSOMOMax, MSmax);
|
||||
}
|
||||
else buildTree(bftree, &(*inode)->C0, isomo+1, izeros+1, icpl+1, NSOMOMax, MSmax);
|
||||
}
|
||||
else buildTree(bftree, &(*inode)->C0, isomo+1, izeros+1, icpl+1, NSOMOMax, MSmax);
|
||||
|
||||
// Call 1 branch
|
||||
if(((*inode)->C1) == NULL && icpl-1 >= 0){
|
||||
((*inode)->C1) = malloc(sizeof(Node));
|
||||
(*(*inode)->C1) = (Node){ .C0 = NULL, .C1 = NULL, .PREV = *inode, .addr = -1, .cpl = 1, .iSOMO = isomo };
|
||||
buildTree(bftree, &(*inode)->C1, isomo+1, izeros+0, icpl-1, NSOMOMax, MSmax);
|
||||
if(icpl-1 >=0){
|
||||
if(((*inode)->C1) == NULL){
|
||||
((*inode)->C1) = malloc(sizeof(Node));
|
||||
(*(*inode)->C1) = (Node){ .C0 = NULL, .C1 = NULL, .PREV = *inode, .addr = -1, .cpl = 1, .iSOMO = isomo };
|
||||
buildTree(bftree, &(*inode)->C1, isomo+1, izeros+0, icpl-1, NSOMOMax, MSmax);
|
||||
}
|
||||
else buildTree(bftree, &(*inode)->C1, isomo+1, izeros+0, icpl-1, NSOMOMax, MSmax);
|
||||
}
|
||||
else buildTree(bftree, &(*inode)->C1, isomo+1, izeros+0, icpl-1, NSOMOMax, MSmax);
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
@ -124,7 +124,7 @@ subroutine davidson_diag_csf_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N
|
||||
stop -1
|
||||
endif
|
||||
|
||||
itermax = max(2,min(davidson_sze_max, sze/N_st_diag))+1
|
||||
itermax = max(2,min(davidson_sze_max, sze_csf/N_st_diag))+1
|
||||
itertot = 0
|
||||
|
||||
if (state_following) then
|
||||
@ -263,29 +263,20 @@ subroutine davidson_diag_csf_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N
|
||||
! ===================
|
||||
|
||||
converged = .False.
|
||||
|
||||
call convertWFfromDETtoCSF(N_st_diag,u_in(1,1),U_csf(1,1))
|
||||
do k=N_st+1,N_st_diag
|
||||
do i=1,sze
|
||||
do i=1,sze_csf
|
||||
call random_number(r1)
|
||||
call random_number(r2)
|
||||
r1 = dsqrt(-2.d0*dlog(r1))
|
||||
r2 = dtwo_pi*r2
|
||||
u_in(i,k) = r1*dcos(r2) * u_in(i,k-N_st)
|
||||
U_csf(i,k) = r1*dcos(r2) * u_csf(i,k-N_st)
|
||||
enddo
|
||||
u_in(k,k) = u_in(k,k) + 10.d0
|
||||
U_csf(k,k) = u_csf(k,k) + 10.d0
|
||||
enddo
|
||||
do k=1,N_st_diag
|
||||
call normalize(u_in(1,k),sze)
|
||||
call normalize(U_csf(1,k),sze_csf)
|
||||
enddo
|
||||
|
||||
do k=1,N_st_diag
|
||||
do i=1,sze
|
||||
U(i,k) = u_in(i,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! Make random verctors eigenstates of S2
|
||||
call convertWFfromDETtoCSF(N_st_diag,U(1,1),U_csf(1,1))
|
||||
call convertWFfromCSFtoDET(N_st_diag,U_csf(1,1),U(1,1))
|
||||
|
||||
do while (.not.converged)
|
||||
|
||||
@ -1,3 +1,13 @@
|
||||
BEGIN_PROVIDER [ character*(3), sigma_vector_algorithm ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! If 'det', use <Psi_det|H|Psi_det> in Davidson
|
||||
!
|
||||
! If 'cfg', use <Psi_csf|H|Psi_csf> in Davidson
|
||||
END_DOC
|
||||
sigma_vector_algorithm = 'det'
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, CI_energy, (N_states_diag) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
@ -61,9 +71,18 @@ END_PROVIDER
|
||||
if (diag_algorithm == "Davidson") then
|
||||
|
||||
if (do_csf) then
|
||||
call davidson_diag_H_csf(psi_det,CI_eigenvectors, &
|
||||
size(CI_eigenvectors,1),CI_electronic_energy, &
|
||||
N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged)
|
||||
if (sigma_vector_algorithm == 'det') then
|
||||
call davidson_diag_H_csf(psi_det,CI_eigenvectors, &
|
||||
size(CI_eigenvectors,1),CI_electronic_energy, &
|
||||
N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged)
|
||||
! else if (sigma_vector_algorithm == 'cfg') then
|
||||
! call davidson_diag_H_csf(psi_det,CI_eigenvectors, &
|
||||
! size(CI_eigenvectors,1),CI_electronic_energy, &
|
||||
! N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged)
|
||||
! else
|
||||
! print *, irp_here
|
||||
! stop 'bug'
|
||||
endif
|
||||
else
|
||||
call davidson_diag_HS2(psi_det,CI_eigenvectors, CI_s2, &
|
||||
size(CI_eigenvectors,1),CI_electronic_energy, &
|
||||
|
||||
@ -77,28 +77,31 @@ BEGIN_PROVIDER [ integer, psi_det_size ]
|
||||
END_DOC
|
||||
PROVIDE ezfio_filename
|
||||
logical :: exists
|
||||
if (mpi_master) then
|
||||
call ezfio_has_determinants_n_det(exists)
|
||||
if (exists) then
|
||||
call ezfio_get_determinants_n_det(psi_det_size)
|
||||
else
|
||||
psi_det_size = 1
|
||||
psi_det_size = N_states
|
||||
PROVIDE mpi_master
|
||||
if (read_wf) then
|
||||
if (mpi_master) then
|
||||
call ezfio_has_determinants_n_det(exists)
|
||||
if (exists) then
|
||||
call ezfio_get_determinants_n_det(psi_det_size)
|
||||
else
|
||||
psi_det_size = N_states
|
||||
endif
|
||||
call write_int(6,psi_det_size,'Dimension of the psi arrays')
|
||||
endif
|
||||
call write_int(6,psi_det_size,'Dimension of the psi arrays')
|
||||
IRP_IF MPI_DEBUG
|
||||
print *, irp_here, mpi_rank
|
||||
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
|
||||
IRP_ENDIF
|
||||
IRP_IF MPI
|
||||
include 'mpif.h'
|
||||
integer :: ierr
|
||||
call MPI_BCAST( psi_det_size, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
stop 'Unable to read psi_det_size with MPI'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
endif
|
||||
IRP_IF MPI_DEBUG
|
||||
print *, irp_here, mpi_rank
|
||||
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
|
||||
IRP_ENDIF
|
||||
IRP_IF MPI
|
||||
include 'mpif.h'
|
||||
integer :: ierr
|
||||
call MPI_BCAST( psi_det_size, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
stop 'Unable to read psi_det_size with MPI'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
@ -539,7 +542,7 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef)
|
||||
integer :: i,j,k, ndet_qp_edit
|
||||
|
||||
if (mpi_master) then
|
||||
ndet_qp_edit = min(ndet,N_det_qp_edit)
|
||||
ndet_qp_edit = min(ndet,10000)
|
||||
|
||||
call ezfio_set_determinants_N_int(N_int)
|
||||
call ezfio_set_determinants_bit_kind(bit_kind)
|
||||
|
||||
@ -66,9 +66,13 @@ END_PROVIDER
|
||||
write(*,'(i16)',advance='no') i
|
||||
end do
|
||||
write(*,*) ''
|
||||
write(*,'(A17,100(1pE16.8))') 'x_dipole_moment = ',x_dipole_moment
|
||||
write(*,'(A17,100(1pE16.8))') 'y_dipole_moment = ',y_dipole_moment
|
||||
write(*,'(A17,100(1pE16.8))') 'z_dipole_moment = ',z_dipole_moment
|
||||
write(*,'(A23,100(1pE16.8))') 'x_dipole_moment (au) = ',x_dipole_moment
|
||||
write(*,'(A23,100(1pE16.8))') 'y_dipole_moment (au) = ',y_dipole_moment
|
||||
write(*,'(A23,100(1pE16.8))') 'z_dipole_moment (au) = ',z_dipole_moment
|
||||
write(*,*) ''
|
||||
write(*,'(A23,100(1pE16.8))') 'x_dipole_moment (D) = ',x_dipole_moment * au_to_D
|
||||
write(*,'(A23,100(1pE16.8))') 'y_dipole_moment (D) = ',y_dipole_moment * au_to_D
|
||||
write(*,'(A23,100(1pE16.8))') 'z_dipole_moment (D) = ',z_dipole_moment * au_to_D
|
||||
!print*, 'x_dipole_moment = ',x_dipole_moment
|
||||
!print*, 'y_dipole_moment = ',y_dipole_moment
|
||||
!print*, 'z_dipole_moment = ',z_dipole_moment
|
||||
|
||||
@ -624,6 +624,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
|
||||
double precision :: diag_H_mat_elem, phase
|
||||
integer :: n_occ_ab(2)
|
||||
PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals
|
||||
PROVIDE ao_one_e_integrals mo_one_e_integrals
|
||||
|
||||
ASSERT (Nint > 0)
|
||||
ASSERT (Nint == N_int)
|
||||
@ -681,7 +682,6 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
|
||||
case (1)
|
||||
call get_single_excitation(key_i,key_j,exc,phase,Nint)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
|
||||
if (exc(0,1,1) == 1) then
|
||||
! Single alpha
|
||||
m = exc(1,1,1)
|
||||
@ -700,10 +700,6 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
|
||||
end select
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble,phase)
|
||||
use bitmasks
|
||||
implicit none
|
||||
@ -1038,7 +1034,6 @@ subroutine i_H_psi(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array)
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine i_H_psi_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array)
|
||||
use bitmasks
|
||||
implicit none
|
||||
|
||||
@ -282,9 +282,7 @@ subroutine i_H_j_two_e(key_i,key_j,Nint,hij)
|
||||
double precision :: get_two_e_integral
|
||||
integer :: m,n,p,q
|
||||
integer :: i,j,k
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
double precision :: diag_H_mat_elem, phase,phase_2
|
||||
integer :: n_occ_ab(2)
|
||||
PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals ref_bitmask_two_e_energy
|
||||
|
||||
ASSERT (Nint > 0)
|
||||
@ -342,7 +340,6 @@ subroutine i_H_j_two_e(key_i,key_j,Nint,hij)
|
||||
case (1)
|
||||
call get_single_excitation(key_i,key_j,exc,phase,Nint)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
|
||||
if (exc(0,1,1) == 1) then
|
||||
! Mono alpha
|
||||
m = exc(1,1,1)
|
||||
|
||||
@ -8,12 +8,12 @@ function run() {
|
||||
test_exe fci || skip
|
||||
qp edit --check
|
||||
qp set perturbation do_pt2 False
|
||||
qp set determinants n_det_max 8000
|
||||
qp set determinants n_det_max $3
|
||||
qp set determinants n_states 1
|
||||
qp set davidson threshold_davidson 1.e-10
|
||||
qp set davidson n_states_diag 8
|
||||
qp run fci
|
||||
energy1="$(ezfio get fci energy | tr '[]' ' ' | cut -d ',' -f 1)"
|
||||
energy1="$(qp get fci energy | tr '[]' ' ' | cut -d ',' -f 1)"
|
||||
eq $energy1 $1 $thresh
|
||||
}
|
||||
|
||||
@ -22,166 +22,167 @@ function run_stoch() {
|
||||
thresh=$2
|
||||
test_exe fci || skip
|
||||
qp set perturbation do_pt2 True
|
||||
qp set perturbation pt2_relative_error 0.005
|
||||
qp set determinants n_det_max $3
|
||||
qp set determinants n_states 1
|
||||
qp set davidson threshold_davidson 1.e-10
|
||||
qp set davidson n_states_diag 1
|
||||
qp run fci
|
||||
energy1="$(ezfio get fci energy_pt2 | tr '[]' ' ' | cut -d ',' -f 1)"
|
||||
energy1="$(qp get fci energy_extrapolated | tr '[]' ' ' | cut -d ',' -f 1)"
|
||||
eq $energy1 $1 $thresh
|
||||
}
|
||||
|
||||
@test "B-B" {
|
||||
|
||||
@test "B-B" { # 0:00:10
|
||||
qp set_file b2_stretched.ezfio
|
||||
qp set determinants n_det_max 10000
|
||||
qp set_frozen_core
|
||||
run_stoch -49.14103054419 3.e-4 10000
|
||||
run_stoch -49.14097596 0.0001 10000
|
||||
}
|
||||
|
||||
@test "F2" { # 4.07m
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file f2.ezfio
|
||||
qp set_frozen_core
|
||||
run_stoch -199.304922384814 3.e-4 100000
|
||||
}
|
||||
|
||||
@test "NH3" { # 10.6657s
|
||||
@test "NH3" { # 0:00:11
|
||||
qp set_file nh3.ezfio
|
||||
qp set_mo_class --core="[1-4]" --act="[5-72]"
|
||||
run -56.244753429144986 3.e-4 100000
|
||||
run -56.24474908 1.e-5 10000
|
||||
}
|
||||
|
||||
@test "DHNO" { # 11.4721s
|
||||
@test "DHNO" { # 0:00:10
|
||||
qp set_file dhno.ezfio
|
||||
qp set_mo_class --core="[1-7]" --act="[8-64]"
|
||||
run -130.459020029816 3.e-4 100000
|
||||
run -130.45904647 1.e-4 10000
|
||||
}
|
||||
|
||||
@test "HCO" { # 12.2868s
|
||||
@test "HCO" { # 0:01:16
|
||||
qp set_file hco.ezfio
|
||||
run -113.389297812482 6.e-4 100000
|
||||
run_stoch -113.41448940 2.e-3 50000
|
||||
}
|
||||
|
||||
@test "H2O2" { # 12.9214s
|
||||
@test "H2O2" { # 0:01:48
|
||||
qp set_file h2o2.ezfio
|
||||
qp set_mo_class --core="[1-2]" --act="[3-24]" --del="[25-38]"
|
||||
run -151.00467 1.e-4 100000
|
||||
run_stoch -151.02437936 2.e-3 100000
|
||||
}
|
||||
|
||||
@test "HBO" { # 13.3144s
|
||||
@test "HBO" { # 0:00:46
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file hbo.ezfio
|
||||
run -100.212560384678 1.e-3 100000
|
||||
run_stoch -100.221198108988 2.e-3 50000
|
||||
}
|
||||
|
||||
@test "H2O" { # 11.3727s
|
||||
@test "H2O" { # 0:01:05
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file h2o.ezfio
|
||||
run -76.2361605151999 3.e-4 100000
|
||||
run_stoch -76.241332121813 1.e-3 100000
|
||||
}
|
||||
|
||||
@test "ClO" { # 13.3755s
|
||||
@test "ClO" { # 0:03:07
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file clo.ezfio
|
||||
run -534.545616787223 3.e-4 100000
|
||||
run_stoch -534.573564655419 1.e-3 100000
|
||||
}
|
||||
|
||||
@test "SO" { # 13.4952s
|
||||
@test "SO" { # 0:01:49
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file so.ezfio
|
||||
run -26.0096209515081 1.e-3 100000
|
||||
run_stoch -26.04335528 5.e-3 100000
|
||||
}
|
||||
|
||||
@test "H2S" { # 13.6745s
|
||||
@test "H2S" { # 0:01:12
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file h2s.ezfio
|
||||
run -398.859168655255 3.e-4 100000
|
||||
run_stoch -398.865173546866 1.e-3 50000
|
||||
}
|
||||
|
||||
@test "OH" { # 13.865s
|
||||
@test "OH" { # 0:00:41
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file oh.ezfio
|
||||
run -75.6121856748294 3.e-4 100000
|
||||
run_stoch -75.6193013819546 1.e-3 50000
|
||||
}
|
||||
|
||||
@test "SiH2_3B1" { # 13.938ss
|
||||
@test "SiH2_3B1" { # 0:00:50
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file sih2_3b1.ezfio
|
||||
run -290.0175411299477 3.e-4 100000
|
||||
run_stoch -290.01754869 3.e-5 50000
|
||||
}
|
||||
|
||||
@test "H3COH" { # 14.7299s
|
||||
@test "H3COH" { # 0:01:05
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file h3coh.ezfio
|
||||
run -115.205191406072 3.e-4 100000
|
||||
run_stoch -115.224147057725 2.e-3 50000
|
||||
}
|
||||
|
||||
@test "SiH3" { # 15.99s
|
||||
@test "SiH3" { # 0:01:09
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file sih3.ezfio
|
||||
run -5.57241217753818 3.e-4 100000
|
||||
run_stoch -5.57812512359276 1.e-3 50000
|
||||
}
|
||||
|
||||
@test "CH4" { # 16.1612s
|
||||
@test "CH4" { # 0:02:06
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file ch4.ezfio
|
||||
qp set_mo_class --core="[1]" --act="[2-30]" --del="[31-59]"
|
||||
run -40.2409678239136 3.e-4 100000
|
||||
run_stoch -40.2419474611994 1.e-4 100000
|
||||
}
|
||||
|
||||
@test "ClF" { # 16.8864s
|
||||
@test "ClF" { # 0:01:55
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file clf.ezfio
|
||||
run -559.169313755572 3.e-4 100000
|
||||
run_stoch -559.20666465 1.e-2 50000
|
||||
}
|
||||
|
||||
@test "SO2" { # 17.5645s
|
||||
@test "SO2" { # 0:00:24
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file so2.ezfio
|
||||
qp set_mo_class --core="[1-8]" --act="[9-87]"
|
||||
run -41.5746738713298 3.e-4 100000
|
||||
run_stoch -41.57468756 1.e-4 50000
|
||||
}
|
||||
|
||||
@test "C2H2" { # 17.6827s
|
||||
@test "C2H2" { # 0:00:57
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file c2h2.ezfio
|
||||
qp set_mo_class --act="[1-30]" --del="[31-36]"
|
||||
run -12.3685464085969 3.e-4 100000
|
||||
run_stoch -12.3862664765532 1.e-3 50000
|
||||
}
|
||||
|
||||
@test "N2" { # 18.0198s
|
||||
@test "N2" { # 0:01:15
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file n2.ezfio
|
||||
qp set_mo_class --core="[1,2]" --act="[3-40]" --del="[41-60]"
|
||||
run -109.28681540699360 3.e-4 100000
|
||||
run_stoch -109.311954243348 2.e-3 50000
|
||||
}
|
||||
|
||||
@test "N2H4" { # 18.5006s
|
||||
@test "N2H4" { # 0:00:51
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file n2h4.ezfio
|
||||
qp set_mo_class --core="[1-2]" --act="[3-24]" --del="[25-48]"
|
||||
run -111.367332681559 3.e-4 100000
|
||||
run_stoch -111.38119165053 1.e-3 50000
|
||||
}
|
||||
|
||||
@test "CO2" { # 21.1748s
|
||||
@test "CO2" { # 0:01:00
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file co2.ezfio
|
||||
qp set_mo_class --core="[1,2]" --act="[3-30]" --del="[31-42]"
|
||||
run -187.968547952413 3.e-4 100000
|
||||
run_stoch -188.002190327443 2.e-3 50000
|
||||
}
|
||||
|
||||
|
||||
@test "[Cu(NH3)4]2+" { # 25.0417s
|
||||
@test "[Cu(NH3)4]2+" { # 0:01:53
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file cu_nh3_4_2plus.ezfio
|
||||
qp set_mo_class --core="[1-24]" --act="[25-45]" --del="[46-87]"
|
||||
run -1862.9869374387192 3.e-04 100000
|
||||
run_stoch -1862.98705340328 1.e-05 50000
|
||||
}
|
||||
|
||||
@test "HCN" { # 20.3273s
|
||||
@test "HCN" { # 0:01:26
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file hcn.ezfio
|
||||
qp set_mo_class --core="[1,2]" --act="[3-40]" --del="[41-55]"
|
||||
run -93.0771143355433 3.e-4 100000
|
||||
run_stoch -93.0980746734051 5.e-4 50000
|
||||
}
|
||||
|
||||
@test "F2" { # 0:03:34
|
||||
[[ -n $TRAVIS ]] && skip
|
||||
qp set_file f2.ezfio
|
||||
qp set_frozen_core
|
||||
run_stoch -199.307512211742 0.002 100000
|
||||
}
|
||||
|
||||
|
||||
@ -10,3 +10,9 @@ doc: Calculated |FCI| energy + |PT2|
|
||||
interface: ezfio
|
||||
size: (determinants.n_states)
|
||||
|
||||
[energy_extrapolated]
|
||||
type: double precision
|
||||
doc: Calculated |FCI| energy + |PT2|
|
||||
interface: ezfio
|
||||
size: (determinants.n_states)
|
||||
|
||||
|
||||
@ -35,12 +35,13 @@ subroutine print_extrapolated_energy
|
||||
do k=2,min(N_iter,8)
|
||||
write(*,'(F11.4,X,3(X,F18.8))') pt2_iterations(i,N_iter+1-k), extrapolated_energy(k,i), &
|
||||
extrapolated_energy(k,i) - extrapolated_energy(k,1), &
|
||||
(extrapolated_energy(k,i) - extrapolated_energy(k,1) ) * 27.211396641308d0
|
||||
(extrapolated_energy(k,i) - extrapolated_energy(k,1) ) * ha_to_ev
|
||||
enddo
|
||||
write(*,*) '=========== ', '=================== ', '=================== ', '==================='
|
||||
enddo
|
||||
|
||||
print *, ''
|
||||
call ezfio_set_fci_energy_extrapolated(extrapolated_energy(min(N_iter,3),1:N_states))
|
||||
|
||||
end subroutine
|
||||
|
||||
|
||||
@ -36,7 +36,7 @@ subroutine print_summary(e_,pt2_data,pt2_data_err,n_det_,n_configuration_,n_st,s
|
||||
write(*,fmt) '# E ', e_(1:N_states_p)
|
||||
if (N_states_p > 1) then
|
||||
write(*,fmt) '# Excit. (au)', e_(1:N_states_p)-e_(1)
|
||||
write(*,fmt) '# Excit. (eV)', (e_(1:N_states_p)-e_(1))*27.211396641308d0
|
||||
write(*,fmt) '# Excit. (eV)', (e_(1:N_states_p)-e_(1))*ha_to_ev
|
||||
endif
|
||||
write(fmt,*) '(A13,', 2*N_states_p, '(1X,F14.8))'
|
||||
write(*,fmt) '# PT2 '//pt2_string, (pt2_data % pt2(k), pt2_data_err % pt2(k), k=1,N_states_p)
|
||||
@ -47,8 +47,8 @@ subroutine print_summary(e_,pt2_data,pt2_data_err,n_det_,n_configuration_,n_st,s
|
||||
if (N_states_p > 1) then
|
||||
write(*,fmt) '# Excit. (au)', ( (e_(k)+pt2_data % pt2(k)-e_(1)-pt2_data % pt2(1)), &
|
||||
dsqrt(pt2_data_err % pt2(k)*pt2_data_err % pt2(k)+pt2_data_err % pt2(1)*pt2_data_err % pt2(1)), k=1,N_states_p)
|
||||
write(*,fmt) '# Excit. (eV)', ( (e_(k)+pt2_data % pt2(k)-e_(1)-pt2_data % pt2(1))*27.211396641308d0, &
|
||||
dsqrt(pt2_data_err % pt2(k)*pt2_data_err % pt2(k)+pt2_data_err % pt2(1)*pt2_data_err % pt2(1))*27.211396641308d0, k=1,N_states_p)
|
||||
write(*,fmt) '# Excit. (eV)', ( (e_(k)+pt2_data % pt2(k)-e_(1)-pt2_data % pt2(1))*ha_to_ev, &
|
||||
dsqrt(pt2_data_err % pt2(k)*pt2_data_err % pt2(k)+pt2_data_err % pt2(1)*pt2_data_err % pt2(1))*ha_to_ev, k=1,N_states_p)
|
||||
endif
|
||||
write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
|
||||
write(*,fmt)
|
||||
@ -82,19 +82,19 @@ subroutine print_summary(e_,pt2_data,pt2_data_err,n_det_,n_configuration_,n_st,s
|
||||
print *, 'Variational Energy difference (au | eV)'
|
||||
do i=2, N_states_p
|
||||
print*,'Delta E = ', (e_(i) - e_(1)), &
|
||||
(e_(i) - e_(1)) * 27.211396641308d0
|
||||
(e_(i) - e_(1)) * ha_to_ev
|
||||
enddo
|
||||
print *, '-----'
|
||||
print*, 'Variational + perturbative Energy difference (au | eV)'
|
||||
do i=2, N_states_p
|
||||
print*,'Delta E = ', (e_(i)+ pt2_data % pt2(i) - (e_(1) + pt2_data % pt2(1))), &
|
||||
(e_(i)+ pt2_data % pt2(i) - (e_(1) + pt2_data % pt2(1))) * 27.211396641308d0
|
||||
(e_(i)+ pt2_data % pt2(i) - (e_(1) + pt2_data % pt2(1))) * ha_to_ev
|
||||
enddo
|
||||
print *, '-----'
|
||||
print*, 'Variational + renormalized perturbative Energy difference (au | eV)'
|
||||
do i=2, N_states_p
|
||||
print*,'Delta E = ', (e_(i)+ pt2_data % rpt2(i) - (e_(1) + pt2_data % rpt2(1))), &
|
||||
(e_(i)+ pt2_data % rpt2(i) - (e_(1) + pt2_data % rpt2(1))) * 27.211396641308d0
|
||||
(e_(i)+ pt2_data % rpt2(i) - (e_(1) + pt2_data % rpt2(1))) * ha_to_ev
|
||||
enddo
|
||||
endif
|
||||
|
||||
|
||||
@ -235,11 +235,11 @@ subroutine get_mo_two_e_integrals_erf_ij(k,l,sze,out_array,map)
|
||||
|
||||
logical :: integral_is_in_map
|
||||
if (key_kind == 8) then
|
||||
call i8radix_sort(hash,iorder,kk,-1)
|
||||
call i8sort(hash,iorder,kk)
|
||||
else if (key_kind == 4) then
|
||||
call iradix_sort(hash,iorder,kk,-1)
|
||||
call isort(hash,iorder,kk)
|
||||
else if (key_kind == 2) then
|
||||
call i2radix_sort(hash,iorder,kk,-1)
|
||||
call i2sort(hash,iorder,kk)
|
||||
endif
|
||||
|
||||
call map_get_many(mo_integrals_erf_map, hash, tmp_val, kk)
|
||||
@ -290,11 +290,11 @@ subroutine get_mo_two_e_integrals_erf_i1j1(k,l,sze,out_array,map)
|
||||
|
||||
logical :: integral_is_in_map
|
||||
if (key_kind == 8) then
|
||||
call i8radix_sort(hash,iorder,kk,-1)
|
||||
call i8sort(hash,iorder,kk)
|
||||
else if (key_kind == 4) then
|
||||
call iradix_sort(hash,iorder,kk,-1)
|
||||
call isort(hash,iorder,kk)
|
||||
else if (key_kind == 2) then
|
||||
call i2radix_sort(hash,iorder,kk,-1)
|
||||
call i2sort(hash,iorder,kk)
|
||||
endif
|
||||
|
||||
call map_get_many(mo_integrals_erf_map, hash, tmp_val, kk)
|
||||
|
||||
@ -53,7 +53,11 @@ BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ]
|
||||
! call four_idx_novvvv
|
||||
call four_idx_novvvv_old
|
||||
else
|
||||
call add_integrals_to_map(full_ijkl_bitmask_4)
|
||||
if (32.d-9*dble(ao_num)**4 < dble(qp_max_mem)) then
|
||||
call four_idx_dgemm
|
||||
else
|
||||
call add_integrals_to_map(full_ijkl_bitmask_4)
|
||||
endif
|
||||
endif
|
||||
|
||||
call wall_time(wall_2)
|
||||
@ -77,6 +81,94 @@ BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ]
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine four_idx_dgemm
|
||||
implicit none
|
||||
integer :: p,q,r,s,i,j,k,l
|
||||
double precision, allocatable :: a1(:,:,:,:)
|
||||
double precision, allocatable :: a2(:,:,:,:)
|
||||
|
||||
allocate (a1(ao_num,ao_num,ao_num,ao_num))
|
||||
|
||||
print *, 'Getting AOs'
|
||||
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(q,r,s)
|
||||
do s=1,ao_num
|
||||
do r=1,ao_num
|
||||
do q=1,ao_num
|
||||
call get_ao_two_e_integrals(q,r,s,ao_num,a1(1,q,r,s))
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
|
||||
print *, '1st transformation'
|
||||
! 1st transformation
|
||||
allocate (a2(ao_num,ao_num,ao_num,mo_num))
|
||||
call dgemm('T','N', (ao_num*ao_num*ao_num), mo_num, ao_num, 1.d0, a1, ao_num, mo_coef, ao_num, 0.d0, a2, (ao_num*ao_num*ao_num))
|
||||
|
||||
! 2nd transformation
|
||||
print *, '2nd transformation'
|
||||
deallocate (a1)
|
||||
allocate (a1(ao_num,ao_num,mo_num,mo_num))
|
||||
call dgemm('T','N', (ao_num*ao_num*mo_num), mo_num, ao_num, 1.d0, a2, ao_num, mo_coef, ao_num, 0.d0, a1, (ao_num*ao_num*mo_num))
|
||||
|
||||
! 3rd transformation
|
||||
print *, '3rd transformation'
|
||||
deallocate (a2)
|
||||
allocate (a2(ao_num,mo_num,mo_num,mo_num))
|
||||
call dgemm('T','N', (ao_num*mo_num*mo_num), mo_num, ao_num, 1.d0, a1, ao_num, mo_coef, ao_num, 0.d0, a2, (ao_num*mo_num*mo_num))
|
||||
|
||||
! 4th transformation
|
||||
print *, '4th transformation'
|
||||
deallocate (a1)
|
||||
allocate (a1(mo_num,mo_num,mo_num,mo_num))
|
||||
call dgemm('T','N', (mo_num*mo_num*mo_num), mo_num, ao_num, 1.d0, a2, ao_num, mo_coef, ao_num, 0.d0, a1, (mo_num*mo_num*mo_num))
|
||||
|
||||
deallocate (a2)
|
||||
|
||||
integer :: n_integrals, size_buffer
|
||||
integer(key_kind) , allocatable :: buffer_i(:)
|
||||
real(integral_kind), allocatable :: buffer_value(:)
|
||||
size_buffer = min(ao_num*ao_num*ao_num,16000000)
|
||||
|
||||
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l,buffer_value,buffer_i,n_integrals)
|
||||
allocate ( buffer_i(size_buffer), buffer_value(size_buffer) )
|
||||
|
||||
n_integrals = 0
|
||||
!$OMP DO
|
||||
do l=1,mo_num
|
||||
do k=1,mo_num
|
||||
do j=1,l
|
||||
do i=1,k
|
||||
if (abs(a1(i,j,k,l)) < mo_integrals_threshold) then
|
||||
cycle
|
||||
endif
|
||||
n_integrals += 1
|
||||
buffer_value(n_integrals) = a1(i,j,k,l)
|
||||
!DIR$ FORCEINLINE
|
||||
call mo_two_e_integrals_index(i,j,k,l,buffer_i(n_integrals))
|
||||
if (n_integrals == size_buffer) then
|
||||
call map_append(mo_integrals_map, buffer_i, buffer_value, n_integrals)
|
||||
n_integrals = 0
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
|
||||
call map_append(mo_integrals_map, buffer_i, buffer_value, n_integrals)
|
||||
|
||||
deallocate(buffer_i, buffer_value)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
deallocate (a1)
|
||||
|
||||
call map_unique(mo_integrals_map)
|
||||
|
||||
integer*8 :: get_mo_map_size, mo_map_size
|
||||
mo_map_size = get_mo_map_size()
|
||||
|
||||
end subroutine
|
||||
|
||||
subroutine add_integrals_to_map(mask_ijkl)
|
||||
use bitmasks
|
||||
|
||||
@ -54,11 +54,23 @@ subroutine routine_s2
|
||||
double precision, allocatable :: psi_coef_tmp(:,:)
|
||||
integer :: i,j,k
|
||||
double precision :: accu(N_states)
|
||||
integer :: weights(0:16), ix
|
||||
double precision :: x
|
||||
|
||||
print *, 'Weights of the CFG'
|
||||
weights(:) = 0
|
||||
do i=1,N_det
|
||||
print *, i, real(weight_configuration(det_to_configuration(i),:)), real(sum(weight_configuration(det_to_configuration(i),:)))
|
||||
x = -dlog(1.d-32+sum(weight_configuration(det_to_configuration(i),:)))/dlog(10.d0)
|
||||
ix = min(int(x), 16)
|
||||
weights(ix) += 1
|
||||
enddo
|
||||
|
||||
print *, 'Histogram of the weights of the CFG'
|
||||
do i=0,15
|
||||
print *, ' 10^{-', i, '} ', weights(i)
|
||||
end do
|
||||
print *, '< 10^{-', 15, '} ', weights(16)
|
||||
|
||||
|
||||
print*, 'Min weight of the configuration?'
|
||||
read(5,*) wmin
|
||||
|
||||
|
||||
71
src/utils/format_w_error.irp.f
Normal file
71
src/utils/format_w_error.irp.f
Normal file
@ -0,0 +1,71 @@
|
||||
subroutine format_w_error(value,error,size_nb,max_nb_digits,format_value,str_error)
|
||||
|
||||
implicit none
|
||||
|
||||
BEGIN_DOC
|
||||
! Format for double precision, value(error)
|
||||
END_DOC
|
||||
|
||||
! in
|
||||
! | value | double precision | value... |
|
||||
! | error | double precision | error... |
|
||||
! | size_nb | integer | X in FX.Y |
|
||||
! | max_nb_digits | integer | Max Y in FX.Y |
|
||||
|
||||
! out
|
||||
! | format_value | character | string FX.Y for the format |
|
||||
! | str_error | character | string of the error |
|
||||
|
||||
! internal
|
||||
! | str_size | character | size in string format |
|
||||
! | nb_digits | integer | number of digits Y in FX.Y depending of the error |
|
||||
! | str_nb_digits | character | nb_digits in string format |
|
||||
! | str_exp | character | string of the value in exponential format |
|
||||
|
||||
! in
|
||||
double precision, intent(in) :: error, value
|
||||
integer, intent(in) :: size_nb, max_nb_digits
|
||||
|
||||
! out
|
||||
character(len=20), intent(out) :: str_error, format_value
|
||||
|
||||
! internal
|
||||
character(len=20) :: str_size, str_nb_digits, str_exp
|
||||
integer :: nb_digits
|
||||
|
||||
! max_nb_digit: Y max
|
||||
! size_nb = Size of the double: X (FX.Y)
|
||||
write(str_size,'(I3)') size_nb
|
||||
|
||||
! Error
|
||||
write(str_exp,'(1pE20.0)') error
|
||||
str_error = trim(adjustl(str_exp))
|
||||
|
||||
! Number of digit: Y (FX.Y) from the exponent
|
||||
str_nb_digits = str_exp(19:20)
|
||||
read(str_nb_digits,*) nb_digits
|
||||
|
||||
! If the error is 0d0
|
||||
if (error <= 1d-16) then
|
||||
write(str_nb_digits,*) max_nb_digits
|
||||
endif
|
||||
|
||||
! If the error is too small
|
||||
if (nb_digits > max_nb_digits) then
|
||||
write(str_nb_digits,*) max_nb_digits
|
||||
str_error(1:1) = '0'
|
||||
endif
|
||||
|
||||
! If the error is too big (>= 0.5)
|
||||
if (error >= 0.5d0) then
|
||||
str_nb_digits = '1'
|
||||
str_error(1:1) = '*'
|
||||
endif
|
||||
|
||||
! FX.Y,A1,A1,A1 for value(str_error)
|
||||
!string = 'F'//trim(adjustl(str_size))//'.'//trim(adjustl(str_nb_digits))//',A1,A1,A1'
|
||||
|
||||
! FX.Y just for the value
|
||||
format_value = 'F'//trim(adjustl(str_size))//'.'//trim(adjustl(str_nb_digits))
|
||||
|
||||
end
|
||||
@ -238,11 +238,11 @@ subroutine cache_map_sort(map)
|
||||
iorder(i) = i
|
||||
enddo
|
||||
if (cache_key_kind == 2) then
|
||||
call i2radix_sort(map%key,iorder,map%n_elements,-1)
|
||||
call i2sort(map%key,iorder,map%n_elements,-1)
|
||||
else if (cache_key_kind == 4) then
|
||||
call iradix_sort(map%key,iorder,map%n_elements,-1)
|
||||
call isort(map%key,iorder,map%n_elements,-1)
|
||||
else if (cache_key_kind == 8) then
|
||||
call i8radix_sort(map%key,iorder,map%n_elements,-1)
|
||||
call i8sort(map%key,iorder,map%n_elements,-1)
|
||||
endif
|
||||
if (integral_kind == 4) then
|
||||
call set_order(map%value,iorder,map%n_elements)
|
||||
|
||||
373
src/utils/qsort.c
Normal file
373
src/utils/qsort.c
Normal file
@ -0,0 +1,373 @@
|
||||
/* [[file:~/qp2/src/utils/qsort.org::*Generated%20C%20file][Generated C file:1]] */
|
||||
#include <stdlib.h>
|
||||
#include <stdint.h>
|
||||
|
||||
struct int16_t_comp {
|
||||
int16_t x;
|
||||
int32_t i;
|
||||
};
|
||||
|
||||
int compare_int16_t( const void * l, const void * r )
|
||||
{
|
||||
const int16_t * restrict _l= l;
|
||||
const int16_t * restrict _r= r;
|
||||
if( *_l > *_r ) return 1;
|
||||
if( *_l < *_r ) return -1;
|
||||
return 0;
|
||||
}
|
||||
|
||||
void qsort_int16_t(int16_t* restrict A_in, int32_t* restrict iorder, int32_t isize) {
|
||||
struct int16_t_comp* A = malloc(isize * sizeof(struct int16_t_comp));
|
||||
if (A == NULL) return;
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A[i].x = A_in[i];
|
||||
A[i].i = iorder[i];
|
||||
}
|
||||
|
||||
qsort( (void*) A, (size_t) isize, sizeof(struct int16_t_comp), compare_int16_t);
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A_in[i] = A[i].x;
|
||||
iorder[i] = A[i].i;
|
||||
}
|
||||
free(A);
|
||||
}
|
||||
|
||||
void qsort_int16_t_noidx(int16_t* A, int32_t isize) {
|
||||
qsort( (void*) A, (size_t) isize, sizeof(int16_t), compare_int16_t);
|
||||
}
|
||||
|
||||
|
||||
struct int16_t_comp_big {
|
||||
int16_t x;
|
||||
int64_t i;
|
||||
};
|
||||
|
||||
int compare_int16_t_big( const void * l, const void * r )
|
||||
{
|
||||
const int16_t * restrict _l= l;
|
||||
const int16_t * restrict _r= r;
|
||||
if( *_l > *_r ) return 1;
|
||||
if( *_l < *_r ) return -1;
|
||||
return 0;
|
||||
}
|
||||
|
||||
void qsort_int16_t_big(int16_t* restrict A_in, int64_t* restrict iorder, int64_t isize) {
|
||||
struct int16_t_comp_big* A = malloc(isize * sizeof(struct int16_t_comp_big));
|
||||
if (A == NULL) return;
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A[i].x = A_in[i];
|
||||
A[i].i = iorder[i];
|
||||
}
|
||||
|
||||
qsort( (void*) A, (size_t) isize, sizeof(struct int16_t_comp_big), compare_int16_t_big);
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A_in[i] = A[i].x;
|
||||
iorder[i] = A[i].i;
|
||||
}
|
||||
free(A);
|
||||
}
|
||||
|
||||
void qsort_int16_t_noidx_big(int16_t* A, int64_t isize) {
|
||||
qsort( (void*) A, (size_t) isize, sizeof(int16_t), compare_int16_t_big);
|
||||
}
|
||||
|
||||
|
||||
struct int32_t_comp {
|
||||
int32_t x;
|
||||
int32_t i;
|
||||
};
|
||||
|
||||
int compare_int32_t( const void * l, const void * r )
|
||||
{
|
||||
const int32_t * restrict _l= l;
|
||||
const int32_t * restrict _r= r;
|
||||
if( *_l > *_r ) return 1;
|
||||
if( *_l < *_r ) return -1;
|
||||
return 0;
|
||||
}
|
||||
|
||||
void qsort_int32_t(int32_t* restrict A_in, int32_t* restrict iorder, int32_t isize) {
|
||||
struct int32_t_comp* A = malloc(isize * sizeof(struct int32_t_comp));
|
||||
if (A == NULL) return;
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A[i].x = A_in[i];
|
||||
A[i].i = iorder[i];
|
||||
}
|
||||
|
||||
qsort( (void*) A, (size_t) isize, sizeof(struct int32_t_comp), compare_int32_t);
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A_in[i] = A[i].x;
|
||||
iorder[i] = A[i].i;
|
||||
}
|
||||
free(A);
|
||||
}
|
||||
|
||||
void qsort_int32_t_noidx(int32_t* A, int32_t isize) {
|
||||
qsort( (void*) A, (size_t) isize, sizeof(int32_t), compare_int32_t);
|
||||
}
|
||||
|
||||
|
||||
struct int32_t_comp_big {
|
||||
int32_t x;
|
||||
int64_t i;
|
||||
};
|
||||
|
||||
int compare_int32_t_big( const void * l, const void * r )
|
||||
{
|
||||
const int32_t * restrict _l= l;
|
||||
const int32_t * restrict _r= r;
|
||||
if( *_l > *_r ) return 1;
|
||||
if( *_l < *_r ) return -1;
|
||||
return 0;
|
||||
}
|
||||
|
||||
void qsort_int32_t_big(int32_t* restrict A_in, int64_t* restrict iorder, int64_t isize) {
|
||||
struct int32_t_comp_big* A = malloc(isize * sizeof(struct int32_t_comp_big));
|
||||
if (A == NULL) return;
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A[i].x = A_in[i];
|
||||
A[i].i = iorder[i];
|
||||
}
|
||||
|
||||
qsort( (void*) A, (size_t) isize, sizeof(struct int32_t_comp_big), compare_int32_t_big);
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A_in[i] = A[i].x;
|
||||
iorder[i] = A[i].i;
|
||||
}
|
||||
free(A);
|
||||
}
|
||||
|
||||
void qsort_int32_t_noidx_big(int32_t* A, int64_t isize) {
|
||||
qsort( (void*) A, (size_t) isize, sizeof(int32_t), compare_int32_t_big);
|
||||
}
|
||||
|
||||
|
||||
struct int64_t_comp {
|
||||
int64_t x;
|
||||
int32_t i;
|
||||
};
|
||||
|
||||
int compare_int64_t( const void * l, const void * r )
|
||||
{
|
||||
const int64_t * restrict _l= l;
|
||||
const int64_t * restrict _r= r;
|
||||
if( *_l > *_r ) return 1;
|
||||
if( *_l < *_r ) return -1;
|
||||
return 0;
|
||||
}
|
||||
|
||||
void qsort_int64_t(int64_t* restrict A_in, int32_t* restrict iorder, int32_t isize) {
|
||||
struct int64_t_comp* A = malloc(isize * sizeof(struct int64_t_comp));
|
||||
if (A == NULL) return;
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A[i].x = A_in[i];
|
||||
A[i].i = iorder[i];
|
||||
}
|
||||
|
||||
qsort( (void*) A, (size_t) isize, sizeof(struct int64_t_comp), compare_int64_t);
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A_in[i] = A[i].x;
|
||||
iorder[i] = A[i].i;
|
||||
}
|
||||
free(A);
|
||||
}
|
||||
|
||||
void qsort_int64_t_noidx(int64_t* A, int32_t isize) {
|
||||
qsort( (void*) A, (size_t) isize, sizeof(int64_t), compare_int64_t);
|
||||
}
|
||||
|
||||
|
||||
struct int64_t_comp_big {
|
||||
int64_t x;
|
||||
int64_t i;
|
||||
};
|
||||
|
||||
int compare_int64_t_big( const void * l, const void * r )
|
||||
{
|
||||
const int64_t * restrict _l= l;
|
||||
const int64_t * restrict _r= r;
|
||||
if( *_l > *_r ) return 1;
|
||||
if( *_l < *_r ) return -1;
|
||||
return 0;
|
||||
}
|
||||
|
||||
void qsort_int64_t_big(int64_t* restrict A_in, int64_t* restrict iorder, int64_t isize) {
|
||||
struct int64_t_comp_big* A = malloc(isize * sizeof(struct int64_t_comp_big));
|
||||
if (A == NULL) return;
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A[i].x = A_in[i];
|
||||
A[i].i = iorder[i];
|
||||
}
|
||||
|
||||
qsort( (void*) A, (size_t) isize, sizeof(struct int64_t_comp_big), compare_int64_t_big);
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A_in[i] = A[i].x;
|
||||
iorder[i] = A[i].i;
|
||||
}
|
||||
free(A);
|
||||
}
|
||||
|
||||
void qsort_int64_t_noidx_big(int64_t* A, int64_t isize) {
|
||||
qsort( (void*) A, (size_t) isize, sizeof(int64_t), compare_int64_t_big);
|
||||
}
|
||||
|
||||
|
||||
struct double_comp {
|
||||
double x;
|
||||
int32_t i;
|
||||
};
|
||||
|
||||
int compare_double( const void * l, const void * r )
|
||||
{
|
||||
const double * restrict _l= l;
|
||||
const double * restrict _r= r;
|
||||
if( *_l > *_r ) return 1;
|
||||
if( *_l < *_r ) return -1;
|
||||
return 0;
|
||||
}
|
||||
|
||||
void qsort_double(double* restrict A_in, int32_t* restrict iorder, int32_t isize) {
|
||||
struct double_comp* A = malloc(isize * sizeof(struct double_comp));
|
||||
if (A == NULL) return;
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A[i].x = A_in[i];
|
||||
A[i].i = iorder[i];
|
||||
}
|
||||
|
||||
qsort( (void*) A, (size_t) isize, sizeof(struct double_comp), compare_double);
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A_in[i] = A[i].x;
|
||||
iorder[i] = A[i].i;
|
||||
}
|
||||
free(A);
|
||||
}
|
||||
|
||||
void qsort_double_noidx(double* A, int32_t isize) {
|
||||
qsort( (void*) A, (size_t) isize, sizeof(double), compare_double);
|
||||
}
|
||||
|
||||
|
||||
struct double_comp_big {
|
||||
double x;
|
||||
int64_t i;
|
||||
};
|
||||
|
||||
int compare_double_big( const void * l, const void * r )
|
||||
{
|
||||
const double * restrict _l= l;
|
||||
const double * restrict _r= r;
|
||||
if( *_l > *_r ) return 1;
|
||||
if( *_l < *_r ) return -1;
|
||||
return 0;
|
||||
}
|
||||
|
||||
void qsort_double_big(double* restrict A_in, int64_t* restrict iorder, int64_t isize) {
|
||||
struct double_comp_big* A = malloc(isize * sizeof(struct double_comp_big));
|
||||
if (A == NULL) return;
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A[i].x = A_in[i];
|
||||
A[i].i = iorder[i];
|
||||
}
|
||||
|
||||
qsort( (void*) A, (size_t) isize, sizeof(struct double_comp_big), compare_double_big);
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A_in[i] = A[i].x;
|
||||
iorder[i] = A[i].i;
|
||||
}
|
||||
free(A);
|
||||
}
|
||||
|
||||
void qsort_double_noidx_big(double* A, int64_t isize) {
|
||||
qsort( (void*) A, (size_t) isize, sizeof(double), compare_double_big);
|
||||
}
|
||||
|
||||
|
||||
struct float_comp {
|
||||
float x;
|
||||
int32_t i;
|
||||
};
|
||||
|
||||
int compare_float( const void * l, const void * r )
|
||||
{
|
||||
const float * restrict _l= l;
|
||||
const float * restrict _r= r;
|
||||
if( *_l > *_r ) return 1;
|
||||
if( *_l < *_r ) return -1;
|
||||
return 0;
|
||||
}
|
||||
|
||||
void qsort_float(float* restrict A_in, int32_t* restrict iorder, int32_t isize) {
|
||||
struct float_comp* A = malloc(isize * sizeof(struct float_comp));
|
||||
if (A == NULL) return;
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A[i].x = A_in[i];
|
||||
A[i].i = iorder[i];
|
||||
}
|
||||
|
||||
qsort( (void*) A, (size_t) isize, sizeof(struct float_comp), compare_float);
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A_in[i] = A[i].x;
|
||||
iorder[i] = A[i].i;
|
||||
}
|
||||
free(A);
|
||||
}
|
||||
|
||||
void qsort_float_noidx(float* A, int32_t isize) {
|
||||
qsort( (void*) A, (size_t) isize, sizeof(float), compare_float);
|
||||
}
|
||||
|
||||
|
||||
struct float_comp_big {
|
||||
float x;
|
||||
int64_t i;
|
||||
};
|
||||
|
||||
int compare_float_big( const void * l, const void * r )
|
||||
{
|
||||
const float * restrict _l= l;
|
||||
const float * restrict _r= r;
|
||||
if( *_l > *_r ) return 1;
|
||||
if( *_l < *_r ) return -1;
|
||||
return 0;
|
||||
}
|
||||
|
||||
void qsort_float_big(float* restrict A_in, int64_t* restrict iorder, int64_t isize) {
|
||||
struct float_comp_big* A = malloc(isize * sizeof(struct float_comp_big));
|
||||
if (A == NULL) return;
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A[i].x = A_in[i];
|
||||
A[i].i = iorder[i];
|
||||
}
|
||||
|
||||
qsort( (void*) A, (size_t) isize, sizeof(struct float_comp_big), compare_float_big);
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A_in[i] = A[i].x;
|
||||
iorder[i] = A[i].i;
|
||||
}
|
||||
free(A);
|
||||
}
|
||||
|
||||
void qsort_float_noidx_big(float* A, int64_t isize) {
|
||||
qsort( (void*) A, (size_t) isize, sizeof(float), compare_float_big);
|
||||
}
|
||||
/* Generated C file:1 ends here */
|
||||
169
src/utils/qsort.org
Normal file
169
src/utils/qsort.org
Normal file
@ -0,0 +1,169 @@
|
||||
#+TITLE: Quick sort binding for Fortran
|
||||
|
||||
* C template
|
||||
|
||||
#+NAME: c_template
|
||||
#+BEGIN_SRC c
|
||||
struct TYPE_comp_big {
|
||||
TYPE x;
|
||||
int32_t i;
|
||||
};
|
||||
|
||||
int compare_TYPE_big( const void * l, const void * r )
|
||||
{
|
||||
const TYPE * restrict _l= l;
|
||||
const TYPE * restrict _r= r;
|
||||
if( *_l > *_r ) return 1;
|
||||
if( *_l < *_r ) return -1;
|
||||
return 0;
|
||||
}
|
||||
|
||||
void qsort_TYPE_big(TYPE* restrict A_in, int32_t* restrict iorder, int32_t isize) {
|
||||
struct TYPE_comp_big* A = malloc(isize * sizeof(struct TYPE_comp_big));
|
||||
if (A == NULL) return;
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A[i].x = A_in[i];
|
||||
A[i].i = iorder[i];
|
||||
}
|
||||
|
||||
qsort( (void*) A, (size_t) isize, sizeof(struct TYPE_comp_big), compare_TYPE_big);
|
||||
|
||||
for (int i=0 ; i<isize ; ++i) {
|
||||
A_in[i] = A[i].x;
|
||||
iorder[i] = A[i].i;
|
||||
}
|
||||
free(A);
|
||||
}
|
||||
|
||||
void qsort_TYPE_noidx_big(TYPE* A, int32_t isize) {
|
||||
qsort( (void*) A, (size_t) isize, sizeof(TYPE), compare_TYPE_big);
|
||||
}
|
||||
#+END_SRC
|
||||
|
||||
* Fortran template
|
||||
|
||||
#+NAME:f_template
|
||||
#+BEGIN_SRC f90
|
||||
subroutine Lsort_big_c(A, iorder, isize) bind(C, name="qsort_TYPE_big")
|
||||
use iso_c_binding
|
||||
integer(c_int32_t), value :: isize
|
||||
integer(c_int32_t) :: iorder(isize)
|
||||
real (c_TYPE) :: A(isize)
|
||||
end subroutine Lsort_big_c
|
||||
|
||||
subroutine Lsort_noidx_big_c(A, isize) bind(C, name="qsort_TYPE_noidx_big")
|
||||
use iso_c_binding
|
||||
integer(c_int32_t), value :: isize
|
||||
real (c_TYPE) :: A(isize)
|
||||
end subroutine Lsort_noidx_big_c
|
||||
|
||||
#+END_SRC
|
||||
|
||||
#+NAME:f_template2
|
||||
#+BEGIN_SRC f90
|
||||
subroutine Lsort_big(A, iorder, isize)
|
||||
use qsort_module
|
||||
use iso_c_binding
|
||||
integer(c_int32_t) :: isize
|
||||
integer(c_int32_t) :: iorder(isize)
|
||||
real (c_TYPE) :: A(isize)
|
||||
call Lsort_big_c(A, iorder, isize)
|
||||
end subroutine Lsort_big
|
||||
|
||||
subroutine Lsort_noidx_big(A, isize)
|
||||
use iso_c_binding
|
||||
use qsort_module
|
||||
integer(c_int32_t) :: isize
|
||||
real (c_TYPE) :: A(isize)
|
||||
call Lsort_noidx_big_c(A, isize)
|
||||
end subroutine Lsort_noidx_big
|
||||
|
||||
#+END_SRC
|
||||
|
||||
* Python scripts for type replacements
|
||||
|
||||
#+NAME: replaced
|
||||
#+begin_src python :results output :noweb yes
|
||||
data = """
|
||||
<<c_template>>
|
||||
"""
|
||||
for typ in ["int16_t", "int32_t", "int64_t", "double", "float"]:
|
||||
print( data.replace("TYPE", typ).replace("_big", "") )
|
||||
print( data.replace("int32_t", "int64_t").replace("TYPE", typ) )
|
||||
#+end_src
|
||||
|
||||
#+NAME: replaced_f
|
||||
#+begin_src python :results output :noweb yes
|
||||
data = """
|
||||
<<f_template>>
|
||||
"""
|
||||
c1 = {
|
||||
"int16_t": "i2",
|
||||
"int32_t": "i",
|
||||
"int64_t": "i8",
|
||||
"double": "d",
|
||||
"float": ""
|
||||
}
|
||||
c2 = {
|
||||
"int16_t": "integer",
|
||||
"int32_t": "integer",
|
||||
"int64_t": "integer",
|
||||
"double": "real",
|
||||
"float": "real"
|
||||
}
|
||||
|
||||
for typ in ["int16_t", "int32_t", "int64_t", "double", "float"]:
|
||||
print( data.replace("real",c2[typ]).replace("L",c1[typ]).replace("TYPE", typ).replace("_big", "") )
|
||||
print( data.replace("real",c2[typ]).replace("L",c1[typ]).replace("int32_t", "int64_t").replace("TYPE", typ) )
|
||||
#+end_src
|
||||
|
||||
#+NAME: replaced_f2
|
||||
#+begin_src python :results output :noweb yes
|
||||
data = """
|
||||
<<f_template2>>
|
||||
"""
|
||||
c1 = {
|
||||
"int16_t": "i2",
|
||||
"int32_t": "i",
|
||||
"int64_t": "i8",
|
||||
"double": "d",
|
||||
"float": ""
|
||||
}
|
||||
c2 = {
|
||||
"int16_t": "integer",
|
||||
"int32_t": "integer",
|
||||
"int64_t": "integer",
|
||||
"double": "real",
|
||||
"float": "real"
|
||||
}
|
||||
|
||||
for typ in ["int16_t", "int32_t", "int64_t", "double", "float"]:
|
||||
print( data.replace("real",c2[typ]).replace("L",c1[typ]).replace("TYPE", typ).replace("_big", "") )
|
||||
print( data.replace("real",c2[typ]).replace("L",c1[typ]).replace("int32_t", "int64_t").replace("TYPE", typ) )
|
||||
#+end_src
|
||||
|
||||
* Generated C file
|
||||
|
||||
#+BEGIN_SRC c :comments link :tangle qsort.c :noweb yes
|
||||
#include <stdlib.h>
|
||||
#include <stdint.h>
|
||||
<<replaced()>>
|
||||
#+END_SRC
|
||||
|
||||
* Generated Fortran file
|
||||
|
||||
#+BEGIN_SRC f90 :tangle qsort_module.f90 :noweb yes
|
||||
module qsort_module
|
||||
use iso_c_binding
|
||||
|
||||
interface
|
||||
<<replaced_f()>>
|
||||
end interface
|
||||
|
||||
end module qsort_module
|
||||
|
||||
<<replaced_f2()>>
|
||||
|
||||
#+END_SRC
|
||||
|
||||
347
src/utils/qsort_module.f90
Normal file
347
src/utils/qsort_module.f90
Normal file
@ -0,0 +1,347 @@
|
||||
module qsort_module
|
||||
use iso_c_binding
|
||||
|
||||
interface
|
||||
|
||||
subroutine i2sort_c(A, iorder, isize) bind(C, name="qsort_int16_t")
|
||||
use iso_c_binding
|
||||
integer(c_int32_t), value :: isize
|
||||
integer(c_int32_t) :: iorder(isize)
|
||||
integer (c_int16_t) :: A(isize)
|
||||
end subroutine i2sort_c
|
||||
|
||||
subroutine i2sort_noidx_c(A, isize) bind(C, name="qsort_int16_t_noidx")
|
||||
use iso_c_binding
|
||||
integer(c_int32_t), value :: isize
|
||||
integer (c_int16_t) :: A(isize)
|
||||
end subroutine i2sort_noidx_c
|
||||
|
||||
|
||||
|
||||
subroutine i2sort_big_c(A, iorder, isize) bind(C, name="qsort_int16_t_big")
|
||||
use iso_c_binding
|
||||
integer(c_int64_t), value :: isize
|
||||
integer(c_int64_t) :: iorder(isize)
|
||||
integer (c_int16_t) :: A(isize)
|
||||
end subroutine i2sort_big_c
|
||||
|
||||
subroutine i2sort_noidx_big_c(A, isize) bind(C, name="qsort_int16_t_noidx_big")
|
||||
use iso_c_binding
|
||||
integer(c_int64_t), value :: isize
|
||||
integer (c_int16_t) :: A(isize)
|
||||
end subroutine i2sort_noidx_big_c
|
||||
|
||||
|
||||
|
||||
subroutine isort_c(A, iorder, isize) bind(C, name="qsort_int32_t")
|
||||
use iso_c_binding
|
||||
integer(c_int32_t), value :: isize
|
||||
integer(c_int32_t) :: iorder(isize)
|
||||
integer (c_int32_t) :: A(isize)
|
||||
end subroutine isort_c
|
||||
|
||||
subroutine isort_noidx_c(A, isize) bind(C, name="qsort_int32_t_noidx")
|
||||
use iso_c_binding
|
||||
integer(c_int32_t), value :: isize
|
||||
integer (c_int32_t) :: A(isize)
|
||||
end subroutine isort_noidx_c
|
||||
|
||||
|
||||
|
||||
subroutine isort_big_c(A, iorder, isize) bind(C, name="qsort_int32_t_big")
|
||||
use iso_c_binding
|
||||
integer(c_int64_t), value :: isize
|
||||
integer(c_int64_t) :: iorder(isize)
|
||||
integer (c_int32_t) :: A(isize)
|
||||
end subroutine isort_big_c
|
||||
|
||||
subroutine isort_noidx_big_c(A, isize) bind(C, name="qsort_int32_t_noidx_big")
|
||||
use iso_c_binding
|
||||
integer(c_int64_t), value :: isize
|
||||
integer (c_int32_t) :: A(isize)
|
||||
end subroutine isort_noidx_big_c
|
||||
|
||||
|
||||
|
||||
subroutine i8sort_c(A, iorder, isize) bind(C, name="qsort_int64_t")
|
||||
use iso_c_binding
|
||||
integer(c_int32_t), value :: isize
|
||||
integer(c_int32_t) :: iorder(isize)
|
||||
integer (c_int64_t) :: A(isize)
|
||||
end subroutine i8sort_c
|
||||
|
||||
subroutine i8sort_noidx_c(A, isize) bind(C, name="qsort_int64_t_noidx")
|
||||
use iso_c_binding
|
||||
integer(c_int32_t), value :: isize
|
||||
integer (c_int64_t) :: A(isize)
|
||||
end subroutine i8sort_noidx_c
|
||||
|
||||
|
||||
|
||||
subroutine i8sort_big_c(A, iorder, isize) bind(C, name="qsort_int64_t_big")
|
||||
use iso_c_binding
|
||||
integer(c_int64_t), value :: isize
|
||||
integer(c_int64_t) :: iorder(isize)
|
||||
integer (c_int64_t) :: A(isize)
|
||||
end subroutine i8sort_big_c
|
||||
|
||||
subroutine i8sort_noidx_big_c(A, isize) bind(C, name="qsort_int64_t_noidx_big")
|
||||
use iso_c_binding
|
||||
integer(c_int64_t), value :: isize
|
||||
integer (c_int64_t) :: A(isize)
|
||||
end subroutine i8sort_noidx_big_c
|
||||
|
||||
|
||||
|
||||
subroutine dsort_c(A, iorder, isize) bind(C, name="qsort_double")
|
||||
use iso_c_binding
|
||||
integer(c_int32_t), value :: isize
|
||||
integer(c_int32_t) :: iorder(isize)
|
||||
real (c_double) :: A(isize)
|
||||
end subroutine dsort_c
|
||||
|
||||
subroutine dsort_noidx_c(A, isize) bind(C, name="qsort_double_noidx")
|
||||
use iso_c_binding
|
||||
integer(c_int32_t), value :: isize
|
||||
real (c_double) :: A(isize)
|
||||
end subroutine dsort_noidx_c
|
||||
|
||||
|
||||
|
||||
subroutine dsort_big_c(A, iorder, isize) bind(C, name="qsort_double_big")
|
||||
use iso_c_binding
|
||||
integer(c_int64_t), value :: isize
|
||||
integer(c_int64_t) :: iorder(isize)
|
||||
real (c_double) :: A(isize)
|
||||
end subroutine dsort_big_c
|
||||
|
||||
subroutine dsort_noidx_big_c(A, isize) bind(C, name="qsort_double_noidx_big")
|
||||
use iso_c_binding
|
||||
integer(c_int64_t), value :: isize
|
||||
real (c_double) :: A(isize)
|
||||
end subroutine dsort_noidx_big_c
|
||||
|
||||
|
||||
|
||||
subroutine sort_c(A, iorder, isize) bind(C, name="qsort_float")
|
||||
use iso_c_binding
|
||||
integer(c_int32_t), value :: isize
|
||||
integer(c_int32_t) :: iorder(isize)
|
||||
real (c_float) :: A(isize)
|
||||
end subroutine sort_c
|
||||
|
||||
subroutine sort_noidx_c(A, isize) bind(C, name="qsort_float_noidx")
|
||||
use iso_c_binding
|
||||
integer(c_int32_t), value :: isize
|
||||
real (c_float) :: A(isize)
|
||||
end subroutine sort_noidx_c
|
||||
|
||||
|
||||
|
||||
subroutine sort_big_c(A, iorder, isize) bind(C, name="qsort_float_big")
|
||||
use iso_c_binding
|
||||
integer(c_int64_t), value :: isize
|
||||
integer(c_int64_t) :: iorder(isize)
|
||||
real (c_float) :: A(isize)
|
||||
end subroutine sort_big_c
|
||||
|
||||
subroutine sort_noidx_big_c(A, isize) bind(C, name="qsort_float_noidx_big")
|
||||
use iso_c_binding
|
||||
integer(c_int64_t), value :: isize
|
||||
real (c_float) :: A(isize)
|
||||
end subroutine sort_noidx_big_c
|
||||
|
||||
|
||||
|
||||
end interface
|
||||
|
||||
end module qsort_module
|
||||
|
||||
|
||||
subroutine i2sort(A, iorder, isize)
|
||||
use qsort_module
|
||||
use iso_c_binding
|
||||
integer(c_int32_t) :: isize
|
||||
integer(c_int32_t) :: iorder(isize)
|
||||
integer (c_int16_t) :: A(isize)
|
||||
call i2sort_c(A, iorder, isize)
|
||||
end subroutine i2sort
|
||||
|
||||
subroutine i2sort_noidx(A, isize)
|
||||
use iso_c_binding
|
||||
use qsort_module
|
||||
integer(c_int32_t) :: isize
|
||||
integer (c_int16_t) :: A(isize)
|
||||
call i2sort_noidx_c(A, isize)
|
||||
end subroutine i2sort_noidx
|
||||
|
||||
|
||||
|
||||
subroutine i2sort_big(A, iorder, isize)
|
||||
use qsort_module
|
||||
use iso_c_binding
|
||||
integer(c_int64_t) :: isize
|
||||
integer(c_int64_t) :: iorder(isize)
|
||||
integer (c_int16_t) :: A(isize)
|
||||
call i2sort_big_c(A, iorder, isize)
|
||||
end subroutine i2sort_big
|
||||
|
||||
subroutine i2sort_noidx_big(A, isize)
|
||||
use iso_c_binding
|
||||
use qsort_module
|
||||
integer(c_int64_t) :: isize
|
||||
integer (c_int16_t) :: A(isize)
|
||||
call i2sort_noidx_big_c(A, isize)
|
||||
end subroutine i2sort_noidx_big
|
||||
|
||||
|
||||
|
||||
subroutine isort(A, iorder, isize)
|
||||
use qsort_module
|
||||
use iso_c_binding
|
||||
integer(c_int32_t) :: isize
|
||||
integer(c_int32_t) :: iorder(isize)
|
||||
integer (c_int32_t) :: A(isize)
|
||||
call isort_c(A, iorder, isize)
|
||||
end subroutine isort
|
||||
|
||||
subroutine isort_noidx(A, isize)
|
||||
use iso_c_binding
|
||||
use qsort_module
|
||||
integer(c_int32_t) :: isize
|
||||
integer (c_int32_t) :: A(isize)
|
||||
call isort_noidx_c(A, isize)
|
||||
end subroutine isort_noidx
|
||||
|
||||
|
||||
|
||||
subroutine isort_big(A, iorder, isize)
|
||||
use qsort_module
|
||||
use iso_c_binding
|
||||
integer(c_int64_t) :: isize
|
||||
integer(c_int64_t) :: iorder(isize)
|
||||
integer (c_int32_t) :: A(isize)
|
||||
call isort_big_c(A, iorder, isize)
|
||||
end subroutine isort_big
|
||||
|
||||
subroutine isort_noidx_big(A, isize)
|
||||
use iso_c_binding
|
||||
use qsort_module
|
||||
integer(c_int64_t) :: isize
|
||||
integer (c_int32_t) :: A(isize)
|
||||
call isort_noidx_big_c(A, isize)
|
||||
end subroutine isort_noidx_big
|
||||
|
||||
|
||||
|
||||
subroutine i8sort(A, iorder, isize)
|
||||
use qsort_module
|
||||
use iso_c_binding
|
||||
integer(c_int32_t) :: isize
|
||||
integer(c_int32_t) :: iorder(isize)
|
||||
integer (c_int64_t) :: A(isize)
|
||||
call i8sort_c(A, iorder, isize)
|
||||
end subroutine i8sort
|
||||
|
||||
subroutine i8sort_noidx(A, isize)
|
||||
use iso_c_binding
|
||||
use qsort_module
|
||||
integer(c_int32_t) :: isize
|
||||
integer (c_int64_t) :: A(isize)
|
||||
call i8sort_noidx_c(A, isize)
|
||||
end subroutine i8sort_noidx
|
||||
|
||||
|
||||
|
||||
subroutine i8sort_big(A, iorder, isize)
|
||||
use qsort_module
|
||||
use iso_c_binding
|
||||
integer(c_int64_t) :: isize
|
||||
integer(c_int64_t) :: iorder(isize)
|
||||
integer (c_int64_t) :: A(isize)
|
||||
call i8sort_big_c(A, iorder, isize)
|
||||
end subroutine i8sort_big
|
||||
|
||||
subroutine i8sort_noidx_big(A, isize)
|
||||
use iso_c_binding
|
||||
use qsort_module
|
||||
integer(c_int64_t) :: isize
|
||||
integer (c_int64_t) :: A(isize)
|
||||
call i8sort_noidx_big_c(A, isize)
|
||||
end subroutine i8sort_noidx_big
|
||||
|
||||
|
||||
|
||||
subroutine dsort(A, iorder, isize)
|
||||
use qsort_module
|
||||
use iso_c_binding
|
||||
integer(c_int32_t) :: isize
|
||||
integer(c_int32_t) :: iorder(isize)
|
||||
real (c_double) :: A(isize)
|
||||
call dsort_c(A, iorder, isize)
|
||||
end subroutine dsort
|
||||
|
||||
subroutine dsort_noidx(A, isize)
|
||||
use iso_c_binding
|
||||
use qsort_module
|
||||
integer(c_int32_t) :: isize
|
||||
real (c_double) :: A(isize)
|
||||
call dsort_noidx_c(A, isize)
|
||||
end subroutine dsort_noidx
|
||||
|
||||
|
||||
|
||||
subroutine dsort_big(A, iorder, isize)
|
||||
use qsort_module
|
||||
use iso_c_binding
|
||||
integer(c_int64_t) :: isize
|
||||
integer(c_int64_t) :: iorder(isize)
|
||||
real (c_double) :: A(isize)
|
||||
call dsort_big_c(A, iorder, isize)
|
||||
end subroutine dsort_big
|
||||
|
||||
subroutine dsort_noidx_big(A, isize)
|
||||
use iso_c_binding
|
||||
use qsort_module
|
||||
integer(c_int64_t) :: isize
|
||||
real (c_double) :: A(isize)
|
||||
call dsort_noidx_big_c(A, isize)
|
||||
end subroutine dsort_noidx_big
|
||||
|
||||
|
||||
|
||||
subroutine sort(A, iorder, isize)
|
||||
use qsort_module
|
||||
use iso_c_binding
|
||||
integer(c_int32_t) :: isize
|
||||
integer(c_int32_t) :: iorder(isize)
|
||||
real (c_float) :: A(isize)
|
||||
call sort_c(A, iorder, isize)
|
||||
end subroutine sort
|
||||
|
||||
subroutine sort_noidx(A, isize)
|
||||
use iso_c_binding
|
||||
use qsort_module
|
||||
integer(c_int32_t) :: isize
|
||||
real (c_float) :: A(isize)
|
||||
call sort_noidx_c(A, isize)
|
||||
end subroutine sort_noidx
|
||||
|
||||
|
||||
|
||||
subroutine sort_big(A, iorder, isize)
|
||||
use qsort_module
|
||||
use iso_c_binding
|
||||
integer(c_int64_t) :: isize
|
||||
integer(c_int64_t) :: iorder(isize)
|
||||
real (c_float) :: A(isize)
|
||||
call sort_big_c(A, iorder, isize)
|
||||
end subroutine sort_big
|
||||
|
||||
subroutine sort_noidx_big(A, isize)
|
||||
use iso_c_binding
|
||||
use qsort_module
|
||||
integer(c_int64_t) :: isize
|
||||
real (c_float) :: A(isize)
|
||||
call sort_noidx_big_c(A, isize)
|
||||
end subroutine sort_noidx_big
|
||||
@ -1,222 +1,4 @@
|
||||
BEGIN_TEMPLATE
|
||||
subroutine insertion_$Xsort (x,iorder,isize)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Sort array x(isize) using the insertion sort algorithm.
|
||||
! iorder in input should be (1,2,3,...,isize), and in output
|
||||
! contains the new order of the elements.
|
||||
END_DOC
|
||||
integer,intent(in) :: isize
|
||||
$type,intent(inout) :: x(isize)
|
||||
integer,intent(inout) :: iorder(isize)
|
||||
$type :: xtmp
|
||||
integer :: i, i0, j, jmax
|
||||
|
||||
do i=2,isize
|
||||
xtmp = x(i)
|
||||
i0 = iorder(i)
|
||||
j=i-1
|
||||
do while (j>0)
|
||||
if ((x(j) <= xtmp)) exit
|
||||
x(j+1) = x(j)
|
||||
iorder(j+1) = iorder(j)
|
||||
j=j-1
|
||||
enddo
|
||||
x(j+1) = xtmp
|
||||
iorder(j+1) = i0
|
||||
enddo
|
||||
end subroutine insertion_$Xsort
|
||||
|
||||
subroutine quick_$Xsort(x, iorder, isize)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Sort array x(isize) using the quicksort algorithm.
|
||||
! iorder in input should be (1,2,3,...,isize), and in output
|
||||
! contains the new order of the elements.
|
||||
END_DOC
|
||||
integer,intent(in) :: isize
|
||||
$type,intent(inout) :: x(isize)
|
||||
integer,intent(inout) :: iorder(isize)
|
||||
integer, external :: omp_get_num_threads
|
||||
call rec_$X_quicksort(x,iorder,isize,1,isize,nproc)
|
||||
end
|
||||
|
||||
recursive subroutine rec_$X_quicksort(x, iorder, isize, first, last, level)
|
||||
implicit none
|
||||
integer, intent(in) :: isize, first, last, level
|
||||
integer,intent(inout) :: iorder(isize)
|
||||
$type, intent(inout) :: x(isize)
|
||||
$type :: c, tmp
|
||||
integer :: itmp
|
||||
integer :: i, j
|
||||
|
||||
if(isize<2)return
|
||||
|
||||
c = x( shiftr(first+last,1) )
|
||||
i = first
|
||||
j = last
|
||||
do
|
||||
do while (x(i) < c)
|
||||
i=i+1
|
||||
end do
|
||||
do while (c < x(j))
|
||||
j=j-1
|
||||
end do
|
||||
if (i >= j) exit
|
||||
tmp = x(i)
|
||||
x(i) = x(j)
|
||||
x(j) = tmp
|
||||
itmp = iorder(i)
|
||||
iorder(i) = iorder(j)
|
||||
iorder(j) = itmp
|
||||
i=i+1
|
||||
j=j-1
|
||||
enddo
|
||||
if ( ((i-first <= 10000).and.(last-j <= 10000)).or.(level<=0) ) then
|
||||
if (first < i-1) then
|
||||
call rec_$X_quicksort(x, iorder, isize, first, i-1,level/2)
|
||||
endif
|
||||
if (j+1 < last) then
|
||||
call rec_$X_quicksort(x, iorder, isize, j+1, last,level/2)
|
||||
endif
|
||||
else
|
||||
if (first < i-1) then
|
||||
call rec_$X_quicksort(x, iorder, isize, first, i-1,level/2)
|
||||
endif
|
||||
if (j+1 < last) then
|
||||
call rec_$X_quicksort(x, iorder, isize, j+1, last,level/2)
|
||||
endif
|
||||
endif
|
||||
end
|
||||
|
||||
subroutine heap_$Xsort(x,iorder,isize)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Sort array x(isize) using the heap sort algorithm.
|
||||
! iorder in input should be (1,2,3,...,isize), and in output
|
||||
! contains the new order of the elements.
|
||||
END_DOC
|
||||
integer,intent(in) :: isize
|
||||
$type,intent(inout) :: x(isize)
|
||||
integer,intent(inout) :: iorder(isize)
|
||||
|
||||
integer :: i, k, j, l, i0
|
||||
$type :: xtemp
|
||||
|
||||
l = isize/2+1
|
||||
k = isize
|
||||
do while (.True.)
|
||||
if (l>1) then
|
||||
l=l-1
|
||||
xtemp = x(l)
|
||||
i0 = iorder(l)
|
||||
else
|
||||
xtemp = x(k)
|
||||
i0 = iorder(k)
|
||||
x(k) = x(1)
|
||||
iorder(k) = iorder(1)
|
||||
k = k-1
|
||||
if (k == 1) then
|
||||
x(1) = xtemp
|
||||
iorder(1) = i0
|
||||
exit
|
||||
endif
|
||||
endif
|
||||
i=l
|
||||
j = shiftl(l,1)
|
||||
do while (j<k)
|
||||
if ( x(j) < x(j+1) ) then
|
||||
j=j+1
|
||||
endif
|
||||
if (xtemp < x(j)) then
|
||||
x(i) = x(j)
|
||||
iorder(i) = iorder(j)
|
||||
i = j
|
||||
j = shiftl(j,1)
|
||||
else
|
||||
j = k+1
|
||||
endif
|
||||
enddo
|
||||
if (j==k) then
|
||||
if (xtemp < x(j)) then
|
||||
x(i) = x(j)
|
||||
iorder(i) = iorder(j)
|
||||
i = j
|
||||
j = shiftl(j,1)
|
||||
else
|
||||
j = k+1
|
||||
endif
|
||||
endif
|
||||
x(i) = xtemp
|
||||
iorder(i) = i0
|
||||
enddo
|
||||
end subroutine heap_$Xsort
|
||||
|
||||
subroutine heap_$Xsort_big(x,iorder,isize)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Sort array x(isize) using the heap sort algorithm.
|
||||
! iorder in input should be (1,2,3,...,isize), and in output
|
||||
! contains the new order of the elements.
|
||||
! This is a version for very large arrays where the indices need
|
||||
! to be in integer*8 format
|
||||
END_DOC
|
||||
integer*8,intent(in) :: isize
|
||||
$type,intent(inout) :: x(isize)
|
||||
integer*8,intent(inout) :: iorder(isize)
|
||||
|
||||
integer*8 :: i, k, j, l, i0
|
||||
$type :: xtemp
|
||||
|
||||
l = isize/2+1
|
||||
k = isize
|
||||
do while (.True.)
|
||||
if (l>1) then
|
||||
l=l-1
|
||||
xtemp = x(l)
|
||||
i0 = iorder(l)
|
||||
else
|
||||
xtemp = x(k)
|
||||
i0 = iorder(k)
|
||||
x(k) = x(1)
|
||||
iorder(k) = iorder(1)
|
||||
k = k-1
|
||||
if (k == 1) then
|
||||
x(1) = xtemp
|
||||
iorder(1) = i0
|
||||
exit
|
||||
endif
|
||||
endif
|
||||
i=l
|
||||
j = shiftl(l,1)
|
||||
do while (j<k)
|
||||
if ( x(j) < x(j+1) ) then
|
||||
j=j+1
|
||||
endif
|
||||
if (xtemp < x(j)) then
|
||||
x(i) = x(j)
|
||||
iorder(i) = iorder(j)
|
||||
i = j
|
||||
j = shiftl(j,1)
|
||||
else
|
||||
j = k+1
|
||||
endif
|
||||
enddo
|
||||
if (j==k) then
|
||||
if (xtemp < x(j)) then
|
||||
x(i) = x(j)
|
||||
iorder(i) = iorder(j)
|
||||
i = j
|
||||
j = shiftl(j,1)
|
||||
else
|
||||
j = k+1
|
||||
endif
|
||||
endif
|
||||
x(i) = xtemp
|
||||
iorder(i) = i0
|
||||
enddo
|
||||
|
||||
end subroutine heap_$Xsort_big
|
||||
|
||||
subroutine sorted_$Xnumber(x,isize,n)
|
||||
implicit none
|
||||
@ -250,222 +32,6 @@ SUBST [ X, type ]
|
||||
END_TEMPLATE
|
||||
|
||||
|
||||
!---------------------- INTEL
|
||||
IRP_IF INTEL
|
||||
|
||||
BEGIN_TEMPLATE
|
||||
subroutine $Xsort(x,iorder,isize)
|
||||
use intel
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Sort array x(isize).
|
||||
! iorder in input should be (1,2,3,...,isize), and in output
|
||||
! contains the new order of the elements.
|
||||
END_DOC
|
||||
integer,intent(in) :: isize
|
||||
$type,intent(inout) :: x(isize)
|
||||
integer,intent(inout) :: iorder(isize)
|
||||
integer :: n
|
||||
character, allocatable :: tmp(:)
|
||||
if (isize < 2) return
|
||||
call ippsSortRadixIndexGetBufferSize(isize, $ippsz, n)
|
||||
allocate(tmp(n))
|
||||
call ippsSortRadixIndexAscend_$ityp(x, $n, iorder, isize, tmp)
|
||||
deallocate(tmp)
|
||||
iorder(1:isize) = iorder(1:isize)+1
|
||||
call $Xset_order(x,iorder,isize)
|
||||
end
|
||||
|
||||
subroutine $Xsort_noidx(x,isize)
|
||||
use intel
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Sort array x(isize).
|
||||
! iorder in input should be (1,2,3,...,isize), and in output
|
||||
! contains the new order of the elements.
|
||||
END_DOC
|
||||
integer,intent(in) :: isize
|
||||
$type,intent(inout) :: x(isize)
|
||||
integer :: n
|
||||
character, allocatable :: tmp(:)
|
||||
if (isize < 2) return
|
||||
call ippsSortRadixIndexGetBufferSize(isize, $ippsz, n)
|
||||
allocate(tmp(n))
|
||||
call ippsSortRadixAscend_$ityp_I(x, isize, tmp)
|
||||
deallocate(tmp)
|
||||
end
|
||||
|
||||
SUBST [ X, type, ityp, n, ippsz ]
|
||||
; real ; 32f ; 4 ; 13 ;;
|
||||
i ; integer ; 32s ; 4 ; 11 ;;
|
||||
i2 ; integer*2 ; 16s ; 2 ; 7 ;;
|
||||
END_TEMPLATE
|
||||
|
||||
BEGIN_TEMPLATE
|
||||
|
||||
subroutine $Xsort(x,iorder,isize)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Sort array x(isize).
|
||||
! iorder in input should be (1,2,3,...,isize), and in output
|
||||
! contains the new order of the elements.
|
||||
END_DOC
|
||||
integer,intent(in) :: isize
|
||||
$type,intent(inout) :: x(isize)
|
||||
integer,intent(inout) :: iorder(isize)
|
||||
integer :: n
|
||||
if (isize < 2) then
|
||||
return
|
||||
endif
|
||||
! call sorted_$Xnumber(x,isize,n)
|
||||
! if (isize == n) then
|
||||
! return
|
||||
! endif
|
||||
if ( isize < 32) then
|
||||
call insertion_$Xsort(x,iorder,isize)
|
||||
else
|
||||
! call heap_$Xsort(x,iorder,isize)
|
||||
call quick_$Xsort(x,iorder,isize)
|
||||
endif
|
||||
end subroutine $Xsort
|
||||
|
||||
SUBST [ X, type ]
|
||||
d ; double precision ;;
|
||||
END_TEMPLATE
|
||||
|
||||
BEGIN_TEMPLATE
|
||||
|
||||
subroutine $Xsort(x,iorder,isize)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Sort array x(isize).
|
||||
! iorder in input should be (1,2,3,...,isize), and in output
|
||||
! contains the new order of the elements.
|
||||
END_DOC
|
||||
integer,intent(in) :: isize
|
||||
$type,intent(inout) :: x(isize)
|
||||
integer,intent(inout) :: iorder(isize)
|
||||
integer :: n
|
||||
if (isize < 2) then
|
||||
return
|
||||
endif
|
||||
call sorted_$Xnumber(x,isize,n)
|
||||
if (isize == n) then
|
||||
return
|
||||
endif
|
||||
if ( isize < 32) then
|
||||
call insertion_$Xsort(x,iorder,isize)
|
||||
else
|
||||
! call $Xradix_sort(x,iorder,isize,-1)
|
||||
call quick_$Xsort(x,iorder,isize)
|
||||
endif
|
||||
end subroutine $Xsort
|
||||
|
||||
SUBST [ X, type ]
|
||||
i8 ; integer*8 ;;
|
||||
END_TEMPLATE
|
||||
|
||||
!---------------------- END INTEL
|
||||
IRP_ELSE
|
||||
!---------------------- NON-INTEL
|
||||
BEGIN_TEMPLATE
|
||||
|
||||
subroutine $Xsort_noidx(x,isize)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Sort array x(isize).
|
||||
END_DOC
|
||||
integer,intent(in) :: isize
|
||||
$type,intent(inout) :: x(isize)
|
||||
integer, allocatable :: iorder(:)
|
||||
integer :: i
|
||||
allocate(iorder(isize))
|
||||
do i=1,isize
|
||||
iorder(i)=i
|
||||
enddo
|
||||
call $Xsort(x,iorder,isize)
|
||||
deallocate(iorder)
|
||||
end subroutine $Xsort_noidx
|
||||
|
||||
SUBST [ X, type ]
|
||||
; real ;;
|
||||
d ; double precision ;;
|
||||
i ; integer ;;
|
||||
i8 ; integer*8 ;;
|
||||
i2 ; integer*2 ;;
|
||||
END_TEMPLATE
|
||||
|
||||
BEGIN_TEMPLATE
|
||||
|
||||
subroutine $Xsort(x,iorder,isize)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Sort array x(isize).
|
||||
! iorder in input should be (1,2,3,...,isize), and in output
|
||||
! contains the new order of the elements.
|
||||
END_DOC
|
||||
integer,intent(in) :: isize
|
||||
$type,intent(inout) :: x(isize)
|
||||
integer,intent(inout) :: iorder(isize)
|
||||
integer :: n
|
||||
if (isize < 2) then
|
||||
return
|
||||
endif
|
||||
! call sorted_$Xnumber(x,isize,n)
|
||||
! if (isize == n) then
|
||||
! return
|
||||
! endif
|
||||
if ( isize < 32) then
|
||||
call insertion_$Xsort(x,iorder,isize)
|
||||
else
|
||||
! call heap_$Xsort(x,iorder,isize)
|
||||
call quick_$Xsort(x,iorder,isize)
|
||||
endif
|
||||
end subroutine $Xsort
|
||||
|
||||
SUBST [ X, type ]
|
||||
; real ;;
|
||||
d ; double precision ;;
|
||||
END_TEMPLATE
|
||||
|
||||
BEGIN_TEMPLATE
|
||||
|
||||
subroutine $Xsort(x,iorder,isize)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Sort array x(isize).
|
||||
! iorder in input should be (1,2,3,...,isize), and in output
|
||||
! contains the new order of the elements.
|
||||
END_DOC
|
||||
integer,intent(in) :: isize
|
||||
$type,intent(inout) :: x(isize)
|
||||
integer,intent(inout) :: iorder(isize)
|
||||
integer :: n
|
||||
if (isize < 2) then
|
||||
return
|
||||
endif
|
||||
call sorted_$Xnumber(x,isize,n)
|
||||
if (isize == n) then
|
||||
return
|
||||
endif
|
||||
if ( isize < 32) then
|
||||
call insertion_$Xsort(x,iorder,isize)
|
||||
else
|
||||
! call $Xradix_sort(x,iorder,isize,-1)
|
||||
call quick_$Xsort(x,iorder,isize)
|
||||
endif
|
||||
end subroutine $Xsort
|
||||
|
||||
SUBST [ X, type ]
|
||||
i ; integer ;;
|
||||
i8 ; integer*8 ;;
|
||||
i2 ; integer*2 ;;
|
||||
END_TEMPLATE
|
||||
|
||||
IRP_ENDIF
|
||||
!---------------------- END NON-INTEL
|
||||
|
||||
|
||||
|
||||
BEGIN_TEMPLATE
|
||||
subroutine $Xset_order(x,iorder,isize)
|
||||
@ -491,47 +57,6 @@ BEGIN_TEMPLATE
|
||||
deallocate(xtmp)
|
||||
end
|
||||
|
||||
SUBST [ X, type ]
|
||||
; real ;;
|
||||
d ; double precision ;;
|
||||
i ; integer ;;
|
||||
i8; integer*8 ;;
|
||||
i2; integer*2 ;;
|
||||
END_TEMPLATE
|
||||
|
||||
|
||||
BEGIN_TEMPLATE
|
||||
subroutine insertion_$Xsort_big (x,iorder,isize)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Sort array x(isize) using the insertion sort algorithm.
|
||||
! iorder in input should be (1,2,3,...,isize), and in output
|
||||
! contains the new order of the elements.
|
||||
! This is a version for very large arrays where the indices need
|
||||
! to be in integer*8 format
|
||||
END_DOC
|
||||
integer*8,intent(in) :: isize
|
||||
$type,intent(inout) :: x(isize)
|
||||
integer*8,intent(inout) :: iorder(isize)
|
||||
$type :: xtmp
|
||||
integer*8 :: i, i0, j, jmax
|
||||
|
||||
do i=2_8,isize
|
||||
xtmp = x(i)
|
||||
i0 = iorder(i)
|
||||
j = i-1_8
|
||||
do while (j>0_8)
|
||||
if (x(j)<=xtmp) exit
|
||||
x(j+1_8) = x(j)
|
||||
iorder(j+1_8) = iorder(j)
|
||||
j = j-1_8
|
||||
enddo
|
||||
x(j+1_8) = xtmp
|
||||
iorder(j+1_8) = i0
|
||||
enddo
|
||||
|
||||
end subroutine insertion_$Xsort_big
|
||||
|
||||
subroutine $Xset_order_big(x,iorder,isize)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
@ -565,223 +90,3 @@ SUBST [ X, type ]
|
||||
END_TEMPLATE
|
||||
|
||||
|
||||
BEGIN_TEMPLATE
|
||||
|
||||
recursive subroutine $Xradix_sort$big(x,iorder,isize,iradix)
|
||||
implicit none
|
||||
|
||||
BEGIN_DOC
|
||||
! Sort integer array x(isize) using the radix sort algorithm.
|
||||
! iorder in input should be (1,2,3,...,isize), and in output
|
||||
! contains the new order of the elements.
|
||||
! iradix should be -1 in input.
|
||||
END_DOC
|
||||
integer*$int_type, intent(in) :: isize
|
||||
integer*$int_type, intent(inout) :: iorder(isize)
|
||||
integer*$type, intent(inout) :: x(isize)
|
||||
integer, intent(in) :: iradix
|
||||
integer :: iradix_new
|
||||
integer*$type, allocatable :: x2(:), x1(:)
|
||||
integer*$type :: i4 ! data type
|
||||
integer*$int_type, allocatable :: iorder1(:),iorder2(:)
|
||||
integer*$int_type :: i0, i1, i2, i3, i ! index type
|
||||
integer*$type :: mask
|
||||
integer :: err
|
||||
!DIR$ ATTRIBUTES ALIGN : 128 :: iorder1,iorder2, x2, x1
|
||||
|
||||
if (isize < 2) then
|
||||
return
|
||||
endif
|
||||
|
||||
if (iradix == -1) then ! Sort Positive and negative
|
||||
|
||||
allocate(x1(isize),iorder1(isize), x2(isize),iorder2(isize),stat=err)
|
||||
if (err /= 0) then
|
||||
print *, irp_here, ': Unable to allocate arrays'
|
||||
stop
|
||||
endif
|
||||
|
||||
i1=1_$int_type
|
||||
i2=1_$int_type
|
||||
do i=1_$int_type,isize
|
||||
if (x(i) < 0_$type) then
|
||||
iorder1(i1) = iorder(i)
|
||||
x1(i1) = -x(i)
|
||||
i1 = i1+1_$int_type
|
||||
else
|
||||
iorder2(i2) = iorder(i)
|
||||
x2(i2) = x(i)
|
||||
i2 = i2+1_$int_type
|
||||
endif
|
||||
enddo
|
||||
i1=i1-1_$int_type
|
||||
i2=i2-1_$int_type
|
||||
|
||||
do i=1_$int_type,i2
|
||||
iorder(i1+i) = iorder2(i)
|
||||
x(i1+i) = x2(i)
|
||||
enddo
|
||||
deallocate(x2,iorder2,stat=err)
|
||||
if (err /= 0) then
|
||||
print *, irp_here, ': Unable to deallocate arrays x2, iorder2'
|
||||
stop
|
||||
endif
|
||||
|
||||
|
||||
if (i1 > 1_$int_type) then
|
||||
call $Xradix_sort$big(x1,iorder1,i1,-2)
|
||||
do i=1_$int_type,i1
|
||||
x(i) = -x1(1_$int_type+i1-i)
|
||||
iorder(i) = iorder1(1_$int_type+i1-i)
|
||||
enddo
|
||||
endif
|
||||
|
||||
if (i2>1_$int_type) then
|
||||
call $Xradix_sort$big(x(i1+1_$int_type),iorder(i1+1_$int_type),i2,-2)
|
||||
endif
|
||||
|
||||
deallocate(x1,iorder1,stat=err)
|
||||
if (err /= 0) then
|
||||
print *, irp_here, ': Unable to deallocate arrays x1, iorder1'
|
||||
stop
|
||||
endif
|
||||
return
|
||||
|
||||
else if (iradix == -2) then ! Positive
|
||||
|
||||
! Find most significant bit
|
||||
|
||||
i0 = 0_$int_type
|
||||
i4 = maxval(x)
|
||||
|
||||
iradix_new = max($integer_size-1-leadz(i4),1)
|
||||
mask = ibset(0_$type,iradix_new)
|
||||
|
||||
allocate(x1(isize),iorder1(isize), x2(isize),iorder2(isize),stat=err)
|
||||
if (err /= 0) then
|
||||
print *, irp_here, ': Unable to allocate arrays'
|
||||
stop
|
||||
endif
|
||||
|
||||
i1=1_$int_type
|
||||
i2=1_$int_type
|
||||
|
||||
do i=1_$int_type,isize
|
||||
if (iand(mask,x(i)) == 0_$type) then
|
||||
iorder1(i1) = iorder(i)
|
||||
x1(i1) = x(i)
|
||||
i1 = i1+1_$int_type
|
||||
else
|
||||
iorder2(i2) = iorder(i)
|
||||
x2(i2) = x(i)
|
||||
i2 = i2+1_$int_type
|
||||
endif
|
||||
enddo
|
||||
i1=i1-1_$int_type
|
||||
i2=i2-1_$int_type
|
||||
|
||||
do i=1_$int_type,i1
|
||||
iorder(i0+i) = iorder1(i)
|
||||
x(i0+i) = x1(i)
|
||||
enddo
|
||||
i0 = i0+i1
|
||||
i3 = i0
|
||||
deallocate(x1,iorder1,stat=err)
|
||||
if (err /= 0) then
|
||||
print *, irp_here, ': Unable to deallocate arrays x1, iorder1'
|
||||
stop
|
||||
endif
|
||||
|
||||
|
||||
do i=1_$int_type,i2
|
||||
iorder(i0+i) = iorder2(i)
|
||||
x(i0+i) = x2(i)
|
||||
enddo
|
||||
i0 = i0+i2
|
||||
deallocate(x2,iorder2,stat=err)
|
||||
if (err /= 0) then
|
||||
print *, irp_here, ': Unable to deallocate arrays x2, iorder2'
|
||||
stop
|
||||
endif
|
||||
|
||||
|
||||
if (i3>1_$int_type) then
|
||||
call $Xradix_sort$big(x,iorder,i3,iradix_new-1)
|
||||
endif
|
||||
|
||||
if (isize-i3>1_$int_type) then
|
||||
call $Xradix_sort$big(x(i3+1_$int_type),iorder(i3+1_$int_type),isize-i3,iradix_new-1)
|
||||
endif
|
||||
|
||||
return
|
||||
endif
|
||||
|
||||
ASSERT (iradix >= 0)
|
||||
|
||||
if (isize < 48) then
|
||||
call insertion_$Xsort$big(x,iorder,isize)
|
||||
return
|
||||
endif
|
||||
|
||||
|
||||
allocate(x2(isize),iorder2(isize),stat=err)
|
||||
if (err /= 0) then
|
||||
print *, irp_here, ': Unable to allocate arrays x1, iorder1'
|
||||
stop
|
||||
endif
|
||||
|
||||
|
||||
mask = ibset(0_$type,iradix)
|
||||
i0=1_$int_type
|
||||
i1=1_$int_type
|
||||
|
||||
do i=1_$int_type,isize
|
||||
if (iand(mask,x(i)) == 0_$type) then
|
||||
iorder(i0) = iorder(i)
|
||||
x(i0) = x(i)
|
||||
i0 = i0+1_$int_type
|
||||
else
|
||||
iorder2(i1) = iorder(i)
|
||||
x2(i1) = x(i)
|
||||
i1 = i1+1_$int_type
|
||||
endif
|
||||
enddo
|
||||
i0=i0-1_$int_type
|
||||
i1=i1-1_$int_type
|
||||
|
||||
do i=1_$int_type,i1
|
||||
iorder(i0+i) = iorder2(i)
|
||||
x(i0+i) = x2(i)
|
||||
enddo
|
||||
|
||||
deallocate(x2,iorder2,stat=err)
|
||||
if (err /= 0) then
|
||||
print *, irp_here, ': Unable to allocate arrays x2, iorder2'
|
||||
stop
|
||||
endif
|
||||
|
||||
|
||||
if (iradix == 0) then
|
||||
return
|
||||
endif
|
||||
|
||||
|
||||
if (i1>1_$int_type) then
|
||||
call $Xradix_sort$big(x(i0+1_$int_type),iorder(i0+1_$int_type),i1,iradix-1)
|
||||
endif
|
||||
if (i0>1) then
|
||||
call $Xradix_sort$big(x,iorder,i0,iradix-1)
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
SUBST [ X, type, integer_size, is_big, big, int_type ]
|
||||
i ; 4 ; 32 ; .False. ; ; 4 ;;
|
||||
i8 ; 8 ; 64 ; .False. ; ; 4 ;;
|
||||
i2 ; 2 ; 16 ; .False. ; ; 4 ;;
|
||||
i ; 4 ; 32 ; .True. ; _big ; 8 ;;
|
||||
i8 ; 8 ; 64 ; .True. ; _big ; 8 ;;
|
||||
END_TEMPLATE
|
||||
|
||||
|
||||
|
||||
|
||||
22
src/utils/units.irp.f
Normal file
22
src/utils/units.irp.f
Normal file
@ -0,0 +1,22 @@
|
||||
BEGIN_PROVIDER [double precision, ha_to_ev]
|
||||
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Converstion from Hartree to eV
|
||||
END_DOC
|
||||
|
||||
ha_to_ev = 27.211396641308d0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [double precision, au_to_D]
|
||||
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Converstion from au to Debye
|
||||
END_DOC
|
||||
|
||||
au_to_D = 2.5415802529d0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
@ -37,6 +37,10 @@ double precision function binom_func(i,j)
|
||||
else
|
||||
binom_func = dexp( logfact(i)-logfact(j)-logfact(i-j) )
|
||||
endif
|
||||
|
||||
! To avoid .999999 numbers
|
||||
binom_func = floor(binom_func + 0.5d0)
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
@ -46,7 +46,7 @@ function test_exe() {
|
||||
|
||||
run_only_test() {
|
||||
if [[ "$BATS_TEST_DESCRIPTION" != "$1" ]] && [[ "$BATS_TEST_NUMBER" != "$1" ]]; then
|
||||
if [[ -z $BATS_TEST_FILENAME ]] ; then
|
||||
if [[ -z "$BATS_TEST_FILENAME" ]] ; then
|
||||
exit 0
|
||||
else
|
||||
skip
|
||||
|
||||
@ -1,16 +0,0 @@
|
||||
#!/bin/bash
|
||||
# Stage 2
|
||||
|
||||
# Extract cache from config stage
|
||||
cd ../
|
||||
tar -zxf $HOME/cache/config.tgz
|
||||
|
||||
# Configure QP2
|
||||
cd qp2
|
||||
source ./quantum_package.rc
|
||||
ninja -j 1 -v || exit -1
|
||||
|
||||
# Create cache
|
||||
cd ..
|
||||
tar -zcf $HOME/cache/compil.tgz qp2 && rm $HOME/cache/config.tgz
|
||||
|
||||
@ -1,10 +0,0 @@
|
||||
#!/bin/bash
|
||||
# Stage 1
|
||||
|
||||
# Configure QP2
|
||||
./configure --download all --install all --config ./config/travis.cfg || exit -1
|
||||
|
||||
# Create cache
|
||||
cd ../
|
||||
tar -zcf $HOME/cache/config.tgz qp2
|
||||
|
||||
@ -1,16 +0,0 @@
|
||||
#!/bin/bash
|
||||
# Stage 3
|
||||
|
||||
# Extract cache from compile stage
|
||||
cd ../
|
||||
tar -zxf $HOME/cache/compil.tgz
|
||||
|
||||
# Configure QP2
|
||||
cd qp2
|
||||
source ./quantum_package.rc
|
||||
exec qp_test -a && rm $HOME/cache/compil.tgz
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user