diff --git a/.travis.yml b/.travis.yml index 22cd358e..262f1147 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,6 +4,8 @@ # - sudo apt-get install gfortran liblapack-dev gcc # - sudo apt-get install graphviz +dist: trusty + sudo: false addons: @@ -25,7 +27,7 @@ python: - "2.6" script: - - ./configure --production ./config/travis.cfg + - ./configure ./config/travis.cfg - source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD_ZMQ mrcepa0 All_singles - source ./quantum_package.rc ; ninja - source ./quantum_package.rc ; cd ocaml ; make ; cd - diff --git a/config/gfortran_debug.cfg b/config/gfortran_debug.cfg index 214c3fbe..91a12345 100644 --- a/config/gfortran_debug.cfg +++ b/config/gfortran_debug.cfg @@ -13,7 +13,7 @@ FC : gfortran -g -ffree-line-length-none -I . LAPACK_LIB : -llapack -lblas IRPF90 : irpf90 -IRPF90_FLAGS : --ninja --align=32 +IRPF90_FLAGS : --ninja --align=32 --assert # Global options ################ diff --git a/config/ifort_mpi.cfg b/config/ifort_mpi.cfg new file mode 100644 index 00000000..c0dafc81 --- /dev/null +++ b/config/ifort_mpi.cfg @@ -0,0 +1,63 @@ +# Common flags +############## +# +# -mkl=[parallel|sequential] : Use the MKL library +# --ninja : Allow the utilisation of ninja. It is mandatory ! +# --align=32 : Align all provided arrays on a 32-byte boundary +# +[COMMON] +FC : mpif90 +LAPACK_LIB : -mkl=parallel +IRPF90 : irpf90 +IRPF90_FLAGS : --ninja --align=32 -DMPI + +# Global options +################ +# +# 1 : Activate +# 0 : Deactivate +# +[OPTION] +MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below +CACHE : 1 ; Enable cache_compile.py +OPENMP : 1 ; Append OpenMP flags + +# Optimization flags +#################### +# +# -xHost : Compile a binary optimized for the current architecture +# -O2 : O3 not better than O2. +# -ip : Inter-procedural optimizations +# -ftz : Flushes denormal results to zero +# +[OPT] +FCFLAGS : -xAVX -O2 -ip -ftz -g -traceback + +# Profiling flags +################# +# +[PROFILE] +FC : -p -g +FCFLAGS : -xSSE4.2 -O2 -ip -ftz + +# Debugging flags +################# +# +# -traceback : Activate backtrace on runtime +# -fpe0 : All floating point exaceptions +# -C : Checks uninitialized variables, array subscripts, etc... +# -g : Extra debugging information +# -xSSE2 : Valgrind needs a very simple x86 executable +# +[DEBUG] +FC : -g -traceback +FCFLAGS : -xSSE2 -C -fpe0 +IRPF90_FLAGS : --openmp + +# OpenMP flags +################# +# +[OPENMP] +FC : -openmp +IRPF90_FLAGS : --openmp + diff --git a/configure b/configure index 85285f9b..d41ba5ce 100755 --- a/configure +++ b/configure @@ -2,7 +2,7 @@ # -*- coding: utf-8 -*- """configure -Usage: configure (--production | --development) +Usage: configure Options: @@ -10,18 +10,10 @@ Options: config_file A config file with all the information for compiling. Example config_files are given in config/ - --production You can only compile **all** the modules with this flag, - but it will compile lighting fast. - - --development this will create a build.ninja for each directory which - contains a binary. In a second step you may compile them - individually if you like. - - Examples: - ./configure config/gfortran.cfg --production - ./configure config/ifort.cfg --development + ./configure config/gfortran.cfg + ./configure config/ifort.cfg """ @@ -34,10 +26,7 @@ import sys from os.path import join -if not any(i in ["--production", "--development"] for i in sys.argv): - sys.argv += ["--development"] - -if len(sys.argv) != 3: +if len(sys.argv) != 2: print __doc__ sys.exit() @@ -528,7 +517,7 @@ def create_ninja_and_rc(l_installed): qp_create_ninja = os.path.join(QP_ROOT, "scripts", "compilation", "qp_create_ninja.py") - l = [qp_create_ninja, "create"] + sys.argv[1:] + l = [qp_create_ninja, "create", "--development"] + sys.argv[1:] try: with open('/dev/null', 'w') as dnull: diff --git a/data/basis/v5z-bfd b/data/basis/v5z-bfd index 0afd2bfc..cb5e201f 100644 --- a/data/basis/v5z-bfd +++ b/data/basis/v5z-bfd @@ -862,7 +862,7 @@ S 9 4 0.174186 0.435946 5 0.312836 -0.008188 6 0.561850 0.049509 - 7 9077 -0.114576 + 7 1.009077 -0.114576 8 1.812290 -0.067207 9 3.254852 0.017250 S 1 diff --git a/data/basis/vdz-bfd b/data/basis/vdz-bfd index 8ec29ffe..51952f57 100644 --- a/data/basis/vdz-bfd +++ b/data/basis/vdz-bfd @@ -898,7 +898,7 @@ S 9 4 0.174186 0.435946 5 0.312836 -0.008188 6 0.561850 0.049509 - 7 9077 -0.114576 + 7 1.009077 -0.114576 8 1.812290 -0.067207 9 3.254852 0.017250 S 1 diff --git a/data/basis/vqz-bfd b/data/basis/vqz-bfd index b0fc8d65..cb759866 100644 --- a/data/basis/vqz-bfd +++ b/data/basis/vqz-bfd @@ -688,7 +688,7 @@ S 9 4 0.174186 0.435946 5 0.312836 -0.008188 6 0.561850 0.049509 - 7 9077 -0.114576 + 7 1.009077 -0.114576 8 1.812290 -0.067207 9 3.254852 0.017250 S 1 diff --git a/data/basis/vtz-bfd b/data/basis/vtz-bfd index 2091118e..89d7da93 100644 --- a/data/basis/vtz-bfd +++ b/data/basis/vtz-bfd @@ -1150,7 +1150,7 @@ S 9 4 0.174186 0.435946 5 0.312836 -0.008188 6 0.561850 0.049509 - 7 9077 -0.114576 + 7 1.009077 -0.114576 8 1.812290 -0.067207 9 3.254852 0.017250 S 1 diff --git a/ocaml/Gamess.ml b/ocaml/Gamess.ml new file mode 100644 index 00000000..3b21df51 --- /dev/null +++ b/ocaml/Gamess.ml @@ -0,0 +1,457 @@ +(** CONTRL *) +type scftyp_t = RHF | ROHF | MCSCF | NONE +let string_of_scftyp = function +| RHF -> "RHF" +| ROHF -> "ROHF" +| MCSCF -> "MCSCF" +| NONE -> "NONE" + +type contrl = +{ scftyp: scftyp_t ; + maxit: int; + ispher: int; + icharg: int; + mult: int; + mplevl: int; +} + +let string_of_contrl c = + Printf.sprintf " $CONTRL + EXETYP=RUN COORD=UNIQUE UNITS=ANGS + RUNTYP=ENERGY SCFTYP=%s CITYP=NONE + MAXIT=%d + ISPHER=%d + MULT=%d + ICHARG=%d + MPLEVL=%d + $END" + (string_of_scftyp c.scftyp) + c.maxit c.ispher c.mult c.icharg c.mplevl + +let make_contrl ?(maxit=100) ?(ispher=1) ?(mplevl=0) ~mult ~charge scftyp = + { scftyp ; maxit ; ispher ; mult ; icharg=charge ; mplevl } + + +(** Vec *) +type vec_t = +| Canonical of string +| Natural of string + +let read_mos guide filename = + let text = + let ic = open_in filename in + let n = in_channel_length ic in + let s = Bytes.create n in + really_input ic s 0 n; + close_in ic; + s + in + + let re_vec = + Str.regexp " \\$VEC *\n" + and re_natural = + Str.regexp guide + and re_end = + Str.regexp " \\$END *\n" + and re_eol = + Str.regexp "\n" + in + let i = + Str.search_forward re_natural text 0 + in + let start = + Str.search_forward re_vec text i + in + let i = + Str.search_forward re_end text start + in + let finish = + Str.search_forward re_eol text i + in + String.sub text start (finish-start) + +let read_until_found f tries = + let result = + List.fold_left (fun accu x -> + match accu with + | Some mos -> Some mos + | None -> + begin + try + Some (read_mos x f) + with Not_found -> + None + end + ) None tries + in + match result with + | Some mos -> mos + | None -> raise Not_found + +let read_natural_mos f = + let tries = [ + "--- NATURAL ORBITALS OF MCSCF ---" ; + "MP2 NATURAL ORBITALS" ] + in + read_until_found f tries + +let read_canonical_mos f = + let tries = [ + "--- OPTIMIZED MCSCF MO-S ---" ; + "--- CLOSED SHELL ORBITALS ---" ; + "--- OPEN SHELL ORBITALS ---" + ] + in + read_until_found f tries + +let string_of_vec = function +| Natural filename -> read_natural_mos filename +| Canonical filename -> read_canonical_mos filename + +(** GUESS *) +type guess_t = +| Huckel +| Hcore +| Canonical of (int*string) +| Natural of (int*string) + +let guess_of_string s = + match String.lowercase s with + | "huckel" -> Huckel + | "hcore" -> Hcore + | _ -> raise (Invalid_argument "Bad MO guess") + +let string_of_guess g = + [ + " $GUESS\n" ; " GUESS=" ; + begin + match g with + | Hcore -> "HCORE\n" + | Huckel -> "HUCKEL\n" + | Canonical (norb,_) | Natural (norb,_) -> Printf.sprintf "MOREAD\n NORB=%d\n" norb + end + ; " $END" ; + match g with + | Hcore + | Huckel -> "" + | Natural (_,filename) -> "\n\n"^(string_of_vec (Natural filename)) + | Canonical (_,filename) ->"\n\n"^(string_of_vec (Canonical filename)) + ] |> String.concat "" + + +(** BASIS *) +let string_of_basis = + Printf.sprintf " $BASIS + GBASIS=%s + $END" + + +(** DATA *) +type coord_t = +| Atom of Element.t +| Diatomic_homo of (Element.t*float) +| Diatomic of (Element.t*Element.t*float) +| Xyz of (Element.t*float*float*float) list + + +type data_t = +{ sym: Sym.t ; + title: string; + xyz: string; + nucl_charge: int; +} + +let data_of_atom ele = + let atom = + Element.to_string ele + in + let charge = + Element.to_charge ele + |> Charge.to_int + in + { sym=Sym.D4h ; + title=Printf.sprintf "%s" atom ; + xyz=Printf.sprintf "%s %d.0 0. 0. 0." atom charge ; + nucl_charge = charge + } + +let data_of_diatomic_homo ele r = + assert (r > 0.); + let atom = + Element.to_string ele + in + let charge = + Element.to_charge ele + |> Charge.to_int + in + { sym=Sym.D4h ; + title=Printf.sprintf "%s2" atom ; + xyz=Printf.sprintf "%s %d.0 0. 0. %f" atom charge (-.r *. 0.5) ; + nucl_charge = 2*charge + } + +let data_of_diatomic ele1 ele2 r = + assert (r > 0.); + let atom1, atom2 = + Element.to_string ele1, + Element.to_string ele2 + in + let charge1, charge2 = + Charge.to_int @@ Element.to_charge ele1, + Charge.to_int @@ Element.to_charge ele2 + in + { sym=Sym.C4v ; + title=Printf.sprintf "%s%s" atom1 atom2 ; + xyz=Printf.sprintf "%s %d.0 0. 0. 0.\n%s %d.0 0. 0. %f" + atom1 charge1 atom2 charge2 r ; + nucl_charge = charge1 + charge2 + } + +let data_of_xyz l = + { sym = Sym.C1 ; + title = "..." ; + xyz = String.concat "\n" ( + List.map (fun (e,x,y,z) -> Printf.sprintf "%s %f %f %f %f" + (Element.to_string e) (Element.to_charge e) + x y z) l ) ; + nucl_charge = List.fold_left (fun accu (e,_,_,_) -> + accu + (int_of_float @@ Element.to_charge e) ) 0 l + } + +let make_data = function +| Atom ele -> data_of_atom ele +| Diatomic_homo (ele,r) -> data_of_diatomic_homo ele r +| Diatomic (ele1,ele2,r) -> data_of_diatomic ele1 ele2 r +| Xyz l -> data_of_xyz l + +let string_of_data d = + String.concat "\n" [ " $DATA" ; + d.title ; + Sym.to_data d.sym ; + ] ^ d.xyz ^ "\n $END" + + +(** GUGDM *) +type gugdm2_t = int + +let string_of_gugdm2 = function +| 1 -> "" +| i when i<1 -> raise (Invalid_argument "Nstates must be > 0") +| i -> + let s = + Array.make i "1." + |> Array.to_list + |> String.concat "," + in + Printf.sprintf " + $GUGDM2 + WSTATE(1)=%s + $END +" s + + +type gugdia_t = +{ nstate : int ; + itermx : int ; +} + +let string_of_gugdia g = + Printf.sprintf " + $GUGDIA + PRTTOL=0.0001 + NSTATE=%d + ITERMX=%d + $END +" g.nstate g.itermx + + +let make_gugdia ?(itermx=500) nstate = + assert (nstate > 0); + assert (itermx > 1); + { nstate ; itermx } + + +(** MCSCF *) +type mcscf_t = FULLNR | SOSCF | FOCAS + +let string_of_mcscf m = + " $MCSCF\n" ^ + begin + match m with + | FOCAS -> " FOCAS=.T. SOSCF=.F. FULLNR=.F." + | SOSCF -> " FOCAS=.F. SOSCF=.T. FULLNR=.F." + | FULLNR -> " FOCAS=.F. SOSCF=.F. FULLNR=.T." + end ^ " + CISTEP=GUGA EKT=.F. QUAD=.F. JACOBI=.f. + MAXIT=1000 + $END" + + +type drt_t = +{ nmcc: int ; + ndoc: int ; + nalp: int ; + nval: int ; + istsym: int; +} + + +let make_drt ?(istsym=1) n_elec_alpha n_elec_beta n_e n_act = + let n_elec_tot = + n_elec_alpha + n_elec_beta + in + let nmcc = + (n_elec_tot - n_e)/2 + in + let ndoc = + n_elec_beta - nmcc + in + let nalp = + (n_elec_alpha - nmcc - ndoc) + in + let nval = + n_act - ndoc - nalp + in + { nmcc ; ndoc ; nalp ; nval ; istsym } + +let string_of_drt drt sym = + Printf.sprintf " $DRT + NMCC=%d + NDOC=%d + NALP=%d + NVAL=%d + NEXT=0 + ISTSYM=%d + FORS=.TRUE. + GROUP=C1 + MXNINT= 600000 + NPRT=2 + $END" + drt.nmcc drt.ndoc drt.nalp drt.nval drt.istsym + +(** MP2 *) +let string_of_mp2 = " $MP2 + MP2PRP=.TRUE. + $END" + + +(** Computation *) +type computation = HF | MP2 | CAS of (int*int) + +type system = +{ mult: int ; charge: int ; basis: string ; coord: coord_t } + +let n_elec system = + let data = + make_data system.coord + in + data.nucl_charge - system.charge + +let n_elec_alpha_beta system = + let n = + n_elec system + and m = + system.mult + in + let alpha = + (n+m-1)/2 + in + let beta = + n - alpha + in + (alpha, beta) + + +let create_single_det_input ~mp2 ~guess ?(vecfile="") s = + let scftyp = + match s.mult with + | 1 -> RHF + | _ -> ROHF + and mult = s.mult + and charge = s.charge + and n_elec_alpha, _ = + n_elec_alpha_beta s + and mplevl = + if mp2 then 2 else 0 + in + [ + make_contrl ~mult ~charge ~mplevl scftyp + |> string_of_contrl + ; + begin + match vecfile with + | "" -> string_of_guess guess + | vecfile -> string_of_guess (Canonical (n_elec_alpha, vecfile)) + end + ; + string_of_basis s.basis + ; + if mp2 then + string_of_mp2 + else + "" + ; + make_data s.coord + |> string_of_data + ] |> String.concat "\n\n" + + +let create_hf_input ~guess = + create_single_det_input ~mp2:false ~guess + +let create_mp2_input ~guess = + create_single_det_input ~mp2:true ~guess + + +let create_cas_input ?(vecfile="") ~guess ~nstate s n_e n_a = + let scftyp = MCSCF + and mult = s.mult + and charge = s.charge + in + let n_elec_alpha, n_elec_beta = + n_elec_alpha_beta s + in + let drt = + make_drt n_elec_alpha n_elec_beta n_e n_a + in + let data = + make_data s.coord + in + [ + make_contrl ~mult ~charge scftyp + |> string_of_contrl + ; + begin + match vecfile with + | "" -> string_of_guess guess + | vecfile -> + let norb = + drt.nmcc + drt.ndoc + drt.nval + drt.nalp + in + try + string_of_guess (Natural (norb, vecfile)) + with Not_found -> + string_of_guess (Canonical (norb, vecfile)) + end + ; + string_of_basis s.basis + ; + string_of_mcscf FULLNR + ; + string_of_drt drt data.sym + ; + make_gugdia nstate + |> string_of_gugdia + ; + string_of_gugdm2 nstate + ; + string_of_data data + ] |> String.concat "\n\n" + + +let create_input ?(vecfile="") ?(guess=Huckel) ~system ~nstate = function +| HF -> create_hf_input ~vecfile ~guess system +| MP2 -> create_mp2_input ~vecfile ~guess system +| CAS (n_e,n_a) -> create_cas_input ~vecfile ~nstate ~guess system n_e n_a + + diff --git a/ocaml/Primitive.ml b/ocaml/GaussianPrimitive.ml similarity index 86% rename from ocaml/Primitive.ml rename to ocaml/GaussianPrimitive.ml index a6377d6f..cf3d7cdb 100644 --- a/ocaml/Primitive.ml +++ b/ocaml/GaussianPrimitive.ml @@ -1,5 +1,5 @@ -open Qptypes;; -open Core.Std;; +open Qptypes +open Core.Std type t = { sym : Symmetry.t ; @@ -11,8 +11,7 @@ let to_string p = Printf.sprintf "(%s, %f)" (Symmetry.to_string s) (AO_expo.to_float e) -;; + let of_sym_expo s e = { sym=s ; expo=e} -;; diff --git a/ocaml/Gto.ml b/ocaml/Gto.ml index fb576ee7..2c6efb88 100644 --- a/ocaml/Gto.ml +++ b/ocaml/Gto.ml @@ -10,17 +10,17 @@ type fmt = type t = { sym : Symmetry.t ; - lc : ((Primitive.t * AO_coef.t) list) + lc : ((GaussianPrimitive.t * AO_coef.t) list) } with sexp let of_prim_coef_list pc = let (p,c) = List.hd_exn pc in - let sym = p.Primitive.sym in + let sym = p.GaussianPrimitive.sym in let rec check = function | [] -> `OK | (p,c)::tl -> - if p.Primitive.sym <> sym then + if p.GaussianPrimitive.sym <> sym then `Failed else check tl @@ -59,7 +59,7 @@ let read_one in_channel = let coef = String.tr ~target:'D' ~replacement:'e' coef in let p = - Primitive.of_sym_expo sym + GaussianPrimitive.of_sym_expo sym (AO_expo.of_float (Float.of_string expo) ) and c = AO_coef.of_float (Float.of_string coef) in read_lines ( (p,c)::result) (i-1) @@ -80,7 +80,7 @@ let to_string_gamess { sym = sym ; lc = lc } = let rec do_work accu i = function | [] -> List.rev accu | (p,c)::tail -> - let p = AO_expo.to_float p.Primitive.expo + let p = AO_expo.to_float p.GaussianPrimitive.expo and c = AO_coef.to_float c in let result = @@ -100,7 +100,7 @@ let to_string_gaussian { sym = sym ; lc = lc } = let rec do_work accu i = function | [] -> List.rev accu | (p,c)::tail -> - let p = AO_expo.to_float p.Primitive.expo + let p = AO_expo.to_float p.GaussianPrimitive.expo and c = AO_coef.to_float c in let result = diff --git a/ocaml/Gto.mli b/ocaml/Gto.mli index 753cd81a..93b6c0f3 100644 --- a/ocaml/Gto.mli +++ b/ocaml/Gto.mli @@ -6,12 +6,12 @@ type fmt = type t = { sym : Symmetry.t ; - lc : (Primitive.t * Qptypes.AO_coef.t) list; + lc : (GaussianPrimitive.t * Qptypes.AO_coef.t) list; } with sexp -(** Create from a list of Primitive.t * Qptypes.AO_coef.t *) +(** Create from a list of GaussianPrimitive.t * Qptypes.AO_coef.t *) val of_prim_coef_list : - (Primitive.t * Qptypes.AO_coef.t) list -> t + (GaussianPrimitive.t * Qptypes.AO_coef.t) list -> t (** Read from a file *) val read_one : in_channel -> t diff --git a/ocaml/Input_ao_basis.ml b/ocaml/Input_ao_basis.ml index 88e277ee..8b0f72a2 100644 --- a/ocaml/Input_ao_basis.ml +++ b/ocaml/Input_ao_basis.ml @@ -112,8 +112,8 @@ end = struct let s = Symmetry.Xyz.to_symmetry b.ao_power.(i) in let ao_prim_num = AO_prim_number.to_int b.ao_prim_num.(i) in let prims = List.init ao_prim_num ~f:(fun j -> - let prim = { Primitive.sym = s ; - Primitive.expo = b.ao_expo.(ao_num*j+i) + let prim = { GaussianPrimitive.sym = s ; + GaussianPrimitive.expo = b.ao_expo.(ao_num*j+i) } in let coef = b.ao_coef.(ao_num*j+i) in diff --git a/ocaml/Input_mo_basis.ml b/ocaml/Input_mo_basis.ml index ab75b869..df47abfb 100644 --- a/ocaml/Input_mo_basis.ml +++ b/ocaml/Input_mo_basis.ml @@ -1,32 +1,32 @@ -open Qptypes;; -open Qputils;; -open Core.Std;; +open Qptypes +open Qputils +open Core.Std type t_mo = - { mo_tot_num : MO_number.t ; - mo_label : MO_label.t; - mo_occ : MO_occ.t array; - mo_coef : (MO_coef.t array) array; - ao_md5 : MD5.t; - } with sexp + { mo_tot_num : MO_number.t ; + mo_label : MO_label.t; + mo_class : MO_class.t array; + mo_occ : MO_occ.t array; + mo_coef : (MO_coef.t array) array; + ao_md5 : MD5.t; + } with sexp module Mo_basis : sig - type t = t_mo + type t = t_mo val read : unit -> t option val to_string : t -> string val to_rst : t -> Rst_string.t end = struct type t = t_mo - - let get_default = Qpackage.get_ezfio_default "mo_basis";; + let get_default = Qpackage.get_ezfio_default "mo_basis" let read_mo_label () = if not (Ezfio.has_mo_basis_mo_label ()) then - Ezfio.set_mo_basis_mo_label "None" + Ezfio.set_mo_basis_mo_label "None" ; Ezfio.get_mo_basis_mo_label () |> MO_label.of_string - ;; + let read_ao_md5 () = let ao_md5 = @@ -46,12 +46,28 @@ end = struct if (ao_md5 <> result) then failwith "The current MOs don't correspond to the current AOs."; result - ;; + let read_mo_tot_num () = Ezfio.get_mo_basis_mo_tot_num () |> MO_number.of_int - ;; + + + let read_mo_class () = + if not (Ezfio.has_mo_basis_mo_class ()) then + begin + let mo_tot_num = MO_number.to_int (read_mo_tot_num ()) in + let data = + Array.init mo_tot_num ~f:(fun _ -> MO_class.(to_string (Active []))) + |> Array.to_list + in + Ezfio.ezfio_array_of_list ~rank:1 + ~dim:[| mo_tot_num |] ~data:data + |> Ezfio.set_mo_basis_mo_class + end; + Ezfio.flattened_ezfio (Ezfio.get_mo_basis_mo_class () ) + |> Array.map ~f:MO_class.of_string + let read_mo_occ () = if not (Ezfio.has_mo_basis_mo_label ()) then @@ -60,41 +76,42 @@ end = struct and elec_beta_num = Ezfio.get_electrons_elec_beta_num () and mo_tot_num = MO_number.to_int (read_mo_tot_num ()) in let data = Array.init mo_tot_num ~f:(fun i -> - if (i Array.to_list in + if (i Array.to_list in Ezfio.ezfio_array_of_list ~rank:1 ~dim:[| mo_tot_num |] ~data:data |> Ezfio.set_mo_basis_mo_occ end; Ezfio.flattened_ezfio (Ezfio.get_mo_basis_mo_occ () ) |> Array.map ~f:MO_occ.of_float - ;; + let read_mo_coef () = let a = Ezfio.get_mo_basis_mo_coef () - |> Ezfio.flattened_ezfio - |> Array.map ~f:MO_coef.of_float + |> Ezfio.flattened_ezfio + |> Array.map ~f:MO_coef.of_float in let mo_tot_num = read_mo_tot_num () |> MO_number.to_int in let ao_num = (Array.length a)/mo_tot_num in Array.init mo_tot_num ~f:(fun j -> - Array.sub ~pos:(j*ao_num) ~len:(ao_num) a - ) - ;; + Array.sub ~pos:(j*ao_num) ~len:(ao_num) a + ) + let read () = if (Ezfio.has_mo_basis_mo_tot_num ()) then Some - { mo_tot_num = read_mo_tot_num (); - mo_label = read_mo_label () ; - mo_occ = read_mo_occ (); - mo_coef = read_mo_coef (); - ao_md5 = read_ao_md5 (); - } + { mo_tot_num = read_mo_tot_num (); + mo_label = read_mo_label () ; + mo_class = read_mo_class (); + mo_occ = read_mo_occ (); + mo_coef = read_mo_coef (); + ao_md5 = read_ao_md5 (); + } else None - ;; + let mo_coef_to_string mo_coef = let ao_num = Array.length mo_coef.(0) @@ -102,53 +119,53 @@ end = struct let rec print_five imin imax = match (imax-imin+1) with | 1 -> - let header = [ Printf.sprintf " #%15d" (imin+1) ; ] in - let new_lines = - List.init ao_num ~f:(fun i -> + let header = [ Printf.sprintf " #%15d" (imin+1) ; ] in + let new_lines = + List.init ao_num ~f:(fun i -> Printf.sprintf " %3d %15.10f " (i+1) - (MO_coef.to_float mo_coef.(imin ).(i)) ) - in header @ new_lines + (MO_coef.to_float mo_coef.(imin ).(i)) ) + in header @ new_lines | 2 -> - let header = [ Printf.sprintf " #%15d %15d" (imin+1) (imin+2) ; ] in - let new_lines = - List.init ao_num ~f:(fun i -> + let header = [ Printf.sprintf " #%15d %15d" (imin+1) (imin+2) ; ] in + let new_lines = + List.init ao_num ~f:(fun i -> Printf.sprintf " %3d %15.10f %15.10f" (i+1) - (MO_coef.to_float mo_coef.(imin ).(i)) - (MO_coef.to_float mo_coef.(imin+1).(i)) ) - in header @ new_lines + (MO_coef.to_float mo_coef.(imin ).(i)) + (MO_coef.to_float mo_coef.(imin+1).(i)) ) + in header @ new_lines | 3 -> - let header = [ Printf.sprintf " #%15d %15d %15d" - (imin+1) (imin+2) (imin+3); ] in - let new_lines = - List.init ao_num ~f:(fun i -> + let header = [ Printf.sprintf " #%15d %15d %15d" + (imin+1) (imin+2) (imin+3); ] in + let new_lines = + List.init ao_num ~f:(fun i -> Printf.sprintf " %3d %15.10f %15.10f %15.10f" (i+1) - (MO_coef.to_float mo_coef.(imin ).(i)) - (MO_coef.to_float mo_coef.(imin+1).(i)) - (MO_coef.to_float mo_coef.(imin+2).(i)) ) - in header @ new_lines + (MO_coef.to_float mo_coef.(imin ).(i)) + (MO_coef.to_float mo_coef.(imin+1).(i)) + (MO_coef.to_float mo_coef.(imin+2).(i)) ) + in header @ new_lines | 4 -> - let header = [ Printf.sprintf " #%15d %15d %15d %15d" - (imin+1) (imin+2) (imin+3) (imin+4) ; ] in - let new_lines = - List.init ao_num ~f:(fun i -> + let header = [ Printf.sprintf " #%15d %15d %15d %15d" + (imin+1) (imin+2) (imin+3) (imin+4) ; ] in + let new_lines = + List.init ao_num ~f:(fun i -> Printf.sprintf " %3d %15.10f %15.10f %15.10f %15.10f" (i+1) - (MO_coef.to_float mo_coef.(imin ).(i)) - (MO_coef.to_float mo_coef.(imin+1).(i)) - (MO_coef.to_float mo_coef.(imin+2).(i)) - (MO_coef.to_float mo_coef.(imin+3).(i)) ) - in header @ new_lines + (MO_coef.to_float mo_coef.(imin ).(i)) + (MO_coef.to_float mo_coef.(imin+1).(i)) + (MO_coef.to_float mo_coef.(imin+2).(i)) + (MO_coef.to_float mo_coef.(imin+3).(i)) ) + in header @ new_lines | 5 -> - let header = [ Printf.sprintf " #%15d %15d %15d %15d %15d" - (imin+1) (imin+2) (imin+3) (imin+4) (imin+5) ; ] in - let new_lines = - List.init ao_num ~f:(fun i -> + let header = [ Printf.sprintf " #%15d %15d %15d %15d %15d" + (imin+1) (imin+2) (imin+3) (imin+4) (imin+5) ; ] in + let new_lines = + List.init ao_num ~f:(fun i -> Printf.sprintf " %3d %15.10f %15.10f %15.10f %15.10f %15.10f" (i+1) - (MO_coef.to_float mo_coef.(imin ).(i)) - (MO_coef.to_float mo_coef.(imin+1).(i)) - (MO_coef.to_float mo_coef.(imin+2).(i)) - (MO_coef.to_float mo_coef.(imin+3).(i)) - (MO_coef.to_float mo_coef.(imin+4).(i)) ) - in header @ new_lines + (MO_coef.to_float mo_coef.(imin ).(i)) + (MO_coef.to_float mo_coef.(imin+1).(i)) + (MO_coef.to_float mo_coef.(imin+2).(i)) + (MO_coef.to_float mo_coef.(imin+3).(i)) + (MO_coef.to_float mo_coef.(imin+4).(i)) ) + in header @ new_lines | _ -> assert false in let rec create_list accu i = @@ -158,7 +175,7 @@ end = struct (print_five i (mo_tot_num-1) |> String.concat ~sep:"\n")::accu |> List.rev in create_list [] 0 |> String.concat ~sep:"\n\n" - ;; + let to_rst b = Printf.sprintf " @@ -174,29 +191,32 @@ MO coefficients :: %s " - (MO_label.to_string b.mo_label) - (MO_number.to_string b.mo_tot_num) - (mo_coef_to_string b.mo_coef) + (MO_label.to_string b.mo_label) + (MO_number.to_string b.mo_tot_num) + (mo_coef_to_string b.mo_coef) |> Rst_string.of_string - ;; + let to_string b = Printf.sprintf " mo_label = %s mo_tot_num = \"%s\" +mo_clas = %s mo_occ = %s mo_coef = %s " - (MO_label.to_string b.mo_label) - (MO_number.to_string b.mo_tot_num) - (b.mo_occ |> Array.to_list |> List.map - ~f:(MO_occ.to_string) |> String.concat ~sep:", " ) - (b.mo_coef |> Array.map - ~f:(fun x-> Array.map ~f:MO_coef.to_string x |> String.concat_array - ~sep:"," ) |> - String.concat_array ~sep:"\n" ) - ;; + (MO_label.to_string b.mo_label) + (MO_number.to_string b.mo_tot_num) + (b.mo_class |> Array.to_list |> List.map + ~f:(MO_class.to_string) |> String.concat ~sep:", " ) + (b.mo_occ |> Array.to_list |> List.map + ~f:(MO_occ.to_string) |> String.concat ~sep:", " ) + (b.mo_coef |> Array.map + ~f:(fun x-> Array.map ~f:MO_coef.to_string x |> String.concat_array + ~sep:"," ) |> + String.concat_array ~sep:"\n" ) + end diff --git a/ocaml/MO_class.ml b/ocaml/MO_class.ml index 4fc03da2..adf1a215 100644 --- a/ocaml/MO_class.ml +++ b/ocaml/MO_class.ml @@ -1,46 +1,63 @@ -open Core.Std;; -open Qptypes ;; +open Core.Std +open Qptypes type t = -| Core of MO_number.t list -| Inactive of MO_number.t list -| Active of MO_number.t list -| Virtual of MO_number.t list -| Deleted of MO_number.t list + | Core of MO_number.t list + | Inactive of MO_number.t list + | Active of MO_number.t list + | Virtual of MO_number.t list + | Deleted of MO_number.t list with sexp let to_string x = let print_list l = let s = List.map ~f:(fun x-> MO_number.to_int x |> string_of_int )l - |> (String.concat ~sep:", ") + |> (String.concat ~sep:", ") in "("^s^")" in - + match x with - | Core l -> "Core : "^(print_list l) + | Core [] -> "Core" + | Inactive [] -> "Inactive" + | Active [] -> "Active" + | Virtual [] -> "Virtual" + | Deleted [] -> "Deleted" + | Core l -> "Core : "^(print_list l) | Inactive l -> "Inactive : "^(print_list l) - | Active l -> "Active : "^(print_list l) - | Virtual l -> "Virtual : "^(print_list l) - | Deleted l -> "Deleted : "^(print_list l) -;; + | Active l -> "Active : "^(print_list l) + | Virtual l -> "Virtual : "^(print_list l) + | Deleted l -> "Deleted : "^(print_list l) + +let of_string s = + match (String.lowercase s) with + | "core" -> Core [] + | "inactive" -> Inactive [] + | "active" -> Active [] + | "virtual" -> Virtual [] + | "deleted" -> Deleted [] + | _ -> failwith "MO_class should be (Core|Inactive|Active|Virtual|Deleted)" + + let _mo_number_list_of_range range = - Range.of_string range |> List.map ~f:MO_number.of_int -;; + Range.of_string range |> List.map ~f:MO_number.of_int + + +let create_core range = Core (_mo_number_list_of_range range) +let create_inactive range = Inactive (_mo_number_list_of_range range) +let create_active range = Active (_mo_number_list_of_range range) +let create_virtual range = Virtual (_mo_number_list_of_range range) +let create_deleted range = Deleted (_mo_number_list_of_range range) -let create_core range = Core (_mo_number_list_of_range range) ;; -let create_inactive range = Inactive (_mo_number_list_of_range range) ;; -let create_active range = Active (_mo_number_list_of_range range) ;; -let create_virtual range = Virtual (_mo_number_list_of_range range) ;; -let create_deleted range = Deleted (_mo_number_list_of_range range) ;; let to_bitlist n_int x = - match x with - | Core l - | Inactive l - | Active l - | Virtual l - | Deleted l -> Bitlist.of_mo_number_list n_int l -;; + match x with + | Core l + | Inactive l + | Active l + | Virtual l + | Deleted l -> Bitlist.of_mo_number_list n_int l + + diff --git a/ocaml/MO_class.mli b/ocaml/MO_class.mli index 057d4b20..953e1afe 100644 --- a/ocaml/MO_class.mli +++ b/ocaml/MO_class.mli @@ -19,3 +19,6 @@ val to_bitlist : Qptypes.N_int_number.t -> t -> Bitlist.t (** Convert to string for printing *) val to_string : t -> string + +val of_string : string -> t + diff --git a/ocaml/Message.ml b/ocaml/Message.ml index 72fb41b5..faf5ed69 100644 --- a/ocaml/Message.ml +++ b/ocaml/Message.ml @@ -324,33 +324,28 @@ end (** GetPsiReply_msg : Reply to the GetPsi message *) module GetPsiReply_msg : sig - type t = - { client_id : Id.Client.t ; - psi : Psi.t } - val create : client_id:Id.Client.t -> psi:Psi.t -> t - val to_string_list : t -> string list + type t = string list + val create : psi:Psi.t -> t val to_string : t -> string end = struct - type t = - { client_id : Id.Client.t ; - psi : Psi.t } - let create ~client_id ~psi = - { client_id ; psi } - let to_string x = + type t = string list + let create ~psi = let g, s = - match x.psi.Psi.n_det_generators, x.psi.Psi.n_det_selectors with + match psi.Psi.n_det_generators, psi.Psi.n_det_selectors with | Some g, Some s -> Strictly_positive_int.to_int g, Strictly_positive_int.to_int s | _ -> -1, -1 in - Printf.sprintf "get_psi_reply %d %d %d %d %d %d" - (Id.Client.to_int x.client_id) - (Strictly_positive_int.to_int x.psi.Psi.n_state) - (Strictly_positive_int.to_int x.psi.Psi.n_det) - (Strictly_positive_int.to_int x.psi.Psi.psi_det_size) - g s - let to_string_list x = - [ to_string x ; - x.psi.Psi.psi_det ; x.psi.Psi.psi_coef ; x.psi.Psi.energy ] + let head = + Printf.sprintf "get_psi_reply %d %d %d %d %d" + (Strictly_positive_int.to_int psi.Psi.n_state) + (Strictly_positive_int.to_int psi.Psi.n_det) + (Strictly_positive_int.to_int psi.Psi.psi_det_size) + g s + in + [ head ; psi.Psi.psi_det ; psi.Psi.psi_coef ; psi.Psi.energy ] + let to_string = function + | head :: _ :: _ :: _ :: [] -> head + | _ -> raise (Invalid_argument "Bad wave function message") end @@ -759,7 +754,6 @@ let to_string = function let to_string_list = function | PutPsi x -> PutPsi_msg.to_string_list x -| GetPsiReply x -> GetPsiReply_msg.to_string_list x | PutVector x -> PutVector_msg.to_string_list x | GetVectorReply x -> GetVectorReply_msg.to_string_list x | _ -> assert false diff --git a/ocaml/Molecule.ml b/ocaml/Molecule.ml index a26e23b5..4b740ff7 100644 --- a/ocaml/Molecule.ml +++ b/ocaml/Molecule.ml @@ -2,6 +2,7 @@ open Core.Std ;; open Qptypes ;; exception MultiplicityError of string;; +exception XYZError ;; type t = { nuclei : Atom.t list ; @@ -144,8 +145,16 @@ let of_xyz_file ?(charge=(Charge.of_int 0)) ?(multiplicity=(Multiplicity.of_int 1)) ?(units=Units.Angstrom) filename = - let (_,buffer) = In_channel.read_all filename - |> String.lsplit2_exn ~on:'\n' in + let (x,buffer) = In_channel.read_all filename + |> String.lsplit2_exn ~on:'\n' + in + let result = + try + int_of_string x > 0 + with + | Failure "int_of_string" -> false + in + if not result then raise XYZError; let (_,buffer) = String.lsplit2_exn buffer ~on:'\n' in of_xyz_string ~charge ~multiplicity ~units buffer @@ -166,7 +175,7 @@ let of_file filename = try of_xyz_file ~charge ~multiplicity ~units filename - with _ -> + with XYZError -> of_zmt_file ~charge ~multiplicity ~units filename diff --git a/ocaml/Pseudo.ml b/ocaml/Pseudo.ml index 7f813937..3791167d 100644 --- a/ocaml/Pseudo.ml +++ b/ocaml/Pseudo.ml @@ -2,7 +2,7 @@ open Core.Std open Qptypes -module Primitive_local : sig +module GaussianPrimitive_local : sig type t = { expo : AO_expo.t ; @@ -29,7 +29,7 @@ end = struct end -module Primitive_non_local : sig +module GaussianPrimitive_non_local : sig type t = { expo : AO_expo.t ; @@ -64,8 +64,8 @@ end type t = { element : Element.t ; n_elec : Positive_int.t ; - local : (Primitive_local.t * AO_coef.t ) list ; - non_local : (Primitive_non_local.t * AO_coef.t ) list + local : (GaussianPrimitive_local.t * AO_coef.t ) list ; + non_local : (GaussianPrimitive_non_local.t * AO_coef.t ) list } with sexp let empty e = @@ -83,8 +83,8 @@ let to_string_local = function ( Printf.sprintf "%20s %8s %20s" "Coeff." "r^n" "Exp." ) :: ( List.map t ~f:(fun (l,c) -> Printf.sprintf "%20f %8d %20f" (AO_coef.to_float c) - (R_power.to_int l.Primitive_local.r_power) - (AO_expo.to_float l.Primitive_local.expo) + (R_power.to_int l.GaussianPrimitive_local.r_power) + (AO_expo.to_float l.GaussianPrimitive_local.expo) ) ) |> String.concat ~sep:"\n" @@ -97,12 +97,12 @@ let to_string_non_local = function ( Printf.sprintf "%20s %8s %20s %8s" "Coeff." "r^n" "Exp." "Proj") :: ( List.map t ~f:(fun (l,c) -> let p = - Positive_int.to_int l.Primitive_non_local.proj + Positive_int.to_int l.GaussianPrimitive_non_local.proj in Printf.sprintf "%20f %8d %20f |%d><%d|" (AO_coef.to_float c) - (R_power.to_int l.Primitive_non_local.r_power) - (AO_expo.to_float l.Primitive_non_local.expo) + (R_power.to_int l.GaussianPrimitive_non_local.r_power) + (AO_expo.to_float l.GaussianPrimitive_non_local.expo) p p ) ) |> String.concat ~sep:"\n" @@ -223,7 +223,7 @@ let read_element in_channel element = let decode_local (pseudo,data) = let decode_local_n n rest = let result, rest = - loop Primitive_local.of_expo_r_power [] (Positive_int.to_int n,rest) + loop GaussianPrimitive_local.of_expo_r_power [] (Positive_int.to_int n,rest) in { pseudo with local = result }, rest in @@ -241,7 +241,7 @@ let read_element in_channel element = let decode_non_local (pseudo,data) = let decode_non_local_n proj n (pseudo,data) = let result, rest = - loop (Primitive_non_local.of_proj_expo_r_power proj) + loop (GaussianPrimitive_non_local.of_proj_expo_r_power proj) [] (Positive_int.to_int n, data) in { pseudo with non_local = pseudo.non_local @ result }, rest diff --git a/ocaml/TaskServer.ml b/ocaml/TaskServer.ml index 91fbd231..1ed403f7 100644 --- a/ocaml/TaskServer.ml +++ b/ocaml/TaskServer.ml @@ -25,7 +25,7 @@ type t = state : Message.State.t option ; address_tcp : Address.Tcp.t option ; address_inproc : Address.Inproc.t option ; - psi : Message.Psi.t option; + psi : Message.GetPsiReply_msg.t option; vector : Message.Vector.t option; progress_bar : Progress_bar.t option ; running : bool; @@ -483,7 +483,7 @@ let put_psi msg rest_of_msg program_state rep_socket = in let new_program_state = { program_state with - psi = Some psi_local + psi = Some (Message.GetPsiReply_msg.create ~psi:psi_local) } and client_id = msg.Message.PutPsi_msg.client_id @@ -496,17 +496,12 @@ let put_psi msg rest_of_msg program_state rep_socket = let get_psi msg program_state rep_socket = - - let client_id = - msg.Message.GetPsi_msg.client_id - in - match program_state.psi with - | None -> failwith "No wave function saved in TaskServer" - | Some psi -> - Message.GetPsiReply (Message.GetPsiReply_msg.create ~client_id ~psi) - |> Message.to_string_list - |> ZMQ.Socket.send_all rep_socket; - program_state + begin + match program_state.psi with + | None -> failwith "No wave function saved in TaskServer" + | Some psi_message -> ZMQ.Socket.send_all rep_socket psi_message + end; + program_state diff --git a/ocaml/TaskServer.mli b/ocaml/TaskServer.mli index 7098b55a..4f93dc77 100644 --- a/ocaml/TaskServer.mli +++ b/ocaml/TaskServer.mli @@ -4,7 +4,7 @@ type t = state : Message.State.t option ; address_tcp : Address.Tcp.t option ; address_inproc : Address.Inproc.t option ; - psi : Message.Psi.t option; + psi : Message.GetPsiReply_msg.t option; vector : Message.Vector.t option ; progress_bar : Progress_bar.t option ; running : bool; diff --git a/ocaml/qp_create_ezfio_from_xyz.ml b/ocaml/qp_create_ezfio_from_xyz.ml index 7c07ffe5..787d4a0d 100644 --- a/ocaml/qp_create_ezfio_from_xyz.ml +++ b/ocaml/qp_create_ezfio_from_xyz.ml @@ -420,7 +420,7 @@ let run ?o b c d m p cart xyz_file = let x = List.fold x.Pseudo.non_local ~init:0 ~f:(fun accu (x,_) -> let x = - Positive_int.to_int x.Pseudo.Primitive_non_local.proj + Positive_int.to_int x.Pseudo.GaussianPrimitive_non_local.proj in if (x > accu) then x else accu @@ -435,7 +435,7 @@ let run ?o b c d m p cart xyz_file = Array.init (lmax+1) ~f:(fun i-> List.map pseudo ~f:(fun x -> List.filter x.Pseudo.non_local ~f:(fun (y,_) -> - (Positive_int.to_int y.Pseudo.Primitive_non_local.proj) = i) + (Positive_int.to_int y.Pseudo.GaussianPrimitive_non_local.proj) = i) |> List.length ) |> List.fold ~init:0 ~f:(fun accu x -> if accu > x then accu else x) @@ -458,8 +458,8 @@ let run ?o b c d m p cart xyz_file = List.iteri x.Pseudo.local ~f:(fun i (y,c) -> tmp_array_v_k.(i).(j) <- AO_coef.to_float c; let y, z = - AO_expo.to_float y.Pseudo.Primitive_local.expo, - R_power.to_int y.Pseudo.Primitive_local.r_power + AO_expo.to_float y.Pseudo.GaussianPrimitive_local.expo, + R_power.to_int y.Pseudo.GaussianPrimitive_local.r_power in tmp_array_dz_k.(i).(j) <- y; tmp_array_n_k.(i).(j) <- z; @@ -494,9 +494,9 @@ let run ?o b c d m p cart xyz_file = in List.iter x.Pseudo.non_local ~f:(fun (y,c) -> let k, y, z = - Positive_int.to_int y.Pseudo.Primitive_non_local.proj, - AO_expo.to_float y.Pseudo.Primitive_non_local.expo, - R_power.to_int y.Pseudo.Primitive_non_local.r_power + Positive_int.to_int y.Pseudo.GaussianPrimitive_non_local.proj, + AO_expo.to_float y.Pseudo.GaussianPrimitive_non_local.expo, + R_power.to_int y.Pseudo.GaussianPrimitive_non_local.r_power in let i = last_idx.(k) @@ -602,7 +602,7 @@ let run ?o b c d m p cart xyz_file = List.map x.Gto.lc ~f:(fun (_,coef) -> AO_coef.to_float coef) ) | `Expos -> List.map gtos ~f:(fun x-> List.map x.Gto.lc ~f:(fun (prim,_) -> AO_expo.to_float - prim.Primitive.expo) ) + prim.GaussianPrimitive.expo) ) end in let rec get_n n accu = function diff --git a/ocaml/qp_run.ml b/ocaml/qp_run.ml index e8c8d05a..17d31cea 100644 --- a/ocaml/qp_run.ml +++ b/ocaml/qp_run.ml @@ -120,10 +120,11 @@ let run slave exe ezfio_file = | Some (_,x) -> x^" " | None -> assert false in - match (Sys.command (prefix^exe^ezfio_file)) with - | 0 -> () - | i -> Printf.printf "Program exited with code %d.\n%!" i; - ; + let exit_code = + match (Sys.command (prefix^exe^ezfio_file)) with + | 0 -> 0 + | i -> (Printf.printf "Program exited with code %d.\n%!" i; i) + in TaskServer.stop ~port:port_number; Thread.join task_thread; @@ -132,7 +133,8 @@ let run slave exe ezfio_file = let duration = Time.diff (Time.now()) time_start |> Core.Span.to_string in - Printf.printf "Wall time : %s\n\n" duration + Printf.printf "Wall time : %s\n\n" duration; + exit exit_code let spec = let open Command.Spec in diff --git a/ocaml/qp_set_ddci.ml b/ocaml/qp_set_ddci.ml deleted file mode 100644 index d398bc63..00000000 --- a/ocaml/qp_set_ddci.ml +++ /dev/null @@ -1,305 +0,0 @@ -open Qputils;; -open Qptypes;; -open Core.Std;; - -(* - * Command-line arguments - * ---------------------- - *) - -let build_mask from upto n_int = - let from = MO_number.to_int from - and upto = MO_number.to_int upto - and n_int = N_int_number.to_int n_int - in - let rec build_mask bit = function - | 0 -> [] - | i -> - if ( i = upto ) then - Bit.One::(build_mask Bit.One (i-1)) - else if ( i = from ) then - Bit.One::(build_mask Bit.Zero (i-1)) - else - bit::(build_mask bit (i-1)) - in - let starting_bit = - if ( (upto >= n_int*64) || (upto < 0) ) then Bit.One - else Bit.Zero - in - build_mask starting_bit (n_int*64) - |> List.rev -;; - - -let failure s = raise (Failure s) -;; - -type t = - | Core - | Inactive - | Active - | Virtual - | Deleted - | None -;; - -let t_to_string = function - | Core -> "core" - | Inactive -> "inactive" - | Active -> "active" - | Virtual -> "virtual" - | Deleted -> "deleted" - | None -> assert false -;; - -let run ?(core="[]") ?(inact="[]") ?(act="[]") ?(virt="[]") ?(del="[]") ezfio_filename = - - Ezfio.set_file ezfio_filename ; - if not (Ezfio.has_mo_basis_mo_tot_num ()) then - failure "mo_basis/mo_tot_num not found" ; - - let mo_tot_num = Ezfio.get_mo_basis_mo_tot_num () in - let n_int = - try N_int_number.of_int (Ezfio.get_determinants_n_int ()) - with _ -> Bitlist.n_int_of_mo_tot_num mo_tot_num - in - - - let mo_class = Array.init mo_tot_num ~f:(fun i -> None) in - - (* Check input data *) - let apply_class l = - let rec apply_class t = function - | [] -> () - | k::tail -> let i = MO_number.to_int k in - begin - match mo_class.(i-1) with - | None -> mo_class.(i-1) <- t ; - apply_class t tail; - | x -> failure - (Printf.sprintf "Orbital %d is defined both in the %s and %s spaces" - i (t_to_string x) (t_to_string t)) - end - in - match l with - | MO_class.Core x -> apply_class Core x - | MO_class.Inactive x -> apply_class Inactive x - | MO_class.Active x -> apply_class Active x - | MO_class.Virtual x -> apply_class Virtual x - | MO_class.Deleted x -> apply_class Deleted x - in - - let core_input = core in - let core = MO_class.create_core core in - let inact = MO_class.create_inactive inact in - let act = MO_class.create_active act in - let virt = MO_class.create_virtual virt in - let del = MO_class.create_deleted del in - - apply_class core ; - apply_class inact ; - apply_class act ; - apply_class virt ; - apply_class del ; - - for i=1 to (Array.length mo_class) - do - if (mo_class.(i-1) = None) then - failure (Printf.sprintf "Orbital %d is not specified (mo_tot_num = %d)" i mo_tot_num) - done; - - - (* Debug output *) - MO_class.to_string core |> print_endline ; - MO_class.to_string inact |> print_endline ; - MO_class.to_string act |> print_endline ; - MO_class.to_string virt |> print_endline ; - MO_class.to_string del |> print_endline ; - - (* Create masks *) - let ia = Excitation.create_single inact act - and aa = Excitation.create_single act act - and av = Excitation.create_single act virt - and iv = Excitation.create_single inact virt - in - let single_excitations = [| ia ; aa ; av ; iv |] - |> Array.map ~f:Excitation.(fun x -> - match x with - | Single (x,y) -> - ( MO_class.to_bitlist n_int (Hole.to_mo_class x), - MO_class.to_bitlist n_int (Particle.to_mo_class y) ) - | Double _ -> assert false - ) - - and double_excitations = [| - Excitation.double_of_singles ia ia ; - Excitation.double_of_singles ia aa ; - Excitation.double_of_singles ia iv ; - Excitation.double_of_singles ia av ; - - Excitation.double_of_singles aa aa ; - Excitation.double_of_singles aa iv ; - Excitation.double_of_singles aa av ; - - Excitation.double_of_singles iv aa ; - Excitation.double_of_singles iv av ; - -(* Excitation.double_of_singles iv iv ; *) - |] - - |> Array.map ~f:Excitation.(fun x -> - match x with - | Single _ -> assert false - | Double (x,y,z,t) -> - ( MO_class.to_bitlist n_int (Hole.to_mo_class x), - MO_class.to_bitlist n_int (Particle.to_mo_class y) , - MO_class.to_bitlist n_int (Hole.to_mo_class z), - MO_class.to_bitlist n_int (Particle.to_mo_class t) ) - ) - in - - let extract_hole (h,_) = h - and extract_particle (_,p) = p - and extract_hole1 (h,_,_,_) = h - and extract_particle1 (_,p,_,_) = p - and extract_hole2 (_,_,h,_) = h - and extract_particle2 (_,_,_,p) = p - in -(* --> TODO : This might be wrong *) - let result_ref = - let core = MO_class.create_inactive core_input in - let cv = Excitation.create_single core virt in - let cv = match cv with - | Excitation.Single (x,y) -> - ( MO_class.to_bitlist n_int (Excitation.Hole.to_mo_class x), - MO_class.to_bitlist n_int (Excitation.Particle.to_mo_class y) ) - | Excitation.Double _ -> assert false - in - let iv = match iv with - | Excitation.Single (x,y) -> - ( MO_class.to_bitlist n_int (Excitation.Hole.to_mo_class x), - MO_class.to_bitlist n_int (Excitation.Particle.to_mo_class y) ) - | Excitation.Double _ -> assert false - in - [ Bitlist.or_operator (extract_hole iv) (extract_hole cv); - extract_particle iv ] - in -(* <-- TODO : This might be wrong *) - - let n_single = Array.length single_excitations in - let n_mask = Array.length double_excitations in - let zero = List.init (N_int_number.to_int n_int) ~f:(fun i -> 0L) - |> Bitlist.of_int64_list in - let result_gen = (List.init n_single ~f:(fun i-> [ - extract_hole single_excitations.(i) ; - extract_particle single_excitations.(i) ; - extract_hole1 double_excitations.(i) ; - extract_particle1 double_excitations.(i) ; - extract_hole2 double_excitations.(i) ; - extract_particle2 double_excitations.(i) ; ]) - )@(List.init (n_mask-n_single) ~f:(fun i-> [ - zero ; zero ; - extract_hole1 double_excitations.(n_single+i) ; - extract_particle1 double_excitations.(n_single+i) ; - extract_hole2 double_excitations.(n_single+i) ; - extract_particle2 double_excitations.(n_single+i) ; ]) - ) - |> List.concat - in - - (* Print bitmasks *) - print_endline "Reference Bitmasks:"; - List.iter ~f:(fun x-> print_endline (Bitlist.to_string x)) result_ref; - - print_endline "Generators Bitmasks:"; - List.iter ~f:(fun x-> print_endline (Bitlist.to_string x)) result_gen; - - (* Transform to int64 *) - let result_gen = List.map ~f:(fun x -> - let y = Bitlist.to_int64_list x in y@y ) - result_gen - |> List.concat - in - let result_ref = List.map ~f:(fun x -> - let y = Bitlist.to_int64_list x in y@y ) - result_ref - |> List.concat - in - - (* Write generators masks *) - Ezfio.set_bitmasks_n_int (N_int_number.to_int n_int); - Ezfio.set_bitmasks_bit_kind 8; - Ezfio.set_bitmasks_n_mask_gen n_mask; - Ezfio.ezfio_array_of_list ~rank:4 ~dim:([| (N_int_number.to_int n_int) ; 2; 6; n_mask|]) ~data:result_gen - |> Ezfio.set_bitmasks_generators ; - - (* Write CAS reference masks *) - Ezfio.set_bitmasks_n_mask_cas 1; - Ezfio.ezfio_array_of_list ~rank:3 ~dim:([| (N_int_number.to_int n_int) ; 2; 1|]) ~data:result_ref - |> Ezfio.set_bitmasks_cas ; - - -;; - -let ezfio_file = - let failure filename = - eprintf "'%s' is not an EZFIO file.\n%!" filename; - exit 1 - in - Command.Spec.Arg_type.create - (fun filename -> - match Sys.is_directory filename with - | `Yes -> - begin - match Sys.is_file (filename ^ "/.version") with - | `Yes -> filename - | _ -> failure filename - end - | _ -> failure filename - ) -;; - -let default range = - let failure filename = - eprintf "'%s' is not a regular file.\n%!" filename; - exit 1 - in - Command.Spec.Arg_type.create - (fun filename -> - match Sys.is_directory filename with - | `Yes -> - begin - match Sys.is_file (filename^"/.version") with - | `Yes -> filename - | _ -> failure filename - end - | _ -> failure filename - ) -;; - -let spec = - let open Command.Spec in - empty - +> flag "core" (optional string) ~doc:"range Range of core orbitals" - +> flag "inact" (optional string) ~doc:"range Range of inactive orbitals" - +> flag "act" (optional string) ~doc:"range Range of active orbitals" - +> flag "virt" (optional string) ~doc:"range Range of virtual orbitals" - +> flag "del" (optional string) ~doc:"range Range of deleted orbitals" - +> anon ("ezfio_filename" %: ezfio_file) -;; - -let command = - Command.basic - ~summary: "Quantum Package command" - ~readme:(fun () -> - "Set the orbital classes in an EZFIO directory - The range of MOs has the form : \"[36-53,72-107,126-131]\" - ") - spec - (fun core inact act virt del ezfio_filename () -> run ?core ?inact ?act ?virt ?del ezfio_filename ) -;; - -let () = - Command.run command - - diff --git a/ocaml/qp_set_mo_class.ml b/ocaml/qp_set_mo_class.ml index aaf11422..7451d87d 100644 --- a/ocaml/qp_set_mo_class.ml +++ b/ocaml/qp_set_mo_class.ml @@ -1,6 +1,6 @@ -open Qputils;; -open Qptypes;; -open Core.Std;; +open Qputils +open Qptypes +open Core.Std (* * Command-line arguments @@ -15,12 +15,12 @@ let build_mask from upto n_int = let rec build_mask bit = function | 0 -> [] | i -> - if ( i = upto ) then - Bit.One::(build_mask Bit.One (i-1)) - else if ( i = from ) then - Bit.One::(build_mask Bit.Zero (i-1)) - else - bit::(build_mask bit (i-1)) + if ( i = upto ) then + Bit.One::(build_mask Bit.One (i-1)) + else if ( i = from ) then + Bit.One::(build_mask Bit.Zero (i-1)) + else + bit::(build_mask bit (i-1)) in let starting_bit = if ( (upto >= n_int*64) || (upto < 0) ) then Bit.One @@ -28,83 +28,78 @@ let build_mask from upto n_int = in build_mask starting_bit (n_int*64) |> List.rev -;; -type t = - | Core - | Inactive - | Active - | Virtual - | Deleted - | None -;; -let t_to_string = function - | Core -> "core" - | Inactive -> "inactive" - | Active -> "active" - | Virtual -> "virtual" - | Deleted -> "deleted" - | None -> assert false -;; +type t = MO_class.t option + let set ~core ~inact ~act ~virt ~del = let mo_tot_num = - Ezfio.get_mo_basis_mo_tot_num () + Ezfio.get_mo_basis_mo_tot_num () in let n_int = - try N_int_number.of_int (Ezfio.get_determinants_n_int ()) - with _ -> Bitlist.n_int_of_mo_tot_num mo_tot_num + try N_int_number.of_int (Ezfio.get_determinants_n_int ()) + with _ -> Bitlist.n_int_of_mo_tot_num mo_tot_num in let mo_class = - Array.init mo_tot_num ~f:(fun i -> None) + Array.init mo_tot_num ~f:(fun i -> None) in (* Check input data *) let apply_class l = let rec apply_class t = function - | [] -> () - | k::tail -> let i = MO_number.to_int k in + | [] -> () + | k::tail -> let i = MO_number.to_int k in begin match mo_class.(i-1) with - | None -> mo_class.(i-1) <- t ; + | None -> mo_class.(i-1) <- Some t ; apply_class t tail; - | x -> failwith - (Printf.sprintf "Orbital %d is defined both in the %s and %s spaces" - i (t_to_string x) (t_to_string t)) + | Some x -> failwith + (Printf.sprintf "Orbital %d is defined both in the %s and %s spaces" + i (MO_class.to_string x) (MO_class.to_string t)) end in match l with - | MO_class.Core x -> apply_class Core x - | MO_class.Inactive x -> apply_class Inactive x - | MO_class.Active x -> apply_class Active x - | MO_class.Virtual x -> apply_class Virtual x - | MO_class.Deleted x -> apply_class Deleted x + | MO_class.Core x -> apply_class (MO_class.Core []) x + | MO_class.Inactive x -> apply_class (MO_class.Inactive []) x + | MO_class.Active x -> apply_class (MO_class.Active []) x + | MO_class.Virtual x -> apply_class (MO_class.Virtual []) x + | MO_class.Deleted x -> apply_class (MO_class.Deleted []) x in - let core = MO_class.create_core core in - let inact = MO_class.create_inactive inact in - let act = MO_class.create_active act in - let virt = MO_class.create_virtual virt in - let del = MO_class.create_deleted del in + let check f x = + try f x with Invalid_argument a -> + begin + Printf.printf "Number of MOs: %d\n%!" mo_tot_num; + raise (Invalid_argument a) + end + in + + let core = check MO_class.create_core core in + let inact = check MO_class.create_inactive inact in + let act = check MO_class.create_active act in + let virt = check MO_class.create_virtual virt in + let del = check MO_class.create_deleted del in apply_class core ; apply_class inact ; apply_class act ; apply_class virt ; apply_class del ; + + for i=1 to (Array.length mo_class) do if (mo_class.(i-1) = None) then failwith (Printf.sprintf "Orbital %d is not specified (mo_tot_num = %d)" i mo_tot_num) done; - - + + (* Debug output *) MO_class.to_string core |> print_endline ; MO_class.to_string inact |> print_endline ; @@ -118,14 +113,14 @@ let set ~core ~inact ~act ~virt ~del = and av = Excitation.create_single act virt in let single_excitations = [ ia ; aa ; av ] - |> List.map ~f:Excitation.(fun x -> - match x with - | Single (x,y) -> - ( MO_class.to_bitlist n_int (Hole.to_mo_class x), - MO_class.to_bitlist n_int (Particle.to_mo_class y) ) - | Double _ -> assert false - ) - + |> List.map ~f:Excitation.(fun x -> + match x with + | Single (x,y) -> + ( MO_class.to_bitlist n_int (Hole.to_mo_class x), + MO_class.to_bitlist n_int (Particle.to_mo_class y) ) + | Double _ -> assert false + ) + and double_excitations = [ Excitation.double_of_singles ia ia ; Excitation.double_of_singles ia aa ; @@ -134,16 +129,16 @@ let set ~core ~inact ~act ~virt ~del = Excitation.double_of_singles aa av ; Excitation.double_of_singles av av ] |> List.map ~f:Excitation.(fun x -> - match x with - | Single _ -> assert false - | Double (x,y,z,t) -> - ( MO_class.to_bitlist n_int (Hole.to_mo_class x), - MO_class.to_bitlist n_int (Particle.to_mo_class y) , - MO_class.to_bitlist n_int (Hole.to_mo_class z), - MO_class.to_bitlist n_int (Particle.to_mo_class t) ) - ) + match x with + | Single _ -> assert false + | Double (x,y,z,t) -> + ( MO_class.to_bitlist n_int (Hole.to_mo_class x), + MO_class.to_bitlist n_int (Particle.to_mo_class y) , + MO_class.to_bitlist n_int (Hole.to_mo_class z), + MO_class.to_bitlist n_int (Particle.to_mo_class t) ) + ) in - + let extract_hole (h,_) = h and extract_particle (_,p) = p and extract_hole1 (h,_,_,_) = h @@ -171,9 +166,9 @@ let set ~core ~inact ~act ~virt ~del = (* Write masks *) let result = List.map ~f:(fun x -> - let y = Bitlist.to_int64_list x in y@y ) - result - |> List.concat + let y = Bitlist.to_int64_list x in y@y ) + result + |> List.concat in Ezfio.set_bitmasks_n_int (N_int_number.to_int n_int); @@ -187,57 +182,83 @@ let set ~core ~inact ~act ~virt ~del = match aa with | Double _ -> assert false | Single (x,y) -> - ( MO_class.to_bitlist n_int (Hole.to_mo_class x) ) @ - ( MO_class.to_bitlist n_int (Particle.to_mo_class y) ) - |> Bitlist.to_int64_list + ( MO_class.to_bitlist n_int (Hole.to_mo_class x) ) @ + ( MO_class.to_bitlist n_int (Particle.to_mo_class y) ) + |> Bitlist.to_int64_list in Ezfio.set_bitmasks_n_mask_cas 1; Ezfio.ezfio_array_of_list ~rank:3 ~dim:([| (N_int_number.to_int n_int) ; 2; 1|]) ~data:result - |> Ezfio.set_bitmasks_cas; -;; + |> Ezfio.set_bitmasks_cas; + + let data = + Array.to_list mo_class + |> List.map ~f:(fun x -> match x with + |None -> assert false + | Some x -> MO_class.to_string x + ) + in + Ezfio.ezfio_array_of_list ~rank:1 ~dim:[| mo_tot_num |] ~data + |> Ezfio.set_mo_basis_mo_class + + let get () = + let data = + match Input.Mo_basis.read () with + | None -> failwith "Unable to read MOs" + | Some x -> x + in let mo_tot_num = - Ezfio.get_mo_basis_mo_tot_num () + MO_number.to_int data.Input_mo_basis.mo_tot_num in + let n_int = - try N_int_number.of_int (Ezfio.get_determinants_n_int ()) - with _ -> Bitlist.n_int_of_mo_tot_num mo_tot_num - in - - let bitmasks = - match Input.Bitmasks.read () with - | Some x -> x - | None -> failwith "No data to print" - in - assert (bitmasks.Input.Bitmasks.n_mask_gen |> Bitmask_number.to_int = 1); - assert (bitmasks.Input.Bitmasks.n_mask_cas |> Bitmask_number.to_int = 1); - - let (generators,cas) = - Bitlist.of_int64_array bitmasks.Input.Bitmasks.generators, - Bitlist.of_int64_array bitmasks.Input.Bitmasks.cas + try N_int_number.of_int (Ezfio.get_determinants_n_int ()) + with _ -> Bitlist.n_int_of_mo_tot_num mo_tot_num in Printf.printf "MO : %d\n" mo_tot_num; Printf.printf "n_int: %d\n" (N_int_number.to_int n_int); - Printf.printf "Gen : %s\nCAS : %s\n" - (Bitlist.to_string generators) - (Bitlist.to_string cas) - -;; -let run ~print ?(core="[]") ?(inact="[]") ?(act="[]") ?(virt="[]") ?(del="[]") ezfio_filename = + + let rec work ?(core="[") ?(inact="[") ?(act="[") ?(virt="[") ?(del="[") i l = + match l with + | [] -> + let (core, inact, act, virt, del) = + (core ^"]", + inact ^"]", + act ^"]", + virt ^"]", + del ^"]") + in + set ~core ~inact ~act ~virt ~del + | (MO_class.Core _) :: rest -> + work ~core:(Printf.sprintf "%s,%d" core i) ~inact ~act ~virt ~del (i+1) rest + | (MO_class.Inactive _) :: rest -> + work ~inact:(Printf.sprintf "%s,%d" inact i) ~core ~act ~virt ~del (i+1) rest + | (MO_class.Active _) :: rest -> + work ~act:(Printf.sprintf "%s,%d" act i) ~inact ~core ~virt ~del (i+1) rest + | (MO_class.Virtual _) :: rest -> + work ~virt:(Printf.sprintf "%s,%d" virt i) ~inact ~act ~core ~del (i+1) rest + | (MO_class.Deleted _) :: rest -> + work ~del:(Printf.sprintf "%s,%d" del i) ~inact ~act ~virt ~core (i+1) rest + in + work 1 (Array.to_list data.Input_mo_basis.mo_class) + + + +let run ~q ?(core="[]") ?(inact="[]") ?(act="[]") ?(virt="[]") ?(del="[]") ezfio_filename = Ezfio.set_file ezfio_filename ; if not (Ezfio.has_mo_basis_mo_tot_num ()) then failwith "mo_basis/mo_tot_num not found" ; - if print then + if q then get () else set ~core ~inact ~act ~virt ~del -;; + let ezfio_file = let failure filename = @@ -255,7 +276,7 @@ let ezfio_file = end | _ -> failure filename ) -;; + let default range = let failure filename = @@ -273,7 +294,7 @@ let default range = end | _ -> failure filename ) -;; + let spec = let open Command.Spec in @@ -283,9 +304,9 @@ let spec = +> flag "act" (optional string) ~doc:"range Range of active orbitals" +> flag "virt" (optional string) ~doc:"range Range of virtual orbitals" +> flag "del" (optional string) ~doc:"range Range of deleted orbitals" - +> flag "print" no_arg ~doc:" Print the current masks" + +> flag "q" no_arg ~doc:" Query: print the current masks" +> anon ("ezfio_filename" %: ezfio_file) -;; + let command = Command.basic @@ -295,8 +316,8 @@ let command = The range of MOs has the form : \"[36-53,72-107,126-131]\" ") spec - (fun core inact act virt del print ezfio_filename () -> run ~print ?core ?inact ?act ?virt ?del ezfio_filename ) -;; + (fun core inact act virt del q ezfio_filename () -> run ~q ?core ?inact ?act ?virt ?del ezfio_filename ) + let () = Command.run command diff --git a/ocaml/qptypes_generator.ml b/ocaml/qptypes_generator.ml index 160a07d0..06006181 100644 --- a/ocaml/qptypes_generator.ml +++ b/ocaml/qptypes_generator.ml @@ -2,42 +2,52 @@ open Core.Std;; let input_data = " * Positive_float : float - assert (x >= 0.) ; + if not (x >= 0.) then + raise (Invalid_argument (Printf.sprintf \"Positive_float : (x >= 0.) : x=%f\" x)); * Strictly_positive_float : float - assert (x > 0.) ; + if not (x > 0.) then + raise (Invalid_argument (Printf.sprintf \"Strictly_positive_float : (x > 0.) : x=%f\" x)); * Negative_float : float - assert (x <= 0.) ; + if not (x <= 0.) then + raise (Invalid_argument (Printf.sprintf \"Negative_float : (x <= 0.) : x=%f\" x)); * Strictly_negative_float : float - assert (x < 0.) ; + if not (x < 0.) then + raise (Invalid_argument (Printf.sprintf \"Strictly_negative_float : (x < 0.) : x=%f\" x)); * Positive_int64 : int64 - assert (x >= 0L) ; + if not (x >= 0L) then + raise (Invalid_argument (Printf.sprintf \"Positive_int64 : (x >= 0L) : x=%s\" (Int64.to_string x))); * Positive_int : int - assert (x >= 0) ; + if not (x >= 0) then + raise (Invalid_argument (Printf.sprintf \"Positive_int : (x >= 0) : x=%d\" x)); * Strictly_positive_int : int - assert (x > 0) ; + if not (x > 0) then + raise (Invalid_argument (Printf.sprintf \"Strictly_positive_int : (x > 0) : x=%d\" x)); * Negative_int : int - assert (x <= 0) ; + if not (x <= 0) then + raise (Invalid_argument (Printf.sprintf \"Negative_int : (x <= 0) : x=%d\" x)); * Det_coef : float - assert (x >= -1.) ; - assert (x <= 1.) ; + if (x < -1.) || (x > 1.) then + raise (Invalid_argument (Printf.sprintf \"Det_coef : (-1. <= x <= 1.) : x=%f\" x)); * Normalized_float : float - assert (x <= 1.) ; - assert (x >= 0.) ; + if (x < 0.) || (x > 1.) then + raise (Invalid_argument (Printf.sprintf \"Normalized_float : (0. <= x <= 1.) : x=%f\" x)); * Strictly_negative_int : int - assert (x < 0) ; + if not (x < 0) then + raise (Invalid_argument (Printf.sprintf \"Strictly_negative_int : (x < 0) : x=%d\" x)); * Non_empty_string : string - assert (x <> \"\") ; + if (x = \"\") then + raise (Invalid_argument \"Non_empty_string\"); * Det_number_max : int @@ -53,13 +63,13 @@ let input_data = " * Bit_kind_size : int begin match x with | 8 | 16 | 32 | 64 -> () - | _ -> raise (Failure \"Bit_kind_size should be (8|16|32|64).\") + | _ -> raise (Invalid_argument \"Bit_kind_size should be (8|16|32|64).\") end; * Bit_kind : int begin match x with | 1 | 2 | 4 | 8 -> () - | _ -> raise (Failure \"Bit_kind should be (1|2|4|8).\") + | _ -> raise (Invalid_argument \"Bit_kind should be (1|2|4|8).\") end; * Bitmask_number : int @@ -68,12 +78,14 @@ let input_data = " * MO_coef : float * MO_occ : float - assert (x >= 0.); + if (x < 0.) || (x > 2.) then + raise (Invalid_argument (Printf.sprintf \"MO_occ : (0. <= x <= 2.) : x=%f\" x)); * AO_coef : float * AO_expo : float - assert (x >= 0.) ; + if (x < 0.) then + raise (Invalid_argument (Printf.sprintf \"AO_expo : (x >= 0.) : x=%f\" x)); * AO_prim_number : int assert (x > 0) ; @@ -165,7 +177,7 @@ end = struct match (String.lowercase s) with | \"huckel\" -> Huckel | \"hcore\" -> HCore - | _ -> failwith (\"Wrong Guess type : \"^s) + | _ -> raise (Invalid_argument (\"Wrong Guess type : \"^s)) end @@ -189,7 +201,7 @@ end = struct | \"read\" -> Read | \"write\" -> Write | \"none\" -> None - | _ -> failwith (\"Wrong IO type : \"^s) + | _ -> raise (Invalid_argument (\"Wrong IO type : \"^s)) end " @@ -267,7 +279,9 @@ end = struct begin match max with | %s -> () - | i -> assert ( x <= i ) + | i -> + if ( x > i ) then + raise (Invalid_argument (Printf.sprintf \"%s: %%s\" (%s.to_string x) )) end ; x end @@ -296,7 +310,7 @@ let parse_input_ezfio input= in Printf.sprintf ezfio_template name typ typ typ typ typ typ typ typ (String.capitalize typ) - ezfio_func ezfio_func max min typ typ max msg min + ezfio_func ezfio_func max min typ typ max msg min name (String.capitalize typ) end | _ -> failwith "Error in input_ezfio" in diff --git a/ocaml/test_gto.ml b/ocaml/test_gto.ml index 9b834cd2..423df62b 100644 --- a/ocaml/test_gto.ml +++ b/ocaml/test_gto.ml @@ -1,13 +1,13 @@ -open Core.Std;; -open Qptypes;; +open Core.Std +open Qptypes let test_prim () = let p = - { Primitive.sym = Symmetry.P ; - Primitive.expo = AO_expo.of_float 0.15} in - Primitive.to_string p + { GaussianPrimitive.sym = Symmetry.P ; + GaussianPrimitive.expo = AO_expo.of_float 0.15} in + GaussianPrimitive.to_string p |> print_string -;; + let test_gto_1 () = let in_channel = open_in "/home/scemama/quantum_package/data/basis/cc-pvdz" in @@ -26,24 +26,23 @@ let test_gto_1 () = print_endline "gto3 = gto"; if (gto3 = gto3) then print_endline "gto3 = gto3"; - -;; + let test_gto_2 () = let in_channel = open_in "/home/scemama/quantum_package/data/basis/cc-pvdz" in ignore (input_line in_channel); let basis = Basis.read in_channel (Nucl_number.of_int 1) in List.iter basis ~f:(fun (x,n)-> Printf.printf "%d:%s\n" (Nucl_number.to_int n) (Gto.to_string x)) -;; + let test_gto () = let in_channel = open_in "/home/scemama/quantum_package/data/basis/cc-pvdz" in let basis = Basis.read_element in_channel (Nucl_number.of_int 1) Element.C in List.iter basis ~f:(fun (x,n)-> Printf.printf "%d:%s\n" (Nucl_number.to_int n) (Gto.to_string x)) -;; + let test_module () = test_gto_1() -;; -test_module ();; + +test_module () diff --git a/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f b/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f index 657ad63c..f8a4997a 100644 --- a/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f +++ b/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f @@ -1,11 +1,12 @@ -program selection_slave +program prog_selection_slave implicit none BEGIN_DOC ! Helper program to compute the PT2 in distributed mode. END_DOC read_wf = .False. - SOFT_TOUCH read_wf + distributed_davidson = .False. + SOFT_TOUCH read_wf distributed_davidson call provide_everything call switch_qp_run_to_master call run_wf @@ -23,19 +24,21 @@ subroutine run_wf integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket double precision :: energy(N_states) - character*(64) :: states(1) + character*(64) :: states(4) integer :: rc, i call provide_everything zmq_context = f77_zmq_ctx_new () states(1) = 'selection' + states(2) = 'davidson' + states(3) = 'pt2' zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() do - call wait_for_states(states,zmq_state,1) + call wait_for_states(states,zmq_state,4) if(trim(zmq_state) == 'Stopped') then @@ -51,43 +54,40 @@ subroutine run_wf !$OMP PARALLEL PRIVATE(i) i = omp_get_thread_num() - call selection_slave_tcp(i, energy) + call run_selection_slave(0, i, energy) !$OMP END PARALLEL print *, 'Selection done' + else if (trim(zmq_state) == 'davidson') then + + ! Davidson + ! -------- + + print *, 'Davidson' + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) + call omp_set_nested(.True.) + call davidson_slave_tcp(0) + call omp_set_nested(.False.) + print *, 'Davidson done' + + else if (trim(zmq_state) == 'pt2') then + + ! PT2 + ! --- + + print *, 'PT2' + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) + + !$OMP PARALLEL PRIVATE(i) + i = omp_get_thread_num() + call run_selection_slave(0, i, energy) + !$OMP END PARALLEL + print *, 'PT2 done' + endif end do end -subroutine update_energy(energy) - implicit none - double precision, intent(in) :: energy(N_states) - BEGIN_DOC -! Update energy when it is received from ZMQ - END_DOC - integer :: j,k - do j=1,N_states - do k=1,N_det - CI_eigenvectors(k,j) = psi_coef(k,j) - enddo - enddo - call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int) - if (.True.) then - do k=1,N_states - ci_electronic_energy(k) = energy(k) - enddo - TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors - endif - call write_double(6,ci_energy,'Energy') -end - -subroutine selection_slave_tcp(i,energy) - implicit none - double precision, intent(in) :: energy(N_states) - integer, intent(in) :: i - - call run_selection_slave(0,i,energy) -end diff --git a/plugins/Full_CI/jmmrpt2.irp.f b/plugins/Full_CI/jmmrpt2.irp.f deleted file mode 100644 index cf5bc8be..00000000 --- a/plugins/Full_CI/jmmrpt2.irp.f +++ /dev/null @@ -1,29 +0,0 @@ -program pouet - 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 - double precision :: i_H_psi_array(N_states),diag_H_mat_elem,h,i_O1_psi_array(N_states) - double precision :: E_CI_before(N_states) - integer :: n_det_before - threshold_generators = threshold_generators_pt2 - threshold_selectors = threshold_selectors_pt2 - SOFT_TOUCH threshold_generators threshold_selectors - call H_apply_FCI_PT2_new(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(1:N_states) - print *, 'E+PT2 = ', CI_energy(1:N_states)+pt2(1:N_states) - print *, '-----' - call ezfio_set_full_ci_energy_pt2(CI_energy(1)+pt2(1)) - deallocate(pt2,norm_pert) -end - diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f index 019a19d9..afbf692c 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -167,7 +167,7 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, double precision, allocatable :: val(:) integer(bit_kind), allocatable :: det(:,:,:) integer, allocatable :: task_id(:) - integer :: done, Nindex + integer :: Nindex integer, allocatable :: index(:) double precision, save :: time0 = -1.d0 double precision :: time, timeLast, Nabove_old @@ -249,11 +249,6 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, if(Nabove(1) < 5d0) cycle call get_first_tooth(actually_computed, tooth) - done = 0 - do i=first_det_of_teeth(tooth), first_det_of_teeth(tooth+1)-1 - if(actually_computed(i)) done = done + 1 - end do - E0 = sum(pt2_detail(1,:first_det_of_teeth(tooth)-1)) if (tooth <= comb_teeth) then prop = ((1d0 - dfloat(comb_teeth - tooth + 1) * comb_step) - pt2_cweight(first_det_of_teeth(tooth)-1)) @@ -273,11 +268,9 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, else if (Nabove(tooth) > Nabove_old) then print '(G10.3, 2X, F16.10, 2X, G16.3, 2X, F16.4, A20)', Nabove(tooth), avg+E, eqt, time-time0, '' -!print "(4(G23.13), 4(I9))", time - time0, avg, eqt, Nabove(tooth), tooth, first_det_of_teeth(tooth)-1, done, first_det_of_teeth(tooth+1)-first_det_of_teeth(tooth) Nabove_old = Nabove(tooth) endif endif -!print "(4(G22.13), 4(I9))", time - time0, avg, eqt, Nabove(tooth), tooth, first_det_of_teeth(tooth)-1, done, first_det_of_teeth(tooth+1)-first_det_of_teeth(tooth) end if end do pullLoop @@ -352,27 +345,6 @@ subroutine get_first_tooth(computed, first_teeth) end subroutine -subroutine get_last_full_tooth(computed, last_tooth) - implicit none - logical, intent(in) :: computed(N_det_generators) - integer, intent(out) :: last_tooth - integer :: i, j, missing - - last_tooth = 0 - combLoop : do i=comb_teeth, 1, -1 - missing = 1+ ishft(first_det_of_teeth(i+1)-first_det_of_teeth(i),-4) ! /16 - do j=first_det_of_teeth(i), first_det_of_teeth(i+1)-1 - if(.not.computed(j)) then - missing -= 1 - if(missing < 0) cycle combLoop - end if - end do - last_tooth = i - exit - end do combLoop -end subroutine - - BEGIN_PROVIDER [ integer, size_tbc ] implicit none BEGIN_DOC @@ -410,52 +382,6 @@ subroutine get_carlo_workbatch(computed, comb, Ncomb, tbc) end subroutine -subroutine get_filling_teeth(computed, tbc) - implicit none - integer, intent(inout) :: tbc(0:size_tbc) - logical, intent(inout) :: computed(N_det_generators) - integer :: i, j, k, last_full, dets(comb_teeth) - - call get_last_full_tooth(computed, last_full) - if(last_full /= 0) then - if (tbc(0) > size(tbc) - first_det_of_teeth(last_full+1) -2) then - return - endif - k = tbc(0)+1 - do j=1,first_det_of_teeth(last_full+1)-1 - if(.not.(computed(j))) then - tbc(k) = j - k=k+1 - computed(j) = .true. - end if - end do - tbc(0) = k-1 - end if - -end subroutine - - -subroutine reorder_tbc(tbc) - implicit none - integer, intent(inout) :: tbc(0:size_tbc) - logical, allocatable :: ltbc(:) - integer :: i, ci - - allocate(ltbc(size_tbc)) - ltbc(:) = .false. - do i=1,tbc(0) - ltbc(tbc(i)) = .true. - end do - - ci = 0 - do i=1,size_tbc - if(ltbc(i)) then - ci = ci+1 - tbc(ci) = i - end if - end do -end subroutine - subroutine get_comb(stato, dets, ct) implicit none @@ -545,6 +471,7 @@ end subroutine end if norm_left -= pt2_weight(i) end do + first_det_of_comb = max(1,first_det_of_comb) call write_int(6, first_det_of_comb-1, 'Size of deterministic set') comb_step = (1d0 - pt2_cweight(first_det_of_comb-1)) * comb_step diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index 8e1e43ae..acf19392 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -31,16 +31,6 @@ double precision function integral8(i,j,k,l) end function -BEGIN_PROVIDER [ integer(1), psi_phasemask, (N_int*bit_kind_size, 2, N_det)] - use bitmasks - implicit none - - integer :: i - do i=1, N_det - call get_mask_phase(psi_det_sorted(1,1,i), psi_phasemask(1,1,i)) - end do -END_PROVIDER - subroutine assert(cond, msg) character(*), intent(in) :: msg @@ -56,19 +46,23 @@ end subroutine subroutine get_mask_phase(det, phasemask) use bitmasks implicit none - - integer(bit_kind), intent(in) :: det(N_int, 2) - integer(1), intent(out) :: phasemask(2,N_int*bit_kind_size) - integer :: s, ni, i - logical :: change - + + integer(bit_kind), intent(in) :: det(N_int, 2) + integer, intent(out) :: phasemask(2,N_int*bit_kind_size) + integer :: s, ni, i + logical :: change + phasemask = 0_1 do s=1,2 change = .false. do ni=1,N_int do i=0,bit_kind_size-1 - if(BTEST(det(ni, s), i)) change = .not. change - if(change) phasemask(s, (ni-1)*bit_kind_size + i + 1) = 1_1 + if(BTEST(det(ni, s), i)) then + change = .not. change + endif + if(change) then + phasemask(s, ishft(ni-1,bit_kind_shift) + i + 1) = 1_1 + endif end do end do end do @@ -111,10 +105,10 @@ double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) use bitmasks implicit none - integer(1), intent(in) :: phasemask(2,*) + integer, intent(in) :: phasemask(2,*) integer, intent(in) :: s1, s2, h1, h2, p1, p2 logical :: change - integer(1) :: np1 + integer :: np1 integer :: np double precision, save :: res(0:1) = (/1d0, -1d0/) @@ -134,7 +128,7 @@ subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) implicit none integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) + integer, intent(in) :: phasemask(2,N_int*bit_kind_size) logical, intent(in) :: bannedOrb(mo_tot_num) double precision, intent(in) :: coefs(N_states) double precision, intent(inout) :: vect(N_states, mo_tot_num) @@ -193,7 +187,7 @@ subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) implicit none integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) + integer, intent(in) :: phasemask(2,N_int*bit_kind_size) logical, intent(in) :: bannedOrb(mo_tot_num) double precision, intent(in) :: coefs(N_states) double precision, intent(inout) :: vect(N_states, mo_tot_num) @@ -225,32 +219,32 @@ subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) if(lbanned(i)) cycle hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) - vect(:,i) += hij * coefs + vect(1:N_states,i) += hij * coefs(1:N_states) end do do i=hole+1,mo_tot_num if(lbanned(i)) cycle hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) - vect(:,i) += hij * coefs + vect(1:N_states,i) += hij * coefs(1:N_states) end do call apply_particle(mask, sp, p2, det, ok, N_int) call i_h_j(gen, det, N_int, hij) - vect(:, p2) += hij * coefs + vect(1:N_states, p2) += hij * coefs(1:N_states) else p2 = p(1, sh) do i=1,mo_tot_num if(lbanned(i)) cycle hij = integral8(p1, p2, i, hole) hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) - vect(:,i) += hij * coefs + vect(1:N_states,i) += hij * coefs(1:N_states) end do end if deallocate(lbanned) call apply_particle(mask, sp, p1, det, ok, N_int) call i_h_j(gen, det, N_int, hij) - vect(:, p1) += hij * coefs + vect(1:N_states, p1) += hij * coefs(1:N_states) end @@ -259,7 +253,7 @@ subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) implicit none integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) + integer, intent(in) :: phasemask(2,N_int*bit_kind_size) logical, intent(in) :: bannedOrb(mo_tot_num) double precision, intent(in) :: coefs(N_states) double precision, intent(inout) :: vect(N_states, mo_tot_num) @@ -278,7 +272,7 @@ subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) if(lbanned(i)) cycle call apply_particle(mask, sp, i, det, ok, N_int) call i_h_j(gen, det, N_int, hij) - vect(:, i) += hij * coefs + vect(1:N_states, i) += hij * coefs(1:N_states) end do deallocate(lbanned) end @@ -312,6 +306,9 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d logical :: monoAdo, monoBdo integer :: maskInd + integer(bit_kind), allocatable:: preinteresting_det(:,:,:) + allocate (preinteresting_det(N_int,2,N_det)) + PROVIDE fragment_count monoAdo = .true. @@ -336,17 +333,18 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d integer, allocatable :: indices(:), exc_degree(:), iorder(:) allocate (indices(N_det), & exc_degree(max(N_det_alpha_unique,N_det_beta_unique))) - k=1 - do i=1,N_det_alpha_unique - call get_excitation_degree_spin(psi_det_alpha_unique(1,i), & - psi_det_generators(1,1,i_generator), exc_degree(i), N_int) - enddo PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns PROVIDE psi_bilinear_matrix_transp_order + k=1 + do i=1,N_det_alpha_unique + call get_excitation_degree_spin(psi_det_alpha_unique(1,i), & + psi_det_generators(1,1,i_generator), exc_degree(i), N_int) + enddo + do j=1,N_det_beta_unique call get_excitation_degree_spin(psi_det_beta_unique(1,j), & psi_det_generators(1,2,i_generator), nt, N_int) @@ -415,6 +413,10 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d if(i <= N_det_selectors) then preinteresting(0) += 1 preinteresting(preinteresting(0)) = i + do j=1,N_int + preinteresting_det(j,1,preinteresting(0)) = psi_det_sorted(j,1,i) + preinteresting_det(j,2,preinteresting(0)) = psi_det_sorted(j,2,i) + enddo else if(nt <= 2) then prefullinteresting(0) += 1 prefullinteresting(prefullinteresting(0)) = i @@ -441,35 +443,36 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d do ii=1,preinteresting(0) i = preinteresting(ii) - mobMask(1,1) = iand(negMask(1,1), psi_det_sorted(1,1,preinteresting(ii))) - mobMask(1,2) = iand(negMask(1,2), psi_det_sorted(1,2,preinteresting(ii))) + mobMask(1,1) = iand(negMask(1,1), preinteresting_det(1,1,ii)) + mobMask(1,2) = iand(negMask(1,2), preinteresting_det(1,2,ii)) nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) do j=2,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(1,1,preinteresting(ii))) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(1,2,preinteresting(ii))) + mobMask(j,1) = iand(negMask(j,1), preinteresting_det(j,1,ii)) + mobMask(j,2) = iand(negMask(j,2), preinteresting_det(j,2,ii)) nt = nt+ popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) end do - if(nt <= 4) then - interesting(0) += 1 - interesting(interesting(0)) = i - minilist(1,1,interesting(0)) = psi_det_sorted(1,1,preinteresting(ii)) - minilist(1,2,interesting(0)) = psi_det_sorted(1,2,preinteresting(ii)) - do j=2,N_int - minilist(j,1,interesting(0)) = psi_det_sorted(1,1,preinteresting(ii)) - minilist(j,2,interesting(0)) = psi_det_sorted(1,2,preinteresting(ii)) - enddo - if(nt <= 2) then - fullinteresting(0) += 1 - fullinteresting(fullinteresting(0)) = i - fullminilist(1,1,fullinteresting(0)) = psi_det_sorted(1,1,preinteresting(ii)) - fullminilist(1,2,fullinteresting(0)) = psi_det_sorted(1,2,preinteresting(ii)) - do j=2,N_int - fullminilist(j,1,fullinteresting(0)) = psi_det_sorted(1,1,preinteresting(ii)) - fullminilist(j,2,fullinteresting(0)) = psi_det_sorted(1,2,preinteresting(ii)) - enddo - end if - end if + if(nt <= 4) then + interesting(0) += 1 + interesting(interesting(0)) = i + minilist(1,1,interesting(0)) = preinteresting_det(1,1,ii) + minilist(1,2,interesting(0)) = preinteresting_det(1,2,ii) + do j=2,N_int + minilist(j,1,interesting(0)) = preinteresting_det(j,1,ii) + minilist(j,2,interesting(0)) = preinteresting_det(j,2,ii) + enddo + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(1,1,fullinteresting(0)) = preinteresting_det(1,1,ii) + fullminilist(1,2,fullinteresting(0)) = preinteresting_det(1,2,ii) + do j=2,N_int + fullminilist(j,1,fullinteresting(0)) = preinteresting_det(j,1,ii) + fullminilist(j,2,fullinteresting(0)) = preinteresting_det(j,2,ii) + enddo + end if + end if + end do do ii=1,prefullinteresting(0) @@ -626,13 +629,14 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - - integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt - integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) + + integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) + integer :: phasemask(2,N_int*bit_kind_size) ! logical :: bandon ! ! bandon = .false. - PROVIDE psi_phasemask psi_selectors_coef_transp + PROVIDE psi_selectors_coef_transp mat = 0d0 do i=1,N_int @@ -691,12 +695,13 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere call bitstring_to_list_in_selection(perMask(1,2), h(1,2), h(0,2), N_int) if (interesting(i) >= i_gen) then + call get_mask_phase(psi_det_sorted(1,1,interesting(i)), phasemask) if(nt == 4) then - call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + call get_d2(det(1,1,i), phasemask, bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) else if(nt == 3) then - call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + call get_d1(det(1,1,i), phasemask, bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) else - call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + call get_d0(det(1,1,i), phasemask, bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) end if else if(nt == 4) call past_d2(banned, p, sp) @@ -711,7 +716,7 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) implicit none integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) + integer, intent(in) :: phasemask(2,N_int*bit_kind_size) logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) double precision, intent(in) :: coefs(N_states) double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) @@ -829,7 +834,7 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) implicit none integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1),intent(in) :: phasemask(2,N_int*bit_kind_size) + integer,intent(in) :: phasemask(2,N_int*bit_kind_size) logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) integer(bit_kind) :: det(N_int, 2) double precision, intent(in) :: coefs(N_states) @@ -1001,7 +1006,7 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) implicit none integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) + integer, intent(in) :: phasemask(2,N_int*bit_kind_size) logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) integer(bit_kind) :: det(N_int, 2) double precision, intent(in) :: coefs(N_states) diff --git a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f index b41662f4..f86a7fcd 100644 --- a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f @@ -19,13 +19,14 @@ end subroutine run_wf use f77_zmq + implicit none integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket double precision :: energy(N_states) character*(64) :: states(4) - integer :: rc, i + integer :: rc, i, ierr call provide_everything diff --git a/plugins/Full_CI_ZMQ/selection_slave.irp.f b/plugins/Full_CI_ZMQ/selection_slave.irp.f index 92c6b775..ba85ca82 100644 --- a/plugins/Full_CI_ZMQ/selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_slave.irp.f @@ -5,7 +5,8 @@ program selection_slave END_DOC read_wf = .False. - SOFT_TOUCH read_wf + distributed_davidson = .False. + SOFT_TOUCH read_wf distributed_davidson call provide_everything call switch_qp_run_to_master call run_wf @@ -13,7 +14,7 @@ end subroutine provide_everything PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context - PROVIDE pt2_e0_denominator mo_tot_num N_int fragment_count + PROVIDE pt2_e0_denominator mo_tot_num N_int fragment_count end subroutine run_wf @@ -23,19 +24,21 @@ subroutine run_wf integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket double precision :: energy(N_states) - character*(64) :: states(1) + character*(64) :: states(4) integer :: rc, i call provide_everything zmq_context = f77_zmq_ctx_new () states(1) = 'selection' + states(2) = 'davidson' + states(3) = 'pt2' zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() do - call wait_for_states(states,zmq_state,1) + call wait_for_states(states,zmq_state,3) if(trim(zmq_state) == 'Stopped') then @@ -51,21 +54,30 @@ subroutine run_wf !$OMP PARALLEL PRIVATE(i) i = omp_get_thread_num() - call selection_slave_tcp(i, energy) + call run_selection_slave(0,i,energy) !$OMP END PARALLEL print *, 'Selection done' + else if (trim(zmq_state) == 'pt2') then + + ! PT2 + ! --- + + print *, 'PT2' + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) + + logical :: lstop + lstop = .False. + !$OMP PARALLEL PRIVATE(i) + i = omp_get_thread_num() + call run_pt2_slave(0,i,energy,lstop) + !$OMP END PARALLEL + print *, 'PT2 done' + endif end do end -subroutine selection_slave_tcp(i,energy) - implicit none - double precision, intent(in) :: energy(N_states) - integer, intent(in) :: i - - call run_selection_slave(0,i,energy) -end diff --git a/plugins/Full_CI_ZMQ/zmq_selection.irp.f b/plugins/Full_CI_ZMQ/zmq_selection.irp.f index 5e205e14..2628fb5a 100644 --- a/plugins/Full_CI_ZMQ/zmq_selection.irp.f +++ b/plugins/Full_CI_ZMQ/zmq_selection.irp.f @@ -102,7 +102,7 @@ subroutine selection_collector(b, N, pt2) zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() zmq_socket_pull = new_zmq_pull_socket() - call create_selection_buffer(N, N*8, b2) + call create_selection_buffer(N, N*2, b2) allocate(task_id(N_det_generators)) more = 1 pt2(:) = 0d0 diff --git a/plugins/Full_CI_ZMQ_MPI/NEEDED_CHILDREN_MODULES b/plugins/Full_CI_ZMQ_MPI/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..03d04444 --- /dev/null +++ b/plugins/Full_CI_ZMQ_MPI/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Full_CI_ZMQ MPI diff --git a/plugins/Full_CI_ZMQ_MPI/README.rst b/plugins/Full_CI_ZMQ_MPI/README.rst new file mode 100644 index 00000000..bf9dfab4 --- /dev/null +++ b/plugins/Full_CI_ZMQ_MPI/README.rst @@ -0,0 +1,14 @@ +=============== +Full_CI_ZMQ_MPI +=============== + +MPI Slave for Full_CI with ZMQ + +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/Full_CI_ZMQ_MPI/selection_davidson_slave_mpi.irp.f b/plugins/Full_CI_ZMQ_MPI/selection_davidson_slave_mpi.irp.f new file mode 100644 index 00000000..6e4bf775 --- /dev/null +++ b/plugins/Full_CI_ZMQ_MPI/selection_davidson_slave_mpi.irp.f @@ -0,0 +1,101 @@ +program selection_slave + implicit none + BEGIN_DOC +! Helper program to compute the PT2 in distributed mode. + END_DOC + + read_wf = .False. + distributed_davidson = .False. + SOFT_TOUCH read_wf distributed_davidson + call provide_everything + call switch_qp_run_to_master + call run_wf +end + +subroutine provide_everything + PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context + PROVIDE pt2_e0_denominator mo_tot_num N_int fragment_count MPI_Initialized +end + +subroutine run_wf + use f77_zmq + + implicit none + + integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + double precision :: energy(N_states) + character*(64) :: states(4) + integer :: rc, i, ierr + + call provide_everything + + zmq_context = f77_zmq_ctx_new () + states(1) = 'selection' + states(2) = 'davidson' + states(3) = 'pt2' + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + + do + + call wait_for_states(states,zmq_state,3) + + if(trim(zmq_state) == 'Stopped') then + + exit + + else if (trim(zmq_state) == 'selection') then + + ! Selection + ! --------- + + print *, 'Selection' + if (is_mpi_master) then + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) + endif + IRP_IF MIP + call MPI_BCAST(n,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + IRP_ENDIF + + !$OMP PARALLEL PRIVATE(i) + i = omp_get_thread_num() + call run_selection_slave(0,i,energy) + !$OMP END PARALLEL + print *, 'Selection done' + + else if (trim(zmq_state) == 'davidson') then + + ! Davidson + ! -------- + + print *, 'Davidson' + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) + call omp_set_nested(.True.) + call davidson_slave_tcp(0) + call omp_set_nested(.False.) + print *, 'Davidson done' + + else if (trim(zmq_state) == 'pt2') then + + ! PT2 + ! --- + + print *, 'PT2' + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) + + logical :: lstop + lstop = .False. + !$OMP PARALLEL PRIVATE(i) + i = omp_get_thread_num() + call run_pt2_slave(0,i,energy,lstop) + !$OMP END PARALLEL + print *, 'PT2 done' + + endif + + end do +end + + + diff --git a/plugins/Generators_CAS/generators.irp.f b/plugins/Generators_CAS/generators.irp.f index f47341de..4e2fcd58 100644 --- a/plugins/Generators_CAS/generators.irp.f +++ b/plugins/Generators_CAS/generators.irp.f @@ -14,9 +14,9 @@ BEGIN_PROVIDER [ integer, N_det_generators ] good = .True. do k=1,N_int good = good .and. ( & - iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == & + iand(not(cas_bitmask(k,1,l)), psi_det_sorted(k,1,i)) == & iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) ) .and. ( & - iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == & + iand(not(cas_bitmask(k,2,l)), psi_det_sorted(k,2,i)) == & iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2)) ) enddo if (good) then @@ -46,9 +46,9 @@ END_PROVIDER good = .True. do k=1,N_int good = good .and. ( & - iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == & + iand(not(cas_bitmask(k,1,l)), psi_det_sorted(k,1,i)) == & iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) .and. ( & - iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == & + iand(not(cas_bitmask(k,2,l)), psi_det_sorted(k,2,i)) == & iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2) )) ) enddo if (good) then @@ -58,8 +58,8 @@ END_PROVIDER if (good) then m = m+1 do k=1,N_int - psi_det_generators(k,1,m) = psi_det(k,1,i) - psi_det_generators(k,2,m) = psi_det(k,2,i) + psi_det_generators(k,1,m) = psi_det_sorted(k,1,i) + psi_det_generators(k,2,m) = psi_det_sorted(k,2,i) enddo psi_coef_generators(m,:) = psi_coef(m,:) endif diff --git a/plugins/Hartree_Fock/DIIS.irp.f b/plugins/Hartree_Fock/DIIS.irp.f new file mode 100644 index 00000000..a7ed06bf --- /dev/null +++ b/plugins/Hartree_Fock/DIIS.irp.f @@ -0,0 +1,196 @@ +BEGIN_PROVIDER [ double precision, threshold_DIIS_nonzero ] + implicit none + BEGIN_DOC + ! If threshold_DIIS is zero, choose sqrt(thresh_scf) + END_DOC + if (threshold_DIIS == 0.d0) then + threshold_DIIS_nonzero = dsqrt(thresh_scf) + else + threshold_DIIS_nonzero = threshold_DIIS + endif + ASSERT (threshold_DIIS_nonzero >= 0.d0) + +END_PROVIDER + +BEGIN_PROVIDER [double precision, FPS_SPF_Matrix_AO, (AO_num, AO_num)] + implicit none + BEGIN_DOC + ! Commutator FPS - SPF + END_DOC + double precision, allocatable :: scratch(:,:) + allocate( & + scratch(AO_num_align, AO_num) & + ) + + ! Compute FP + + call dgemm('N','N',AO_num,AO_num,AO_num, & + 1.d0, & + Fock_Matrix_AO,Size(Fock_Matrix_AO,1), & + HF_Density_Matrix_AO,Size(HF_Density_Matrix_AO,1), & + 0.d0, & + scratch,Size(scratch,1)) + + ! Compute FPS + + call dgemm('N','N',AO_num,AO_num,AO_num, & + 1.d0, & + scratch,Size(scratch,1), & + AO_Overlap,Size(AO_Overlap,1), & + 0.d0, & + FPS_SPF_Matrix_AO,Size(FPS_SPF_Matrix_AO,1)) + + ! Compute SP + + call dgemm('N','N',AO_num,AO_num,AO_num, & + 1.d0, & + AO_Overlap,Size(AO_Overlap,1), & + HF_Density_Matrix_AO,Size(HF_Density_Matrix_AO,1), & + 0.d0, & + scratch,Size(scratch,1)) + + ! Compute FPS - SPF + + call dgemm('N','N',AO_num,AO_num,AO_num, & + -1.d0, & + scratch,Size(scratch,1), & + Fock_Matrix_AO,Size(Fock_Matrix_AO,1), & + 1.d0, & + FPS_SPF_Matrix_AO,Size(FPS_SPF_Matrix_AO,1)) + +END_PROVIDER + +bEGIN_PROVIDER [double precision, FPS_SPF_Matrix_MO, (mo_tot_num, mo_tot_num)] + implicit none + begin_doc +! Commutator FPS - SPF in MO basis + end_doc + call ao_to_mo(FPS_SPF_Matrix_AO, size(FPS_SPF_Matrix_AO,1), & + FPS_SPF_Matrix_MO, size(FPS_SPF_Matrix_MO,1)) +END_PROVIDER + + + BEGIN_PROVIDER [ double precision, eigenvalues_Fock_matrix_AO, (AO_num) ] +&BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_AO, (AO_num_align,AO_num) ] + + BEGIN_DOC + ! Eigenvalues and eigenvectors of the Fock matrix over the AO basis + END_DOC + + implicit none + + double precision, allocatable :: scratch(:,:),work(:),Xt(:,:) + integer :: lwork,info + integer :: i,j + + lwork = 3*AO_num - 1 + allocate( & + scratch(AO_num_align,AO_num), & + work(lwork), & + Xt(AO_num,AO_num) & + ) + +! Calculate Xt + + do i=1,AO_num + do j=1,AO_num + Xt(i,j) = X_Matrix_AO(j,i) + enddo + enddo + +! Calculate Fock matrix in orthogonal basis: F' = Xt.F.X + + call dgemm('N','N',AO_num,AO_num,AO_num, & + 1.d0, & + Fock_matrix_AO,size(Fock_matrix_AO,1), & + X_Matrix_AO,size(X_Matrix_AO,1), & + 0.d0, & + eigenvectors_Fock_matrix_AO,size(eigenvectors_Fock_matrix_AO,1)) + + call dgemm('N','N',AO_num,AO_num,AO_num, & + 1.d0, & + Xt,size(Xt,1), & + eigenvectors_Fock_matrix_AO,size(eigenvectors_Fock_matrix_AO,1), & + 0.d0, & + scratch,size(scratch,1)) + +! Diagonalize F' to obtain eigenvectors in orthogonal basis C' and eigenvalues + + call dsyev('V','U',AO_num, & + scratch,size(scratch,1), & + eigenvalues_Fock_matrix_AO, & + work,lwork,info) + + if(info /= 0) then + print *, irp_here//' failed : ', info + stop 1 + endif + +! Back-transform eigenvectors: C =X.C' + + call dgemm('N','N',AO_num,AO_num,AO_num, & + 1.d0, & + X_matrix_AO,size(X_matrix_AO,1), & + scratch,size(scratch,1), & + 0.d0, & + eigenvectors_Fock_matrix_AO,size(eigenvectors_Fock_matrix_AO,1)) + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, X_matrix_AO, (AO_num_align,AO_num) ] + + BEGIN_DOC +! Matrix X = S^{-1/2} obtained by SVD + END_DOC + + implicit none + + integer :: num_linear_dependencies + integer :: LDA, LDC + double precision, allocatable :: U(:,:),Vt(:,:), D(:) + integer :: info, i, j, k + + LDA = size(AO_overlap,1) + LDC = size(X_matrix_AO,1) + + allocate( & + U(LDC,AO_num), & + Vt(LDA,AO_num), & + D(AO_num)) + + call svd( & + AO_overlap,LDA, & + U,LDC, & + D, & + Vt,LDA, & + AO_num,AO_num) + + num_linear_dependencies = 0 + do i=1,AO_num + print*,D(i) + if(abs(D(i)) <= threshold_overlap_AO_eigenvalues) then + D(i) = 0.d0 + num_linear_dependencies += 1 + else + ASSERT (D(i) > 0.d0) + D(i) = 1.d0/sqrt(D(i)) + endif + do j=1,AO_num + X_matrix_AO(j,i) = 0.d0 + enddo + enddo + write(*,*) 'linear dependencies',num_linear_dependencies +! stop + + do k=1,AO_num + if(D(k) /= 0.d0) then + do j=1,AO_num + do i=1,AO_num + X_matrix_AO(i,j) = X_matrix_AO(i,j) + U(i,k)*D(k)*Vt(k,j) + enddo + enddo + endif + enddo + + +END_PROVIDER diff --git a/plugins/Hartree_Fock/EZFIO.cfg b/plugins/Hartree_Fock/EZFIO.cfg index 2fa29cf0..a4b646e1 100644 --- a/plugins/Hartree_Fock/EZFIO.cfg +++ b/plugins/Hartree_Fock/EZFIO.cfg @@ -1,6 +1,24 @@ +[threshold_overlap_ao_eigenvalues] +type: Threshold +doc: Threshold on the magnitude of the smallest eigenvalues of the overlap matrix in the AO basis +interface: ezfio,provider,ocaml +default: 1.e-6 + +[max_dim_diis] +type: integer +doc: Maximum size of the DIIS extrapolation procedure +interface: ezfio,provider,ocaml +default: 15 + +[threshold_diis] +type: Threshold +doc: Threshold on the convergence of the DIIS error vector during a Hartree-Fock calculation. If 0. is chosen, the square root of thresh_scf will be used. +interface: ezfio,provider,ocaml +default: 0. + [thresh_scf] type: Threshold -doc: Threshold on the convergence of the Hartree Fock energy +doc: Threshold on the convergence of the Hartree Fock energy. interface: ezfio,provider,ocaml default: 1.e-10 @@ -8,13 +26,19 @@ default: 1.e-10 type: Strictly_positive_int doc: Maximum number of SCF iterations interface: ezfio,provider,ocaml -default: 200 +default: 500 [level_shift] type: Positive_float doc: Energy shift on the virtual MOs to improve SCF convergence interface: ezfio,provider,ocaml -default: 0.5 +default: 0.0 + +[scf_algorithm] +type: character*(32) +doc: Type of SCF algorithm used. Possible choices are [ Simple | DIIS] +interface: ezfio,provider,ocaml +default: DIIS [mo_guess_type] type: MO_guess diff --git a/plugins/Hartree_Fock/Fock_matrix.irp.f b/plugins/Hartree_Fock/Fock_matrix.irp.f index af9255c8..25eadd24 100644 --- a/plugins/Hartree_Fock/Fock_matrix.irp.f +++ b/plugins/Hartree_Fock/Fock_matrix.irp.f @@ -18,57 +18,57 @@ END_DOC integer :: i,j,n if (elec_alpha_num == elec_beta_num) then - Fock_matrix_mo = Fock_matrix_alpha_mo + Fock_matrix_mo = Fock_matrix_mo_alpha else do j=1,elec_beta_num ! F-K do i=1,elec_beta_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - - (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))& + - (Fock_matrix_mo_beta(i,j) - Fock_matrix_mo_alpha(i,j)) enddo ! F+K/2 do i=elec_beta_num+1,elec_alpha_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - + 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))& + + 0.5d0*(Fock_matrix_mo_beta(i,j) - Fock_matrix_mo_alpha(i,j)) enddo ! F do i=elec_alpha_num+1, mo_tot_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j)) enddo enddo do j=elec_beta_num+1,elec_alpha_num ! F+K/2 do i=1,elec_beta_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - + 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))& + + 0.5d0*(Fock_matrix_mo_beta(i,j) - Fock_matrix_mo_alpha(i,j)) enddo ! F do i=elec_beta_num+1,elec_alpha_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j)) enddo ! F-K/2 do i=elec_alpha_num+1, mo_tot_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - - 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))& + - 0.5d0*(Fock_matrix_mo_beta(i,j) - Fock_matrix_mo_alpha(i,j)) enddo enddo do j=elec_alpha_num+1, mo_tot_num ! F do i=1,elec_beta_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j)) enddo ! F-K/2 do i=elec_beta_num+1,elec_alpha_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - - 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))& + - 0.5d0*(Fock_matrix_mo_beta(i,j) - Fock_matrix_mo_alpha(i,j)) enddo ! F+K do i=elec_alpha_num+1,mo_tot_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) & - + (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j)) & + + (Fock_matrix_mo_beta(i,j) - Fock_matrix_mo_alpha(i,j)) enddo enddo @@ -81,8 +81,8 @@ END_PROVIDER - BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_ao, (ao_num_align, ao_num) ] -&BEGIN_PROVIDER [ double precision, Fock_matrix_beta_ao, (ao_num_align, ao_num) ] + BEGIN_PROVIDER [ double precision, Fock_matrix_ao_alpha, (ao_num_align, ao_num) ] +&BEGIN_PROVIDER [ double precision, Fock_matrix_ao_beta, (ao_num_align, ao_num) ] implicit none BEGIN_DOC ! Alpha Fock matrix in AO basis set @@ -92,8 +92,8 @@ END_PROVIDER do j=1,ao_num !DIR$ VECTOR ALIGNED do i=1,ao_num - Fock_matrix_alpha_ao(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_alpha(i,j) - Fock_matrix_beta_ao (i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_beta (i,j) + Fock_matrix_ao_alpha(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_alpha(i,j) + Fock_matrix_ao_beta (i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_beta (i,j) enddo enddo @@ -261,12 +261,7 @@ END_PROVIDER END_PROVIDER - - - - - -BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_mo, (mo_tot_num_align,mo_tot_num) ] +BEGIN_PROVIDER [ double precision, Fock_matrix_mo_alpha, (mo_tot_num_align,mo_tot_num) ] implicit none BEGIN_DOC ! Fock matrix on the MO basis @@ -275,18 +270,18 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_mo, (mo_tot_num_align,mo_to allocate ( T(ao_num_align,mo_tot_num) ) !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T call dgemm('N','N', ao_num, mo_tot_num, ao_num, & - 1.d0, Fock_matrix_alpha_ao,size(Fock_matrix_alpha_ao,1), & + 1.d0, Fock_matrix_ao_alpha,size(Fock_matrix_ao_alpha,1), & mo_coef, size(mo_coef,1), & 0.d0, T, ao_num_align) call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, & 1.d0, mo_coef,size(mo_coef,1), & T, size(T,1), & - 0.d0, Fock_matrix_alpha_mo, mo_tot_num_align) + 0.d0, Fock_matrix_mo_alpha, mo_tot_num_align) deallocate(T) END_PROVIDER -BEGIN_PROVIDER [ double precision, Fock_matrix_beta_mo, (mo_tot_num_align,mo_tot_num) ] +BEGIN_PROVIDER [ double precision, Fock_matrix_mo_beta, (mo_tot_num_align,mo_tot_num) ] implicit none BEGIN_DOC ! Fock matrix on the MO basis @@ -295,13 +290,13 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_beta_mo, (mo_tot_num_align,mo_tot allocate ( T(ao_num_align,mo_tot_num) ) !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T call dgemm('N','N', ao_num, mo_tot_num, ao_num, & - 1.d0, Fock_matrix_beta_ao,size(Fock_matrix_beta_ao,1), & + 1.d0, Fock_matrix_ao_beta,size(Fock_matrix_ao_beta,1), & mo_coef, size(mo_coef,1), & 0.d0, T, ao_num_align) call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, & 1.d0, mo_coef,size(mo_coef,1), & T, size(T,1), & - 0.d0, Fock_matrix_beta_mo, mo_tot_num_align) + 0.d0, Fock_matrix_mo_beta, mo_tot_num_align) deallocate(T) END_PROVIDER @@ -316,8 +311,8 @@ BEGIN_PROVIDER [ double precision, HF_energy ] do j=1,ao_num do i=1,ao_num HF_energy += 0.5d0 * ( & - (ao_mono_elec_integral(i,j) + Fock_matrix_alpha_ao(i,j) ) * HF_density_matrix_ao_alpha(i,j) +& - (ao_mono_elec_integral(i,j) + Fock_matrix_beta_ao (i,j) ) * HF_density_matrix_ao_beta (i,j) ) + (ao_mono_elec_integral(i,j) + Fock_matrix_ao_alpha(i,j) ) * HF_density_matrix_ao_alpha(i,j) +& + (ao_mono_elec_integral(i,j) + Fock_matrix_ao_beta (i,j) ) * HF_density_matrix_ao_beta (i,j) ) enddo enddo @@ -337,7 +332,7 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_ao, (ao_num_align, ao_num) ] do j=1,ao_num !DIR$ VECTOR ALIGNED do i=1,ao_num_align - Fock_matrix_ao(i,j) = Fock_matrix_alpha_ao(i,j) + Fock_matrix_ao(i,j) = Fock_matrix_ao_alpha(i,j) enddo enddo else diff --git a/plugins/Hartree_Fock/HF_density_matrix_ao.irp.f b/plugins/Hartree_Fock/HF_density_matrix_ao.irp.f index e8585f59..b6efd62c 100644 --- a/plugins/Hartree_Fock/HF_density_matrix_ao.irp.f +++ b/plugins/Hartree_Fock/HF_density_matrix_ao.irp.f @@ -1,4 +1,4 @@ -BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_alpha, (ao_num_align,ao_num) ] +BEGIN_PROVIDER [double precision, HF_density_matrix_ao_alpha, (ao_num_align,ao_num) ] implicit none BEGIN_DOC ! S^-1 x Alpha density matrix in the AO basis x S^-1 diff --git a/plugins/Hartree_Fock/Roothaan_Hall_SCF.irp.f b/plugins/Hartree_Fock/Roothaan_Hall_SCF.irp.f new file mode 100644 index 00000000..5d8097d9 --- /dev/null +++ b/plugins/Hartree_Fock/Roothaan_Hall_SCF.irp.f @@ -0,0 +1,283 @@ +subroutine Roothaan_Hall_SCF + +BEGIN_DOC +! Roothaan-Hall algorithm for SCF Hartree-Fock calculation +END_DOC + + implicit none + + double precision :: energy_SCF,energy_SCF_previous,Delta_energy_SCF + double precision :: max_error_DIIS,max_error_DIIS_alpha,max_error_DIIS_beta + double precision, allocatable :: Fock_matrix_DIIS(:,:,:),error_matrix_DIIS(:,:,:) + + integer :: iteration_SCF,dim_DIIS,index_dim_DIIS + + integer :: i,j + double precision, allocatable :: mo_coef_save(:,:) + + allocate(mo_coef_save(ao_num,mo_tot_num), & + Fock_matrix_DIIS (ao_num,ao_num,max_dim_DIIS), & + error_matrix_DIIS(ao_num,ao_num,max_dim_DIIS) & + ) + + call write_time(output_hartree_fock) + + write(output_hartree_fock,'(A4, 1X, A16, 1X, A16, 1X, A16)') & + '====','================','================','================' + write(output_hartree_fock,'(A4, 1X, A16, 1X, A16, 1X, A16)') & + ' N ', 'Energy ', 'Energy diff ', 'DIIS error ' + write(output_hartree_fock,'(A4, 1X, A16, 1X, A16, 1X, A16)') & + '====','================','================','================' + +! Initialize energies and density matrices + + energy_SCF_previous = HF_energy + Delta_energy_SCF = 1.d0 + iteration_SCF = 0 + dim_DIIS = 0 + max_error_DIIS = 1.d0 + + +! +! Start of main SCF loop +! + do while(( (max_error_DIIS > threshold_DIIS_nonzero).or.(dabs(Delta_energy_SCF) > thresh_SCF) ) .and. (iteration_SCF < n_it_SCF_max)) + +! Increment cycle number + + iteration_SCF += 1 + +! Current size of the DIIS space + + dim_DIIS = min(dim_DIIS+1,max_dim_DIIS) + + if (scf_algorithm == 'DIIS') then + + ! Store Fock and error matrices at each iteration + do j=1,ao_num + do i=1,ao_num + index_dim_DIIS = mod(dim_DIIS-1,max_dim_DIIS)+1 + Fock_matrix_DIIS (i,j,index_dim_DIIS) = Fock_matrix_AO(i,j) + error_matrix_DIIS(i,j,index_dim_DIIS) = FPS_SPF_matrix_AO(i,j) + enddo + enddo + + ! Compute the extrapolated Fock matrix + + call extrapolate_Fock_matrix( & + error_matrix_DIIS,Fock_matrix_DIIS, & + Fock_matrix_AO,size(Fock_matrix_AO,1), & + iteration_SCF,dim_DIIS & + ) + + Fock_matrix_AO_alpha = Fock_matrix_AO*0.5d0 + Fock_matrix_AO_beta = Fock_matrix_AO*0.5d0 + TOUCH Fock_matrix_AO_alpha Fock_matrix_AO_beta + + endif + + MO_coef = eigenvectors_Fock_matrix_MO + + TOUCH MO_coef + +! Calculate error vectors + + max_error_DIIS = maxval(Abs(FPS_SPF_Matrix_MO)) + +! SCF energy + + energy_SCF = HF_energy + Delta_Energy_SCF = energy_SCF - energy_SCF_previous + if ( (SCF_algorithm == 'DIIS').and.(Delta_Energy_SCF > 0.d0) ) then + Fock_matrix_AO(1:ao_num,1:ao_num) = Fock_matrix_DIIS (1:ao_num,1:ao_num,index_dim_DIIS) + Fock_matrix_AO_alpha = Fock_matrix_AO*0.5d0 + Fock_matrix_AO_beta = Fock_matrix_AO*0.5d0 + TOUCH Fock_matrix_AO_alpha Fock_matrix_AO_beta + endif + + double precision :: level_shift_save + level_shift_save = level_shift + mo_coef_save(1:ao_num,1:mo_tot_num) = mo_coef(1:ao_num,1:mo_tot_num) + do while (Delta_Energy_SCF > 0.d0) + mo_coef(1:ao_num,1:mo_tot_num) = mo_coef_save + TOUCH mo_coef + level_shift = level_shift + 0.1d0 + mo_coef(1:ao_num,1:mo_tot_num) = eigenvectors_Fock_matrix_MO(1:ao_num,1:mo_tot_num) + TOUCH mo_coef level_shift + Delta_Energy_SCF = HF_energy - energy_SCF_previous + energy_SCF = HF_energy + if (level_shift-level_shift_save > 1.d0) exit + dim_DIIS=0 + enddo + level_shift = level_shift_save + SOFT_TOUCH level_shift + energy_SCF_previous = energy_SCF + +! Print results at the end of each iteration + + write(output_hartree_fock,'(I4, 1X, F16.10, 1X, F16.10, 1X, F16.10, 1X, I3)') & + iteration_SCF, energy_SCF, Delta_energy_SCF, max_error_DIIS, dim_DIIS + + if (Delta_energy_SCF < 0.d0) then + call save_mos + endif + + enddo + +! +! End of Main SCF loop +! + + write(output_hartree_fock,'(A4, 1X, A16, 1X, A16, 1X, A16)') & + '====','================','================','================' + write(output_hartree_fock,*) + + if(.not.no_oa_or_av_opt)then + call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1),size(Fock_matrix_mo,2),mo_label,1) + endif + + call write_double(output_hartree_fock, Energy_SCF, 'Hartree-Fock energy') + call ezfio_set_hartree_fock_energy(Energy_SCF) + + call write_time(output_hartree_fock) + +end + +subroutine extrapolate_Fock_matrix( & + error_matrix_DIIS,Fock_matrix_DIIS, & + Fock_matrix_AO_,size_Fock_matrix_AO, & + iteration_SCF,dim_DIIS & +) + +BEGIN_DOC +! Compute the extrapolated Fock matrix using the DIIS procedure +END_DOC + + implicit none + + double precision,intent(in) :: Fock_matrix_DIIS(ao_num,ao_num,*),error_matrix_DIIS(ao_num,ao_num,*) + integer,intent(in) :: iteration_SCF, size_Fock_matrix_AO + double precision,intent(inout):: Fock_matrix_AO_(size_Fock_matrix_AO,ao_num) + integer,intent(inout) :: dim_DIIS + + double precision,allocatable :: B_matrix_DIIS(:,:),X_vector_DIIS(:) + double precision,allocatable :: C_vector_DIIS(:) + + double precision,allocatable :: scratch(:,:) + integer :: i,j,k,i_DIIS,j_DIIS + + allocate( & + B_matrix_DIIS(dim_DIIS+1,dim_DIIS+1), & + X_vector_DIIS(dim_DIIS+1), & + C_vector_DIIS(dim_DIIS+1), & + scratch(ao_num,ao_num) & + ) + +! Compute the matrices B and X + do j=1,dim_DIIS + do i=1,dim_DIIS + + j_DIIS = mod(iteration_SCF-j,max_dim_DIIS)+1 + i_DIIS = mod(iteration_SCF-i,max_dim_DIIS)+1 + +! Compute product of two errors vectors + + call dgemm('N','N',ao_num,ao_num,ao_num, & + 1.d0, & + error_matrix_DIIS(1,1,i_DIIS),size(error_matrix_DIIS,1), & + error_matrix_DIIS(1,1,j_DIIS),size(error_matrix_DIIS,1), & + 0.d0, & + scratch,size(scratch,1)) + +! Compute Trace + + B_matrix_DIIS(i,j) = 0.d0 + do k=1,ao_num + B_matrix_DIIS(i,j) = B_matrix_DIIS(i,j) + scratch(k,k) + enddo + enddo + enddo + +! Pad B matrix and build the X matrix + + do i=1,dim_DIIS + B_matrix_DIIS(i,dim_DIIS+1) = -1.d0 + B_matrix_DIIS(dim_DIIS+1,i) = -1.d0 + C_vector_DIIS(i) = 0.d0 + enddo + B_matrix_DIIS(dim_DIIS+1,dim_DIIS+1) = 0.d0 + C_vector_DIIS(dim_DIIS+1) = -1.d0 + +! Solve the linear system C = B.X + + integer :: info + integer,allocatable :: ipiv(:) + + allocate( & + ipiv(dim_DIIS+1) & + ) + + double precision, allocatable :: AF(:,:) + allocate (AF(dim_DIIS+1,dim_DIIS+1)) + double precision :: rcond, ferr, berr + integer :: iwork(dim_DIIS+1), lwork + + call dsysvx('N','U',dim_DIIS+1,1, & + B_matrix_DIIS,size(B_matrix_DIIS,1), & + AF, size(AF,1), & + ipiv, & + C_vector_DIIS,size(C_vector_DIIS,1), & + X_vector_DIIS,size(X_vector_DIIS,1), & + rcond, & + ferr, & + berr, & + scratch,-1, & + iwork, & + info & + ) + lwork = int(scratch(1,1)) + deallocate(scratch) + allocate(scratch(lwork,1)) + + call dsysvx('N','U',dim_DIIS+1,1, & + B_matrix_DIIS,size(B_matrix_DIIS,1), & + AF, size(AF,1), & + ipiv, & + C_vector_DIIS,size(C_vector_DIIS,1), & + X_vector_DIIS,size(X_vector_DIIS,1), & + rcond, & + ferr, & + berr, & + scratch,size(scratch), & + iwork, & + info & + ) + + if(info < 0) then + stop 'bug in DIIS' + endif + + if (rcond > 1.d-12) then + + ! Compute extrapolated Fock matrix + + + !$OMP PARALLEL DO PRIVATE(i,j,k) DEFAULT(SHARED) + do j=1,ao_num + do i=1,ao_num + Fock_matrix_AO_(i,j) = 0.d0 + enddo + do k=1,dim_DIIS + do i=1,ao_num + Fock_matrix_AO_(i,j) = Fock_matrix_AO_(i,j) + & + X_vector_DIIS(k)*Fock_matrix_DIIS(i,j,dim_DIIS-k+1) + enddo + enddo + enddo + !$OMP END PARALLEL DO + + else + dim_DIIS = 0 + endif + +end diff --git a/plugins/Hartree_Fock/SCF.irp.f b/plugins/Hartree_Fock/SCF.irp.f index dead61ee..64263e83 100644 --- a/plugins/Hartree_Fock/SCF.irp.f +++ b/plugins/Hartree_Fock/SCF.irp.f @@ -13,7 +13,7 @@ end subroutine create_guess implicit none BEGIN_DOC -! Create an MO guess if no MOs are present in the EZFIO directory +! Create a MO guess if no MOs are present in the EZFIO directory END_DOC logical :: exists PROVIDE ezfio_filename @@ -34,21 +34,30 @@ subroutine create_guess endif end +ao_to_mo subroutine run + BEGIN_DOC +! Run SCF calculation + END_DOC + use bitmasks implicit none - BEGIN_DOC -! Run SCF calculation - END_DOC + double precision :: SCF_energy_before,SCF_energy_after,diag_H_mat_elem - double precision :: E0 + double precision :: EHF integer :: i_it, i, j, k - E0 = HF_energy + EHF = HF_energy mo_label = "Canonical" - call damping_SCF + +! Choose SCF algorithm + +! call damping_SCF ! Deprecated routine + call Roothaan_Hall_SCF end + + diff --git a/plugins/Hartree_Fock/damping_SCF.irp.f b/plugins/Hartree_Fock/damping_SCF.irp.f index aa6f02b0..58fcb3e2 100644 --- a/plugins/Hartree_Fock/damping_SCF.irp.f +++ b/plugins/Hartree_Fock/damping_SCF.irp.f @@ -114,7 +114,6 @@ subroutine damping_SCF mo_coef = eigenvectors_fock_matrix_mo TOUCH mo_coef - enddo write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') '====','================','================','================', '====' write(output_hartree_fock,*) diff --git a/plugins/Hartree_Fock/diagonalize_fock.irp.f b/plugins/Hartree_Fock/diagonalize_fock.irp.f index c80077b3..b303b537 100644 --- a/plugins/Hartree_Fock/diagonalize_fock.irp.f +++ b/plugins/Hartree_Fock/diagonalize_fock.irp.f @@ -10,85 +10,95 @@ integer, allocatable :: iwork(:) double precision, allocatable :: work(:), F(:,:), S(:,:) - - 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 + + allocate( F(mo_tot_num,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 + if(no_oa_or_av_opt)then + integer :: iorb,jorb + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_inact_orb + jorb = list_inact(j) + F(iorb,jorb) = 0.d0 + F(jorb,iorb) = 0.d0 enddo - if(no_oa_or_av_opt)then - integer :: iorb,jorb - do i = 1, n_act_orb - iorb = list_act(i) - do j = 1, n_inact_orb - jorb = list_inact(j) - F(iorb,jorb) = 0.d0 - F(jorb,iorb) = 0.d0 - enddo - do j = 1, n_virt_orb - jorb = list_virt(j) - F(iorb,jorb) = 0.d0 - F(jorb,iorb) = 0.d0 - enddo - do j = 1, n_core_orb - jorb = list_core(j) - F(iorb,jorb) = 0.d0 - F(jorb,iorb) = 0.d0 - enddo - enddo - endif - - - - - ! Insert level shift here - do i = elec_beta_num+1, elec_alpha_num - F(i,i) += 0.5d0*level_shift + do j = 1, n_virt_orb + jorb = list_virt(j) + F(iorb,jorb) = 0.d0 + F(jorb,iorb) = 0.d0 enddo - - do i = elec_alpha_num+1, mo_tot_num - F(i,i) += level_shift + do j = 1, n_core_orb + jorb = list_core(j) + F(iorb,jorb) = 0.d0 + F(jorb,iorb) = 0.d0 enddo + enddo + endif + + + + + ! Insert level shift here + do i = elec_beta_num+1, elec_alpha_num + F(i,i) += 0.5d0*level_shift + enddo + + do i = elec_alpha_num+1, mo_tot_num + F(i,i) += level_shift + enddo + + n = mo_tot_num + lwork = 1+6*n + 2*n*n + liwork = 3 + 5*n + + allocate(work(lwork)) + allocate(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//' DSYEVD failed : ', info + stop 1 + endif + lwork = int(work(1)) + liwork = iwork(1) + deallocate(iwork) + deallocate(work) + + allocate(work(lwork)) + allocate(iwork(liwork) ) + call dsyevd( 'V', 'U', mo_tot_num, F, & + size(F,1), diagonal_Fock_matrix_mo, & + work, lwork, iwork, liwork, info) + deallocate(iwork) + + + if (info /= 0) then + call dsyev( 'V', 'L', mo_tot_num, F, & + size(F,1), diagonal_Fock_matrix_mo, & + work, lwork, info) + + if (info /= 0) then + print *, irp_here//' DSYEV failed : ', info + stop 1 + endif + 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, F) + - 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 END_PROVIDER diff --git a/plugins/Hartree_Fock/huckel.irp.f b/plugins/Hartree_Fock/huckel.irp.f index 103de83a..a7e852a6 100644 --- a/plugins/Hartree_Fock/huckel.irp.f +++ b/plugins/Hartree_Fock/huckel.irp.f @@ -22,7 +22,7 @@ subroutine huckel_guess 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) + Fock_matrix_ao(j,j) = Fock_matrix_ao_alpha(j,j) enddo TOUCH Fock_matrix_ao mo_coef = eigenvectors_fock_matrix_mo diff --git a/plugins/Hartree_Fock_SlaterDressed/EZFIO.cfg b/plugins/Hartree_Fock_SlaterDressed/EZFIO.cfg new file mode 100644 index 00000000..8e4b2847 --- /dev/null +++ b/plugins/Hartree_Fock_SlaterDressed/EZFIO.cfg @@ -0,0 +1,14 @@ +[slater_expo_ezfio] +type: double precision +doc: Exponents of the additional Slater functions +size: (nuclei.nucl_num) +interface: ezfio, provider + +[slater_coef_ezfio] +type: double precision +doc: Exponents of the additional Slater functions +size: (nuclei.nucl_num,mo_basis.mo_tot_num) +interface: ezfio, provider + + + diff --git a/plugins/Hartree_Fock_SlaterDressed/LinearSystem.irp.f b/plugins/Hartree_Fock_SlaterDressed/LinearSystem.irp.f new file mode 100644 index 00000000..490e344c --- /dev/null +++ b/plugins/Hartree_Fock_SlaterDressed/LinearSystem.irp.f @@ -0,0 +1,53 @@ +BEGIN_PROVIDER [ double precision, cusp_A, (nucl_num, nucl_num) ] + implicit none + BEGIN_DOC + ! Equations to solve : A.X = B + END_DOC + + integer :: mu, A, B + + cusp_A = 0.d0 + do A=1,nucl_num + cusp_A(A,A) = slater_expo(A)/nucl_charge(A) * slater_value_at_nucl(A,A) + do B=1,nucl_num + cusp_A(A,B) -= slater_value_at_nucl(B,A) + ! Projector + do mu=1,mo_tot_num + cusp_A(A,B) += MOSlaOverlap_matrix(mu,B) * mo_value_at_nucl(mu,A) + enddo + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, cusp_B, (nucl_num, mo_tot_num) ] + implicit none + BEGIN_DOC + ! Equations to solve : A.C = B + END_DOC + + integer :: i, A, info + + do i=1,mo_tot_num + do A=1,nucl_num + cusp_B(A,i) = mo_value_at_nucl(i,A) + enddo + enddo +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, cusp_C, (nucl_num, mo_tot_num) ] + implicit none + BEGIN_DOC + ! Equations to solve : A.C = B + END_DOC + + double precision, allocatable :: AF(:,:) + integer :: info + allocate ( AF(nucl_num,nucl_num) ) + + call get_pseudo_inverse(cusp_A,nucl_num,nucl_num,AF,size(AF,1)) + call dgemm('N','N',nucl_num,mo_tot_num,nucl_num,1.d0, & + AF,size(AF,1), cusp_B, size(cusp_B,1), 0.d0, cusp_C, size(cusp_C,1)) + +END_PROVIDER + diff --git a/plugins/Hartree_Fock_SlaterDressed/SCF_dressed.irp.f b/plugins/Hartree_Fock_SlaterDressed/SCF_dressed.irp.f new file mode 100644 index 00000000..a8c1351a --- /dev/null +++ b/plugins/Hartree_Fock_SlaterDressed/SCF_dressed.irp.f @@ -0,0 +1,98 @@ +program scf + BEGIN_DOC +! Produce `Hartree_Fock` MO orbital with Slater cusp dressing +! output: mo_basis.mo_tot_num mo_basis.mo_label mo_basis.ao_md5 mo_basis.mo_coef mo_basis.mo_occ +! output: hartree_fock.energy +! optional: mo_basis.mo_coef + END_DOC + call check_mos + call debug + call run +end + +subroutine check_mos + implicit none + BEGIN_DOC +! Create a MO guess if no MOs are present in the EZFIO directory + END_DOC + logical :: exists + PROVIDE ezfio_filename + call ezfio_has_mo_basis_mo_coef(exists) + if (.not.exists) then + print *, 'Please run SCF first' + stop + endif +end + +subroutine debug + implicit none + integer :: i,j,k + print *, 'A' + do i=1,nucl_num + print *, i, cusp_A(1:nucl_num, i) + enddo + print *, 'B' + do i=1,mo_tot_num + print *, i, cusp_B(1:nucl_num, i) + enddo + print *, 'X' + do i=1,mo_tot_num + print *, i, cusp_C(1:nucl_num, i) + enddo + print *, '-----' + return + do k=-100,100 + double precision :: x, y, z + x = 0.01d0 * k + y = 0.d0 + do i=1,ao_num + z = 0.d0 + do j=1,ao_prim_num(i) + z += ao_coef_normalized_ordered_transp(j,i) * dexp(-ao_expo_ordered_transp(j,i) * x**2) + enddo + y += mo_coef(i,1) * z + y += exp(-slater_expo(1)*dabs(x)) * slater_coef(1,1) + z = 0.d0 + do j=1,ao_prim_num(i) + z += ao_coef_normalized_ordered_transp(j,i) * dexp(-ao_expo_ordered_transp(j,i) * x**2) + enddo + y -= z * GauSlaOverlap_matrix(i,1)* slater_coef(1,1) + enddo + print *, x, y + enddo + print *, '-----' +end + +subroutine run + + BEGIN_DOC +! Run SCF calculation + END_DOC + + use bitmasks + implicit none + + double precision :: SCF_energy_before,SCF_energy_after,diag_H_mat_elem + double precision :: EHF + integer :: i_it, i, j, k + + mo_label = "CuspDressed" + + + print *, HF_energy + + call ezfio_set_Hartree_Fock_SlaterDressed_slater_coef_ezfio(cusp_C) + + do i=1,ao_num + print *, mo_coef(i,1), cusp_corrected_mos(i,1) + enddo + mo_coef(1:ao_num,1:mo_tot_num) = cusp_corrected_mos(1:ao_num,1:mo_tot_num) + TOUCH mo_coef + + EHF = HF_energy + print *, HF_energy +! call Roothaan_Hall_SCF + +end + + diff --git a/plugins/Hartree_Fock_SlaterDressed/at_nucl.irp.f b/plugins/Hartree_Fock_SlaterDressed/at_nucl.irp.f new file mode 100644 index 00000000..910c5a16 --- /dev/null +++ b/plugins/Hartree_Fock_SlaterDressed/at_nucl.irp.f @@ -0,0 +1,66 @@ +BEGIN_PROVIDER [ double precision , ao_value_at_nucl, (ao_num,nucl_num) ] + implicit none + BEGIN_DOC +! Values of the atomic orbitals at the nucleus + END_DOC + integer :: i,j,k + double precision :: x,y,z,expo,poly, r2 + + do k=1,nucl_num + do i=1,ao_num + x = nucl_coord(ao_nucl(i),1) - nucl_coord(k,1) + y = nucl_coord(ao_nucl(i),2) - nucl_coord(k,2) + z = nucl_coord(ao_nucl(i),3) - nucl_coord(k,3) + poly = x**(ao_power(i,1)) * y**(ao_power(i,2)) * z**(ao_power(i,3)) + if (poly == 0.d0) cycle + + r2 = (x*x) + (y*y) + (z*z) + ao_value_at_nucl(i,k) = 0.d0 + do j=1,ao_prim_num(i) + expo = ao_expo_ordered_transp(j,i)*r2 + if (expo > 40.d0) cycle + ao_value_at_nucl(i,k) = ao_value_at_nucl(i,k) + & + ao_coef_normalized_ordered_transp(j,i) * & + dexp(-expo) + enddo + ao_value_at_nucl(i,k) *= poly + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, mo_value_at_nucl, (mo_tot_num,nucl_num) ] + implicit none + BEGIN_DOC +! Values of the molecular orbitals at the nucleus + END_DOC + + call dgemm('N','N',mo_tot_num,nucl_num,ao_num,1.d0, & + mo_coef_transp, size(mo_coef_transp,1), & + ao_value_at_nucl, size(ao_value_at_nucl,1), & + 0.d0, mo_value_at_nucl, size(mo_value_at_nucl,1)) +END_PROVIDER + + +BEGIN_PROVIDER [ double precision , slater_value_at_nucl, (nucl_num,nucl_num) ] + implicit none + BEGIN_DOC +! Values of the Slater orbitals (1) at the nucleus (2) + END_DOC + integer :: i,j,k + double precision :: x,y,z,expo,poly, r + + do k=1,nucl_num + do i=1,nucl_num + x = nucl_coord(i,1) - nucl_coord(k,1) + y = nucl_coord(i,2) - nucl_coord(k,2) + z = nucl_coord(i,3) - nucl_coord(k,3) + +! expo = slater_expo(i)*slater_expo(i)*((x*x) + (y*y) + (z*z)) +! if (expo > 160.d0) cycle +! expo = dsqrt(expo) + expo = slater_expo(i) * dsqrt((x*x) + (y*y) + (z*z)) + slater_value_at_nucl(i,k) = dexp(-expo) * slater_normalization(i) + enddo + enddo +END_PROVIDER + diff --git a/plugins/Hartree_Fock_SlaterDressed/integrals.irp.f b/plugins/Hartree_Fock_SlaterDressed/integrals.irp.f new file mode 100644 index 00000000..1111055b --- /dev/null +++ b/plugins/Hartree_Fock_SlaterDressed/integrals.irp.f @@ -0,0 +1,624 @@ +!***************************************************************************** +subroutine GauSlaOverlap(expGau,cGau,aGau,expSla,cSla,result) + implicit none + + BEGIN_DOC + ! Compute the overlap integral between a Gaussian function + ! with arbitrary angular momemtum and a s-type Slater function + END_DOC + +! Input variables + double precision,intent(in) :: expGau,expSla + double precision,intent(in) :: cGau(3),cSla(3) + integer,intent(in) :: aGau(3) + double precision,intent(out) :: result + +! Final value of the integrals + double precision :: ss,ps,ds + double precision :: pxs,pys,pzs + double precision :: dxxs,dyys,dzzs,dxys,dxzs,dyzs + + double precision :: pi,E,AB,AxBx,AyBy,AzBz,t,u,k + + pi = 4d0*atan(1d0) + +! calculate the length AB between the two centers and other usful quantities + + AB = (cGau(1)-cSla(1))**2 + (cGau(2)-cSla(2))**2 + (cGau(3)-cSla(3))**2 + AB = dsqrt(AB) + + AxBx = (cGau(1)-cSla(1))/2d0 + AyBy = (cGau(2)-cSla(2))/2d0 + AzBz = (cGau(3)-cSla(3))/2d0 + ds = 0.d0 + +! intermediate variables + + t = expSla*dsqrt(0.25d0/expGau) + u = dsqrt(expGau)*AB + + double precision :: d, et2 + if(AB > 0d0) then + +! (s|s) + ss = 0.d0 + + d = derfc(t+u) + if (dabs(d) > 1.d-30) then + ss = (t+u)*d*dexp(2d0*t*(t+u)) + endif + + d = derfc(t-u) + if (dabs(d) > 1.d-30) then + ss -= (t-u)*d*dexp(2d0*t*(t-u)) + endif + +! (p|s) + ps = 0.d0 + if (t*t-u*u > 300.d0) then + et2 = huge(1.0) + else + et2 = dexp(t*t-u*u) + endif + if (et2 /= 0.d0) then + d = derfc(t-u) + if (d /= 0.d0) then + ps += dexp((t-u)**2)*(1d0+2d0*t*(t-u))*d + endif + d = derfc(t+u) + if (d /= 0.d0) then + ps += dexp((t+u)**2)*(1d0+2d0*t*(t+u))*d + endif + ps *= dsqrt(pi) + ps -= 4d0*t + ps *= et2/dsqrt(pi) + endif + +! (d|s) +! ds = 4d0*dexp(2d0*t*(t-u))*t*(-((1d0+t**2-t*u)*derfc(t-u))+dexp(4d0*t*u)*(1d0+t*(t+u))*derfc(t+u)) + ds = 0.d0 + d = derfc(t+u) + if (d /= 0.d0) then + ds = dexp(4d0*t*u)*(1d0+t*(t+u))*d + endif + d = derfc(t-u) + if (d /= 0.d0) then + ds -= (1d0+t*t-t*u)*d + endif + + if ( dabs(ds) > 1.d-100) then + ds *= 4d0*dexp(2d0*t*(t-u))*t + endif + +! backward scaling + ds = 3d0*ss/u**5d0 - 3d0*ps/u**4d0 + ds/u**3d0 + ps = ps/u**2-ss/u**3d0 + ss = ss/u + + else + +! concentric case + d = derfc(t) + if (d /= 0.d0) then + et2 = dexp(t*t) + ss = 2d0*et2*((-2d0*t)/dsqrt(pi)+et2*(1d0+2d0*t*t)*d) + ps = (8d0*et2*t*(-2d0*(1d0+t*t)+et2*dsqrt(pi)*t*(3d0+2d0*t*t)*d))/(3d0*dsqrt(pi)) + else + ss = 0.d0 + ps = 0.d0 + endif + + endif + + k = t**3d0*dexp(-t*t)*4d0*pi/expSla**(3d0/2d0) + +! (s|s) + ss = k*ss + +! (p|s) + ps = k*ps + + pxs = AxBx*ps + pys = AyBy*ps + pzs = AzBz*ps + +! (d|s) + ds = k*ds + + dxxs = (2d0*ss+ps)/(4d0*expGau) + AxBx**2*ds + dyys = (2d0*ss+ps)/(4d0*expGau) + AyBy**2*ds + dzzs = (2d0*ss+ps)/(4d0*expGau) + AzBz**2*ds + + dxys = AxBx*AyBy*ds + dxzs = AxBx*AzBz*ds + dyzs = AyBy*AzBz*ds + + select case (sum(aGau)) + case (0) + result = ss + + case (1) + if (aGau(1) == 1) then + result = pxs + else if (aGau(2) == 1) then + result = pys + else if (aGau(3) == 1) then + result = pzs + endif + + case (2) + if (aGau(1) == 2) then + result = dxxs + else if (aGau(2) == 2) then + result = dyys + else if (aGau(3) == 2) then + result = dzzs + else if (aGau(1)+aGau(2) == 2) then + result = dxys + else if (aGau(1)+aGau(3) == 2) then + result = dxzs + else if (aGau(2)+aGau(3) == 2) then + result = dyzs + endif + + case default + stop 'GauSlaOverlap not implemented' + + end select + +end +!***************************************************************************** + +!***************************************************************************** +subroutine GauSlaKinetic(expGau,cGau,aGau,expSla,cSla,result) + + implicit none + + BEGIN_DOC + ! Compute the kinetic energy integral between a Gaussian function + ! with arbitrary angular momemtum and a s-type Slater function + END_DOC + +! Input variables + double precision,intent(in) :: expGau,expSla + double precision,intent(in) :: cGau(3),cSla(3) + integer,intent(in) :: aGau(3) + double precision,intent(out) :: result + +! Final value of the integrals + double precision :: ss,ps,ds + double precision :: pxs,pys,pzs + double precision :: dxxs,dyys,dzzs,dxys,dxzs,dyzs + + double precision :: pi,E,AB,AxBx,AyBy,AzBz,t,u,k + + pi = 4d0*atan(1d0) + +! calculate the length AB between the two centers + + AB = (cGau(1)-cSla(1))**2 + (cGau(2)-cSla(2))**2 + (cGau(3)-cSla(3))**2 + AB = dsqrt(AB) + + AxBx = (cGau(1)-cSla(1))/2d0 + AyBy = (cGau(2)-cSla(2))/2d0 + AzBz = (cGau(3)-cSla(3))/2d0 + +! intermediate variables + + t = expSla*dsqrt(0.25d0/expGau) + u = dsqrt(expGau)*AB + + if(AB > 0d0) then + +! (s|s) + ss = (1d0+t*(t-u))*derfc(t-u)*dexp(2d0*t*(t-u)) - (1d0+t*(t+u))*derfc(t+u)*dexp(2d0*t*(t+u)) + +! (p|s) + ps = (dexp(t**2-2d0*t*u-u**2)*(4d0*dexp(2d0*t*u)*(1d0+t**2) & + + dsqrt(pi)*t*(-(dexp(t**2+u**2)*(3d0+2d0*t*(t-u))*derfc(t-u)) & + - dexp(2d0*t*u+(t+u)**2)*(3d0+2d0*t*(t+u))*derfc(t+u))))/dsqrt(pi) + +! (d|s) + ds = (-8d0*dexp(t**2-u**2)*u+4d0*dexp(2d0*t*(t-u))*dsqrt(pi)*t**2*((2d0+t**2-t*u)*derfc(t-u) & + - dexp(4d0*t*u)*(2d0+t*(t+u))*derfc(t+u)))/dsqrt(pi) + +! backward scaling + ds = 3d0*ss/u**5d0 - 3d0*ps/u**4d0 + ds/u**3d0 + ps = ps/u**2-ss/u**3d0 + ss = ss/u + + else + +! concentric case + ss = (4d0*dexp(t**2)*(1d0+t**2))/dsqrt(pi)-2d0*dexp(2d0*t**2)*t*(3d0+2d0*t**2)*derfc(t) + ps = (8d0*dexp(t**2)*(-1d0+4d0*t**2+2d0*t**4d0-dexp(t**2)*dsqrt(pi)*t**3d0*(5d0+2d0*t**2)*derfc(t)))/(3d0*dsqrt(pi)) + + endif + + k = expSla*dsqrt(expGau)*t**3d0*dexp(-t*t)*4d0*pi/expSla**(3d0/2d0) + +! (s|s) + ss = k*ss + +! (p|s) + ps = k*ps + + pxs = AxBx*ps + pys = AyBy*ps + pzs = AzBz*ps + +! (d|s) + ds = k*ds + + dxxs = (2d0*ss+ps)/(4d0*expGau) + AxBx**2*ds + dyys = (2d0*ss+ps)/(4d0*expGau) + AyBy**2*ds + dzzs = (2d0*ss+ps)/(4d0*expGau) + AzBz**2*ds + + dxys = AxBx*AyBy*ds + dxzs = AxBx*AzBz*ds + dyzs = AyBy*AzBz*ds + + select case (sum(aGau)) + case (0) + result = ss + + case (1) + if (aGau(1) == 1) then + result = pxs + else if (aGau(2) == 1) then + result = pys + else if (aGau(3) == 1) then + result = pzs + endif + + case (2) + if (aGau(1) == 2) then + result = dxxs + else if (aGau(2) == 2) then + result = dyys + else if (aGau(3) == 2) then + result = dzzs + else if (aGau(1)+aGau(2) == 2) then + result = dxys + else if (aGau(1)+aGau(3) == 2) then + result = dxzs + else if (aGau(2)+aGau(3) == 2) then + result = dyzs + endif + + case default + stop 'GauSlaOverlap not implemented' + + end select + +end +!***************************************************************************** + + + +!***************************************************************************** +subroutine GauSlaNuclear(expGau,cGau,aGau,expSla,cSla,ZNuc,cNuc,result) + + implicit none + + BEGIN_DOC + ! Compute the nuclear attraction integral between a Gaussian function + ! with arbitrary angular momemtum and a s-type Slater function + END_DOC + +! Input variables + double precision,intent(in) :: expGau,expSla + double precision,intent(in) :: cGau(3),cSla(3) + integer,intent(in) :: aGau(3) + double precision,intent(in) :: cNuc(3) + double precision,intent(in) :: ZNuc + double precision,intent(out) :: result + +! Final value of the overlap integral + double precision :: ss,ps,ds,fs + double precision :: pxs,pys,pzs + + double precision :: pi,E,AB,x,y,k + + pi = 4d0*atan(1d0) + E = exp(1d0) + +! calculate the length AB between the two centers + + AB = (cGau(1)-cSla(1))**2 + (cGau(2)-cSla(2))**2 + (cGau(3)-cSla(3))**2 + AB = dsqrt(AB) + +! intermediate variables + + x = dsqrt(expSla**2/(4d0*expGau)) + y = dsqrt(expGau)*AB + + if(AB > 0d0) then + ss = (1d0+x*(x+y))*derfc(x+y)*dexp(2d0*x*(x+y)) - (1d0+x*(x-y))*derfc(x-y)*dexp(2d0*x*(x-y)) + ss = ss/y + else + ss = (4d0*E**x**2*(1d0+x**2))/dsqrt(Pi)-2d0*E**(2d0*x**2)*x*(3d0+2d0*x**2)*dErfc(x) + endif + + k = expSla*dsqrt(expGau)*x**3d0*dexp(-x*x)*4d0*pi/expSla**(3d0/2d0) + ss = k*ss + +! Print result + write(*,*) ss + result = 0.d0 + +end +!***************************************************************************** + +double precision function BoysF0(t) + implicit none + double precision, intent(in) :: t + double precision :: pi + + pi = 4d0*atan(1d0) + + if(t > 0d0) then + BoysF0 = 0.5d0*dsqrt(pi/t)*derf(dsqrt(t)) + else + BoysF0 = 1d0 + endif + +end +!***************************************************************************** + +!TODO +subroutine GauSlaOverlap_write(expGau,cGau,aGau,expSla,cSla,result,iunit) + implicit none + double precision,intent(in) :: expGau,expSla + double precision,intent(in) :: cGau(3),cSla(3) + integer,intent(in) :: aGau(3) + integer,intent(in) :: iunit + double precision,intent(out) :: result + write(iunit, *) & + 'SDrSla[ {',expGau,',{',cGau(1),',',cGau(2),',',cGau(3),'},{',aGau(1),',',aGau(2),',',aGau(3),'} },{', expSla,', {',cSla(1),',',cSla(2),',',cSla(3),'} } ],' + result = 0.d0 +end + +subroutine GauSlaOverlap_read(expGau,cGau,aGau,expSla,cSla,result,iunit) + implicit none + double precision,intent(in) :: expGau,expSla + double precision,intent(in) :: cGau(3),cSla(3) + integer,intent(in) :: aGau(3) + integer,intent(in) :: iunit + double precision,intent(out) :: result + read(iunit, *) result +end + +subroutine GauSlaKinetic_write(expGau,cGau,aGau,expSla,cSla,result,iunit) + implicit none + double precision,intent(in) :: expGau,expSla + double precision,intent(in) :: cGau(3),cSla(3) + integer,intent(in) :: aGau(3) + integer,intent(in) :: iunit + double precision,intent(out) :: result + write(iunit, *) & + 'TDrSla[ {',expGau,',{',cGau(1),',',cGau(2),',',cGau(3),'},{',aGau(1),',',aGau(2),',',aGau(3),'} },{', expSla,',{',cSla(1),',',cSla(2),',',cSla(3),'} } ],' + result = 0.d0 +end + +subroutine GauSlaKinetic_read(expGau,cGau,aGau,expSla,cSla,result,iunit) + implicit none + double precision,intent(in) :: expGau,expSla + double precision,intent(in) :: cGau(3),cSla(3) + integer,intent(in) :: aGau(3) + integer,intent(in) :: iunit + double precision,intent(out) :: result + read(iunit, *) result +end + +subroutine GauSlaNuclear_write(expGau,cGau,aGau,expSla,cSla,ZNuc,cNuc,result,iunit) + implicit none + double precision,intent(in) :: expGau,expSla + double precision,intent(in) :: cGau(3),cSla(3) + integer,intent(in) :: aGau(3) + double precision,intent(in) :: cNuc(3) + double precision,intent(in) :: ZNuc + integer,intent(in) :: iunit + double precision,intent(out) :: result + write(iunit, *) & + 'VDrSla[ {',expGau,',{',cGau(1),',',cGau(2),',',cGau(3),'},{',aGau(1),',',aGau(2),',',aGau(3),'} },{ ', expSla,',{',cSla(1),',',cSla(2),',',cSla(3),'} }, {', ZNuc, ',{', cNuc(1),',', cNuc(2),',', cNuc(3), '} } ],' + result = 0.d0 +end + +subroutine GauSlaNuclear_read(expGau,cGau,aGau,expSla,cSla,ZNuc,cNuc,result,iunit) + implicit none + double precision,intent(in) :: expGau,expSla + double precision,intent(in) :: cGau(3),cSla(3) + integer,intent(in) :: aGau(3) + double precision,intent(in) :: cNuc(3) + double precision,intent(in) :: ZNuc + integer,intent(in) :: iunit + double precision,intent(out) :: result + read(iunit, *) result +end +!TODO + +BEGIN_TEMPLATE + +BEGIN_PROVIDER [ double precision, GauSla$X_matrix, (ao_num, nucl_num) ] + implicit none + BEGIN_DOC + ! overlap matrix + END_DOC + integer :: i,j,k + double precision :: cGau(3) + double precision :: cSla(3) + double precision :: expSla, res, expGau + integer :: aGau(3) + +!TODO + logical :: read + integer :: iunit + integer :: getunitandopen + + inquire(FILE=trim(ezfio_filename)//'/work/GauSla$X.dat',EXIST=read) + if (read) then + print *, 'READ $X' + iunit = getunitandopen(trim(ezfio_filename)//'/work/GauSla$X.dat','r') + else + print *, 'WRITE $X' + iunit = getunitandopen(trim(ezfio_filename)//'/work/GauSla$X.inp','w') + write(iunit,*) '{' + endif +!TODO + + do k=1,nucl_num + cSla(1:3) = nucl_coord_transp(1:3,k) + expSla = slater_expo(k) + + do i=1,ao_num + cGau(1:3) = nucl_coord_transp(1:3, ao_nucl(i)) + aGau(1:3) = ao_power(i,1:3) + GauSla$X_matrix(i,k) = 0.d0 + + do j=1,ao_prim_num(i) + expGau = ao_expo_ordered_transp(j,i) +! call GauSla$X(expGau,cGau,aGau,expSla,cSla,res) + if (read) then + call GauSla$X_read(expGau,cGau,aGau,expSla,cSla,res,iunit) + else + call GauSla$X_write(expGau,cGau,aGau,expSla,cSla,res,iunit) + endif + GauSla$X_matrix(i,k) += ao_coef_normalized_ordered_transp(j,i) * res + enddo + + enddo + + enddo + if (.not.read) then + write(iunit,*) '0.}' + endif + close(iunit) + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, MOSla$X_matrix, (mo_tot_num, nucl_num) ] + implicit none + BEGIN_DOC +! + END_DOC + call dgemm('N','N',mo_tot_num,nucl_num,ao_num,1.d0, & + mo_coef_transp, size(mo_coef_transp,1), & + GauSla$X_matrix, size(GauSla$X_matrix,1), & + 0.d0, MOSla$X_matrix, size(MOSla$X_matrix,1)) +END_PROVIDER + +BEGIN_PROVIDER [ double precision, AO_orthoSla$X_matrix, (ao_num, nucl_num) ] + implicit none + BEGIN_DOC + ! + END_DOC + call dgemm('T','N',ao_num,nucl_num,ao_num,1.d0, & + ao_ortho_canonical_coef, size(ao_ortho_canonical_coef,1), & + GauSla$X_matrix, size(GauSla$X_matrix,1), & + 0.d0, AO_orthoSla$X_matrix, size(AO_orthoSla$X_matrix,1)) + +END_PROVIDER + +SUBST [ X ] + +Overlap ;; +Kinetic ;; + +END_TEMPLATE + +BEGIN_PROVIDER [ double precision, GauSlaNuclear_matrix, (ao_num, nucl_num) ] + implicit none + BEGIN_DOC + ! overlap matrix + END_DOC + integer :: i,j,k,A + double precision :: cGau(3) + double precision :: cSla(3) + double precision :: expSla, res, expGau, Znuc, cNuc(3) + integer :: aGau(3) + +!TODO + logical :: read + integer :: iunit + integer :: getunitandopen + + inquire(FILE=trim(ezfio_filename)//'/work/GauSlaNuclear.dat',EXIST=read) + if (read) then + print *, 'READ Nuclear' + iunit = getunitandopen(trim(ezfio_filename)//'/work/GauSlaNuclear.dat','r') + else + print *, 'WRITE Nuclear' + iunit = getunitandopen(trim(ezfio_filename)//'/work/GauSlaNuclear.inp','w') + write(iunit,*)'{' + endif +!TODO + + do k=1,nucl_num + cSla(1:3) = nucl_coord_transp(1:3,k) + expSla = slater_expo(k) + + do i=1,ao_num + cGau(1:3) = nucl_coord_transp(1:3, ao_nucl(i)) + aGau(1:3) = ao_power(i,1:3) + GauSlaNuclear_matrix(i,k) = 0.d0 + + do j=1,ao_prim_num(i) + expGau = ao_expo_ordered_transp(j,i) + do A=1,nucl_num + cNuc(1:3) = nucl_coord_transp(1:3,A) + Znuc = nucl_charge(A) +! call GauSlaNuclear(expGau,cGau,aGau,expSla,cSla,Znuc,cNuc,res) + if (read) then + call GauSlaNuclear_read(expGau,cGau,aGau,expSla,cSla,Znuc,cNuc,res,iunit) + else + call GauSlaNuclear_write(expGau,cGau,aGau,expSla,cSla,Znuc,cNuc,res,iunit) + endif + GauSlaNuclear_matrix(i,k) += ao_coef_normalized_ordered_transp(j,i) * res + enddo + enddo + + enddo + + enddo + if (.not.read) then + write(iunit,*) '0.}' + endif + close(iunit) + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, GauSlaH_matrix, (ao_num, nucl_num) ] + implicit none + BEGIN_DOC + ! Core hamiltonian in AO basis + END_DOC + GauSlaH_matrix(1:ao_num,1:nucl_num) = & + GauSlaKinetic_matrix(1:ao_num,1:nucl_num) + & + GauSlaNuclear_matrix(1:ao_num,1:nucl_num) + +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, MOSlaNuclear_matrix, (mo_tot_num, nucl_num) ] + implicit none + BEGIN_DOC +! + END_DOC + call dgemm('N','N',mo_tot_num,nucl_num,ao_num,1.d0, & + mo_coef_transp, size(mo_coef_transp,1), & + GauSlaNuclear_matrix, size(GauSlaNuclear_matrix,1), & + 0.d0, MOSlaNuclear_matrix, size(MOSlaNuclear_matrix,1)) +END_PROVIDER + +BEGIN_PROVIDER [ double precision, AO_orthoSlaH_matrix, (ao_num, nucl_num) ] + implicit none + BEGIN_DOC +! + END_DOC + call dgemm('T','N',ao_num,nucl_num,ao_num,1.d0, & + ao_ortho_canonical_coef, size(ao_ortho_canonical_coef,1), & + GauSlaH_matrix, size(GauSlaH_matrix,1), & + 0.d0, AO_orthoSlaH_matrix, size(AO_orthoSlaH_matrix,1)) +END_PROVIDER + diff --git a/plugins/Hartree_Fock_SlaterDressed/slater.irp.f b/plugins/Hartree_Fock_SlaterDressed/slater.irp.f new file mode 100644 index 00000000..8a11b9b1 --- /dev/null +++ b/plugins/Hartree_Fock_SlaterDressed/slater.irp.f @@ -0,0 +1,43 @@ +BEGIN_PROVIDER [ double precision, slater_expo, (nucl_num) ] + implicit none + BEGIN_DOC + ! Exponents of the Slater functions + END_DOC + logical :: exists + call ezfio_has_Hartree_Fock_SlaterDressed_slater_expo_ezfio(exists) + if (exists) then + slater_expo(1:nucl_num) = slater_expo_ezfio(1:nucl_num) + else + slater_expo(1:nucl_num) = nucl_charge(1:nucl_num) + call ezfio_set_Hartree_Fock_SlaterDressed_slater_expo_ezfio(slater_expo) + endif +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, slater_coef, (nucl_num,mo_tot_num) ] + implicit none + BEGIN_DOC + ! Exponents of the Slater functions + END_DOC + logical :: exists + slater_coef = 0.d0 + call ezfio_has_Hartree_Fock_SlaterDressed_slater_coef_ezfio(exists) + if (exists) then + slater_coef = slater_coef_ezfio + else + call ezfio_set_Hartree_Fock_SlaterDressed_slater_coef_ezfio(slater_coef) + endif +END_PROVIDER + +BEGIN_PROVIDER [ double precision, slater_normalization, (nucl_num) ] + implicit none + BEGIN_DOC + ! Normalization of Slater functions : sqrt(expo^3/pi) + END_DOC + integer :: i + do i=1,nucl_num + slater_normalization(i) = dsqrt( slater_expo(i)**3/dacos(-1.d0) ) + enddo + +END_PROVIDER + diff --git a/plugins/MP2/mp2_wf.irp.f b/plugins/MP2/mp2_wf.irp.f index e7419319..1dda8d69 100644 --- a/plugins/MP2/mp2_wf.irp.f +++ b/plugins/MP2/mp2_wf.irp.f @@ -21,15 +21,22 @@ subroutine run selection_criterion_factor = 0.d0 TOUCH selection_criterion_min selection_criterion selection_criterion_factor call H_apply_mp2_selection(pt2, norm_pert, H_pert_diag, N_st) + touch N_det psi_det psi_coef psi_det = psi_det_sorted psi_coef = psi_coef_sorted touch N_det psi_det psi_coef + do i=N_det,1,-1 + if (dabs(psi_coef(i,1)) <= 1.d-8) then + N_det -= 1 + endif + enddo 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) + touch N_det psi_det psi_coef call save_wavefunction call ezfio_set_mp2_energy(HF_energy+pt2(1)) deallocate(pt2,norm_pert,H_pert_diag) diff --git a/plugins/MPI/NEEDED_CHILDREN_MODULES b/plugins/MPI/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..8b137891 --- /dev/null +++ b/plugins/MPI/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ + diff --git a/plugins/MPI/README.rst b/plugins/MPI/README.rst new file mode 100644 index 00000000..7962296b --- /dev/null +++ b/plugins/MPI/README.rst @@ -0,0 +1,14 @@ +=== +MPI +=== + +Providers for MPI programs. + +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/MPI/bcast.irp.f b/plugins/MPI/bcast.irp.f new file mode 100644 index 00000000..3236f9f5 --- /dev/null +++ b/plugins/MPI/bcast.irp.f @@ -0,0 +1,46 @@ +subroutine mpi_bcast_psi() + use f77_zmq + implicit none + BEGIN_DOC +! Put the wave function on the qp_run scheduler + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer, intent(in) :: worker_id + integer :: ierr + character*(256) :: msg + + IRP_IF MPI + call MPI_BCast(N_states, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + call MPI_BCast(N_det, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + call MPI_BCast(psi_det_size, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + + TOUCH psi_det_size N_det N_states + + call MPI_BCast(psi_det, N_det, MPI_INTEGER8, 0, MPI_COMM_WORLD, ierr) + call MPI_BCast(psi_coef, psi_det_size, MPI_DOUBLE_PRECISION* N_states, 0, MPI_COMM_WORLD, ierr) + + + rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_coef,int(psi_det_size*N_states*8_8,8),0) + if (rc8 /= psi_det_size*N_states*8_8) then + print *, '77_zmq_recv8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)' + stop 'error' + endif + TOUCH psi_det psi_coef + + rc = f77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0) + if (rc /= size_energy*8) then + print *, '77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)' + stop 'error' + endif + + if (N_det_generators_read > 0) then + N_det_generators = N_det_generators_read + TOUCH N_det_generators + endif + if (N_det_selectors_read > 0) then + N_det_selectors = N_det_selectors_read + TOUCH N_det_selectors + endif + +end + diff --git a/plugins/MPI/utils.irp.f b/plugins/MPI/utils.irp.f new file mode 100644 index 00000000..aa4e0742 --- /dev/null +++ b/plugins/MPI/utils.irp.f @@ -0,0 +1,68 @@ + BEGIN_PROVIDER [ logical, MPI_Initialized ] +&BEGIN_PROVIDER [ logical, has_mpi ] + implicit none + BEGIN_DOC +! This is true when MPI_Init has been called + END_DOC + + IRP_IF MPI + integer :: ierr + call MPI_Init(ierr) + if (ierr /= 0) then + print *, ierr + print *, 'MPI failed to initialize' + stop -1 + endif + IRP_ENDIF + MPI_Initialized = .True. +END_PROVIDER + + + BEGIN_PROVIDER [ integer, MPI_rank ] +&BEGIN_PROVIDER [ integer, MPI_size ] +&BEGIN_PROVIDER [ logical, is_MPI_master ] + implicit none + BEGIN_DOC +! Usual MPI variables + END_DOC + + PROVIDE MPI_Initialized + + IRP_IF MPI + integer :: ierr + call mpi_comm_size(MPI_COMM_WORLD, MPI_size, ierr) + if (ierr /= 0) then + print *, ierr + print *, 'Unable to get MPI_size' + stop -1 + endif + call mpi_comm_rank(MPI_COMM_WORLD, MPI_rank, ierr) + if (ierr /= 0) then + print *, ierr + print *, 'Unable to get MPI_rank' + stop -1 + endif + is_MPI_master = (MPI_rank == 0) + IRP_ELSE + MPI_rank = 0 + MPI_size = 1 + is_MPI_master = .True. + IRP_ENDIF + + +END_PROVIDER + +subroutine qp_mpi_finalize() + implicit none + PROVIDE MPI_Initialized + IRP_IF MPI + integer :: ierr + call MPI_Finalize(ierr) + if (ierr /= 0) then + print *, ierr + print *, 'Unable to finalize MPI' + stop -1 + endif + IRP_ENDIF +end subroutine + diff --git a/plugins/MRPT/NEEDED_CHILDREN_MODULES b/plugins/MRPT/NEEDED_CHILDREN_MODULES index 7340c609..281fbc60 100644 --- a/plugins/MRPT/NEEDED_CHILDREN_MODULES +++ b/plugins/MRPT/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -MRPT_Utils Selectors_full Generators_full +MRPT_Utils Selectors_full Generators_full diff --git a/plugins/MRPT/MRPT_Utils.main.irp.f b/plugins/MRPT/jm_mrpt2.irp.f similarity index 71% rename from plugins/MRPT/MRPT_Utils.main.irp.f rename to plugins/MRPT/jm_mrpt2.irp.f index 13c8228a..89deef2e 100644 --- a/plugins/MRPT/MRPT_Utils.main.irp.f +++ b/plugins/MRPT/jm_mrpt2.irp.f @@ -15,11 +15,17 @@ subroutine routine_3 print *, 'N_det = ', N_det print *, 'N_states = ', N_states - print *, 'PT2 = ', second_order_pt_new(1) - print *, 'E = ', CI_energy(1) - print *, 'E+PT2 = ', CI_energy(1)+second_order_pt_new(1) + + integer :: i + do i=1,N_states + print *, 'State = ', i + print *, 'PT2 = ', second_order_pt_new(i) + print *, 'E = ', CI_energy(i) + print *, 'E+PT2 = ', CI_energy(i)+second_order_pt_new(i) + print *, '-----------------------------' + enddo print *,'****** DIAGONALIZATION OF DRESSED MATRIX ******' - print *, 'E dressed= ', CI_dressed_pt2_new_energy(1) + print *, 'E dressed= ', CI_dressed_pt2_new_energy(i) end diff --git a/plugins/MRPT/mrpt.irp.f b/plugins/MRPT/mrpt.irp.f deleted file mode 100644 index 8c8d746d..00000000 --- a/plugins/MRPT/mrpt.irp.f +++ /dev/null @@ -1,38 +0,0 @@ -program MRPT - 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 diff --git a/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES b/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES index 34de8ddb..a41f499b 100644 --- a/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES +++ b/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Determinants Davidson +Determinants Davidson Psiref_CAS diff --git a/plugins/MRPT_Utils/density_matrix_based.irp.f b/plugins/MRPT_Utils/density_matrix_based.irp.f new file mode 100644 index 00000000..b2f3b8cf --- /dev/null +++ b/plugins/MRPT_Utils/density_matrix_based.irp.f @@ -0,0 +1,193 @@ +subroutine contrib_1h2p_dm_based(accu) + implicit none + integer :: i_i,i_r,i_v,i_a,i_b + integer :: i,r,v,a,b + integer :: ispin,jspin + integer :: istate + double precision, intent(out) :: accu(N_states) + double precision :: active_int(n_act_orb,2) + double precision :: delta_e(n_act_orb,2,N_states) + double precision :: get_mo_bielec_integral + accu = 0.d0 +!do i_i = 1, 1 + do i_i = 1, n_inact_orb + i = list_inact(i_i) +! do i_r = 1, 1 + do i_r = 1, n_virt_orb + r = list_virt(i_r) +! do i_v = 1, 1 + do i_v = 1, n_virt_orb + v = list_virt(i_v) + do i_a = 1, n_act_orb + a = list_act(i_a) + active_int(i_a,1) = get_mo_bielec_integral(i,a,r,v,mo_integrals_map) ! direct + active_int(i_a,2) = get_mo_bielec_integral(i,a,v,r,mo_integrals_map) ! exchange + do istate = 1, N_states + do jspin=1, 2 + delta_e(i_a,jspin,istate) = one_anhil(i_a,jspin,istate) & + - fock_virt_total_spin_trace(r,istate) & + - fock_virt_total_spin_trace(v,istate) & + + fock_core_inactive_total_spin_trace(i,istate) + delta_e(i_a,jspin,istate) = 1.d0/delta_e(i_a,jspin,istate) + enddo + enddo + enddo + do i_a = 1, n_act_orb + a = list_act(i_a) + do i_b = 1, n_act_orb +! do i_b = i_a, i_a + b = list_act(i_b) + do ispin = 1, 2 ! spin of (i --> r) + do jspin = 1, 2 ! spin of (a --> v) + if(ispin == jspin .and. r.le.v)cycle ! condition not to double count + do istate = 1, N_states + if(ispin == jspin)then + accu(istate) += (active_int(i_a,1) - active_int(i_a,2)) * one_body_dm_mo_spin_index(a,b,istate,ispin) & + * (active_int(i_b,1) - active_int(i_b,2)) & + * delta_e(i_a,jspin,istate) + else + accu(istate) += active_int(i_a,1) * one_body_dm_mo_spin_index(a,b,istate,ispin) * delta_e(i_a,ispin,istate) & + * active_int(i_b,1) + endif + enddo + enddo + enddo + enddo + enddo + enddo + enddo + enddo + + +end + +subroutine contrib_2h1p_dm_based(accu) + implicit none + integer :: i_i,i_j,i_v,i_a,i_b + integer :: i,j,v,a,b + integer :: ispin,jspin + integer :: istate + double precision, intent(out) :: accu(N_states) + double precision :: active_int(n_act_orb,2) + double precision :: delta_e(n_act_orb,2,N_states) + double precision :: get_mo_bielec_integral + accu = 0.d0 + do i_i = 1, n_inact_orb + i = list_inact(i_i) + do i_j = 1, n_inact_orb + j = list_inact(i_j) + do i_v = 1, n_virt_orb + v = list_virt(i_v) + do i_a = 1, n_act_orb + a = list_act(i_a) + active_int(i_a,1) = get_mo_bielec_integral(i,j,v,a,mo_integrals_map) ! direct + active_int(i_a,2) = get_mo_bielec_integral(i,j,a,v,mo_integrals_map) ! exchange + do istate = 1, N_states + do jspin=1, 2 +! delta_e(i_a,jspin,istate) = +! + delta_e(i_a,jspin,istate) = one_creat(i_a,jspin,istate) - fock_virt_total_spin_trace(v,istate) & + + fock_core_inactive_total_spin_trace(i,istate) & + + fock_core_inactive_total_spin_trace(j,istate) + delta_e(i_a,jspin,istate) = 1.d0/delta_e(i_a,jspin,istate) + enddo + enddo + enddo + do i_a = 1, n_act_orb + a = list_act(i_a) + do i_b = 1, n_act_orb +! do i_b = i_a, i_a + b = list_act(i_b) + do ispin = 1, 2 ! spin of (i --> v) + do jspin = 1, 2 ! spin of (j --> a) + if(ispin == jspin .and. i.le.j)cycle ! condition not to double count + do istate = 1, N_states + if(ispin == jspin)then + accu(istate) += (active_int(i_a,1) - active_int(i_a,2)) * one_body_dm_dagger_mo_spin_index(a,b,istate,ispin) & + * (active_int(i_b,1) - active_int(i_b,2)) & + * delta_e(i_a,jspin,istate) + else + accu(istate) += active_int(i_a,1) * one_body_dm_dagger_mo_spin_index(a,b,istate,ispin) * delta_e(i_a,ispin,istate) & + * active_int(i_b,1) + endif + enddo + enddo + enddo + enddo + enddo + enddo + enddo + enddo + + +end + + +!subroutine contrib_2p_dm_based(accu) +!implicit none +!integer :: i_r,i_v,i_a,i_b,i_c,i_d +!integer :: r,v,a,b,c,d +!integer :: ispin,jspin +!integer :: istate +!double precision, intent(out) :: accu(N_states) +!double precision :: active_int(n_act_orb,n_act_orb,2) +!double precision :: delta_e(n_act_orb,n_act_orb,2,2,N_states) +!double precision :: get_mo_bielec_integral +!accu = 0.d0 +!do i_r = 1, n_virt_orb +! r = list_virt(i_r) +! do i_v = 1, n_virt_orb +! v = list_virt(i_v) +! do i_a = 1, n_act_orb +! a = list_act(i_a) +! do i_b = 1, n_act_orb +! b = list_act(i_b) +! active_int(i_a,i_b,1) = get_mo_bielec_integral(a,b,r,v,mo_integrals_map) ! direct +! active_int(i_a,i_b,2) = get_mo_bielec_integral(a,b,v,r,mo_integrals_map) ! direct +! do istate = 1, N_states +! do jspin=1, 2 ! spin of i_a +! do ispin = 1, 2 ! spin of i_b +! delta_e(i_a,i_b,jspin,ispin,istate) = two_anhil(i_a,i_b,jspin,ispin,istate) & +! - fock_virt_total_spin_trace(r,istate) & +! - fock_virt_total_spin_trace(v,istate) +! delta_e(i_a,i_b,jspin,ispin,istate) = 1.d0/delta_e(i_a,i_b,jspin,ispin,istate) +! enddo +! enddo +! enddo +! enddo +! enddo +! ! diagonal terms +! do i_a = 1, n_act_orb +! a = list_act(i_a) +! do i_b = 1, n_act_orb +! b = list_act(i_b) +! do ispin = 1, 2 ! spin of (a --> r) +! do jspin = 1, 2 ! spin of (b --> v) +! if(ispin == jspin .and. r.le.v)cycle ! condition not to double count +! if(ispin == jspin .and. a.le.b)cycle ! condition not to double count +! do istate = 1, N_states +! if(ispin == jspin)then +! double precision :: contrib_spin +! if(ispin == 1)then +! contrib_spin = two_body_dm_aa_diag_act(i_a,i_b) +! else +! contrib_spin = two_body_dm_bb_diag_act(i_a,i_b) +! endif +! accu(istate) += (active_int(i_a,i_b,1) - active_int(i_a,i_b,2)) * contrib_spin & +! * (active_int(i_a,i_b,1) - active_int(i_a,i_b,2)) & +! * delta_e(i_a,i_b,ispin,jspin,istate) +! else +! accu(istate) += 0.5d0 * active_int(i_a,i_b,1) * two_body_dm_ab_diag_act(i_a,i_b) * delta_e(i_a,i_b,ispin,jspin,istate) & +! * active_int(i_a,i_b,1) +! endif +! enddo +! enddo +! enddo +! enddo +! enddo +! enddo +! enddo + + +!end + diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f index dd79edbe..89a183c9 100644 --- a/plugins/MRPT_Utils/energies_cas.irp.f +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -1,9 +1,9 @@ BEGIN_PROVIDER [ double precision, energy_cas_dyall, (N_states)] implicit none integer :: i - double precision :: energies(N_states_diag) + double precision :: energies(N_states) do i = 1, N_states - call u0_H_dyall_u0(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states_diag,i) + call u0_H_dyall_u0(energies,psi_active,psi_coef,n_det_ref,psi_det_size,psi_det_size,N_states,i) energy_cas_dyall(i) = energies(i) print*, 'energy_cas_dyall(i)', energy_cas_dyall(i) enddo @@ -13,9 +13,9 @@ END_PROVIDER BEGIN_PROVIDER [ double precision, energy_cas_dyall_no_exchange, (N_states)] implicit none integer :: i - double precision :: energies(N_states_diag) + double precision :: energies(N_states) do i = 1, N_states - call u0_H_dyall_u0_no_exchange(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states_diag,i) + call u0_H_dyall_u0_no_exchange(energies,psi_active,psi_coef,n_det_ref,psi_det_size,psi_det_size,N_states,i) energy_cas_dyall_no_exchange(i) = energies(i) print*, 'energy_cas_dyall(i)_no_exchange', energy_cas_dyall_no_exchange(i) enddo @@ -28,22 +28,22 @@ BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] integer :: i,j integer :: ispin integer :: orb, hole_particle,spin_exc - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) use bitmasks integer :: iorb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb = list_act(iorb) hole_particle = 1 spin_exc = ispin - do i = 1, n_det - do j = 1, n_states_diag + do i = 1, n_det_ref + do j = 1, n_states psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int @@ -53,8 +53,8 @@ BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] enddo do state_target = 1,N_states call apply_exc_to_psi(orb,hole_particle,spin_exc, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) one_creat(iorb,ispin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -68,22 +68,22 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] integer :: i,j integer :: ispin integer :: orb, hole_particle,spin_exc - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb = list_act(iorb) hole_particle = -1 spin_exc = ispin - do i = 1, n_det - do j = 1, n_states_diag + do i = 1, n_det_ref + do j = 1, n_states psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int @@ -93,8 +93,8 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] enddo do state_target = 1, N_states call apply_exc_to_psi(orb,hole_particle,spin_exc, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) one_anhil(iorb,ispin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -109,15 +109,15 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) integer :: ispin,jspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -128,8 +128,8 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) orb_j = list_act(jorb) hole_particle_j = 1 spin_exc_j = jspin - do i = 1, n_det - do j = 1, n_states_diag + do i = 1, n_det_ref + do j = 1, n_states psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int @@ -139,10 +139,10 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) enddo do state_target = 1 , N_states call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) two_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -159,16 +159,16 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) integer :: ispin,jspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: state_target state_target = 1 - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -179,8 +179,8 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) orb_j = list_act(jorb) hole_particle_j = -1 spin_exc_j = jspin - do i = 1, n_det - do j = 1, n_states_diag + do i = 1, n_det_ref + do j = 1, n_states psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int @@ -189,10 +189,10 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) enddo enddo call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) two_anhil(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -208,15 +208,15 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 integer :: ispin,jspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -227,8 +227,8 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 orb_j = list_act(jorb) hole_particle_j = -1 spin_exc_j = jspin - do i = 1, n_det - do j = 1, n_states_diag + do i = 1, n_det_ref + do j = 1, n_states psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int @@ -238,14 +238,14 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 enddo do state_target = 1, N_states call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) if(orb_i == orb_j .and. ispin .ne. jspin)then - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) else - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) endif enddo @@ -264,16 +264,16 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: korb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -289,8 +289,8 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a orb_k = list_act(korb) hole_particle_k = -1 spin_exc_k = kspin - do i = 1, n_det - do j = 1, n_states_diag + do i = 1, n_det_ref + do j = 1, n_states psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int @@ -301,12 +301,12 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a do state_target = 1, N_states call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) two_anhil_one_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -326,16 +326,16 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: korb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -351,8 +351,8 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a orb_k = list_act(korb) hole_particle_k = -1 spin_exc_k = kspin - do i = 1, n_det - do j = 1, n_states_diag + do i = 1, n_det_ref + do j = 1, n_states psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int @@ -362,12 +362,12 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a enddo do state_target = 1, N_states call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -387,16 +387,16 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: korb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -412,8 +412,8 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 orb_k = list_act(korb) hole_particle_k = 1 spin_exc_k = kspin - do i = 1, n_det - do j = 1, n_states_diag + do i = 1, n_det_ref + do j = 1, n_states psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int @@ -423,12 +423,12 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 enddo do state_target = 1, N_states call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) three_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -448,16 +448,16 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: korb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -473,8 +473,8 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 orb_k = list_act(korb) hole_particle_k = -1 spin_exc_k = kspin - do i = 1, n_det - do j = 1, n_states_diag + do i = 1, n_det_ref + do j = 1, n_states psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int @@ -484,12 +484,12 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 enddo do state_target = 1, N_states call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) three_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo @@ -511,15 +511,15 @@ END_PROVIDER integer :: ispin,jspin integer :: orb_i, hole_particle_i integer :: orb_v - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb,i_ok integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) double precision :: hij double precision :: norm(N_states,2),norm_no_inv(N_states,2),norm_bis(N_states,2) double precision :: energies_alpha_beta(N_states,2) @@ -541,10 +541,10 @@ END_PROVIDER do state_target =1 , N_states one_anhil_one_creat_inact_virt_norm(iorb,vorb,state_target,ispin) = 0.d0 enddo - do i = 1, n_det + do i = 1, n_det_ref do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_ref(j,1,i) + psi_in_out(j,2,i) = psi_ref(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) if(i_ok.ne.1)then @@ -552,7 +552,7 @@ END_PROVIDER call debug_det(psi_in_out,N_int) print*, 'pb, i_ok ne 0 !!!' endif - call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) + call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij) do j = 1, n_states double precision :: coef,contrib coef = psi_coef(i,j) !* psi_coef(i,j) @@ -585,7 +585,7 @@ END_PROVIDER energies_alpha_beta(state_target, ispin) = - mo_bielec_integral_jj_exchange(orb_i,orb_v) ! energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif enddo @@ -616,15 +616,15 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta integer :: i,iorb,j integer :: ispin,jspin integer :: orb_i, hole_particle_i - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: jorb,i_ok,aorb,orb_a integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) double precision :: hij double precision :: norm(N_states,2),norm_no_inv(N_states,2) double precision :: energies_alpha_beta(N_states,2) @@ -645,10 +645,10 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta norm = 0.d0 norm_bis = 0.d0 do ispin = 1,2 - do i = 1, n_det + do i = 1, n_det_ref do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_ref(j,1,i) + psi_in_out(j,2,i) = psi_ref(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_a,ispin,i_ok) if(i_ok.ne.1)then @@ -656,7 +656,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta psi_in_out_coef(i,j) = 0.d0 enddo else - call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) + call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij) do j = 1, n_states double precision :: coef,contrib coef = psi_coef(i,j) !* psi_coef(i,j) @@ -688,7 +688,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta do state_target = 1, N_states energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif enddo @@ -701,11 +701,6 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta else one_anhil_inact(iorb,aorb,state_target) = 0.d0 endif -! print*, '********' -! print*, energies_alpha_beta(state_target,1) , energies_alpha_beta(state_target,2) -! print*, norm_bis(state_target,1) , norm_bis(state_target,2) -! print*, one_anhil_inact(iorb,aorb,state_target) -! print*, one_creat(aorb,1,state_target) enddo enddo enddo @@ -719,15 +714,15 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State integer :: ispin,jspin integer :: orb_i, hole_particle_i integer :: orb_v - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb,i_ok,aorb,orb_a integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) double precision :: hij double precision :: norm(N_states,2),norm_no_inv(N_states,2) double precision :: energies_alpha_beta(N_states,2) @@ -748,10 +743,10 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State norm = 0.d0 norm_bis = 0.d0 do ispin = 1,2 - do i = 1, n_det + do i = 1, n_det_ref do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_ref(j,1,i) + psi_in_out(j,2,i) = psi_ref(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_a,orb_v,ispin,i_ok) if(i_ok.ne.1)then @@ -759,7 +754,7 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State psi_in_out_coef(i,j) = 0.d0 enddo else - call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) + call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij) do j = 1, n_states double precision :: coef,contrib coef = psi_coef(i,j) !* psi_coef(i,j) @@ -791,7 +786,7 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State do state_target = 1, N_states energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) ! print*, energies(state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif @@ -825,19 +820,19 @@ END_PROVIDER integer :: ispin,jspin integer :: orb_i, hole_particle_i integer :: orb_v - double precision :: norm_out(N_states_diag),diag_elem(N_det),interact_psi0(N_det) + double precision :: norm_out(N_states),diag_elem(N_det),interact_psi0(N_det) double precision :: delta_e_inact_virt(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag),H_matrix(N_det+1,N_det+1)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states),H_matrix(N_det+1,N_det+1)) allocate (eigenvectors(size(H_matrix,1),N_det+1)) allocate (eigenvalues(N_det+1)) integer :: iorb,jorb,i_ok integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) double precision :: hij double precision :: energies_alpha_beta(N_states,2) @@ -857,10 +852,10 @@ END_PROVIDER - fock_virt_total_spin_trace(orb_v,j) enddo do ispin = 1,2 - do i = 1, n_det + do i = 1, n_det_ref do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_ref(j,1,i) + psi_in_out(j,2,i) = psi_ref(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) if(i_ok.ne.1)then @@ -870,7 +865,7 @@ END_PROVIDER endif interact_psi0(i) = 0.d0 do j = 1 , N_det - call i_H_j(psi_in_out(1,1,i),psi_det(1,1,j),N_int,hij) + call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,j),N_int,hij) interact_psi0(i) += hij * psi_coef(j,1) enddo do j = 1, N_int @@ -973,21 +968,21 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from integer :: ispin,jspin integer :: orb_i, hole_particle_i integer :: orb_v - double precision :: norm_out(N_states_diag),diag_elem(N_det),interact_psi0(N_det) + double precision :: norm_out(N_states),diag_elem(N_det),interact_psi0(N_det) double precision :: delta_e_inact_virt(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:),interact_cas(:,:) double precision, allocatable :: delta_e_det(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag),H_matrix(N_det+1,N_det+1)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states),H_matrix(N_det+1,N_det+1)) allocate (eigenvectors(size(H_matrix,1),N_det+1)) allocate (eigenvalues(N_det+1),interact_cas(N_det,N_det)) allocate (delta_e_det(N_det,N_det)) integer :: iorb,jorb,i_ok integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) double precision :: hij double precision :: energies_alpha_beta(N_states,2) double precision :: lamda_pt2(N_det) @@ -1009,10 +1004,10 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from - fock_virt_total_spin_trace(orb_v,j) enddo do ispin = 1,2 - do i = 1, n_det + do i = 1, n_det_ref do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_ref(j,1,i) + psi_in_out(j,2,i) = psi_ref(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) if(i_ok.ne.1)then @@ -1022,8 +1017,8 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from endif interact_psi0(i) = 0.d0 do j = 1 , N_det - call i_H_j(psi_in_out(1,1,i),psi_det(1,1,j),N_int,hij) - call get_delta_e_dyall(psi_det(1,1,j),psi_in_out(1,1,i),coef_array,hij,delta_e_det(i,j)) + call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,j),N_int,hij) + call get_delta_e_dyall(psi_ref(1,1,j),psi_in_out(1,1,i),delta_e_det(i,j)) interact_cas(i,j) = hij interact_psi0(i) += hij * psi_coef(j,1) enddo diff --git a/plugins/MRPT_Utils/mrpt_dress.irp.f b/plugins/MRPT_Utils/mrpt_dress.irp.f index 275af0e4..c7371ab3 100644 --- a/plugins/MRPT_Utils/mrpt_dress.irp.f +++ b/plugins/MRPT_Utils/mrpt_dress.irp.f @@ -62,7 +62,7 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip call find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) if(N_tq > 0) then - call create_minilist(key_mask, psi_det, miniList, idx_miniList, N_det, N_minilist, Nint) + call create_minilist(key_mask, psi_ref, miniList, idx_miniList, N_det, N_minilist, Nint) end if @@ -79,14 +79,15 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip phase_array =0.d0 do i = 1,idx_alpha(0) index_i = idx_alpha(i) - call i_h_j(tq(1,1,i_alpha),psi_det(1,1,index_i),Nint,hialpha) + call i_h_j(tq(1,1,i_alpha),psi_ref(1,1,index_i),Nint,hialpha) double precision :: coef_array(N_states) do i_state = 1, N_states coef_array(i_state) = psi_coef(index_i,i_state) enddo - call get_delta_e_dyall(psi_det(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) + call get_delta_e_dyall(psi_ref(1,1,index_i),tq(1,1,i_alpha),delta_e) +! call get_delta_e_dyall_general_mp(psi_ref(1,1,index_i),tq(1,1,i_alpha),delta_e) hij_array(index_i) = hialpha - call get_excitation(psi_det(1,1,index_i),tq(1,1,i_alpha),exc,degree,phase,N_int) + call get_excitation(psi_ref(1,1,index_i),tq(1,1,i_alpha),exc,degree,phase,N_int) ! phase_array(index_i) = phase do i_state = 1,N_states delta_e_inv_array(index_i,i_state) = 1.d0/delta_e(i_state) @@ -99,12 +100,12 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip call omp_set_lock( psi_ref_bis_lock(index_i) ) do j = 1, idx_alpha(0) index_j = idx_alpha(j) -! call get_excitation(psi_det(1,1,index_i),psi_det(1,1,index_i),exc,degree,phase,N_int) +! call get_excitation(psi_ref(1,1,index_i),psi_ref(1,1,index_i),exc,degree,phase,N_int) ! if(index_j.ne.index_i)then ! if(phase_array(index_j) * phase_array(index_i) .ne. phase)then ! print*, phase_array(index_j) , phase_array(index_i) ,phase -! call debug_det(psi_det(1,1,index_i),N_int) -! call debug_det(psi_det(1,1,index_j),N_int) +! call debug_det(psi_ref(1,1,index_i),N_int) +! call debug_det(psi_ref(1,1,index_j),N_int) ! call debug_det(tq(1,1,i_alpha),N_int) ! stop ! endif @@ -122,14 +123,14 @@ 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) + BEGIN_PROVIDER [ integer(bit_kind), gen_det_ref_sorted, (N_int,2,N_det_generators,2) ] +&BEGIN_PROVIDER [ integer, gen_det_ref_shortcut, (0:N_det_generators,2) ] +&BEGIN_PROVIDER [ integer, gen_det_ref_version, (N_int, N_det_generators,2) ] +&BEGIN_PROVIDER [ integer, gen_det_ref_idx, (N_det_generators,2) ] + gen_det_ref_sorted(:,:,:,1) = psi_det_generators(:,:,:N_det_generators) + gen_det_ref_sorted(:,:,:,2) = psi_det_generators(:,:,:N_det_generators) + call sort_dets_ab_v(gen_det_ref_sorted(:,:,:,1), gen_det_ref_idx(:,1), gen_det_ref_shortcut(0:,1), gen_det_ref_version(:,:,1), N_det_generators, N_int) + call sort_dets_ba_v(gen_det_ref_sorted(:,:,:,2), gen_det_ref_idx(:,2), gen_det_ref_shortcut(0:,2), gen_det_ref_version(:,:,2), N_det_generators, N_int) END_PROVIDER diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f index d7b1f0f6..83f087bc 100644 --- a/plugins/MRPT_Utils/mrpt_utils.irp.f +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -58,8 +58,6 @@ delta_ij_tmp = 0.d0 call H_apply_mrpt_1h1p(delta_ij_tmp,N_det) double precision :: e_corr_from_1h1p_singles(N_states) -!call give_singles_and_partial_doubles_1h1p_contrib(delta_ij_tmp,e_corr_from_1h1p_singles) -!call give_1h1p_only_doubles_spin_cross(delta_ij_tmp) accu = 0.d0 do i_state = 1, N_states do i = 1, N_det @@ -121,7 +119,7 @@ ! 1h2p delta_ij_tmp = 0.d0 -!call give_1h2p_contrib(delta_ij_tmp) + call give_1h2p_contrib(delta_ij_tmp) call H_apply_mrpt_1h2p(delta_ij_tmp,N_det) accu = 0.d0 do i_state = 1, N_states @@ -137,7 +135,7 @@ ! 2h1p delta_ij_tmp = 0.d0 -!call give_2h1p_contrib(delta_ij_tmp) + call give_2h1p_contrib(delta_ij_tmp) call H_apply_mrpt_2h1p(delta_ij_tmp,N_det) accu = 0.d0 do i_state = 1, N_states @@ -223,9 +221,9 @@ END_PROVIDER enddo END_PROVIDER - BEGIN_PROVIDER [ double precision, CI_electronic_dressed_pt2_new_energy, (N_states_diag) ] - &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors, (N_det,N_states_diag) ] - &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors_s2, (N_states_diag) ] + BEGIN_PROVIDER [ double precision, CI_electronic_dressed_pt2_new_energy, (N_states) ] + &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors, (N_det,N_states) ] + &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors_s2, (N_states) ] BEGIN_DOC ! Eigenvectors/values of the CI matrix END_DOC @@ -244,14 +242,14 @@ END_PROVIDER double precision, allocatable :: e_array(:) integer, allocatable :: iorder(:) - ! Guess values for the "N_states_diag" states of the CI_dressed_pt2_new_eigenvectors - do j=1,min(N_states_diag,N_det) + ! Guess values for the "N_states" states of the CI_dressed_pt2_new_eigenvectors + do j=1,min(N_states,N_det) do i=1,N_det CI_dressed_pt2_new_eigenvectors(i,j) = psi_coef(i,j) enddo enddo - do j=N_det+1,N_states_diag + do j=N_det+1,N_states do i=1,N_det CI_dressed_pt2_new_eigenvectors(i,j) = 0.d0 enddo @@ -267,14 +265,14 @@ END_PROVIDER allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) allocate (eigenvalues(N_det)) call lapack_diag(eigenvalues,eigenvectors, & - H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) - CI_electronic_energy(:) = 0.d0 + Hmatrix_dressed_pt2_new_symmetrized(1,1,1),size(H_matrix_all_dets,1),N_det) + CI_electronic_dressed_pt2_new_energy(:) = 0.d0 if (s2_eig) then i_state = 0 allocate (s2_eigvalues(N_det)) allocate(index_good_state_array(N_det),good_state_array(N_det)) good_state_array = .False. - call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,& + call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_ref,N_int,& N_det,size(eigenvectors,1)) do j=1,N_det ! Select at least n_states states with S^2 values closed to "expected_s2" @@ -291,54 +289,54 @@ END_PROVIDER ! Fill the first "i_state" states that have a correct S^2 value do j = 1, i_state do i=1,N_det - CI_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j)) + CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j)) enddo - CI_electronic_energy(j) = eigenvalues(index_good_state_array(j)) - CI_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j)) + CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(index_good_state_array(j)) + CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j)) enddo i_other_state = 0 do j = 1, N_det if(good_state_array(j))cycle i_other_state +=1 - if(i_state+i_other_state.gt.n_states_diag)then + if(i_state+i_other_state.gt.n_states)then exit endif do i=1,N_det - CI_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j) + CI_dressed_pt2_new_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j) enddo - CI_electronic_energy(i_state+i_other_state) = eigenvalues(j) - CI_eigenvectors_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state) + CI_electronic_dressed_pt2_new_energy(i_state+i_other_state) = eigenvalues(j) + CI_dressed_pt2_new_eigenvectors_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state) enddo else print*,'' print*,'!!!!!!!! WARNING !!!!!!!!!' print*,' Within the ',N_det,'determinants selected' - print*,' and the ',N_states_diag,'states requested' + print*,' and the ',N_states,'states requested' print*,' We did not find any state with S^2 values close to ',expected_s2 print*,' We will then set the first N_states eigenvectors of the H matrix' - print*,' as the CI_eigenvectors' + print*,' as the CI_dressed_pt2_new_eigenvectors' print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space' print*,'' - do j=1,min(N_states_diag,N_det) + do j=1,min(N_states,N_det) do i=1,N_det - CI_eigenvectors(i,j) = eigenvectors(i,j) + CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) enddo - CI_electronic_energy(j) = eigenvalues(j) - CI_eigenvectors_s2(j) = s2_eigvalues(j) + CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(j) + CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(j) enddo endif deallocate(index_good_state_array,good_state_array) deallocate(s2_eigvalues) else - call u_0_S2_u_0(CI_eigenvectors_s2,eigenvectors,N_det,psi_det,N_int,& - min(N_det,N_states_diag),size(eigenvectors,1)) - ! Select the "N_states_diag" states of lowest energy - do j=1,min(N_det,N_states_diag) + call u_0_S2_u_0(CI_dressed_pt2_new_eigenvectors_s2,eigenvectors,N_det,psi_ref,N_int,& + min(N_det,N_states),size(eigenvectors,1)) + ! Select the "N_states" states of lowest energy + do j=1,min(N_det,N_states) do i=1,N_det - CI_eigenvectors(i,j) = eigenvectors(i,j) + CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) enddo - CI_electronic_energy(j) = eigenvalues(j) + CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(j) enddo endif deallocate(eigenvectors,eigenvalues) @@ -348,7 +346,7 @@ END_PROVIDER END_PROVIDER -BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states_diag) ] +BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states) ] implicit none BEGIN_DOC ! N_states lowest eigenvalues of the CI matrix @@ -357,11 +355,11 @@ BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states_diag) ] integer :: j character*(8) :: st call write_time(output_determinants) - do j=1,N_states_diag + do j=1,N_states CI_dressed_pt2_new_energy(j) = CI_electronic_dressed_pt2_new_energy(j) + nuclear_repulsion write(st,'(I4)') j call write_double(output_determinants,CI_dressed_pt2_new_energy(j),'Energy of state '//trim(st)) - call write_double(output_determinants,CI_eigenvectors_s2(j),'S^2 of state '//trim(st)) + call write_double(output_determinants,CI_dressed_pt2_new_eigenvectors_s2(j),'S^2 of state '//trim(st)) enddo END_PROVIDER diff --git a/plugins/MRPT_Utils/new_way.irp.f b/plugins/MRPT_Utils/new_way.irp.f index fa5812e1..1775ec41 100644 --- a/plugins/MRPT_Utils/new_way.irp.f +++ b/plugins/MRPT_Utils/new_way.irp.f @@ -22,8 +22,8 @@ subroutine give_2h1p_contrib(matrix_2h1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) @@ -45,7 +45,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) integer :: index_orb_act_mono(N_det,3) do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) do jspin = 1, 2 ! spin of the couple z-a^dagger (j,a) @@ -53,8 +53,8 @@ subroutine give_2h1p_contrib(matrix_2h1p) do a = 1, n_act_orb ! First active aorb = list_act(a) do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation inactive -- > virtual call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin @@ -64,7 +64,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int) ! hole in "jorb" of spin Jspin call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin - ! Check if the excitation is possible or not on psi_det(idet) + ! Check if the excitation is possible or not on psi_ref(idet) accu_elec= 0 do inint = 1, N_int accu_elec+= popcnt(det_tmp(inint,jspin)) @@ -81,7 +81,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) enddo - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int) perturb_dets_phase(a,jspin,ispin) = phase do istate = 1, N_states delta_e(a,jspin,istate) = one_creat(a,jspin,istate) & @@ -109,7 +109,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) !!!!!!!!!!!!!!!!!!!!!!!!!!!! do jdet = 1, idx(0) if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_a @@ -150,7 +150,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) ! you determine the interaction between the excited determinant and the other parent | Jdet > ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet > ! hja = < det_tmp | H | Jdet > - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int) if(kspin == ispin)then hja = phase * (active_int(borb,2) - active_int(borb,1) ) else @@ -216,8 +216,8 @@ subroutine give_1h2p_contrib(matrix_1h2p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) @@ -239,7 +239,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) integer :: index_orb_act_mono(N_det,3) do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements do ispin = 1, 2 ! spin of the couple a-a^dagger (iorb,rorb) do jspin = 1, 2 ! spin of the couple a-a^dagger (aorb,vorb) @@ -247,8 +247,8 @@ subroutine give_1h2p_contrib(matrix_1h2p) aorb = list_act(a) if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation inactive -- > virtual call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin @@ -258,7 +258,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! hole in "aorb" of spin Jspin call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin - ! Check if the excitation is possible or not on psi_det(idet) + ! Check if the excitation is possible or not on psi_ref(idet) accu_elec= 0 do inint = 1, N_int accu_elec+= popcnt(det_tmp(inint,jspin)) @@ -280,7 +280,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) det_tmp(inint,2) = perturb_dets(inint,2,a,jspin,ispin) enddo - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int) perturb_dets_phase(a,jspin,ispin) = phase do istate = 1, N_states delta_e(a,jspin,istate) = one_anhil(a,jspin,istate) & @@ -308,7 +308,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) !!!!!!!!!!!!!!!!!!!!!!!!!!!! do jdet = 1, idx(0) if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a @@ -350,7 +350,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{borb,kspin} a_{iorb,ispin} | Jdet > ! hja = < det_tmp | H | Jdet > - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int) if(kspin == ispin)then hja = phase * (active_int(borb,1) - active_int(borb,2) ) else @@ -418,8 +418,8 @@ subroutine give_1h1p_contrib(matrix_1h1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) @@ -430,20 +430,20 @@ subroutine give_1h1p_contrib(matrix_1h1p) - fock_virt_total_spin_trace(rorb,j) enddo do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations do jdet = 1, idx(0) do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation inactive -- > virtual double precision :: himono,delta_e(N_states),coef_mono(N_states) call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) + call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,himono) do state_target = 1, N_states ! delta_e(state_target) = one_anhil_one_creat_inact_virt(i,r,state_target) + delta_e_inact_virt(state_target) @@ -451,7 +451,7 @@ subroutine give_1h1p_contrib(matrix_1h1p) coef_mono(state_target) = himono / delta_e(state_target) enddo if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha aorb = (exc(1,2,1)) !!! a^{\dagger}_a @@ -464,15 +464,15 @@ subroutine give_1h1p_contrib(matrix_1h1p) jspin = 2 endif - call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) + call get_excitation_degree(psi_ref(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) if(degree_scalar .ne. 2)then print*, 'pb !!!' print*, degree_scalar - call debug_det(psi_det(1,1,idx(jdet)),N_int) + call debug_det(psi_ref(1,1,idx(jdet)),N_int) call debug_det(det_tmp,N_int) stop endif - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int) if(ispin == jspin )then hij = -get_mo_bielec_integral(iorb,aorb,rorb,borb,mo_integrals_map) & + get_mo_bielec_integral(iorb,aorb,borb,rorb,mo_integrals_map) @@ -482,17 +482,17 @@ subroutine give_1h1p_contrib(matrix_1h1p) hij = hij * phase double precision :: hij_test integer :: state_target - call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) + call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hij_test) if(dabs(hij - hij_test).gt.1.d-10)then print*, 'ahah pb !!' print*, 'hij .ne. hij_test' print*, hij,hij_test - call debug_det(psi_det(1,1,idx(jdet)),N_int) + call debug_det(psi_ref(1,1,idx(jdet)),N_int) call debug_det(det_tmp,N_int) print*, ispin, jspin print*,iorb,borb,rorb,aorb print*, phase - call i_H_j_verbose(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) + call i_H_j_verbose(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hij_test) stop endif do state_target = 1, N_states @@ -542,13 +542,13 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo double precision :: himono,delta_e(N_states),coef_mono(N_states) integer :: state_target do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx) do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) do r = 1, n_virt_orb ! First virtual @@ -563,13 +563,13 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) - fock_virt_total_spin_trace(rorb,j) enddo do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation inactive -- > virtual call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) + call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,himono) do inint = 1, N_int det_pert(inint,1,i,r,ispin) = det_tmp(inint,1) det_pert(inint,2,i,r,ispin) = det_tmp(inint,2) @@ -630,7 +630,7 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) do jdet = 1, idx(0) ! if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha aorb = (exc(1,2,1)) !!! a^{\dagger}_a @@ -642,24 +642,24 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) jspin = 2 endif - call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) + call get_excitation_degree(psi_ref(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) if(degree_scalar .ne. 2)then print*, 'pb !!!' print*, degree_scalar - call debug_det(psi_det(1,1,idx(jdet)),N_int) + call debug_det(psi_ref(1,1,idx(jdet)),N_int) call debug_det(det_tmp,N_int) stop endif - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int) double precision :: hij_test hij_test = 0.d0 - call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) + call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hij_test) do state_target = 1, N_states matrix_1h1p(idx(jdet),idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2) enddo else hij_test = 0.d0 - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hij_test) + call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,hij_test) do state_target = 1, N_states matrix_1h1p(idet,idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2) enddo @@ -701,13 +701,13 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo double precision :: himono,delta_e(N_states),coef_mono(N_states) integer :: state_target do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx) do i = 1, n_act_orb ! First active iorb = list_act(i) do r = 1, n_virt_orb ! First virtual @@ -721,8 +721,8 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) delta_e_act_virt(j) = - fock_virt_total_spin_trace(rorb,j) enddo do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation active -- > virtual call do_mono_excitation(det_tmp,iorb,rorb,ispin,i_ok) @@ -739,7 +739,7 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) enddo cycle endif - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) + call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,himono) do inint = 1, N_int det_pert(inint,1,i,r,ispin) = det_tmp(inint,1) det_pert(inint,2,i,r,ispin) = det_tmp(inint,2) @@ -803,8 +803,8 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) enddo do jdet = 1,N_det double precision :: coef_array(N_states),hij_test - call i_H_j(det_tmp,psi_det(1,1,jdet),N_int,himono) - call get_delta_e_dyall(psi_det(1,1,jdet),det_tmp,coef_array,hij_test,delta_e) + call i_H_j(det_tmp,psi_ref(1,1,jdet),N_int,himono) + call get_delta_e_dyall(psi_ref(1,1,jdet),det_tmp,delta_e) do state_target = 1, N_states ! matrix_1p(idet,jdet,state_target) += himono * coef_det_pert(i,r,ispin,state_target,1) matrix_1p(idet,jdet,state_target) += himono * hij_det_pert(i,r,ispin) / delta_e(state_target) @@ -850,8 +850,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) @@ -862,7 +862,7 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) - fock_virt_total_spin_trace(rorb,j) enddo do idet = 1, N_det - call get_excitation_degree_vector_double_alpha_beta(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + call get_excitation_degree_vector_double_alpha_beta(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations do ispin = 1, 2 @@ -872,8 +872,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) do b = 1, n_act_orb borb = list_act(b) do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation (i-->a)(ispin) + (b-->r)(other_spin(ispin)) integer :: i_ok,corb,dorb @@ -904,7 +904,7 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) pert_det(inint,2,a,b,ispin) = det_tmp(inint,2) enddo - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hidouble) + call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,hidouble) do state_target = 1, N_states delta_e(state_target) = one_anhil_one_creat(a,b,ispin,jspin,state_target) + delta_e_inact_virt(state_target) pert_det_coef(a,b,ispin,state_target) = hidouble / delta_e(state_target) @@ -915,7 +915,7 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) enddo do jdet = 1, idx(0) if(idx(jdet).ne.idet)then - call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) integer :: c,d,state_target integer(bit_kind) :: det_tmp_bis(N_int,2) ! excitation from I --> J @@ -935,8 +935,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) det_tmp_bis(inint,2) = pert_det(inint,2,c,d,2) enddo double precision :: hjdouble_1,hjdouble_2 - call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hjdouble_1) - call i_H_j(psi_det(1,1,idx(jdet)),det_tmp_bis,N_int,hjdouble_2) + call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hjdouble_1) + call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp_bis,N_int,hjdouble_2) do state_target = 1, N_states matrix_1h1p(idx(jdet),idet,state_target) += (pert_det_coef(c,d,1,state_target) * hjdouble_1 + pert_det_coef(c,d,2,state_target) * hjdouble_2 ) enddo diff --git a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f index ce3a74c8..170d3f5e 100644 --- a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f +++ b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f @@ -24,8 +24,8 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) @@ -50,9 +50,9 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) integer :: istate do idet = 1, N_det - call get_excitation_degree_vector_mono_or_exchange(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + call get_excitation_degree_vector_mono_or_exchange(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx) ! if(idet == 81)then -! call get_excitation_degree_vector_mono_or_exchange_verbose(psi_det(1,1,1),psi_det(1,1,idet),degree,N_int,N_det,idx) +! call get_excitation_degree_vector_mono_or_exchange_verbose(psi_ref(1,1,1),psi_ref(1,1,idet),degree,N_int,N_det,idx) ! endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) @@ -61,8 +61,8 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) do a = 1, n_act_orb ! First active aorb = list_act(a) do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation inactive -- > virtual call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin @@ -72,7 +72,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int) ! hole in "jorb" of spin Jspin call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin - ! Check if the excitation is possible or not on psi_det(idet) + ! Check if the excitation is possible or not on psi_ref(idet) accu_elec= 0 do inint = 1, N_int accu_elec+= popcnt(det_tmp(inint,jspin)) @@ -90,7 +90,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) enddo - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int) perturb_dets_phase(a,jspin,ispin) = phase do istate = 1, N_states delta_e(a,jspin,istate) = one_creat(a,jspin,istate) & @@ -124,7 +124,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) do jdet = 1, idx(0) if(idx(jdet).ne.idet)then if(degree(jdet)==1)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha i_hole = list_act_reverse(exc(1,1,1)) !!! a_a @@ -149,7 +149,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator endif else if(degree(jdet)==2)then - call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) ! Mono alpha index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} @@ -196,7 +196,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) enddo ! ! < idet | H | det_tmp > = phase * (ir|cv) - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int) if(ispin == jspin)then hib= phase * (active_int(corb,1) - active_int(corb,2)) else @@ -215,7 +215,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) stop endif ! < jdet | H | det_tmp_bis > = phase * (ir|cv) - call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_double_excitation(det_tmp_bis,psi_ref(1,1,idx(jdet)),exc,phase,N_int) if(ispin == jspin)then hja= phase * (active_int(corb,1) - active_int(corb,2)) else @@ -243,7 +243,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) enddo ! < idet | H | det_tmp > = phase * ( (ir|cv) - (iv|cr) ) - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int) if(ispin == jspin)then hib= phase * (active_int(corb,1) - active_int(corb,2)) else @@ -260,7 +260,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) stop endif ! < jdet | H | det_tmp_bis > = phase * ( (ir|cv) - (iv|cr) ) - call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_double_excitation(det_tmp_bis,psi_ref(1,1,idx(jdet)),exc,phase,N_int) if(ispin == jspin)then hja= phase * (active_int(corb,1) - active_int(corb,2)) else @@ -296,7 +296,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin) enddo ! | det_tmp > = a^{\dagger}_{aorb,beta} | Idet > - call get_double_excitation(det_tmp,psi_det(1,1,idet),exc,phase,N_int) + call get_double_excitation(det_tmp,psi_ref(1,1,idet),exc,phase,N_int) if(ispin == jspin)then hib= phase * (active_int(aorb,1) - active_int(aorb,2)) else @@ -312,15 +312,15 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) else if(index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),4))then !! closed shell double excitation else - call get_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,degree_scalar,phase,N_int) + call get_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,degree_scalar,phase,N_int) integer :: h1,h2,p1,p2,s1,s2 , degree_scalar call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) print*, h1,p1,h2,p2,s1,s2 - call debug_det(psi_det(1,1,idet),N_int) - call debug_det(psi_det(1,1,idx(jdet)),N_int) + call debug_det(psi_ref(1,1,idet),N_int) + call debug_det(psi_ref(1,1,idx(jdet)),N_int) print*, idet,idx(jdet) print*, 'pb !!!!!!!!!!!!!' - call get_excitation_degree_vector_mono_or_exchange_verbose(psi_det(1,1,1),psi_det(1,1,idet),degree,N_int,N_det,idx) + call get_excitation_degree_vector_mono_or_exchange_verbose(psi_ref(1,1,1),psi_ref(1,1,idet),degree,N_int,N_det,idx) stop endif endif @@ -398,8 +398,8 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) @@ -430,7 +430,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) + fock_core_inactive_total_spin_trace(iorb,istate) enddo do idet = 1, N_det - call get_excitation_degree_vector_mono_or_exchange(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + call get_excitation_degree_vector_mono_or_exchange(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements do ispin = 1, 2 ! spin of the couple a-a^dagger (iorb,rorb) do jspin = 1, 2 ! spin of the couple a-a^dagger (aorb,vorb) @@ -443,8 +443,8 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) enddo if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation inactive -- > virtual call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin @@ -454,7 +454,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! hole in "aorb" of spin Jspin call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin - ! Check if the excitation is possible or not on psi_det(idet) + ! Check if the excitation is possible or not on psi_ref(idet) accu_elec= 0 do inint = 1, N_int accu_elec+= popcnt(det_tmp(inint,jspin)) @@ -477,7 +477,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) det_tmp(inint,2) = perturb_dets(inint,2,a,jspin,ispin) enddo - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int) perturb_dets_phase(a,jspin,ispin) = phase do istate = 1, N_states @@ -501,7 +501,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) do jdet = 1, idx(0) if(idx(jdet).ne.idet)then if(degree(jdet)==1)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha i_hole = list_act_reverse(exc(1,1,1)) !!! a_a @@ -526,7 +526,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator endif else if(degree(jdet)==2)then - call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) ! Mono alpha index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} @@ -575,7 +575,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) enddo ! < idet | H | det_tmp > = phase * (ir|cv) - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int) if(ispin == jspin)then hib= phase * (active_int(corb,1) - active_int(corb,2)) else @@ -590,7 +590,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} hab = (fock_operator_local(aorb,borb,kspin) ) * phase ! < jdet | H | det_tmp_bis > = phase * (ir|cv) - call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_double_excitation(det_tmp_bis,psi_ref(1,1,idx(jdet)),exc,phase,N_int) if(ispin == jspin)then hja= phase * (active_int(corb,1) - active_int(corb,2)) else @@ -617,7 +617,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) enddo ! < idet | H | det_tmp > = phase * ( (ir|cv) - (iv|cr) ) - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int) if(ispin == jspin)then hib= phase * (active_int(corb,1) - active_int(corb,2)) else @@ -630,7 +630,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) ! ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} hab = fock_operator_local(aorb,borb,kspin) * phase ! < jdet | H | det_tmp_bis > = phase * ( (ir|cv) - (iv|cr) ) - call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_double_excitation(det_tmp_bis,psi_ref(1,1,idx(jdet)),exc,phase,N_int) if(ispin == jspin)then hja= phase * (active_int(corb,1) - active_int(corb,2)) else @@ -665,7 +665,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,jspin,ispin) det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin) enddo - call get_double_excitation(det_tmp,psi_det(1,1,idet),exc,phase,N_int) + call get_double_excitation(det_tmp,psi_ref(1,1,idet),exc,phase,N_int) if(ispin == jspin)then hib= phase * (active_int(borb,1) - active_int(borb,2)) else @@ -674,8 +674,8 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) if( index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),5))then call do_mono_excitation(det_tmp_bis,list_act(borb),list_act(aorb),1,i_ok) if(i_ok .ne. 1)then - call debug_det(psi_det(1,1,idet),N_int) - call debug_det(psi_det(1,1,idx(jdet)),N_int) + call debug_det(psi_ref(1,1,idet),N_int) + call debug_det(psi_ref(1,1,idx(jdet)),N_int) print*, aorb, borb call debug_det(det_tmp,N_int) stop @@ -692,7 +692,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) stop endif hab = fock_operator_local(aorb,borb,1) * phase - call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_double_excitation(det_tmp_bis,psi_ref(1,1,idx(jdet)),exc,phase,N_int) if(ispin == jspin)then hja= phase * (active_int(borb,1) - active_int(borb,2)) else @@ -716,7 +716,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,jspin,ispin) det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin) enddo - call get_double_excitation(det_tmp,psi_det(1,1,idet),exc,phase,N_int) + call get_double_excitation(det_tmp,psi_ref(1,1,idet),exc,phase,N_int) if(ispin == jspin)then hib= phase * (active_int(borb,1) - active_int(borb,2)) else @@ -725,8 +725,8 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) if( index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),5))then call do_mono_excitation(det_tmp_bis,list_act(borb),list_act(aorb),2,i_ok) if(i_ok .ne. 1)then - call debug_det(psi_det(1,1,idet),N_int) - call debug_det(psi_det(1,1,idx(jdet)),N_int) + call debug_det(psi_ref(1,1,idet),N_int) + call debug_det(psi_ref(1,1,idx(jdet)),N_int) print*, aorb, borb call debug_det(det_tmp,N_int) stop @@ -739,7 +739,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} hab = fock_operator_local(aorb,borb,2) * phase - call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_double_excitation(det_tmp_bis,psi_ref(1,1,idx(jdet)),exc,phase,N_int) if(ispin == jspin)then hja= phase * (active_int(borb,1) - active_int(borb,2)) else diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index 794742b4..bfc2d9b0 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -11,8 +11,8 @@ BEGIN_PROVIDER [integer(bit_kind), psi_active, (N_int,2,psi_det_size)] !print*, 'psi_active ' do i = 1, N_det do j = 1, N_int - psi_active(j,1,i) = iand(psi_det(j,1,i),cas_bitmask(j,1,1)) - psi_active(j,2,i) = iand(psi_det(j,2,i),cas_bitmask(j,1,1)) + psi_active(j,1,i) = iand(psi_ref(j,1,i),cas_bitmask(j,1,1)) + psi_active(j,2,i) = iand(psi_ref(j,2,i),cas_bitmask(j,1,1)) enddo enddo END_PROVIDER @@ -152,7 +152,7 @@ subroutine give_particles_in_virt_space(det_1,n_particles_spin,n_particles,parti end -subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) +subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) BEGIN_DOC ! routine that returns the delta_e with the Moller Plesset and Dyall operators ! @@ -170,7 +170,6 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) use bitmasks double precision, intent(out) :: delta_e_final(N_states) integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) - double precision, intent(in) :: coef_array(N_states),hij integer :: i,j,k,l integer :: i_state @@ -293,20 +292,9 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) if (n_holes_act == 0 .and. n_particles_act == 1) then ispin = particle_list_practical(1,1) i_particle_act = particle_list_practical(2,1) -! call get_excitation_degree(det_1,det_2,degree,N_int) -! if(degree == 1)then -! call get_excitation(det_1,det_2,exc,degree,phase,N_int) -! call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) -! i_hole = list_inact_reverse(h1) -! i_part = list_act_reverse(p1) -! do i_state = 1, N_states -! delta_e_act(i_state) += one_anhil_inact(i_hole,i_part,i_state) -! enddo -! else if (degree == 2)then do i_state = 1, N_states delta_e_act(i_state) += one_creat(i_particle_act,ispin,i_state) enddo -! endif else if (n_holes_act == 1 .and. n_particles_act == 0) then ispin = hole_list_practical(1,1) @@ -433,3 +421,159 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) end + + +subroutine get_delta_e_dyall_general_mp(det_1,det_2,delta_e_final) + BEGIN_DOC + ! routine that returns the delta_e with the Moller Plesset and Dyall operators + ! + ! with det_1 being a determinant from the cas, and det_2 being a perturber + ! + ! Delta_e(det_1,det_2) = sum (hole) epsilon(hole) + sum(part) espilon(part) + delta_e(act) + ! + ! where hole is necessary in the inactive, part necessary in the virtuals + ! + ! and delta_e(act) is obtained as the sum of energies of excitations a la MP + ! + END_DOC + implicit none + use bitmasks + double precision, intent(out) :: delta_e_final(N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer :: i,j,k,l + integer :: i_state + + integer :: n_holes_spin(2) + integer :: n_holes + integer :: holes_list(N_int*bit_kind_size,2) + + + double precision :: delta_e_inactive(N_states) + integer :: i_hole_inact + + + call give_holes_in_inactive_space(det_2,n_holes_spin,n_holes,holes_list) + delta_e_inactive = 0.d0 + do i = 1, n_holes_spin(1) + i_hole_inact = holes_list(i,1) + do i_state = 1, N_states + delta_e_inactive += fock_core_inactive_total_spin_trace(i_hole_inact,i_state) + enddo + enddo + + do i = 1, n_holes_spin(2) + i_hole_inact = holes_list(i,2) + do i_state = 1, N_states + delta_e_inactive(i_state) += fock_core_inactive_total_spin_trace(i_hole_inact,i_state) + enddo + enddo + + double precision :: delta_e_virt(N_states) + integer :: i_part_virt + integer :: n_particles_spin(2) + integer :: n_particles + integer :: particles_list(N_int*bit_kind_size,2) + + call give_particles_in_virt_space(det_2,n_particles_spin,n_particles,particles_list) + delta_e_virt = 0.d0 + do i = 1, n_particles_spin(1) + i_part_virt = particles_list(i,1) + do i_state = 1, N_states + delta_e_virt += fock_virt_total_spin_trace(i_part_virt,i_state) + enddo + enddo + + do i = 1, n_particles_spin(2) + i_part_virt = particles_list(i,2) + do i_state = 1, N_states + delta_e_virt += fock_virt_total_spin_trace(i_part_virt,i_state) + enddo + enddo + + + integer :: n_holes_spin_act(2),n_particles_spin_act(2) + integer :: n_holes_act,n_particles_act + integer :: holes_active_list(2*n_act_orb,2) + integer :: holes_active_list_spin_traced(4*n_act_orb) + integer :: particles_active_list(2*n_act_orb,2) + integer :: particles_active_list_spin_traced(4*n_act_orb) + double precision :: delta_e_act(N_states) + delta_e_act = 0.d0 + call give_holes_and_particles_in_active_space(det_1,det_2,n_holes_spin_act,n_particles_spin_act, & + n_holes_act,n_particles_act,holes_active_list,particles_active_list) + integer :: icount,icountbis + integer :: hole_list_practical(2,elec_num_tab(1)+elec_num_tab(2)), particle_list_practical(2,elec_num_tab(1)+elec_num_tab(2)) + icount = 0 + icountbis = 0 + do i = 1, n_holes_spin_act(1) + icount += 1 + icountbis += 1 + hole_list_practical(1,icountbis) = 1 ! spin + hole_list_practical(2,icountbis) = holes_active_list(i,1) ! index of active orb + holes_active_list_spin_traced(icount) = holes_active_list(i,1) + enddo + do i = 1, n_holes_spin_act(2) + icount += 1 + icountbis += 1 + hole_list_practical(1,icountbis) = 2 + hole_list_practical(2,icountbis) = holes_active_list(i,2) + holes_active_list_spin_traced(icount) = holes_active_list(i,2) + enddo + if(icount .ne. n_holes_act) then + print*,'' + print*, icount, n_holes_act + print * , 'pb in holes_active_list_spin_traced !!' + stop + endif + + icount = 0 + icountbis = 0 + do i = 1, n_particles_spin_act(1) + icount += 1 + icountbis += 1 + particle_list_practical(1,icountbis) = 1 + particle_list_practical(2,icountbis) = particles_active_list(i,1) + particles_active_list_spin_traced(icount) = particles_active_list(i,1) + enddo + do i = 1, n_particles_spin_act(2) + icount += 1 + icountbis += 1 + particle_list_practical(1,icountbis) = 2 + particle_list_practical(2,icountbis) = particles_active_list(i,2) + particles_active_list_spin_traced(icount) = particles_active_list(i,2) + enddo + if(icount .ne. n_particles_act) then + print*, icount, n_particles_act + print * , 'pb in particles_active_list_spin_traced !!' + stop + endif + + + integer :: i_hole_act, j_hole_act, k_hole_act + integer :: i_particle_act, j_particle_act, k_particle_act + + + integer :: ispin,jspin,kspin + + do i = 1, n_holes_act + ispin = hole_list_practical(1,i) + i_hole_act = hole_list_practical(2,i) + do i_state = 1, N_states + delta_e_act(i_state) += one_anhil(i_hole_act , ispin,i_state) + enddo + enddo + + do i = 1, n_particles_act + ispin = particle_list_practical(1,i) + i_particle_act = particle_list_practical(2,i) + do i_state = 1, N_states + delta_e_act(i_state) += one_creat(i_particle_act, ispin,i_state) + enddo + enddo + + do i_state = 1, n_states + delta_e_final(i_state) = delta_e_act(i_state) + delta_e_inactive(i_state) - delta_e_virt(i_state) + enddo + +end + diff --git a/plugins/MRPT_Utils/second_order_new.irp.f b/plugins/MRPT_Utils/second_order_new.irp.f index ba3b421b..43c5f3d4 100644 --- a/plugins/MRPT_Utils/second_order_new.irp.f +++ b/plugins/MRPT_Utils/second_order_new.irp.f @@ -51,8 +51,8 @@ subroutine give_1h2p_new(matrix_1h2p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) @@ -79,7 +79,7 @@ subroutine give_1h2p_new(matrix_1h2p) + fock_core_inactive_total_spin_trace(iorb,istate) enddo do idet = 1, N_det - call get_excitation_degree_vector_mono_or_exchange(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + call get_excitation_degree_vector_mono_or_exchange(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements do ispin = 1, 2 ! spin of the couple a-a^dagger (iorb,rorb) do jspin = 1, 2 ! spin of the couple a-a^dagger (aorb,vorb) @@ -90,8 +90,8 @@ subroutine give_1h2p_new(matrix_1h2p) enddo if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation inactive -- > virtual call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin @@ -101,7 +101,7 @@ subroutine give_1h2p_new(matrix_1h2p) call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! hole in "aorb" of spin Jspin call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin - ! Check if the excitation is possible or not on psi_det(idet) + ! Check if the excitation is possible or not on psi_ref(idet) accu_elec= 0 do inint = 1, N_int accu_elec+= popcnt(det_tmp(inint,jspin)) @@ -116,7 +116,7 @@ subroutine give_1h2p_new(matrix_1h2p) perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) enddo - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int) perturb_dets_phase(a,jspin,ispin) = phase do istate = 1, N_states @@ -138,7 +138,7 @@ subroutine give_1h2p_new(matrix_1h2p) !!!!!!!!!!!!!!!!!!!!!!!!!!!! do jdet = 1, idx(0) if(degree(jdet)==1)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha i_hole = list_act_reverse(exc(1,1,1)) !!! a_a @@ -163,7 +163,7 @@ subroutine give_1h2p_new(matrix_1h2p) fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator endif else if(degree(jdet)==2)then - call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) ! Mono alpha index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a ALPHA index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} ALPHA @@ -209,13 +209,13 @@ subroutine give_1h2p_new(matrix_1h2p) det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin) det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin) enddo - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int) if(kspin == ispin)then hia = phase * (active_int(aorb,1) - active_int(aorb,2) ) else hia = phase * active_int(aorb,1) endif - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int) if(kspin == ispin)then hja = phase * (active_int(borb,1) - active_int(borb,2) ) else @@ -254,7 +254,7 @@ subroutine give_1h2p_new(matrix_1h2p) if(dabs(hia).le.1.d-12)cycle if(dabs(hab).le.1.d-12)cycle - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) if(jspin == ispin)then hjb = phase * (active_int(corb,1) - active_int(corb,2) ) else @@ -307,7 +307,7 @@ subroutine give_1h2p_new(matrix_1h2p) hab = fock_operator_local(aorb,borb,1) * phase if(dabs(hab).le.1.d-12)cycle - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) if(ispin == 2)then hjb = phase * (active_int(aorb,1) - active_int(aorb,2) ) else if (ispin == 1)then @@ -341,7 +341,7 @@ subroutine give_1h2p_new(matrix_1h2p) hab = fock_operator_local(aorb,borb,2) * phase if(dabs(hab).le.1.d-12)cycle - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) if(ispin == 1)then hjb = phase * (active_int(borb,1) - active_int(borb,2) ) else if (ispin == 2)then @@ -380,7 +380,7 @@ subroutine give_1h2p_new(matrix_1h2p) hab = fock_operator_local(aorb,borb,1) * phase if(dabs(hab).le.1.d-12)cycle - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) if(ispin == 2)then hjb = phase * (active_int(borb,1) - active_int(borb,2) ) else if (ispin == 1)then @@ -415,7 +415,7 @@ subroutine give_1h2p_new(matrix_1h2p) hab = fock_operator_local(aorb,borb,2) * phase if(dabs(hab).le.1.d-12)cycle - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) if(ispin == 1)then hjb = phase * (active_int(borb,1) - active_int(borb,2) ) else if (ispin == 2)then @@ -433,9 +433,9 @@ subroutine give_1h2p_new(matrix_1h2p) else ! one should not fall in this case ... - call debug_det(psi_det(1,1,i),N_int) - call debug_det(psi_det(1,1,idx(jdet)),N_int) - call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call debug_det(psi_ref(1,1,i),N_int) + call debug_det(psi_ref(1,1,idx(jdet)),N_int) + call get_double_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) call decode_exc(exc,2,h1,p1,h2,p2,s1,s2) integer :: h1, p1, h2, p2, s1, s2 print*, h1, p1, h2, p2, s1, s2 @@ -519,8 +519,8 @@ subroutine give_2h1p_new(matrix_2h1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) @@ -547,7 +547,7 @@ subroutine give_2h1p_new(matrix_2h1p) enddo do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) do jspin = 1, 2 ! spin of the couple z-a^dagger (j,a) @@ -555,8 +555,8 @@ subroutine give_2h1p_new(matrix_2h1p) do a = 1, n_act_orb ! First active aorb = list_act(a) do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation inactive -- > virtual call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin @@ -566,7 +566,7 @@ subroutine give_2h1p_new(matrix_2h1p) call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int) ! hole in "jorb" of spin Jspin call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin - ! Check if the excitation is possible or not on psi_det(idet) + ! Check if the excitation is possible or not on psi_ref(idet) accu_elec= 0 do inint = 1, N_int accu_elec+= popcnt(det_tmp(inint,jspin)) @@ -580,7 +580,7 @@ subroutine give_2h1p_new(matrix_2h1p) perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) enddo - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int) perturb_dets_phase(a,jspin,ispin) = phase do istate = 1, N_states delta_e(a,jspin,istate) = one_creat(a,jspin,istate) + delta_e_inactive_virt(istate) @@ -602,7 +602,7 @@ subroutine give_2h1p_new(matrix_2h1p) !!!!!!!!!!!!!!!!!!!!!!!!!!!! do jdet = 1, idx(0) if(degree(jdet)==1)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha i_part = list_act_reverse(exc(1,2,1)) ! a^{\dagger}_{aorb} @@ -658,7 +658,7 @@ subroutine give_2h1p_new(matrix_2h1p) ! you determine the interaction between the excited determinant and the other parent | Jdet > ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet > ! hja = < det_tmp | H | Jdet > - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int) if(kspin == ispin)then hja = phase * (active_int(borb,1) - active_int(borb,2) ) else @@ -698,7 +698,7 @@ subroutine give_2h1p_new(matrix_2h1p) hab = fock_operator_local(borb,aorb,kspin) * phase if(dabs(hab).le.1.d-10)cycle - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) if(jspin == ispin)then hjb = phase * (active_int(corb,1) - active_int(corb,2) ) else diff --git a/plugins/MRPT_Utils/second_order_new_2p.irp.f b/plugins/MRPT_Utils/second_order_new_2p.irp.f index 11ae18da..302e699b 100644 --- a/plugins/MRPT_Utils/second_order_new_2p.irp.f +++ b/plugins/MRPT_Utils/second_order_new_2p.irp.f @@ -50,8 +50,8 @@ subroutine give_2p_new(matrix_2p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo do v = 1, n_virt_orb ! First virtual vorb = list_virt(v) @@ -82,8 +82,8 @@ subroutine give_2p_new(matrix_2p) - fock_virt_total_spin_trace(vorb,istate) enddo do idet = 1, N_det -! call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) - call get_excitation_degree_vector(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) +! call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx) + call get_excitation_degree_vector(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements do ispin = 1, 2 ! spin of the couple a-a^dagger (aorb,rorb) do jspin = 1, 2 ! spin of the couple a-a^dagger (borb,vorb) @@ -108,8 +108,8 @@ subroutine give_2p_new(matrix_2p) cycle ! condition not to double count endif do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation (aorb,ispin) --> (rorb,ispin) call clear_bit_to_integer(aorb,det_tmp(1,ispin),N_int) ! hole in "aorb" of spin Ispin @@ -119,7 +119,7 @@ subroutine give_2p_new(matrix_2p) call clear_bit_to_integer(borb,det_tmp(1,jspin),N_int) ! hole in "borb" of spin Jspin call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin - ! Check if the excitation is possible or not on psi_det(idet) + ! Check if the excitation is possible or not on psi_ref(idet) accu_elec= 0 do inint = 1, N_int accu_elec+= popcnt(det_tmp(inint,1)) + popcnt(det_tmp(inint,2)) @@ -134,7 +134,7 @@ subroutine give_2p_new(matrix_2p) perturb_dets(inint,2,a,b,ispin,jspin) = det_tmp(inint,2) enddo - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int) perturb_dets_phase(a,b,ispin,jspin) = phase do istate = 1, N_states @@ -146,16 +146,16 @@ subroutine give_2p_new(matrix_2p) else perturb_dets_hij(a,b,ispin,jspin) = phase * active_int(a,b,1) endif - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hij) + call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,hij) if(hij.ne.perturb_dets_hij(a,b,ispin,jspin))then print*, active_int(a,b,1) , active_int(b,a,1) double precision :: hmono,hdouble - call i_H_j_verbose(psi_det(1,1,idet),det_tmp,N_int,hij,hmono,hdouble) + call i_H_j_verbose(psi_ref(1,1,idet),det_tmp,N_int,hij,hmono,hdouble) print*, 'pb !! hij.ne.perturb_dets_hij(a,b,ispin,jspin)' print*, ispin,jspin print*, aorb,rorb,borb,vorb print*, hij,perturb_dets_hij(a,b,ispin,jspin) - call debug_det(psi_det(1,1,idet),N_int) + call debug_det(psi_ref(1,1,idet),N_int) call debug_det(det_tmp,N_int) stop endif @@ -170,7 +170,7 @@ subroutine give_2p_new(matrix_2p) !!!!!!!!!!!!!!!!!!!!!!!!!!!! do jdet = 1, idx(0) if(degree(jdet)==1)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha i_hole = list_act_reverse(exc(1,1,1)) !!! a_a @@ -195,7 +195,7 @@ subroutine give_2p_new(matrix_2p) fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator endif else if(degree(jdet)==2)then - call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a ALPHA @@ -262,7 +262,7 @@ subroutine give_2p_new(matrix_2p) do jdet = 1, idx(0) ! if(idx(jdet).gt.idet)cycle do istate = 1, N_states - call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij) + call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hij) matrix_2p(idx(jdet),idet,istate) += hij * perturb_dets_hij(a,b,ispin,jspin) * delta_e_inv(a,b,ispin,jspin,istate) enddo enddo ! jdet diff --git a/plugins/Perturbation/pt2_equations.irp.f b/plugins/Perturbation/pt2_equations.irp.f index b29e130f..1cd0d440 100644 --- a/plugins/Perturbation/pt2_equations.irp.f +++ b/plugins/Perturbation/pt2_equations.irp.f @@ -226,18 +226,15 @@ subroutine pt2_moller_plesset ($arguments) call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) delta_e = (Fock_matrix_diag_mo(h1) - Fock_matrix_diag_mo(p1)) + & (Fock_matrix_diag_mo(h2) - Fock_matrix_diag_mo(p2)) - delta_e = 1.d0/delta_e -! print*,'h1,p1',h1,p1 -! print*,'h2,p2',h2,p2 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 - if (delta_e /= 0.d0) then + if (dabs(delta_e) > 1.d-10) then + delta_e = 1.d0/delta_e call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array) h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint) else @@ -246,11 +243,6 @@ subroutine pt2_moller_plesset ($arguments) endif do i =1,N_st H_pert_diag(i) = h -! if(dabs(i_H_psi_array(i)).gt.1.d-8)then -! print*, i_H_psi_array(i) -! call debug_det(det_pert,N_int) -! print*, h1,p1,h2,p2,s1,s2 -! endif c_pert(i) = i_H_psi_array(i) *delta_e e_2_pert(i) = c_pert(i) * i_H_psi_array(i) enddo diff --git a/plugins/Selectors_CASSD/selectors.irp.f b/plugins/Selectors_CASSD/selectors.irp.f index ab36527d..31a8ab4f 100644 --- a/plugins/Selectors_CASSD/selectors.irp.f +++ b/plugins/Selectors_CASSD/selectors.irp.f @@ -30,7 +30,7 @@ END_PROVIDER enddo enddo do k=1,N_states - do i=1,N_det_selectors + do i=1,N_det_generators psi_selectors_coef(i,k) = psi_coef_generators(i,k) enddo enddo diff --git a/plugins/Selectors_CASSD/zmq.irp.f b/plugins/Selectors_CASSD/zmq.irp.f index 4359a876..2d4987d3 100644 --- a/plugins/Selectors_CASSD/zmq.irp.f +++ b/plugins/Selectors_CASSD/zmq.irp.f @@ -9,6 +9,7 @@ subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id, energy, size_energy) integer, intent(in) :: size_energy double precision, intent(out) :: energy(size_energy) integer :: rc + integer*8 :: rc8 character*(256) :: msg write(msg,*) 'put_psi ', worker_id, N_states, N_det, psi_det_size, n_det_generators, n_det_selectors @@ -19,15 +20,15 @@ subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id, energy, size_energy) stop 'error' endif - rc = f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE) - if (rc /= N_int*2*N_det*bit_kind) then - print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)' + rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,ZMQ_SNDMORE) + if (rc8 /= N_int*2_8*N_det*bit_kind) then + print *, 'f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,ZMQ_SNDMORE)' stop 'error' endif - rc = f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE) - if (rc /= psi_det_size*N_states*8) then - print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)' + rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,ZMQ_SNDMORE) + if (rc8 /= psi_det_size*N_states*8_8) then + print *, 'f77_zmq_send8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,ZMQ_SNDMORE)' stop 'error' endif @@ -59,6 +60,7 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy) integer, intent(in) :: size_energy double precision, intent(out) :: energy(size_energy) integer :: rc + integer*8 :: rc8 character*(64) :: msg write(msg,*) 'get_psi ', worker_id @@ -78,33 +80,30 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy) integer :: N_states_read, N_det_read, psi_det_size_read integer :: N_det_selectors_read, N_det_generators_read - read(msg(14:rc),*) rc, N_states_read, N_det_read, psi_det_size_read, & + read(msg(14:rc),*) N_states_read, N_det_read, psi_det_size_read, & N_det_generators_read, N_det_selectors_read - if (rc /= worker_id) then - print *, 'Wrong worker ID' - stop 'error' - endif N_states = N_states_read N_det = N_det_read psi_det_size = psi_det_size_read + TOUCH psi_det_size N_det N_states - rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE) - if (rc /= N_int*2*N_det*bit_kind) then + rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,0) + if (rc8 /= N_int*2_8*N_det*bit_kind) then print *, 'f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)' stop 'error' endif - rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE) - if (rc /= psi_det_size*N_states*8) then - print *, '77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)' + rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,0) + if (rc8 /= psi_det_size*N_states*8_8) then + print *, '77_zmq_recv8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,ZMQ_SNDMORE)' stop 'error' endif - TOUCH psi_det_size N_det N_states psi_det psi_coef + TOUCH psi_det psi_coef rc = f77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0) if (rc /= size_energy*8) then - print *, 'f77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)' + print *, '77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)' stop 'error' endif diff --git a/plugins/Selectors_full/zmq.irp.f b/plugins/Selectors_full/zmq.irp.f index 59f40daf..88f7fa06 100644 --- a/plugins/Selectors_full/zmq.irp.f +++ b/plugins/Selectors_full/zmq.irp.f @@ -9,6 +9,7 @@ subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id, energy, size_energy) integer, intent(in) :: size_energy double precision, intent(out) :: energy(size_energy) integer :: rc + integer*8 :: rc8 character*(256) :: msg write(msg,*) 'put_psi ', worker_id, N_states, N_det, psi_det_size, n_det_generators, n_det_selectors @@ -19,15 +20,15 @@ subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id, energy, size_energy) stop 'error' endif - rc = f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE) - if (rc /= N_int*2*N_det*bit_kind) then - print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)' + rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,ZMQ_SNDMORE) + if (rc8 /= N_int*2_8*N_det*bit_kind) then + print *, 'f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,ZMQ_SNDMORE)' stop 'error' endif - rc = f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE) - if (rc /= psi_det_size*N_states*8) then - print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)' + rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,ZMQ_SNDMORE) + if (rc8 /= psi_det_size*N_states*8_8) then + print *, 'f77_zmq_send8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,ZMQ_SNDMORE)' stop 'error' endif @@ -59,6 +60,7 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy) integer, intent(in) :: size_energy double precision, intent(out) :: energy(size_energy) integer :: rc + integer*8 :: rc8 character*(64) :: msg write(msg,*) 'get_psi ', worker_id @@ -78,27 +80,23 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy) integer :: N_states_read, N_det_read, psi_det_size_read integer :: N_det_selectors_read, N_det_generators_read - read(msg(14:rc),*) rc, N_states_read, N_det_read, psi_det_size_read, & + read(msg(14:rc),*) N_states_read, N_det_read, psi_det_size_read, & N_det_generators_read, N_det_selectors_read - if (rc /= worker_id) then - print *, 'Wrong worker ID' - stop 'error' - endif N_states = N_states_read N_det = N_det_read psi_det_size = psi_det_size_read TOUCH psi_det_size N_det N_states - rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,0) - if (rc /= N_int*2*N_det*bit_kind) then - print *, 'f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)' + rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_det,int(N_int*2_8*N_det*bit_kind,8),0) + if (rc8 /= N_int*2_8*N_det*bit_kind) then + print *, 'f77_zmq_recv8(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)' stop 'error' endif - rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,0) - if (rc /= psi_det_size*N_states*8) then - print *, '77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)' + rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_coef,int(psi_det_size*N_states*8_8,8),0) + if (rc8 /= psi_det_size*N_states*8_8) then + print *, '77_zmq_recv8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)' stop 'error' endif TOUCH psi_det psi_coef diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index cb229e36..9524716b 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -98,19 +98,18 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen integer :: mobiles(2), smallerlist logical, external :: detEq, is_generable !double precision, external :: get_dij, get_dij_index + double precision :: Delta_E_inv(N_states) + if (perturbative_triples) then + PROVIDE one_anhil fock_virt_total fock_core_inactive_total one_creat + endif leng = max(N_det_generators, N_det_non_ref) allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref), sij_cache(N_det_non_ref)) allocate(idx_alpha(0:psi_det_size), degree_alpha(psi_det_size)) - !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 - allocate(ptr_microlist(0:mo_tot_num*2+1), & N_microlist(0:mo_tot_num*2) ) allocate( microlist(Nint,2,N_minilist*4), & @@ -138,7 +137,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen if(N_minilist == 0) return - if(key_mask(1,1) /= 0) then !!!!!!!!!!! PAS GENERAL !!!!!!!!! + if(sum(abs(key_mask(1:N_int,1))) /= 0) then allocate(microlist_zero(Nint,2,N_minilist), idx_microlist_zero(N_minilist)) allocate( microlist(Nint,2,N_minilist*4), & @@ -191,14 +190,6 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen end do end if - if (perturbative_triples) then - double precision :: Delta_E_inv(N_states) - double precision, external :: diag_H_mat_elem - do i_state=1,N_states - Delta_E_inv(i_state) = 1.d0 / (psi_ref_energy_diagonalized(i_state) - diag_H_mat_elem(tq(1,1,i_alpha),N_int) ) - enddo - endif - do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd)) @@ -236,9 +227,6 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen enddo logical :: ok call apply_excitation(psi_ref(1,1,i_I), exc, tmp_det, ok, Nint) - if (perturbative_triples) then - ok = ok .and. ( (degree2 /= 1).and.(degree /=1) ) - endif do i_state=1,N_states dIK(i_state) = dij(i_I, idx_alpha(k_sd), i_state) @@ -262,11 +250,30 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen enddo else if (perturbative_triples) then + ! Linked - hka = hij_cache(idx_alpha(k_sd)) - do i_state=1,N_states - dka(i_state) = hka * Delta_E_inv(i_state) - enddo + hka = hij_cache(idx_alpha(k_sd)) + if (dabs(hka) > 1.d-12) then + call get_delta_e_dyall_general_mp(psi_ref(1,1,i_I),tq(1,1,i_alpha),Delta_E_inv) + + do i_state=1,N_states + ASSERT (Delta_E_inv(i_state) < 0.d0) + dka(i_state) = hka / Delta_E_inv(i_state) + enddo + endif + + endif + + if (perturbative_triples.and. (degree2 == 1) ) then + call i_h_j(psi_ref(1,1,i_I),tmp_det,Nint,hka) + hka = hij_cache(idx_alpha(k_sd)) - hka + if (dabs(hka) > 1.d-12) then + call get_delta_e_dyall_general_mp(psi_ref(1,1,i_I),tq(1,1,i_alpha),Delta_E_inv) + do i_state=1,N_states + ASSERT (Delta_E_inv(i_state) < 0.d0) + dka(i_state) = hka / Delta_E_inv(i_state) + enddo + endif endif diff --git a/plugins/mrcepa0/mrcepa0_general.irp.f b/plugins/mrcepa0/mrcepa0_general.irp.f index 1b2e2fcb..f2630520 100644 --- a/plugins/mrcepa0/mrcepa0_general.irp.f +++ b/plugins/mrcepa0/mrcepa0_general.irp.f @@ -47,6 +47,9 @@ subroutine run(N_st,energy) enddo call diagonalize_ci_dressed(lambda) E_new = sum(ci_energy_dressed(1:N_states)) +! if (.true.) then +! provide delta_ij_mrcc_pouet +! endif delta_E = (E_new - E_old)/dble(N_states) print *, '' call write_double(6,thresh_mrcc,"thresh_mrcc") diff --git a/plugins/read_integral/read_integrals_mo.irp.f b/plugins/read_integral/read_integrals_mo.irp.f index dc887c11..e1ff5fe8 100644 --- a/plugins/read_integral/read_integrals_mo.irp.f +++ b/plugins/read_integral/read_integrals_mo.irp.f @@ -1,4 +1,7 @@ program read_integrals + + PROVIDE ezfio_filename + call ezfio_set_integrals_monoelec_disk_access_mo_one_integrals("None") call run end @@ -18,9 +21,10 @@ subroutine run real(integral_kind), allocatable :: buffer_values(:) integer(key_kind) :: key - call ezfio_set_mo_basis_mo_tot_num(mo_tot_num) + call ezfio_get_mo_basis_mo_tot_num(mo_tot_num) allocate (A(mo_tot_num_align,mo_tot_num)) + A = 0.d0 iunit = getunitandopen('kinetic_mo','r') do @@ -41,6 +45,10 @@ subroutine run close(iunit) call write_one_e_integrals('mo_ne_integral', A, size(A,1), size(A,2)) + call write_one_e_integrals('mo_pseudo_integral', mo_pseudo_integral,& + size(mo_pseudo_integral,1), size(mo_pseudo_integral,2)) + + call ezfio_set_integrals_monoelec_disk_access_mo_one_integrals("Read") allocate(buffer_i(mo_tot_num**4), buffer_values(mo_tot_num**4)) @@ -56,7 +64,7 @@ subroutine run 13 continue close(iunit) - call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_values, 0.d0) + call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_values,0.d0) call map_sort(mo_integrals_map) diff --git a/scripts/ezfio_interface/ei_handler.py b/scripts/ezfio_interface/ei_handler.py index ef15c9b8..7fc77c38 100755 --- a/scripts/ezfio_interface/ei_handler.py +++ b/scripts/ezfio_interface/ei_handler.py @@ -183,6 +183,8 @@ def get_type_dict(): str_ocaml_type, str_fortran_type) + fancy_type["MO_class"] = Type("MO_class", "MO_class", "character*(32)") + # ~#~#~#~#~#~#~#~ # # F i n a l i z e # # ~#~#~#~#~#~#~#~ # diff --git a/scripts/ezfio_interface/qp_convert_output_to_ezfio.py b/scripts/ezfio_interface/qp_convert_output_to_ezfio.py index 6823df81..2a9bc087 100755 --- a/scripts/ezfio_interface/qp_convert_output_to_ezfio.py +++ b/scripts/ezfio_interface/qp_convert_output_to_ezfio.py @@ -3,7 +3,7 @@ convert output of gamess/GAU$$IAN to ezfio Usage: - qp_convert_output_to_ezfio.py [--ezfio=] + qp_convert_output_to_ezfio.py [--ezfio=] Option: file.out is the file to check (like gamess.out) @@ -20,18 +20,17 @@ from functools import reduce # Add to the path # # ~#~#~#~#~#~#~#~ # + try: QP_ROOT = os.environ["QP_ROOT"] except: print "Error: QP_ROOT environment variable not found." sys.exit(1) else: - sys.path = [ QP_ROOT + "/install/EZFIO/Python", QP_ROOT + "/resultsFile", QP_ROOT + "/scripts"] + sys.path - # ~#~#~#~#~#~ # # I m p o r t # # ~#~#~#~#~#~ # @@ -280,12 +279,13 @@ def write_ezfio(res, filename): # {% for coef,n,zeta for l_param} # {coef,n, zeta} + # OUTPUT # Local are 1 array padded by max(n_max_block) when l == 0 (output:k_loc_max) # v_k[n-2][atom] = value - #No Local are 2 array padded with max of lmax_block when l!=0 (output:lmax+1) and max(n_max_block)whem l !=0 (kmax) + #Non Local are 2 array padded with max of lmax_block when l!=0 (output:lmax+1) and max(n_max_block)whem l !=0 (kmax) # v_kl[l][n-2][atom] = value def pad(array, size, value=0): @@ -309,8 +309,16 @@ def write_ezfio(res, filename): array_l_max_block.append(l_max_block) array_z_remove.append(z_remove) - matrix.append([[coef_n_zeta.split()[1:] for coef_n_zeta in l.split('\n')] for l in array_party[1:]]) - + x = [[ filter(None,coef_n_zeta.split()) for coef_n_zeta in l.split('\n')] \ + for l in array_party[1:] ] +# x = [] +# for l in array_party[1:]: +# y = [] +# for coef_n_zeta in l.split('\n'): +# z = coef_n_zeta.split() +# if z : y.append(z) +# x.append(y) +# matrix.append(x) return (matrix, array_l_max_block, array_z_remove) def get_local_stuff(matrix): @@ -319,7 +327,6 @@ def write_ezfio(res, filename): k_loc_max = max(len(i) for i in matrix_local_unpad) matrix_local = [ pad(ll, k_loc_max, [0., 2, 0.]) for ll in matrix_local_unpad] - m_coef = [[float(i[0]) for i in atom] for atom in matrix_local] m_n = [[int(i[1]) - 2 for i in atom] for atom in matrix_local] m_zeta = [[float(i[2]) for i in atom] for atom in matrix_local] @@ -343,26 +350,42 @@ def write_ezfio(res, filename): return (l_max_block, k_max, m_coef_noloc, m_n_noloc, m_zeta_noloc) try: - pseudo_str = res_file.get_pseudo() + pseudo_str = [] + label = ezfio.get_nuclei_nucl_label() + for ecp in res.pseudo: + pseudo_str += [ "%(label)s GEN %(zcore)d %(lmax)d" % { "label": label[ ecp["atom"]-1 ], + "zcore": ecp["zcore"], "lmax": ecp["lmax"] } ] + lmax = ecp["lmax"] + for l in [lmax] + list(range(0,lmax)): + pseudo_str += [ "%d"%len(ecp[str(l)]) ] + for t in ecp[str(l)]: + pseudo_str += [ "%f %d %f"%t ] + pseudo_str += [""] + pseudo_str = "\n".join(pseudo_str) + matrix, array_l_max_block, array_z_remove = parse_str(pseudo_str) - + array_z_remove = map(float,array_z_remove) except: ezfio.set_pseudo_do_pseudo(False) else: ezfio.set_pseudo_do_pseudo(True) - + # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ # # Z _ e f f , a l p h a / b e t a _ e l e c # # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ # - ezfio.pseudo_charge_remove = array_z_remove - ezfio.nuclei_nucl_charge = [i - j for i, j in zip(ezfio.nuclei_nucl_charge, array_z_remove)] + ezfio.set_pseudo_nucl_charge_remove(array_z_remove) + charge = ezfio.get_nuclei_nucl_charge() + charge = [ i - j for i, j in zip(charge, array_z_remove) ] + ezfio.set_nuclei_nucl_charge (charge) import math - num_elec = sum(ezfio.nuclei_nucl_charge) + num_elec_diff = sum(array_z_remove)/2 + nalpha = ezfio.get_electrons_elec_alpha_num() - num_elec_diff + nbeta = ezfio.get_electrons_elec_beta_num() - num_elec_diff - ezfio.electrons_elec_alpha_num = int(math.ceil(num_elec / 2.)) - ezfio.electrons_elec_beta_num = int(math.floor(num_elec / 2.)) + ezfio.set_electrons_elec_alpha_num(nalpha) + ezfio.set_electrons_elec_beta_num( nbeta ) # Change all the array 'cause EZFIO # v_kl (v, l) => v_kl(l,v) @@ -421,3 +444,12 @@ if __name__ == '__main__': print file_, 'recognized as', str(res_file).split('.')[-1].split()[0] write_ezfio(res_file, ezfio_file) + if os.system("qp_run save_ortho_mos "+ezfio_file) != 0: + print """Warning: You need to run + + qp_run save_ortho_mos """+ezfio_file+""" + +to be sure your MOs will be orthogonal, which is not the case when +the MOs are read from output files (not enough precision in output).""" + + diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index 76386c7b..2b57545b 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -71,6 +71,7 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze, ! ----------------------- integer :: rc + integer*8 :: rc8 integer :: N_states_read, N_det_read, psi_det_size_read integer :: N_det_selectors_read, N_det_generators_read double precision :: energy(N_st) @@ -90,14 +91,9 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze, stop 'error' endif - read(msg(14:rc),*) rc, N_states_read, N_det_read, psi_det_size_read, & + read(msg(14:rc),*) N_states_read, N_det_read, psi_det_size_read, & N_det_generators_read, N_det_selectors_read - if (rc /= worker_id) then - print *, 'Wrong worker ID' - stop 'error' - endif - if (N_states_read /= N_st) then print *, N_st stop 'error : N_st' @@ -110,16 +106,16 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze, allocate(u_t(N_st,N_det_read)) - rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det_read*bit_kind,0) - if (rc /= N_int*2*N_det_read*bit_kind) then - print *, 'f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det_read*bit_kind,0)' + rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det_read*bit_kind,0) + if (rc8 /= N_int*2_8*N_det_read*bit_kind) then + print *, 'f77_zmq_recv8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det_read*bit_kind,0)' stop 'error' endif - rc = f77_zmq_recv(zmq_to_qp_run_socket,u_t,size(u_t)*8,0) - if (rc /= size(u_t)*8) then + rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,u_t,size(u_t)*8_8,0) + if (rc8 /= size(u_t)*8_8) then print *, rc, size(u_t)*8 - print *, 'f77_zmq_recv(zmq_to_qp_run_socket,u_t,size(u_t)*8,0)' + print *, 'f77_zmq_recv8(zmq_to_qp_run_socket,u_t,size(u_t)*8_8,0)' stop 'error' endif @@ -159,6 +155,7 @@ subroutine davidson_push_results(zmq_socket_push, v_t, s_t, imin, imax, task_id) double precision ,intent(in) :: v_t(N_states_diag,N_det) double precision ,intent(in) :: s_t(N_states_diag,N_det) integer :: rc, sz + integer*8 :: rc8 sz = (imax-imin+1)*N_states_diag @@ -171,11 +168,11 @@ subroutine davidson_push_results(zmq_socket_push, v_t, s_t, imin, imax, task_id) rc = f77_zmq_send( zmq_socket_push, imax, 4, ZMQ_SNDMORE) if(rc /= 4) stop "davidson_push_results failed to push imax" - rc = f77_zmq_send( zmq_socket_push, v_t(1,imin), 8*sz, ZMQ_SNDMORE) - if(rc /= 8*sz) stop "davidson_push_results failed to push vt" + rc8 = f77_zmq_send8( zmq_socket_push, v_t(1,imin), 8_8*sz, ZMQ_SNDMORE) + if(rc8 /= 8_8*sz) stop "davidson_push_results failed to push vt" - rc = f77_zmq_send( zmq_socket_push, s_t(1,imin), 8*sz, 0) - if(rc /= 8*sz) stop "davidson_push_results failed to push st" + rc8 = f77_zmq_send8( zmq_socket_push, s_t(1,imin), 8_8*sz, 0) + if(rc8 /= 8_8*sz) stop "davidson_push_results failed to push st" ! Activate is zmq_socket_push is a REQ IRP_IF ZMQ_PUSH @@ -202,6 +199,7 @@ subroutine davidson_pull_results(zmq_socket_pull, v_t, s_t, imin, imax, task_id) double precision ,intent(out) :: s_t(N_states_diag,N_det) integer :: rc, sz + integer*8 :: rc8 rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0) if(rc /= 4) stop "davidson_pull_results failed to pull task_id" @@ -214,11 +212,11 @@ subroutine davidson_pull_results(zmq_socket_pull, v_t, s_t, imin, imax, task_id) sz = (imax-imin+1)*N_states_diag - rc = f77_zmq_recv( zmq_socket_pull, v_t(1,imin), 8*sz, 0) - if(rc /= 8*sz) stop "davidson_pull_results failed to pull v_t" + rc8 = f77_zmq_recv8( zmq_socket_pull, v_t(1,imin), 8_8*sz, 0) + if(rc8 /= 8*sz) stop "davidson_pull_results failed to pull v_t" - rc = f77_zmq_recv( zmq_socket_pull, s_t(1,imin), 8*sz, 0) - if(rc /= 8*sz) stop "davidson_pull_results failed to pull s_t" + rc8 = f77_zmq_recv8( zmq_socket_pull, s_t(1,imin), 8_8*sz, 0) + if(rc8 /= 8*sz) stop "davidson_pull_results failed to pull s_t" ! Activate if zmq_socket_pull is a REP IRP_IF ZMQ_PUSH @@ -322,6 +320,7 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze) character*(512) :: task integer :: rc + integer*8 :: rc8 double precision :: energy(N_st) energy = 0.d0 @@ -329,25 +328,25 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze) write(task,*) 'put_psi ', 1, N_st, N_det, N_det rc = f77_zmq_send(zmq_to_qp_run_socket,trim(task),len(trim(task)),ZMQ_SNDMORE) if (rc /= len(trim(task))) then - print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(task),len(trim(task)),ZMQ_SNDMORE)' + print *, 'f77_zmq_send8(zmq_to_qp_run_socket,trim(task),len(trim(task)),ZMQ_SNDMORE)' stop 'error' endif - rc = f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE) - if (rc /= N_int*2*N_det*bit_kind) then - print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)' + rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,ZMQ_SNDMORE) + if (rc8 /= N_int*2_8*N_det*bit_kind) then + print *, 'f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)' stop 'error' endif - rc = f77_zmq_send(zmq_to_qp_run_socket,u_t,size(u_t)*8,ZMQ_SNDMORE) - if (rc /= size(u_t)*8) then - print *, 'f77_zmq_send(zmq_to_qp_run_socket,u_t,size(u_t)*8,ZMQ_SNDMORE)' + rc8 = f77_zmq_send8(zmq_to_qp_run_socket,u_t,size(u_t)*8_8,ZMQ_SNDMORE) + if (rc8 /= size(u_t)*8_8) then + print *, 'f77_zmq_send8(zmq_to_qp_run_socket,u_t,int(size(u_t)*8,8),ZMQ_SNDMORE)' stop 'error' endif rc = f77_zmq_send(zmq_to_qp_run_socket,energy,N_st*8,0) if (rc /= N_st*8) then - print *, 'f77_zmq_send(zmq_to_qp_run_socket,energy,size_energy*8,0)' + print *, 'f77_zmq_send8(zmq_to_qp_run_socket,energy,int(size_energy*8,8),0)' stop 'error' endif @@ -415,3 +414,18 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze) enddo end + +BEGIN_PROVIDER [ integer, nthreads_davidson ] + implicit none + BEGIN_DOC + ! Number of threads for Davdison + END_DOC + nthreads_davidson = nproc + character*(32) :: env + call getenv('NTHREADS_DAVIDSON',env) + if (trim(env) /= '') then + read(env,*) nthreads_davidson + endif + call write_int(6,nthreads_davidson,'Number of threads for Diagonalization') +END_PROVIDER + diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index ffd8b971..0a2d5389 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -139,7 +139,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ write(iunit,'(A)') trim(write_buffer) write_buffer = ' Iter' do i=1,N_st - write_buffer = trim(write_buffer)//' Energy S^2 Residual ' + write_buffer = trim(write_buffer)//' Energy S^2 Residual ' enddo write(iunit,'(A)') trim(write_buffer) write_buffer = '===== ' diff --git a/src/Davidson/diagonalize_CI.irp.f b/src/Davidson/diagonalize_CI.irp.f index 9b98ea91..f01cfb28 100644 --- a/src/Davidson/diagonalize_CI.irp.f +++ b/src/Davidson/diagonalize_CI.irp.f @@ -40,7 +40,7 @@ END_PROVIDER double precision, allocatable :: e_array(:) integer, allocatable :: iorder(:) - PROVIDE threshold_davidson + PROVIDE threshold_davidson nthreads_davidson ! Guess values for the "N_states" states of the CI_eigenvectors do j=1,min(N_states,N_det) do i=1,N_det diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 1fbf00e0..c67b1440 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -134,8 +134,8 @@ subroutine H_S2_u_0_nstates_openmp_work_$N_int(v_t,s_t,u_t,N_st,sze,istart,iend, ! Prepare the array of all alpha single excitations ! ------------------------------------------------- - PROVIDE N_int - !$OMP PARALLEL DEFAULT(NONE) & + PROVIDE N_int nthreads_davidson + !$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) & !$OMP SHARED(psi_bilinear_matrix_rows, N_det, & !$OMP psi_bilinear_matrix_columns, & !$OMP psi_det_alpha_unique, psi_det_beta_unique, & diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index 442d0d84..26f981dc 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -76,7 +76,8 @@ subroutine resize_H_apply_buffer(new_size,iproc) allocate ( buffer_det(N_int,2,new_size), & buffer_coef(new_size,N_states), & buffer_e2(new_size,N_states) ) - + buffer_coef = 0.d0 + buffer_e2 = 0.d0 do i=1,min(new_size,H_apply_buffer(iproc)%N_det) do k=1,N_int buffer_det(k,1,i) = H_apply_buffer(iproc)%det(k,1,i) diff --git a/src/Determinants/density_matrix.irp.f b/src/Determinants/density_matrix.irp.f index e4e94b7f..e0764d96 100644 --- a/src/Determinants/density_matrix.irp.f +++ b/src/Determinants/density_matrix.irp.f @@ -15,6 +15,57 @@ enddo END_PROVIDER + BEGIN_PROVIDER [ double precision, one_body_dm_mo_spin_index, (mo_tot_num_align,mo_tot_num,N_states,2) ] + implicit none + integer :: i,j,ispin,istate + ispin = 1 + do istate = 1, N_states + do j = 1, mo_tot_num + do i = 1, mo_tot_num + one_body_dm_mo_spin_index(i,j,istate,ispin) = one_body_dm_mo_alpha(i,j,istate) + enddo + enddo + enddo + + ispin = 2 + do istate = 1, N_states + do j = 1, mo_tot_num + do i = 1, mo_tot_num + one_body_dm_mo_spin_index(i,j,istate,ispin) = one_body_dm_mo_beta(i,j,istate) + enddo + enddo + enddo + + END_PROVIDER + + + BEGIN_PROVIDER [ double precision, one_body_dm_dagger_mo_spin_index, (mo_tot_num_align,mo_tot_num,N_states,2) ] + implicit none + integer :: i,j,ispin,istate + ispin = 1 + do istate = 1, N_states + do j = 1, mo_tot_num + one_body_dm_dagger_mo_spin_index(j,j,istate,ispin) = 1 - one_body_dm_mo_alpha(j,j,istate) + do i = j+1, mo_tot_num + one_body_dm_dagger_mo_spin_index(i,j,istate,ispin) = -one_body_dm_mo_alpha(i,j,istate) + one_body_dm_dagger_mo_spin_index(j,i,istate,ispin) = -one_body_dm_mo_alpha(i,j,istate) + enddo + enddo + enddo + + ispin = 2 + do istate = 1, N_states + do j = 1, mo_tot_num + one_body_dm_dagger_mo_spin_index(j,j,istate,ispin) = 1 - one_body_dm_mo_beta(j,j,istate) + do i = j+1, mo_tot_num + one_body_dm_dagger_mo_spin_index(i,j,istate,ispin) = -one_body_dm_mo_beta(i,j,istate) + one_body_dm_dagger_mo_spin_index(j,i,istate,ispin) = -one_body_dm_mo_beta(i,j,istate) + enddo + enddo + enddo + + END_PROVIDER + BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha, (mo_tot_num_align,mo_tot_num,N_states) ] &BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta, (mo_tot_num_align,mo_tot_num,N_states) ] implicit none @@ -285,6 +336,8 @@ END_PROVIDER BEGIN_PROVIDER [ double precision, one_body_dm_ao_alpha, (ao_num_align,ao_num) ] &BEGIN_PROVIDER [ double precision, one_body_dm_ao_beta, (ao_num_align,ao_num) ] +&BEGIN_PROVIDER [ double precision, one_body_dm_ao_alpha_no_align, (ao_num,ao_num) ] +&BEGIN_PROVIDER [ double precision, one_body_dm_ao_beta_no_align, (ao_num,ao_num) ] BEGIN_DOC ! one body density matrix on the AO basis : rho_AO(alpha) , rho_AO(beta) END_DOC @@ -303,11 +356,16 @@ END_PROVIDER ! if(dabs(dm_mo).le.1.d-10)cycle one_body_dm_ao_alpha(l,k) += mo_coef(k,i) * mo_coef(l,j) * mo_alpha one_body_dm_ao_beta(l,k) += mo_coef(k,i) * mo_coef(l,j) * mo_beta - enddo enddo enddo enddo + do i = 1, ao_num + do j = 1, ao_num + one_body_dm_ao_alpha_no_align(j,i) = one_body_dm_ao_alpha(j,i) + one_body_dm_ao_beta_no_align(j,i) = one_body_dm_ao_beta(j,i) + enddo + enddo END_PROVIDER diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 110d9014..51572462 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -1977,7 +1977,7 @@ subroutine ac_operator(iorb,ispin,key,hjj,Nint,na,nb) !DIR$ FORCEINLINE call bitstring_to_list_ab(key, occ, tmp, Nint) ASSERT (tmp(1) == elec_alpha_num) - ASSERT (tmp(2) == elec_alpha_num) + ASSERT (tmp(2) == elec_beta_num) k = ishft(iorb-1,-bit_kind_shift)+1 ASSERT (k >0) diff --git a/src/Integrals_Bielec/map_integrals.irp.f b/src/Integrals_Bielec/map_integrals.irp.f index 82b89f22..190615c3 100644 --- a/src/Integrals_Bielec/map_integrals.irp.f +++ b/src/Integrals_Bielec/map_integrals.irp.f @@ -294,7 +294,7 @@ BEGIN_PROVIDER [ type(map_type), mo_integrals_map ] call bielec_integrals_index(mo_tot_num,mo_tot_num,mo_tot_num,mo_tot_num,key_max) sze = key_max call map_init(mo_integrals_map,sze) - print*, 'MO map initialized' + print*, 'MO map initialized: ', sze END_PROVIDER subroutine insert_into_ao_integrals_map(n_integrals,buffer_i, buffer_values) diff --git a/src/MOGuess/mo_ortho_lowdin.irp.f b/src/MOGuess/mo_ortho_lowdin.irp.f index 90672b5e..519e4f0d 100644 --- a/src/MOGuess/mo_ortho_lowdin.irp.f +++ b/src/MOGuess/mo_ortho_lowdin.irp.f @@ -6,7 +6,9 @@ BEGIN_PROVIDER [double precision, ao_ortho_lowdin_coef, (ao_num_align,ao_num)] ! ao_ortho_lowdin_coef(i,j) = coefficient of the ith ao on the jth ao_ortho_lowdin orbital END_DOC integer :: i,j,k,l - double precision :: tmp_matrix(ao_num_align,ao_num),accu + double precision :: accu + double precision, allocatable :: tmp_matrix(:,:) + allocate (tmp_matrix(ao_num_align,ao_num)) tmp_matrix(:,:) = 0.d0 do j=1, ao_num tmp_matrix(j,j) = 1.d0 @@ -17,6 +19,7 @@ BEGIN_PROVIDER [double precision, ao_ortho_lowdin_coef, (ao_num_align,ao_num)] ao_ortho_lowdin_coef(j,i) = tmp_matrix(i,j) enddo enddo + deallocate(tmp_matrix) END_PROVIDER BEGIN_PROVIDER [double precision, ao_ortho_lowdin_overlap, (ao_num_align,ao_num)] diff --git a/src/MO_Basis/EZFIO.cfg b/src/MO_Basis/EZFIO.cfg index 368b70a0..b95148eb 100644 --- a/src/MO_Basis/EZFIO.cfg +++ b/src/MO_Basis/EZFIO.cfg @@ -21,8 +21,8 @@ interface: ezfio size: (mo_basis.mo_tot_num) [mo_class] -type: character*(32) -doc: c: core, i: inactive, a: active, v: virtual, d: deleted +type: MO_class +doc: Core|Inactive|Active|Virtual|Deleted interface: ezfio, provider size: (mo_basis.mo_tot_num) diff --git a/src/MO_Basis/ao_ortho_canonical.irp.f b/src/MO_Basis/ao_ortho_canonical.irp.f index 48341129..b0eabfbd 100644 --- a/src/MO_Basis/ao_ortho_canonical.irp.f +++ b/src/MO_Basis/ao_ortho_canonical.irp.f @@ -82,6 +82,15 @@ END_PROVIDER +BEGIN_PROVIDER [ double precision, ao_ortho_canonical_coef_inv, (ao_num,ao_num)] + implicit none + BEGIN_DOC +! ao_ortho_canonical_coef^(-1) + END_DOC + call get_pseudo_inverse(ao_ortho_canonical_coef,ao_num,ao_num, & + ao_ortho_canonical_coef_inv, size(ao_ortho_canonical_coef,1)) +END_PROVIDER + BEGIN_PROVIDER [ double precision, ao_ortho_canonical_coef, (ao_num_align,ao_num)] &BEGIN_PROVIDER [ integer, ao_ortho_canonical_num ] implicit none diff --git a/src/MO_Basis/mos.irp.f b/src/MO_Basis/mos.irp.f index 19835395..260af392 100644 --- a/src/MO_Basis/mos.irp.f +++ b/src/MO_Basis/mos.irp.f @@ -68,6 +68,18 @@ END_PROVIDER endif END_PROVIDER +BEGIN_PROVIDER [ double precision, mo_coef_in_ao_ortho_basis, (ao_num_align, mo_tot_num) ] + implicit none + BEGIN_DOC + ! MO coefficients in orthogonalized AO basis + END_DOC + call dgemm('T','N',ao_num,mo_tot_num,ao_num,1.d0, & + ao_ortho_canonical_coef_inv, size(ao_ortho_canonical_coef_inv,1),& + mo_coef, size(mo_coef,1), 0.d0, & + mo_coef_in_ao_ortho_basis, size(mo_coef_in_ao_ortho_basis,1)) + +END_PROVIDER + BEGIN_PROVIDER [ character*(64), mo_label ] implicit none BEGIN_DOC @@ -139,8 +151,6 @@ BEGIN_PROVIDER [ double precision, mo_occ, (mo_tot_num) ] endif END_PROVIDER - - subroutine ao_to_mo(A_ao,LDA_ao,A_mo,LDA_mo) implicit none BEGIN_DOC @@ -259,3 +269,62 @@ subroutine mix_mo_jk(j,k) end +subroutine ao_ortho_cano_to_ao(A_ao,LDA_ao,A,LDA) + implicit none + BEGIN_DOC + ! Transform A from the AO basis to the orthogonal AO basis + END_DOC + integer, intent(in) :: LDA_ao,LDA + double precision, intent(in) :: A_ao(LDA_ao,*) + double precision, intent(out) :: A(LDA,*) + double precision, allocatable :: T(:,:) + + allocate ( T(ao_num_align,ao_num) ) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T + + call dgemm('T','N', ao_num, ao_num, ao_num, & + 1.d0, & + ao_ortho_canonical_coef_inv, size(ao_ortho_canonical_coef_inv,1), & + A_ao,LDA_ao, & + 0.d0, T, ao_num_align) + + call dgemm('N','N', ao_num, ao_num, ao_num, 1.d0, & + T, size(T,1), & + ao_ortho_canonical_coef_inv,size(ao_ortho_canonical_coef_inv,1),& + 0.d0, A, LDA) + + deallocate(T) +end + +subroutine mo_to_ao_ortho_cano(A_mo,LDA_mo,A_ao,LDA_ao) + implicit none + BEGIN_DOC + ! Transform A from the AO orthogonal basis to the AO basis + END_DOC + integer, intent(in) :: LDA_ao,LDA_mo + double precision, intent(in) :: A_mo(LDA_mo) + double precision, intent(out) :: A_ao(LDA_ao) + double precision, allocatable :: T(:,:), SC(:,:) + + allocate ( SC(ao_num_align,mo_tot_num) ) + allocate ( T(mo_tot_num_align,ao_num) ) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T + + call dgemm('N','N', ao_num, mo_tot_num, ao_num, & + 1.d0, ao_overlap,size(ao_overlap,1), & + ao_ortho_canonical_coef, size(ao_ortho_canonical_coef,1), & + 0.d0, SC, ao_num_align) + + call dgemm('N','T', mo_tot_num, ao_num, mo_tot_num, & + 1.d0, A_mo,LDA_mo, & + SC, size(SC,1), & + 0.d0, T, mo_tot_num_align) + + call dgemm('N','N', ao_num, ao_num, mo_tot_num, & + 1.d0, SC,size(SC,1), & + T, mo_tot_num_align, & + 0.d0, A_ao, LDA_ao) + + deallocate(T,SC) +end + diff --git a/src/Utils/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index 9f94bb62..92bcdf53 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -72,6 +72,8 @@ subroutine ortho_canonical(overlap,LDA,N,C,LDC,m) double precision, allocatable :: S_half(:,:) !DEC$ ATTRIBUTES ALIGN : 64 :: U, Vt, D integer :: info, i, j +!call ortho_lowdin(overlap,LDA,N,C,LDC,m) +!return if (n < 2) then return @@ -200,7 +202,7 @@ subroutine ortho_lowdin(overlap,LDA,N,C,LDC,m) ! ! LDC : leftmost dimension of C ! - ! m : Coefficients matrix is MxN, ( array is (LDC,N) ) + ! M : Coefficients matrix is MxN, ( array is (LDC,N) ) ! END_DOC @@ -211,7 +213,6 @@ subroutine ortho_lowdin(overlap,LDA,N,C,LDC,m) double precision, allocatable :: Vt(:,:) double precision, allocatable :: D(:) double precision, allocatable :: S_half(:,:) - !DEC$ ATTRIBUTES ALIGN : 64 :: U, Vt, D integer :: info, i, j, k if (n < 2) then @@ -298,12 +299,12 @@ subroutine get_pseudo_inverse(A,m,n,C,LDA) allocate(work(lwork)) call dgesvd('S','A', m, n, A_tmp, m,D,U,m,Vt,n,work,lwork,info) if (info /= 0) then - print *, info, ': SVD failed' + print *, info, ':: SVD failed' stop 1 endif do i=1,n - if (abs(D(i)) > 1.d-6) then + if (dabs(D(i)) > 1.d-6) then D(i) = 1.d0/D(i) else D(i) = 0.d0 diff --git a/tests/bats/pseudo.bats b/tests/bats/pseudo.bats index 4b374d76..ea043851 100644 --- a/tests/bats/pseudo.bats +++ b/tests/bats/pseudo.bats @@ -14,7 +14,7 @@ function run_HF() { test_exe SCF || skip qp_edit -c $1 ezfio set_file $1 - ezfio set hartree_fock thresh_scf 1.e-11 + ezfio set hartree_fock thresh_scf 1.e-8 qp_run SCF $1 energy="$(ezfio get hartree_fock energy)" eq $energy $2 $thresh