mirror of
https://github.com/LCPQ/quantum_package
synced 2024-08-25 14:01:46 +02:00
Merge pull request #201 from scemama/master
DIIS in HF + Fixed FCI bugs (correlation_ratio)
This commit is contained in:
commit
73de13320b
@ -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 -
|
||||
|
@ -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
|
||||
################
|
||||
|
63
config/ifort_mpi.cfg
Normal file
63
config/ifort_mpi.cfg
Normal file
@ -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
|
||||
|
21
configure
vendored
21
configure
vendored
@ -2,7 +2,7 @@
|
||||
# -*- coding: utf-8 -*-
|
||||
"""configure
|
||||
|
||||
Usage: configure <config_file> (--production | --development)
|
||||
Usage: configure <config_file>
|
||||
|
||||
|
||||
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:
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
457
ocaml/Gamess.ml
Normal file
457
ocaml/Gamess.ml
Normal file
@ -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
|
||||
|
||||
|
@ -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}
|
||||
;;
|
12
ocaml/Gto.ml
12
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 =
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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<elec_beta_num) then 2.
|
||||
else if (i < elec_alpha_num) then 1.
|
||||
else 0.) |> Array.to_list in
|
||||
if (i<elec_beta_num) then 2.
|
||||
else if (i < elec_alpha_num) then 1.
|
||||
else 0.) |> 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
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
@ -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;
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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 ()
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
1
plugins/Full_CI_ZMQ_MPI/NEEDED_CHILDREN_MODULES
Normal file
1
plugins/Full_CI_ZMQ_MPI/NEEDED_CHILDREN_MODULES
Normal file
@ -0,0 +1 @@
|
||||
Full_CI_ZMQ MPI
|
14
plugins/Full_CI_ZMQ_MPI/README.rst
Normal file
14
plugins/Full_CI_ZMQ_MPI/README.rst
Normal file
@ -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.
|
101
plugins/Full_CI_ZMQ_MPI/selection_davidson_slave_mpi.irp.f
Normal file
101
plugins/Full_CI_ZMQ_MPI/selection_davidson_slave_mpi.irp.f
Normal file
@ -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
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
196
plugins/Hartree_Fock/DIIS.irp.f
Normal file
196
plugins/Hartree_Fock/DIIS.irp.f
Normal file
@ -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
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
283
plugins/Hartree_Fock/Roothaan_Hall_SCF.irp.f
Normal file
283
plugins/Hartree_Fock/Roothaan_Hall_SCF.irp.f
Normal file
@ -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
|
@ -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
|
||||
|
||||
|
||||
|
@ -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,*)
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
14
plugins/Hartree_Fock_SlaterDressed/EZFIO.cfg
Normal file
14
plugins/Hartree_Fock_SlaterDressed/EZFIO.cfg
Normal file
@ -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
|
||||
|
||||
|
||||
|
53
plugins/Hartree_Fock_SlaterDressed/LinearSystem.irp.f
Normal file
53
plugins/Hartree_Fock_SlaterDressed/LinearSystem.irp.f
Normal file
@ -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
|
||||
|
98
plugins/Hartree_Fock_SlaterDressed/SCF_dressed.irp.f
Normal file
98
plugins/Hartree_Fock_SlaterDressed/SCF_dressed.irp.f
Normal file
@ -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
|
||||
|
||||
|
66
plugins/Hartree_Fock_SlaterDressed/at_nucl.irp.f
Normal file
66
plugins/Hartree_Fock_SlaterDressed/at_nucl.irp.f
Normal file
@ -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
|
||||
|
624
plugins/Hartree_Fock_SlaterDressed/integrals.irp.f
Normal file
624
plugins/Hartree_Fock_SlaterDressed/integrals.irp.f
Normal file
@ -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
|
||||
! <Gaussian | Slater> 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
|
||||
! <MO | Slater>
|
||||
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
|
||||
! <AO_ortho | Slater>
|
||||
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
|
||||
! <Gaussian | Slater> 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
|
||||
! <MO | Slater>
|
||||
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
|
||||
! <AO ortho | Slater>
|
||||
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
|
||||
|
43
plugins/Hartree_Fock_SlaterDressed/slater.irp.f
Normal file
43
plugins/Hartree_Fock_SlaterDressed/slater.irp.f
Normal file
@ -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
|
||||
|
@ -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)
|
||||
|
1
plugins/MPI/NEEDED_CHILDREN_MODULES
Normal file
1
plugins/MPI/NEEDED_CHILDREN_MODULES
Normal file
@ -0,0 +1 @@
|
||||
|
14
plugins/MPI/README.rst
Normal file
14
plugins/MPI/README.rst
Normal file
@ -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.
|
46
plugins/MPI/bcast.irp.f
Normal file
46
plugins/MPI/bcast.irp.f
Normal file
@ -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
|
||||
|
68
plugins/MPI/utils.irp.f
Normal file
68
plugins/MPI/utils.irp.f
Normal file
@ -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
|
||||
|
@ -1 +1 @@
|
||||
MRPT_Utils Selectors_full Generators_full
|
||||
MRPT_Utils Selectors_full Generators_full
|
||||
|
@ -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
|
||||
|
@ -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<uQWmmvd, -.-:=!'
|
||||
print *, ' "{Z jC]QW|=3Zv)Bi3BmXv3 = _7'
|
||||
print *, ' ]h[Z6)WQ;)jZs]C;|$BZv+, : ./ '
|
||||
print *, ' -#sJX%$Wmm#ev]hinW#Xi:` c ; '
|
||||
print *, ' #X#X23###1}vI$WWmX1>|,)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#><iiii|i||||==vn2( '
|
||||
print *, ' ]Z#i<ii||+|=||=:{no2[ '
|
||||
print *, ' ]ZUsiiiiivi|=||=vo22[ '
|
||||
print *, ' ]XZvlliiIi|i=|+|vooo '
|
||||
print *, ' =v1llli||||=|||||lii( '
|
||||
print *, ' ]iillii||||||||=>=|< '
|
||||
print *, ' -ziiiii||||||+||==+> '
|
||||
print *, ' -%|+++||=|=+|=|==/ '
|
||||
print *, ' -a>====+|====-:- '
|
||||
print *, ' "~,- -- /- '
|
||||
print *, ' -. )> '
|
||||
print *, ' .~ +- '
|
||||
print *, ' . .... : . '
|
||||
print *, ' -------~ '
|
||||
print *, ''
|
||||
end
|
@ -1 +1 @@
|
||||
Determinants Davidson
|
||||
Determinants Davidson Psiref_CAS
|
||||
|
193
plugins/MRPT_Utils/density_matrix_based.irp.f
Normal file
193
plugins/MRPT_Utils/density_matrix_based.irp.f
Normal file
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | a_{b} a^{\dagger}_a | Idet>
|
||||
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)
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | a^{\dagger}_b a_{a} | Idet>
|
||||
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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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)
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | K_{ab} | Idet>
|
||||
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)
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | a_{b} a^{\dagger}_a | Idet>
|
||||
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
|
||||
|
@ -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)
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | K_{ab} | Idet>
|
||||
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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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")
|
||||
|
@ -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)
|
||||
|
||||
|
@ -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 #
|
||||
# ~#~#~#~#~#~#~#~ #
|
||||
|
@ -3,7 +3,7 @@
|
||||
convert output of gamess/GAU$$IAN to ezfio
|
||||
|
||||
Usage:
|
||||
qp_convert_output_to_ezfio.py <file.out> [--ezfio=<folder.ezfio>]
|
||||
qp_convert_output_to_ezfio.py <file.out> [--ezfio=<ezfio_directory>]
|
||||
|
||||
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)."""
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
@ -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 = '===== '
|
||||
|
@ -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
|
||||
|
@ -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, &
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
||||
|
@ -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)
|
||||
|
@ -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)
|
||||
|
@ -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)]
|
||||
|
@ -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)
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user