LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-12-21 11:03:29 +01:00
Code Releases Activity

Merge pull request #285 from AbdAmmar/dev-stable-tc-scf
Some checks failed
continuous-integration/drone/push Build is failing
Details

Browse Source 
Dev stable tc scf
This commit is contained in:
AbdAmmar 2023-05-19 11:37:55 +02:00 committed by GitHub
commit 15dcd3d18f
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
169 changed files with 32611 additions and 1704 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.github/workflows/compilation.yml vendored
View File

@ -48,6 +48,7 @@ jobs:
./configure -i docopt || :
./configure -i resultsFile || :
./configure -i bats || :
./configure -i trexio-nohdf5 || :
./configure -c ./config/gfortran_debug.cfg
- name: Compilation
run: |

8
.github/workflows/configuration.yml vendored
View File

@ -22,7 +22,7 @@ jobs:
- uses: actions/checkout@v3
- name: Install dependencies
run: |
sudo apt install gfortran gcc liblapack-dev libblas-dev wget python3 make m4 pkg-config
sudo apt install gfortran gcc liblapack-dev libblas-dev wget python3 make m4 pkg-config hdf5
- name: zlib
run: |
./configure -i zlib || echo OK
@ -50,6 +50,12 @@ jobs:
- name: bats
run: |
./configure -i bats || echo OK
- name: trexio-nohdf5
run: |
./configure -i trexio-nohdf5 || echo OK
- name: trexio
run: |
./configure -i trexio || echo OK
- name: Final check
run: |
./configure -c config/gfortran_debug.cfg

3
bin/qp_test
View File

@ -46,7 +46,7 @@ def main(arguments):
append_bats(dirname, filenames)
else:
for (dirname, _, filenames) in os.walk(os.getcwd(), followlinks=False):
if "IRPF90_temp" not in dirname:
if "IRPF90_temp" not in dirname and "external" not in dirname:
append_bats(dirname, filenames)
l_bats = [y for _, y in sorted(l_bats)]
@ -67,6 +67,7 @@ def main(arguments):
os.system(test+" python3 bats_to_sh.py "+bats_file+
"| bash")
else:
# print(" ".join(["bats", "--verbose-run", "--trace", bats_file]))
subprocess.check_call(["bats", "--verbose-run", "--trace", bats_file], env=os.environ)

37
configure vendored
View File

@ -9,6 +9,8 @@ echo "QP_ROOT="$QP_ROOT
unset CC
unset CCXX
TREXIO_VERSION=2.3.2
# Force GCC instead of ICC for dependencies
export CC=gcc
@ -189,7 +191,7 @@ if [[ "${PACKAGES}.x" != ".x" ]] ; then
fi
if [[ ${PACKAGES} = all ]] ; then
PACKAGES="zlib ninja zeromq f77zmq gmp ocaml docopt resultsFile bats"
PACKAGES="zlib ninja zeromq f77zmq gmp ocaml docopt resultsFile bats trexio"
fi
@ -203,6 +205,33 @@ for PACKAGE in ${PACKAGES} ; do
mv ninja "\${QP_ROOT}"/bin/
EOF
elif [[ ${PACKAGE} = trexio-nohdf5 ]] ; then
VERSION=$TREXIO_VERSION
execute << EOF
cd "\${QP_ROOT}"/external
wget https://github.com/TREX-CoE/trexio/releases/download/v${VERSION}/trexio-${VERSION}.tar.gz
tar -zxf trexio-${VERSION}.tar.gz
cd trexio-${VERSION}
./configure --prefix=\${QP_ROOT} --without-hdf5
make -j 8 && make -j 8 check && make -j 8 install
cp ${QP_ROOT}/include/trexio_f.f90 ${QP_ROOT}/src/ezfio_files
tar -zxvf "\${QP_ROOT}"/external/qp2-dependencies/${ARCHITECTURE}/ninja.tar.gz
mv ninja "\${QP_ROOT}"/bin/
EOF
elif [[ ${PACKAGE} = trexio ]] ; then
VERSION=$TREXIO_VERSION
execute << EOF
cd "\${QP_ROOT}"/external
wget https://github.com/TREX-CoE/trexio/releases/download/v${VERSION}/trexio-${VERSION}.tar.gz
tar -zxf trexio-${VERSION}.tar.gz
cd trexio-${VERSION}
./configure --prefix=\${QP_ROOT}
make -j 8 && make -j 8 check && make -j 8 install
cp ${QP_ROOT}/include/trexio_f.f90 ${QP_ROOT}/src/ezfio_files
EOF
elif [[ ${PACKAGE} = gmp ]] ; then
@ -338,6 +367,12 @@ if [[ ${ZEROMQ} = $(not_found) ]] ; then
fail
fi
TREXIO=$(find_lib -ltrexio)
if [[ ${TREXIO} = $(not_found) ]] ; then
error "TREXIO (trexio,trexio-nohdf5) is not installed. If you don't have HDF5, use trexio-nohdf5"
fail
fi
F77ZMQ=$(find_lib -lzmq -lf77zmq -lpthread)
if [[ ${F77ZMQ} = $(not_found) ]] ; then
error "Fortran binding of ZeroMQ (f77zmq) is not installed."

5
data/basis/none Normal file
View File

@ -0,0 +1,5 @@
$DATA
HYDROGEN
$END

12
etc/qp.rc
View File

@ -110,6 +110,11 @@ function qp()
unset COMMAND
;;
"test")
shift
qp_test $@
;;
*)
which "qp_$1" &> /dev/null
if [[ $? -eq 0 ]] ; then
@ -183,7 +188,7 @@ _qp_Complete()
;;
esac;;
set_file)
COMPREPLY=( $(compgen -W "$(for i in * ; do [[ -f ${i}/ezfio/.version ]] && echo $i ; done)" -- ${cur} ) )
COMPREPLY=( $(compgen -W "$(for i in */ $(find . -name ezfio | sed 's/ezfio$/.version/') ; do [[ -f $i ]] && echo ${i%/.version} ; done)" -- ${cur} ) )
return 0
;;
plugins)
@ -215,10 +220,15 @@ _qp_Complete()
return 0
;;
esac;;
test)
COMPREPLY=( $(compgen -W "-v -a " -- $cur ) )
return 0
;;
*)
COMPREPLY=( $(compgen -W 'plugins set_file \
unset_file man \
create_ezfio \
test \
convert_output_to_ezfio \
-h update' -- $cur ) )

8
ocaml/Input_ao_basis.ml
View File

@ -247,8 +247,7 @@ end = struct
let read () =
if (Ezfio.has_ao_basis_ao_basis ()) then
begin
try
let result =
{ ao_basis = read_ao_basis ();
ao_num = read_ao_num () ;
@ -267,9 +266,8 @@ end = struct
|> MD5.to_string
|> Ezfio.set_ao_basis_ao_md5 ;
Some result
end
else
None
with
| _ -> (Ezfio.set_ao_basis_ao_md5 "None" ; None)
;;

262
ocaml/qp_create_ezfio.ml
View File

@ -478,6 +478,7 @@ let run ?o b au c d m p cart xyz_file =
let nmax =
Nucl_number.get_max ()
in
let rec do_work (accu:(Atom.t*Nucl_number.t) list) (n:int) = function
| [] -> accu
| e::tail ->
@ -520,141 +521,144 @@ let run ?o b au c d m p cart xyz_file =
in
let long_basis = Long_basis.of_basis basis in
let ao_num = List.length long_basis in
Ezfio.set_ao_basis_ao_num ao_num;
Ezfio.set_ao_basis_ao_basis b;
Ezfio.set_basis_basis b;
let ao_prim_num = list_map (fun (_,g,_) -> List.length g.Gto.lc) long_basis
and ao_nucl = list_map (fun (_,_,n) -> Nucl_number.to_int n) long_basis
and ao_power=
let l = list_map (fun (x,_,_) -> x) long_basis in
(list_map (fun t -> Positive_int.to_int Angmom.Xyz.(t.x)) l)@
(list_map (fun t -> Positive_int.to_int Angmom.Xyz.(t.y)) l)@
(list_map (fun t -> Positive_int.to_int Angmom.Xyz.(t.z)) l)
in
let ao_prim_num_max = List.fold_left (fun s x ->
if x > s then x
else s) 0 ao_prim_num
in
let gtos =
list_map (fun (_,x,_) -> x) long_basis
in
let create_expo_coef ec =
let coefs =
begin match ec with
| `Coefs -> list_map (fun x->
list_map (fun (_,coef) ->
AO_coef.to_float coef) x.Gto.lc) gtos
| `Expos -> list_map (fun x->
list_map (fun (prim,_) -> AO_expo.to_float
prim.GaussianPrimitive.expo) x.Gto.lc) gtos
end
if ao_num > 0 then
begin
Ezfio.set_ao_basis_ao_num ao_num;
Ezfio.set_ao_basis_ao_basis b;
Ezfio.set_basis_basis b;
let ao_prim_num = list_map (fun (_,g,_) -> List.length g.Gto.lc) long_basis
and ao_nucl = list_map (fun (_,_,n) -> Nucl_number.to_int n) long_basis
and ao_power=
let l = list_map (fun (x,_,_) -> x) long_basis in
(list_map (fun t -> Positive_int.to_int Angmom.Xyz.(t.x)) l)@
(list_map (fun t -> Positive_int.to_int Angmom.Xyz.(t.y)) l)@
(list_map (fun t -> Positive_int.to_int Angmom.Xyz.(t.z)) l)
in
let rec get_n n accu = function
| [] -> List.rev accu
| h::tail ->
let y =
begin match List.nth_opt h n with
| Some x -> x
| None -> 0.
let ao_prim_num_max = List.fold_left (fun s x ->
if x > s then x
else s) 0 ao_prim_num
in
let gtos =
list_map (fun (_,x,_) -> x) long_basis
in
let create_expo_coef ec =
let coefs =
begin match ec with
| `Coefs -> list_map (fun x->
list_map (fun (_,coef) ->
AO_coef.to_float coef) x.Gto.lc) gtos
| `Expos -> list_map (fun x->
list_map (fun (prim,_) -> AO_expo.to_float
prim.GaussianPrimitive.expo) x.Gto.lc) gtos
end
in
get_n n (y::accu) tail
in
let rec get_n n accu = function
| [] -> List.rev accu
| h::tail ->
let y =
begin match List.nth_opt h n with
| Some x -> x
| None -> 0.
end
in
get_n n (y::accu) tail
in
let rec build accu = function
| n when n=ao_prim_num_max -> accu
| n -> build ( accu @ (get_n n [] coefs) ) (n+1)
in
build [] 0
in
let rec build accu = function
| n when n=ao_prim_num_max -> accu
| n -> build ( accu @ (get_n n [] coefs) ) (n+1)
in
build [] 0
in
let ao_coef = create_expo_coef `Coefs
and ao_expo = create_expo_coef `Expos
in
let () =
let shell_num = List.length basis in
let lc : (GaussianPrimitive.t * Qptypes.AO_coef.t) list list =
list_map ( fun (g,_) -> g.Gto.lc ) basis
in
let ang_mom =
list_map (fun (l : (GaussianPrimitive.t * Qptypes.AO_coef.t) list) ->
let x, _ = List.hd l in
Angmom.to_l x.GaussianPrimitive.sym |> Qptypes.Positive_int.to_int
) lc
in
let expo =
list_map (fun l -> list_map (fun (x,_) -> Qptypes.AO_expo.to_float x.GaussianPrimitive.expo) l ) lc
|> List.concat
in
let coef =
list_map (fun l ->
list_map (fun (_,x) -> Qptypes.AO_coef.to_float x) l
) lc
|> List.concat
in
let shell_prim_num =
list_map List.length lc
in
let shell_idx =
let rec make_list n accu = function
| 0 -> accu
| i -> make_list n (n :: accu) (i-1)
let ao_coef = create_expo_coef `Coefs
and ao_expo = create_expo_coef `Expos
in
let rec aux count accu = function
| [] -> List.rev accu
| l::rest ->
let new_l = make_list count accu (List.length l) in
aux (count+1) new_l rest
in
aux 1 [] lc
in
let prim_num = List.length coef in
Ezfio.set_basis_typ "Gaussian";
Ezfio.set_basis_shell_num shell_num;
Ezfio.set_basis_prim_num prim_num ;
Ezfio.set_basis_shell_prim_num (Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| shell_num |] ~data:shell_prim_num);
Ezfio.set_basis_shell_ang_mom (Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| shell_num |] ~data:ang_mom ) ;
Ezfio.set_basis_shell_index (Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| prim_num |] ~data:shell_idx) ;
Ezfio.set_basis_basis_nucleus_index (Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| shell_num |]
~data:( list_map (fun (_,n) -> Nucl_number.to_int n) basis)
) ;
Ezfio.set_basis_nucleus_shell_num(Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| nucl_num |]
~data:(
list_map (fun (_,n) -> Nucl_number.to_int n) basis
|> List.fold_left (fun accu i ->
match accu with
| [] -> [(1,i)]
| (h,j) :: rest -> if j == i then ((h+1,j)::rest) else ((1,i)::(h,j)::rest)
) []
|> List.rev
|> List.map fst
)) ;
Ezfio.set_basis_prim_coef (Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| prim_num |] ~data:coef) ;
Ezfio.set_basis_prim_expo (Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| prim_num |] ~data:expo) ;
let () =
let shell_num = List.length basis in
let lc : (GaussianPrimitive.t * Qptypes.AO_coef.t) list list =
list_map ( fun (g,_) -> g.Gto.lc ) basis
in
let ang_mom =
list_map (fun (l : (GaussianPrimitive.t * Qptypes.AO_coef.t) list) ->
let x, _ = List.hd l in
Angmom.to_l x.GaussianPrimitive.sym |> Qptypes.Positive_int.to_int
) lc
in
let expo =
list_map (fun l -> list_map (fun (x,_) -> Qptypes.AO_expo.to_float x.GaussianPrimitive.expo) l ) lc
|> List.concat
in
let coef =
list_map (fun l ->
list_map (fun (_,x) -> Qptypes.AO_coef.to_float x) l
) lc
|> List.concat
in
let shell_prim_num =
list_map List.length lc
in
let shell_idx =
let rec make_list n accu = function
| 0 -> accu
| i -> make_list n (n :: accu) (i-1)
in
let rec aux count accu = function
| [] -> List.rev accu
| l::rest ->
let new_l = make_list count accu (List.length l) in
aux (count+1) new_l rest
in
aux 1 [] lc
in
let prim_num = List.length coef in
Ezfio.set_basis_typ "Gaussian";
Ezfio.set_basis_shell_num shell_num;
Ezfio.set_basis_prim_num prim_num ;
Ezfio.set_basis_shell_prim_num (Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| shell_num |] ~data:shell_prim_num);
Ezfio.set_basis_shell_ang_mom (Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| shell_num |] ~data:ang_mom ) ;
Ezfio.set_basis_shell_index (Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| prim_num |] ~data:shell_idx) ;
Ezfio.set_basis_basis_nucleus_index (Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| shell_num |]
~data:( list_map (fun (_,n) -> Nucl_number.to_int n) basis)
) ;
Ezfio.set_basis_nucleus_shell_num(Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| nucl_num |]
~data:(
list_map (fun (_,n) -> Nucl_number.to_int n) basis
|> List.fold_left (fun accu i ->
match accu with
| [] -> [(1,i)]
| (h,j) :: rest -> if j == i then ((h+1,j)::rest) else ((1,i)::(h,j)::rest)
) []
|> List.rev
|> List.map fst
)) ;
Ezfio.set_basis_prim_coef (Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| prim_num |] ~data:coef) ;
Ezfio.set_basis_prim_expo (Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| prim_num |] ~data:expo) ;
Ezfio.set_ao_basis_ao_prim_num (Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| ao_num |] ~data:ao_prim_num) ;
Ezfio.set_ao_basis_ao_nucl(Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| ao_num |] ~data:ao_nucl) ;
Ezfio.set_ao_basis_ao_power(Ezfio.ezfio_array_of_list
~rank:2 ~dim:[| ao_num ; 3 |] ~data:ao_power) ;
Ezfio.set_ao_basis_ao_coef(Ezfio.ezfio_array_of_list
~rank:2 ~dim:[| ao_num ; ao_prim_num_max |] ~data:ao_coef) ;
Ezfio.set_ao_basis_ao_expo(Ezfio.ezfio_array_of_list
~rank:2 ~dim:[| ao_num ; ao_prim_num_max |] ~data:ao_expo) ;
Ezfio.set_ao_basis_ao_cartesian(cart);
in
match Input.Ao_basis.read () with
| None -> failwith "Error in basis"
| Some x -> Input.Ao_basis.write x
Ezfio.set_ao_basis_ao_prim_num (Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| ao_num |] ~data:ao_prim_num) ;
Ezfio.set_ao_basis_ao_nucl(Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| ao_num |] ~data:ao_nucl) ;
Ezfio.set_ao_basis_ao_power(Ezfio.ezfio_array_of_list
~rank:2 ~dim:[| ao_num ; 3 |] ~data:ao_power) ;
Ezfio.set_ao_basis_ao_coef(Ezfio.ezfio_array_of_list
~rank:2 ~dim:[| ao_num ; ao_prim_num_max |] ~data:ao_coef) ;
Ezfio.set_ao_basis_ao_expo(Ezfio.ezfio_array_of_list
~rank:2 ~dim:[| ao_num ; ao_prim_num_max |] ~data:ao_expo) ;
Ezfio.set_ao_basis_ao_cartesian(cart);
in
match Input.Ao_basis.read () with
| None -> failwith "Error in basis"
| Some x -> Input.Ao_basis.write x
end
in
let () =
try write_file () with
@ -781,7 +785,7 @@ If a file with the same name as the basis set exists, this file will be read. O
run ?o:output basis au charge dummy multiplicity pseudo cart xyz_filename
)
with
| Failure txt -> Printf.eprintf "Fatal error: %s\n%!" txt
(* | Failure txt -> Printf.eprintf "Fatal error: %s\n%!" txt *)
| Command_line.Error txt -> Printf.eprintf "Command line error: %s\n%!" txt

2
scripts/compilation/qp_create_ninja
View File

@ -38,7 +38,7 @@ def comp_path(path):
from qp_path import QP_ROOT, QP_SRC, QP_EZFIO
LIB = " -lz"
LIB = " -lz -ltrexio"
EZFIO_LIB = join("$QP_ROOT", "lib", "libezfio_irp.a")
ZMQ_LIB = join("$QP_ROOT", "lib", "libf77zmq.a") + " " + join("$QP_ROOT", "lib", "libzmq.a") + " -lstdc++ -lrt -ldl"
ROOT_BUILD_NINJA = join("$QP_ROOT", "config", "build.ninja")

36
scripts/ezfio_interface/qp_edit_template
View File

@ -172,25 +172,23 @@ let run check_only ?ndet ?state ezfio_filename =
(* Reorder basis set *)
begin
let aos =
match Input.Ao_basis.read() with
| Some x -> x
| _ -> assert false
in
let ordering = Input.Ao_basis.ordering aos in
let test = Array.copy ordering in
Array.sort compare test ;
if test <> ordering then
begin
Printf.eprintf "Warning: Basis set is not properly ordered. Redordering.\n";
let new_aos = Input.Ao_basis.reorder aos in
Input.Ao_basis.write new_aos;
match Input.Mo_basis.read() with
| None -> ()
| Some mos ->
let new_mos = Input.Mo_basis.reorder mos ordering in
Input.Mo_basis.write new_mos
end
match Input.Ao_basis.read() with
| Some aos ->
let ordering = Input.Ao_basis.ordering aos in
let test = Array.copy ordering in
Array.sort compare test ;
if test <> ordering then
begin
Printf.eprintf "Warning: Basis set is not properly ordered. Redordering.\n";
let new_aos = Input.Ao_basis.reorder aos in
Input.Ao_basis.write new_aos;
match Input.Mo_basis.read() with
| None -> ()
| Some mos ->
let new_mos = Input.Mo_basis.reorder mos ordering in
Input.Mo_basis.write new_mos
end
| _ -> ()
end;
begin

18
scripts/qp_exc_energy.py
View File

@ -42,13 +42,15 @@ import sys, os
import scipy
import scipy.stats
from math import sqrt, gamma, exp
import json
import qp_json
def read_data(filename,state):
def read_data(ezfio_filename,state):
""" Read energies and PT2 from input file """
with open(filename,'r') as f:
lines = json.load(f)['fci']
data = qp_json.load_last(ezfio_filename)
for method in data.keys():
x = data[method]
lines = x
print(f"State: {state}")
@ -138,15 +140,15 @@ def compute(data):
return mu, err, bias, p
filename = sys.argv[1]
print(filename)
ezfio_filename = sys.argv[1]
print(ezfio_filename)
if len(sys.argv) > 2:
state = int(sys.argv[2])
else:
state = 1
data = read_data(filename,state)
data = read_data(ezfio_filename,state)
mu, err, bias, _ = compute(data)
print(" %s: %8.3f +/- %5.3f eV\n"%(filename, mu, err))
print(" %s: %8.3f +/- %5.3f eV\n"%(ezfio_filename, mu, err))
import numpy as np
A = np.array( [ [ data[-1][1], 1. ],

82
scripts/qp_extract_cipsi_data.py
View File

@ -1,57 +1,37 @@
#!/usr/bin/env python3
import re
import qp_json
import sys
# Read output file
with open(sys.argv[1], 'r') as file:
output = file.read()
if len(sys.argv) == 1:
print(f"syntax: {sys.argv[0]} EZFIO_FILE")
d = qp_json.load_all(sys.argv[1])
k = [ x for x in d.keys() ]
k.sort()
print("# Energy PT2 PT2_err rPT2 rPT2_err exFCI\n")
for f in k:
try:
j = d[f]["fci"]
except:
continue
print(f"# {f}")
for e in j:
out = f" {e['n_det']:8d}"
nstates = len(e["states"])
for ee in e["states"]:
try:
exc_energy = ee['ex_energy'][0]
except:
exc_energy = 0.
out += f" {ee['energy']:16.8f} {ee['pt2']:e} {ee['pt2_err']:e} {ee['rpt2']:e} {ee['rpt2_err']:e} {exc_energy:16.8f}"
print(out)
print("\n")
def extract_data(output):
lines = output.split("\n")
data = []
n_det = None
e = None
pt2 = None
err_pt2 = None
rpt2 = None
err_rpt2 = None
e_ex = None
reading = False
for iline, line in enumerate(lines):
if line.startswith("Summary at N_det"):
reading = False
if not reading and line.startswith(" N_det "):
n_det = int(re.search(r"N_det\s+=\s+(\d+)", line).group(1))
reading = True
if reading:
if line.startswith(" E "):
e = float(re.search(r"E\s+=\s+(-?\d+\.\d+)", line).group(1))
elif line.startswith(" PT2 "):
pt2 = float(re.search(r"PT2\s+=\s+(-?\d+\.\d+E?.\d*)", line).group(1))
err_pt2 = float(re.search(r"\+/-\s+(-?\d+\.\d+E?.\d*)", line).group(1))
elif line.startswith(" rPT2 "):
rpt2 = float(re.search(r"rPT2\s+=\s+(-?\d+\.\d+E?.\d*)", line).group(1))
err_rpt2 = float(re.search(r"\+/-\s+(-?\d+\.\d+E?.\d*)", line).group(1))
elif "minimum PT2 Extrapolated energy" in line:
e_ex_line = lines[iline+2]
e_ex = float(e_ex_line.split()[1])
reading = False
new_data = " {:8d} {:16.8f} {:e} {:e} {:e} {:e} {:16.8f}".format(n_det, e, pt2, err_pt2, rpt2, err_rpt2, e_ex)
data.append(new_data)
n_det = e = pt2 = err_pt2 = rpt2 = err_rpt2 = e_ex = None
return data
data = extract_data(output)
for item in data:
print(item)

66
scripts/utility/qp_json.py Normal file
View File

@ -0,0 +1,66 @@
#!/usr/bin/env python
import os
import json
def fix_json(s):
"""Properly termitates an incomplete JSON file"""
s = s.replace(' ','')
s = s.replace('\n','')
s = s.replace('\t','')
s = s.replace(",{}",'')
tmp = [ c for c in s if c in "[]{}" ]
tmp = "".join(tmp)
tmp_old = ""
while tmp != tmp_old:
tmp_old = tmp
tmp = tmp.replace("{}","")
tmp = tmp.replace("[]","")
while s[-1] in [ ',', '\n', ' ', '\t' ]:
s = s[:-1]
tmp = [ c for c in tmp ]
tmp.reverse()
for c in tmp:
if c == '[': s += "]"
elif c == '{': s += "}"
return s
def load(filename):
"""Loads a JSON file after calling the fix_json function."""
with open(filename,'r') as f:
data = f.read()
new_data = fix_json(data)
return json.loads(new_data)
def load_all(ezfio_filename):
"""Loads all JSON files of an EZFIO."""
d = {}
prefix = ezfio_filename+'/json/'
for filename in [ x for x in os.listdir(prefix) if x.endswith(".json")]:
d[filename] = load(prefix+filename)
return d
def load_last(ezfio_filename):
"""Loads last JSON file of an EZFIO."""
d = {}
prefix = ezfio_filename+'/json/'
l = [ x for x in os.listdir(prefix) if x.endswith(".json")]
l.sort()
filename = l[-1]
print(filename)
return load(prefix+filename)
def fix(ezfio_filename):
"""Fixes all JSON files in an EZFIO."""
d = load_all(ezfio_filename)
prefix = ezfio_filename+'/json/'
for filename in d.keys():
with open(prefix+filename, 'w') as json_file:
json.dump(d[filename], json_file)

26
src/ao_basis/aos_in_r.irp.f
View File

@ -12,21 +12,21 @@ double precision function ao_value(i,r)
integer :: power_ao(3)
double precision :: accu,dx,dy,dz,r2
num_ao = ao_nucl(i)
! power_ao(1:3)= ao_power(i,1:3)
! center_ao(1:3) = nucl_coord(num_ao,1:3)
! dx = (r(1) - center_ao(1))
! dy = (r(2) - center_ao(2))
! dz = (r(3) - center_ao(3))
! r2 = dx*dx + dy*dy + dz*dz
! dx = dx**power_ao(1)
! dy = dy**power_ao(2)
! dz = dz**power_ao(3)
power_ao(1:3)= ao_power(i,1:3)
center_ao(1:3) = nucl_coord(num_ao,1:3)
dx = (r(1) - center_ao(1))
dy = (r(2) - center_ao(2))
dz = (r(3) - center_ao(3))
r2 = dx*dx + dy*dy + dz*dz
dx = dx**power_ao(1)
dy = dy**power_ao(2)
dz = dz**power_ao(3)
accu = 0.d0
! do m=1,ao_prim_num(i)
! beta = ao_expo_ordered_transp(m,i)
! accu += ao_coef_normalized_ordered_transp(m,i) * dexp(-beta*r2)
! enddo
do m=1,ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
accu += ao_coef_normalized_ordered_transp(m,i) * dexp(-beta*r2)
enddo
ao_value = accu * dx * dy * dz
end

24
src/ao_many_one_e_ints/listj1b.irp.f
View File

@ -7,17 +7,17 @@ BEGIN_PROVIDER [integer, List_all_comb_b2_size]
PROVIDE j1b_type
if(j1b_type .eq. 3) then
if((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
List_all_comb_b2_size = 2**nucl_num
elseif(j1b_type .eq. 4) then
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
List_all_comb_b2_size = nucl_num + 1
else
print *, 'j1b_type = ', j1b_pen, 'is not implemented'
print *, 'j1b_type = ', j1b_type, 'is not implemented'
stop
endif
@ -67,7 +67,7 @@ END_PROVIDER
List_all_comb_b2_expo = 0.d0
List_all_comb_b2_cent = 0.d0
if(j1b_type .eq. 3) then
if((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
do i = 1, List_all_comb_b2_size
@ -121,7 +121,7 @@ END_PROVIDER
List_all_comb_b2_coef(i) = (-1.d0)**dble(phase) * dexp(-List_all_comb_b2_coef(i))
enddo
elseif(j1b_type .eq. 4) then
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
List_all_comb_b2_coef( 1) = 1.d0
List_all_comb_b2_expo( 1) = 0.d0
@ -136,7 +136,7 @@ END_PROVIDER
else
print *, 'j1b_type = ', j1b_pen, 'is not implemented'
print *, 'j1b_type = ', j1b_type, 'is not implemented'
stop
endif
@ -156,18 +156,18 @@ BEGIN_PROVIDER [ integer, List_all_comb_b3_size]
implicit none
double precision :: tmp
if(j1b_type .eq. 3) then
if((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
List_all_comb_b3_size = 3**nucl_num
elseif(j1b_type .eq. 4) then
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
tmp = 0.5d0 * dble(nucl_num) * (dble(nucl_num) + 3.d0)
List_all_comb_b3_size = int(tmp) + 1
else
print *, 'j1b_type = ', j1b_pen, 'is not implemented'
print *, 'j1b_type = ', j1b_type, 'is not implemented'
stop
endif
@ -230,7 +230,7 @@ END_PROVIDER
List_all_comb_b3_expo = 0.d0
List_all_comb_b3_cent = 0.d0
if(j1b_type .eq. 3) then
if((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
do i = 1, List_all_comb_b3_size
@ -287,7 +287,7 @@ END_PROVIDER
List_all_comb_b3_coef(i) = (-1.d0)**dble(phase) * facto * dexp(-List_all_comb_b3_coef(i))
enddo
elseif(j1b_type .eq. 4) then
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
ii = 1
List_all_comb_b3_coef( ii) = 1.d0
@ -347,7 +347,7 @@ END_PROVIDER
else
print *, 'j1b_type = ', j1b_pen, 'is not implemented'
print *, 'j1b_type = ', j1b_type, 'is not implemented'
stop
endif

1
src/ao_one_e_ints/NEED
View File

@ -1,2 +1,3 @@
ao_basis
pseudo
cosgtos_ao_int

200
src/ao_one_e_ints/ao_overlap.irp.f
View File

@ -1,75 +1,99 @@
BEGIN_PROVIDER [ double precision, ao_overlap,(ao_num,ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_overlap_x,(ao_num,ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_overlap_y,(ao_num,ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_overlap_z,(ao_num,ao_num) ]
implicit none
! ---
BEGIN_PROVIDER [ double precision, ao_overlap , (ao_num, ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_overlap_x, (ao_num, ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_overlap_y, (ao_num, ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_overlap_z, (ao_num, ao_num) ]
BEGIN_DOC
! Overlap between atomic basis functions:
!
! :math:`\int \chi_i(r) \chi_j(r) dr`
! Overlap between atomic basis functions:
!
! :math:`\int \chi_i(r) \chi_j(r) dr`
END_DOC
integer :: i,j,n,l
double precision :: f
integer :: dim1
implicit none
integer :: i, j, n, l, dim1, power_A(3), power_B(3)
double precision :: overlap, overlap_x, overlap_y, overlap_z
double precision :: alpha, beta, c
double precision :: A_center(3), B_center(3)
integer :: power_A(3), power_B(3)
ao_overlap = 0.d0
ao_overlap = 0.d0
ao_overlap_x = 0.d0
ao_overlap_y = 0.d0
ao_overlap_z = 0.d0
if (read_ao_integrals_overlap) then
call ezfio_get_ao_one_e_ints_ao_integrals_overlap(ao_overlap(1:ao_num, 1:ao_num))
print *, 'AO overlap integrals read from disk'
if(read_ao_integrals_overlap) then
call ezfio_get_ao_one_e_ints_ao_integrals_overlap(ao_overlap(1:ao_num, 1:ao_num))
print *, 'AO overlap integrals read from disk'
else
dim1=100
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
!$OMP DEFAULT(NONE) &
!$OMP PRIVATE(A_center,B_center,power_A,power_B,&
!$OMP overlap_x,overlap_y, overlap_z, overlap, &
!$OMP alpha, beta,i,j,c) &
!$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
!$OMP ao_overlap_x,ao_overlap_y,ao_overlap_z,ao_overlap,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, &
!$OMP ao_expo_ordered_transp,dim1)
do j=1,ao_num
A_center(1) = nucl_coord( ao_nucl(j), 1 )
A_center(2) = nucl_coord( ao_nucl(j), 2 )
A_center(3) = nucl_coord( ao_nucl(j), 3 )
power_A(1) = ao_power( j, 1 )
power_A(2) = ao_power( j, 2 )
power_A(3) = ao_power( j, 3 )
do i= 1,ao_num
B_center(1) = nucl_coord( ao_nucl(i), 1 )
B_center(2) = nucl_coord( ao_nucl(i), 2 )
B_center(3) = nucl_coord( ao_nucl(i), 3 )
power_B(1) = ao_power( i, 1 )
power_B(2) = ao_power( i, 2 )
power_B(3) = ao_power( i, 3 )
do n = 1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(n,j)
do l = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(l,i)
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1)
c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i)
ao_overlap(i,j) += c * overlap
if(isnan(ao_overlap(i,j)))then
print*,'i,j',i,j
print*,'l,n',l,n
print*,'c,overlap',c,overlap
print*,overlap_x,overlap_y,overlap_z
stop
endif
ao_overlap_x(i,j) += c * overlap_x
ao_overlap_y(i,j) += c * overlap_y
ao_overlap_z(i,j) += c * overlap_z
if(use_cosgtos) then
!print*, ' use_cosgtos for ao_overlap ?', use_cosgtos
do j = 1, ao_num
do i = 1, ao_num
ao_overlap (i,j) = ao_overlap_cosgtos (i,j)
ao_overlap_x(i,j) = ao_overlap_cosgtos_x(i,j)
ao_overlap_y(i,j) = ao_overlap_cosgtos_y(i,j)
ao_overlap_z(i,j) = ao_overlap_cosgtos_z(i,j)
enddo
enddo
else
dim1=100
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
!$OMP DEFAULT(NONE) &
!$OMP PRIVATE(A_center,B_center,power_A,power_B,&
!$OMP overlap_x,overlap_y, overlap_z, overlap, &
!$OMP alpha, beta,i,j,c) &
!$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
!$OMP ao_overlap_x,ao_overlap_y,ao_overlap_z,ao_overlap,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, &
!$OMP ao_expo_ordered_transp,dim1)
do j=1,ao_num
A_center(1) = nucl_coord( ao_nucl(j), 1 )
A_center(2) = nucl_coord( ao_nucl(j), 2 )
A_center(3) = nucl_coord( ao_nucl(j), 3 )
power_A(1) = ao_power( j, 1 )
power_A(2) = ao_power( j, 2 )
power_A(3) = ao_power( j, 3 )
do i= 1,ao_num
B_center(1) = nucl_coord( ao_nucl(i), 1 )
B_center(2) = nucl_coord( ao_nucl(i), 2 )
B_center(3) = nucl_coord( ao_nucl(i), 3 )
power_B(1) = ao_power( i, 1 )
power_B(2) = ao_power( i, 2 )
power_B(3) = ao_power( i, 3 )
do n = 1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(n,j)
do l = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(l,i)
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1)
c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i)
ao_overlap(i,j) += c * overlap
if(isnan(ao_overlap(i,j)))then
print*,'i,j',i,j
print*,'l,n',l,n
print*,'c,overlap',c,overlap
print*,overlap_x,overlap_y,overlap_z
stop
endif
ao_overlap_x(i,j) += c * overlap_x
ao_overlap_y(i,j) += c * overlap_y
ao_overlap_z(i,j) += c * overlap_z
enddo
enddo
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
!$OMP END PARALLEL DO
endif
endif
if (write_ao_integrals_overlap) then
call ezfio_set_ao_one_e_ints_ao_integrals_overlap(ao_overlap(1:ao_num, 1:ao_num))
print *, 'AO overlap integrals written to disk'
@ -77,6 +101,8 @@
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, ao_overlap_imag, (ao_num, ao_num) ]
implicit none
BEGIN_DOC
@ -85,6 +111,8 @@ BEGIN_PROVIDER [ double precision, ao_overlap_imag, (ao_num, ao_num) ]
ao_overlap_imag = 0.d0
END_PROVIDER
! ---
BEGIN_PROVIDER [ complex*16, ao_overlap_complex, (ao_num, ao_num) ]
implicit none
BEGIN_DOC
@ -98,41 +126,43 @@ BEGIN_PROVIDER [ complex*16, ao_overlap_complex, (ao_num, ao_num) ]
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, ao_overlap_abs, (ao_num, ao_num) ]
BEGIN_PROVIDER [ double precision, ao_overlap_abs,(ao_num,ao_num) ]
implicit none
BEGIN_DOC
! Overlap between absolute values of atomic basis functions:
!
! :math:`\int |\chi_i(r)| |\chi_j(r)| dr`
! Overlap between absolute values of atomic basis functions:
!
! :math:`\int |\chi_i(r)| |\chi_j(r)| dr`
END_DOC
integer :: i,j,n,l
double precision :: f
integer :: dim1
double precision :: overlap, overlap_x, overlap_y, overlap_z
implicit none
integer :: i, j, n, l, dim1, power_A(3), power_B(3)
double precision :: overlap_x, overlap_y, overlap_z
double precision :: alpha, beta
double precision :: A_center(3), B_center(3)
integer :: power_A(3), power_B(3)
double precision :: lower_exp_val, dx
if (is_periodic) then
do j=1,ao_num
do i= 1,ao_num
ao_overlap_abs(i,j)= cdabs(ao_overlap_complex(i,j))
if(is_periodic) then
do j = 1, ao_num
do i = 1, ao_num
ao_overlap_abs(i,j) = cdabs(ao_overlap_complex(i,j))
enddo
enddo
else
dim1=100
lower_exp_val = 40.d0
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
!$OMP DEFAULT(NONE) &
!$OMP PRIVATE(A_center,B_center,power_A,power_B, &
!$OMP overlap_x,overlap_y, overlap_z, overlap, &
!$OMP alpha, beta,i,j,dx) &
!$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
!$OMP ao_overlap_abs,ao_num,ao_coef_normalized_ordered_transp,ao_nucl,&
!$OMP ao_expo_ordered_transp,dim1,lower_exp_val)
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
!$OMP DEFAULT(NONE) &
!$OMP PRIVATE(A_center,B_center,power_A,power_B, &
!$OMP overlap_x,overlap_y, overlap_z, &
!$OMP alpha, beta,i,j,dx) &
!$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
!$OMP ao_overlap_abs,ao_num,ao_coef_normalized_ordered_transp,ao_nucl,&
!$OMP ao_expo_ordered_transp,dim1,lower_exp_val)
do j=1,ao_num
A_center(1) = nucl_coord( ao_nucl(j), 1 )
A_center(2) = nucl_coord( ao_nucl(j), 2 )
@ -160,10 +190,14 @@ BEGIN_PROVIDER [ double precision, ao_overlap_abs,(ao_num,ao_num) ]
enddo
enddo
enddo
!$OMP END PARALLEL DO
!$OMP END PARALLEL DO
endif
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, S_inv,(ao_num,ao_num) ]
implicit none
BEGIN_DOC

206
src/ao_one_e_ints/kin_ao_ints.irp.f
View File

@ -1,7 +1,10 @@
BEGIN_PROVIDER [ double precision, ao_deriv2_x,(ao_num,ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_deriv2_y,(ao_num,ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_deriv2_z,(ao_num,ao_num) ]
implicit none
! ---
BEGIN_PROVIDER [ double precision, ao_deriv2_x, (ao_num, ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_deriv2_y, (ao_num, ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_deriv2_z, (ao_num, ao_num) ]
BEGIN_DOC
! Second derivative matrix elements in the |AO| basis.
!
@ -11,114 +14,131 @@
! \langle \chi_i(x,y,z) | \frac{\partial^2}{\partial x^2} |\chi_j (x,y,z) \rangle
!
END_DOC
integer :: i,j,n,l
double precision :: f
integer :: dim1
implicit none
integer :: i, j, n, l, dim1, power_A(3), power_B(3)
double precision :: overlap, overlap_y, overlap_z
double precision :: overlap_x0, overlap_y0, overlap_z0
double precision :: alpha, beta, c
double precision :: A_center(3), B_center(3)
integer :: power_A(3), power_B(3)
double precision :: d_a_2,d_2
dim1=100
! -- Dummy call to provide everything
A_center(:) = 0.d0
B_center(:) = 1.d0
alpha = 1.d0
beta = .1d0
power_A = 1
power_B = 0
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_a_2,overlap_z,overlap,dim1)
! --
if(use_cosgtos) then
!print*, 'use_cosgtos for ao_kinetic_integrals ?', use_cosgtos
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
!$OMP DEFAULT(NONE) &
!$OMP PRIVATE(A_center,B_center,power_A,power_B,&
!$OMP overlap_y, overlap_z, overlap, &
!$OMP alpha, beta,i,j,c,d_a_2,d_2,deriv_tmp, &
!$OMP overlap_x0,overlap_y0,overlap_z0) &
!$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
!$OMP ao_deriv2_x,ao_deriv2_y,ao_deriv2_z,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, &
!$OMP ao_expo_ordered_transp,dim1)
do j=1,ao_num
A_center(1) = nucl_coord( ao_nucl(j), 1 )
A_center(2) = nucl_coord( ao_nucl(j), 2 )
A_center(3) = nucl_coord( ao_nucl(j), 3 )
power_A(1) = ao_power( j, 1 )
power_A(2) = ao_power( j, 2 )
power_A(3) = ao_power( j, 3 )
do i= 1,ao_num
ao_deriv2_x(i,j)= 0.d0
ao_deriv2_y(i,j)= 0.d0
ao_deriv2_z(i,j)= 0.d0
B_center(1) = nucl_coord( ao_nucl(i), 1 )
B_center(2) = nucl_coord( ao_nucl(i), 2 )
B_center(3) = nucl_coord( ao_nucl(i), 3 )
power_B(1) = ao_power( i, 1 )
power_B(2) = ao_power( i, 2 )
power_B(3) = ao_power( i, 3 )
do n = 1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(n,j)
do l = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(l,i)
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x0,overlap_y0,overlap_z0,overlap,dim1)
c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i)
do j = 1, ao_num
do i = 1, ao_num
ao_deriv2_x(i,j) = ao_deriv2_cosgtos_x(i,j)
ao_deriv2_y(i,j) = ao_deriv2_cosgtos_y(i,j)
ao_deriv2_z(i,j) = ao_deriv2_cosgtos_z(i,j)
enddo
enddo
power_A(1) = power_A(1)-2
if (power_A(1)>-1) then
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,d_a_2,overlap_y,overlap_z,overlap,dim1)
else
d_a_2 = 0.d0
endif
power_A(1) = power_A(1)+4
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,d_2,overlap_y,overlap_z,overlap,dim1)
power_A(1) = power_A(1)-2
else
double precision :: deriv_tmp
deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(1) +1.d0) * overlap_x0 &
+power_A(1) * (power_A(1)-1.d0) * d_a_2 &
+4.d0 * alpha * alpha * d_2 )*overlap_y0*overlap_z0
dim1=100
ao_deriv2_x(i,j) += c*deriv_tmp
power_A(2) = power_A(2)-2
if (power_A(2)>-1) then
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_a_2,overlap_z,overlap,dim1)
else
d_a_2 = 0.d0
endif
power_A(2) = power_A(2)+4
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_2,overlap_z,overlap,dim1)
power_A(2) = power_A(2)-2
! -- Dummy call to provide everything
A_center(:) = 0.d0
B_center(:) = 1.d0
alpha = 1.d0
beta = .1d0
power_A = 1
power_B = 0
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_a_2,overlap_z,overlap,dim1)
! --
deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(2) +1.d0 ) * overlap_y0 &
+power_A(2) * (power_A(2)-1.d0) * d_a_2 &
+4.d0 * alpha * alpha * d_2 )*overlap_x0*overlap_z0
ao_deriv2_y(i,j) += c*deriv_tmp
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
!$OMP DEFAULT(NONE) &
!$OMP PRIVATE(A_center,B_center,power_A,power_B,&
!$OMP overlap_y, overlap_z, overlap, &
!$OMP alpha, beta,i,j,c,d_a_2,d_2,deriv_tmp, &
!$OMP overlap_x0,overlap_y0,overlap_z0) &
!$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
!$OMP ao_deriv2_x,ao_deriv2_y,ao_deriv2_z,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, &
!$OMP ao_expo_ordered_transp,dim1)
do j=1,ao_num
A_center(1) = nucl_coord( ao_nucl(j), 1 )
A_center(2) = nucl_coord( ao_nucl(j), 2 )
A_center(3) = nucl_coord( ao_nucl(j), 3 )
power_A(1) = ao_power( j, 1 )
power_A(2) = ao_power( j, 2 )
power_A(3) = ao_power( j, 3 )
do i= 1,ao_num
ao_deriv2_x(i,j)= 0.d0
ao_deriv2_y(i,j)= 0.d0
ao_deriv2_z(i,j)= 0.d0
B_center(1) = nucl_coord( ao_nucl(i), 1 )
B_center(2) = nucl_coord( ao_nucl(i), 2 )
B_center(3) = nucl_coord( ao_nucl(i), 3 )
power_B(1) = ao_power( i, 1 )
power_B(2) = ao_power( i, 2 )
power_B(3) = ao_power( i, 3 )
do n = 1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(n,j)
do l = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(l,i)
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x0,overlap_y0,overlap_z0,overlap,dim1)
c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i)
power_A(3) = power_A(3)-2
if (power_A(3)>-1) then
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,overlap_z,d_a_2,overlap,dim1)
else
d_a_2 = 0.d0
endif
power_A(3) = power_A(3)+4
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,overlap_z,d_2,overlap,dim1)
power_A(3) = power_A(3)-2
power_A(1) = power_A(1)-2
if (power_A(1)>-1) then
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,d_a_2,overlap_y,overlap_z,overlap,dim1)
else
d_a_2 = 0.d0
endif
power_A(1) = power_A(1)+4
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,d_2,overlap_y,overlap_z,overlap,dim1)
power_A(1) = power_A(1)-2
deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(3) +1.d0 ) * overlap_z0 &
+power_A(3) * (power_A(3)-1.d0) * d_a_2 &
+4.d0 * alpha * alpha * d_2 )*overlap_x0*overlap_y0
ao_deriv2_z(i,j) += c*deriv_tmp
double precision :: deriv_tmp
deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(1) +1.d0) * overlap_x0 &
+power_A(1) * (power_A(1)-1.d0) * d_a_2 &
+4.d0 * alpha * alpha * d_2 )*overlap_y0*overlap_z0
ao_deriv2_x(i,j) += c*deriv_tmp
power_A(2) = power_A(2)-2
if (power_A(2)>-1) then
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_a_2,overlap_z,overlap,dim1)
else
d_a_2 = 0.d0
endif
power_A(2) = power_A(2)+4
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_2,overlap_z,overlap,dim1)
power_A(2) = power_A(2)-2
deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(2) +1.d0 ) * overlap_y0 &
+power_A(2) * (power_A(2)-1.d0) * d_a_2 &
+4.d0 * alpha * alpha * d_2 )*overlap_x0*overlap_z0
ao_deriv2_y(i,j) += c*deriv_tmp
power_A(3) = power_A(3)-2
if (power_A(3)>-1) then
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,overlap_z,d_a_2,overlap,dim1)
else
d_a_2 = 0.d0
endif
power_A(3) = power_A(3)+4
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,overlap_z,d_2,overlap,dim1)
power_A(3) = power_A(3)-2
deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(3) +1.d0 ) * overlap_z0 &
+power_A(3) * (power_A(3)-1.d0) * d_a_2 &
+4.d0 * alpha * alpha * d_2 )*overlap_x0*overlap_y0
ao_deriv2_z(i,j) += c*deriv_tmp
enddo
enddo
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
!$OMP END PARALLEL DO
endif
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, ao_kinetic_integrals, (ao_num,ao_num)]
implicit none
BEGIN_DOC

531
src/ao_one_e_ints/pot_ao_erf_ints.irp.f
View File

@ -1,3 +1,6 @@
! ---
subroutine give_all_erf_kl_ao(integrals_ao,mu_in,C_center)
implicit none
BEGIN_DOC
@ -15,36 +18,104 @@ subroutine give_all_erf_kl_ao(integrals_ao,mu_in,C_center)
enddo
end
! ---
double precision function NAI_pol_mult_erf_ao(i_ao, j_ao, mu_in, C_center)
double precision function NAI_pol_mult_erf_ao(i_ao,j_ao,mu_in,C_center)
implicit none
BEGIN_DOC
!
! Computes the following integral :
! $\int_{-\infty}^{infty} dr \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! $\int_{-\infty}^{infty} dr \chi_i(r) \chi_j(r) \frac{\erf(\mu |r - R_C|)}{|r - R_C|}$.
!
END_DOC
integer, intent(in) :: i_ao,j_ao
implicit none
integer, intent(in) :: i_ao, j_ao
double precision, intent(in) :: mu_in, C_center(3)
integer :: i,j,num_A,num_B, power_A(3), power_B(3), n_pt_in
double precision :: A_center(3), B_center(3),integral, alpha,beta
integer :: i, j, num_A, num_B, power_A(3), power_B(3), n_pt_in
double precision :: A_center(3), B_center(3), integral, alpha, beta
double precision :: NAI_pol_mult_erf
num_A = ao_nucl(i_ao)
power_A(1:3)= ao_power(i_ao,1:3)
num_A = ao_nucl(i_ao)
power_A(1:3) = ao_power(i_ao,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
num_B = ao_nucl(j_ao)
power_B(1:3)= ao_power(j_ao,1:3)
num_B = ao_nucl(j_ao)
power_B(1:3) = ao_power(j_ao,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
n_pt_in = n_pt_max_integrals
NAI_pol_mult_erf_ao = 0.d0
do i = 1, ao_prim_num(i_ao)
alpha = ao_expo_ordered_transp(i,i_ao)
do j = 1, ao_prim_num(j_ao)
beta = ao_expo_ordered_transp(j,j_ao)
integral = NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in,mu_in)
NAI_pol_mult_erf_ao += integral * ao_coef_normalized_ordered_transp(j,j_ao)*ao_coef_normalized_ordered_transp(i,i_ao)
integral = NAI_pol_mult_erf(A_center, B_center, power_A, power_B, alpha, beta, C_center, n_pt_in,mu_in)
NAI_pol_mult_erf_ao += integral * ao_coef_normalized_ordered_transp(j,j_ao) * ao_coef_normalized_ordered_transp(i,i_ao)
enddo
enddo
end
end function NAI_pol_mult_erf_ao
! ---
double precision function NAI_pol_mult_erf_ao_with1s(i_ao, j_ao, beta, B_center, mu_in, C_center)
BEGIN_DOC
!
! Computes the following integral :
! $\int_{-\infty}^{infty} dr \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu |r - R_C|)}{|r - R_C|}$.
!
END_DOC
implicit none
integer, intent(in) :: i_ao, j_ao
double precision, intent(in) :: beta, B_center(3)
double precision, intent(in) :: mu_in, C_center(3)
integer :: i, j, power_A1(3), power_A2(3), n_pt_in
double precision :: A1_center(3), A2_center(3), alpha1, alpha2, coef12, coef1, integral
double precision, external :: NAI_pol_mult_erf_with1s, NAI_pol_mult_erf_ao
ASSERT(beta .ge. 0.d0)
if(beta .lt. 1d-10) then
NAI_pol_mult_erf_ao_with1s = NAI_pol_mult_erf_ao(i_ao, j_ao, mu_in, C_center)
return
endif
power_A1(1:3) = ao_power(i_ao,1:3)
power_A2(1:3) = ao_power(j_ao,1:3)
A1_center(1:3) = nucl_coord(ao_nucl(i_ao),1:3)
A2_center(1:3) = nucl_coord(ao_nucl(j_ao),1:3)
n_pt_in = n_pt_max_integrals
NAI_pol_mult_erf_ao_with1s = 0.d0
do i = 1, ao_prim_num(i_ao)
alpha1 = ao_expo_ordered_transp (i,i_ao)
coef1 = ao_coef_normalized_ordered_transp(i,i_ao)
do j = 1, ao_prim_num(j_ao)
alpha2 = ao_expo_ordered_transp(j,j_ao)
coef12 = coef1 * ao_coef_normalized_ordered_transp(j,j_ao)
if(dabs(coef12) .lt. 1d-14) cycle
integral = NAI_pol_mult_erf_with1s( A1_center, A2_center, power_A1, power_A2, alpha1, alpha2 &
, beta, B_center, C_center, n_pt_in, mu_in )
NAI_pol_mult_erf_ao_with1s += integral * coef12
enddo
enddo
end function NAI_pol_mult_erf_ao_with1s
! ---
double precision function NAI_pol_mult_erf(A_center, B_center, power_A, power_B, alpha, beta, C_center, n_pt_in, mu_in)
@ -127,58 +198,221 @@ end function NAI_pol_mult_erf
! ---
double precision function NAI_pol_mult_erf_ao_with1s(i_ao, j_ao, beta, B_center, mu_in, C_center)
subroutine NAI_pol_mult_erf_v(A_center, B_center, power_A, power_B, alpha, beta, C_center, LD_C, n_pt_in, mu_in, res_v, LD_resv, n_points)
BEGIN_DOC
!
! Computes the following integral :
! $\int_{-\infty}^{infty} dr \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu |r - R_C|)}{|r - R_C|}$.
!
! .. math::
!
! \int dr (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
! \frac{\erf(\mu |r - R_C |)}{| r - R_C |}$.
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i_ao, j_ao
double precision, intent(in) :: beta, B_center(3)
double precision, intent(in) :: mu_in, C_center(3)
integer :: i, j, power_A1(3), power_A2(3), n_pt_in
double precision :: A1_center(3), A2_center(3), alpha1, alpha2, coef12, coef1, integral
integer, intent(in) :: n_pt_in, n_points, LD_C, LD_resv
integer, intent(in) :: power_A(3), power_B(3)
double precision, intent(in) :: A_center(3), B_center(3), alpha, beta, mu_in
double precision, intent(in) :: C_center(LD_C,3)
double precision, intent(out) :: res_v(LD_resv)
double precision, external :: NAI_pol_mult_erf_with1s, NAI_pol_mult_erf_ao
integer :: i, n_pt, n_pt_out, ipoint
double precision :: P_center(3)
double precision :: d(0:n_pt_in), coeff, dist, const, factor
double precision :: const_factor, dist_integral
double precision :: accu, p_inv, p, rho, p_inv_2
double precision :: p_new, p_new2, coef_tmp
ASSERT(beta .ge. 0.d0)
if(beta .lt. 1d-10) then
NAI_pol_mult_erf_ao_with1s = NAI_pol_mult_erf_ao(i_ao, j_ao, mu_in, C_center)
double precision :: rint
res_V(1:LD_resv) = 0.d0
p = alpha + beta
p_inv = 1.d0 / p
p_inv_2 = 0.5d0 * p_inv
rho = alpha * beta * p_inv
p_new = mu_in / dsqrt(p + mu_in * mu_in)
p_new2 = p_new * p_new
coef_tmp = p * p_new2
dist = 0.d0
do i = 1, 3
P_center(i) = (alpha * A_center(i) + beta * B_center(i)) * p_inv
dist += (A_center(i) - B_center(i)) * (A_center(i) - B_center(i))
enddo
const_factor = dist * rho
if(const_factor > 80.d0) then
return
endif
factor = dexp(-const_factor)
coeff = dtwo_pi * factor * p_inv * p_new
n_pt = 2 * ( power_A(1) + power_B(1) + power_A(2) + power_B(2) + power_A(3) + power_B(3) )
if(n_pt == 0) then
do ipoint = 1, n_points
dist_integral = 0.d0
do i = 1, 3
dist_integral += (P_center(i) - C_center(ipoint,i)) * (P_center(i) - C_center(ipoint,i))
enddo
const = coef_tmp * dist_integral
res_v(ipoint) = coeff * rint(0, const)
enddo
else
do ipoint = 1, n_points
dist_integral = 0.d0
do i = 1, 3
dist_integral += (P_center(i) - C_center(ipoint,i)) * (P_center(i) - C_center(ipoint,i))
enddo
const = coef_tmp * dist_integral
do i = 0, n_pt_in
d(i) = 0.d0
enddo
call give_polynomial_mult_center_one_e_erf_opt(A_center, B_center, power_A, power_B, C_center(ipoint,1:3), n_pt_in, d, n_pt_out, p_inv_2, p_new2, P_center)
if(n_pt_out < 0) then
res_v(ipoint) = 0.d0
cycle
endif
! sum of integrals of type : int {t,[0,1]} exp-(rho.(P-Q)^2 * t^2) * t^i
accu = 0.d0
do i = 0, n_pt_out, 2
accu += d(i) * rint(i/2, const)
enddo
res_v(ipoint) = accu * coeff
enddo
endif
end subroutine NAI_pol_mult_erf_v
! ---
double precision function NAI_pol_mult_erf_with1s( A1_center, A2_center, power_A1, power_A2, alpha1, alpha2 &
, beta, B_center, C_center, n_pt_in, mu_in )
BEGIN_DOC
!
! Computes the following integral :
!
! .. math::
!
! \int dx (x - A1_x)^a_1 (x - B1_x)^a_2 \exp(-\alpha_1 (x - A1_x)^2 - \alpha_2 (x - A2_x)^2)
! \int dy (y - A1_y)^b_1 (y - B1_y)^b_2 \exp(-\alpha_1 (y - A1_y)^2 - \alpha_2 (y - A2_y)^2)
! \int dz (x - A1_z)^c_1 (z - B1_z)^c_2 \exp(-\alpha_1 (z - A1_z)^2 - \alpha_2 (z - A2_z)^2)
! \exp(-\beta (r - B)^2)
! \frac{\erf(\mu |r - R_C|)}{|r - R_C|}$.
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: n_pt_in
integer, intent(in) :: power_A1(3), power_A2(3)
double precision, intent(in) :: C_center(3), A1_center(3), A2_center(3), B_center(3)
double precision, intent(in) :: alpha1, alpha2, beta, mu_in
integer :: i, n_pt, n_pt_out
double precision :: alpha12, alpha12_inv, alpha12_inv_2, rho12, A12_center(3), dist12, const_factor12
double precision :: p, p_inv, p_inv_2, rho, P_center(3), dist, const_factor
double precision :: dist_integral
double precision :: d(0:n_pt_in), coeff, const, factor
double precision :: accu
double precision :: p_new
double precision :: rint
! e^{-alpha1 (r - A1)^2} e^{-alpha2 (r - A2)^2} = e^{-K12} e^{-alpha12 (r - A12)^2}
alpha12 = alpha1 + alpha2
alpha12_inv = 1.d0 / alpha12
alpha12_inv_2 = 0.5d0 * alpha12_inv
rho12 = alpha1 * alpha2 * alpha12_inv
A12_center(1) = (alpha1 * A1_center(1) + alpha2 * A2_center(1)) * alpha12_inv
A12_center(2) = (alpha1 * A1_center(2) + alpha2 * A2_center(2)) * alpha12_inv
A12_center(3) = (alpha1 * A1_center(3) + alpha2 * A2_center(3)) * alpha12_inv
dist12 = (A1_center(1) - A2_center(1)) * (A1_center(1) - A2_center(1)) &
+ (A1_center(2) - A2_center(2)) * (A1_center(2) - A2_center(2)) &
+ (A1_center(3) - A2_center(3)) * (A1_center(3) - A2_center(3))
const_factor12 = dist12 * rho12
if(const_factor12 > 80.d0) then
NAI_pol_mult_erf_with1s = 0.d0
return
endif
power_A1(1:3) = ao_power(i_ao,1:3)
power_A2(1:3) = ao_power(j_ao,1:3)
! ---
A1_center(1:3) = nucl_coord(ao_nucl(i_ao),1:3)
A2_center(1:3) = nucl_coord(ao_nucl(j_ao),1:3)
! e^{-K12} e^{-alpha12 (r - A12)^2} e^{-beta (r - B)^2} = e^{-K} e^{-p (r - P)^2}
p = alpha12 + beta
p_inv = 1.d0 / p
p_inv_2 = 0.5d0 * p_inv
rho = alpha12 * beta * p_inv
P_center(1) = (alpha12 * A12_center(1) + beta * B_center(1)) * p_inv
P_center(2) = (alpha12 * A12_center(2) + beta * B_center(2)) * p_inv
P_center(3) = (alpha12 * A12_center(3) + beta * B_center(3)) * p_inv
dist = (A12_center(1) - B_center(1)) * (A12_center(1) - B_center(1)) &
+ (A12_center(2) - B_center(2)) * (A12_center(2) - B_center(2)) &
+ (A12_center(3) - B_center(3)) * (A12_center(3) - B_center(3))
n_pt_in = n_pt_max_integrals
const_factor = const_factor12 + dist * rho
if(const_factor > 80.d0) then
NAI_pol_mult_erf_with1s = 0.d0
return
endif
NAI_pol_mult_erf_ao_with1s = 0.d0
do i = 1, ao_prim_num(i_ao)
alpha1 = ao_expo_ordered_transp (i,i_ao)
coef1 = ao_coef_normalized_ordered_transp(i,i_ao)
dist_integral = (P_center(1) - C_center(1)) * (P_center(1) - C_center(1)) &
+ (P_center(2) - C_center(2)) * (P_center(2) - C_center(2)) &
+ (P_center(3) - C_center(3)) * (P_center(3) - C_center(3))
do j = 1, ao_prim_num(j_ao)
alpha2 = ao_expo_ordered_transp(j,j_ao)
coef12 = coef1 * ao_coef_normalized_ordered_transp(j,j_ao)
if(dabs(coef12) .lt. 1d-14) cycle
! ---
integral = NAI_pol_mult_erf_with1s( A1_center, A2_center, power_A1, power_A2, alpha1, alpha2 &
, beta, B_center, C_center, n_pt_in, mu_in )
p_new = mu_in / dsqrt(p + mu_in * mu_in)
factor = dexp(-const_factor)
coeff = dtwo_pi * factor * p_inv * p_new
NAI_pol_mult_erf_ao_with1s += integral * coef12
enddo
n_pt = 2 * ( (power_A1(1) + power_A2(1)) + (power_A1(2) + power_A2(2)) + (power_A1(3) + power_A2(3)) )
const = p * dist_integral * p_new * p_new
if(n_pt == 0) then
NAI_pol_mult_erf_with1s = coeff * rint(0, const)
return
endif
do i = 0, n_pt_in
d(i) = 0.d0
enddo
p_new = p_new * p_new
call give_polynomial_mult_center_one_e_erf_opt( A1_center, A2_center, power_A1, power_A2, C_center, n_pt_in, d, n_pt_out, p_inv_2, p_new, P_center)
end function NAI_pol_mult_erf_ao_with1s
if(n_pt_out < 0) then
NAI_pol_mult_erf_with1s = 0.d0
return
endif
! sum of integrals of type : int {t,[0,1]} exp-(rho.(P-Q)^2 * t^2) * t^i
accu = 0.d0
do i = 0, n_pt_out, 2
accu += d(i) * rint(i/2, const)
enddo
NAI_pol_mult_erf_with1s = accu * coeff
end function NAI_pol_mult_erf_with1s
! ---
subroutine NAI_pol_mult_erf_with1s_v(A1_center, A2_center, power_A1, power_A2, alpha1, alpha2, beta, B_center, LD_B, C_center, LD_C, n_pt_in, mu_in, res_v, LD_resv, n_points)
@ -428,107 +662,6 @@ subroutine give_polynomial_mult_center_one_e_erf_opt(A_center, B_center, power_A
end subroutine give_polynomial_mult_center_one_e_erf_opt
! ---
subroutine NAI_pol_mult_erf_v(A_center, B_center, power_A, power_B, alpha, beta, C_center, LD_C, n_pt_in, mu_in, res_v, LD_resv, n_points)
BEGIN_DOC
!
! Computes the following integral :
!
! .. math::
!
! \int dr (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
! \frac{\erf(\mu |r - R_C |)}{| r - R_C |}$.
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: n_pt_in, n_points, LD_C, LD_resv
integer, intent(in) :: power_A(3), power_B(3)
double precision, intent(in) :: A_center(3), B_center(3), alpha, beta, mu_in
double precision, intent(in) :: C_center(LD_C,3)
double precision, intent(out) :: res_v(LD_resv)
integer :: i, n_pt, n_pt_out, ipoint
double precision :: P_center(3)
double precision :: d(0:n_pt_in), coeff, dist, const, factor
double precision :: const_factor, dist_integral
double precision :: accu, p_inv, p, rho, p_inv_2
double precision :: p_new, p_new2, coef_tmp
double precision :: rint
res_V(1:LD_resv) = 0.d0
p = alpha + beta
p_inv = 1.d0 / p
p_inv_2 = 0.5d0 * p_inv
rho = alpha * beta * p_inv
p_new = mu_in / dsqrt(p + mu_in * mu_in)
p_new2 = p_new * p_new
coef_tmp = p * p_new2
dist = 0.d0
do i = 1, 3
P_center(i) = (alpha * A_center(i) + beta * B_center(i)) * p_inv
dist += (A_center(i) - B_center(i)) * (A_center(i) - B_center(i))
enddo
const_factor = dist * rho
if(const_factor > 80.d0) then
return
endif
factor = dexp(-const_factor)
coeff = dtwo_pi * factor * p_inv * p_new
n_pt = 2 * ( power_A(1) + power_B(1) + power_A(2) + power_B(2) + power_A(3) + power_B(3) )
if(n_pt == 0) then
do ipoint = 1, n_points
dist_integral = 0.d0
do i = 1, 3
dist_integral += (P_center(i) - C_center(ipoint,i)) * (P_center(i) - C_center(ipoint,i))
enddo
const = coef_tmp * dist_integral
res_v(ipoint) = coeff * rint(0, const)
enddo
else
do ipoint = 1, n_points
dist_integral = 0.d0
do i = 1, 3
dist_integral += (P_center(i) - C_center(ipoint,i)) * (P_center(i) - C_center(ipoint,i))
enddo
const = coef_tmp * dist_integral
do i = 0, n_pt_in
d(i) = 0.d0
enddo
call give_polynomial_mult_center_one_e_erf_opt(A_center, B_center, power_A, power_B, C_center(ipoint,1:3), n_pt_in, d, n_pt_out, p_inv_2, p_new2, P_center)
if(n_pt_out < 0) then
res_v(ipoint) = 0.d0
cycle
endif
! sum of integrals of type : int {t,[0,1]} exp-(rho.(P-Q)^2 * t^2) * t^i
accu = 0.d0
do i = 0, n_pt_out, 2
accu += d(i) * rint(i/2, const)
enddo
res_v(ipoint) = accu * coeff
enddo
endif
end subroutine NAI_pol_mult_erf_v
subroutine give_polynomial_mult_center_one_e_erf(A_center,B_center,alpha,beta,power_A,power_B,C_center,n_pt_in,d,n_pt_out,mu_in)
@ -659,113 +792,3 @@ subroutine give_polynomial_mult_center_one_e_erf(A_center,B_center,alpha,beta,po
end
double precision function NAI_pol_mult_erf_with1s( A1_center, A2_center, power_A1, power_A2, alpha1, alpha2 &
, beta, B_center, C_center, n_pt_in, mu_in )
BEGIN_DOC
!
! Computes the following integral :
!
! .. math::
!
! \int dx (x - A1_x)^a_1 (x - B1_x)^a_2 \exp(-\alpha_1 (x - A1_x)^2 - \alpha_2 (x - A2_x)^2)
! \int dy (y - A1_y)^b_1 (y - B1_y)^b_2 \exp(-\alpha_1 (y - A1_y)^2 - \alpha_2 (y - A2_y)^2)
! \int dz (x - A1_z)^c_1 (z - B1_z)^c_2 \exp(-\alpha_1 (z - A1_z)^2 - \alpha_2 (z - A2_z)^2)
! \exp(-\beta (r - B)^2)
! \frac{\erf(\mu |r - R_C|)}{|r - R_C|}$.
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: n_pt_in
integer, intent(in) :: power_A1(3), power_A2(3)
double precision, intent(in) :: C_center(3), A1_center(3), A2_center(3), B_center(3)
double precision, intent(in) :: alpha1, alpha2, beta, mu_in
integer :: i, n_pt, n_pt_out
double precision :: alpha12, alpha12_inv, alpha12_inv_2, rho12, A12_center(3), dist12, const_factor12
double precision :: p, p_inv, p_inv_2, rho, P_center(3), dist, const_factor
double precision :: dist_integral
double precision :: d(0:n_pt_in), coeff, const, factor
double precision :: accu
double precision :: p_new
double precision :: rint
! e^{-alpha1 (r - A1)^2} e^{-alpha2 (r - A2)^2} = e^{-K12} e^{-alpha12 (r - A12)^2}
alpha12 = alpha1 + alpha2
alpha12_inv = 1.d0 / alpha12
alpha12_inv_2 = 0.5d0 * alpha12_inv
rho12 = alpha1 * alpha2 * alpha12_inv
A12_center(1) = (alpha1 * A1_center(1) + alpha2 * A2_center(1)) * alpha12_inv
A12_center(2) = (alpha1 * A1_center(2) + alpha2 * A2_center(2)) * alpha12_inv
A12_center(3) = (alpha1 * A1_center(3) + alpha2 * A2_center(3)) * alpha12_inv
dist12 = (A1_center(1) - A2_center(1)) * (A1_center(1) - A2_center(1)) &
+ (A1_center(2) - A2_center(2)) * (A1_center(2) - A2_center(2)) &
+ (A1_center(3) - A2_center(3)) * (A1_center(3) - A2_center(3))
const_factor12 = dist12 * rho12
if(const_factor12 > 80.d0) then
NAI_pol_mult_erf_with1s = 0.d0
return
endif
! ---
! e^{-K12} e^{-alpha12 (r - A12)^2} e^{-beta (r - B)^2} = e^{-K} e^{-p (r - P)^2}
p = alpha12 + beta
p_inv = 1.d0 / p
p_inv_2 = 0.5d0 * p_inv
rho = alpha12 * beta * p_inv
P_center(1) = (alpha12 * A12_center(1) + beta * B_center(1)) * p_inv
P_center(2) = (alpha12 * A12_center(2) + beta * B_center(2)) * p_inv
P_center(3) = (alpha12 * A12_center(3) + beta * B_center(3)) * p_inv
dist = (A12_center(1) - B_center(1)) * (A12_center(1) - B_center(1)) &
+ (A12_center(2) - B_center(2)) * (A12_center(2) - B_center(2)) &
+ (A12_center(3) - B_center(3)) * (A12_center(3) - B_center(3))
const_factor = const_factor12 + dist * rho
if(const_factor > 80.d0) then
NAI_pol_mult_erf_with1s = 0.d0
return
endif
dist_integral = (P_center(1) - C_center(1)) * (P_center(1) - C_center(1)) &
+ (P_center(2) - C_center(2)) * (P_center(2) - C_center(2)) &
+ (P_center(3) - C_center(3)) * (P_center(3) - C_center(3))
! ---
p_new = mu_in / dsqrt(p + mu_in * mu_in)
factor = dexp(-const_factor)
coeff = dtwo_pi * factor * p_inv * p_new
n_pt = 2 * ( (power_A1(1) + power_A2(1)) + (power_A1(2) + power_A2(2)) + (power_A1(3) + power_A2(3)) )
const = p * dist_integral * p_new * p_new
if(n_pt == 0) then
NAI_pol_mult_erf_with1s = coeff * rint(0, const)
return
endif
do i = 0, n_pt_in
d(i) = 0.d0
enddo
p_new = p_new * p_new
call give_polynomial_mult_center_one_e_erf_opt( A1_center, A2_center, power_A1, power_A2, C_center, n_pt_in, d, n_pt_out, p_inv_2, p_new, P_center)
if(n_pt_out < 0) then
NAI_pol_mult_erf_with1s = 0.d0
return
endif
! sum of integrals of type : int {t,[0,1]} exp-(rho.(P-Q)^2 * t^2) * t^i
accu = 0.d0
do i = 0, n_pt_out, 2
accu += d(i) * rint(i/2, const)
enddo
NAI_pol_mult_erf_with1s = accu * coeff
end function NAI_pol_mult_erf_with1s

179
src/ao_one_e_ints/pot_ao_ints.irp.f
View File

@ -1,4 +1,8 @@
! ---
BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
BEGIN_DOC
! Nucleus-electron interaction, in the |AO| basis set.
!
@ -6,84 +10,100 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
!
! These integrals also contain the pseudopotential integrals.
END_DOC
implicit none
double precision :: alpha, beta, gama, delta
integer :: num_A,num_B
double precision :: A_center(3),B_center(3),C_center(3)
integer :: power_A(3),power_B(3)
integer :: i,j,k,l,n_pt_in,m
double precision :: overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult
integer :: num_A, num_B, power_A(3), power_B(3)
integer :: i, j, k, l, n_pt_in, m
double precision :: alpha, beta
double precision :: A_center(3),B_center(3),C_center(3)
double precision :: overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult
ao_integrals_n_e = 0.d0
if (read_ao_integrals_n_e) then
call ezfio_get_ao_one_e_ints_ao_integrals_n_e(ao_integrals_n_e)
print *, 'AO N-e integrals read from disk'
else
ao_integrals_n_e = 0.d0
if(use_cosgtos) then
!print *, " use_cosgtos for ao_integrals_n_e ?", use_cosgtos
! _
! /| / |_)
! | / | \
!
do j = 1, ao_num
do i = 1, ao_num
ao_integrals_n_e(i,j) = ao_integrals_n_e_cosgtos(i,j)
enddo
enddo
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B,&
!$OMP num_A,num_B,Z,c,n_pt_in) &
!$OMP SHARED (ao_num,ao_prim_num,ao_expo_ordered_transp,ao_power,ao_nucl,nucl_coord,ao_coef_normalized_ordered_transp,&
!$OMP n_pt_max_integrals,ao_integrals_n_e,nucl_num,nucl_charge)
else
n_pt_in = n_pt_max_integrals
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B,&
!$OMP num_A,num_B,Z,c,c1,n_pt_in) &
!$OMP SHARED (ao_num,ao_prim_num,ao_expo_ordered_transp,ao_power,ao_nucl,nucl_coord,ao_coef_normalized_ordered_transp,&
!$OMP n_pt_max_integrals,ao_integrals_n_e,nucl_num,nucl_charge)
!$OMP DO SCHEDULE (dynamic)
n_pt_in = n_pt_max_integrals
do j = 1, ao_num
num_A = ao_nucl(j)
power_A(1:3)= ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
!$OMP DO SCHEDULE (dynamic)
do i = 1, ao_num
do j = 1, ao_num
num_A = ao_nucl(j)
power_A(1:3)= ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
num_B = ao_nucl(i)
power_B(1:3)= ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do i = 1, ao_num
do l=1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
num_B = ao_nucl(i)
power_B(1:3)= ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do m=1,ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
do l=1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
double precision :: c
c = 0.d0
do m=1,ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
do k = 1, nucl_num
double precision :: Z
Z = nucl_charge(k)
double precision :: c, c1
c = 0.d0
C_center(1:3) = nucl_coord(k,1:3)
do k = 1, nucl_num
double precision :: Z
Z = nucl_charge(k)
c = c - Z * NAI_pol_mult(A_center,B_center, &
power_A,power_B,alpha,beta,C_center,n_pt_in)
C_center(1:3) = nucl_coord(k,1:3)
!print *, ' '
!print *, A_center, B_center, C_center, power_A, power_B
!print *, alpha, beta
c1 = NAI_pol_mult( A_center, B_center, power_A, power_B &
, alpha, beta, C_center, n_pt_in )
!print *, ' c1 = ', c1
c = c - Z * c1
enddo
ao_integrals_n_e(i,j) = ao_integrals_n_e(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c
enddo
ao_integrals_n_e(i,j) = ao_integrals_n_e(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
IF (DO_PSEUDO) THEN
endif
IF(do_pseudo) THEN
ao_integrals_n_e += ao_pseudo_integrals
ENDIF
IF(point_charges) THEN
ao_integrals_n_e += ao_integrals_pt_chrg
ENDIF
endif
@ -102,7 +122,7 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e_imag, (ao_num,ao_num)]
! :math:`\langle \chi_i | -\sum_A \frac{1}{|r-R_A|} | \chi_j \rangle`
END_DOC
implicit none
double precision :: alpha, beta, gama, delta
double precision :: alpha, beta
integer :: num_A,num_B
double precision :: A_center(3),B_center(3),C_center(3)
integer :: power_A(3),power_B(3)
@ -125,7 +145,7 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e_per_atom, (ao_num,ao_num,nuc
! :math:`\langle \chi_i | -\frac{1}{|r-R_A|} | \chi_j \rangle`
END_DOC
implicit none
double precision :: alpha, beta, gama, delta
double precision :: alpha, beta
integer :: i_c,num_A,num_B
double precision :: A_center(3),B_center(3),C_center(3)
integer :: power_A(3),power_B(3)
@ -268,6 +288,7 @@ double precision function NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,b
end
! ---
subroutine give_polynomial_mult_center_one_e(A_center,B_center,alpha,beta,power_A,power_B,C_center,n_pt_in,d,n_pt_out)
implicit none
@ -579,61 +600,3 @@ double precision function V_r(n,alpha)
end
double precision function V_phi(n,m)
implicit none
BEGIN_DOC
! Computes the angular $\phi$ part of the nuclear attraction integral:
!
! $\int_{0}^{2 \pi} \cos(\phi)^n \sin(\phi)^m d\phi$.
END_DOC
integer :: n,m, i
double precision :: prod, Wallis
prod = 1.d0
do i = 0,shiftr(n,1)-1
prod = prod/ (1.d0 + dfloat(m+1)/dfloat(n-i-i-1))
enddo
V_phi = 4.d0 * prod * Wallis(m)
end
double precision function V_theta(n,m)
implicit none
BEGIN_DOC
! Computes the angular $\theta$ part of the nuclear attraction integral:
!
! $\int_{0}^{\pi} \cos(\theta)^n \sin(\theta)^m d\theta$
END_DOC
integer :: n,m,i
double precision :: Wallis, prod
include 'utils/constants.include.F'
V_theta = 0.d0
prod = 1.d0
do i = 0,shiftr(n,1)-1
prod = prod / (1.d0 + dfloat(m+1)/dfloat(n-i-i-1))
enddo
V_theta = (prod+prod) * Wallis(m)
end
double precision function Wallis(n)
implicit none
BEGIN_DOC
! Wallis integral:
!
! $\int_{0}^{\pi} \cos(\theta)^n d\theta$.
END_DOC
double precision :: fact
integer :: n,p
include 'utils/constants.include.F'
if(iand(n,1).eq.0)then
Wallis = fact(shiftr(n,1))
Wallis = pi * fact(n) / (dble(ibset(0_8,n)) * (Wallis+Wallis)*Wallis)
else
p = shiftr(n,1)
Wallis = fact(p)
Wallis = dble(ibset(0_8,p+p)) * Wallis*Wallis / fact(p+p+1)
endif
end

9
src/ao_two_e_ints/EZFIO.cfg
View File

@ -4,13 +4,6 @@ doc: Read/Write |AO| integrals from/to disk [ Write | Read | None ]
interface: ezfio,provider,ocaml
default: None
[ao_integrals_threshold]
type: Threshold
doc: If | (pq|rs) | < `ao_integrals_threshold` then (pq|rs) is zero
interface: ezfio,provider,ocaml
default: 1.e-15
ezfio_name: threshold_ao
[do_direct_integrals]
type: logical
doc: Compute integrals on the fly (very slow, only for debugging)
@ -22,4 +15,4 @@ ezfio_name: direct
type: logical
doc: Perform Cholesky decomposition of AO integrals
interface: ezfio,provider,ocaml
default: True
default: False

195
src/ao_two_e_ints/two_e_integrals.irp.f
View File

@ -1,102 +1,123 @@
double precision function ao_two_e_integral(i,j,k,l)
implicit none
! ---
double precision function ao_two_e_integral(i, j, k, l)
BEGIN_DOC
! integral of the AO basis <ik|jl> or (ij|kl)
! i(r1) j(r1) 1/r12 k(r2) l(r2)
END_DOC
integer,intent(in) :: i,j,k,l
integer :: p,q,r,s
double precision :: I_center(3),J_center(3),K_center(3),L_center(3)
integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3)
double precision :: integral
implicit none
include 'utils/constants.include.F'
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s
integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3)
integer :: iorder_p(3), iorder_q(3)
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: integral
double precision :: P_new(0:max_dim,3),P_center(3),fact_p,pp
double precision :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq
integer :: iorder_p(3), iorder_q(3)
double precision :: ao_two_e_integral_schwartz_accel
if (ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then
ao_two_e_integral = ao_two_e_integral_schwartz_accel(i,j,k,l)
else
double precision :: ao_two_e_integral_cosgtos
dim1 = n_pt_max_integrals
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
ao_two_e_integral = 0.d0
if(use_cosgtos) then
!print *, ' use_cosgtos for ao_two_e_integral ?', use_cosgtos
if (num_i /= num_j .or. num_k /= num_l .or. num_j /= num_k)then
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
ao_two_e_integral = ao_two_e_integral_cosgtos(i, j, k, l)
double precision :: coef1, coef2, coef3, coef4
double precision :: p_inv,q_inv
double precision :: general_primitive_integral
else
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p,i)
do q = 1, ao_prim_num(j)
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,&
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), &
I_power,J_power,I_center,J_center,dim1)
p_inv = 1.d0/pp
do r = 1, ao_prim_num(k)
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
do s = 1, ao_prim_num(l)
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,&
ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), &
K_power,L_power,K_center,L_center,dim1)
q_inv = 1.d0/qq
integral = general_primitive_integral(dim1, &
P_new,P_center,fact_p,pp,p_inv,iorder_p, &
Q_new,Q_center,fact_q,qq,q_inv,iorder_q)
ao_two_e_integral = ao_two_e_integral + coef4 * integral
enddo ! s
enddo ! r
enddo ! q
enddo ! p
if (ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then
ao_two_e_integral = ao_two_e_integral_schwartz_accel(i,j,k,l)
else
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
enddo
double precision :: ERI
dim1 = n_pt_max_integrals
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p,i)
do q = 1, ao_prim_num(j)
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
do r = 1, ao_prim_num(k)
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
do s = 1, ao_prim_num(l)
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
integral = ERI( &
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),&
I_power(1),J_power(1),K_power(1),L_power(1), &
I_power(2),J_power(2),K_power(2),L_power(2), &
I_power(3),J_power(3),K_power(3),L_power(3))
ao_two_e_integral = ao_two_e_integral + coef4 * integral
enddo ! s
enddo ! r
enddo ! q
enddo ! p
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
ao_two_e_integral = 0.d0
if (num_i /= num_j .or. num_k /= num_l .or. num_j /= num_k)then
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
double precision :: coef1, coef2, coef3, coef4
double precision :: p_inv,q_inv
double precision :: general_primitive_integral
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p,i)
do q = 1, ao_prim_num(j)
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,&
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), &
I_power,J_power,I_center,J_center,dim1)
p_inv = 1.d0/pp
do r = 1, ao_prim_num(k)
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
do s = 1, ao_prim_num(l)
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,&
ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), &
K_power,L_power,K_center,L_center,dim1)
q_inv = 1.d0/qq
integral = general_primitive_integral(dim1, &
P_new,P_center,fact_p,pp,p_inv,iorder_p, &
Q_new,Q_center,fact_q,qq,q_inv,iorder_q)
ao_two_e_integral = ao_two_e_integral + coef4 * integral
enddo ! s
enddo ! r
enddo ! q
enddo ! p
else
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
enddo
double precision :: ERI
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p,i)
do q = 1, ao_prim_num(j)
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
do r = 1, ao_prim_num(k)
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
do s = 1, ao_prim_num(l)
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
integral = ERI( &
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),&
I_power(1),J_power(1),K_power(1),L_power(1), &
I_power(2),J_power(2),K_power(2),L_power(2), &
I_power(3),J_power(3),K_power(3),L_power(3))
ao_two_e_integral = ao_two_e_integral + coef4 * integral
enddo ! s
enddo ! r
enddo ! q
enddo ! p
endif
endif
@ -104,6 +125,8 @@ double precision function ao_two_e_integral(i,j,k,l)
end
! ---
double precision function ao_two_e_integral_schwartz_accel(i,j,k,l)
implicit none
BEGIN_DOC
@ -421,14 +444,17 @@ BEGIN_PROVIDER [ logical, ao_two_e_integrals_in_map ]
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_two_e_integral_schwartz,(ao_num,ao_num) ]
implicit none
! ---
BEGIN_PROVIDER [ double precision, ao_two_e_integral_schwartz, (ao_num, ao_num) ]
BEGIN_DOC
! Needed to compute Schwartz inequalities
END_DOC
integer :: i,k
double precision :: ao_two_e_integral,cpu_1,cpu_2, wall_1, wall_2
implicit none
integer :: i, k
double precision :: ao_two_e_integral,cpu_1,cpu_2, wall_1, wall_2
ao_two_e_integral_schwartz(1,1) = ao_two_e_integral(1,1,1,1)
!$OMP PARALLEL DO PRIVATE(i,k) &
@ -445,6 +471,7 @@ BEGIN_PROVIDER [ double precision, ao_two_e_integral_schwartz,(ao_num,ao_num) ]
END_PROVIDER
! ---
double precision function general_primitive_integral(dim, &
P_new,P_center,fact_p,p,p_inv,iorder_p, &

12
src/becke_numerical_grid/EZFIO.cfg
View File

@ -64,3 +64,15 @@ doc: Number of angular extra_grid points given from input. Warning, this number
interface: ezfio,provider,ocaml
default: 1202
[rad_grid_type]
type: character*(32)
doc: method used to sample the radial space. Possible choices are [KNOWLES | GILL]
interface: ezfio,provider,ocaml
default: KNOWLES
[extra_rad_grid_type]
type: character*(32)
doc: method used to sample the radial space. Possible choices are [KNOWLES | GILL]
interface: ezfio,provider,ocaml
default: KNOWLES

278
src/becke_numerical_grid/extra_grid.irp.f
View File

@ -1,96 +1,149 @@
! ---
BEGIN_PROVIDER [integer, n_points_extra_radial_grid]
&BEGIN_PROVIDER [integer, n_points_extra_integration_angular]
implicit none
BEGIN_DOC
! n_points_extra_radial_grid = number of radial grid points_extra per atom
!
! n_points_extra_integration_angular = number of angular grid points_extra per atom
!
! These numbers are automatically set by setting the grid_type_sgn parameter
END_DOC
if(.not.my_extra_grid_becke)then
select case (extra_grid_type_sgn)
case(0)
n_points_extra_radial_grid = 23
n_points_extra_integration_angular = 170
case(1)
n_points_extra_radial_grid = 50
n_points_extra_integration_angular = 194
case(2)
n_points_extra_radial_grid = 75
n_points_extra_integration_angular = 302
case(3)
n_points_extra_radial_grid = 99
n_points_extra_integration_angular = 590
case default
write(*,*) '!!! Quadrature grid not available !!!'
stop
end select
else
n_points_extra_radial_grid = my_n_pt_r_extra_grid
n_points_extra_integration_angular = my_n_pt_a_extra_grid
endif
BEGIN_DOC
! n_points_extra_radial_grid = number of radial grid points_extra per atom
!
! n_points_extra_integration_angular = number of angular grid points_extra per atom
!
! These numbers are automatically set by setting the grid_type_sgn parameter
END_DOC
implicit none
if(.not.my_extra_grid_becke)then
select case (extra_grid_type_sgn)
case(0)
n_points_extra_radial_grid = 23
n_points_extra_integration_angular = 170
case(1)
n_points_extra_radial_grid = 50
n_points_extra_integration_angular = 194
case(2)
n_points_extra_radial_grid = 75
n_points_extra_integration_angular = 302
case(3)
n_points_extra_radial_grid = 99
n_points_extra_integration_angular = 590
case default
write(*,*) '!!! Quadrature grid not available !!!'
stop
end select
else
n_points_extra_radial_grid = my_n_pt_r_extra_grid
n_points_extra_integration_angular = my_n_pt_a_extra_grid
endif
END_PROVIDER
! ---
BEGIN_PROVIDER [integer, n_points_extra_grid_per_atom]
implicit none
BEGIN_DOC
! Number of grid points_extra per atom
END_DOC
implicit none
n_points_extra_grid_per_atom = n_points_extra_integration_angular * n_points_extra_radial_grid
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, grid_points_extra_radial, (n_points_extra_radial_grid)]
&BEGIN_PROVIDER [double precision, dr_radial_extra_integral]
implicit none
BEGIN_DOC
! points_extra in [0,1] to map the radial integral [0,\infty]
END_DOC
implicit none
integer :: i
dr_radial_extra_integral = 1.d0/dble(n_points_extra_radial_grid-1)
integer :: i
do i = 1, n_points_extra_radial_grid
grid_points_extra_radial(i) = dble(i-1) * dr_radial_extra_integral
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, grid_points_extra_per_atom, (3,n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)]
BEGIN_DOC
! x,y,z coordinates of grid points_extra used for integration in 3d space
END_DOC
implicit none
integer :: i,j,k
double precision :: dr,x_ref,y_ref,z_ref
double precision :: knowles_function
do i = 1, nucl_num
x_ref = nucl_coord(i,1)
y_ref = nucl_coord(i,2)
z_ref = nucl_coord(i,3)
do j = 1, n_points_extra_radial_grid-1
double precision :: x,r
! x value for the mapping of the [0, +\infty] to [0,1]
x = grid_points_extra_radial(j)
integer :: i, j, k
double precision :: dr, x_ref, y_ref, z_ref
double precision :: x, r, tmp
double precision, external :: knowles_function
! value of the radial coordinate for the integration
r = knowles_function(alpha_knowles(grid_atomic_number(i)),m_knowles,x)
grid_points_extra_per_atom = 0.d0
! explicit values of the grid points_extra centered around each atom
do k = 1, n_points_extra_integration_angular
grid_points_extra_per_atom(1,k,j,i) = &
x_ref + angular_quadrature_points_extra(k,1) * r
grid_points_extra_per_atom(2,k,j,i) = &
y_ref + angular_quadrature_points_extra(k,2) * r
grid_points_extra_per_atom(3,k,j,i) = &
z_ref + angular_quadrature_points_extra(k,3) * r
PROVIDE extra_rad_grid_type
if(extra_rad_grid_type .eq. "KNOWLES") then
do i = 1, nucl_num
x_ref = nucl_coord(i,1)
y_ref = nucl_coord(i,2)
z_ref = nucl_coord(i,3)
do j = 1, n_points_extra_radial_grid-1
! x value for the mapping of the [0, +\infty] to [0,1]
x = grid_points_extra_radial(j)
! value of the radial coordinate for the integration
r = knowles_function(alpha_knowles(grid_atomic_number(i)), m_knowles, x)
! explicit values of the grid points_extra centered around each atom
do k = 1, n_points_extra_integration_angular
grid_points_extra_per_atom(1,k,j,i) = x_ref + angular_quadrature_points_extra(k,1) * r
grid_points_extra_per_atom(2,k,j,i) = y_ref + angular_quadrature_points_extra(k,2) * r
grid_points_extra_per_atom(3,k,j,i) = z_ref + angular_quadrature_points_extra(k,3) * r
enddo
enddo
enddo
enddo
elseif(extra_rad_grid_type .eq. "GILL") then
! GILL & CHIEN, 2002
do i = 1, nucl_num
x_ref = nucl_coord(i,1)
y_ref = nucl_coord(i,2)
z_ref = nucl_coord(i,3)
do j = 1, n_points_extra_radial_grid-1
r = R_gill * dble(j-1)**2 / dble(n_points_extra_radial_grid-j+1)**2
! explicit values of the grid points_extra centered around each atom
do k = 1, n_points_extra_integration_angular
grid_points_extra_per_atom(1,k,j,i) = x_ref + angular_quadrature_points_extra(k,1) * r
grid_points_extra_per_atom(2,k,j,i) = y_ref + angular_quadrature_points_extra(k,2) * r
grid_points_extra_per_atom(3,k,j,i) = z_ref + angular_quadrature_points_extra(k,3) * r
enddo
enddo
enddo
else
print*, " extra_rad_grid_type = ", extra_rad_grid_type, ' is not implemented'
stop
endif
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, weight_at_r_extra, (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num) ]
BEGIN_DOC
! Weight function at grid points_extra : w_n(r) according to the equation (22)
! of Becke original paper (JCP, 88, 1988)
@ -99,11 +152,14 @@ BEGIN_PROVIDER [double precision, weight_at_r_extra, (n_points_extra_integration
! represented by the last dimension and the points_extra are labelled by the
! other dimensions.
END_DOC
implicit none
integer :: i,j,k,l,m
double precision :: r(3)
double precision :: accu,cell_function_becke
double precision :: tmp_array(nucl_num)
integer :: i, j, k, l, m
double precision :: r(3)
double precision :: accu
double precision :: tmp_array(nucl_num)
double precision, external :: cell_function_becke
! run over all points_extra in space
! that are referred to each atom
do j = 1, nucl_num
@ -114,6 +170,7 @@ BEGIN_PROVIDER [double precision, weight_at_r_extra, (n_points_extra_integration
r(1) = grid_points_extra_per_atom(1,l,k,j)
r(2) = grid_points_extra_per_atom(2,l,k,j)
r(3) = grid_points_extra_per_atom(3,l,k,j)
accu = 0.d0
! For each of these points_extra in space, ou need to evaluate the P_n(r)
do i = 1, nucl_num
@ -124,18 +181,19 @@ BEGIN_PROVIDER [double precision, weight_at_r_extra, (n_points_extra_integration
enddo
accu = 1.d0/accu
weight_at_r_extra(l,k,j) = tmp_array(j) * accu
if(isnan(weight_at_r_extra(l,k,j)))then
print*,'isnan(weight_at_r_extra(l,k,j))'
print*,l,k,j
accu = 0.d0
do i = 1, nucl_num
! function defined for each atom "i" by equation (13) and (21) with k == 3
tmp_array(i) = cell_function_becke(r,i) ! P_n(r)
print*,i,tmp_array(i)
! Then you compute the summ the P_n(r) function for each of the "r" points_extra
accu += tmp_array(i)
enddo
write(*,'(100(F16.10,X))')tmp_array(j) , accu
print*,'isnan(weight_at_r_extra(l,k,j))'
print*,l,k,j
accu = 0.d0
do i = 1, nucl_num
! function defined for each atom "i" by equation (13) and (21) with k == 3
tmp_array(i) = cell_function_becke(r,i) ! P_n(r)
print*,i,tmp_array(i)
! Then you compute the summ the P_n(r) function for each of the "r" points_extra
accu += tmp_array(i)
enddo
write(*,'(100(F16.10,X))')tmp_array(j) , accu
stop
endif
enddo
@ -144,35 +202,73 @@ BEGIN_PROVIDER [double precision, weight_at_r_extra, (n_points_extra_integration
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, final_weight_at_r_extra, (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num) ]
BEGIN_DOC
! Total weight on each grid point which takes into account all Lebedev, Voronoi and radial weights.
END_DOC
implicit none
integer :: i,j,k,l,m
double precision :: r(3)
double precision :: accu,cell_function_becke
double precision :: tmp_array(nucl_num)
double precision :: contrib_integration,x
double precision :: derivative_knowles_function,knowles_function
! run over all points_extra in space
do j = 1, nucl_num ! that are referred to each atom
do i = 1, n_points_extra_radial_grid -1 !for each radial grid attached to the "jth" atom
x = grid_points_extra_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1]
do k = 1, n_points_extra_integration_angular ! for each angular point attached to the "jth" atom
contrib_integration = derivative_knowles_function(alpha_knowles(grid_atomic_number(j)),m_knowles,x)&
*knowles_function(alpha_knowles(grid_atomic_number(j)),m_knowles,x)**2
final_weight_at_r_extra(k,i,j) = weights_angular_points_extra(k) * weight_at_r_extra(k,i,j) * contrib_integration * dr_radial_extra_integral
if(isnan(final_weight_at_r_extra(k,i,j)))then
print*,'isnan(final_weight_at_r_extra(k,i,j))'
print*,k,i,j
write(*,'(100(F16.10,X))')weights_angular_points_extra(k) , weight_at_r_extra(k,i,j) , contrib_integration , dr_radial_extra_integral
stop
endif
integer :: i, j, k, l, m
double precision :: r(3)
double precision :: tmp_array(nucl_num)
double precision :: contrib_integration, x, tmp
double precision, external :: derivative_knowles_function, knowles_function
PROVIDE extra_rad_grid_type
if(extra_rad_grid_type .eq. "KNOWLES") then
! run over all points_extra in space
do j = 1, nucl_num ! that are referred to each atom
do i = 1, n_points_extra_radial_grid -1 !for each radial grid attached to the "jth" atom
x = grid_points_extra_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1]
do k = 1, n_points_extra_integration_angular ! for each angular point attached to the "jth" atom
contrib_integration = derivative_knowles_function(alpha_knowles(grid_atomic_number(j)),m_knowles,x)&
* knowles_function(alpha_knowles(grid_atomic_number(j)),m_knowles,x)**2
final_weight_at_r_extra(k,i,j) = weights_angular_points_extra(k) * weight_at_r_extra(k,i,j) * contrib_integration * dr_radial_extra_integral
if(isnan(final_weight_at_r_extra(k,i,j)))then
print*,'isnan(final_weight_at_r_extra(k,i,j))'
print*,k,i,j
write(*,'(100(F16.10,X))')weights_angular_points_extra(k) , weight_at_r_extra(k,i,j) , contrib_integration , dr_radial_extra_integral
stop
endif
enddo
enddo
enddo
enddo
elseif(extra_rad_grid_type .eq. "GILL") then
! GILL & CHIEN, 2002
PROVIDE R_gill
tmp = 2.d0 * R_gill * R_gill * R_gill * dble(n_points_extra_radial_grid)
! run over all points_extra in space
do j = 1, nucl_num ! that are referred to each atom
do i = 1, n_points_extra_radial_grid -1 !for each radial grid attached to the "jth" atom
contrib_integration = tmp * dble(i-1)**5 / dble(n_points_extra_radial_grid-i+1)**7
do k = 1, n_points_extra_integration_angular ! for each angular point attached to the "jth" atom
final_weight_at_r_extra(k,i,j) = weights_angular_points_extra(k) * weight_at_r_extra(k,i,j) * contrib_integration
if(isnan(final_weight_at_r_extra(k,i,j)))then
print*,'isnan(final_weight_at_r_extra(k,i,j))'
print*,k,i,j
write(*,'(100(F16.10,X))') weights_angular_points_extra(k), weight_at_r_extra(k,i,j), contrib_integration
stop
endif
enddo
enddo
enddo
else
print*, " extra_rad_grid_type = ", extra_rad_grid_type, ' is not implemented'
stop
endif
END_PROVIDER

15
src/becke_numerical_grid/extra_grid_vector.irp.f
View File

@ -1,26 +1,35 @@
! ---
BEGIN_PROVIDER [integer, n_points_extra_final_grid]
implicit none
BEGIN_DOC
! Number of points_extra which are non zero
END_DOC
integer :: i,j,k,l
implicit none
integer :: i, j, k, l
n_points_extra_final_grid = 0
do j = 1, nucl_num
do i = 1, n_points_extra_radial_grid -1
do k = 1, n_points_extra_integration_angular
if(dabs(final_weight_at_r_extra(k,i,j)) < thresh_extra_grid)then
if(dabs(final_weight_at_r_extra(k,i,j)) < thresh_extra_grid) then
cycle
endif
n_points_extra_final_grid += 1
enddo
enddo
enddo
print*,'n_points_extra_final_grid = ',n_points_extra_final_grid
print*,'n max point = ',n_points_extra_integration_angular*(n_points_extra_radial_grid*nucl_num - 1)
! call ezfio_set_becke_numerical_grid_n_points_extra_final_grid(n_points_extra_final_grid)
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, final_grid_points_extra, (3,n_points_extra_final_grid)]
&BEGIN_PROVIDER [double precision, final_weight_at_r_vector_extra, (n_points_extra_final_grid) ]
&BEGIN_PROVIDER [integer, index_final_points_extra, (3,n_points_extra_final_grid) ]

314
src/becke_numerical_grid/grid_becke.irp.f
View File

@ -1,103 +1,174 @@
! ---
BEGIN_PROVIDER [integer, n_points_radial_grid]
&BEGIN_PROVIDER [integer, n_points_integration_angular]
implicit none
BEGIN_DOC
! n_points_radial_grid = number of radial grid points per atom
!
! n_points_integration_angular = number of angular grid points per atom
!
! These numbers are automatically set by setting the grid_type_sgn parameter
END_DOC
if(.not.my_grid_becke)then
select case (grid_type_sgn)
case(0)
n_points_radial_grid = 23
n_points_integration_angular = 170
case(1)
n_points_radial_grid = 50
n_points_integration_angular = 194
case(2)
n_points_radial_grid = 75
n_points_integration_angular = 302
case(3)
n_points_radial_grid = 99
n_points_integration_angular = 590
case default
write(*,*) '!!! Quadrature grid not available !!!'
stop
end select
else
n_points_radial_grid = my_n_pt_r_grid
n_points_integration_angular = my_n_pt_a_grid
endif
BEGIN_DOC
! n_points_radial_grid = number of radial grid points per atom
!
! n_points_integration_angular = number of angular grid points per atom
!
! These numbers are automatically set by setting the grid_type_sgn parameter
END_DOC
implicit none
if(.not.my_grid_becke)then
select case (grid_type_sgn)
case(0)
n_points_radial_grid = 23
n_points_integration_angular = 170
case(1)
n_points_radial_grid = 50
n_points_integration_angular = 194
case(2)
n_points_radial_grid = 75
n_points_integration_angular = 302
case(3)
n_points_radial_grid = 99
n_points_integration_angular = 590
case default
write(*,*) '!!! Quadrature grid not available !!!'
stop
end select
else
n_points_radial_grid = my_n_pt_r_grid
n_points_integration_angular = my_n_pt_a_grid
endif
END_PROVIDER
! ---
BEGIN_PROVIDER [integer, n_points_grid_per_atom]
implicit none
BEGIN_DOC
! Number of grid points per atom
END_DOC
implicit none
n_points_grid_per_atom = n_points_integration_angular * n_points_radial_grid
END_PROVIDER
BEGIN_PROVIDER [integer , m_knowles]
implicit none
! ---
BEGIN_PROVIDER [integer, m_knowles]
BEGIN_DOC
! value of the "m" parameter in the equation (7) of the paper of Knowles (JCP, 104, 1996)
END_DOC
implicit none
m_knowles = 3
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, R_gill]
implicit none
R_gill = 3.d0
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, grid_points_radial, (n_points_radial_grid)]
&BEGIN_PROVIDER [double precision, dr_radial_integral]
implicit none
BEGIN_DOC
! points in [0,1] to map the radial integral [0,\infty]
END_DOC
dr_radial_integral = 1.d0/dble(n_points_radial_grid-1)
integer :: i
implicit none
integer :: i
dr_radial_integral = 1.d0 / dble(n_points_radial_grid-1)
do i = 1, n_points_radial_grid
grid_points_radial(i) = dble(i-1) * dr_radial_integral
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_angular,n_points_radial_grid,nucl_num)]
BEGIN_DOC
! x,y,z coordinates of grid points used for integration in 3d space
END_DOC
implicit none
integer :: i,j,k
double precision :: dr,x_ref,y_ref,z_ref
double precision :: knowles_function
do i = 1, nucl_num
x_ref = nucl_coord(i,1)
y_ref = nucl_coord(i,2)
z_ref = nucl_coord(i,3)
do j = 1, n_points_radial_grid-1
double precision :: x,r
! x value for the mapping of the [0, +\infty] to [0,1]
x = grid_points_radial(j)
integer :: i, j, k
double precision :: dr, x_ref, y_ref, z_ref
double precision :: x, r, tmp
double precision, external :: knowles_function
! value of the radial coordinate for the integration
r = knowles_function(alpha_knowles(grid_atomic_number(i)),m_knowles,x)
grid_points_per_atom = 0.d0
! explicit values of the grid points centered around each atom
do k = 1, n_points_integration_angular
grid_points_per_atom(1,k,j,i) = &
x_ref + angular_quadrature_points(k,1) * r
grid_points_per_atom(2,k,j,i) = &
y_ref + angular_quadrature_points(k,2) * r
grid_points_per_atom(3,k,j,i) = &
z_ref + angular_quadrature_points(k,3) * r
PROVIDE rad_grid_type
if(rad_grid_type .eq. "KNOWLES") then
do i = 1, nucl_num
x_ref = nucl_coord(i,1)
y_ref = nucl_coord(i,2)
z_ref = nucl_coord(i,3)
do j = 1, n_points_radial_grid-1
! x value for the mapping of the [0, +\infty] to [0,1]
x = grid_points_radial(j)
! value of the radial coordinate for the integration
r = knowles_function(alpha_knowles(grid_atomic_number(i)), m_knowles, x)
! explicit values of the grid points centered around each atom
do k = 1, n_points_integration_angular
grid_points_per_atom(1,k,j,i) = x_ref + angular_quadrature_points(k,1) * r
grid_points_per_atom(2,k,j,i) = y_ref + angular_quadrature_points(k,2) * r
grid_points_per_atom(3,k,j,i) = z_ref + angular_quadrature_points(k,3) * r
enddo
enddo
enddo
enddo
elseif(rad_grid_type .eq. "GILL") then
! GILL & CHIEN, 2002
do i = 1, nucl_num
x_ref = nucl_coord(i,1)
y_ref = nucl_coord(i,2)
z_ref = nucl_coord(i,3)
do j = 1, n_points_radial_grid-1
r = R_gill * dble(j-1)**2 / dble(n_points_radial_grid-j+1)**2
! explicit values of the grid points centered around each atom
do k = 1, n_points_integration_angular
grid_points_per_atom(1,k,j,i) = x_ref + angular_quadrature_points(k,1) * r
grid_points_per_atom(2,k,j,i) = y_ref + angular_quadrature_points(k,2) * r
grid_points_per_atom(3,k,j,i) = z_ref + angular_quadrature_points(k,3) * r
enddo
enddo
enddo
else
print*, " rad_grid_type = ", rad_grid_type, ' is not implemented'
stop
endif
END_PROVIDER
BEGIN_PROVIDER [double precision, weight_at_r, (n_points_integration_angular,n_points_radial_grid,nucl_num) ]
! ---
BEGIN_PROVIDER [double precision, weight_at_r, (n_points_integration_angular,n_points_radial_grid,nucl_num)]
BEGIN_DOC
! Weight function at grid points : w_n(r) according to the equation (22)
! of Becke original paper (JCP, 88, 1988)
@ -106,11 +177,13 @@ BEGIN_PROVIDER [double precision, weight_at_r, (n_points_integration_angular,n_p
! represented by the last dimension and the points are labelled by the
! other dimensions.
END_DOC
implicit none
integer :: i,j,k,l,m
double precision :: r(3)
double precision :: accu,cell_function_becke
double precision :: tmp_array(nucl_num)
integer :: i, j, k, l, m
double precision :: r(3), accu
double precision :: tmp_array(nucl_num)
double precision, external :: cell_function_becke
! run over all points in space
! that are referred to each atom
do j = 1, nucl_num
@ -121,28 +194,30 @@ BEGIN_PROVIDER [double precision, weight_at_r, (n_points_integration_angular,n_p
r(1) = grid_points_per_atom(1,l,k,j)
r(2) = grid_points_per_atom(2,l,k,j)
r(3) = grid_points_per_atom(3,l,k,j)
accu = 0.d0
! For each of these points in space, ou need to evaluate the P_n(r)
do i = 1, nucl_num
! function defined for each atom "i" by equation (13) and (21) with k == 3
tmp_array(i) = cell_function_becke(r,i) ! P_n(r)
tmp_array(i) = cell_function_becke(r, i) ! P_n(r)
! Then you compute the summ the P_n(r) function for each of the "r" points
accu += tmp_array(i)
enddo
accu = 1.d0/accu
weight_at_r(l,k,j) = tmp_array(j) * accu
if(isnan(weight_at_r(l,k,j)))then
print*,'isnan(weight_at_r(l,k,j))'
print*,l,k,j
accu = 0.d0
do i = 1, nucl_num
! function defined for each atom "i" by equation (13) and (21) with k == 3
tmp_array(i) = cell_function_becke(r,i) ! P_n(r)
print*,i,tmp_array(i)
! Then you compute the summ the P_n(r) function for each of the "r" points
accu += tmp_array(i)
enddo
write(*,'(100(F16.10,X))')tmp_array(j) , accu
if(isnan(weight_at_r(l,k,j))) then
print*,'isnan(weight_at_r(l,k,j))'
print*,l,k,j
accu = 0.d0
do i = 1, nucl_num
! function defined for each atom "i" by equation (13) and (21) with k == 3
tmp_array(i) = cell_function_becke(r,i) ! P_n(r)
print*,i,tmp_array(i)
! Then you compute the summ the P_n(r) function for each of the "r" points
accu += tmp_array(i)
enddo
write(*,'(100(F16.10,X))')tmp_array(j) , accu
stop
endif
enddo
@ -151,35 +226,76 @@ BEGIN_PROVIDER [double precision, weight_at_r, (n_points_integration_angular,n_p
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, final_weight_at_r, (n_points_integration_angular,n_points_radial_grid,nucl_num)]
BEGIN_PROVIDER [double precision, final_weight_at_r, (n_points_integration_angular,n_points_radial_grid,nucl_num) ]
BEGIN_DOC
! Total weight on each grid point which takes into account all Lebedev, Voronoi and radial weights.
! Total weight on each grid point which takes into account all Lebedev, Voronoi and radial weights.
END_DOC
implicit none
integer :: i,j,k,l,m
double precision :: r(3)
double precision :: accu,cell_function_becke
double precision :: tmp_array(nucl_num)
double precision :: contrib_integration,x
double precision :: derivative_knowles_function,knowles_function
! run over all points in space
do j = 1, nucl_num ! that are referred to each atom
do i = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom
x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1]
do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom
contrib_integration = derivative_knowles_function(alpha_knowles(grid_atomic_number(j)),m_knowles,x)&
*knowles_function(alpha_knowles(grid_atomic_number(j)),m_knowles,x)**2
final_weight_at_r(k,i,j) = weights_angular_points(k) * weight_at_r(k,i,j) * contrib_integration * dr_radial_integral
if(isnan(final_weight_at_r(k,i,j)))then
print*,'isnan(final_weight_at_r(k,i,j))'
print*,k,i,j
write(*,'(100(F16.10,X))')weights_angular_points(k) , weight_at_r(k,i,j) , contrib_integration , dr_radial_integral
stop
endif
integer :: i, j, k, l, m
double precision :: r(3)
double precision :: tmp_array(nucl_num)
double precision :: contrib_integration, x, tmp
double precision, external :: derivative_knowles_function, knowles_function
final_weight_at_r = 0.d0
PROVIDE rad_grid_type
if(rad_grid_type .eq. "KNOWLES") then
! run over all points in space
do j = 1, nucl_num ! that are referred to each atom
do i = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom
x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1]
do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom
contrib_integration = derivative_knowles_function(alpha_knowles(grid_atomic_number(j)), m_knowles, x) &
* knowles_function(alpha_knowles(grid_atomic_number(j)), m_knowles, x)**2
final_weight_at_r(k,i,j) = weights_angular_points(k) * weight_at_r(k,i,j) * contrib_integration * dr_radial_integral
if(isnan(final_weight_at_r(k,i,j))) then
print*,'isnan(final_weight_at_r(k,i,j))'
print*,k,i,j
write(*,'(100(F16.10,X))') weights_angular_points(k), weight_at_r(k,i,j), contrib_integration
stop
endif
enddo
enddo
enddo
enddo
elseif(rad_grid_type .eq. "GILL") then
! GILL & CHIEN, 2002
tmp = 2.d0 * R_gill * R_gill * R_gill * dble(n_points_radial_grid)
! run over all points in space
do j = 1, nucl_num ! that are referred to each atom
do i = 1, n_points_radial_grid - 1 !for each radial grid attached to the "jth" atom
contrib_integration = tmp * dble(i-1)**5 / dble(n_points_radial_grid-i+1)**7
do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom
final_weight_at_r(k,i,j) = weights_angular_points(k) * weight_at_r(k,i,j) * contrib_integration
if(isnan(final_weight_at_r(k,i,j))) then
print*,'isnan(final_weight_at_r(k,i,j))'
print*,k,i,j
write(*,'(100(F16.10,X))') weights_angular_points(k), weight_at_r(k,i,j), contrib_integration, dr_radial_integral
stop
endif
enddo
enddo
enddo
else
print*, " rad_grid_type = ", rad_grid_type, ' is not implemented'
stop
endif
END_PROVIDER

35
src/becke_numerical_grid/grid_becke_vector.irp.f
View File

@ -21,22 +21,27 @@ BEGIN_PROVIDER [integer, n_points_final_grid]
call ezfio_set_becke_numerical_grid_n_points_final_grid(n_points_final_grid)
END_PROVIDER
BEGIN_PROVIDER [double precision, final_grid_points, (3,n_points_final_grid)]
&BEGIN_PROVIDER [double precision, final_weight_at_r_vector, (n_points_final_grid) ]
&BEGIN_PROVIDER [integer, index_final_points, (3,n_points_final_grid) ]
&BEGIN_PROVIDER [integer, index_final_points_reverse, (n_points_integration_angular,n_points_radial_grid,nucl_num) ]
implicit none
! ---
BEGIN_PROVIDER [double precision, final_grid_points, (3,n_points_final_grid)]
&BEGIN_PROVIDER [double precision, final_weight_at_r_vector, (n_points_final_grid)]
&BEGIN_PROVIDER [integer, index_final_points, (3,n_points_final_grid)]
&BEGIN_PROVIDER [integer, index_final_points_reverse, (n_points_integration_angular,n_points_radial_grid,nucl_num)]
BEGIN_DOC
! final_grid_points(1:3,j) = (/ x, y, z /) of the jth grid point
!
! final_weight_at_r_vector(i) = Total weight function of the ith grid point which contains the Lebedev, Voronoi and radial weights contributions
!
! index_final_points(1:3,i) = gives the angular, radial and atomic indices associated to the ith grid point
!
! index_final_points_reverse(i,j,k) = index of the grid point having i as angular, j as radial and l as atomic indices
! final_grid_points(1:3,j) = (/ x, y, z /) of the jth grid point
!
! final_weight_at_r_vector(i) = Total weight function of the ith grid point which contains the Lebedev, Voronoi and radial weights contributions
!
! index_final_points(1:3,i) = gives the angular, radial and atomic indices associated to the ith grid point
!
! index_final_points_reverse(i,j,k) = index of the grid point having i as angular, j as radial and l as atomic indices
END_DOC
integer :: i,j,k,l,i_count
double precision :: r(3)
implicit none
integer :: i, j, k, l, i_count
double precision :: r(3)
i_count = 0
do j = 1, nucl_num
do i = 1, n_points_radial_grid -1
@ -59,6 +64,8 @@ END_PROVIDER
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, final_grid_points_transp, (n_points_final_grid,3)]
implicit none
BEGIN_DOC

142
src/becke_numerical_grid/integration_radial.irp.f
View File

@ -1,71 +1,93 @@
double precision function knowles_function(alpha,m,x)
implicit none
BEGIN_DOC
! Function proposed by Knowles (JCP, 104, 1996) for distributing the radial points :
! the Log "m" function ( equation (7) in the paper )
END_DOC
double precision, intent(in) :: alpha,x
integer, intent(in) :: m
!print*, x
knowles_function = -alpha * dlog(1.d0-x**m)
end
double precision function derivative_knowles_function(alpha,m,x)
implicit none
BEGIN_DOC
! Derivative of the function proposed by Knowles (JCP, 104, 1996) for distributing the radial points
END_DOC
double precision, intent(in) :: alpha,x
integer, intent(in) :: m
double precision :: f
f = x**(m-1)
derivative_knowles_function = alpha * dble(m) * f / (1.d0 - x*f)
end
! ---
BEGIN_PROVIDER [double precision, alpha_knowles, (100)]
implicit none
integer :: i
BEGIN_DOC
! Recommended values for the alpha parameters according to the paper of Knowles (JCP, 104, 1996)
! as a function of the nuclear charge
END_DOC
double precision function knowles_function(alpha, m, x)
! H-He
alpha_knowles(1) = 5.d0
alpha_knowles(2) = 5.d0
BEGIN_DOC
! Function proposed by Knowles (JCP, 104, 1996) for distributing the radial points :
! the Log "m" function ( equation (7) in the paper )
END_DOC
implicit none
double precision, intent(in) :: alpha, x
integer, intent(in) :: m
! Li-Be
alpha_knowles(3) = 7.d0
alpha_knowles(4) = 7.d0
!print*, x
knowles_function = -alpha * dlog(1.d0-x**m)
! B-Ne
do i = 5, 10
alpha_knowles(i) = 5.d0
enddo
return
end
! Na-Mg
do i = 11, 12
alpha_knowles(i) = 7.d0
enddo
! ---
! Al-Ar
do i = 13, 18
alpha_knowles(i) = 5.d0
enddo
double precision function derivative_knowles_function(alpha, m, x)
! K-Ca
do i = 19, 20
alpha_knowles(i) = 7.d0
enddo
BEGIN_DOC
! Derivative of the function proposed by Knowles (JCP, 104, 1996) for distributing the radial points
END_DOC
! Sc-Zn
do i = 21, 30
alpha_knowles(i) = 5.d0
enddo
implicit none
double precision, intent(in) :: alpha, x
integer, intent(in) :: m
double precision :: f
! Ga-Kr
do i = 31, 100
alpha_knowles(i) = 7.d0
enddo
f = x**(m-1)
derivative_knowles_function = alpha * dble(m) * f / (1.d0 - x*f)
return
end
! ---
BEGIN_PROVIDER [double precision, alpha_knowles, (100)]
BEGIN_DOC
! Recommended values for the alpha parameters according to the paper of Knowles (JCP, 104, 1996)
! as a function of the nuclear charge
END_DOC
implicit none
integer :: i
! H-He
alpha_knowles(1) = 5.d0
alpha_knowles(2) = 5.d0
! Li-Be
alpha_knowles(3) = 7.d0
alpha_knowles(4) = 7.d0
! B-Ne
do i = 5, 10
alpha_knowles(i) = 5.d0
enddo
! Na-Mg
do i = 11, 12
alpha_knowles(i) = 7.d0
enddo
! Al-Ar
do i = 13, 18
alpha_knowles(i) = 5.d0
enddo
! K-Ca
do i = 19, 20
alpha_knowles(i) = 7.d0
enddo
! Sc-Zn
do i = 21, 30
alpha_knowles(i) = 5.d0
enddo
! Ga-Kr
do i = 31, 100
alpha_knowles(i) = 7.d0
enddo
END_PROVIDER
! ---
END_PROVIDER

43
src/becke_numerical_grid/step_function_becke.irp.f
View File

@ -20,31 +20,42 @@ double precision function f_function_becke(x)
f_function_becke = 1.5d0 * x - 0.5d0 * x*x*x
end
double precision function cell_function_becke(r,atom_number)
implicit none
double precision, intent(in) :: r(3)
integer, intent(in) :: atom_number
! ---
double precision function cell_function_becke(r, atom_number)
BEGIN_DOC
! atom_number :: atom on which the cell function of Becke (1988, JCP,88(4))
! atom_number :: atom on which the cell function of Becke (1988, JCP,88(4))
! r(1:3) :: x,y,z coordinantes of the current point
END_DOC
double precision :: mu_ij,nu_ij
double precision :: distance_i,distance_j,step_function_becke
integer :: j
distance_i = (r(1) - nucl_coord_transp(1,atom_number) ) * (r(1) - nucl_coord_transp(1,atom_number))
implicit none
double precision, intent(in) :: r(3)
integer, intent(in) :: atom_number
integer :: j
double precision :: mu_ij, nu_ij
double precision :: distance_i, distance_j, step_function_becke
distance_i = (r(1) - nucl_coord_transp(1,atom_number) ) * (r(1) - nucl_coord_transp(1,atom_number))
distance_i += (r(2) - nucl_coord_transp(2,atom_number) ) * (r(2) - nucl_coord_transp(2,atom_number))
distance_i += (r(3) - nucl_coord_transp(3,atom_number) ) * (r(3) - nucl_coord_transp(3,atom_number))
distance_i = dsqrt(distance_i)
distance_i = dsqrt(distance_i)
cell_function_becke = 1.d0
do j = 1, nucl_num
if(j==atom_number)cycle
distance_j = (r(1) - nucl_coord_transp(1,j) ) * (r(1) - nucl_coord_transp(1,j))
distance_j+= (r(2) - nucl_coord_transp(2,j) ) * (r(2) - nucl_coord_transp(2,j))
distance_j+= (r(3) - nucl_coord_transp(3,j) ) * (r(3) - nucl_coord_transp(3,j))
distance_j = dsqrt(distance_j)
mu_ij = (distance_i - distance_j)*nucl_dist_inv(atom_number,j)
if(j==atom_number) cycle
distance_j = (r(1) - nucl_coord_transp(1,j) ) * (r(1) - nucl_coord_transp(1,j))
distance_j += (r(2) - nucl_coord_transp(2,j) ) * (r(2) - nucl_coord_transp(2,j))
distance_j += (r(3) - nucl_coord_transp(3,j) ) * (r(3) - nucl_coord_transp(3,j))
distance_j = dsqrt(distance_j)
mu_ij = (distance_i - distance_j) * nucl_dist_inv(atom_number,j)
nu_ij = mu_ij + slater_bragg_type_inter_distance_ua(atom_number,j) * (1.d0 - mu_ij*mu_ij)
cell_function_becke *= step_function_becke(nu_ij)
enddo
return
end

247
src/ccsd/ccsd_t_space_orb.irp.f
View File

@ -8,15 +8,15 @@ subroutine ccsd_par_t_space(nO,nV,t1,t2,energy)
double precision, intent(in) :: t1(nO, nV)
double precision, intent(in) :: t2(nO, nO, nV, nV)
double precision, intent(out) :: energy
double precision, allocatable :: W(:,:,:,:,:,:)
double precision, allocatable :: V(:,:,:,:,:,:)
integer :: i,j,k,a,b,c
allocate(W(nO,nO,nO,nV,nV,nV))
allocate(V(nO,nO,nO,nV,nV,nV))
call form_w(nO,nV,t2,W)
call form_w(nO,nV,t2,W)
call form_v(nO,nV,t1,W,V)
energy = 0d0
@ -33,9 +33,9 @@ subroutine ccsd_par_t_space(nO,nV,t1,t2,energy)
enddo
enddo
enddo
energy = energy / 3d0
deallocate(V,W)
end
@ -46,7 +46,7 @@ subroutine form_w(nO,nV,t2,W)
integer, intent(in) :: nO,nV
double precision, intent(in) :: t2(nO, nO, nV, nV)
double precision, intent(out) :: W(nO, nO, nO, nV, nV, nV)
integer :: i,j,k,l,a,b,c,d
W = 0d0
@ -133,7 +133,7 @@ subroutine ccsd_par_t_space_v2(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energy)
double precision, intent(in) :: t2(nO,nO,nV,nV)
double precision, intent(in) :: v_vvvo(nV,nV,nV,nO), v_vvoo(nV,nV,nO,nO), v_vooo(nV,nO,nO,nO)
double precision, intent(out) :: energy
double precision, allocatable :: W(:,:,:,:,:,:)
double precision, allocatable :: V(:,:,:,:,:,:)
double precision, allocatable :: W_ijk(:,:,:), V_ijk(:,:,:)
@ -141,7 +141,7 @@ subroutine ccsd_par_t_space_v2(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energy)
double precision, allocatable :: T_vvoo(:,:,:,:), T_ovvo(:,:,:,:), T_vo(:,:)
integer :: i,j,k,l,a,b,c,d
double precision :: e,ta,tb, delta, delta_ijk
!allocate(W(nV,nV,nV,nO,nO,nO))
!allocate(V(nV,nV,nV,nO,nO,nO))
allocate(W_ijk(nV,nV,nV), V_ijk(nV,nV,nV))
@ -154,10 +154,10 @@ subroutine ccsd_par_t_space_v2(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energy)
!$OMP t1,t2,v_vvvo,v_vooo,v_vvoo) &
!$OMP PRIVATE(a,b,c,d,i,j,k,l) &
!$OMP DEFAULT(NONE)
!v_vvvo(b,a,d,i) * t2(k,j,c,d) &
!X_vvvo(d,b,a,i) * T_vvoo(d,c,k,j)
!$OMP DO collapse(3)
do i = 1, nO
do a = 1, nV
@ -181,7 +181,7 @@ subroutine ccsd_par_t_space_v2(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energy)
enddo
enddo
!$OMP END DO nowait
!v_vooo(c,j,k,l) * t2(i,l,a,b) &
!X_ovoo(l,c,j,k) * T_ovvo(l,a,b,i) &
@ -208,10 +208,10 @@ subroutine ccsd_par_t_space_v2(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energy)
enddo
enddo
!$OMP END DO nowait
!v_vvoo(b,c,j,k) * t1(i,a) &
!X_vvoo(b,c,k,j) * T1_vo(a,i) &
!$OMP DO collapse(3)
do j = 1, nO
do k = 1, nO
@ -257,7 +257,7 @@ subroutine ccsd_par_t_space_v2(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energy)
enddo
enddo
enddo
!$OMP END DO
!$OMP END DO NOWAIT
!$OMP CRITICAL
energy = energy + e
!$OMP END CRITICAL
@ -267,7 +267,7 @@ subroutine ccsd_par_t_space_v2(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energy)
call wall_time(tb)
write(*,'(F12.2,A5,F12.2,A2)') dble(i)/dble(nO)*100d0, '% in ', tb - ta, ' s'
enddo
energy = energy / 3d0
deallocate(W_ijk,V_ijk,X_vvvo,X_ovoo,T_vvoo,T_ovvo,T_vo)
@ -285,78 +285,178 @@ subroutine form_w_ijk(nO,nV,i,j,k,T_vvoo,T_ovvo,X_vvvo,X_ovoo,W)
double precision, intent(in) :: T_vvoo(nV,nV,nO,nO), T_ovvo(nO,nV,nV,nO)
double precision, intent(in) :: X_vvvo(nV,nV,nV,nO), X_ovoo(nO,nV,nO,nO)
double precision, intent(out) :: W(nV,nV,nV)!,nO,nO,nO)
integer :: l,a,b,c,d
double precision, allocatable, dimension(:,:,:) :: X, Y, Z
!W = 0d0
!do i = 1, nO
! do j = 1, nO
! do k = 1, nO
!$OMP PARALLEL &
!$OMP SHARED(nO,nV,i,j,k,T_vvoo,T_ovvo,X_vvvo,X_ovoo,W) &
!$OMP PRIVATE(a,b,c,d,l) &
!$OMP DEFAULT(NONE)
!$OMP DO collapse(2)
do c = 1, nV
do b = 1, nV
do a = 1, nV
W(a,b,c) = 0d0
allocate(X(nV,nV,nV))
allocate(Y(nV,nV,nV))
allocate(Z(nV,nV,nV))
do d = 1, nV
!W(i,j,k,a,b,c) = W(i,j,k,a,b,c) &
W(a,b,c) = W(a,b,c) &
! chem (bd|ai)
! phys <ba|di>
!+ cc_space_v_vvvo(b,a,d,i) * t2(k,j,c,d) &
!+ cc_space_v_vvvo(c,a,d,i) * t2(j,k,b,d) & ! bc kj
!+ cc_space_v_vvvo(a,c,d,k) * t2(j,i,b,d) & ! prev ac ik
!+ cc_space_v_vvvo(b,c,d,k) * t2(i,j,a,d) & ! prev ab ij
!+ cc_space_v_vvvo(c,b,d,j) * t2(i,k,a,d) & ! prev bc kj
!+ cc_space_v_vvvo(a,b,d,j) * t2(k,i,c,d) ! prev ac ik
+ X_vvvo(d,b,a,i) * T_vvoo(d,c,k,j) &
+ X_vvvo(d,c,a,i) * T_vvoo(d,b,j,k) & ! bc kj
+ X_vvvo(d,a,c,k) * T_vvoo(d,b,j,i) & ! prev ac ik
+ X_vvvo(d,b,c,k) * T_vvoo(d,a,i,j) & ! prev ab ij
+ X_vvvo(d,c,b,j) * T_vvoo(d,a,i,k) & ! prev bc kj
+ X_vvvo(d,a,b,j) * T_vvoo(d,c,k,i) ! prev ac ik
enddo
!$OMP PARALLEL DO
do b = 1, nV
do a = 1, nV
do d = 1, nV
Z(d,a,b) = X_vvvo(d,b,a,i)
enddo
enddo
enddo
!$OMP END DO nowait
!$OMP END PARALLEL DO
!$OMP DO collapse(2)
call dgemm('T','N',nV*nV,nV,nV, 1.d0, &
Z, nV, T_vvoo(1,1,k,j), nV, 0.d0, W, nV*nV)
!$OMP PARALLEL DO
do c = 1, nV
do b = 1, nV
do a = 1, nV
do l = 1, nO
!W(i,j,k,a,b,c) = W(i,j,k,a,b,c) &
W(a,b,c) = W(a,b,c) &
! chem (ck|jl)
! phys <cj|kl>
!- cc_space_v_vooo(c,j,k,l) * t2(i,l,a,b) &
!- cc_space_v_vooo(b,k,j,l) * t2(i,l,a,c) & ! bc kj
!- cc_space_v_vooo(b,i,j,l) * t2(k,l,c,a) & ! prev ac ik
!- cc_space_v_vooo(a,j,i,l) * t2(k,l,c,b) & ! prev ab ij
!- cc_space_v_vooo(a,k,i,l) * t2(j,l,b,c) & ! prev bc kj
!- cc_space_v_vooo(c,i,k,l) * t2(j,l,b,a) ! prev ac ik
- X_ovoo(l,c,j,k) * T_ovvo(l,a,b,i) &
- X_ovoo(l,b,k,j) * T_ovvo(l,a,c,i) & ! bc kj
- X_ovoo(l,b,i,j) * T_ovvo(l,c,a,k) & ! prev ac ik
- X_ovoo(l,a,j,i) * T_ovvo(l,c,b,k) & ! prev ab ij
- X_ovoo(l,a,k,i) * T_ovvo(l,b,c,j) & ! prev bc kj
- X_ovoo(l,c,i,k) * T_ovvo(l,b,a,j) ! prev ac ik
enddo
do a = 1, nV
do d = 1, nV
Z(d,a,c) = X_vvvo(d,c,a,i)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
!$OMP END PARALLEL DO
call dgemm('T','N',nV*nV,nV,nV, 1.d0, &
Z, nV, T_vvoo(1,1,j,k), nV, 0.d0, Y, nV*nV)
call dgemm('T','N',nV*nV,nV,nV, 1.d0, &
X_vvvo(1,1,1,k), nV, T_vvoo(1,1,j,i), nV, 1.d0, Y, nV*nV)
call dgemm('T','N',nV,nV*nV,nV, 1.d0, &
T_vvoo(1,1,i,j), nV, X_vvvo(1,1,1,k), nV, 1.d0, W, nV)
call dgemm('T','N',nV,nV*nV,nV, 1.d0, &
T_vvoo(1,1,i,k), nV, X_vvvo(1,1,1,j), nV, 1.d0, Y, nV)
call dgemm('T','N',nV*nV,nV,nV, 1.d0, &
X_vvvo(1,1,1,j), nV, T_vvoo(1,1,k,i), nV, 1.d0, W, nV*nV)
deallocate(Z)
allocate(Z(nO,nV,nV))
call dgemm('T','N',nV*nV,nV,nO, -1.d0, &
T_ovvo(1,1,1,i), nO, X_ovoo(1,1,j,k), nO, 1.d0, W, nV*nV)
call dgemm('T','N',nV*nV,nV,nO, -1.d0, &
T_ovvo(1,1,1,i), nO, X_ovoo(1,1,k,j), nO, 1.d0, Y, nV*nV)
!$OMP PARALLEL DO
do c = 1, nV
do a = 1, nV
do l = 1, nO
Z(l,a,c) = T_ovvo(l,c,a,k)
enddo
enddo
enddo
!$OMP END PARALLEL DO
call dgemm('T','N',nV*nV,nV,nO, -1.d0, &
Z, nO, X_ovoo(1,1,i,j), nO, 1.d0, Y, nV*nV)
call dgemm('T','N',nV,nV*nV,nO, -1.d0, &
X_ovoo(1,1,j,i), nO, T_ovvo(1,1,1,k), nO, 1.d0, Y, nV)
call dgemm('T','N',nV,nV*nV,nO, -1.d0, &
X_ovoo(1,1,k,i), nO, T_ovvo(1,1,1,j), nO, 1.d0, W, nV)
!$OMP PARALLEL DO
do b = 1, nV
do a = 1, nV
do l = 1, nO
Z(l,a,b) = T_ovvo(l,b,a,j)
enddo
enddo
enddo
!$OMP END PARALLEL DO
call dgemm('T','N',nV*nV,nV,nO, -1.d0, &
Z, nO, X_ovoo(1,1,i,k), nO, 1.d0, W, nV*nV)
!$OMP PARALLEL DO
do c = 1, nV
do b = 1, nV
do a = 1, nV
W(a,b,c) = W(a,b,c) + Y(a,c,b)
enddo
enddo
enddo
!$OMP END PARALLEL DO
deallocate(X,Y,Z)
! !$OMP PARALLEL &
! !$OMP SHARED(nO,nV,i,j,k,T_vvoo,T_ovvo,X_vvvo,X_ovoo,W) &
! !$OMP PRIVATE(a,b,c,d,l) &
! !$OMP DEFAULT(NONE)
!
! !$OMP DO collapse(2)
! do c = 1, nV
! do b = 1, nV
! do a = 1, nV
! W(a,b,c) = 0.d0
!
! do d = 1, nV
! !W(i,j,k,a,b,c) = W(i,j,k,a,b,c) &
! W(a,b,c) = W(a,b,c) &
! ! chem (bd|ai)
! ! phys <ba|di>
! !+ cc_space_v_vvvo(b,a,d,i) * t2(k,j,c,d) &
! !+ cc_space_v_vvvo(c,a,d,i) * t2(j,k,b,d) & ! bc kj
! !+ cc_space_v_vvvo(a,c,d,k) * t2(j,i,b,d) & ! prev ac ik
! !+ cc_space_v_vvvo(b,c,d,k) * t2(i,j,a,d) & ! prev ab ij
! !+ cc_space_v_vvvo(c,b,d,j) * t2(i,k,a,d) & ! prev bc kj
! !+ cc_space_v_vvvo(a,b,d,j) * t2(k,i,c,d) ! prev ac ik
! + X_vvvo(d,b,a,i) * T_vvoo(d,c,k,j) &
! + X_vvvo(d,c,a,i) * T_vvoo(d,b,j,k) & ! bc kj
! + X_vvvo(d,a,c,k) * T_vvoo(d,b,j,i) & ! prev ac ik
! + X_vvvo(d,b,c,k) * T_vvoo(d,a,i,j) & ! prev ab ij
! + X_vvvo(d,c,b,j) * T_vvoo(d,a,i,k) & ! prev bc kj
! + X_vvvo(d,a,b,j) * T_vvoo(d,c,k,i) ! prev ac ik
! enddo
!
! enddo
! enddo
! enddo
! !$OMP END DO nowait
!
! !$OMP DO collapse(2)
! do c = 1, nV
! do b = 1, nV
! do a = 1, nV
!
! do l = 1, nO
! !W(i,j,k,a,b,c) = W(i,j,k,a,b,c) &
! W(a,b,c) = W(a,b,c) &
! ! chem (ck|jl)
! ! phys <cj|kl>
! !- cc_space_v_vooo(c,j,k,l) * t2(i,l,a,b) &
! !- cc_space_v_vooo(b,k,j,l) * t2(i,l,a,c) & ! bc kj
! !- cc_space_v_vooo(b,i,j,l) * t2(k,l,c,a) & ! prev ac ik
! !- cc_space_v_vooo(a,j,i,l) * t2(k,l,c,b) & ! prev ab ij
! !- cc_space_v_vooo(a,k,i,l) * t2(j,l,b,c) & ! prev bc kj
! !- cc_space_v_vooo(c,i,k,l) * t2(j,l,b,a) ! prev ac ik
! - T_ovvo(l,a,b,i) * X_ovoo(l,c,j,k) &
! - T_ovvo(l,a,c,i) * X_ovoo(l,b,k,j) & ! bc kj
! - T_ovvo(l,c,a,k) * X_ovoo(l,b,i,j) & ! prev ac ik
! - T_ovvo(l,c,b,k) * X_ovoo(l,a,j,i) & ! prev ab ij
! - T_ovvo(l,b,c,j) * X_ovoo(l,a,k,i) & ! prev bc kj
! - T_ovvo(l,b,a,j) * X_ovoo(l,c,i,k) ! prev ac ik
! enddo
!
! enddo
! enddo
! enddo
! !$OMP END DO
! !$OMP END PARALLEL
! enddo
! enddo
!enddo
@ -382,7 +482,7 @@ implicit none
!do i = 1, nO
! do j = 1, nO
! do k = 1, nO
!$OMP PARALLEL &
!$OMP SHARED(nO,nV,i,j,k,T_vo,X_vvoo,W,V) &
!$OMP PRIVATE(a,b,c) &
@ -404,9 +504,10 @@ implicit none
enddo
!$OMP END DO
!$OMP END PARALLEL
! enddo
! enddo
!enddo
end

252
src/ccsd/ccsd_t_space_orb_abc.irp.f Normal file
View File

@ -0,0 +1,252 @@
! Main
subroutine ccsd_par_t_space_v3(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energy)
implicit none
integer, intent(in) :: nO,nV
double precision, intent(in) :: t1(nO,nV), f_o(nO), f_v(nV)
double precision, intent(in) :: t2(nO,nO,nV,nV)
double precision, intent(in) :: v_vvvo(nV,nV,nV,nO), v_vvoo(nV,nV,nO,nO), v_vooo(nV,nO,nO,nO)
double precision, intent(out) :: energy
double precision, allocatable :: W(:,:,:,:,:,:)
double precision, allocatable :: V(:,:,:,:,:,:)
double precision, allocatable :: W_abc(:,:,:), V_abc(:,:,:)
double precision, allocatable :: W_cab(:,:,:), W_cba(:,:,:)
double precision, allocatable :: W_bca(:,:,:), V_cba(:,:,:)
double precision, allocatable :: X_vvvo(:,:,:,:), X_ovoo(:,:,:,:), X_vvoo(:,:,:,:)
double precision, allocatable :: T_vvoo(:,:,:,:), T_ovvo(:,:,:,:), T_vo(:,:)
integer :: i,j,k,l,a,b,c,d
double precision :: e,ta,tb, delta, delta_abc
!allocate(W(nV,nV,nV,nO,nO,nO))
!allocate(V(nV,nV,nV,nO,nO,nO))
allocate(W_abc(nO,nO,nO), V_abc(nO,nO,nO), W_cab(nO,nO,nO))
allocate(W_bca(nO,nO,nO), V_cba(nO,nO,nO), W_cba(nO,nO,nO))
allocate(X_vvvo(nV,nV,nV,nO), X_ovoo(nO,nV,nO,nO), X_vvoo(nV,nV,nO,nO))
allocate(T_vvoo(nV,nV,nO,nO), T_ovvo(nO,nV,nV,nO), T_vo(nV,nO))
! Temporary arrays
!$OMP PARALLEL &
!$OMP SHARED(nO,nV,T_vvoo,T_ovvo,T_vo,X_vvvo,X_ovoo,X_vvoo, &
!$OMP t1,t2,v_vvvo,v_vooo,v_vvoo) &
!$OMP PRIVATE(a,b,c,d,i,j,k,l) &
!$OMP DEFAULT(NONE)
!v_vvvo(b,a,d,i) * t2(k,j,c,d) &
!X_vvvo(d,b,a,i) * T_vvoo(d,c,k,j)
!$OMP DO collapse(3)
do i = 1, nO
do a = 1, nV
do b = 1, nV
do d = 1, nV
X_vvvo(d,b,a,i) = v_vvvo(b,a,d,i)
enddo
enddo
enddo
enddo
!$OMP END DO nowait
!$OMP DO collapse(3)
do j = 1, nO
do k = 1, nO
do c = 1, nV
do d = 1, nV
T_vvoo(d,c,k,j) = t2(k,j,c,d)
enddo
enddo
enddo
enddo
!$OMP END DO nowait
!v_vooo(c,j,k,l) * t2(i,l,a,b) &
!X_ovoo(l,c,j,k) * T_ovvo(l,a,b,i) &
!$OMP DO collapse(3)
do k = 1, nO
do j = 1, nO
do c = 1, nV
do l = 1, nO
X_ovoo(l,c,j,k) = v_vooo(c,j,k,l)
enddo
enddo
enddo
enddo
!$OMP END DO nowait
!$OMP DO collapse(3)
do i = 1, nO
do b = 1, nV
do a = 1, nV
do l = 1, nO
T_ovvo(l,a,b,i) = t2(i,l,a,b)
enddo
enddo
enddo
enddo
!$OMP END DO nowait
!v_vvoo(b,c,j,k) * t1(i,a) &
!X_vvoo(b,c,k,j) * T1_vo(a,i) &
!$OMP DO collapse(3)
do j = 1, nO
do k = 1, nO
do c = 1, nV
do b = 1, nV
X_vvoo(b,c,k,j) = v_vvoo(b,c,j,k)
enddo
enddo
enddo
enddo
!$OMP END DO nowait
!$OMP DO collapse(1)
do i = 1, nO
do a = 1, nV
T_vo(a,i) = t1(i,a)
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(ta)
energy = 0d0
do c = 1, nV
do b = 1, nV
do a = 1, nV
delta_abc = f_v(a) + f_v(b) + f_v(c)
call form_w_abc(nO,nV,a,b,c,T_vvoo,T_ovvo,X_vvvo,X_ovoo,W_abc)
call form_w_abc(nO,nV,b,c,a,T_vvoo,T_ovvo,X_vvvo,X_ovoo,W_bca)
call form_w_abc(nO,nV,c,a,b,T_vvoo,T_ovvo,X_vvvo,X_ovoo,W_cab)
call form_w_abc(nO,nV,c,b,a,T_vvoo,T_ovvo,X_vvvo,X_ovoo,W_cba)
call form_v_abc(nO,nV,a,b,c,T_vo,X_vvoo,W_abc,V_abc)
call form_v_abc(nO,nV,c,b,a,T_vo,X_vvoo,W_cba,V_cba)
!$OMP PARALLEL &
!$OMP SHARED(energy,nO,a,b,c,W_abc,W_cab,W_bca,V_abc,V_cba,f_o,f_v,delta_abc)&
!$OMP PRIVATE(i,j,k,e,delta) &
!$OMP DEFAULT(NONE)
e = 0d0
!$OMP DO
do i = 1, nO
do j = 1, nO
do k = 1, nO
delta = 1d0 / (f_o(i) + f_o(j) + f_o(k) - delta_abc)
!energy = energy + (4d0 * W(i,j,k,a,b,c) + W(i,j,k,b,c,a) + W(i,j,k,c,a,b)) * (V(i,j,k,a,b,c) - V(i,j,k,c,b,a)) / (cc_space_f_o(i) + cc_space_f_o(j) + cc_space_f_o(k) - cc_space_f_v(a) - cc_space_f_v(b) - cc_space_f_v(c)) !delta_ooovvv(i,j,k,a,b,c)
e = e + (4d0 * W_abc(i,j,k) + W_bca(i,j,k) + W_cab(i,j,k))&
* (V_abc(i,j,k) - V_cba(i,j,k)) * delta
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
energy = energy + e
!$OMP END CRITICAL
!$OMP END PARALLEL
enddo
enddo
call wall_time(tb)
write(*,'(F12.2,A5,F12.2,A2)') dble(i)/dble(nO)*100d0, '% in ', tb - ta, ' s'
enddo
energy = energy / 3d0
deallocate(W_abc,V_abc,W_cab,V_cba,W_bca,X_vvvo,X_ovoo,T_vvoo,T_ovvo,T_vo)
!deallocate(V,W)
end
subroutine form_w_abc(nO,nV,a,b,c,T_vvoo,T_ovvo,X_vvvo,X_ovoo,W_abc)
implicit none
integer, intent(in) :: nO,nV,a,b,c
!double precision, intent(in) :: t2(nO,nO,nV,nV)
double precision, intent(in) :: T_vvoo(nV,nV,nO,nO), T_ovvo(nO,nV,nV,nO)
double precision, intent(in) :: X_vvvo(nV,nV,nV,nO), X_ovoo(nO,nV,nO,nO)
double precision, intent(out) :: W_abc(nO,nO,nO)
integer :: l,i,j,k,d
!$OMP PARALLEL &
!$OMP SHARED(nO,nV,a,b,c,T_vvoo,T_ovvo,X_vvvo,X_ovoo,W_abc) &
!$OMP PRIVATE(i,j,k,d,l) &
!$OMP DEFAULT(NONE)
!$OMP DO collapse(3)
do k = 1, nO
do j = 1, nO
do i = 1, nO
W_abc(i,j,k) = 0.d0
do d = 1, nV
W_abc(i,j,k) = W_abc(i,j,k) &
+ X_vvvo(d,b,a,i) * T_vvoo(d,c,k,j) &
+ X_vvvo(d,c,a,i) * T_vvoo(d,b,j,k) &
+ X_vvvo(d,a,c,k) * T_vvoo(d,b,j,i) &
+ X_vvvo(d,b,c,k) * T_vvoo(d,a,i,j) &
+ X_vvvo(d,c,b,j) * T_vvoo(d,a,i,k) &
+ X_vvvo(d,a,b,j) * T_vvoo(d,c,k,i)
enddo
do l = 1, nO
W_abc(i,j,k) = W_abc(i,j,k) &
- T_ovvo(l,a,b,i) * X_ovoo(l,c,j,k) &
- T_ovvo(l,a,c,i) * X_ovoo(l,b,k,j) & ! bc kj
- T_ovvo(l,c,a,k) * X_ovoo(l,b,i,j) & ! prev ac ik
- T_ovvo(l,c,b,k) * X_ovoo(l,a,j,i) & ! prev ab ij
- T_ovvo(l,b,c,j) * X_ovoo(l,a,k,i) & ! prev bc kj
- T_ovvo(l,b,a,j) * X_ovoo(l,c,i,k) ! prev ac ik
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
end
! V_abc
subroutine form_v_abc(nO,nV,a,b,c,T_vo,X_vvoo,W,V)
implicit none
integer, intent(in) :: nO,nV,a,b,c
!double precision, intent(in) :: t1(nO,nV)
double precision, intent(in) :: T_vo(nV,nO)
double precision, intent(in) :: X_vvoo(nV,nV,nO,nO)
double precision, intent(in) :: W(nO,nO,nO)
double precision, intent(out) :: V(nO,nO,nO)
integer :: i,j,k
!$OMP PARALLEL &
!$OMP SHARED(nO,nV,a,b,c,T_vo,X_vvoo,W,V) &
!$OMP PRIVATE(i,j,k) &
!$OMP DEFAULT(NONE)
!$OMP DO collapse(2)
do k = 1, nO
do j = 1, nO
do i = 1, nO
!V(i,j,k,a,b,c) = V(i,j,k,a,b,c) + W(i,j,k,a,b,c) &
V(i,j,k) = W(i,j,k) &
+ X_vvoo(b,c,k,j) * T_vo(a,i) &
+ X_vvoo(a,c,k,i) * T_vo(b,j) &
+ X_vvoo(a,b,j,i) * T_vo(c,k)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
end

0
src/utils_trust_region/TANGLE_org_mode.sh → src/ccsd/org/TANGLE_org_mode.sh
View File

19
src/cosgtos_ao_int/EZFIO.cfg Normal file
View File

@ -0,0 +1,19 @@
[ao_expoim_cosgtos]
type: double precision
doc: imag part for Exponents for each primitive of each cosGTOs |AO|
size: (ao_basis.ao_num,ao_basis.ao_prim_num_max)
interface: ezfio, provider
[use_cosgtos]
type: logical
doc: If true, use cosgtos for AO integrals
interface: ezfio,provider,ocaml
default: False
[ao_integrals_threshold]
type: Threshold
doc: If | (pq|rs) | < `ao_integrals_threshold` then (pq|rs) is zero
interface: ezfio,provider,ocaml
default: 1.e-15
ezfio_name: threshold_ao

2
src/cosgtos_ao_int/NEED Normal file
View File

@ -0,0 +1,2 @@
ezfio_files
ao_basis

4
src/cosgtos_ao_int/README.rst Normal file
View File

@ -0,0 +1,4 @@
==============
cosgtos_ao_int
==============

210
src/cosgtos_ao_int/aos_cosgtos.irp.f Normal file
View File

@ -0,0 +1,210 @@
! ---
BEGIN_PROVIDER [ double precision, ao_coef_norm_ord_transp_cosgtos, (ao_prim_num_max, ao_num) ]
implicit none
integer :: i, j
do j = 1, ao_num
do i = 1, ao_prim_num_max
ao_coef_norm_ord_transp_cosgtos(i,j) = ao_coef_norm_ord_cosgtos(j,i)
enddo
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [ complex*16, ao_expo_ord_transp_cosgtos, (ao_prim_num_max, ao_num) ]
implicit none
integer :: i, j
do j = 1, ao_num
do i = 1, ao_prim_num_max
ao_expo_ord_transp_cosgtos(i,j) = ao_expo_ord_cosgtos(j,i)
enddo
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, ao_coef_norm_cosgtos, (ao_num, ao_prim_num_max) ]
implicit none
integer :: i, j, powA(3), nz
double precision :: norm
complex*16 :: overlap_x, overlap_y, overlap_z, C_A(3)
complex*16 :: integ1, integ2, expo
nz = 100
C_A(1) = (0.d0, 0.d0)
C_A(2) = (0.d0, 0.d0)
C_A(3) = (0.d0, 0.d0)
ao_coef_norm_cosgtos = 0.d0
do i = 1, ao_num
powA(1) = ao_power(i,1)
powA(2) = ao_power(i,2)
powA(3) = ao_power(i,3)
! Normalization of the primitives
if(primitives_normalized) then
do j = 1, ao_prim_num(i)
expo = ao_expo(i,j) + (0.d0, 1.d0) * ao_expoim_cosgtos(i,j)
call overlap_cgaussian_xyz(C_A, C_A, expo, expo, powA, powA, overlap_x, overlap_y, overlap_z, integ1, nz)
call overlap_cgaussian_xyz(C_A, C_A, conjg(expo), expo, powA, powA, overlap_x, overlap_y, overlap_z, integ2, nz)
norm = 2.d0 * real( integ1 + integ2 )
ao_coef_norm_cosgtos(i,j) = ao_coef(i,j) / dsqrt(norm)
enddo
else
do j = 1, ao_prim_num(i)
ao_coef_norm_cosgtos(i,j) = ao_coef(i,j)
enddo
endif
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, ao_coef_norm_ord_cosgtos, (ao_num, ao_prim_num_max) ]
&BEGIN_PROVIDER [ complex*16 , ao_expo_ord_cosgtos, (ao_num, ao_prim_num_max) ]
implicit none
integer :: i, j
integer :: iorder(ao_prim_num_max)
double precision :: d(ao_prim_num_max,3)
d = 0.d0
do i = 1, ao_num
do j = 1, ao_prim_num(i)
iorder(j) = j
d(j,1) = ao_expo(i,j)
d(j,2) = ao_coef_norm_cosgtos(i,j)
d(j,3) = ao_expoim_cosgtos(i,j)
enddo
call dsort (d(1,1), iorder, ao_prim_num(i))
call dset_order(d(1,2), iorder, ao_prim_num(i))
call dset_order(d(1,3), iorder, ao_prim_num(i))
do j = 1, ao_prim_num(i)
ao_expo_ord_cosgtos (i,j) = d(j,1) + (0.d0, 1.d0) * d(j,3)
ao_coef_norm_ord_cosgtos(i,j) = d(j,2)
enddo
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, ao_overlap_cosgtos, (ao_num, ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_overlap_cosgtos_x, (ao_num, ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_overlap_cosgtos_y, (ao_num, ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_overlap_cosgtos_z, (ao_num, ao_num) ]
implicit none
integer :: i, j, n, l, dim1, power_A(3), power_B(3)
double precision :: c, overlap, overlap_x, overlap_y, overlap_z
complex*16 :: alpha, beta, A_center(3), B_center(3)
complex*16 :: overlap1, overlap_x1, overlap_y1, overlap_z1
complex*16 :: overlap2, overlap_x2, overlap_y2, overlap_z2
ao_overlap_cosgtos = 0.d0
ao_overlap_cosgtos_x = 0.d0
ao_overlap_cosgtos_y = 0.d0
ao_overlap_cosgtos_z = 0.d0
dim1 = 100
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
!$OMP DEFAULT(NONE) &
!$OMP PRIVATE( A_center, B_center, power_A, power_B, alpha, beta, i, j, n, l, c &
!$OMP , overlap_x , overlap_y , overlap_z , overlap &
!$OMP , overlap_x1, overlap_y1, overlap_z1, overlap1 &
!$OMP , overlap_x2, overlap_y2, overlap_z2, overlap2 ) &
!$OMP SHARED( nucl_coord, ao_power, ao_prim_num, ao_num, ao_nucl, dim1 &
!$OMP , ao_overlap_cosgtos_x, ao_overlap_cosgtos_y, ao_overlap_cosgtos_z, ao_overlap_cosgtos &
!$OMP , ao_coef_norm_ord_transp_cosgtos, ao_expo_ord_transp_cosgtos )
do j = 1, ao_num
A_center(1) = nucl_coord(ao_nucl(j),1) * (1.d0, 0.d0)
A_center(2) = nucl_coord(ao_nucl(j),2) * (1.d0, 0.d0)
A_center(3) = nucl_coord(ao_nucl(j),3) * (1.d0, 0.d0)
power_A(1) = ao_power(j,1)
power_A(2) = ao_power(j,2)
power_A(3) = ao_power(j,3)
do i = 1, ao_num
B_center(1) = nucl_coord(ao_nucl(i),1) * (1.d0, 0.d0)
B_center(2) = nucl_coord(ao_nucl(i),2) * (1.d0, 0.d0)
B_center(3) = nucl_coord(ao_nucl(i),3) * (1.d0, 0.d0)
power_B(1) = ao_power(i,1)
power_B(2) = ao_power(i,2)
power_B(3) = ao_power(i,3)
do n = 1, ao_prim_num(j)
alpha = ao_expo_ord_transp_cosgtos(n,j)
do l = 1, ao_prim_num(i)
c = ao_coef_norm_ord_transp_cosgtos(n,j) * ao_coef_norm_ord_transp_cosgtos(l,i)
beta = ao_expo_ord_transp_cosgtos(l,i)
call overlap_cgaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
, overlap_x1, overlap_y1, overlap_z1, overlap1, dim1 )
call overlap_cgaussian_xyz( A_center, B_center, conjg(alpha), beta, power_A, power_B &
, overlap_x2, overlap_y2, overlap_z2, overlap2, dim1 )
overlap_x = 2.d0 * real( overlap_x1 + overlap_x2 )
overlap_y = 2.d0 * real( overlap_y1 + overlap_y2 )
overlap_z = 2.d0 * real( overlap_z1 + overlap_z2 )
overlap = 2.d0 * real( overlap1 + overlap2 )
ao_overlap_cosgtos(i,j) = ao_overlap_cosgtos(i,j) + c * overlap
if( isnan(ao_overlap_cosgtos(i,j)) ) then
print*,'i, j', i, j
print*,'l, n', l, n
print*,'c, overlap', c, overlap
print*, overlap_x, overlap_y, overlap_z
stop
endif
ao_overlap_cosgtos_x(i,j) = ao_overlap_cosgtos_x(i,j) + c * overlap_x
ao_overlap_cosgtos_y(i,j) = ao_overlap_cosgtos_y(i,j) + c * overlap_y
ao_overlap_cosgtos_z(i,j) = ao_overlap_cosgtos_z(i,j) + c * overlap_z
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
END_PROVIDER
! ---

7
src/cosgtos_ao_int/cosgtos_ao_int.irp.f Normal file
View File

@ -0,0 +1,7 @@
program cosgtos_ao_int
implicit none
BEGIN_DOC
! TODO : Put the documentation of the program here
END_DOC
print *, 'Hello world'
end

0
src/ao_two_e_ints/gauss_legendre.irp.f → src/cosgtos_ao_int/gauss_legendre.irp.f
View File

535
src/cosgtos_ao_int/one_e_Coul_integrals.irp.f Normal file
View File

@ -0,0 +1,535 @@
! ---
BEGIN_PROVIDER [ double precision, ao_integrals_n_e_cosgtos, (ao_num, ao_num)]
BEGIN_DOC
!
! Nucleus-electron interaction, in the cosgtos |AO| basis set.
!
! :math:`\langle \chi_i | -\sum_A \frac{1}{|r-R_A|} | \chi_j \rangle`
!
END_DOC
implicit none
integer :: num_A, num_B, power_A(3), power_B(3)
integer :: i, j, k, l, n_pt_in, m
double precision :: c, Z, A_center(3), B_center(3), C_center(3)
complex*16 :: alpha, beta, c1, c2
complex*16 :: NAI_pol_mult_cosgtos
ao_integrals_n_e_cosgtos = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE ( i, j, k, l, m, alpha, beta, A_center, B_center, C_center &
!$OMP , power_A, power_B, num_A, num_B, Z, c, c1, c2, n_pt_in ) &
!$OMP SHARED ( ao_num, ao_prim_num, ao_nucl, nucl_coord, ao_power, nucl_num, nucl_charge &
!$OMP , ao_expo_ord_transp_cosgtos, ao_coef_norm_ord_transp_cosgtos &
!$OMP , n_pt_max_integrals, ao_integrals_n_e_cosgtos )
n_pt_in = n_pt_max_integrals
!$OMP DO SCHEDULE (dynamic)
do j = 1, ao_num
num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
do i = 1, ao_num
num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l = 1, ao_prim_num(j)
alpha = ao_expo_ord_transp_cosgtos(l,j)
do m = 1, ao_prim_num(i)
beta = ao_expo_ord_transp_cosgtos(m,i)
c = 0.d0
do k = 1, nucl_num
Z = nucl_charge(k)
C_center(1:3) = nucl_coord(k,1:3)
!print *, ' '
!print *, A_center, B_center, C_center, power_A, power_B
!print *, real(alpha), real(beta)
c1 = NAI_pol_mult_cosgtos( A_center, B_center, power_A, power_B &
, alpha, beta, C_center, n_pt_in )
!c2 = c1
c2 = NAI_pol_mult_cosgtos( A_center, B_center, power_A, power_B &
, conjg(alpha), beta, C_center, n_pt_in )
!print *, ' c1 = ', real(c1)
!print *, ' c2 = ', real(c2)
c = c - Z * 2.d0 * real(c1 + c2)
enddo
ao_integrals_n_e_cosgtos(i,j) = ao_integrals_n_e_cosgtos(i,j) &
+ ao_coef_norm_ord_transp_cosgtos(l,j) &
* ao_coef_norm_ord_transp_cosgtos(m,i) * c
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
END_PROVIDER
! ---
complex*16 function NAI_pol_mult_cosgtos(A_center, B_center, power_A, power_B, alpha, beta, C_center, n_pt_in)
BEGIN_DOC
!
! Computes the electron-nucleus attraction with two primitves cosgtos.
!
! :math:`\langle g_i | \frac{1}{|r-R_c|} | g_j \rangle`
!
END_DOC
implicit none
include 'utils/constants.include.F'
integer, intent(in) :: n_pt_in, power_A(3), power_B(3)
double precision, intent(in) :: C_center(3), A_center(3), B_center(3)
complex*16, intent(in) :: alpha, beta
integer :: i, n_pt, n_pt_out
double precision :: dist, const_mod
complex*16 :: p, p_inv, rho, dist_integral, const, const_factor, coeff, factor
complex*16 :: accu, P_center(3)
complex*16 :: d(0:n_pt_in)
complex*16 :: V_n_e_cosgtos
complex*16 :: crint
if ( (A_center(1)/=B_center(1)) .or. (A_center(2)/=B_center(2)) .or. (A_center(3)/=B_center(3)) .or. &
(A_center(1)/=C_center(1)) .or. (A_center(2)/=C_center(2)) .or. (A_center(3)/=C_center(3)) ) then
continue
else
NAI_pol_mult_cosgtos = V_n_e_cosgtos( power_A(1), power_A(2), power_A(3) &
, power_B(1), power_B(2), power_B(3) &
, alpha, beta )
return
endif
p = alpha + beta
p_inv = (1.d0, 0.d0) / p
rho = alpha * beta * p_inv
dist = 0.d0
dist_integral = (0.d0, 0.d0)
do i = 1, 3
P_center(i) = (alpha * A_center(i) + beta * B_center(i)) * p_inv
dist += (A_center(i) - B_center(i)) * (A_center(i) - B_center(i))
dist_integral += (P_center(i) - C_center(i)) * (P_center(i) - C_center(i))
enddo
const_factor = dist * rho
const = p * dist_integral
const_mod = dsqrt(real(const_factor)*real(const_factor) + aimag(const_factor)*aimag(const_factor))
if(const_mod > 80.d0) then
NAI_pol_mult_cosgtos = (0.d0, 0.d0)
return
endif
factor = zexp(-const_factor)
coeff = dtwo_pi * factor * p_inv
do i = 0, n_pt_in
d(i) = (0.d0, 0.d0)
enddo
n_pt = 2 * ( (power_A(1) + power_B(1)) + (power_A(2) + power_B(2)) + (power_A(3) + power_B(3)) )
if(n_pt == 0) then
NAI_pol_mult_cosgtos = coeff * crint(0, const)
return
endif
call give_cpolynomial_mult_center_one_e( A_center, B_center, alpha, beta &
, power_A, power_B, C_center, n_pt_in, d, n_pt_out)
if(n_pt_out < 0) then
NAI_pol_mult_cosgtos = (0.d0, 0.d0)
return
endif
accu = (0.d0, 0.d0)
do i = 0, n_pt_out, 2
accu += crint(shiftr(i, 1), const) * d(i)
! print *, shiftr(i, 1), real(const), real(d(i)), real(crint(shiftr(i, 1), const))
enddo
NAI_pol_mult_cosgtos = accu * coeff
end function NAI_pol_mult_cosgtos
! ---
subroutine give_cpolynomial_mult_center_one_e( A_center, B_center, alpha, beta &
, power_A, power_B, C_center, n_pt_in, d, n_pt_out)
BEGIN_DOC
! Returns the explicit polynomial in terms of the "t" variable of the following
!
! $I_{x1}(a_x, d_x,p,q) \times I_{x1}(a_y, d_y,p,q) \times I_{x1}(a_z, d_z,p,q)$.
END_DOC
implicit none
integer, intent(in) :: n_pt_in, power_A(3), power_B(3)
double precision, intent(in) :: A_center(3), B_center(3), C_center(3)
complex*16, intent(in) :: alpha, beta
integer, intent(out) :: n_pt_out
complex*16, intent(out) :: d(0:n_pt_in)
integer :: a_x, b_x, a_y, b_y, a_z, b_z
integer :: n_pt1, n_pt2, n_pt3, dim, i, n_pt_tmp
complex*16 :: p, P_center(3), rho, p_inv, p_inv_2
complex*16 :: R1x(0:2), B01(0:2), R1xp(0:2),R2x(0:2)
complex*16 :: d1(0:n_pt_in), d2(0:n_pt_in), d3(0:n_pt_in)
ASSERT (n_pt_in > 1)
p = alpha + beta
p_inv = (1.d0, 0.d0) / p
p_inv_2 = 0.5d0 * p_inv
do i = 1, 3
P_center(i) = (alpha * A_center(i) + beta * B_center(i)) * p_inv
enddo
do i = 0, n_pt_in
d(i) = (0.d0, 0.d0)
d1(i) = (0.d0, 0.d0)
d2(i) = (0.d0, 0.d0)
d3(i) = (0.d0, 0.d0)
enddo
! ---
n_pt1 = n_pt_in
R1x(0) = (P_center(1) - A_center(1))
R1x(1) = (0.d0, 0.d0)
R1x(2) = -(P_center(1) - C_center(1))
R1xp(0) = (P_center(1) - B_center(1))
R1xp(1) = (0.d0, 0.d0)
R1xp(2) = -(P_center(1) - C_center(1))
R2x(0) = p_inv_2
R2x(1) = (0.d0, 0.d0)
R2x(2) = -p_inv_2
a_x = power_A(1)
b_x = power_B(1)
call I_x1_pol_mult_one_e_cosgtos(a_x, b_x, R1x, R1xp, R2x, d1, n_pt1, n_pt_in)
if(n_pt1 < 0) then
n_pt_out = -1
do i = 0, n_pt_in
d(i) = (0.d0, 0.d0)
enddo
return
endif
! ---
n_pt2 = n_pt_in
R1x(0) = (P_center(2) - A_center(2))
R1x(1) = (0.d0, 0.d0)
R1x(2) = -(P_center(2) - C_center(2))
R1xp(0) = (P_center(2) - B_center(2))
R1xp(1) = (0.d0, 0.d0)
R1xp(2) = -(P_center(2) - C_center(2))
a_y = power_A(2)
b_y = power_B(2)
call I_x1_pol_mult_one_e_cosgtos(a_y, b_y, R1x, R1xp, R2x, d2, n_pt2, n_pt_in)
if(n_pt2 < 0) then
n_pt_out = -1
do i = 0, n_pt_in
d(i) = (0.d0, 0.d0)
enddo
return
endif
! ---
n_pt3 = n_pt_in
R1x(0) = (P_center(3) - A_center(3))
R1x(1) = (0.d0, 0.d0)
R1x(2) = -(P_center(3) - C_center(3))
R1xp(0) = (P_center(3) - B_center(3))
R1xp(1) = (0.d0, 0.d0)
R1xp(2) = -(P_center(3) - C_center(3))
a_z = power_A(3)
b_z = power_B(3)
call I_x1_pol_mult_one_e_cosgtos(a_z, b_z, R1x, R1xp, R2x, d3, n_pt3, n_pt_in)
if(n_pt3 < 0) then
n_pt_out = -1
do i = 0, n_pt_in
d(i) = (0.d0, 0.d0)
enddo
return
endif
! ---
n_pt_tmp = 0
call multiply_cpoly(d1, n_pt1, d2, n_pt2, d, n_pt_tmp)
do i = 0, n_pt_tmp
d1(i) = (0.d0, 0.d0)
enddo
n_pt_out = 0
call multiply_cpoly(d, n_pt_tmp, d3, n_pt3, d1, n_pt_out)
do i = 0, n_pt_out
d(i) = d1(i)
enddo
end subroutine give_cpolynomial_mult_center_one_e
! ---
recursive subroutine I_x1_pol_mult_one_e_cosgtos(a, c, R1x, R1xp, R2x, d, nd, n_pt_in)
BEGIN_DOC
! Recursive routine involved in the electron-nucleus potential
END_DOC
implicit none
include 'utils/constants.include.F'
integer, intent(in) :: a, c, n_pt_in
complex*16, intent(in) :: R1x(0:2), R1xp(0:2), R2x(0:2)
integer, intent(inout) :: nd
complex*16, intent(inout) :: d(0:n_pt_in)
integer :: nx, ix, dim, iy, ny
complex*16 :: X(0:max_dim)
complex*16 :: Y(0:max_dim)
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: X, Y
dim = n_pt_in
if( (a==0) .and. (c==0)) then
nd = 0
d(0) = (1.d0, 0.d0)
return
elseif( (c < 0) .or. (nd < 0) ) then
nd = -1
return
elseif((a == 0) .and. (c .ne. 0)) then
call I_x2_pol_mult_one_e_cosgtos(c, R1x, R1xp, R2x, d, nd, n_pt_in)
elseif(a == 1) then
nx = nd
do ix = 0, n_pt_in
X(ix) = (0.d0, 0.d0)
Y(ix) = (0.d0, 0.d0)
enddo
call I_x2_pol_mult_one_e_cosgtos(c-1, R1x, R1xp, R2x, X, nx, n_pt_in)
do ix = 0, nx
X(ix) *= dble(c)
enddo
call multiply_cpoly(X, nx, R2x, 2, d, nd)
ny = 0
call I_x2_pol_mult_one_e_cosgtos(c, R1x, R1xp, R2x, Y, ny, n_pt_in)
call multiply_cpoly(Y, ny, R1x, 2, d, nd)
else
nx = 0
do ix = 0, n_pt_in
X(ix) = (0.d0, 0.d0)
Y(ix) = (0.d0, 0.d0)
enddo
call I_x1_pol_mult_one_e_cosgtos(a-2, c, R1x, R1xp, R2x, X, nx, n_pt_in)
do ix = 0, nx
X(ix) *= dble(a-1)
enddo
call multiply_cpoly(X, nx, R2x, 2, d, nd)
nx = nd
do ix = 0, n_pt_in
X(ix) = (0.d0, 0.d0)
enddo
call I_x1_pol_mult_one_e_cosgtos(a-1, c-1, R1x, R1xp, R2x, X, nx, n_pt_in)
do ix = 0, nx
X(ix) *= dble(c)
enddo
call multiply_cpoly(X, nx, R2x, 2, d, nd)
ny = 0
call I_x1_pol_mult_one_e_cosgtos(a-1, c, R1x, R1xp, R2x, Y, ny, n_pt_in)
call multiply_cpoly(Y, ny, R1x, 2, d, nd)
endif
end subroutine I_x1_pol_mult_one_e_cosgtos
! ---
recursive subroutine I_x2_pol_mult_one_e_cosgtos(c, R1x, R1xp, R2x, d, nd, dim)
BEGIN_DOC
! Recursive routine involved in the electron-nucleus potential
END_DOC
implicit none
include 'utils/constants.include.F'
integer, intent(in) :: dim, c
complex*16, intent(in) :: R1x(0:2), R1xp(0:2), R2x(0:2)
integer, intent(inout) :: nd
complex*16, intent(out) :: d(0:max_dim)
integer :: i, nx, ix, ny
complex*16 :: X(0:max_dim), Y(0:max_dim)
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: X, Y
if(c == 0) then
nd = 0
d(0) = (1.d0, 0.d0)
return
elseif((nd < 0) .or. (c < 0)) then
nd = -1
return
else
nx = 0
do ix = 0, dim
X(ix) = (0.d0, 0.d0)
Y(ix) = (0.d0, 0.d0)
enddo
call I_x1_pol_mult_one_e_cosgtos(0, c-2, R1x, R1xp, R2x, X, nx, dim)
do ix = 0, nx
X(ix) *= dble(c-1)
enddo
call multiply_cpoly(X, nx, R2x, 2, d, nd)
ny = 0
do ix = 0, dim
Y(ix) = (0.d0, 0.d0)
enddo
call I_x1_pol_mult_one_e_cosgtos(0, c-1, R1x, R1xp, R2x, Y, ny, dim)
if(ny .ge. 0) then
call multiply_cpoly(Y, ny, R1xp, 2, d, nd)
endif
endif
end subroutine I_x2_pol_mult_one_e_cosgtos
! ---
complex*16 function V_n_e_cosgtos(a_x, a_y, a_z, b_x, b_y, b_z, alpha, beta)
BEGIN_DOC
! Primitve nuclear attraction between the two primitves centered on the same atom.
!
! $p_1 = x^{a_x} y^{a_y} z^{a_z} \exp(-\alpha r^2)$
!
! $p_2 = x^{b_x} y^{b_y} z^{b_z} \exp(-\beta r^2)$
END_DOC
implicit none
integer, intent(in) :: a_x, a_y, a_z, b_x, b_y, b_z
complex*16, intent(in) :: alpha, beta
double precision :: V_phi, V_theta
complex*16 :: V_r_cosgtos
if( (iand(a_x + b_x, 1) == 1) .or. &
(iand(a_y + b_y, 1) == 1) .or. &
(iand(a_z + b_z, 1) == 1) ) then
V_n_e_cosgtos = (0.d0, 0.d0)
else
V_n_e_cosgtos = V_r_cosgtos(a_x + b_x + a_y + b_y + a_z + b_z + 1, alpha + beta) &
* V_phi(a_x + b_x, a_y + b_y) &
* V_theta(a_z + b_z, a_x + b_x + a_y + b_y + 1)
endif
end function V_n_e_cosgtos
! ---
complex*16 function V_r_cosgtos(n, alpha)
BEGIN_DOC
! Computes the radial part of the nuclear attraction integral:
!
! $\int_{0}^{\infty} r^n \exp(-\alpha r^2) dr$
!
END_DOC
implicit none
include 'utils/constants.include.F'
integer , intent(in) :: n
complex*16, intent(in) :: alpha
double precision :: fact
if(iand(n, 1) .eq. 1) then
V_r_cosgtos = 0.5d0 * fact(shiftr(n, 1)) / (alpha**(shiftr(n, 1) + 1))
else
V_r_cosgtos = sqpi * fact(n) / fact(shiftr(n, 1)) * (0.5d0/zsqrt(alpha))**(n+1)
endif
end function V_r_cosgtos
! ---

223
src/cosgtos_ao_int/one_e_kin_integrals.irp.f Normal file
View File

@ -0,0 +1,223 @@
! ---
BEGIN_PROVIDER [ double precision, ao_deriv2_cosgtos_x, (ao_num, ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_deriv2_cosgtos_y, (ao_num, ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_deriv2_cosgtos_z, (ao_num, ao_num) ]
implicit none
integer :: i, j, n, l, dim1, power_A(3), power_B(3)
double precision :: c, deriv_tmp
complex*16 :: alpha, beta, A_center(3), B_center(3)
complex*16 :: overlap_x, overlap_y, overlap_z, overlap
complex*16 :: overlap_x0_1, overlap_y0_1, overlap_z0_1
complex*16 :: overlap_x0_2, overlap_y0_2, overlap_z0_2
complex*16 :: overlap_m2_1, overlap_p2_1
complex*16 :: overlap_m2_2, overlap_p2_2
complex*16 :: deriv_tmp_1, deriv_tmp_2
dim1 = 100
! -- Dummy call to provide everything
A_center(:) = (0.0d0, 0.d0)
B_center(:) = (1.0d0, 0.d0)
alpha = (1.0d0, 0.d0)
beta = (0.1d0, 0.d0)
power_A = 1
power_B = 0
call overlap_cgaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
, overlap_x0_1, overlap_y0_1, overlap_z0_1, overlap, dim1 )
! ---
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
!$OMP DEFAULT(NONE) &
!$OMP PRIVATE( A_center, B_center, power_A, power_B, alpha, beta, i, j, l, n, c &
!$OMP , deriv_tmp, deriv_tmp_1, deriv_tmp_2 &
!$OMP , overlap_x, overlap_y, overlap_z, overlap &
!$OMP , overlap_m2_1, overlap_p2_1, overlap_m2_2, overlap_p2_2 &
!$OMP , overlap_x0_1, overlap_y0_1, overlap_z0_1, overlap_x0_2, overlap_y0_2, overlap_z0_2 ) &
!$OMP SHARED( nucl_coord, ao_power, ao_prim_num, ao_num, ao_nucl, dim1 &
!$OMP , ao_coef_norm_ord_transp_cosgtos, ao_expo_ord_transp_cosgtos &
!$OMP , ao_deriv2_cosgtos_x, ao_deriv2_cosgtos_y, ao_deriv2_cosgtos_z )
do j = 1, ao_num
A_center(1) = nucl_coord(ao_nucl(j),1) * (1.d0, 0.d0)
A_center(2) = nucl_coord(ao_nucl(j),2) * (1.d0, 0.d0)
A_center(3) = nucl_coord(ao_nucl(j),3) * (1.d0, 0.d0)
power_A(1) = ao_power(j,1)
power_A(2) = ao_power(j,2)
power_A(3) = ao_power(j,3)
do i = 1, ao_num
B_center(1) = nucl_coord(ao_nucl(i),1) * (1.d0, 0.d0)
B_center(2) = nucl_coord(ao_nucl(i),2) * (1.d0, 0.d0)
B_center(3) = nucl_coord(ao_nucl(i),3) * (1.d0, 0.d0)
power_B(1) = ao_power(i,1)
power_B(2) = ao_power(i,2)
power_B(3) = ao_power(i,3)
ao_deriv2_cosgtos_x(i,j) = 0.d0
ao_deriv2_cosgtos_y(i,j) = 0.d0
ao_deriv2_cosgtos_z(i,j) = 0.d0
do n = 1, ao_prim_num(j)
alpha = ao_expo_ord_transp_cosgtos(n,j)
do l = 1, ao_prim_num(i)
c = ao_coef_norm_ord_transp_cosgtos(n,j) * ao_coef_norm_ord_transp_cosgtos(l,i)
beta = ao_expo_ord_transp_cosgtos(l,i)
call overlap_cgaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
, overlap_x0_1, overlap_y0_1, overlap_z0_1, overlap, dim1 )
call overlap_cgaussian_xyz( A_center, B_center, alpha, conjg(beta), power_A, power_B &
, overlap_x0_2, overlap_y0_2, overlap_z0_2, overlap, dim1 )
! ---
power_A(1) = power_A(1) - 2
if(power_A(1) > -1) then
call overlap_cgaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
, overlap_m2_1, overlap_y, overlap_z, overlap, dim1 )
call overlap_cgaussian_xyz( A_center, B_center, alpha, conjg(beta), power_A, power_B &
, overlap_m2_2, overlap_y, overlap_z, overlap, dim1 )
else
overlap_m2_1 = (0.d0, 0.d0)
overlap_m2_2 = (0.d0, 0.d0)
endif
power_A(1) = power_A(1) + 4
call overlap_cgaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
, overlap_p2_1, overlap_y, overlap_z, overlap, dim1 )
call overlap_cgaussian_xyz( A_center, B_center, alpha, conjg(beta), power_A, power_B &
, overlap_p2_2, overlap_y, overlap_z, overlap, dim1 )
power_A(1) = power_A(1) - 2
deriv_tmp_1 = ( -2.d0 * alpha * (2.d0 * power_A(1) + 1.d0) * overlap_x0_1 &
+ power_A(1) * (power_A(1) - 1.d0) * overlap_m2_1 &
+ 4.d0 * alpha * alpha * overlap_p2_1 ) * overlap_y0_1 * overlap_z0_1
deriv_tmp_2 = ( -2.d0 * alpha * (2.d0 * power_A(1) + 1.d0) * overlap_x0_2 &
+ power_A(1) * (power_A(1) - 1.d0) * overlap_m2_2 &
+ 4.d0 * alpha * alpha * overlap_p2_2 ) * overlap_y0_2 * overlap_z0_2
deriv_tmp = 2.d0 * real(deriv_tmp_1 + deriv_tmp_2)
ao_deriv2_cosgtos_x(i,j) += c * deriv_tmp
! ---
power_A(2) = power_A(2) - 2
if(power_A(2) > -1) then
call overlap_cgaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
, overlap_x, overlap_m2_1, overlap_y, overlap, dim1 )
call overlap_cgaussian_xyz( A_center, B_center, alpha, conjg(beta), power_A, power_B &
, overlap_x, overlap_m2_2, overlap_y, overlap, dim1 )
else
overlap_m2_1 = (0.d0, 0.d0)
overlap_m2_2 = (0.d0, 0.d0)
endif
power_A(2) = power_A(2) + 4
call overlap_cgaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
, overlap_x, overlap_p2_1, overlap_y, overlap, dim1 )
call overlap_cgaussian_xyz( A_center, B_center, alpha, conjg(beta), power_A, power_B &
, overlap_x, overlap_p2_2, overlap_y, overlap, dim1 )
power_A(2) = power_A(2) - 2
deriv_tmp_1 = ( -2.d0 * alpha * (2.d0 * power_A(2) + 1.d0) * overlap_y0_1 &
+ power_A(2) * (power_A(2) - 1.d0) * overlap_m2_1 &
+ 4.d0 * alpha * alpha * overlap_p2_1 ) * overlap_x0_1 * overlap_z0_1
deriv_tmp_2 = ( -2.d0 * alpha * (2.d0 * power_A(2) + 1.d0) * overlap_y0_2 &
+ power_A(2) * (power_A(2) - 1.d0) * overlap_m2_2 &
+ 4.d0 * alpha * alpha * overlap_p2_2 ) * overlap_x0_2 * overlap_z0_2
deriv_tmp = 2.d0 * real(deriv_tmp_1 + deriv_tmp_2)
ao_deriv2_cosgtos_y(i,j) += c * deriv_tmp
! ---
power_A(3) = power_A(3) - 2
if(power_A(3) > -1) then
call overlap_cgaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
, overlap_x, overlap_y, overlap_m2_1, overlap, dim1 )
call overlap_cgaussian_xyz( A_center, B_center, alpha, conjg(beta), power_A, power_B &
, overlap_x, overlap_y, overlap_m2_2, overlap, dim1 )
else
overlap_m2_1 = (0.d0, 0.d0)
overlap_m2_2 = (0.d0, 0.d0)
endif
power_A(3) = power_A(3) + 4
call overlap_cgaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
, overlap_x, overlap_y, overlap_p2_1, overlap, dim1 )
call overlap_cgaussian_xyz( A_center, B_center, alpha, conjg(beta), power_A, power_B &
, overlap_x, overlap_y, overlap_p2_2, overlap, dim1 )
power_A(3) = power_A(3) - 2
deriv_tmp_1 = ( -2.d0 * alpha * (2.d0 * power_A(3) + 1.d0) * overlap_z0_1 &
+ power_A(3) * (power_A(3) - 1.d0) * overlap_m2_1 &
+ 4.d0 * alpha * alpha * overlap_p2_1 ) * overlap_x0_1 * overlap_y0_1
deriv_tmp_2 = ( -2.d0 * alpha * (2.d0 * power_A(3) + 1.d0) * overlap_z0_2 &
+ power_A(3) * (power_A(3) - 1.d0) * overlap_m2_2 &
+ 4.d0 * alpha * alpha * overlap_p2_2 ) * overlap_x0_2 * overlap_y0_2
deriv_tmp = 2.d0 * real(deriv_tmp_1 + deriv_tmp_2)
ao_deriv2_cosgtos_z(i,j) += c * deriv_tmp
! ---
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, ao_kinetic_integrals_cosgtos, (ao_num, ao_num)]
BEGIN_DOC
!
! Kinetic energy integrals in the cosgtos |AO| basis.
!
! $\langle \chi_i |\hat{T}| \chi_j \rangle$
!
END_DOC
implicit none
integer :: i, j
!$OMP PARALLEL DO DEFAULT(NONE) &
!$OMP PRIVATE(i, j) &
!$OMP SHARED(ao_num, ao_kinetic_integrals_cosgtos, ao_deriv2_cosgtos_x, ao_deriv2_cosgtos_y, ao_deriv2_cosgtos_z)
do j = 1, ao_num
do i = 1, ao_num
ao_kinetic_integrals_cosgtos(i,j) = -0.5d0 * ( ao_deriv2_cosgtos_x(i,j) &
+ ao_deriv2_cosgtos_y(i,j) &
+ ao_deriv2_cosgtos_z(i,j) )
enddo
enddo
!$OMP END PARALLEL DO
END_PROVIDER
! ---

1584
src/cosgtos_ao_int/two_e_Coul_integrals.irp.f Normal file
View File

File diff suppressed because it is too large Load Diff

2
src/iterations/print_extrapolation.irp.f
View File

@ -25,7 +25,7 @@ subroutine print_extrapolated_energy
write(*,*) 'minimum PT2 ', 'Extrapolated energy'
write(*,*) '=========== ', '==================='
do k=2,N_iter_p
write(*,'(F11.4,2X,F18.8)') pt2_iterations(1,k), extrapolated_energy(k,1)
write(*,'(F11.4,2X,F18.8)') pt2_iterations(1,N_iter_p+1-k), extrapolated_energy(k,1)
enddo
write(*,*) '=========== ', '==================='

5
src/mo_basis/utils.irp.f
View File

@ -3,7 +3,6 @@ subroutine save_mos
double precision, allocatable :: buffer(:,:)
integer :: i,j
call system('$QP_ROOT/scripts/save_current_mos.sh '//trim(ezfio_filename))
call ezfio_set_mo_basis_mo_num(mo_num)
call ezfio_set_mo_basis_mo_label(mo_label)
call ezfio_set_mo_basis_ao_md5(ao_md5)
@ -27,7 +26,7 @@ subroutine save_mos_no_occ
double precision, allocatable :: buffer(:,:)
integer :: i,j
call system('$QP_ROOT/scripts/save_current_mos.sh '//trim(ezfio_filename))
! call system('$QP_ROOT/scripts/save_current_mos.sh '//trim(ezfio_filename))
!call ezfio_set_mo_basis_mo_num(mo_num)
!call ezfio_set_mo_basis_mo_label(mo_label)
!call ezfio_set_mo_basis_ao_md5(ao_md5)
@ -48,7 +47,7 @@ subroutine save_mos_truncated(n)
double precision, allocatable :: buffer(:,:)
integer :: i,j,n
call system('$QP_ROOT/scripts/save_current_mos.sh '//trim(ezfio_filename))
! call system('$QP_ROOT/scripts/save_current_mos.sh '//trim(ezfio_filename))
call ezfio_set_mo_basis_mo_num(n)
call ezfio_set_mo_basis_mo_label(mo_label)

97
src/mo_localization/84.mo_localization.bats Normal file
View File

@ -0,0 +1,97 @@
#!/usr/bin/env bats
source $QP_ROOT/tests/bats/common.bats.sh
source $QP_ROOT/quantum_package.rc
zero () {
if [ -z "$1" ]; then echo 0.0; else echo $1; fi
}
function run() {
thresh1=1e-10
thresh2=1e-12
thresh3=1e-4
test_exe scf || skip
qp set_file $1
qp edit --check
qp reset -d
qp set_frozen_core
qp set localization localization_method boys
file="$(echo $1 | sed 's/.ezfio//g')"
energy="$(cat $1/hartree_fock/energy)"
fb_err1="$(qp run debug_gradient_loc | grep 'Max error' | tail -n 1 | awk '{print $3}')"
fb_err2="$(qp run debug_hessian_loc | grep 'Max error' | tail -n 1 | awk '{print $3}')"
qp run localization > $file.loc.out
fb_energy="$(qp run print_energy | grep -A 1 'Nuclear repulsion energy' | tail -n 1 )"
fb_c="$(cat $file.loc.out | grep 'Criterion:Core' | tail -n 1 | awk '{print $3}')i"
fb_i="$(cat $file.loc.out | grep 'Criterion:Inactive' | tail -n 1 | awk '{print $3}')"
fb_a="$(cat $file.loc.out | grep 'Criterion:Active' | tail -n 1 | awk '{print $3}')"
fb_v="$(cat $file.loc.out | grep 'Criterion:Virtual' | tail -n 1 | awk '{print $3}')"
qp reset -a
qp run scf
qp set_frozen_core
qp set localization localization_method pipek
pm_err1="$(qp run debug_gradient_loc | grep 'Max error' | tail -n 1 | awk '{print $3}')"
pm_err2="$(qp run debug_hessian_loc | grep 'Max error' | tail -n 1 | awk '{print $3}')"
qp run localization > $file.loc.out
pm_c="$(cat $file.loc.out | grep 'Criterion:Core' | tail -n 1 | awk '{print $3}')i"
pm_i="$(cat $file.loc.out | grep 'Criterion:Inactive' | tail -n 1 | awk '{print $3}')"
pm_a="$(cat $file.loc.out | grep 'Criterion:Active' | tail -n 1 | awk '{print $3}')"
pm_v="$(cat $file.loc.out | grep 'Criterion:Virtual' | tail -n 1 | awk '{print $3}')"
pm_energy="$(qp run print_energy | grep -A 1 'Nuclear repulsion energy' | tail -n 1 )"
qp set localization localization_method boys
qp reset -a
qp run scf
qp set_frozen_core
eq $energy $fb_energy $thresh1
eq $fb_err1 0.0 $thresh2
eq $fb_err2 0.0 $thresh2
eq $energy $pm_energy $thresh1
eq $pm_err1 0.0 $thresh2
eq $pm_err2 0.0 $thresh2
fb_c=$(zero $fb_c)
fb_i=$(zero $fb_i)
fb_a=$(zero $fb_a)
fb_v=$(zero $fb_v)
pm_c=$(zero $pm_c)
pm_i=$(zero $pm_i)
pm_a=$(zero $pm_a)
pm_v=$(zero $pm_v)
eq $fb_c $2 $thresh3
eq $fb_i $3 $thresh3
eq $fb_a $4 $thresh3
eq $fb_v $5 $thresh3
eq $pm_c $6 $thresh3
eq $pm_i $7 $thresh3
eq $pm_a $8 $thresh3
eq $pm_v $9 $thresh3
}
@test "b2_stretched" {
run b2_stretched.ezfio -32.1357551678876 -47.0041982094667 0.0 -223.470015856259 -1.99990778964451 -2.51376723927071 0.0 -12.8490602539275
}
@test "clo" {
run clo.ezfio -44.1624001765291 -32.4386660941387 0.0 -103.666309287187 -5.99985418946811 -5.46871580225222 0.0 -20.2480064922275
}
@test "clf" {
run clf.ezfio -47.5143398826967 -35.7206886315104 0.0 -107.043029033468 -5.99994222062230 -6.63916513458470 0.0 -19.7035159913484
}
@test "h2o2" {
run h2o2.ezfio -7.76848143170524 -30.9694344369829 0.0 -175.898343829453 -1.99990497554575 -5.62980322957485 0.0 -33.5699813186666
}
@test "h2o" {
run h2o.ezfio 0.0 -2.52317434969591 0.0 -45.3136377925359 0.0 -3.01248365356981 0.0 -22.4470831240924
}
@test "h3coh" {
run h3coh.ezfio -3.66763692804590 -24.0463089480870 0.0 -111.485948435075 -1.99714061342078 -4.89242181322988 0.0 -23.6405412057679
}
@test "n2h4" {
run n2h4.ezfio -7.46608163002070 -35.7632174051822 0.0 -305.913449004632 -1.99989326143356 -4.62496615892268 0.0 -51.5171904685553
}

54
src/mo_localization/EZFIO.cfg Normal file
View File

@ -0,0 +1,54 @@
[localization_method]
type: character*(32)
doc: Method for the orbital localization. boys: Foster-Boys, pipek: Pipek-Mezey.
interface: ezfio,provider,ocaml
default: boys
[localization_max_nb_iter]
type: integer
doc: Maximal number of iterations for the orbital localization.
interface: ezfio,provider,ocaml
default: 1000
[localization_use_hessian]
type: logical
doc: If true, it uses the trust region algorithm with the gradient and the diagonal of the hessian. Else it computes the rotation between each pair of MOs that should be applied to maximize/minimize the localization criterion. The last option is not easy to converge.
interface: ezfio,provider,ocaml
default: true
[auto_mo_class]
type: logical
doc: If true, set automatically the classes.
interface: ezfio,provider,ocaml
default: true
[thresh_loc_max_elem_grad]
type: double precision
doc: Threshold for the convergence, the localization exits when the largest element in the gradient is smaller than thresh_localization_max_elem_grad.
interface: ezfio,provider,ocaml
default: 1.e-6
[kick_in_mos]
type: logical
doc: If True, it applies a rotation of an angle angle_pre_rot between the MOs of a same mo_class before the localization.
interface: ezfio,provider,ocaml
default: true
[angle_pre_rot]
type: double precision
doc: To define the angle for the rotation of the MOs before the localization (in rad).
interface: ezfio,provider,ocaml
default: 0.1
[sort_mos_by_e]
type: logical
doc: If True, the MOs are sorted using the diagonal elements of the Fock matrix.
interface: ezfio,provider,ocaml
default: false
[debug_hf]
type: logical
doc: If True, prints the HF energy before/after the different steps of the localization. Only for debugging.
interface: ezfio,provider,ocaml
default: false

3
src/mo_localization/NEED Normal file
View File

@ -0,0 +1,3 @@
hartree_fock
utils_trust_region
determinants

113
src/mo_localization/README.md Normal file
View File

@ -0,0 +1,113 @@
# Orbital localisation
To localize the MOs:
```
qp run localization
```
By default, the different otbital classes are automatically set by splitting
the orbitales in the following classes:
- Core -> Core
- Active, doubly occupied -> Inactive
- Active, singly occupied -> Active
- Active, empty -> Virtual
- Deleted -> Deleted
The orbitals will be localized among each class, excpect the deleted ones.
If you want to choose another splitting, you can set
```
qp set mo_localization auto_mo_class false
```
and define the classes with
```
qp set_mo_class -c [] -a [] -v [] -i [] -d []
```
for more information
```
qp set_mo_class -q
```
We don't care about the name of the
mo classes. The algorithm just localizes all the MOs of
a given class between them, for all the classes, except the deleted MOs.
If you are using the last option don't forget to reset the initial mo classes
after the localization.
Before the localization, a kick is done for each mo class
(except the deleted ones) to break the MOs. This is done by
doing a given rotation between the MOs.
This feature can be removed by setting:
```
qp set localization kick_in_mos false
```
and the default angle for the rotation can be changed with:
```
qp set localization angle_pre_rot 1e-3 # or something else
```
After the localization, the MOs of each class (except the deleted ones)
can be sorted between them using the diagonal elements of
the fock matrix with:
```
qp set localization sort_mos_by_e true
```
You can check the Hartree-Fock energy before/during/after the localization
by putting (only for debugging):
```
qp set localization debug_hf true
```
## Foster-Boys & Pipek-Mezey
Foster-Boys:
```
qp set localization localization_method boys
```
Pipek-Mezey:
```
qp set localization localization_method pipek
```
# Break the spatial symmetry of the MOs
This program work exactly as the localization.
To break the spatial symmetry of the MOs:
```
qp run break_spatial_sym
```
The default angle for the rotations is too big for this kind of
application, a value between 1e-3 and 1e-6 should break the spatial
symmetry with just a small change in the energy:
```
qp set localization angle_pre_rot 1e-3
```
# With or without hessian + trust region
With hessian + trust region
```
qp set localization localisation_use_hessian true
```
It uses the trust region algorithm with the diagonal of the hessian of the
localization criterion with respect to the MO rotations.
Without the hessian and the trust region
```
qp set localization localisation_use_hessian false
```
By doing so it does not require to store the hessian but the
convergence is not easy, in particular for virtual MOs.
It seems that it not possible to converge with Pipek-Mezey
localization with this approach.
# Parameters
Some other parameters are available for the localization (qp edit for more details).
# Tests
```
qp test
```
# Org files
The org files are stored in the directory org in order to avoid overwriting on user changes.
The org files can be modified, to export the change to the source code, run
```
./TANGLE_org_mode.sh
mv *.irp.f ../.
```

27
src/mo_localization/break_spatial_sym.irp.f Normal file
View File

@ -0,0 +1,27 @@
! ! A small program to break the spatial symmetry of the MOs.
! ! You have to defined your MO classes or set security_mo_class to false
! ! with:
! ! qp set orbital_optimization security_mo_class false
! ! The default angle for the rotations is too big for this kind of
! ! application, a value between 1e-3 and 1e-6 should break the spatial
! ! symmetry with just a small change in the energy.
program break_spatial_sym
!BEGIN_DOC
! Break the symmetry of the MOs with a rotation
!END_DOC
implicit none
kick_in_mos = .True.
TOUCH kick_in_mos
call set_classes_loc
call apply_pre_rotation
call unset_classes_loc
end

65
src/mo_localization/debug_gradient_loc.irp.f Normal file
View File

@ -0,0 +1,65 @@
program debug_gradient_loc
!BEGIN_DOC
! Check if the gradient is correct
!END_DOC
implicit none
integer :: list_size, n
integer, allocatable :: list(:)
double precision, allocatable :: v_grad(:), v_grad2(:)
double precision :: norm, max_elem, threshold, max_error
integer :: i, nb_error
threshold = 1d-12
list_size = dim_list_act_orb
allocate(list(list_size))
list = list_act
n = list_size*(list_size-1)/2
allocate(v_grad(n),v_grad2(n))
if (localization_method == 'boys') then
print*,'Foster-Boys'
call gradient_FB(n,list_size,list,v_grad,max_elem,norm)
call gradient_FB_omp(n,list_size,list,v_grad2,max_elem,norm)
elseif (localization_method == 'pipek') then
print*,'Pipek-Mezey'
call gradient_PM(n,list_size,list,v_grad,max_elem,norm)
call gradient_PM(n,list_size,list,v_grad2,max_elem,norm)
else
print*,'Unknown localization_method, please select boys or pipek'
call abort
endif
do i = 1, n
print*,i,v_grad(i)
enddo
v_grad = v_grad - v_grad2
nb_error = 0
max_elem = 0d0
do i = 1, n
if (dabs(v_grad(i)) > threshold) then
print*,v_grad(i)
nb_error = nb_error + 1
if (dabs(v_grad(i)) > max_elem) then
max_elem = v_grad(i)
endif
endif
enddo
print*,'Threshold error', threshold
print*, 'Nb error', nb_error
print*,'Max error', max_elem
deallocate(v_grad,v_grad2)
end

65
src/mo_localization/debug_hessian_loc.irp.f Normal file
View File

@ -0,0 +1,65 @@
program debug_hessian_loc
!BEGIN_DOC
! Check if the hessian is correct
!END_DOC
implicit none
integer :: list_size, n
integer, allocatable :: list(:)
double precision, allocatable :: H(:), H2(:)
double precision :: threshold, max_error, max_elem
integer :: i, nb_error
threshold = 1d-12
list_size = dim_list_act_orb
allocate(list(list_size))
list = list_act
n = list_size*(list_size-1)/2
allocate(H(n),H2(n))
if (localization_method == 'boys') then
print*,'Foster-Boys'
call hessian_FB(n,list_size,list,H)
call hessian_FB_omp(n,list_size,list,H2)
elseif(localization_method == 'pipek') then
print*,'Pipek-Mezey'
call hessian_PM(n,list_size,list,H)
call hessian_PM(n,list_size,list,H2)
else
print*,'Unknown localization_method, please select boys or pipek'
call abort
endif
do i = 1, n
print*,i,H(i)
enddo
H = H - H2
nb_error = 0
max_elem = 0d0
do i = 1, n
if (dabs(H(i)) > threshold) then
print*,H(i)
nb_error = nb_error + 1
if (dabs(H(i)) > max_elem) then
max_elem = H(i)
endif
endif
enddo
print*,'Threshold error', threshold
print*, 'Nb error', nb_error
print*,'Max error', max_elem
deallocate(H,H2)
end

16
src/mo_localization/kick_the_mos.irp.f Normal file
View File

@ -0,0 +1,16 @@
program kick_the_mos
!BEGIN_DOC
! To do a small rotation of the MOs
!END_DOC
implicit none
kick_in_mos = .True.
TOUCH kick_in_mos
call set_classes_loc
call apply_pre_rotation
call unset_classes_loc
end

520
src/mo_localization/localization.irp.f Normal file
View File

@ -0,0 +1,520 @@
program localization
implicit none
call set_classes_loc
call run_localization
call unset_classes_loc
end
! Variables:
! | pre_rot(mo_num, mo_num) | double precision | Matrix for the pre rotation |
! | R(mo_num,mo_num) | double precision | Rotation matrix |
! | tmp_R(:,:) | double precision | Rottation matrix in a subsapce |
! | prev_mos(ao_num, mo_num) | double precision | Previous mo_coef |
! | spatial_extent(mo_num) | double precision | Spatial extent of the orbitals |
! | criterion | double precision | Localization criterion |
! | prev_criterion | double precision | Previous criterion |
! | criterion_model | double precision | Estimated next criterion |
! | rho | double precision | Ratio to measure the agreement between the model |
! | | | and the reality |
! | delta | double precision | Radisu of the trust region |
! | norm_grad | double precision | Norm of the gradient |
! | info | integer | for dsyev from Lapack |
! | max_elem | double precision | maximal element in the gradient |
! | v_grad(:) | double precision | Gradient |
! | H(:,:) | double precision | Hessian (diagonal) |
! | e_val(:) | double precision | Eigenvalues of the hessian |
! | W(:,:) | double precision | Eigenvectors of the hessian |
! | tmp_x(:) | double precision | Step in 1D (in a subaspace) |
! | tmp_m_x(:,:) | double precision | Step in 2D (in a subaspace) |
! | tmp_list(:) | double precision | List of MOs in a mo_class |
! | i,j,k | integer | Indexes in the full MO space |
! | tmp_i, tmp_j, tmp_k | integer | Indexes in a subspace |
! | l | integer | Index for the mo_class |
! | key(:) | integer | Key to sort the eigenvalues of the hessian |
! | nb_iter | integer | Number of iterations |
! | must_exit | logical | To exit the trust region loop |
! | cancel_step | logical | To cancel a step |
! | not_*converged | logical | To localize the different mo classes |
! | t* | double precision | To measure the time |
! | n | integer | mo_num*(mo_num-1)/2, number of orbital parameters |
! | tmp_n | integer | dim_subspace*(dim_subspace-1)/2 |
! | | | Number of dimension in the subspace |
! Variables in qp_edit for the localization:
! | localization_method |
! | localization_max_nb_iter |
! | default_mo_class |
! | thresh_loc_max_elem_grad |
! | kick_in_mos |
! | angle_pre_rot |
! + all the variables for the trust region
! Cf. qp_edit orbital optimization
subroutine run_localization
include 'pi.h'
BEGIN_DOC
! Orbital localization
END_DOC
implicit none
! Variables
double precision, allocatable :: pre_rot(:,:), R(:,:)
double precision, allocatable :: prev_mos(:,:), spatial_extent(:), tmp_R(:,:)
double precision :: criterion, norm_grad
integer :: i,j,k,l,p, tmp_i, tmp_j, tmp_k
integer :: info
integer :: n, tmp_n, tmp_list_size
double precision, allocatable :: v_grad(:), H(:), tmp_m_x(:,:), tmp_x(:),W(:),e_val(:)
double precision :: max_elem, t1, t2, t3, t4, t5, t6
integer, allocatable :: tmp_list(:), key(:)
double precision :: prev_criterion, rho, delta, criterion_model
integer :: nb_iter, nb_sub_iter
logical :: not_converged, not_core_converged
logical :: not_act_converged, not_inact_converged, not_virt_converged
logical :: use_trust_region, must_exit, cancel_step,enforce_step_cancellation
n = mo_num*(mo_num-1)/2
! Allocation
allocate(spatial_extent(mo_num))
allocate(pre_rot(mo_num, mo_num), R(mo_num, mo_num))
allocate(prev_mos(ao_num, mo_num))
! Locality before the localization
call compute_spatial_extent(spatial_extent)
! Choice of the method
print*,''
print*,'Localization method:',localization_method
if (localization_method == 'boys') then
print*,'Foster-Boys localization'
elseif (localization_method == 'pipek') then
print*,'Pipek-Mezey localization'
else
print*,'Unknown localization_method, please select boys or pipek'
call abort
endif
print*,''
! Localization criterion (FB, PM, ...) for each mo_class
print*,'### Before the pre rotation'
! Debug
if (debug_hf) then
print*,'HF energy:', HF_energy
endif
do l = 1, 4
if (l==1) then ! core
tmp_list_size = dim_list_core_orb
elseif (l==2) then ! act
tmp_list_size = dim_list_act_orb
elseif (l==3) then ! inact
tmp_list_size = dim_list_inact_orb
else ! virt
tmp_list_size = dim_list_virt_orb
endif
! Allocation tmp array
allocate(tmp_list(tmp_list_size))
! To give the list of MOs in a mo_class
if (l==1) then ! core
tmp_list = list_core
elseif (l==2) then
tmp_list = list_act
elseif (l==3) then
tmp_list = list_inact
else
tmp_list = list_virt
endif
if (tmp_list_size >= 2) then
call criterion_localization(tmp_list_size, tmp_list,criterion)
print*,'Criterion:', criterion, mo_class(tmp_list(1))
endif
deallocate(tmp_list)
enddo
! Debug
!print*,'HF', HF_energy
! Loc
! Pre rotation, to give a little kick in the MOs
call apply_pre_rotation()
! Criterion after the pre rotation
! Localization criterion (FB, PM, ...) for each mo_class
print*,'### After the pre rotation'
! Debug
if (debug_hf) then
touch mo_coef
print*,'HF energy:', HF_energy
endif
do l = 1, 4
if (l==1) then ! core
tmp_list_size = dim_list_core_orb
elseif (l==2) then ! act
tmp_list_size = dim_list_act_orb
elseif (l==3) then ! inact
tmp_list_size = dim_list_inact_orb
else ! virt
tmp_list_size = dim_list_virt_orb
endif
if (tmp_list_size >= 2) then
! Allocation tmp array
allocate(tmp_list(tmp_list_size))
! To give the list of MOs in a mo_class
if (l==1) then ! core
tmp_list = list_core
elseif (l==2) then
tmp_list = list_act
elseif (l==3) then
tmp_list = list_inact
else
tmp_list = list_virt
endif
call criterion_localization(tmp_list_size, tmp_list,criterion)
print*,'Criterion:', criterion, trim(mo_class(tmp_list(1)))
deallocate(tmp_list)
endif
enddo
! Debug
!print*,'HF', HF_energy
print*,''
print*,'========================'
print*,' Orbital localization'
print*,'========================'
print*,''
!Initialization
not_converged = .TRUE.
! To do the localization only if there is at least 2 MOs
if (dim_list_core_orb >= 2) then
not_core_converged = .TRUE.
else
not_core_converged = .FALSE.
endif
if (dim_list_act_orb >= 2) then
not_act_converged = .TRUE.
else
not_act_converged = .FALSE.
endif
if (dim_list_inact_orb >= 2) then
not_inact_converged = .TRUE.
else
not_inact_converged = .FALSE.
endif
if (dim_list_virt_orb >= 2) then
not_virt_converged = .TRUE.
else
not_virt_converged = .FALSE.
endif
! Loop over the mo_classes
do l = 1, 4
if (l==1) then ! core
not_converged = not_core_converged
tmp_list_size = dim_list_core_orb
elseif (l==2) then ! act
not_converged = not_act_converged
tmp_list_size = dim_list_act_orb
elseif (l==3) then ! inact
not_converged = not_inact_converged
tmp_list_size = dim_list_inact_orb
else ! virt
not_converged = not_virt_converged
tmp_list_size = dim_list_virt_orb
endif
! Next iteration if converged = true
if (.not. not_converged) then
cycle
endif
! Allocation tmp array
allocate(tmp_list(tmp_list_size))
! To give the list of MOs in a mo_class
if (l==1) then ! core
tmp_list = list_core
elseif (l==2) then
tmp_list = list_act
elseif (l==3) then
tmp_list = list_inact
else
tmp_list = list_virt
endif
! Display
if (not_converged) then
print*,''
print*,'###', trim(mo_class(tmp_list(1))), 'MOs ###'
print*,''
endif
! Size for the 2D -> 1D transformation
tmp_n = tmp_list_size * (tmp_list_size - 1)/2
! Without hessian + trust region
if (.not. localization_use_hessian) then
! Allocation of temporary arrays
allocate(v_grad(tmp_n), tmp_m_x(tmp_list_size, tmp_list_size))
allocate(tmp_R(tmp_list_size, tmp_list_size), tmp_x(tmp_n))
! Criterion
call criterion_localization(tmp_list_size, tmp_list, prev_criterion)
! Init
nb_iter = 0
delta = 1d0
!Loop
do while (not_converged)
print*,''
print*,'***********************'
print*,'Iteration', nb_iter
print*,'***********************'
print*,''
! Angles of rotation
call theta_localization(tmp_list, tmp_list_size, tmp_m_x, max_elem)
tmp_m_x = - tmp_m_x * delta
! Rotation submatrix
call rotation_matrix(tmp_m_x, tmp_list_size, tmp_R, tmp_list_size, tmp_list_size, &
info, enforce_step_cancellation)
! To ensure that the rotation matrix is unitary
if (enforce_step_cancellation) then
print*, 'Step cancellation, too large error in the rotation matrix'
delta = delta * 0.5d0
cycle
else
delta = min(delta * 2d0, 1d0)
endif
! Full rotation matrix and application of the rotation
call sub_to_full_rotation_matrix(tmp_list_size, tmp_list, tmp_R, R)
call apply_mo_rotation(R, prev_mos)
! Update the needed data
call update_data_localization()
! New criterion
call criterion_localization(tmp_list_size, tmp_list, criterion)
print*,'Criterion:', trim(mo_class(tmp_list(1))), nb_iter, criterion
print*,'Max elem :', max_elem
print*,'Delta :', delta
nb_iter = nb_iter + 1
! Exit
if (nb_iter >= localization_max_nb_iter .or. dabs(max_elem) < thresh_loc_max_elem_grad) then
not_converged = .False.
endif
enddo
! Save the changes
call update_data_localization()
call save_mos()
TOUCH mo_coef
! Deallocate
deallocate(v_grad, tmp_m_x, tmp_list)
deallocate(tmp_R, tmp_x)
! Trust region
else
! Allocation of temporary arrays
allocate(v_grad(tmp_n), H(tmp_n), tmp_m_x(tmp_list_size, tmp_list_size))
allocate(tmp_R(tmp_list_size, tmp_list_size))
allocate(tmp_x(tmp_n), W(tmp_n), e_val(tmp_n), key(tmp_n))
! ### Initialization ###
delta = 0d0 ! can be deleted (normally)
nb_iter = 0 ! Must start at 0 !!!
rho = 0.5d0 ! Must be 0.5
! Compute the criterion before the loop
call criterion_localization(tmp_list_size, tmp_list, prev_criterion)
! Loop until the convergence
do while (not_converged)
print*,''
print*,'***********************'
print*,'Iteration', nb_iter
print*,'***********************'
print*,''
! Gradient
call gradient_localization(tmp_n, tmp_list_size, tmp_list, v_grad, max_elem, norm_grad)
! Diagonal hessian
call hessian_localization(tmp_n, tmp_list_size, tmp_list, H)
! Diagonalization of the diagonal hessian by hands
!call diagonalization_hessian(tmp_n,H,e_val,w)
do i = 1, tmp_n
e_val(i) = H(i)
enddo
! Key list for dsort
do i = 1, tmp_n
key(i) = i
enddo
! Sort of the eigenvalues
call dsort(e_val, key, tmp_n)
! Eigenvectors
W = 0d0
do i = 1, tmp_n
W(i) = dble(key(i))
enddo
! To enter in the loop just after
cancel_step = .True.
nb_sub_iter = 0
! Loop to reduce the trust radius until the criterion decreases and rho >= thresh_rho
do while (cancel_step)
print*,'-----------------------------'
print*, mo_class(tmp_list(1))
print*,'Iteration:', nb_iter
print*,'Sub iteration:', nb_sub_iter
print*,'Max elem grad:', max_elem
print*,'-----------------------------'
! Hessian,gradient,Criterion -> x
call trust_region_step_w_expected_e(tmp_n,1, H, W, e_val, v_grad, prev_criterion, &
rho, nb_iter, delta, criterion_model, tmp_x, must_exit)
! Internal loop exit condition
if (must_exit) then
print*,'trust_region_step_w_expected_e sent: Exit'
exit
endif
! 1D tmp -> 2D tmp
call vec_to_mat_v2(tmp_n, tmp_list_size, tmp_x, tmp_m_x)
! Rotation submatrix (square matrix tmp_list_size by tmp_list_size)
call rotation_matrix(tmp_m_x, tmp_list_size, tmp_R, tmp_list_size, tmp_list_size, &
info, enforce_step_cancellation)
if (enforce_step_cancellation) then
print*, 'Step cancellation, too large error in the rotation matrix'
rho = 0d0
cycle
endif
! tmp_R to R, subspace to full space
call sub_to_full_rotation_matrix(tmp_list_size, tmp_list, tmp_R, R)
! Rotation of the MOs
call apply_mo_rotation(R, prev_mos)
! Update the things related to mo_coef
call update_data_localization()
! Update the criterion
call criterion_localization(tmp_list_size, tmp_list, criterion)
print*,'Criterion:', trim(mo_class(tmp_list(1))), nb_iter, criterion
! Criterion -> step accepted or rejected
call trust_region_is_step_cancelled(nb_iter, prev_criterion, criterion, &
criterion_model, rho, cancel_step)
! Cancellation of the step, previous MOs
if (cancel_step) then
mo_coef = prev_mos
endif
nb_sub_iter = nb_sub_iter + 1
enddo
!call save_mos() !### depend of the time for 1 iteration
! To exit the external loop if must_exti = .True.
if (must_exit) then
exit
endif
! Step accepted, nb iteration + 1
nb_iter = nb_iter + 1
! External loop exit conditions
if (DABS(max_elem) < thresh_loc_max_elem_grad) then
not_converged = .False.
endif
if (nb_iter > localization_max_nb_iter) then
not_converged = .False.
endif
enddo
! Deallocation of temporary arrays
deallocate(v_grad, H, tmp_m_x, tmp_R, tmp_list, tmp_x, W, e_val, key)
! Save the MOs
call save_mos()
TOUCH mo_coef
! Debug
if (debug_hf) then
touch mo_coef
print*,'HF energy:', HF_energy
endif
endif
enddo
! Seems unecessary
TOUCH mo_coef
! To sort the MOs using the diagonal elements of the Fock matrix
if (sort_mos_by_e) then
call run_sort_by_fock_energies()
endif
! Debug
if (debug_hf) then
touch mo_coef
print*,'HF energy:', HF_energy
endif
! Locality after the localization
call compute_spatial_extent(spatial_extent)
end

2008
src/mo_localization/localization_sub.irp.f Normal file
View File

File diff suppressed because it is too large Load Diff

7
src/mo_localization/org/TANGLE_org_mode.sh Executable file
View File

@ -0,0 +1,7 @@
#!/bin/sh
list='ls *.org'
for element in $list
do
emacs --batch $element -f org-babel-tangle
done

28
src/mo_localization/org/break_spatial_sym.org Normal file
View File

@ -0,0 +1,28 @@
! A small program to break the spatial symmetry of the MOs.
! You have to defined your MO classes or set security_mo_class to false
! with:
! qp set orbital_optimization security_mo_class false
! The default angle for the rotations is too big for this kind of
! application, a value between 1e-3 and 1e-6 should break the spatial
! symmetry with just a small change in the energy.
#+BEGIN_SRC f90 :comments org :tangle break_spatial_sym.irp.f
program break_spatial_sym
!BEGIN_DOC
! Break the symmetry of the MOs with a rotation
!END_DOC
implicit none
kick_in_mos = .True.
TOUCH kick_in_mos
call set_classes_loc
call apply_pre_rotation
call unset_classes_loc
end
#+END_SRC

67
src/mo_localization/org/debug_gradient_loc.org Normal file
View File

@ -0,0 +1,67 @@
#+BEGIN_SRC f90 :comments org :tangle debug_gradient_loc.irp.f
program debug_gradient_loc
!BEGIN_DOC
! Check if the gradient is correct
!END_DOC
implicit none
integer :: list_size, n
integer, allocatable :: list(:)
double precision, allocatable :: v_grad(:), v_grad2(:)
double precision :: norm, max_elem, threshold, max_error
integer :: i, nb_error
threshold = 1d-12
list_size = dim_list_act_orb
allocate(list(list_size))
list = list_act
n = list_size*(list_size-1)/2
allocate(v_grad(n),v_grad2(n))
if (localization_method == 'boys') then
print*,'Foster-Boys'
call gradient_FB(n,list_size,list,v_grad,max_elem,norm)
call gradient_FB_omp(n,list_size,list,v_grad2,max_elem,norm)
elseif (localization_method == 'pipek') then
print*,'Pipek-Mezey'
call gradient_PM(n,list_size,list,v_grad,max_elem,norm)
call gradient_PM(n,list_size,list,v_grad2,max_elem,norm)
else
print*,'Unknown localization_method, please select boys or pipek'
call abort
endif
do i = 1, n
print*,i,v_grad(i)
enddo
v_grad = v_grad - v_grad2
nb_error = 0
max_elem = 0d0
do i = 1, n
if (dabs(v_grad(i)) > threshold) then
print*,v_grad(i)
nb_error = nb_error + 1
if (dabs(v_grad(i)) > max_elem) then
max_elem = v_grad(i)
endif
endif
enddo
print*,'Threshold error', threshold
print*, 'Nb error', nb_error
print*,'Max error', max_elem
deallocate(v_grad,v_grad2)
end
#+END_SRC

67
src/mo_localization/org/debug_hessian_loc.org Normal file
View File

@ -0,0 +1,67 @@
#+BEGIN_SRC f90 :comments org :tangle debug_hessian_loc.irp.f
program debug_hessian_loc
!BEGIN_DOC
! Check if the hessian is correct
!END_DOC
implicit none
integer :: list_size, n
integer, allocatable :: list(:)
double precision, allocatable :: H(:), H2(:)
double precision :: threshold, max_error, max_elem
integer :: i, nb_error
threshold = 1d-12
list_size = dim_list_act_orb
allocate(list(list_size))
list = list_act
n = list_size*(list_size-1)/2
allocate(H(n),H2(n))
if (localization_method == 'boys') then
print*,'Foster-Boys'
call hessian_FB(n,list_size,list,H)
call hessian_FB_omp(n,list_size,list,H2)
elseif(localization_method == 'pipek') then
print*,'Pipek-Mezey'
call hessian_PM(n,list_size,list,H)
call hessian_PM(n,list_size,list,H2)
else
print*,'Unknown localization_method, please select boys or pipek'
call abort
endif
do i = 1, n
print*,i,H(i)
enddo
H = H - H2
nb_error = 0
max_elem = 0d0
do i = 1, n
if (dabs(H(i)) > threshold) then
print*,H(i)
nb_error = nb_error + 1
if (dabs(H(i)) > max_elem) then
max_elem = H(i)
endif
endif
enddo
print*,'Threshold error', threshold
print*, 'Nb error', nb_error
print*,'Max error', max_elem
deallocate(H,H2)
end
#+END_SRC

18
src/mo_localization/org/kick_the_mos.org Normal file
View File

@ -0,0 +1,18 @@
#+BEGIN_SRC f90 :comments org :tangle kick_the_mos.irp.f
program kick_the_mos
!BEGIN_DOC
! To do a small rotation of the MOs
!END_DOC
implicit none
kick_in_mos = .True.
TOUCH kick_in_mos
call set_classes_loc
call apply_pre_rotation
call unset_classes_loc
end
#+END_SRC

2899
src/mo_localization/org/localization.org Normal file
View File

File diff suppressed because it is too large Load Diff

62
src/mo_optimization/83.mo_optimization.bats Normal file
View File

@ -0,0 +1,62 @@
#!/usr/bin/env bats
source $QP_ROOT/tests/bats/common.bats.sh
source $QP_ROOT/quantum_package.rc
function run() {
thresh=2e-3
test_exe scf || skip
qp set_file $1
qp edit --check
qp reset -a
qp run scf
qp set_frozen_core
qp set determinants n_states 2
qp set determinants read_wf true
qp set mo_two_e_ints io_mo_two_e_integrals None
file="$(echo $1 | sed 's/.ezfio//g')"
qp run cis
qp run debug_gradient_list_opt > $file.debug_g.out
err3="$(grep 'Max error:' $file.debug_g.out | awk '{print $3}')"
qp run debug_hessian_list_opt > $file.debug_h1.out
err1="$(grep 'Max error:' $file.debug_h1.out | awk '{print $3}')"
qp run orb_opt > $file.opt1.out
energy1="$(grep 'State average energy:' $file.opt1.out | tail -n 1 | awk '{print $4}')"
qp set orbital_optimization optimization_method diag
qp reset -d
qp run scf
qp run cis
qp run debug_hessian_list_opt > $file.debug_h2.out
err2="$(grep 'Max error_H:' $file.debug_h2.out | awk '{print $3}')"
qp run orb_opt > $file.opt2.out
energy2="$(grep 'State average energy:' $file.opt2.out | tail -n 1 | awk '{print $4}')"
qp set orbital_optimization optimization_method full
qp reset -d
qp run scf
eq $energy1 $2 $thresh
eq $energy2 $3 $thresh
eq $err1 0.0 1e-12
eq $err2 0.0 1e-12
eq $err3 0.0 1e-12
}
@test "b2_stretched" {
run b2_stretched.ezfio -48.9852901484277 -48.9852937541510
}
@test "h2o" {
run h2o.ezfio -75.9025622449206 -75.8691844585879
}
@test "h2s" {
run h2s.ezfio -398.576255809878 -398.574145943928
}
@test "hbo" {
run hbo.ezfio -99.9234823022109 -99.9234763597840
}
@test "hco" {
run hco.ezfio -113.204915552241 -113.204905207050
}

23
src/mo_optimization/EZFIO.cfg Normal file
View File

@ -0,0 +1,23 @@
[optimization_method]
type: character*(32)
doc: Define the kind of hessian for the orbital optimization full : full hessian, diag : diagonal hessian, none : no hessian
interface: ezfio,provider,ocaml
default: full
[n_det_max_opt]
type: integer
doc: Maximal number of the determinants in the wf for the orbital optimization (to stop the optimization if n_det > n_det_max_opt)
interface: ezfio,provider,ocaml
default: 200000
[optimization_max_nb_iter]
type: integer
doc: Maximal number of iterations for the orbital optimization
interface: ezfio,provider,ocaml
default: 20
[thresh_opt_max_elem_grad]
type: double precision
doc: Threshold for the convergence, the optimization exits when the biggest element in the gradient is smaller than thresh_optimization_max_elem_grad
interface: ezfio,provider,ocaml
default: 1.e-5

7
src/mo_optimization/NEED Normal file
View File

@ -0,0 +1,7 @@
two_body_rdm
hartree_fock
cipsi
davidson_undressed
selectors_full
generators_full
utils_trust_region

74
src/mo_optimization/README.md Normal file
View File

@ -0,0 +1,74 @@
# Orbital optimization
## Methods
Different methods are available:
- full hessian
```
qp set orbital_optimization optimization_method full
```
- diagonal hessian
```
qp set orbital_optimization optimization_method diag
```
- identity matrix
```
qp set orbital_optimization optimization_method none
```
After the optimization the ezfio contains the optimized orbitals
## For a fixed number of determinants
To optimize the MOs for the actual determinants:
```
qp run orb_opt
```
## For a complete optimization, i.e, with a larger and larger wave function
To optimize the MOs with a larger and larger wave function:
```
qp run optimization
```
The results are stored in the EZFIO in "mo_optimization/result_opt",
with the following format:
(1) (2) (3) (4)
1: Number of determinants in the wf,
2: Cispi energy before the optimization,
3: Cipsi energy after the optimization,
4: Energy difference between (2) and (3).
The optimization process if the following:
- we do a first cipsi step to obtain a small number of determinants in the wf
- we run an orbital optimization for this wf
- we do a new cipsi step to double the number of determinants in the wf
- we run an orbital optimization for this wf
- ...
- we do that until the energy difference between (2) and (3) is
smaller than the targeted accuracy for the cispi (targeted_accuracy_cipsi in qp edit)
or the wf is larger than a given size (n_det_max_opt in qp_edit)
- after that you can reset your determinants (qp reset -d) and run a clean Cispi calculation
### End of the optimization
You can choos the number of determinants after what the
optimization will stop:
```
qp set orbital_optimization n_det_max_opt 1e5 # or any number
```
## Weight of the states
You can change the weights of the differents states directly in qp edit.
It will affect ths weights used in the orbital optimization.
# Tests
To run the tests:
```
qp test
```
# Org files
The org files are stored in the directory org in order to avoid overwriting on user changes.
The org files can be modified, to export the change to the source code, run
```
./TANGLE_org_mode.sh
mv *.irp.f ../.
```

12
src/mo_optimization/class.irp.f Normal file
View File

@ -0,0 +1,12 @@
BEGIN_PROVIDER [ logical, do_only_1h1p ]
&BEGIN_PROVIDER [ logical, do_only_cas ]
&BEGIN_PROVIDER [ logical, do_ddci ]
implicit none
BEGIN_DOC
! In the FCI case, all those are always false
END_DOC
do_only_1h1p = .False.
do_only_cas = .False.
do_ddci = .False.
END_PROVIDER

1
src/mo_optimization/constants.h Normal file
View File

@ -0,0 +1 @@
logical, parameter :: debug=.False.

78
src/mo_optimization/debug_gradient_list_opt.irp.f Normal file
View File

@ -0,0 +1,78 @@
! Debug the gradient
! *Program to check the gradient*
! The program compares the result of the first and last code for the
! gradient.
! Provided:
! | mo_num | integer | number of MOs |
! Internal:
! | n | integer | number of orbitals pairs (p,q) p<q |
! | v_grad(n) | double precision | Original gradient |
! | v_grad2(n) | double precision | Gradient |
! | i | integer | index |
! | threshold | double precision | threshold for the errors |
! | max_error | double precision | maximal error in the gradient |
! | nb_error | integer | number of error in the gradient |
program debug_gradient_list
implicit none
! Variables
double precision, allocatable :: v_grad(:), v_grad2(:)
integer :: n,m
integer :: i
double precision :: threshold
double precision :: max_error, max_elem, norm
integer :: nb_error
m = dim_list_act_orb
! Definition of n
n = m*(m-1)/2
PROVIDE mo_two_e_integrals_in_map ! Vérifier pour suppression
! Allocation
allocate(v_grad(n), v_grad2(n))
! Calculation
call diagonalize_ci ! Vérifier pour suppression
! Gradient
call gradient_list_opt(n,m,list_act,v_grad,max_elem,norm)
call first_gradient_list_opt(n,m,list_act,v_grad2)
v_grad = v_grad - v_grad2
nb_error = 0
max_error = 0d0
threshold = 1d-12
do i = 1, n
if (ABS(v_grad(i)) > threshold) then
print*,i,v_grad(i)
nb_error = nb_error + 1
if (ABS(v_grad(i)) > max_error) then
max_error = v_grad(i)
endif
endif
enddo
print*,''
print*,'Check the gradient'
print*,'Threshold:', threshold
print*,'Nb error:', nb_error
print*,'Max error:', max_error
! Deallocation
deallocate(v_grad,v_grad2)
end program

76
src/mo_optimization/debug_gradient_opt.irp.f Normal file
View File

@ -0,0 +1,76 @@
! Debug the gradient
! *Program to check the gradient*
! The program compares the result of the first and last code for the
! gradient.
! Provided:
! | mo_num | integer | number of MOs |
! Internal:
! | n | integer | number of orbitals pairs (p,q) p<q |
! | v_grad(n) | double precision | Original gradient |
! | v_grad2(n) | double precision | Gradient |
! | i | integer | index |
! | threshold | double precision | threshold for the errors |
! | max_error | double precision | maximal error in the gradient |
! | nb_error | integer | number of error in the gradient |
program debug_gradient
implicit none
! Variables
double precision, allocatable :: v_grad(:), v_grad2(:)
integer :: n
integer :: i
double precision :: threshold
double precision :: max_error, max_elem
integer :: nb_error
! Definition of n
n = mo_num*(mo_num-1)/2
PROVIDE mo_two_e_integrals_in_map ! Vérifier pour suppression
! Allocation
allocate(v_grad(n), v_grad2(n))
! Calculation
call diagonalize_ci ! Vérifier pour suppression
! Gradient
call first_gradient_opt(n,v_grad)
call gradient_opt(n,v_grad2,max_elem)
v_grad = v_grad - v_grad2
nb_error = 0
max_error = 0d0
threshold = 1d-12
do i = 1, n
if (ABS(v_grad(i)) > threshold) then
print*,v_grad(i)
nb_error = nb_error + 1
if (ABS(v_grad(i)) > max_error) then
max_error = v_grad(i)
endif
endif
enddo
print*,''
print*,'Check the gradient'
print*,'Threshold :', threshold
print*,'Nb error :', nb_error
print*,'Max error :', max_error
! Deallocation
deallocate(v_grad,v_grad2)
end program

147
src/mo_optimization/debug_hessian_list_opt.irp.f Normal file
View File

@ -0,0 +1,147 @@
! Debug the hessian
! *Program to check the hessian matrix*
! The program compares the result of the first and last code for the
! hessian. First of all the 4D hessian and after the 2D hessian.
! Provided:
! | mo_num | integer | number of MOs |
! | optimization_method | string | Method for the orbital optimization: |
! | | | - 'full' -> full hessian |
! | | | - 'diag' -> diagonal hessian |
! | dim_list_act_orb | integer | number of active MOs |
! | list_act(dim_list_act_orb) | integer | list of the actives MOs |
! | | | |
! Internal:
! | m | integer | number of MOs in the list |
! | | | (active MOs) |
! | n | integer | number of orbitals pairs (p,q) p<q |
! | | | n = m*(m-1)/2 |
! | H(n,n) | double precision | Original hessian matrix (2D) |
! | H2(n,n) | double precision | Hessian matrix (2D) |
! | h_f(mo_num,mo_num,mo_num,mo_num) | double precision | Original hessian matrix (4D) |
! | h_f2(mo_num,mo_num,mo_num,mo_num) | double precision | Hessian matrix (4D) |
! | i,j,p,q,k | integer | indexes |
! | threshold | double precision | threshold for the errors |
! | max_error | double precision | maximal error in the 4D hessian |
! | max_error_H | double precision | maximal error in the 2D hessian |
! | nb_error | integer | number of errors in the 4D hessian |
! | nb_error_H | integer | number of errors in the 2D hessian |
program debug_hessian_list_opt
implicit none
! Variables
double precision, allocatable :: H(:,:),H2(:,:), h_f(:,:,:,:), h_f2(:,:,:,:)
integer :: n,m
integer :: i,j,k,l
double precision :: max_error, max_error_H
integer :: nb_error, nb_error_H
double precision :: threshold
m = dim_list_act_orb !mo_num
! Definition of n
n = m*(m-1)/2
PROVIDE mo_two_e_integrals_in_map ! Vérifier pour suppression
! Hessian
if (optimization_method == 'full') then
print*,'Use the full hessian matrix'
allocate(H(n,n),H2(n,n))
allocate(h_f(m,m,m,m),h_f2(m,m,m,m))
call hessian_list_opt(n,m,list_act,H,h_f)
call first_hessian_list_opt(n,m,list_act,H2,h_f2)
!call hessian_opt(n,H2,h_f2)
! Difference
h_f = h_f - h_f2
H = H - H2
max_error = 0d0
nb_error = 0
threshold = 1d-12
do l = 1, m
do k= 1, m
do j = 1, m
do i = 1, m
if (ABS(h_f(i,j,k,l)) > threshold) then
print*,h_f(i,j,k,l)
nb_error = nb_error + 1
if (ABS(h_f(i,j,k,l)) > ABS(max_error)) then
max_error = h_f(i,j,k,l)
endif
endif
enddo
enddo
enddo
enddo
max_error_H = 0d0
nb_error_H = 0
do j = 1, n
do i = 1, n
if (ABS(H(i,j)) > threshold) then
print*, H(i,j)
nb_error_H = nb_error_H + 1
if (ABS(H(i,j)) > ABS(max_error_H)) then
max_error_H = H(i,j)
endif
endif
enddo
enddo
! Deallocation
deallocate(H, H2, h_f, h_f2)
else
print*, 'Use the diagonal hessian matrix'
allocate(H(n,1),H2(n,1))
call diag_hessian_list_opt(n,m,list_act,H)
call first_diag_hessian_list_opt(n,m,list_act,H2)
H = H - H2
max_error_H = 0d0
nb_error_H = 0
do i = 1, n
if (ABS(H(i,1)) > threshold) then
print*, H(i,1)
nb_error_H = nb_error_H + 1
if (ABS(H(i,1)) > ABS(max_error_H)) then
max_error_H = H(i,1)
endif
endif
enddo
endif
print*,''
if (optimization_method == 'full') then
print*,'Check of the full hessian'
print*,'Threshold:', threshold
print*,'Nb error:', nb_error
print*,'Max error:', max_error
print*,''
else
print*,'Check of the diagonal hessian'
endif
print*,'Nb error_H:', nb_error_H
print*,'Max error_H:', max_error_H
end program

171
src/mo_optimization/debug_hessian_opt.irp.f Normal file
View File

@ -0,0 +1,171 @@
! Debug the hessian
! *Program to check the hessian matrix*
! The program compares the result of the first and last code for the
! hessian. First of all the 4D hessian and after the 2D hessian.
! Provided:
! | mo_num | integer | number of MOs |
! Internal:
! | n | integer | number of orbitals pairs (p,q) p<q |
! | H(n,n) | double precision | Original hessian matrix (2D) |
! | H2(n,n) | double precision | Hessian matrix (2D) |
! | h_f(mo_num,mo_num,mo_num,mo_num) | double precision | Original hessian matrix (4D) |
! | h_f2(mo_num,mo_num,mo_num,mo_num) | double precision | Hessian matrix (4D) |
! | method | integer | - 1: full hessian |
! | | | - 2: diagonal hessian |
! | i,j,p,q,k | integer | indexes |
! | threshold | double precision | threshold for the errors |
! | max_error | double precision | maximal error in the 4D hessian |
! | max_error_H | double precision | maximal error in the 2D hessian |
! | nb_error | integer | number of errors in the 4D hessian |
! | nb_error_H | integer | number of errors in the 2D hessian |
program debug_hessian
implicit none
! Variables
double precision, allocatable :: H(:,:),H2(:,:), h_f(:,:,:,:), h_f2(:,:,:,:)
integer :: n
integer :: i,j,k,l
double precision :: max_error, max_error_H
integer :: nb_error, nb_error_H
double precision :: threshold
! Definition of n
n = mo_num*(mo_num-1)/2
PROVIDE mo_two_e_integrals_in_map ! Vérifier pour suppression
! Allocation
allocate(H(n,n),H2(n,n))
allocate(h_f(mo_num,mo_num,mo_num,mo_num),h_f2(mo_num,mo_num,mo_num,mo_num))
! Calculation
! Hessian
if (optimization_method == 'full') then
print*,'Use the full hessian matrix'
call hessian_opt(n,H,h_f)
call first_hessian_opt(n,H2,h_f2)
! Difference
h_f = h_f - h_f2
H = H - H2
max_error = 0d0
nb_error = 0
threshold = 1d-12
do l = 1, mo_num
do k= 1, mo_num
do j = 1, mo_num
do i = 1, mo_num
if (ABS(h_f(i,j,k,l)) > threshold) then
print*,h_f(i,j,k,l)
nb_error = nb_error + 1
if (ABS(h_f(i,j,k,l)) > ABS(max_error)) then
max_error = h_f(i,j,k,l)
endif
endif
enddo
enddo
enddo
enddo
max_error_H = 0d0
nb_error_H = 0
do j = 1, n
do i = 1, n
if (ABS(H(i,j)) > threshold) then
print*, H(i,j)
nb_error_H = nb_error_H + 1
if (ABS(H(i,j)) > ABS(max_error_H)) then
max_error_H = H(i,j)
endif
endif
enddo
enddo
elseif (optimization_method == 'diag') then
print*, 'Use the diagonal hessian matrix'
call diag_hessian_opt(n,H,h_f)
call first_diag_hessian_opt(n,H2,h_f2)
h_f = h_f - h_f2
max_error = 0d0
nb_error = 0
threshold = 1d-12
do l = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do i = 1, mo_num
if (ABS(h_f(i,j,k,l)) > threshold) then
print*,h_f(i,j,k,l)
nb_error = nb_error + 1
if (ABS(h_f(i,j,k,l)) > ABS(max_error)) then
max_error = h_f(i,j,k,l)
endif
endif
enddo
enddo
enddo
enddo
h=H-H2
max_error_H = 0d0
nb_error_H = 0
do j = 1, n
do i = 1, n
if (ABS(H(i,j)) > threshold) then
print*, H(i,j)
nb_error_H = nb_error_H + 1
if (ABS(H(i,j)) > ABS(max_error_H)) then
max_error_H = H(i,j)
endif
endif
enddo
enddo
else
print*,'Unknown optimization_method, please select full, diag'
call abort
endif
print*,''
if (optimization_method == 'full') then
print*,'Check the full hessian'
else
print*,'Check the diagonal hessian'
endif
print*,'Threshold :', threshold
print*,'Nb error :', nb_error
print*,'Max error :', max_error
print*,''
print*,'Nb error_H :', nb_error_H
print*,'Max error_H :', max_error_H
! Deallocation
deallocate(H,H2,h_f,h_f2)
end program

1556
src/mo_optimization/diagonal_hessian_list_opt.irp.f Normal file
View File

File diff suppressed because it is too large Load Diff

1511
src/mo_optimization/diagonal_hessian_opt.irp.f Normal file
View File

File diff suppressed because it is too large Load Diff

136
src/mo_optimization/diagonalization_hessian.irp.f Normal file
View File

@ -0,0 +1,136 @@
! Diagonalization of the hessian
! Just a matrix diagonalization using Lapack
! Input:
! | n | integer | mo_num*(mo_num-1)/2 |
! | H(n,n) | double precision | hessian |
! Output:
! | e_val(n) | double precision | eigenvalues of the hessian |
! | w(n,n) | double precision | eigenvectors of the hessian |
! Internal:
! | nb_negative_nv | integer | number of negative eigenvalues |
! | lwork | integer | for Lapack |
! | work(lwork,n) | double precision | temporary array for Lapack |
! | info | integer | if 0 -> ok, else problem in the diagonalization |
! | i,j | integer | dummy indexes |
subroutine diagonalization_hessian(n,H,e_val,w)
include 'constants.h'
implicit none
! Variables
! in
integer, intent(in) :: n
double precision, intent(in) :: H(n,n)
! out
double precision, intent(out) :: e_val(n), w(n,n)
! internal
double precision, allocatable :: work(:,:)
integer, allocatable :: key(:)
integer :: info,lwork
integer :: i,j
integer :: nb_negative_vp
double precision :: t1,t2,t3,max_elem
print*,''
print*,'---Diagonalization_hessian---'
call wall_time(t1)
if (optimization_method == 'full') then
! Allocation
! For Lapack
lwork=3*n-1
allocate(work(lwork,n))
! Calculation
! Copy the hessian matrix, the eigenvectors will be store in W
W=H
! Diagonalization of the hessian
call dsyev('V','U',n,W,size(W,1),e_val,work,lwork,info)
if (info /= 0) then
print*, 'Error diagonalization : diagonalization_hessian'
print*, 'info = ', info
call ABORT
endif
if (debug) then
print *, 'vp Hess:'
write(*,'(100(F10.5))') real(e_val(:))
endif
! Number of negative eigenvalues
max_elem = 0d0
nb_negative_vp = 0
do i = 1, n
if (e_val(i) < 0d0) then
nb_negative_vp = nb_negative_vp + 1
if (e_val(i) < max_elem) then
max_elem = e_val(i)
endif
!print*,'e_val < 0 :', e_val(i)
endif
enddo
print*,'Number of negative eigenvalues:', nb_negative_vp
print*,'Lowest eigenvalue:',max_elem
!nb_negative_vp = 0
!do i = 1, n
! if (e_val(i) < -thresh_eig) then
! nb_negative_vp = nb_negative_vp + 1
! endif
!enddo
!print*,'Number of negative eigenvalues <', -thresh_eig,':', nb_negative_vp
! Deallocation
deallocate(work)
elseif (optimization_method == 'diag') then
! Diagonalization of the diagonal hessian by hands
allocate(key(n))
do i = 1, n
e_val(i) = H(i,i)
enddo
! Key list for dsort
do i = 1, n
key(i) = i
enddo
! Sort of the eigenvalues
call dsort(e_val, key, n)
! Eigenvectors
W = 0d0
do i = 1, n
j = key(i)
W(j,i) = 1d0
enddo
deallocate(key)
else
print*,'Diagonalization_hessian, abort'
call abort
endif
call wall_time(t2)
t3 = t2 - t1
print*,'Time in diagonalization_hessian:', t3
print*,'---End diagonalization_hessian---'
end subroutine

372
src/mo_optimization/first_diagonal_hessian_list_opt.irp.f Normal file
View File

@ -0,0 +1,372 @@
subroutine first_diag_hessian_list_opt(tmp_n,m,list,H)!, h_tmpr)
include 'constants.h'
implicit none
!===========================================================================
! Compute the diagonal hessian of energy with respects to orbital rotations
!===========================================================================
!===========
! Variables
!===========
! in
integer, intent(in) :: tmp_n, m, list(m)
! tmp_n : integer, tmp_n = m*(m-1)/2
! out
double precision, intent(out) :: H(tmp_n)!, h_tmpr(m,m,m,m)
! H : n by n double precision matrix containing the 2D hessian
! internal
double precision, allocatable :: hessian(:,:,:,:), tmp(:,:),h_tmpr(:,:,:,:)
integer :: p,q, tmp_p,tmp_q
integer :: r,s,t,u,v,tmp_r,tmp_s,tmp_t,tmp_u,tmp_v
integer :: pq,rs,tmp_pq,tmp_rs
double precision :: t1,t2,t3
! hessian : mo_num 4D double precision matrix containing the hessian before the permutations
! h_tmpr : mo_num 4D double precision matrix containing the hessian after the permutations
! p,q,r,s : integer, indexes of the 4D hessian matrix
! t,u,v : integer, indexes to compute hessian elements
! pq,rs : integer, indexes for the conversion from 4D to 2D hessian matrix
! t1,t2,t3 : double precision, t3 = t2 - t1, time to compute the hessian
! Function
double precision :: get_two_e_integral
! get_two_e_integral : double precision function, two e integrals
! Provided :
! mo_one_e_integrals : mono e- integrals
! get_two_e_integral : two e- integrals
! one_e_dm_mo_alpha, one_e_dm_mo_beta : one body density matrix
! two_e_dm_mo : two body density matrix
print*,'---first_diag_hess_list---'
!============
! Allocation
!============
allocate(hessian(m,m,m,m),tmp(tmp_n,tmp_n),h_tmpr(mo_num,mo_num,mo_num,mo_num))
!=============
! Calculation
!=============
! From Anderson et. al. (2014)
! The Journal of Chemical Physics 141, 244104 (2014); doi: 10.1063/1.4904384
! LaTeX formula :
!\begin{align*}
!H_{pq,rs} &= \dfrac{\partial^2 E(x)}{\partial x_{pq}^2} \\
!&= \mathcal{P}_{pq} \mathcal{P}_{rs} [ \frac{1}{2} \sum_u [\delta_{qr}(h_p^u \gamma_u^s + h_u^s \gamma_p^u)
!+ \delta_{ps}(h_r^u \gamma_u^q + h_u^q \gamma_u^r)]
!-(h_p^s \gamma_r^q + h_r^q \gamma_p^s) \\
!&+ \frac{1}{2} \sum_{tuv} [\delta_{qr}(v_{pt}^{uv} \Gamma_{uv}^{st} +v_{uv}^{st} \Gamma_{pt}^{uv})
!+ \delta_{ps}(v_{uv}^{qt} \Gamma_{rt}^{uv} + v_{rt}^{uv}\Gamma_{uv}^{qt})] \\
!&+ \sum_{uv} (v_{pr}^{uv} \Gamma_{uv}^{qs} + v_{uv}^{qs} \Gamma_{ps}^{uv}) \\
!&- \sum_{tu} (v_{pu}^{st} \Gamma_{rt}^{qu}+v_{pu}^{tr} \Gamma_{tr}^{qu}+v_{rt}^{qu}\Gamma_{pu}^{st} + v_{tr}^{qu}\Gamma_{pu}^{ts})
!\end{align*}
!================
! Initialization
!================
hessian = 0d0
CALL wall_time(t1)
!========================
! First line, first term
!========================
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
if (q==r) then
do u = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) + 0.5d0 * ( &
mo_one_e_integrals(u,p) * one_e_dm_mo(u,s) &
+ mo_one_e_integrals(s,u) * one_e_dm_mo(p,u))
enddo
endif
endif
enddo
enddo
enddo
enddo
!=========================
! First line, second term
!=========================
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
if (p==s) then
do u = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) + 0.5d0 * ( &
mo_one_e_integrals(u,r) * one_e_dm_mo(u,q) &
+ mo_one_e_integrals(q,u) * one_e_dm_mo(r,u))
enddo
endif
endif
enddo
enddo
enddo
enddo
!========================
! First line, third term
!========================
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) &
- mo_one_e_integrals(s,p) * one_e_dm_mo(r,q) &
- mo_one_e_integrals(q,r) * one_e_dm_mo(p,s)
endif
enddo
enddo
enddo
enddo
!=========================
! Second line, first term
!=========================
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
if (q==r) then
do t = 1, mo_num
do u = 1, mo_num
do v = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) + 0.5d0 * ( &
get_two_e_integral(u,v,p,t,mo_integrals_map) * two_e_dm_mo(u,v,s,t) &
+ get_two_e_integral(s,t,u,v,mo_integrals_map) * two_e_dm_mo(p,t,u,v))
enddo
enddo
enddo
endif
endif
enddo
enddo
enddo
enddo
!==========================
! Second line, second term
!==========================
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
if (p==s) then
do t = 1, mo_num
do u = 1, mo_num
do v = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) + 0.5d0 * ( &
get_two_e_integral(q,t,u,v,mo_integrals_map) * two_e_dm_mo(r,t,u,v) &
+ get_two_e_integral(u,v,r,t,mo_integrals_map) * two_e_dm_mo(u,v,q,t))
enddo
enddo
enddo
endif
endif
enddo
enddo
enddo
enddo
!========================
! Third line, first term
!========================
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
do u = 1, mo_num
do v = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) &
+ get_two_e_integral(u,v,p,r,mo_integrals_map) * two_e_dm_mo(u,v,q,s) &
+ get_two_e_integral(q,s,u,v,mo_integrals_map) * two_e_dm_mo(p,r,u,v)
enddo
enddo
endif
enddo
enddo
enddo
enddo
!=========================
! Third line, second term
!=========================
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
do t = 1, mo_num
do u = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) &
- get_two_e_integral(s,t,p,u,mo_integrals_map) * two_e_dm_mo(r,t,q,u) &
- get_two_e_integral(t,s,p,u,mo_integrals_map) * two_e_dm_mo(t,r,q,u) &
- get_two_e_integral(q,u,r,t,mo_integrals_map) * two_e_dm_mo(p,u,s,t) &
- get_two_e_integral(q,u,t,r,mo_integrals_map) * two_e_dm_mo(p,u,t,s)
enddo
enddo
endif
enddo
enddo
enddo
enddo
CALL wall_time(t2)
t2 = t2 - t1
print*, 'Time to compute the hessian :', t2
!==============
! Permutations
!==============
! Convert the hessian mo_num * mo_num * mo_num * mo_num matrix in a
! 2D n * n matrix (n = mo_num*(mo_num-1)/2)
! H(pq,rs) : p<q and r<s
do tmp_r = 1, m
do tmp_s = 1, m
do tmp_q = 1, m
do tmp_p = 1, m
h_tmpr(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) - hessian(tmp_q,tmp_p,tmp_r,tmp_s) &
- hessian(tmp_p,tmp_q,tmp_s,tmp_r) + hessian(tmp_q,tmp_p,tmp_s,tmp_r)
enddo
enddo
enddo
enddo
!========================
! 4D matrix -> 2D matrix
!========================
! Convert the hessian mo_num * mo_num * mo_num * mo_num matrix in a
! 2D n * n matrix (n = mo_num*(mo_num-1)/2)
! H(pq,rs) : p<q and r<s
! 4D mo_num matrix to 2D n matrix
do tmp_rs = 1, tmp_n
call vec_to_mat_index(tmp_rs,tmp_r,tmp_s)
do tmp_pq = 1, tmp_n
call vec_to_mat_index(tmp_pq,tmp_p,tmp_q)
tmp(tmp_pq,tmp_rs) = h_tmpr(tmp_p,tmp_q,tmp_r,tmp_s)
enddo
enddo
do p = 1, tmp_n
H(p) = tmp(p,p)
enddo
! Display
if (debug) then
print*,'2D diag Hessian matrix'
do tmp_pq = 1, tmp_n
write(*,'(100(F10.5))') tmp(tmp_pq,:)
enddo
endif
!==============
! Deallocation
!==============
deallocate(hessian,h_tmpr,tmp)
print*,'---End first_diag_hess_list---'
end subroutine

344
src/mo_optimization/first_diagonal_hessian_opt.irp.f Normal file
View File

@ -0,0 +1,344 @@
subroutine first_diag_hessian_opt(n,H, h_tmpr)
include 'constants.h'
implicit none
!===========================================================================
! Compute the diagonal hessian of energy with respects to orbital rotations
!===========================================================================
!===========
! Variables
!===========
! in
integer, intent(in) :: n
! n : integer, n = mo_num*(mo_num-1)/2
! out
double precision, intent(out) :: H(n,n), h_tmpr(mo_num,mo_num,mo_num,mo_num)
! H : n by n double precision matrix containing the 2D hessian
! internal
double precision, allocatable :: hessian(:,:,:,:)
integer :: p,q
integer :: r,s,t,u,v
integer :: pq,rs
double precision :: t1,t2,t3
! hessian : mo_num 4D double precision matrix containing the hessian before the permutations
! h_tmpr : mo_num 4D double precision matrix containing the hessian after the permutations
! p,q,r,s : integer, indexes of the 4D hessian matrix
! t,u,v : integer, indexes to compute hessian elements
! pq,rs : integer, indexes for the conversion from 4D to 2D hessian matrix
! t1,t2,t3 : double precision, t3 = t2 - t1, time to compute the hessian
! Function
double precision :: get_two_e_integral
! get_two_e_integral : double precision function, two e integrals
! Provided :
! mo_one_e_integrals : mono e- integrals
! get_two_e_integral : two e- integrals
! one_e_dm_mo_alpha, one_e_dm_mo_beta : one body density matrix
! two_e_dm_mo : two body density matrix
!============
! Allocation
!============
allocate(hessian(mo_num,mo_num,mo_num,mo_num))!,h_tmpr(mo_num,mo_num,mo_num,mo_num))
!=============
! Calculation
!=============
if (debug) then
print*,'Enter in first_diag_hessien'
endif
! From Anderson et. al. (2014)
! The Journal of Chemical Physics 141, 244104 (2014); doi: 10.1063/1.4904384
! LaTeX formula :
!\begin{align*}
!H_{pq,rs} &= \dfrac{\partial^2 E(x)}{\partial x_{pq}^2} \\
!&= \mathcal{P}_{pq} \mathcal{P}_{rs} [ \frac{1}{2} \sum_u [\delta_{qr}(h_p^u \gamma_u^s + h_u^s \gamma_p^u)
!+ \delta_{ps}(h_r^u \gamma_u^q + h_u^q \gamma_u^r)]
!-(h_p^s \gamma_r^q + h_r^q \gamma_p^s) \\
!&+ \frac{1}{2} \sum_{tuv} [\delta_{qr}(v_{pt}^{uv} \Gamma_{uv}^{st} +v_{uv}^{st} \Gamma_{pt}^{uv})
!+ \delta_{ps}(v_{uv}^{qt} \Gamma_{rt}^{uv} + v_{rt}^{uv}\Gamma_{uv}^{qt})] \\
!&+ \sum_{uv} (v_{pr}^{uv} \Gamma_{uv}^{qs} + v_{uv}^{qs} \Gamma_{ps}^{uv}) \\
!&- \sum_{tu} (v_{pu}^{st} \Gamma_{rt}^{qu}+v_{pu}^{tr} \Gamma_{tr}^{qu}+v_{rt}^{qu}\Gamma_{pu}^{st} + v_{tr}^{qu}\Gamma_{pu}^{ts})
!\end{align*}
!================
! Initialization
!================
hessian = 0d0
CALL wall_time(t1)
!========================
! First line, first term
!========================
do p = 1, mo_num
do q = 1, mo_num
do r = 1, mo_num
do s = 1, mo_num
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
if (q==r) then
do u = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) + 0.5d0 * ( &
mo_one_e_integrals(u,p) * one_e_dm_mo(u,s) &
+ mo_one_e_integrals(s,u) * one_e_dm_mo(p,u))
enddo
endif
endif
enddo
enddo
enddo
enddo
!=========================
! First line, second term
!=========================
do p = 1, mo_num
do q = 1, mo_num
do r = 1, mo_num
do s = 1, mo_num
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
if (p==s) then
do u = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) + 0.5d0 * ( &
mo_one_e_integrals(u,r) * one_e_dm_mo(u,q) &
+ mo_one_e_integrals(q,u) * one_e_dm_mo(r,u))
enddo
endif
endif
enddo
enddo
enddo
enddo
!========================
! First line, third term
!========================
do p = 1, mo_num
do q = 1, mo_num
do r = 1, mo_num
do s = 1, mo_num
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
hessian(p,q,r,s) = hessian(p,q,r,s) &
- mo_one_e_integrals(s,p) * one_e_dm_mo(r,q) &
- mo_one_e_integrals(q,r) * one_e_dm_mo(p,s)
endif
enddo
enddo
enddo
enddo
!=========================
! Second line, first term
!=========================
do p = 1, mo_num
do q = 1, mo_num
do r = 1, mo_num
do s = 1, mo_num
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
if (q==r) then
do t = 1, mo_num
do u = 1, mo_num
do v = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) + 0.5d0 * ( &
get_two_e_integral(u,v,p,t,mo_integrals_map) * two_e_dm_mo(u,v,s,t) &
+ get_two_e_integral(s,t,u,v,mo_integrals_map) * two_e_dm_mo(p,t,u,v))
enddo
enddo
enddo
endif
endif
enddo
enddo
enddo
enddo
!==========================
! Second line, second term
!==========================
do p = 1, mo_num
do q = 1, mo_num
do r = 1, mo_num
do s = 1, mo_num
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
if (p==s) then
do t = 1, mo_num
do u = 1, mo_num
do v = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) + 0.5d0 * ( &
get_two_e_integral(q,t,u,v,mo_integrals_map) * two_e_dm_mo(r,t,u,v) &
+ get_two_e_integral(u,v,r,t,mo_integrals_map) * two_e_dm_mo(u,v,q,t))
enddo
enddo
enddo
endif
endif
enddo
enddo
enddo
enddo
!========================
! Third line, first term
!========================
do p = 1, mo_num
do q = 1, mo_num
do r = 1, mo_num
do s = 1, mo_num
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
do u = 1, mo_num
do v = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) &
+ get_two_e_integral(u,v,p,r,mo_integrals_map) * two_e_dm_mo(u,v,q,s) &
+ get_two_e_integral(q,s,u,v,mo_integrals_map) * two_e_dm_mo(p,r,u,v)
enddo
enddo
endif
enddo
enddo
enddo
enddo
!=========================
! Third line, second term
!=========================
do p = 1, mo_num
do q = 1, mo_num
do r = 1, mo_num
do s = 1, mo_num
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
do t = 1, mo_num
do u = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) &
- get_two_e_integral(s,t,p,u,mo_integrals_map) * two_e_dm_mo(r,t,q,u) &
- get_two_e_integral(t,s,p,u,mo_integrals_map) * two_e_dm_mo(t,r,q,u) &
- get_two_e_integral(q,u,r,t,mo_integrals_map) * two_e_dm_mo(p,u,s,t) &
- get_two_e_integral(q,u,t,r,mo_integrals_map) * two_e_dm_mo(p,u,t,s)
enddo
enddo
endif
enddo
enddo
enddo
enddo
CALL wall_time(t2)
t2 = t2 - t1
print*, 'Time to compute the hessian :', t2
!==============
! Permutations
!==============
! Convert the hessian mo_num * mo_num * mo_num * mo_num matrix in a
! 2D n * n matrix (n = mo_num*(mo_num-1)/2)
! H(pq,rs) : p<q and r<s
do r = 1, mo_num
do s = 1, mo_num
do q = 1, mo_num
do p = 1, mo_num
h_tmpr(p,q,r,s) = (hessian(p,q,r,s) - hessian(q,p,r,s) - hessian(p,q,s,r) + hessian(q,p,s,r))
enddo
enddo
enddo
enddo
!========================
! 4D matrix -> 2D matrix
!========================
! Convert the hessian mo_num * mo_num * mo_num * mo_num matrix in a
! 2D n * n matrix (n = mo_num*(mo_num-1)/2)
! H(pq,rs) : p<q and r<s
! 4D mo_num matrix to 2D n matrix
do rs = 1, n
call vec_to_mat_index(rs,r,s)
do pq = 1, n
call vec_to_mat_index(pq,p,q)
H(pq,rs) = h_tmpr(p,q,r,s)
enddo
enddo
! Display
if (debug) then
print*,'2D diag Hessian matrix'
do pq = 1, n
write(*,'(100(F10.5))') H(pq,:)
enddo
endif
!==============
! Deallocation
!==============
deallocate(hessian)
if (debug) then
print*,'Leave first_diag_hessien'
endif
end subroutine

125
src/mo_optimization/first_gradient_list_opt.irp.f Normal file
View File

@ -0,0 +1,125 @@
! First gradient
subroutine first_gradient_list_opt(tmp_n,m,list,v_grad)
include 'constants.h'
implicit none
!===================================================================
! Compute the gradient of energy with respects to orbital rotations
!===================================================================
! Check if read_wf = true, else :
! qp set determinant read_wf true
! in
integer, intent(in) :: tmp_n,m,list(m)
! n : integer, n = m*(m-1)/2
! m = list_size
! out
double precision, intent(out) :: v_grad(tmp_n)
! v_grad : double precision vector of length n containeing the gradient
! internal
double precision, allocatable :: grad(:,:),A(:,:)
double precision :: norm
integer :: i,p,q,r,s,t,tmp_i,tmp_p,tmp_q,tmp_r,tmp_s,tmp_t
! grad : double precision matrix containing the gradient before the permutation
! A : double precision matrix containing the gradient after the permutation
! norm : double precision number, the norm of the vector gradient
! i,p,q,r,s,t : integer, indexes
! istate : integer, the electronic state
! Function
double precision :: get_two_e_integral, norm2
! get_two_e_integral : double precision function that gives the two e integrals
! norm2 : double precision function that gives the norm of a vector
! Provided :
! mo_one_e_integrals : mono e- integrals
! get_two_e_integral : two e- integrals
! one_e_dm_mo : one body density matrix (state average)
! two_e_dm_mo : two body density matrix (state average)
print*,'---first_gradient_list---'
!============
! Allocation
!============
allocate(grad(m,m),A(m,m))
!=============
! Calculation
!=============
v_grad = 0d0
grad = 0d0
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
!grad(tmp_p,tmp_q) = 0d0
do r = 1, mo_num
grad(tmp_p,tmp_q) = grad(tmp_p,tmp_q) + mo_one_e_integrals(p,r) * one_e_dm_mo(r,q) &
- mo_one_e_integrals(r,q) * one_e_dm_mo(p,r)
enddo
do r = 1, mo_num
do s = 1, mo_num
do t = 1, mo_num
grad(tmp_p,tmp_q) = grad(tmp_p,tmp_q) &
+ get_two_e_integral(p,t,r,s,mo_integrals_map) * two_e_dm_mo(r,s,q,t) &
- get_two_e_integral(r,s,q,t,mo_integrals_map) * two_e_dm_mo(p,t,r,s)
enddo
enddo
enddo
enddo
enddo
! Conversion mo_num*mo_num matrix to mo_num(mo_num-1)/2 vector
do tmp_i = 1, tmp_n
call vec_to_mat_index(tmp_i,tmp_p,tmp_q)
v_grad(tmp_i)=(grad(tmp_p,tmp_q) - grad(tmp_q,tmp_p))
enddo
! Display, vector containing the gradient elements
if (debug) then
print*,'Vector containing the gradient :'
write(*,'(100(F10.5))') v_grad(1:tmp_n)
endif
! Norm of the vector
norm = norm2(v_grad)
print*, 'Norm : ', norm
! Matrix gradient
A = 0d0
do tmp_q = 1, m
do tmp_p = 1, m
A(tmp_p,tmp_q) = grad(tmp_p,tmp_q) - grad(tmp_q,tmp_p)
enddo
enddo
! Display, matrix containting the gradient elements
if (debug) then
print*,'Matrix containing the gradient :'
do tmp_i = 1, m
write(*,'(100(E12.5))') A(tmp_i,1:m)
enddo
endif
!==============
! Deallocation
!==============
deallocate(grad,A)
print*,'---End first_gradient_list---'
end subroutine

128
src/mo_optimization/first_gradient_opt.irp.f Normal file
View File

@ -0,0 +1,128 @@
! First gradient
subroutine first_gradient_opt(n,v_grad)
include 'constants.h'
implicit none
!===================================================================
! Compute the gradient of energy with respects to orbital rotations
!===================================================================
! Check if read_wf = true, else :
! qp set determinant read_wf true
END_DOC
! in
integer, intent(in) :: n
! n : integer, n = mo_num*(mo_num-1)/2
! out
double precision, intent(out) :: v_grad(n)
! v_grad : double precision vector of length n containeing the gradient
! internal
double precision, allocatable :: grad(:,:),A(:,:)
double precision :: norm
integer :: i,p,q,r,s,t
integer :: istate
! grad : double precision matrix containing the gradient before the permutation
! A : double precision matrix containing the gradient after the permutation
! norm : double precision number, the norm of the vector gradient
! i,p,q,r,s,t : integer, indexes
! istate : integer, the electronic state
! Function
double precision :: get_two_e_integral, norm2
! get_two_e_integral : double precision function that gives the two e integrals
! norm2 : double precision function that gives the norm of a vector
! Provided :
! mo_one_e_integrals : mono e- integrals
! get_two_e_integral : two e- integrals
! one_e_dm_mo : one body density matrix (state average)
! two_e_dm_mo : two body density matrix (state average)
!============
! Allocation
!============
allocate(grad(mo_num,mo_num),A(mo_num,mo_num))
!=============
! Calculation
!=============
if (debug) then
print*,'---first_gradient---'
endif
v_grad = 0d0
do p = 1, mo_num
do q = 1, mo_num
grad(p,q) = 0d0
do r = 1, mo_num
grad(p,q) = grad(p,q) + mo_one_e_integrals(p,r) * one_e_dm_mo(r,q) &
- mo_one_e_integrals(r,q) * one_e_dm_mo(p,r)
enddo
do r = 1, mo_num
do s = 1, mo_num
do t= 1, mo_num
grad(p,q) = grad(p,q) &
+ get_two_e_integral(p,t,r,s,mo_integrals_map) * two_e_dm_mo(r,s,q,t) &
- get_two_e_integral(r,s,q,t,mo_integrals_map) * two_e_dm_mo(p,t,r,s)
enddo
enddo
enddo
enddo
enddo
! Conversion mo_num*mo_num matrix to mo_num(mo_num-1)/2 vector
do i=1,n
call vec_to_mat_index(i,p,q)
v_grad(i)=(grad(p,q) - grad(q,p))
enddo
! Display, vector containing the gradient elements
if (debug) then
print*,'Vector containing the gradient :'
write(*,'(100(F10.5))') v_grad(1:n)
endif
! Norm of the vector
norm = norm2(v_grad)
print*, 'Norm : ', norm
! Matrix gradient
A = 0d0
do q=1,mo_num
do p=1,mo_num
A(p,q) = grad(p,q) - grad(q,p)
enddo
enddo
! Display, matrix containting the gradient elements
if (debug) then
print*,'Matrix containing the gradient :'
do i = 1, mo_num
write(*,'(100(E12.5))') A(i,1:mo_num)
enddo
endif
!==============
! Deallocation
!==============
deallocate(grad,A)
if (debug) then
print*,'---End first_gradient---'
endif
end subroutine

365
src/mo_optimization/first_hessian_list_opt.irp.f Normal file
View File

@ -0,0 +1,365 @@
subroutine first_hessian_list_opt(tmp_n,m,list,H,h_tmpr)
include 'constants.h'
implicit none
!==================================================================
! Compute the hessian of energy with respects to orbital rotations
!==================================================================
!===========
! Variables
!===========
! in
integer, intent(in) :: tmp_n, m, list(m)
!tmp_n : integer, tmp_n = m*(m-1)/2
! out
double precision, intent(out) :: H(tmp_n,tmp_n),h_tmpr(m,m,m,m)
! H : n by n double precision matrix containing the 2D hessian
! internal
double precision, allocatable :: hessian(:,:,:,:)
integer :: p,q, tmp_p,tmp_q
integer :: r,s,t,u,v,tmp_r,tmp_s,tmp_t,tmp_u,tmp_v
integer :: pq,rs,tmp_pq,tmp_rs
double precision :: t1,t2,t3,t4,t5,t6
! hessian : mo_num 4D double precision matrix containing the hessian before the permutations
! h_tmpr : mo_num 4D double precision matrix containing the hessian after the permutations
! p,q,r,s : integer, indexes of the 4D hessian matrix
! t,u,v : integer, indexes to compute hessian elements
! pq,rs : integer, indexes for the conversion from 4D to 2D hessian matrix
! t1,t2,t3 : double precision, t3 = t2 - t1, time to compute the hessian
! Funtion
double precision :: get_two_e_integral
! get_two_e_integral : double precision function, two e integrals
! Provided :
! mo_one_e_integrals : mono e- integrals
! get_two_e_integral : two e- integrals
! one_e_dm_mo_alpha, one_e_dm_mo_beta : one body density matrix
! two_e_dm_mo : two body density matrix
!============
! Allocation
!============
allocate(hessian(m,m,m,m))
!=============
! Calculation
!=============
print*,'---first_hess_list---'
! From Anderson et. al. (2014)
! The Journal of Chemical Physics 141, 244104 (2014); doi: 10.1063/1.4904384
CALL wall_time(t1)
! Initialization
hessian = 0d0
!========================
! First line, first term
!========================
CALL wall_time(t4)
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
if (q==r) then
do u = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) + 0.5d0 * ( &
mo_one_e_integrals(u,p) * one_e_dm_mo(u,s) &
+ mo_one_e_integrals(s,u) * one_e_dm_mo(p,u))
enddo
endif
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l1 1 :', t6
!=========================
! First line, second term
!=========================
CALL wall_time(t4)
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
if (p==s) then
do u = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) + 0.5d0 * ( &
mo_one_e_integrals(u,r) * one_e_dm_mo(u,q) &
+ mo_one_e_integrals(q,u) * one_e_dm_mo(r,u))
enddo
endif
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l1 2 :', t6
!========================
! First line, third term
!========================
CALL wall_time(t4)
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) &
- mo_one_e_integrals(s,p) * one_e_dm_mo(r,q)&
- mo_one_e_integrals(q,r) * one_e_dm_mo(p,s)
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l1 3 :', t6
!=========================
! Second line, first term
!=========================
CALL wall_time(t4)
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
if (q==r) then
do t = 1, mo_num
do u = 1, mo_num
do v = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) + 0.5d0 * ( &
get_two_e_integral(u,v,p,t,mo_integrals_map) * two_e_dm_mo(u,v,s,t) &
+ get_two_e_integral(s,t,u,v,mo_integrals_map) * two_e_dm_mo(p,t,u,v))
enddo
enddo
enddo
endif
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l2 1 :', t6
!==========================
! Second line, second term
!==========================
CALL wall_time(t4)
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
if (p==s) then
do t = 1, mo_num
do u = 1, mo_num
do v = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) + 0.5d0 * ( &
get_two_e_integral(q,t,u,v,mo_integrals_map) * two_e_dm_mo(r,t,u,v) &
+ get_two_e_integral(u,v,r,t,mo_integrals_map) * two_e_dm_mo(u,v,q,t))
enddo
enddo
enddo
endif
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l2 2 :', t6
!========================
! Third line, first term
!========================
CALL wall_time(t4)
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
do u = 1, mo_num
do v = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) &
+ get_two_e_integral(u,v,p,r,mo_integrals_map) * two_e_dm_mo(u,v,q,s) &
+ get_two_e_integral(q,s,u,v,mo_integrals_map) * two_e_dm_mo(p,r,u,v)
enddo
enddo
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l3 1 :', t6
!=========================
! Third line, second term
!=========================
CALL wall_time(t4)
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
do t = 1, mo_num
do u = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) &
- get_two_e_integral(s,t,p,u,mo_integrals_map) * two_e_dm_mo(r,t,q,u) &
- get_two_e_integral(t,s,p,u,mo_integrals_map) * two_e_dm_mo(t,r,q,u) &
- get_two_e_integral(q,u,r,t,mo_integrals_map) * two_e_dm_mo(p,u,s,t) &
- get_two_e_integral(q,u,t,r,mo_integrals_map) * two_e_dm_mo(p,u,t,s)
enddo
enddo
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l3 2 :', t6
CALL wall_time(t2)
t3 = t2 -t1
print*,'Time to compute the hessian : ', t3
!==============
! Permutations
!==============
! Hessian(p,q,r,s) = P_pq P_rs [ ...]
! => Hessian(p,q,r,s) = (p,q,r,s) - (q,p,r,s) - (p,q,s,r) + (q,p,s,r)
do tmp_s = 1, m
do tmp_r = 1, m
do tmp_q = 1, m
do tmp_p = 1, m
h_tmpr(tmp_p,tmp_q,tmp_r,tmp_s) = (hessian(tmp_p,tmp_q,tmp_r,tmp_s) - hessian(tmp_q,tmp_p,tmp_r,tmp_s) &
- hessian(tmp_p,tmp_q,tmp_s,tmp_r) + hessian(tmp_q,tmp_p,tmp_s,tmp_r))
enddo
enddo
enddo
enddo
!========================
! 4D matrix to 2D matrix
!========================
! Convert the hessian mo_num * mo_num * mo_num * mo_num matrix in a
! 2D n * n matrix (n = mo_num*(mo_num-1)/2)
! H(pq,rs) : p<q and r<s
! 4D mo_num matrix to 2D n matrix
do tmp_pq = 1, tmp_n
call vec_to_mat_index(tmp_pq,tmp_p,tmp_q)
do tmp_rs = 1, tmp_n
call vec_to_mat_index(tmp_rs,tmp_r,tmp_s)
H(tmp_pq,tmp_rs) = h_tmpr(tmp_p,tmp_q,tmp_r,tmp_s)
enddo
enddo
! Display
if (debug) then
print*,'2D Hessian matrix'
do tmp_pq = 1, tmp_n
write(*,'(100(F10.5))') H(tmp_pq,:)
enddo
endif
!==============
! Deallocation
!==============
deallocate(hessian)
print*,'---End first_hess_list---'
end subroutine

360
src/mo_optimization/first_hessian_opt.irp.f Normal file
View File

@ -0,0 +1,360 @@
subroutine first_hessian_opt(n,H,h_tmpr)
include 'constants.h'
implicit none
!==================================================================
! Compute the hessian of energy with respects to orbital rotations
!==================================================================
!===========
! Variables
!===========
! in
integer, intent(in) :: n
!n : integer, n = mo_num*(mo_num-1)/2
! out
double precision, intent(out) :: H(n,n),h_tmpr(mo_num,mo_num,mo_num,mo_num)
! H : n by n double precision matrix containing the 2D hessian
! internal
double precision, allocatable :: hessian(:,:,:,:)
integer :: p,q
integer :: r,s,t,u,v
integer :: pq,rs
double precision :: t1,t2,t3,t4,t5,t6
! hessian : mo_num 4D double precision matrix containing the hessian before the permutations
! h_tmpr : mo_num 4D double precision matrix containing the hessian after the permutations
! p,q,r,s : integer, indexes of the 4D hessian matrix
! t,u,v : integer, indexes to compute hessian elements
! pq,rs : integer, indexes for the conversion from 4D to 2D hessian matrix
! t1,t2,t3 : double precision, t3 = t2 - t1, time to compute the hessian
! Funtion
double precision :: get_two_e_integral
! get_two_e_integral : double precision function, two e integrals
! Provided :
! mo_one_e_integrals : mono e- integrals
! get_two_e_integral : two e- integrals
! one_e_dm_mo_alpha, one_e_dm_mo_beta : one body density matrix
! two_e_dm_mo : two body density matrix
!============
! Allocation
!============
allocate(hessian(mo_num,mo_num,mo_num,mo_num))
!=============
! Calculation
!=============
if (debug) then
print*,'Enter in first_hess'
endif
! From Anderson et. al. (2014)
! The Journal of Chemical Physics 141, 244104 (2014); doi: 10.1063/1.4904384
CALL wall_time(t1)
! Initialization
hessian = 0d0
!========================
! First line, first term
!========================
CALL wall_time(t4)
do p = 1, mo_num
do q = 1, mo_num
do r = 1, mo_num
do s = 1, mo_num
if (q==r) then
do u = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) + 0.5d0 * ( &
mo_one_e_integrals(u,p) * one_e_dm_mo(u,s) &
+ mo_one_e_integrals(s,u) * one_e_dm_mo(p,u))
enddo
endif
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l1 1 :', t6
!=========================
! First line, second term
!=========================
CALL wall_time(t4)
do p = 1, mo_num
do q = 1, mo_num
do r = 1, mo_num
do s = 1, mo_num
if (p==s) then
do u = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) + 0.5d0 * ( &
mo_one_e_integrals(u,r) * one_e_dm_mo(u,q) &
+ mo_one_e_integrals(q,u) * one_e_dm_mo(r,u))
enddo
endif
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l1 2 :', t6
!========================
! First line, third term
!========================
CALL wall_time(t4)
do p = 1, mo_num
do q = 1, mo_num
do r = 1, mo_num
do s = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) &
- mo_one_e_integrals(s,p) * one_e_dm_mo(r,q)&
- mo_one_e_integrals(q,r) * one_e_dm_mo(p,s)
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l1 3 :', t6
!=========================
! Second line, first term
!=========================
CALL wall_time(t4)
do s = 1, mo_num
do r = 1, mo_num
do q = 1, mo_num
do p = 1, mo_num
! do p = 1, mo_num
! do q = 1, mo_num
! do r = 1, mo_num
! do s = 1, mo_num
if (q==r) then
do t = 1, mo_num
do u = 1, mo_num
do v = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) + 0.5d0 * ( &
get_two_e_integral(u,v,p,t,mo_integrals_map) * two_e_dm_mo(u,v,s,t) &
+ get_two_e_integral(s,t,u,v,mo_integrals_map) * two_e_dm_mo(p,t,u,v))
enddo
enddo
enddo
endif
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l2 1 :', t6
!==========================
! Second line, second term
!==========================
CALL wall_time(t4)
do s = 1, mo_num
do r = 1, mo_num
do q = 1, mo_num
do p = 1, mo_num
! do p = 1, mo_num
! do q = 1, mo_num
! do r = 1, mo_num
! do s = 1, mo_num
if (p==s) then
do t = 1, mo_num
do u = 1, mo_num
do v = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) + 0.5d0 * ( &
get_two_e_integral(q,t,u,v,mo_integrals_map) * two_e_dm_mo(r,t,u,v) &
+ get_two_e_integral(u,v,r,t,mo_integrals_map) * two_e_dm_mo(u,v,q,t))
enddo
enddo
enddo
endif
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l2 2 :', t6
!========================
! Third line, first term
!========================
CALL wall_time(t4)
do s = 1, mo_num
do r = 1, mo_num
do q = 1, mo_num
do p = 1, mo_num
! do p = 1, mo_num
! do q = 1, mo_num
! do r = 1, mo_num
! do s = 1, mo_num
do u = 1, mo_num
do v = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) &
+ get_two_e_integral(u,v,p,r,mo_integrals_map) * two_e_dm_mo(u,v,q,s) &
+ get_two_e_integral(q,s,u,v,mo_integrals_map) * two_e_dm_mo(p,r,u,v)
enddo
enddo
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l3 1 :', t6
!=========================
! Third line, second term
!=========================
CALL wall_time(t4)
do s = 1, mo_num
do r = 1, mo_num
do q = 1, mo_num
do p = 1, mo_num
! do p = 1, mo_num
! do q = 1, mo_num
! do r = 1, mo_num
! do s = 1, mo_num
do t = 1, mo_num
do u = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) &
- get_two_e_integral(s,t,p,u,mo_integrals_map) * two_e_dm_mo(r,t,q,u) &
- get_two_e_integral(t,s,p,u,mo_integrals_map) * two_e_dm_mo(t,r,q,u) &
- get_two_e_integral(q,u,r,t,mo_integrals_map) * two_e_dm_mo(p,u,s,t) &
- get_two_e_integral(q,u,t,r,mo_integrals_map) * two_e_dm_mo(p,u,t,s)
enddo
enddo
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l3 2 :', t6
CALL wall_time(t2)
t3 = t2 -t1
print*,'Time to compute the hessian : ', t3
!==============
! Permutations
!==============
! Hessian(p,q,r,s) = P_pq P_rs [ ...]
! => Hessian(p,q,r,s) = (p,q,r,s) - (q,p,r,s) - (p,q,s,r) + (q,p,s,r)
do s = 1, mo_num
do r = 1, mo_num
do q = 1, mo_num
do p = 1, mo_num
h_tmpr(p,q,r,s) = (hessian(p,q,r,s) - hessian(q,p,r,s) - hessian(p,q,s,r) + hessian(q,p,s,r))
enddo
enddo
enddo
enddo
!========================
! 4D matrix to 2D matrix
!========================
! Convert the hessian mo_num * mo_num * mo_num * mo_num matrix in a
! 2D n * n matrix (n = mo_num*(mo_num-1)/2)
! H(pq,rs) : p<q and r<s
! 4D mo_num matrix to 2D n matrix
do pq = 1, n
call vec_to_mat_index(pq,p,q)
do rs = 1, n
call vec_to_mat_index(rs,r,s)
H(pq,rs) = h_tmpr(p,q,r,s)
enddo
enddo
! Display
if (debug) then
print*,'2D Hessian matrix'
do pq = 1, n
write(*,'(100(F10.5))') H(pq,:)
enddo
endif
!==============
! Deallocation
!==============
deallocate(hessian)
if (debug) then
print*,'Leave first_hess'
endif
end subroutine

381
src/mo_optimization/gradient_list_opt.irp.f Normal file
View File

@ -0,0 +1,381 @@
! Gradient
! The gradient of the CI energy with respects to the orbital rotation
! is:
! (C-c C-x C-l)
! $$
! G(p,q) = \mathcal{P}_{pq} \left[ \sum_r (h_p^r \gamma_r^q - h_r^q \gamma_p^r) +
! \sum_{rst}(v_{pt}^{rs} \Gamma_{rs}^{qt} - v_{rs}^{qt} \Gamma_{pt}^{rs})
! \right]
! $$
! $$
! \mathcal{P}_{pq}= 1 - (p \leftrightarrow q)
! $$
! $$
! G(p,q) = \left[
! \sum_r (h_p^r \gamma_r^q - h_r^q \gamma_p^r) +
! \sum_{rst}(v_{pt}^{rs} \Gamma_{rs}^{qt} - v_{rs}^{qt} \Gamma_{pt}^{rs})
! \right] -
! \left[
! \sum_r (h_q^r \gamma_r^p - h_r^p \gamma_q^r) +
! \sum_{rst}(v_{qt}^{rs} \Gamma_{rs}^{pt} - v_{rs}^{pt}
! \Gamma_{qt}^{rs})
! \right]
! $$
! Where p,q,r,s,t are general spatial orbitals
! mo_num : the number of molecular orbitals
! $$h$$ : One electron integrals
! $$\gamma$$ : One body density matrix (state average in our case)
! $$v$$ : Two electron integrals
! $$\Gamma$$ : Two body density matrice (state average in our case)
! The gradient is a mo_num by mo_num matrix, p,q,r,s,t take all the
! values between 1 and mo_num (1 and mo_num include).
! To do that we compute $$G(p,q)$$ for all the pairs (p,q).
! Source :
! Seniority-based coupled cluster theory
! J. Chem. Phys. 141, 244104 (2014); https://doi.org/10.1063/1.4904384
! Thomas M. Henderson, Ireneusz W. Bulik, Tamar Stein, and Gustavo
! E. Scuseria
! *Compute the gradient of energy with respects to orbital rotations*
! Provided:
! | mo_num | integer | number of MOs |
! | mo_one_e_integrals(mo_num,mo_num) | double precision | mono_electronic integrals |
! | one_e_dm_mo(mo_num,mo_num) | double precision | one e- density matrix |
! | two_e_dm_mo(mo_num,mo_num,mo_num,mo_num) | double precision | two e- density matrix |
! Input:
! | n | integer | mo_num*(mo_num-1)/2 |
! Output:
! | v_grad(n) | double precision | the gradient |
! | max_elem | double precision | maximum element of the gradient |
! Internal:
! | grad(mo_num,mo_num) | double precison | gradient before the tranformation in a vector |
! | A((mo_num,mo_num) | doubre precision | gradient after the permutations |
! | norm | double precision | norm of the gradient |
! | p, q | integer | indexes of the element in the matrix grad |
! | i | integer | index for the tranformation in a vector |
! | r, s, t | integer | indexes dor the sums |
! | t1, t2, t3 | double precision | t3 = t2 - t1, time to compute the gradient |
! | t4, t5, t6 | double precission | t6 = t5 - t4, time to compute each element |
! | tmp_bi_int_3(mo_num,mo_num,mo_num) | double precision | 3 indexes temporary array for the bi-electronic integrals |
! | tmp_2rdm_3(mo_num,mo_num,mo_num) | double precision | 3 indexes temporary array for the two e- density matrix |
! | tmp_accu(mo_num,mo_num) | double precision | temporary array |
! Function:
! | get_two_e_integral | double precision | bi-electronic integrals |
! | dnrm2 | double precision | (Lapack) norm |
subroutine gradient_list_opt(n,m,list,v_grad,max_elem,norm)
use omp_lib
include 'constants.h'
implicit none
! Variables
! in
integer, intent(in) :: n,m,list(m)
! out
double precision, intent(out) :: v_grad(n), max_elem, norm
! internal
double precision, allocatable :: grad(:,:),A(:,:)
integer :: i,p,q,r,s,t, tmp_p, tmp_q, tmp_i
double precision :: t1,t2,t3,t4,t5,t6
double precision, allocatable :: tmp_accu(:,:), tmp_mo_one_e_integrals(:,:),tmp_one_e_dm_mo(:,:)
double precision, allocatable :: tmp_bi_int_3(:,:,:), tmp_2rdm_3(:,:,:)
! Functions
double precision :: get_two_e_integral, dnrm2
print*,''
print*,'---gradient---'
! Allocation of shared arrays
allocate(grad(m,m),A(m,m))
allocate(tmp_mo_one_e_integrals(m,mo_num),tmp_one_e_dm_mo(mo_num,m))
! Initialization omp
call omp_set_max_active_levels(1)
!$OMP PARALLEL &
!$OMP PRIVATE( &
!$OMP p,q,r,s,t,tmp_p,tmp_q, &
!$OMP tmp_accu,tmp_bi_int_3, tmp_2rdm_3) &
!$OMP SHARED(grad, one_e_dm_mo,m,list,mo_num,mo_one_e_integrals, &
!$OMP mo_integrals_map,tmp_one_e_dm_mo, tmp_mo_one_e_integrals,t4,t5,t6) &
!$OMP DEFAULT(SHARED)
! Allocation of private arrays
allocate(tmp_accu(m,m))
allocate(tmp_bi_int_3(mo_num,mo_num,m))
allocate(tmp_2rdm_3(mo_num,mo_num,m))
! Initialization
!$OMP DO
do tmp_q = 1, m
do tmp_p = 1, m
grad(tmp_p,tmp_q) = 0d0
enddo
enddo
!$OMP END DO
! Term 1
! Without optimization the term 1 is :
! do p = 1, mo_num
! do q = 1, mo_num
! do r = 1, mo_num
! grad(p,q) = grad(p,q) &
! + mo_one_e_integrals(p,r) * one_e_dm_mo(r,q) &
! - mo_one_e_integrals(r,q) * one_e_dm_mo(p,r)
! enddo
! enddo
! enddo
! Since the matrix multiplication A.B is defined like :
! \begin{equation}
! c_{ij} = \sum_k a_{ik}.b_{kj}
! \end{equation}
! The previous equation can be rewritten as a matrix multplication
!****************
! Opt first term
!****************
!$OMP DO
do r = 1, mo_num
do tmp_p = 1, m
p = list(tmp_p)
tmp_mo_one_e_integrals(tmp_p,r) = mo_one_e_integrals(p,r)
enddo
enddo
!$OMP END DO
!$OMP DO
do tmp_q = 1, m
q = list(tmp_q)
do r = 1, mo_num
tmp_one_e_dm_mo(r,tmp_q) = one_e_dm_mo(r,q)
enddo
enddo
!$OMP END DO
call dgemm('N','N',m,m,mo_num,1d0,&
tmp_mo_one_e_integrals, size(tmp_mo_one_e_integrals,1),&
tmp_one_e_dm_mo,size(tmp_one_e_dm_mo,1),0d0,tmp_accu,size(tmp_accu,1))
!$OMP DO
do tmp_q = 1, m
do tmp_p = 1, m
grad(tmp_p,tmp_q) = grad(tmp_p,tmp_q) + (tmp_accu(tmp_p,tmp_q) - tmp_accu(tmp_q,tmp_p))
enddo
enddo
!$OMP END DO
!$OMP MASTER
CALL wall_TIME(t4)
!$OMP END MASTER
! call dgemm('N','N',mo_num,mo_num,mo_num,1d0,mo_one_e_integrals,&
! mo_num,one_e_dm_mo,mo_num,0d0,tmp_accu,mo_num)
!
! !$OMP DO
! do q = 1, mo_num
! do p = 1, mo_num
!
! grad(p,q) = grad(p,q) + (tmp_accu(p,q) - tmp_accu(q,p))
!
! enddo
! enddo
! !$OMP END DO
!$OMP MASTER
CALL wall_TIME(t5)
t6 = t5-t4
print*,'Gradient, first term (s) :', t6
!$OMP END MASTER
! Term 2
! Without optimization the second term is :
! do p = 1, mo_num
! do q = 1, mo_num
! do r = 1, mo_num
! do s = 1, mo_num
! do t= 1, mo_num
! grad(p,q) = grad(p,q) &
! + get_two_e_integral(p,t,r,s,mo_integrals_map) * two_e_dm_mo(r,s,q,t) &
! - get_two_e_integral(r,s,q,t,mo_integrals_map) * two_e_dm_mo(p,t,r,s)
! enddo
! enddo
! enddo
! enddo
! enddo
! Using the bielectronic integral properties :
! get_two_e_integral(p,t,r,s,mo_integrals_map) = get_two_e_integral(r,s,p,t,mo_integrals_map)
! Using the two body matrix properties :
! two_e_dm_mo(p,t,r,s) = two_e_dm_mo(r,s,p,t)
! t is one the right, we can put it on the external loop and create 3
! indexes temporary array
! r,s can be seen as one index
! By doing so, a matrix multiplication appears
!*****************
! Opt second term
!*****************
!$OMP MASTER
CALL wall_TIME(t4)
!$OMP END MASTER
!$OMP DO
do t = 1, mo_num
do tmp_p = 1, m
p = list(tmp_p)
do s = 1, mo_num
do r = 1, mo_num
tmp_bi_int_3(r,s,tmp_p) = get_two_e_integral(r,s,p,t,mo_integrals_map)
enddo
enddo
enddo
do tmp_q = 1, m
q = list(tmp_q)
do s = 1, mo_num
do r = 1, mo_num
tmp_2rdm_3(r,s,tmp_q) = two_e_dm_mo(r,s,q,t)
enddo
enddo
enddo
call dgemm('T','N',m,m,mo_num*mo_num,1d0,tmp_bi_int_3,&
mo_num*mo_num,tmp_2rdm_3,mo_num*mo_num,0d0,tmp_accu,size(tmp_accu,1))
!$OMP CRITICAL
do tmp_q = 1, m
do tmp_p = 1, m
grad(tmp_p,tmp_q) = grad(tmp_p,tmp_q) + tmp_accu(tmp_p,tmp_q) - tmp_accu(tmp_q,tmp_p)
enddo
enddo
!$OMP END CRITICAL
enddo
!$OMP END DO
!$OMP MASTER
CALL wall_TIME(t5)
t6 = t5-t4
print*,'Gradient second term (s) : ', t6
!$OMP END MASTER
! Deallocation of private arrays
deallocate(tmp_bi_int_3,tmp_2rdm_3,tmp_accu)
!$OMP END PARALLEL
call omp_set_max_active_levels(4)
! Permutation, 2D matrix -> vector, transformation
! In addition there is a permutation in the gradient formula :
! \begin{equation}
! P_{pq} = 1 - (p <-> q)
! \end{equation}
! We need a vector to use the gradient. Here the gradient is a
! antisymetric matrix so we can transform it in a vector of length
! mo_num*(mo_num-1)/2.
! Here we do these two things at the same time.
do i=1,n
call vec_to_mat_index(i,p,q)
v_grad(i)=(grad(p,q) - grad(q,p))
enddo
! Debug, diplay the vector containing the gradient elements
if (debug) then
print*,'Vector containing the gradient :'
write(*,'(100(F10.5))') v_grad(1:n)
endif
! Norm of the gradient
! The norm can be useful.
norm = dnrm2(n,v_grad,1)
print*, 'Gradient norm : ', norm
! Maximum element in the gradient
! The maximum element in the gradient is very important for the
! convergence criterion of the Newton method.
! Max element of the gradient
max_elem = 0d0
do i = 1, n
if (DABS(v_grad(i)) > DABS(max_elem)) then
max_elem = v_grad(i)
endif
enddo
print*,'Max element in the gradient :', max_elem
! Debug, display the matrix containting the gradient elements
if (debug) then
! Matrix gradient
A = 0d0
do q=1,m
do p=1,m
A(p,q) = grad(p,q) - grad(q,p)
enddo
enddo
print*,'Matrix containing the gradient :'
do i = 1, m
write(*,'(100(F10.5))') A(i,1:m)
enddo
endif
! Deallocation of shared arrays and end
deallocate(grad,A, tmp_mo_one_e_integrals,tmp_one_e_dm_mo)
print*,'---End gradient---'
end subroutine

346
src/mo_optimization/gradient_opt.irp.f Normal file
View File

@ -0,0 +1,346 @@
! Gradient
! The gradient of the CI energy with respects to the orbital rotation
! is:
! (C-c C-x C-l)
! $$
! G(p,q) = \mathcal{P}_{pq} \left[ \sum_r (h_p^r \gamma_r^q - h_r^q \gamma_p^r) +
! \sum_{rst}(v_{pt}^{rs} \Gamma_{rs}^{qt} - v_{rs}^{qt} \Gamma_{pt}^{rs})
! \right]
! $$
! $$
! \mathcal{P}_{pq}= 1 - (p \leftrightarrow q)
! $$
! $$
! G(p,q) = \left[
! \sum_r (h_p^r \gamma_r^q - h_r^q \gamma_p^r) +
! \sum_{rst}(v_{pt}^{rs} \Gamma_{rs}^{qt} - v_{rs}^{qt} \Gamma_{pt}^{rs})
! \right] -
! \left[
! \sum_r (h_q^r \gamma_r^p - h_r^p \gamma_q^r) +
! \sum_{rst}(v_{qt}^{rs} \Gamma_{rs}^{pt} - v_{rs}^{pt}
! \Gamma_{qt}^{rs})
! \right]
! $$
! Where p,q,r,s,t are general spatial orbitals
! mo_num : the number of molecular orbitals
! $$h$$ : One electron integrals
! $$\gamma$$ : One body density matrix (state average in our case)
! $$v$$ : Two electron integrals
! $$\Gamma$$ : Two body density matrice (state average in our case)
! The gradient is a mo_num by mo_num matrix, p,q,r,s,t take all the
! values between 1 and mo_num (1 and mo_num include).
! To do that we compute $$G(p,q)$$ for all the pairs (p,q).
! Source :
! Seniority-based coupled cluster theory
! J. Chem. Phys. 141, 244104 (2014); https://doi.org/10.1063/1.4904384
! Thomas M. Henderson, Ireneusz W. Bulik, Tamar Stein, and Gustavo
! E. Scuseria
! *Compute the gradient of energy with respects to orbital rotations*
! Provided:
! | mo_num | integer | number of MOs |
! | mo_one_e_integrals(mo_num,mo_num) | double precision | mono_electronic integrals |
! | one_e_dm_mo(mo_num,mo_num) | double precision | one e- density matrix |
! | two_e_dm_mo(mo_num,mo_num,mo_num,mo_num) | double precision | two e- density matrix |
! Input:
! | n | integer | mo_num*(mo_num-1)/2 |
! Output:
! | v_grad(n) | double precision | the gradient |
! | max_elem | double precision | maximum element of the gradient |
! Internal:
! | grad(mo_num,mo_num) | double precison | gradient before the tranformation in a vector |
! | A((mo_num,mo_num) | doubre precision | gradient after the permutations |
! | norm | double precision | norm of the gradient |
! | p, q | integer | indexes of the element in the matrix grad |
! | i | integer | index for the tranformation in a vector |
! | r, s, t | integer | indexes dor the sums |
! | t1, t2, t3 | double precision | t3 = t2 - t1, time to compute the gradient |
! | t4, t5, t6 | double precission | t6 = t5 - t4, time to compute each element |
! | tmp_bi_int_3(mo_num,mo_num,mo_num) | double precision | 3 indexes temporary array for the bi-electronic integrals |
! | tmp_2rdm_3(mo_num,mo_num,mo_num) | double precision | 3 indexes temporary array for the two e- density matrix |
! | tmp_accu(mo_num,mo_num) | double precision | temporary array |
! Function:
! | get_two_e_integral | double precision | bi-electronic integrals |
! | dnrm2 | double precision | (Lapack) norm |
subroutine gradient_opt(n,v_grad,max_elem)
use omp_lib
include 'constants.h'
implicit none
! Variables
! in
integer, intent(in) :: n
! out
double precision, intent(out) :: v_grad(n), max_elem
! internal
double precision, allocatable :: grad(:,:),A(:,:)
double precision :: norm
integer :: i,p,q,r,s,t
double precision :: t1,t2,t3,t4,t5,t6
double precision, allocatable :: tmp_accu(:,:)
double precision, allocatable :: tmp_bi_int_3(:,:,:), tmp_2rdm_3(:,:,:)
! Functions
double precision :: get_two_e_integral, dnrm2
print*,''
print*,'---gradient---'
! Allocation of shared arrays
allocate(grad(mo_num,mo_num),A(mo_num,mo_num))
! Initialization omp
call omp_set_max_active_levels(1)
!$OMP PARALLEL &
!$OMP PRIVATE( &
!$OMP p,q,r,s,t, &
!$OMP tmp_accu, tmp_bi_int_3, tmp_2rdm_3) &
!$OMP SHARED(grad, one_e_dm_mo, mo_num,mo_one_e_integrals, &
!$OMP mo_integrals_map,t4,t5,t6) &
!$OMP DEFAULT(SHARED)
! Allocation of private arrays
allocate(tmp_accu(mo_num,mo_num))
allocate(tmp_bi_int_3(mo_num,mo_num,mo_num))
allocate(tmp_2rdm_3(mo_num,mo_num,mo_num))
! Initialization
!$OMP DO
do q = 1, mo_num
do p = 1,mo_num
grad(p,q) = 0d0
enddo
enddo
!$OMP END DO
! Term 1
! Without optimization the term 1 is :
! do p = 1, mo_num
! do q = 1, mo_num
! do r = 1, mo_num
! grad(p,q) = grad(p,q) &
! + mo_one_e_integrals(p,r) * one_e_dm_mo(r,q) &
! - mo_one_e_integrals(r,q) * one_e_dm_mo(p,r)
! enddo
! enddo
! enddo
! Since the matrix multiplication A.B is defined like :
! \begin{equation}
! c_{ij} = \sum_k a_{ik}.b_{kj}
! \end{equation}
! The previous equation can be rewritten as a matrix multplication
!****************
! Opt first term
!****************
!$OMP MASTER
CALL wall_TIME(t4)
!$OMP END MASTER
call dgemm('N','N',mo_num,mo_num,mo_num,1d0,mo_one_e_integrals,&
mo_num,one_e_dm_mo,mo_num,0d0,tmp_accu,mo_num)
!$OMP DO
do q = 1, mo_num
do p = 1, mo_num
grad(p,q) = grad(p,q) + (tmp_accu(p,q) - tmp_accu(q,p))
enddo
enddo
!$OMP END DO
!$OMP MASTER
CALL wall_TIME(t5)
t6 = t5-t4
print*,'Gradient, first term (s) :', t6
!$OMP END MASTER
! Term 2
! Without optimization the second term is :
! do p = 1, mo_num
! do q = 1, mo_num
! do r = 1, mo_num
! do s = 1, mo_num
! do t= 1, mo_num
! grad(p,q) = grad(p,q) &
! + get_two_e_integral(p,t,r,s,mo_integrals_map) * two_e_dm_mo(r,s,q,t) &
! - get_two_e_integral(r,s,q,t,mo_integrals_map) * two_e_dm_mo(p,t,r,s)
! enddo
! enddo
! enddo
! enddo
! enddo
! Using the bielectronic integral properties :
! get_two_e_integral(p,t,r,s,mo_integrals_map) = get_two_e_integral(r,s,p,t,mo_integrals_map)
! Using the two body matrix properties :
! two_e_dm_mo(p,t,r,s) = two_e_dm_mo(r,s,p,t)
! t is one the right, we can put it on the external loop and create 3
! indexes temporary array
! r,s can be seen as one index
! By doing so, a matrix multiplication appears
!*****************
! Opt second term
!*****************
!$OMP MASTER
CALL wall_TIME(t4)
!$OMP END MASTER
!$OMP DO
do t = 1, mo_num
do p = 1, mo_num
do s = 1, mo_num
do r = 1, mo_num
tmp_bi_int_3(r,s,p) = get_two_e_integral(r,s,p,t,mo_integrals_map)
enddo
enddo
enddo
do q = 1, mo_num
do s = 1, mo_num
do r = 1, mo_num
tmp_2rdm_3(r,s,q) = two_e_dm_mo(r,s,q,t)
enddo
enddo
enddo
call dgemm('T','N',mo_num,mo_num,mo_num*mo_num,1d0,tmp_bi_int_3,&
mo_num*mo_num,tmp_2rdm_3,mo_num*mo_num,0d0,tmp_accu,mo_num)
!$OMP CRITICAL
do q = 1, mo_num
do p = 1, mo_num
grad(p,q) = grad(p,q) + tmp_accu(p,q) - tmp_accu(q,p)
enddo
enddo
!$OMP END CRITICAL
enddo
!$OMP END DO
!$OMP MASTER
CALL wall_TIME(t5)
t6 = t5-t4
print*,'Gradient second term (s) : ', t6
!$OMP END MASTER
! Deallocation of private arrays
deallocate(tmp_bi_int_3,tmp_2rdm_3,tmp_accu)
!$OMP END PARALLEL
call omp_set_max_active_levels(4)
! Permutation, 2D matrix -> vector, transformation
! In addition there is a permutation in the gradient formula :
! \begin{equation}
! P_{pq} = 1 - (p <-> q)
! \end{equation}
! We need a vector to use the gradient. Here the gradient is a
! antisymetric matrix so we can transform it in a vector of length
! mo_num*(mo_num-1)/2.
! Here we do these two things at the same time.
do i=1,n
call vec_to_mat_index(i,p,q)
v_grad(i)=(grad(p,q) - grad(q,p))
enddo
! Debug, diplay the vector containing the gradient elements
if (debug) then
print*,'Vector containing the gradient :'
write(*,'(100(F10.5))') v_grad(1:n)
endif
! Norm of the gradient
! The norm can be useful.
norm = dnrm2(n,v_grad,1)
print*, 'Gradient norm : ', norm
! Maximum element in the gradient
! The maximum element in the gradient is very important for the
! convergence criterion of the Newton method.
! Max element of the gradient
max_elem = 0d0
do i = 1, n
if (ABS(v_grad(i)) > ABS(max_elem)) then
max_elem = v_grad(i)
endif
enddo
print*,'Max element in the gradient :', max_elem
! Debug, display the matrix containting the gradient elements
if (debug) then
! Matrix gradient
A = 0d0
do q=1,mo_num
do p=1,mo_num
A(p,q) = grad(p,q) - grad(q,p)
enddo
enddo
print*,'Matrix containing the gradient :'
do i = 1, mo_num
write(*,'(100(F10.5))') A(i,1:mo_num)
enddo
endif
! Deallocation of shared arrays and end
deallocate(grad,A)
print*,'---End gradient---'
end subroutine

1129
src/mo_optimization/hessian_list_opt.irp.f Normal file
View File

File diff suppressed because it is too large Load Diff

1043
src/mo_optimization/hessian_opt.irp.f Normal file
View File

File diff suppressed because it is too large Load Diff

141
src/mo_optimization/my_providers.irp.f Normal file
View File

@ -0,0 +1,141 @@
! Dimensions of MOs
BEGIN_PROVIDER [ integer, n_mo_dim ]
implicit none
BEGIN_DOC
! Number of different pairs (i,j) of MOs we can build,
! with i>j
END_DOC
n_mo_dim = mo_num*(mo_num-1)/2
END_PROVIDER
BEGIN_PROVIDER [ integer, n_mo_dim_core ]
implicit none
BEGIN_DOC
! Number of different pairs (i,j) of core MOs we can build,
! with i>j
END_DOC
n_mo_dim_core = dim_list_core_orb*(dim_list_core_orb-1)/2
END_PROVIDER
BEGIN_PROVIDER [ integer, n_mo_dim_act ]
implicit none
BEGIN_DOC
! Number of different pairs (i,j) of active MOs we can build,
! with i>j
END_DOC
n_mo_dim_act = dim_list_act_orb*(dim_list_act_orb-1)/2
END_PROVIDER
BEGIN_PROVIDER [ integer, n_mo_dim_inact ]
implicit none
BEGIN_DOC
! Number of different pairs (i,j) of inactive MOs we can build,
! with i>j
END_DOC
n_mo_dim_inact = dim_list_inact_orb*(dim_list_inact_orb-1)/2
END_PROVIDER
BEGIN_PROVIDER [ integer, n_mo_dim_virt ]
implicit none
BEGIN_DOC
! Number of different pairs (i,j) of virtual MOs we can build,
! with i>j
END_DOC
n_mo_dim_virt = dim_list_virt_orb*(dim_list_virt_orb-1)/2
END_PROVIDER
! Energies/criterions
BEGIN_PROVIDER [ double precision, my_st_av_energy ]
implicit none
BEGIN_DOC
! State average CI energy
END_DOC
!call update_st_av_ci_energy(my_st_av_energy)
call state_average_energy(my_st_av_energy)
END_PROVIDER
! With all the MOs
BEGIN_PROVIDER [ double precision, my_gradient_opt, (n_mo_dim) ]
&BEGIN_PROVIDER [ double precision, my_CC1_opt ]
implicit none
BEGIN_DOC
! - Gradient of the energy with respect to the MO rotations, for all the MOs.
! - Maximal element of the gradient in absolute value
END_DOC
double precision :: norm_grad
PROVIDE mo_two_e_integrals_in_map
call gradient_opt(n_mo_dim, my_gradient_opt, my_CC1_opt, norm_grad)
END_PROVIDER
BEGIN_PROVIDER [ double precision, my_hessian_opt, (n_mo_dim, n_mo_dim) ]
implicit none
BEGIN_DOC
! - Gradient of the energy with respect to the MO rotations, for all the MOs.
! - Maximal element of the gradient in absolute value
END_DOC
double precision, allocatable :: h_f(:,:,:,:)
PROVIDE mo_two_e_integrals_in_map
allocate(h_f(mo_num, mo_num, mo_num, mo_num))
call hessian_list_opt(n_mo_dim, my_hessian_opt, h_f)
END_PROVIDER
! With the list of active MOs
! Can be generalized to any mo_class by changing the list/dimension
BEGIN_PROVIDER [ double precision, my_gradient_list_opt, (n_mo_dim_act) ]
&BEGIN_PROVIDER [ double precision, my_CC2_opt ]
implicit none
BEGIN_DOC
! - Gradient of the energy with respect to the MO rotations, only for the active MOs !
! - Maximal element of the gradient in absolute value
END_DOC
double precision :: norm_grad
PROVIDE mo_two_e_integrals_in_map !one_e_dm_mo two_e_dm_mo mo_one_e_integrals
call gradient_list_opt(n_mo_dim_act, dim_list_act_orb, list_act, my_gradient_list_opt, my_CC2_opt, norm_grad)
END_PROVIDER
BEGIN_PROVIDER [ double precision, my_hessian_list_opt, (n_mo_dim_act, n_mo_dim_act) ]
implicit none
BEGIN_DOC
! - Gradient of the energy with respect to the MO rotations, only for the active MOs !
! - Maximal element of the gradient in absolute value
END_DOC
double precision, allocatable :: h_f(:,:,:,:)
PROVIDE mo_two_e_integrals_in_map
allocate(h_f(dim_list_act_orb, dim_list_act_orb, dim_list_act_orb, dim_list_act_orb))
call hessian_list_opt(n_mo_dim_act, dim_list_act_orb, list_act, my_hessian_list_opt, h_f)
END_PROVIDER

86
src/mo_optimization/optimization.irp.f Normal file
View File

@ -0,0 +1,86 @@
program optimization
read_wf = .true. ! must be True for the orbital optimization !!!
TOUCH read_wf
call run_optimization
end
subroutine run_optimization
implicit none
double precision :: e_cipsi, e_opt, delta_e
integer :: nb_iter,i
logical :: not_converged
character (len=100) :: filename
PROVIDE psi_det psi_coef mo_two_e_integrals_in_map
not_converged = .True.
nb_iter = 0
! To start from the wf
N_det_max = max(n_det,5)
TOUCH N_det_max
open(unit=10, file=trim(ezfio_filename)//'/mo_optimization/result_opt')
write(10,*) " Ndet E_cipsi E_opt Delta_e"
call state_average_energy(e_cipsi)
write(10,'(I10, 3F15.7)') n_det, e_cipsi, e_cipsi, 0d0
close(10)
do while (not_converged)
print*,''
print*,'======================'
print*,' Cipsi step:', nb_iter
print*,'======================'
print*,''
print*,'********** cipsi step **********'
! cispi calculation
call run_stochastic_cipsi
! State average energy after the cipsi step
call state_average_energy(e_cipsi)
print*,''
print*,'********** optimization step **********'
! orbital optimization
call run_orb_opt_trust_v2
! State average energy after the orbital optimization
call state_average_energy(e_opt)
print*,''
print*,'********** diff step **********'
! Gain in energy
delta_e = e_opt - e_cipsi
print*, 'Gain in energy during the orbital optimization:', delta_e
open(unit=10, file=trim(ezfio_filename)//'/mo_optimization/result_opt', position='append')
write(10,'(I10, 3F15.7)') n_det, e_cipsi, e_opt, delta_e
close(10)
! Exit
if (delta_e > 1d-12) then
print*, 'WARNING, something wrong happened'
print*, 'The gain (delta_e) in energy during the optimization process'
print*, 'is > 0, but it must be < 0'
print*, 'The program will exit'
exit
endif
if (n_det > n_det_max_opt) then
print*, 'The number of determinants in the wf > n_det_max_opt'
print*, 'The program will exit'
exit
endif
! To double the number of determinants in the wf
N_det_max = int(dble(n_det * 2)*0.9)
TOUCH N_det_max
nb_iter = nb_iter + 1
enddo
end

22
src/mo_optimization/orb_opt.irp.f Normal file
View File

@ -0,0 +1,22 @@
! Orbital optimization program
! This is an optimization program for molecular orbitals. It produces
! orbital rotations in order to lower the energy of a truncated wave
! function.
! This program just optimize the orbitals for a fixed number of
! determinants. This optimization process must be repeated for different
! number of determinants.
! Main program : orb_opt_trust
program orb_opt
read_wf = .true. ! must be True for the orbital optimization !!!
TOUCH read_wf
io_mo_two_e_integrals = 'None'
TOUCH io_mo_two_e_integrals
call run_orb_opt_trust_v2
end

7
src/mo_optimization/org/TANGLE_org_mode.sh Executable file
View File

@ -0,0 +1,7 @@
#!/bin/sh
list='ls *.org'
for element in $list
do
emacs --batch $element -f org-babel-tangle
done

17
src/mo_optimization/org/TODO.org Normal file
View File

@ -0,0 +1,17 @@
TODO:
** TODO Keep under surveillance the performance of rotation matrix
- is the fix ok ?
** DONE Provider state_average_weight
** DONE Diagonal hessian for orbital optimization with a list of MOs
** DONE Something to force the step cancellation if R.R^T > treshold
** TODO Iterative method to compute the rotation matrix
- doesn't work actually
** DONE Test trust region with polynomial functions
** DONE Optimization/Localization program using the template
** DONE Correction OMP hessian shared/private arrays
** DONE State average energy
** DONE Correction of Rho
** TODO Check the PROVIDE/FREE/TOUCH
** TODO research of lambda without the power 2
** DONE Clean the OMP sections

79
src/mo_optimization/org/debug_gradient_list_opt.org Normal file
View File

@ -0,0 +1,79 @@
* Debug the gradient
*Program to check the gradient*
The program compares the result of the first and last code for the
gradient.
Provided:
| mo_num | integer | number of MOs |
Internal:
| n | integer | number of orbitals pairs (p,q) p<q |
| v_grad(n) | double precision | Original gradient |
| v_grad2(n) | double precision | Gradient |
| i | integer | index |
| threshold | double precision | threshold for the errors |
| max_error | double precision | maximal error in the gradient |
| nb_error | integer | number of error in the gradient |
#+BEGIN_SRC f90 :comments org :tangle debug_gradient_list_opt.irp.f
program debug_gradient_list
implicit none
! Variables
double precision, allocatable :: v_grad(:), v_grad2(:)
integer :: n,m
integer :: i
double precision :: threshold
double precision :: max_error, max_elem, norm
integer :: nb_error
m = dim_list_act_orb
! Definition of n
n = m*(m-1)/2
PROVIDE mo_two_e_integrals_in_map ! Vérifier pour suppression
! Allocation
allocate(v_grad(n), v_grad2(n))
! Calculation
call diagonalize_ci ! Vérifier pour suppression
! Gradient
call gradient_list_opt(n,m,list_act,v_grad,max_elem,norm)
call first_gradient_list_opt(n,m,list_act,v_grad2)
v_grad = v_grad - v_grad2
nb_error = 0
max_error = 0d0
threshold = 1d-12
do i = 1, n
if (ABS(v_grad(i)) > threshold) then
print*,i,v_grad(i)
nb_error = nb_error + 1
if (ABS(v_grad(i)) > max_error) then
max_error = v_grad(i)
endif
endif
enddo
print*,''
print*,'Check the gradient'
print*,'Threshold:', threshold
print*,'Nb error:', nb_error
print*,'Max error:', max_error
! Deallocation
deallocate(v_grad,v_grad2)
end program
#+END_SRC

77
src/mo_optimization/org/debug_gradient_opt.org Normal file
View File

@ -0,0 +1,77 @@
* Debug the gradient
*Program to check the gradient*
The program compares the result of the first and last code for the
gradient.
Provided:
| mo_num | integer | number of MOs |
Internal:
| n | integer | number of orbitals pairs (p,q) p<q |
| v_grad(n) | double precision | Original gradient |
| v_grad2(n) | double precision | Gradient |
| i | integer | index |
| threshold | double precision | threshold for the errors |
| max_error | double precision | maximal error in the gradient |
| nb_error | integer | number of error in the gradient |
#+BEGIN_SRC f90 :comments org :tangle debug_gradient_opt.irp.f
program debug_gradient
implicit none
! Variables
double precision, allocatable :: v_grad(:), v_grad2(:)
integer :: n
integer :: i
double precision :: threshold
double precision :: max_error, max_elem
integer :: nb_error
! Definition of n
n = mo_num*(mo_num-1)/2
PROVIDE mo_two_e_integrals_in_map ! Vérifier pour suppression
! Allocation
allocate(v_grad(n), v_grad2(n))
! Calculation
call diagonalize_ci ! Vérifier pour suppression
! Gradient
call first_gradient_opt(n,v_grad)
call gradient_opt(n,v_grad2,max_elem)
v_grad = v_grad - v_grad2
nb_error = 0
max_error = 0d0
threshold = 1d-12
do i = 1, n
if (ABS(v_grad(i)) > threshold) then
print*,v_grad(i)
nb_error = nb_error + 1
if (ABS(v_grad(i)) > max_error) then
max_error = v_grad(i)
endif
endif
enddo
print*,''
print*,'Check the gradient'
print*,'Threshold :', threshold
print*,'Nb error :', nb_error
print*,'Max error :', max_error
! Deallocation
deallocate(v_grad,v_grad2)
end program
#+END_SRC

148
src/mo_optimization/org/debug_hessian_list_opt.org Normal file
View File

@ -0,0 +1,148 @@
* Debug the hessian
*Program to check the hessian matrix*
The program compares the result of the first and last code for the
hessian. First of all the 4D hessian and after the 2D hessian.
Provided:
| mo_num | integer | number of MOs |
| optimization_method | string | Method for the orbital optimization: |
| | | - 'full' -> full hessian |
| | | - 'diag' -> diagonal hessian |
| dim_list_act_orb | integer | number of active MOs |
| list_act(dim_list_act_orb) | integer | list of the actives MOs |
| | | |
Internal:
| m | integer | number of MOs in the list |
| | | (active MOs) |
| n | integer | number of orbitals pairs (p,q) p<q |
| | | n = m*(m-1)/2 |
| H(n,n) | double precision | Original hessian matrix (2D) |
| H2(n,n) | double precision | Hessian matrix (2D) |
| h_f(mo_num,mo_num,mo_num,mo_num) | double precision | Original hessian matrix (4D) |
| h_f2(mo_num,mo_num,mo_num,mo_num) | double precision | Hessian matrix (4D) |
| i,j,p,q,k | integer | indexes |
| threshold | double precision | threshold for the errors |
| max_error | double precision | maximal error in the 4D hessian |
| max_error_H | double precision | maximal error in the 2D hessian |
| nb_error | integer | number of errors in the 4D hessian |
| nb_error_H | integer | number of errors in the 2D hessian |
#+BEGIN_SRC f90 :comments org :tangle debug_hessian_list_opt.irp.f
program debug_hessian_list_opt
implicit none
! Variables
double precision, allocatable :: H(:,:),H2(:,:), h_f(:,:,:,:), h_f2(:,:,:,:)
integer :: n,m
integer :: i,j,k,l
double precision :: max_error, max_error_H
integer :: nb_error, nb_error_H
double precision :: threshold
m = dim_list_act_orb !mo_num
! Definition of n
n = m*(m-1)/2
PROVIDE mo_two_e_integrals_in_map ! Vérifier pour suppression
! Hessian
if (optimization_method == 'full') then
print*,'Use the full hessian matrix'
allocate(H(n,n),H2(n,n))
allocate(h_f(m,m,m,m),h_f2(m,m,m,m))
call hessian_list_opt(n,m,list_act,H,h_f)
call first_hessian_list_opt(n,m,list_act,H2,h_f2)
!call hessian_opt(n,H2,h_f2)
! Difference
h_f = h_f - h_f2
H = H - H2
max_error = 0d0
nb_error = 0
threshold = 1d-12
do l = 1, m
do k= 1, m
do j = 1, m
do i = 1, m
if (ABS(h_f(i,j,k,l)) > threshold) then
print*,h_f(i,j,k,l)
nb_error = nb_error + 1
if (ABS(h_f(i,j,k,l)) > ABS(max_error)) then
max_error = h_f(i,j,k,l)
endif
endif
enddo
enddo
enddo
enddo
max_error_H = 0d0
nb_error_H = 0
do j = 1, n
do i = 1, n
if (ABS(H(i,j)) > threshold) then
print*, H(i,j)
nb_error_H = nb_error_H + 1
if (ABS(H(i,j)) > ABS(max_error_H)) then
max_error_H = H(i,j)
endif
endif
enddo
enddo
! Deallocation
deallocate(H, H2, h_f, h_f2)
else
print*, 'Use the diagonal hessian matrix'
allocate(H(n,1),H2(n,1))
call diag_hessian_list_opt(n,m,list_act,H)
call first_diag_hessian_list_opt(n,m,list_act,H2)
H = H - H2
max_error_H = 0d0
nb_error_H = 0
do i = 1, n
if (ABS(H(i,1)) > threshold) then
print*, H(i,1)
nb_error_H = nb_error_H + 1
if (ABS(H(i,1)) > ABS(max_error_H)) then
max_error_H = H(i,1)
endif
endif
enddo
endif
print*,''
if (optimization_method == 'full') then
print*,'Check of the full hessian'
print*,'Threshold:', threshold
print*,'Nb error:', nb_error
print*,'Max error:', max_error
print*,''
else
print*,'Check of the diagonal hessian'
endif
print*,'Nb error_H:', nb_error_H
print*,'Max error_H:', max_error_H
end program
#+END_SRC

172
src/mo_optimization/org/debug_hessian_opt.org Normal file
View File

@ -0,0 +1,172 @@
* Debug the hessian
*Program to check the hessian matrix*
The program compares the result of the first and last code for the
hessian. First of all the 4D hessian and after the 2D hessian.
Provided:
| mo_num | integer | number of MOs |
Internal:
| n | integer | number of orbitals pairs (p,q) p<q |
| H(n,n) | double precision | Original hessian matrix (2D) |
| H2(n,n) | double precision | Hessian matrix (2D) |
| h_f(mo_num,mo_num,mo_num,mo_num) | double precision | Original hessian matrix (4D) |
| h_f2(mo_num,mo_num,mo_num,mo_num) | double precision | Hessian matrix (4D) |
| method | integer | - 1: full hessian |
| | | - 2: diagonal hessian |
| i,j,p,q,k | integer | indexes |
| threshold | double precision | threshold for the errors |
| max_error | double precision | maximal error in the 4D hessian |
| max_error_H | double precision | maximal error in the 2D hessian |
| nb_error | integer | number of errors in the 4D hessian |
| nb_error_H | integer | number of errors in the 2D hessian |
#+BEGIN_SRC f90 :comments org :tangle debug_hessian_opt.irp.f
program debug_hessian
implicit none
! Variables
double precision, allocatable :: H(:,:),H2(:,:), h_f(:,:,:,:), h_f2(:,:,:,:)
integer :: n
integer :: i,j,k,l
double precision :: max_error, max_error_H
integer :: nb_error, nb_error_H
double precision :: threshold
! Definition of n
n = mo_num*(mo_num-1)/2
PROVIDE mo_two_e_integrals_in_map ! Vérifier pour suppression
! Allocation
allocate(H(n,n),H2(n,n))
allocate(h_f(mo_num,mo_num,mo_num,mo_num),h_f2(mo_num,mo_num,mo_num,mo_num))
! Calculation
! Hessian
if (optimization_method == 'full') then
print*,'Use the full hessian matrix'
call hessian_opt(n,H,h_f)
call first_hessian_opt(n,H2,h_f2)
! Difference
h_f = h_f - h_f2
H = H - H2
max_error = 0d0
nb_error = 0
threshold = 1d-12
do l = 1, mo_num
do k= 1, mo_num
do j = 1, mo_num
do i = 1, mo_num
if (ABS(h_f(i,j,k,l)) > threshold) then
print*,h_f(i,j,k,l)
nb_error = nb_error + 1
if (ABS(h_f(i,j,k,l)) > ABS(max_error)) then
max_error = h_f(i,j,k,l)
endif
endif
enddo
enddo
enddo
enddo
max_error_H = 0d0
nb_error_H = 0
do j = 1, n
do i = 1, n
if (ABS(H(i,j)) > threshold) then
print*, H(i,j)
nb_error_H = nb_error_H + 1
if (ABS(H(i,j)) > ABS(max_error_H)) then
max_error_H = H(i,j)
endif
endif
enddo
enddo
elseif (optimization_method == 'diag') then
print*, 'Use the diagonal hessian matrix'
call diag_hessian_opt(n,H,h_f)
call first_diag_hessian_opt(n,H2,h_f2)
h_f = h_f - h_f2
max_error = 0d0
nb_error = 0
threshold = 1d-12
do l = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do i = 1, mo_num
if (ABS(h_f(i,j,k,l)) > threshold) then
print*,h_f(i,j,k,l)
nb_error = nb_error + 1
if (ABS(h_f(i,j,k,l)) > ABS(max_error)) then
max_error = h_f(i,j,k,l)
endif
endif
enddo
enddo
enddo
enddo
h=H-H2
max_error_H = 0d0
nb_error_H = 0
do j = 1, n
do i = 1, n
if (ABS(H(i,j)) > threshold) then
print*, H(i,j)
nb_error_H = nb_error_H + 1
if (ABS(H(i,j)) > ABS(max_error_H)) then
max_error_H = H(i,j)
endif
endif
enddo
enddo
else
print*,'Unknown optimization_method, please select full, diag'
call abort
endif
print*,''
if (optimization_method == 'full') then
print*,'Check the full hessian'
else
print*,'Check the diagonal hessian'
endif
print*,'Threshold :', threshold
print*,'Nb error :', nb_error
print*,'Max error :', max_error
print*,''
print*,'Nb error_H :', nb_error_H
print*,'Max error_H :', max_error_H
! Deallocation
deallocate(H,H2,h_f,h_f2)
end program
#+END_SRC

1561
src/mo_optimization/org/diagonal_hessian_list_opt.org Normal file
View File

File diff suppressed because it is too large Load Diff

1516
src/mo_optimization/org/diagonal_hessian_opt.org Normal file
View File

File diff suppressed because it is too large Load Diff

138
src/mo_optimization/org/diagonalization_hessian.org Normal file
View File

@ -0,0 +1,138 @@
* Diagonalization of the hessian
Just a matrix diagonalization using Lapack
Input:
| n | integer | mo_num*(mo_num-1)/2 |
| H(n,n) | double precision | hessian |
Output:
| e_val(n) | double precision | eigenvalues of the hessian |
| w(n,n) | double precision | eigenvectors of the hessian |
Internal:
| nb_negative_nv | integer | number of negative eigenvalues |
| lwork | integer | for Lapack |
| work(lwork,n) | double precision | temporary array for Lapack |
| info | integer | if 0 -> ok, else problem in the diagonalization |
| i,j | integer | dummy indexes |
#+BEGIN_SRC f90 :comments org :tangle diagonalization_hessian.irp.f
subroutine diagonalization_hessian(n,H,e_val,w)
include 'constants.h'
implicit none
! Variables
! in
integer, intent(in) :: n
double precision, intent(in) :: H(n,n)
! out
double precision, intent(out) :: e_val(n), w(n,n)
! internal
double precision, allocatable :: work(:,:)
integer, allocatable :: key(:)
integer :: info,lwork
integer :: i,j
integer :: nb_negative_vp
double precision :: t1,t2,t3,max_elem
print*,''
print*,'---Diagonalization_hessian---'
call wall_time(t1)
if (optimization_method == 'full') then
! Allocation
! For Lapack
lwork=3*n-1
allocate(work(lwork,n))
! Calculation
! Copy the hessian matrix, the eigenvectors will be store in W
W=H
! Diagonalization of the hessian
call dsyev('V','U',n,W,size(W,1),e_val,work,lwork,info)
if (info /= 0) then
print*, 'Error diagonalization : diagonalization_hessian'
print*, 'info = ', info
call ABORT
endif
if (debug) then
print *, 'vp Hess:'
write(*,'(100(F10.5))') real(e_val(:))
endif
! Number of negative eigenvalues
max_elem = 0d0
nb_negative_vp = 0
do i = 1, n
if (e_val(i) < 0d0) then
nb_negative_vp = nb_negative_vp + 1
if (e_val(i) < max_elem) then
max_elem = e_val(i)
endif
!print*,'e_val < 0 :', e_val(i)
endif
enddo
print*,'Number of negative eigenvalues:', nb_negative_vp
print*,'Lowest eigenvalue:',max_elem
!nb_negative_vp = 0
!do i = 1, n
! if (e_val(i) < -thresh_eig) then
! nb_negative_vp = nb_negative_vp + 1
! endif
!enddo
!print*,'Number of negative eigenvalues <', -thresh_eig,':', nb_negative_vp
! Deallocation
deallocate(work)
elseif (optimization_method == 'diag') then
! Diagonalization of the diagonal hessian by hands
allocate(key(n))
do i = 1, n
e_val(i) = H(i,i)
enddo
! Key list for dsort
do i = 1, n
key(i) = i
enddo
! Sort of the eigenvalues
call dsort(e_val, key, n)
! Eigenvectors
W = 0d0
do i = 1, n
j = key(i)
W(j,i) = 1d0
enddo
deallocate(key)
else
print*,'Diagonalization_hessian, abort'
call abort
endif
call wall_time(t2)
t3 = t2 - t1
print*,'Time in diagonalization_hessian:', t3
print*,'---End diagonalization_hessian---'
end subroutine
#+END_SRC

376
src/mo_optimization/org/first_diagonal_hessian_list_opt.org Normal file
View File

@ -0,0 +1,376 @@
* First diagonal hessian
#+BEGIN_SRC f90 :comments :tangle first_diagonal_hessian_list_opt.irp.f
subroutine first_diag_hessian_list_opt(tmp_n,m,list,H)!, h_tmpr)
include 'constants.h'
implicit none
!===========================================================================
! Compute the diagonal hessian of energy with respects to orbital rotations
!===========================================================================
!===========
! Variables
!===========
! in
integer, intent(in) :: tmp_n, m, list(m)
! tmp_n : integer, tmp_n = m*(m-1)/2
! out
double precision, intent(out) :: H(tmp_n)!, h_tmpr(m,m,m,m)
! H : n by n double precision matrix containing the 2D hessian
! internal
double precision, allocatable :: hessian(:,:,:,:), tmp(:,:),h_tmpr(:,:,:,:)
integer :: p,q, tmp_p,tmp_q
integer :: r,s,t,u,v,tmp_r,tmp_s,tmp_t,tmp_u,tmp_v
integer :: pq,rs,tmp_pq,tmp_rs
double precision :: t1,t2,t3
! hessian : mo_num 4D double precision matrix containing the hessian before the permutations
! h_tmpr : mo_num 4D double precision matrix containing the hessian after the permutations
! p,q,r,s : integer, indexes of the 4D hessian matrix
! t,u,v : integer, indexes to compute hessian elements
! pq,rs : integer, indexes for the conversion from 4D to 2D hessian matrix
! t1,t2,t3 : double precision, t3 = t2 - t1, time to compute the hessian
! Function
double precision :: get_two_e_integral
! get_two_e_integral : double precision function, two e integrals
! Provided :
! mo_one_e_integrals : mono e- integrals
! get_two_e_integral : two e- integrals
! one_e_dm_mo_alpha, one_e_dm_mo_beta : one body density matrix
! two_e_dm_mo : two body density matrix
print*,'---first_diag_hess_list---'
!============
! Allocation
!============
allocate(hessian(m,m,m,m),tmp(tmp_n,tmp_n),h_tmpr(mo_num,mo_num,mo_num,mo_num))
!=============
! Calculation
!=============
! From Anderson et. al. (2014)
! The Journal of Chemical Physics 141, 244104 (2014); doi: 10.1063/1.4904384
! LaTeX formula :
!\begin{align*}
!H_{pq,rs} &= \dfrac{\partial^2 E(x)}{\partial x_{pq}^2} \\
!&= \mathcal{P}_{pq} \mathcal{P}_{rs} [ \frac{1}{2} \sum_u [\delta_{qr}(h_p^u \gamma_u^s + h_u^s \gamma_p^u)
!+ \delta_{ps}(h_r^u \gamma_u^q + h_u^q \gamma_u^r)]
!-(h_p^s \gamma_r^q + h_r^q \gamma_p^s) \\
!&+ \frac{1}{2} \sum_{tuv} [\delta_{qr}(v_{pt}^{uv} \Gamma_{uv}^{st} +v_{uv}^{st} \Gamma_{pt}^{uv})
!+ \delta_{ps}(v_{uv}^{qt} \Gamma_{rt}^{uv} + v_{rt}^{uv}\Gamma_{uv}^{qt})] \\
!&+ \sum_{uv} (v_{pr}^{uv} \Gamma_{uv}^{qs} + v_{uv}^{qs} \Gamma_{ps}^{uv}) \\
!&- \sum_{tu} (v_{pu}^{st} \Gamma_{rt}^{qu}+v_{pu}^{tr} \Gamma_{tr}^{qu}+v_{rt}^{qu}\Gamma_{pu}^{st} + v_{tr}^{qu}\Gamma_{pu}^{ts})
!\end{align*}
!================
! Initialization
!================
hessian = 0d0
CALL wall_time(t1)
!========================
! First line, first term
!========================
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
if (q==r) then
do u = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) + 0.5d0 * ( &
mo_one_e_integrals(u,p) * one_e_dm_mo(u,s) &
+ mo_one_e_integrals(s,u) * one_e_dm_mo(p,u))
enddo
endif
endif
enddo
enddo
enddo
enddo
!=========================
! First line, second term
!=========================
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
if (p==s) then
do u = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) + 0.5d0 * ( &
mo_one_e_integrals(u,r) * one_e_dm_mo(u,q) &
+ mo_one_e_integrals(q,u) * one_e_dm_mo(r,u))
enddo
endif
endif
enddo
enddo
enddo
enddo
!========================
! First line, third term
!========================
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) &
- mo_one_e_integrals(s,p) * one_e_dm_mo(r,q) &
- mo_one_e_integrals(q,r) * one_e_dm_mo(p,s)
endif
enddo
enddo
enddo
enddo
!=========================
! Second line, first term
!=========================
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
if (q==r) then
do t = 1, mo_num
do u = 1, mo_num
do v = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) + 0.5d0 * ( &
get_two_e_integral(u,v,p,t,mo_integrals_map) * two_e_dm_mo(u,v,s,t) &
+ get_two_e_integral(s,t,u,v,mo_integrals_map) * two_e_dm_mo(p,t,u,v))
enddo
enddo
enddo
endif
endif
enddo
enddo
enddo
enddo
!==========================
! Second line, second term
!==========================
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
if (p==s) then
do t = 1, mo_num
do u = 1, mo_num
do v = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) + 0.5d0 * ( &
get_two_e_integral(q,t,u,v,mo_integrals_map) * two_e_dm_mo(r,t,u,v) &
+ get_two_e_integral(u,v,r,t,mo_integrals_map) * two_e_dm_mo(u,v,q,t))
enddo
enddo
enddo
endif
endif
enddo
enddo
enddo
enddo
!========================
! Third line, first term
!========================
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
do u = 1, mo_num
do v = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) &
+ get_two_e_integral(u,v,p,r,mo_integrals_map) * two_e_dm_mo(u,v,q,s) &
+ get_two_e_integral(q,s,u,v,mo_integrals_map) * two_e_dm_mo(p,r,u,v)
enddo
enddo
endif
enddo
enddo
enddo
enddo
!=========================
! Third line, second term
!=========================
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
do t = 1, mo_num
do u = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) &
- get_two_e_integral(s,t,p,u,mo_integrals_map) * two_e_dm_mo(r,t,q,u) &
- get_two_e_integral(t,s,p,u,mo_integrals_map) * two_e_dm_mo(t,r,q,u) &
- get_two_e_integral(q,u,r,t,mo_integrals_map) * two_e_dm_mo(p,u,s,t) &
- get_two_e_integral(q,u,t,r,mo_integrals_map) * two_e_dm_mo(p,u,t,s)
enddo
enddo
endif
enddo
enddo
enddo
enddo
CALL wall_time(t2)
t2 = t2 - t1
print*, 'Time to compute the hessian :', t2
!==============
! Permutations
!==============
! Convert the hessian mo_num * mo_num * mo_num * mo_num matrix in a
! 2D n * n matrix (n = mo_num*(mo_num-1)/2)
! H(pq,rs) : p<q and r<s
do tmp_r = 1, m
do tmp_s = 1, m
do tmp_q = 1, m
do tmp_p = 1, m
h_tmpr(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) - hessian(tmp_q,tmp_p,tmp_r,tmp_s) &
- hessian(tmp_p,tmp_q,tmp_s,tmp_r) + hessian(tmp_q,tmp_p,tmp_s,tmp_r)
enddo
enddo
enddo
enddo
!========================
! 4D matrix -> 2D matrix
!========================
! Convert the hessian mo_num * mo_num * mo_num * mo_num matrix in a
! 2D n * n matrix (n = mo_num*(mo_num-1)/2)
! H(pq,rs) : p<q and r<s
! 4D mo_num matrix to 2D n matrix
do tmp_rs = 1, tmp_n
call vec_to_mat_index(tmp_rs,tmp_r,tmp_s)
do tmp_pq = 1, tmp_n
call vec_to_mat_index(tmp_pq,tmp_p,tmp_q)
tmp(tmp_pq,tmp_rs) = h_tmpr(tmp_p,tmp_q,tmp_r,tmp_s)
enddo
enddo
do p = 1, tmp_n
H(p) = tmp(p,p)
enddo
! Display
if (debug) then
print*,'2D diag Hessian matrix'
do tmp_pq = 1, tmp_n
write(*,'(100(F10.5))') tmp(tmp_pq,:)
enddo
endif
!==============
! Deallocation
!==============
deallocate(hessian,h_tmpr,tmp)
print*,'---End first_diag_hess_list---'
end subroutine
#+END_SRC

348
src/mo_optimization/org/first_diagonal_hessian_opt.org Normal file
View File

@ -0,0 +1,348 @@
* First diagonal hessian
#+BEGIN_SRC f90 :comments :tangle first_diagonal_hessian_opt.irp.f
subroutine first_diag_hessian_opt(n,H, h_tmpr)
include 'constants.h'
implicit none
!===========================================================================
! Compute the diagonal hessian of energy with respects to orbital rotations
!===========================================================================
!===========
! Variables
!===========
! in
integer, intent(in) :: n
! n : integer, n = mo_num*(mo_num-1)/2
! out
double precision, intent(out) :: H(n,n), h_tmpr(mo_num,mo_num,mo_num,mo_num)
! H : n by n double precision matrix containing the 2D hessian
! internal
double precision, allocatable :: hessian(:,:,:,:)
integer :: p,q
integer :: r,s,t,u,v
integer :: pq,rs
double precision :: t1,t2,t3
! hessian : mo_num 4D double precision matrix containing the hessian before the permutations
! h_tmpr : mo_num 4D double precision matrix containing the hessian after the permutations
! p,q,r,s : integer, indexes of the 4D hessian matrix
! t,u,v : integer, indexes to compute hessian elements
! pq,rs : integer, indexes for the conversion from 4D to 2D hessian matrix
! t1,t2,t3 : double precision, t3 = t2 - t1, time to compute the hessian
! Function
double precision :: get_two_e_integral
! get_two_e_integral : double precision function, two e integrals
! Provided :
! mo_one_e_integrals : mono e- integrals
! get_two_e_integral : two e- integrals
! one_e_dm_mo_alpha, one_e_dm_mo_beta : one body density matrix
! two_e_dm_mo : two body density matrix
!============
! Allocation
!============
allocate(hessian(mo_num,mo_num,mo_num,mo_num))!,h_tmpr(mo_num,mo_num,mo_num,mo_num))
!=============
! Calculation
!=============
if (debug) then
print*,'Enter in first_diag_hessien'
endif
! From Anderson et. al. (2014)
! The Journal of Chemical Physics 141, 244104 (2014); doi: 10.1063/1.4904384
! LaTeX formula :
!\begin{align*}
!H_{pq,rs} &= \dfrac{\partial^2 E(x)}{\partial x_{pq}^2} \\
!&= \mathcal{P}_{pq} \mathcal{P}_{rs} [ \frac{1}{2} \sum_u [\delta_{qr}(h_p^u \gamma_u^s + h_u^s \gamma_p^u)
!+ \delta_{ps}(h_r^u \gamma_u^q + h_u^q \gamma_u^r)]
!-(h_p^s \gamma_r^q + h_r^q \gamma_p^s) \\
!&+ \frac{1}{2} \sum_{tuv} [\delta_{qr}(v_{pt}^{uv} \Gamma_{uv}^{st} +v_{uv}^{st} \Gamma_{pt}^{uv})
!+ \delta_{ps}(v_{uv}^{qt} \Gamma_{rt}^{uv} + v_{rt}^{uv}\Gamma_{uv}^{qt})] \\
!&+ \sum_{uv} (v_{pr}^{uv} \Gamma_{uv}^{qs} + v_{uv}^{qs} \Gamma_{ps}^{uv}) \\
!&- \sum_{tu} (v_{pu}^{st} \Gamma_{rt}^{qu}+v_{pu}^{tr} \Gamma_{tr}^{qu}+v_{rt}^{qu}\Gamma_{pu}^{st} + v_{tr}^{qu}\Gamma_{pu}^{ts})
!\end{align*}
!================
! Initialization
!================
hessian = 0d0
CALL wall_time(t1)
!========================
! First line, first term
!========================
do p = 1, mo_num
do q = 1, mo_num
do r = 1, mo_num
do s = 1, mo_num
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
if (q==r) then
do u = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) + 0.5d0 * ( &
mo_one_e_integrals(u,p) * one_e_dm_mo(u,s) &
+ mo_one_e_integrals(s,u) * one_e_dm_mo(p,u))
enddo
endif
endif
enddo
enddo
enddo
enddo
!=========================
! First line, second term
!=========================
do p = 1, mo_num
do q = 1, mo_num
do r = 1, mo_num
do s = 1, mo_num
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
if (p==s) then
do u = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) + 0.5d0 * ( &
mo_one_e_integrals(u,r) * one_e_dm_mo(u,q) &
+ mo_one_e_integrals(q,u) * one_e_dm_mo(r,u))
enddo
endif
endif
enddo
enddo
enddo
enddo
!========================
! First line, third term
!========================
do p = 1, mo_num
do q = 1, mo_num
do r = 1, mo_num
do s = 1, mo_num
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
hessian(p,q,r,s) = hessian(p,q,r,s) &
- mo_one_e_integrals(s,p) * one_e_dm_mo(r,q) &
- mo_one_e_integrals(q,r) * one_e_dm_mo(p,s)
endif
enddo
enddo
enddo
enddo
!=========================
! Second line, first term
!=========================
do p = 1, mo_num
do q = 1, mo_num
do r = 1, mo_num
do s = 1, mo_num
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
if (q==r) then
do t = 1, mo_num
do u = 1, mo_num
do v = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) + 0.5d0 * ( &
get_two_e_integral(u,v,p,t,mo_integrals_map) * two_e_dm_mo(u,v,s,t) &
+ get_two_e_integral(s,t,u,v,mo_integrals_map) * two_e_dm_mo(p,t,u,v))
enddo
enddo
enddo
endif
endif
enddo
enddo
enddo
enddo
!==========================
! Second line, second term
!==========================
do p = 1, mo_num
do q = 1, mo_num
do r = 1, mo_num
do s = 1, mo_num
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
if (p==s) then
do t = 1, mo_num
do u = 1, mo_num
do v = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) + 0.5d0 * ( &
get_two_e_integral(q,t,u,v,mo_integrals_map) * two_e_dm_mo(r,t,u,v) &
+ get_two_e_integral(u,v,r,t,mo_integrals_map) * two_e_dm_mo(u,v,q,t))
enddo
enddo
enddo
endif
endif
enddo
enddo
enddo
enddo
!========================
! Third line, first term
!========================
do p = 1, mo_num
do q = 1, mo_num
do r = 1, mo_num
do s = 1, mo_num
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
do u = 1, mo_num
do v = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) &
+ get_two_e_integral(u,v,p,r,mo_integrals_map) * two_e_dm_mo(u,v,q,s) &
+ get_two_e_integral(q,s,u,v,mo_integrals_map) * two_e_dm_mo(p,r,u,v)
enddo
enddo
endif
enddo
enddo
enddo
enddo
!=========================
! Third line, second term
!=========================
do p = 1, mo_num
do q = 1, mo_num
do r = 1, mo_num
do s = 1, mo_num
! Permutations
if (((p==r) .and. (q==s)) .or. ((q==r) .and. (p==s)) &
.or. ((p==s) .and. (q==r))) then
do t = 1, mo_num
do u = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) &
- get_two_e_integral(s,t,p,u,mo_integrals_map) * two_e_dm_mo(r,t,q,u) &
- get_two_e_integral(t,s,p,u,mo_integrals_map) * two_e_dm_mo(t,r,q,u) &
- get_two_e_integral(q,u,r,t,mo_integrals_map) * two_e_dm_mo(p,u,s,t) &
- get_two_e_integral(q,u,t,r,mo_integrals_map) * two_e_dm_mo(p,u,t,s)
enddo
enddo
endif
enddo
enddo
enddo
enddo
CALL wall_time(t2)
t2 = t2 - t1
print*, 'Time to compute the hessian :', t2
!==============
! Permutations
!==============
! Convert the hessian mo_num * mo_num * mo_num * mo_num matrix in a
! 2D n * n matrix (n = mo_num*(mo_num-1)/2)
! H(pq,rs) : p<q and r<s
do r = 1, mo_num
do s = 1, mo_num
do q = 1, mo_num
do p = 1, mo_num
h_tmpr(p,q,r,s) = (hessian(p,q,r,s) - hessian(q,p,r,s) - hessian(p,q,s,r) + hessian(q,p,s,r))
enddo
enddo
enddo
enddo
!========================
! 4D matrix -> 2D matrix
!========================
! Convert the hessian mo_num * mo_num * mo_num * mo_num matrix in a
! 2D n * n matrix (n = mo_num*(mo_num-1)/2)
! H(pq,rs) : p<q and r<s
! 4D mo_num matrix to 2D n matrix
do rs = 1, n
call vec_to_mat_index(rs,r,s)
do pq = 1, n
call vec_to_mat_index(pq,p,q)
H(pq,rs) = h_tmpr(p,q,r,s)
enddo
enddo
! Display
if (debug) then
print*,'2D diag Hessian matrix'
do pq = 1, n
write(*,'(100(F10.5))') H(pq,:)
enddo
endif
!==============
! Deallocation
!==============
deallocate(hessian)
if (debug) then
print*,'Leave first_diag_hessien'
endif
end subroutine
#+END_SRC

127
src/mo_optimization/org/first_gradient_list_opt.org Normal file
View File

@ -0,0 +1,127 @@
* First gradient
#+BEGIN_SRC f90 :comments org :tangle first_gradient_list_opt.irp.f
subroutine first_gradient_list_opt(tmp_n,m,list,v_grad)
include 'constants.h'
implicit none
!===================================================================
! Compute the gradient of energy with respects to orbital rotations
!===================================================================
! Check if read_wf = true, else :
! qp set determinant read_wf true
! in
integer, intent(in) :: tmp_n,m,list(m)
! n : integer, n = m*(m-1)/2
! m = list_size
! out
double precision, intent(out) :: v_grad(tmp_n)
! v_grad : double precision vector of length n containeing the gradient
! internal
double precision, allocatable :: grad(:,:),A(:,:)
double precision :: norm
integer :: i,p,q,r,s,t,tmp_i,tmp_p,tmp_q,tmp_r,tmp_s,tmp_t
! grad : double precision matrix containing the gradient before the permutation
! A : double precision matrix containing the gradient after the permutation
! norm : double precision number, the norm of the vector gradient
! i,p,q,r,s,t : integer, indexes
! istate : integer, the electronic state
! Function
double precision :: get_two_e_integral, norm2
! get_two_e_integral : double precision function that gives the two e integrals
! norm2 : double precision function that gives the norm of a vector
! Provided :
! mo_one_e_integrals : mono e- integrals
! get_two_e_integral : two e- integrals
! one_e_dm_mo : one body density matrix (state average)
! two_e_dm_mo : two body density matrix (state average)
print*,'---first_gradient_list---'
!============
! Allocation
!============
allocate(grad(m,m),A(m,m))
!=============
! Calculation
!=============
v_grad = 0d0
grad = 0d0
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
!grad(tmp_p,tmp_q) = 0d0
do r = 1, mo_num
grad(tmp_p,tmp_q) = grad(tmp_p,tmp_q) + mo_one_e_integrals(p,r) * one_e_dm_mo(r,q) &
- mo_one_e_integrals(r,q) * one_e_dm_mo(p,r)
enddo
do r = 1, mo_num
do s = 1, mo_num
do t = 1, mo_num
grad(tmp_p,tmp_q) = grad(tmp_p,tmp_q) &
+ get_two_e_integral(p,t,r,s,mo_integrals_map) * two_e_dm_mo(r,s,q,t) &
- get_two_e_integral(r,s,q,t,mo_integrals_map) * two_e_dm_mo(p,t,r,s)
enddo
enddo
enddo
enddo
enddo
! Conversion mo_num*mo_num matrix to mo_num(mo_num-1)/2 vector
do tmp_i = 1, tmp_n
call vec_to_mat_index(tmp_i,tmp_p,tmp_q)
v_grad(tmp_i)=(grad(tmp_p,tmp_q) - grad(tmp_q,tmp_p))
enddo
! Display, vector containing the gradient elements
if (debug) then
print*,'Vector containing the gradient :'
write(*,'(100(F10.5))') v_grad(1:tmp_n)
endif
! Norm of the vector
norm = norm2(v_grad)
print*, 'Norm : ', norm
! Matrix gradient
A = 0d0
do tmp_q = 1, m
do tmp_p = 1, m
A(tmp_p,tmp_q) = grad(tmp_p,tmp_q) - grad(tmp_q,tmp_p)
enddo
enddo
! Display, matrix containting the gradient elements
if (debug) then
print*,'Matrix containing the gradient :'
do tmp_i = 1, m
write(*,'(100(E12.5))') A(tmp_i,1:m)
enddo
endif
!==============
! Deallocation
!==============
deallocate(grad,A)
print*,'---End first_gradient_list---'
end subroutine
#+END_SRC

130
src/mo_optimization/org/first_gradient_opt.org Normal file
View File

@ -0,0 +1,130 @@
* First gradient
#+BEGIN_SRC f90 :comments org :tangle first_gradient_opt.irp.f
subroutine first_gradient_opt(n,v_grad)
include 'constants.h'
implicit none
!===================================================================
! Compute the gradient of energy with respects to orbital rotations
!===================================================================
! Check if read_wf = true, else :
! qp set determinant read_wf true
END_DOC
! in
integer, intent(in) :: n
! n : integer, n = mo_num*(mo_num-1)/2
! out
double precision, intent(out) :: v_grad(n)
! v_grad : double precision vector of length n containeing the gradient
! internal
double precision, allocatable :: grad(:,:),A(:,:)
double precision :: norm
integer :: i,p,q,r,s,t
integer :: istate
! grad : double precision matrix containing the gradient before the permutation
! A : double precision matrix containing the gradient after the permutation
! norm : double precision number, the norm of the vector gradient
! i,p,q,r,s,t : integer, indexes
! istate : integer, the electronic state
! Function
double precision :: get_two_e_integral, norm2
! get_two_e_integral : double precision function that gives the two e integrals
! norm2 : double precision function that gives the norm of a vector
! Provided :
! mo_one_e_integrals : mono e- integrals
! get_two_e_integral : two e- integrals
! one_e_dm_mo : one body density matrix (state average)
! two_e_dm_mo : two body density matrix (state average)
!============
! Allocation
!============
allocate(grad(mo_num,mo_num),A(mo_num,mo_num))
!=============
! Calculation
!=============
if (debug) then
print*,'---first_gradient---'
endif
v_grad = 0d0
do p = 1, mo_num
do q = 1, mo_num
grad(p,q) = 0d0
do r = 1, mo_num
grad(p,q) = grad(p,q) + mo_one_e_integrals(p,r) * one_e_dm_mo(r,q) &
- mo_one_e_integrals(r,q) * one_e_dm_mo(p,r)
enddo
do r = 1, mo_num
do s = 1, mo_num
do t= 1, mo_num
grad(p,q) = grad(p,q) &
+ get_two_e_integral(p,t,r,s,mo_integrals_map) * two_e_dm_mo(r,s,q,t) &
- get_two_e_integral(r,s,q,t,mo_integrals_map) * two_e_dm_mo(p,t,r,s)
enddo
enddo
enddo
enddo
enddo
! Conversion mo_num*mo_num matrix to mo_num(mo_num-1)/2 vector
do i=1,n
call vec_to_mat_index(i,p,q)
v_grad(i)=(grad(p,q) - grad(q,p))
enddo
! Display, vector containing the gradient elements
if (debug) then
print*,'Vector containing the gradient :'
write(*,'(100(F10.5))') v_grad(1:n)
endif
! Norm of the vector
norm = norm2(v_grad)
print*, 'Norm : ', norm
! Matrix gradient
A = 0d0
do q=1,mo_num
do p=1,mo_num
A(p,q) = grad(p,q) - grad(q,p)
enddo
enddo
! Display, matrix containting the gradient elements
if (debug) then
print*,'Matrix containing the gradient :'
do i = 1, mo_num
write(*,'(100(E12.5))') A(i,1:mo_num)
enddo
endif
!==============
! Deallocation
!==============
deallocate(grad,A)
if (debug) then
print*,'---End first_gradient---'
endif
end subroutine
#+END_SRC

370
src/mo_optimization/org/first_hessian_list_opt.org Normal file
View File

@ -0,0 +1,370 @@
* First hessian
#+BEGIN_SRC f90 :comments :tangle first_hessian_list_opt.irp.f
subroutine first_hessian_list_opt(tmp_n,m,list,H,h_tmpr)
include 'constants.h'
implicit none
!==================================================================
! Compute the hessian of energy with respects to orbital rotations
!==================================================================
!===========
! Variables
!===========
! in
integer, intent(in) :: tmp_n, m, list(m)
!tmp_n : integer, tmp_n = m*(m-1)/2
! out
double precision, intent(out) :: H(tmp_n,tmp_n),h_tmpr(m,m,m,m)
! H : n by n double precision matrix containing the 2D hessian
! internal
double precision, allocatable :: hessian(:,:,:,:)
integer :: p,q, tmp_p,tmp_q
integer :: r,s,t,u,v,tmp_r,tmp_s,tmp_t,tmp_u,tmp_v
integer :: pq,rs,tmp_pq,tmp_rs
double precision :: t1,t2,t3,t4,t5,t6
! hessian : mo_num 4D double precision matrix containing the hessian before the permutations
! h_tmpr : mo_num 4D double precision matrix containing the hessian after the permutations
! p,q,r,s : integer, indexes of the 4D hessian matrix
! t,u,v : integer, indexes to compute hessian elements
! pq,rs : integer, indexes for the conversion from 4D to 2D hessian matrix
! t1,t2,t3 : double precision, t3 = t2 - t1, time to compute the hessian
! Funtion
double precision :: get_two_e_integral
! get_two_e_integral : double precision function, two e integrals
! Provided :
! mo_one_e_integrals : mono e- integrals
! get_two_e_integral : two e- integrals
! one_e_dm_mo_alpha, one_e_dm_mo_beta : one body density matrix
! two_e_dm_mo : two body density matrix
!============
! Allocation
!============
allocate(hessian(m,m,m,m))
!=============
! Calculation
!=============
print*,'---first_hess_list---'
! From Anderson et. al. (2014)
! The Journal of Chemical Physics 141, 244104 (2014); doi: 10.1063/1.4904384
CALL wall_time(t1)
! Initialization
hessian = 0d0
!========================
! First line, first term
!========================
CALL wall_time(t4)
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
if (q==r) then
do u = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) + 0.5d0 * ( &
mo_one_e_integrals(u,p) * one_e_dm_mo(u,s) &
+ mo_one_e_integrals(s,u) * one_e_dm_mo(p,u))
enddo
endif
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l1 1 :', t6
!=========================
! First line, second term
!=========================
CALL wall_time(t4)
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
if (p==s) then
do u = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) + 0.5d0 * ( &
mo_one_e_integrals(u,r) * one_e_dm_mo(u,q) &
+ mo_one_e_integrals(q,u) * one_e_dm_mo(r,u))
enddo
endif
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l1 2 :', t6
!========================
! First line, third term
!========================
CALL wall_time(t4)
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) &
- mo_one_e_integrals(s,p) * one_e_dm_mo(r,q)&
- mo_one_e_integrals(q,r) * one_e_dm_mo(p,s)
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l1 3 :', t6
!=========================
! Second line, first term
!=========================
CALL wall_time(t4)
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
if (q==r) then
do t = 1, mo_num
do u = 1, mo_num
do v = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) + 0.5d0 * ( &
get_two_e_integral(u,v,p,t,mo_integrals_map) * two_e_dm_mo(u,v,s,t) &
+ get_two_e_integral(s,t,u,v,mo_integrals_map) * two_e_dm_mo(p,t,u,v))
enddo
enddo
enddo
endif
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l2 1 :', t6
!==========================
! Second line, second term
!==========================
CALL wall_time(t4)
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
if (p==s) then
do t = 1, mo_num
do u = 1, mo_num
do v = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) + 0.5d0 * ( &
get_two_e_integral(q,t,u,v,mo_integrals_map) * two_e_dm_mo(r,t,u,v) &
+ get_two_e_integral(u,v,r,t,mo_integrals_map) * two_e_dm_mo(u,v,q,t))
enddo
enddo
enddo
endif
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l2 2 :', t6
!========================
! Third line, first term
!========================
CALL wall_time(t4)
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
do u = 1, mo_num
do v = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) &
+ get_two_e_integral(u,v,p,r,mo_integrals_map) * two_e_dm_mo(u,v,q,s) &
+ get_two_e_integral(q,s,u,v,mo_integrals_map) * two_e_dm_mo(p,r,u,v)
enddo
enddo
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l3 1 :', t6
!=========================
! Third line, second term
!=========================
CALL wall_time(t4)
do tmp_p = 1, m
p = list(tmp_p)
do tmp_q = 1, m
q = list(tmp_q)
do tmp_r = 1, m
r = list(tmp_r)
do tmp_s = 1, m
s = list(tmp_s)
do t = 1, mo_num
do u = 1, mo_num
hessian(tmp_p,tmp_q,tmp_r,tmp_s) = hessian(tmp_p,tmp_q,tmp_r,tmp_s) &
- get_two_e_integral(s,t,p,u,mo_integrals_map) * two_e_dm_mo(r,t,q,u) &
- get_two_e_integral(t,s,p,u,mo_integrals_map) * two_e_dm_mo(t,r,q,u) &
- get_two_e_integral(q,u,r,t,mo_integrals_map) * two_e_dm_mo(p,u,s,t) &
- get_two_e_integral(q,u,t,r,mo_integrals_map) * two_e_dm_mo(p,u,t,s)
enddo
enddo
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l3 2 :', t6
CALL wall_time(t2)
t3 = t2 -t1
print*,'Time to compute the hessian : ', t3
!==============
! Permutations
!==============
! Hessian(p,q,r,s) = P_pq P_rs [ ...]
! => Hessian(p,q,r,s) = (p,q,r,s) - (q,p,r,s) - (p,q,s,r) + (q,p,s,r)
do tmp_s = 1, m
do tmp_r = 1, m
do tmp_q = 1, m
do tmp_p = 1, m
h_tmpr(tmp_p,tmp_q,tmp_r,tmp_s) = (hessian(tmp_p,tmp_q,tmp_r,tmp_s) - hessian(tmp_q,tmp_p,tmp_r,tmp_s) &
- hessian(tmp_p,tmp_q,tmp_s,tmp_r) + hessian(tmp_q,tmp_p,tmp_s,tmp_r))
enddo
enddo
enddo
enddo
!========================
! 4D matrix to 2D matrix
!========================
! Convert the hessian mo_num * mo_num * mo_num * mo_num matrix in a
! 2D n * n matrix (n = mo_num*(mo_num-1)/2)
! H(pq,rs) : p<q and r<s
! 4D mo_num matrix to 2D n matrix
do tmp_pq = 1, tmp_n
call vec_to_mat_index(tmp_pq,tmp_p,tmp_q)
do tmp_rs = 1, tmp_n
call vec_to_mat_index(tmp_rs,tmp_r,tmp_s)
H(tmp_pq,tmp_rs) = h_tmpr(tmp_p,tmp_q,tmp_r,tmp_s)
enddo
enddo
! Display
if (debug) then
print*,'2D Hessian matrix'
do tmp_pq = 1, tmp_n
write(*,'(100(F10.5))') H(tmp_pq,:)
enddo
endif
!==============
! Deallocation
!==============
deallocate(hessian)
print*,'---End first_hess_list---'
end subroutine
#+END_SRC

365
src/mo_optimization/org/first_hessian_opt.org Normal file
View File

@ -0,0 +1,365 @@
* First hessian
#+BEGIN_SRC f90 :comments :tangle first_hessian_opt.irp.f
subroutine first_hessian_opt(n,H,h_tmpr)
include 'constants.h'
implicit none
!==================================================================
! Compute the hessian of energy with respects to orbital rotations
!==================================================================
!===========
! Variables
!===========
! in
integer, intent(in) :: n
!n : integer, n = mo_num*(mo_num-1)/2
! out
double precision, intent(out) :: H(n,n),h_tmpr(mo_num,mo_num,mo_num,mo_num)
! H : n by n double precision matrix containing the 2D hessian
! internal
double precision, allocatable :: hessian(:,:,:,:)
integer :: p,q
integer :: r,s,t,u,v
integer :: pq,rs
double precision :: t1,t2,t3,t4,t5,t6
! hessian : mo_num 4D double precision matrix containing the hessian before the permutations
! h_tmpr : mo_num 4D double precision matrix containing the hessian after the permutations
! p,q,r,s : integer, indexes of the 4D hessian matrix
! t,u,v : integer, indexes to compute hessian elements
! pq,rs : integer, indexes for the conversion from 4D to 2D hessian matrix
! t1,t2,t3 : double precision, t3 = t2 - t1, time to compute the hessian
! Funtion
double precision :: get_two_e_integral
! get_two_e_integral : double precision function, two e integrals
! Provided :
! mo_one_e_integrals : mono e- integrals
! get_two_e_integral : two e- integrals
! one_e_dm_mo_alpha, one_e_dm_mo_beta : one body density matrix
! two_e_dm_mo : two body density matrix
!============
! Allocation
!============
allocate(hessian(mo_num,mo_num,mo_num,mo_num))
!=============
! Calculation
!=============
if (debug) then
print*,'Enter in first_hess'
endif
! From Anderson et. al. (2014)
! The Journal of Chemical Physics 141, 244104 (2014); doi: 10.1063/1.4904384
CALL wall_time(t1)
! Initialization
hessian = 0d0
!========================
! First line, first term
!========================
CALL wall_time(t4)
do p = 1, mo_num
do q = 1, mo_num
do r = 1, mo_num
do s = 1, mo_num
if (q==r) then
do u = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) + 0.5d0 * ( &
mo_one_e_integrals(u,p) * one_e_dm_mo(u,s) &
+ mo_one_e_integrals(s,u) * one_e_dm_mo(p,u))
enddo
endif
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l1 1 :', t6
!=========================
! First line, second term
!=========================
CALL wall_time(t4)
do p = 1, mo_num
do q = 1, mo_num
do r = 1, mo_num
do s = 1, mo_num
if (p==s) then
do u = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) + 0.5d0 * ( &
mo_one_e_integrals(u,r) * one_e_dm_mo(u,q) &
+ mo_one_e_integrals(q,u) * one_e_dm_mo(r,u))
enddo
endif
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l1 2 :', t6
!========================
! First line, third term
!========================
CALL wall_time(t4)
do p = 1, mo_num
do q = 1, mo_num
do r = 1, mo_num
do s = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) &
- mo_one_e_integrals(s,p) * one_e_dm_mo(r,q)&
- mo_one_e_integrals(q,r) * one_e_dm_mo(p,s)
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l1 3 :', t6
!=========================
! Second line, first term
!=========================
CALL wall_time(t4)
do s = 1, mo_num
do r = 1, mo_num
do q = 1, mo_num
do p = 1, mo_num
! do p = 1, mo_num
! do q = 1, mo_num
! do r = 1, mo_num
! do s = 1, mo_num
if (q==r) then
do t = 1, mo_num
do u = 1, mo_num
do v = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) + 0.5d0 * ( &
get_two_e_integral(u,v,p,t,mo_integrals_map) * two_e_dm_mo(u,v,s,t) &
+ get_two_e_integral(s,t,u,v,mo_integrals_map) * two_e_dm_mo(p,t,u,v))
enddo
enddo
enddo
endif
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l2 1 :', t6
!==========================
! Second line, second term
!==========================
CALL wall_time(t4)
do s = 1, mo_num
do r = 1, mo_num
do q = 1, mo_num
do p = 1, mo_num
! do p = 1, mo_num
! do q = 1, mo_num
! do r = 1, mo_num
! do s = 1, mo_num
if (p==s) then
do t = 1, mo_num
do u = 1, mo_num
do v = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) + 0.5d0 * ( &
get_two_e_integral(q,t,u,v,mo_integrals_map) * two_e_dm_mo(r,t,u,v) &
+ get_two_e_integral(u,v,r,t,mo_integrals_map) * two_e_dm_mo(u,v,q,t))
enddo
enddo
enddo
endif
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l2 2 :', t6
!========================
! Third line, first term
!========================
CALL wall_time(t4)
do s = 1, mo_num
do r = 1, mo_num
do q = 1, mo_num
do p = 1, mo_num
! do p = 1, mo_num
! do q = 1, mo_num
! do r = 1, mo_num
! do s = 1, mo_num
do u = 1, mo_num
do v = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) &
+ get_two_e_integral(u,v,p,r,mo_integrals_map) * two_e_dm_mo(u,v,q,s) &
+ get_two_e_integral(q,s,u,v,mo_integrals_map) * two_e_dm_mo(p,r,u,v)
enddo
enddo
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l3 1 :', t6
!=========================
! Third line, second term
!=========================
CALL wall_time(t4)
do s = 1, mo_num
do r = 1, mo_num
do q = 1, mo_num
do p = 1, mo_num
! do p = 1, mo_num
! do q = 1, mo_num
! do r = 1, mo_num
! do s = 1, mo_num
do t = 1, mo_num
do u = 1, mo_num
hessian(p,q,r,s) = hessian(p,q,r,s) &
- get_two_e_integral(s,t,p,u,mo_integrals_map) * two_e_dm_mo(r,t,q,u) &
- get_two_e_integral(t,s,p,u,mo_integrals_map) * two_e_dm_mo(t,r,q,u) &
- get_two_e_integral(q,u,r,t,mo_integrals_map) * two_e_dm_mo(p,u,s,t) &
- get_two_e_integral(q,u,t,r,mo_integrals_map) * two_e_dm_mo(p,u,t,s)
enddo
enddo
enddo
enddo
enddo
enddo
CALL wall_time(t5)
t6 = t5-t4
print*,'l3 2 :', t6
CALL wall_time(t2)
t3 = t2 -t1
print*,'Time to compute the hessian : ', t3
!==============
! Permutations
!==============
! Hessian(p,q,r,s) = P_pq P_rs [ ...]
! => Hessian(p,q,r,s) = (p,q,r,s) - (q,p,r,s) - (p,q,s,r) + (q,p,s,r)
do s = 1, mo_num
do r = 1, mo_num
do q = 1, mo_num
do p = 1, mo_num
h_tmpr(p,q,r,s) = (hessian(p,q,r,s) - hessian(q,p,r,s) - hessian(p,q,s,r) + hessian(q,p,s,r))
enddo
enddo
enddo
enddo
!========================
! 4D matrix to 2D matrix
!========================
! Convert the hessian mo_num * mo_num * mo_num * mo_num matrix in a
! 2D n * n matrix (n = mo_num*(mo_num-1)/2)
! H(pq,rs) : p<q and r<s
! 4D mo_num matrix to 2D n matrix
do pq = 1, n
call vec_to_mat_index(pq,p,q)
do rs = 1, n
call vec_to_mat_index(rs,r,s)
H(pq,rs) = h_tmpr(p,q,r,s)
enddo
enddo
! Display
if (debug) then
print*,'2D Hessian matrix'
do pq = 1, n
write(*,'(100(F10.5))') H(pq,:)
enddo
endif
!==============
! Deallocation
!==============
deallocate(hessian)
if (debug) then
print*,'Leave first_hess'
endif
end subroutine
#+END_SRC

Some files were not shown because too many files have changed in this diff Show More