diff --git a/.travis.yml b/.travis.yml index b763532c..56c55504 100644 --- a/.travis.yml +++ b/.travis.yml @@ -27,7 +27,7 @@ python: script: - ./configure --production ./config/gfortran.cfg - source ./quantum_package.rc - - qp_module.py install Full_CI Hartree_Fock + - qp_install_module.py install Full_CI Hartree_Fock CAS_SD MRCC_CASSD - ninja - cd ocaml ; make ; cd - - cd testing_no_regression ; ./unit_test.py diff --git a/config/gfortran.cfg b/config/gfortran.cfg index c1032aa1..b713aaf0 100644 --- a/config/gfortran.cfg +++ b/config/gfortran.cfg @@ -10,7 +10,7 @@ # # [COMMON] -FC : gfortran -g -ffree-line-length-none -I . +FC : gfortran -g -ffree-line-length-none -I . -static-libgcc LAPACK_LIB : -llapack -lblas IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 @@ -22,7 +22,7 @@ IRPF90_FLAGS : --ninja --align=32 # 0 : Deactivate # [OPTION] -MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below +MODE : DEBUG ; [ OPT | PROFILE | DEBUG ] : Chooses the section below CACHE : 1 ; Enable cache_compile.py OPENMP : 1 ; Append OpenMP flags diff --git a/configure b/configure index 043f7454..81968573 100755 --- a/configure +++ b/configure @@ -33,8 +33,8 @@ import sys from os.path import join if not any(i in ["--production", "--development"] for i in sys.argv): - print __doc__ - sys.exit() + sys.argv += ["--development"] + if len(sys.argv) != 3: print __doc__ sys.exit() @@ -46,6 +46,7 @@ if len(sys.argv) != 3: QP_ROOT = os.getcwd() QP_ROOT_BIN = join(QP_ROOT, "bin") +QP_ROOT_LIB = join(QP_ROOT, "lib") QP_ROOT_INSTALL = join(QP_ROOT, "install") os.environ["PATH"] = os.environ["PATH"] + ":" + QP_ROOT_BIN @@ -62,8 +63,11 @@ d_dependency = { "resultsFile": ["python"], "emsl": ["python"], "gcc": [], + "g++": [], + "zeromq" : [ "g++" ], + "f77zmq" : [ "zeromq", "python" ], "python": [], - "ninja": ["gcc", "python"], + "ninja": ["g++", "python"], "make": [], "p_graphviz": ["python"] } @@ -92,12 +96,12 @@ curl = Info( zlib = Info( url='http://zlib.net/zlib-1.2.8.tar.gz', description=' zlib', - default_path=join(QP_ROOT_INSTALL, "zlib")) + default_path=join(QP_ROOT_LIB, "libz.a")) -path = Info( +patch = Info( url='ftp://ftp.gnu.org/gnu/patch/patch-2.7.5.tar.gz', - description=' path', - default_path=join(QP_ROOT, "lib", "libz.a")) + description=' patch', + default_path=join(QP_ROOT_BIN, "patch")) irpf90 = Info( url='{head}/LCPQ/irpf90/{tail}'.format(**path_github), @@ -116,12 +120,11 @@ resultsFile = Info( ninja = Info( url='{head}/martine/ninja/{tail}'.format(**path_github), - description=' nina', + description=' ninja', default_path=join(QP_ROOT_BIN, "ninja")) emsl = Info( - url='{head}/LCPQ/EMSL_Basis_Set_Exchange_Local/{tail}'.format(** - path_github), + url='{head}/LCPQ/EMSL_Basis_Set_Exchange_Local/{tail}'.format(**path_github), description=' EMSL basis set library', default_path=join(QP_ROOT_INSTALL, "emsl")) @@ -130,6 +133,16 @@ ezfio = Info( description=' EZFIO', default_path=join(QP_ROOT_INSTALL, "EZFIO")) +zeromq = Info( + url='http://download.zeromq.org/zeromq-4.1.3.tar.gz', + description=' ZeroMQ', + default_path=join(QP_ROOT_LIB, "libzmq.a")) + +f77zmq = Info( + url='{head}/zeromq/f77_zmq/{tail}'.format(**path_github), + description=' F77-ZeroMQ', + default_path=join(QP_ROOT_LIB, "libf77zmq.a")) + p_graphviz = Info( url='https://github.com/xflr6/graphviz/archive/master.tar.gz', description=' Python library for graphviz', @@ -137,8 +150,9 @@ p_graphviz = Info( d_info = dict() -for m in ["ocaml", "m4", "curl", "zlib", "path", "irpf90", "docopt", - "resultsFile", "ninja", "emsl", "ezfio", "p_graphviz"]: +for m in ["ocaml", "m4", "curl", "zlib", "patch", "irpf90", "docopt", + "resultsFile", "ninja", "emsl", "ezfio", "p_graphviz", + "zeromq", "f77zmq" ]: exec ("d_info['{0}']={0}".format(m)) @@ -189,8 +203,7 @@ def check_output(*popenargs, **kwargs): def checking(d_dependency): """ - For each key in d_dependency check if it - is avalabie or not + For each key in d_dependency check if it is avalabie """ def check_python(): @@ -260,7 +273,7 @@ def checking(d_dependency): l_installed = dict() l_needed = [] - # Check all the other + # Check all the others length = max(map(len, d_dependency)) for i in d_dependency.keys(): @@ -275,7 +288,7 @@ def checking(d_dependency): l_needed.append(i) print "" - # Expend the need_stuff for all the genealogy + # Expand the needed stuff for all the genealogy l_install_descendant = get_list_descendant(d_dependency, l_installed, l_needed) @@ -328,7 +341,7 @@ _|_ | | _> |_ (_| | | (_| |_ | (_) | | d_print = { "install_ninja": "Install ninja...", "build": "Creating build.ninja...", - "install": "Installing the dependencies with Ninja..." + "install": "Installing the dependencies using Ninja..." } length = max(map(len, d_print.values())) @@ -372,7 +385,7 @@ _|_ | | _> |_ (_| | | (_| |_ | (_) | | descr = d_info[need].description default_path = d_info[need].default_path - # Build to dowload + # Build to download l_build += ["build {0}: download".format(archive_path), " url = {0}".format(url), " descr = {0}".format(descr), ""] @@ -404,7 +417,16 @@ _|_ | | _> |_ (_| | | (_| |_ | (_) | | path_ninja = find_path("ninja", l_installed) subprocess.check_call("cd install ;{0}".format(path_ninja), shell=True) except: - raise + prefix = os.path.join('install', '_build') + for filename in os.listdir(prefix): + if filename.endswith(".log"): + with open( os.path.join(prefix,filename) ,'r') as f: + print "\n\n" + print "=-=-=-=-=-=- %s =-=-=-=-=-=-" %(filename) + print f.read() + print "=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n\n" + print "Error in installation of dependencies" + sys.exit(1) else: print r""" _________ @@ -437,11 +459,12 @@ def create_ninja_and_rc(l_installed): print str_info("qp_root"), python_path = [join(QP_ROOT, "scripts"), join(QP_ROOT, "install")] - l_python = [join(QP_ROOT, "scripts")] + l_python = [join("${QP_ROOT}", "scripts")] for dir_ in python_path: for folder in os.listdir(dir_): path = join(dir_, folder) if os.path.isdir(path): + path = path.replace(QP_ROOT,"${QP_ROOT}") l_python.append(path) path_ezfio = find_path('ezfio', l_installed, var_for_qp_root=True) @@ -450,9 +473,9 @@ def create_ninja_and_rc(l_installed): l_rc = [ 'export QP_ROOT={0}'.format(QP_ROOT), - 'export QP_EZFIO={0}'.format(path_ezfio), - 'export IRPF90={0}'.format(path_irpf90), - 'export NINJA={0}'.format(path_ninja), + 'export QP_EZFIO={0}'.format(path_ezfio.replace(QP_ROOT,"${QP_ROOT}")), + 'export IRPF90={0}'.format(path_irpf90.replace(QP_ROOT,"${QP_ROOT}")), + 'export NINJA={0}'.format(path_ninja.replace(QP_ROOT,"${QP_ROOT}")), 'export QP_PYTHON={0}'.format(":".join(l_python)), "", 'export PYTHONPATH="${QP_EZFIO}/Python":"${QP_PYTHON}":"${PYTHONPATH}"', 'export PATH="${QP_PYTHON}":"${QP_ROOT}"/bin:"${QP_ROOT}"/ocaml:"${PATH}"', @@ -526,3 +549,4 @@ if __name__ == '__main__': create_ninja_and_rc(l_installed) recommendation() + diff --git a/install/scripts/build.sh b/install/scripts/build.sh index 6b7fc80a..79a71065 100755 --- a/install/scripts/build.sh +++ b/install/scripts/build.sh @@ -7,4 +7,4 @@ mkdir ${BUILD} || exit 1 tar -zxf Downloads/${TARGET}.tar.gz --strip-components=1 --directory=${BUILD} || exit 1 _install || exit 1 rm -rf -- ${BUILD} _build/${TARGET}.log -exit 0 \ No newline at end of file +exit 0 diff --git a/install/scripts/install_f77zmq.sh b/install/scripts/install_f77zmq.sh new file mode 100755 index 00000000..8357857c --- /dev/null +++ b/install/scripts/install_f77zmq.sh @@ -0,0 +1,23 @@ +#!/bin/bash -x + +TARGET=f77zmq + +function _install() +{ + cd .. + QP_ROOT=$PWD + cd - + export C_INCLUDE_PATH="${C_INCLUDE_PATH}":"${QP_ROOT}"/lib + set -e + set -u + export ZMQ_H="${QP_ROOT}"/lib/zmq.h + cd "${BUILD}" + make -j 8 || exit 1 + mv libf77zmq.a "${QP_ROOT}"/lib || exit 1 + mv libf77zmq.so "${QP_ROOT}"/lib || exit 1 + cp f77_zmq.h "${QP_ROOT}"/src/ZMQ/ + cd - + return 0 +} + +source scripts/build.sh diff --git a/install/scripts/install_zeromq.sh b/install/scripts/install_zeromq.sh new file mode 100755 index 00000000..9508f457 --- /dev/null +++ b/install/scripts/install_zeromq.sh @@ -0,0 +1,27 @@ +#!/bin/bash -x + +TARGET=zeromq + +function _install() +{ + cd .. + QP_ROOT=$PWD + cd - + export C_INCLUDE_PATH="${C_INCLUDE_PATH}":./ + set -e + set -u + ORIG=$(pwd) + cd "${BUILD}" + ./configure --without-libsodium || exit 1 + make -j 8 || exit 1 + rm -f -- "${QP_ROOT}"/lib/libzmq.a "${QP_ROOT}"/lib/libzmq.so "${QP_ROOT}"/lib/libzmq.so.5 + cp .libs/libzmq.a "${QP_ROOT}"/lib + cp .libs/libzmq.so "${QP_ROOT}"/lib/libzmq.so.5 + cp include/{zmq.h,zmq_utils.h} "${QP_ROOT}"/lib + cd "${QP_ROOT}"/lib + ln -s libzmq.so.5 libzmq.so + cd ${ORIG} + return 0 +} + +source scripts/build.sh diff --git a/ocaml/Atom.ml b/ocaml/Atom.ml index 2aafe644..832cfa5b 100644 --- a/ocaml/Atom.ml +++ b/ocaml/Atom.ml @@ -8,8 +8,8 @@ type t = coord : Point3d.t ; } with sexp -(** Read xyz coordinates of the atom with unit u *) -let of_string u s = +(** Read xyz coordinates of the atom *) +let of_string ~units s = let buffer = s |> String.split ~on:' ' |> List.filter ~f:(fun x -> x <> "") @@ -18,21 +18,21 @@ let of_string u s = | [ name; charge; x; y; z ] -> { element = Element.of_string name ; charge = Charge.of_string charge ; - coord = Point3d.of_string u (String.concat [x; y; z] ~sep:" ") + coord = Point3d.of_string ~units (String.concat [x; y; z] ~sep:" ") } | [ name; x; y; z ] -> let e = Element.of_string name in { element = e ; charge = Element.to_charge e; - coord = Point3d.of_string u (String.concat [x; y; z] ~sep:" ") + coord = Point3d.of_string ~units (String.concat [x; y; z] ~sep:" ") } | _ -> raise (AtomError s) ;; -let to_string u a = +let to_string ~units a = [ Element.to_string a.element ; Charge.to_string a.charge ; - Point3d.to_string u a.coord ] + Point3d.to_string ~units a.coord ] |> String.concat ~sep:" " ;; diff --git a/ocaml/Atom.mli b/ocaml/Atom.mli index 93f7d885..28915993 100644 --- a/ocaml/Atom.mli +++ b/ocaml/Atom.mli @@ -5,5 +5,5 @@ type t = { element : Element.t; charge : Charge.t; coord : Point3d.t; } val t_of_sexp : Sexplib.Sexp.t -> t val sexp_of_t : t -> Sexplib.Sexp.t -val of_string : Units.units -> string -> t -val to_string : Units.units -> t -> string +val of_string : units:Units.units -> string -> t +val to_string : units:Units.units -> t -> string diff --git a/ocaml/Element.ml b/ocaml/Element.ml index d282340b..6bc2de4e 100644 --- a/ocaml/Element.ml +++ b/ocaml/Element.ml @@ -1,4 +1,5 @@ -open Core.Std;; +open Core.Std +open Qptypes exception ElementError of string @@ -8,49 +9,49 @@ type t = |Li|Be |B |C |N |O |F |Ne |Na|Mg |Al|Si|P |S |Cl|Ar |K |Ca|Sc|Ti|V |Cr|Mn|Fe|Co|Ni|Cu|Zn|Ga|Ge|As|Se|Br|Kr -with sexp;; +with sexp let of_string x = match (String.capitalize (String.lowercase x)) with -| "X" | "Dummy" -> X -| "H" | "Hydrogen" -> H -| "He" | "Helium" -> He -| "Li" | "Lithium" -> Li -| "Be" | "Beryllium" -> Be -| "B" | "Boron" -> B -| "C" | "Carbon" -> C -| "N" | "Nitrogen" -> N -| "O" | "Oxygen" -> O -| "F" | "Fluorine" -> F -| "Ne" | "Neon" -> Ne -| "Na" | "Sodium" -> Na -| "Mg" | "Magnesium" -> Mg -| "Al" | "Aluminum" -> Al -| "Si" | "Silicon" -> Si -| "P" | "Phosphorus" -> P -| "S" | "Sulfur" -> S -| "Cl" | "Chlorine" -> Cl -| "Ar" | "Argon" -> Ar -| "K" | "Potassium" -> K -| "Ca" | "Calcium" -> Ca -| "Sc" | "Scandium" -> Sc -| "Ti" | "Titanium" -> Ti -| "V" | "Vanadium" -> V -| "Cr" | "Chromium" -> Cr -| "Mn" | "Manganese" -> Mn -| "Fe" | "Iron" -> Fe -| "Co" | "Cobalt" -> Co -| "Ni" | "Nickel" -> Ni -| "Cu" | "Copper" -> Cu -| "Zn" | "Zinc" -> Zn -| "Ga" | "Gallium" -> Ga -| "Ge" | "Germanium" -> Ge -| "As" | "Arsenic" -> As -| "Se" | "Selenium" -> Se -| "Br" | "Bromine" -> Br -| "Kr" | "Krypton" -> Kr +| "X" | "Dummy" -> X +| "H" | "Hydrogen" -> H +| "He" | "Helium" -> He +| "Li" | "Lithium" -> Li +| "Be" | "Beryllium" -> Be +| "B" | "Boron" -> B +| "C" | "Carbon" -> C +| "N" | "Nitrogen" -> N +| "O" | "Oxygen" -> O +| "F" | "Fluorine" -> F +| "Ne" | "Neon" -> Ne +| "Na" | "Sodium" -> Na +| "Mg" | "Magnesium" -> Mg +| "Al" | "Aluminum" -> Al +| "Si" | "Silicon" -> Si +| "P" | "Phosphorus" -> P +| "S" | "Sulfur" -> S +| "Cl" | "Chlorine" -> Cl +| "Ar" | "Argon" -> Ar +| "K" | "Potassium" -> K +| "Ca" | "Calcium" -> Ca +| "Sc" | "Scandium" -> Sc +| "Ti" | "Titanium" -> Ti +| "V" | "Vanadium" -> V +| "Cr" | "Chromium" -> Cr +| "Mn" | "Manganese" -> Mn +| "Fe" | "Iron" -> Fe +| "Co" | "Cobalt" -> Co +| "Ni" | "Nickel" -> Ni +| "Cu" | "Copper" -> Cu +| "Zn" | "Zinc" -> Zn +| "Ga" | "Gallium" -> Ga +| "Ge" | "Germanium" -> Ge +| "As" | "Arsenic" -> As +| "Se" | "Selenium" -> Se +| "Br" | "Bromine" -> Br +| "Kr" | "Krypton" -> Kr | x -> raise (ElementError ("Element "^x^" unknown")) -;; + let to_string = function | X -> "X" @@ -90,7 +91,7 @@ let to_string = function | Se -> "Se" | Br -> "Br" | Kr -> "Kr" -;; + let to_long_string = function | X -> "Dummy" @@ -130,7 +131,7 @@ let to_long_string = function | Se -> "Selenium" | Br -> "Bromine" | Kr -> "Krypton" -;; + let to_charge c = let result = match c with @@ -172,7 +173,7 @@ let to_charge c = | Br -> 35 | Kr -> 36 in Charge.of_int result -;; + let of_charge c = match (Charge.to_int c) with | 0 -> X @@ -213,5 +214,134 @@ let of_charge c = match (Charge.to_int c) with | 35 -> Br | 36 -> Kr | x -> raise (ElementError ("Element of charge "^(string_of_int x)^" unknown")) -;; + + +let covalent_radius x = + let result = function + | X -> 0. + | H -> 0.37 + | He -> 0.70 + | Li -> 1.23 + | Be -> 0.89 + | B -> 0.90 + | C -> 0.85 + | N -> 0.74 + | O -> 0.74 + | F -> 0.72 + | Ne -> 0.70 + | Na -> 1.00 + | Mg -> 1.36 + | Al -> 1.25 + | Si -> 1.17 + | P -> 1.10 + | S -> 1.10 + | Cl -> 0.99 + | Ar -> 0.70 + | K -> 2.03 + | Ca -> 1.74 + | Sc -> 1.44 + | Ti -> 1.32 + | V -> 1.22 + | Cr -> 0.00 + | Mn -> 1.16 + | Fe -> 0.00 + | Co -> 1.15 + | Ni -> 1.17 + | Cu -> 1.25 + | Zn -> 1.25 + | Ga -> 1.20 + | Ge -> 1.21 + | As -> 1.16 + | Se -> 0.70 + | Br -> 1.24 + | Kr -> 1.91 + in + Units.angstrom_to_bohr *. (result x) + |> Positive_float.of_float + +let vdw_radius x = + let result = function + | X -> 0. + | H -> 1.20 + | He -> 1.70 + | Li -> 1.70 + | Be -> 1.70 + | B -> 1.70 + | C -> 1.70 + | N -> 1.55 + | O -> 1.52 + | F -> 1.47 + | Ne -> 1.70 + | Na -> 1.70 + | Mg -> 1.70 + | Al -> 1.94 + | Si -> 2.10 + | P -> 1.80 + | S -> 1.80 + | Cl -> 1.75 + | Ar -> 1.70 + | K -> 1.70 + | Ca -> 1.70 + | Sc -> 1.70 + | Ti -> 1.70 + | V -> 1.98 + | Cr -> 1.94 + | Mn -> 1.93 + | Fe -> 1.93 + | Co -> 1.92 + | Ni -> 1.70 + | Cu -> 1.70 + | Zn -> 1.70 + | Ga -> 2.02 + | Ge -> 1.70 + | As -> 1.96 + | Se -> 1.70 + | Br -> 2.10 + | Kr -> 1.70 + in + Units.angstrom_to_bohr *. (result x) + |> Positive_float.of_float + +let mass x = + let result = function + | X -> 0. + | H -> 1.0079 + | He -> 4.00260 + | Li -> 6.941 + | Be -> 9.01218 + | B -> 10.81 + | C -> 12.011 + | N -> 14.0067 + | O -> 15.9994 + | F -> 18.998403 + | Ne -> 20.179 + | Na -> 22.98977 + | Mg -> 24.305 + | Al -> 26.98154 + | Si -> 28.0855 + | P -> 30.97376 + | S -> 32.06 + | Cl -> 35.453 + | Ar -> 39.948 + | K -> 39.0983 + | Ca -> 40.08 + | Sc -> 44.9559 + | Ti -> 47.90 + | V -> 50.9415 + | Cr -> 51.996 + | Mn -> 54.9380 + | Fe -> 55.9332 + | Co -> 58.9332 + | Ni -> 58.70 + | Cu -> 63.546 + | Zn -> 65.38 + | Ga -> 69.72 + | Ge -> 72.59 + | As -> 74.9216 + | Se -> 78.96 + | Br -> 79.904 + | Kr -> 83.80 + in + result x + |> Positive_float.of_float diff --git a/ocaml/Element.mli b/ocaml/Element.mli index 48bd3c61..8d9862c9 100644 --- a/ocaml/Element.mli +++ b/ocaml/Element.mli @@ -13,6 +13,8 @@ val of_string : string -> t val to_string : t -> string val to_long_string : t -> string -(** get the positive charge *) +(** Properties *) val to_charge : t -> Charge.t val of_charge : Charge.t -> t +val covalent_radius : t -> Qptypes.Positive_float.t +val vdw_radius : t -> Qptypes.Positive_float.t diff --git a/ocaml/Input_determinants_by_hand.ml b/ocaml/Input_determinants_by_hand.ml index 4c0453e6..d78233ca 100644 --- a/ocaml/Input_determinants_by_hand.ml +++ b/ocaml/Input_determinants_by_hand.ml @@ -7,8 +7,6 @@ module Determinants_by_hand : sig { n_int : N_int_number.t; bit_kind : Bit_kind.t; n_det : Det_number.t; - n_states : States_number.t; - n_states_diag : States_number.t; expected_s2 : Positive_float.t; psi_coef : Det_coef.t array; psi_det : Determinant.t array; @@ -23,8 +21,6 @@ end = struct { n_int : N_int_number.t; bit_kind : Bit_kind.t; n_det : Det_number.t; - n_states : States_number.t; - n_states_diag : States_number.t; expected_s2 : Positive_float.t; psi_coef : Det_coef.t array; psi_det : Determinant.t array; @@ -146,11 +142,12 @@ end = struct |> Array.map ~f:Det_coef.of_float ;; - let write_psi_coef ~n_det ~n_states c = + let write_psi_coef ~n_det c = let n_det = Det_number.to_int n_det and c = Array.to_list c |> List.map ~f:Det_coef.to_float - and n_states = States_number.to_int n_states + and n_states = + read_n_states () |> States_number.to_int in Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| n_det ; n_states |] ~data:c |> Ezfio.set_determinants_psi_coef @@ -214,8 +211,6 @@ end = struct { n_int = read_n_int () ; bit_kind = read_bit_kind () ; n_det = read_n_det () ; - n_states = read_n_states () ; - n_states_diag = read_n_states_diag () ; expected_s2 = read_expected_s2 () ; psi_coef = read_psi_coef () ; psi_det = read_psi_det () ; @@ -227,8 +222,6 @@ end = struct let write { n_int ; bit_kind ; n_det ; - n_states ; - n_states_diag ; expected_s2 ; psi_coef ; psi_det ; @@ -236,10 +229,8 @@ end = struct write_n_int n_int ; write_bit_kind bit_kind; write_n_det n_det; - write_n_states n_states; - write_n_states_diag ~n_states:n_states n_states_diag; write_expected_s2 expected_s2; - write_psi_coef ~n_det:n_det psi_coef ~n_states:n_states; + write_psi_coef ~n_det:n_det psi_coef ; write_psi_det ~n_int:n_int ~n_det:n_det psi_det; ;; @@ -249,7 +240,7 @@ end = struct let mo_tot_num = MO_number.of_int mo_tot_num ~max:mo_tot_num in let det_text = let nstates = - States_number.to_int b.n_states + read_n_states () |> States_number.to_int and ndet = Det_number.to_int b.n_det in @@ -284,12 +275,6 @@ If true, input the expected value of S^2 :: expected_s2 = %s -Number of requested states, and number of states used for the -Davidson diagonalization :: - - n_states = %s - n_states_diag = %s - Number of determinants :: n_det = %s @@ -299,8 +284,6 @@ Determinants :: %s " (b.expected_s2 |> Positive_float.to_string) - (b.n_states |> States_number.to_string) - (b.n_states_diag |> States_number.to_string) (b.n_det |> Det_number.to_string) det_text |> Rst_string.of_string @@ -313,8 +296,6 @@ Determinants :: n_int = %s bit_kind = %s n_det = %s -n_states = %s -n_states_diag = %s expected_s2 = %s psi_coef = %s psi_det = %s @@ -322,8 +303,6 @@ psi_det = %s (b.n_int |> N_int_number.to_string) (b.bit_kind |> Bit_kind.to_string) (b.n_det |> Det_number.to_string) - (b.n_states |> States_number.to_string) - (b.n_states_diag |> States_number.to_string) (b.expected_s2 |> Positive_float.to_string) (b.psi_coef |> Array.to_list |> List.map ~f:Det_coef.to_string |> String.concat ~sep:", ") diff --git a/ocaml/Input_nuclei.ml b/ocaml/Input_nuclei.ml index cbcb9f46..d050ded9 100644 --- a/ocaml/Input_nuclei.ml +++ b/ocaml/Input_nuclei.ml @@ -147,7 +147,7 @@ nucl_coord = %s (b.nucl_charge |> Array.to_list |> List.map ~f:(Charge.to_string) |> String.concat ~sep:", " ) (b.nucl_coord |> Array.to_list |> List.map - ~f:(Point3d.to_string Units.Bohr) |> String.concat ~sep:"\n" ) + ~f:(Point3d.to_string ~units:Units.Bohr) |> String.concat ~sep:"\n" ) ;; @@ -161,7 +161,7 @@ nucl_coord = %s Printf.sprintf " %-3s %d %s" (b.nucl_label.(i) |> Element.to_string) (b.nucl_charge.(i) |> Charge.to_int ) - (b.nucl_coord.(i) |> Point3d.to_string Units.Angstrom) ) + (b.nucl_coord.(i) |> Point3d.to_string ~units:Units.Angstrom) ) ) |> String.concat ~sep:"\n" in Printf.sprintf " diff --git a/ocaml/Molecule.ml b/ocaml/Molecule.ml index f295420b..f0800f7f 100644 --- a/ocaml/Molecule.ml +++ b/ocaml/Molecule.ml @@ -10,27 +10,36 @@ type t = { } with sexp let get_charge { nuclei ; elec_alpha ; elec_beta } = - let result = (Elec_alpha_number.to_int elec_alpha) + - (Elec_beta_number.to_int elec_beta) in + let result = + (Elec_alpha_number.to_int elec_alpha) + + (Elec_beta_number.to_int elec_beta) + in let rec nucl_charge = function | a::rest -> (Charge.to_float a.Atom.charge) +. nucl_charge rest | [] -> 0. in Charge.of_float (nucl_charge nuclei -. (Float.of_int result)) -;; + let get_multiplicity m = - let elec_alpha = m.elec_alpha in + let elec_alpha = + m.elec_alpha + in Multiplicity.of_alpha_beta elec_alpha m.elec_beta -;; + let get_nucl_num m = - let nmax = (List.length m.nuclei) in + let nmax = + List.length m.nuclei + in Nucl_number.of_int nmax ~max:nmax -;; + let name m = - let cm = Charge.to_int (get_charge m) in + let cm = + get_charge m + |> Charge.to_int + in let c = match cm with | 0 -> "" @@ -39,8 +48,12 @@ let name m = | i when i>1 -> Printf.sprintf " (%d+)" i | i -> Printf.sprintf " (%d-)" (-i) in - let mult = Multiplicity.to_string (get_multiplicity m) in - let { nuclei ; elec_alpha ; elec_beta } = m in + let mult = + get_multiplicity m + |> Multiplicity.to_string + in + let { nuclei ; elec_alpha ; elec_beta } = m + in let rec build_list accu = function | a::rest -> begin @@ -53,7 +66,9 @@ let name m = in let rec build_name accu = function | (a, n)::rest -> - let a = Element.to_string a in + let a = + Element.to_string a + in begin match n with | 1 -> build_name (a::accu) rest @@ -64,19 +79,25 @@ let name m = end | [] -> accu in - let result = build_list [] nuclei |> build_name [c ; ", " ; mult] + let result = + build_list [] nuclei |> build_name [c ; ", " ; mult] in String.concat (result) -;; + let to_string m = - let { nuclei ; elec_alpha ; elec_beta } = m in - let n = List.length nuclei in - let title = name m in - [ Int.to_string n ; title ] @ (List.map ~f:(fun x -> Atom.to_string - Units.Angstrom x) nuclei) + let { nuclei ; elec_alpha ; elec_beta } = m + in + let n = + List.length nuclei + in + let title = + name m + in + [ Int.to_string n ; title ] @ + (List.map ~f:(fun x -> Atom.to_string Units.Angstrom x) nuclei) |> String.concat ~sep:"\n" -;; + let of_xyz_string ?(charge=(Charge.of_int 0)) ?(multiplicity=(Multiplicity.of_int 1)) @@ -94,7 +115,9 @@ let of_xyz_string ) + 1 - (Charge.to_int charge) |> Elec_number.of_int in - let (na,nb) = Multiplicity.to_alpha_beta ne multiplicity in + let (na,nb) = + Multiplicity.to_alpha_beta ne multiplicity + in let result = { nuclei = l ; elec_alpha = na ; @@ -109,7 +132,7 @@ let of_xyz_string raise (MultiplicityError msg); else () ; result -;; + let of_xyz_file @@ -121,8 +144,33 @@ let of_xyz_file let (_,buffer) = String.lsplit2_exn buffer ~on:'\n' in of_xyz_string ~charge:charge ~multiplicity:multiplicity ~units:units buffer -;; -include To_md5;; + + +let distance_matrix molecule = + let coord = + molecule.nuclei + |> List.map ~f:(fun x -> x.Atom.coord) + |> Array.of_list + in + let n = + Array.length coord + in + let result = + Array.make_matrix ~dimx:n ~dimy:n 0. + in + for i = 0 to (n-1) + do + for j = 0 to (n-1) + do + result.(i).(j) <- Point3d.distance coord.(i) coord.(j) + done; + done; + result + + + + +include To_md5 let to_md5 = to_md5 sexp_of_t -;; + diff --git a/ocaml/Molecule.mli b/ocaml/Molecule.mli index 176441d4..1a3d9715 100644 --- a/ocaml/Molecule.mli +++ b/ocaml/Molecule.mli @@ -34,5 +34,9 @@ val of_xyz_string : ?multiplicity:Multiplicity.t -> ?units:Units.units -> string -> t +(** Creates the distance matrix between all the atoms *) +val distance_matrix : + t -> (float array) array + (** Computes the MD5 hash *) val to_md5 : t -> Qptypes.MD5.t diff --git a/ocaml/Point3d.ml b/ocaml/Point3d.ml index 18f091f1..5717ed39 100644 --- a/ocaml/Point3d.ml +++ b/ocaml/Point3d.ml @@ -7,9 +7,16 @@ type t = { z : float ; } with sexp +let of_tuple ~units (x,y,z) = + let f = match units with + | Units.Bohr -> 1. + | Units.Angstrom -> Units.angstrom_to_bohr + in + { x = x *. f ; y = y *. f ; z = z *. f } + (** Read x y z coordinates in string s with units u *) -let of_string u s = - let f = match u with +let of_string ~units s = + let f = match units with | Units.Bohr -> 1. | Units.Angstrom -> Units.angstrom_to_bohr in @@ -22,7 +29,6 @@ let of_string u s = { x = l.(0) *. f ; y = l.(1) *. f ; z = l.(2) *. f } -;; let distance2 p1 p2 = @@ -30,17 +36,18 @@ let distance2 p1 p2 = and { x=x2 ; y=y2 ; z=z2 } = p2 in (x2-.x1)*.(x2-.x1) +. (y2-.y1)*.(y2-.y1) +. (z2-.z1)*.(z2-.z1) |> Positive_float.of_float -;; -let distance p1 p2 = sqrt (Positive_float.to_float (distance2 p1 p2)) -;; -let to_string u p = - let f = match u with +let distance p1 p2 = + sqrt (Positive_float.to_float (distance2 p1 p2)) + + +let to_string ~units p = + let f = match units with | Units.Bohr -> 1. | Units.Angstrom -> Units.bohr_to_angstrom in let { x=x ; y=y ; z=z } = p in Printf.sprintf "%16.8f %16.8f %16.8f" (x*.f) (y*.f) (z*.f) -;; + diff --git a/ocaml/Point3d.mli b/ocaml/Point3d.mli index 066a4514..6d7428ec 100644 --- a/ocaml/Point3d.mli +++ b/ocaml/Point3d.mli @@ -4,11 +4,14 @@ type t = z : float; } with sexp +(** Create from a tuple of floats *) +val of_tuple : units:Units.units -> float*float*float -> t + (** Create from an xyz string *) -val of_string : Units.units -> string -> t +val of_string : units:Units.units -> string -> t (** Convert to a string for printing *) -val to_string : Units.units -> t -> string +val to_string : units:Units.units -> t -> string (** Computes the squared distance between 2 points *) val distance2 : t -> t -> Qptypes.Positive_float.t diff --git a/ocaml/Qputils.ml b/ocaml/Qputils.ml index ed112de3..7f840fde 100644 --- a/ocaml/Qputils.ml +++ b/ocaml/Qputils.ml @@ -12,7 +12,6 @@ let rec transpose = function ;; *) - let input_to_sexp s = let result = String.split_lines s diff --git a/ocaml/qp_create_ezfio_from_xyz.ml b/ocaml/qp_create_ezfio_from_xyz.ml index 544e6e09..ee7e7d40 100644 --- a/ocaml/qp_create_ezfio_from_xyz.ml +++ b/ocaml/qp_create_ezfio_from_xyz.ml @@ -11,76 +11,169 @@ let spec = ~doc:"string Name of basis set." +> flag "c" (optional_with_default 0 int) ~doc:"int Total charge of the molecule. Default is 0." + +> flag "d" (optional_with_default 0. float) + ~doc:"float Add dummy atoms. x * (covalent radii of the atoms)" +> flag "m" (optional_with_default 1 int) ~doc:"int Spin multiplicity (2S+1) of the molecule. Default is 1." +> flag "p" no_arg ~doc:" Using pseudopotentials" - +> anon ("xyz_file" %: string) -;; + +> anon ("xyz_file" %: file ) -let run ?o b c m p xyz_file = + +let dummy_centers ~threshold ~molecule ~nuclei = + let d = + Molecule.distance_matrix molecule + in + let n = + Array.length d + in + let nuclei = + Array.of_list nuclei + in + let rec aux accu = function + | (-1,_) -> accu + | (i,-1) -> aux accu (i-1,i-1) + | (i,j) when (i>j) -> + let new_accu = + let x,y = + Element.covalent_radius (nuclei.(i)).Atom.element |> Positive_float.to_float, + Element.covalent_radius (nuclei.(j)).Atom.element |> Positive_float.to_float + in + let r = + ( x +. y ) *. threshold + in + if d.(i).(j) < r then + (i,x,j,y,d.(i).(j)) :: accu + else + accu + in aux new_accu (i,j-1) + | (i,j) when (i=j) -> aux accu (i,j-1) + | _ -> assert false + in + aux [] (n-1,n-1) + |> List.map ~f:(fun (i,x,j,y,r) -> + let f = + x /. (x +. y) + in + let u = + Point3d.of_tuple ~units:Units.Bohr + ( nuclei.(i).Atom.coord.Point3d.x +. + (nuclei.(j).Atom.coord.Point3d.x -. nuclei.(i).Atom.coord.Point3d.x) *. f, + nuclei.(i).Atom.coord.Point3d.y +. + (nuclei.(j).Atom.coord.Point3d.y -. nuclei.(i).Atom.coord.Point3d.y) *. f, + nuclei.(i).Atom.coord.Point3d.z +. + (nuclei.(j).Atom.coord.Point3d.z -. nuclei.(i).Atom.coord.Point3d.z) *. f) + in + Atom.{ element = Element.X ; charge = Charge.of_int 0 ; coord = u } + ) + + +let list_basis () = + let basis_list = + Qpackage.root ^ "/install/emsl/EMSL_api.py list_basis" + |> Unix.open_process_in + |> In_channel.input_lines + |> List.map ~f:(fun x -> + match String.split x ~on:'\'' with + | [] -> "" + | a :: [] + | _ :: a :: _ -> String.strip a + ) + in + List.sort basis_list ~cmp:String.ascending + |> String.concat ~sep:"\t" + + +let run ?o b c d m p xyz_file = (* Read molecule *) let molecule = (Molecule.of_xyz_file xyz_file ~charge:(Charge.of_int c) ~multiplicity:(Multiplicity.of_int m) ) in - let nuclei = molecule.Molecule.nuclei in + let dummy = + dummy_centers ~threshold:d ~molecule ~nuclei:molecule.Molecule.nuclei + in +(* + List.iter dummy ~f:(fun x -> + Printf.printf "%s\n" (Atom.to_string ~units:Units.Angstrom x) + ); +*) + let nuclei = + molecule.Molecule.nuclei @ dummy + in + + + let basis_table = + Hashtbl.Poly.create () + in - let basis_table = Hashtbl.Poly.create () in (* Open basis set channels *) let basis_channel element = - let key = Element.to_string element in + let key = + Element.to_string element + in match Hashtbl.find basis_table key with | Some in_channel -> in_channel - | None -> - begin - Printf.printf "%s is not defined in basis %s.\nEnter alternate basis : %!" - (Element.to_long_string element) b ; - let bas = - match In_channel.input_line stdin with - | Some line -> String.strip line |> String.lowercase - | None -> failwith "Aborted" - in - let new_channel = In_channel.create - (Qpackage.root ^ "/data/basis/" ^ bas) - in - Hashtbl.add_exn basis_table ~key:key ~data:new_channel; - new_channel - end + | None -> + let msg = + Printf.sprintf "%s is not defined in basis %s.%!" + (Element.to_long_string element) b ; + in + failwith msg in let temp_filename = Filename.temp_file "qp_create_" ".basis" in + let () = + Sys.remove temp_filename + in + + let fetch_channel basis = + let command = + if (p) then + Qpackage.root ^ "/scripts/get_basis.sh \"" ^ temp_filename + ^ "." ^ basis ^ "\" \"" ^ basis ^"\" pseudo" + else + Qpackage.root ^ "/scripts/get_basis.sh \"" ^ temp_filename + ^ "." ^ basis ^ "\" \"" ^ basis ^"\"" + in + match Sys.is_file basis with + | `Yes -> + In_channel.create basis + | _ -> + begin + let filename = + Unix.open_process_in command + |> In_channel.input_all + |> String.strip + in + let new_channel = + In_channel.create filename + in + Unix.unlink filename; + new_channel + end + in + let rec build_basis = function | [] -> () | elem_and_basis_name :: rest -> begin match (String.lsplit2 ~on:':' elem_and_basis_name) with | None -> (* Principal basis *) - let basis = elem_and_basis_name in - let command = - if (p) then - Qpackage.root ^ "/scripts/get_basis.sh \"" ^ temp_filename - ^ "\" \"" ^ basis ^"\" pseudo" - else - Qpackage.root ^ "/scripts/get_basis.sh \"" ^ temp_filename - ^ "\" \"" ^ basis ^"\"" - in begin - let filename = - Unix.open_process_in command - |> In_channel.input_all - |> String.strip + let basis = + elem_and_basis_name in let new_channel = - In_channel.create filename + fetch_channel basis in - Unix.unlink filename; List.iter nuclei ~f:(fun elem-> - let key = Element.to_string elem.Atom.element + let key = + Element.to_string elem.Atom.element in match Hashtbl.add basis_table ~key:key ~data:new_channel with | `Ok -> () @@ -89,25 +182,18 @@ let run ?o b c m p xyz_file = end | Some (key, basis) -> (*Aux basis *) begin - let elem = Element.of_string key - and basis = String.lowercase basis + let elem = + Element.of_string key + and basis = + String.lowercase basis in - let key = Element.to_string elem + let key = + Element.to_string elem in - let command = - Qpackage.root ^ "/scripts/get_basis.sh \"" ^ temp_filename ^ - "\" \"" ^ basis ^ "\" " ^ key + let new_channel = + fetch_channel basis in begin - let filename = - Unix.open_process_in command - |> In_channel.input_all - |> String.strip - in - let new_channel = - In_channel.create filename - in - Unix.unlink filename; match Hashtbl.add basis_table ~key:key ~data:new_channel with | `Ok -> () | `Duplicate -> failwith ("Duplicate definition of basis for "^(Element.to_long_string elem)) @@ -164,28 +250,30 @@ let run ?o b c m p xyz_file = (* Write Basis set *) let basis = - let nmax = Nucl_number.get_max () in + let nmax = + Nucl_number.get_max () + in let rec do_work (accu:(Atom.t*Nucl_number.t) list) (n:int) = function | [] -> accu | e::tail -> - let new_accu = (e,(Nucl_number.of_int ~max:nmax n))::accu in + let new_accu = + (e,(Nucl_number.of_int ~max:nmax n))::accu + in do_work new_accu (n+1) tail in let result = do_work [] 1 nuclei |> List.rev |> List.map ~f:(fun (x,i) -> try - Basis.read_element (basis_channel x.Atom.element) i x.Atom.element + let e = + match x.Atom.element with + | Element.X -> Element.H + | e -> e + in + Basis.read_element (basis_channel x.Atom.element) i e with - | End_of_file -> - begin - let alt_channel = basis_channel x.Atom.element in - try - Basis.read_element alt_channel i x.Atom.element - with - End_of_file -> failwith - ("Element "^(Element.to_string x.Atom.element)^" not found") - end + | End_of_file -> failwith + ("Element "^(Element.to_string x.Atom.element)^" not found in basis set.") ) |> List.concat in @@ -264,28 +352,37 @@ let run ?o b c m p xyz_file = | None -> failwith "Error in basis" | Some x -> Input.Ao_basis.write x -;; + let command = Command.basic ~summary: "Quantum Package command" ~readme:(fun () -> " -Creates an EZFIO directory from a standard xyz file. -The basis set is defined as a single string if all the -atoms are taken from the same basis set, otherwise specific -elements can be defined as follows: + +=== Available basis sets === + +" ^ (list_basis ()) ^ " + +============================ + +Creates an EZFIO directory from a standard xyz file. The basis set is defined +as a single string if all the atoms are taken from the same basis set, +otherwise specific elements can be defined as follows: -b \"cc-pcvdz | H:cc-pvdz | C:6-31g\" - ") +If a file with the same name as the basis set exists, this file will be read. +Otherwise, the basis set is obtained from the database. + +" ) spec - (fun o b c m p xyz_file () -> - run ?o b c m p xyz_file ) -;; + (fun o b c d m p xyz_file () -> + run ?o b c d m p xyz_file ) + let () = Command.run command -;; + diff --git a/ocaml/qp_edit.ml b/ocaml/qp_edit.ml new file mode 100644 index 00000000..f6a2ac9c --- /dev/null +++ b/ocaml/qp_edit.ml @@ -0,0 +1,308 @@ +open Qputils;; +open Qptypes;; +open Core.Std;; + +(** Interactive editing of the input. + +WARNING +This file is autogenerad by +`${QP_ROOT}/script/ezfio_interface/ei_handler.py` +*) + + +(** Keywords used to define input sections *) +type keyword = +| Ao_basis +| Determinants_by_hand +| Electrons +| Mo_basis +| Nuclei +| Determinants +| Hartree_fock +| Integrals_bielec +| Perturbation +| Properties +| Pseudo +;; + + +let keyword_to_string = function +| Ao_basis -> "AO basis" +| Determinants_by_hand -> "Determinants_by_hand" +| Electrons -> "Electrons" +| Mo_basis -> "MO basis" +| Nuclei -> "Molecule" +| Determinants -> "Determinants" +| Hartree_fock -> "Hartree_fock" +| Integrals_bielec -> "Integrals_bielec" +| Perturbation -> "Perturbation" +| Properties -> "Properties" +| Pseudo -> "Pseudo" +;; + + + +(** Create the header of the temporary file *) +let file_header filename = + Printf.sprintf " +================================================================== + Quantum Package +================================================================== + +Editing file `%s` + +" filename +;; + + +(** Creates the header of a section *) +let make_header kw = + let s = keyword_to_string kw in + let l = String.length s in + "\n\n"^s^"\n"^(String.init l ~f:(fun _ -> '='))^"\n\n" +;; + + +(** Returns the rst string of section [s] *) +let get s = + let header = (make_header s) in + let f (read,to_rst) = + match read () with + | Some text -> header ^ (Rst_string.to_string (to_rst text)) + | None -> "" + in + let rst = + try + begin + let open Input in + match s with + | Mo_basis -> + f Mo_basis.(read, to_rst) + | Electrons -> + f Electrons.(read, to_rst) + | Nuclei -> + f Nuclei.(read, to_rst) + | Ao_basis -> + f Ao_basis.(read, to_rst) + | Determinants_by_hand -> + f Determinants_by_hand.(read, to_rst) + | Determinants -> + f Determinants.(read, to_rst) + | Hartree_fock -> + f Hartree_fock.(read, to_rst) + | Integrals_bielec -> + f Integrals_bielec.(read, to_rst) + | Perturbation -> + f Perturbation.(read, to_rst) + | Properties -> + f Properties.(read, to_rst) + | Pseudo -> + f Pseudo.(read, to_rst) + end + with + | Sys_error msg -> (Printf.eprintf "Info: %s\n%!" msg ; "") + in + rst +;; + + +(** Applies the changes from the string [str] corresponding to section [s] *) +let set str s = + let header = (make_header s) in + match String.substr_index ~pos:0 ~pattern:header str with + | None -> () + | Some idx -> + begin + let index_begin = idx + (String.length header) in + let index_end = + match ( String.substr_index ~pos:(index_begin+(String.length header)+1) + ~pattern:"==" str) with + | Some i -> i + | None -> String.length str + in + let l = index_end - index_begin in + let str = String.sub ~pos:index_begin ~len:l str + |> Rst_string.of_string + in + let write (of_rst,w) s = + try + match of_rst str with + | Some data -> w data + | None -> () + with + | _ -> (Printf.eprintf "Info: Read error in %s\n%!" + (keyword_to_string s); ignore (of_rst str) ) + in + let open Input in + match s with + | Determinants -> write Determinants.(of_rst, write) s + | Hartree_fock -> write Hartree_fock.(of_rst, write) s + | Integrals_bielec -> write Integrals_bielec.(of_rst, write) s + | Perturbation -> write Perturbation.(of_rst, write) s + | Properties -> write Properties.(of_rst, write) s + | Pseudo -> write Pseudo.(of_rst, write) s + | Electrons -> write Electrons.(of_rst, write) s + | Determinants_by_hand -> write Determinants_by_hand.(of_rst, write) s + | Nuclei -> write Nuclei.(of_rst, write) s + | Ao_basis -> () (* TODO *) + | Mo_basis -> () (* TODO *) + end +;; + + +(** Creates the temporary file for interactive editing *) +let create_temp_file ezfio_filename fields = + let temp_filename = Filename.temp_file "qp_edit_" ".rst" in + begin + Out_channel.with_file temp_filename ~f:(fun out_channel -> + (file_header ezfio_filename) :: (List.map ~f:get fields) + |> String.concat ~sep:"\n" + |> Out_channel.output_string out_channel + ) + end + ; temp_filename +;; + + + +let run check_only ezfio_filename = + + (* Open EZFIO *) + if (not (Sys.file_exists_exn ezfio_filename)) then + failwith (ezfio_filename^" does not exists"); + + Ezfio.set_file ezfio_filename; + + (* + let output = (file_header ezfio_filename) :: ( + List.map ~f:get [ + Ao_basis ; + Mo_basis ; + ]) + in + String.concat output + |> print_string + *) + + let tasks = [ + Nuclei ; + Ao_basis; + Electrons ; + Determinants ; + Hartree_fock ; + Integrals_bielec ; + Perturbation ; + Properties ; + Pseudo ; + Mo_basis; + Determinants_by_hand ; + ] + in + + (* Create the temp file *) + let temp_filename = create_temp_file ezfio_filename tasks in + + (* Open the temp file with external editor *) + let editor = + match Sys.getenv "EDITOR" with + | Some editor -> editor + | None -> "vi" + in + + match check_only with + | true -> () + | false -> + Printf.sprintf "%s %s ; tput sgr0 2> /dev/null" editor temp_filename + |> Sys.command_exn + ; + + (* Re-read the temp file *) + let temp_string = + In_channel.with_file temp_filename ~f:(fun in_channel -> + In_channel.input_all in_channel) + in + List.iter ~f:(fun x -> set temp_string x) tasks; + + (* Remove temp_file *) + Sys.remove temp_filename; +;; + + +(** Create a backup file in case of an exception *) +let create_backup ezfio_filename = + Printf.sprintf " + rm -f %s/backup.tgz ; + tar -zcf .backup.tgz %s && mv .backup.tgz %s/backup.tgz + " + ezfio_filename ezfio_filename ezfio_filename + |> Sys.command_exn +;; + + +(** Restore the backup file when an exception occuprs *) +let restore_backup ezfio_filename = + Printf.sprintf "tar -zxf %s/backup.tgz" + ezfio_filename + |> Sys.command_exn +;; + + +let spec = + let open Command.Spec in + empty + +> flag "-c" no_arg + ~doc:"Checks the input data" +(* + +> flag "o" (optional string) + ~doc:"Prints output data" +*) + +> anon ("ezfio_file" %: string) +;; + +let command = + Command.basic + ~summary: "Quantum Package command" + ~readme:(fun () -> + " +Edit input data + ") + spec +(* (fun i o ezfio_file () -> *) + (*fun ezfio_file () -> + try + run ezfio_file + with + | _ msg -> print_string ("\n\nError\n\n"^msg^"\n\n") + *) + (fun c ezfio_file () -> + try + run c ezfio_file ; + (* create_backup ezfio_file; *) + with + | Failure exc + | Invalid_argument exc as e -> + begin + Printf.eprintf "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n\n"; + Printf.eprintf "%s\n\n" exc; + Printf.eprintf "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n\n"; + (* restore_backup ezfio_file; *) + raise e + end + | Assert_failure (file, line, ch) as e -> + begin + Printf.eprintf "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n\n"; + Printf.eprintf "Assert error in file $QP_ROOT/ocaml/%s, line %d, character %d\n\n" file line ch; + Printf.eprintf "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n\n"; + (* restore_backup ezfio_file; *) + raise e + end + ) +;; + +let () = + Command.run command; + exit 0 +;; + + + diff --git a/ocaml/qp_run.ml b/ocaml/qp_run.ml index 2abea107..eb1445d8 100644 --- a/ocaml/qp_run.ml +++ b/ocaml/qp_run.ml @@ -42,7 +42,7 @@ let run exe ezfio_file = let spec = let open Command.Spec in empty - +> anon ("exectuable" %: string) + +> anon ("executable" %: string) +> anon ("ezfio_file" %: string) ;; diff --git a/ocaml/qptypes_generator.ml b/ocaml/qptypes_generator.ml index be2bf18c..44901af8 100644 --- a/ocaml/qptypes_generator.ml +++ b/ocaml/qptypes_generator.ml @@ -83,6 +83,12 @@ let input_data = " assert (x >= 0.) ; assert (x <= 1.) ; +* Energy : float + assert (x <=0.) ; + +* S2 : float + assert (x >=0.) ; + * PT2_energy : float assert (x >=0.) ; diff --git a/ocaml/test_molecule.ml b/ocaml/test_molecule.ml index 3abd7e9a..5d2935ed 100644 --- a/ocaml/test_molecule.ml +++ b/ocaml/test_molecule.ml @@ -39,6 +39,15 @@ H 0.54386314 0.00000000 -0.92559535 let m = Molecule.of_xyz_file "c2h6.xyz" in print_string (Molecule.to_string m); + print_string "\nDistance matrix\n"; + print_string "---------------\n"; + let d = + Molecule.distance_matrix m + in + Array.iter d ~f:(fun x -> + Array.iter x ~f:(fun y -> Printf.printf "%12.8f " y); + print_newline (); + ) ;; test_molecule ();; diff --git a/plugins/CASSCF/EZFIO.cfg b/plugins/CASSCF/EZFIO.cfg new file mode 100644 index 00000000..e9e6e92e --- /dev/null +++ b/plugins/CASSCF/EZFIO.cfg @@ -0,0 +1,10 @@ +[energy] +type: double precision +doc: "Calculated CAS-SCF energy" +interface: ezfio + +[energy_pt2] +type: double precision +doc: "Calculated selected CAS-SCF energy with PT2 correction" +interface: ezfio + diff --git a/plugins/CASSCF/H_apply.irp.f b/plugins/CASSCF/H_apply.irp.f new file mode 100644 index 00000000..35c45fb6 --- /dev/null +++ b/plugins/CASSCF/H_apply.irp.f @@ -0,0 +1,39 @@ +use bitmasks +BEGIN_SHELL [ /usr/bin/env python ] +from generate_h_apply import * + +s = H_apply("CAS_SD") +print s + +s = H_apply("CAS_SD_selected_no_skip") +s.set_selection_pt2("epstein_nesbet_2x2") +s.unset_skip() +print s + +s = H_apply("CAS_SD_selected") +s.set_selection_pt2("epstein_nesbet_2x2") +print s + +s = H_apply("CAS_SD_PT2") +s.set_perturbation("epstein_nesbet_2x2") +print s + + +s = H_apply("CAS_S",do_double_exc=False) +print s + +s = H_apply("CAS_S_selected_no_skip",do_double_exc=False) +s.set_selection_pt2("epstein_nesbet_2x2") +s.unset_skip() +print s + +s = H_apply("CAS_S_selected",do_double_exc=False) +s.set_selection_pt2("epstein_nesbet_2x2") +print s + +s = H_apply("CAS_S_PT2",do_double_exc=False) +s.set_perturbation("epstein_nesbet_2x2") +print s + +END_SHELL + diff --git a/plugins/CASSCF/NEEDED_CHILDREN_MODULES b/plugins/CASSCF/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..29e39f2f --- /dev/null +++ b/plugins/CASSCF/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Generators_CAS Perturbation Selectors_full diff --git a/plugins/CASSCF/README.rst b/plugins/CASSCF/README.rst new file mode 100644 index 00000000..ceeb7477 --- /dev/null +++ b/plugins/CASSCF/README.rst @@ -0,0 +1,20 @@ +====== +CASSCF +====== + +This module is not a "real" CAS-SCF. It is an orbital optimization step done by : + +1) Doing the CAS+SD +2) Taking one-electron density matrix +3) Cancelling all active-active rotations +4) Finding the order which matches with the input MOs + + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. diff --git a/plugins/CASSCF/casscf.irp.f b/plugins/CASSCF/casscf.irp.f new file mode 100644 index 00000000..4e7450dc --- /dev/null +++ b/plugins/CASSCF/casscf.irp.f @@ -0,0 +1,220 @@ +program casscf + implicit none + BEGIN_DOC +! Optimize MOs and CI coefficients of the CAS + END_DOC + + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) + integer(bit_kind), allocatable :: generators_bitmask_save(:,:,:,:) + + integer :: degree, N_generators_bitmask_save, N_det_ci + double precision :: E_old, E_CI + double precision :: selection_criterion_save, selection_criterion_min_save + + integer :: N_det_old + integer :: i, j, k, l + integer :: i_bit, j_bit, i_int, j_int + integer(bit_kind), allocatable :: bit_tmp(:), cas_bm(:) + character*(64) :: label + + allocate( pt2(N_states), norm_pert(N_states),H_pert_diag(N_states) ) + allocate( generators_bitmask_save(N_int,2,6,N_generators_bitmask) ) + allocate( bit_tmp(N_int), cas_bm(N_int) ) + + PROVIDE N_det_cas + N_det_old = 0 + pt2 = 1.d0 + E_CI = 1.d0 + E_old = 0.d0 + diag_algorithm = "Lapack" + selection_criterion_save = selection_criterion + selection_criterion_min_save = selection_criterion_min + + + cas_bm = 0_bit_kind + do i=1,N_cas_bitmask + do j=1,N_int + cas_bm(j) = ior(cas_bm(j), cas_bitmask(j,1,i)) + cas_bm(j) = ior(cas_bm(j), cas_bitmask(j,2,i)) + enddo + enddo + + ! Save CAS-SD bitmask + generators_bitmask_save = generators_bitmask + N_generators_bitmask_save = N_generators_bitmask + + ! Set the CAS bitmask + do i=1,6 + generators_bitmask(:,:,i,:) = cas_bitmask + enddo + N_generators_bitmask = N_cas_bitmask + SOFT_TOUCH generators_bitmask N_generators_bitmask + + + ! If the number of dets already in the file is larger than the requested + ! number of determinants, truncate the wf + if (N_det > N_det_max) then + call diagonalize_CI + call save_wavefunction + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + N_det = N_det_max + soft_touch N_det psi_det psi_coef + call diagonalize_CI + call save_wavefunction + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + print *, 'PT2 = ', pt2 + print *, 'E = ', CI_energy + print *, 'E+PT2 = ', CI_energy+pt2 + print *, '-----' + endif + + ! Start MCSCF iteration + + ! CAS-CI + ! ------ + + E_old = E_CI + + ! Reset the selection criterion + selection_criterion = selection_criterion_save + selection_criterion_min = selection_criterion_min_save + SOFT_TOUCH selection_criterion_min selection_criterion selection_criterion_factor + + ! Set the CAS bitmask + do i=1,6 + generators_bitmask(:,:,i,:) = cas_bitmask + enddo + N_generators_bitmask = N_cas_bitmask + SOFT_TOUCH generators_bitmask N_generators_bitmask + + do while (N_det < N_det_max.and.maxval(abs(pt2(1:N_states))) > pt2_max) + N_det_old = N_det + call H_apply_CAS_SD_selected_no_skip(pt2, norm_pert, H_pert_diag, N_states) + + PROVIDE psi_coef + PROVIDE psi_det + PROVIDE psi_det_sorted + + if (N_det > N_det_max) then + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + N_det = N_det_max + soft_touch N_det psi_det psi_coef + endif + call diagonalize_CI + call save_wavefunction + print *, '======' + print *, 'CAS-CI' + print *, '======' + print *, '' + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + print *, 'PT2 = ', pt2 + print *, 'E(CAS) = ', CI_energy + print *, 'E(CAS)+PT2 = ', CI_energy+pt2 + print *, '-----' + print *, '' + E_CI = sum(CI_energy(1:N_states)+pt2(1:N_states))/dble(N_states) + + call ezfio_set_casscf_energy(CI_energy(1)) + if (abort_all) then + exit + endif + if (N_det == N_det_old) then + exit + endif + + enddo + + ! Super-CI + ! -------- + + selection_criterion_min = 1.d-12 + selection_criterion = 1.d-12 + + ! Set the CAS bitmask + generators_bitmask = generators_bitmask_save + N_generators_bitmask = N_generators_bitmask_save + SOFT_TOUCH generators_bitmask N_generators_bitmask selection_criterion selection_criterion_min selection_criterion_factor + + N_det_ci = N_det + + call H_apply_CAS_SD_selected(pt2, norm_pert, H_pert_diag, N_states) + + + do i=1,mo_tot_num + i_int = ishft(i-1,-bit_kind_shift)+1 + i_bit = j-ishft(i_int-1,bit_kind_shift)-1 + bit_tmp(:) = 0_bit_kind + bit_tmp(i_int) = ibset(0_bit_kind,i_bit) + if (iand(bit_tmp(i_int), cas_bm(i_int)) == 0_bit_kind) then + ! Not a CAS MO + cycle + endif + + do j=1,mo_tot_num + if (j == i) then + cycle + endif + j_int = ishft(j-1,-bit_kind_shift)+1 + j_bit = j-ishft(j_int-1,bit_kind_shift)-1 + bit_tmp(:) = 0_bit_kind + bit_tmp(j_int) = ibset(0_bit_kind,j_bit) + if (iand(bit_tmp(j_int), cas_bm(j_int)) == 0_bit_kind) then + ! Not a CAS MO + cycle + endif + ! Now, both i and j are MOs of the CAS. De-couple them in the DM + one_body_dm_mo(i,j) = 0.d0 + enddo + + enddo + + SOFT_TOUCH one_body_dm_mo + + double precision :: mx, ov + double precision, allocatable :: mo_coef_old(:,:) + integer, allocatable :: iorder(:) + logical, allocatable :: selected(:) + allocate( mo_coef_old(size(mo_coef,1), size(mo_coef,2)), iorder(mo_tot_num), selected(mo_tot_num) ) + mo_coef_old = mo_coef + label = "Canonical" + call mo_as_eigvectors_of_mo_matrix(one_body_dm_mo,size(one_body_dm_mo,1),size(one_body_dm_mo,2),label,-1) + selected = .False. + do j=1,mo_tot_num + mx = -1.d0 + iorder(j) = j + do i=1,mo_tot_num + if (selected(i)) then + cycle + endif + ov = 0.d0 + do l=1,ao_num + do k=1,ao_num + ov = ov + mo_coef_old(k,j) * ao_overlap(k,l) * mo_coef(l,i) + enddo + enddo + ov= dabs(ov) + if (ov > mx) then + mx = ov + iorder(j) = i + endif + enddo + selected( iorder(j) ) = .True. + enddo + mo_coef_old = mo_coef + do i=1,mo_tot_num + mo_coef(:,i) = mo_coef_old(:,iorder(i)) + enddo + + call save_mos + + call write_double(6,E_CI,"Energy(CAS)") + + deallocate( mo_coef_old ) + deallocate( pt2, norm_pert,H_pert_diag ) + deallocate( generators_bitmask_save ) + deallocate( bit_tmp, cas_bm, iorder ) +end diff --git a/plugins/CAS_SD/H_apply.irp.f b/plugins/CAS_SD/H_apply.irp.f index e2f939fe..35c45fb6 100644 --- a/plugins/CAS_SD/H_apply.irp.f +++ b/plugins/CAS_SD/H_apply.irp.f @@ -5,7 +5,6 @@ from generate_h_apply import * s = H_apply("CAS_SD") print s - s = H_apply("CAS_SD_selected_no_skip") s.set_selection_pt2("epstein_nesbet_2x2") s.unset_skip() @@ -19,5 +18,22 @@ s = H_apply("CAS_SD_PT2") s.set_perturbation("epstein_nesbet_2x2") print s + +s = H_apply("CAS_S",do_double_exc=False) +print s + +s = H_apply("CAS_S_selected_no_skip",do_double_exc=False) +s.set_selection_pt2("epstein_nesbet_2x2") +s.unset_skip() +print s + +s = H_apply("CAS_S_selected",do_double_exc=False) +s.set_selection_pt2("epstein_nesbet_2x2") +print s + +s = H_apply("CAS_S_PT2",do_double_exc=False) +s.set_perturbation("epstein_nesbet_2x2") +print s + END_SHELL diff --git a/plugins/CAS_SD/README.rst b/plugins/CAS_SD/README.rst index 258410a1..f2d76615 100644 --- a/plugins/CAS_SD/README.rst +++ b/plugins/CAS_SD/README.rst @@ -118,69 +118,101 @@ Documentation Undocumented -`h_apply_cas_sd `_ +h_apply_cas_sd Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_cas_sd_diexc `_ +h_apply_cas_sd_diexc + Undocumented + + +h_apply_cas_sd_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cas_sd_monoexc `_ +h_apply_cas_sd_diexcp + Undocumented + + +h_apply_cas_sd_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cas_sd_pt2 `_ +h_apply_cas_sd_pt2 Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_cas_sd_pt2_diexc `_ +h_apply_cas_sd_pt2_diexc + Undocumented + + +h_apply_cas_sd_pt2_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cas_sd_pt2_monoexc `_ +h_apply_cas_sd_pt2_diexcp + Undocumented + + +h_apply_cas_sd_pt2_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cas_sd_selected `_ +h_apply_cas_sd_selected Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_cas_sd_selected_diexc `_ +h_apply_cas_sd_selected_diexc + Undocumented + + +h_apply_cas_sd_selected_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cas_sd_selected_monoexc `_ +h_apply_cas_sd_selected_diexcp + Undocumented + + +h_apply_cas_sd_selected_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cas_sd_selected_no_skip `_ +h_apply_cas_sd_selected_no_skip Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_cas_sd_selected_no_skip_diexc `_ +h_apply_cas_sd_selected_no_skip_diexc + Undocumented + + +h_apply_cas_sd_selected_no_skip_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cas_sd_selected_no_skip_monoexc `_ +h_apply_cas_sd_selected_no_skip_diexcp + Undocumented + + +h_apply_cas_sd_selected_no_skip_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. diff --git a/plugins/CAS_SD/cas_s.irp.f b/plugins/CAS_SD/cas_s.irp.f new file mode 100644 index 00000000..e0c4a663 --- /dev/null +++ b/plugins/CAS_SD/cas_s.irp.f @@ -0,0 +1,95 @@ +program full_ci + implicit none + integer :: i,k + integer :: N_det_old + + + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) + integer :: N_st, degree + N_st = N_states + allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st)) + character*(64) :: perturbation + PROVIDE N_det_cas + + N_det_old = 0 + pt2 = 1.d0 + diag_algorithm = "Lapack" + if (N_det > N_det_max) then + call diagonalize_CI + call save_wavefunction + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + N_det = N_det_max + soft_touch N_det psi_det psi_coef + call diagonalize_CI + call save_wavefunction + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + print *, 'PT2 = ', pt2 + print *, 'E = ', CI_energy + print *, 'E+PT2 = ', CI_energy+pt2 + print *, '-----' + endif + + do while (N_det < N_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) + N_det_old = N_det + call H_apply_CAS_S(pt2, norm_pert, H_pert_diag, N_st) + + PROVIDE psi_coef + PROVIDE psi_det + PROVIDE psi_det_sorted + + if (N_det > N_det_max) then + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + N_det = N_det_max + soft_touch N_det psi_det psi_coef + endif + call diagonalize_CI + call save_wavefunction + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + print *, 'PT2 = ', pt2 + print *, 'E = ', CI_energy + print *, 'E+PT2 = ', CI_energy+pt2 + print *, '-----' + call ezfio_set_cas_sd_energy(CI_energy(1)) + if (abort_all) then + exit + endif + if (N_det == N_det_old) then + exit + endif + enddo + call diagonalize_CI + + if(do_pt2_end)then + print*,'Last iteration only to compute the PT2' + threshold_selectors = 1.d0 + threshold_generators = 0.999d0 + call H_apply_CAS_S_PT2(pt2, norm_pert, H_pert_diag, N_st) + + print *, 'Final step' + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + print *, 'PT2 = ', pt2 + print *, 'E = ', CI_energy + print *, 'E+PT2 = ', CI_energy+pt2 + print *, '-----' + call ezfio_set_cas_sd_energy_pt2(CI_energy(1)+pt2(1)) + endif + + + integer :: exc_max, degree_min + exc_max = 0 + print *, 'CAS determinants : ', N_det_cas + do i=1,min(N_det_cas,10) + do k=i,N_det_cas + call get_excitation_degree(psi_cas(1,1,k),psi_cas(1,1,i),degree,N_int) + exc_max = max(exc_max,degree) + enddo + call debug_det(psi_cas(1,1,i),N_int) + print *, '' + enddo + print *, 'Max excitation degree in the CAS :', exc_max +end diff --git a/plugins/CAS_SD/cas_s_selected.irp.f b/plugins/CAS_SD/cas_s_selected.irp.f new file mode 100644 index 00000000..7a72a243 --- /dev/null +++ b/plugins/CAS_SD/cas_s_selected.irp.f @@ -0,0 +1,89 @@ +program full_ci + implicit none + integer :: i,k + + + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) + integer :: N_st, degree + N_st = N_states + allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st)) + character*(64) :: perturbation + PROVIDE N_det_cas + + pt2 = 1.d0 + diag_algorithm = "Lapack" + if (N_det > N_det_max) then + call diagonalize_CI + call save_wavefunction + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + N_det = N_det_max + soft_touch N_det psi_det psi_coef + call diagonalize_CI + call save_wavefunction + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + print *, 'PT2 = ', pt2 + print *, 'E = ', CI_energy + print *, 'E+PT2 = ', CI_energy+pt2 + print *, '-----' + endif + + do while (N_det < N_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) + call H_apply_CAS_S_selected(pt2, norm_pert, H_pert_diag, N_st) + + PROVIDE psi_coef + PROVIDE psi_det + PROVIDE psi_det_sorted + + if (N_det > N_det_max) then + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + N_det = N_det_max + soft_touch N_det psi_det psi_coef + endif + call diagonalize_CI + call save_wavefunction + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + print *, 'PT2 = ', pt2 + print *, 'E = ', CI_energy + print *, 'E+PT2 = ', CI_energy+pt2 + print *, '-----' + call ezfio_set_cas_sd_energy(CI_energy(1)) + if (abort_all) then + exit + endif + enddo + call diagonalize_CI + + if(do_pt2_end)then + print*,'Last iteration only to compute the PT2' + threshold_selectors = 1.d0 + threshold_generators = 0.999d0 + call H_apply_CAS_S_PT2(pt2, norm_pert, H_pert_diag, N_st) + + print *, 'Final step' + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + print *, 'PT2 = ', pt2 + print *, 'E = ', CI_energy + print *, 'E+PT2 = ', CI_energy+pt2 + print *, '-----' + call ezfio_set_cas_sd_energy_pt2(CI_energy(1)+pt2(1)) + endif + + + integer :: exc_max, degree_min + exc_max = 0 + print *, 'CAS determinants : ', N_det_cas + do i=1,min(N_det_cas,10) + do k=i,N_det_cas + call get_excitation_degree(psi_cas(1,1,k),psi_cas(1,1,i),degree,N_int) + exc_max = max(exc_max,degree) + enddo + call debug_det(psi_cas(1,1,i),N_int) + print *, '' + enddo + print *, 'Max excitation degree in the CAS :', exc_max +end diff --git a/plugins/CID/README.rst b/plugins/CID/README.rst index 385ef092..3dd5ae24 100644 --- a/plugins/CID/README.rst +++ b/plugins/CID/README.rst @@ -203,3 +203,48 @@ Documentation particles. Assume N_int is already provided. +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +.. image:: tree_dependency.png + +* `Selectors_full `_ +* `SingleRefMethod `_ + +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +`cid `_ + Undocumented + + +h_apply_cid + Calls H_apply on the HF determinant and selects all connected single and double + excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + + +h_apply_cid_diexc + Undocumented + + +h_apply_cid_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_cid_diexcp + Undocumented + + +h_apply_cid_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + diff --git a/plugins/CISD/.gitignore b/plugins/CISD/.gitignore index 49d9e244..5c7aee18 100644 --- a/plugins/CISD/.gitignore +++ b/plugins/CISD/.gitignore @@ -20,6 +20,7 @@ Pseudo Selectors_full SingleRefMethod Utils +cisd cisd_lapack ezfio_interface.irp.f irpf90.make diff --git a/plugins/CISD/EZFIO.cfg b/plugins/CISD/EZFIO.cfg new file mode 100644 index 00000000..dc3ee61d --- /dev/null +++ b/plugins/CISD/EZFIO.cfg @@ -0,0 +1,10 @@ +[energy] +type: double precision +doc: Variational CISD energy +interface: ezfio + +[energy_pt2] +type: double precision +doc: Estimated CISD energy (including PT2) +interface: ezfio + diff --git a/plugins/CISD/README.rst b/plugins/CISD/README.rst index 79123d2a..af772201 100644 --- a/plugins/CISD/README.rst +++ b/plugins/CISD/README.rst @@ -59,22 +59,26 @@ Documentation .. by the `update_README.py` script. -`cisd `_ - Undocumented - - -`h_apply_cisd `_ +h_apply_cisd Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_cisd_diexc `_ +h_apply_cisd_diexc + Undocumented + + +h_apply_cisd_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cisd_monoexc `_ +h_apply_cisd_diexcp + Undocumented + + +h_apply_cisd_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. diff --git a/plugins/CISD/tree_dependency.png b/plugins/CISD/tree_dependency.png index fbe8169d..fcf48831 100644 Binary files a/plugins/CISD/tree_dependency.png and b/plugins/CISD/tree_dependency.png differ diff --git a/plugins/CISD_SC2_selected/README.rst b/plugins/CISD_SC2_selected/README.rst index a4ddd1bd..6b7aba83 100644 --- a/plugins/CISD_SC2_selected/README.rst +++ b/plugins/CISD_SC2_selected/README.rst @@ -72,3 +72,122 @@ Needed Modules * `CISD_selected `_ +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +.. image:: tree_dependency.png + +* `CISD_selected `_ + +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +`cisd_sc2_selected `_ + Undocumented + + +h_apply_cisd + Calls H_apply on the HF determinant and selects all connected single and double + excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + + +h_apply_cisd_diexc + Undocumented + + +h_apply_cisd_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_cisd_diexcp + Undocumented + + +h_apply_cisd_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_pt2 + Calls H_apply on the HF determinant and selects all connected single and double + excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + + +h_apply_pt2_diexc + Undocumented + + +h_apply_pt2_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_pt2_diexcp + Undocumented + + +h_apply_pt2_en_sc2 + Calls H_apply on the HF determinant and selects all connected single and double + excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + + +h_apply_pt2_en_sc2_diexc + Undocumented + + +h_apply_pt2_en_sc2_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_pt2_en_sc2_diexcp + Undocumented + + +h_apply_pt2_en_sc2_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_pt2_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_sc2_selected + Calls H_apply on the HF determinant and selects all connected single and double + excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + + +h_apply_sc2_selected_diexc + Undocumented + + +h_apply_sc2_selected_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_sc2_selected_diexcp + Undocumented + + +h_apply_sc2_selected_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + diff --git a/plugins/CISD_selected/README.rst b/plugins/CISD_selected/README.rst index 12ee6318..dfc4c406 100644 --- a/plugins/CISD_selected/README.rst +++ b/plugins/CISD_selected/README.rst @@ -196,22 +196,26 @@ Documentation .. by the `update_README.py` script. -`cisd `_ - Undocumented - - -`h_apply_cisd `_ +h_apply_cisd Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_cisd_diexc `_ +h_apply_cisd_diexc + Undocumented + + +h_apply_cisd_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cisd_monoexc `_ +h_apply_cisd_diexcp + Undocumented + + +h_apply_cisd_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. @@ -221,154 +225,226 @@ Documentation Undocumented -`h_apply_cisd_selection_delta_rho_one_point `_ +h_apply_cisd_selection_delta_rho_one_point Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_cisd_selection_delta_rho_one_point_diexc `_ +h_apply_cisd_selection_delta_rho_one_point_diexc + Undocumented + + +h_apply_cisd_selection_delta_rho_one_point_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cisd_selection_delta_rho_one_point_monoexc `_ +h_apply_cisd_selection_delta_rho_one_point_diexcp + Undocumented + + +h_apply_cisd_selection_delta_rho_one_point_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cisd_selection_dipole_moment_z `_ +h_apply_cisd_selection_dipole_moment_z Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_cisd_selection_dipole_moment_z_diexc `_ +h_apply_cisd_selection_dipole_moment_z_diexc + Undocumented + + +h_apply_cisd_selection_dipole_moment_z_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cisd_selection_dipole_moment_z_monoexc `_ +h_apply_cisd_selection_dipole_moment_z_diexcp + Undocumented + + +h_apply_cisd_selection_dipole_moment_z_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cisd_selection_epstein_nesbet `_ +h_apply_cisd_selection_epstein_nesbet Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_cisd_selection_epstein_nesbet_2x2 `_ +h_apply_cisd_selection_epstein_nesbet_2x2 Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_cisd_selection_epstein_nesbet_2x2_diexc `_ +h_apply_cisd_selection_epstein_nesbet_2x2_diexc + Undocumented + + +h_apply_cisd_selection_epstein_nesbet_2x2_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cisd_selection_epstein_nesbet_2x2_monoexc `_ +h_apply_cisd_selection_epstein_nesbet_2x2_diexcp + Undocumented + + +h_apply_cisd_selection_epstein_nesbet_2x2_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cisd_selection_epstein_nesbet_diexc `_ +h_apply_cisd_selection_epstein_nesbet_diexc + Undocumented + + +h_apply_cisd_selection_epstein_nesbet_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cisd_selection_epstein_nesbet_monoexc `_ +h_apply_cisd_selection_epstein_nesbet_diexcp + Undocumented + + +h_apply_cisd_selection_epstein_nesbet_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cisd_selection_epstein_nesbet_sc2 `_ +h_apply_cisd_selection_epstein_nesbet_sc2 Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_cisd_selection_epstein_nesbet_sc2_diexc `_ +h_apply_cisd_selection_epstein_nesbet_sc2_diexc + Undocumented + + +h_apply_cisd_selection_epstein_nesbet_sc2_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cisd_selection_epstein_nesbet_sc2_monoexc `_ +h_apply_cisd_selection_epstein_nesbet_sc2_diexcp + Undocumented + + +h_apply_cisd_selection_epstein_nesbet_sc2_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cisd_selection_epstein_nesbet_sc2_no_projected `_ +h_apply_cisd_selection_epstein_nesbet_sc2_no_projected Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_cisd_selection_epstein_nesbet_sc2_no_projected_diexc `_ +h_apply_cisd_selection_epstein_nesbet_sc2_no_projected_diexc + Undocumented + + +h_apply_cisd_selection_epstein_nesbet_sc2_no_projected_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cisd_selection_epstein_nesbet_sc2_no_projected_monoexc `_ +h_apply_cisd_selection_epstein_nesbet_sc2_no_projected_diexcp + Undocumented + + +h_apply_cisd_selection_epstein_nesbet_sc2_no_projected_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cisd_selection_epstein_nesbet_sc2_projected `_ +h_apply_cisd_selection_epstein_nesbet_sc2_projected Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_cisd_selection_epstein_nesbet_sc2_projected_diexc `_ +h_apply_cisd_selection_epstein_nesbet_sc2_projected_diexc + Undocumented + + +h_apply_cisd_selection_epstein_nesbet_sc2_projected_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cisd_selection_epstein_nesbet_sc2_projected_monoexc `_ +h_apply_cisd_selection_epstein_nesbet_sc2_projected_diexcp + Undocumented + + +h_apply_cisd_selection_epstein_nesbet_sc2_projected_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cisd_selection_h_core `_ +h_apply_cisd_selection_h_core Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_cisd_selection_h_core_diexc `_ +h_apply_cisd_selection_h_core_diexc + Undocumented + + +h_apply_cisd_selection_h_core_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cisd_selection_h_core_monoexc `_ +h_apply_cisd_selection_h_core_diexcp + Undocumented + + +h_apply_cisd_selection_h_core_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cisd_selection_moller_plesset `_ +h_apply_cisd_selection_moller_plesset Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_cisd_selection_moller_plesset_diexc `_ +h_apply_cisd_selection_moller_plesset_diexc + Undocumented + + +h_apply_cisd_selection_moller_plesset_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_cisd_selection_moller_plesset_monoexc `_ +h_apply_cisd_selection_moller_plesset_diexcp + Undocumented + + +h_apply_cisd_selection_moller_plesset_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. diff --git a/plugins/CISD_selected/cisd_selection.irp.f b/plugins/CISD_selected/cisd_selection.irp.f index b2178860..ad31269c 100644 --- a/plugins/CISD_selected/cisd_selection.irp.f +++ b/plugins/CISD_selected/cisd_selection.irp.f @@ -41,8 +41,8 @@ program cisd N_det = min(N_det,N_det_max) touch N_det psi_det psi_coef call diagonalize_CI - deallocate(pt2,norm_pert,H_pert_diag) - call save_wavefunction + call save_wavefunction call ezfio_set_cisd_selected_energy(CI_energy) call ezfio_set_cisd_selected_energy_pt2(CI_energy+pt2) + deallocate(pt2,norm_pert,H_pert_diag) end diff --git a/plugins/DDCI_selected/README.rst b/plugins/DDCI_selected/README.rst index 59489e86..91e55b32 100644 --- a/plugins/DDCI_selected/README.rst +++ b/plugins/DDCI_selected/README.rst @@ -57,3 +57,74 @@ Needed Modules * `Selectors_full `_ * `Generators_CAS `_ +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +.. image:: tree_dependency.png + +* `Perturbation `_ +* `Selectors_full `_ +* `Generators_CAS `_ + +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +`ddci `_ + Undocumented + + +h_apply_ddci_pt2 + Calls H_apply on the HF determinant and selects all connected single and double + excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + + +h_apply_ddci_pt2_diexc + Undocumented + + +h_apply_ddci_pt2_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_ddci_pt2_diexcp + Undocumented + + +h_apply_ddci_pt2_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_ddci_selection + Calls H_apply on the HF determinant and selects all connected single and double + excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + + +h_apply_ddci_selection_diexc + Undocumented + + +h_apply_ddci_selection_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_ddci_selection_diexcp + Undocumented + + +h_apply_ddci_selection_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + diff --git a/plugins/FCIdump/tree_dependency.png b/plugins/FCIdump/tree_dependency.png index e99d0434..04877dea 100644 Binary files a/plugins/FCIdump/tree_dependency.png and b/plugins/FCIdump/tree_dependency.png differ diff --git a/plugins/Full_CI/.gitignore b/plugins/Full_CI/.gitignore new file mode 100644 index 00000000..a806bcbc --- /dev/null +++ b/plugins/Full_CI/.gitignore @@ -0,0 +1,32 @@ +# Automatically created by $QP_ROOT/scripts/module/module_handler.py +.ninja_deps +.ninja_log +AO_Basis +Bitmask +Determinants +Electrons +Ezfio_files +Generators_full +Hartree_Fock +IRPF90_man +IRPF90_temp +Integrals_Bielec +Integrals_Monoelec +MOGuess +MO_Basis +Makefile +Makefile.depend +Nuclei +Perturbation +Properties +Pseudo +Selectors_full +Utils +ezfio_interface.irp.f +full_ci +full_ci_no_skip +irpf90.make +irpf90_entities +tags +target_pt2 +var_pt2_ratio \ No newline at end of file diff --git a/plugins/Full_CI/README.rst b/plugins/Full_CI/README.rst index bc2307cd..08a0d1ea 100644 --- a/plugins/Full_CI/README.rst +++ b/plugins/Full_CI/README.rst @@ -27,137 +27,201 @@ Documentation Undocumented -`h_apply_fci `_ +h_apply_fci Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_fci_diexc `_ +h_apply_fci_diexc + Undocumented + + +h_apply_fci_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_fci_mono `_ +h_apply_fci_diexcp + Undocumented + + +h_apply_fci_mono Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_fci_mono_diexc `_ +h_apply_fci_mono_diexc + Undocumented + + +h_apply_fci_mono_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_fci_mono_monoexc `_ +h_apply_fci_mono_diexcp + Undocumented + + +h_apply_fci_mono_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_fci_monoexc `_ +h_apply_fci_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_fci_no_skip `_ +h_apply_fci_no_skip Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_fci_no_skip_diexc `_ +h_apply_fci_no_skip_diexc + Undocumented + + +h_apply_fci_no_skip_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_fci_no_skip_monoexc `_ +h_apply_fci_no_skip_diexcp + Undocumented + + +h_apply_fci_no_skip_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_fci_pt2 `_ +h_apply_fci_pt2 Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_fci_pt2_diexc `_ +h_apply_fci_pt2_diexc + Undocumented + + +h_apply_fci_pt2_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_fci_pt2_monoexc `_ +h_apply_fci_pt2_diexcp + Undocumented + + +h_apply_fci_pt2_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_pt2_mono_delta_rho `_ +h_apply_pt2_mono_delta_rho Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_pt2_mono_delta_rho_diexc `_ +h_apply_pt2_mono_delta_rho_diexc + Undocumented + + +h_apply_pt2_mono_delta_rho_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_pt2_mono_delta_rho_monoexc `_ +h_apply_pt2_mono_delta_rho_diexcp + Undocumented + + +h_apply_pt2_mono_delta_rho_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_pt2_mono_di_delta_rho `_ +h_apply_pt2_mono_di_delta_rho Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_pt2_mono_di_delta_rho_diexc `_ +h_apply_pt2_mono_di_delta_rho_diexc + Undocumented + + +h_apply_pt2_mono_di_delta_rho_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_pt2_mono_di_delta_rho_monoexc `_ +h_apply_pt2_mono_di_delta_rho_diexcp + Undocumented + + +h_apply_pt2_mono_di_delta_rho_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_select_mono_delta_rho `_ +h_apply_select_mono_delta_rho Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_select_mono_delta_rho_diexc `_ +h_apply_select_mono_delta_rho_diexc + Undocumented + + +h_apply_select_mono_delta_rho_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_select_mono_delta_rho_monoexc `_ +h_apply_select_mono_delta_rho_diexcp + Undocumented + + +h_apply_select_mono_delta_rho_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_select_mono_di_delta_rho `_ +h_apply_select_mono_di_delta_rho Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_select_mono_di_delta_rho_diexc `_ +h_apply_select_mono_di_delta_rho_diexc + Undocumented + + +h_apply_select_mono_di_delta_rho_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_select_mono_di_delta_rho_monoexc `_ +h_apply_select_mono_di_delta_rho_diexcp + Undocumented + + +h_apply_select_mono_di_delta_rho_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. diff --git a/plugins/Full_CI/target_pt2.irp.f b/plugins/Full_CI/target_pt2.irp.f index f86a21a4..7e7c8fcf 100644 --- a/plugins/Full_CI/target_pt2.irp.f +++ b/plugins/Full_CI/target_pt2.irp.f @@ -27,6 +27,8 @@ program var_pt2_ratio_run call diagonalize_CI ratio = (CI_energy(1) - HF_energy) / (CI_energy(1)+pt2(1) - HF_energy) if (N_det > 20000) then + N_det = 20000 + TOUCH N_det exit endif enddo diff --git a/plugins/Full_CI/tree_dependency.png b/plugins/Full_CI/tree_dependency.png index 0dca9e35..caedb2e0 100644 Binary files a/plugins/Full_CI/tree_dependency.png and b/plugins/Full_CI/tree_dependency.png differ diff --git a/plugins/Generators_full/tree_dependency.png b/plugins/Generators_full/tree_dependency.png index ec074255..94ad6358 100644 Binary files a/plugins/Generators_full/tree_dependency.png and b/plugins/Generators_full/tree_dependency.png differ diff --git a/plugins/Hartree_Fock/EZFIO.cfg b/plugins/Hartree_Fock/EZFIO.cfg index c39c3483..d8207cc4 100644 --- a/plugins/Hartree_Fock/EZFIO.cfg +++ b/plugins/Hartree_Fock/EZFIO.cfg @@ -10,6 +10,12 @@ doc: Maximum number of SCF iterations interface: ezfio,provider,ocaml default: 200 +[level_shift] +type: Positive_float +doc: Energy shift on the virtual MOs to improve SCF convergence +interface: ezfio,provider,ocaml +default: 0.5 + [mo_guess_type] type: MO_guess doc: Initial MO guess. Can be [ Huckel | HCore ] diff --git a/plugins/Hartree_Fock/Fock_matrix.irp.f b/plugins/Hartree_Fock/Fock_matrix.irp.f index 2561ad03..12ee276b 100644 --- a/plugins/Hartree_Fock/Fock_matrix.irp.f +++ b/plugins/Hartree_Fock/Fock_matrix.irp.f @@ -73,8 +73,13 @@ enddo endif + ! Introduce level shift here + do i = elec_alpha_num+1, mo_tot_num + Fock_matrix_mo(i,i) += level_shift + enddo + do i = 1, mo_tot_num - Fock_matrix_diag_mo(i) = Fock_matrix_mo(i,i) + Fock_matrix_diag_mo(i) = Fock_matrix_mo(i,i) enddo END_PROVIDER @@ -108,9 +113,10 @@ END_PROVIDER END_DOC integer :: i,j,k,l,k1,r,s + integer :: i0,j0,k0,l0 integer*8 :: p,q - double precision :: integral - double precision :: ao_bielec_integral + double precision :: integral, c0, c1, c2 + double precision :: ao_bielec_integral, local_threshold double precision, allocatable :: ao_bi_elec_integral_alpha_tmp(:,:) double precision, allocatable :: ao_bi_elec_integral_beta_tmp(:,:) !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_beta_tmp @@ -121,11 +127,12 @@ END_PROVIDER if (do_direct_integrals) then !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,p,q,r,s, & - !$OMP ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)& + !$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,p,q,r,s,i0,j0,k0,l0, & + !$OMP ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp, c0, c1, c2, & + !$OMP local_threshold)& !$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,& !$OMP ao_integrals_map,ao_integrals_threshold, ao_bielec_integral_schwartz, & - !$OMP ao_overlap_abs, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta) + !$OMP ao_overlap_abs, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta) allocate(keys(1), values(1)) allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), & @@ -152,14 +159,16 @@ END_PROVIDER < ao_integrals_threshold) then cycle endif - if (ao_bielec_integral_schwartz(k,l)*ao_bielec_integral_schwartz(i,j) & - < ao_integrals_threshold) then - cycle - endif - values(1) = ao_bielec_integral(k,l,i,j) - if (abs(values(1)) < ao_integrals_threshold) then + local_threshold = ao_bielec_integral_schwartz(k,l)*ao_bielec_integral_schwartz(i,j) + if (local_threshold < ao_integrals_threshold) then cycle endif + i0 = i + j0 = j + k0 = k + l0 = l + values(1) = 0.d0 + local_threshold = ao_integrals_threshold/local_threshold do k2=1,8 if (kk(k2)==0) then cycle @@ -168,12 +177,21 @@ END_PROVIDER j = jj(k2) k = kk(k2) l = ll(k2) - integral = (HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l)) * values(1) + c0 = HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l) + c1 = HF_density_matrix_ao_alpha(k,i) + c2 = HF_density_matrix_ao_beta(k,i) + if ( dabs(c0)+dabs(c1)+dabs(c2) < local_threshold) then + cycle + endif + if (values(1) == 0.d0) then + values(1) = ao_bielec_integral(k0,l0,i0,j0) + endif + integral = c0 * values(1) ao_bi_elec_integral_alpha_tmp(i,j) += integral ao_bi_elec_integral_beta_tmp (i,j) += integral integral = values(1) - ao_bi_elec_integral_alpha_tmp(l,j) -= HF_density_matrix_ao_alpha(k,i) * integral - ao_bi_elec_integral_beta_tmp (l,j) -= HF_density_matrix_ao_beta (k,i) * integral + ao_bi_elec_integral_alpha_tmp(l,j) -= c1 * integral + ao_bi_elec_integral_beta_tmp (l,j) -= c2 * integral enddo enddo !$OMP END DO NOWAIT @@ -315,7 +333,9 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_ao, (ao_num_align, ao_num) ] ! Fock matrix in AO basis set END_DOC - if (elec_alpha_num == elec_beta_num) then + if ( (elec_alpha_num == elec_beta_num).and. & + (level_shift == 0.) ) & + then integer :: i,j do j=1,ao_num !DIR$ VECTOR ALIGNED @@ -324,30 +344,47 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_ao, (ao_num_align, ao_num) ] enddo enddo else - double precision, allocatable :: T(:,:), M(:,:) + double precision, allocatable :: T(:,:), M(:,:) + integer :: ierr ! F_ao = S C F_mo C^t S - allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num)) - call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, & + allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr) + if (ierr /=0 ) then + print *, irp_here, ' : allocation failed' + endif + +! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num) +! -> M(ao_num,mo_tot_num) + call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, & ao_overlap, size(ao_overlap,1), & mo_coef, size(mo_coef,1), & 0.d0, & M, size(M,1)) + +! M(ao_num,mo_tot_num) . Fock_matrix_mo (mo_tot_num,mo_tot_num) +! -> T(ao_num,mo_tot_num) call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, & M, size(M,1), & Fock_matrix_mo, size(Fock_matrix_mo,1), & 0.d0, & T, size(T,1)) - call dgemm('N','T', mo_tot_num,ao_num,mo_tot_num, 1.d0, & + +! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num) +! -> M(ao_num,ao_num) + call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, & T, size(T,1), & mo_coef, size(mo_coef,1), & 0.d0, & M, size(M,1)) + +! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num) +! -> Fock_matrix_ao(ao_num,ao_num) call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, & M, size(M,1), & ao_overlap, size(ao_overlap,1), & 0.d0, & Fock_matrix_ao, size(Fock_matrix_ao,1)) + deallocate(T) endif END_PROVIDER @@ -360,23 +397,39 @@ subroutine Fock_mo_to_ao(FMO,LDFMO,FAO,LDFAO) double precision, intent(out) :: FAO(LDFAO,*) double precision, allocatable :: T(:,:), M(:,:) + integer :: ierr ! F_ao = S C F_mo C^t S - allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num)) - call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, & + allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr) + if (ierr /=0 ) then + print *, irp_here, ' : allocation failed' + endif + +! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num) +! -> M(ao_num,mo_tot_num) + call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, & ao_overlap, size(ao_overlap,1), & mo_coef, size(mo_coef,1), & 0.d0, & M, size(M,1)) + +! M(ao_num,mo_tot_num) . FMO (mo_tot_num,mo_tot_num) +! -> T(ao_num,mo_tot_num) call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, & M, size(M,1), & FMO, size(FMO,1), & 0.d0, & T, size(T,1)) - call dgemm('N','T', mo_tot_num,ao_num,mo_tot_num, 1.d0, & + +! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num) +! -> M(ao_num,ao_num) + call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, & T, size(T,1), & mo_coef, size(mo_coef,1), & 0.d0, & M, size(M,1)) + +! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num) +! -> Fock_matrix_ao(ao_num,ao_num) call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, & M, size(M,1), & ao_overlap, size(ao_overlap,1), & diff --git a/plugins/Hartree_Fock/NEEDED_CHILDREN_MODULES b/plugins/Hartree_Fock/NEEDED_CHILDREN_MODULES index 784cb0fb..85bdd3ad 100644 --- a/plugins/Hartree_Fock/NEEDED_CHILDREN_MODULES +++ b/plugins/Hartree_Fock/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Integrals_Bielec MOGuess +Integrals_Bielec MOGuess diff --git a/plugins/Hartree_Fock/README.rst b/plugins/Hartree_Fock/README.rst index ffe80c75..26976226 100644 --- a/plugins/Hartree_Fock/README.rst +++ b/plugins/Hartree_Fock/README.rst @@ -32,11 +32,11 @@ Documentation .. by the `update_README.py` script. -`ao_bi_elec_integral_alpha `_ +`ao_bi_elec_integral_alpha `_ Alpha Fock matrix in AO basis set -`ao_bi_elec_integral_beta `_ +`ao_bi_elec_integral_beta `_ Alpha Fock matrix in AO basis set @@ -62,23 +62,23 @@ Documentation Diagonal Fock matrix in the MO basis -`fock_matrix_alpha_ao `_ +`fock_matrix_alpha_ao `_ Alpha Fock matrix in AO basis set -`fock_matrix_alpha_mo `_ +`fock_matrix_alpha_mo `_ Fock matrix on the MO basis -`fock_matrix_ao `_ +`fock_matrix_ao `_ Fock matrix in AO basis set -`fock_matrix_beta_ao `_ +`fock_matrix_beta_ao `_ Alpha Fock matrix in AO basis set -`fock_matrix_beta_mo `_ +`fock_matrix_beta_mo `_ Fock matrix on the MO basis @@ -114,7 +114,7 @@ Documentation .br -`fock_mo_to_ao `_ +`fock_mo_to_ao `_ Undocumented @@ -134,7 +134,7 @@ Documentation S^-1 Beta density matrix in the AO basis x S^-1 -`hf_energy `_ +`hf_energy `_ Hartree-Fock energy @@ -142,7 +142,11 @@ Documentation Build the MOs using the extended Huckel model -`mo_guess_type `_ +`level_shift `_ + Energy shift on the virtual MOs to improve SCF convergence + + +`mo_guess_type `_ Initial MO guess. Can be [ Huckel | HCore ] @@ -161,6 +165,6 @@ Documentation optional: mo_basis.mo_coef -`thresh_scf `_ +`thresh_scf `_ Threshold on the convergence of the Hartree Fock energy diff --git a/plugins/Hartree_Fock/SCF.irp.f b/plugins/Hartree_Fock/SCF.irp.f index 864e9f3f..dead61ee 100644 --- a/plugins/Hartree_Fock/SCF.irp.f +++ b/plugins/Hartree_Fock/SCF.irp.f @@ -42,16 +42,13 @@ subroutine run BEGIN_DOC ! Run SCF calculation END_DOC - double precision :: SCF_energy_before,SCF_energy_after,diag_H_mat_elem,get_mo_bielec_integral + double precision :: SCF_energy_before,SCF_energy_after,diag_H_mat_elem double precision :: E0 integer :: i_it, i, j, k E0 = HF_energy - thresh_SCF = 1.d-10 - call damping_SCF mo_label = "Canonical" - TOUCH mo_label mo_coef - call save_mos + call damping_SCF end diff --git a/plugins/Hartree_Fock/damping_SCF.irp.f b/plugins/Hartree_Fock/damping_SCF.irp.f index d7d9c2bf..d77c91c5 100644 --- a/plugins/Hartree_Fock/damping_SCF.irp.f +++ b/plugins/Hartree_Fock/damping_SCF.irp.f @@ -86,7 +86,7 @@ subroutine damping_SCF if ((E_half > E).and.(E_new < E)) then lambda = 1.d0 exit - else if ((E_half > E).and.(lambda > 5.d-2)) then + else if ((E_half > E).and.(lambda > 5.d-4)) then lambda = 0.5d0 * lambda E_new = E_half else @@ -119,7 +119,7 @@ subroutine damping_SCF write(output_hartree_fock,'(A4,X,A16, X, A16, X, A16, X, A4 )'), '====','================','================','================', '====' write(output_hartree_fock,*) - call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1),size(Fock_matrix_mo,2),mo_label) + call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1),size(Fock_matrix_mo,2),mo_label,1) call write_double(output_hartree_fock, E_min, 'Hartree-Fock energy') call ezfio_set_hartree_fock_energy(E_min) diff --git a/plugins/Hartree_Fock/diagonalize_fock.irp.f b/plugins/Hartree_Fock/diagonalize_fock.irp.f index 90bfddcb..850ba0aa 100644 --- a/plugins/Hartree_Fock/diagonalize_fock.irp.f +++ b/plugins/Hartree_Fock/diagonalize_fock.irp.f @@ -10,58 +10,103 @@ integer, allocatable :: iwork(:) double precision, allocatable :: work(:), F(:,:), S(:,:) - allocate(F(ao_num_align,ao_num), S(ao_num_align,ao_num) ) - do j=1,ao_num - do i=1,ao_num - S(i,j) = ao_overlap(i,j) - F(i,j) = Fock_matrix_ao(i,j) - enddo - enddo - n = ao_num - lwork = 1+6*n + 2*n*n - liwork = 3 + 5*n - - allocate(work(lwork), iwork(liwork) ) + if (mo_tot_num == ao_num) then + ! Solve H.C = E.S.C in AO basis set - lwork = -1 - liwork = -1 + allocate(F(ao_num_align,ao_num), S(ao_num_align,ao_num) ) + do j=1,ao_num + do i=1,ao_num + S(i,j) = ao_overlap(i,j) + F(i,j) = Fock_matrix_ao(i,j) + enddo + enddo - call dsygvd(1,'v','u',ao_num,F,size(F,1),S,size(S,1),& - diagonal_Fock_matrix_mo, work, lwork, iwork, liwork, info) -! call dsygv(1, 'v', 'u',ao_num,F,size(F,1),S,size(S,1),& -! diagonal_Fock_matrix_mo, work, lwork, info) + n = ao_num + lwork = 1+6*n + 2*n*n + liwork = 3 + 5*n + + allocate(work(lwork), iwork(liwork) ) + lwork = -1 + liwork = -1 + call dsygvd(1,'v','u',ao_num,F,size(F,1),S,size(S,1),& + diagonal_Fock_matrix_mo, work, lwork, iwork, liwork, info) - if (info /= 0) then - print *, irp_here//' failed : ', info - stop 1 - endif - lwork = int(work(1)) - liwork = iwork(1) - deallocate(work,iwork) - allocate(work(lwork), iwork(liwork) ) -! deallocate(work) -! allocate(work(lwork)) + if (info /= 0) then + print *, irp_here//' failed : ', info + stop 1 + endif + lwork = int(work(1)) + liwork = iwork(1) + deallocate(work,iwork) + allocate(work(lwork), iwork(liwork) ) - call dsygvd(1,'v','u',ao_num,F,size(F,1),S,size(S,1),& - diagonal_Fock_matrix_mo, work, lwork, iwork, liwork, info) + call dsygvd(1,'v','u',ao_num,F,size(F,1),S,size(S,1),& + diagonal_Fock_matrix_mo, work, lwork, iwork, liwork, info) -! call dsygv(1, 'v', 'u',ao_num,F,size(F,1),S,size(S,1),& -! diagonal_Fock_matrix_mo, work, lwork, info) + if (info /= 0) then + print *, irp_here//' failed : ', info + stop 1 + endif + do j=1,mo_tot_num + do i=1,ao_num + eigenvectors_Fock_matrix_mo(i,j) = F(i,j) + enddo + enddo - if (info /= 0) then - print *, irp_here//' failed : ', info - stop 1 - endif - do j=1,mo_tot_num - do i=1,ao_num - eigenvectors_Fock_matrix_mo(i,j) = F(i,j) - enddo - enddo + deallocate(work, iwork, F, S) + + else + + ! Solve H.C = E.C in MO basis set + + allocate( F(mo_tot_num_align,mo_tot_num) ) + do j=1,mo_tot_num + do i=1,mo_tot_num + F(i,j) = Fock_matrix_mo(i,j) + enddo + enddo + + n = mo_tot_num + lwork = 1+6*n + 2*n*n + liwork = 3 + 5*n + + allocate(work(lwork), iwork(liwork) ) + + lwork = -1 + liwork = -1 + + call dsyevd( 'V', 'U', mo_tot_num, F, & + size(F,1), diagonal_Fock_matrix_mo, & + work, lwork, iwork, liwork, info) + + if (info /= 0) then + print *, irp_here//' failed : ', info + stop 1 + endif + lwork = int(work(1)) + liwork = iwork(1) + deallocate(work,iwork) + allocate(work(lwork), iwork(liwork) ) + + call dsyevd( 'V', 'U', mo_tot_num, F, & + size(F,1), diagonal_Fock_matrix_mo, & + work, lwork, iwork, liwork, info) + + if (info /= 0) then + print *, irp_here//' failed : ', info + stop 1 + endif + + call dgemm('N','N',ao_num,mo_tot_num,mo_tot_num, 1.d0, & + mo_coef, size(mo_coef,1), F, size(F,1), & + 0.d0, eigenvectors_Fock_matrix_mo, size(eigenvectors_Fock_matrix_mo,1)) + deallocate(work, iwork, F) + + endif - deallocate(work, iwork, F, S) END_PROVIDER BEGIN_PROVIDER [double precision, diagonal_Fock_matrix_mo_sum, (mo_tot_num)] @@ -73,19 +118,19 @@ BEGIN_PROVIDER [double precision, diagonal_Fock_matrix_mo_sum, (mo_tot_num)] END_DOC integer :: i,j double precision :: accu - do i = 1,elec_alpha_num + do j = 1,elec_alpha_num accu = 0.d0 - do j = 1, elec_alpha_num + do i = 1, elec_alpha_num accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j) enddo - diagonal_Fock_matrix_mo_sum(i) = accu + mo_mono_elec_integral(i,i) + diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j) enddo - do i = elec_alpha_num+1,mo_tot_num + do j = elec_alpha_num+1,mo_tot_num accu = 0.d0 - do j = 1, elec_alpha_num + do i = 1, elec_alpha_num accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j) enddo - diagonal_Fock_matrix_mo_sum(i) = accu + mo_mono_elec_integral(i,i) + diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j) enddo END_PROVIDER diff --git a/plugins/Hartree_Fock/huckel.irp.f b/plugins/Hartree_Fock/huckel.irp.f index 1b9e02aa..8f61f0cf 100644 --- a/plugins/Hartree_Fock/huckel.irp.f +++ b/plugins/Hartree_Fock/huckel.irp.f @@ -4,7 +4,7 @@ subroutine huckel_guess ! Build the MOs using the extended Huckel model END_DOC integer :: i,j - double precision :: tmp_matrix(ao_num_align,ao_num),accu + double precision :: accu double precision :: c character*(64) :: label @@ -13,20 +13,18 @@ subroutine huckel_guess label = "Guess" call mo_as_eigvectors_of_mo_matrix(mo_mono_elec_integral, & size(mo_mono_elec_integral,1), & - size(mo_mono_elec_integral,2),label) + size(mo_mono_elec_integral,2),label,1) TOUCH mo_coef c = 0.5d0 * 1.75d0 do j=1,ao_num + !DIR$ VECTOR ALIGNED do i=1,ao_num - if (i.ne.j) then - Fock_matrix_ao(i,j) = c*ao_overlap(i,j)*(ao_mono_elec_integral(i,i) + & - ao_mono_elec_integral(j,j)) - else - Fock_matrix_ao(i,j) = Fock_matrix_alpha_ao(i,j) - endif + Fock_matrix_ao(i,j) = c*ao_overlap(i,j)*(ao_mono_elec_integral_diag(i) + & + ao_mono_elec_integral_diag(j)) enddo + Fock_matrix_ao(j,j) = Fock_matrix_alpha_ao(j,j) enddo TOUCH Fock_matrix_ao mo_coef = eigenvectors_fock_matrix_mo diff --git a/plugins/Hartree_Fock/tree_dependency.png b/plugins/Hartree_Fock/tree_dependency.png index 410232bd..cb1d9738 100644 Binary files a/plugins/Hartree_Fock/tree_dependency.png and b/plugins/Hartree_Fock/tree_dependency.png differ diff --git a/plugins/MP2/EZFIO.cfg b/plugins/MP2/EZFIO.cfg new file mode 100644 index 00000000..8577d8f1 --- /dev/null +++ b/plugins/MP2/EZFIO.cfg @@ -0,0 +1,5 @@ +[energy] +type: double precision +doc: MP2 energy +interface: ezfio + diff --git a/plugins/MP2/H_apply.irp.f b/plugins/MP2/H_apply.irp.f index 2f15391f..a79e3879 100644 --- a/plugins/MP2/H_apply.irp.f +++ b/plugins/MP2/H_apply.irp.f @@ -6,5 +6,9 @@ from perturbation import perturbations s = H_apply("mp2") s.set_perturbation("Moller_plesset") print s + +s = H_apply("mp2_selection") +s.set_selection_pt2("Moller_plesset") +print s END_SHELL diff --git a/plugins/MP2/README.rst b/plugins/MP2/README.rst index 98d84eeb..062b48c9 100644 --- a/plugins/MP2/README.rst +++ b/plugins/MP2/README.rst @@ -40,3 +40,49 @@ Needed Modules * `Selectors_full `_ * `SingleRefMethod `_ +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +.. image:: tree_dependency.png + +* `Perturbation `_ +* `Selectors_full `_ +* `SingleRefMethod `_ + +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +h_apply_mp2 + Calls H_apply on the HF determinant and selects all connected single and double + excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + + +h_apply_mp2_diexc + Undocumented + + +h_apply_mp2_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_mp2_diexcp + Undocumented + + +h_apply_mp2_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +`mp2 `_ + Undocumented + diff --git a/plugins/MP2/mp2_wf.irp.f b/plugins/MP2/mp2_wf.irp.f new file mode 100644 index 00000000..ad068b8a --- /dev/null +++ b/plugins/MP2/mp2_wf.irp.f @@ -0,0 +1,31 @@ +program mp2_wf + implicit none + BEGIN_DOC +! Save the MP2 wave function + END_DOC + integer :: i,k + + + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) + integer :: N_st, iter + N_st = N_states + allocate (pt2(N_st), norm_pert(N_st), H_pert_diag(N_st)) + + pt2 = 1.d0 + selection_criterion = 1.e-12 + selection_criterion_min = 1.e-12 + TOUCH selection_criterion_min selection_criterion selection_criterion_factor + call H_apply_mp2_selection(pt2, norm_pert, H_pert_diag, N_st) + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + touch N_det psi_det psi_coef + print*,'N_det = ',N_det + print*,'-----' + print *, 'PT2 = ', pt2(1) + print *, 'E = ', HF_energy + print *, 'E_before +PT2 = ', HF_energy+pt2(1) + N_det = min(N_det,N_det_max) + call save_wavefunction + call ezfio_set_mp2_energy(HF_energy+pt2(1)) + deallocate(pt2,norm_pert,H_pert_diag) +end diff --git a/plugins/MRCC_CASSD/tree_dependency.png b/plugins/MRCC_CASSD/tree_dependency.png new file mode 100644 index 00000000..480c38a8 Binary files /dev/null and b/plugins/MRCC_CASSD/tree_dependency.png differ diff --git a/plugins/MRCC_Utils/README.rst b/plugins/MRCC_Utils/README.rst index 56b519f2..8b97bfbe 100644 --- a/plugins/MRCC_Utils/README.rst +++ b/plugins/MRCC_Utils/README.rst @@ -1,171 +1,3 @@ -=========== -MRCC Module -=========== - -Needed Modules -============== - -.. Do not edit this section. It was auto-generated from the -.. by the `update_README.py` script. - -.. image:: tree_dependency.png - -* `Perturbation `_ -* `Selectors_full `_ -* `Generators_full `_ -* `Psiref_Utils `_ - -Documentation -============= - -.. Do not edit this section. It was auto-generated from the -.. by the `update_README.py` script. - -`ci_eigenvectors_dressed `_ - Eigenvectors/values of the CI matrix - - -`ci_eigenvectors_s2_dressed `_ - Eigenvectors/values of the CI matrix - - -`ci_electronic_energy_dressed `_ - Eigenvectors/values of the CI matrix - - -`ci_energy_dressed `_ - N_states lowest eigenvalues of the dressed CI matrix - - -`davidson_diag_hjj_mrcc `_ - Davidson diagonalization with specific diagonal elements of the H matrix - .br - H_jj : specific diagonal H matrix elements to diagonalize de Davidson - .br - dets_in : bitmasks corresponding to determinants - .br - u_in : guess coefficients on the various states. Overwritten - on exit - .br - dim_in : leftmost dimension of u_in - .br - sze : Number of determinants - .br - N_st : Number of eigenstates - .br - iunit : Unit for the I/O - .br - Initial guess vectors are not necessarily orthonormal - - -`davidson_diag_mrcc `_ - Davidson diagonalization. - .br - dets_in : bitmasks corresponding to determinants - .br - u_in : guess coefficients on the various states. Overwritten - on exit - .br - dim_in : leftmost dimension of u_in - .br - sze : Number of determinants - .br - N_st : Number of eigenstates - .br - iunit : Unit number for the I/O - .br - Initial guess vectors are not necessarily orthonormal - - -`delta_ii `_ - Dressing matrix in N_det basis - - -`delta_ij `_ - Dressing matrix in N_det basis - - -`diagonalize_ci_dressed `_ - Replace the coefficients of the CI states by the coefficients of the - eigenstates of the CI matrix - - -`find_triples_and_quadruples `_ - Undocumented - - -`h_apply_mrcc `_ - Calls H_apply on the HF determinant and selects all connected single and double - excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. - - -`h_apply_mrcc_diexc `_ - Generate all double excitations of key_in using the bit masks of holes and - particles. - Assume N_int is already provided. - - -`h_apply_mrcc_monoexc `_ - Generate all single excitations of key_in using the bit masks of holes and - particles. - Assume N_int is already provided. - - -`h_matrix_dressed `_ - Dressed H with Delta_ij - - -`h_u_0_mrcc `_ - Computes v_0 = H|u_0> - .br - n : number of determinants - .br - H_jj : array of - - -`lambda_mrcc `_ - cm/ or perturbative 1/Delta_E(m) - - -`lambda_mrcc_tmp `_ - Undocumented - - -`lambda_pert `_ - cm/ or perturbative 1/Delta_E(m) - - -`mrcc_dress `_ - Undocumented - - -`mrcc_dress_simple `_ - Undocumented - - -`mrcc_iterations `_ - Undocumented - - -`oscillations `_ - Undocumented - - -`pert_determinants `_ - Undocumented - - -`psi_ref_lock `_ - Locks on ref determinants to fill delta_ij - - -`run_mrcc `_ - Undocumented - - -`set_generators_bitmasks_as_holes_and_particles `_ - Undocumented - Needed Modules ============== .. Do not edit this section It was auto-generated @@ -258,10 +90,6 @@ Documentation N_states lowest eigenvalues of the dressed CI matrix -`create_minilist `_ - Undocumented - - `davidson_diag_hjj_mrcc `_ Davidson diagonalization with specific diagonal elements of the H matrix .br @@ -374,7 +202,7 @@ Documentation Find A.C = B -`find_triples_and_quadruples `_ +`find_triples_and_quadruples `_ Undocumented @@ -400,6 +228,22 @@ Documentation Undocumented +`gen_det_idx `_ + Undocumented + + +`gen_det_shortcut `_ + Undocumented + + +`gen_det_sorted `_ + Undocumented + + +`gen_det_version `_ + Undocumented + + `get_pseudo_inverse `_ Find C = A^-1 @@ -435,26 +279,26 @@ Documentation Undocumented -`h_apply_mrcc `_ +h_apply_mrcc Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. -`h_apply_mrcc_diexc `_ +h_apply_mrcc_diexc Undocumented -`h_apply_mrcc_diexcorg `_ +h_apply_mrcc_diexcorg Generate all double excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. -`h_apply_mrcc_diexcp `_ +h_apply_mrcc_diexcp Undocumented -`h_apply_mrcc_monoexc `_ +h_apply_mrcc_monoexc Generate all single excitations of key_in using the bit masks of holes and particles. Assume N_int is already provided. @@ -464,15 +308,7 @@ Documentation Dressed H with Delta_ij -`h_u_0_mrcc `_ - Computes v_0 = H|u_0> - .br - n : number of determinants - .br - H_jj : array of - - -`h_u_0_mrcc_org `_ +`h_u_0_mrcc `_ Computes v_0 = H|u_0> .br n : number of determinants @@ -781,10 +617,6 @@ Documentation Undocumented -`mrcc_dress_simple `_ - Undocumented - - `mrcc_iterations `_ Undocumented diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 2fa09575..6752afcb 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -105,10 +105,7 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nin double precision :: to_print(2,N_st) double precision :: cpu, wall - integer(bit_kind) :: dets_in_sorted(Nint,2,sze) - integer :: idx(sze), shortcut(0:sze+1),sh,ii,tmp - - PROVIDE det_connections + !PROVIDE det_connections call write_time(iunit) call wall_time(wall) @@ -154,8 +151,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nin ! ============== - dets_in_sorted(:,:,:) = dets_in(:,:,:) - call sort_dets_ab(dets_in_sorted, idx, shortcut, sze, Nint) k_pairs=0 do l=1,N_st @@ -215,8 +210,7 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nin ! ---------------------- do k=1,N_st - call H_u_0_mrcc(W(1,k,iter),U(1,k,iter),H_jj,sze,dets_in_sorted,shortcut,idx,Nint,istate) - !call H_u_0_mrcc_org(W(1,k,iter),U(1,k,iter),H_jj,sze,dets_in,Nint,istate) + call H_u_0_mrcc(W(1,k,iter),U(1,k,iter),H_jj,sze,dets_in,Nint,istate) enddo ! Compute h_kl = = @@ -368,7 +362,9 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nin abort_here = abort_all end -subroutine H_u_0_mrcc(v_0,u_0,H_jj,n,keys_tmp,shortcut,sort_idx,Nint,istate) + + +subroutine H_u_0_mrcc(v_0,u_0,H_jj,n,keys_tmp,Nint,istate) use bitmasks implicit none BEGIN_DOC @@ -389,8 +385,11 @@ subroutine H_u_0_mrcc(v_0,u_0,H_jj,n,keys_tmp,shortcut,sort_idx,Nint,istate) integer :: i,j,k,l, jj,ii integer :: i0, j0 - integer,intent(in) :: shortcut(0:n+1), sort_idx(n) - integer :: tmp, warp(2,0:n+1), sh, ni + integer :: shortcut(0:n+1), sort_idx(n) + integer(bit_kind) :: sorted(Nint,n), version(Nint,n) + + + integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, pass ! ASSERT (Nint > 0) @@ -399,12 +398,14 @@ subroutine H_u_0_mrcc(v_0,u_0,H_jj,n,keys_tmp,shortcut,sort_idx,Nint,istate) PROVIDE ref_bitmask_energy delta_ij integer, parameter :: block_size = 157 - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,hij,j,k,idx,jj,vt,ii,warp,tmp,sh) & - !$OMP SHARED(n_det_ref,n_det_non_ref,idx_ref,idx_non_ref,n,H_jj,u_0,keys_tmp,Nint,v_0,istate,delta_ij,shortcut,sort_idx) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,hij,j,k,idx,jj,vt,ii,sh, sh2, ni, exa, ext, org_i, org_j, endi, pass) & + !$OMP SHARED(n_det_ref,n_det_non_ref,idx_ref,idx_non_ref,n,H_jj,u_0,keys_tmp,Nint,v_0,istate,delta_ij,sorted,shortcut,sort_idx,version) - !$OMP DO SCHEDULE(static) + + + !$OMP DO SCHEDULE(static) do i=1,n v_0(i) = H_jj(i) * u_0(i) enddo @@ -412,43 +413,73 @@ subroutine H_u_0_mrcc(v_0,u_0,H_jj,n,keys_tmp,shortcut,sort_idx,Nint,istate) allocate(idx(0:n), vt(n)) Vt = 0.d0 + + + !$OMP SINGLE + call sort_dets_ab_v(keys_tmp, sorted, sort_idx, shortcut, version, n, Nint) + !$OMP END SINGLE + + !$OMP DO SCHEDULE(dynamic) do sh=1,shortcut(0) - warp(1,0) = 0 - do ii=1,sh!shortcut(0) - tmp = 0 - do ni=1,Nint - tmp = popcnt(xor(keys_tmp(ni,1, shortcut(ii)), keys_tmp(ni,1,shortcut(sh)))) - end do - if(tmp <= 4) then - tmp = warp(1,0) + 1 - warp(1,0) = tmp - warp(1,tmp) = shortcut(ii) - warp(2,tmp) = shortcut(ii+1)-1 - end if + do sh2=1,sh + exa = 0 + do ni=1,Nint + exa += popcnt(xor(version(ni,sh), version(ni,sh2))) end do + if(exa > 2) then + cycle + end if - do ii=shortcut(sh),shortcut(sh+1)-1 - idx(0) = ii + do i=shortcut(sh),shortcut(sh+1)-1 + if(sh==sh2) then + endi = i-1 + else + endi = shortcut(sh2+1)-1 + end if - - !call filter_connected_davidson_mwen(keys_tmp,shortcut,keys_tmp(1,1,ii),Nint,ii-1,idx) - call filter_connected_davidson_warp(keys_tmp,warp,keys_tmp(1,1,ii),Nint,ii-1,idx) - i = sort_idx(ii) - - do jj=1,idx(0) - j = sort_idx(idx(jj)) - !j = idx(jj) - if ( (dabs(u_0(j)) > 1.d-7).or.((dabs(u_0(i)) > 1.d-7)) ) then - call i_H_j(keys_tmp(1,1,idx(jj)),keys_tmp(1,1,ii),Nint,hij) - vt (i) = vt (i) + hij*u_0(j) - vt (j) = vt (j) + hij*u_0(i) - endif - enddo - enddo + do j=shortcut(sh2),endi + ext = exa + do ni=1,Nint + ext += popcnt(xor(sorted(ni,i), sorted(ni,j))) + end do + if(ext <= 4) then + org_i = sort_idx(i) + org_j = sort_idx(j) + + call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) + vt (org_i) = vt (org_i) + hij*u_0(org_j) + vt (org_j) = vt (org_j) + hij*u_0(org_i) + end if + end do + end do + end do enddo !$OMP END DO + !$OMP SINGLE + call sort_dets_ba_v(keys_tmp, sorted, sort_idx, shortcut, version, n, Nint) + !$OMP END SINGLE + + !$OMP DO SCHEDULE(dynamic) + do sh=1,shortcut(0) + do i=shortcut(sh),shortcut(sh+1)-1 + do j=shortcut(sh),i-1 + ext = 0 + do ni=1,Nint + ext += popcnt(xor(sorted(ni,i), sorted(ni,j))) + end do + if(ext == 4) then + org_i = sort_idx(i) + org_j = sort_idx(j) + call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) + vt (org_i) = vt (org_i) + hij*u_0(org_j) + vt (org_j) = vt (org_j) + hij*u_0(org_i) + end if + end do + end do + enddo + !$OMP END DO !$OMP DO SCHEDULE(guided) @@ -470,80 +501,3 @@ subroutine H_u_0_mrcc(v_0,u_0,H_jj,n,keys_tmp,shortcut,sort_idx,Nint,istate) !$OMP END PARALLEL end - - -subroutine H_u_0_mrcc_org(v_0,u_0,H_jj,n,keys_tmp,Nint,istate) - use bitmasks - implicit none - BEGIN_DOC - ! Computes v_0 = H|u_0> - ! - ! n : number of determinants - ! - ! H_jj : array of - END_DOC - integer, intent(in) :: n,Nint,istate - double precision, intent(out) :: v_0(n) - double precision, intent(in) :: u_0(n) - double precision, intent(in) :: H_jj(n) - integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) - integer, allocatable :: idx(:) - double precision :: hij - double precision, allocatable :: vt(:) - integer :: i,j,k,l, jj,ii - integer :: i0, j0 - - - - - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (n>0) - PROVIDE ref_bitmask_energy delta_ij - integer, parameter :: block_size = 157 - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,hij,j,k,idx,jj,ii,vt) & - !$OMP SHARED(n_det_ref,n_det_non_ref,idx_ref,idx_non_ref,n,H_jj,u_0,keys_tmp,Nint,v_0,istate,delta_ij) - !$OMP DO SCHEDULE(static) - do i=1,n - v_0(i) = H_jj(i) * u_0(i) - enddo - !$OMP END DO - allocate(idx(0:n), vt(n)) - Vt = 0.d0 - !$OMP DO SCHEDULE(guided) - do i=1,n - idx(0) = i - call filter_connected_davidson(keys_tmp,keys_tmp(1,1,i),Nint,i-1,idx) - do jj=1,idx(0) - j = idx(jj) -! if ( (dabs(u_0(j)) > 1.d-7).or.((dabs(u_0(i)) > 1.d-7)) ) then - call i_H_j(keys_tmp(1,1,j),keys_tmp(1,1,i),Nint,hij) - hij = hij - vt (i) = vt (i) + hij*u_0(j) - vt (j) = vt (j) + hij*u_0(i) -! endif - enddo - enddo - !$OMP END DO - - !$OMP DO SCHEDULE(guided) - do ii=1,n_det_ref - i = idx_ref(ii) - do jj = 1, n_det_non_ref - j = idx_non_ref(jj) - vt (i) = vt (i) + delta_ij(ii,jj,istate)*u_0(j) - vt (j) = vt (j) + delta_ij(ii,jj,istate)*u_0(i) - enddo - enddo - !$OMP END DO - !$OMP CRITICAL - do i=1,n - v_0(i) = v_0(i) + vt(i) - enddo - !$OMP END CRITICAL - deallocate(idx,vt) - !$OMP END PARALLEL -end - diff --git a/plugins/MRCC_Utils/mrcc_dress.irp.f b/plugins/MRCC_Utils/mrcc_dress.irp.f index f427c81f..5747b174 100644 --- a/plugins/MRCC_Utils/mrcc_dress.irp.f +++ b/plugins/MRCC_Utils/mrcc_dress.irp.f @@ -14,54 +14,6 @@ BEGIN_PROVIDER [ integer(omp_lock_kind), psi_ref_lock, (psi_det_size) ] END_PROVIDER -subroutine create_minilist(key_mask, fullList, miniList, idx_miniList, N_fullList, N_miniList, Nint) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList) - integer, intent(in) :: N_fullList - integer(bit_kind),intent(out) :: miniList(Nint, 2, N_fullList) - integer,intent(out) :: idx_miniList(N_fullList), N_miniList - integer, intent(in) :: Nint - integer(bit_kind) :: key_mask(Nint, 2) - integer :: ni, i, n_a, n_b, e_a, e_b - - - n_a = 0 - n_b = 0 - do ni=1,nint - n_a = n_a + popcnt(key_mask(ni,1)) - n_b = n_b + popcnt(key_mask(ni,2)) - end do - - if(n_a == 0) then - N_miniList = N_fullList - miniList(:,:,:) = fullList(:,:,:) - do i=1,N_fullList - idx_miniList(i) = i - end do - return - end if - - N_miniList = 0 - - do i=1,N_fullList - e_a = n_a - e_b = n_b - do ni=1,nint - e_a -= popcnt(iand(fullList(ni, 1, i), key_mask(ni, 1))) - e_b -= popcnt(iand(fullList(ni, 2, i), key_mask(ni, 2))) - end do - - if(e_a + e_b <= 2) then - N_miniList = N_miniList + 1 - miniList(:,:,N_miniList) = fullList(:,:,i) - idx_miniList(N_miniList) = i - end if - end do -end subroutine - - subroutine mrcc_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n_selected,det_buffer,Nint,iproc,key_mask) use bitmasks implicit none @@ -75,11 +27,10 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n integer :: i,j,k,l integer :: degree_alpha(psi_det_size) integer :: idx_alpha(0:psi_det_size) - logical :: good + logical :: good, fullMatch integer(bit_kind) :: tq(Nint,2,n_selected) integer :: N_tq, c_ref ,degree - integer :: connected_to_ref double precision :: hIk, hla, hIl, dIk(N_states), dka(N_states), dIa(N_states) double precision, allocatable :: dIa_hla(:,:) @@ -91,11 +42,24 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n integer :: iint, ipos integer :: i_state, k_sd, l_sd, i_I, i_alpha - integer(bit_kind) :: miniList(Nint, 2, N_det_non_ref), key_mask(Nint, 2) - integer :: idx_miniList(N_det_non_ref), N_miniList + integer(bit_kind),allocatable :: miniList(:,:,:) + integer(bit_kind),intent(in) :: key_mask(Nint, 2) + integer,allocatable :: idx_miniList(:) + integer :: N_miniList, ni, leng - call find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq) + leng = max(N_det_generators, N_det_non_ref) + allocate(miniList(Nint, 2, leng), idx_miniList(leng)) + + !create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint) + call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint) + + if(fullMatch) then + return + end if + + + call find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) allocate (dIa_hla(N_states,Ndet_non_ref)) @@ -214,61 +178,24 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Ndet_ref, Ndet_non_ref,i_generator,n enddo enddo deallocate (dIa_hla) + deallocate(miniList, idx_miniList) end + BEGIN_PROVIDER [ integer(bit_kind), gen_det_sorted, (N_int,2,N_det_generators,2) ] +&BEGIN_PROVIDER [ integer, gen_det_shortcut, (0:N_det_generators,2) ] +&BEGIN_PROVIDER [ integer, gen_det_version, (N_int, N_det_generators,2) ] +&BEGIN_PROVIDER [ integer, gen_det_idx, (N_det_generators,2) ] + gen_det_sorted(:,:,:,1) = psi_det_generators(:,:,:N_det_generators) + gen_det_sorted(:,:,:,2) = psi_det_generators(:,:,:N_det_generators) + call sort_dets_ab_v(gen_det_sorted(:,:,:,1), gen_det_idx(:,1), gen_det_shortcut(0:,1), gen_det_version(:,:,1), N_det_generators, N_int) + call sort_dets_ba_v(gen_det_sorted(:,:,:,2), gen_det_idx(:,2), gen_det_shortcut(0:,2), gen_det_version(:,:,2), N_det_generators, N_int) +END_PROVIDER +subroutine find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList) - -subroutine mrcc_dress_simple(delta_ij_non_ref_,Ndet_non_ref,i_generator,n_selected,det_buffer,Nint,iproc) - use bitmasks - implicit none - - integer, intent(in) :: i_generator,n_selected, Nint, iproc - integer, intent(in) :: Ndet_non_ref - double precision, intent(inout) :: delta_ij_non_ref_(Ndet_non_ref,Ndet_non_ref,*) - - integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) - integer :: i,j,k,m - integer :: new_size - integer :: degree(psi_det_size) - integer :: idx(0:psi_det_size) - logical :: good - - integer(bit_kind) :: tq(Nint,2,n_selected) - integer :: N_tq, c_ref - integer :: connected_to_ref - - call find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq) - - ! Compute / (E0 - Haa) - double precision :: hka, haa - double precision :: haj - double precision :: f(N_states) - - do i=1,N_tq - call get_excitation_degree_vector(psi_non_ref,tq(1,1,i),degree,Nint,Ndet_non_ref,idx) - call i_h_j(tq(1,1,i),tq(1,1,i),Nint,haa) - do m=1,N_states - f(m) = 1.d0/(ci_electronic_energy(m)-haa) - enddo - do k=1,idx(0) - call i_h_j(tq(1,1,i),psi_non_ref(1,1,idx(k)),Nint,hka) - do j=k,idx(0) - call i_h_j(tq(1,1,i),psi_non_ref(1,1,idx(j)),Nint,haj) - do m=1,N_states - delta_ij_non_ref_(idx(k), idx(j),m) += haj*hka* f(m) - delta_ij_non_ref_(idx(j), idx(k),m) += haj*hka* f(m) - enddo - enddo - enddo - enddo -end - - -subroutine find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq) use bitmasks implicit none @@ -283,18 +210,24 @@ subroutine find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq integer(bit_kind), intent(out) :: tq(Nint,2,n_selected) integer, intent(out) :: N_tq - integer :: c_ref - integer :: connected_to_ref + + integer :: nt,ni + logical, external :: is_connected_to + + + integer(bit_kind),intent(in) :: miniList(Nint,2,N_det_generators) + integer,intent(in) :: N_miniList + + N_tq = 0 - do i=1,N_selected - c_ref = connected_to_ref(det_buffer(1,1,i),psi_det_generators,Nint, & - i_generator,N_det_generators) - - if (c_ref /= 0) then + + + i_loop : do i=1,N_selected + if(is_connected_to(det_buffer(1,1,i), miniList, Nint, N_miniList)) then cycle - endif + end if ! Select determinants that are triple or quadruple excitations ! from the ref @@ -316,8 +249,7 @@ subroutine find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq enddo endif endif - enddo - + enddo i_loop end diff --git a/plugins/MRCC_Utils/tree_dependency.png b/plugins/MRCC_Utils/tree_dependency.png index cd3d2f4b..500e5d43 100644 Binary files a/plugins/MRCC_Utils/tree_dependency.png and b/plugins/MRCC_Utils/tree_dependency.png differ diff --git a/plugins/Molden/README.rst b/plugins/Molden/README.rst index 71639cad..05a8d23a 100644 --- a/plugins/Molden/README.rst +++ b/plugins/Molden/README.rst @@ -38,3 +38,39 @@ Needed Modules * `MO_Basis `_ * `Utils `_ +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +.. image:: tree_dependency.png + +* `MO_Basis `_ +* `Utils `_ + +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +`print_mos `_ + Undocumented + + +`write_ao_basis `_ + Undocumented + + +`write_geometry `_ + Undocumented + + +`write_intro_gamess `_ + Undocumented + + +`write_mo_basis `_ + Undocumented + diff --git a/plugins/Perturbation/Moller_plesset.irp.f b/plugins/Perturbation/Moller_plesset.irp.f deleted file mode 100644 index 7435f70c..00000000 --- a/plugins/Perturbation/Moller_plesset.irp.f +++ /dev/null @@ -1,42 +0,0 @@ -subroutine pt2_moller_plesset(det_pert,c_pert,e_2_pert,H_pert_diag,Nint,ndet,n_st) - use bitmasks - implicit none - integer, intent(in) :: Nint,ndet,n_st - integer(bit_kind), intent(in) :: det_pert(Nint,2) - double precision , intent(out) :: c_pert(n_st),e_2_pert(n_st),H_pert_diag(N_st) - double precision :: i_H_psi_array(N_st) - - BEGIN_DOC - ! compute the standard Moller-Plesset perturbative first order coefficient and second order energetic contribution - ! - ! for the various n_st states. - ! - ! c_pert(i) = /(difference of orbital energies) - ! - ! e_2_pert(i) = ^2/(difference of orbital energies) - ! - END_DOC - - integer :: i,j - double precision :: diag_H_mat_elem - integer :: exc(0:2,2,2) - integer :: degree - double precision :: phase,delta_e,h - integer :: h1,h2,p1,p2,s1,s2 - ASSERT (Nint == N_int) - ASSERT (Nint > 0) - call get_excitation(ref_bitmask,det_pert,exc,degree,phase,Nint) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - delta_e = Fock_matrix_diag_mo(h1) + Fock_matrix_diag_mo(h2) - & - (Fock_matrix_diag_mo(p1) + Fock_matrix_diag_mo(p2)) - delta_e = 1.d0/delta_e - - call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det,psi_selectors_size,n_st,i_H_psi_array) - h = diag_H_mat_elem(det_pert,Nint) - do i =1,n_st - H_pert_diag(i) = h - c_pert(i) = i_H_psi_array(i) *delta_e - e_2_pert(i) = c_pert(i) * i_H_psi_array(i) - enddo - -end diff --git a/plugins/Perturbation/README.rst b/plugins/Perturbation/README.rst index aa6ebf54..4bf62a2a 100644 --- a/plugins/Perturbation/README.rst +++ b/plugins/Perturbation/README.rst @@ -107,92 +107,92 @@ Documentation Undocumented -`perturb_buffer_by_mono_delta_rho_one_point `_ +perturb_buffer_by_mono_delta_rho_one_point Applly pertubration ``delta_rho_one_point`` to the buffer of determinants generated in the H_apply routine. -`perturb_buffer_by_mono_dipole_moment_z `_ +perturb_buffer_by_mono_dipole_moment_z Applly pertubration ``dipole_moment_z`` to the buffer of determinants generated in the H_apply routine. -`perturb_buffer_by_mono_epstein_nesbet `_ +perturb_buffer_by_mono_epstein_nesbet Applly pertubration ``epstein_nesbet`` to the buffer of determinants generated in the H_apply routine. -`perturb_buffer_by_mono_epstein_nesbet_2x2 `_ +perturb_buffer_by_mono_epstein_nesbet_2x2 Applly pertubration ``epstein_nesbet_2x2`` to the buffer of determinants generated in the H_apply routine. -`perturb_buffer_by_mono_epstein_nesbet_sc2 `_ +perturb_buffer_by_mono_epstein_nesbet_sc2 Applly pertubration ``epstein_nesbet_sc2`` to the buffer of determinants generated in the H_apply routine. -`perturb_buffer_by_mono_epstein_nesbet_sc2_no_projected `_ +perturb_buffer_by_mono_epstein_nesbet_sc2_no_projected Applly pertubration ``epstein_nesbet_sc2_no_projected`` to the buffer of determinants generated in the H_apply routine. -`perturb_buffer_by_mono_epstein_nesbet_sc2_projected `_ +perturb_buffer_by_mono_epstein_nesbet_sc2_projected Applly pertubration ``epstein_nesbet_sc2_projected`` to the buffer of determinants generated in the H_apply routine. -`perturb_buffer_by_mono_h_core `_ +perturb_buffer_by_mono_h_core Applly pertubration ``h_core`` to the buffer of determinants generated in the H_apply routine. -`perturb_buffer_by_mono_moller_plesset `_ +perturb_buffer_by_mono_moller_plesset Applly pertubration ``moller_plesset`` to the buffer of determinants generated in the H_apply routine. -`perturb_buffer_delta_rho_one_point `_ +perturb_buffer_delta_rho_one_point Applly pertubration ``delta_rho_one_point`` to the buffer of determinants generated in the H_apply routine. -`perturb_buffer_dipole_moment_z `_ +perturb_buffer_dipole_moment_z Applly pertubration ``dipole_moment_z`` to the buffer of determinants generated in the H_apply routine. -`perturb_buffer_epstein_nesbet `_ +perturb_buffer_epstein_nesbet Applly pertubration ``epstein_nesbet`` to the buffer of determinants generated in the H_apply routine. -`perturb_buffer_epstein_nesbet_2x2 `_ +perturb_buffer_epstein_nesbet_2x2 Applly pertubration ``epstein_nesbet_2x2`` to the buffer of determinants generated in the H_apply routine. -`perturb_buffer_epstein_nesbet_sc2 `_ +perturb_buffer_epstein_nesbet_sc2 Applly pertubration ``epstein_nesbet_sc2`` to the buffer of determinants generated in the H_apply routine. -`perturb_buffer_epstein_nesbet_sc2_no_projected `_ +perturb_buffer_epstein_nesbet_sc2_no_projected Applly pertubration ``epstein_nesbet_sc2_no_projected`` to the buffer of determinants generated in the H_apply routine. -`perturb_buffer_epstein_nesbet_sc2_projected `_ +perturb_buffer_epstein_nesbet_sc2_projected Applly pertubration ``epstein_nesbet_sc2_projected`` to the buffer of determinants generated in the H_apply routine. -`perturb_buffer_h_core `_ +perturb_buffer_h_core Applly pertubration ``h_core`` to the buffer of determinants generated in the H_apply routine. -`perturb_buffer_moller_plesset `_ +perturb_buffer_moller_plesset Applly pertubration ``moller_plesset`` to the buffer of determinants generated in the H_apply routine. @@ -239,7 +239,7 @@ Documentation .br -`pt2_epstein_nesbet `_ +`pt2_epstein_nesbet `_ compute the standard Epstein-Nesbet perturbative first order coefficient and second order energetic contribution .br for the various N_st states. @@ -250,7 +250,7 @@ Documentation .br -`pt2_epstein_nesbet_2x2 `_ +`pt2_epstein_nesbet_2x2 `_ compute the Epstein-Nesbet 2x2 diagonalization coefficient and energetic contribution .br for the various N_st states. @@ -261,7 +261,7 @@ Documentation .br -`pt2_epstein_nesbet_sc2 `_ +`pt2_epstein_nesbet_sc2 `_ compute the standard Epstein-Nesbet perturbative first order coefficient and second order energetic contribution .br for the various N_st states, but with the CISD_SC2 energies and coefficients @@ -272,7 +272,7 @@ Documentation .br -`pt2_epstein_nesbet_sc2_no_projected `_ +`pt2_epstein_nesbet_sc2_no_projected `_ compute the Epstein-Nesbet perturbative first order coefficient and second order energetic contribution .br for the various N_st states, @@ -296,7 +296,7 @@ Documentation H_pert_diag = c_pert -`pt2_epstein_nesbet_sc2_projected `_ +`pt2_epstein_nesbet_sc2_projected `_ compute the Epstein-Nesbet perturbative first order coefficient and second order energetic contribution .br for the various N_st states, @@ -336,7 +336,7 @@ Documentation than pt2_max in absolute value -`pt2_moller_plesset `_ +`pt2_moller_plesset `_ compute the standard Moller-Plesset perturbative first order coefficient and second order energetic contribution .br for the various n_st states. @@ -352,7 +352,7 @@ Documentation provided. -`repeat_all_e_corr `_ +`repeat_all_e_corr `_ Undocumented diff --git a/plugins/Perturbation/delta_rho_perturbation.irp.f b/plugins/Perturbation/delta_rho_perturbation.irp.f index d83eb9a8..c95972a6 100644 --- a/plugins/Perturbation/delta_rho_perturbation.irp.f +++ b/plugins/Perturbation/delta_rho_perturbation.irp.f @@ -1,4 +1,4 @@ -subroutine pt2_delta_rho_one_point(det_pert,c_pert,e_2_pert,H_pert_diag,Nint,ndet,n_st) +subroutine pt2_delta_rho_one_point(det_pert,c_pert,e_2_pert,H_pert_diag,Nint,ndet,n_st,minilist,idx_minilist,N_minilist) use bitmasks implicit none integer, intent(in) :: Nint,ndet,n_st @@ -7,6 +7,10 @@ subroutine pt2_delta_rho_one_point(det_pert,c_pert,e_2_pert,H_pert_diag,Nint,nde double precision :: i_O1_psi_array(N_st) double precision :: i_H_psi_array(N_st) + integer, intent(in) :: N_minilist + integer, intent(in) :: idx_minilist(0:N_det_selectors) + integer(bit_kind), intent(in) :: minilist(Nint,2,N_det_selectors) + BEGIN_DOC ! compute the perturbatibe contribution to the Integrated Spin density at z = z_one point of one determinant ! @@ -46,7 +50,8 @@ subroutine pt2_delta_rho_one_point(det_pert,c_pert,e_2_pert,H_pert_diag,Nint,nde ! endif call i_O1_psi_alpha_beta(mo_integrated_delta_rho_one_point,det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_O1_psi_array) - call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) + !call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) + call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array) h = diag_H_mat_elem(det_pert,Nint) oii = diag_O1_mat_elem_alpha_beta(mo_integrated_delta_rho_one_point,det_pert,N_int) diff --git a/plugins/Perturbation/dipole_moment.irp.f b/plugins/Perturbation/dipole_moment.irp.f index ca09c31c..53beb081 100644 --- a/plugins/Perturbation/dipole_moment.irp.f +++ b/plugins/Perturbation/dipole_moment.irp.f @@ -1,4 +1,4 @@ -subroutine pt2_dipole_moment_z(det_pert,c_pert,e_2_pert,H_pert_diag,Nint,ndet,n_st) +subroutine pt2_dipole_moment_z(det_pert,c_pert,e_2_pert,H_pert_diag,Nint,ndet,n_st,minilist,idx_minilist,N_minilist) use bitmasks implicit none integer, intent(in) :: Nint,ndet,n_st @@ -7,6 +7,10 @@ subroutine pt2_dipole_moment_z(det_pert,c_pert,e_2_pert,H_pert_diag,Nint,ndet,n_ double precision :: i_O1_psi_array(N_st) double precision :: i_H_psi_array(N_st) + integer, intent(in) :: N_minilist + integer, intent(in) :: idx_minilist(0:N_det_selectors) + integer(bit_kind), intent(in) :: minilist(Nint,2,N_det_selectors) + BEGIN_DOC ! compute the perturbatibe contribution to the dipole moment of one determinant ! @@ -46,7 +50,9 @@ subroutine pt2_dipole_moment_z(det_pert,c_pert,e_2_pert,H_pert_diag,Nint,ndet,n_ ! endif call i_O1_psi(mo_dipole_z,det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_O1_psi_array) - call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) + !call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) + call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array) + h = diag_H_mat_elem(det_pert,Nint) oii = diag_O1_mat_elem(mo_dipole_z,det_pert,N_int) diff --git a/plugins/Perturbation/epstein_nesbet.irp.f b/plugins/Perturbation/epstein_nesbet.irp.f deleted file mode 100644 index 62cb0cd6..00000000 --- a/plugins/Perturbation/epstein_nesbet.irp.f +++ /dev/null @@ -1,93 +0,0 @@ -subroutine pt2_epstein_nesbet(det_pert,c_pert,e_2_pert,H_pert_diag,Nint,ndet,N_st) - use bitmasks - implicit none - integer, intent(in) :: Nint,ndet,N_st - integer(bit_kind), intent(in) :: det_pert(Nint,2) - double precision , intent(out) :: c_pert(N_st),e_2_pert(N_st),H_pert_diag(N_st) - double precision :: i_H_psi_array(N_st) - - BEGIN_DOC - ! compute the standard Epstein-Nesbet perturbative first order coefficient and second order energetic contribution - ! - ! for the various N_st states. - ! - ! c_pert(i) = /( E(i) - ) - ! - ! e_2_pert(i) = ^2/( E(i) - ) - ! - END_DOC - - integer :: i,j - double precision :: diag_H_mat_elem, h - PROVIDE selection_criterion - - ASSERT (Nint == N_int) - ASSERT (Nint > 0) - call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) - h = diag_H_mat_elem(det_pert,Nint) - do i =1,N_st - if(CI_electronic_energy(i)>h.and.CI_electronic_energy(i).ne.0.d0)then - c_pert(i) = -1.d0 - e_2_pert(i) = selection_criterion*selection_criterion_factor*2.d0 - else if (dabs(CI_electronic_energy(i) - h) > 1.d-6) then - c_pert(i) = i_H_psi_array(i) / (CI_electronic_energy(i) - h) - H_pert_diag(i) = h*c_pert(i)*c_pert(i) - e_2_pert(i) = c_pert(i) * i_H_psi_array(i) - else - c_pert(i) = -1.d0 - e_2_pert(i) = -dabs(i_H_psi_array(i)) - H_pert_diag(i) = h - endif - enddo - -end - -subroutine pt2_epstein_nesbet_2x2(det_pert,c_pert,e_2_pert,H_pert_diag,Nint,ndet,N_st) - use bitmasks - implicit none - integer, intent(in) :: Nint,ndet,N_st - integer(bit_kind), intent(in) :: det_pert(Nint,2) - double precision , intent(out) :: c_pert(N_st),e_2_pert(N_st),H_pert_diag(N_st) - double precision :: i_H_psi_array(N_st) - - BEGIN_DOC - ! compute the Epstein-Nesbet 2x2 diagonalization coefficient and energetic contribution - ! - ! for the various N_st states. - ! - ! e_2_pert(i) = 0.5 * (( - E(i) ) - sqrt( ( - E(i)) ^2 + 4 ^2 ) - ! - ! c_pert(i) = e_2_pert(i)/ - ! - END_DOC - - integer :: i,j - double precision :: diag_H_mat_elem,delta_e, h - ASSERT (Nint == N_int) - ASSERT (Nint > 0) - PROVIDE CI_electronic_energy - - call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) - h = diag_H_mat_elem(det_pert,Nint) - do i =1,N_st - if (i_H_psi_array(i) /= 0.d0) then - delta_e = h - CI_electronic_energy(i) - if (delta_e > 0.d0) then - e_2_pert(i) = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * i_H_psi_array(i) * i_H_psi_array(i))) - else - e_2_pert(i) = 0.5d0 * (delta_e + dsqrt(delta_e * delta_e + 4.d0 * i_H_psi_array(i) * i_H_psi_array(i))) - endif - if (dabs(i_H_psi_array(i)) > 1.d-6) then - c_pert(i) = e_2_pert(i)/i_H_psi_array(i) - else - c_pert(i) = 0.d0 - endif - H_pert_diag(i) = h*c_pert(i)*c_pert(i) - else - e_2_pert(i) = 0.d0 - c_pert(i) = 0.d0 - H_pert_diag(i) = 0.d0 - endif - enddo - -end diff --git a/plugins/Perturbation/pert_sc2.irp.f b/plugins/Perturbation/pert_sc2.irp.f index bdd8f97c..f225e757 100644 --- a/plugins/Perturbation/pert_sc2.irp.f +++ b/plugins/Perturbation/pert_sc2.irp.f @@ -1,158 +1,3 @@ - -subroutine pt2_epstein_nesbet_SC2_projected(det_pert,c_pert,e_2_pert,H_pert_diag,Nint,ndet,N_st) - use bitmasks - implicit none - integer, intent(in) :: Nint,ndet,N_st - integer(bit_kind), intent(in) :: det_pert(Nint,2) - double precision , intent(out) :: c_pert(N_st),e_2_pert(N_st),H_pert_diag(N_st) - double precision :: i_H_psi_array(N_st) - integer :: idx_repeat(0:ndet) - - BEGIN_DOC - ! compute the Epstein-Nesbet perturbative first order coefficient and second order energetic contribution - ! - ! for the various N_st states, - ! - ! but with the correction in the denominator - ! - ! comming from the interaction of that determinant with all the others determinants - ! - ! that can be repeated by repeating all the double excitations - ! - ! : you repeat all the correlation energy already taken into account in CI_electronic_energy(1) - ! - ! that could be repeated to this determinant. - ! - ! In addition, for the perturbative energetic contribution you have the standard second order - ! - ! e_2_pert = ^2/(Delta_E) - ! - ! and also the purely projected contribution - ! - ! H_pert_diag = c_pert - END_DOC - - integer :: i,j,degree,l - double precision :: diag_H_mat_elem,accu_e_corr,hij,h0j,h,delta_E - double precision :: repeat_all_e_corr,accu_e_corr_tmp,e_2_pert_fonda - - ASSERT (Nint == N_int) - ASSERT (Nint > 0) - - call i_H_psi_SC2(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array,idx_repeat) - accu_e_corr = 0.d0 - !$IVDEP - do i = 1, idx_repeat(0) - accu_e_corr = accu_e_corr + E_corr_per_selectors(idx_repeat(i)) - enddo - h = diag_H_mat_elem(det_pert,Nint) + accu_e_corr - delta_E = 1.d0/(CI_SC2_electronic_energy(1) - h) - - - c_pert(1) = i_H_psi_array(1) /(CI_SC2_electronic_energy(1) - h) - e_2_pert(1) = i_H_psi_array(1) * c_pert(1) - - do i =2,N_st - H_pert_diag(i) = h - if (dabs(CI_SC2_electronic_energy(i) - h) > 1.d-6) then - c_pert(i) = i_H_psi_array(i) / (-dabs(CI_SC2_electronic_energy(i) - h)) - e_2_pert(i) = (c_pert(i) * i_H_psi_array(i)) - else - c_pert(i) = i_H_psi_array(i) - e_2_pert(i) = -dabs(i_H_psi_array(i)) - endif - enddo - - degree = popcnt(xor( ref_bitmask(1,1), det_pert(1,1))) + & - popcnt(xor( ref_bitmask(1,2), det_pert(1,2))) - !DEC$ NOUNROLL - do l=2,Nint - degree = degree+ popcnt(xor( ref_bitmask(l,1), det_pert(l,1))) + & - popcnt(xor( ref_bitmask(l,2), det_pert(l,2))) - enddo - if(degree==4)then - ! - e_2_pert_fonda = e_2_pert(1) - H_pert_diag(1) = e_2_pert(1) * c_pert(1) * c_pert(1) - do i = 1, N_st - do j = 1, idx_repeat(0) - e_2_pert(i) += e_2_pert_fonda * psi_selectors_coef(idx_repeat(j),i) * psi_selectors_coef(idx_repeat(j),i) - enddo - enddo - endif - -end - - -subroutine pt2_epstein_nesbet_SC2_no_projected(det_pert,c_pert,e_2_pert,H_pert_diag,Nint,ndet,N_st) - use bitmasks - implicit none - integer, intent(in) :: Nint,ndet,N_st - integer(bit_kind), intent(in) :: det_pert(Nint,2) - double precision , intent(out) :: c_pert(N_st),e_2_pert(N_st),H_pert_diag(N_st) - double precision :: i_H_psi_array(N_st) - integer :: idx_repeat(0:ndet) - - BEGIN_DOC - ! compute the Epstein-Nesbet perturbative first order coefficient and second order energetic contribution - ! - ! for the various N_st states, - ! - ! but with the correction in the denominator - ! - ! comming from the interaction of that determinant with all the others determinants - ! - ! that can be repeated by repeating all the double excitations - ! - ! : you repeat all the correlation energy already taken into account in CI_electronic_energy(1) - ! - ! that could be repeated to this determinant. - ! - ! In addition, for the perturbative energetic contribution you have the standard second order - ! - ! e_2_pert = ^2/(Delta_E) - ! - ! and also the purely projected contribution - ! - ! H_pert_diag = c_pert - END_DOC - - integer :: i,j,degree,l - double precision :: diag_H_mat_elem,accu_e_corr,hij,h0j,h,delta_E - double precision :: repeat_all_e_corr,accu_e_corr_tmp,e_2_pert_fonda - - ASSERT (Nint == N_int) - ASSERT (Nint > 0) - - call i_H_psi_SC2(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array,idx_repeat) - accu_e_corr = 0.d0 - !$IVDEP - do i = 1, idx_repeat(0) - accu_e_corr = accu_e_corr + E_corr_per_selectors(idx_repeat(i)) - enddo - h = diag_H_mat_elem(det_pert,Nint) + accu_e_corr - delta_E = 1.d0/(CI_SC2_electronic_energy(1) - h) - - - c_pert(1) = i_H_psi_array(1) /(CI_SC2_electronic_energy(1) - h) - e_2_pert(1) = i_H_psi_array(1) * c_pert(1) - - do i =2,N_st - H_pert_diag(i) = h - if (dabs(CI_SC2_electronic_energy(i) - h) > 1.d-6) then - c_pert(i) = i_H_psi_array(i) / (-dabs(CI_SC2_electronic_energy(i) - h)) - e_2_pert(i) = (c_pert(i) * i_H_psi_array(i)) - else - c_pert(i) = i_H_psi_array(i) - e_2_pert(i) = -dabs(i_H_psi_array(i)) - endif - enddo -end - - - - - double precision function repeat_all_e_corr(key_in) implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) @@ -182,47 +27,3 @@ double precision function repeat_all_e_corr(key_in) end - -subroutine pt2_epstein_nesbet_sc2(det_pert,c_pert,e_2_pert,H_pert_diag,Nint,ndet,N_st) - use bitmasks - implicit none - integer, intent(in) :: Nint,ndet,N_st - integer(bit_kind), intent(in) :: det_pert(Nint,2) - double precision , intent(out) :: c_pert(N_st),e_2_pert(N_st),H_pert_diag(N_st) - double precision :: i_H_psi_array(N_st) - - BEGIN_DOC - ! compute the standard Epstein-Nesbet perturbative first order coefficient and second order energetic contribution - ! - ! for the various N_st states, but with the CISD_SC2 energies and coefficients - ! - ! c_pert(i) = /( E(i) - ) - ! - ! e_2_pert(i) = ^2/( E(i) - ) - ! - END_DOC - - integer :: i,j - double precision :: diag_H_mat_elem, h - PROVIDE selection_criterion - - ASSERT (Nint == N_int) - ASSERT (Nint > 0) - call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) - h = diag_H_mat_elem(det_pert,Nint) - do i =1,N_st - if(CI_SC2_electronic_energy(i)>h.and.CI_SC2_electronic_energy(i).ne.0.d0)then - c_pert(i) = -1.d0 - e_2_pert(i) = selection_criterion*selection_criterion_factor*2.d0 - else if (dabs(CI_SC2_electronic_energy(i) - h) > 1.d-6) then - c_pert(i) = i_H_psi_array(i) / (CI_SC2_electronic_energy(i) - h) - H_pert_diag(i) = h*c_pert(i)*c_pert(i) - e_2_pert(i) = c_pert(i) * i_H_psi_array(i) - else - c_pert(i) = -1.d0 - e_2_pert(i) = -dabs(i_H_psi_array(i)) - H_pert_diag(i) = h - endif - enddo - -end diff --git a/plugins/Perturbation/pert_single.irp.f b/plugins/Perturbation/pert_single.irp.f index d04ca7ca..e2fbc9bf 100644 --- a/plugins/Perturbation/pert_single.irp.f +++ b/plugins/Perturbation/pert_single.irp.f @@ -1,4 +1,4 @@ -subroutine pt2_h_core(det_pert,c_pert,e_2_pert,H_pert_diag,Nint,ndet,N_st) +subroutine pt2_h_core(det_pert,c_pert,e_2_pert,H_pert_diag,Nint,ndet,N_st,minilist,idx_minilist,N_minilist) use bitmasks implicit none integer, intent(in) :: Nint,ndet,N_st @@ -6,6 +6,10 @@ subroutine pt2_h_core(det_pert,c_pert,e_2_pert,H_pert_diag,Nint,ndet,N_st) double precision , intent(out) :: c_pert(N_st),e_2_pert(N_st),H_pert_diag(N_st) double precision :: i_H_psi_array(N_st) + integer, intent(in) :: N_minilist + integer, intent(in) :: idx_minilist(0:N_det_selectors) + integer(bit_kind), intent(in) :: minilist(Nint,2,N_det_selectors) + BEGIN_DOC ! compute the standard Epstein-Nesbet perturbative first order coefficient and second order energetic contribution ! diff --git a/plugins/Perturbation/perturbation.template.f b/plugins/Perturbation/perturbation.template.f index a5ab12e7..33bd10dd 100644 --- a/plugins/Perturbation/perturbation.template.f +++ b/plugins/Perturbation/perturbation.template.f @@ -2,7 +2,7 @@ BEGIN_SHELL [ /usr/bin/env python ] import perturbation END_SHELL -subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert,sum_norm_pert,sum_H_pert_diag,N_st,Nint) +subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert,sum_norm_pert,sum_H_pert_diag,N_st,Nint,key_mask,fock_diag_tmp) implicit none BEGIN_DOC ! Applly pertubration ``$PERT`` to the buffer of determinants generated in the H_apply @@ -11,49 +11,73 @@ subroutine perturb_buffer_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,c integer, intent(in) :: Nint, N_st, buffer_size, i_generator integer(bit_kind), intent(in) :: buffer(Nint,2,buffer_size) + integer(bit_kind),intent(in) :: key_mask(Nint,2) + double precision, intent(in) :: fock_diag_tmp(2,0:mo_tot_num) double precision, intent(inout) :: sum_norm_pert(N_st),sum_e_2_pert(N_st) double precision, intent(inout) :: coef_pert_buffer(N_st,buffer_size),e_2_pert_buffer(N_st,buffer_size),sum_H_pert_diag(N_st) double precision :: c_pert(N_st), e_2_pert(N_st), H_pert_diag(N_st) - integer :: i,k, c_ref + integer :: i,k, c_ref, ni, ex integer, external :: connected_to_ref logical, external :: is_in_wavefunction + integer(bit_kind), allocatable :: minilist(:,:,:) + integer, allocatable :: idx_minilist(:) + integer :: N_minilist + + integer(bit_kind), allocatable :: minilist_gen(:,:,:) + integer :: N_minilist_gen + logical :: fullMatch + logical, external :: is_connected_to + + allocate( minilist(Nint,2,N_det_selectors), & + minilist_gen(Nint,2,N_det_generators), & + idx_minilist(N_det_selectors) ) + + ASSERT (Nint > 0) ASSERT (Nint == N_int) ASSERT (buffer_size >= 0) ASSERT (minval(sum_norm_pert) >= 0.d0) ASSERT (N_st > 0) - do i = 1,buffer_size - - c_ref = connected_to_ref(buffer(1,1,i),psi_det_generators,Nint,i_generator,N_det_generators) - - if (c_ref /= 0) then + + call create_minilist(key_mask, psi_selectors, miniList, idx_miniList, N_det_selectors, N_minilist, Nint) + call create_minilist_find_previous(key_mask, psi_det_generators, miniList_gen, i_generator-1, N_minilist_gen, fullMatch, Nint) + + if(fullMatch) then + deallocate( minilist, minilist_gen, idx_minilist ) + return + end if + + + do i=1,buffer_size + + if(is_connected_to(buffer(1,1,i), miniList_gen, Nint, N_minilist_gen)) then cycle - endif + end if if (is_in_wavefunction(buffer(1,1,i),Nint)) then cycle endif - integer :: degree - call get_excitation_degree(HF_bitmask,buffer(1,1,i),degree,N_int) - call pt2_$PERT(buffer(1,1,i), & - c_pert,e_2_pert,H_pert_diag,Nint,N_det_selectors,n_st) + call pt2_$PERT(psi_det_generators(1,1,i_generator),buffer(1,1,i), fock_diag_tmp, & + c_pert,e_2_pert,H_pert_diag,Nint,N_minilist,n_st,minilist,idx_minilist,N_minilist) do k = 1,N_st - e_2_pert_buffer(k,i) = e_2_pert(k) - coef_pert_buffer(k,i) = c_pert(k) - sum_norm_pert(k) += c_pert(k) * c_pert(k) - sum_e_2_pert(k) += e_2_pert(k) - sum_H_pert_diag(k) += H_pert_diag(k) + e_2_pert_buffer(k,i) = e_2_pert(k) + coef_pert_buffer(k,i) = c_pert(k) + sum_norm_pert(k) = sum_norm_pert(k) + c_pert(k) * c_pert(k) + sum_e_2_pert(k) = sum_e_2_pert(k) + e_2_pert(k) + sum_H_pert_diag(k) = sum_H_pert_diag(k) + H_pert_diag(k) enddo - enddo + enddo + deallocate( minilist, minilist_gen, idx_minilist ) end -subroutine perturb_buffer_by_mono_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert,sum_norm_pert,sum_H_pert_diag,N_st,Nint) + +subroutine perturb_buffer_by_mono_$PERT(i_generator,buffer,buffer_size,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert,sum_norm_pert,sum_H_pert_diag,N_st,Nint,key_mask,fock_diag_tmp) implicit none BEGIN_DOC ! Applly pertubration ``$PERT`` to the buffer of determinants generated in the H_apply @@ -62,20 +86,46 @@ subroutine perturb_buffer_by_mono_$PERT(i_generator,buffer,buffer_size,e_2_pert_ integer, intent(in) :: Nint, N_st, buffer_size, i_generator integer(bit_kind), intent(in) :: buffer(Nint,2,buffer_size) + integer(bit_kind),intent(in) :: key_mask(Nint,2) + double precision, intent(in) :: fock_diag_tmp(2,0:mo_tot_num) double precision, intent(inout) :: sum_norm_pert(N_st),sum_e_2_pert(N_st) double precision, intent(inout) :: coef_pert_buffer(N_st,buffer_size),e_2_pert_buffer(N_st,buffer_size),sum_H_pert_diag(N_st) double precision :: c_pert(N_st), e_2_pert(N_st), H_pert_diag(N_st) - integer :: i,k, c_ref + integer :: i,k, c_ref, ni, ex integer, external :: connected_to_ref_by_mono logical, external :: is_in_wavefunction + integer(bit_kind), allocatable :: minilist(:,:,:) + integer, allocatable :: idx_minilist(:) + integer :: N_minilist + + integer(bit_kind), allocatable :: minilist_gen(:,:,:) + integer :: N_minilist_gen + logical :: fullMatch + logical, external :: is_connected_to + + allocate( minilist(Nint,2,N_det_selectors), & + minilist_gen(Nint,2,N_det_generators), & + idx_minilist(N_det_selectors) ) + + ASSERT (Nint > 0) ASSERT (Nint == N_int) ASSERT (buffer_size >= 0) ASSERT (minval(sum_norm_pert) >= 0.d0) ASSERT (N_st > 0) - do i = 1,buffer_size - + + call create_minilist(key_mask, psi_selectors, miniList, idx_miniList, N_det_selectors, N_minilist, Nint) + call create_minilist_find_previous(key_mask, psi_det_generators, miniList_gen, i_generator-1, N_minilist_gen, fullMatch, Nint) + + if(fullMatch) then + deallocate( minilist, minilist_gen, idx_minilist ) + return + end if + + + do i=1,buffer_size + c_ref = connected_to_ref_by_mono(buffer(1,1,i),psi_det_generators,Nint,i_generator,N_det) if (c_ref /= 0) then @@ -86,19 +136,19 @@ subroutine perturb_buffer_by_mono_$PERT(i_generator,buffer,buffer_size,e_2_pert_ cycle endif - integer :: degree - call pt2_$PERT(buffer(1,1,i), & - c_pert,e_2_pert,H_pert_diag,Nint,N_det_selectors,n_st) + call pt2_$PERT(psi_det_generators(1,1,i_generator),buffer(1,1,i), fock_diag_tmp, & + c_pert,e_2_pert,H_pert_diag,Nint,N_minilist,n_st,minilist,idx_minilist,N_minilist) do k = 1,N_st - e_2_pert_buffer(k,i) = e_2_pert(k) - coef_pert_buffer(k,i) = c_pert(k) - sum_norm_pert(k) += c_pert(k) * c_pert(k) - sum_e_2_pert(k) += e_2_pert(k) - sum_H_pert_diag(k) += H_pert_diag(k) + e_2_pert_buffer(k,i) = e_2_pert(k) + coef_pert_buffer(k,i) = c_pert(k) + sum_norm_pert(k) = sum_norm_pert(k) + c_pert(k) * c_pert(k) + sum_e_2_pert(k) = sum_e_2_pert(k) + e_2_pert(k) + sum_H_pert_diag(k) = sum_H_pert_diag(k) + H_pert_diag(k) enddo - enddo + enddo + deallocate( minilist, minilist_gen, idx_minilist ) end diff --git a/plugins/Perturbation/pt2_equations.irp.f b/plugins/Perturbation/pt2_equations.irp.f new file mode 100644 index 00000000..f49ee2ff --- /dev/null +++ b/plugins/Perturbation/pt2_equations.irp.f @@ -0,0 +1,367 @@ +BEGIN_TEMPLATE + +subroutine pt2_epstein_nesbet ($arguments) + use bitmasks + implicit none + $declarations + + BEGIN_DOC + ! compute the standard Epstein-Nesbet perturbative first order coefficient and second order energetic contribution + ! + ! for the various N_st states. + ! + ! c_pert(i) = /( E(i) - ) + ! + ! e_2_pert(i) = ^2/( E(i) - ) + ! + END_DOC + + integer :: i,j + double precision :: diag_H_mat_elem_fock, h + double precision :: i_H_psi_array(N_st) + PROVIDE selection_criterion + + ASSERT (Nint == N_int) + ASSERT (Nint > 0) + !call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) + call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array) + + + h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint) + do i =1,N_st + if(CI_electronic_energy(i)>h.and.CI_electronic_energy(i).ne.0.d0)then + c_pert(i) = -1.d0 + e_2_pert(i) = selection_criterion*selection_criterion_factor*2.d0 + else if (dabs(CI_electronic_energy(i) - h) > 1.d-6) then + c_pert(i) = i_H_psi_array(i) / (CI_electronic_energy(i) - h) + H_pert_diag(i) = h*c_pert(i)*c_pert(i) + e_2_pert(i) = c_pert(i) * i_H_psi_array(i) + else + c_pert(i) = -1.d0 + e_2_pert(i) = -dabs(i_H_psi_array(i)) + H_pert_diag(i) = h + endif + enddo + +end + +subroutine pt2_epstein_nesbet_2x2 ($arguments) + use bitmasks + implicit none + $declarations + + BEGIN_DOC + ! compute the Epstein-Nesbet 2x2 diagonalization coefficient and energetic contribution + ! + ! for the various N_st states. + ! + ! e_2_pert(i) = 0.5 * (( - E(i) ) - sqrt( ( - E(i)) ^2 + 4 ^2 ) + ! + ! c_pert(i) = e_2_pert(i)/ + ! + END_DOC + + integer :: i,j + double precision :: diag_H_mat_elem_fock,delta_e, h + double precision :: i_H_psi_array(N_st) + ASSERT (Nint == N_int) + ASSERT (Nint > 0) + PROVIDE CI_electronic_energy + + !call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) + call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array) + + h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint) + do i =1,N_st + if (i_H_psi_array(i) /= 0.d0) then + delta_e = h - CI_electronic_energy(i) + if (delta_e > 0.d0) then + e_2_pert(i) = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * i_H_psi_array(i) * i_H_psi_array(i))) + else + e_2_pert(i) = 0.5d0 * (delta_e + dsqrt(delta_e * delta_e + 4.d0 * i_H_psi_array(i) * i_H_psi_array(i))) + endif + if (dabs(i_H_psi_array(i)) > 1.d-6) then + c_pert(i) = e_2_pert(i)/i_H_psi_array(i) + else + c_pert(i) = 0.d0 + endif + H_pert_diag(i) = h*c_pert(i)*c_pert(i) + else + e_2_pert(i) = 0.d0 + c_pert(i) = 0.d0 + H_pert_diag(i) = 0.d0 + endif + enddo + +end + +subroutine pt2_moller_plesset ($arguments) + use bitmasks + implicit none + $declarations + + BEGIN_DOC + ! compute the standard Moller-Plesset perturbative first order coefficient and second order energetic contribution + ! + ! for the various n_st states. + ! + ! c_pert(i) = /(difference of orbital energies) + ! + ! e_2_pert(i) = ^2/(difference of orbital energies) + ! + END_DOC + + integer :: i,j + double precision :: diag_H_mat_elem_fock + integer :: exc(0:2,2,2) + integer :: degree + double precision :: phase,delta_e,h + double precision :: i_H_psi_array(N_st) + integer :: h1,h2,p1,p2,s1,s2 + ASSERT (Nint == N_int) + ASSERT (Nint > 0) + call get_excitation(ref_bitmask,det_pert,exc,degree,phase,Nint) + if (degree == 2) then + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + delta_e = Fock_matrix_diag_mo(h1) + Fock_matrix_diag_mo(h2) - & + (Fock_matrix_diag_mo(p1) + Fock_matrix_diag_mo(p2)) + delta_e = 1.d0/delta_e + else if (degree == 1) then + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + delta_e = Fock_matrix_diag_mo(h1) - Fock_matrix_diag_mo(p1) + delta_e = 1.d0/delta_e + else + delta_e = 0.d0 + endif + + call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det,psi_selectors_size,n_st,i_H_psi_array) + h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint) + do i =1,n_st + H_pert_diag(i) = h + c_pert(i) = i_H_psi_array(i) *delta_e + e_2_pert(i) = c_pert(i) * i_H_psi_array(i) + enddo + +end + + +subroutine pt2_epstein_nesbet_SC2_projected ($arguments) + use bitmasks + implicit none + $declarations + BEGIN_DOC + ! compute the Epstein-Nesbet perturbative first order coefficient and second order energetic contribution + ! + ! for the various N_st states, + ! + ! but with the correction in the denominator + ! + ! comming from the interaction of that determinant with all the others determinants + ! + ! that can be repeated by repeating all the double excitations + ! + ! : you repeat all the correlation energy already taken into account in CI_electronic_energy(1) + ! + ! that could be repeated to this determinant. + ! + ! In addition, for the perturbative energetic contribution you have the standard second order + ! + ! e_2_pert = ^2/(Delta_E) + ! + ! and also the purely projected contribution + ! + ! H_pert_diag = c_pert + END_DOC + + double precision :: i_H_psi_array(N_st) + integer :: idx_repeat(0:ndet) + integer :: i,j,degree,l + double precision :: diag_H_mat_elem_fock,accu_e_corr,hij,h0j,h,delta_E + double precision :: repeat_all_e_corr,accu_e_corr_tmp,e_2_pert_fonda + + ASSERT (Nint == N_int) + ASSERT (Nint > 0) + + call i_H_psi_SC2(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array,idx_repeat) + accu_e_corr = 0.d0 + !$IVDEP + do i = 1, idx_repeat(0) + accu_e_corr = accu_e_corr + E_corr_per_selectors(idx_repeat(i)) + enddo + h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint) + h = h + accu_e_corr + delta_E = 1.d0/(CI_SC2_electronic_energy(1) - h) + + + c_pert(1) = i_H_psi_array(1) /(CI_SC2_electronic_energy(1) - h) + e_2_pert(1) = i_H_psi_array(1) * c_pert(1) + + do i =2,N_st + H_pert_diag(i) = h + if (dabs(CI_SC2_electronic_energy(i) - h) > 1.d-6) then + c_pert(i) = i_H_psi_array(i) / (-dabs(CI_SC2_electronic_energy(i) - h)) + e_2_pert(i) = (c_pert(i) * i_H_psi_array(i)) + else + c_pert(i) = i_H_psi_array(i) + e_2_pert(i) = -dabs(i_H_psi_array(i)) + endif + enddo + + degree = popcnt(xor( ref_bitmask(1,1), det_pert(1,1))) + & + popcnt(xor( ref_bitmask(1,2), det_pert(1,2))) + !DEC$ NOUNROLL + do l=2,Nint + degree = degree+ popcnt(xor( ref_bitmask(l,1), det_pert(l,1))) + & + popcnt(xor( ref_bitmask(l,2), det_pert(l,2))) + enddo + if(degree==4)then + ! + e_2_pert_fonda = e_2_pert(1) + H_pert_diag(1) = e_2_pert(1) * c_pert(1) * c_pert(1) + do i = 1, N_st + do j = 1, idx_repeat(0) + e_2_pert(i) += e_2_pert_fonda * psi_selectors_coef(idx_repeat(j),i) * psi_selectors_coef(idx_repeat(j),i) + enddo + enddo + endif + +end + + +subroutine pt2_epstein_nesbet_SC2_no_projected ($arguments) + use bitmasks + implicit none + $declarations + BEGIN_DOC + ! compute the Epstein-Nesbet perturbative first order coefficient and second order energetic contribution + ! + ! for the various N_st states, + ! + ! but with the correction in the denominator + ! + ! comming from the interaction of that determinant with all the others determinants + ! + ! that can be repeated by repeating all the double excitations + ! + ! : you repeat all the correlation energy already taken into account in CI_electronic_energy(1) + ! + ! that could be repeated to this determinant. + ! + ! In addition, for the perturbative energetic contribution you have the standard second order + ! + ! e_2_pert = ^2/(Delta_E) + ! + ! and also the purely projected contribution + ! + ! H_pert_diag = c_pert + END_DOC + + double precision :: i_H_psi_array(N_st) + integer :: idx_repeat(0:ndet) + integer :: i,j,degree,l + double precision :: diag_H_mat_elem_fock,accu_e_corr,hij,h0j,h,delta_E + double precision :: repeat_all_e_corr,accu_e_corr_tmp,e_2_pert_fonda + + ASSERT (Nint == N_int) + ASSERT (Nint > 0) + + call i_H_psi_SC2(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array,idx_repeat) + accu_e_corr = 0.d0 + !$IVDEP + do i = 1, idx_repeat(0) + accu_e_corr = accu_e_corr + E_corr_per_selectors(idx_repeat(i)) + enddo + h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint) + h = h + accu_e_corr + delta_E = 1.d0/(CI_SC2_electronic_energy(1) - h) + + + c_pert(1) = i_H_psi_array(1) /(CI_SC2_electronic_energy(1) - h) + e_2_pert(1) = i_H_psi_array(1) * c_pert(1) + + do i =2,N_st + H_pert_diag(i) = h + if (dabs(CI_SC2_electronic_energy(i) - h) > 1.d-6) then + c_pert(i) = i_H_psi_array(i) / (-dabs(CI_SC2_electronic_energy(i) - h)) + e_2_pert(i) = (c_pert(i) * i_H_psi_array(i)) + else + c_pert(i) = i_H_psi_array(i) + e_2_pert(i) = -dabs(i_H_psi_array(i)) + endif + enddo +end + + + + + +subroutine pt2_epstein_nesbet_sc2 ($arguments) + use bitmasks + implicit none + $declarations + BEGIN_DOC + ! compute the standard Epstein-Nesbet perturbative first order coefficient and second order energetic contribution + ! + ! for the various N_st states, but with the CISD_SC2 energies and coefficients + ! + ! c_pert(i) = /( E(i) - ) + ! + ! e_2_pert(i) = ^2/( E(i) - ) + ! + END_DOC + + integer :: i,j + double precision :: i_H_psi_array(N_st) + double precision :: diag_H_mat_elem_fock, h + PROVIDE selection_criterion + + ASSERT (Nint == N_int) + ASSERT (Nint > 0) + !call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) + call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array) + + + h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint) + do i =1,N_st + if(CI_SC2_electronic_energy(i)>h.and.CI_SC2_electronic_energy(i).ne.0.d0)then + c_pert(i) = -1.d0 + e_2_pert(i) = selection_criterion*selection_criterion_factor*2.d0 + else if (dabs(CI_SC2_electronic_energy(i) - h) > 1.d-6) then + c_pert(i) = i_H_psi_array(i) / (CI_SC2_electronic_energy(i) - h) + H_pert_diag(i) = h*c_pert(i)*c_pert(i) + e_2_pert(i) = c_pert(i) * i_H_psi_array(i) + else + c_pert(i) = -1.d0 + e_2_pert(i) = -dabs(i_H_psi_array(i)) + H_pert_diag(i) = h + endif + enddo + +end + + + +SUBST [ arguments, declarations ] + +det_ref,det_pert,fock_diag_tmp,c_pert,e_2_pert,H_pert_diag,Nint,ndet,N_st,minilist,idx_minilist,N_minilist ; + + integer, intent(in) :: Nint + integer, intent(in) :: ndet + integer, intent(in) :: N_st + integer, intent(in) :: N_minilist + integer(bit_kind), intent(in) :: det_ref (Nint,2) + integer(bit_kind), intent(in) :: det_pert(Nint,2) + double precision , intent(in) :: fock_diag_tmp(2,mo_tot_num+1) + double precision , intent(out) :: c_pert(N_st) + double precision , intent(out) :: e_2_pert(N_st) + double precision, intent(out) :: H_pert_diag(N_st) + integer, intent(in) :: idx_minilist(0:N_det_selectors) + integer(bit_kind), intent(in) :: minilist(Nint,2,N_det_selectors) +;; + + +END_TEMPLATE + +! Note : If the arguments are changed here, they should also be changed accordingly in +! the perturbation.template.f file. + diff --git a/plugins/Perturbation/tree_dependency.png b/plugins/Perturbation/tree_dependency.png index 4b13b985..dac64544 100644 Binary files a/plugins/Perturbation/tree_dependency.png and b/plugins/Perturbation/tree_dependency.png differ diff --git a/plugins/Properties/tree_dependency.png b/plugins/Properties/tree_dependency.png index 6a6c00ca..1ba8d487 100644 Binary files a/plugins/Properties/tree_dependency.png and b/plugins/Properties/tree_dependency.png differ diff --git a/plugins/Psiref_CAS/tree_dependency.png b/plugins/Psiref_CAS/tree_dependency.png index 8c7c26e6..1a922bdc 100644 Binary files a/plugins/Psiref_CAS/tree_dependency.png and b/plugins/Psiref_CAS/tree_dependency.png differ diff --git a/plugins/Psiref_Utils/tree_dependency.png b/plugins/Psiref_Utils/tree_dependency.png index a2c21ac9..20482ad2 100644 Binary files a/plugins/Psiref_Utils/tree_dependency.png and b/plugins/Psiref_Utils/tree_dependency.png differ diff --git a/plugins/QmcChem/.gitignore b/plugins/QmcChem/.gitignore index f2a19776..608403d4 100644 --- a/plugins/QmcChem/.gitignore +++ b/plugins/QmcChem/.gitignore @@ -20,4 +20,5 @@ ezfio_interface.irp.f irpf90.make irpf90_entities save_for_qmcchem -tags \ No newline at end of file +tags +target_pt2_qmc \ No newline at end of file diff --git a/plugins/QmcChem/README.rst b/plugins/QmcChem/README.rst index 9724e4fb..7e942878 100644 --- a/plugins/QmcChem/README.rst +++ b/plugins/QmcChem/README.rst @@ -66,6 +66,14 @@ Documentation title="f(|r-r_A|) = \int Y_{lm}^{C} (|r-r_C|, \Omega_C) \chi_i^{A} (r-r_A) d\Omega_C" /> +`compute_energy `_ + Compute an energy when a threshold is applied + + +`e_curve `_ + Undocumented + + `mo_pseudo_grid `_ Grid points for f(|r-r_A|) = \int Y_{lm}^{C} (|r-r_C|, \Omega_C) \phi_i^{A} (r-r_A) d\Omega_C .br diff --git a/plugins/QmcChem/save_for_qmcchem.irp.f b/plugins/QmcChem/save_for_qmcchem.irp.f index 4b028a7c..c8ddb4d9 100644 --- a/plugins/QmcChem/save_for_qmcchem.irp.f +++ b/plugins/QmcChem/save_for_qmcchem.irp.f @@ -1,6 +1,7 @@ program save_for_qmc read_wf = .True. TOUCH read_wf + print *, "N_det = ", N_det call write_spindeterminants if (do_pseudo) then call write_pseudopotential diff --git a/plugins/QmcChem/target_pt2_qmc.irp.f b/plugins/QmcChem/target_pt2_qmc.irp.f new file mode 100644 index 00000000..228bcb5e --- /dev/null +++ b/plugins/QmcChem/target_pt2_qmc.irp.f @@ -0,0 +1,121 @@ +program e_curve + use bitmasks + implicit none + integer :: i,j,k, nab, m, l, n_up, n_dn, n + double precision :: norm, E, hij, num, ci, cj + integer, allocatable :: iorder(:) + double precision , allocatable :: norm_sort(:), psi_bilinear_matrix_values_save(:) + nab = n_det_alpha_unique+n_det_beta_unique + + allocate ( norm_sort(0:nab), iorder(0:nab), psi_bilinear_matrix_values_save(N_det) ) + + + norm_sort(0) = 0.d0 + iorder(0) = 0 + do i=1,n_det_alpha_unique + norm_sort(i) = det_alpha_norm(i) + iorder(i) = i + enddo + + do i=1,n_det_beta_unique + norm_sort(i+n_det_alpha_unique) = det_beta_norm(i) + iorder(i+n_det_alpha_unique) = -i + enddo + + call dsort(norm_sort(1),iorder(1),nab) + + if (.not.read_wf) then + stop 'Please set read_wf to true' + endif + + psi_bilinear_matrix_values_save = psi_bilinear_matrix_values(:,1) + print *, '==========================================================' + print '(A8,2X,A8,2X,A12,2X,A10,2X,A12)', 'Thresh.', 'Ndet', 'Cost', 'Norm', 'E' + print *, '==========================================================' + integer(bit_kind), allocatable :: det_i(:,:), det_j(:,:) + + double precision :: thresh, E_min, E_max, E_prev + thresh = 0.d0 + call compute_energy(psi_bilinear_matrix_values_save,E_max,m,norm) + call i_h_j(psi_det_sorted(1,1,1), psi_det_sorted(1,1,1), N_int, E_min) + print *, E_min, E_max + + n_up = nab + n_dn = 0 + do while (n_up > n_dn) + n = n_dn + (n_up-n_dn)/2 + psi_bilinear_matrix_values_save = psi_bilinear_matrix_values(:,1) + do j=1,n + i = iorder(j) + if (i<0) then + do k=1,n_det + if (psi_bilinear_matrix_columns(k) == -i) then + psi_bilinear_matrix_values_save(k) = 0.d0 + endif + enddo + else + do k=1,n_det + if (psi_bilinear_matrix_rows(k) == i) then + psi_bilinear_matrix_values_save(k) = 0.d0 + endif + enddo + endif + enddo + call compute_energy(psi_bilinear_matrix_values_save,E,m,norm) + print '(E9.1,2X,I8,2X,F10.2,2X,F10.6,2X,F12.6)', norm_sort(n), m, & + dble( elec_alpha_num**3 + elec_alpha_num**2 * m ) / & + dble( elec_alpha_num**3 + elec_alpha_num**2 * n ), norm, E + if (E < target_energy) then + n_dn = n+1 + else + n_up = n + endif + enddo + print *, '==========================================================' + print *, norm_sort(n), target_energy + + deallocate (iorder, norm_sort, psi_bilinear_matrix_values_save) +end + +subroutine compute_energy(psi_bilinear_matrix_values_save, E, m, norm) + implicit none + BEGIN_DOC + ! Compute an energy when a threshold is applied + END_DOC + double precision, intent(in) :: psi_bilinear_matrix_values_save(n_det) + integer(bit_kind), allocatable :: det_i(:,:), det_j(:,:) + integer :: i,j, k, l, m + double precision :: num, norm, ci, cj, hij, E + + + num = 0.d0 + norm = 0.d0 + m = 0 + !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(k,l,det_i,det_j,ci,cj,hij) REDUCTION(+:norm,m,num) + allocate( det_i(N_int,2), det_j(N_int,2)) + !$OMP DO schedule(guided) + do k=1,n_det + if (psi_bilinear_matrix_values_save(k) == 0.d0) then + cycle + endif + ci = psi_bilinear_matrix_values_save(k) + det_i(:,1) = psi_det_alpha_unique(:,psi_bilinear_matrix_rows(k)) + det_i(:,2) = psi_det_beta_unique(:,psi_bilinear_matrix_columns(k)) + do l=1,n_det + if (psi_bilinear_matrix_values_save(l) == 0.d0) then + cycle + endif + cj = psi_bilinear_matrix_values_save(l) + det_j(:,1) = psi_det_alpha_unique(:,psi_bilinear_matrix_rows(l)) + det_j(:,2) = psi_det_beta_unique(:,psi_bilinear_matrix_columns(l)) + call i_h_j(det_i, det_j, N_int, hij) + num = num + ci*cj*hij + enddo + norm = norm + ci*ci + m = m+1 + enddo + !$OMP END DO + deallocate (det_i,det_j) + !$OMP END PARALLEL + E = num / norm + nuclear_repulsion +end diff --git a/plugins/Selectors_full/tree_dependency.png b/plugins/Selectors_full/tree_dependency.png index 53d48336..f49b2e9a 100644 Binary files a/plugins/Selectors_full/tree_dependency.png and b/plugins/Selectors_full/tree_dependency.png differ diff --git a/plugins/SingleRefMethod/tree_dependency.png b/plugins/SingleRefMethod/tree_dependency.png index aea802f4..2b7f777f 100644 Binary files a/plugins/SingleRefMethod/tree_dependency.png and b/plugins/SingleRefMethod/tree_dependency.png differ diff --git a/plugins/loc_cele/README.rst b/plugins/loc_cele/README.rst index c2bd983d..f6c6a7d7 100644 --- a/plugins/loc_cele/README.rst +++ b/plugins/loc_cele/README.rst @@ -20,3 +20,25 @@ Needed Modules * `MO_Basis `_ +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +.. image:: tree_dependency.png + +* `MO_Basis `_ + +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +`loc_rasorb `_ + This program performs a localization of the active orbitals + of a CASSCF wavefunction, reading the orbitals from a RASORB + file of molcas. + id1=max is the number of MO in a given symmetry. + diff --git a/plugins/loc_cele/loc_cele.irp.f b/plugins/loc_cele/loc_cele.irp.f index 30624c1d..12f90b64 100644 --- a/plugins/loc_cele/loc_cele.irp.f +++ b/plugins/loc_cele/loc_cele.irp.f @@ -280,7 +280,7 @@ enddo !big loop over symmetry - 10 format (4E18.12) + 10 format (4E20.12) ! Now we copyt the newcmo into the mo_coef diff --git a/scripts/compilation/qp_create_ninja.py b/scripts/compilation/qp_create_ninja.py index cfb0a998..d267e628 100755 --- a/scripts/compilation/qp_create_ninja.py +++ b/scripts/compilation/qp_create_ninja.py @@ -35,7 +35,9 @@ except ImportError: from qp_path import QP_ROOT, QP_SRC, QP_EZFIO -EZFIO_LIB = join(QP_ROOT, "lib", "libezfio.a") +LIB = "" # join(QP_ROOT, "lib", "rdtsc.o") +EZFIO_LIB = join(QP_ROOT, "lib", "libezfio_irp.a") +ZMQ_LIB = join(QP_ROOT, "lib", "libf77zmq.a") + " " + join(QP_ROOT, "lib", "libzmq.a") + " -lstdc++ -lrt" ROOT_BUILD_NINJA = join(QP_ROOT, "config", "build.ninja") header = r"""# @@ -94,7 +96,7 @@ def ninja_create_env_variable(pwd_config_file): l_string.append(str_) lib_lapack = get_compilation_option(pwd_config_file, "LAPACK_LIB") - l_string.append("{0} = {1} {2}".format("LIB", lib_lapack, EZFIO_LIB)) + l_string.append("LIB = {0} {1} {2} {3}".format(LIB, lib_lapack, EZFIO_LIB, ZMQ_LIB)) l_string.append("") @@ -260,7 +262,7 @@ def ninja_ezfio_rule(): l_flag = ["export {0}='${0}'".format(flag) for flag in ["FC", "FCFLAGS", "IRPF90"]] - install_lib_ezfio = join(QP_ROOT, 'install', 'EZFIO', "lib", "libezfio.a") + install_lib_ezfio = join(QP_ROOT, 'install', 'EZFIO', "lib", "libezfio_irp.a") l_cmd = ["cd {0}".format(QP_EZFIO)] + l_flag l_cmd += ["rm -f make.config ; ninja && ln -sf {0} {1}".format(install_lib_ezfio, EZFIO_LIB)] @@ -707,7 +709,7 @@ def ninja_dot_tree_rule(): l_string = [ "rule build_dot_tree", " command = {0}".format(" ; ".join(l_cmd)), " generator = 1", - " description = Generate Png representtion of the Tree Dependencies of $module_rel", + " description = Generating Png representation of the Tree Dependencies of $module_rel", "" ] diff --git a/scripts/generate_h_apply.py b/scripts/generate_h_apply.py index 51ef5090..e1c915bc 100755 --- a/scripts/generate_h_apply.py +++ b/scripts/generate_h_apply.py @@ -60,7 +60,7 @@ class H_apply(object): s["omp_master"] = "!$OMP MASTER" s["omp_end_master"] = "!$OMP END MASTER" s["omp_barrier"] = "!$OMP BARRIER" - s["omp_do"] = "!$OMP DO SCHEDULE (static)" + s["omp_do"] = "!$OMP DO SCHEDULE (static,1)" s["omp_enddo"] = "!$OMP ENDDO NOWAIT" d = { True : '.True.', False : '.False.'} @@ -99,7 +99,7 @@ class H_apply(object): deallocate(H_jj,iorder) """ - s["size_max"] = str(1024*128) + s["size_max"] = "256" s["copy_buffer"] = """call copy_H_apply_buffer_to_wf if (s2_eig) then call make_s2_eigenfunction @@ -131,10 +131,10 @@ class H_apply(object): def filter_vvvv_excitation(self): self["filter_vvvv_excitation"] = """ key_union_hole_part = 0_bit_kind - call set_bite_to_integer(i_a,key_union_hole_part,N_int) - call set_bite_to_integer(j_a,key_union_hole_part,N_int) - call set_bite_to_integer(i_b,key_union_hole_part,N_int) - call set_bite_to_integer(j_b,key_union_hole_part,N_int) + call set_bit_to_integer(i_a,key_union_hole_part,N_int) + call set_bit_to_integer(j_a,key_union_hole_part,N_int) + call set_bit_to_integer(i_b,key_union_hole_part,N_int) + call set_bit_to_integer(j_b,key_union_hole_part,N_int) do jtest_vvvv = 1, N_int if(iand(key_union_hole_part(jtest_vvvv),virt_bitmask(jtest_vvvv,1).ne.key_union_hole_part(jtest_vvvv)))then b_cycle = .False. @@ -157,7 +157,6 @@ class H_apply(object): def set_filter_2h_2p(self): self["filter2h2p"] = """ -! ! DIR$ FORCEINLINE if (is_a_two_holes_two_particles(key)) cycle """ @@ -201,11 +200,11 @@ class H_apply(object): """ self.data["size_max"] = "256" self.data["initialization"] = """ - PROVIDE CI_electronic_energy psi_selectors_coef psi_selectors E_corr_per_selectors psi_det_sorted_bit + PROVIDE psi_selectors_coef psi_selectors E_corr_per_selectors psi_det_sorted_bit """ self.data["keys_work"] = """ call perturb_buffer_%s(i_generator,keys_out,key_idx,e_2_pert_buffer,coef_pert_buffer,sum_e_2_pert, & - sum_norm_pert,sum_H_pert_diag,N_st,N_int) + sum_norm_pert,sum_H_pert_diag,N_st,N_int,key_mask,fock_diag_tmp) """%(pert,) self.data["finalization"] = """ """ @@ -219,7 +218,7 @@ class H_apply(object): double precision, intent(inout):: norm_pert(N_st) double precision, intent(inout):: H_pert_diag(N_st) double precision :: delta_pt2(N_st), norm_psi(N_st), pt2_old(N_st) - PROVIDE CI_electronic_energy N_det_generators + PROVIDE N_det_generators do k=1,N_st pt2(k) = 0.d0 norm_pert(k) = 0.d0 @@ -266,7 +265,7 @@ class H_apply(object): double precision, intent(inout) :: select_max_out""" self.data["params_post"] += ", select_max(min(i_generator,size(select_max,1)))" - self.data["size_max"] = str(1024*128) + self.data["size_max"] = "256" self.data["copy_buffer"] = """ call copy_H_apply_buffer_to_wf if (s2_eig) then diff --git a/scripts/get_basis.sh b/scripts/get_basis.sh index 1e969d5c..c708511b 100755 --- a/scripts/get_basis.sh +++ b/scripts/get_basis.sh @@ -8,7 +8,8 @@ # Prints in stdout the name of a temporary file containing the basis set. # - +#DEBUG: +#echo $0 $@ 1>&2 if [[ -z ${QP_ROOT} ]] then diff --git a/scripts/module/create_gitignore.sh b/scripts/module/create_gitignore.sh index cf86ee39..e022da8b 100755 --- a/scripts/module/create_gitignore.sh +++ b/scripts/module/create_gitignore.sh @@ -13,7 +13,6 @@ then fi source ${QP_ROOT}/scripts/qp_include.sh - function do_gitingore() { cat << EOF > .gitignore diff --git a/scripts/module/module_handler.py b/scripts/module/module_handler.py index b491fd9d..136dc8cf 100755 --- a/scripts/module/module_handler.py +++ b/scripts/module/module_handler.py @@ -88,7 +88,7 @@ def get_l_module_descendant(d_child, l_module): except KeyError: print >> sys.stderr, "Error: " print >> sys.stderr, "`{0}` is not a submodule".format(module) - print >> sys.stderr, "Check the typo (orthograph, case, '/', etc.) " + print >> sys.stderr, "Check the typo (spelling, case, '/', etc.) " sys.exit(1) return list(set(l)) @@ -180,6 +180,11 @@ class ModuleHandler(): def create_png(self, l_module): """Create the png of the dependency tree for a l_module""" + # Don't update if we are not in the main repository + from is_master_repository import is_master_repository + if not is_master_repository: + return + basename = "tree_dependency" path = '{0}.png'.format(basename) @@ -289,6 +294,12 @@ if __name__ == '__main__': pass if arguments["create_git_ignore"]: + + # Don't update if we are not in the main repository + from is_master_repository import is_master_repository + if not is_master_repository: + sys.exit() + path = os.path.join(module_abs, ".gitignore") with open(path, "w+") as f: diff --git a/scripts/module/qp_module.py b/scripts/module/qp_module.py index 10c0fada..e8f63b13 100755 --- a/scripts/module/qp_module.py +++ b/scripts/module/qp_module.py @@ -57,10 +57,48 @@ def save_new_module(path, l_child): f.write(D_KEY["needed_module"]) f.write(D_KEY["documentation"]) + with open(os.path.join(path, "%s.main.irp.f"%(module_name) ), "w") as f: + f.write("program {0}".format(module_name) ) + f.write(""" implicit none + BEGIN_DOC +! TODO + END_DOC + print *, ' _/ ' + print *, ' -:\_?, _Jm####La ' + print *, 'J"(:" > _]#AZ#Z#UUZ##, ' + print *, '_,::./ %(|i%12XmX1*1XL _?, ' + print *, ' \..\ _\(vmWQwodY+ia%lnL _",/ ( ' + print *, ' .:< ]J=mQD?WXn|,)nr" ' + print *, ' 4XZ#Xov1v}=)vnXAX1nnv;1n" ' + print *, ' ]XX#ZXoovvvivnnnlvvo2*i7 ' + print *, ' "23Z#1S2oo2XXSnnnoSo2>v" ' + print *, ' miX#L -~`""!!1}oSoe|i7 ' + print *, ' 4cn#m, v221=|v[ ' + print *, ' ]hI3Zma,;..__wXSe=+vo ' + print *, ' ]Zov*XSUXXZXZXSe||vo2 ' + print *, ' ]Z#>=|< ' + print *, ' -ziiiii||||||+||==+> ' + print *, ' -%|+++||=|=+|=|==/ ' + print *, ' -a>====+|====-:- ' + print *, ' "~,- -- /- ' + print *, ' -. )> ' + print *, ' .~ +- ' + print *, ' . .... : . ' + print *, ' -------~ ' + print *, '' +end +""") -if __name__ == '__main__': - arguments = docopt(__doc__) - +def main(arguments): if arguments["list"]: if arguments["--installed"]: @@ -107,12 +145,14 @@ if __name__ == '__main__': save_new_module(path, l_child_reduce) print " [ OK ]" - print "Your module is created in the `plugins` directory." - print "You need to create some `.irp.f` to be able to install it." # print "` {0} install {1} `".format(os.path.basename(__file__), name) print "" + arguments["create"]=False + arguments["install"]=True + main(arguments) elif arguments["download"]: + print "Not yet implemented" pass # d_local = get_dict_child([QP_SRC]) # d_remote = get_dict_child(arguments[""]) @@ -205,3 +245,8 @@ if __name__ == '__main__': except OSError: print "%s is a core module which can't be removed" % module + +if __name__ == '__main__': + arguments = docopt(__doc__) + main(arguments) + diff --git a/scripts/module/qp_update_readme.py b/scripts/module/qp_update_readme.py index 9ff9603b..cc42e49e 100755 --- a/scripts/module/qp_update_readme.py +++ b/scripts/module/qp_update_readme.py @@ -44,7 +44,7 @@ def get_url(path_module_rel): elif is_module(path_module_rel): url = "http://github.com/LCPQ/quantum_package/tree/master/src" else: - print "{0} Is not a valide module nor plugin".format(path_module_rel) + print "{0} Is not a valid module nor plugin".format(path_module_rel) sys.exit(1) return os.path.join(url, path_module_rel) @@ -155,20 +155,32 @@ def update_documentation(d_readmen, root_module): l_doc = [] for irp in d_info[path]: - url = os.path.join(get_url(os.path.basename(path)), irp.file) doc = extract_doc(root_module, irp.provider) - l_doc += ["`{0} <{1}#L{2}>`_".format(irp.provider, url, irp.line), - doc, - ""] + if ".irp.f_shell_" in irp.file: + l_doc += ["{0}".format(irp.provider), + doc, + ""] + else: + l_doc += ["`{0} <{1}#L{2}>`_".format(irp.provider, url, irp.line), + doc, + ""] l_doc_section = [D_KEY["documentation"], '', "\n".join(l_doc)] d_readme[path]["documentation"] = "\n".join(l_doc_section) + if __name__ == '__main__': + + # Update documentation only if the remote repository is + # the main repository + from is_master_repository import is_master_repository + if not is_master_repository: + sys.exit(0) + arguments = docopt(__doc__) if arguments["--root_module"]: @@ -188,8 +200,8 @@ if __name__ == '__main__': fetch_splitted_data(d_readme, l_module_readme) except IOError: print l_module_readme, "is not a module and/or", - print "have not a `README.rst` file inside" - print "Abort..." + print "has not a `README.rst` file inside" + print "Aborting..." sys.exit(1) update_needed(d_readme) diff --git a/scripts/pseudo/elts_num_ele.py b/scripts/pseudo/elts_num_ele.py index 3c4ad09f..8f31f4f7 100644 --- a/scripts/pseudo/elts_num_ele.py +++ b/scripts/pseudo/elts_num_ele.py @@ -1,4 +1,5 @@ -name_to_elec = {"H": 1, +name_to_elec = {"X": 0, + "H": 1, "He": 2, "Li": 3, "Be": 4, diff --git a/scripts/pseudo/put_pseudo_in_ezfio.py b/scripts/pseudo/put_pseudo_in_ezfio.py index f44fb097..6ad69f10 100755 --- a/scripts/pseudo/put_pseudo_in_ezfio.py +++ b/scripts/pseudo/put_pseudo_in_ezfio.py @@ -58,17 +58,35 @@ def get_pseudo_str(l_atom): str_ = "" for a in l_atom: - l_cmd_atom = ["--atom", a] - l_cmd_head = [EMSL_path, "get_basis_data", - "--db_path", db_path, - "--basis", "BFD-Pseudo"] + if a is not 'X': + l_cmd_atom = ["--atom", a] - process = Popen(l_cmd_head + l_cmd_atom, stdout=PIPE, stderr=PIPE) + l_cmd_head = [EMSL_path, "get_basis_data", + "--db_path", db_path, + "--basis", "BFD-Pseudo"] - stdout, _ = process.communicate() - str_ += stdout.strip() + "\n" + process = Popen(l_cmd_head + l_cmd_atom, stdout=PIPE, stderr=PIPE) + stdout, _ = process.communicate() + str_ += stdout.strip() + "\n" + + else: # Dummy atoms + str_ += """Element Symbol: X +Number of replaced protons: 0 +Number of projectors: 0 + +Pseudopotential data: + +Local component: +Coeff. r^n Exp. +0.0 -1 0. +0.0 1 0. +0.0 0 0. + +Non-local component: +Coeff. r^n Exp. Proj. +""" return str_ diff --git a/scripts/utility/is_master_repository.py b/scripts/utility/is_master_repository.py new file mode 100755 index 00000000..da5fb56f --- /dev/null +++ b/scripts/utility/is_master_repository.py @@ -0,0 +1,14 @@ +#!/usr/bin/env python + +import subprocess +pipe = subprocess.Popen("git config --get remote.origin.url", \ + shell=True, stdout=subprocess.PIPE) +result = pipe.stdout.read() +is_master_repository = "LCPQ/quantum_package" in result + +if __name__ == "__main__": + import sys + if is_master_repository: + sys.exit(0) + else: + sys.exit(-1) diff --git a/src/AO_Basis/ao_overlap.irp.f b/src/AO_Basis/ao_overlap.irp.f index 737f03f7..4487ff77 100644 --- a/src/AO_Basis/ao_overlap.irp.f +++ b/src/AO_Basis/ao_overlap.irp.f @@ -59,6 +59,7 @@ enddo enddo !$OMP END PARALLEL DO + END_PROVIDER diff --git a/src/AO_Basis/tree_dependency.png b/src/AO_Basis/tree_dependency.png index 5d3366ea..acaeb7af 100644 Binary files a/src/AO_Basis/tree_dependency.png and b/src/AO_Basis/tree_dependency.png differ diff --git a/src/Bitmask/bitmasks.irp.f b/src/Bitmask/bitmasks.irp.f index 044fa18b..29588369 100644 --- a/src/Bitmask/bitmasks.irp.f +++ b/src/Bitmask/bitmasks.irp.f @@ -262,13 +262,7 @@ END_PROVIDER logical :: exists integer :: j,i integer :: i_hole,i_part,i_gen - PROVIDE ezfio_filename -!do j = 1, N_int -! inact_bitmask(j,1) = xor(generators_bitmask(j,1,1,1),cas_bitmask(j,1,1)) -! inact_bitmask(j,2) = xor(generators_bitmask(j,2,1,1),cas_bitmask(j,2,1)) -! virt_bitmask(j,1) = xor(generators_bitmask(j,1,2,1),cas_bitmask(j,1,1)) -! virt_bitmask(j,2) = xor(generators_bitmask(j,2,2,1),cas_bitmask(j,2,1)) -!enddo + n_inact_orb = 0 n_virt_orb = 0 if(N_generators_bitmask == 1)then diff --git a/src/Bitmask/tree_dependency.png b/src/Bitmask/tree_dependency.png index 2308df3d..24ce3397 100644 Binary files a/src/Bitmask/tree_dependency.png and b/src/Bitmask/tree_dependency.png differ diff --git a/src/Determinants/EZFIO.cfg b/src/Determinants/EZFIO.cfg index fe9612cb..9613c6c1 100644 --- a/src/Determinants/EZFIO.cfg +++ b/src/Determinants/EZFIO.cfg @@ -40,6 +40,12 @@ doc: Force the wave function to be an eigenfunction of S^2 interface: ezfio,provider,ocaml default: False +[threshold_davidson] +type: Threshold +doc: Thresholds of Davidson's algorithm +interface: ezfio,provider,ocaml +default: 1.e-8 + [threshold_generators] type: Threshold doc: Thresholds on generators (fraction of the norm) @@ -53,9 +59,10 @@ interface: ezfio,provider,ocaml default: 0.999 [n_states_diag] -type: integer +type: States_number doc: n_states_diag -interface: ezfio,provider +default: 1 +interface: ezfio,provider,ocaml [n_int] interface: ezfio @@ -89,24 +96,25 @@ doc: psi_det type: integer*8 size: (determinants.n_int*determinants.bit_kind/8,2,determinants.n_det) -[det_num] -interface: ezfio,provider -doc: det_num -type: integer - [det_occ] interface: ezfio,provider doc: det_occ type: integer -size: (electrons.elec_alpha_num,determinants.det_num,2) +size: (electrons.elec_alpha_num,determinants.n_det,2) [det_coef] interface: ezfio,provider doc: det_coef type: double precision -size: (determinants.det_num) +size: (determinants.n_det) [expected_s2] interface: ezfio,provider -doc: expcted_s2 -type: double precision +doc: Expected value of S^2 +type: double precision + +[target_energy] +interface: ezfio,provider,ocaml +doc: Energy that should be obtained when truncating the wave function (optional) +type: Energy +default: 0. diff --git a/src/Determinants/Fock_diag.irp.f b/src/Determinants/Fock_diag.irp.f new file mode 100644 index 00000000..a99bbcad --- /dev/null +++ b/src/Determinants/Fock_diag.irp.f @@ -0,0 +1,84 @@ +subroutine build_fock_tmp(fock_diag_tmp,det_ref,Nint) + use bitmasks + implicit none + BEGIN_DOC +! Build the diagonal of the Fock matrix corresponding to a generator +! determinant. F_00 is = E0. + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det_ref(Nint,2) + double precision, intent(out) :: fock_diag_tmp(2,mo_tot_num+1) + + integer :: occ(Nint*bit_kind_size,2) + integer :: ne(2), i, j, ii, jj + double precision :: E0 + + ! Compute Fock matrix diagonal elements + call bitstring_to_list_ab(det_ref,occ,Ne,Nint) + + fock_diag_tmp = 0.d0 + E0 = 0.d0 + + ! Occupied MOs + do ii=1,elec_alpha_num + i = occ(ii,1) + fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_mono_elec_integral(i,i) + E0 = E0 + mo_mono_elec_integral(i,i) + do jj=1,elec_alpha_num + j = occ(jj,1) + if (i==j) cycle + fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_bielec_integral_jj_anti(i,j) + E0 = E0 + 0.5d0*mo_bielec_integral_jj_anti(i,j) + enddo + do jj=1,elec_beta_num + j = occ(jj,2) + fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_bielec_integral_jj(i,j) + E0 = E0 + mo_bielec_integral_jj(i,j) + enddo + enddo + do ii=1,elec_beta_num + i = occ(ii,2) + fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_mono_elec_integral(i,i) + E0 = E0 + mo_mono_elec_integral(i,i) + do jj=1,elec_beta_num + j = occ(jj,2) + if (i==j) cycle + fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_bielec_integral_jj_anti(i,j) + E0 = E0 + 0.5d0*mo_bielec_integral_jj_anti(i,j) + enddo + do jj=1,elec_alpha_num + j = occ(jj,1) + fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_bielec_integral_jj(i,j) + enddo + enddo + + ! Virtual MOs + do i=1,mo_tot_num + if (fock_diag_tmp(1,i) /= 0.d0) cycle + fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_mono_elec_integral(i,i) + do jj=1,elec_alpha_num + j = occ(jj,1) + fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_bielec_integral_jj_anti(i,j) + enddo + do jj=1,elec_beta_num + j = occ(jj,2) + fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_bielec_integral_jj(i,j) + enddo + enddo + do i=1,mo_tot_num + if (fock_diag_tmp(2,i) /= 0.d0) cycle + fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_mono_elec_integral(i,i) + do jj=1,elec_beta_num + j = occ(jj,2) + fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_bielec_integral_jj_anti(i,j) + enddo + do jj=1,elec_alpha_num + j = occ(jj,1) + fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_bielec_integral_jj(i,j) + enddo + enddo + + fock_diag_tmp(1,mo_tot_num+1) = E0 + fock_diag_tmp(2,mo_tot_num+1) = E0 + +end diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index 6e2b3a5a..7e9861fe 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -2,11 +2,11 @@ use bitmasks use omp_lib type H_apply_buffer_type -integer :: N_det -integer :: sze -integer(bit_kind), pointer :: det(:,:,:) -double precision , pointer :: coef(:,:) -double precision , pointer :: e2(:,:) + integer :: N_det + integer :: sze + integer(bit_kind), pointer :: det(:,:,:) + double precision , pointer :: coef(:,:) + double precision , pointer :: e2(:,:) end type H_apply_buffer_type type(H_apply_buffer_type), pointer :: H_apply_buffer(:) @@ -41,6 +41,15 @@ type(H_apply_buffer_type), pointer :: H_apply_buffer(:) call omp_init_lock(H_apply_buffer_lock(1,iproc)) !$OMP END PARALLEL endif + do iproc=2,nproc-1 + if (.not.associated(H_apply_buffer(iproc)%det)) then + print *, ' ===================== Error =================== ' + print *, 'H_apply_buffer_allocated should be provided outside' + print *, 'of an OpenMP section' + print *, ' =============================================== ' + stop + endif + enddo END_PROVIDER @@ -111,7 +120,6 @@ subroutine copy_H_apply_buffer_to_wf double precision, allocatable :: buffer_coef(:,:) integer :: i,j,k integer :: N_det_old - integer :: iproc PROVIDE H_apply_buffer_allocated @@ -158,7 +166,7 @@ subroutine copy_H_apply_buffer_to_wf enddo !$OMP PARALLEL DEFAULT(SHARED) & !$OMP PRIVATE(j,k,i) FIRSTPRIVATE(N_det_old) & - !$OMP SHARED(N_int,H_apply_buffer,psi_det,psi_coef,N_states) + !$OMP SHARED(N_int,H_apply_buffer,psi_det,psi_coef,N_states,psi_det_size) j=0 !$ j=omp_get_thread_num() do k=0,j-1 diff --git a/src/Determinants/H_apply.template.f b/src/Determinants/H_apply.template.f index fe360a96..58ae8b08 100644 --- a/src/Determinants/H_apply.template.f +++ b/src/Determinants/H_apply.template.f @@ -1,6 +1,6 @@ -subroutine $subroutine_diexc(key_in, key_prev, hole_1,particl_1, hole_2, particl_2, i_generator, iproc_in $parameters ) +subroutine $subroutine_diexc(key_in, key_prev, hole_1,particl_1, hole_2, particl_2, fock_diag_tmp, i_generator, iproc_in $parameters ) integer(bit_kind), intent(in) :: key_in(N_int, 2), hole_1(N_int, 2), hole_2(N_int, 2) integer(bit_kind), intent(in) :: particl_1(N_int, 2), particl_2(N_int, 2) @@ -8,8 +8,11 @@ subroutine $subroutine_diexc(key_in, key_prev, hole_1,particl_1, hole_2, particl integer,intent(in) :: i_generator,iproc_in integer(bit_kind) :: status(N_int*bit_kind_size, 2) integer :: highest, p1,p2,sp,ni,i,mi,nt,ns - - integer(bit_kind), intent(in) :: key_prev(N_int, 2, *) + double precision, intent(in) :: fock_diag_tmp(2,mo_tot_num+1) + integer(bit_kind), intent(in) :: key_prev(N_int, 2, *) + PROVIDE N_int + PROVIDE N_det + $declarations @@ -31,30 +34,30 @@ subroutine $subroutine_diexc(key_in, key_prev, hole_1,particl_1, hole_2, particl end do end do -! GEL D'ELECTRONS -! nt = 0 +! ! GEL D'ELECTRONS +! ! nt = 0 ! do i=1,i_generator-1 ! if(key_in(1,1) == key_prev(1,1,i)) then ! tmp = xor(key_in(1,2), key_prev(1,2,i)) ! if(popcnt(tmp) == 2) then ! ns = 1+trailz(iand(tmp, key_in(1,2))) -! if(status(ns, 2) /= 0) then -! nt += 1 -! end if +! ! if(status(ns, 2) /= 0) then +! ! nt += 1 +! ! end if ! status(ns, 2) = 0 ! end if ! else if(key_in(1,2) == key_prev(1,2,i)) then ! tmp = xor(key_in(1,1), key_prev(1,1,i)) ! if(popcnt(tmp) == 2) then ! ns = 1+trailz(iand(tmp, key_in(1,1))) -! if(status(ns, 1) /= 0) then -! nt += 1 -! end if +! ! if(status(ns, 1) /= 0) then +! ! nt += 1 +! ! end if ! status(ns, 1) = 0 ! end if ! end if ! end do -! print *, "nt", nt, i_generator +! ! print *, "nt", nt, i_generator do sp=1,2 @@ -69,7 +72,7 @@ subroutine $subroutine_diexc(key_in, key_prev, hole_1,particl_1, hole_2, particl if((status(p1, sp) == 1 .and. status(p2, sp) > 1) .or. & (status(p1, sp) == 2 .and. status(p2, sp) == 3) .or. & (status(p1, sp) == 3 .and. status(p2, sp) == 3 .and. p2 > p1)) then - call $subroutine_diexcP(key_in, sp, p1, particl_1, sp, p2, particl_2, i_generator, iproc_in $parameters ) + call $subroutine_diexcP(key_in, sp, p1, particl_1, sp, p2, particl_2, fock_diag_tmp, i_generator, iproc_in $parameters ) end if end do end do @@ -86,16 +89,17 @@ subroutine $subroutine_diexc(key_in, key_prev, hole_1,particl_1, hole_2, particl (status(p1, 1) == 1 .and. status(p2, 2) >= 2) .or. & (status(p1, 1) == 2 .and. status(p2, 2) /= 2)) then - call $subroutine_diexcP(key_in, 1, p1, particl_1, 2, p2, particl_2, i_generator, iproc_in $parameters ) + call $subroutine_diexcP(key_in, 1, p1, particl_1, 2, p2, particl_2, fock_diag_tmp, i_generator, iproc_in $parameters ) end if end do end do end subroutine -subroutine $subroutine_diexcP(key_in, fs1, fh1, particl_1, fs2, fh2, particl_2, i_generator, iproc_in $parameters ) +subroutine $subroutine_diexcP(key_in, fs1, fh1, particl_1, fs2, fh2, particl_2, fock_diag_tmp, i_generator, iproc_in $parameters ) integer(bit_kind), intent(in) :: key_in(N_int, 2), particl_1(N_int, 2), particl_2(N_int, 2) + double precision, intent(in) :: fock_diag_tmp(2,mo_tot_num+1) integer(bit_kind) :: p1_mask(N_int, 2), p2_mask(N_int, 2), key_mask(N_int, 2) integer,intent(in) :: fh1,fh2,fs1,fs2,i_generator,iproc_in integer(bit_kind) :: miniList(N_int, 2, N_det) @@ -112,11 +116,11 @@ subroutine $subroutine_diexcP(key_in, fs1, fh1, particl_1, fs2, fh2, particl_2, key_mask(ishft(fh1,-bit_kind_shift) + 1, fs1) -= ishft(1,iand(fh1-1,bit_kind_size-1)) key_mask(ishft(fh2,-bit_kind_shift) + 1, fs2) -= ishft(1,iand(fh2-1,bit_kind_size-1)) - call $subroutine_diexcOrg(key_in, key_mask, p1_mask, particl_1, p2_mask, particl_2, i_generator, iproc_in $parameters ) + call $subroutine_diexcOrg(key_in, key_mask, p1_mask, particl_1, p2_mask, particl_2, fock_diag_tmp, i_generator, iproc_in $parameters ) end subroutine -subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl_2, i_generator, iproc_in $parameters ) +subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl_2, fock_diag_tmp, i_generator, iproc_in $parameters ) use omp_lib use bitmasks implicit none @@ -133,6 +137,7 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl integer(bit_kind), intent(in) :: hole_1(N_int,2), particl_1(N_int,2) integer(bit_kind), intent(in) :: hole_2(N_int,2), particl_2(N_int,2) integer, intent(in) :: iproc_in + double precision, intent(in) :: fock_diag_tmp(2,mo_tot_num+1) integer(bit_kind), allocatable :: hole_save(:,:) integer(bit_kind), allocatable :: key(:,:),hole(:,:), particle(:,:) integer(bit_kind), allocatable :: hole_tmp(:,:), particle_tmp(:,:) @@ -172,6 +177,7 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl particle_tmp(N_int,2), occ_particle(N_int*bit_kind_size,2), & occ_hole(N_int*bit_kind_size,2), occ_particle_tmp(N_int*bit_kind_size,2),& occ_hole_tmp(N_int*bit_kind_size,2),key_union_hole_part(N_int)) + $init_thread @@ -183,10 +189,8 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl particle(j,1) = iand(xor(particl_1(j,1),key_in(j,1)),particl_1(j,1)) particle(j,2) = iand(xor(particl_1(j,2),key_in(j,2)),particl_1(j,2)) enddo - call bitstring_to_list(particle(1,1),occ_particle(1,1),N_elec_in_key_part_1(1),N_int) - call bitstring_to_list(particle(1,2),occ_particle(1,2),N_elec_in_key_part_1(2),N_int) - call bitstring_to_list(hole(1,1),occ_hole(1,1),N_elec_in_key_hole_1(1),N_int) - call bitstring_to_list(hole(1,2),occ_hole(1,2),N_elec_in_key_hole_1(2),N_int) + call bitstring_to_list_ab(particle,occ_particle,N_elec_in_key_part_1,N_int) + call bitstring_to_list_ab(hole,occ_hole,N_elec_in_key_hole_1,N_int) allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2), & ib_jb_pairs(2,0:(elec_alpha_num)*mo_tot_num)) @@ -249,10 +253,8 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl particle_tmp(j,2) = iand(xor(particl_2(j,2),hole(j,2)),particl_2(j,2)) enddo - call bitstring_to_list(particle_tmp(1,1),occ_particle_tmp(1,1),N_elec_in_key_part_2(1),N_int) - call bitstring_to_list(particle_tmp(1,2),occ_particle_tmp(1,2),N_elec_in_key_part_2(2),N_int) - call bitstring_to_list(hole_tmp (1,1),occ_hole_tmp (1,1),N_elec_in_key_hole_2(1),N_int) - call bitstring_to_list(hole_tmp (1,2),occ_hole_tmp (1,2),N_elec_in_key_hole_2(2),N_int) + call bitstring_to_list_ab(particle_tmp,occ_particle_tmp,N_elec_in_key_part_2,N_int) + call bitstring_to_list_ab(hole_tmp,occ_hole_tmp,N_elec_in_key_hole_2,N_int) ! hole = a^(+)_j_a(ispin) a_i_a(ispin)|key_in> : mono exc :: orb(i_a,ispin) --> orb(j_a,ispin) hole_save = hole @@ -363,17 +365,17 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl enddo ! ispin $keys_work $deinit_thread - deallocate (ia_ja_pairs, ib_jb_pairs, & - keys_out, hole_save, & - key,hole, particle, hole_tmp,& - particle_tmp, occ_particle, & - occ_hole, occ_particle_tmp,& + deallocate (ia_ja_pairs, ib_jb_pairs, & + keys_out, hole_save, & + key,hole, particle, hole_tmp, & + particle_tmp, occ_particle, & + occ_hole, occ_particle_tmp, & occ_hole_tmp,array_pairs,key_union_hole_part) $omp_end_parallel $finalization end -subroutine $subroutine_monoexc(key_in, hole_1,particl_1,i_generator,iproc_in $parameters ) +subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generator,iproc_in $parameters ) use omp_lib use bitmasks implicit none @@ -388,6 +390,7 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,i_generator,iproc_in $pa integer(bit_kind),intent(in) :: key_in(N_int,2) integer(bit_kind),intent(in) :: hole_1(N_int,2), particl_1(N_int,2) integer, intent(in) :: iproc_in + double precision, intent(in) :: fock_diag_tmp(2,mo_tot_num+1) integer(bit_kind),allocatable :: keys_out(:,:,:) integer(bit_kind),allocatable :: hole_save(:,:) integer(bit_kind),allocatable :: key(:,:),hole(:,:), particle(:,:) @@ -444,10 +447,8 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,i_generator,iproc_in $pa particle(j,2) = iand(xor(particl_1(j,2),key_in(j,2)),particl_1(j,2)) enddo - call bitstring_to_list(particle(1,1),occ_particle(1,1),N_elec_in_key_part_1(1),N_int) - call bitstring_to_list(particle(1,2),occ_particle(1,2),N_elec_in_key_part_1(2),N_int) - call bitstring_to_list(hole (1,1),occ_hole (1,1),N_elec_in_key_hole_1(1),N_int) - call bitstring_to_list(hole (1,2),occ_hole (1,2),N_elec_in_key_hole_1(2),N_int) + call bitstring_to_list_ab(particle,occ_particle,N_elec_in_key_part_1,N_int) + call bitstring_to_list_ab(hole,occ_hole,N_elec_in_key_hole_1,N_int) allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2)) do ispin=1,2 @@ -529,6 +530,7 @@ subroutine $subroutine($params_main) integer(bit_kind), allocatable :: mask(:,:,:) integer :: ispin, k integer :: iproc + double precision, allocatable :: fock_diag_tmp(:,:) $initialization PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators @@ -542,7 +544,7 @@ subroutine $subroutine($params_main) call wall_time(wall_0) iproc = 0 - allocate( mask(N_int,2,6) ) + allocate( mask(N_int,2,6), fock_diag_tmp(2,mo_tot_num+1) ) do i_generator=1,nmax progress_bar(1) = i_generator @@ -552,6 +554,9 @@ subroutine $subroutine($params_main) endif $skip + ! Compute diagonal of the Fock matrix + call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) + ! Create bit masks for holes and particles do ispin=1,2 do k=1,N_int @@ -580,12 +585,12 @@ subroutine $subroutine($params_main) psi_det_generators(1,1,1), & mask(1,1,d_hole1), mask(1,1,d_part1), & mask(1,1,d_hole2), mask(1,1,d_part2), & - i_generator, iproc $params_post) + fock_diag_tmp, i_generator, iproc $params_post) endif if($do_mono_excitations)then call $subroutine_monoexc(psi_det_generators(1,1,i_generator), & mask(1,1,s_hole ), mask(1,1,s_part ), & - i_generator, iproc $params_post) + fock_diag_tmp, i_generator, iproc $params_post) endif call wall_time(wall_1) $printout_always @@ -595,13 +600,13 @@ subroutine $subroutine($params_main) endif enddo - deallocate( mask ) + deallocate( mask, fock_diag_tmp ) !$OMP PARALLEL DEFAULT(SHARED) & - !$OMP PRIVATE(i_generator,wall_1,wall_0,ispin,k,mask,iproc) + !$OMP PRIVATE(i_generator,wall_1,wall_0,ispin,k,mask,iproc,fock_diag_tmp) call wall_time(wall_0) !$ iproc = omp_get_thread_num() - allocate( mask(N_int,2,6) ) + allocate( mask(N_int,2,6), fock_diag_tmp(2,mo_tot_num+1) ) !$OMP DO SCHEDULE(dynamic,1) do i_generator=nmax+1,N_det_generators if (iproc == 0) then @@ -612,6 +617,9 @@ subroutine $subroutine($params_main) endif $skip + ! Compute diagonal of the Fock matrix + call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) + ! Create bit masks for holes and particles do ispin=1,2 do k=1,N_int @@ -641,12 +649,12 @@ subroutine $subroutine($params_main) psi_det_generators(1,1,1), & mask(1,1,d_hole1), mask(1,1,d_part1), & mask(1,1,d_hole2), mask(1,1,d_part2), & - i_generator, iproc $params_post) + fock_diag_tmp, i_generator, iproc $params_post) endif if($do_mono_excitations)then call $subroutine_monoexc(psi_det_generators(1,1,i_generator), & mask(1,1,s_hole ), mask(1,1,s_part ), & - i_generator, iproc $params_post) + fock_diag_tmp, i_generator, iproc $params_post) endif !$ call omp_set_lock(lck) call wall_time(wall_1) @@ -658,7 +666,7 @@ subroutine $subroutine($params_main) !$ call omp_unset_lock(lck) enddo !$OMP END DO - deallocate( mask ) + deallocate( mask, fock_diag_tmp ) !$OMP END PARALLEL !$ call omp_destroy_lock(lck) diff --git a/src/Determinants/README.rst b/src/Determinants/README.rst index d12d8426..19eec306 100644 --- a/src/Determinants/README.rst +++ b/src/Determinants/README.rst @@ -1,42 +1,3 @@ -=========== -Dets Module -=========== - -This module contains the determinants of the CI wave function. - -H is applied on the list of generator determinants. Selected determinants -are added into the *H_apply buffer*. Then the new wave function is -constructred as the concatenation of the odl wave function and -some determinants of the H_apply buffer. Generator determinants are built -as a subset of the determinants of the wave function. - - -Assumptions -=========== - -.. Do not edit this section. It was auto-generated from the -.. NEEDED_MODULES_CHILDREN file by the `update_README.py` script. - -* The MOs are orthonormal -* All the determinants have the same number of electrons -* The determinants are orthonormal -* The number of generator determinants <= the number of determinants -* All the determinants in the H_apply buffer are supposed to be different from the - wave function determinants -* All the determinants in the H_apply buffer are supposed to be unique - - -Needed Modules -============== - -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. - -.. image:: tree_dependency.png - -* `Integrals_Monoelec `_ -* `Integrals_Bielec `_ - Needed Modules ============== .. Do not edit this section It was auto-generated @@ -54,19 +15,19 @@ Documentation .. by the `update_README.py` script. -`a_operator `_ +`a_operator `_ Needed for diag_H_mat_elem -`abs_psi_coef_max `_ +`abs_psi_coef_max `_ Max and min values of the coefficients -`abs_psi_coef_min `_ +`abs_psi_coef_min `_ Max and min values of the coefficients -`ac_operator `_ +`ac_operator `_ Needed for diag_H_mat_elem @@ -78,6 +39,21 @@ Documentation Energy of the reference bitmask used in Slater rules +`bitstring_to_list_ab `_ + Gives the inidices(+1) of the bits set to 1 in the bit string + For alpha/beta determinants + + +`bitstring_to_list_ab_old `_ + Gives the inidices(+1) of the bits set to 1 in the bit string + For alpha/beta determinants + + +`build_fock_tmp `_ + Build the diagonal of the Fock matrix corresponding to a generator + determinant. F_00 is = E0. + + `ci_eigenvectors `_ Eigenvectors/values of the CI matrix @@ -139,29 +115,37 @@ Documentation Initial guess vectors are not necessarily orthonormal -`connected_to_ref `_ +`connected_to_ref `_ Undocumented -`connected_to_ref_by_mono `_ +`connected_to_ref_by_mono `_ Undocumented -`copy_h_apply_buffer_to_wf `_ +`copy_h_apply_buffer_to_wf `_ Copies the H_apply buffer to psi_coef. After calling this subroutine, N_det, psi_det and psi_coef need to be touched -`create_wf_of_psi_bilinear_matrix `_ +`create_minilist `_ + Undocumented + + +`create_minilist_find_previous `_ + Undocumented + + +`create_wf_of_psi_bilinear_matrix `_ Generate a wave function containing all possible products of alpha and beta determinants -`davidson_converged `_ +`davidson_converged `_ True if the Davidson algorithm is converged -`davidson_criterion `_ +`davidson_criterion `_ Can be : [ energy | residual | both | wall_time | cpu_time | iterations ] @@ -184,7 +168,7 @@ Documentation Initial guess vectors are not necessarily orthonormal -`davidson_diag_hjj `_ +`davidson_diag_hjj `_ Davidson diagonalization with specific diagonal elements of the H matrix .br H_jj : specific diagonal H matrix elements to diagonalize de Davidson @@ -213,10 +197,6 @@ Documentation Max number of Davidson sizes -`davidson_threshold `_ - Can be : [ energy | residual | both | wall_time | cpu_time | iterations ] - - `decode_exc `_ Decodes the exc arrays returned by get_excitation. h1,h2 : Holes @@ -225,23 +205,27 @@ Documentation degree : Degree of excitation +`det_alpha_norm `_ + Norm of the alpha and beta spin determinants in the wave function: + .br + ||Da||_i \sum_j C_{ij}**2 + + +`det_beta_norm `_ + Norm of the alpha and beta spin determinants in the wave function: + .br + ||Da||_i \sum_j C_{ij}**2 + + `det_coef `_ det_coef -`det_connections `_ - Build connection proxy between determinants - - `det_inf `_ Undocumented -`det_num `_ - det_num - - -`det_occ `_ +`det_occ `_ det_occ @@ -257,10 +241,15 @@ Documentation Diagonalization algorithm (Davidson or Lapack) -`diag_h_mat_elem `_ +`diag_h_mat_elem `_ Computes +`diag_h_mat_elem_fock `_ + Computes when i is at most a double excitation from + a reference. + + `diagonalize_ci `_ Replace the coefficients of the CI states by the coefficients of the eigenstates of the CI matrix @@ -297,11 +286,11 @@ Documentation Expected value of S2 : S*(S+1) -`fill_h_apply_buffer_no_selection `_ +`fill_h_apply_buffer_no_selection `_ Fill the H_apply buffer with determiants for CISD -`filter_3_highest_electrons `_ +`filter_3_highest_electrons `_ Returns a determinant with only the 3 highest electrons @@ -317,37 +306,7 @@ Documentation idx(0) is the number of determinants that interact with key1 -`filter_connected_davidson `_ - Filters out the determinants that are not connected by H - returns the array idx which contains the index of the - determinants in the array key1 that interact - via the H operator with key2. - .br - idx(0) is the number of determinants that interact with key1 - key1 should come from psi_det_sorted_ab. - - -`filter_connected_davidson_shortcut `_ - Filters out the determinants that are not connected by H - returns the array idx which contains the index of the - determinants in the array key1 that interact - via the H operator with key2. - .br - idx(0) is the number of determinants that interact with key1 - key1 should come from psi_det_sorted_ab. - - -`filter_connected_davidson_warp `_ - Filters out the determinants that are not connected by H - returns the array idx which contains the index of the - determinants in the array key1 that interact - via the H operator with key2. - .br - idx(0) is the number of determinants that interact with key1 - key1 should come from psi_det_sorted_ab. - - -`filter_connected_i_h_psi0 `_ +`filter_connected_i_h_psi0 `_ returns the array idx which contains the index of the .br determinants in the array key1 that interact @@ -357,7 +316,7 @@ Documentation idx(0) is the number of determinants that interact with key1 -`filter_connected_i_h_psi0_sc2 `_ +`filter_connected_i_h_psi0_sc2 `_ standard filter_connected_i_H_psi but returns in addition .br the array of the index of the non connected determinants to key1 @@ -369,17 +328,11 @@ Documentation to repeat the excitations -`filter_connected_sorted_ab `_ - Filters out the determinants that are not connected by H - returns the array idx which contains the index of the - determinants in the array key1 that interact - via the H operator with key2. - idx(0) is the number of determinants that interact with key1 - .br - Determinants are taken from the psi_det_sorted_ab array +`first_guess `_ + Select all the determinants with the lowest energy as a starting point. -`generate_all_alpha_beta_det_products `_ +`generate_all_alpha_beta_det_products `_ Create a wave function from all possible alpha x beta determinants @@ -395,7 +348,7 @@ Documentation Returns the excitation degree between two determinants -`get_excitation_degree_vector `_ +`get_excitation_degree_vector `_ Applies get_excitation_degree to an array of determinants @@ -415,7 +368,7 @@ Documentation Returns the excitation operator between two singly excited determinants and the phase -`get_occ_from_key `_ +`get_occ_from_key `_ Returns a list of occupation numbers from a bitstring @@ -449,7 +402,7 @@ Documentation Undocumented -`h_u_0 `_ +`h_u_0 `_ Computes v_0 = H|u_0> .br n : number of determinants @@ -457,31 +410,35 @@ Documentation H_jj : array of -`h_u_0_org `_ - Computes v_0 = H|u_0> +`i_h_j `_ + Returns where i and j are determinants + + +`i_h_j_phase_out `_ + Returns where i and j are determinants + + +`i_h_j_verbose `_ + Returns where i and j are determinants + + +`i_h_psi `_ + Computes = \sum_J c_J . .br - n : number of determinants + Uses filter_connected_i_H_psi0 to get all the |J> to which |i> + is connected. + The i_H_psi_minilist is much faster but requires to build the + minilists + + +`i_h_psi_minilist `_ + Computes = \sum_J c_J . .br - H_jj : array of + Uses filter_connected_i_H_psi0 to get all the |J> to which |i> + is connected. The |J> are searched in short pre-computed lists. -`i_h_j `_ - Returns where i and j are determinants - - -`i_h_j_phase_out `_ - Returns where i and j are determinants - - -`i_h_j_verbose `_ - Returns where i and j are determinants - - -`i_h_psi `_ - for the various Nstates - - -`i_h_psi_sc2 `_ +`i_h_psi_sc2 `_ for the various Nstate .br returns in addition @@ -495,7 +452,7 @@ Documentation to repeat the excitations -`i_h_psi_sc2_verbose `_ +`i_h_psi_sc2_verbose `_ for the various Nstate .br returns in addition @@ -509,7 +466,7 @@ Documentation to repeat the excitations -`i_h_psi_sec_ord `_ +`i_h_psi_sec_ord `_ for the various Nstates @@ -524,7 +481,7 @@ Documentation idx_non_cas gives the indice of the determinant in psi_det. -`int_of_3_highest_electrons `_ +`int_of_3_highest_electrons `_ Returns an integer*8 as : .br |_<--- 21 bits ---><--- 21 bits ---><--- 21 bits --->| @@ -536,6 +493,10 @@ Documentation .br +`is_connected_to `_ + Undocumented + + `is_in_wavefunction `_ True if the determinant ``det`` is in the wave function @@ -548,7 +509,7 @@ Documentation Undocumented -`max_degree_exc `_ +`max_degree_exc `_ Maximum degree of excitation in the wf @@ -556,10 +517,6 @@ Documentation Energy of the reference bitmask used in Slater rules -`n_con_int `_ - Number of integers to represent the connections between determinants - - `n_det `_ Number of determinants in the wave function @@ -585,7 +542,7 @@ Documentation Maximum number of determinants diagonalized by Jacobi -`n_det_max_property `_ +`n_det_max_property `_ Max number of determinants in the wave function when you select for a given property @@ -633,7 +590,7 @@ Documentation Number of possible determinants for a given occ_pattern -`one_body_dm_mo `_ +`one_body_dm_mo `_ One-body density matrix @@ -645,15 +602,15 @@ Documentation Alpha and beta one-body density matrix for each state -`one_body_single_double_dm_mo_alpha `_ +`one_body_single_double_dm_mo_alpha `_ Alpha and beta one-body density matrix for each state -`one_body_single_double_dm_mo_beta `_ +`one_body_single_double_dm_mo_beta `_ Alpha and beta one-body density matrix for each state -`one_body_spin_density_mo `_ +`one_body_spin_density_mo `_ rho(alpha) - rho(beta) @@ -661,34 +618,30 @@ Documentation If true, The One body DM is calculated with ignoring the Double<->Doubles extra diag elements -`pouet `_ - Undocumented - - -`psi_average_norm_contrib `_ +`psi_average_norm_contrib `_ Contribution of determinants to the state-averaged density -`psi_average_norm_contrib_sorted `_ +`psi_average_norm_contrib_sorted `_ Wave function sorted by determinants contribution to the norm (state-averaged) -`psi_bilinear_matrix `_ +`psi_bilinear_matrix `_ Coefficient matrix if the wave function is expressed in a bilinear form : D_a^t C D_b -`psi_bilinear_matrix_columns `_ +`psi_bilinear_matrix_columns `_ Sparse coefficient matrix if the wave function is expressed in a bilinear form : D_a^t C D_b -`psi_bilinear_matrix_rows `_ +`psi_bilinear_matrix_rows `_ Sparse coefficient matrix if the wave function is expressed in a bilinear form : D_a^t C D_b -`psi_bilinear_matrix_values `_ +`psi_bilinear_matrix_values `_ Sparse coefficient matrix if the wave function is expressed in a bilinear form : D_a^t C D_b @@ -721,7 +674,7 @@ Documentation function. -`psi_coef `_ +`psi_coef `_ The wave function coefficients. Initialized with Hartree-Fock if the EZFIO file is empty @@ -730,33 +683,33 @@ Documentation Undocumented -`psi_coef_max `_ +`psi_coef_max `_ Max and min values of the coefficients -`psi_coef_min `_ +`psi_coef_min `_ Max and min values of the coefficients -`psi_coef_sorted `_ +`psi_coef_sorted `_ Wave function sorted by determinants contribution to the norm (state-averaged) -`psi_coef_sorted_ab `_ +`psi_coef_sorted_ab `_ Determinants on which we apply . They are sorted by the 3 highest electrons in the alpha part, then by the 3 highest electrons in the beta part to accelerate the research of connected determinants. -`psi_coef_sorted_bit `_ +`psi_coef_sorted_bit `_ Determinants on which we apply for perturbation. They are sorted by determinants interpreted as integers. Useful to accelerate the search of a random determinant in the wave function. -`psi_det `_ +`psi_det `_ The wave function determinants. Initialized with Hartree-Fock if the EZFIO file is empty @@ -777,29 +730,29 @@ Documentation Unique beta determinants -`psi_det_size `_ +`psi_det_size `_ Size of the psi_det/psi_coef arrays -`psi_det_sorted `_ +`psi_det_sorted `_ Wave function sorted by determinants contribution to the norm (state-averaged) -`psi_det_sorted_ab `_ +`psi_det_sorted_ab `_ Determinants on which we apply . They are sorted by the 3 highest electrons in the alpha part, then by the 3 highest electrons in the beta part to accelerate the research of connected determinants. -`psi_det_sorted_bit `_ +`psi_det_sorted_bit `_ Determinants on which we apply for perturbation. They are sorted by determinants interpreted as integers. Useful to accelerate the search of a random determinant in the wave function. -`psi_det_sorted_next_ab `_ +`psi_det_sorted_next_ab `_ Determinants on which we apply . They are sorted by the 3 highest electrons in the alpha part, then by the 3 highest electrons in the beta part to accelerate @@ -838,11 +791,11 @@ Documentation Undocumented -`read_dets `_ +`read_dets `_ Reads the determinants from the EZFIO file -`read_wf `_ +`read_wf `_ If true, read the wave function from the EZFIO file @@ -854,20 +807,16 @@ Documentation Energy of the reference bitmask used in Slater rules -`remove_duplicates_in_psi_det `_ +`remove_duplicates_in_psi_det `_ Removes duplicate determinants in the wave function. -`resize_h_apply_buffer `_ +`resize_h_apply_buffer `_ Resizes the H_apply buffer of proc iproc. The buffer lock should be set before calling this function. -`routine `_ - Undocumented - - -`s2_eig `_ +`s2_eig `_ Force the wave function to be an eigenfunction of S^2 @@ -887,31 +836,31 @@ Documentation Undocumented -`save_natural_mos `_ +`save_natural_mos `_ Save natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis -`save_wavefunction `_ +`save_wavefunction `_ Save the wave function into the EZFIO file -`save_wavefunction_general `_ +`save_wavefunction_general `_ Save the wave function into the EZFIO file -`save_wavefunction_specified `_ +`save_wavefunction_specified `_ Save the wave function into the EZFIO file -`save_wavefunction_unsorted `_ +`save_wavefunction_unsorted `_ Save the wave function into the EZFIO file -`set_bite_to_integer `_ +`set_bit_to_integer `_ Undocumented -`set_natural_mos `_ +`set_natural_mos `_ Set natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis @@ -921,18 +870,26 @@ Documentation for a given couple of hole/particle excitations i. -`sort_dets_ab `_ - Undocumented +`sort_dets_ab `_ + Uncodumented : TODO -`sort_dets_by_3_highest_electrons `_ +`sort_dets_ab_v `_ + Uncodumented : TODO + + +`sort_dets_ba_v `_ + Uncodumented : TODO + + +`sort_dets_by_3_highest_electrons `_ Determinants on which we apply . They are sorted by the 3 highest electrons in the alpha part, then by the 3 highest electrons in the beta part to accelerate the research of connected determinants. -`sort_dets_by_det_search_key `_ +`sort_dets_by_det_search_key `_ Determinants are sorted are sorted according to their det_search_key. Useful to accelerate the search of a random determinant in the wave function. @@ -942,19 +899,27 @@ Documentation Return an integer*8 corresponding to a determinant index for searching -`state_average_weight `_ +`state_average_weight `_ Weights in the state-average calculation of the density matrix `tamiser `_ - Undocumented + Uncodumented : TODO + + +`target_energy `_ + Energy that should be obtained when truncating the wave function (optional) `threshold_convergence_sc2 `_ convergence of the correlation energy of SC2 iterations -`threshold_generators `_ +`threshold_davidson `_ + Thresholds of Davidson's algorithm + + +`threshold_generators `_ Thresholds on generators (fraction of the norm) diff --git a/src/Determinants/connected_to_ref.irp.f b/src/Determinants/connected_to_ref.irp.f index 8f594738..dc7698b5 100644 --- a/src/Determinants/connected_to_ref.irp.f +++ b/src/Determinants/connected_to_ref.irp.f @@ -154,6 +154,41 @@ integer function get_index_in_psi_det_sorted_bit(key,Nint) ! END DEBUG is_in_wf end + +logical function is_connected_to(key,keys,Nint,Ndet) + use bitmasks + implicit none + integer, intent(in) :: Nint, Ndet + integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) + integer(bit_kind), intent(in) :: key(Nint,2) + + integer :: i, l + integer :: degree_x2 + + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + + is_connected_to = .false. + + do i=1,Ndet + degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & + popcnt(xor( key(1,2), keys(1,2,i))) + !DEC$ LOOP COUNT MIN(3) + do l=2,Nint + degree_x2 = degree_x2 + popcnt(xor( key(l,1), keys(l,1,i))) +& + popcnt(xor( key(l,2), keys(l,2,i))) + enddo + if (degree_x2 > 4) then + cycle + else + is_connected_to = .true. + return + endif + enddo +end + + integer function connected_to_ref(key,keys,Nint,N_past_in,Ndet) use bitmasks implicit none diff --git a/src/Determinants/create_excitations.irp.f b/src/Determinants/create_excitations.irp.f index a2acc8df..b7233beb 100644 --- a/src/Determinants/create_excitations.irp.f +++ b/src/Determinants/create_excitations.irp.f @@ -35,7 +35,7 @@ subroutine do_mono_excitation(key_in,i_hole,i_particle,ispin,i_ok) endif end -subroutine set_bite_to_integer(i_physical,key,Nint) +subroutine set_bit_to_integer(i_physical,key,Nint) use bitmasks implicit none integer, intent(in) :: i_physical,Nint diff --git a/src/Determinants/davidson.irp.f b/src/Determinants/davidson.irp.f index 626ecec3..3432ab2e 100644 --- a/src/Determinants/davidson.irp.f +++ b/src/Determinants/davidson.irp.f @@ -90,34 +90,144 @@ end function subroutine tamiser(key, idx, no, n, Nint, N_key) use bitmasks - implicit none - integer(bit_kind),intent(inout) :: key(Nint, 2, N_key) + + BEGIN_DOC +! Uncodumented : TODO + END_DOC integer,intent(in) :: no, n, Nint, N_key + integer(bit_kind),intent(inout) :: key(Nint, 2, N_key) integer,intent(inout) :: idx(N_key) integer :: k,j,tmpidx integer(bit_kind) :: tmp(Nint, 2) logical :: det_inf + integer :: ni k = no j = 2*k do while(j <= n) - if(j < n .and. det_inf(key(:,:,j), key(:,:,j+1), Nint)) then - j = j+1 - end if - if(det_inf(key(:,:,k), key(:,:,j), Nint)) then - tmp(:,:) = key(:,:,k) - key(:,:,k) = key(:,:,j) - key(:,:,j) = tmp(:,:) + if(j < n) then + if (det_inf(key(1,1,j), key(1,1,j+1), Nint)) then + j = j+1 + endif + endif + if(det_inf(key(1,1,k), key(1,1,j), Nint)) then + do ni=1,Nint + tmp(ni,1) = key(ni,1,k) + tmp(ni,2) = key(ni,2,k) + key(ni,1,k) = key(ni,1,j) + key(ni,2,k) = key(ni,2,j) + key(ni,1,j) = tmp(ni,1) + key(ni,2,j) = tmp(ni,2) + enddo tmpidx = idx(k) idx(k) = idx(j) idx(j) = tmpidx k = j - j = 2*k + j = k+k else return - end if + endif + enddo +end subroutine + + +subroutine sort_dets_ba_v(key_in, key_out, idx, shortcut, version, N_key, Nint) + use bitmasks + implicit none + BEGIN_DOC +! Uncodumented : TODO + END_DOC + integer, intent(in) :: Nint, N_key + integer(bit_kind),intent(in) :: key_in(Nint,2,N_key) + integer(bit_kind),intent(out) :: key_out(Nint,N_key) + integer,intent(out) :: idx(N_key) + integer,intent(out) :: shortcut(0:N_key+1) + integer(bit_kind),intent(out) :: version(Nint,N_key+1) + integer(bit_kind), allocatable :: key(:,:,:) + integer :: i,ni + + allocate ( key(Nint,2,N_key) ) + do i=1,N_key + do ni=1,Nint + key(ni,1,i) = key_in(ni,2,i) + key(ni,2,i) = key_in(ni,1,i) + enddo + enddo + + call sort_dets_ab_v(key, key_out, idx, shortcut, version, N_key, Nint) + deallocate ( key ) +end subroutine + + + +subroutine sort_dets_ab_v(key_in, key_out, idx, shortcut, version, N_key, Nint) + use bitmasks + implicit none + + BEGIN_DOC +! Uncodumented : TODO + END_DOC + integer, intent(in) :: Nint, N_key + integer(bit_kind),intent(in) :: key_in(Nint,2,N_key) + integer(bit_kind),intent(out) :: key_out(Nint,N_key) + integer,intent(out) :: idx(N_key) + integer,intent(out) :: shortcut(0:N_key+1) + integer(bit_kind),intent(out) :: version(Nint,N_key+1) + integer(bit_kind), allocatable :: key(:,:,:) + integer(bit_kind) :: tmp(Nint, 2) + integer :: tmpidx,i,ni + + allocate (key(Nint,2,N_key)) + do i=1,N_key + do ni=1,Nint + key(ni,1,i) = key_in(ni,1,i) + key(ni,2,i) = key_in(ni,2,i) + enddo + idx(i) = i end do + + do i=N_key/2,1,-1 + call tamiser(key, idx, i, N_key, Nint, N_key) + end do + + do i=N_key,2,-1 + do ni=1,Nint + tmp(ni,1) = key(ni,1,i) + tmp(ni,2) = key(ni,2,i) + key(ni,1,i) = key(ni,1,1) + key(ni,2,i) = key(ni,2,1) + key(ni,1,1) = tmp(ni,1) + key(ni,2,1) = tmp(ni,2) + enddo + tmpidx = idx(i) + idx(i) = idx(1) + idx(1) = tmpidx + call tamiser(key, idx, 1, i-1, Nint, N_key) + end do + + shortcut(0) = 1 + shortcut(1) = 1 + do ni=1,Nint + version(ni,1) = key(ni,1,1) + enddo + do i=2,N_key + do ni=1,nint + if(key(ni,1,i) /= key(ni,1,i-1)) then + shortcut(0) = shortcut(0) + 1 + shortcut(shortcut(0)) = i + version(:,shortcut(0)) = key(:,1,i) + exit + end if + end do + end do + shortcut(shortcut(0)+1) = N_key+1 + do i=1,N_key + do ni=1,Nint + key_out(ni,i) = key(ni,2,i) + enddo + enddo + deallocate (key) end subroutine @@ -125,6 +235,10 @@ subroutine sort_dets_ab(key, idx, shortcut, N_key, Nint) use bitmasks implicit none + + BEGIN_DOC +! Uncodumented : TODO + END_DOC integer(bit_kind),intent(inout) :: key(Nint,2,N_key) integer,intent(out) :: idx(N_key) integer,intent(out) :: shortcut(0:N_key+1) @@ -141,9 +255,15 @@ subroutine sort_dets_ab(key, idx, shortcut, N_key, Nint) end do do i=N_key,2,-1 - tmp(:,:) = key(:,:,i) - key(:,:,i) = key(:,:,1) - key(:,:,1) = tmp(:,:) + do ni=1,Nint + tmp(ni,1) = key(ni,1,i) + tmp(ni,2) = key(ni,2,i) + key(ni,1,i) = key(ni,1,1) + key(ni,2,i) = key(ni,2,1) + key(ni,1,1) = tmp(ni,1) + key(ni,2,1) = tmp(ni,2) + enddo + tmpidx = idx(i) idx(i) = idx(1) idx(1) = tmpidx @@ -214,10 +334,7 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iun double precision :: to_print(2,N_st) double precision :: cpu, wall - integer(bit_kind) :: dets_in_sorted(Nint, 2, sze) - integer :: idx(sze), shortcut(0:sze+1) - - PROVIDE det_connections + call write_time(iunit) call wall_time(wall) @@ -263,9 +380,7 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iun ! Initialization ! ============== - dets_in_sorted(:,:,:) = dets_in(:,:,:) - call sort_dets_ab(dets_in_sorted, idx, shortcut, sze, Nint) - + k_pairs=0 do l=1,N_st do k=1,l @@ -275,9 +390,9 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iun enddo enddo - !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PARALLEL DEFAULT(NONE) & !$OMP SHARED(U,sze,N_st,overlap,kl_pairs,k_pairs, & - !$OMP Nint,dets_in_sorted,dets_in,u_in) & + !$OMP Nint,dets_in,u_in) & !$OMP PRIVATE(k,l,kl,i) @@ -324,8 +439,7 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iun ! ---------------------- do k=1,N_st -! call H_u_0_org(W(1,k,iter),U(1,k,iter),H_jj,sze,dets_in,Nint) - call H_u_0(W(1,k,iter),U(1,k,iter),H_jj,sze,dets_in_sorted,shortcut,idx,Nint) + call H_u_0(W(1,k,iter),U(1,k,iter),H_jj,sze,dets_in,Nint) enddo @@ -479,14 +593,12 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iun abort_here = abort_all end - BEGIN_PROVIDER [ character(64), davidson_criterion ] -&BEGIN_PROVIDER [ double precision, davidson_threshold ] +BEGIN_PROVIDER [ character(64), davidson_criterion ] implicit none BEGIN_DOC ! Can be : [ energy | residual | both | wall_time | cpu_time | iterations ] END_DOC davidson_criterion = 'residual' - davidson_threshold = 1.d-10 END_PROVIDER subroutine davidson_converged(energy,residual,wall,iterations,cpu,N_st,converged) @@ -509,20 +621,20 @@ subroutine davidson_converged(energy,residual,wall,iterations,cpu,N_st,converged E = energy - energy_old energy_old = energy if (davidson_criterion == 'energy') then - converged = dabs(maxval(E(1:N_st))) < davidson_threshold + converged = dabs(maxval(E(1:N_st))) < threshold_davidson else if (davidson_criterion == 'residual') then - converged = dabs(maxval(residual(1:N_st))) < davidson_threshold + converged = dabs(maxval(residual(1:N_st))) < threshold_davidson else if (davidson_criterion == 'both') then converged = dabs(maxval(residual(1:N_st))) + dabs(maxval(E(1:N_st)) ) & - < davidson_threshold + < threshold_davidson else if (davidson_criterion == 'wall_time') then call wall_time(time) - converged = time - wall > davidson_threshold + converged = time - wall > threshold_davidson else if (davidson_criterion == 'cpu_time') then call cpu_time(time) - converged = time - cpu > davidson_threshold + converged = time - cpu > threshold_davidson else if (davidson_criterion == 'iterations') then - converged = iterations >= int(davidson_threshold) + converged = iterations >= int(threshold_davidson) endif converged = converged.or.abort_here end diff --git a/src/Determinants/density_matrix.irp.f b/src/Determinants/density_matrix.irp.f index f72b337c..9aeb658e 100644 --- a/src/Determinants/density_matrix.irp.f +++ b/src/Determinants/density_matrix.irp.f @@ -71,7 +71,6 @@ one_body_dm_mo_beta = one_body_dm_mo_beta + tmp_b !$OMP END CRITICAL deallocate(tmp_a,tmp_b) - !$OMP BARRIER !$OMP END PARALLEL endif @@ -157,7 +156,6 @@ END_PROVIDER one_body_single_double_dm_mo_beta = one_body_single_double_dm_mo_beta + tmp_b !$OMP END CRITICAL deallocate(tmp_a,tmp_b) - !$OMP BARRIER !$OMP END PARALLEL END_PROVIDER @@ -187,9 +185,9 @@ subroutine set_natural_mos allocate(tmp(size(one_body_dm_mo,1),size(one_body_dm_mo,2))) ! Negation to have the occupied MOs first after the diagonalization - tmp = -one_body_dm_mo + tmp = one_body_dm_mo label = "Natural" - call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label) + call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label,-1) deallocate(tmp) end diff --git a/src/Determinants/determinants.irp.f b/src/Determinants/determinants.irp.f index d1c36163..5fe18c49 100644 --- a/src/Determinants/determinants.irp.f +++ b/src/Determinants/determinants.irp.f @@ -8,6 +8,7 @@ BEGIN_PROVIDER [ integer, N_det ] logical :: exists character*64 :: label PROVIDE ezfio_filename + PROVIDE nproc if (read_wf) then call ezfio_has_determinants_n_det(exists) if (exists) then diff --git a/src/Determinants/filter_connected.irp.f b/src/Determinants/filter_connected.irp.f index f55643bd..1bf76dc4 100644 --- a/src/Determinants/filter_connected.irp.f +++ b/src/Determinants/filter_connected.irp.f @@ -98,352 +98,6 @@ subroutine filter_connected(key1,key2,Nint,sze,idx) end -subroutine filter_connected_sorted_ab(key1,key2,next,Nint,sze,idx) - use bitmasks - implicit none - BEGIN_DOC - ! Filters out the determinants that are not connected by H - ! returns the array idx which contains the index of the - ! determinants in the array key1 that interact - ! via the H operator with key2. - ! idx(0) is the number of determinants that interact with key1 - ! - ! Determinants are taken from the psi_det_sorted_ab array - END_DOC - integer, intent(in) :: Nint, sze - integer, intent(in) :: next(2,N_det) - integer(bit_kind), intent(in) :: key1(Nint,2,sze) - integer(bit_kind), intent(in) :: key2(Nint,2) - integer, intent(out) :: idx(0:sze) - - integer :: i,j,l - integer :: degree_x2 - integer(bit_kind) :: det3_1(Nint,2), det3_2(Nint,2) - - ASSERT (Nint > 0) - ASSERT (sze >= 0) - - l=1 - - call filter_3_highest_electrons( key2(1,1), det3_2(1,1), Nint) - if (Nint==1) then - - i = 1 - do while ( i<= sze ) - call filter_3_highest_electrons( key1(1,1,i), det3_1(1,1), Nint) - degree_x2 = popcnt( xor( det3_1(1,1), det3_2(1,1))) - if (degree_x2 > 4) then - i = next(1,i) - cycle - else - degree_x2 = popcnt( xor( key1(1,1,i), key2(1,1)) ) - if (degree_x2 <= 4) then - degree_x2 += popcnt( xor( key1(1,2,i), key2(1,2)) ) - if (degree_x2 <= 4) then - idx(l) = i - l += 1 - endif - endif - i += 1 - endif - enddo - - else - - print *, 'Not implemented', irp_here - stop 1 - - endif - idx(0) = l-1 -end - - -subroutine filter_connected_davidson_warp(key1,warp,key2,Nint,sze,idx) - use bitmasks - implicit none - BEGIN_DOC - ! Filters out the determinants that are not connected by H - ! returns the array idx which contains the index of the - ! determinants in the array key1 that interact - ! via the H operator with key2. - ! - ! idx(0) is the number of determinants that interact with key1 - ! key1 should come from psi_det_sorted_ab. - END_DOC - integer, intent(in) :: Nint, sze - integer(bit_kind), intent(in) :: key1(Nint,2,sze) - integer(bit_kind), intent(in) :: key2(Nint,2) - integer, intent(out) :: idx(0:sze) - - integer,intent(in) :: warp(2,0:sze+1) - - integer :: i,j,k,l - integer :: degree_x2 - integer :: i_alpha, i_beta, exc_a, exc_b, endloop, ni - integer(bit_kind) :: tmp1, tmp2 - - ASSERT (Nint > 0) - ASSERT (sze >= 0) - - l=1 - i_alpha = 0 - - - if (Nint /= 1) then - do while(i_alpha < warp(1,0) .and. warp(1,i_alpha+1) <= sze) - i_alpha = i_alpha + 1 - exc_a = 0 - do ni=1,Nint - exc_a += popcnt(xor(key1(ni,1,warp(1,i_alpha)), key2(ni,1))) - end do - endloop = min(warp(2,i_alpha), sze) - if(exc_a == 4) then - beta_loop : do i_beta=warp(1,i_alpha),endloop - do ni=1,Nint - if(key1(ni,2,i_beta) /= key2(ni,2)) then - cycle beta_loop - end if - end do - idx(l) = i_beta - l = l + 1 - end do beta_loop - else - do i_beta=warp(1,i_alpha),endloop - exc_b = 0 - do ni=1,Nint - exc_b += popcnt(xor(key1(ni,2,i_beta), key2(ni,2))) - end do - if(exc_b + exc_a <= 4) then - idx(l) = i_beta - l = l + 1 - end if - end do - end if - end do - else - do while(i_alpha < warp(1,0) .and. warp(1,i_alpha+1) <= sze) - i_alpha = i_alpha + 1 - exc_a = popcnt(xor(key1(1,1,warp(1,i_alpha)), key2(1,1))) - endloop = min(warp(2,i_alpha), sze) - if(exc_a == 4) then - do i_beta=warp(1,i_alpha),endloop - if(key1(1,2,i_beta) == key2(1,2)) then - idx(l) = i_beta - l = l + 1 - exit - end if - end do - else - do i_beta=warp(1,i_alpha),endloop - exc_b = popcnt(xor(key1(1,2,i_beta), key2(1,2))) - if(exc_b + exc_a <= 4) then - idx(l) = i_beta - l = l + 1 - end if - end do - end if - end do - end if - - idx(0) = l-1 -end - - -subroutine filter_connected_davidson_shortcut(key1,shortcut,key2,Nint,sze,idx) - use bitmasks - implicit none - BEGIN_DOC - ! Filters out the determinants that are not connected by H - ! returns the array idx which contains the index of the - ! determinants in the array key1 that interact - ! via the H operator with key2. - ! - ! idx(0) is the number of determinants that interact with key1 - ! key1 should come from psi_det_sorted_ab. - END_DOC - integer, intent(in) :: Nint, sze - integer(bit_kind), intent(in) :: key1(Nint,2,sze) - integer(bit_kind), intent(in) :: key2(Nint,2) - integer, intent(out) :: idx(0:sze) - - integer,intent(in) :: shortcut(0:sze+1) - - integer :: i,j,k,l - integer :: degree_x2 - integer :: i_alpha, i_beta, exc_a, exc_b, endloop - integer(bit_kind) :: tmp1, tmp2 - - ASSERT (Nint > 0) - ASSERT (sze >= 0) - - l=1 - i_alpha = 0 - - if (Nint==1) then - do while(shortcut(i_alpha+1) < sze) - i_alpha = i_alpha + 1 - exc_a = popcnt(xor(key1(1,1,shortcut(i_alpha)), key2(1,1))) - if(exc_a > 4) then - cycle - end if - endloop = min(shortcut(i_alpha+1)-1, sze) - if(exc_a == 4) then - do i_beta = shortcut(i_alpha), endloop - if(key1(1,2,i_beta) == key2(1,2)) then - idx(l) = i_beta - l = l + 1 - exit - end if - end do - else - do i_beta = shortcut(i_alpha), endloop - exc_b = popcnt(xor(key1(1,2,i_beta), key2(1,2))) - if(exc_b + exc_a <= 4) then - idx(l) = i_beta - l = l + 1 - end if - end do - end if - end do - else - print *, "TBD : filter_connected_davidson_shortcut Nint>1" - stop - end if - - idx(0) = l-1 -end - -subroutine filter_connected_davidson(key1,key2,Nint,sze,idx) - use bitmasks - implicit none - BEGIN_DOC - ! Filters out the determinants that are not connected by H - ! returns the array idx which contains the index of the - ! determinants in the array key1 that interact - ! via the H operator with key2. - ! - ! idx(0) is the number of determinants that interact with key1 - ! key1 should come from psi_det_sorted_ab. - END_DOC - integer, intent(in) :: Nint, sze - integer(bit_kind), intent(in) :: key1(Nint,2,sze) - integer(bit_kind), intent(in) :: key2(Nint,2) - integer, intent(out) :: idx(0:sze) - - integer :: i,j,k,l - integer :: degree_x2 - integer :: j_int, j_start - integer*8 :: itmp - - PROVIDE N_con_int det_connections - - ASSERT (Nint > 0) - ASSERT (sze >= 0) - - l=1 - - if (Nint==1) then - - i = idx(0) ! lecture dans un intent(out) ? - do j_int=1,N_con_int - itmp = det_connections(j_int,i) - do while (itmp /= 0_8) - j_start = ishft(j_int-1,11) + ishft(trailz(itmp),5) - do j = j_start+1, min(j_start+32,i-1) - degree_x2 = popcnt(xor( key1(1,1,j), key2(1,1))) + & - popcnt(xor( key1(1,2,j), key2(1,2))) - if (degree_x2 > 4) then - cycle - else - idx(l) = j - l = l+1 - endif - enddo - itmp = iand(itmp-1_8,itmp) - enddo - enddo - - else if (Nint==2) then - - - i = idx(0) - do j_int=1,N_con_int - itmp = det_connections(j_int,i) - do while (itmp /= 0_8) - j_start = ishft(j_int-1,11) + ishft(trailz(itmp),5) - do j = j_start+1, min(j_start+32,i-1) - degree_x2 = popcnt(xor( key1(1,1,j), key2(1,1))) + & - popcnt(xor( key1(2,1,j), key2(2,1))) + & - popcnt(xor( key1(1,2,j), key2(1,2))) + & - popcnt(xor( key1(2,2,j), key2(2,2))) - if (degree_x2 > 4) then - cycle - else - idx(l) = j - l = l+1 - endif - enddo - itmp = iand(itmp-1_8,itmp) - enddo - enddo - - else if (Nint==3) then - - i = idx(0) - !DIR$ LOOP COUNT (1000) - do j_int=1,N_con_int - itmp = det_connections(j_int,i) - do while (itmp /= 0_8) - j_start = ishft(j_int-1,11) + ishft(trailz(itmp),5) - do j = j_start+1, min(j_start+32,i-1) - degree_x2 = popcnt(xor( key1(1,1,j), key2(1,1))) + & - popcnt(xor( key1(1,2,j), key2(1,2))) + & - popcnt(xor( key1(2,1,j), key2(2,1))) + & - popcnt(xor( key1(2,2,j), key2(2,2))) + & - popcnt(xor( key1(3,1,j), key2(3,1))) + & - popcnt(xor( key1(3,2,j), key2(3,2))) - if (degree_x2 > 4) then - cycle - else - idx(l) = j - l = l+1 - endif - enddo - itmp = iand(itmp-1_8,itmp) - enddo - enddo - - else - - i = idx(0) - !DIR$ LOOP COUNT (1000) - do j_int=1,N_con_int - itmp = det_connections(j_int,i) - do while (itmp /= 0_8) - j_start = ishft(j_int-1,11) + ishft(trailz(itmp),5) - do j = j_start+1, min(j_start+32,i-1) - degree_x2 = 0 - !DEC$ LOOP COUNT MIN(4) - do k=1,Nint - degree_x2 = degree_x2+ popcnt(xor( key1(k,1,j), key2(k,1))) +& - popcnt(xor( key1(k,2,j), key2(k,2))) - if (degree_x2 > 4) then - exit - endif - enddo - if (degree_x2 <= 5) then - idx(l) = j - l = l+1 - endif - enddo - itmp = iand(itmp-1_8,itmp) - enddo - enddo - - endif - idx(0) = l-1 -end - subroutine filter_connected_i_H_psi0(key1,key2,Nint,sze,idx) use bitmasks BEGIN_DOC @@ -476,9 +130,7 @@ subroutine filter_connected_i_H_psi0(key1,key2,Nint,sze,idx) do i=1,sze degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & popcnt(xor( key1(1,2,i), key2(1,2))) - if (degree_x2 > 4) then - cycle - else if(degree_x2 .ne. 0)then + if (degree_x2 <= 4) then idx(l) = i l = l+1 endif @@ -492,9 +144,7 @@ subroutine filter_connected_i_H_psi0(key1,key2,Nint,sze,idx) popcnt(xor( key1(2,1,i), key2(2,1))) + & popcnt(xor( key1(1,2,i), key2(1,2))) + & popcnt(xor( key1(2,2,i), key2(2,2))) - if (degree_x2 > 4) then - cycle - else if(degree_x2 .ne. 0)then + if (degree_x2 <= 4) then idx(l) = i l = l+1 endif @@ -510,9 +160,7 @@ subroutine filter_connected_i_H_psi0(key1,key2,Nint,sze,idx) popcnt(xor( key1(2,2,i), key2(2,2))) + & popcnt(xor( key1(3,1,i), key2(3,1))) + & popcnt(xor( key1(3,2,i), key2(3,2))) - if (degree_x2 > 4) then - cycle - else if(degree_x2 .ne. 0)then + if (degree_x2 <= 4) then idx(l) = i l = l+1 endif @@ -520,24 +168,27 @@ subroutine filter_connected_i_H_psi0(key1,key2,Nint,sze,idx) else + + integer, save :: icount(4) = (/0,0,0,0/) !DIR$ LOOP COUNT (1000) - do i=1,sze + outer: do i=1,sze degree_x2 = 0 !DEC$ LOOP COUNT MIN(4) do m=1,Nint - degree_x2 = degree_x2+ popcnt(xor( key1(m,1,i), key2(m,1))) +& - popcnt(xor( key1(m,2,i), key2(m,2))) + if ( key1(m,1,i) /= key2(m,1)) then + degree_x2 = degree_x2+ popcnt(xor( key1(m,1,i), key2(m,1))) + endif + if ( key1(m,2,i) /= key2(m,2)) then + degree_x2 = degree_x2+ popcnt(xor( key1(m,2,i), key2(m,2))) + endif if (degree_x2 > 4) then - exit + cycle outer endif enddo - if (degree_x2 > 4) then - cycle - else if(degree_x2 .ne. 0)then - idx(l) = i - l = l+1 - endif - enddo + idx(l) = i + l = l+1 + icount(3) = icount(3) + 1_8 + enddo outer endif idx(0) = l-1 diff --git a/src/Determinants/guess_lowest_state.irp.f b/src/Determinants/guess_lowest_state.irp.f new file mode 100644 index 00000000..f6d0a004 --- /dev/null +++ b/src/Determinants/guess_lowest_state.irp.f @@ -0,0 +1,162 @@ +program first_guess + use bitmasks + implicit none + BEGIN_DOC + ! Select all the determinants with the lowest energy as a starting point. + END_DOC + integer :: i,j + double precision, allocatable :: orb_energy(:) + double precision :: E + integer, allocatable :: kept(:) + integer :: nelec_kept(2) + character :: occ_char, keep_char + + PROVIDE H_apply_buffer_allocated psi_det + allocate (orb_energy(mo_tot_num), kept(0:mo_tot_num)) + nelec_kept(1:2) = 0 + kept(0) = 0 + + print *, 'Orbital energies' + print *, '================' + print *, '' + do i=1,mo_tot_num + keep_char = ' ' + occ_char = '-' + orb_energy(i) = mo_mono_elec_integral(i,i) + do j=1,elec_beta_num + if (i==j) cycle + orb_energy(i) += mo_bielec_integral_jj_anti(i,j) + enddo + do j=1,elec_alpha_num + orb_energy(i) += mo_bielec_integral_jj(i,j) + enddo + if ( (orb_energy(i) > -.5d0).and.(orb_energy(i) < .1d0) ) then + kept(0) += 1 + keep_char = 'X' + kept( kept(0) ) = i + if (i <= elec_beta_num) then + nelec_kept(2) += 1 + endif + if (i <= elec_alpha_num) then + nelec_kept(1) += 1 + endif + endif + if (i <= elec_alpha_num) then + if (i <= elec_beta_num) then + occ_char = '#' + else + occ_char = '+' + endif + endif + print '(I4, 3X, A, 3X, F10.6, 3X, A)', i, occ_char, orb_energy(i), keep_char + enddo + + + integer, allocatable :: list (:,:) + integer(bit_kind), allocatable :: string(:,:) + allocate ( list(N_int*bit_kind_size,2), string(N_int,2) ) + + string = ref_bitmask + call bitstring_to_list( string(1,1), list(1,1), elec_alpha_num, N_int) + call bitstring_to_list( string(1,2), list(1,2), elec_beta_num , N_int) + + psi_det_alpha_unique(:,1) = string(:,1) + psi_det_beta_unique (:,1) = string(:,2) + N_det_alpha_unique = 1 + N_det_beta_unique = 1 + + integer :: i1,i2,i3,i4,i5,i6,i7,i8,i9 + + psi_det_size = kept(0)**(nelec_kept(1)+nelec_kept(2)) + print *, kept(0), nelec_kept(:) + call write_int(6,psi_det_size,'psi_det_size') + TOUCH psi_det_size + +BEGIN_SHELL [ /usr/bin/python ] + +template_alpha_ext = """ +do %(i2)s = %(i1)s-1,1,-1 + list(elec_alpha_num-%(i)d,1) = kept(%(i2)s) + call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) +""" + +template_alpha = """ +do %(i2)s = %(i1)s-1,1,-1 + list(elec_alpha_num-%(i)d,1) = kept(%(i2)s) + call list_to_bitstring( string(1,1), list(1,1), elec_alpha_num, N_int) + N_det_alpha_unique += 1 + psi_det_alpha_unique(:,N_det_alpha_unique) = string(:,1) +""" + +template_beta_ext = """ +do %(i2)s = %(i1)s-1,1,-1 + list(elec_beta_num-%(i)d,2) = kept(%(i2)s) + call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) +""" +template_beta = """ +do %(i2)s = %(i1)s-1,1,-1 + list(elec_beta_num-%(i)d,2) = kept(%(i2)s) + call list_to_bitstring( string(1,2), list(1,2), elec_beta_num, N_int) + N_det_beta_unique += 1 + psi_det_beta_unique(:,N_det_beta_unique) = string(:,2) +""" + +def write(template_ext,template,imax): + print "case(%d)"%(imax) + def aux(i2,i1,i,j): + if (i==imax-1): + print template%locals() + else: + print template_ext%locals() + i += 1 + j -= 1 + if (i != imax): + i1 = "i%d"%(i) + i2 = "i%d"%(i+1) + aux(i2,i1,i,j) + print "enddo" + + i2 = "i1" + i1 = "kept(0)+1" + i = 0 + aux(i2,i1,i,imax) + +def main(): + print """ + select case (nelec_kept(1)) + case(0) + continue + """ + for imax in range(1,10): + write(template_alpha_ext,template_alpha,imax) + + print """ + end select + + select case (nelec_kept(2)) + case(0) + continue + """ + for imax in range(1,10): + write(template_beta_ext,template_beta,imax) + print "end select" + +main() + +END_SHELL + + TOUCH N_det_alpha_unique N_det_beta_unique psi_det_alpha_unique psi_det_beta_unique + call create_wf_of_psi_bilinear_matrix(.False.) + call diagonalize_ci + j= N_det + do i=1,N_det + if (psi_average_norm_contrib_sorted(i) < 1.d-6) then + j = i-1 + exit + endif +! call debug_det(psi_det_sorted(1,1,i),N_int) + enddo + call save_wavefunction_general(j,N_states,psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted) + + deallocate(orb_energy, kept, list, string) +end diff --git a/src/Determinants/program_initial_determinants.irp.f b/src/Determinants/program_initial_determinants.irp.f deleted file mode 100644 index 6375af22..00000000 --- a/src/Determinants/program_initial_determinants.irp.f +++ /dev/null @@ -1,138 +0,0 @@ -program pouet - implicit none - print*,'HF energy = ',ref_bitmask_energy + nuclear_repulsion - call routine - -end -subroutine routine - use bitmasks - implicit none - integer :: i,j,k,l - double precision :: hij,get_mo_bielec_integral - double precision :: hmono,h_bi_ispin,h_bi_other_spin - integer(bit_kind),allocatable :: key_tmp(:,:) - integer, allocatable :: occ(:,:) - integer :: n_occ_alpha, n_occ_beta - ! First checks - print*,'N_int = ',N_int - print*,'mo_tot_num = ',mo_tot_num - print*,'mo_tot_num / 64+1= ',mo_tot_num/64+1 - ! We print the HF determinant - do i = 1, N_int - print*,'ref_bitmask(i,1) = ',ref_bitmask(i,1) - print*,'ref_bitmask(i,2) = ',ref_bitmask(i,2) - enddo - print*,'' - print*,'Hartree Fock determinant ...' - call debug_det(ref_bitmask,N_int) - allocate(key_tmp(N_int,2)) - ! We initialize key_tmp to the Hartree Fock one - key_tmp = ref_bitmask - integer :: i_hole,i_particle,ispin,i_ok,other_spin - ! We do a mono excitation on the top of the HF determinant - write(*,*)'Enter the (hole, particle) couple for the mono excitation ...' - read(5,*)i_hole,i_particle -!!i_hole = 4 -!!i_particle = 20 - write(*,*)'Enter the ispin variable ...' - write(*,*)'ispin = 1 ==> alpha ' - write(*,*)'ispin = 2 ==> beta ' - read(5,*)ispin - if(ispin == 1)then - other_spin = 2 - else if(ispin == 2)then - other_spin = 1 - else - print*,'PB !! ' - print*,'ispin must be 1 or 2 !' - stop - endif -!!ispin = 1 - call do_mono_excitation(key_tmp,i_hole,i_particle,ispin,i_ok) - ! We check if it the excitation was possible with "i_ok" - if(i_ok == -1)then - print*,'i_ok = ',i_ok - print*,'You can not do this excitation because of Pauli principle ...' - print*,'check your hole particle couple, there must be something wrong ...' - stop - - endif - print*,'New det = ' - call debug_det(key_tmp,N_int) - call i_H_j(key_tmp,ref_bitmask,N_int,hij) - ! We calculate the H matrix element between the new determinant and HF - print*,' = ',hij - print*,'' - print*,'' - print*,'Recalculating it old school style ....' - print*,'' - print*,'' - ! We recalculate this old school style !!! - ! Mono electronic part - hmono = mo_mono_elec_integral(i_hole,i_particle) - print*,'' - print*,'Mono electronic part ' - print*,'' - print*,' = ',hmono - h_bi_ispin = 0.d0 - h_bi_other_spin = 0.d0 - print*,'' - print*,'Getting all the info for the calculation of the bi electronic part ...' - print*,'' - allocate (occ(N_int*bit_kind_size,2)) - ! We get the occupation of the alpha electrons in occ(:,1) - call bitstring_to_list(key_tmp(1,1), occ(1,1), n_occ_alpha, N_int) - print*,'n_occ_alpha = ',n_occ_alpha - print*,'elec_alpha_num = ',elec_alpha_num - ! We get the occupation of the beta electrons in occ(:,2) - call bitstring_to_list(key_tmp(1,2), occ(1,2), n_occ_beta, N_int) - print*,'n_occ_beta = ',n_occ_beta - print*,'elec_beta_num = ',elec_beta_num - ! We print the occupation of the alpha electrons - print*,'Alpha electrons !' - do i = 1, n_occ_alpha - print*,'i = ',i - print*,'occ(i,1) = ',occ(i,1) - enddo - ! We print the occupation of the beta electrons - print*,'Alpha electrons !' - do i = 1, n_occ_beta - print*,'i = ',i - print*,'occ(i,2) = ',occ(i,2) - enddo - integer :: exc(0:2,2,2),degree,h1,p1,h2,p2,s1,s2 - double precision :: phase - - call get_excitation_degree(key_tmp,ref_bitmask,degree,N_int) - print*,'degree = ',degree - call get_mono_excitation(ref_bitmask,key_tmp,exc,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - print*,'h1 = ',h1 - print*,'p1 = ',p1 - print*,'s1 = ',s1 - print*,'phase = ',phase - do i = 1, elec_num_tab(ispin) - integer :: orb_occupied - orb_occupied = occ(i,ispin) - h_bi_ispin += get_mo_bielec_integral(i_hole,orb_occupied,i_particle,orb_occupied,mo_integrals_map) & - -get_mo_bielec_integral(i_hole,i_particle,orb_occupied,orb_occupied,mo_integrals_map) - enddo - print*,'h_bi_ispin = ',h_bi_ispin - - do i = 1, elec_num_tab(other_spin) - orb_occupied = occ(i,other_spin) - h_bi_other_spin += get_mo_bielec_integral(i_hole,orb_occupied,i_particle,orb_occupied,mo_integrals_map) - enddo - print*,'h_bi_other_spin = ',h_bi_other_spin - print*,'h_bi_ispin + h_bi_other_spin = ',h_bi_ispin + h_bi_other_spin - - print*,'Total matrix element = ',phase*(h_bi_ispin + h_bi_other_spin + hmono) -!i = 1 -!j = 1 -!k = 1 -!l = 1 -!hij = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) -!print*,' = ',hij - - -end diff --git a/src/Determinants/s2.irp.f b/src/Determinants/s2.irp.f index 72c1b9aa..6da7b8ec 100644 --- a/src/Determinants/s2.irp.f +++ b/src/Determinants/s2.irp.f @@ -107,42 +107,111 @@ subroutine get_s2_u0_old(psi_keys_tmp,psi_coefs_tmp,n,nmax,s2) end subroutine get_s2_u0(psi_keys_tmp,psi_coefs_tmp,n,nmax,s2) - implicit none - use bitmasks - integer(bit_kind), intent(in) :: psi_keys_tmp(N_int,2,nmax) - integer, intent(in) :: n,nmax - double precision, intent(in) :: psi_coefs_tmp(nmax) - double precision, intent(out) :: s2 - double precision :: s2_tmp - integer :: i,j,l,jj - integer, allocatable :: idx(:) - s2 = 0.d0 - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,j,s2_tmp,idx) & - !$OMP SHARED(n,psi_coefs_tmp,psi_keys_tmp,N_int,davidson_threshold)& - !$OMP REDUCTION(+:s2) - allocate(idx(0:n)) - !$OMP DO SCHEDULE(dynamic) - do i=1,n - idx(0) = i - call filter_connected_davidson(psi_keys_tmp,psi_keys_tmp(1,1,i),N_int,i-1,idx) - do jj=1,idx(0) - j = idx(jj) - if ( dabs(psi_coefs_tmp(j)) + dabs(psi_coefs_tmp(i)) & - > davidson_threshold ) then - call get_s2(psi_keys_tmp(1,1,i),psi_keys_tmp(1,1,j),s2_tmp,N_int) - s2 = s2 + psi_coefs_tmp(i)*psi_coefs_tmp(j)*s2_tmp - endif - enddo - enddo - !$OMP END DO - deallocate(idx) - !$OMP END PARALLEL - s2 = s2+s2 - do i=1,n - call get_s2(psi_keys_tmp(1,1,i),psi_keys_tmp(1,1,i),s2_tmp,N_int) - s2 = s2 + psi_coefs_tmp(i)*psi_coefs_tmp(i)*s2_tmp - enddo - s2 = s2 + S_z2_Sz + implicit none + use bitmasks + integer(bit_kind), intent(in) :: psi_keys_tmp(N_int,2,nmax) + integer, intent(in) :: n,nmax + double precision, intent(in) :: psi_coefs_tmp(nmax) + double precision, intent(out) :: s2 + double precision :: s2_tmp + integer :: i,j,l,jj,ii + integer, allocatable :: idx(:) + + integer, allocatable :: shortcut(:), sort_idx(:) + integer(bit_kind), allocatable :: sorted(:,:), version(:,:) + integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, pass + double precision :: davidson_threshold_bis + + allocate (shortcut(0:n+1), sort_idx(n), sorted(N_int,n), version(N_int,n)) + s2 = 0.d0 + davidson_threshold_bis = threshold_davidson + call sort_dets_ab_v(psi_keys_tmp, sorted, sort_idx, shortcut, version, n, N_int) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,j,s2_tmp,sh, sh2, ni, exa, ext, org_i, org_j, endi, pass)& + !$OMP SHARED(n,psi_coefs_tmp,psi_keys_tmp,N_int,threshold_davidson,shortcut,sorted,sort_idx,version)& + !$OMP REDUCTION(+:s2) + + !$OMP DO SCHEDULE(dynamic) + do sh=1,shortcut(0) + + do sh2=1,sh + exa = 0 + do ni=1,N_int + exa += popcnt(xor(version(ni,sh), version(ni,sh2))) + end do + if(exa > 2) then + cycle + end if + + do i=shortcut(sh),shortcut(sh+1)-1 + if(sh==sh2) then + endi = i-1 + else + endi = shortcut(sh2+1)-1 + end if + + do j=shortcut(sh2),endi + ext = exa + do ni=1,N_int + ext += popcnt(xor(sorted(ni,i), sorted(ni,j))) + end do + if(ext <= 4) then + org_i = sort_idx(i) + org_j = sort_idx(j) + + if ( dabs(psi_coefs_tmp(org_j)) + dabs(psi_coefs_tmp(org_i))& + > threshold_davidson ) then + call get_s2(psi_keys_tmp(1,1,org_i),psi_keys_tmp(1,1,org_j),s2_tmp,N_int) + s2 = s2 + psi_coefs_tmp(org_i)*psi_coefs_tmp(org_j)*s2_tmp + endif + end if + end do + end do + end do + enddo + !$OMP END DO + + !$OMP END PARALLEL + + call sort_dets_ba_v(psi_keys_tmp, sorted, sort_idx, shortcut, version, n, N_int) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,j,s2_tmp,sh, sh2, ni, exa, ext, org_i, org_j, endi, pass)& + !$OMP SHARED(n,psi_coefs_tmp,psi_keys_tmp,N_int,threshold_davidson,shortcut,sorted,sort_idx,version)& + !$OMP REDUCTION(+:s2) + + !$OMP DO SCHEDULE(dynamic) + do sh=1,shortcut(0) + do i=shortcut(sh),shortcut(sh+1)-1 + do j=shortcut(sh),i-1 + ext = 0 + do ni=1,N_int + ext += popcnt(xor(sorted(ni,i), sorted(ni,j))) + end do + if(ext == 4) then + org_i = sort_idx(i) + org_j = sort_idx(j) + + if ( dabs(psi_coefs_tmp(org_j)) + dabs(psi_coefs_tmp(org_i))& + > threshold_davidson ) then + call get_s2(psi_keys_tmp(1,1,org_i),psi_keys_tmp(1,1,org_j),s2_tmp,N_int) + s2 = s2 + psi_coefs_tmp(org_i)*psi_coefs_tmp(org_j)*s2_tmp + endif + end if + end do + end do + enddo + !$OMP END DO + + !$OMP END PARALLEL + s2 = s2+s2 + do i=1,n + call get_s2(psi_keys_tmp(1,1,i),psi_keys_tmp(1,1,i),s2_tmp,N_int) + s2 = s2 + psi_coefs_tmp(i)*psi_coefs_tmp(i)*s2_tmp + enddo + s2 = s2 + S_z2_Sz + deallocate (shortcut, sort_idx, sorted, version) end + diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 72615089..32e84532 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -15,7 +15,7 @@ subroutine get_excitation_degree(key1,key2,degree,Nint) degree = popcnt(xor( key1(1,1), key2(1,1))) + & popcnt(xor( key1(1,2), key2(1,2))) - !DEC$ NOUNROLL + !DIR$ NOUNROLL do l=2,Nint degree = degree+ popcnt(xor( key1(l,1), key2(l,1))) + & popcnt(xor( key1(l,2), key2(l,2))) @@ -349,6 +349,80 @@ subroutine get_mono_excitation(det1,det2,exc,phase,Nint) enddo end +subroutine bitstring_to_list_ab( string, list, n_elements, Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Gives the inidices(+1) of the bits set to 1 in the bit string + ! For alpha/beta determinants + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: string(Nint,2) + integer, intent(out) :: list(Nint*bit_kind_size,2) + integer, intent(out) :: n_elements(2) + + integer :: i, j, ishift + integer(bit_kind) :: l + + n_elements(1) = 0 + n_elements(2) = 0 + ishift = 1 + do i=1,Nint + l = string(i,1) + do while (l /= 0_bit_kind) + j = trailz(l) + n_elements(1) = n_elements(1)+1 + l = ibclr(l,j) + list(n_elements(1),1) = ishift+j + enddo + l = string(i,2) + do while (l /= 0_bit_kind) + j = trailz(l) + n_elements(2) = n_elements(2)+1 + l = ibclr(l,j) + list(n_elements(2),2) = ishift+j + enddo + ishift = ishift + bit_kind_size + enddo + +end + +subroutine bitstring_to_list_ab_old( string, list, n_elements, Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Gives the inidices(+1) of the bits set to 1 in the bit string + ! For alpha/beta determinants + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: string(Nint,2) + integer, intent(out) :: list(Nint*bit_kind_size,2) + integer, intent(out) :: n_elements(2) + + integer :: i, ishift + integer(bit_kind) :: l + + n_elements(1) = 0 + n_elements(2) = 0 + ishift = 2 + do i=1,Nint + l = string(i,1) + do while (l /= 0_bit_kind) + n_elements(1) = n_elements(1)+1 + list(n_elements(1),1) = ishift+popcnt(l-1_bit_kind) - popcnt(l) + l = iand(l,l-1_bit_kind) + enddo + l = string(i,2) + do while (l /= 0_bit_kind) + n_elements(2) = n_elements(2)+1 + list(n_elements(2),2) = ishift+popcnt(l-1_bit_kind) - popcnt(l) + l = iand(l,l-1_bit_kind) + enddo + ishift = ishift + bit_kind_size + enddo + +end + @@ -365,12 +439,12 @@ subroutine i_H_j(key_i,key_j,Nint,hij) integer :: exc(0:2,2,2) integer :: degree - double precision :: get_mo_bielec_integral + double precision :: get_mo_bielec_integral_schwartz 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_alpha, n_occ_beta + integer :: n_occ_ab(2) logical :: has_mipi(Nint*bit_kind_size) double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size) PROVIDE mo_bielec_integrals_in_map mo_integrals_map @@ -383,38 +457,38 @@ subroutine i_H_j(key_i,key_j,Nint,hij) ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) hij = 0.d0 - !DEC$ FORCEINLINE + !DIR$ FORCEINLINE call get_excitation_degree(key_i,key_j,degree,Nint) select case (degree) case (2) call get_double_excitation(key_i,key_j,exc,phase,Nint) if (exc(0,1,1) == 1) then ! Mono alpha, mono beta - hij = phase*get_mo_bielec_integral( & + hij = phase*get_mo_bielec_integral_schwartz( & exc(1,1,1), & exc(1,1,2), & exc(1,2,1), & exc(1,2,2) ,mo_integrals_map) else if (exc(0,1,1) == 2) then ! Double alpha - hij = phase*(get_mo_bielec_integral( & + hij = phase*(get_mo_bielec_integral_schwartz( & exc(1,1,1), & exc(2,1,1), & exc(1,2,1), & exc(2,2,1) ,mo_integrals_map) - & - get_mo_bielec_integral( & + get_mo_bielec_integral_schwartz( & exc(1,1,1), & exc(2,1,1), & exc(2,2,1), & exc(1,2,1) ,mo_integrals_map) ) else if (exc(0,1,2) == 2) then ! Double beta - hij = phase*(get_mo_bielec_integral( & + hij = phase*(get_mo_bielec_integral_schwartz( & exc(1,1,2), & exc(2,1,2), & exc(1,2,2), & exc(2,2,2) ,mo_integrals_map) - & - get_mo_bielec_integral( & + get_mo_bielec_integral_schwartz( & exc(1,1,2), & exc(2,1,2), & exc(2,2,2), & @@ -422,8 +496,8 @@ subroutine i_H_j(key_i,key_j,Nint,hij) endif case (1) call get_mono_excitation(key_i,key_j,exc,phase,Nint) - call bitstring_to_list(key_i(1,1), occ(1,1), n_occ_alpha, Nint) - call bitstring_to_list(key_i(1,2), occ(1,2), n_occ_beta, Nint) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) has_mipi = .False. if (exc(0,1,1) == 1) then ! Mono alpha @@ -432,15 +506,15 @@ subroutine i_H_j(key_i,key_j,Nint,hij) do k = 1, elec_alpha_num i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, elec_beta_num i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo @@ -459,15 +533,15 @@ subroutine i_H_j(key_i,key_j,Nint,hij) do k = 1, elec_beta_num i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, elec_alpha_num i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo @@ -501,12 +575,12 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree) integer,intent(out) :: exc(0:2,2,2) integer,intent(out) :: degree - double precision :: get_mo_bielec_integral + double precision :: get_mo_bielec_integral_schwartz integer :: m,n,p,q integer :: i,j,k integer :: occ(Nint*bit_kind_size,2) double precision :: diag_H_mat_elem - integer :: n_occ_alpha, n_occ_beta + integer :: n_occ_ab(2) logical :: has_mipi(Nint*bit_kind_size) double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size) PROVIDE mo_bielec_integrals_in_map mo_integrals_map @@ -519,38 +593,38 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree) ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) hij = 0.d0 - !DEC$ FORCEINLINE + !DIR$ FORCEINLINE call get_excitation_degree(key_i,key_j,degree,Nint) select case (degree) case (2) call get_double_excitation(key_i,key_j,exc,phase,Nint) if (exc(0,1,1) == 1) then ! Mono alpha, mono beta - hij = phase*get_mo_bielec_integral( & + hij = phase*get_mo_bielec_integral_schwartz( & exc(1,1,1), & exc(1,1,2), & exc(1,2,1), & exc(1,2,2) ,mo_integrals_map) else if (exc(0,1,1) == 2) then ! Double alpha - hij = phase*(get_mo_bielec_integral( & + hij = phase*(get_mo_bielec_integral_schwartz( & exc(1,1,1), & exc(2,1,1), & exc(1,2,1), & exc(2,2,1) ,mo_integrals_map) - & - get_mo_bielec_integral( & + get_mo_bielec_integral_schwartz( & exc(1,1,1), & exc(2,1,1), & exc(2,2,1), & exc(1,2,1) ,mo_integrals_map) ) else if (exc(0,1,2) == 2) then ! Double beta - hij = phase*(get_mo_bielec_integral( & + hij = phase*(get_mo_bielec_integral_schwartz( & exc(1,1,2), & exc(2,1,2), & exc(1,2,2), & exc(2,2,2) ,mo_integrals_map) - & - get_mo_bielec_integral( & + get_mo_bielec_integral_schwartz( & exc(1,1,2), & exc(2,1,2), & exc(2,2,2), & @@ -558,8 +632,8 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree) endif case (1) call get_mono_excitation(key_i,key_j,exc,phase,Nint) - call bitstring_to_list(key_i(1,1), occ(1,1), n_occ_alpha, Nint) - call bitstring_to_list(key_i(1,2), occ(1,2), n_occ_beta, Nint) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) has_mipi = .False. if (exc(0,1,1) == 1) then ! Mono alpha @@ -568,15 +642,15 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree) do k = 1, elec_alpha_num i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, elec_beta_num i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo @@ -595,15 +669,15 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree) do k = 1, elec_beta_num i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, elec_alpha_num i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo @@ -637,12 +711,12 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) integer :: exc(0:2,2,2) integer :: degree - double precision :: get_mo_bielec_integral + double precision :: get_mo_bielec_integral_schwartz 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_alpha, n_occ_beta + integer :: n_occ_ab(2) logical :: has_mipi(Nint*bit_kind_size) double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size) PROVIDE mo_bielec_integrals_in_map mo_integrals_map @@ -657,38 +731,38 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) hij = 0.d0 hmono = 0.d0 hdouble = 0.d0 - !DEC$ FORCEINLINE + !DIR$ FORCEINLINE call get_excitation_degree(key_i,key_j,degree,Nint) select case (degree) case (2) call get_double_excitation(key_i,key_j,exc,phase,Nint) if (exc(0,1,1) == 1) then ! Mono alpha, mono beta - hij = phase*get_mo_bielec_integral( & + hij = phase*get_mo_bielec_integral_schwartz( & exc(1,1,1), & exc(1,1,2), & exc(1,2,1), & exc(1,2,2) ,mo_integrals_map) else if (exc(0,1,1) == 2) then ! Double alpha - hij = phase*(get_mo_bielec_integral( & + hij = phase*(get_mo_bielec_integral_schwartz( & exc(1,1,1), & exc(2,1,1), & exc(1,2,1), & exc(2,2,1) ,mo_integrals_map) - & - get_mo_bielec_integral( & + get_mo_bielec_integral_schwartz( & exc(1,1,1), & exc(2,1,1), & exc(2,2,1), & exc(1,2,1) ,mo_integrals_map) ) else if (exc(0,1,2) == 2) then ! Double beta - hij = phase*(get_mo_bielec_integral( & + hij = phase*(get_mo_bielec_integral_schwartz( & exc(1,1,2), & exc(2,1,2), & exc(1,2,2), & exc(2,2,2) ,mo_integrals_map) - & - get_mo_bielec_integral( & + get_mo_bielec_integral_schwartz( & exc(1,1,2), & exc(2,1,2), & exc(2,2,2), & @@ -696,8 +770,8 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) endif case (1) call get_mono_excitation(key_i,key_j,exc,phase,Nint) - call bitstring_to_list(key_i(1,1), occ(1,1), n_occ_alpha, Nint) - call bitstring_to_list(key_i(1,2), occ(1,2), n_occ_beta, Nint) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) has_mipi = .False. if (exc(0,1,1) == 1) then ! Mono alpha @@ -706,15 +780,15 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) do k = 1, elec_alpha_num i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, elec_beta_num i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo @@ -733,15 +807,15 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) do k = 1, elec_beta_num i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, elec_alpha_num i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo @@ -763,10 +837,117 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) end +subroutine create_minilist(key_mask, fullList, miniList, idx_miniList, N_fullList, N_miniList, Nint) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList) + integer, intent(in) :: N_fullList + integer(bit_kind),intent(out) :: miniList(Nint, 2, N_fullList) + integer,intent(out) :: idx_miniList(N_fullList), N_miniList + integer, intent(in) :: Nint + integer(bit_kind) :: key_mask(Nint, 2) + integer :: ni, i, n_a, n_b, e_a, e_b + + + n_a = 0 + n_b = 0 + do ni=1,nint + n_a = n_a + popcnt(key_mask(ni,1)) + n_b = n_b + popcnt(key_mask(ni,2)) + end do + + if(n_a == 0) then + N_miniList = N_fullList + miniList(:,:,:) = fullList(:,:,:) + do i=1,N_fullList + idx_miniList(i) = i + end do + return + end if + + N_miniList = 0 + + do i=1,N_fullList + e_a = n_a + e_b = n_b + do ni=1,nint + e_a -= popcnt(iand(fullList(ni, 1, i), key_mask(ni, 1))) + e_b -= popcnt(iand(fullList(ni, 2, i), key_mask(ni, 2))) + end do + + if(e_a + e_b <= 2) then + N_miniList = N_miniList + 1 + miniList(:,:,N_miniList) = fullList(:,:,i) + idx_miniList(N_miniList) = i + end if + end do +end subroutine + +subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList) + integer, intent(in) :: N_fullList + integer(bit_kind),intent(out) :: miniList(Nint, 2, N_fullList) + integer(bit_kind) :: subList(Nint, 2, N_fullList) + logical,intent(out) :: fullMatch + integer,intent(out) :: N_miniList + integer, intent(in) :: Nint + integer(bit_kind) :: key_mask(Nint, 2) + integer :: ni, i, k, l, N_subList + + + fullMatch = .false. + l = 0 + N_miniList = 0 + N_subList = 0 + + do ni = 1,Nint + l += popcnt(key_mask(ni,1)) + popcnt(key_mask(ni,2)) + end do + + if(l == 0) then + N_miniList = N_fullList + miniList(:,:,:N_miniList) = fullList(:,:,:N_minilist) + else + do i=N_fullList,1,-1 + k = l + do ni=1,nint + k -= popcnt(iand(key_mask(ni,1), fullList(ni,1,i))) + popcnt(iand(key_mask(ni,2), fullList(ni,2,i))) + end do + if(k == 2) then + N_subList += 1 + subList(:,:,N_subList) = fullList(:,:,i) + else if(k == 1) then + N_minilist += 1 + miniList(:,:,N_minilist) = fullList(:,:,i) + else if(k == 0) then + fullMatch = .true. + return + end if + end do + end if + + if(N_subList > 0) then + miniList(:,:,N_minilist+1:N_minilist+N_subList) = sublist(:,:,:N_subList) + N_minilist = N_minilist + N_subList + end if +end subroutine + subroutine i_H_psi(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array) use bitmasks implicit none + BEGIN_DOC +! Computes = \sum_J c_J . +! +! Uses filter_connected_i_H_psi0 to get all the |J> to which |i> +! is connected. +! The i_H_psi_minilist is much faster but requires to build the +! minilists + END_DOC integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) integer(bit_kind), intent(in) :: key(Nint,2) @@ -778,9 +959,6 @@ subroutine i_H_psi(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array) integer :: exc(0:2,2,2) double precision :: hij integer :: idx(0:Ndet) - BEGIN_DOC - ! for the various Nstates - END_DOC ASSERT (Nint > 0) ASSERT (N_int == Nint) @@ -792,7 +970,7 @@ subroutine i_H_psi(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array) call filter_connected_i_H_psi0(keys,key,Nint,Ndet,idx) do ii=1,idx(0) i = idx(ii) - !DEC$ FORCEINLINE + !DIR$ FORCEINLINE call i_H_j(keys(1,1,i),key,Nint,hij) do j = 1, Nstate i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij @@ -800,6 +978,47 @@ subroutine i_H_psi(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array) enddo 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 + integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate,idx_key(Ndet), N_minilist + integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) + integer(bit_kind), intent(in) :: key(Nint,2) + double precision, intent(in) :: coef(Ndet_max,Nstate) + double precision, intent(out) :: i_H_psi_array(Nstate) + + integer :: i, ii,j, i_in_key, i_in_coef + double precision :: phase + integer :: exc(0:2,2,2) + double precision :: hij + integer :: idx(0:Ndet) + BEGIN_DOC +! Computes = \sum_J c_J . +! +! Uses filter_connected_i_H_psi0 to get all the |J> to which |i> +! is connected. The |J> are searched in short pre-computed lists. + END_DOC + + ASSERT (Nint > 0) + ASSERT (N_int == Nint) + ASSERT (Nstate > 0) + ASSERT (Ndet > 0) + ASSERT (Ndet_max >= Ndet) + i_H_psi_array = 0.d0 + + call filter_connected_i_H_psi0(keys,key,Nint,N_minilist,idx) + do ii=1,idx(0) + i_in_key = idx(ii) + i_in_coef = idx_key(idx(ii)) + !DIR$ FORCEINLINE + call i_H_j(keys(1,1,i_in_key),key,Nint,hij) + do j = 1, Nstate + i_H_psi_array(j) = i_H_psi_array(j) + coef(i_in_coef,j)*hij + enddo + enddo +end + subroutine i_H_psi_sec_ord(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,idx_interaction,interactions) use bitmasks implicit none @@ -830,7 +1049,7 @@ subroutine i_H_psi_sec_ord(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array n_interact = 0 do ii=1,idx(0) i = idx(ii) - !DEC$ FORCEINLINE + !DIR$ FORCEINLINE call i_H_j(keys(1,1,i),key,Nint,hij) if(dabs(hij).ge.1.d-8)then if(i.ne.1)then @@ -885,7 +1104,7 @@ subroutine i_H_psi_SC2(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,idx call filter_connected_i_H_psi0_SC2(keys,key,Nint,Ndet,idx,idx_repeat) do ii=1,idx(0) i = idx(ii) - !DEC$ FORCEINLINE + !DIR$ FORCEINLINE call i_H_j(keys(1,1,i),key,Nint,hij) do j = 1, Nstate i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij @@ -934,7 +1153,7 @@ subroutine i_H_psi_SC2_verbose(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_a do ii=1,idx(0) print*,'--' i = idx(ii) - !DEC$ FORCEINLINE + !DIR$ FORCEINLINE call i_H_j(keys(1,1,i),key,Nint,hij) if (i==1)then print*,'i==1 !!' @@ -1024,7 +1243,7 @@ subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx) !DIR$ LOOP COUNT (1000) do i=1,sze d = 0 - !DEC$ LOOP COUNT MIN(4) + !DIR$ LOOP COUNT MIN(4) do m=1,Nint d = d + popcnt(xor( key1(m,1,i), key2(m,1))) & + popcnt(xor( key1(m,2,i), key2(m,2))) @@ -1045,6 +1264,75 @@ end +double precision function diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Computes when i is at most a double excitation from + ! a reference. + END_DOC + integer,intent(in) :: Nint + integer(bit_kind),intent(in) :: det_ref(Nint,2), det_pert(Nint,2) + double precision, intent(in) :: fock_diag_tmp(2,mo_tot_num+1) + + integer :: degree + double precision :: phase, E0 + integer :: exc(0:2,2,2) + integer :: h1, p1, h2, p2, s1, s2 + + call get_excitation_degree(det_ref,det_pert,degree,Nint) + E0 = fock_diag_tmp(1,mo_tot_num+1) + if (degree == 2) then + call get_double_excitation(det_ref,det_pert,exc,phase,Nint) + call decode_exc(exc,2,h1,p1,h2,p2,s1,s2) + + if ( (s1 == 1).and.(s2 == 1) ) then ! alpha/alpha + diag_H_mat_elem_fock = E0 & + - fock_diag_tmp(1,h1) & + + ( fock_diag_tmp(1,p1) - mo_bielec_integral_jj_anti(h1,p1) ) & + - ( fock_diag_tmp(1,h2) - mo_bielec_integral_jj_anti(h1,h2) & + + mo_bielec_integral_jj_anti(p1,h2) ) & + + ( fock_diag_tmp(1,p2) - mo_bielec_integral_jj_anti(h1,p2) & + + mo_bielec_integral_jj_anti(p1,p2) - mo_bielec_integral_jj_anti(h2,p2) ) + + else if ( (s1 == 2).and.(s2 == 2) ) then ! beta/beta + diag_H_mat_elem_fock = E0 & + - fock_diag_tmp(2,h1) & + + ( fock_diag_tmp(2,p1) - mo_bielec_integral_jj_anti(h1,p1) ) & + - ( fock_diag_tmp(2,h2) - mo_bielec_integral_jj_anti(h1,h2) & + + mo_bielec_integral_jj_anti(p1,h2) ) & + + ( fock_diag_tmp(2,p2) - mo_bielec_integral_jj_anti(h1,p2) & + + mo_bielec_integral_jj_anti(p1,p2) - mo_bielec_integral_jj_anti(h2,p2) ) + + else ! alpha/beta + diag_H_mat_elem_fock = E0 & + - fock_diag_tmp(1,h1) & + + ( fock_diag_tmp(1,p1) - mo_bielec_integral_jj_anti(h1,p1) ) & + - ( fock_diag_tmp(2,h2) - mo_bielec_integral_jj(h1,h2) & + + mo_bielec_integral_jj(p1,h2) ) & + + ( fock_diag_tmp(2,p2) - mo_bielec_integral_jj(h1,p2) & + + mo_bielec_integral_jj(p1,p2) - mo_bielec_integral_jj_anti(h2,p2) ) + + endif + + else if (degree == 1) then + call get_mono_excitation(det_ref,det_pert,exc,phase,Nint) + call decode_exc(exc,1,h1,p1,h2,p2,s1,s2) + if (s1 == 1) then + diag_H_mat_elem_fock = E0 - fock_diag_tmp(1,h1) & + + ( fock_diag_tmp(1,p1) - mo_bielec_integral_jj_anti(h1,p1) ) + else + diag_H_mat_elem_fock = E0 - fock_diag_tmp(2,h1) & + + ( fock_diag_tmp(2,p1) - mo_bielec_integral_jj_anti(h1,p1) ) + endif + + else if (degree == 0) then + diag_H_mat_elem_fock = E0 + else + STOP 'Bug in diag_H_mat_elem_fock' + endif +end + double precision function diag_H_mat_elem(det_in,Nint) implicit none BEGIN_DOC @@ -1068,14 +1356,14 @@ double precision function diag_H_mat_elem(det_in,Nint) nexc(1) = 0 nexc(2) = 0 do i=1,Nint - hole(i,1) = xor(det_in(i,1),ref_bitmask(i,1)) - hole(i,2) = xor(det_in(i,2),ref_bitmask(i,2)) + hole(i,1) = xor(det_in(i,1),ref_bitmask(i,1)) + hole(i,2) = xor(det_in(i,2),ref_bitmask(i,2)) particle(i,1) = iand(hole(i,1),det_in(i,1)) particle(i,2) = iand(hole(i,2),det_in(i,2)) hole(i,1) = iand(hole(i,1),ref_bitmask(i,1)) hole(i,2) = iand(hole(i,2),ref_bitmask(i,2)) - nexc(1) += popcnt(hole(i,1)) - nexc(2) += popcnt(hole(i,2)) + nexc(1) = nexc(1) + popcnt(hole(i,1)) + nexc(2) = nexc(2) + popcnt(hole(i,2)) enddo diag_H_mat_elem = ref_bitmask_energy @@ -1084,15 +1372,15 @@ double precision function diag_H_mat_elem(det_in,Nint) endif !call debug_det(det_in,Nint) - integer :: tmp - call bitstring_to_list(particle(1,1), occ_particle(1,1), tmp, Nint) - ASSERT (tmp == nexc(1)) - call bitstring_to_list(particle(1,2), occ_particle(1,2), tmp, Nint) - ASSERT (tmp == nexc(2)) - call bitstring_to_list(hole(1,1), occ_hole(1,1), tmp, Nint) - ASSERT (tmp == nexc(1)) - call bitstring_to_list(hole(1,2), occ_hole(1,2), tmp, Nint) - ASSERT (tmp == nexc(2)) + integer :: tmp(2) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(particle, occ_particle, tmp, Nint) + ASSERT (tmp(1) == nexc(1)) + ASSERT (tmp(2) == nexc(2)) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(hole, occ_hole, tmp, Nint) + ASSERT (tmp(1) == nexc(1)) + ASSERT (tmp(2) == nexc(2)) det_tmp = ref_bitmask do ispin=1,2 @@ -1121,6 +1409,7 @@ subroutine a_operator(iorb,ispin,key,hjj,Nint,na,nb) integer :: occ(Nint*bit_kind_size,2) integer :: other_spin integer :: k,l,i + integer :: tmp(2) ASSERT (iorb > 0) ASSERT (ispin > 0) @@ -1134,19 +1423,19 @@ subroutine a_operator(iorb,ispin,key,hjj,Nint,na,nb) other_spin = iand(ispin,1)+1 !DIR$ FORCEINLINE - call get_occ_from_key(key,occ,Nint) - na -= 1 + call bitstring_to_list_ab(key, occ, tmp, Nint) + na = na-1 - hjj -= mo_mono_elec_integral(iorb,iorb) + hjj = hjj - mo_mono_elec_integral(iorb,iorb) ! Same spin do i=1,na - hjj -= mo_bielec_integral_jj_anti(occ(i,ispin),iorb) + hjj = hjj - mo_bielec_integral_jj_anti(occ(i,ispin),iorb) enddo ! Opposite spin do i=1,nb - hjj -= mo_bielec_integral_jj(occ(i,other_spin),iorb) + hjj = hjj - mo_bielec_integral_jj(occ(i,other_spin),iorb) enddo end @@ -1172,13 +1461,11 @@ subroutine ac_operator(iorb,ispin,key,hjj,Nint,na,nb) ASSERT (ispin < 3) ASSERT (Nint > 0) - integer :: tmp + integer :: tmp(2) !DIR$ FORCEINLINE - call bitstring_to_list(key(1,1), occ(1,1), tmp, Nint) - ASSERT (tmp == elec_alpha_num) - !DIR$ FORCEINLINE - call bitstring_to_list(key(1,2), occ(1,2), tmp, Nint) - ASSERT (tmp == elec_beta_num) + call bitstring_to_list_ab(key, occ, tmp, Nint) + ASSERT (tmp(1) == elec_alpha_num) + ASSERT (tmp(2) == elec_beta_num) k = ishft(iorb-1,-bit_kind_shift)+1 ASSERT (k > 0) @@ -1186,18 +1473,18 @@ subroutine ac_operator(iorb,ispin,key,hjj,Nint,na,nb) key(k,ispin) = ibset(key(k,ispin),l) other_spin = iand(ispin,1)+1 - hjj += mo_mono_elec_integral(iorb,iorb) + hjj = hjj + mo_mono_elec_integral(iorb,iorb) ! Same spin do i=1,na - hjj += mo_bielec_integral_jj_anti(occ(i,ispin),iorb) + hjj = hjj + mo_bielec_integral_jj_anti(occ(i,ispin),iorb) enddo ! Opposite spin do i=1,nb - hjj += mo_bielec_integral_jj(occ(i,other_spin),iorb) + hjj = hjj + mo_bielec_integral_jj(occ(i,other_spin),iorb) enddo - na += 1 + na = na+1 end subroutine get_occ_from_key(key,occ,Nint) @@ -1209,14 +1496,14 @@ subroutine get_occ_from_key(key,occ,Nint) integer(bit_kind), intent(in) :: key(Nint,2) integer , intent(in) :: Nint integer , intent(out) :: occ(Nint*bit_kind_size,2) - integer :: tmp + integer :: tmp(2) - call bitstring_to_list(key(1,1), occ(1,1), tmp, Nint) - call bitstring_to_list(key(1,2), occ(1,2), tmp, Nint) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key, occ, tmp, Nint) end -subroutine H_u_0(v_0,u_0,H_jj,n,keys_tmp,shortcut,sort_idx,Nint) +subroutine H_u_0(v_0,u_0,H_jj,n,keys_tmp,Nint) use bitmasks implicit none BEGIN_DOC @@ -1234,308 +1521,126 @@ subroutine H_u_0(v_0,u_0,H_jj,n,keys_tmp,shortcut,sort_idx,Nint) integer, allocatable :: idx(:) double precision :: hij double precision, allocatable :: vt(:) - integer :: i,j,k,l, jj,ii,sh + integer :: i,j,k,l, jj,ii integer :: i0, j0 - integer,intent(in) :: shortcut(0:n+1), sort_idx(n) - integer :: tmp, warp(2,0:n+1), ni + integer, allocatable :: shortcut(:), sort_idx(:) + integer(bit_kind), allocatable :: sorted(:,:), version(:,:) + integer(bit_kind) :: sorted_i(Nint) + + integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi + double precision :: local_threshold ASSERT (Nint > 0) ASSERT (Nint == N_int) ASSERT (n>0) - PROVIDE ref_bitmask_energy - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,hij,j,k,idx,jj,vt,ii,warp,tmp,sh) & - !$OMP SHARED(n,H_jj,u_0,keys_tmp,Nint,v_0,davidson_threshold,shortcut,sort_idx) - allocate(idx(0:n), vt(n)) - Vt = 0.d0 + PROVIDE ref_bitmask_energy davidson_criterion + + allocate (shortcut(0:n+1), sort_idx(n), sorted(Nint,n), version(Nint,n)) v_0 = 0.d0 + + call sort_dets_ab_v(keys_tmp, sorted, sort_idx, shortcut, version, n, Nint) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,hij,j,k,jj,vt,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,local_threshold,sorted_i)& + !$OMP SHARED(n,H_jj,u_0,keys_tmp,Nint,v_0,threshold_davidson,sorted,shortcut,sort_idx,version) + allocate(vt(n)) + Vt = 0.d0 + !$OMP DO SCHEDULE(dynamic) - - do sh=1,shortcut(0) - warp(1,0) = 0 - do ii=1,sh!shortcut(0) - tmp = 0 + do sh2=1,sh + exa = 0 do ni=1,Nint - tmp = popcnt(xor(keys_tmp(ni,1, shortcut(ii)), keys_tmp(ni,1,shortcut(sh)))) + exa = exa + popcnt(xor(version(ni,sh), version(ni,sh2))) end do - if(tmp <= 4) then - warp(1,0) = warp(1,0) + 1 - warp(1,warp(1,0)) = shortcut(ii) - warp(2,warp(1,0)) = shortcut(ii+1)-1 + if(exa > 2) then + cycle end if - end do - - - do ii=shortcut(sh),shortcut(sh+1)-1 - idx(0) = ii - call filter_connected_davidson_warp(keys_tmp,warp,keys_tmp(1,1,ii),Nint,ii-1,idx) - i = sort_idx(ii) - - do jj=1,idx(0) - j = sort_idx(idx(jj)) - if ( dabs(u_0(j)) + dabs(u_0(i)) > davidson_threshold ) then - call i_H_j(keys_tmp(1,1,idx(jj)),keys_tmp(1,1,ii),Nint,hij) - vt (i) = vt (i) + hij*u_0(j) - vt (j) = vt (j) + hij*u_0(i) - endif + do i=shortcut(sh),shortcut(sh+1)-1 + org_i = sort_idx(i) + local_threshold = threshold_davidson - dabs(u_0(org_i)) + if(sh==sh2) then + endi = i-1 + else + endi = shortcut(sh2+1)-1 + end if + do ni=1,Nint + sorted_i(ni) = sorted(ni,i) + enddo + + do j=shortcut(sh2),endi + org_j = sort_idx(j) + if ( dabs(u_0(org_j)) > local_threshold ) then + ext = exa + do ni=1,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j))) + end do + if(ext <= 4) then + call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) + vt (org_i) = vt (org_i) + hij*u_0(org_j) + vt (org_j) = vt (org_j) + hij*u_0(org_i) + endif + endif + enddo enddo enddo enddo !$OMP END DO + !$OMP CRITICAL do i=1,n v_0(i) = v_0(i) + vt(i) enddo !$OMP END CRITICAL - deallocate(idx,vt) + + deallocate(vt) !$OMP END PARALLEL - do i=1,n - v_0(i) += H_jj(i) * u_0(i) - enddo -end - - -subroutine H_u_0_org(v_0,u_0,H_jj,n,keys_tmp,Nint) - use bitmasks - implicit none - BEGIN_DOC - ! Computes v_0 = H|u_0> - ! - ! n : number of determinants - ! - ! H_jj : array of - END_DOC - integer, intent(in) :: n,Nint - double precision, intent(out) :: v_0(n) - double precision, intent(in) :: u_0(n) - double precision, intent(in) :: H_jj(n) - integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) - integer, allocatable :: idx(:) - double precision :: hij - double precision, allocatable :: vt(:) - integer :: i,j,k,l, jj,ii,sh - integer :: i0, j0 + call sort_dets_ba_v(keys_tmp, sorted, sort_idx, shortcut, version, n, Nint) - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (n>0) - PROVIDE ref_bitmask_energy !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,hij,j,k,idx,jj,vt,ii) & - !$OMP SHARED(n,H_jj,u_0,keys_tmp,Nint,v_0,davidson_threshold) - allocate(idx(0:n), vt(n)) + !$OMP PRIVATE(i,hij,j,k,jj,vt,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,local_threshold)& + !$OMP SHARED(n,H_jj,u_0,keys_tmp,Nint,v_0,threshold_davidson,sorted,shortcut,sort_idx,version) + allocate(vt(n)) Vt = 0.d0 - v_0 = 0.d0 - !$OMP DO SCHEDULE(guided) - - - - - do ii=1,n - idx(0) = ii - i = ii - call filter_connected_davidson(keys_tmp,keys_tmp(1,1,ii),Nint,ii-1,idx) - - do jj=1,idx(0) - j = idx(jj) - if ( dabs(u_0(j)) + dabs(u_0(i)) > davidson_threshold ) then - call i_H_j(keys_tmp(1,1,idx(jj)),keys_tmp(1,1,ii),Nint,hij) - vt (i) = vt (i) + hij*u_0(j) - vt (j) = vt (j) + hij*u_0(i) - endif - enddo - enddo - + !$OMP DO SCHEDULE(dynamic) + do sh=1,shortcut(0) + do i=shortcut(sh),shortcut(sh+1)-1 + org_i = sort_idx(i) + local_threshold = threshold_davidson - dabs(u_0(org_i)) + do j=shortcut(sh),i-1 + org_j = sort_idx(j) + if ( dabs(u_0(org_j)) > local_threshold ) then + ext = 0 + do ni=1,Nint + ext = ext + popcnt(xor(sorted(ni,i), sorted(ni,j))) + end do + if(ext == 4) then + call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) + vt (org_i) = vt (org_i) + hij*u_0(org_j) + vt (org_j) = vt (org_j) + hij*u_0(org_i) + end if + end if + end do + end do + enddo !$OMP END DO + !$OMP CRITICAL do i=1,n v_0(i) = v_0(i) + vt(i) enddo !$OMP END CRITICAL - deallocate(idx,vt) + deallocate(vt) !$OMP END PARALLEL + do i=1,n v_0(i) += H_jj(i) * u_0(i) enddo + deallocate (shortcut, sort_idx, sorted, version) end - - -BEGIN_PROVIDER [ integer, N_con_int ] - implicit none - BEGIN_DOC - ! Number of integers to represent the connections between determinants - END_DOC - N_con_int = 1 + ishft(N_det-1,-11) -END_PROVIDER - -BEGIN_PROVIDER [ integer*8, det_connections, (N_con_int,N_det) ] - implicit none - BEGIN_DOC - ! Build connection proxy between determinants - END_DOC - integer :: i,j - integer :: degree - integer :: j_int, j_k, j_l - integer, allocatable :: idx(:) - integer :: thread_num - integer :: omp_get_thread_num - - PROVIDE progress_bar - call start_progress(N_det,'Det connections',0.d0) - - select case(N_int) - - case(1) - - - !$OMP PARALLEL DEFAULT (NONE) & - !$OMP SHARED(N_det, N_con_int, psi_det,N_int, det_connections, & - !$OMP progress_bar,progress_value)& - !$OMP PRIVATE(i,j_int,j_k,j_l,j,degree,idx,thread_num) - - !$ thread_num = omp_get_thread_num() - allocate (idx(0:N_det)) - !$OMP DO SCHEDULE(guided) - do i=1,N_det - if (thread_num == 0) then - progress_bar(1) = i - progress_value = dble(i) - endif - do j_int=1,N_con_int - det_connections(j_int,i) = 0_8 - j_k = ishft(j_int-1,11) - do j_l = j_k,min(j_k+2047,N_det), 32 - do j = j_l+1,min(j_l+32,i) - degree = popcnt(xor( psi_det(1,1,i),psi_det(1,1,j))) + & - popcnt(xor( psi_det(1,2,i),psi_det(1,2,j))) - if (degree < 5) then - det_connections(j_int,i) = ibset( det_connections(j_int,i), iand(63,ishft(j_l,-5)) ) - exit - endif - enddo - enddo - enddo - enddo - !$OMP ENDDO - deallocate(idx) - !$OMP END PARALLEL - - case(2) - - !$OMP PARALLEL DEFAULT (NONE) & - !$OMP SHARED(N_det, N_con_int, psi_det,N_int, det_connections,& - !$OMP progress_bar,progress_value)& - !$OMP PRIVATE(i,j_int,j_k,j_l,j,degree,idx,thread_num) - !$ thread_num = omp_get_thread_num() - allocate (idx(0:N_det)) - !$OMP DO SCHEDULE(guided) - do i=1,N_det - if (thread_num == 0) then - progress_bar(1) = i - progress_value = dble(i) - endif - do j_int=1,N_con_int - det_connections(j_int,i) = 0_8 - j_k = ishft(j_int-1,11) - do j_l = j_k,min(j_k+2047,N_det), 32 - do j = j_l+1,min(j_l+32,i) - degree = popcnt(xor( psi_det(1,1,i),psi_det(1,1,j))) + & - popcnt(xor( psi_det(1,2,i),psi_det(1,2,j))) + & - popcnt(xor( psi_det(2,1,i),psi_det(2,1,j))) + & - popcnt(xor( psi_det(2,2,i),psi_det(2,2,j))) - if (degree < 5) then - det_connections(j_int,i) = ibset( det_connections(j_int,i), iand(63,ishft(j_l,-5)) ) - exit - endif - enddo - enddo - enddo - enddo - !$OMP ENDDO - deallocate(idx) - !$OMP END PARALLEL - - case(3) - - !$OMP PARALLEL DEFAULT (NONE) & - !$OMP SHARED(N_det, N_con_int, psi_det,N_int, det_connections,& - !$OMP progress_bar,progress_value)& - !$OMP PRIVATE(i,j_int,j_k,j_l,j,degree,idx,thread_num) - !$ thread_num = omp_get_thread_num() - allocate (idx(0:N_det)) - !$OMP DO SCHEDULE(guided) - do i=1,N_det - if (thread_num == 0) then - progress_bar(1) = i - progress_value = dble(i) - endif - do j_int=1,N_con_int - det_connections(j_int,i) = 0_8 - j_k = ishft(j_int-1,11) - do j_l = j_k,min(j_k+2047,N_det), 32 - do j = j_l+1,min(j_l+32,i) - degree = popcnt(xor( psi_det(1,1,i),psi_det(1,1,j))) + & - popcnt(xor( psi_det(1,2,i),psi_det(1,2,j))) + & - popcnt(xor( psi_det(2,1,i),psi_det(2,1,j))) + & - popcnt(xor( psi_det(2,2,i),psi_det(2,2,j))) + & - popcnt(xor( psi_det(3,1,i),psi_det(3,1,j))) + & - popcnt(xor( psi_det(3,2,i),psi_det(3,2,j))) - if (degree < 5) then - det_connections(j_int,i) = ibset( det_connections(j_int,i), iand(63,ishft(j_l,-5)) ) - exit - endif - enddo - enddo - enddo - enddo - !$OMP ENDDO - deallocate(idx) - !$OMP END PARALLEL - - case default - - - !$OMP PARALLEL DEFAULT (NONE) & - !$OMP SHARED(N_det, N_con_int, psi_det,N_int, det_connections,& - !$OMP progress_bar,progress_value)& - !$OMP PRIVATE(i,j_int,j_k,j_l,j,degree,idx,thread_num) - !$ thread_num = omp_get_thread_num() - allocate (idx(0:N_det)) - !$OMP DO SCHEDULE(guided) - do i=1,N_det - if (thread_num == 0) then - progress_bar(1) = i - progress_value = dble(i) - endif - do j_int=1,N_con_int - det_connections(j_int,i) = 0_8 - j_k = ishft(j_int-1,11) - do j_l = j_k,min(j_k+2047,N_det), 32 - do j = j_l+1,min(j_l+32,i) - !DIR$ FORCEINLINE - call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) - if (degree < 3) then - det_connections(j_int,i) = ibset( det_connections(j_int,i), iand(63,ishft(j_l,-5)) ) - exit - endif - enddo - enddo - enddo - enddo - !$OMP ENDDO - deallocate(idx) - !$OMP END PARALLEL - - end select - call stop_progress - -END_PROVIDER - diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index 5994798d..0ca6301a 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -350,6 +350,34 @@ subroutine write_spindeterminants end + BEGIN_PROVIDER [ double precision, det_alpha_norm, (N_det_alpha_unique) ] +&BEGIN_PROVIDER [ double precision, det_beta_norm, (N_det_beta_unique) ] + implicit none + BEGIN_DOC + ! Norm of the alpha and beta spin determinants in the wave function: + ! + ! ||Da||_i \sum_j C_{ij}**2 + END_DOC + + integer :: i,j,k,l + double precision :: f + + det_alpha_norm = 0.d0 + det_beta_norm = 0.d0 + do k=1,N_det + i = psi_bilinear_matrix_rows(k) + j = psi_bilinear_matrix_columns(k) + do l=1,N_states + f = psi_bilinear_matrix_values(k,l)*psi_bilinear_matrix_values(k,l) + enddo + det_alpha_norm(i) += f + det_beta_norm(j) += f + enddo + det_alpha_norm = det_alpha_norm / dble(N_states) + det_beta_norm = det_beta_norm / dble(N_states) + +END_PROVIDER + !==============================================================================! ! ! @@ -414,13 +442,14 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix, (N_det_alpha_unique,N_de enddo END_PROVIDER -subroutine create_wf_of_psi_bilinear_matrix +subroutine create_wf_of_psi_bilinear_matrix(truncate) use bitmasks implicit none BEGIN_DOC ! Generate a wave function containing all possible products ! of alpha and beta determinants END_DOC + logical, intent(in) :: truncate integer :: i,j,k integer(bit_kind) :: tmp_det(N_int,2) integer :: idx @@ -460,8 +489,10 @@ subroutine create_wf_of_psi_bilinear_matrix norm(1) = 0.d0 do i=1,N_det norm(1) += psi_average_norm_contrib_sorted(i) - if (norm(1) >= 0.999999d0) then - exit + if (truncate) then + if (norm(1) >= 0.999999d0) then + exit + endif endif enddo N_det = min(i,N_det) @@ -504,7 +535,6 @@ subroutine generate_all_alpha_beta_det_products !$OMP END DO NOWAIT deallocate(tmp_det) !$OMP END PARALLEL - deallocate (tmp_det) call copy_H_apply_buffer_to_wf SOFT_TOUCH psi_det psi_coef N_det end diff --git a/src/Determinants/tree_dependency.png b/src/Determinants/tree_dependency.png index 53c75ffc..f9eb10c3 100644 Binary files a/src/Determinants/tree_dependency.png and b/src/Determinants/tree_dependency.png differ diff --git a/src/Determinants/truncate_wf.irp.f b/src/Determinants/truncate_wf.irp.f index f867ad7e..42340c71 100644 --- a/src/Determinants/truncate_wf.irp.f +++ b/src/Determinants/truncate_wf.irp.f @@ -8,10 +8,10 @@ program cisd N_det=10000 do i=1,N_det do k=1,N_int - psi_det(k,1,i) = psi_det_sorted(k,1,i) - psi_det(k,2,i) = psi_det_sorted(k,2,i) + psi_det(k,1,i) = psi_det_sorted(k,1,i) + psi_det(k,2,i) = psi_det_sorted(k,2,i) enddo - psi_coef(k,:) = psi_coef_sorted(k,:) + psi_coef(i,:) = psi_coef_sorted(i,:) enddo TOUCH psi_det psi_coef psi_det_sorted psi_coef_sorted psi_average_norm_contrib_sorted N_det call save_wavefunction diff --git a/src/Electrons/tree_dependency.png b/src/Electrons/tree_dependency.png index 3f82c435..b90a1f83 100644 Binary files a/src/Electrons/tree_dependency.png and b/src/Electrons/tree_dependency.png differ diff --git a/src/Ezfio_files/README.rst b/src/Ezfio_files/README.rst index 986d7216..c7183a64 100644 --- a/src/Ezfio_files/README.rst +++ b/src/Ezfio_files/README.rst @@ -195,11 +195,11 @@ Documentation .br -`output_ao_basis `_ +output_ao_basis Output file for AO_Basis -`output_bitmask `_ +output_bitmask Output file for Bitmask @@ -207,79 +207,83 @@ Documentation Initial CPU and wall times when printing in the output files -`output_determinants `_ +output_determinants Output file for Determinants -`output_electrons `_ +output_electrons Output file for Electrons -`output_ezfio_files `_ +output_ezfio_files Output file for Ezfio_files -`output_generators_full `_ +output_full_ci + Output file for Full_CI + + +output_generators_full Output file for Generators_full -`output_hartree_fock `_ +output_hartree_fock Output file for Hartree_Fock -`output_integrals_bielec `_ +output_integrals_bielec Output file for Integrals_Bielec -`output_integrals_monoelec `_ +output_integrals_monoelec Output file for Integrals_Monoelec -`output_mo_basis `_ +output_mo_basis Output file for MO_Basis -`output_moguess `_ +output_moguess Output file for MOGuess -`output_mrcc_cassd `_ +output_mrcc_cassd Output file for MRCC_CASSD -`output_mrcc_utils `_ +output_mrcc_utils Output file for MRCC_Utils -`output_nuclei `_ +output_nuclei Output file for Nuclei -`output_perturbation `_ +output_perturbation Output file for Perturbation -`output_properties `_ +output_properties Output file for Properties -`output_pseudo `_ +output_pseudo Output file for Pseudo -`output_psiref_cas `_ +output_psiref_cas Output file for Psiref_CAS -`output_psiref_utils `_ +output_psiref_utils Output file for Psiref_Utils -`output_selectors_full `_ +output_selectors_full Output file for Selectors_full -`output_utils `_ +output_utils Output file for Utils diff --git a/src/Ezfio_files/tree_dependency.png b/src/Ezfio_files/tree_dependency.png index 6df8c015..48f53991 100644 Binary files a/src/Ezfio_files/tree_dependency.png and b/src/Ezfio_files/tree_dependency.png differ diff --git a/src/Integrals_Bielec/.gitignore b/src/Integrals_Bielec/.gitignore index 54da4aed..f4bdeaca 100644 --- a/src/Integrals_Bielec/.gitignore +++ b/src/Integrals_Bielec/.gitignore @@ -1,20 +1,20 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp +# Automatically created by $QP_ROOT/scripts/module/module_handler.py +.ninja_deps +.ninja_log +AO_Basis +Bitmask +Electrons +Ezfio_files IRPF90_man -irpf90_entities -tags -irpf90.make +IRPF90_temp +MO_Basis Makefile Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Ezfio_files -MO_Basis -Utils +Nuclei Pseudo -Bitmask -AO_Basis -Electrons -Nuclei \ No newline at end of file +Utils +ezfio_interface.irp.f +irpf90.make +irpf90_entities +tags +test_integrals \ No newline at end of file diff --git a/src/Integrals_Bielec/NEEDED_CHILDREN_MODULES b/src/Integrals_Bielec/NEEDED_CHILDREN_MODULES index 5888fc95..152711f3 100644 --- a/src/Integrals_Bielec/NEEDED_CHILDREN_MODULES +++ b/src/Integrals_Bielec/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Pseudo Bitmask +Pseudo Bitmask ZMQ diff --git a/src/Integrals_Bielec/README.rst b/src/Integrals_Bielec/README.rst index b71d9c0d..f09d1a9c 100644 --- a/src/Integrals_Bielec/README.rst +++ b/src/Integrals_Bielec/README.rst @@ -47,7 +47,7 @@ Documentation i(r1) j(r1) 1/r12 k(r2) l(r2) -`ao_bielec_integral_schwartz `_ +`ao_bielec_integral_schwartz `_ Needed to compute Schwartz inequalities @@ -56,7 +56,7 @@ Documentation i(r1) j(r1) 1/r12 k(r2) l(r2) -`ao_bielec_integrals_in_map `_ +`ao_bielec_integrals_in_map `_ Map of Atomic integrals i(r1) j(r2) 1/r12 k(r1) l(r2) @@ -73,6 +73,10 @@ Documentation Computes the product of l values of i,j,k,and l +`bench_maps `_ + Performs timing benchmarks on integral access + + `bielec_integrals_index `_ Undocumented @@ -85,7 +89,7 @@ Documentation Frees the memory of the AO map -`clear_mo_map `_ +`clear_mo_map `_ Frees the memory of the MO map @@ -105,15 +109,15 @@ Documentation Compute integrals on the fly -`dump_ao_integrals `_ +`dump_ao_integrals `_ Save to disk the $ao integrals -`dump_mo_integrals `_ +`dump_mo_integrals `_ Save to disk the $ao integrals -`eri `_ +`eri `_ ATOMIC PRIMTIVE bielectronic integral between the 4 primitives :: primitive_1 = x1**(a_x) y1**(a_y) z1**(a_z) exp(-alpha * r1**2) primitive_2 = x1**(b_x) y1**(b_y) z1**(b_z) exp(- beta * r1**2) @@ -135,7 +139,7 @@ Documentation t_w(i,2,k) = t(i) -`general_primitive_integral `_ +`general_primitive_integral `_ Computes the integral where p,q,r,s are Gaussian primitives @@ -161,52 +165,56 @@ Documentation Returns one integral in the MO basis -`get_mo_bielec_integrals `_ +`get_mo_bielec_integral_schwartz `_ + Returns one integral in the MO basis + + +`get_mo_bielec_integrals `_ Returns multiple integrals in the MO basis, all i for j,k,l fixed. -`get_mo_bielec_integrals_existing_ik `_ +`get_mo_bielec_integrals_existing_ik `_ Returns multiple integrals in the MO basis, all i(1)j(1) 1/r12 k(2)l(2) i for j,k,l fixed. -`get_mo_map_size `_ +`get_mo_map_size `_ Return the number of elements in the MO map -`give_polynom_mult_center_x `_ +`give_polynom_mult_center_x `_ subroutine that returns the explicit polynom in term of the "t" variable of the following polynomw : I_x1(a_x, d_x,p,q) * I_x1(a_y, d_y,p,q) * I_x1(a_z, d_z,p,q) -`i_x1_new `_ +`i_x1_new `_ recursive function involved in the bielectronic integral -`i_x1_pol_mult `_ +`i_x1_pol_mult `_ recursive function involved in the bielectronic integral -`i_x1_pol_mult_a1 `_ +`i_x1_pol_mult_a1 `_ recursive function involved in the bielectronic integral -`i_x1_pol_mult_a2 `_ +`i_x1_pol_mult_a2 `_ recursive function involved in the bielectronic integral -`i_x1_pol_mult_recurs `_ +`i_x1_pol_mult_recurs `_ recursive function involved in the bielectronic integral -`i_x2_new `_ +`i_x2_new `_ recursive function involved in the bielectronic integral -`i_x2_pol_mult `_ +`i_x2_pol_mult `_ recursive function involved in the bielectronic integral @@ -218,21 +226,21 @@ Documentation Create new entry into MO map, or accumulate in an existing entry -`integrale_new `_ +`integrale_new `_ calculate the integral of the polynom :: I_x1(a_x+b_x, c_x+d_x,p,q) * I_x1(a_y+b_y, c_y+d_y,p,q) * I_x1(a_z+b_z, c_z+d_z,p,q) between ( 0 ; 1) -`load_ao_integrals `_ +`load_ao_integrals `_ Read from disk the $ao integrals -`load_mo_integrals `_ +`load_mo_integrals `_ Read from disk the $ao integrals -`mo_bielec_integral `_ +`mo_bielec_integral `_ Returns one integral in the MO basis @@ -272,6 +280,10 @@ Documentation mo_bielec_integral_jj_anti_from_ao(i,j) = J_ij - K_ij +`mo_bielec_integral_schwartz `_ + Needed to compute Schwartz inequalities + + `mo_bielec_integrals_in_map `_ If True, the map of MO bielectronic integrals is provided @@ -292,7 +304,7 @@ Documentation Aligned n_pt_max_integrals -`n_pt_sup `_ +`n_pt_sup `_ Returns the upper boundary of the degree of the polynomial involved in the bielctronic integral : Ix(a_x,b_x,c_x,d_x) * Iy(a_y,b_y,c_y,d_y) * Iz(a_z,b_z,c_z,d_z) diff --git a/src/Integrals_Bielec/ao_bi_integrals.irp.f b/src/Integrals_Bielec/ao_bi_integrals.irp.f index ba3bbcc1..53ce68e9 100644 --- a/src/Integrals_Bielec/ao_bi_integrals.irp.f +++ b/src/Integrals_Bielec/ao_bi_integrals.irp.f @@ -204,7 +204,7 @@ double precision function ao_bielec_integral_schwartz_accel(i,j,k,l) integral = general_primitive_integral(dim1, & P_new,P_center,fact_p,pp,p_inv,iorder_p, & Q_new,Q_center,fact_q,qq,q_inv,iorder_q) - ao_bielec_integral_schwartz_accel += coef4 * integral + ao_bielec_integral_schwartz_accel = ao_bielec_integral_schwartz_accel + coef4 * integral enddo ! s enddo ! r enddo ! q @@ -264,7 +264,7 @@ double precision function ao_bielec_integral_schwartz_accel(i,j,k,l) I_power(1),J_power(1),K_power(1),L_power(1), & I_power(2),J_power(2),K_power(2),L_power(2), & I_power(3),J_power(3),K_power(3),L_power(3)) - ao_bielec_integral_schwartz_accel += coef4 * integral + ao_bielec_integral_schwartz_accel = ao_bielec_integral_schwartz_accel + coef4 * integral enddo ! s enddo ! r enddo ! q @@ -301,18 +301,26 @@ subroutine compute_ao_bielec_integrals(j,k,l,sze,buffer_value) double precision :: thresh thresh = ao_integrals_threshold - integer :: n_centers, i + integer :: i if (ao_overlap_abs(j,l) < thresh) then buffer_value = 0._integral_kind return endif + if (ao_bielec_integral_schwartz(j,l) < thresh ) then + buffer_value = 0._integral_kind + return + endif do i = 1, ao_num if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < thresh) then buffer_value(i) = 0._integral_kind cycle endif + if (ao_bielec_integral_schwartz(i,k)*ao_bielec_integral_schwartz(j,l) < thresh ) then + buffer_value(i) = 0._integral_kind + cycle + endif !DIR$ FORCEINLINE buffer_value(i) = ao_bielec_integral(i,k,j,l) enddo @@ -321,6 +329,7 @@ end BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ] implicit none + use f77_zmq use map_module BEGIN_DOC ! Map of Atomic integrals @@ -337,9 +346,8 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ] integer(key_kind),allocatable :: buffer_i(:) integer,parameter :: size_buffer = 1024*64 real(integral_kind),allocatable :: buffer_value(:) - integer(omp_lock_kind) :: lock - integer :: n_integrals, n_centers, thread_num + integer :: n_integrals, rc integer :: jl_pairs(2,ao_num*(ao_num+1)/2), kk, m, j1, i1, lmax integral = ao_bielec_integral(1,1,1,1) @@ -355,116 +363,61 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ] endif endif - kk=1 - do l = 1, ao_num ! r2 - do j = 1, l ! r2 - jl_pairs(1,kk) = j - jl_pairs(2,kk) = l - kk += 1 - enddo - enddo - - PROVIDE progress_bar - call omp_init_lock(lock) - lmax = ao_num*(ao_num+1)/2 print*, 'Providing the AO integrals' call wall_time(wall_0) call wall_time(wall_1) call cpu_time(cpu_1) - call start_progress(lmax,'AO integrals (MB)',0.d0) - !$OMP PARALLEL PRIVATE(i,j,k,l,kk, & - !$OMP integral,buffer_i,buffer_value,n_integrals, & - !$OMP cpu_2,wall_2,i1,j1,thread_num) & - !$OMP DEFAULT(NONE) & - !$OMP SHARED (ao_num, jl_pairs, ao_integrals_map,thresh, & - !$OMP cpu_1,wall_1,lock, lmax,n_centers,ao_nucl, & - !$OMP ao_overlap_abs,ao_overlap,abort_here, & - !$OMP wall_0,progress_bar,progress_value) - - allocate(buffer_i(size_buffer)) - allocate(buffer_value(size_buffer)) - n_integrals = 0 -!$ thread_num = omp_get_thread_num() - - !$OMP DO SCHEDULE(dynamic) - do kk=1,lmax -IRP_IF COARRAY - if (mod(kk-this_image(),num_images()) /= 0) then - cycle - endif -IRP_ENDIF - if (abort_here) then - cycle - endif - if (thread_num == 0) then - progress_bar(1) = kk - endif - j = jl_pairs(1,kk) - l = jl_pairs(2,kk) - j1 = j+ishft(l*l-l,-1) - if (ao_overlap_abs(j,l) < thresh) then - cycle - endif - do k = 1, ao_num ! r1 - i1 = ishft(k*k-k,-1) - if (i1 > j1) then - exit - endif - do i = 1, k - i1 += 1 - if (i1 > j1) then - exit - endif - if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < thresh) then - cycle - endif - !DIR$ FORCEINLINE - integral = ao_bielec_integral(i,k,j,l) - if (abs(integral) < thresh) then - cycle - endif - n_integrals += 1 - !DIR$ FORCEINLINE - call bielec_integrals_index(i,j,k,l,buffer_i(n_integrals)) - buffer_value(n_integrals) = integral - if (n_integrals > 1024 ) then - if (omp_test_lock(lock)) then - call insert_into_ao_integrals_map(n_integrals,buffer_i,buffer_value) - n_integrals = 0 - call omp_unset_lock(lock) - endif - endif - if (n_integrals == size(buffer_i)) then - call insert_into_ao_integrals_map(n_integrals,buffer_i,buffer_value) - n_integrals = 0 - endif - enddo - enddo - call wall_time(wall_2) - - if (thread_num == 0) then - if (wall_2 - wall_0 > 1.d0) then - wall_0 = wall_2 - print*, 100.*float(kk)/float(lmax), '% in ', & - wall_2-wall_1, 's', map_mb(ao_integrals_map) ,'MB' - progress_value = dble(map_mb(ao_integrals_map)) - endif - endif - enddo - !$OMP END DO NOWAIT - call insert_into_ao_integrals_map(n_integrals,buffer_i,buffer_value) - deallocate(buffer_i) - deallocate(buffer_value) - !$OMP END PARALLEL - call omp_destroy_lock(lock) - call stop_progress - if (abort_here) then - stop 'Aborting in AO integrals calculation' + + integer(ZMQ_PTR) :: zmq_socket_rep_inproc, zmq_socket_push_inproc + zmq_socket_rep_inproc = f77_zmq_socket(zmq_context, ZMQ_REP) + rc = f77_zmq_bind(zmq_socket_rep_inproc, 'inproc://req_rep') + if (rc /= 0) then + stop 'Unable to connect zmq_socket_rep_inproc' endif -IRP_IF COARRAY - print*, 'Communicating the map' - call communicate_ao_integrals() -IRP_ENDIF COARRAY + + integer(ZMQ_PTR) :: thread(0:nproc) + external :: ao_bielec_integrals_in_map_slave, ao_bielec_integrals_in_map_collector + rc = pthread_create( thread(0), ao_bielec_integrals_in_map_collector ) + ! Create client threads + do i=1,nproc + rc = pthread_create( thread(i), ao_bielec_integrals_in_map_slave ) + enddo + + character*(64) :: message_string + + do l = ao_num, 1, -1 + rc = f77_zmq_recv( zmq_socket_rep_inproc, message_string, 64, 0) + print *, l + ! TODO : error handling + ASSERT (rc >= 0) + ASSERT (message == 'get_ao_integrals') + rc = f77_zmq_send( zmq_socket_rep_inproc, l, 4, 0) + enddo + do i=1,nproc + rc = f77_zmq_recv( zmq_socket_rep_inproc, message_string, 64, 0) + ! TODO : error handling + ASSERT (rc >= 0) + ASSERT (message == 'get_ao_integrals') + rc = f77_zmq_send( zmq_socket_rep_inproc, 0, 4, 0) + enddo + ! TODO terminer thread(0) + + rc = f77_zmq_unbind(zmq_socket_rep_inproc, 'inproc://req_rep') + do i=1,nproc + rc = pthread_join( thread(i) ) + enddo + + zmq_socket_push_inproc = f77_zmq_socket(zmq_context, ZMQ_PUSH) + rc = f77_zmq_connect(zmq_socket_push_inproc, 'inproc://push_pull') + if (rc /= 0) then + stop 'Unable to connect zmq_socket_push_inproc' + endif + rc = f77_zmq_send( zmq_socket_push_inproc, -1, 4, ZMQ_SNDMORE) + rc = f77_zmq_send( zmq_socket_push_inproc, 0_key_kind, key_kind, ZMQ_SNDMORE) + rc = f77_zmq_send( zmq_socket_push_inproc, 0_integral_kind, integral_kind, 0) + + rc = pthread_join( thread(0) ) + print*, 'Sorting the map' call map_sort(ao_integrals_map) call cpu_time(cpu_2) @@ -481,7 +434,7 @@ IRP_ENDIF COARRAY ao_bielec_integrals_in_map = .True. if (write_ao_integrals) then call dump_ao_integrals(trim(ezfio_filename)//'/work/ao_integrals.bin') - call ezfio_set_integrals_bielec_disk_access_ao_integrals(.True.) + call ezfio_set_integrals_bielec_disk_access_ao_integrals("Read") endif END_PROVIDER @@ -665,32 +618,44 @@ double precision function ERI(alpha,beta,delta,gama,a_x,b_x,c_x,d_x,a_y,b_y,c_y, integer :: n_pt_sup double precision :: p,q,denom,coeff double precision :: I_f + integer :: nx,ny,nz include 'Utils/constants.include.F' - if(iand(a_x+b_x+c_x+d_x,1).eq.1.or.iand(a_y+b_y+c_y+d_y,1).eq.1.or.iand(a_z+b_z+c_z+d_z,1).eq.1)then + nx = a_x+b_x+c_x+d_x + if(iand(nx,1) == 1) then ERI = 0.d0 return - else - - ASSERT (alpha >= 0.d0) - ASSERT (beta >= 0.d0) - ASSERT (delta >= 0.d0) - ASSERT (gama >= 0.d0) - p = alpha + beta - q = delta + gama - ASSERT (p+q >= 0.d0) - coeff = pi_5_2 / (p * q * dsqrt(p+q)) - !DIR$ FORCEINLINE - n_pt = n_pt_sup(a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z) - - if (n_pt == 0) then - ERI = coeff - return - endif - - call integrale_new(I_f,a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z,p,q,n_pt) - - ERI = I_f * coeff endif + + ny = a_y+b_y+c_y+d_y + if(iand(ny,1) == 1) then + ERI = 0.d0 + return + endif + + nz = a_z+b_z+c_z+d_z + if(iand(nz,1) == 1) then + ERI = 0.d0 + return + endif + + ASSERT (alpha >= 0.d0) + ASSERT (beta >= 0.d0) + ASSERT (delta >= 0.d0) + ASSERT (gama >= 0.d0) + p = alpha + beta + q = delta + gama + ASSERT (p+q >= 0.d0) + n_pt = ishft( nx+ny+nz,1 ) + + coeff = pi_5_2 / (p * q * dsqrt(p+q)) + if (n_pt == 0) then + ERI = coeff + return + endif + + call integrale_new(I_f,a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z,p,q,n_pt) + + ERI = I_f * coeff end @@ -703,6 +668,7 @@ subroutine integrale_new(I_f,a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z,p,q implicit none + include 'Utils/constants.include.F' double precision :: p,q integer :: a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z integer :: i, n_iter, n_pt, j @@ -717,8 +683,9 @@ subroutine integrale_new(I_f,a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z,p,q p01_1 = 0.5d0/q p10_2 = 0.5d0 * q /(p * q + p * p) p01_2 = 0.5d0 * p /(q * q + q * p) - double precision :: B10(n_pt), B01(n_pt), B00(n_pt) - double precision :: t1(n_pt), t2(n_pt) + double precision :: B00(n_pt_max_integrals) + double precision :: B10(n_pt_max_integrals), B01(n_pt_max_integrals) + double precision :: t1(n_pt_max_integrals), t2(n_pt_max_integrals) !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: t1, t2, B10, B01, B00 ix = a_x+b_x jx = c_x+d_x @@ -773,10 +740,11 @@ recursive subroutine I_x1_new(a,c,B_10,B_01,B_00,res,n_pt) ! recursive function involved in the bielectronic integral END_DOC implicit none + include 'Utils/constants.include.F' integer, intent(in) :: a,c,n_pt - double precision, intent(in) :: B_10(n_pt),B_01(n_pt),B_00(n_pt) - double precision, intent(out) :: res(n_pt) - double precision :: res2(n_pt) + double precision, intent(in) :: B_10(n_pt_max_integrals),B_01(n_pt_max_integrals),B_00(n_pt_max_integrals) + double precision, intent(out) :: res(n_pt_max_integrals) + double precision :: res2(n_pt_max_integrals) integer :: i if(c<0)then @@ -808,9 +776,10 @@ recursive subroutine I_x2_new(c,B_10,B_01,B_00,res,n_pt) BEGIN_DOC ! recursive function involved in the bielectronic integral END_DOC + include 'Utils/constants.include.F' integer, intent(in) :: c, n_pt - double precision, intent(in) :: B_10(n_pt),B_01(n_pt),B_00(n_pt) - double precision, intent(out) :: res(n_pt) + double precision, intent(in) :: B_10(n_pt_max_integrals),B_01(n_pt_max_integrals),B_00(n_pt_max_integrals) + double precision, intent(out) :: res(n_pt_max_integrals) integer :: i if(c==1)then @@ -1228,3 +1197,57 @@ recursive subroutine I_x2_pol_mult(c,B_10,B_01,B_00,C_00,D_00,d,nd,dim) end + + +subroutine compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value) + implicit none + use map_module + BEGIN_DOC + ! Parallel client for AO integrals + END_DOC + + integer, intent(in) :: j,l + integer,intent(out) :: n_integrals + integer(key_kind),intent(out) :: buffer_i(ao_num*ao_num) + real(integral_kind),intent(out) :: buffer_value(ao_num*ao_num) + + integer :: i,k + double precision :: ao_bielec_integral,cpu_1,cpu_2, wall_1, wall_2 + double precision :: integral, wall_0 + double precision :: thresh + integer :: kk, m, j1, i1 + + thresh = ao_integrals_threshold + + n_integrals = 0 + + j1 = j+ishft(l*l-l,-1) + do k = 1, ao_num ! r1 + i1 = ishft(k*k-k,-1) + if (i1 > j1) then + exit + endif + do i = 1, k + i1 += 1 + if (i1 > j1) then + exit + endif + if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < thresh) then + cycle + endif + if (ao_bielec_integral_schwartz(i,k)*ao_bielec_integral_schwartz(j,l) < thresh ) then + cycle + endif + !DIR$ FORCEINLINE + integral = ao_bielec_integral(i,k,j,l) + if (abs(integral) < thresh) then + cycle + endif + n_integrals += 1 + !DIR$ FORCEINLINE + call bielec_integrals_index(i,j,k,l,buffer_i(n_integrals)) + buffer_value(n_integrals) = integral + enddo + enddo + +end diff --git a/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f b/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f new file mode 100644 index 00000000..7aa59c0d --- /dev/null +++ b/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f @@ -0,0 +1,99 @@ +subroutine ao_bielec_integrals_in_map_slave + use map_module + use f77_zmq + implicit none + BEGIN_DOC +! Computes a buffer of integrals + END_DOC + + integer :: j,l,n_integrals + integer :: rc + character*(8), external :: zmq_port + integer(ZMQ_PTR) :: zmq_socket_req_inproc, zmq_socket_push_inproc + real(integral_kind), allocatable :: buffer_value(:) + integer(key_kind), allocatable :: buffer_i(:) + + allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) ) + + ! Sockets + zmq_socket_req_inproc = f77_zmq_socket(zmq_context, ZMQ_REQ) + rc = f77_zmq_connect(zmq_socket_req_inproc, 'inproc://req_rep') + if (rc /= 0) then + stop 'Unable to connect zmq_socket_req_inproc' + endif + + zmq_socket_push_inproc = f77_zmq_socket(zmq_context, ZMQ_PUSH) + rc = f77_zmq_connect(zmq_socket_push_inproc, 'inproc://push_pull') + if (rc /= 0) then + stop 'Unable to connect zmq_socket_push_inproc' + endif + + + + rc = f77_zmq_send( zmq_socket_req_inproc, 'get_ao_integrals', 16, 0) + rc = f77_zmq_recv( zmq_socket_req_inproc, l, 4, 0) + + do while (l > 0) + rc = f77_zmq_send( zmq_socket_req_inproc, 'get_ao_integrals', 16, 0) + + do j = 1, l + if (ao_overlap_abs(j,l) < ao_integrals_threshold) then + cycle + endif + call compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value) + rc = f77_zmq_send( zmq_socket_push_inproc, n_integrals, 4, ZMQ_SNDMORE) + rc = f77_zmq_send( zmq_socket_push_inproc, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE) + rc = f77_zmq_send( zmq_socket_push_inproc, buffer_value, integral_kind*n_integrals, 0) + enddo + rc = f77_zmq_recv( zmq_socket_req_inproc, l, 4, 0) + enddo + + deallocate( buffer_i, buffer_value ) + + rc = f77_zmq_disconnect(zmq_socket_req_inproc, 'inproc://req_rep') +end + + +subroutine ao_bielec_integrals_in_map_collector + use map_module + use f77_zmq + implicit none + BEGIN_DOC +! Collects results from the AO integral calculation + END_DOC + + integer :: j,l,n_integrals + integer :: rc + character*(8), external :: zmq_port + integer(ZMQ_PTR) :: zmq_socket_pull_inproc + real(integral_kind), allocatable :: buffer_value(:) + integer(key_kind), allocatable :: buffer_i(:) + + allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) ) + + zmq_socket_pull_inproc = f77_zmq_socket(zmq_context, ZMQ_PULL) + rc = f77_zmq_bind(zmq_socket_pull_inproc, 'inproc://push_pull') + if (rc /= 0) then + stop 'Unable to connect zmq_socket_pull_inproc' + endif + + n_integrals = 0 + do while (n_integrals >= 0) + + rc = f77_zmq_recv( zmq_socket_pull_inproc, n_integrals, 4, 0) + if (n_integrals > -1) then + rc = f77_zmq_recv( zmq_socket_pull_inproc, buffer_i, key_kind*n_integrals, 0) + rc = f77_zmq_recv( zmq_socket_pull_inproc, buffer_value, integral_kind*n_integrals, 0) + call insert_into_ao_integrals_map(n_integrals,buffer_i,buffer_value) + else + rc = f77_zmq_recv( zmq_socket_pull_inproc, buffer_i, key_kind, 0) + rc = f77_zmq_recv( zmq_socket_pull_inproc, buffer_value, integral_kind, 0) + endif + + enddo + + rc = f77_zmq_unbind(zmq_socket_pull_inproc, 'inproc://push_pull') + + deallocate( buffer_i, buffer_value ) +end + diff --git a/src/Integrals_Bielec/map_integrals.irp.f b/src/Integrals_Bielec/map_integrals.irp.f index 83950c5c..84b08715 100644 --- a/src/Integrals_Bielec/map_integrals.irp.f +++ b/src/Integrals_Bielec/map_integrals.irp.f @@ -247,8 +247,7 @@ BEGIN_PROVIDER [ type(map_type), mo_integrals_map ] print*, 'MO map initialized' END_PROVIDER -subroutine insert_into_ao_integrals_map(n_integrals, & - buffer_i, buffer_values) +subroutine insert_into_ao_integrals_map(n_integrals,buffer_i, buffer_values) use map_module implicit none BEGIN_DOC @@ -291,19 +290,43 @@ double precision function get_mo_bielec_integral(i,j,k,l,map) PROVIDE mo_bielec_integrals_in_map !DIR$ FORCEINLINE call bielec_integrals_index(i,j,k,l,idx) + !DIR$ FORCEINLINE call map_get(map,idx,tmp) get_mo_bielec_integral = dble(tmp) end +double precision function get_mo_bielec_integral_schwartz(i,j,k,l,map) + use map_module + implicit none + BEGIN_DOC + ! Returns one integral in the MO basis + END_DOC + integer, intent(in) :: i,j,k,l + integer(key_kind) :: idx + type(map_type), intent(inout) :: map + real(integral_kind) :: tmp + PROVIDE mo_bielec_integrals_in_map + if (mo_bielec_integral_schwartz(i,k)*mo_bielec_integral_schwartz(j,l) > mo_integrals_threshold) then + !DIR$ FORCEINLINE + call bielec_integrals_index(i,j,k,l,idx) + !DIR$ FORCEINLINE + call map_get(map,idx,tmp) + else + tmp = 0.d0 + endif + get_mo_bielec_integral_schwartz = dble(tmp) +end + + double precision function mo_bielec_integral(i,j,k,l) implicit none BEGIN_DOC ! Returns one integral in the MO basis END_DOC integer, intent(in) :: i,j,k,l - double precision :: get_mo_bielec_integral + double precision :: get_mo_bielec_integral_schwartz PROVIDE mo_bielec_integrals_in_map - mo_bielec_integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + mo_bielec_integral = get_mo_bielec_integral_schwartz(i,j,k,l,mo_integrals_map) return end @@ -333,36 +356,40 @@ subroutine get_mo_bielec_integrals(j,k,l,sze,out_val,map) call map_get_many(map, hash, tmp_val, sze) ! Conversion to double precision do i=1,sze - out_val(i) = tmp_val(i) + out_val(i) = dble(tmp_val(i)) enddo endif end -subroutine get_mo_bielec_integrals_existing_ik(j,l,sze,out_array,map) +subroutine get_mo_bielec_integrals_ij(k,l,sze,out_array,map) use map_module implicit none BEGIN_DOC ! Returns multiple integrals in the MO basis, all - ! i(1)j(1) 1/r12 k(2)l(2) - ! i for j,k,l fixed. + ! i(1)j(2) 1/r12 k(1)l(2) + ! i, j for k,l fixed. END_DOC - integer, intent(in) :: j,l, sze - logical, intent(out) :: out_array(sze,sze) + integer, intent(in) :: k,l, sze + double precision, intent(out) :: out_array(sze,sze) type(map_type), intent(inout) :: map - integer :: i,k,kk,ll,m + integer :: i,j,kk,ll,m integer(key_kind),allocatable :: hash(:) integer ,allocatable :: pairs(:,:), iorder(:) + real(integral_kind), allocatable :: tmp_val(:) + PROVIDE mo_bielec_integrals_in_map - allocate (hash(sze*sze), pairs(2,sze*sze),iorder(sze*sze)) + allocate (hash(sze*sze), pairs(2,sze*sze),iorder(sze*sze), & + tmp_val(sze*sze)) kk=0 - do k=1,sze + out_array = 0.d0 + do j=1,sze do i=1,sze kk += 1 !DIR$ FORCEINLINE call bielec_integrals_index(i,j,k,l,hash(kk)) pairs(1,kk) = i - pairs(2,kk) = k + pairs(2,kk) = j iorder(kk) = kk enddo enddo @@ -376,16 +403,16 @@ subroutine get_mo_bielec_integrals_existing_ik(j,l,sze,out_array,map) call i2radix_sort(hash,iorder,kk,-1) endif - call map_exists_many(mo_integrals_map, hash, kk) + call map_get_many(mo_integrals_map, hash, tmp_val, kk) do ll=1,kk m = iorder(ll) i=pairs(1,m) - k=pairs(2,m) - out_array(i,k) = (hash(ll) /= 0_8) + j=pairs(2,m) + out_array(i,j) = tmp_val(ll) enddo - deallocate(pairs,hash,iorder) + deallocate(pairs,hash,iorder,tmp_val) end integer*8 function get_mo_map_size() @@ -396,15 +423,6 @@ integer*8 function get_mo_map_size() get_mo_map_size = mo_integrals_map % n_elements end -subroutine clear_mo_map - implicit none - BEGIN_DOC - ! Frees the memory of the MO map - END_DOC - call map_deinit(mo_integrals_map) - FREE mo_integrals_map -end - BEGIN_TEMPLATE subroutine dump_$ao_integrals(filename) @@ -502,7 +520,8 @@ integer function load_$ao_integrals(filename) integer*8 :: i integer(cache_key_kind), pointer :: key(:) real(integral_kind), pointer :: val(:) - integer :: iknd, kknd, n, j + integer :: iknd, kknd + integer*8 :: n, j load_$ao_integrals = 1 open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN') read(66,err=98,end=98) iknd, kknd @@ -532,12 +551,8 @@ integer function load_$ao_integrals(filename) return 99 continue call map_deinit($ao_integrals_map) - FREE $ao_integrals_map - if (.True.) then - PROVIDE $ao_integrals_map - endif - stop 'Problem reading $ao_integrals_map file in work/' 98 continue + stop 'Problem reading $ao_integrals_map file in work/' end diff --git a/src/Integrals_Bielec/mo_bi_integrals.irp.f b/src/Integrals_Bielec/mo_bi_integrals.irp.f index bc724e9b..83f0ce05 100644 --- a/src/Integrals_Bielec/mo_bi_integrals.irp.f +++ b/src/Integrals_Bielec/mo_bi_integrals.irp.f @@ -102,7 +102,7 @@ subroutine add_integrals_to_map(mask_ijkl) !$OMP mo_coef_transp, & !$OMP mo_coef_transp_is_built, list_ijkl, & !$OMP mo_coef_is_built, wall_1, abort_here, & - !$OMP mo_coef,mo_integrals_threshold,ao_integrals_map,mo_integrals_map,progress_bar,progress_value) + !$OMP mo_coef,mo_integrals_threshold,mo_integrals_map,progress_bar,progress_value) n_integrals = 0 allocate(bielec_tmp_3(mo_tot_num_align, n_j, n_k), & bielec_tmp_1(mo_tot_num_align), & @@ -312,10 +312,9 @@ IRP_ENDIF if (write_mo_integrals) then call dump_mo_integrals(trim(ezfio_filename)//'/work/mo_integrals.bin') - call ezfio_set_integrals_bielec_disk_access_mo_integrals(.True.) + call ezfio_set_integrals_bielec_disk_access_mo_integrals("Read") endif - end @@ -488,3 +487,30 @@ END_PROVIDER enddo END_PROVIDER + +BEGIN_PROVIDER [ double precision, mo_bielec_integral_schwartz,(mo_tot_num,mo_tot_num) ] + implicit none + BEGIN_DOC + ! Needed to compute Schwartz inequalities + END_DOC + + integer :: i,k + + do i=1,mo_tot_num + do k=1,mo_tot_num + mo_bielec_integral_schwartz(k,i) = dsqrt(mo_bielec_integral_jj(k,i)) + enddo + enddo + +END_PROVIDER + + +subroutine clear_mo_map + implicit none + BEGIN_DOC + ! Frees the memory of the MO map + END_DOC + call map_deinit(mo_integrals_map) + FREE mo_integrals_map mo_bielec_integral_schwartz mo_bielec_integral_jj mo_bielec_integral_jj_anti + FREE mo_bielec_integral_jj_exchange mo_bielec_integrals_in_map +end diff --git a/src/Integrals_Bielec/test_integrals.irp.f b/src/Integrals_Bielec/test_integrals.irp.f new file mode 100644 index 00000000..8d590f27 --- /dev/null +++ b/src/Integrals_Bielec/test_integrals.irp.f @@ -0,0 +1,136 @@ +program bench_maps + implicit none + BEGIN_DOC +! Performs timing benchmarks on integral access + END_DOC + integer :: i,j,k,l + integer*8 :: ii,jj + double precision :: r, cpu + integer*8 :: cpu0, cpu1, count_rate, count_max + + PROVIDE mo_bielec_integrals_in_map + print *, mo_tot_num, 'MOs' + + ! Time random function + call system_clock(cpu0, count_rate, count_max) + do ii=1,100000000_8 + call random_number(r) + i = int(r*mo_tot_num)+1 + call random_number(r) + j = int(r*mo_tot_num)+1 + call random_number(r) + k = int(r*mo_tot_num)+1 + call random_number(r) + l = int(r*mo_tot_num)+1 + enddo + call system_clock(cpu1, count_rate, count_max) + cpu = (cpu1-cpu0)/count_rate + print *, 'Random function : ', cpu/dble(ii) + + call system_clock(cpu0, count_rate, count_max) + do ii=1,100000000_8 + call random_number(r) + i = int(r*mo_tot_num)+1 + call random_number(r) + j = int(r*mo_tot_num)+1 + call random_number(r) + k = int(r*mo_tot_num)+1 + call random_number(r) + l = int(r*mo_tot_num)+1 + call get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + enddo + call system_clock(cpu1, count_rate, count_max) + cpu = -cpu + (cpu1 - cpu0)/count_rate + print *, 'Random access : ', cpu/dble(ii) + + ii=0_8 + call system_clock(cpu0, count_rate, count_max) + do jj=1,10 + do l=1,mo_tot_num + do k=1,mo_tot_num + do j=1,mo_tot_num + do i=1,mo_tot_num + ii += 1 + call get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + enddo + enddo + enddo + enddo + enddo + call system_clock(cpu1, count_rate, count_max) + cpu = (cpu1 - cpu0)/count_rate + print *, 'loop ijkl : ', cpu/dble(ii) + + ii=0 + call system_clock(cpu0, count_rate, count_max) + do jj=1,10 + do l=1,mo_tot_num + do j=1,mo_tot_num + do k=1,mo_tot_num + do i=1,mo_tot_num + ii += 1 + call get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + enddo + enddo + enddo + enddo + enddo + call system_clock(cpu1, count_rate, count_max) + cpu = (cpu1 - cpu0)/count_rate + print *, 'loop ikjl : ', cpu/dble(ii) + + ii=0 + call system_clock(cpu0, count_rate, count_max) + do jj=1,10 + do k=1,mo_tot_num + do l=1,mo_tot_num + do j=1,mo_tot_num + do i=1,mo_tot_num + ii += 1 + call get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + enddo + enddo + enddo + enddo + enddo + call system_clock(cpu1, count_rate, count_max) + cpu = (cpu1 - cpu0)/count_rate + print *, 'loop ijlk : ', cpu/dble(ii) + + ii=0 + call system_clock(cpu0, count_rate, count_max) + do jj=1,10 + do i=1,mo_tot_num + do j=1,mo_tot_num + do k=1,mo_tot_num + do l=1,mo_tot_num + ii += 1 + call get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + enddo + enddo + enddo + enddo + enddo + call system_clock(cpu1, count_rate, count_max) + cpu = (cpu1 - cpu0)/count_rate + print *, 'loop lkji : ', cpu/dble(ii) + + ii=0 + call system_clock(cpu0, count_rate, count_max) + do jj=1,10 + do j=1,mo_tot_num + do i=1,mo_tot_num + do k=1,mo_tot_num + do l=1,mo_tot_num + ii += 1 + call get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + enddo + enddo + enddo + enddo + enddo + call system_clock(cpu1, count_rate, count_max) + cpu = (cpu1 - cpu0)/count_rate + print *, 'loop lkij : ', cpu/dble(ii) + +end diff --git a/src/Integrals_Bielec/tree_dependency.png b/src/Integrals_Bielec/tree_dependency.png index 9c58a4ae..4161fd0a 100644 Binary files a/src/Integrals_Bielec/tree_dependency.png and b/src/Integrals_Bielec/tree_dependency.png differ diff --git a/src/Integrals_Monoelec/README.rst b/src/Integrals_Monoelec/README.rst index 13aceb0e..1d2d158b 100644 --- a/src/Integrals_Monoelec/README.rst +++ b/src/Integrals_Monoelec/README.rst @@ -93,6 +93,11 @@ Documentation : sum of the kinetic and nuclear electronic potential +`ao_mono_elec_integral_diag `_ + array of the mono electronic hamiltonian on the AOs basis + : sum of the kinetic and nuclear electronic potential + + `ao_nucl_elec_integral `_ interaction nuclear electron @@ -106,11 +111,11 @@ Documentation Pseudo-potential -`ao_pseudo_integral_local `_ +`ao_pseudo_integral_local `_ Local pseudo-potential -`ao_pseudo_integral_non_local `_ +`ao_pseudo_integral_non_local `_ Local pseudo-potential diff --git a/src/Integrals_Monoelec/ao_mono_ints.irp.f b/src/Integrals_Monoelec/ao_mono_ints.irp.f index a59ed3df..4646326e 100644 --- a/src/Integrals_Monoelec/ao_mono_ints.irp.f +++ b/src/Integrals_Monoelec/ao_mono_ints.irp.f @@ -1,4 +1,5 @@ -BEGIN_PROVIDER [ double precision, ao_mono_elec_integral,(ao_num_align,ao_num)] + BEGIN_PROVIDER [ double precision, ao_mono_elec_integral,(ao_num_align,ao_num)] +&BEGIN_PROVIDER [ double precision, ao_mono_elec_integral_diag,(ao_num)] implicit none integer :: i,j,n,l BEGIN_DOC @@ -6,9 +7,11 @@ BEGIN_PROVIDER [ double precision, ao_mono_elec_integral,(ao_num_align,ao_num)] ! : sum of the kinetic and nuclear electronic potential END_DOC do j = 1, ao_num + !DIR$ VECTOR ALIGNED do i = 1, ao_num ao_mono_elec_integral(i,j) = ao_nucl_elec_integral(i,j) + ao_kinetic_integral(i,j) + ao_pseudo_integral(i,j) enddo + ao_mono_elec_integral_diag(j) = ao_mono_elec_integral(j,j) enddo END_PROVIDER diff --git a/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f b/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f index 95023177..e18bc006 100644 --- a/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f +++ b/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f @@ -5,106 +5,105 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral, (ao_num_align,ao_num)] END_DOC if (do_pseudo) then ao_pseudo_integral = ao_pseudo_integral_local + ao_pseudo_integral_non_local -! ao_pseudo_integral = ao_pseudo_integral_local -! ao_pseudo_integral = ao_pseudo_integral_non_local else ao_pseudo_integral = 0.d0 endif END_PROVIDER - BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_num)] +BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_num)] implicit none BEGIN_DOC -! Local pseudo-potential + ! Local pseudo-potential END_DOC - double precision :: alpha, beta, gama, delta - integer :: num_A,num_B - double precision :: A_center(3),B_center(3),C_center(3) - integer :: power_A(3),power_B(3) - integer :: i,j,k,l,n_pt_in,m - double precision :: Vloc, Vpseudo - - double precision :: cpu_1, cpu_2, wall_1, wall_2, wall_0 - integer :: thread_num - + double precision :: alpha, beta, gama, delta + integer :: num_A,num_B + double precision :: A_center(3),B_center(3),C_center(3) + integer :: power_A(3),power_B(3) + integer :: i,j,k,l,n_pt_in,m + double precision :: Vloc, Vpseudo + + double precision :: cpu_1, cpu_2, wall_1, wall_2, wall_0 + integer :: thread_num + !$ integer :: omp_get_thread_num + ao_pseudo_integral_local = 0.d0 - - !! Dump array - integer, allocatable :: n_k_dump(:) - double precision, allocatable :: v_k_dump(:), dz_k_dump(:) - - allocate(n_k_dump(1:pseudo_klocmax), v_k_dump(1:pseudo_klocmax), dz_k_dump(1:pseudo_klocmax)) - - - ! _ - ! / _. | _ | - ! \_ (_| | (_ |_| | - ! - - print*, 'Providing the nuclear electron pseudo integrals ' - + + !! Dump array + integer, allocatable :: n_k_dump(:) + double precision, allocatable :: v_k_dump(:), dz_k_dump(:) + + allocate(n_k_dump(1:pseudo_klocmax), v_k_dump(1:pseudo_klocmax), dz_k_dump(1:pseudo_klocmax)) + + print*, 'Providing the nuclear electron pseudo integrals (local)' + call wall_time(wall_1) call cpu_time(cpu_1) - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B, & - !$OMP num_A,num_B,Z,c,n_pt_in, & - !$OMP v_k_dump,n_k_dump, dz_k_dump, & - !$OMP wall_0,wall_2,thread_num) & - !$OMP SHARED (ao_num,ao_prim_num,ao_expo_ordered_transp,ao_power,ao_nucl,nucl_coord,ao_coef_normalized_ordered_transp, & - !$OMP ao_pseudo_integral_local,nucl_num,nucl_charge, & - !$OMP pseudo_klocmax,pseudo_lmax,pseudo_kmax,pseudo_v_k,pseudo_n_k, pseudo_dz_k, & - !$OMP wall_1) + thread_num = 0 + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B,& + !$OMP num_A,num_B,Z,c,n_pt_in, & + !$OMP v_k_dump,n_k_dump, dz_k_dump, & + !$OMP wall_0,wall_2,thread_num) & + !$OMP SHARED (ao_num,ao_prim_num,ao_expo_ordered_transp,ao_power,ao_nucl,nucl_coord,ao_coef_normalized_ordered_transp,& + !$OMP ao_pseudo_integral_local,nucl_num,nucl_charge, & + !$OMP pseudo_klocmax,pseudo_lmax,pseudo_kmax,pseudo_v_k,pseudo_n_k, pseudo_dz_k,& + !$OMP wall_1) + + !$ thread_num = omp_get_thread_num() !$OMP DO SCHEDULE (guided) - + do j = 1, ao_num - - num_A = ao_nucl(j) - power_A(1:3)= ao_power(j,1:3) - A_center(1:3) = nucl_coord(num_A,1:3) - - do i = 1, ao_num - - num_B = ao_nucl(i) - power_B(1:3)= ao_power(i,1:3) - B_center(1:3) = nucl_coord(num_B,1:3) - - do l=1,ao_prim_num(j) - alpha = ao_expo_ordered_transp(l,j) - - do m=1,ao_prim_num(i) - beta = ao_expo_ordered_transp(m,i) - double precision :: c - c = 0.d0 - - do k = 1, nucl_num - double precision :: Z - Z = nucl_charge(k) - - C_center(1:3) = nucl_coord(k,1:3) - - v_k_dump = pseudo_v_k(k,1:pseudo_klocmax) - n_k_dump = pseudo_n_k(k,1:pseudo_klocmax) - dz_k_dump = pseudo_dz_k(k,1:pseudo_klocmax) - - c = c + Vloc(pseudo_klocmax, v_k_dump,n_k_dump, dz_k_dump, & - A_center,power_A,alpha,B_center,power_B,beta,C_center) - + + num_A = ao_nucl(j) + power_A(1:3)= ao_power(j,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) + + do i = 1, ao_num + + num_B = ao_nucl(i) + power_B(1:3)= ao_power(i,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) + + do l=1,ao_prim_num(j) + alpha = ao_expo_ordered_transp(l,j) + + do m=1,ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) + double precision :: c + c = 0.d0 + + if (dabs(ao_coef_normalized_ordered_transp(l,j)*ao_coef_normalized_ordered_transp(m,i))& + < 1.d-10) then + cycle + endif + do k = 1, nucl_num + double precision :: Z + Z = nucl_charge(k) + + C_center(1:3) = nucl_coord(k,1:3) + + v_k_dump = pseudo_v_k(k,1:pseudo_klocmax) + n_k_dump = pseudo_n_k(k,1:pseudo_klocmax) + dz_k_dump = pseudo_dz_k(k,1:pseudo_klocmax) + + c = c + Vloc(pseudo_klocmax, v_k_dump,n_k_dump, dz_k_dump,& + A_center,power_A,alpha,B_center,power_B,beta,C_center) + + enddo + ao_pseudo_integral_local(i,j) = ao_pseudo_integral_local(i,j) +& + ao_coef_normalized_ordered_transp(l,j)*ao_coef_normalized_ordered_transp(m,i)*c + enddo enddo - ao_pseudo_integral_local(i,j) = ao_pseudo_integral_local(i,j) + & - ao_coef_normalized_ordered_transp(l,j)*ao_coef_normalized_ordered_transp(m,i)*c - enddo - enddo - enddo - + enddo + call wall_time(wall_2) if (thread_num == 0) then if (wall_2 - wall_0 > 1.d0) then wall_0 = wall_2 - print*, 100.*float(j)/float(ao_num), '% in ', & - wall_2-wall_1, 's' + print*, 100.*float(j)/float(ao_num), '% in ', & + wall_2-wall_1, 's' endif endif enddo @@ -121,106 +120,108 @@ END_PROVIDER BEGIN_PROVIDER [ double precision, ao_pseudo_integral_non_local, (ao_num_align,ao_num)] implicit none BEGIN_DOC -! Local pseudo-potential + ! Local pseudo-potential END_DOC - double precision :: alpha, beta, gama, delta - integer :: num_A,num_B - double precision :: A_center(3),B_center(3),C_center(3) - integer :: power_A(3),power_B(3) - integer :: i,j,k,l,n_pt_in,m - double precision :: Vloc, Vpseudo - - double precision :: cpu_1, cpu_2, wall_1, wall_2, wall_0 - integer :: thread_num - + double precision :: alpha, beta, gama, delta + integer :: num_A,num_B + double precision :: A_center(3),B_center(3),C_center(3) + integer :: power_A(3),power_B(3) + integer :: i,j,k,l,n_pt_in,m + double precision :: Vloc, Vpseudo + !$ integer :: omp_get_thread_num + + double precision :: cpu_1, cpu_2, wall_1, wall_2, wall_0 + integer :: thread_num + ao_pseudo_integral_non_local = 0.d0 - - !! Dump array - integer, allocatable :: n_kl_dump(:,:) - double precision, allocatable :: v_kl_dump(:,:), dz_kl_dump(:,:) - - allocate(n_kl_dump(pseudo_kmax,0:pseudo_lmax), v_kl_dump(pseudo_kmax,0:pseudo_lmax), dz_kl_dump(pseudo_kmax,0:pseudo_lmax)) - - ! _ - ! / _. | _ | - ! \_ (_| | (_ |_| | - ! - - print*, 'Providing the nuclear electron pseudo integrals ' - + + !! Dump array + integer, allocatable :: n_kl_dump(:,:) + double precision, allocatable :: v_kl_dump(:,:), dz_kl_dump(:,:) + + allocate(n_kl_dump(pseudo_kmax,0:pseudo_lmax), v_kl_dump(pseudo_kmax,0:pseudo_lmax), dz_kl_dump(pseudo_kmax,0:pseudo_lmax)) + + print*, 'Providing the nuclear electron pseudo integrals (non-local)' + call wall_time(wall_1) call cpu_time(cpu_1) - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B, & - !$OMP num_A,num_B,Z,c,n_pt_in, & - !$OMP n_kl_dump, v_kl_dump, dz_kl_dump, & - !$OMP wall_0,wall_2,thread_num) & - !$OMP SHARED (ao_num,ao_prim_num,ao_expo_ordered_transp,ao_power,ao_nucl,nucl_coord,ao_coef_normalized_ordered_transp, & - !$OMP ao_pseudo_integral_non_local,nucl_num,nucl_charge, & - !$OMP pseudo_klocmax,pseudo_lmax,pseudo_kmax,pseudo_n_kl, pseudo_v_kl, pseudo_dz_kl, & - !$OMP wall_1) + thread_num = 0 + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B,& + !$OMP num_A,num_B,Z,c,n_pt_in, & + !$OMP n_kl_dump, v_kl_dump, dz_kl_dump, & + !$OMP wall_0,wall_2,thread_num) & + !$OMP SHARED (ao_num,ao_prim_num,ao_expo_ordered_transp,ao_power,ao_nucl,nucl_coord,ao_coef_normalized_ordered_transp,& + !$OMP ao_pseudo_integral_non_local,nucl_num,nucl_charge,& + !$OMP pseudo_klocmax,pseudo_lmax,pseudo_kmax,pseudo_n_kl, pseudo_v_kl, pseudo_dz_kl,& + !$OMP wall_1) + !$ thread_num = omp_get_thread_num() !$OMP DO SCHEDULE (guided) - + do j = 1, ao_num - - num_A = ao_nucl(j) - power_A(1:3)= ao_power(j,1:3) - A_center(1:3) = nucl_coord(num_A,1:3) - - do i = 1, ao_num - - num_B = ao_nucl(i) - power_B(1:3)= ao_power(i,1:3) - B_center(1:3) = nucl_coord(num_B,1:3) - - do l=1,ao_prim_num(j) - alpha = ao_expo_ordered_transp(l,j) - - do m=1,ao_prim_num(i) - beta = ao_expo_ordered_transp(m,i) - double precision :: c - c = 0.d0 - - do k = 1, nucl_num - double precision :: Z - Z = nucl_charge(k) - - C_center(1:3) = nucl_coord(k,1:3) - - n_kl_dump = pseudo_n_kl(k,1:pseudo_kmax,0:pseudo_lmax) - v_kl_dump = pseudo_v_kl(k,1:pseudo_kmax,0:pseudo_lmax) - dz_kl_dump = pseudo_dz_kl(k,1:pseudo_kmax,0:pseudo_lmax) - - c = c + Vpseudo(pseudo_lmax,pseudo_kmax,v_kl_dump,n_kl_dump,dz_kl_dump,A_center,power_A,alpha,B_center,power_B,beta,C_center) - + + num_A = ao_nucl(j) + power_A(1:3)= ao_power(j,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) + + do i = 1, ao_num + + num_B = ao_nucl(i) + power_B(1:3)= ao_power(i,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) + + do l=1,ao_prim_num(j) + alpha = ao_expo_ordered_transp(l,j) + + do m=1,ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) + double precision :: c + c = 0.d0 + + if (dabs(ao_coef_normalized_ordered_transp(l,j)*ao_coef_normalized_ordered_transp(m,i))& + < 1.d-10) then + cycle + endif + + do k = 1, nucl_num + double precision :: Z + Z = nucl_charge(k) + + C_center(1:3) = nucl_coord(k,1:3) + + n_kl_dump = pseudo_n_kl(k,1:pseudo_kmax,0:pseudo_lmax) + v_kl_dump = pseudo_v_kl(k,1:pseudo_kmax,0:pseudo_lmax) + dz_kl_dump = pseudo_dz_kl(k,1:pseudo_kmax,0:pseudo_lmax) + + c = c + Vpseudo(pseudo_lmax,pseudo_kmax,v_kl_dump,n_kl_dump,dz_kl_dump,A_center,power_A,alpha,B_center,power_B,beta,C_center) + + enddo + ao_pseudo_integral_non_local(i,j) = ao_pseudo_integral_non_local(i,j) +& + ao_coef_normalized_ordered_transp(l,j)*ao_coef_normalized_ordered_transp(m,i)*c + enddo enddo - ao_pseudo_integral_non_local(i,j) = ao_pseudo_integral_non_local(i,j) + & - ao_coef_normalized_ordered_transp(l,j)*ao_coef_normalized_ordered_transp(m,i)*c - enddo - enddo - enddo - + enddo + call wall_time(wall_2) if (thread_num == 0) then if (wall_2 - wall_0 > 1.d0) then wall_0 = wall_2 - print*, 100.*float(j)/float(ao_num), '% in ', & - wall_2-wall_1, 's' + print*, 100.*float(j)/float(ao_num), '% in ', & + wall_2-wall_1, 's' endif endif enddo - - !$OMP END DO - !$OMP END PARALLEL - - + + !$OMP END DO + !$OMP END PARALLEL + + deallocate(n_kl_dump,v_kl_dump, dz_kl_dump) - - - END_PROVIDER + + +END_PROVIDER diff --git a/src/Integrals_Monoelec/pseudopot.f90 b/src/Integrals_Monoelec/pseudopot.f90 index bd00dc51..32402c74 100644 --- a/src/Integrals_Monoelec/pseudopot.f90 +++ b/src/Integrals_Monoelec/pseudopot.f90 @@ -197,8 +197,8 @@ integer, intent(in) :: n_a(3),n_b(3) double precision, intent(in) :: v_kl(kmax,0:lmax),dz_kl(kmax,0:lmax) ! -! | _ _ _. | _ -! |_ (_) (_ (_| | (/_ +! | _ _ _. | +! |_ (_) (_ (_| | ! double precision :: fourpi,f,prod,prodp,binom_func,accu,bigR,bigI,ylm @@ -214,18 +214,14 @@ integer :: l,k, nkl_max ! |_) | (_| (_| | | (_| \/ ! _| / -double precision, allocatable :: array_coefs_A(:,:,:) -double precision, allocatable :: array_coefs_B(:,:,:) +double precision, allocatable :: array_coefs_A(:,:) +double precision, allocatable :: array_coefs_B(:,:) double precision, allocatable :: array_R(:,:,:,:,:) double precision, allocatable :: array_I_A(:,:,:,:,:) double precision, allocatable :: array_I_B(:,:,:,:,:) - -! _ -! / _. | _ | -! \_ (_| | (_ |_| | -! +double precision :: f1, f2, f3 if (kmax.eq.1.and.lmax.eq.0.and.v_kl(1,0).eq.0.d0) then Vpseudo=0.d0 @@ -235,7 +231,7 @@ end if fourpi=4.d0*dacos(-1.d0) ac=dsqrt((a(1)-c(1))**2+(a(2)-c(2))**2+(a(3)-c(3))**2) bc=dsqrt((b(1)-c(1))**2+(b(2)-c(2))**2+(b(3)-c(3))**2) -arg=g_a*ac**2+g_b*bc**2 +arg= g_a*ac*ac + g_b*bc*bc if(arg.gt.-dlog(1.d-20))then Vpseudo=0.d0 @@ -255,14 +251,14 @@ nkl_max=4 ! A l l o c a t e ! !=!=!=!=!=!=!=!=!=! -allocate (array_coefs_A(0:ntot,0:ntot,0:ntot)) -allocate (array_coefs_B(0:ntot,0:ntot,0:ntot)) +allocate (array_coefs_A(0:ntot,3)) +allocate (array_coefs_B(0:ntot,3)) -allocate (array_R(0:ntot+nkl_max,kmax,0:lmax,0:lmax+ntot,0:lmax+ntot)) +allocate (array_R(kmax,0:ntot+nkl_max,0:lmax,0:lmax+ntot,0:lmax+ntot)) -allocate (array_I_A(0:lmax+ntot,-(lmax+ntot):lmax+ntot,0:ntot,0:ntot,0:ntot)) - -allocate (array_I_B(0:lmax+ntot,-(lmax+ntot):lmax+ntot,0:ntot,0:ntot,0:ntot)) +allocate (array_I_A(-(lmax+ntot):lmax+ntot,0:lmax+ntot,0:ntot,0:ntot,0:ntot)) + +allocate (array_I_B(-(lmax+ntot):lmax+ntot,0:lmax+ntot,0:ntot,0:ntot,0:ntot)) if(ac.eq.0.d0.and.bc.eq.0.d0)then @@ -289,6 +285,21 @@ if(ac.eq.0.d0.and.bc.eq.0.d0)then enddo enddo enddo +! do k=1,kmax +! do l=0,lmax +! ktot=ntot+n_kl(k,l) +! do m=-l,l +! prod =bigI(0,0,l,m,n_a(1),n_a(2),n_a(3))*v_kl(k,l) +! prodp=bigI(0,0,l,m,n_b(1),n_b(2),n_b(3))*prod +! if (dabs (prodp) < 1.d-15) then +! cycle +! endif +! +! accu=accu+prodp*int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),0,0,areal,breal,arg) +! +! enddo +! enddo +! enddo !=!=!=!=! ! E n d ! @@ -310,108 +321,110 @@ else if(ac.ne.0.d0.and.bc.ne.0.d0)then phi_BC0=datan2((b(2)-c(2))/bc,(b(1)-c(1))/bc) - - - do ktot=0,ntotA+ntotB+nkl_max + do lambdap=0,lmax+ntotB do lambda=0,lmax+ntotA - do lambdap=0,lmax+ntotB + do l=0,lmax + do ktot=0,ntotA+ntotB+nkl_max do k=1,kmax - do l=0,lmax - array_R(ktot,k,l,lambda,lambdap)= int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),lambda,lambdap,areal,breal,arg) - enddo - enddo - enddo + array_R(k,ktot,l,lambda,lambdap)= int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),lambda,lambdap,areal,breal,arg) + enddo + enddo + enddo enddo enddo - + do k1=0,n_a(1) + array_coefs_A(k1,1) = binom_func(n_a(1),k1)*(c(1)-a(1))**(n_a(1)-k1) + enddo do k2=0,n_a(2) + array_coefs_A(k2,2) = binom_func(n_a(2),k2)*(c(2)-a(2))**(n_a(2)-k2) + enddo do k3=0,n_a(3) - array_coefs_A(k1,k2,k3)=binom_func(n_a(1),k1)*binom_func(n_a(2),k2)*binom_func(n_a(3),k3) & - *(c(1)-a(1))**(n_a(1)-k1)*(c(2)-a(2))**(n_a(2)-k2)*(c(3)-a(3))**(n_a(3)-k3) - enddo - enddo + array_coefs_A(k3,3) = binom_func(n_a(3),k3)*(c(3)-a(3))**(n_a(3)-k3) enddo do k1p=0,n_b(1) + array_coefs_B(k1p,1) = binom_func(n_b(1),k1p)*(c(1)-b(1))**(n_b(1)-k1p) + enddo do k2p=0,n_b(2) + array_coefs_B(k2p,2) = binom_func(n_b(2),k2p)*(c(2)-b(2))**(n_b(2)-k2p) + enddo do k3p=0,n_b(3) - array_coefs_B(k1p,k2p,k3p)=binom_func(n_b(1),k1p)*binom_func(n_b(2),k2p)*binom_func(n_b(3),k3p) & - *(c(1)-b(1))**(n_b(1)-k1p)*(c(2)-b(2))**(n_b(2)-k2p)*(c(3)-b(3))**(n_b(3)-k3p) + array_coefs_B(k3p,3) = binom_func(n_b(3),k3p)*(c(3)-b(3))**(n_b(3)-k3p) enddo - enddo - enddo - + !=!=!=!=!=!=!=! ! c a l c u l ! !=!=!=!=!=!=!=! accu=0.d0 do l=0,lmax - do m=-l,l - - do lambda=0,l+ntotA - do mu=-lambda,lambda - do k1=0,n_a(1) - do k2=0,n_a(2) - do k3=0,n_a(3) - array_I_A(lambda,mu,k1,k2,k3)=bigI(lambda,mu,l,m,k1,k2,k3) + do m=-l,l + + do k3=0,n_a(3) + do k2=0,n_a(2) + do k1=0,n_a(1) + do lambda=0,l+ntotA + do mu=-lambda,lambda + array_I_A(mu,lambda,k1,k2,k3)=bigI(lambda,mu,l,m,k1,k2,k3) + enddo enddo - enddo - enddo - enddo + enddo enddo - - do lambdap=0,l+ntotB - do mup=-lambdap,lambdap - do k1p=0,n_b(1) - do k2p=0,n_b(2) - do k3p=0,n_b(3) - array_I_B(lambdap,mup,k1p,k2p,k3p)=bigI(lambdap,mup,l,m,k1p,k2p,k3p) - enddo - enddo - enddo - enddo + enddo + + do k3p=0,n_b(3) + do k2p=0,n_b(2) + do k1p=0,n_b(1) + do lambdap=0,l+ntotB + do mup=-lambdap,lambdap + array_I_B(mup,lambdap,k1p,k2p,k3p)=bigI(lambdap,mup,l,m,k1p,k2p,k3p) + enddo + enddo + enddo enddo - - do lambda=0,l+ntotA - do mu=-lambda,lambda - - do k1=0,n_a(1) - do k2=0,n_a(2) - do k3=0,n_a(3) - - prod=ylm(lambda,mu,theta_AC0,phi_AC0)*array_coefs_A(k1,k2,k3)*array_I_A(lambda,mu,k1,k2,k3) - - do lambdap=0,l+ntotB - do mup=-lambdap,lambdap - - do k1p=0,n_b(1) - do k2p=0,n_b(2) - do k3p=0,n_b(3) - - prodp=ylm(lambdap,mup,theta_BC0,phi_BC0)*array_coefs_B(k1p,k2p,k3p)*array_I_B(lambdap,mup,k1p,k2p,k3p) - - do k=1,kmax - ktot=k1+k2+k3+k1p+k2p+k3p+n_kl(k,l) - accu=accu+prod*prodp*v_kl(k,l)*array_R(ktot,k,l,lambda,lambdap) - enddo - - enddo - enddo - enddo - + enddo + + do k3=0,n_a(3) + do k2=0,n_a(2) + do k1=0,n_a(1) + + do lambda=0,l+ntotA + do mu=-lambda,lambda + + prod=ylm(lambda,mu,theta_AC0,phi_AC0)*array_coefs_A(k1,1)*array_coefs_A(k2,2)*array_coefs_A(k3,3)*array_I_A(mu,lambda,k1,k2,k3) + + + do k3p=0,n_b(3) + do k2p=0,n_b(2) + do k1p=0,n_b(1) + do lambdap=0,l+ntotB + do mup=-lambdap,lambdap + + prodp=prod*ylm(lambdap,mup,theta_BC0,phi_BC0)* & + array_coefs_B(k1p,1)*array_coefs_B(k2p,2)*array_coefs_B(k3p,3)* & + array_I_B(mup,lambdap,k1p,k2p,k3p) + + do k=1,kmax + ktot=k1+k2+k3+k1p+k2p+k3p+n_kl(k,l) + accu=accu+prodp*v_kl(k,l)*array_R(k,ktot,l,lambda,lambdap) + enddo + + enddo + enddo + enddo + + enddo enddo - enddo - - enddo - enddo - enddo - - enddo + + enddo + enddo + enddo + enddo - - enddo + enddo + + enddo enddo !=!=!=!=! @@ -434,24 +447,24 @@ else if(ac.eq.0.d0.and.bc.ne.0.d0)then breal=2.d0*g_b*bc freal=dexp(-g_a*ac**2-g_b*bc**2) - do ktot=0,ntotA+ntotB+nkl_max - do lambdap=0,lmax+ntotB - do k=1,kmax - do l=0,lmax - array_R(ktot,k,l,0,lambdap)= int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),0,lambdap,areal,breal,arg) + do lambdap=0,lmax+ntotB + do l=0,lmax + do ktot=0,ntotA+ntotB+nkl_max + do k=1,kmax + array_R(k,ktot,l,0,lambdap)= int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),0,lambdap,areal,breal,arg) enddo - enddo - enddo + enddo + enddo enddo do k1p=0,n_b(1) + array_coefs_B(k1p,1) = binom_func(n_b(1),k1p)*(c(1)-b(1))**(n_b(1)-k1p) + enddo do k2p=0,n_b(2) + array_coefs_B(k2p,2) = binom_func(n_b(2),k2p)*(c(2)-b(2))**(n_b(2)-k2p) + enddo do k3p=0,n_b(3) - - array_coefs_B(k1p,k2p,k3p)=binom_func(n_b(1),k1p)*binom_func(n_b(2),k2p)*binom_func(n_b(3),k3p) & - *(c(1)-b(1))**(n_b(1)-k1p)*(c(2)-b(2))**(n_b(2)-k2p)*(c(3)-b(3))**(n_b(3)-k3p) - enddo - enddo + array_coefs_B(k3p,3) = binom_func(n_b(3),k3p)*(c(3)-b(3))**(n_b(3)-k3p) enddo !=!=!=!=!=!=!=! @@ -460,43 +473,43 @@ else if(ac.eq.0.d0.and.bc.ne.0.d0)then accu=0.d0 do l=0,lmax - do m=-l,l - - do lambdap=0,l+ntotB - do mup=-lambdap,lambdap - do k1p=0,n_b(1) - do k2p=0,n_b(2) - do k3p=0,n_b(3) - array_I_B(lambdap,mup,k1p,k2p,k3p)=bigI(lambdap,mup,l,m,k1p,k2p,k3p) - enddo - enddo - enddo - enddo - enddo - - prod=bigI(0,0,l,m,n_a(1),n_a(2),n_a(3)) - - do lambdap=0,l+ntotB - do mup=-lambdap,lambdap + do m=-l,l + + do k3p=0,n_b(3) + do k2p=0,n_b(2) do k1p=0,n_b(1) - do k2p=0,n_b(2) - do k3p=0,n_b(3) - - prodp=array_coefs_B(k1p,k2p,k3p)*ylm(lambdap,mup,theta_BC0,phi_BC0)*array_I_B(lambdap,mup,k1p,k2p,k3p) - - do k=1,kmax - - ktot=ntotA+k1p+k2p+k3p+n_kl(k,l) - accu=accu+prod*prodp*v_kl(k,l)*array_R(ktot,k,l,0,lambdap) - - enddo - - enddo - enddo + do lambdap=0,l+ntotB + do mup=-lambdap,lambdap + array_I_B(mup,lambdap,k1p,k2p,k3p)=bigI(lambdap,mup,l,m,k1p,k2p,k3p) + enddo + enddo enddo + enddo enddo - enddo - enddo + + prod=bigI(0,0,l,m,n_a(1),n_a(2),n_a(3)) + + do k3p=0,n_b(3) + do k2p=0,n_b(2) + do k1p=0,n_b(1) + do lambdap=0,l+ntotB + do mup=-lambdap,lambdap + + prodp=prod*array_coefs_B(k1p,1)*array_coefs_B(k2p,2)*array_coefs_B(k3p,3)*ylm(lambdap,mup,theta_BC0,phi_BC0)*array_I_B(mup,lambdap,k1p,k2p,k3p) + + do k=1,kmax + + ktot=ntotA+k1p+k2p+k3p+n_kl(k,l) + accu=accu+prodp*v_kl(k,l)*array_R(k,ktot,l,0,lambdap) + + enddo + + enddo + enddo + enddo + enddo + enddo + enddo enddo !=!=!=!=! @@ -519,26 +532,24 @@ else if(ac.ne.0.d0.and.bc.eq.0.d0)then breal=2.d0*g_b*bc freal=dexp(-g_a*ac**2-g_b*bc**2) - do ktot=0,ntotA+ntotB+nkl_max - do lambda=0,lmax+ntotA - do k=1,kmax - do l=0,lmax - - array_R(ktot,k,l,lambda,0)= int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),lambda,0,areal,breal,arg) - enddo - enddo - enddo + do lambda=0,lmax+ntotA + do l=0,lmax + do ktot=0,ntotA+ntotB+nkl_max + do k=1,kmax + array_R(k,ktot,l,lambda,0)= int_prod_bessel(ktot+2,g_a+g_b+dz_kl(k,l),lambda,0,areal,breal,arg) + enddo + enddo + enddo enddo do k1=0,n_a(1) + array_coefs_A(k1,1) = binom_func(n_a(1),k1)*(c(1)-a(1))**(n_a(1)-k1) + enddo do k2=0,n_a(2) + array_coefs_A(k2,2) = binom_func(n_a(2),k2)*(c(2)-a(2))**(n_a(2)-k2) + enddo do k3=0,n_a(3) - - array_coefs_A(k1,k2,k3)=binom_func(n_a(1),k1)*binom_func(n_a(2),k2)*binom_func(n_a(3),k3) & - *(c(1)-a(1))**(n_a(1)-k1)*(c(2)-a(2))**(n_a(2)-k2)*(c(3)-a(3))**(n_a(3)-k3) - - enddo - enddo + array_coefs_A(k3,3) = binom_func(n_a(3),k3)*(c(3)-a(3))**(n_a(3)-k3) enddo !=!=!=!=!=!=!=! @@ -549,36 +560,36 @@ else if(ac.ne.0.d0.and.bc.eq.0.d0)then do l=0,lmax do m=-l,l - do lambda=0,l+ntotA - do mu=-lambda,lambda + do k3=0,n_a(3) + do k2=0,n_a(2) do k1=0,n_a(1) - do k2=0,n_a(2) - do k3=0,n_a(3) - array_I_A(lambda,mu,k1,k2,k3)=bigI(lambda,mu,l,m,k1,k2,k3) - enddo - enddo + do lambda=0,l+ntotA + do mu=-lambda,lambda + array_I_A(mu,lambda,k1,k2,k3)=bigI(lambda,mu,l,m,k1,k2,k3) + enddo + enddo enddo enddo enddo - do lambda=0,l+ntotA - do mu=-lambda,lambda + do k3=0,n_a(3) + do k2=0,n_a(2) do k1=0,n_a(1) - do k2=0,n_a(2) - do k3=0,n_a(3) - - prod=array_coefs_A(k1,k2,k3)*ylm(lambda,mu,theta_AC0,phi_AC0)*array_I_A(lambda,mu,k1,k2,k3) - prodp=bigI(0,0,l,m,n_b(1),n_b(2),n_b(3)) - - do k=1,kmax - ktot=k1+k2+k3+ntotB+n_kl(k,l) - accu=accu+prod*prodp*v_kl(k,l)*array_R(ktot,k,l,lambda,0) + do lambda=0,l+ntotA + do mu=-lambda,lambda + + prod=array_coefs_A(k1,1)*array_coefs_A(k2,2)*array_coefs_A(k3,3)*ylm(lambda,mu,theta_AC0,phi_AC0)*array_I_A(mu,lambda,k1,k2,k3) + prodp=prod*bigI(0,0,l,m,n_b(1),n_b(2),n_b(3)) + + do k=1,kmax + ktot=k1+k2+k3+ntotB+n_kl(k,l) + accu=accu+prodp*v_kl(k,l)*array_R(k,ktot,l,lambda,0) + enddo + + enddo enddo - enddo - enddo - enddo - enddo + enddo enddo enddo @@ -624,8 +635,8 @@ double precision, intent(in) :: v_kl(kmax,0:lmax),dz_kl(kmax,0:lmax) double precision, intent(in) :: rmax ! -! | _ _ _. | _ -! |_ (_) (_ (_| | (/_ +! | _ _ _. | +! |_ (_) (_ (_| | ! integer :: l,m,k,kk @@ -850,22 +861,27 @@ implicit none integer lambda,mu,l,m,k1,k2,k3 integer k,i,kp,ip double precision pi,sum,factor1,factor2,cylm,cylmp,bigA,binom_func,fact,coef_pm +double precision sgn, sgnp pi=dacos(-1.d0) if(mu.gt.0.and.m.gt.0)then sum=0.d0 -factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(4.d0*pi*fact(lambda+iabs(mu)))) -factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(4.d0*pi*fact(l+iabs(m)))) +factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(2.d0*pi*fact(lambda+iabs(mu)))) +factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(2.d0*pi*fact(l+iabs(m)))) +sgn = 1.d0 do k=0,mu/2 do i=0,lambda-mu + sgnp = 1.d0 do kp=0,m/2 do ip=0,l-m - cylm=(-1.d0)**k*factor1*dsqrt(2.d0)*binom_func(mu,2*k)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) - cylmp=(-1.d0)**kp*factor2*dsqrt(2.d0)*binom_func(m,2*kp)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) + cylm=sgn*factor1*binom_func(mu,2*k)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) + cylmp=sgnp*factor2*binom_func(m,2*kp)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) sum=sum+cylm*cylmp*bigA(mu-2*k+m-2*kp+k1,2*k+2*kp+k2,i+ip+k3) enddo + sgnp = -sgnp enddo enddo + sgn = -sgn enddo bigI=sum return @@ -888,15 +904,17 @@ endif if(mu.eq.0.and.m.gt.0)then factor1=dsqrt((2*lambda+1)/(4.d0*pi)) -factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(4.d0*pi*fact(l+iabs(m)))) +factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(2.d0*pi*fact(l+iabs(m)))) sum=0.d0 do i=0,lambda + sgnp = 1.d0 do kp=0,m/2 do ip=0,l-m cylm=factor1*coef_pm(lambda,i) - cylmp=(-1.d0)**kp*factor2*dsqrt(2.d0)*binom_func(m,2*kp)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) + cylmp=sgnp*factor2*binom_func(m,2*kp)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) sum=sum+cylm*cylmp*bigA(m-2*kp+k1,2*kp+k2,i+ip+k3) enddo + sgnp = -sgnp enddo enddo bigI=sum @@ -905,16 +923,18 @@ endif if(mu.gt.0.and.m.eq.0)then sum=0.d0 -factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(4.d0*pi*fact(lambda+iabs(mu)))) +factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(2.d0*pi*fact(lambda+iabs(mu)))) factor2=dsqrt((2*l+1)/(4.d0*pi)) +sgn = 1.d0 do k=0,mu/2 do i=0,lambda-mu do ip=0,l - cylm=(-1.d0)**k*factor1*dsqrt(2.d0)*binom_func(mu,2*k)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) + cylm=sgn*factor1*binom_func(mu,2*k)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) cylmp=factor2*coef_pm(l,ip) sum=sum+cylm*cylmp*bigA(mu-2*k +k1,2*k +k2,i+ip +k3) enddo enddo + sgn = -sgn enddo bigI=sum return @@ -923,19 +943,23 @@ endif if(mu.lt.0.and.m.lt.0)then mu=-mu m=-m -factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(4.d0*pi*fact(lambda+iabs(mu)))) -factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(4.d0*pi*fact(l+iabs(m)))) +factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(2.d0*pi*fact(lambda+iabs(mu)))) +factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(2.d0*pi*fact(l+iabs(m)))) sum=0.d0 +sgn = 1.d0 do k=0,(mu-1)/2 do i=0,lambda-mu + sgnp = 1.d0 do kp=0,(m-1)/2 do ip=0,l-m - cylm=(-1.d0)**k*factor1*dsqrt(2.d0)*binom_func(mu,2*k+1)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) - cylmp=(-1.d0)**kp*factor2*dsqrt(2.d0)*binom_func(m,2*kp+1)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) + cylm=sgn*factor1*binom_func(mu,2*k+1)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) + cylmp=sgnp*factor2*binom_func(m,2*kp+1)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) sum=sum+cylm*cylmp*bigA(mu-(2*k+1)+m-(2*kp+1)+k1,(2*k+1)+(2*kp+1)+k2,i+ip+k3) enddo + sgnp = -sgnp enddo enddo + sgn = -sgn enddo mu=-mu m=-m @@ -946,15 +970,17 @@ endif if(mu.eq.0.and.m.lt.0)then m=-m factor1=dsqrt((2*lambda+1)/(4.d0*pi)) -factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(4.d0*pi*fact(l+iabs(m)))) +factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(2.d0*pi*fact(l+iabs(m)))) sum=0.d0 do i=0,lambda + sgnp = 1.d0 do kp=0,(m-1)/2 do ip=0,l-m cylm=factor1*coef_pm(lambda,i) - cylmp=(-1.d0)**kp*factor2*dsqrt(2.d0)*binom_func(m,2*kp+1)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) + cylmp=sgnp*factor2*binom_func(m,2*kp+1)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) sum=sum+cylm*cylmp*bigA(m-(2*kp+1)+k1,2*kp+1+k2,i+ip+k3) enddo + sgnp = -sgnp enddo enddo m=-m @@ -965,16 +991,18 @@ endif if(mu.lt.0.and.m.eq.0)then sum=0.d0 mu=-mu -factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(4.d0*pi*fact(lambda+iabs(mu)))) +factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(2.d0*pi*fact(lambda+iabs(mu)))) factor2=dsqrt((2*l+1)/(4.d0*pi)) +sgn = 1.d0 do k=0,(mu-1)/2 do i=0,lambda-mu do ip=0,l - cylm=(-1.d0)**k*factor1*dsqrt(2.d0)*binom_func(mu,2*k+1)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) + cylm=sgn*factor1*binom_func(mu,2*k+1)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) cylmp=factor2*coef_pm(l,ip) sum=sum+cylm*cylmp*bigA(mu-(2*k+1)+k1,2*k+1+k2,i+ip+k3) enddo enddo + sgn = -sgn enddo mu=-mu bigI=sum @@ -983,19 +1011,23 @@ endif if(mu.gt.0.and.m.lt.0)then sum=0.d0 -factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(4.d0*pi*fact(lambda+iabs(mu)))) -factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(4.d0*pi*fact(l+iabs(m)))) +factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(2.d0*pi*fact(lambda+iabs(mu)))) +factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(2.d0*pi*fact(l+iabs(m)))) m=-m +sgn=1.d0 do k=0,mu/2 do i=0,lambda-mu + sgnp=1.d0 do kp=0,(m-1)/2 do ip=0,l-m - cylm=(-1.d0)**k*factor1*dsqrt(2.d0)*binom_func(mu,2*k)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) - cylmp=(-1.d0)**kp*factor2*dsqrt(2.d0)*binom_func(m,2*kp+1)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) + cylm =sgn *factor1*binom_func(mu,2*k)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) + cylmp=sgnp*factor2*binom_func(m,2*kp+1)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) sum=sum+cylm*cylmp*bigA(mu-2*k+m-(2*kp+1)+k1,2*k+2*kp+1+k2,i+ip+k3) enddo + sgnp = -sgnp enddo enddo + sgn = -sgn enddo m=-m bigI=sum @@ -1004,19 +1036,23 @@ endif if(mu.lt.0.and.m.gt.0)then mu=-mu -factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(4.d0*pi*fact(lambda+iabs(mu)))) -factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(4.d0*pi*fact(l+iabs(m)))) +factor1=dsqrt((2*lambda+1)*fact(lambda-iabs(mu))/(2.d0*pi*fact(lambda+iabs(mu)))) +factor2=dsqrt((2*l+1)*fact(l-iabs(m))/(2.d0*pi*fact(l+iabs(m)))) sum=0.d0 +sgn = 1.d0 do k=0,(mu-1)/2 do i=0,lambda-mu + sgnp = 1.d0 do kp=0,m/2 do ip=0,l-m - cylm=(-1.d0)**k*factor1*dsqrt(2.d0)*binom_func(mu,2*k+1)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) - cylmp=(-1.d0)**kp*factor2*dsqrt(2.d0)*binom_func(m,2*kp)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) + cylm=sgn*factor1 *binom_func(mu,2*k+1)*fact(mu+i)/fact(i)*coef_pm(lambda,i+mu) + cylmp=sgnp*factor2*binom_func(m,2*kp)*fact(m+ip)/fact(ip)*coef_pm(l,ip+m) sum=sum+cylm*cylmp*bigA(mu-(2*k+1)+m-2*kp+k1,2*k+1+2*kp+k2,i+ip+k3) enddo + sgnp = -sgnp enddo enddo + sgn = -sgn enddo bigI=sum mu=-mu @@ -1128,28 +1164,49 @@ end ! IMPLICIT DOUBLE PRECISION (P,X) DIMENSION PM(0:MM,0:(N+1)) - DO 10 I=0,N - DO 10 J=0,M -10 PM(J,I)=0.0D0 + DOUBLE PRECISION, SAVE :: INVERSE(100) = 0.D0 + DOUBLE PRECISION :: LS, II, JJ + IF (INVERSE(1) == 0.d0) THEN + DO I=1,100 + INVERSE(I) = 1.D0/DBLE(I) + ENDDO + ENDIF + DO I=0,N + DO J=0,M + PM(J,I)=0.0D0 + ENDDO + ENDDO PM(0,0)=1.0D0 IF (DABS(X).EQ.1.0D0) THEN - DO 15 I=1,N -15 PM(0,I)=X**I + DO I=1,N + PM(0,I)=X**I + ENDDO RETURN ENDIF - LS=1 - IF (DABS(X).GT.1.0D0) LS=-1 + LS=1.D0 + IF (DABS(X).GT.1.0D0) LS=-1.D0 XQ=DSQRT(LS*(1.0D0-X*X)) XS=LS*(1.0D0-X*X) - DO 30 I=1,M -30 PM(I,I)=-LS*(2.0D0*I-1.0D0)*XQ*PM(I-1,I-1) - DO 35 I=0,M -35 PM(I,I+1)=(2.0D0*I+1.0D0)*X*PM(I,I) + II = 1.D0 + DO I=1,M + PM(I,I)=-LS*II*XQ*PM(I-1,I-1) + II = II+2.D0 + ENDDO + II = 1.D0 + DO I=0,M + PM(I,I+1)=II*X*PM(I,I) + II = II+2.D0 + ENDDO - DO 40 I=0,M - DO 40 J=I+2,N - PM(I,J)=((2.0D0*J-1.0D0)*X*PM(I,J-1)- (I+J-1.0D0)*PM(I,J-2))/(J-I) -40 CONTINUE + II = 0.D0 + DO I=0,M + JJ = II+2.D0 + DO J=I+2,N + PM(I,J)=((2.0D0*JJ-1.0D0)*X*PM(I,J-1)- (II+JJ-1.0D0)*PM(I,J-2))*INVERSE(J-I) + JJ = JJ+1.D0 + ENDDO + II = II+1.D0 + ENDDO END @@ -1528,148 +1585,8 @@ end bessel_mod_exp=x**n*accu end -! double precision function bessel_mod(x,n) -! IMPLICIT DOUBLE PRECISION (A-H,O-Z) -! parameter(NBESSMAX=100) -! dimension SI(0:NBESSMAX),DI(0:NBESSMAX) -! if(n.lt.0.or.n.gt.NBESSMAX)stop 'pb with argument of bessel_mod' -! CALL SPHI(N,X,NBESSMAX,SI,DI) -! bessel_mod=si(n) -! end - - SUBROUTINE SPHI(N,X,NMAX,SI,DI) -! -! ======================================================== -! Purpose: Compute modified spherical Bessel functions -! of the first kind, in(x) and in'(x) -! Input : x --- Argument of in(x) -! n --- Order of in(x) ( n = 0,1,2,... ) -! Output: SI(n) --- in(x) -! DI(n) --- in'(x) -! NM --- Highest order computed -! Routines called: -! MSTA1 and MSTA2 for computing the starting -! point for backward recurrence -! ======================================================== -! - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION SI(0:NMAX),DI(0:NMAX) - NM=N - IF (DABS(X).LT.1.0D-100) THEN - DO 10 K=0,N - SI(K)=0.0D0 -10 DI(K)=0.0D0 - SI(0)=1.0D0 - DI(1)=0.333333333333333D0 - RETURN - ENDIF - SI(0)=DSINH(X)/X - SI(1)=-(DSINH(X)/X-DCOSH(X))/X - SI0=SI(0) - IF (N.GE.2) THEN - M=MSTA1(X,200) - - write(34,*)'m=',m - - IF (M.LT.N) THEN - NM=M - ELSE - M=MSTA2(X,N,15) - write(34,*)'m=',m - ENDIF - F0=0.0D0 - F1=1.0D0-100 - DO 15 K=M,0,-1 - F=(2.0D0*K+3.0D0)*F1/X+F0 - IF (K.LE.NM) SI(K)=F - F0=F1 -15 F1=F - CS=SI0/F - write(34,*)'cs=',cs - DO 20 K=0,NM -20 SI(K)=CS*SI(K) - ENDIF - DI(0)=SI(1) - DO 25 K=1,NM -25 DI(K)=SI(K-1)-(K+1.0D0)/X*SI(K) - RETURN - END - INTEGER FUNCTION MSTA1(X,MP) -! -! =================================================== -! Purpose: Determine the starting point for backward -! recurrence such that the magnitude of -! Jn(x) at that point is about 10^(-MP) -! Input : x --- Argument of Jn(x) -! MP --- Value of magnitude -! Output: MSTA1 --- Starting point -! =================================================== -! - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - A0=DABS(X) - N0=INT(1.1*A0)+1 - F0=ENVJ(N0,A0)-MP - N1=N0+5 - F1=ENVJ(N1,A0)-MP - DO 10 IT=1,20 - NN=N1-(N1-N0)/(1.0D0-F0/F1) - F=ENVJ(NN,A0)-MP - IF(ABS(NN-N1).LT.1) GO TO 20 - N0=N1 - F0=F1 - N1=NN - 10 F1=F - 20 MSTA1=NN - RETURN - END - - - INTEGER FUNCTION MSTA2(X,N,MP) -! -! =================================================== -! Purpose: Determine the starting point for backward -! recurrence such that all Jn(x) has MP -! significant digits -! Input : x --- Argument of Jn(x) -! n --- Order of Jn(x) -! MP --- Significant digit -! Output: MSTA2 --- Starting point -! =================================================== -! - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - A0=DABS(X) - HMP=0.5D0*MP - EJN=ENVJ(N,A0) - IF (EJN.LE.HMP) THEN - OBJ=MP - N0=INT(1.1*A0) - ELSE - OBJ=HMP+EJN - N0=N - ENDIF - F0=ENVJ(N0,A0)-OBJ - N1=N0+5 - F1=ENVJ(N1,A0)-OBJ - DO 10 IT=1,20 - NN=N1-(N1-N0)/(1.0D0-F0/F1) - F=ENVJ(NN,A0)-OBJ - IF (iABS(NN-N1).LT.1) GO TO 20 - N0=N1 - F0=F1 - N1=NN -10 F1=F -20 MSTA2=NN+10 - RETURN - END - - double precision FUNCTION ENVJ(N,X) - DOUBLE PRECISION X - integer N - ENVJ=0.5D0*DLOG10(6.28D0*N)-N*DLOG10(1.36D0*X/N) - RETURN - END !c Computation of real spherical harmonics Ylm(theta,phi) !c @@ -1703,17 +1620,37 @@ end !c double precision function ylm(l,m,theta,phi) implicit none -integer l,m -double precision theta,phi,pm,factor,pi,x,fact,sign +integer l,m,i +double precision theta,phi,pm,factor,twopi,x,fact,sign DIMENSION PM(0:100,0:100) -pi=dacos(-1.d0) +twopi=2.d0*dacos(-1.d0) x=dcos(theta) -sign=(-1.d0)**m +if (iand(m,1) == 1) then + sign=-1.d0 +else + sign=1.d0 +endif CALL LPMN(100,l,l,X,PM) -factor=dsqrt( (2*l+1)*fact(l-iabs(m)) /(4.d0*pi*fact(l+iabs(m))) ) -if(m.gt.0)ylm=sign*dsqrt(2.d0)*factor*pm(m,l)*dcos(dfloat(m)*phi) -if(m.eq.0)ylm=factor*pm(m,l) -if(m.lt.0)ylm=sign*dsqrt(2.d0)*factor*pm(iabs(m),l)*dsin(dfloat(iabs(m))*phi) +if (m > 0) then + factor=dsqrt((l+l+1)*fact(l-m) /(twopi*fact(l+m)) ) +! factor = dble(l+m) +! do i=-m,m-1 +! factor = factor * (factor - 1.d0) +! enddo +! factor=dsqrt(dble(l+l+1)/(twopi*factor) ) + ylm=sign*factor*pm(m,l)*dcos(dfloat(m)*phi) +else if (m == 0) then + factor=dsqrt( 0.5d0*(l+l+1) /twopi ) + ylm=factor*pm(m,l) +else if (m < 0) then + factor=dsqrt( (l+l+1)*fact(l+m) /(twopi*fact(l-m)) ) +! factor = dble(l-m) +! do i=m,-m-1 +! factor = factor * (factor - 1.d0) +! enddo +! factor=dsqrt(dble(l+l+1)/(twopi*factor) ) + ylm=sign*factor*pm(-m,l)*dsin(dfloat(-m)*phi) +endif end !c Explicit representation of Legendre polynomials P_n(x) @@ -1829,11 +1766,12 @@ end double precision function binom_gen(alpha,n) implicit none integer :: n,k - double precision :: fact,alpha,prod + double precision :: fact,alpha,prod, factn_inv prod=1.d0 + factn_inv = 1.d0/fact(n) do k=0,n-1 prod=prod*(alpha-k) - binom_gen = prod/(fact(n)) + binom_gen = prod*factn_inv enddo end @@ -1881,6 +1819,8 @@ double precision function int_prod_bessel(l,gam,n,m,a,b,arg) double precision :: term_A, term_B, term_rap, expo double precision :: s_q_0, s_q_k, s_0_0, a_over_b_square double precision :: int_prod_bessel_loc + double precision :: inverses(0:300) + double precision :: two_qkmp1, qk logical done @@ -1927,18 +1867,31 @@ double precision function int_prod_bessel(l,gam,n,m,a,b,arg) ! Initialise the first recurence terme for the q loop s_q_0 = s_0_0 + ! Loop over q for the convergence of the sequence do while (.not.done) ! Init - sum=0 s_q_k=s_q_0 + sum=s_q_0 - ! Iteration of k - do k=0,q + if (q>300) then + stop 'pseudopot.f90 : q > 300' + endif + + two_qkmp1 = dble(2*(q+m)+1) + qk = dble(q) + do k=0,q-1 + s_q_k = ( two_qkmp1*qk*inverses(k) ) * s_q_k sum=sum+s_q_k - s_q_k = a_over_b_square * ( dble(2*(q-k+m)+1)/dble(2*(k+n)+3) ) * ( dble(q-k)/dble(k+1)) * s_q_k + two_qkmp1 = two_qkmp1-2.d0 + qk = qk-1.d0 enddo + inverses(q) = a_over_b_square/(dble(2*(q+n)+3) * dble(q+1)) +! do k=0,q +! sum=sum+s_q_k +! s_q_k = a_over_b_square * ( dble(2*(q-k+m)+1)*dble(q-k)/(dble(2*(k+n)+3) * dble(k+1)) ) * s_q_k +! enddo int=int+sum @@ -2120,15 +2073,15 @@ parameter (ntot_max=14) integer l,m double precision a(3),g_a,c(3) double precision prod,binom_func,accu,bigI,ylm,bessel_mod -double precision theta_AC0,phi_AC0,ac,factor,fourpi,arg,r,areal +double precision theta_AC0,phi_AC0,ac,ac2,factor,fourpi,arg,r,areal integer ntotA,mu,k1,k2,k3,lambda integer n_a(3) -double precision & -array_I_A(0:lmax_max+ntot_max,-(lmax_max+ntot_max):lmax_max+ntot_max,0:ntot_max,0:ntot_max,0:ntot_max) -double precision array_coefs_A(0:ntot_max,0:ntot_max,0:ntot_max), y +double precision y, f1, f2 +double precision, allocatable :: array_coefs_A(:,:) -ac=dsqrt((a(1)-c(1))**2+(a(2)-c(2))**2+(a(3)-c(3))**2) -arg=g_a*(ac**2+r**2) +ac2=(a(1)-c(1))**2+(a(2)-c(2))**2+(a(3)-c(3))**2 +ac=dsqrt(ac2) +arg=g_a*(ac2+r*r) fourpi=4.d0*dacos(-1.d0) factor=fourpi*dexp(-arg) areal=2.d0*g_a*ac @@ -2144,51 +2097,45 @@ else theta_AC0=dacos( (a(3)-c(3))/ac ) phi_AC0=datan2((a(2)-c(2))/ac,(a(1)-c(1))/ac) + allocate (array_coefs_A(0:ntotA,3)) do k1=0,n_a(1) - do k2=0,n_a(2) - do k3=0,n_a(3) - array_coefs_A(k1,k2,k3)=binom_func(n_a(1),k1)*binom_func(n_a(2),k2)*binom_func(n_a(3),k3) & - *(c(1)-a(1))**(n_a(1)-k1)*(c(2)-a(2))**(n_a(2)-k2)*(c(3)-a(3))**(n_a(3)-k3) & - *r**(k1+k2+k3) - enddo - enddo + array_coefs_A(k1,1) = binom_func(n_a(1),k1)*(c(1)-a(1))**(n_a(1)-k1)*r**(k1) enddo - - do lambda=0,l+ntotA - do mu=-lambda,lambda - do k1=0,n_a(1) - do k2=0,n_a(2) - do k3=0,n_a(3) - array_I_A(lambda,mu,k1,k2,k3)=bigI(lambda,mu,l,m,k1,k2,k3) - enddo - enddo - enddo - enddo + do k2=0,n_a(2) + array_coefs_A(k2,2) = binom_func(n_a(2),k2)*(c(2)-a(2))**(n_a(2)-k2)*r**(k2) + enddo + do k3=0,n_a(3) + array_coefs_A(k3,3) = binom_func(n_a(3),k3)*(c(3)-a(3))**(n_a(3)-k3)*r**(k3) enddo accu=0.d0 do lambda=0,l+ntotA - do mu=-lambda,lambda - y = ylm(lambda,mu,theta_AC0,phi_AC0) - if (y == 0.d0) then - cycle - endif - do k1=0,n_a(1) - do k2=0,n_a(2) - do k3=0,n_a(3) - prod=y*array_coefs_A(k1,k2,k3)*array_I_A(lambda,mu,k1,k2,k3) - if (prod == 0.d0) then - cycle - endif - if (areal*r < 100.d0) then ! overflow! - accu=accu+prod*bessel_mod(areal*r,lambda) - endif + do mu=-lambda,lambda + y = ylm(lambda,mu,theta_AC0,phi_AC0) + if (y == 0.d0) then + cycle + endif + do k3=0,n_a(3) + f1 = y*array_coefs_A(k3,3) + if (f1 == 0.d0) cycle + do k2=0,n_a(2) + f2 = f1*array_coefs_A(k2,2) + if (f2 == 0.d0) cycle + do k1=0,n_a(1) + prod=f2*array_coefs_A(k1,1)*bigI(lambda,mu,l,m,k1,k2,k3) + if (prod == 0.d0) then + cycle + endif + if (areal*r < 100.d0) then ! overflow! + accu=accu+prod*bessel_mod(areal*r,lambda) + endif + enddo + enddo + enddo enddo - enddo - enddo - enddo enddo ylm_orb=factor*accu + deallocate (array_coefs_A) return endif diff --git a/src/Integrals_Monoelec/tree_dependency.png b/src/Integrals_Monoelec/tree_dependency.png index 276dff5d..f56c1e77 100644 Binary files a/src/Integrals_Monoelec/tree_dependency.png and b/src/Integrals_Monoelec/tree_dependency.png differ diff --git a/src/MOGuess/H_CORE_guess.irp.f b/src/MOGuess/H_CORE_guess.irp.f index 1893c08b..b65fe07d 100644 --- a/src/MOGuess/H_CORE_guess.irp.f +++ b/src/MOGuess/H_CORE_guess.irp.f @@ -10,7 +10,7 @@ program H_CORE_guess label = "Guess" call mo_as_eigvectors_of_mo_matrix(mo_mono_elec_integral, & size(mo_mono_elec_integral,1), & - size(mo_mono_elec_integral,2),label) + size(mo_mono_elec_integral,2),label,1) print *, 'save mos' call save_mos diff --git a/src/MOGuess/guess_overlap.irp.f b/src/MOGuess/guess_overlap.irp.f new file mode 100644 index 00000000..c2f090e5 --- /dev/null +++ b/src/MOGuess/guess_overlap.irp.f @@ -0,0 +1,15 @@ +program guess_mimi + BEGIN_DOC +! Produce `H_core` MO orbital + END_DOC + implicit none + character*(64) :: label + + mo_coef = ao_ortho_lowdin_coef + TOUCH mo_coef + label = "Guess" + call mo_as_eigvectors_of_mo_matrix(ao_overlap, & + size(ao_overlap,1), & + size(ao_overlap,2),label,-1) + call save_mos +end diff --git a/src/MOGuess/h_core_guess_routine.irp.f b/src/MOGuess/h_core_guess_routine.irp.f index 566592ba..605c7c8a 100644 --- a/src/MOGuess/h_core_guess_routine.irp.f +++ b/src/MOGuess/h_core_guess_routine.irp.f @@ -9,7 +9,7 @@ subroutine hcore_guess label = "Guess" call mo_as_eigvectors_of_mo_matrix(mo_mono_elec_integral, & size(mo_mono_elec_integral,1), & - size(mo_mono_elec_integral,2),label) + size(mo_mono_elec_integral,2),label,1) print *, 'save mos' call save_mos SOFT_TOUCH mo_coef mo_label diff --git a/src/MOGuess/tree_dependency.png b/src/MOGuess/tree_dependency.png index 13728161..f33b4bb3 100644 Binary files a/src/MOGuess/tree_dependency.png and b/src/MOGuess/tree_dependency.png differ diff --git a/src/MOGuess/truncate_mos.irp.f b/src/MOGuess/truncate_mos.irp.f new file mode 100644 index 00000000..29756055 --- /dev/null +++ b/src/MOGuess/truncate_mos.irp.f @@ -0,0 +1,10 @@ +program prog_truncate_mo + BEGIN_DOC +! Truncate MO set + END_DOC + implicit none + integer :: n + write(*,*) 'Number of MOs to keep' + read (*,*) n + call save_mos_truncated(n) +end diff --git a/src/MO_Basis/tree_dependency.png b/src/MO_Basis/tree_dependency.png index 4ce1ecce..c8086369 100644 Binary files a/src/MO_Basis/tree_dependency.png and b/src/MO_Basis/tree_dependency.png differ diff --git a/src/MO_Basis/utils.irp.f b/src/MO_Basis/utils.irp.f index 7cc94c6d..0d8ef5fa 100644 --- a/src/MO_Basis/utils.irp.f +++ b/src/MO_Basis/utils.irp.f @@ -21,13 +21,37 @@ subroutine save_mos end -subroutine mo_as_eigvectors_of_mo_matrix(matrix,n,m,label) +subroutine save_mos_truncated(n) implicit none - integer,intent(in) :: n,m + double precision, allocatable :: buffer(:,:) + integer :: i,j,n + + call system('$QP_ROOT/scripts/save_current_mos.sh '//trim(ezfio_filename)) + + call ezfio_set_mo_basis_mo_tot_num(n) + call ezfio_set_mo_basis_mo_label(mo_label) + call ezfio_set_mo_basis_ao_md5(ao_md5) + allocate ( buffer(ao_num,n) ) + buffer = 0.d0 + do j = 1, n + do i = 1, ao_num + buffer(i,j) = mo_coef(i,j) + enddo + enddo + call ezfio_set_mo_basis_mo_coef(buffer) + call ezfio_set_mo_basis_mo_occ(mo_occ) + deallocate (buffer) + +end + +subroutine mo_as_eigvectors_of_mo_matrix(matrix,n,m,label,sign) + implicit none + integer,intent(in) :: n,m, sign character*(64), intent(in) :: label double precision, intent(in) :: matrix(n,m) - double precision, allocatable :: mo_coef_new(:,:), R(:,:),eigvalues(:) + integer :: i,j + double precision, allocatable :: mo_coef_new(:,:), R(:,:),eigvalues(:), A(:,:) !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: mo_coef_new, R call write_time(output_mo_basis) @@ -35,30 +59,47 @@ subroutine mo_as_eigvectors_of_mo_matrix(matrix,n,m,label) print *, irp_here, ': Error : m/= mo_tot_num' stop 1 endif - allocate(R(n,m),mo_coef_new(ao_num_align,m),eigvalues(m)) + allocate(A(n,m),R(n,m),mo_coef_new(ao_num_align,m),eigvalues(m)) + if (sign == -1) then + do j=1,m + do i=1,n + A(i,j) = -matrix(i,j) + enddo + enddo + else + do j=1,m + do i=1,n + A(i,j) = matrix(i,j) + enddo + enddo + endif mo_coef_new = mo_coef - call lapack_diag(eigvalues,R,matrix,size(matrix,1),size(matrix,2)) - integer :: i + call lapack_diag(eigvalues,R,A,n,m) write (output_mo_basis,'(A)'), 'MOs are now **'//trim(label)//'**' write (output_mo_basis,'(A)'), '' write (output_mo_basis,'(A)'), 'Eigenvalues' write (output_mo_basis,'(A)'), '-----------' write (output_mo_basis,'(A)'), '' write (output_mo_basis,'(A)'), '======== ================' - do i = 1, m - write (output_mo_basis,'(I8,X,F16.10)'), i,eigvalues(i) + if (sign == -1) then + do i=1,m + eigvalues(i) = -eigvalues(i) + enddo + endif + do i=1,m + write (output_mo_basis,'(I8,X,F16.10)'), i,eigvalues(i) enddo write (output_mo_basis,'(A)'), '======== ================' write (output_mo_basis,'(A)'), '' call dgemm('N','N',ao_num,m,m,1.d0,mo_coef_new,size(mo_coef_new,1),R,size(R,1),0.d0,mo_coef,size(mo_coef,1)) - deallocate(mo_coef_new,R,eigvalues) + deallocate(A,mo_coef_new,R,eigvalues) call write_time(output_mo_basis) mo_label = label - SOFT_TOUCH mo_coef mo_label end + subroutine mo_as_eigvectors_of_mo_matrix_sort_by_observable(matrix,observable,n,m,label) implicit none integer,intent(in) :: n,m diff --git a/src/Nuclei/tree_dependency.png b/src/Nuclei/tree_dependency.png index e3a17492..72cfaeee 100644 Binary files a/src/Nuclei/tree_dependency.png and b/src/Nuclei/tree_dependency.png differ diff --git a/src/Pseudo/EZFIO.cfg b/src/Pseudo/EZFIO.cfg index 80d857e3..58df78a0 100644 --- a/src/Pseudo/EZFIO.cfg +++ b/src/Pseudo/EZFIO.cfg @@ -51,7 +51,7 @@ size: (nuclei.nucl_num,pseudo.pseudo_kmax,0:pseudo.pseudo_lmax) [do_pseudo] type: logical -doc: Using pseudo potential integral of not +doc: Using pseudo potential integral or not interface: ezfio,provider,ocaml default: False diff --git a/src/Pseudo/README.rst b/src/Pseudo/README.rst index 062a9465..cba187aa 100644 --- a/src/Pseudo/README.rst +++ b/src/Pseudo/README.rst @@ -29,7 +29,7 @@ Documentation `do_pseudo `_ - Using pseudo potential integral of not + Using pseudo potential integral or not `pseudo_dz_k `_ diff --git a/src/Pseudo/tree_dependency.png b/src/Pseudo/tree_dependency.png index 55656d8e..5a9af5ae 100644 Binary files a/src/Pseudo/tree_dependency.png and b/src/Pseudo/tree_dependency.png differ diff --git a/src/Utils/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index a7462f94..e3ef0bfe 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -1,3 +1,48 @@ +subroutine svd(A,LDA,U,LDU,D,Vt,LDVt,m,n) + implicit none + BEGIN_DOC + ! Compute A = U.D.Vt + ! + ! LDx : leftmost dimension of x + ! + ! Dimsneion of A is m x n + ! + END_DOC + + integer, intent(in) :: LDA, LDU, LDVt, m, n + double precision, intent(in) :: A(LDA,n) + double precision, intent(out) :: U(LDU,n) + double precision,intent(out) :: Vt(LDVt,n) + double precision,intent(out) :: D(n) + double precision,allocatable :: work(:) + integer :: info, lwork, i, j, k + + double precision,allocatable :: A_tmp(:,:) + allocate (A_tmp(LDA,n)) + A_tmp = A + + ! Find optimal size for temp arrays + allocate(work(1)) + lwork = -1 + call dgesvd('A','A', n, n, A_tmp, LDA, & + D, U, LDU, Vt, LDVt, work, lwork, info) + lwork = work(1) + deallocate(work) + + allocate(work(lwork)) + call dgesvd('A','A', n, n, A_tmp, LDA, & + D, U, LDU, Vt, LDVt, work, lwork, info) + deallocate(work,A_tmp) + + if (info /= 0) then + print *, info, ': SVD failed' + stop + endif + +end + + + subroutine ortho_lowdin(overlap,LDA,N,C,LDC,m) implicit none BEGIN_DOC @@ -29,32 +74,15 @@ subroutine ortho_lowdin(overlap,LDA,N,C,LDC,m) !DEC$ ATTRIBUTES ALIGN : 64 :: U, Vt, D, work integer :: info, lwork, i, j, k - double precision,allocatable :: overlap_tmp(:,:) - allocate (overlap_tmp(lda,n)) - overlap_tmp = overlap - - allocate(work(1)) - lwork = -1 - call dgesvd('A','A', n, n, overlap_tmp, lda, & - D, U, ldc, Vt, lda, work, lwork, info) - lwork = work(1) - deallocate(work) - allocate(work(lwork)) - call dgesvd('A','A', n, n, overlap_tmp, lda, & - D, U, ldc, Vt, lda, work, lwork, info) - deallocate(work,overlap_tmp) - if (info /= 0) then - print *, info, ': SVD failed' - stop - endif - + call svd(overlap,lda,U,ldc,D,Vt,lda,m,n) + !$OMP PARALLEL DEFAULT(NONE) & !$OMP SHARED(S_half,U,D,Vt,n,C,m) & !$OMP PRIVATE(i,j,k) !$OMP DO do i=1,n - if ( D(i) < 1.d-6 ) then + if ( D(i) < 1.d-12 ) then D(i) = 0.d0 else D(i) = 1.d0/dsqrt(D(i)) diff --git a/src/Utils/map_module.f90 b/src/Utils/map_module.f90 index ecff478f..24f5a328 100644 --- a/src/Utils/map_module.f90 +++ b/src/Utils/map_module.f90 @@ -437,97 +437,6 @@ call omp_unset_lock(map%lock) end -subroutine map_update_verbose(map, key, value, sze, thr) - use map_module - implicit none - type (map_type), intent(inout) :: map - integer, intent(in) :: sze - integer(key_kind), intent(inout) :: key(sze) - real(integral_kind), intent(inout) :: value(sze) - real(integral_kind), intent(in) :: thr - - integer :: i - integer(map_size_kind) :: idx_cache, idx_cache_new - integer(cache_map_size_kind) :: idx - integer :: sze2 - integer(cache_key_kind) :: cache_key - integer(map_size_kind) :: n_elements_temp - type (cache_map_type) :: local_map - logical :: map_sorted -! do i = 1, sze -! print*,'value in map = ',value(i) -! enddo - - sze2 = sze - map_sorted = .True. - - n_elements_temp = 0_8 - n_elements_temp = n_elements_temp + 1_8 - do while (sze2>0) - i=1 - do while (i<=sze) - if (key(i) /= 0_8) then - idx_cache = ishft(key(i),map_shift) - if (omp_test_lock(map%map(idx_cache)%lock)) then - local_map%key => map%map(idx_cache)%key - local_map%value => map%map(idx_cache)%value - local_map%sorted = map%map(idx_cache)%sorted - local_map%map_size = map%map(idx_cache)%map_size - local_map%n_elements = map%map(idx_cache)%n_elements - do - !DIR$ FORCEINLINE - call search_key_big_interval(key(i),local_map%key, local_map%n_elements, idx, 1, local_map%n_elements) - if (idx > 0_8) then -! print*,'AHAAH' -! print*,'local_map%value(idx) = ',local_map%value(idx) - local_map%value(idx) = local_map%value(idx) + value(i) -! print*,'not a new value !' -! print*,'local_map%value(idx) = ',local_map%value(idx) - else - ! Assert that the map has a proper size - if (local_map%n_elements == local_map%map_size) then - call cache_map_unique(local_map) - call cache_map_reallocate(local_map, local_map%n_elements + local_map%n_elements) - call cache_map_shrink(local_map,thr) - endif - cache_key = iand(key(i),map_mask) - local_map%n_elements = local_map%n_elements + 1_8 - local_map%value(local_map%n_elements) = value(i) -! print*,'new value !' - local_map%key(local_map%n_elements) = cache_key - local_map%sorted = .False. - n_elements_temp = n_elements_temp + 1_8 - endif ! idx > 0 - key(i) = 0_8 - i = i+1 - sze2 = sze2-1 - if (i>sze) then - i=1 - endif - if ( (ishft(key(i),map_shift) /= idx_cache).or.(key(i)==0_8)) then - exit - endif - enddo - map%map(idx_cache)%key => local_map%key - map%map(idx_cache)%value => local_map%value - map%map(idx_cache)%sorted = local_map%sorted - map%map(idx_cache)%n_elements = local_map%n_elements - map%map(idx_cache)%map_size = local_map%map_size - map_sorted = map_sorted .and. local_map%sorted - call omp_unset_lock(map%map(idx_cache)%lock) - endif ! omp_test_lock - else - i=i+1 - endif ! key = 0 - enddo ! i -enddo ! sze2 > 0 -call omp_set_lock(map%lock) -map%n_elements = map%n_elements + n_elements_temp -map%sorted = map%sorted .and. map_sorted -call omp_unset_lock(map%lock) - -end - subroutine map_append(map, key, value, sze) use map_module implicit none @@ -587,13 +496,16 @@ subroutine cache_map_get_interval(map, key, value, ibegin, iend, idx) integer(cache_map_size_kind), intent(in) :: ibegin, iend real(integral_kind), intent(out) :: value integer(cache_map_size_kind), intent(inout) :: idx + double precision, pointer :: v(:) + integer :: i - call search_key_big_interval(key,map%key, map%n_elements, idx, ibegin, iend) - if (idx > 0) then - value = map%value(idx) - else - value = 0._integral_kind - endif +! call search_key_big_interval(key,map%key, map%n_elements, idx, ibegin, iend) + call search_key_value_big_interval(key, value, map%key, map%value, map%n_elements, idx, ibegin, iend) +! if (idx > 0) then +! value = v(idx) +! else +! value = 0._integral_kind +! endif end @@ -703,7 +615,7 @@ subroutine search_key_big_interval(key,X,sze,idx,ibegin_in,iend_in) istep = ishft(iend-ibegin,-1) idx = ibegin + istep - do while (istep > 32) + do while (istep > 16) idx = ibegin + istep if (cache_key < X(idx)) then iend = idx @@ -740,8 +652,8 @@ subroutine search_key_big_interval(key,X,sze,idx,ibegin_in,iend_in) endif enddo idx = ibegin - if (min(iend_in,sze) > ibegin+64) then - iend = ibegin+64 + if (min(iend_in,sze) > ibegin+16) then + iend = ibegin+16 !DIR$ VECTOR ALIGNED do while (cache_key > X(idx)) idx = idx+1 @@ -784,6 +696,126 @@ subroutine search_key_big_interval(key,X,sze,idx,ibegin_in,iend_in) end +subroutine search_key_value_big_interval(key,value,X,Y,sze,idx,ibegin_in,iend_in) + use map_module + implicit none + integer(cache_map_size_kind), intent(in) :: sze + integer(key_kind) , intent(in) :: key + real(integral_kind) , intent(out) :: value + integer(cache_key_kind) , intent(in) :: X(sze) + real(integral_kind) , intent(in) :: Y(sze) + integer(cache_map_size_kind), intent(in) :: ibegin_in, iend_in + integer(cache_map_size_kind), intent(out) :: idx + + integer(cache_map_size_kind) :: istep, ibegin, iend, i + integer(cache_key_kind) :: cache_key + + if (sze /= 0) then + continue + else + idx = -1 + value = 0.d0 + return + endif + cache_key = iand(key,map_mask) + ibegin = min(ibegin_in,sze) + iend = min(iend_in,sze) + if ((cache_key > X(ibegin)) .and. (cache_key < X(iend))) then + + istep = ishft(iend-ibegin,-1) + idx = ibegin + istep + do while (istep > 16) + idx = ibegin + istep + if (cache_key < X(idx)) then + iend = idx + istep = ishft(idx-ibegin,-1) + idx = ibegin + istep + if (cache_key < X(idx)) then + iend = idx + istep = ishft(idx-ibegin,-1) + cycle + else if (cache_key > X(idx)) then + ibegin = idx + istep = ishft(iend-idx,-1) + cycle + else + value = Y(idx) + return + endif + else if (cache_key > X(idx)) then + ibegin = idx + istep = ishft(iend-idx,-1) + idx = idx + istep + if (cache_key < X(idx)) then + iend = idx + istep = ishft(idx-ibegin,-1) + cycle + else if (cache_key > X(idx)) then + ibegin = idx + istep = ishft(iend-idx,-1) + cycle + else + value = Y(idx) + return + endif + else + value = Y(idx) + return + endif + enddo + idx = ibegin + value = Y(idx) + if (min(iend_in,sze) > ibegin+16) then + iend = ibegin+16 + !DIR$ VECTOR ALIGNED + do while (cache_key > X(idx)) + idx = idx+1 + value = Y(idx) + end do + else + !DIR$ VECTOR ALIGNED + do while (cache_key > X(idx)) + idx = idx+1 + value = Y(idx) + if (idx /= iend) then + cycle + else + exit + endif + end do + endif + if (cache_key /= X(idx)) then + idx = 1-idx + value = 0.d0 + endif + return + + else + + if (cache_key < X(ibegin)) then + idx = -ibegin + value = 0.d0 + return + endif + if (cache_key > X(iend)) then + idx = -iend + value = 0.d0 + return + endif + if (cache_key == X(ibegin)) then + idx = ibegin + value = Y(idx) + return + endif + if (cache_key == X(iend)) then + idx = iend + value = Y(idx) + return + endif + endif + +end + subroutine get_cache_map_n_elements_max(map,n_elements_max) use map_module diff --git a/src/Utils/tree_dependency.png b/src/Utils/tree_dependency.png index 5636a6e3..38b04785 100644 Binary files a/src/Utils/tree_dependency.png and b/src/Utils/tree_dependency.png differ diff --git a/src/ZMQ/NEEDED_CHILDREN_MODULES b/src/ZMQ/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..8b137891 --- /dev/null +++ b/src/ZMQ/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ + diff --git a/src/ZMQ/README.rst b/src/ZMQ/README.rst new file mode 100644 index 00000000..9a12751d --- /dev/null +++ b/src/ZMQ/README.rst @@ -0,0 +1,15 @@ +=== +ZMQ +=== + +Socket address : defined as an environment variable : QP_RUN_ADDRESS + + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. diff --git a/src/ZMQ/f77_zmq_module.f90 b/src/ZMQ/f77_zmq_module.f90 new file mode 100644 index 00000000..d0f551fa --- /dev/null +++ b/src/ZMQ/f77_zmq_module.f90 @@ -0,0 +1,4 @@ +module f77_zmq + include 'f77_zmq.h' +end module + diff --git a/src/ZMQ/zmq.irp.f b/src/ZMQ/zmq.irp.f new file mode 100644 index 00000000..1577e12f --- /dev/null +++ b/src/ZMQ/zmq.irp.f @@ -0,0 +1,105 @@ +use f77_zmq + + +BEGIN_PROVIDER [ integer(ZMQ_PTR), zmq_context ] + implicit none + BEGIN_DOC + ! Context for the ZeroMQ library + END_DOC + zmq_context = f77_zmq_ctx_new () +END_PROVIDER + + + BEGIN_PROVIDER [ character*(128), qp_run_address ] +&BEGIN_PROVIDER [ integer, zmq_port_start ] + implicit none + BEGIN_DOC + ! Address of the qp_run socket + ! Example : tcp://130.120.229.139:12345 + END_DOC + character*(128) :: buffer + call getenv('QP_RUN_ADDRESS',buffer) + if (trim(buffer) == '') then + stop 'QP_RUN_ADDRESS environment variable not defined' + endif + + print *, trim(buffer) + integer :: i + do i=len(buffer),1,-1 + if ( buffer(i:i) == ':') then + qp_run_address = trim(buffer(1:i-1)) + read(buffer(i+1:), *) zmq_port_start + exit + endif + enddo +END_PROVIDER + + +function zmq_port(ishift) + implicit none + integer, intent(in) :: ishift + character*(8) :: zmq_port + write(zmq_port,'(I8)') zmq_port_start+ishift + zmq_port = adjustl(trim(zmq_port)) +end + + +BEGIN_PROVIDER [ integer(ZMQ_PTR), zmq_to_qp_run_socket ] + implicit none + BEGIN_DOC + ! Socket on which the qp_run process replies + END_DOC + integer :: rc + zmq_to_qp_run_socket = f77_zmq_socket(zmq_context, ZMQ_REQ) + rc = f77_zmq_connect(zmq_to_qp_run_socket, trim(qp_run_address)) + if (rc /= 0) then + stop 'Unable to connect zmq_to_qp_run_socket' + endif + integer :: i + i=4 + rc = f77_zmq_setsockopt(zmq_to_qp_run_socket, ZMQ_SNDTIMEO, 120000, i) + if (rc /= 0) then + stop 'Unable to set send timout in zmq_to_qp_run_socket' + endif + rc = f77_zmq_setsockopt(zmq_to_qp_run_socket, ZMQ_RCVTIMEO, 120000, i) + if (rc /= 0) then + stop 'Unable to set recv timout in zmq_to_qp_run_socket' + endif +END_PROVIDER + +BEGIN_PROVIDER [ integer(ZMQ_PTR), zmq_socket_push ] + implicit none + BEGIN_DOC + ! Socket on which to push the results (1) + END_DOC + integer :: rc + character*(64) :: address + character*(8), external :: zmq_port + zmq_socket_push = f77_zmq_socket(zmq_context, ZMQ_PUSH) + address = trim(qp_run_address)//':'//zmq_port(1) + rc = f77_zmq_connect(zmq_socket_push, trim(address)) + if (rc /= 0) then + stop 'Unable to connect zmq_socket_push' + endif + +END_PROVIDER + +BEGIN_PROVIDER [ integer(ZMQ_PTR), zmq_socket_pull ] + implicit none + BEGIN_DOC + ! Socket which pulls the results (2) + END_DOC + integer :: rc + character*(64) :: address + character*(8), external :: zmq_port + zmq_socket_pull = f77_zmq_socket(zmq_context, ZMQ_PULL) + address = 'tcp://*:'//zmq_port(2) + rc = f77_zmq_bind(zmq_socket_pull, trim(address)) + if (rc /= 0) then + stop 'Unable to connect zmq_socket_pull' + endif + +END_PROVIDER + + +