From 10446b66bd75e906a37a2af35905abaaf068dda5 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 25 Mar 2022 15:29:28 +0100 Subject: [PATCH 01/80] Minor change --- src/cipsi/selection.irp.f | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/cipsi/selection.irp.f b/src/cipsi/selection.irp.f index f1ec6ff6..e62d5c8a 100644 --- a/src/cipsi/selection.irp.f +++ b/src/cipsi/selection.irp.f @@ -783,7 +783,9 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d alpha_h_psi = mat(istate, p1, p2) - pt2_data % overlap(:,istate) = pt2_data % overlap(:,istate) + coef(:) * coef(istate) + do k=1,N_states + pt2_data % overlap(k,istate) = pt2_data % overlap(k,istate) + coef(k) * coef(istate) + end do pt2_data % variance(istate) = pt2_data % variance(istate) + alpha_h_psi * alpha_h_psi pt2_data % pt2(istate) = pt2_data % pt2(istate) + e_pert(istate) From db08b90945926b41c46a49f3048a3ac5af686d45 Mon Sep 17 00:00:00 2001 From: eginer Date: Mon, 28 Mar 2022 16:48:24 +0200 Subject: [PATCH 02/80] added save_wf_unormalized --- src/determinants/determinants.irp.f | 65 +++++++++++++++++++++++++++++ 1 file changed, 65 insertions(+) diff --git a/src/determinants/determinants.irp.f b/src/determinants/determinants.irp.f index b8c8658f..5b12a6d9 100644 --- a/src/determinants/determinants.irp.f +++ b/src/determinants/determinants.irp.f @@ -587,6 +587,71 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef) end +subroutine save_wavefunction_general_unormalized(ndet,nstates,psidet,dim_psicoef,psicoef) + implicit none + BEGIN_DOC + ! Save the wave function into the |EZFIO| file + END_DOC + use bitmasks + include 'constants.include.F' + integer, intent(in) :: ndet,nstates,dim_psicoef + integer(bit_kind), intent(in) :: psidet(N_int,2,ndet) + double precision, intent(in) :: psicoef(dim_psicoef,nstates) + integer*8, allocatable :: psi_det_save(:,:,:) + double precision, allocatable :: psi_coef_save(:,:) + + double precision :: accu_norm + integer :: i,j,k, ndet_qp_edit + + if (mpi_master) then + ndet_qp_edit = min(ndet,N_det_qp_edit) + + call ezfio_set_determinants_N_int(N_int) + call ezfio_set_determinants_bit_kind(bit_kind) + call ezfio_set_determinants_N_det(ndet) + call ezfio_set_determinants_N_det_qp_edit(ndet_qp_edit) + call ezfio_set_determinants_n_states(nstates) + call ezfio_set_determinants_mo_label(mo_label) + + allocate (psi_det_save(N_int,2,ndet)) + do i=1,ndet + do j=1,2 + do k=1,N_int + psi_det_save(k,j,i) = transfer(psidet(k,j,i),1_8) + enddo + enddo + enddo + call ezfio_set_determinants_psi_det(psi_det_save) + call ezfio_set_determinants_psi_det_qp_edit(psi_det_save) + deallocate (psi_det_save) + + allocate (psi_coef_save(ndet,nstates)) + do k=1,nstates + do i=1,ndet + psi_coef_save(i,k) = psicoef(i,k) + enddo + enddo + + call ezfio_set_determinants_psi_coef(psi_coef_save) + deallocate (psi_coef_save) + + allocate (psi_coef_save(ndet_qp_edit,nstates)) + do k=1,nstates + do i=1,ndet_qp_edit + psi_coef_save(i,k) = psicoef(i,k) + enddo + enddo + + call ezfio_set_determinants_psi_coef_qp_edit(psi_coef_save) + deallocate (psi_coef_save) + + call write_int(6,ndet,'Saved determinants') + endif +end + + + + subroutine save_wavefunction_specified(ndet,nstates,psidet,psicoef,ndetsave,index_det_save) implicit none From 644aa334dc8557b1796cf395687d63f988fe9ab2 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 21 Apr 2022 13:39:01 +0200 Subject: [PATCH 03/80] Update test values --- src/fci/40.fci.bats | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/fci/40.fci.bats b/src/fci/40.fci.bats index 1a0c5507..b8528e97 100644 --- a/src/fci/40.fci.bats +++ b/src/fci/40.fci.bats @@ -71,7 +71,7 @@ function run_stoch() { @test "HBO" { # 13.3144s [[ -n $TRAVIS ]] && skip qp set_file hbo.ezfio - run -100.214099486337 1.e-3 100000 + run -100.213 1.e-3 100000 } @test "H2O" { # 11.3727s @@ -89,7 +89,7 @@ function run_stoch() { @test "SO" { # 13.4952s [[ -n $TRAVIS ]] && skip qp set_file so.ezfio - run -26.0176563764039 1.e-3 100000 + run -26.014 5.e-3 100000 } @test "H2S" { # 13.6745s @@ -119,7 +119,7 @@ function run_stoch() { @test "SiH3" { # 15.99s [[ -n $TRAVIS ]] && skip qp set_file sih3.ezfio - run -5.57241217753818 5.e-4 100000 + run -5.572 1.e-3 100000 } @test "CH4" { # 16.1612s @@ -153,7 +153,7 @@ function run_stoch() { [[ -n $TRAVIS ]] && skip qp set_file n2.ezfio qp set_mo_class --core="[1,2]" --act="[3-40]" --del="[41-60]" - run -109.287917088107 1.5e-3 100000 + run -109.288 2.e-3 100000 } @test "N2H4" { # 18.5006s From 1d5f8400aa8d7e7bcf89eaca052b63904f78fa54 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 21 Apr 2022 13:42:10 +0200 Subject: [PATCH 04/80] Update test values --- src/fci/40.fci.bats | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/fci/40.fci.bats b/src/fci/40.fci.bats index b8528e97..d890d586 100644 --- a/src/fci/40.fci.bats +++ b/src/fci/40.fci.bats @@ -42,7 +42,7 @@ function run_stoch() { [[ -n $TRAVIS ]] && skip qp set_file f2.ezfio qp set_frozen_core - run_stoch -199.304922384814 3.e-4 100000 + run_stoch -199.304922384814 3.e-3 100000 } @test "NH3" { # 10.6657s @@ -89,7 +89,7 @@ function run_stoch() { @test "SO" { # 13.4952s [[ -n $TRAVIS ]] && skip qp set_file so.ezfio - run -26.014 5.e-3 100000 + run -26.015 3.e-3 100000 } @test "H2S" { # 13.6745s @@ -146,7 +146,7 @@ function run_stoch() { [[ -n $TRAVIS ]] && skip qp set_file c2h2.ezfio qp set_mo_class --act="[1-30]" --del="[31-36]" - run -12.3685464085969 2.e-3 100000 + run -12.367 3.e-3 100000 } @test "N2" { # 18.0198s @@ -182,6 +182,6 @@ function run_stoch() { [[ -n $TRAVIS ]] && skip qp set_file hcn.ezfio qp set_mo_class --core="[1,2]" --act="[3-40]" --del="[41-55]" - run -93.0777619629755 1.e-3 100000 + run -93.078 2.e-3 100000 } From 57b47807fa1b7265345d877ca4902e87f39935ba Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 21 Apr 2022 14:25:29 +0200 Subject: [PATCH 05/80] Added CIS_read --- src/cis_read/EZFIO.cfg | 7 +++ src/cis_read/NEED | 3 ++ src/cis_read/README.rst | 5 +++ src/cis_read/cis_read.irp.f | 88 +++++++++++++++++++++++++++++++++++++ src/cis_read/h_apply.irp.f | 14 ++++++ 5 files changed, 117 insertions(+) create mode 100644 src/cis_read/EZFIO.cfg create mode 100644 src/cis_read/NEED create mode 100644 src/cis_read/README.rst create mode 100644 src/cis_read/cis_read.irp.f create mode 100644 src/cis_read/h_apply.irp.f diff --git a/src/cis_read/EZFIO.cfg b/src/cis_read/EZFIO.cfg new file mode 100644 index 00000000..955d1bef --- /dev/null +++ b/src/cis_read/EZFIO.cfg @@ -0,0 +1,7 @@ +[energy] +type: double precision +doc: Variational |CIS| energy +interface: ezfio +size: (determinants.n_states) + + diff --git a/src/cis_read/NEED b/src/cis_read/NEED new file mode 100644 index 00000000..42992ac6 --- /dev/null +++ b/src/cis_read/NEED @@ -0,0 +1,3 @@ +selectors_full +generators_full +davidson_undressed diff --git a/src/cis_read/README.rst b/src/cis_read/README.rst new file mode 100644 index 00000000..31648636 --- /dev/null +++ b/src/cis_read/README.rst @@ -0,0 +1,5 @@ +=== +cis_read +=== + +Reads the input WF and performs all singles on top of it. diff --git a/src/cis_read/cis_read.irp.f b/src/cis_read/cis_read.irp.f new file mode 100644 index 00000000..055b5e15 --- /dev/null +++ b/src/cis_read/cis_read.irp.f @@ -0,0 +1,88 @@ +program cis + implicit none + BEGIN_DOC +! +! Configuration Interaction with Single excitations. +! +! This program takes a reference Slater determinant of ROHF-like +! occupancy, and performs all single excitations on top of it. +! Disregarding spatial symmetry, it computes the `n_states` lowest +! eigenstates of that CI matrix. (see :option:`determinants n_states`) +! +! This program can be useful in many cases: +! +! +! 1. Ground state calculation +! +! To be sure to have the lowest |SCF| solution, perform an :ref:`scf` +! (see the :ref:`module_hartree_fock` module), then a :ref:`cis`, save the +! natural orbitals (see :ref:`save_natorb`) and re-run an :ref:`scf` +! optimization from this |MO| guess. +! +! +! 2. Excited states calculations +! +! The lowest excited states are much likely to be dominated by +! single-excitations. Therefore, running a :ref:`cis` will save the +! `n_states` lowest states within the |CIS| space in the |EZFIO| +! directory, which can afterwards be used as guess wave functions for +! a further multi-state |FCI| calculation if :option:`determinants +! read_wf` is set to |true| before running the :ref:`fci` executable. +! +! +! If :option:`determinants s2_eig` is set to |true|, the |CIS| +! will only retain states having the expected |S^2| value (see +! :option:`determinants expected_s2`). Otherwise, the |CIS| will take +! the lowest :option:`determinants n_states`, whatever multiplicity +! they are. +! +! .. note:: +! +! To discard some orbitals, use the :ref:`qp_set_mo_class` +! command to specify: +! +! * *core* orbitals which will be always doubly occupied +! +! * *act* orbitals where an electron can be either excited from or to +! +! * *del* orbitals which will be never occupied +! + END_DOC + read_wf = .True. + TOUCH read_wf + call run +end + +subroutine run + implicit none + integer :: i + + + if(pseudo_sym)then + call H_apply_cis_sym + else + call H_apply_cis + endif + print*,'' + print *, 'N_det = ', N_det + print*,'******************************' + print *, 'Energies of the states:' + do i = 1,N_states + print *, i, CI_energy(i) + enddo + if (N_states > 1) then + print*,'' + print*,'******************************************************' + print*,'Excitation energies (au) (eV)' + do i = 2, N_states + print*, i ,CI_energy(i) - CI_energy(1), (CI_energy(i) - CI_energy(1))/0.0367502d0 + enddo + print*,'' + endif + + call ezfio_set_cis_energy(CI_energy) + psi_coef = ci_eigenvectors + SOFT_TOUCH psi_coef + call save_wavefunction_truncated(save_threshold) + +end diff --git a/src/cis_read/h_apply.irp.f b/src/cis_read/h_apply.irp.f new file mode 100644 index 00000000..14389bed --- /dev/null +++ b/src/cis_read/h_apply.irp.f @@ -0,0 +1,14 @@ +! Generates subroutine H_apply_cis +! -------------------------------- + +BEGIN_SHELL [ /usr/bin/env python3 ] +from generate_h_apply import H_apply +H = H_apply("cis",do_double_exc=False) +print(H) + +H = H_apply("cis_sym",do_double_exc=False) +H.filter_only_connected_to_hf() +print(H) + +END_SHELL + From 7cd6b13805b9a9e59bb027181c6176182ad81ccb Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sun, 1 May 2022 14:12:28 +0200 Subject: [PATCH 06/80] C quicksort --- src/utils/map_module.f90 | 6 +- src/utils/qsort.c | 373 ++++++++++++++++++++ src/utils/qsort.org | 169 +++++++++ src/utils/qsort_module.f90 | 347 ++++++++++++++++++ src/utils/sort.irp.f | 695 ------------------------------------- 5 files changed, 892 insertions(+), 698 deletions(-) create mode 100644 src/utils/qsort.c create mode 100644 src/utils/qsort.org create mode 100644 src/utils/qsort_module.f90 diff --git a/src/utils/map_module.f90 b/src/utils/map_module.f90 index 98e73470..ceaec874 100644 --- a/src/utils/map_module.f90 +++ b/src/utils/map_module.f90 @@ -238,11 +238,11 @@ subroutine cache_map_sort(map) iorder(i) = i enddo if (cache_key_kind == 2) then - call i2radix_sort(map%key,iorder,map%n_elements,-1) + call i2sort(map%key,iorder,map%n_elements,-1) else if (cache_key_kind == 4) then - call iradix_sort(map%key,iorder,map%n_elements,-1) + call isort(map%key,iorder,map%n_elements,-1) else if (cache_key_kind == 8) then - call i8radix_sort(map%key,iorder,map%n_elements,-1) + call i8sort(map%key,iorder,map%n_elements,-1) endif if (integral_kind == 4) then call set_order(map%value,iorder,map%n_elements) diff --git a/src/utils/qsort.c b/src/utils/qsort.c new file mode 100644 index 00000000..5d685741 --- /dev/null +++ b/src/utils/qsort.c @@ -0,0 +1,373 @@ +/* [[file:~/qp2/src/utils/qsort.org::*Generated%20C%20file][Generated C file:1]] */ +#include +#include + +struct int16_t_comp { + int16_t x; + int32_t i; +}; + +int compare_int16_t( const void * l, const void * r ) +{ + const struct int16_t_comp * restrict _l= l; + const struct int16_t_comp * restrict _r= r; + if( _l->x > _r->x ) return 1; + if( _l->x < _r->x ) return -1; + return 0; +} + +void qsort_int16_t(int16_t* A_in, int32_t* iorder, int32_t isize) { + struct int16_t_comp* A = malloc(isize * sizeof(struct int16_t_comp)); + if (A == NULL) return; + + for (int i=0 ; ix > _r->x ) return 1; + if( _l->x < _r->x ) return -1; + return 0; +} + +void qsort_int16_t_big(int16_t* A_in, int64_t* iorder, int64_t isize) { + struct int16_t_comp_big* A = malloc(isize * sizeof(struct int16_t_comp_big)); + if (A == NULL) return; + + for (int i=0 ; ix > _r->x ) return 1; + if( _l->x < _r->x ) return -1; + return 0; +} + +void qsort_int32_t(int32_t* A_in, int32_t* iorder, int32_t isize) { + struct int32_t_comp* A = malloc(isize * sizeof(struct int32_t_comp)); + if (A == NULL) return; + + for (int i=0 ; ix > _r->x ) return 1; + if( _l->x < _r->x ) return -1; + return 0; +} + +void qsort_int32_t_big(int32_t* A_in, int64_t* iorder, int64_t isize) { + struct int32_t_comp_big* A = malloc(isize * sizeof(struct int32_t_comp_big)); + if (A == NULL) return; + + for (int i=0 ; ix > _r->x ) return 1; + if( _l->x < _r->x ) return -1; + return 0; +} + +void qsort_int64_t(int64_t* A_in, int32_t* iorder, int32_t isize) { + struct int64_t_comp* A = malloc(isize * sizeof(struct int64_t_comp)); + if (A == NULL) return; + + for (int i=0 ; ix > _r->x ) return 1; + if( _l->x < _r->x ) return -1; + return 0; +} + +void qsort_int64_t_big(int64_t* A_in, int64_t* iorder, int64_t isize) { + struct int64_t_comp_big* A = malloc(isize * sizeof(struct int64_t_comp_big)); + if (A == NULL) return; + + for (int i=0 ; ix > _r->x ) return 1; + if( _l->x < _r->x ) return -1; + return 0; +} + +void qsort_double(double* A_in, int32_t* iorder, int32_t isize) { + struct double_comp* A = malloc(isize * sizeof(struct double_comp)); + if (A == NULL) return; + + for (int i=0 ; ix > _r->x ) return 1; + if( _l->x < _r->x ) return -1; + return 0; +} + +void qsort_double_big(double* A_in, int64_t* iorder, int64_t isize) { + struct double_comp_big* A = malloc(isize * sizeof(struct double_comp_big)); + if (A == NULL) return; + + for (int i=0 ; ix > _r->x ) return 1; + if( _l->x < _r->x ) return -1; + return 0; +} + +void qsort_float(float* A_in, int32_t* iorder, int32_t isize) { + struct float_comp* A = malloc(isize * sizeof(struct float_comp)); + if (A == NULL) return; + + for (int i=0 ; ix > _r->x ) return 1; + if( _l->x < _r->x ) return -1; + return 0; +} + +void qsort_float_big(float* A_in, int64_t* iorder, int64_t isize) { + struct float_comp_big* A = malloc(isize * sizeof(struct float_comp_big)); + if (A == NULL) return; + + for (int i=0 ; ix > _r->x ) return 1; + if( _l->x < _r->x ) return -1; + return 0; +} + +void qsort_TYPE_big(TYPE* A_in, int32_t* iorder, int32_t isize) { + struct TYPE_comp_big* A = malloc(isize * sizeof(struct TYPE_comp_big)); + if (A == NULL) return; + + for (int i=0 ; i> +""" +for typ in ["int16_t", "int32_t", "int64_t", "double", "float"]: + print( data.replace("TYPE", typ).replace("_big", "") ) + print( data.replace("int32_t", "int64_t").replace("TYPE", typ) ) +#+end_src + +#+NAME: replaced_f +#+begin_src python :results output :noweb yes +data = """ +<> +""" +c1 = { + "int16_t": "i2", + "int32_t": "i", + "int64_t": "i8", + "double": "d", + "float": "" +} +c2 = { + "int16_t": "integer", + "int32_t": "integer", + "int64_t": "integer", + "double": "real", + "float": "real" +} + +for typ in ["int16_t", "int32_t", "int64_t", "double", "float"]: + print( data.replace("real",c2[typ]).replace("L",c1[typ]).replace("TYPE", typ).replace("_big", "") ) + print( data.replace("real",c2[typ]).replace("L",c1[typ]).replace("int32_t", "int64_t").replace("TYPE", typ) ) +#+end_src + +#+NAME: replaced_f2 +#+begin_src python :results output :noweb yes +data = """ +<> +""" +c1 = { + "int16_t": "i2", + "int32_t": "i", + "int64_t": "i8", + "double": "d", + "float": "" +} +c2 = { + "int16_t": "integer", + "int32_t": "integer", + "int64_t": "integer", + "double": "real", + "float": "real" +} + +for typ in ["int16_t", "int32_t", "int64_t", "double", "float"]: + print( data.replace("real",c2[typ]).replace("L",c1[typ]).replace("TYPE", typ).replace("_big", "") ) + print( data.replace("real",c2[typ]).replace("L",c1[typ]).replace("int32_t", "int64_t").replace("TYPE", typ) ) +#+end_src + +* Generated C file + +#+BEGIN_SRC c :comments link :tangle qsort.c :noweb yes +#include +#include +<> +#+END_SRC + +* Generated Fortran file + +#+BEGIN_SRC f90 :tangle qsort_module.f90 :noweb yes +module qsort_module + use iso_c_binding + + interface + <> + end interface + +end module qsort_module + +<> + +#+END_SRC + diff --git a/src/utils/qsort_module.f90 b/src/utils/qsort_module.f90 new file mode 100644 index 00000000..a72a4f9e --- /dev/null +++ b/src/utils/qsort_module.f90 @@ -0,0 +1,347 @@ +module qsort_module + use iso_c_binding + + interface + + subroutine i2sort_c(A, iorder, isize) bind(C, name="qsort_int16_t") + use iso_c_binding + integer(c_int32_t), value :: isize + integer(c_int32_t) :: iorder(isize) + integer (c_int16_t) :: A(isize) + end subroutine i2sort_c + + subroutine i2sort_noidx_c(A, isize) bind(C, name="qsort_int16_t_noidx") + use iso_c_binding + integer(c_int32_t), value :: isize + integer (c_int16_t) :: A(isize) + end subroutine i2sort_noidx_c + + + + subroutine i2sort_big_c(A, iorder, isize) bind(C, name="qsort_int16_t_big") + use iso_c_binding + integer(c_int64_t), value :: isize + integer(c_int64_t) :: iorder(isize) + integer (c_int16_t) :: A(isize) + end subroutine i2sort_big_c + + subroutine i2sort_noidx_big_c(A, isize) bind(C, name="qsort_int16_t_noidx_big") + use iso_c_binding + integer(c_int64_t), value :: isize + integer (c_int16_t) :: A(isize) + end subroutine i2sort_noidx_big_c + + + + subroutine isort_c(A, iorder, isize) bind(C, name="qsort_int32_t") + use iso_c_binding + integer(c_int32_t), value :: isize + integer(c_int32_t) :: iorder(isize) + integer (c_int32_t) :: A(isize) + end subroutine isort_c + + subroutine isort_noidx_c(A, isize) bind(C, name="qsort_int32_t_noidx") + use iso_c_binding + integer(c_int32_t), value :: isize + integer (c_int32_t) :: A(isize) + end subroutine isort_noidx_c + + + + subroutine isort_big_c(A, iorder, isize) bind(C, name="qsort_int32_t_big") + use iso_c_binding + integer(c_int64_t), value :: isize + integer(c_int64_t) :: iorder(isize) + integer (c_int32_t) :: A(isize) + end subroutine isort_big_c + + subroutine isort_noidx_big_c(A, isize) bind(C, name="qsort_int32_t_noidx_big") + use iso_c_binding + integer(c_int64_t), value :: isize + integer (c_int32_t) :: A(isize) + end subroutine isort_noidx_big_c + + + + subroutine i8sort_c(A, iorder, isize) bind(C, name="qsort_int64_t") + use iso_c_binding + integer(c_int32_t), value :: isize + integer(c_int32_t) :: iorder(isize) + integer (c_int64_t) :: A(isize) + end subroutine i8sort_c + + subroutine i8sort_noidx_c(A, isize) bind(C, name="qsort_int64_t_noidx") + use iso_c_binding + integer(c_int32_t), value :: isize + integer (c_int64_t) :: A(isize) + end subroutine i8sort_noidx_c + + + + subroutine i8sort_big_c(A, iorder, isize) bind(C, name="qsort_int64_t_big") + use iso_c_binding + integer(c_int64_t), value :: isize + integer(c_int64_t) :: iorder(isize) + integer (c_int64_t) :: A(isize) + end subroutine i8sort_big_c + + subroutine i8sort_noidx_big_c(A, isize) bind(C, name="qsort_int64_t_noidx_big") + use iso_c_binding + integer(c_int64_t), value :: isize + integer (c_int64_t) :: A(isize) + end subroutine i8sort_noidx_big_c + + + + subroutine dsort_c(A, iorder, isize) bind(C, name="qsort_double") + use iso_c_binding + integer(c_int32_t), value :: isize + integer(c_int32_t) :: iorder(isize) + real (c_double) :: A(isize) + end subroutine dsort_c + + subroutine dsort_noidx_c(A, isize) bind(C, name="qsort_double_noidx") + use iso_c_binding + integer(c_int32_t), value :: isize + real (c_double) :: A(isize) + end subroutine dsort_noidx_c + + + + subroutine dsort_big_c(A, iorder, isize) bind(C, name="qsort_double_big") + use iso_c_binding + integer(c_int64_t), value :: isize + integer(c_int64_t) :: iorder(isize) + real (c_double) :: A(isize) + end subroutine dsort_big_c + + subroutine dsort_noidx_big_c(A, isize) bind(C, name="qsort_double_noidx_big") + use iso_c_binding + integer(c_int64_t), value :: isize + real (c_double) :: A(isize) + end subroutine dsort_noidx_big_c + + + + subroutine sort_c(A, iorder, isize) bind(C, name="qsort_float") + use iso_c_binding + integer(c_int32_t), value :: isize + integer(c_int32_t) :: iorder(isize) + real (c_float) :: A(isize) + end subroutine sort_c + + subroutine sort_noidx_c(A, isize) bind(C, name="qsort_float_noidx") + use iso_c_binding + integer(c_int32_t), value :: isize + real (c_float) :: A(isize) + end subroutine sort_noidx_c + + + + subroutine sort_big_c(A, iorder, isize) bind(C, name="qsort_float_big") + use iso_c_binding + integer(c_int64_t), value :: isize + integer(c_int64_t) :: iorder(isize) + real (c_float) :: A(isize) + end subroutine sort_big_c + + subroutine sort_noidx_big_c(A, isize) bind(C, name="qsort_float_noidx_big") + use iso_c_binding + integer(c_int64_t), value :: isize + real (c_float) :: A(isize) + end subroutine sort_noidx_big_c + + + + end interface + +end module qsort_module + + +subroutine i2sort(A, iorder, isize) + use qsort_module + use iso_c_binding + integer(c_int32_t) :: isize + integer(c_int32_t) :: iorder(isize) + integer (c_int16_t) :: A(isize) + call i2sort_c(A, iorder, isize) +end subroutine i2sort + +subroutine i2sort_noidx(A, isize) + use iso_c_binding + use qsort_module + integer(c_int32_t) :: isize + integer (c_int16_t) :: A(isize) + call i2sort_noidx_c(A, isize) +end subroutine i2sort_noidx + + + +subroutine i2sort_big(A, iorder, isize) + use qsort_module + use iso_c_binding + integer(c_int64_t) :: isize + integer(c_int64_t) :: iorder(isize) + integer (c_int16_t) :: A(isize) + call i2sort_big_c(A, iorder, isize) +end subroutine i2sort_big + +subroutine i2sort_noidx_big(A, isize) + use iso_c_binding + use qsort_module + integer(c_int64_t) :: isize + integer (c_int16_t) :: A(isize) + call i2sort_noidx_big_c(A, isize) +end subroutine i2sort_noidx_big + + + +subroutine isort(A, iorder, isize) + use qsort_module + use iso_c_binding + integer(c_int32_t) :: isize + integer(c_int32_t) :: iorder(isize) + integer (c_int32_t) :: A(isize) + call isort_c(A, iorder, isize) +end subroutine isort + +subroutine isort_noidx(A, isize) + use iso_c_binding + use qsort_module + integer(c_int32_t) :: isize + integer (c_int32_t) :: A(isize) + call isort_noidx_c(A, isize) +end subroutine isort_noidx + + + +subroutine isort_big(A, iorder, isize) + use qsort_module + use iso_c_binding + integer(c_int64_t) :: isize + integer(c_int64_t) :: iorder(isize) + integer (c_int32_t) :: A(isize) + call isort_big_c(A, iorder, isize) +end subroutine isort_big + +subroutine isort_noidx_big(A, isize) + use iso_c_binding + use qsort_module + integer(c_int64_t) :: isize + integer (c_int32_t) :: A(isize) + call isort_noidx_big_c(A, isize) +end subroutine isort_noidx_big + + + +subroutine i8sort(A, iorder, isize) + use qsort_module + use iso_c_binding + integer(c_int32_t) :: isize + integer(c_int32_t) :: iorder(isize) + integer (c_int64_t) :: A(isize) + call i8sort_c(A, iorder, isize) +end subroutine i8sort + +subroutine i8sort_noidx(A, isize) + use iso_c_binding + use qsort_module + integer(c_int32_t) :: isize + integer (c_int64_t) :: A(isize) + call i8sort_noidx_c(A, isize) +end subroutine i8sort_noidx + + + +subroutine i8sort_big(A, iorder, isize) + use qsort_module + use iso_c_binding + integer(c_int64_t) :: isize + integer(c_int64_t) :: iorder(isize) + integer (c_int64_t) :: A(isize) + call i8sort_big_c(A, iorder, isize) +end subroutine i8sort_big + +subroutine i8sort_noidx_big(A, isize) + use iso_c_binding + use qsort_module + integer(c_int64_t) :: isize + integer (c_int64_t) :: A(isize) + call i8sort_noidx_big_c(A, isize) +end subroutine i8sort_noidx_big + + + +subroutine dsort(A, iorder, isize) + use qsort_module + use iso_c_binding + integer(c_int32_t) :: isize + integer(c_int32_t) :: iorder(isize) + real (c_double) :: A(isize) + call dsort_c(A, iorder, isize) +end subroutine dsort + +subroutine dsort_noidx(A, isize) + use iso_c_binding + use qsort_module + integer(c_int32_t) :: isize + real (c_double) :: A(isize) + call dsort_noidx_c(A, isize) +end subroutine dsort_noidx + + + +subroutine dsort_big(A, iorder, isize) + use qsort_module + use iso_c_binding + integer(c_int64_t) :: isize + integer(c_int64_t) :: iorder(isize) + real (c_double) :: A(isize) + call dsort_big_c(A, iorder, isize) +end subroutine dsort_big + +subroutine dsort_noidx_big(A, isize) + use iso_c_binding + use qsort_module + integer(c_int64_t) :: isize + real (c_double) :: A(isize) + call dsort_noidx_big_c(A, isize) +end subroutine dsort_noidx_big + + + +subroutine sort(A, iorder, isize) + use qsort_module + use iso_c_binding + integer(c_int32_t) :: isize + integer(c_int32_t) :: iorder(isize) + real (c_float) :: A(isize) + call sort_c(A, iorder, isize) +end subroutine sort + +subroutine sort_noidx(A, isize) + use iso_c_binding + use qsort_module + integer(c_int32_t) :: isize + real (c_float) :: A(isize) + call sort_noidx_c(A, isize) +end subroutine sort_noidx + + + +subroutine sort_big(A, iorder, isize) + use qsort_module + use iso_c_binding + integer(c_int64_t) :: isize + integer(c_int64_t) :: iorder(isize) + real (c_float) :: A(isize) + call sort_big_c(A, iorder, isize) +end subroutine sort_big + +subroutine sort_noidx_big(A, isize) + use iso_c_binding + use qsort_module + integer(c_int64_t) :: isize + real (c_float) :: A(isize) + call sort_noidx_big_c(A, isize) +end subroutine sort_noidx_big diff --git a/src/utils/sort.irp.f b/src/utils/sort.irp.f index ff40263c..089c3871 100644 --- a/src/utils/sort.irp.f +++ b/src/utils/sort.irp.f @@ -1,222 +1,4 @@ BEGIN_TEMPLATE - subroutine insertion_$Xsort (x,iorder,isize) - implicit none - BEGIN_DOC - ! Sort array x(isize) using the insertion sort algorithm. - ! iorder in input should be (1,2,3,...,isize), and in output - ! contains the new order of the elements. - END_DOC - integer,intent(in) :: isize - $type,intent(inout) :: x(isize) - integer,intent(inout) :: iorder(isize) - $type :: xtmp - integer :: i, i0, j, jmax - - do i=2,isize - xtmp = x(i) - i0 = iorder(i) - j=i-1 - do while (j>0) - if ((x(j) <= xtmp)) exit - x(j+1) = x(j) - iorder(j+1) = iorder(j) - j=j-1 - enddo - x(j+1) = xtmp - iorder(j+1) = i0 - enddo - end subroutine insertion_$Xsort - - subroutine quick_$Xsort(x, iorder, isize) - implicit none - BEGIN_DOC - ! Sort array x(isize) using the quicksort algorithm. - ! iorder in input should be (1,2,3,...,isize), and in output - ! contains the new order of the elements. - END_DOC - integer,intent(in) :: isize - $type,intent(inout) :: x(isize) - integer,intent(inout) :: iorder(isize) - integer, external :: omp_get_num_threads - call rec_$X_quicksort(x,iorder,isize,1,isize,nproc) - end - - recursive subroutine rec_$X_quicksort(x, iorder, isize, first, last, level) - implicit none - integer, intent(in) :: isize, first, last, level - integer,intent(inout) :: iorder(isize) - $type, intent(inout) :: x(isize) - $type :: c, tmp - integer :: itmp - integer :: i, j - - if(isize<2)return - - c = x( shiftr(first+last,1) ) - i = first - j = last - do - do while (x(i) < c) - i=i+1 - end do - do while (c < x(j)) - j=j-1 - end do - if (i >= j) exit - tmp = x(i) - x(i) = x(j) - x(j) = tmp - itmp = iorder(i) - iorder(i) = iorder(j) - iorder(j) = itmp - i=i+1 - j=j-1 - enddo - if ( ((i-first <= 10000).and.(last-j <= 10000)).or.(level<=0) ) then - if (first < i-1) then - call rec_$X_quicksort(x, iorder, isize, first, i-1,level/2) - endif - if (j+1 < last) then - call rec_$X_quicksort(x, iorder, isize, j+1, last,level/2) - endif - else - if (first < i-1) then - call rec_$X_quicksort(x, iorder, isize, first, i-1,level/2) - endif - if (j+1 < last) then - call rec_$X_quicksort(x, iorder, isize, j+1, last,level/2) - endif - endif - end - - subroutine heap_$Xsort(x,iorder,isize) - implicit none - BEGIN_DOC - ! Sort array x(isize) using the heap sort algorithm. - ! iorder in input should be (1,2,3,...,isize), and in output - ! contains the new order of the elements. - END_DOC - integer,intent(in) :: isize - $type,intent(inout) :: x(isize) - integer,intent(inout) :: iorder(isize) - - integer :: i, k, j, l, i0 - $type :: xtemp - - l = isize/2+1 - k = isize - do while (.True.) - if (l>1) then - l=l-1 - xtemp = x(l) - i0 = iorder(l) - else - xtemp = x(k) - i0 = iorder(k) - x(k) = x(1) - iorder(k) = iorder(1) - k = k-1 - if (k == 1) then - x(1) = xtemp - iorder(1) = i0 - exit - endif - endif - i=l - j = shiftl(l,1) - do while (j1) then - l=l-1 - xtemp = x(l) - i0 = iorder(l) - else - xtemp = x(k) - i0 = iorder(k) - x(k) = x(1) - iorder(k) = iorder(1) - k = k-1 - if (k == 1) then - x(1) = xtemp - iorder(1) = i0 - exit - endif - endif - i=l - j = shiftl(l,1) - do while (j0_8) - if (x(j)<=xtmp) exit - x(j+1_8) = x(j) - iorder(j+1_8) = iorder(j) - j = j-1_8 - enddo - x(j+1_8) = xtmp - iorder(j+1_8) = i0 - enddo - - end subroutine insertion_$Xsort_big - subroutine $Xset_order_big(x,iorder,isize) implicit none BEGIN_DOC @@ -565,223 +90,3 @@ SUBST [ X, type ] END_TEMPLATE -BEGIN_TEMPLATE - -recursive subroutine $Xradix_sort$big(x,iorder,isize,iradix) - implicit none - - BEGIN_DOC - ! Sort integer array x(isize) using the radix sort algorithm. - ! iorder in input should be (1,2,3,...,isize), and in output - ! contains the new order of the elements. - ! iradix should be -1 in input. - END_DOC - integer*$int_type, intent(in) :: isize - integer*$int_type, intent(inout) :: iorder(isize) - integer*$type, intent(inout) :: x(isize) - integer, intent(in) :: iradix - integer :: iradix_new - integer*$type, allocatable :: x2(:), x1(:) - integer*$type :: i4 ! data type - integer*$int_type, allocatable :: iorder1(:),iorder2(:) - integer*$int_type :: i0, i1, i2, i3, i ! index type - integer*$type :: mask - integer :: err - !DIR$ ATTRIBUTES ALIGN : 128 :: iorder1,iorder2, x2, x1 - - if (isize < 2) then - return - endif - - if (iradix == -1) then ! Sort Positive and negative - - allocate(x1(isize),iorder1(isize), x2(isize),iorder2(isize),stat=err) - if (err /= 0) then - print *, irp_here, ': Unable to allocate arrays' - stop - endif - - i1=1_$int_type - i2=1_$int_type - do i=1_$int_type,isize - if (x(i) < 0_$type) then - iorder1(i1) = iorder(i) - x1(i1) = -x(i) - i1 = i1+1_$int_type - else - iorder2(i2) = iorder(i) - x2(i2) = x(i) - i2 = i2+1_$int_type - endif - enddo - i1=i1-1_$int_type - i2=i2-1_$int_type - - do i=1_$int_type,i2 - iorder(i1+i) = iorder2(i) - x(i1+i) = x2(i) - enddo - deallocate(x2,iorder2,stat=err) - if (err /= 0) then - print *, irp_here, ': Unable to deallocate arrays x2, iorder2' - stop - endif - - - if (i1 > 1_$int_type) then - call $Xradix_sort$big(x1,iorder1,i1,-2) - do i=1_$int_type,i1 - x(i) = -x1(1_$int_type+i1-i) - iorder(i) = iorder1(1_$int_type+i1-i) - enddo - endif - - if (i2>1_$int_type) then - call $Xradix_sort$big(x(i1+1_$int_type),iorder(i1+1_$int_type),i2,-2) - endif - - deallocate(x1,iorder1,stat=err) - if (err /= 0) then - print *, irp_here, ': Unable to deallocate arrays x1, iorder1' - stop - endif - return - - else if (iradix == -2) then ! Positive - - ! Find most significant bit - - i0 = 0_$int_type - i4 = maxval(x) - - iradix_new = max($integer_size-1-leadz(i4),1) - mask = ibset(0_$type,iradix_new) - - allocate(x1(isize),iorder1(isize), x2(isize),iorder2(isize),stat=err) - if (err /= 0) then - print *, irp_here, ': Unable to allocate arrays' - stop - endif - - i1=1_$int_type - i2=1_$int_type - - do i=1_$int_type,isize - if (iand(mask,x(i)) == 0_$type) then - iorder1(i1) = iorder(i) - x1(i1) = x(i) - i1 = i1+1_$int_type - else - iorder2(i2) = iorder(i) - x2(i2) = x(i) - i2 = i2+1_$int_type - endif - enddo - i1=i1-1_$int_type - i2=i2-1_$int_type - - do i=1_$int_type,i1 - iorder(i0+i) = iorder1(i) - x(i0+i) = x1(i) - enddo - i0 = i0+i1 - i3 = i0 - deallocate(x1,iorder1,stat=err) - if (err /= 0) then - print *, irp_here, ': Unable to deallocate arrays x1, iorder1' - stop - endif - - - do i=1_$int_type,i2 - iorder(i0+i) = iorder2(i) - x(i0+i) = x2(i) - enddo - i0 = i0+i2 - deallocate(x2,iorder2,stat=err) - if (err /= 0) then - print *, irp_here, ': Unable to deallocate arrays x2, iorder2' - stop - endif - - - if (i3>1_$int_type) then - call $Xradix_sort$big(x,iorder,i3,iradix_new-1) - endif - - if (isize-i3>1_$int_type) then - call $Xradix_sort$big(x(i3+1_$int_type),iorder(i3+1_$int_type),isize-i3,iradix_new-1) - endif - - return - endif - - ASSERT (iradix >= 0) - - if (isize < 48) then - call insertion_$Xsort$big(x,iorder,isize) - return - endif - - - allocate(x2(isize),iorder2(isize),stat=err) - if (err /= 0) then - print *, irp_here, ': Unable to allocate arrays x1, iorder1' - stop - endif - - - mask = ibset(0_$type,iradix) - i0=1_$int_type - i1=1_$int_type - - do i=1_$int_type,isize - if (iand(mask,x(i)) == 0_$type) then - iorder(i0) = iorder(i) - x(i0) = x(i) - i0 = i0+1_$int_type - else - iorder2(i1) = iorder(i) - x2(i1) = x(i) - i1 = i1+1_$int_type - endif - enddo - i0=i0-1_$int_type - i1=i1-1_$int_type - - do i=1_$int_type,i1 - iorder(i0+i) = iorder2(i) - x(i0+i) = x2(i) - enddo - - deallocate(x2,iorder2,stat=err) - if (err /= 0) then - print *, irp_here, ': Unable to allocate arrays x2, iorder2' - stop - endif - - - if (iradix == 0) then - return - endif - - - if (i1>1_$int_type) then - call $Xradix_sort$big(x(i0+1_$int_type),iorder(i0+1_$int_type),i1,iradix-1) - endif - if (i0>1) then - call $Xradix_sort$big(x,iorder,i0,iradix-1) - endif - - end - -SUBST [ X, type, integer_size, is_big, big, int_type ] - i ; 4 ; 32 ; .False. ; ; 4 ;; - i8 ; 8 ; 64 ; .False. ; ; 4 ;; - i2 ; 2 ; 16 ; .False. ; ; 4 ;; - i ; 4 ; 32 ; .True. ; _big ; 8 ;; - i8 ; 8 ; 64 ; .True. ; _big ; 8 ;; -END_TEMPLATE - - - From f168b885db26c1121486c5f4d219968f4474e0c1 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sun, 1 May 2022 14:32:30 +0200 Subject: [PATCH 07/80] Removed IPP dependency with intel using C quicksort --- config/ifort_2019_avx.cfg | 2 +- config/ifort_2019_avx_mpi.cfg | 2 +- config/ifort_2019_mpi_rome.cfg | 2 +- config/ifort_2019_rome.cfg | 2 +- config/ifort_2019_sse4.cfg | 2 +- config/ifort_2019_sse4_mpi.cfg | 2 +- config/ifort_2019_xHost.cfg | 2 +- config/ifort_2021_avx.cfg | 2 +- config/ifort_2021_avx_mpi.cfg | 2 +- config/ifort_2021_mpi_rome.cfg | 2 +- config/ifort_2021_rome.cfg | 2 +- config/ifort_2021_sse4.cfg | 2 +- config/ifort_2021_sse4_mpi.cfg | 2 +- config/ifort_2021_xHost.cfg | 2 +- src/fci/40.fci.bats | 2 +- src/utils/qsort.c | 100 ++++++++++++++++----------------- src/utils/qsort.org | 10 ++-- 17 files changed, 70 insertions(+), 70 deletions(-) diff --git a/config/ifort_2019_avx.cfg b/config/ifort_2019_avx.cfg index 661a0e8f..c5bed0d8 100644 --- a/config/ifort_2019_avx.cfg +++ b/config/ifort_2019_avx.cfg @@ -7,7 +7,7 @@ # [COMMON] FC : ifort -fpic -LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps +LAPACK_LIB : -mkl=parallel IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 -DINTEL -DSET_NESTED diff --git a/config/ifort_2019_avx_mpi.cfg b/config/ifort_2019_avx_mpi.cfg index 2d212db5..5b4d2922 100644 --- a/config/ifort_2019_avx_mpi.cfg +++ b/config/ifort_2019_avx_mpi.cfg @@ -7,7 +7,7 @@ # [COMMON] FC : mpiifort -fpic -LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps +LAPACK_LIB : -mkl=parallel IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 -DMPI -DINTEL -DSET_NESTED diff --git a/config/ifort_2019_mpi_rome.cfg b/config/ifort_2019_mpi_rome.cfg index 171219e6..054d4d7d 100644 --- a/config/ifort_2019_mpi_rome.cfg +++ b/config/ifort_2019_mpi_rome.cfg @@ -7,7 +7,7 @@ # [COMMON] FC : mpiifort -fpic -LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps +LAPACK_LIB : -mkl=parallel IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 -DINTEL -DSET_NESTED diff --git a/config/ifort_2019_rome.cfg b/config/ifort_2019_rome.cfg index e923a1dd..a18a0acb 100644 --- a/config/ifort_2019_rome.cfg +++ b/config/ifort_2019_rome.cfg @@ -7,7 +7,7 @@ # [COMMON] FC : ifort -fpic -LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps +LAPACK_LIB : -mkl=parallel IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 -DINTEL -DSET_NESTED diff --git a/config/ifort_2019_sse4.cfg b/config/ifort_2019_sse4.cfg index a3aa7cbd..2cdbc2c5 100644 --- a/config/ifort_2019_sse4.cfg +++ b/config/ifort_2019_sse4.cfg @@ -7,7 +7,7 @@ # [COMMON] FC : ifort -fpic -LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps +LAPACK_LIB : -mkl=parallel IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 -DINTEL -DSET_NESTED diff --git a/config/ifort_2019_sse4_mpi.cfg b/config/ifort_2019_sse4_mpi.cfg index 6959d176..d20cd2a2 100644 --- a/config/ifort_2019_sse4_mpi.cfg +++ b/config/ifort_2019_sse4_mpi.cfg @@ -7,7 +7,7 @@ # [COMMON] FC : mpiifort -fpic -LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps +LAPACK_LIB : -mkl=parallel IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 -DMPI -DINTEL -DSET_NESTED diff --git a/config/ifort_2019_xHost.cfg b/config/ifort_2019_xHost.cfg index 22d28803..59c6146b 100644 --- a/config/ifort_2019_xHost.cfg +++ b/config/ifort_2019_xHost.cfg @@ -7,7 +7,7 @@ # [COMMON] FC : ifort -fpic -LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps +LAPACK_LIB : -mkl=parallel IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=64 -DINTEL -DSET_NESTED diff --git a/config/ifort_2021_avx.cfg b/config/ifort_2021_avx.cfg index 6f657052..6c34cf47 100644 --- a/config/ifort_2021_avx.cfg +++ b/config/ifort_2021_avx.cfg @@ -7,7 +7,7 @@ # [COMMON] FC : ifort -fpic -LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps +LAPACK_LIB : -mkl=parallel IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 -DINTEL diff --git a/config/ifort_2021_avx_mpi.cfg b/config/ifort_2021_avx_mpi.cfg index c991a4a9..4c893c73 100644 --- a/config/ifort_2021_avx_mpi.cfg +++ b/config/ifort_2021_avx_mpi.cfg @@ -7,7 +7,7 @@ # [COMMON] FC : mpiifort -fpic -LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps +LAPACK_LIB : -mkl=parallel IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 -DMPI -DINTEL diff --git a/config/ifort_2021_mpi_rome.cfg b/config/ifort_2021_mpi_rome.cfg index 8413d23d..e47a466e 100644 --- a/config/ifort_2021_mpi_rome.cfg +++ b/config/ifort_2021_mpi_rome.cfg @@ -7,7 +7,7 @@ # [COMMON] FC : mpiifort -fpic -LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps +LAPACK_LIB : -mkl=parallel IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 -DINTEL diff --git a/config/ifort_2021_rome.cfg b/config/ifort_2021_rome.cfg index b3023186..504438c9 100644 --- a/config/ifort_2021_rome.cfg +++ b/config/ifort_2021_rome.cfg @@ -7,7 +7,7 @@ # [COMMON] FC : ifort -fpic -LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps +LAPACK_LIB : -mkl=parallel IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 -DINTEL diff --git a/config/ifort_2021_sse4.cfg b/config/ifort_2021_sse4.cfg index a6299665..07c3ebb8 100644 --- a/config/ifort_2021_sse4.cfg +++ b/config/ifort_2021_sse4.cfg @@ -7,7 +7,7 @@ # [COMMON] FC : ifort -fpic -LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps +LAPACK_LIB : -mkl=parallel IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 -DINTEL diff --git a/config/ifort_2021_sse4_mpi.cfg b/config/ifort_2021_sse4_mpi.cfg index 6ae56d2a..f3fa0eaa 100644 --- a/config/ifort_2021_sse4_mpi.cfg +++ b/config/ifort_2021_sse4_mpi.cfg @@ -7,7 +7,7 @@ # [COMMON] FC : mpiifort -fpic -LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps +LAPACK_LIB : -mkl=parallel IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 -DMPI -DINTEL diff --git a/config/ifort_2021_xHost.cfg b/config/ifort_2021_xHost.cfg index 1e76a69d..1161833b 100644 --- a/config/ifort_2021_xHost.cfg +++ b/config/ifort_2021_xHost.cfg @@ -7,7 +7,7 @@ # [COMMON] FC : ifort -fpic -LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps +LAPACK_LIB : -mkl=parallel IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=64 -DINTEL diff --git a/src/fci/40.fci.bats b/src/fci/40.fci.bats index 1a0c5507..23818f44 100644 --- a/src/fci/40.fci.bats +++ b/src/fci/40.fci.bats @@ -65,7 +65,7 @@ function run_stoch() { @test "H2O2" { # 12.9214s qp set_file h2o2.ezfio qp set_mo_class --core="[1-2]" --act="[3-24]" --del="[25-38]" - run -151.005848404095 1.e-3 100000 + run -151.005848404095 2.e-3 100000 } @test "HBO" { # 13.3144s diff --git a/src/utils/qsort.c b/src/utils/qsort.c index 5d685741..c011b35a 100644 --- a/src/utils/qsort.c +++ b/src/utils/qsort.c @@ -9,14 +9,14 @@ struct int16_t_comp { int compare_int16_t( const void * l, const void * r ) { - const struct int16_t_comp * restrict _l= l; - const struct int16_t_comp * restrict _r= r; - if( _l->x > _r->x ) return 1; - if( _l->x < _r->x ) return -1; + const int16_t * restrict _l= l; + const int16_t * restrict _r= r; + if( *_l > *_r ) return 1; + if( *_l < *_r ) return -1; return 0; } -void qsort_int16_t(int16_t* A_in, int32_t* iorder, int32_t isize) { +void qsort_int16_t(int16_t* restrict A_in, int32_t* restrict iorder, int32_t isize) { struct int16_t_comp* A = malloc(isize * sizeof(struct int16_t_comp)); if (A == NULL) return; @@ -46,14 +46,14 @@ struct int16_t_comp_big { int compare_int16_t_big( const void * l, const void * r ) { - const struct int16_t_comp_big * restrict _l= l; - const struct int16_t_comp_big * restrict _r= r; - if( _l->x > _r->x ) return 1; - if( _l->x < _r->x ) return -1; + const int16_t * restrict _l= l; + const int16_t * restrict _r= r; + if( *_l > *_r ) return 1; + if( *_l < *_r ) return -1; return 0; } -void qsort_int16_t_big(int16_t* A_in, int64_t* iorder, int64_t isize) { +void qsort_int16_t_big(int16_t* restrict A_in, int64_t* restrict iorder, int64_t isize) { struct int16_t_comp_big* A = malloc(isize * sizeof(struct int16_t_comp_big)); if (A == NULL) return; @@ -83,14 +83,14 @@ struct int32_t_comp { int compare_int32_t( const void * l, const void * r ) { - const struct int32_t_comp * restrict _l= l; - const struct int32_t_comp * restrict _r= r; - if( _l->x > _r->x ) return 1; - if( _l->x < _r->x ) return -1; + const int32_t * restrict _l= l; + const int32_t * restrict _r= r; + if( *_l > *_r ) return 1; + if( *_l < *_r ) return -1; return 0; } -void qsort_int32_t(int32_t* A_in, int32_t* iorder, int32_t isize) { +void qsort_int32_t(int32_t* restrict A_in, int32_t* restrict iorder, int32_t isize) { struct int32_t_comp* A = malloc(isize * sizeof(struct int32_t_comp)); if (A == NULL) return; @@ -120,14 +120,14 @@ struct int32_t_comp_big { int compare_int32_t_big( const void * l, const void * r ) { - const struct int32_t_comp_big * restrict _l= l; - const struct int32_t_comp_big * restrict _r= r; - if( _l->x > _r->x ) return 1; - if( _l->x < _r->x ) return -1; + const int32_t * restrict _l= l; + const int32_t * restrict _r= r; + if( *_l > *_r ) return 1; + if( *_l < *_r ) return -1; return 0; } -void qsort_int32_t_big(int32_t* A_in, int64_t* iorder, int64_t isize) { +void qsort_int32_t_big(int32_t* restrict A_in, int64_t* restrict iorder, int64_t isize) { struct int32_t_comp_big* A = malloc(isize * sizeof(struct int32_t_comp_big)); if (A == NULL) return; @@ -157,14 +157,14 @@ struct int64_t_comp { int compare_int64_t( const void * l, const void * r ) { - const struct int64_t_comp * restrict _l= l; - const struct int64_t_comp * restrict _r= r; - if( _l->x > _r->x ) return 1; - if( _l->x < _r->x ) return -1; + const int64_t * restrict _l= l; + const int64_t * restrict _r= r; + if( *_l > *_r ) return 1; + if( *_l < *_r ) return -1; return 0; } -void qsort_int64_t(int64_t* A_in, int32_t* iorder, int32_t isize) { +void qsort_int64_t(int64_t* restrict A_in, int32_t* restrict iorder, int32_t isize) { struct int64_t_comp* A = malloc(isize * sizeof(struct int64_t_comp)); if (A == NULL) return; @@ -194,14 +194,14 @@ struct int64_t_comp_big { int compare_int64_t_big( const void * l, const void * r ) { - const struct int64_t_comp_big * restrict _l= l; - const struct int64_t_comp_big * restrict _r= r; - if( _l->x > _r->x ) return 1; - if( _l->x < _r->x ) return -1; + const int64_t * restrict _l= l; + const int64_t * restrict _r= r; + if( *_l > *_r ) return 1; + if( *_l < *_r ) return -1; return 0; } -void qsort_int64_t_big(int64_t* A_in, int64_t* iorder, int64_t isize) { +void qsort_int64_t_big(int64_t* restrict A_in, int64_t* restrict iorder, int64_t isize) { struct int64_t_comp_big* A = malloc(isize * sizeof(struct int64_t_comp_big)); if (A == NULL) return; @@ -231,14 +231,14 @@ struct double_comp { int compare_double( const void * l, const void * r ) { - const struct double_comp * restrict _l= l; - const struct double_comp * restrict _r= r; - if( _l->x > _r->x ) return 1; - if( _l->x < _r->x ) return -1; + const double * restrict _l= l; + const double * restrict _r= r; + if( *_l > *_r ) return 1; + if( *_l < *_r ) return -1; return 0; } -void qsort_double(double* A_in, int32_t* iorder, int32_t isize) { +void qsort_double(double* restrict A_in, int32_t* restrict iorder, int32_t isize) { struct double_comp* A = malloc(isize * sizeof(struct double_comp)); if (A == NULL) return; @@ -268,14 +268,14 @@ struct double_comp_big { int compare_double_big( const void * l, const void * r ) { - const struct double_comp_big * restrict _l= l; - const struct double_comp_big * restrict _r= r; - if( _l->x > _r->x ) return 1; - if( _l->x < _r->x ) return -1; + const double * restrict _l= l; + const double * restrict _r= r; + if( *_l > *_r ) return 1; + if( *_l < *_r ) return -1; return 0; } -void qsort_double_big(double* A_in, int64_t* iorder, int64_t isize) { +void qsort_double_big(double* restrict A_in, int64_t* restrict iorder, int64_t isize) { struct double_comp_big* A = malloc(isize * sizeof(struct double_comp_big)); if (A == NULL) return; @@ -305,14 +305,14 @@ struct float_comp { int compare_float( const void * l, const void * r ) { - const struct float_comp * restrict _l= l; - const struct float_comp * restrict _r= r; - if( _l->x > _r->x ) return 1; - if( _l->x < _r->x ) return -1; + const float * restrict _l= l; + const float * restrict _r= r; + if( *_l > *_r ) return 1; + if( *_l < *_r ) return -1; return 0; } -void qsort_float(float* A_in, int32_t* iorder, int32_t isize) { +void qsort_float(float* restrict A_in, int32_t* restrict iorder, int32_t isize) { struct float_comp* A = malloc(isize * sizeof(struct float_comp)); if (A == NULL) return; @@ -342,14 +342,14 @@ struct float_comp_big { int compare_float_big( const void * l, const void * r ) { - const struct float_comp_big * restrict _l= l; - const struct float_comp_big * restrict _r= r; - if( _l->x > _r->x ) return 1; - if( _l->x < _r->x ) return -1; + const float * restrict _l= l; + const float * restrict _r= r; + if( *_l > *_r ) return 1; + if( *_l < *_r ) return -1; return 0; } -void qsort_float_big(float* A_in, int64_t* iorder, int64_t isize) { +void qsort_float_big(float* restrict A_in, int64_t* restrict iorder, int64_t isize) { struct float_comp_big* A = malloc(isize * sizeof(struct float_comp_big)); if (A == NULL) return; diff --git a/src/utils/qsort.org b/src/utils/qsort.org index 0c344207..abf0d54a 100644 --- a/src/utils/qsort.org +++ b/src/utils/qsort.org @@ -11,14 +11,14 @@ struct TYPE_comp_big { int compare_TYPE_big( const void * l, const void * r ) { - const struct TYPE_comp_big * restrict _l= l; - const struct TYPE_comp_big * restrict _r= r; - if( _l->x > _r->x ) return 1; - if( _l->x < _r->x ) return -1; + const TYPE * restrict _l= l; + const TYPE * restrict _r= r; + if( *_l > *_r ) return 1; + if( *_l < *_r ) return -1; return 0; } -void qsort_TYPE_big(TYPE* A_in, int32_t* iorder, int32_t isize) { +void qsort_TYPE_big(TYPE* restrict A_in, int32_t* restrict iorder, int32_t isize) { struct TYPE_comp_big* A = malloc(isize * sizeof(struct TYPE_comp_big)); if (A == NULL) return; From be6c230f52641631f26ad15f6793efb8feaaab89 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sun, 1 May 2022 15:01:37 +0200 Subject: [PATCH 08/80] Accelerated PT2 by removing sort --- src/cipsi/selection.irp.f | 2 -- src/fci/40.fci.bats | 2 +- src/mo_two_e_erf_ints/map_integrals_erf.irp.f | 12 ++++++------ 3 files changed, 7 insertions(+), 9 deletions(-) diff --git a/src/cipsi/selection.irp.f b/src/cipsi/selection.irp.f index 7417dd05..ec60c606 100644 --- a/src/cipsi/selection.irp.f +++ b/src/cipsi/selection.irp.f @@ -258,8 +258,6 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d deallocate(exc_degree) nmax=k-1 - call isort_noidx(indices,nmax) - ! Start with 32 elements. Size will double along with the filtering. allocate(preinteresting(0:32), prefullinteresting(0:32), & interesting(0:32), fullinteresting(0:32)) diff --git a/src/fci/40.fci.bats b/src/fci/40.fci.bats index 23818f44..89c65c94 100644 --- a/src/fci/40.fci.bats +++ b/src/fci/40.fci.bats @@ -77,7 +77,7 @@ function run_stoch() { @test "H2O" { # 11.3727s [[ -n $TRAVIS ]] && skip qp set_file h2o.ezfio - run -76.2361605151999 5.e-4 100000 + run -76.2361605151999 2.e-3 100000 } @test "ClO" { # 13.3755s diff --git a/src/mo_two_e_erf_ints/map_integrals_erf.irp.f b/src/mo_two_e_erf_ints/map_integrals_erf.irp.f index 73050ec5..3405ec2b 100644 --- a/src/mo_two_e_erf_ints/map_integrals_erf.irp.f +++ b/src/mo_two_e_erf_ints/map_integrals_erf.irp.f @@ -235,11 +235,11 @@ subroutine get_mo_two_e_integrals_erf_ij(k,l,sze,out_array,map) logical :: integral_is_in_map if (key_kind == 8) then - call i8radix_sort(hash,iorder,kk,-1) + call i8sort(hash,iorder,kk) else if (key_kind == 4) then - call iradix_sort(hash,iorder,kk,-1) + call isort(hash,iorder,kk) else if (key_kind == 2) then - call i2radix_sort(hash,iorder,kk,-1) + call i2sort(hash,iorder,kk) endif call map_get_many(mo_integrals_erf_map, hash, tmp_val, kk) @@ -290,11 +290,11 @@ subroutine get_mo_two_e_integrals_erf_i1j1(k,l,sze,out_array,map) logical :: integral_is_in_map if (key_kind == 8) then - call i8radix_sort(hash,iorder,kk,-1) + call i8sort(hash,iorder,kk) else if (key_kind == 4) then - call iradix_sort(hash,iorder,kk,-1) + call isort(hash,iorder,kk) else if (key_kind == 2) then - call i2radix_sort(hash,iorder,kk,-1) + call i2sort(hash,iorder,kk) endif call map_get_many(mo_integrals_erf_map, hash, tmp_val, kk) From abac06299cd965d304b1aad4b4fc4b8de4f7d136 Mon Sep 17 00:00:00 2001 From: ydamour Date: Thu, 5 May 2022 16:22:44 +0200 Subject: [PATCH 09/80] update i_H_j --- src/determinants/slater_rules.irp.f | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/src/determinants/slater_rules.irp.f b/src/determinants/slater_rules.irp.f index 3a33a37d..897607a9 100644 --- a/src/determinants/slater_rules.irp.f +++ b/src/determinants/slater_rules.irp.f @@ -623,7 +623,8 @@ subroutine i_H_j(key_i,key_j,Nint,hij) integer :: occ(Nint*bit_kind_size,2) double precision :: diag_H_mat_elem, phase integer :: n_occ_ab(2) - PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals + PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals + PROVIDE ao_one_e_integrals mo_one_e_integrals ASSERT (Nint > 0) ASSERT (Nint == N_int) @@ -681,7 +682,6 @@ subroutine i_H_j(key_i,key_j,Nint,hij) case (1) call get_single_excitation(key_i,key_j,exc,phase,Nint) !DIR$ FORCEINLINE - call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) if (exc(0,1,1) == 1) then ! Single alpha m = exc(1,1,1) @@ -700,10 +700,6 @@ subroutine i_H_j(key_i,key_j,Nint,hij) end select end - - - - subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble,phase) use bitmasks implicit none @@ -1038,7 +1034,6 @@ subroutine i_H_psi(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array) end - subroutine i_H_psi_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array) use bitmasks implicit none From 57527c94a27491107e49d9623c0124c516976d34 Mon Sep 17 00:00:00 2001 From: ydamour Date: Thu, 5 May 2022 17:26:41 +0200 Subject: [PATCH 10/80] update binom_func to avoid .999... --- src/utils/util.irp.f | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/utils/util.irp.f b/src/utils/util.irp.f index ef846bdb..127d5433 100644 --- a/src/utils/util.irp.f +++ b/src/utils/util.irp.f @@ -37,6 +37,10 @@ double precision function binom_func(i,j) else binom_func = dexp( logfact(i)-logfact(j)-logfact(i-j) ) endif + + ! To avoid .999999 numbers + binom_func = binom_func + 0.5d0 + end From e15dceaa10c0abbfdda434b89429c6be87214815 Mon Sep 17 00:00:00 2001 From: ydamour Date: Wed, 11 May 2022 12:59:58 +0200 Subject: [PATCH 11/80] new format for pt2 --- src/cipsi/pt2_stoch_routines.irp.f | 88 ++++++++++++++++++++++++++---- src/utils/format_w_error.irp.f | 71 ++++++++++++++++++++++++ 2 files changed, 147 insertions(+), 12 deletions(-) create mode 100644 src/utils/format_w_error.irp.f diff --git a/src/cipsi/pt2_stoch_routines.irp.f b/src/cipsi/pt2_stoch_routines.irp.f index c7cee1ac..1328e7a0 100644 --- a/src/cipsi/pt2_stoch_routines.irp.f +++ b/src/cipsi/pt2_stoch_routines.irp.f @@ -290,9 +290,13 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in) call set_multiple_levels_omp(.False.) - print '(A)', '========== ======================= ===================== ===================== ===========' - print '(A)', ' Samples Energy Variance Norm^2 Seconds' - print '(A)', '========== ======================= ===================== ===================== ===========' + ! old + !print '(A)', '========== ======================= ===================== ===================== ===========' + !print '(A)', ' Samples Energy Variance Norm^2 Seconds' + !print '(A)', '========== ======================= ===================== ===================== ===========' + print '(A)', '========== ==================== ================ ================ ================ ============= ===========' + print '(A)', ' Samples Energy PT2 Variance Norm^2 Convergence Seconds' + print '(A)', '========== ==================== ================ ================ ================ ============= ===========' PROVIDE global_selection_buffer @@ -316,7 +320,10 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in) call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2') call set_multiple_levels_omp(.True.) - print '(A)', '========== ======================= ===================== ===================== ===========' + ! old + !print '(A)', '========== ======================= ===================== ===================== ===========' + print '(A)', '========== ==================== ================ ================ ================ ============= ===========' + do k=1,N_states pt2_overlap(pt2_stoch_istate,k) = pt2_data % overlap(k,pt2_stoch_istate) @@ -414,6 +421,17 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_ double precision :: rss double precision, external :: memory_of_double, memory_of_int + character(len=20) :: format_str1, str_error1, format_str2, str_error2 + character(len=20) :: format_str3, str_error3, format_str4, str_error4 + character(len=20) :: format_value1, format_value2, format_value3, format_value4 + character(len=20) :: str_value1, str_value2, str_value3, str_value4 + character(len=20) :: str_conv + double precision :: value1, value2, value3, value4 + double precision :: error1, error2, error3, error4 + integer :: size1,size2,size3,size4 + + double precision :: conv_crit + sending =.False. rss = memory_of_int(pt2_n_tasks_max*2+N_det_generators*2) @@ -537,14 +555,60 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_ if ((time - time1 > 1.d0) .or. (n==N_det_generators)) then time1 = time - print '(I10, X, F12.6, X, G10.3, X, F10.6, X, G10.3, X, F10.6, X, G10.3, X, F10.1)', c, & - pt2_data % pt2(pt2_stoch_istate) +E, & - pt2_data_err % pt2(pt2_stoch_istate), & - pt2_data % variance(pt2_stoch_istate), & - pt2_data_err % variance(pt2_stoch_istate), & - pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate), & - pt2_data_err % overlap(pt2_stoch_istate,pt2_stoch_istate), & - time-time0 + + value1 = pt2_data % pt2(pt2_stoch_istate) + E + error1 = pt2_data_err % pt2(pt2_stoch_istate) + value2 = pt2_data % pt2(pt2_stoch_istate) + error2 = pt2_data_err % pt2(pt2_stoch_istate) + value3 = pt2_data % variance(pt2_stoch_istate) + error3 = pt2_data_err % variance(pt2_stoch_istate) + value4 = pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate) + error4 = pt2_data_err % overlap(pt2_stoch_istate,pt2_stoch_istate) + + ! Max size of the values (FX.Y) with X=size + size1 = 15 + size2 = 12 + size3 = 12 + size4 = 12 + + ! To generate the format: number(error) + call format_w_error(value1,error1,size1,8,format_value1,str_error1) + call format_w_error(value2,error2,size2,8,format_value2,str_error2) + call format_w_error(value3,error3,size3,8,format_value3,str_error3) + call format_w_error(value4,error4,size4,8,format_value4,str_error4) + + ! value > string with the right format + write(str_value1,'('//format_value1//')') value1 + write(str_value2,'('//format_value2//')') value2 + write(str_value3,'('//format_value3//')') value3 + write(str_value4,'('//format_value4//')') value4 + + ! Convergence criterion + conv_crit = dabs(pt2_data_err % pt2(pt2_stoch_istate)) / & + (1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) ) + write(str_conv,'(G10.3)') conv_crit + + write(*,'(I10,X,X,A20,X,A16,X,A16,X,A16,X,A12,X,F10.1)') c,& + adjustl(adjustr(str_value1)//'('//str_error1(1:1)//')'),& + adjustl(adjustr(str_value2)//'('//str_error2(1:1)//')'),& + adjustl(adjustr(str_value3)//'('//str_error3(1:1)//')'),& + adjustl(adjustr(str_value4)//'('//str_error4(1:1)//')'),& + adjustl(str_conv),& + time-time0 + + ! Old print + !print '(I10, X, F12.6, X, G10.3, X, F10.6, X, G10.3, X, F10.6, X, G10.3, X, F10.1,1pE16.6,1pE16.6)', c, & + ! pt2_data % pt2(pt2_stoch_istate) +E, & + ! pt2_data_err % pt2(pt2_stoch_istate), & + ! pt2_data % variance(pt2_stoch_istate), & + ! pt2_data_err % variance(pt2_stoch_istate), & + ! pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate), & + ! pt2_data_err % overlap(pt2_stoch_istate,pt2_stoch_istate), & + ! time-time0, & + ! pt2_data % pt2(pt2_stoch_istate), & + ! dabs(pt2_data_err % pt2(pt2_stoch_istate)) / & + ! (1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) ) + if (stop_now .or. ( & (do_exit .and. (dabs(pt2_data_err % pt2(pt2_stoch_istate)) / & (1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) ) <= relative_error))) ) then diff --git a/src/utils/format_w_error.irp.f b/src/utils/format_w_error.irp.f new file mode 100644 index 00000000..1378d367 --- /dev/null +++ b/src/utils/format_w_error.irp.f @@ -0,0 +1,71 @@ +subroutine format_w_error(value,error,size_nb,max_nb_digits,format_value,str_error) + + implicit none + + BEGIN_DOC + ! Format for double precision, value(error) + END_DOC + + ! in + ! | value | double precision | value... | + ! | error | double precision | error... | + ! | size_nb | integer | X in FX.Y | + ! | max_nb_digits | integer | Max Y in FX.Y | + + ! out + ! | format_value | character | string FX.Y for the format | + ! | str_error | character | string of the error | + + ! internal + ! | str_size | character | size in string format | + ! | nb_digits | integer | number of digits Y in FX.Y depending of the error | + ! | str_nb_digits | character | nb_digits in string format | + ! | str_exp | character | string of the value in exponential format | + + ! in + double precision, intent(in) :: error, value + integer, intent(in) :: size_nb, max_nb_digits + + ! out + character(len=20), intent(out) :: str_error, format_value + + ! internal + character(len=20) :: str_size, str_nb_digits, str_exp + integer :: nb_digits + + ! max_nb_digit: Y max + ! size_nb = Size of the double: X (FX.Y) + write(str_size,'(I3)') size_nb + + ! Error + write(str_exp,'(1pE20.0)') error + str_error = trim(adjustl(str_exp)) + + ! Number of digit: Y (FX.Y) from the exponent + str_nb_digits = str_exp(19:20) + read(str_nb_digits,*) nb_digits + + ! If the error is 0d0 + if (error <= 1d-16) then + write(str_nb_digits,*) max_nb_digits + endif + + ! If the error is too small + if (nb_digits > max_nb_digits) then + write(str_nb_digits,*) max_nb_digits + str_error(1:1) = '0' + endif + + ! If the error is too big (>= 0.5) + if (error >= 0.5d0) then + str_nb_digits = '1' + str_error(1:1) = '*' + endif + + ! FX.Y,A1,A1,A1 for value(str_error) + !string = 'F'//trim(adjustl(str_size))//'.'//trim(adjustl(str_nb_digits))//',A1,A1,A1' + + ! FX.Y just for the value + format_value = 'F'//trim(adjustl(str_size))//'.'//trim(adjustl(str_nb_digits)) + +end From 7df328724152480842fde2a183b08cb0a81c116b Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 12 May 2022 10:12:36 +0200 Subject: [PATCH 12/80] Fix bug introduced by 57527c94a27491107e --- src/utils/util.irp.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/utils/util.irp.f b/src/utils/util.irp.f index 127d5433..84593031 100644 --- a/src/utils/util.irp.f +++ b/src/utils/util.irp.f @@ -39,7 +39,7 @@ double precision function binom_func(i,j) endif ! To avoid .999999 numbers - binom_func = binom_func + 0.5d0 + binom_func = floor(binom_func + 0.5d0) end From 185f3a500ca8d3bdb49d59902266caa2910190af Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 12 May 2022 11:48:40 +0200 Subject: [PATCH 13/80] Fixed tests for Drone CI --- src/fci/40.fci.bats | 105 ++++++++++++----------- src/fci/EZFIO.cfg | 6 ++ src/iterations/print_extrapolation.irp.f | 1 + 3 files changed, 60 insertions(+), 52 deletions(-) diff --git a/src/fci/40.fci.bats b/src/fci/40.fci.bats index 89c65c94..9b99d865 100644 --- a/src/fci/40.fci.bats +++ b/src/fci/40.fci.bats @@ -8,12 +8,12 @@ function run() { test_exe fci || skip qp edit --check qp set perturbation do_pt2 False - qp set determinants n_det_max 8000 + qp set determinants n_det_max $3 qp set determinants n_states 1 qp set davidson threshold_davidson 1.e-10 qp set davidson n_states_diag 8 qp run fci - energy1="$(ezfio get fci energy | tr '[]' ' ' | cut -d ',' -f 1)" + energy1="$(qp get fci energy | tr '[]' ' ' | cut -d ',' -f 1)" eq $energy1 $1 $thresh } @@ -22,166 +22,167 @@ function run_stoch() { thresh=$2 test_exe fci || skip qp set perturbation do_pt2 True + qp set perturbation pt2_relative_error 0.005 qp set determinants n_det_max $3 qp set determinants n_states 1 qp set davidson threshold_davidson 1.e-10 qp set davidson n_states_diag 1 qp run fci - energy1="$(ezfio get fci energy_pt2 | tr '[]' ' ' | cut -d ',' -f 1)" + energy1="$(qp get fci energy_extrapolated | tr '[]' ' ' | cut -d ',' -f 1)" eq $energy1 $1 $thresh } -@test "B-B" { + +@test "B-B" { # 0:00:10 qp set_file b2_stretched.ezfio qp set determinants n_det_max 10000 qp set_frozen_core - run_stoch -49.14103054419 3.e-4 10000 + run_stoch -49.14104086 0.0001 10000 } -@test "F2" { # 4.07m +@test "F2" { # 0:03:34 [[ -n $TRAVIS ]] && skip qp set_file f2.ezfio qp set_frozen_core - run_stoch -199.304922384814 3.e-4 100000 + run_stoch -199.30821487 0.002 100000 } -@test "NH3" { # 10.6657s +@test "NH3" { # 0:00:11 qp set_file nh3.ezfio qp set_mo_class --core="[1-4]" --act="[5-72]" - run -56.244753429144986 3.e-4 100000 + run -56.24474790 1.e-5 10000 } -@test "DHNO" { # 11.4721s +@test "DHNO" { # 0:00:10 qp set_file dhno.ezfio qp set_mo_class --core="[1-7]" --act="[8-64]" - run -130.459020029816 3.e-4 100000 + run -130.45901042 1.e-4 10000 } -@test "HCO" { # 12.2868s +@test "HCO" { # 0:01:16 qp set_file hco.ezfio - run -113.393356604085 1.e-3 100000 + run_stoch -113.41658256 1.e-3 50000 } -@test "H2O2" { # 12.9214s +@test "H2O2" { # 0:01:48 qp set_file h2o2.ezfio qp set_mo_class --core="[1-2]" --act="[3-24]" --del="[25-38]" - run -151.005848404095 2.e-3 100000 + run_stoch -151.02317880 2.e-3 100000 } -@test "HBO" { # 13.3144s +@test "HBO" { # 0:00:46 [[ -n $TRAVIS ]] && skip qp set_file hbo.ezfio - run -100.214099486337 1.e-3 100000 + run_stoch -100.22361288 1.e-4 50000 } -@test "H2O" { # 11.3727s +@test "H2O" { # 0:01:05 [[ -n $TRAVIS ]] && skip qp set_file h2o.ezfio - run -76.2361605151999 2.e-3 100000 + run_stoch -76.24347962 1.e-4 100000 } -@test "ClO" { # 13.3755s +@test "ClO" { # 0:03:07 [[ -n $TRAVIS ]] && skip qp set_file clo.ezfio - run -534.546453546852 1.e-3 100000 + run_stoch -534.58202840 1.e-3 100000 } -@test "SO" { # 13.4952s +@test "SO" { # 0:01:49 [[ -n $TRAVIS ]] && skip qp set_file so.ezfio - run -26.0176563764039 1.e-3 100000 + run_stoch -26.04335528 5.e-3 100000 } -@test "H2S" { # 13.6745s +@test "H2S" { # 0:01:12 [[ -n $TRAVIS ]] && skip qp set_file h2s.ezfio - run -398.859577605891 5.e-4 100000 + run_stoch -398.87187312 1.e-3 50000 } -@test "OH" { # 13.865s +@test "OH" { # 0:00:41 [[ -n $TRAVIS ]] && skip qp set_file oh.ezfio - run -75.6121856748294 3.e-4 100000 + run_stoch -75.62393829 1.e-3 50000 } -@test "SiH2_3B1" { # 13.938ss +@test "SiH2_3B1" { # 0:00:50 [[ -n $TRAVIS ]] && skip qp set_file sih2_3b1.ezfio - run -290.0175411299477 3.e-4 100000 + run_stoch -290.02083172 3.e-5 50000 } -@test "H3COH" { # 14.7299s +@test "H3COH" { # 0:01:05 [[ -n $TRAVIS ]] && skip qp set_file h3coh.ezfio - run -115.205632960026 1.e-3 100000 + run_stoch -115.22625460 2.e-3 50000 } -@test "SiH3" { # 15.99s +@test "SiH3" { # 0:01:09 [[ -n $TRAVIS ]] && skip qp set_file sih3.ezfio - run -5.57241217753818 5.e-4 100000 + run_stoch -5.57818759 1.e-3 50000 } -@test "CH4" { # 16.1612s +@test "CH4" { # 0:02:06 [[ -n $TRAVIS ]] && skip qp set_file ch4.ezfio qp set_mo_class --core="[1]" --act="[2-30]" --del="[31-59]" - run -40.2409678239136 3.e-4 100000 + run_stoch -40.24195947 1.e-4 100000 } -@test "ClF" { # 16.8864s +@test "ClF" { # 0:01:55 [[ -n $TRAVIS ]] && skip qp set_file clf.ezfio - run -559.169748890031 1.5e-3 100000 + run_stoch -559.20157348 1.e-3 50000 } -@test "SO2" { # 17.5645s +@test "SO2" { # 0:00:24 [[ -n $TRAVIS ]] && skip qp set_file so2.ezfio qp set_mo_class --core="[1-8]" --act="[9-87]" - run -41.5746738713298 1.5e-3 100000 + run_stoch -41.57468087 1.e-4 50000 } -@test "C2H2" { # 17.6827s +@test "C2H2" { # 0:00:57 [[ -n $TRAVIS ]] && skip qp set_file c2h2.ezfio qp set_mo_class --act="[1-30]" --del="[31-36]" - run -12.3685464085969 2.e-3 100000 + run_stoch -12.38655876 1.e-3 50000 } -@test "N2" { # 18.0198s +@test "N2" { # 0:01:15 [[ -n $TRAVIS ]] && skip qp set_file n2.ezfio qp set_mo_class --core="[1,2]" --act="[3-40]" --del="[41-60]" - run -109.287917088107 1.5e-3 100000 + run_stoch -109.31133266 2.e-3 50000 } -@test "N2H4" { # 18.5006s +@test "N2H4" { # 0:00:51 [[ -n $TRAVIS ]] && skip qp set_file n2h4.ezfio qp set_mo_class --core="[1-2]" --act="[3-24]" --del="[25-48]" - run -111.367332681559 3.e-4 100000 + run_stoch -111.38161063 1.e-3 50000 } -@test "CO2" { # 21.1748s +@test "CO2" { # 0:01:00 [[ -n $TRAVIS ]] && skip qp set_file co2.ezfio qp set_mo_class --core="[1,2]" --act="[3-30]" --del="[31-42]" - run -187.970184372047 1.5e-3 100000 + run_stoch -188.00154729 2.e-3 50000 } - -@test "[Cu(NH3)4]2+" { # 25.0417s +@test "[Cu(NH3)4]2+" { # 0:01:53 [[ -n $TRAVIS ]] && skip qp set_file cu_nh3_4_2plus.ezfio qp set_mo_class --core="[1-24]" --act="[25-45]" --del="[46-87]" - run -1862.9869374387192 3.e-04 100000 + run_stoch -1862.98705091 1.e-05 50000 } -@test "HCN" { # 20.3273s +@test "HCN" { # 0:01:26 [[ -n $TRAVIS ]] && skip qp set_file hcn.ezfio qp set_mo_class --core="[1,2]" --act="[3-40]" --del="[41-55]" - run -93.0777619629755 1.e-3 100000 + run_stoch -93.09855896 5.e-4 50000 } diff --git a/src/fci/EZFIO.cfg b/src/fci/EZFIO.cfg index d897428a..6b46a85f 100644 --- a/src/fci/EZFIO.cfg +++ b/src/fci/EZFIO.cfg @@ -10,3 +10,9 @@ doc: Calculated |FCI| energy + |PT2| interface: ezfio size: (determinants.n_states) +[energy_extrapolated] +type: double precision +doc: Calculated |FCI| energy + |PT2| +interface: ezfio +size: (determinants.n_states) + diff --git a/src/iterations/print_extrapolation.irp.f b/src/iterations/print_extrapolation.irp.f index cb46fb67..e07cc1ed 100644 --- a/src/iterations/print_extrapolation.irp.f +++ b/src/iterations/print_extrapolation.irp.f @@ -41,6 +41,7 @@ subroutine print_extrapolated_energy enddo print *, '' + call ezfio_set_fci_energy_extrapolated(extrapolated_energy(2,1:N_states)) end subroutine From 687fa9472a707157ae4f4d58d9cc65c2ab803bba Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 12 May 2022 12:03:22 +0200 Subject: [PATCH 14/80] Update drone config --- .drone.yml | 74 ++++++++++++++--------------- bin/qp_convert_output_to_ezfio | 2 +- src/determinants/determinants.irp.f | 3 +- 3 files changed, 39 insertions(+), 40 deletions(-) diff --git a/.drone.yml b/.drone.yml index 256b8e9b..52b48829 100644 --- a/.drone.yml +++ b/.drone.yml @@ -7,46 +7,46 @@ clone: depth: 10 steps: + - name: configure debug + image: scemama666/qp2_env + commands: + - ./configure -i all -c ./config/gfortran_debug.cfg + - bash -c "source quantum_package.rc ; exec qp_plugins download https://gitlab.com/scemama/qp_plugins_scemama" + - bash -c "source quantum_package.rc ; exec qp_plugins install champ" -- name: configure - image: scemama666/qp2_env - commands: - - ./configure -i all -c ./config/gfortran_debug.cfg - - bash -c "source quantum_package.rc ; exec qp_plugins download https://gitlab.com/scemama/qp_plugins_scemama" - - bash -c "source quantum_package.rc ; exec qp_plugins install champ" + - name: compile debug + image: scemama666/qp2_env + commands: + - bash -c "source quantum_package.rc ; exec ninja" -- name: compile - image: scemama666/qp2_env - commands: - - bash -c "source quantum_package.rc ; exec ninja" + - name: testing debug + image: scemama666/qp2_env + commands: + - bash -c "source quantum_package.rc ; TRAVIS=1 exec qp_test -a" -- name: testing - image: scemama666/qp2_env - commands: - - bash -c "source quantum_package.rc ; TRAVIS=1 exec qp_test -a" + - name: configure fast + image: scemama666/qp2_env + commands: + - ./configure -i all -c ./config/gfortran_avx.cfg ---- -kind: pipeline -type: docker -name: gfortran-avx + - name: compile fast + image: scemama666/qp2_env + commands: + - bash -c "source quantum_package.rc ; exec ninja" -clone: - depth: 10 - -steps: - -- name: configure - image: scemama666/qp2_env - commands: - - ./configure -i all -c ./config/gfortran_avx.cfg - -- name: compile - image: scemama666/qp2_env - commands: - - bash -c "source quantum_package.rc ; exec ninja" - -- name: testing - image: scemama666/qp2_env - commands: - - bash -c "source quantum_package.rc ; exec qp_test -a" + - name: testing fast + image: scemama666/qp2_env + commands: + - bash -c "source quantum_package.rc ; exec qp_test -a" + - name: notify + image: drillster/drone-email + settings: + host: + from_secret: hostname # irsamc.ups-tlse.fr + from: + from_secret: from # drone@irssv7.ups-tlse.fr + recipients: + from_secret: recipients # scemama@irsamc.ups-tlse.fr + when: + status: [changed, failure] diff --git a/bin/qp_convert_output_to_ezfio b/bin/qp_convert_output_to_ezfio index 091423e4..07ad2236 100755 --- a/bin/qp_convert_output_to_ezfio +++ b/bin/qp_convert_output_to_ezfio @@ -224,7 +224,7 @@ def write_ezfio(res, filename): exponent += [p.expo for p in b.prim] ang_mom.append(str.count(s, "z")) shell_prim_num.append(len(b.prim)) - shell_index += [nshell_tot+1] * len(b.prim) + shell_index += [nshell_tot] * len(b.prim) # ~#~#~#~#~ # # W r i t e # diff --git a/src/determinants/determinants.irp.f b/src/determinants/determinants.irp.f index eeadf779..12ad912f 100644 --- a/src/determinants/determinants.irp.f +++ b/src/determinants/determinants.irp.f @@ -542,12 +542,11 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef) integer :: i,j,k, ndet_qp_edit if (mpi_master) then - ndet_qp_edit = min(ndet,N_det_qp_edit) call ezfio_set_determinants_N_int(N_int) call ezfio_set_determinants_bit_kind(bit_kind) call ezfio_set_determinants_N_det(ndet) - call ezfio_set_determinants_N_det_qp_edit(ndet_qp_edit) + call ezfio_set_determinants_N_det_qp_edit(min(ndet,10000)) call ezfio_set_determinants_n_states(nstates) call ezfio_set_determinants_mo_label(mo_label) From 8a7854de574ebb0679f849ba14f5b3d42651b2f4 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 12 May 2022 12:08:18 +0200 Subject: [PATCH 15/80] Update drone.yml --- .drone.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.drone.yml b/.drone.yml index 52b48829..d3d3ef92 100644 --- a/.drone.yml +++ b/.drone.yml @@ -27,7 +27,7 @@ steps: - name: configure fast image: scemama666/qp2_env commands: - - ./configure -i all -c ./config/gfortran_avx.cfg + - ./configure -c ./config/gfortran_avx.cfg - name: compile fast image: scemama666/qp2_env From 6224e449ca2f1850152e2fdc46f838806e1b5907 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 12 May 2022 14:28:25 +0200 Subject: [PATCH 16/80] Replaces psi_det_size by N_det --- src/csf/configurations.irp.f | 2 +- src/davidson/davidson_parallel.irp.f | 2 +- src/davidson/davidson_parallel_csf.irp.f | 2 +- src/davidson/davidson_parallel_nos2.irp.f | 2 +- src/davidson/u0_hs2_u0.irp.f | 2 +- src/davidson/u0_wee_u0.irp.f | 2 +- src/determinants/determinants.irp.f | 69 +++++------------------ src/determinants/h_apply.irp.f | 7 +-- src/determinants/psi_cas.irp.f | 20 +++---- src/determinants/s2.irp.f | 2 +- src/determinants/spindeterminants.irp.f | 6 +- src/determinants/zmq.irp.f | 23 ++------ src/generators_cas/generators.irp.f | 10 ++-- src/generators_full/generators.irp.f | 10 ++-- src/perturbation/selection.irp.f | 4 +- src/psiref_cas/psi_ref.irp.f | 12 ++-- src/psiref_utils/psi_ref_utils.irp.f | 26 ++++----- src/selectors_utils/selectors.irp.f | 2 +- src/single_ref_method/generators.irp.f | 4 +- 19 files changed, 77 insertions(+), 130 deletions(-) diff --git a/src/csf/configurations.irp.f b/src/csf/configurations.irp.f index ce5d48ab..3ecaa517 100644 --- a/src/csf/configurations.irp.f +++ b/src/csf/configurations.irp.f @@ -332,7 +332,7 @@ subroutine configuration_to_dets_tree_addressing(o,d,sze,n_alpha,Nint) end - BEGIN_PROVIDER [ integer(bit_kind), psi_configuration, (N_int,2,psi_det_size) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_configuration, (N_int,2,N_det) ] &BEGIN_PROVIDER [ integer, N_configuration ] implicit none BEGIN_DOC diff --git a/src/davidson/davidson_parallel.irp.f b/src/davidson/davidson_parallel.irp.f index e627dfc9..b642d7a4 100644 --- a/src/davidson/davidson_parallel.irp.f +++ b/src/davidson/davidson_parallel.irp.f @@ -99,7 +99,7 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze, integer :: rc, ni, nj integer*8 :: rc8 - integer :: N_states_read, N_det_read, psi_det_size_read + integer :: N_states_read, N_det_read integer :: N_det_selectors_read, N_det_generators_read integer, external :: zmq_get_dvector diff --git a/src/davidson/davidson_parallel_csf.irp.f b/src/davidson/davidson_parallel_csf.irp.f index d8e9bffa..8a8fcc4a 100644 --- a/src/davidson/davidson_parallel_csf.irp.f +++ b/src/davidson/davidson_parallel_csf.irp.f @@ -99,7 +99,7 @@ subroutine davidson_csf_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, integer :: rc, ni, nj integer*8 :: rc8 - integer :: N_states_read, N_det_read, psi_det_size_read + integer :: N_states_read, N_det_read integer :: N_det_selectors_read, N_det_generators_read integer, external :: zmq_get_dvector diff --git a/src/davidson/davidson_parallel_nos2.irp.f b/src/davidson/davidson_parallel_nos2.irp.f index 597b001f..dcc9687d 100644 --- a/src/davidson/davidson_parallel_nos2.irp.f +++ b/src/davidson/davidson_parallel_nos2.irp.f @@ -99,7 +99,7 @@ subroutine davidson_nos2_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, integer :: rc, ni, nj integer*8 :: rc8 - integer :: N_states_read, N_det_read, psi_det_size_read + integer :: N_states_read, N_det_read integer :: N_det_selectors_read, N_det_generators_read integer, external :: zmq_get_dvector diff --git a/src/davidson/u0_hs2_u0.irp.f b/src/davidson/u0_hs2_u0.irp.f index 38fb56bd..e67777e7 100644 --- a/src/davidson/u0_hs2_u0.irp.f +++ b/src/davidson/u0_hs2_u0.irp.f @@ -6,7 +6,7 @@ ! ! psi_s2(i) = $\langle \Psi_i | S^2 | \Psi_i \rangle$ END_DOC - call u_0_HS2_u_0(psi_energy,psi_s2,psi_coef,N_det,psi_det,N_int,N_states,psi_det_size) + call u_0_HS2_u_0(psi_energy,psi_s2,psi_coef,N_det,psi_det,N_int,N_states,N_det) integer :: i do i=N_det+1,N_states psi_energy(i) = 0.d0 diff --git a/src/davidson/u0_wee_u0.irp.f b/src/davidson/u0_wee_u0.irp.f index 0c543aca..e53d76ea 100644 --- a/src/davidson/u0_wee_u0.irp.f +++ b/src/davidson/u0_wee_u0.irp.f @@ -4,7 +4,7 @@ BEGIN_PROVIDER [ double precision, psi_energy_two_e, (N_states) ] ! Energy of the current wave function END_DOC integer :: i,j - call u_0_H_u_0_two_e(psi_energy_two_e,psi_coef,N_det,psi_det,N_int,N_states,psi_det_size) + call u_0_H_u_0_two_e(psi_energy_two_e,psi_coef,N_det,psi_det,N_int,N_states,N_det) do i=N_det+1,N_states psi_energy_two_e(i) = 0.d0 enddo diff --git a/src/determinants/determinants.irp.f b/src/determinants/determinants.irp.f index eeadf779..16f3bedb 100644 --- a/src/determinants/determinants.irp.f +++ b/src/determinants/determinants.irp.f @@ -70,42 +70,7 @@ BEGIN_PROVIDER [integer, max_degree_exc] enddo END_PROVIDER -BEGIN_PROVIDER [ integer, psi_det_size ] - implicit none - BEGIN_DOC - ! Size of the psi_det and psi_coef arrays - END_DOC - PROVIDE ezfio_filename - logical :: exists - psi_det_size = 1 - PROVIDE mpi_master - if (read_wf) then - if (mpi_master) then - call ezfio_has_determinants_n_det(exists) - if (exists) then - call ezfio_get_determinants_n_det(psi_det_size) - else - psi_det_size = 1 - endif - call write_int(6,psi_det_size,'Dimension of the psi arrays') - endif - IRP_IF MPI_DEBUG - print *, irp_here, mpi_rank - call MPI_BARRIER(MPI_COMM_WORLD, ierr) - IRP_ENDIF - IRP_IF MPI - include 'mpif.h' - integer :: ierr - call MPI_BCAST( psi_det_size, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to read psi_det_size with MPI' - endif - IRP_ENDIF - endif - -END_PROVIDER - -BEGIN_PROVIDER [ integer(bit_kind), psi_det, (N_int,2,psi_det_size) ] +BEGIN_PROVIDER [ integer(bit_kind), psi_det, (N_int,2,N_det) ] implicit none BEGIN_DOC ! The determinants of the wave function. Initialized with Hartree-Fock if the |EZFIO| file @@ -176,7 +141,7 @@ END_PROVIDER -BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states) ] +BEGIN_PROVIDER [ double precision, psi_coef, (N_det,N_states) ] implicit none BEGIN_DOC ! The wave function coefficients. Initialized with Hartree-Fock if the |EZFIO| file @@ -189,7 +154,7 @@ BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states) ] PROVIDE read_wf N_det mo_label ezfio_filename psi_coef = 0.d0 - do i=1,min(N_states,psi_det_size) + do i=1,min(N_states,N_det) psi_coef(i,i) = 1.d0 enddo @@ -237,7 +202,7 @@ BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states) ] END_PROVIDER -BEGIN_PROVIDER [ double precision, psi_average_norm_contrib, (psi_det_size) ] +BEGIN_PROVIDER [ double precision, psi_average_norm_contrib, (N_det) ] implicit none BEGIN_DOC ! Contribution of determinants to the state-averaged density. @@ -287,10 +252,10 @@ END_PROVIDER !==============================================================================! - BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_coef_sorted, (psi_det_size,N_states) ] -&BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_sorted, (psi_det_size) ] -&BEGIN_PROVIDER [ integer, psi_det_sorted_order, (psi_det_size) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted, (N_int,2,N_det) ] +&BEGIN_PROVIDER [ double precision, psi_coef_sorted, (N_det,N_states) ] +&BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_sorted, (N_det) ] +&BEGIN_PROVIDER [ integer, psi_det_sorted_order, (N_det) ] implicit none BEGIN_DOC ! Wave function sorted by determinants contribution to the norm (state-averaged) @@ -319,17 +284,12 @@ END_PROVIDER psi_det_sorted_order(iorder(i)) = i enddo - psi_det_sorted(:,:,N_det+1:psi_det_size) = 0_bit_kind - psi_coef_sorted(N_det+1:psi_det_size,:) = 0.d0 - psi_average_norm_contrib_sorted(N_det+1:psi_det_size) = 0.d0 - psi_det_sorted_order(N_det+1:psi_det_size) = 0 - deallocate(iorder) END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_bit, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_coef_sorted_bit, (psi_det_size,N_states) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_bit, (N_int,2,N_det) ] +&BEGIN_PROVIDER [ double precision, psi_coef_sorted_bit, (N_det,N_states) ] implicit none BEGIN_DOC ! Determinants on which we apply $\langle i|H|psi \rangle$ for perturbation. @@ -355,9 +315,6 @@ subroutine sort_dets_by_det_search_key(Ndet, det_in, coef_in, sze, det_out, coef ! Determinants are sorted according to their :c:func:`det_search_key`. ! Useful to accelerate the search of a random determinant in the wave ! function. - ! - ! /!\ The first dimension of coef_out and coef_in need to be psi_det_size - ! END_DOC integer :: i,j,k integer, allocatable :: iorder(:) @@ -491,7 +448,11 @@ subroutine save_wavefunction_truncated(thr) endif enddo if (mpi_master) then - call save_wavefunction_general(N_det_save,min(N_states,N_det_save),psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted) + call save_wavefunction_general(N_det_save, & + min(N_states,N_det_save), & + psi_det_sorted, & + size(psi_coef_sorted,1), & + psi_coef_sorted) endif end diff --git a/src/determinants/h_apply.irp.f b/src/determinants/h_apply.irp.f index d01ad1c7..246ff209 100644 --- a/src/determinants/h_apply.irp.f +++ b/src/determinants/h_apply.irp.f @@ -159,10 +159,7 @@ subroutine copy_H_apply_buffer_to_wf enddo ! Update array sizes - if (psi_det_size < N_det) then - psi_det_size = N_det - TOUCH psi_det_size - endif + TOUCH N_det ! Restore backup in resized array do i=1,N_det_old @@ -180,7 +177,7 @@ subroutine copy_H_apply_buffer_to_wf !$OMP PARALLEL DEFAULT(SHARED) & !$OMP PRIVATE(j,k,i) FIRSTPRIVATE(N_det_old) & - !$OMP SHARED(N_int,H_apply_buffer,psi_det,psi_coef,N_states,psi_det_size) + !$OMP SHARED(N_int,H_apply_buffer,psi_det,psi_coef,N_states,N_det) j=0 !$ j=omp_get_thread_num() do k=0,j-1 diff --git a/src/determinants/psi_cas.irp.f b/src/determinants/psi_cas.irp.f index 19a1c260..125ec1e1 100644 --- a/src/determinants/psi_cas.irp.f +++ b/src/determinants/psi_cas.irp.f @@ -1,8 +1,8 @@ use bitmasks - BEGIN_PROVIDER [ integer(bit_kind), psi_cas, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_cas_coef, (psi_det_size,n_states) ] -&BEGIN_PROVIDER [ integer, idx_cas, (psi_det_size) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_cas, (N_int,2,N_det) ] +&BEGIN_PROVIDER [ double precision, psi_cas_coef, (N_det,n_states) ] +&BEGIN_PROVIDER [ integer, idx_cas, (N_det) ] &BEGIN_PROVIDER [ integer, N_det_cas ] implicit none BEGIN_DOC @@ -44,8 +44,8 @@ use bitmasks END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_cas_sorted_bit, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_cas_coef_sorted_bit, (psi_det_size,N_states) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_cas_sorted_bit, (N_int,2,N_det) ] +&BEGIN_PROVIDER [ double precision, psi_cas_coef_sorted_bit, (N_det,N_states) ] implicit none BEGIN_DOC ! |CAS| determinants sorted to accelerate the search of a random determinant in the wave @@ -58,9 +58,9 @@ END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_non_cas, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_non_cas_coef, (psi_det_size,n_states) ] -&BEGIN_PROVIDER [ integer, idx_non_cas, (psi_det_size) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_non_cas, (N_int,2,N_det) ] +&BEGIN_PROVIDER [ double precision, psi_non_cas_coef, (N_det,n_states) ] +&BEGIN_PROVIDER [ integer, idx_non_cas, (N_det) ] &BEGIN_PROVIDER [ integer, N_det_non_cas ] implicit none BEGIN_DOC @@ -97,8 +97,8 @@ END_PROVIDER N_det_non_cas = i_non_cas END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_non_cas_sorted_bit, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_non_cas_coef_sorted_bit, (psi_det_size,N_states) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_non_cas_sorted_bit, (N_int,2,N_det) ] +&BEGIN_PROVIDER [ double precision, psi_non_cas_coef_sorted_bit, (N_det,N_states) ] implicit none BEGIN_DOC ! |CAS| determinants sorted to accelerate the search of a random determinant in the wave diff --git a/src/determinants/s2.irp.f b/src/determinants/s2.irp.f index 2c1a8757..abae212f 100644 --- a/src/determinants/s2.irp.f +++ b/src/determinants/s2.irp.f @@ -110,7 +110,7 @@ END_PROVIDER ! array of the averaged values of the S^2 operator on the various states END_DOC integer :: i - call u_0_S2_u_0(s2_values,psi_coef,n_det,psi_det,N_int,N_states,psi_det_size) + call u_0_S2_u_0(s2_values,psi_coef,n_det,psi_det,N_int,N_states,N_det) do i = 1, N_states s_values(i) = 0.5d0 *(-1.d0 + dsqrt(1.d0 + 4 * s2_values(i))) enddo diff --git a/src/determinants/spindeterminants.irp.f b/src/determinants/spindeterminants.irp.f index dd55e112..e4a857a9 100644 --- a/src/determinants/spindeterminants.irp.f +++ b/src/determinants/spindeterminants.irp.f @@ -24,7 +24,7 @@ integer*8 function spin_det_search_key(det,Nint) end -BEGIN_PROVIDER [ integer(bit_kind), psi_det_alpha, (N_int,psi_det_size) ] +BEGIN_PROVIDER [ integer(bit_kind), psi_det_alpha, (N_int,N_det) ] implicit none BEGIN_DOC ! List of $\alpha$ determinants of psi_det @@ -39,7 +39,7 @@ BEGIN_PROVIDER [ integer(bit_kind), psi_det_alpha, (N_int,psi_det_size) ] END_PROVIDER -BEGIN_PROVIDER [ integer(bit_kind), psi_det_beta, (N_int,psi_det_size) ] +BEGIN_PROVIDER [ integer(bit_kind), psi_det_beta, (N_int,N_det) ] implicit none BEGIN_DOC ! List of $\beta$ determinants of psi_det @@ -56,7 +56,7 @@ END_PROVIDER BEGIN_TEMPLATE - BEGIN_PROVIDER [ integer(bit_kind), psi_det_$alpha_unique, (N_int,psi_det_size) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_det_$alpha_unique, (N_int,N_det) ] &BEGIN_PROVIDER [ integer, N_det_$alpha_unique ] implicit none BEGIN_DOC diff --git a/src/determinants/zmq.irp.f b/src/determinants/zmq.irp.f index 5a114533..7288de05 100644 --- a/src/determinants/zmq.irp.f +++ b/src/determinants/zmq.irp.f @@ -10,7 +10,6 @@ integer function zmq_put_psi(zmq_to_qp_run_socket,worker_id) integer, external :: zmq_put_N_states integer, external :: zmq_put_N_det - integer, external :: zmq_put_psi_det_size integer*8, external :: zmq_put_psi_det integer*8, external :: zmq_put_psi_coef @@ -23,10 +22,6 @@ integer function zmq_put_psi(zmq_to_qp_run_socket,worker_id) zmq_put_psi = -1 return endif - if (zmq_put_psi_det_size(zmq_to_qp_run_socket, worker_id) == -1) then - zmq_put_psi = -1 - return - endif if (zmq_put_psi_det(zmq_to_qp_run_socket, worker_id) == -1) then zmq_put_psi = -1 return @@ -51,7 +46,6 @@ integer function zmq_get_psi_notouch(zmq_to_qp_run_socket, worker_id) integer, external :: zmq_get_N_states integer, external :: zmq_get_N_det - integer, external :: zmq_get_psi_det_size integer*8, external :: zmq_get_psi_det integer*8, external :: zmq_get_psi_coef @@ -65,19 +59,15 @@ integer function zmq_get_psi_notouch(zmq_to_qp_run_socket, worker_id) zmq_get_psi_notouch = -1 return endif - if (zmq_get_psi_det_size(zmq_to_qp_run_socket, worker_id) == -1) then - zmq_get_psi_notouch = -1 - return - endif - if (size(psi_det,kind=8) /= N_int*2_8*psi_det_size*bit_kind) then + if (size(psi_det,kind=8) /= N_int*2_8*N_det*bit_kind) then deallocate(psi_det) - allocate(psi_det(N_int,2,psi_det_size)) + allocate(psi_det(N_int,2,N_det)) endif - if (size(psi_coef,kind=8) /= psi_det_size*N_states) then + if (size(psi_coef,kind=8) /= N_det*N_states) then deallocate(psi_coef) - allocate(psi_coef(psi_det_size,N_states)) + allocate(psi_coef(N_det,N_states)) endif if (zmq_get_psi_det(zmq_to_qp_run_socket, worker_id) == -1_8) then @@ -102,7 +92,7 @@ integer function zmq_get_psi(zmq_to_qp_run_socket, worker_id) integer, intent(in) :: worker_id integer, external :: zmq_get_psi_notouch zmq_get_psi = zmq_get_psi_notouch(zmq_to_qp_run_socket, worker_id) - SOFT_TOUCH psi_det psi_coef psi_det_size N_det N_states + SOFT_TOUCH psi_det psi_coef N_det N_states end @@ -266,7 +256,7 @@ integer function zmq_get_psi_bilinear(zmq_to_qp_run_socket, worker_id) return endif - SOFT_TOUCH psi_bilinear_matrix_values psi_bilinear_matrix_rows psi_bilinear_matrix_columns psi_bilinear_matrix_order psi_det psi_coef psi_det_size N_det N_states psi_det_beta_unique psi_det_alpha_unique N_det_beta_unique N_det_alpha_unique + SOFT_TOUCH psi_bilinear_matrix_values psi_bilinear_matrix_rows psi_bilinear_matrix_columns psi_bilinear_matrix_order psi_det psi_coef N_det N_states psi_det_beta_unique psi_det_alpha_unique N_det_beta_unique N_det_alpha_unique end @@ -374,7 +364,6 @@ N_states ;; N_det ;; N_det_alpha_unique ;; N_det_beta_unique ;; -psi_det_size ;; END_TEMPLATE diff --git a/src/generators_cas/generators.irp.f b/src/generators_cas/generators.irp.f index b2f58202..e499f703 100644 --- a/src/generators_cas/generators.irp.f +++ b/src/generators_cas/generators.irp.f @@ -20,11 +20,11 @@ BEGIN_PROVIDER [ integer, N_det_generators ] call write_int(6,N_det_generators,'Number of generators') END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ] -&BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_gen, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen, (psi_det_size,N_states) ] -&BEGIN_PROVIDER [ integer, psi_det_sorted_gen_order, (psi_det_size) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,N_det) ] +&BEGIN_PROVIDER [ double precision, psi_coef_generators, (N_det,N_states) ] +&BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_gen, (N_int,2,N_det) ] +&BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen, (N_det,N_states) ] +&BEGIN_PROVIDER [ integer, psi_det_sorted_gen_order, (N_det) ] implicit none BEGIN_DOC ! For Single reference wave functions, the generator is the diff --git a/src/generators_full/generators.irp.f b/src/generators_full/generators.irp.f index 7f18947f..376e5e3e 100644 --- a/src/generators_full/generators.irp.f +++ b/src/generators_full/generators.irp.f @@ -22,8 +22,8 @@ BEGIN_PROVIDER [ integer, N_det_generators ] call write_int(6,N_det_generators,'Number of generators') END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,N_det) ] +&BEGIN_PROVIDER [ double precision, psi_coef_generators, (N_det,N_states) ] implicit none BEGIN_DOC ! For Single reference wave functions, the generator is the @@ -34,9 +34,9 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_gen, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen, (psi_det_size,N_states) ] -&BEGIN_PROVIDER [ integer, psi_det_sorted_gen_order, (psi_det_size) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_gen, (N_int,2,N_det) ] +&BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen, (N_det,N_states) ] +&BEGIN_PROVIDER [ integer, psi_det_sorted_gen_order, (N_det) ] implicit none BEGIN_DOC diff --git a/src/perturbation/selection.irp.f b/src/perturbation/selection.irp.f index f3f03673..67422226 100644 --- a/src/perturbation/selection.irp.f +++ b/src/perturbation/selection.irp.f @@ -90,12 +90,12 @@ subroutine remove_small_contributions enddo !$OMP PARALLEL DEFAULT(NONE) & !$OMP PRIVATE(i,j,i_H_psi_array) & - !$OMP SHARED(k,psi_det_sorted,psi_coef_sorted,N_int,N_det,psi_det_size,N_states, & + !$OMP SHARED(k,psi_det_sorted,psi_coef_sorted,N_int,N_det,N_det,N_states, & !$OMP selection_criterion_min,keep,N_det_generators) & !$OMP REDUCTION(+:N_removed) !$OMP DO do i=2*N_det_generators+1, N_det - call i_H_psi(psi_det_sorted(1,1,i),psi_det_sorted,psi_coef_sorted,N_int,min(N_det,2*N_det_generators),psi_det_size,N_states,i_H_psi_array) + call i_H_psi(psi_det_sorted(1,1,i),psi_det_sorted,psi_coef_sorted,N_int,min(N_det,2*N_det_generators),N_det,N_states,i_H_psi_array) keep(i) = .False. do j=1,N_states keep(i) = keep(i) .or. (-(psi_coef_sorted(i,j)*i_H_psi_array(j)) > selection_criterion_min) diff --git a/src/psiref_cas/psi_ref.irp.f b/src/psiref_cas/psi_ref.irp.f index 78dd2239..0e1df986 100644 --- a/src/psiref_cas/psi_ref.irp.f +++ b/src/psiref_cas/psi_ref.irp.f @@ -1,8 +1,8 @@ use bitmasks - BEGIN_PROVIDER [ integer(bit_kind), psi_ref, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_ref_coef, (psi_det_size,n_states) ] -&BEGIN_PROVIDER [ integer, idx_ref, (psi_det_size) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_ref, (N_int,2,N_det) ] +&BEGIN_PROVIDER [ double precision, psi_ref_coef, (N_det,n_states) ] +&BEGIN_PROVIDER [ integer, idx_ref, (N_det) ] &BEGIN_PROVIDER [ integer, N_det_ref ] implicit none BEGIN_DOC @@ -26,7 +26,7 @@ use bitmasks END_PROVIDER -BEGIN_PROVIDER [ double precision, psi_ref_coef_inv, (psi_det_size,n_states) ] +BEGIN_PROVIDER [ double precision, psi_ref_coef_inv, (N_det,n_states) ] implicit none BEGIN_DOC ! 1/psi_ref_coef @@ -41,8 +41,8 @@ BEGIN_PROVIDER [ double precision, psi_ref_coef_inv, (psi_det_size,n_states) ] END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_ref_restart, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_ref_coef_restart, (psi_det_size,n_states) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_ref_restart, (N_int,2,N_det) ] +&BEGIN_PROVIDER [ double precision, psi_ref_coef_restart, (N_det,n_states) ] implicit none BEGIN_DOC ! Projection of the CAS wave function on the restart wave function. diff --git a/src/psiref_utils/psi_ref_utils.irp.f b/src/psiref_utils/psi_ref_utils.irp.f index 19e42283..185d9778 100644 --- a/src/psiref_utils/psi_ref_utils.irp.f +++ b/src/psiref_utils/psi_ref_utils.irp.f @@ -1,8 +1,8 @@ use bitmasks - BEGIN_PROVIDER [ integer(bit_kind), psi_ref_sorted_bit, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_ref_coef_sorted_bit, (psi_det_size,N_states) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_ref_sorted_bit, (N_int,2,N_det) ] +&BEGIN_PROVIDER [ double precision, psi_ref_coef_sorted_bit, (N_det,N_states) ] implicit none BEGIN_DOC ! Reference determinants sorted to accelerate the search of a random determinant in the wave @@ -14,7 +14,7 @@ use bitmasks END_PROVIDER -BEGIN_PROVIDER [ double precision, psi_ref_coef_transp, (n_states,psi_det_size) ] +BEGIN_PROVIDER [ double precision, psi_ref_coef_transp, (n_states,N_det) ] implicit none BEGIN_DOC ! Transposed psi_ref_coef @@ -27,7 +27,7 @@ BEGIN_PROVIDER [ double precision, psi_ref_coef_transp, (n_states,psi_det_size) enddo END_PROVIDER -BEGIN_PROVIDER [ double precision, psi_ref_coef_normalized, (psi_det_size,n_states) ] +BEGIN_PROVIDER [ double precision, psi_ref_coef_normalized, (N_det,n_states) ] implicit none BEGIN_DOC ! Normalized coefficients of the reference @@ -43,7 +43,7 @@ BEGIN_PROVIDER [ double precision, psi_ref_coef_normalized, (psi_det_size,n_sta END_PROVIDER -BEGIN_PROVIDER [ double precision, psi_non_ref_coef_transp, (n_states,psi_det_size) ] +BEGIN_PROVIDER [ double precision, psi_non_ref_coef_transp, (n_states,N_det) ] implicit none BEGIN_DOC ! Transposed psi_non_ref_coef @@ -56,10 +56,10 @@ BEGIN_PROVIDER [ double precision, psi_non_ref_coef_transp, (n_states,psi_det_si enddo END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_non_ref_coef, (psi_det_size,n_states) ] -&BEGIN_PROVIDER [ integer, idx_non_ref, (psi_det_size) ] -&BEGIN_PROVIDER [ integer, idx_non_ref_rev, (psi_det_size) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref, (N_int,2,N_det) ] +&BEGIN_PROVIDER [ double precision, psi_non_ref_coef, (N_det,n_states) ] +&BEGIN_PROVIDER [ integer, idx_non_ref, (N_det) ] +&BEGIN_PROVIDER [ integer, idx_non_ref_rev, (N_det) ] &BEGIN_PROVIDER [ integer, N_det_non_ref ] implicit none BEGIN_DOC @@ -102,8 +102,8 @@ END_PROVIDER endif END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref_restart, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_non_ref_coef_restart, (psi_det_size,n_states) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref_restart, (N_int,2,N_det) ] +&BEGIN_PROVIDER [ double precision, psi_non_ref_coef_restart, (N_det,n_states) ] implicit none BEGIN_DOC ! Set of determinants which are not part of the reference, defined from the application @@ -144,8 +144,8 @@ END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref_sorted_bit, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_non_ref_coef_sorted_bit, (psi_det_size,N_states) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref_sorted_bit, (N_int,2,N_det) ] +&BEGIN_PROVIDER [ double precision, psi_non_ref_coef_sorted_bit, (N_det,N_states) ] implicit none BEGIN_DOC ! Reference determinants sorted to accelerate the search of a random determinant in the wave diff --git a/src/selectors_utils/selectors.irp.f b/src/selectors_utils/selectors.irp.f index 92366d1d..765bd5e8 100644 --- a/src/selectors_utils/selectors.irp.f +++ b/src/selectors_utils/selectors.irp.f @@ -2,7 +2,7 @@ use bitmasks BEGIN_PROVIDER [ integer, psi_selectors_size ] implicit none - psi_selectors_size = psi_det_size + psi_selectors_size = N_det END_PROVIDER BEGIN_PROVIDER [ double precision, psi_selectors_coef_transp, (N_states,psi_selectors_size) ] diff --git a/src/single_ref_method/generators.irp.f b/src/single_ref_method/generators.irp.f index ce71f996..dd6985a5 100644 --- a/src/single_ref_method/generators.irp.f +++ b/src/single_ref_method/generators.irp.f @@ -9,8 +9,8 @@ BEGIN_PROVIDER [ integer, N_det_generators ] N_det_generators = 1 END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,N_det) ] +&BEGIN_PROVIDER [ double precision, psi_coef_generators, (N_det,N_states) ] implicit none BEGIN_DOC ! For Single reference wave functions, the generator is the From eaf34675c2336151b124e61bac738712f13e0048 Mon Sep 17 00:00:00 2001 From: ydamour Date: Thu, 12 May 2022 19:58:23 +0200 Subject: [PATCH 17/80] another useless bitstring_to_list --- src/determinants/slater_rules_wee_mono.irp.f | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/determinants/slater_rules_wee_mono.irp.f b/src/determinants/slater_rules_wee_mono.irp.f index 4c1c9330..7c2ad148 100644 --- a/src/determinants/slater_rules_wee_mono.irp.f +++ b/src/determinants/slater_rules_wee_mono.irp.f @@ -282,9 +282,7 @@ subroutine i_H_j_two_e(key_i,key_j,Nint,hij) double precision :: get_two_e_integral integer :: m,n,p,q integer :: i,j,k - integer :: occ(Nint*bit_kind_size,2) double precision :: diag_H_mat_elem, phase,phase_2 - integer :: n_occ_ab(2) PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals ref_bitmask_two_e_energy ASSERT (Nint > 0) @@ -342,7 +340,6 @@ subroutine i_H_j_two_e(key_i,key_j,Nint,hij) case (1) call get_single_excitation(key_i,key_j,exc,phase,Nint) !DIR$ FORCEINLINE - call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) if (exc(0,1,1) == 1) then ! Mono alpha m = exc(1,1,1) From bcb334afd295aea112ab46b3e17247df7c929d2c Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 12 May 2022 12:32:28 +0200 Subject: [PATCH 18/80] Changed order of tests --- src/fci/40.fci.bats | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/fci/40.fci.bats b/src/fci/40.fci.bats index 9b99d865..c303ea87 100644 --- a/src/fci/40.fci.bats +++ b/src/fci/40.fci.bats @@ -40,13 +40,6 @@ function run_stoch() { run_stoch -49.14104086 0.0001 10000 } -@test "F2" { # 0:03:34 - [[ -n $TRAVIS ]] && skip - qp set_file f2.ezfio - qp set_frozen_core - run_stoch -199.30821487 0.002 100000 -} - @test "NH3" { # 0:00:11 qp set_file nh3.ezfio qp set_mo_class --core="[1-4]" --act="[5-72]" @@ -186,3 +179,10 @@ function run_stoch() { run_stoch -93.09855896 5.e-4 50000 } +@test "F2" { # 0:03:34 + [[ -n $TRAVIS ]] && skip + qp set_file f2.ezfio + qp set_frozen_core + run_stoch -199.30821487 0.002 100000 +} + From 1f81de5bd4c2788dfdec8193feb3c9fa8631fdd5 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 13 May 2022 10:11:17 +0200 Subject: [PATCH 19/80] Additional check in run_selection_slave --- src/cipsi/run_selection_slave.irp.f | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/cipsi/run_selection_slave.irp.f b/src/cipsi/run_selection_slave.irp.f index 91bd3a38..de7c209c 100644 --- a/src/cipsi/run_selection_slave.irp.f +++ b/src/cipsi/run_selection_slave.irp.f @@ -61,10 +61,14 @@ subroutine run_selection_slave(thread,iproc,energy) if (N /= buf%N) then print *, 'N=', N print *, 'buf%N=', buf%N - print *, 'bug in ', irp_here - stop '-1' + print *, 'In ', irp_here, ': N /= buf%N' + stop -1 end if end if + if (i_generator > N_det_generators) then + print *, 'In ', irp_here, ': i_generator > N_det_generators' + stop -1 + endif call select_connected(i_generator,energy,pt2_data,buf,subset,pt2_F(i_generator)) endif From 135082dd7d72d44c4724ac121f090ee3b2e7661d Mon Sep 17 00:00:00 2001 From: ydamour Date: Fri, 13 May 2022 18:07:40 +0200 Subject: [PATCH 20/80] duplication if N_det in OMP section --- src/perturbation/selection.irp.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/perturbation/selection.irp.f b/src/perturbation/selection.irp.f index 67422226..d5947d25 100644 --- a/src/perturbation/selection.irp.f +++ b/src/perturbation/selection.irp.f @@ -90,7 +90,7 @@ subroutine remove_small_contributions enddo !$OMP PARALLEL DEFAULT(NONE) & !$OMP PRIVATE(i,j,i_H_psi_array) & - !$OMP SHARED(k,psi_det_sorted,psi_coef_sorted,N_int,N_det,N_det,N_states, & + !$OMP SHARED(k,psi_det_sorted,psi_coef_sorted,N_int,N_det,N_states, & !$OMP selection_criterion_min,keep,N_det_generators) & !$OMP REDUCTION(+:N_removed) !$OMP DO From 29c0dc2e2fdcb029dd6e04f2cc3288d46db162aa Mon Sep 17 00:00:00 2001 From: ydamour Date: Fri, 13 May 2022 18:50:54 +0200 Subject: [PATCH 21/80] fix bug save_wavefunction_general --- src/determinants/determinants.irp.f | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/determinants/determinants.irp.f b/src/determinants/determinants.irp.f index d9e1303e..36da8c07 100644 --- a/src/determinants/determinants.irp.f +++ b/src/determinants/determinants.irp.f @@ -503,11 +503,12 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef) integer :: i,j,k, ndet_qp_edit if (mpi_master) then + ndet_qp_edit = min(ndet,10000) call ezfio_set_determinants_N_int(N_int) call ezfio_set_determinants_bit_kind(bit_kind) call ezfio_set_determinants_N_det(ndet) - call ezfio_set_determinants_N_det_qp_edit(min(ndet,10000)) + call ezfio_set_determinants_N_det_qp_edit(ndet_qp_edit) call ezfio_set_determinants_n_states(nstates) call ezfio_set_determinants_mo_label(mo_label) From eda7ea74407cb600e033c289ecd285a5b60b73aa Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 16 May 2022 13:47:55 +0200 Subject: [PATCH 22/80] Removed docker files --- drone/Docker/README.md | 8 -------- drone/Docker/Ubuntu/Dockerfile | 27 --------------------------- drone/compilation.sh | 16 ---------------- drone/configuration.sh | 10 ---------- drone/drone_docker.yml | 30 ------------------------------ drone/drone_ssh.yml | 29 ----------------------------- drone/testing.sh | 16 ---------------- src/cisd/30.cisd.bats | 2 +- 8 files changed, 1 insertion(+), 137 deletions(-) delete mode 100644 drone/Docker/README.md delete mode 100644 drone/Docker/Ubuntu/Dockerfile delete mode 100755 drone/compilation.sh delete mode 100755 drone/configuration.sh delete mode 100644 drone/drone_docker.yml delete mode 100644 drone/drone_ssh.yml delete mode 100755 drone/testing.sh diff --git a/drone/Docker/README.md b/drone/Docker/README.md deleted file mode 100644 index eb569777..00000000 --- a/drone/Docker/README.md +++ /dev/null @@ -1,8 +0,0 @@ -Docker files to build the containers used with DroneCI. - -Example: -``` -docker build -t ubuntu/qp2_env . - -``` - diff --git a/drone/Docker/Ubuntu/Dockerfile b/drone/Docker/Ubuntu/Dockerfile deleted file mode 100644 index 05d87ad8..00000000 --- a/drone/Docker/Ubuntu/Dockerfile +++ /dev/null @@ -1,27 +0,0 @@ -ARG UBUNTU_VERSION=20.04 -FROM ubuntu:${UBUNTU_VERSION} AS builder - -# Timezone for tzdata -ARG tz=Etc/UTC -RUN echo $tz > /etc/timezone && rm -rf /etc/localtime - -# Install -RUN apt-get update && DEBIAN_FRONTEND=noninteractive apt-get install -y \ - git \ - curl \ - wget \ - python3 \ - gfortran \ - gcc \ - g++ \ - make \ - build-essential \ - rsync \ - unzip \ - libopenblas-dev \ - pkg-config \ - m4 - -RUN ln -s /usr/bin/python3 /usr/bin/python - - diff --git a/drone/compilation.sh b/drone/compilation.sh deleted file mode 100755 index 071b4872..00000000 --- a/drone/compilation.sh +++ /dev/null @@ -1,16 +0,0 @@ -#!/bin/bash -# Stage 2 - -# Extract cache from config stage -cd ../ -tar -zxf $HOME/cache/config.tgz - -# Configure QP2 -cd qp2 -source ./quantum_package.rc -ninja -j 1 -v || exit -1 - -# Create cache -cd .. -tar -zcf $HOME/cache/compil.tgz qp2 && rm $HOME/cache/config.tgz - diff --git a/drone/configuration.sh b/drone/configuration.sh deleted file mode 100755 index f925107d..00000000 --- a/drone/configuration.sh +++ /dev/null @@ -1,10 +0,0 @@ -#!/bin/bash -# Stage 1 - -# Configure QP2 -./configure --download all --install all --config ./config/travis.cfg || exit -1 - -# Create cache -cd ../ -tar -zcf $HOME/cache/config.tgz qp2 - diff --git a/drone/drone_docker.yml b/drone/drone_docker.yml deleted file mode 100644 index d1eb7175..00000000 --- a/drone/drone_docker.yml +++ /dev/null @@ -1,30 +0,0 @@ ---- -kind: pipeline -type: docker -name: default - -clone: - depth: 10 - -steps: -- name: configure - pull: never - image: ubuntu/qp2_env - commands: - - ./configure -i all -c ./config/gfortran_debug.cfg - - source quantum_package.rc ; qp plugins download https://gitlab.com/scemama/qp_plugins_scemama - - source quantum_package.rc ; qp plugins install champ - -- name: compile - pull: never - image: ubuntu/qp2_env - commands: - - ninja - -- name: testing - pull: never - image: ubuntu/qp2_env - commands: - - qp test - - diff --git a/drone/drone_ssh.yml b/drone/drone_ssh.yml deleted file mode 100644 index 99397f11..00000000 --- a/drone/drone_ssh.yml +++ /dev/null @@ -1,29 +0,0 @@ -kind: pipeline -type: ssh -name: default - -clone: - depth: 10 - -server: - host: 130.120.229.139 - user: test - password: - from_secret: ssh_pass - -steps: -- name: configure - commands: - - ./configure -i all -c ./config/gfortran_debug.cfg - - source quantum_package.rc ; qp plugins download https://gitlab.com/scemama/qp_plugins_scemama - - source quantum_package.rc ; qp plugins install champ - -- name: compile - commands: - - ninja - -- name: testing - commands: - - qp test - - diff --git a/drone/testing.sh b/drone/testing.sh deleted file mode 100755 index f67bd106..00000000 --- a/drone/testing.sh +++ /dev/null @@ -1,16 +0,0 @@ -#!/bin/bash -# Stage 3 - -# Extract cache from compile stage -cd ../ -tar -zxf $HOME/cache/compil.tgz - -# Configure QP2 -cd qp2 -source ./quantum_package.rc -exec qp_test -a && rm $HOME/cache/compil.tgz - - - - - diff --git a/src/cisd/30.cisd.bats b/src/cisd/30.cisd.bats index 58d996f8..6e110aa3 100644 --- a/src/cisd/30.cisd.bats +++ b/src/cisd/30.cisd.bats @@ -77,7 +77,7 @@ function run() { [[ -n $TRAVIS ]] && skip qp set_file ch4.ezfio qp set_mo_class --core="[1]" --act="[2-30]" --del="[31-59]" - run -40.2403962667047 -39.8433221754964 + run -40.2403962667047 -39.843315 } @test "SiH3" { # 20.2202s 1.38648m From 62dbf1194249cde77526aea436d83897299c408c Mon Sep 17 00:00:00 2001 From: ydamour Date: Thu, 19 May 2022 10:28:05 +0200 Subject: [PATCH 23/80] update au to eV --- src/cis/cis.irp.f | 2 +- src/cisd/cisd.irp.f | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/cis/cis.irp.f b/src/cis/cis.irp.f index f72197c2..57bf7789 100644 --- a/src/cis/cis.irp.f +++ b/src/cis/cis.irp.f @@ -74,7 +74,7 @@ subroutine run print*,'******************************************************' print*,'Excitation energies (au) (eV)' do i = 2, N_states - print*, i ,CI_energy(i) - CI_energy(1), (CI_energy(i) - CI_energy(1))/0.0367502d0 + print*, i ,CI_energy(i) - CI_energy(1), (CI_energy(i) - CI_energy(1)) * 27.211396641308d0 enddo print*,'' endif diff --git a/src/cisd/cisd.irp.f b/src/cisd/cisd.irp.f index fca3b10e..a6211d20 100644 --- a/src/cisd/cisd.irp.f +++ b/src/cisd/cisd.irp.f @@ -95,8 +95,8 @@ subroutine run print*,'******************************' print*,'Excitation energies (eV) (CISD+Q)' do i = 2, N_states - print*, i ,(CI_energy(i) - CI_energy(1))/0.0367502d0, & - (cisdq(i) - cisdq(1)) / 0.0367502d0 + print*, i ,(CI_energy(i) - CI_energy(1))*27.211396641308d0, & + (cisdq(i) - cisdq(1)) * 27.211396641308d0 enddo endif From f4512851bfc354144ad696e677cbf5d8fe135396 Mon Sep 17 00:00:00 2001 From: ydamour Date: Thu, 19 May 2022 10:42:29 +0200 Subject: [PATCH 24/80] provder for Ha to eV --- src/cis/cis.irp.f | 2 +- src/cisd/cisd.irp.f | 4 ++-- src/iterations/print_extrapolation.irp.f | 2 +- src/iterations/print_summary.irp.f | 12 ++++++------ src/utils/units.irp.f | 10 ++++++++++ 5 files changed, 20 insertions(+), 10 deletions(-) create mode 100644 src/utils/units.irp.f diff --git a/src/cis/cis.irp.f b/src/cis/cis.irp.f index 57bf7789..2b16a5f7 100644 --- a/src/cis/cis.irp.f +++ b/src/cis/cis.irp.f @@ -74,7 +74,7 @@ subroutine run print*,'******************************************************' print*,'Excitation energies (au) (eV)' do i = 2, N_states - print*, i ,CI_energy(i) - CI_energy(1), (CI_energy(i) - CI_energy(1)) * 27.211396641308d0 + print*, i ,CI_energy(i) - CI_energy(1), (CI_energy(i) - CI_energy(1)) * ha_to_ev enddo print*,'' endif diff --git a/src/cisd/cisd.irp.f b/src/cisd/cisd.irp.f index a6211d20..6137643c 100644 --- a/src/cisd/cisd.irp.f +++ b/src/cisd/cisd.irp.f @@ -95,8 +95,8 @@ subroutine run print*,'******************************' print*,'Excitation energies (eV) (CISD+Q)' do i = 2, N_states - print*, i ,(CI_energy(i) - CI_energy(1))*27.211396641308d0, & - (cisdq(i) - cisdq(1)) * 27.211396641308d0 + print*, i ,(CI_energy(i) - CI_energy(1)) * ha_to_ev, & + (cisdq(i) - cisdq(1)) * ha_to_ev enddo endif diff --git a/src/iterations/print_extrapolation.irp.f b/src/iterations/print_extrapolation.irp.f index e07cc1ed..7f602ffb 100644 --- a/src/iterations/print_extrapolation.irp.f +++ b/src/iterations/print_extrapolation.irp.f @@ -35,7 +35,7 @@ subroutine print_extrapolated_energy do k=2,min(N_iter,8) write(*,'(F11.4,X,3(X,F18.8))') pt2_iterations(i,N_iter+1-k), extrapolated_energy(k,i), & extrapolated_energy(k,i) - extrapolated_energy(k,1), & - (extrapolated_energy(k,i) - extrapolated_energy(k,1) ) * 27.211396641308d0 + (extrapolated_energy(k,i) - extrapolated_energy(k,1) ) * ha_to_ev enddo write(*,*) '=========== ', '=================== ', '=================== ', '===================' enddo diff --git a/src/iterations/print_summary.irp.f b/src/iterations/print_summary.irp.f index 8e6285e2..a0db3534 100644 --- a/src/iterations/print_summary.irp.f +++ b/src/iterations/print_summary.irp.f @@ -36,7 +36,7 @@ subroutine print_summary(e_,pt2_data,pt2_data_err,n_det_,n_configuration_,n_st,s write(*,fmt) '# E ', e_(1:N_states_p) if (N_states_p > 1) then write(*,fmt) '# Excit. (au)', e_(1:N_states_p)-e_(1) - write(*,fmt) '# Excit. (eV)', (e_(1:N_states_p)-e_(1))*27.211396641308d0 + write(*,fmt) '# Excit. (eV)', (e_(1:N_states_p)-e_(1))*ha_to_ev endif write(fmt,*) '(A13,', 2*N_states_p, '(1X,F14.8))' write(*,fmt) '# PT2 '//pt2_string, (pt2_data % pt2(k), pt2_data_err % pt2(k), k=1,N_states_p) @@ -47,8 +47,8 @@ subroutine print_summary(e_,pt2_data,pt2_data_err,n_det_,n_configuration_,n_st,s if (N_states_p > 1) then write(*,fmt) '# Excit. (au)', ( (e_(k)+pt2_data % pt2(k)-e_(1)-pt2_data % pt2(1)), & dsqrt(pt2_data_err % pt2(k)*pt2_data_err % pt2(k)+pt2_data_err % pt2(1)*pt2_data_err % pt2(1)), k=1,N_states_p) - write(*,fmt) '# Excit. (eV)', ( (e_(k)+pt2_data % pt2(k)-e_(1)-pt2_data % pt2(1))*27.211396641308d0, & - dsqrt(pt2_data_err % pt2(k)*pt2_data_err % pt2(k)+pt2_data_err % pt2(1)*pt2_data_err % pt2(1))*27.211396641308d0, k=1,N_states_p) + write(*,fmt) '# Excit. (eV)', ( (e_(k)+pt2_data % pt2(k)-e_(1)-pt2_data % pt2(1))*ha_to_ev, & + dsqrt(pt2_data_err % pt2(k)*pt2_data_err % pt2(k)+pt2_data_err % pt2(1)*pt2_data_err % pt2(1))*ha_to_ev, k=1,N_states_p) endif write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))' write(*,fmt) @@ -82,19 +82,19 @@ subroutine print_summary(e_,pt2_data,pt2_data_err,n_det_,n_configuration_,n_st,s print *, 'Variational Energy difference (au | eV)' do i=2, N_states_p print*,'Delta E = ', (e_(i) - e_(1)), & - (e_(i) - e_(1)) * 27.211396641308d0 + (e_(i) - e_(1)) * ha_to_ev enddo print *, '-----' print*, 'Variational + perturbative Energy difference (au | eV)' do i=2, N_states_p print*,'Delta E = ', (e_(i)+ pt2_data % pt2(i) - (e_(1) + pt2_data % pt2(1))), & - (e_(i)+ pt2_data % pt2(i) - (e_(1) + pt2_data % pt2(1))) * 27.211396641308d0 + (e_(i)+ pt2_data % pt2(i) - (e_(1) + pt2_data % pt2(1))) * ha_to_ev enddo print *, '-----' print*, 'Variational + renormalized perturbative Energy difference (au | eV)' do i=2, N_states_p print*,'Delta E = ', (e_(i)+ pt2_data % rpt2(i) - (e_(1) + pt2_data % rpt2(1))), & - (e_(i)+ pt2_data % rpt2(i) - (e_(1) + pt2_data % rpt2(1))) * 27.211396641308d0 + (e_(i)+ pt2_data % rpt2(i) - (e_(1) + pt2_data % rpt2(1))) * ha_to_ev enddo endif diff --git a/src/utils/units.irp.f b/src/utils/units.irp.f new file mode 100644 index 00000000..914fd041 --- /dev/null +++ b/src/utils/units.irp.f @@ -0,0 +1,10 @@ +BEGIN_PROVIDER [double precision, ha_to_ev] + + implicit none + BEGIN_DOC + ! Converstion from Hartree to eV + END_DOC + + ha_to_ev = 27.211396641308d0 + +END_PROVIDER From 7a67d69c0a794bbb0e6cbe24a5b9a62142479f44 Mon Sep 17 00:00:00 2001 From: ydamour Date: Thu, 19 May 2022 11:12:20 +0200 Subject: [PATCH 25/80] au to Debye --- src/determinants/dipole_moments.irp.f | 10 +++++++--- src/utils/units.irp.f | 12 ++++++++++++ 2 files changed, 19 insertions(+), 3 deletions(-) diff --git a/src/determinants/dipole_moments.irp.f b/src/determinants/dipole_moments.irp.f index 06fca0cd..b411dda4 100644 --- a/src/determinants/dipole_moments.irp.f +++ b/src/determinants/dipole_moments.irp.f @@ -66,9 +66,13 @@ END_PROVIDER write(*,'(i16)',advance='no') i end do write(*,*) '' - write(*,'(A17,100(1pE16.8))') 'x_dipole_moment = ',x_dipole_moment - write(*,'(A17,100(1pE16.8))') 'y_dipole_moment = ',y_dipole_moment - write(*,'(A17,100(1pE16.8))') 'z_dipole_moment = ',z_dipole_moment + write(*,'(A23,100(1pE16.8))') 'x_dipole_moment (au) = ',x_dipole_moment + write(*,'(A23,100(1pE16.8))') 'y_dipole_moment (au) = ',y_dipole_moment + write(*,'(A23,100(1pE16.8))') 'z_dipole_moment (au) = ',z_dipole_moment + write(*,*) '' + write(*,'(A23,100(1pE16.8))') 'x_dipole_moment (D) = ',x_dipole_moment * au_to_D + write(*,'(A23,100(1pE16.8))') 'y_dipole_moment (D) = ',y_dipole_moment * au_to_D + write(*,'(A23,100(1pE16.8))') 'z_dipole_moment (D) = ',z_dipole_moment * au_to_D !print*, 'x_dipole_moment = ',x_dipole_moment !print*, 'y_dipole_moment = ',y_dipole_moment !print*, 'z_dipole_moment = ',z_dipole_moment diff --git a/src/utils/units.irp.f b/src/utils/units.irp.f index 914fd041..1850b28b 100644 --- a/src/utils/units.irp.f +++ b/src/utils/units.irp.f @@ -8,3 +8,15 @@ BEGIN_PROVIDER [double precision, ha_to_ev] ha_to_ev = 27.211396641308d0 END_PROVIDER + +BEGIN_PROVIDER [double precision, au_to_D] + + implicit none + BEGIN_DOC + ! Converstion from au to Debye + END_DOC + + au_to_D = 2.5415802529d0 + +END_PROVIDER + From ec39cad837eb5deea739b96ad63e63a11b2aba7b Mon Sep 17 00:00:00 2001 From: ydamour Date: Thu, 19 May 2022 11:12:39 +0200 Subject: [PATCH 26/80] cisd(q) only if n_elec >= 4 --- src/cisd/cisd.irp.f | 59 ++++++++++++++++++++++++++++++--------------- 1 file changed, 39 insertions(+), 20 deletions(-) diff --git a/src/cisd/cisd.irp.f b/src/cisd/cisd.irp.f index 6137643c..5f167686 100644 --- a/src/cisd/cisd.irp.f +++ b/src/cisd/cisd.irp.f @@ -69,7 +69,9 @@ subroutine run do i = 1,N_states k = maxloc(dabs(psi_coef_sorted(1:N_det,i)),dim=1) delta_E = CI_electronic_energy(i) - diag_h_mat_elem(psi_det_sorted(1,1,k),N_int) - cisdq(i) = CI_energy(i) + delta_E * (1.d0 - psi_coef_sorted(k,i)**2) + if (elec_alpha_num + elec_beta_num >= 4) then + cisdq(i) = CI_energy(i) + delta_E * (1.d0 - psi_coef_sorted(k,i)**2) + endif enddo print *, 'N_det = ', N_det print*,'' @@ -78,26 +80,43 @@ subroutine run do i = 1,N_states print *, i, CI_energy(i) enddo - print*,'' - print*,'******************************' - print *, 'CISD+Q Energies' - do i = 1,N_states - print *, i, cisdq(i) - enddo + if (elec_alpha_num + elec_beta_num >= 4) then + print*,'' + print*,'******************************' + print *, 'CISD+Q Energies' + do i = 1,N_states + print *, i, cisdq(i) + enddo + endif if (N_states > 1) then - print*,'' - print*,'******************************' - print*,'Excitation energies (au) (CISD+Q)' - do i = 2, N_states - print*, i ,CI_energy(i) - CI_energy(1), cisdq(i) - cisdq(1) - enddo - print*,'' - print*,'******************************' - print*,'Excitation energies (eV) (CISD+Q)' - do i = 2, N_states - print*, i ,(CI_energy(i) - CI_energy(1)) * ha_to_ev, & - (cisdq(i) - cisdq(1)) * ha_to_ev - enddo + if (elec_alpha_num + elec_beta_num >= 4) then + print*,'' + print*,'******************************' + print*,'Excitation energies (au) (CISD+Q)' + do i = 2, N_states + print*, i ,CI_energy(i) - CI_energy(1), cisdq(i) - cisdq(1) + enddo + print*,'' + print*,'******************************' + print*,'Excitation energies (eV) (CISD+Q)' + do i = 2, N_states + print*, i ,(CI_energy(i) - CI_energy(1)) * ha_to_ev, & + (cisdq(i) - cisdq(1)) * ha_to_ev + enddo + else + print*,'' + print*,'******************************' + print*,'Excitation energies (au) (CISD)' + do i = 2, N_states + print*, i ,CI_energy(i) - CI_energy(1) + enddo + print*,'' + print*,'******************************' + print*,'Excitation energies (eV) (CISD)' + do i = 2, N_states + print*, i ,(CI_energy(i) - CI_energy(1)) * ha_to_ev + enddo + endif endif end From a52a084f583a7bad79394aa279df421a00cd80de Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 25 May 2022 13:34:56 +0200 Subject: [PATCH 27/80] Revert "Replaces psi_det_size by N_det" This reverts commit 6224e449ca2f1850152e2fdc46f838806e1b5907. --- src/csf/configurations.irp.f | 2 +- src/davidson/davidson_parallel.irp.f | 2 +- src/davidson/davidson_parallel_csf.irp.f | 2 +- src/davidson/davidson_parallel_nos2.irp.f | 2 +- src/davidson/u0_hs2_u0.irp.f | 2 +- src/davidson/u0_wee_u0.irp.f | 2 +- src/determinants/determinants.irp.f | 69 ++++++++++++++++++----- src/determinants/h_apply.irp.f | 7 ++- src/determinants/psi_cas.irp.f | 20 +++---- src/determinants/s2.irp.f | 2 +- src/determinants/spindeterminants.irp.f | 6 +- src/determinants/zmq.irp.f | 27 ++++++--- src/generators_cas/generators.irp.f | 10 ++-- src/generators_full/generators.irp.f | 10 ++-- src/perturbation/selection.irp.f | 4 +- src/psiref_cas/psi_ref.irp.f | 12 ++-- src/psiref_utils/psi_ref_utils.irp.f | 26 ++++----- src/selectors_utils/selectors.irp.f | 2 +- src/single_ref_method/generators.irp.f | 4 +- 19 files changed, 132 insertions(+), 79 deletions(-) diff --git a/src/csf/configurations.irp.f b/src/csf/configurations.irp.f index 3ecaa517..ce5d48ab 100644 --- a/src/csf/configurations.irp.f +++ b/src/csf/configurations.irp.f @@ -332,7 +332,7 @@ subroutine configuration_to_dets_tree_addressing(o,d,sze,n_alpha,Nint) end - BEGIN_PROVIDER [ integer(bit_kind), psi_configuration, (N_int,2,N_det) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_configuration, (N_int,2,psi_det_size) ] &BEGIN_PROVIDER [ integer, N_configuration ] implicit none BEGIN_DOC diff --git a/src/davidson/davidson_parallel.irp.f b/src/davidson/davidson_parallel.irp.f index b642d7a4..e627dfc9 100644 --- a/src/davidson/davidson_parallel.irp.f +++ b/src/davidson/davidson_parallel.irp.f @@ -99,7 +99,7 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze, integer :: rc, ni, nj integer*8 :: rc8 - integer :: N_states_read, N_det_read + integer :: N_states_read, N_det_read, psi_det_size_read integer :: N_det_selectors_read, N_det_generators_read integer, external :: zmq_get_dvector diff --git a/src/davidson/davidson_parallel_csf.irp.f b/src/davidson/davidson_parallel_csf.irp.f index 8a8fcc4a..d8e9bffa 100644 --- a/src/davidson/davidson_parallel_csf.irp.f +++ b/src/davidson/davidson_parallel_csf.irp.f @@ -99,7 +99,7 @@ subroutine davidson_csf_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, integer :: rc, ni, nj integer*8 :: rc8 - integer :: N_states_read, N_det_read + integer :: N_states_read, N_det_read, psi_det_size_read integer :: N_det_selectors_read, N_det_generators_read integer, external :: zmq_get_dvector diff --git a/src/davidson/davidson_parallel_nos2.irp.f b/src/davidson/davidson_parallel_nos2.irp.f index dcc9687d..597b001f 100644 --- a/src/davidson/davidson_parallel_nos2.irp.f +++ b/src/davidson/davidson_parallel_nos2.irp.f @@ -99,7 +99,7 @@ subroutine davidson_nos2_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, integer :: rc, ni, nj integer*8 :: rc8 - integer :: N_states_read, N_det_read + integer :: N_states_read, N_det_read, psi_det_size_read integer :: N_det_selectors_read, N_det_generators_read integer, external :: zmq_get_dvector diff --git a/src/davidson/u0_hs2_u0.irp.f b/src/davidson/u0_hs2_u0.irp.f index e67777e7..38fb56bd 100644 --- a/src/davidson/u0_hs2_u0.irp.f +++ b/src/davidson/u0_hs2_u0.irp.f @@ -6,7 +6,7 @@ ! ! psi_s2(i) = $\langle \Psi_i | S^2 | \Psi_i \rangle$ END_DOC - call u_0_HS2_u_0(psi_energy,psi_s2,psi_coef,N_det,psi_det,N_int,N_states,N_det) + call u_0_HS2_u_0(psi_energy,psi_s2,psi_coef,N_det,psi_det,N_int,N_states,psi_det_size) integer :: i do i=N_det+1,N_states psi_energy(i) = 0.d0 diff --git a/src/davidson/u0_wee_u0.irp.f b/src/davidson/u0_wee_u0.irp.f index e53d76ea..0c543aca 100644 --- a/src/davidson/u0_wee_u0.irp.f +++ b/src/davidson/u0_wee_u0.irp.f @@ -4,7 +4,7 @@ BEGIN_PROVIDER [ double precision, psi_energy_two_e, (N_states) ] ! Energy of the current wave function END_DOC integer :: i,j - call u_0_H_u_0_two_e(psi_energy_two_e,psi_coef,N_det,psi_det,N_int,N_states,N_det) + call u_0_H_u_0_two_e(psi_energy_two_e,psi_coef,N_det,psi_det,N_int,N_states,psi_det_size) do i=N_det+1,N_states psi_energy_two_e(i) = 0.d0 enddo diff --git a/src/determinants/determinants.irp.f b/src/determinants/determinants.irp.f index 36da8c07..4b317025 100644 --- a/src/determinants/determinants.irp.f +++ b/src/determinants/determinants.irp.f @@ -70,7 +70,42 @@ BEGIN_PROVIDER [integer, max_degree_exc] enddo END_PROVIDER -BEGIN_PROVIDER [ integer(bit_kind), psi_det, (N_int,2,N_det) ] +BEGIN_PROVIDER [ integer, psi_det_size ] + implicit none + BEGIN_DOC + ! Size of the psi_det and psi_coef arrays + END_DOC + PROVIDE ezfio_filename + logical :: exists + psi_det_size = 1 + PROVIDE mpi_master + if (read_wf) then + if (mpi_master) then + call ezfio_has_determinants_n_det(exists) + if (exists) then + call ezfio_get_determinants_n_det(psi_det_size) + else + psi_det_size = 1 + endif + call write_int(6,psi_det_size,'Dimension of the psi arrays') + endif + IRP_IF MPI_DEBUG + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + IRP_ENDIF + IRP_IF MPI + include 'mpif.h' + integer :: ierr + call MPI_BCAST( psi_det_size, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read psi_det_size with MPI' + endif + IRP_ENDIF + endif + +END_PROVIDER + +BEGIN_PROVIDER [ integer(bit_kind), psi_det, (N_int,2,psi_det_size) ] implicit none BEGIN_DOC ! The determinants of the wave function. Initialized with Hartree-Fock if the |EZFIO| file @@ -141,7 +176,7 @@ END_PROVIDER -BEGIN_PROVIDER [ double precision, psi_coef, (N_det,N_states) ] +BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states) ] implicit none BEGIN_DOC ! The wave function coefficients. Initialized with Hartree-Fock if the |EZFIO| file @@ -154,7 +189,7 @@ BEGIN_PROVIDER [ double precision, psi_coef, (N_det,N_states) ] PROVIDE read_wf N_det mo_label ezfio_filename psi_coef = 0.d0 - do i=1,min(N_states,N_det) + do i=1,min(N_states,psi_det_size) psi_coef(i,i) = 1.d0 enddo @@ -202,7 +237,7 @@ BEGIN_PROVIDER [ double precision, psi_coef, (N_det,N_states) ] END_PROVIDER -BEGIN_PROVIDER [ double precision, psi_average_norm_contrib, (N_det) ] +BEGIN_PROVIDER [ double precision, psi_average_norm_contrib, (psi_det_size) ] implicit none BEGIN_DOC ! Contribution of determinants to the state-averaged density. @@ -252,10 +287,10 @@ END_PROVIDER !==============================================================================! - BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted, (N_int,2,N_det) ] -&BEGIN_PROVIDER [ double precision, psi_coef_sorted, (N_det,N_states) ] -&BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_sorted, (N_det) ] -&BEGIN_PROVIDER [ integer, psi_det_sorted_order, (N_det) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_sorted, (psi_det_size,N_states) ] +&BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_sorted, (psi_det_size) ] +&BEGIN_PROVIDER [ integer, psi_det_sorted_order, (psi_det_size) ] implicit none BEGIN_DOC ! Wave function sorted by determinants contribution to the norm (state-averaged) @@ -284,12 +319,17 @@ END_PROVIDER psi_det_sorted_order(iorder(i)) = i enddo + psi_det_sorted(:,:,N_det+1:psi_det_size) = 0_bit_kind + psi_coef_sorted(N_det+1:psi_det_size,:) = 0.d0 + psi_average_norm_contrib_sorted(N_det+1:psi_det_size) = 0.d0 + psi_det_sorted_order(N_det+1:psi_det_size) = 0 + deallocate(iorder) END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_bit, (N_int,2,N_det) ] -&BEGIN_PROVIDER [ double precision, psi_coef_sorted_bit, (N_det,N_states) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_bit, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_sorted_bit, (psi_det_size,N_states) ] implicit none BEGIN_DOC ! Determinants on which we apply $\langle i|H|psi \rangle$ for perturbation. @@ -315,6 +355,9 @@ subroutine sort_dets_by_det_search_key(Ndet, det_in, coef_in, sze, det_out, coef ! Determinants are sorted according to their :c:func:`det_search_key`. ! Useful to accelerate the search of a random determinant in the wave ! function. + ! + ! /!\ The first dimension of coef_out and coef_in need to be psi_det_size + ! END_DOC integer :: i,j,k integer, allocatable :: iorder(:) @@ -448,11 +491,7 @@ subroutine save_wavefunction_truncated(thr) endif enddo if (mpi_master) then - call save_wavefunction_general(N_det_save, & - min(N_states,N_det_save), & - psi_det_sorted, & - size(psi_coef_sorted,1), & - psi_coef_sorted) + call save_wavefunction_general(N_det_save,min(N_states,N_det_save),psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted) endif end diff --git a/src/determinants/h_apply.irp.f b/src/determinants/h_apply.irp.f index 246ff209..d01ad1c7 100644 --- a/src/determinants/h_apply.irp.f +++ b/src/determinants/h_apply.irp.f @@ -159,7 +159,10 @@ subroutine copy_H_apply_buffer_to_wf enddo ! Update array sizes - TOUCH N_det + if (psi_det_size < N_det) then + psi_det_size = N_det + TOUCH psi_det_size + endif ! Restore backup in resized array do i=1,N_det_old @@ -177,7 +180,7 @@ subroutine copy_H_apply_buffer_to_wf !$OMP PARALLEL DEFAULT(SHARED) & !$OMP PRIVATE(j,k,i) FIRSTPRIVATE(N_det_old) & - !$OMP SHARED(N_int,H_apply_buffer,psi_det,psi_coef,N_states,N_det) + !$OMP SHARED(N_int,H_apply_buffer,psi_det,psi_coef,N_states,psi_det_size) j=0 !$ j=omp_get_thread_num() do k=0,j-1 diff --git a/src/determinants/psi_cas.irp.f b/src/determinants/psi_cas.irp.f index 125ec1e1..19a1c260 100644 --- a/src/determinants/psi_cas.irp.f +++ b/src/determinants/psi_cas.irp.f @@ -1,8 +1,8 @@ use bitmasks - BEGIN_PROVIDER [ integer(bit_kind), psi_cas, (N_int,2,N_det) ] -&BEGIN_PROVIDER [ double precision, psi_cas_coef, (N_det,n_states) ] -&BEGIN_PROVIDER [ integer, idx_cas, (N_det) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_cas, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_cas_coef, (psi_det_size,n_states) ] +&BEGIN_PROVIDER [ integer, idx_cas, (psi_det_size) ] &BEGIN_PROVIDER [ integer, N_det_cas ] implicit none BEGIN_DOC @@ -44,8 +44,8 @@ use bitmasks END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_cas_sorted_bit, (N_int,2,N_det) ] -&BEGIN_PROVIDER [ double precision, psi_cas_coef_sorted_bit, (N_det,N_states) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_cas_sorted_bit, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_cas_coef_sorted_bit, (psi_det_size,N_states) ] implicit none BEGIN_DOC ! |CAS| determinants sorted to accelerate the search of a random determinant in the wave @@ -58,9 +58,9 @@ END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_non_cas, (N_int,2,N_det) ] -&BEGIN_PROVIDER [ double precision, psi_non_cas_coef, (N_det,n_states) ] -&BEGIN_PROVIDER [ integer, idx_non_cas, (N_det) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_non_cas, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_non_cas_coef, (psi_det_size,n_states) ] +&BEGIN_PROVIDER [ integer, idx_non_cas, (psi_det_size) ] &BEGIN_PROVIDER [ integer, N_det_non_cas ] implicit none BEGIN_DOC @@ -97,8 +97,8 @@ END_PROVIDER N_det_non_cas = i_non_cas END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_non_cas_sorted_bit, (N_int,2,N_det) ] -&BEGIN_PROVIDER [ double precision, psi_non_cas_coef_sorted_bit, (N_det,N_states) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_non_cas_sorted_bit, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_non_cas_coef_sorted_bit, (psi_det_size,N_states) ] implicit none BEGIN_DOC ! |CAS| determinants sorted to accelerate the search of a random determinant in the wave diff --git a/src/determinants/s2.irp.f b/src/determinants/s2.irp.f index abae212f..2c1a8757 100644 --- a/src/determinants/s2.irp.f +++ b/src/determinants/s2.irp.f @@ -110,7 +110,7 @@ END_PROVIDER ! array of the averaged values of the S^2 operator on the various states END_DOC integer :: i - call u_0_S2_u_0(s2_values,psi_coef,n_det,psi_det,N_int,N_states,N_det) + call u_0_S2_u_0(s2_values,psi_coef,n_det,psi_det,N_int,N_states,psi_det_size) do i = 1, N_states s_values(i) = 0.5d0 *(-1.d0 + dsqrt(1.d0 + 4 * s2_values(i))) enddo diff --git a/src/determinants/spindeterminants.irp.f b/src/determinants/spindeterminants.irp.f index e4a857a9..dd55e112 100644 --- a/src/determinants/spindeterminants.irp.f +++ b/src/determinants/spindeterminants.irp.f @@ -24,7 +24,7 @@ integer*8 function spin_det_search_key(det,Nint) end -BEGIN_PROVIDER [ integer(bit_kind), psi_det_alpha, (N_int,N_det) ] +BEGIN_PROVIDER [ integer(bit_kind), psi_det_alpha, (N_int,psi_det_size) ] implicit none BEGIN_DOC ! List of $\alpha$ determinants of psi_det @@ -39,7 +39,7 @@ BEGIN_PROVIDER [ integer(bit_kind), psi_det_alpha, (N_int,N_det) ] END_PROVIDER -BEGIN_PROVIDER [ integer(bit_kind), psi_det_beta, (N_int,N_det) ] +BEGIN_PROVIDER [ integer(bit_kind), psi_det_beta, (N_int,psi_det_size) ] implicit none BEGIN_DOC ! List of $\beta$ determinants of psi_det @@ -56,7 +56,7 @@ END_PROVIDER BEGIN_TEMPLATE - BEGIN_PROVIDER [ integer(bit_kind), psi_det_$alpha_unique, (N_int,N_det) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_det_$alpha_unique, (N_int,psi_det_size) ] &BEGIN_PROVIDER [ integer, N_det_$alpha_unique ] implicit none BEGIN_DOC diff --git a/src/determinants/zmq.irp.f b/src/determinants/zmq.irp.f index 7288de05..5a114533 100644 --- a/src/determinants/zmq.irp.f +++ b/src/determinants/zmq.irp.f @@ -10,6 +10,7 @@ integer function zmq_put_psi(zmq_to_qp_run_socket,worker_id) integer, external :: zmq_put_N_states integer, external :: zmq_put_N_det + integer, external :: zmq_put_psi_det_size integer*8, external :: zmq_put_psi_det integer*8, external :: zmq_put_psi_coef @@ -22,6 +23,10 @@ integer function zmq_put_psi(zmq_to_qp_run_socket,worker_id) zmq_put_psi = -1 return endif + if (zmq_put_psi_det_size(zmq_to_qp_run_socket, worker_id) == -1) then + zmq_put_psi = -1 + return + endif if (zmq_put_psi_det(zmq_to_qp_run_socket, worker_id) == -1) then zmq_put_psi = -1 return @@ -46,6 +51,7 @@ integer function zmq_get_psi_notouch(zmq_to_qp_run_socket, worker_id) integer, external :: zmq_get_N_states integer, external :: zmq_get_N_det + integer, external :: zmq_get_psi_det_size integer*8, external :: zmq_get_psi_det integer*8, external :: zmq_get_psi_coef @@ -59,15 +65,19 @@ integer function zmq_get_psi_notouch(zmq_to_qp_run_socket, worker_id) zmq_get_psi_notouch = -1 return endif - - if (size(psi_det,kind=8) /= N_int*2_8*N_det*bit_kind) then - deallocate(psi_det) - allocate(psi_det(N_int,2,N_det)) + if (zmq_get_psi_det_size(zmq_to_qp_run_socket, worker_id) == -1) then + zmq_get_psi_notouch = -1 + return endif - if (size(psi_coef,kind=8) /= N_det*N_states) then + if (size(psi_det,kind=8) /= N_int*2_8*psi_det_size*bit_kind) then + deallocate(psi_det) + allocate(psi_det(N_int,2,psi_det_size)) + endif + + if (size(psi_coef,kind=8) /= psi_det_size*N_states) then deallocate(psi_coef) - allocate(psi_coef(N_det,N_states)) + allocate(psi_coef(psi_det_size,N_states)) endif if (zmq_get_psi_det(zmq_to_qp_run_socket, worker_id) == -1_8) then @@ -92,7 +102,7 @@ integer function zmq_get_psi(zmq_to_qp_run_socket, worker_id) integer, intent(in) :: worker_id integer, external :: zmq_get_psi_notouch zmq_get_psi = zmq_get_psi_notouch(zmq_to_qp_run_socket, worker_id) - SOFT_TOUCH psi_det psi_coef N_det N_states + SOFT_TOUCH psi_det psi_coef psi_det_size N_det N_states end @@ -256,7 +266,7 @@ integer function zmq_get_psi_bilinear(zmq_to_qp_run_socket, worker_id) return endif - SOFT_TOUCH psi_bilinear_matrix_values psi_bilinear_matrix_rows psi_bilinear_matrix_columns psi_bilinear_matrix_order psi_det psi_coef N_det N_states psi_det_beta_unique psi_det_alpha_unique N_det_beta_unique N_det_alpha_unique + SOFT_TOUCH psi_bilinear_matrix_values psi_bilinear_matrix_rows psi_bilinear_matrix_columns psi_bilinear_matrix_order psi_det psi_coef psi_det_size N_det N_states psi_det_beta_unique psi_det_alpha_unique N_det_beta_unique N_det_alpha_unique end @@ -364,6 +374,7 @@ N_states ;; N_det ;; N_det_alpha_unique ;; N_det_beta_unique ;; +psi_det_size ;; END_TEMPLATE diff --git a/src/generators_cas/generators.irp.f b/src/generators_cas/generators.irp.f index e499f703..b2f58202 100644 --- a/src/generators_cas/generators.irp.f +++ b/src/generators_cas/generators.irp.f @@ -20,11 +20,11 @@ BEGIN_PROVIDER [ integer, N_det_generators ] call write_int(6,N_det_generators,'Number of generators') END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,N_det) ] -&BEGIN_PROVIDER [ double precision, psi_coef_generators, (N_det,N_states) ] -&BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_gen, (N_int,2,N_det) ] -&BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen, (N_det,N_states) ] -&BEGIN_PROVIDER [ integer, psi_det_sorted_gen_order, (N_det) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ] +&BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_gen, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen, (psi_det_size,N_states) ] +&BEGIN_PROVIDER [ integer, psi_det_sorted_gen_order, (psi_det_size) ] implicit none BEGIN_DOC ! For Single reference wave functions, the generator is the diff --git a/src/generators_full/generators.irp.f b/src/generators_full/generators.irp.f index 376e5e3e..7f18947f 100644 --- a/src/generators_full/generators.irp.f +++ b/src/generators_full/generators.irp.f @@ -22,8 +22,8 @@ BEGIN_PROVIDER [ integer, N_det_generators ] call write_int(6,N_det_generators,'Number of generators') END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,N_det) ] -&BEGIN_PROVIDER [ double precision, psi_coef_generators, (N_det,N_states) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ] implicit none BEGIN_DOC ! For Single reference wave functions, the generator is the @@ -34,9 +34,9 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_gen, (N_int,2,N_det) ] -&BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen, (N_det,N_states) ] -&BEGIN_PROVIDER [ integer, psi_det_sorted_gen_order, (N_det) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_gen, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen, (psi_det_size,N_states) ] +&BEGIN_PROVIDER [ integer, psi_det_sorted_gen_order, (psi_det_size) ] implicit none BEGIN_DOC diff --git a/src/perturbation/selection.irp.f b/src/perturbation/selection.irp.f index d5947d25..f3f03673 100644 --- a/src/perturbation/selection.irp.f +++ b/src/perturbation/selection.irp.f @@ -90,12 +90,12 @@ subroutine remove_small_contributions enddo !$OMP PARALLEL DEFAULT(NONE) & !$OMP PRIVATE(i,j,i_H_psi_array) & - !$OMP SHARED(k,psi_det_sorted,psi_coef_sorted,N_int,N_det,N_states, & + !$OMP SHARED(k,psi_det_sorted,psi_coef_sorted,N_int,N_det,psi_det_size,N_states, & !$OMP selection_criterion_min,keep,N_det_generators) & !$OMP REDUCTION(+:N_removed) !$OMP DO do i=2*N_det_generators+1, N_det - call i_H_psi(psi_det_sorted(1,1,i),psi_det_sorted,psi_coef_sorted,N_int,min(N_det,2*N_det_generators),N_det,N_states,i_H_psi_array) + call i_H_psi(psi_det_sorted(1,1,i),psi_det_sorted,psi_coef_sorted,N_int,min(N_det,2*N_det_generators),psi_det_size,N_states,i_H_psi_array) keep(i) = .False. do j=1,N_states keep(i) = keep(i) .or. (-(psi_coef_sorted(i,j)*i_H_psi_array(j)) > selection_criterion_min) diff --git a/src/psiref_cas/psi_ref.irp.f b/src/psiref_cas/psi_ref.irp.f index 0e1df986..78dd2239 100644 --- a/src/psiref_cas/psi_ref.irp.f +++ b/src/psiref_cas/psi_ref.irp.f @@ -1,8 +1,8 @@ use bitmasks - BEGIN_PROVIDER [ integer(bit_kind), psi_ref, (N_int,2,N_det) ] -&BEGIN_PROVIDER [ double precision, psi_ref_coef, (N_det,n_states) ] -&BEGIN_PROVIDER [ integer, idx_ref, (N_det) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_ref, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_ref_coef, (psi_det_size,n_states) ] +&BEGIN_PROVIDER [ integer, idx_ref, (psi_det_size) ] &BEGIN_PROVIDER [ integer, N_det_ref ] implicit none BEGIN_DOC @@ -26,7 +26,7 @@ use bitmasks END_PROVIDER -BEGIN_PROVIDER [ double precision, psi_ref_coef_inv, (N_det,n_states) ] +BEGIN_PROVIDER [ double precision, psi_ref_coef_inv, (psi_det_size,n_states) ] implicit none BEGIN_DOC ! 1/psi_ref_coef @@ -41,8 +41,8 @@ BEGIN_PROVIDER [ double precision, psi_ref_coef_inv, (N_det,n_states) ] END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_ref_restart, (N_int,2,N_det) ] -&BEGIN_PROVIDER [ double precision, psi_ref_coef_restart, (N_det,n_states) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_ref_restart, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_ref_coef_restart, (psi_det_size,n_states) ] implicit none BEGIN_DOC ! Projection of the CAS wave function on the restart wave function. diff --git a/src/psiref_utils/psi_ref_utils.irp.f b/src/psiref_utils/psi_ref_utils.irp.f index 185d9778..19e42283 100644 --- a/src/psiref_utils/psi_ref_utils.irp.f +++ b/src/psiref_utils/psi_ref_utils.irp.f @@ -1,8 +1,8 @@ use bitmasks - BEGIN_PROVIDER [ integer(bit_kind), psi_ref_sorted_bit, (N_int,2,N_det) ] -&BEGIN_PROVIDER [ double precision, psi_ref_coef_sorted_bit, (N_det,N_states) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_ref_sorted_bit, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_ref_coef_sorted_bit, (psi_det_size,N_states) ] implicit none BEGIN_DOC ! Reference determinants sorted to accelerate the search of a random determinant in the wave @@ -14,7 +14,7 @@ use bitmasks END_PROVIDER -BEGIN_PROVIDER [ double precision, psi_ref_coef_transp, (n_states,N_det) ] +BEGIN_PROVIDER [ double precision, psi_ref_coef_transp, (n_states,psi_det_size) ] implicit none BEGIN_DOC ! Transposed psi_ref_coef @@ -27,7 +27,7 @@ BEGIN_PROVIDER [ double precision, psi_ref_coef_transp, (n_states,N_det) ] enddo END_PROVIDER -BEGIN_PROVIDER [ double precision, psi_ref_coef_normalized, (N_det,n_states) ] +BEGIN_PROVIDER [ double precision, psi_ref_coef_normalized, (psi_det_size,n_states) ] implicit none BEGIN_DOC ! Normalized coefficients of the reference @@ -43,7 +43,7 @@ BEGIN_PROVIDER [ double precision, psi_ref_coef_normalized, (N_det,n_states) ] END_PROVIDER -BEGIN_PROVIDER [ double precision, psi_non_ref_coef_transp, (n_states,N_det) ] +BEGIN_PROVIDER [ double precision, psi_non_ref_coef_transp, (n_states,psi_det_size) ] implicit none BEGIN_DOC ! Transposed psi_non_ref_coef @@ -56,10 +56,10 @@ BEGIN_PROVIDER [ double precision, psi_non_ref_coef_transp, (n_states,N_det) ] enddo END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref, (N_int,2,N_det) ] -&BEGIN_PROVIDER [ double precision, psi_non_ref_coef, (N_det,n_states) ] -&BEGIN_PROVIDER [ integer, idx_non_ref, (N_det) ] -&BEGIN_PROVIDER [ integer, idx_non_ref_rev, (N_det) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_non_ref_coef, (psi_det_size,n_states) ] +&BEGIN_PROVIDER [ integer, idx_non_ref, (psi_det_size) ] +&BEGIN_PROVIDER [ integer, idx_non_ref_rev, (psi_det_size) ] &BEGIN_PROVIDER [ integer, N_det_non_ref ] implicit none BEGIN_DOC @@ -102,8 +102,8 @@ END_PROVIDER endif END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref_restart, (N_int,2,N_det) ] -&BEGIN_PROVIDER [ double precision, psi_non_ref_coef_restart, (N_det,n_states) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref_restart, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_non_ref_coef_restart, (psi_det_size,n_states) ] implicit none BEGIN_DOC ! Set of determinants which are not part of the reference, defined from the application @@ -144,8 +144,8 @@ END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref_sorted_bit, (N_int,2,N_det) ] -&BEGIN_PROVIDER [ double precision, psi_non_ref_coef_sorted_bit, (N_det,N_states) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref_sorted_bit, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_non_ref_coef_sorted_bit, (psi_det_size,N_states) ] implicit none BEGIN_DOC ! Reference determinants sorted to accelerate the search of a random determinant in the wave diff --git a/src/selectors_utils/selectors.irp.f b/src/selectors_utils/selectors.irp.f index 765bd5e8..92366d1d 100644 --- a/src/selectors_utils/selectors.irp.f +++ b/src/selectors_utils/selectors.irp.f @@ -2,7 +2,7 @@ use bitmasks BEGIN_PROVIDER [ integer, psi_selectors_size ] implicit none - psi_selectors_size = N_det + psi_selectors_size = psi_det_size END_PROVIDER BEGIN_PROVIDER [ double precision, psi_selectors_coef_transp, (N_states,psi_selectors_size) ] diff --git a/src/single_ref_method/generators.irp.f b/src/single_ref_method/generators.irp.f index dd6985a5..ce71f996 100644 --- a/src/single_ref_method/generators.irp.f +++ b/src/single_ref_method/generators.irp.f @@ -9,8 +9,8 @@ BEGIN_PROVIDER [ integer, N_det_generators ] N_det_generators = 1 END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,N_det) ] -&BEGIN_PROVIDER [ double precision, psi_coef_generators, (N_det,N_states) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ] implicit none BEGIN_DOC ! For Single reference wave functions, the generator is the From 727815751cdcadc8affbdd87897150dbb06e6e76 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 25 May 2022 19:35:44 +0200 Subject: [PATCH 28/80] DGEMM four-index transformation --- src/mo_two_e_ints/mo_bi_integrals.irp.f | 96 ++++++++++++++++++++++++- 1 file changed, 95 insertions(+), 1 deletion(-) diff --git a/src/mo_two_e_ints/mo_bi_integrals.irp.f b/src/mo_two_e_ints/mo_bi_integrals.irp.f index d58932ce..c03b363d 100644 --- a/src/mo_two_e_ints/mo_bi_integrals.irp.f +++ b/src/mo_two_e_ints/mo_bi_integrals.irp.f @@ -53,7 +53,11 @@ BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ] ! call four_idx_novvvv call four_idx_novvvv_old else - call add_integrals_to_map(full_ijkl_bitmask_4) + if (ao_num*ao_num*ao_num*ao_num*32.d-9 < dble(qp_max_mem)) then + call four_idx_dgemm + else + call add_integrals_to_map(full_ijkl_bitmask_4) + endif endif call wall_time(wall_2) @@ -77,6 +81,96 @@ BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ] END_PROVIDER +subroutine four_idx_dgemm + implicit none + integer :: p,q,r,s,i,j,k,l + double precision, allocatable :: a1(:,:,:,:) + double precision, allocatable :: a2(:,:,:,:) + + allocate (a1(ao_num,ao_num,ao_num,ao_num)) + + print *, 'Getting AOs' + !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(q,r,s) + do s=1,ao_num + do r=1,ao_num + do q=1,ao_num + call get_ao_two_e_integrals(q,r,s,ao_num,a1(1,q,r,s)) + enddo + enddo + enddo + !$OMP END PARALLEL DO + + print *, '1st transformation' + ! 1st transformation + allocate (a2(ao_num,ao_num,ao_num,mo_num)) + call dgemm('T','N', (ao_num*ao_num*ao_num), mo_num, ao_num, 1.d0, a1, ao_num, mo_coef, ao_num, 0.d0, a2, (ao_num*ao_num*ao_num)) + + ! 2nd transformation + print *, '2nd transformation' + deallocate (a1) + allocate (a1(ao_num,ao_num,mo_num,mo_num)) + call dgemm('T','N', (ao_num*ao_num*mo_num), mo_num, ao_num, 1.d0, a2, ao_num, mo_coef, ao_num, 0.d0, a1, (ao_num*ao_num*mo_num)) + + ! 3rd transformation + print *, '3rd transformation' + deallocate (a2) + allocate (a2(ao_num,mo_num,mo_num,mo_num)) + call dgemm('T','N', (ao_num*mo_num*mo_num), mo_num, ao_num, 1.d0, a1, ao_num, mo_coef, ao_num, 0.d0, a2, (ao_num*mo_num*mo_num)) + + ! 4th transformation + print *, '4th transformation' + deallocate (a1) + allocate (a1(mo_num,mo_num,mo_num,mo_num)) + call dgemm('T','N', (mo_num*mo_num*mo_num), mo_num, ao_num, 1.d0, a2, ao_num, mo_coef, ao_num, 0.d0, a1, (mo_num*mo_num*mo_num)) + + deallocate (a2) + + integer :: n_integrals, size_buffer + integer(key_kind) , allocatable :: buffer_i(:) + real(integral_kind), allocatable :: buffer_value(:) + size_buffer = min(ao_num*ao_num*ao_num,16000000) + + print *, 'Storing' + !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l,buffer_value,buffer_i,n_integrals) + allocate ( buffer_i(size_buffer), buffer_value(size_buffer) ) + + n_integrals = 0 + !$OMP DO + do l=1,mo_num + do k=1,mo_num + do j=1,l + do i=1,k + if (abs(a1(i,j,k,l)) < mo_integrals_threshold) then + cycle + endif + n_integrals += 1 + buffer_value(n_integrals) = a1(i,j,k,l) + !DIR$ FORCEINLINE + call mo_two_e_integrals_index(i,j,k,l,buffer_i(n_integrals)) + if (n_integrals == size_buffer) then + call map_append(mo_integrals_map, buffer_i, buffer_value, n_integrals) + n_integrals = 0 + endif + enddo + enddo + enddo + enddo + !$OMP END DO + + call map_append(mo_integrals_map, buffer_i, buffer_value, n_integrals) + + deallocate(buffer_i, buffer_value) + !$OMP END PARALLEL + + deallocate (a1) + + print *, 'Unique' + call map_unique(mo_integrals_map) + + integer*8 :: get_mo_map_size, mo_map_size + mo_map_size = get_mo_map_size() + +end subroutine subroutine add_integrals_to_map(mask_ijkl) use bitmasks From 4ccaa8f695a4928be80bb214dd063a7b7e9d28a9 Mon Sep 17 00:00:00 2001 From: v1j4y Date: Mon, 6 Jun 2022 13:41:29 +0200 Subject: [PATCH 29/80] Open-Shell CSF: Fix bug in getbftodetfunction. --- src/csf/cfgCI_utils.c | 50 +++++++++++++++++++++++++++++++++++++------ 1 file changed, 44 insertions(+), 6 deletions(-) diff --git a/src/csf/cfgCI_utils.c b/src/csf/cfgCI_utils.c index 23b984a0..63172d14 100644 --- a/src/csf/cfgCI_utils.c +++ b/src/csf/cfgCI_utils.c @@ -68,10 +68,16 @@ void getBFIndexList(int NSOMO, int *BF1, int *IdxListBF1){ break; } } - BFcopy[Iidx] = -1; - BFcopy[Jidx] = -1; - IdxListBF1[Jidx] = Iidx; - IdxListBF1[Iidx] = Jidx; + if(countN1 <= 0){ + BFcopy[Iidx] = -1; + IdxListBF1[Iidx] = Iidx; + } + else{ + BFcopy[Iidx] = -1; + BFcopy[Jidx] = -1; + IdxListBF1[Jidx] = Iidx; + IdxListBF1[Iidx] = Jidx; + } } } @@ -1297,16 +1303,21 @@ void getbftodetfunction(Tree *dettree, int NSOMO, int MS, int *BF1, double *rowv double fac = 1.0; for(int i = 0; i < NSOMO; i++) donepq[i] = 0.0; + for(int i=0;i 0.0 || donepq[idxq] > 0.0) continue; + if(donepq[idxp] > 0.0 || donepq[idxq] > 0.0 || idxp == idxq) continue; fac *= 2.0; donepq[idxp] = 1.0; donepq[idxq] = 1.0; for(int j = 0; j < npairs; j = j + shft){ + printf("i=%d j=%d (%d,%d)\n",i,j,idxp,idxq); for(int k = 0; k < shft/2; k++){ detslist[(k+j)*NSOMO + idxp] = 1; detslist[(k+j)*NSOMO + idxq] = 0; @@ -1319,15 +1330,26 @@ void getbftodetfunction(Tree *dettree, int NSOMO, int MS, int *BF1, double *rowv } shft /= 2; } + for(int i=0;i Date: Mon, 6 Jun 2022 14:08:34 +0200 Subject: [PATCH 30/80] Open-Shell CSF: Fix bug in build csftree. --- src/csf/cfgCI_utils.c | 34 +++++----------------------------- src/csf/tree_utils.c | 26 +++++++++++++++----------- 2 files changed, 20 insertions(+), 40 deletions(-) diff --git a/src/csf/cfgCI_utils.c b/src/csf/cfgCI_utils.c index 63172d14..91e7360a 100644 --- a/src/csf/cfgCI_utils.c +++ b/src/csf/cfgCI_utils.c @@ -1317,7 +1317,6 @@ void getbftodetfunction(Tree *dettree, int NSOMO, int MS, int *BF1, double *rowv donepq[idxp] = 1.0; donepq[idxq] = 1.0; for(int j = 0; j < npairs; j = j + shft){ - printf("i=%d j=%d (%d,%d)\n",i,j,idxp,idxq); for(int k = 0; k < shft/2; k++){ detslist[(k+j)*NSOMO + idxp] = 1; detslist[(k+j)*NSOMO + idxq] = 0; @@ -1330,14 +1329,7 @@ void getbftodetfunction(Tree *dettree, int NSOMO, int MS, int *BF1, double *rowv } shft /= 2; } - for(int i=0;i NSOMOMax || icpl < 0 || izeros > zeromax ) return; // If we find a valid BF assign its address - if(isomo == NSOMOMax){ + if(isomo == NSOMOMax && icpl == MSmax){ (*inode)->addr = bftree->rootNode->addr; bftree->rootNode->addr += 1; return; } // Call 0 branch - if(((*inode)->C0) == NULL && izeros+1 <= zeromax){ - ((*inode)->C0) = malloc(sizeof(Node)); - (*(*inode)->C0) = (Node){ .C0 = NULL, .C1 = NULL, .PREV = *inode, .addr = -1, .cpl = 0, .iSOMO = isomo }; - buildTree(bftree, &(*inode)->C0, isomo+1, izeros+1, icpl+1, NSOMOMax, MSmax); + if(izeros+1 <= zeromax){ + if(((*inode)->C0) == NULL){ + ((*inode)->C0) = malloc(sizeof(Node)); + (*(*inode)->C0) = (Node){ .C0 = NULL, .C1 = NULL, .PREV = *inode, .addr = -1, .cpl = 0, .iSOMO = isomo }; + buildTree(bftree, &(*inode)->C0, isomo+1, izeros+1, icpl+1, NSOMOMax, MSmax); + } + else buildTree(bftree, &(*inode)->C0, isomo+1, izeros+1, icpl+1, NSOMOMax, MSmax); } - else buildTree(bftree, &(*inode)->C0, isomo+1, izeros+1, icpl+1, NSOMOMax, MSmax); // Call 1 branch - if(((*inode)->C1) == NULL && icpl-1 >= 0){ - ((*inode)->C1) = malloc(sizeof(Node)); - (*(*inode)->C1) = (Node){ .C0 = NULL, .C1 = NULL, .PREV = *inode, .addr = -1, .cpl = 1, .iSOMO = isomo }; - buildTree(bftree, &(*inode)->C1, isomo+1, izeros+0, icpl-1, NSOMOMax, MSmax); + if(icpl-1 >=0){ + if(((*inode)->C1) == NULL){ + ((*inode)->C1) = malloc(sizeof(Node)); + (*(*inode)->C1) = (Node){ .C0 = NULL, .C1 = NULL, .PREV = *inode, .addr = -1, .cpl = 1, .iSOMO = isomo }; + buildTree(bftree, &(*inode)->C1, isomo+1, izeros+0, icpl-1, NSOMOMax, MSmax); + } + else buildTree(bftree, &(*inode)->C1, isomo+1, izeros+0, icpl-1, NSOMOMax, MSmax); } - else buildTree(bftree, &(*inode)->C1, isomo+1, izeros+0, icpl-1, NSOMOMax, MSmax); return; } From e06ab2fd05d46a8f8be6c86f23e3870615287b8d Mon Sep 17 00:00:00 2001 From: v1j4y Date: Mon, 6 Jun 2022 15:23:25 +0200 Subject: [PATCH 31/80] Open-Shell CSF: Fix bug in convertCSFtoDetBasis. --- src/csf/cfgCI_utils.c | 26 ++++++++++++++++---------- 1 file changed, 16 insertions(+), 10 deletions(-) diff --git a/src/csf/cfgCI_utils.c b/src/csf/cfgCI_utils.c index 91e7360a..746de04e 100644 --- a/src/csf/cfgCI_utils.c +++ b/src/csf/cfgCI_utils.c @@ -334,10 +334,21 @@ void convertCSFtoDetBasis(int64_t Isomo, int MS, int rowsmax, int colsmax, doubl Get Overlap ************************************/ // Fill matrix + + int rowsbftodetI, colsbftodetI; + + /*********************************** + Get BFtoDeterminant Matrix + ************************************/ + + printf("In convertcsftodet\n"); + convertBFtoDetBasis(Isomo, MS, &bftodetmatrixI, &rowsbftodetI, &colsbftodetI); + int rowsI = 0; int colsI = 0; - getOverlapMatrix(Isomo, MS, &overlapMatrixI, &rowsI, &colsI, &NSOMO); + //getOverlapMatrix(Isomo, MS, &overlapMatrixI, &rowsI, &colsI, &NSOMO); + getOverlapMatrix_withDet(bftodetmatrixI, rowsbftodetI, colsbftodetI, Isomo, MS, &overlapMatrixI, &rowsI, &colsI, &NSOMO); /*********************************** @@ -348,14 +359,6 @@ void convertCSFtoDetBasis(int64_t Isomo, int MS, int rowsmax, int colsmax, doubl gramSchmidt(overlapMatrixI, rowsI, colsI, orthoMatrixI); - /*********************************** - Get BFtoDeterminant Matrix - ************************************/ - - int rowsbftodetI, colsbftodetI; - - convertBFtoDetBasis(Isomo, MS, &bftodetmatrixI, &rowsbftodetI, &colsbftodetI); - /*********************************** Get Final CSF to Det Matrix ************************************/ @@ -1305,7 +1308,7 @@ void getbftodetfunction(Tree *dettree, int NSOMO, int MS, int *BF1, double *rowv donepq[i] = 0.0; for(int i=0;i Date: Wed, 8 Jun 2022 07:48:58 +0200 Subject: [PATCH 32/80] Update tests --- src/fci/40.fci.bats | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/fci/40.fci.bats b/src/fci/40.fci.bats index c303ea87..871de780 100644 --- a/src/fci/40.fci.bats +++ b/src/fci/40.fci.bats @@ -54,7 +54,7 @@ function run_stoch() { @test "HCO" { # 0:01:16 qp set_file hco.ezfio - run_stoch -113.41658256 1.e-3 50000 + run_stoch -113.41658256 2.e-3 50000 } @test "H2O2" { # 0:01:48 @@ -66,7 +66,7 @@ function run_stoch() { @test "HBO" { # 0:00:46 [[ -n $TRAVIS ]] && skip qp set_file hbo.ezfio - run_stoch -100.22361288 1.e-4 50000 + run_stoch -100.22361288 2.e-3 50000 } @test "H2O" { # 0:01:05 From 6861cea2ac2bd5cbd40c9bd3f4b076602da830a0 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 8 Jun 2022 11:08:53 +0200 Subject: [PATCH 33/80] Compiles with OCaml 4.13.1 --- bin/qp_test | 9 +- configure | 4 +- external/qp2-dependencies | 2 +- ocaml/Qputils.ml | 4 + ocaml/qp_tunnel.ml | 139 ++++++++++++++--------- src/fci/40.fci.bats | 16 +-- src/iterations/print_extrapolation.irp.f | 2 +- tests/bats/common.bats.sh | 2 +- 8 files changed, 102 insertions(+), 76 deletions(-) diff --git a/bin/qp_test b/bin/qp_test index 67b3ea02..288b7291 100755 --- a/bin/qp_test +++ b/bin/qp_test @@ -60,19 +60,14 @@ def main(arguments): print("Running tests for %s"%(bats_file)) print("") if arguments["-v"]: - p = None if arguments["TEST"]: test = "export TEST=%s ; "%arguments["TEST"] else: test = "" - try: - os.system(test+" python3 bats_to_sh.py "+bats_file+ + os.system(test+" python3 bats_to_sh.py "+bats_file+ "| bash") - except: - if p: - p.terminate() else: - subprocess.check_call(["bats", bats_file], env=os.environ) + subprocess.check_call(["bats", "--verbose-run", "--trace", bats_file], env=os.environ) diff --git a/configure b/configure index e70820fe..5c38b9f2 100755 --- a/configure +++ b/configure @@ -281,8 +281,8 @@ EOF execute << EOF cd "\${QP_ROOT}"/external - tar -zxf qp2-dependencies/bats-v1.1.0.tar.gz - ( cd bats-core-1.1.0/ ; ./install.sh \${QP_ROOT}) + tar -zxf qp2-dependencies/bats-v1.7.0.tar.gz + ( cd bats-core-1.7.0/ ; ./install.sh \${QP_ROOT}) EOF else diff --git a/external/qp2-dependencies b/external/qp2-dependencies index 90ee61f5..242151e0 160000 --- a/external/qp2-dependencies +++ b/external/qp2-dependencies @@ -1 +1 @@ -Subproject commit 90ee61f5041c7c94a0c605625a264860292813a0 +Subproject commit 242151e03d1d6bf042387226431d82d35845686a diff --git a/ocaml/Qputils.ml b/ocaml/Qputils.ml index 270e069f..752a65a0 100644 --- a/ocaml/Qputils.ml +++ b/ocaml/Qputils.ml @@ -56,3 +56,7 @@ let string_of_string s = s let list_map f l = List.rev_map f l |> List.rev + +let socket_convert socket = + ((Obj.magic (Obj.repr socket)) : [ `Xsub ] Zmq.Socket.t ) + diff --git a/ocaml/qp_tunnel.ml b/ocaml/qp_tunnel.ml index 84e50eb5..6885db73 100644 --- a/ocaml/qp_tunnel.ml +++ b/ocaml/qp_tunnel.ml @@ -2,7 +2,7 @@ open Qputils open Qptypes type ezfio_or_address = EZFIO of string | ADDRESS of string -type req_or_sub = REQ | SUB +type req_or_sub = REQ | SUB let localport = 42379 @@ -29,7 +29,7 @@ let () = end; let arg = - let x = + let x = match Command_line.anon_args () with | [x] -> x | _ -> begin @@ -44,7 +44,7 @@ let () = in - let localhost = + let localhost = Lazy.force TaskServer.ip_address in @@ -52,28 +52,28 @@ let () = let long_address = match arg with | ADDRESS x -> x - | EZFIO x -> - let ic = + | EZFIO x -> + let ic = Filename.concat (Qpackage.ezfio_work x) "qp_run_address" |> open_in in - let result = + let result = input_line ic |> String.trim in close_in ic; result in - + let protocol, address, port = match String.split_on_char ':' long_address with | t :: a :: p :: [] -> t, a, int_of_string p - | _ -> failwith @@ + | _ -> failwith @@ Printf.sprintf "%s : Malformed address" long_address in - let zmq_context = + let zmq_context = Zmq.Context.create () in @@ -105,10 +105,10 @@ let () = let create_socket sock_type bind_or_connect addr = - let socket = + let socket = Zmq.Socket.create zmq_context sock_type in - let () = + let () = try bind_or_connect socket addr with @@ -131,37 +131,64 @@ let () = Sys.set_signal Sys.sigint handler; - let new_thread req_or_sub addr_in addr_out = + let new_thread_req addr_in addr_out = let socket_in, socket_out = - match req_or_sub with - | REQ -> create_socket Zmq.Socket.router Zmq.Socket.bind addr_in, create_socket Zmq.Socket.dealer Zmq.Socket.connect addr_out - | SUB -> - create_socket Zmq.Socket.sub Zmq.Socket.connect addr_in, - create_socket Zmq.Socket.pub Zmq.Socket.bind addr_out in - if req_or_sub = SUB then - Zmq.Socket.subscribe socket_in ""; - - - let action_in = - match req_or_sub with - | REQ -> (fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out) - | SUB -> (fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out) + let action_in = + fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out in - let action_out = - match req_or_sub with - | REQ -> (fun () -> Zmq.Socket.recv_all socket_out |> Zmq.Socket.send_all socket_in ) - | SUB -> (fun () -> () ) + let action_out = + fun () -> Zmq.Socket.recv_all socket_out |> Zmq.Socket.send_all socket_in in let pollitem = Zmq.Poll.mask_of - [| (socket_in, Zmq.Poll.In) ; (socket_out, Zmq.Poll.In) |] + [| (socket_convert socket_in, Zmq.Poll.In) ; (socket_convert socket_out, Zmq.Poll.In) |] + in + + while !run_status do + + let polling = + Zmq.Poll.poll ~timeout:1000 pollitem + in + + match polling with + | [| Some Zmq.Poll.In ; Some Zmq.Poll.In |] -> ( action_out () ; action_in () ) + | [| _ ; Some Zmq.Poll.In |] -> action_out () + | [| Some Zmq.Poll.In ; _ |] -> action_in () + | _ -> () + done; + + Zmq.Socket.close socket_in; + Zmq.Socket.close socket_out; + in + + let new_thread_sub addr_in addr_out = + let socket_in, socket_out = + create_socket Zmq.Socket.sub Zmq.Socket.connect addr_in, + create_socket Zmq.Socket.pub Zmq.Socket.bind addr_out + in + + Zmq.Socket.subscribe socket_in ""; + + + + let action_in = + fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out + in + + let action_out = + fun () -> () + in + + let pollitem = + Zmq.Poll.mask_of + [| (socket_convert socket_in, Zmq.Poll.In) ; (socket_convert socket_out, Zmq.Poll.In) |] in @@ -173,8 +200,8 @@ let () = match polling with | [| Some Zmq.Poll.In ; Some Zmq.Poll.In |] -> ( action_out () ; action_in () ) - | [| _ ; Some Zmq.Poll.In |] -> action_out () - | [| Some Zmq.Poll.In ; _ |] -> action_in () + | [| _ ; Some Zmq.Poll.In |] -> action_out () + | [| Some Zmq.Poll.In ; _ |] -> action_in () | _ -> () done; @@ -193,8 +220,8 @@ let () = Printf.sprintf "tcp://*:%d" localport in - let f () = - new_thread REQ addr_in addr_out + let f () = + new_thread_req addr_in addr_out in (Thread.create f) () @@ -211,8 +238,8 @@ let () = Printf.sprintf "tcp://*:%d" (localport+2) in - let f () = - new_thread REQ addr_in addr_out + let f () = + new_thread_req addr_in addr_out in (Thread.create f) () in @@ -227,8 +254,8 @@ let () = Printf.sprintf "tcp://*:%d" (localport+1) in - let f () = - new_thread SUB addr_in addr_out + let f () = + new_thread_sub addr_in addr_out in (Thread.create f) () in @@ -236,7 +263,7 @@ let () = let input_thread = - let f () = + let f () = let addr_out = match arg with | EZFIO _ -> None @@ -248,22 +275,22 @@ let () = Printf.sprintf "tcp://*:%d" (localport+9) in - let socket_in = + let socket_in = create_socket Zmq.Socket.rep Zmq.Socket.bind addr_in in let socket_out = - match addr_out with + match addr_out with | Some addr_out -> Some ( create_socket Zmq.Socket.req Zmq.Socket.connect addr_out) | None -> None in - let temp_file = + let temp_file = Filename.temp_file "qp_tunnel" ".tar.gz" in - let get_ezfio_filename () = + let get_ezfio_filename () = match arg with | EZFIO x -> x | ADDRESS _ -> @@ -277,9 +304,9 @@ let () = end in - let get_input () = + let get_input () = match arg with - | EZFIO x -> + | EZFIO x -> begin Printf.sprintf "tar --exclude=\"*.gz.*\" -zcf %s %s" temp_file x |> Sys.command |> ignore; @@ -291,11 +318,11 @@ let () = in ignore @@ Unix.lseek fd 0 Unix.SEEK_SET ; let bstr = - Unix.map_file fd Bigarray.char + Unix.map_file fd Bigarray.char Bigarray.c_layout false [| len |] |> Bigarray.array1_of_genarray in - let result = + let result = String.init len (fun i -> bstr.{i}) ; in Unix.close fd; @@ -313,7 +340,7 @@ let () = end in - let () = + let () = match socket_out with | None -> () | Some socket_out -> @@ -329,7 +356,7 @@ let () = | ADDRESS _ -> begin Printf.printf "Getting input... %!"; - let ezfio_filename = + let ezfio_filename = get_ezfio_filename () in Printf.printf "%s%!" ezfio_filename; @@ -343,7 +370,7 @@ let () = |> Sys.command |> ignore ; let oc = Filename.concat (Qpackage.ezfio_work ezfio_filename) "qp_run_address" - |> open_out + |> open_out in Printf.fprintf oc "tcp://%s:%d\n" localhost localport; close_out oc; @@ -359,9 +386,9 @@ let () = let action () = match Zmq.Socket.recv socket_in with | "get_input" -> get_input () - |> Zmq.Socket.send socket_in + |> Zmq.Socket.send socket_in | "get_ezfio_filename" -> get_ezfio_filename () - |> Zmq.Socket.send socket_in + |> Zmq.Socket.send socket_in | "test" -> Zmq.Socket.send socket_in "OK" | x -> Printf.sprintf "Message '%s' not understood" x |> Zmq.Socket.send socket_in @@ -372,7 +399,7 @@ On remote hosts, create ssh tunnel using: ssh -L %d:%s:%d -L %d:%s:%d -L %d:%s:%d -L %d:%s:%d %s & Or from this host connect to clients using: ssh -R %d:localhost:%d -R %d:localhost:%d -R %d:localhost:%d -R %d:localhost:%d & -%!" +%!" (port ) localhost (localport ) (port+1) localhost (localport+1) (port+2) localhost (localport+2) @@ -392,12 +419,12 @@ Or from this host connect to clients using: match polling.(0) with | Some Zmq.Poll.In -> action () | None -> () - | Some Zmq.Poll.In_out + | Some Zmq.Poll.In_out | Some Zmq.Poll.Out -> () done; - let () = + let () = match socket_out with | Some socket_out -> Zmq.Socket.close socket_out | None -> () @@ -415,7 +442,7 @@ Or from this host connect to clients using: Thread.join ocaml_thread; Zmq.Context.terminate zmq_context; Printf.printf "qp_tunnel exited properly.\n" - + diff --git a/src/fci/40.fci.bats b/src/fci/40.fci.bats index 871de780..600217de 100644 --- a/src/fci/40.fci.bats +++ b/src/fci/40.fci.bats @@ -37,48 +37,48 @@ function run_stoch() { qp set_file b2_stretched.ezfio qp set determinants n_det_max 10000 qp set_frozen_core - run_stoch -49.14104086 0.0001 10000 + run_stoch -49.14097596 0.0001 10000 } @test "NH3" { # 0:00:11 qp set_file nh3.ezfio qp set_mo_class --core="[1-4]" --act="[5-72]" - run -56.24474790 1.e-5 10000 + run -56.24474908 1.e-5 10000 } @test "DHNO" { # 0:00:10 qp set_file dhno.ezfio qp set_mo_class --core="[1-7]" --act="[8-64]" - run -130.45901042 1.e-4 10000 + run -130.45904647 1.e-4 10000 } @test "HCO" { # 0:01:16 qp set_file hco.ezfio - run_stoch -113.41658256 2.e-3 50000 + run_stoch -113.41448940 2.e-3 50000 } @test "H2O2" { # 0:01:48 qp set_file h2o2.ezfio qp set_mo_class --core="[1-2]" --act="[3-24]" --del="[25-38]" - run_stoch -151.02317880 2.e-3 100000 + run_stoch -151.02437936 2.e-3 100000 } @test "HBO" { # 0:00:46 [[ -n $TRAVIS ]] && skip qp set_file hbo.ezfio - run_stoch -100.22361288 2.e-3 50000 + run_stoch -100.221198108988 2.e-3 50000 } @test "H2O" { # 0:01:05 [[ -n $TRAVIS ]] && skip qp set_file h2o.ezfio - run_stoch -76.24347962 1.e-4 100000 + run_stoch -76.241332121813 1.e-3 100000 } @test "ClO" { # 0:03:07 [[ -n $TRAVIS ]] && skip qp set_file clo.ezfio - run_stoch -534.58202840 1.e-3 100000 + run_stoch -534.573564655419 1.e-3 100000 } @test "SO" { # 0:01:49 diff --git a/src/iterations/print_extrapolation.irp.f b/src/iterations/print_extrapolation.irp.f index 7f602ffb..7c6dbb9b 100644 --- a/src/iterations/print_extrapolation.irp.f +++ b/src/iterations/print_extrapolation.irp.f @@ -41,7 +41,7 @@ subroutine print_extrapolated_energy enddo print *, '' - call ezfio_set_fci_energy_extrapolated(extrapolated_energy(2,1:N_states)) + call ezfio_set_fci_energy_extrapolated(extrapolated_energy(min(N_iter,3),1:N_states)) end subroutine diff --git a/tests/bats/common.bats.sh b/tests/bats/common.bats.sh index f6ea4023..802c0232 100644 --- a/tests/bats/common.bats.sh +++ b/tests/bats/common.bats.sh @@ -46,7 +46,7 @@ function test_exe() { run_only_test() { if [[ "$BATS_TEST_DESCRIPTION" != "$1" ]] && [[ "$BATS_TEST_NUMBER" != "$1" ]]; then - if [[ -z $BATS_TEST_FILENAME ]] ; then + if [[ -z "$BATS_TEST_FILENAME" ]] ; then exit 0 else skip From cea413b00a775bb08cafd33621a63f839432935e Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 8 Jun 2022 17:44:53 +0200 Subject: [PATCH 34/80] 3-point extrapolation in tests --- src/fci/40.fci.bats | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/fci/40.fci.bats b/src/fci/40.fci.bats index 600217de..ac34251f 100644 --- a/src/fci/40.fci.bats +++ b/src/fci/40.fci.bats @@ -90,99 +90,99 @@ function run_stoch() { @test "H2S" { # 0:01:12 [[ -n $TRAVIS ]] && skip qp set_file h2s.ezfio - run_stoch -398.87187312 1.e-3 50000 + run_stoch -398.865173546866 1.e-3 50000 } @test "OH" { # 0:00:41 [[ -n $TRAVIS ]] && skip qp set_file oh.ezfio - run_stoch -75.62393829 1.e-3 50000 + run_stoch -75.6193013819546 1.e-3 50000 } @test "SiH2_3B1" { # 0:00:50 [[ -n $TRAVIS ]] && skip qp set_file sih2_3b1.ezfio - run_stoch -290.02083172 3.e-5 50000 + run_stoch -290.01754869 3.e-5 50000 } @test "H3COH" { # 0:01:05 [[ -n $TRAVIS ]] && skip qp set_file h3coh.ezfio - run_stoch -115.22625460 2.e-3 50000 + run_stoch -115.224147057725 2.e-3 50000 } @test "SiH3" { # 0:01:09 [[ -n $TRAVIS ]] && skip qp set_file sih3.ezfio - run_stoch -5.57818759 1.e-3 50000 + run_stoch -5.57812512359276 1.e-3 50000 } @test "CH4" { # 0:02:06 [[ -n $TRAVIS ]] && skip qp set_file ch4.ezfio qp set_mo_class --core="[1]" --act="[2-30]" --del="[31-59]" - run_stoch -40.24195947 1.e-4 100000 + run_stoch -40.2419474611994 1.e-4 100000 } @test "ClF" { # 0:01:55 [[ -n $TRAVIS ]] && skip qp set_file clf.ezfio - run_stoch -559.20157348 1.e-3 50000 + run_stoch -559.20666465 1.e-2 50000 } @test "SO2" { # 0:00:24 [[ -n $TRAVIS ]] && skip qp set_file so2.ezfio qp set_mo_class --core="[1-8]" --act="[9-87]" - run_stoch -41.57468087 1.e-4 50000 + run_stoch -41.57468756 1.e-4 50000 } @test "C2H2" { # 0:00:57 [[ -n $TRAVIS ]] && skip qp set_file c2h2.ezfio qp set_mo_class --act="[1-30]" --del="[31-36]" - run_stoch -12.38655876 1.e-3 50000 + run_stoch -12.3862664765532 1.e-3 50000 } @test "N2" { # 0:01:15 [[ -n $TRAVIS ]] && skip qp set_file n2.ezfio qp set_mo_class --core="[1,2]" --act="[3-40]" --del="[41-60]" - run_stoch -109.31133266 2.e-3 50000 + run_stoch -109.311954243348 2.e-3 50000 } @test "N2H4" { # 0:00:51 [[ -n $TRAVIS ]] && skip qp set_file n2h4.ezfio qp set_mo_class --core="[1-2]" --act="[3-24]" --del="[25-48]" - run_stoch -111.38161063 1.e-3 50000 + run_stoch -111.38119165053 1.e-3 50000 } @test "CO2" { # 0:01:00 [[ -n $TRAVIS ]] && skip qp set_file co2.ezfio qp set_mo_class --core="[1,2]" --act="[3-30]" --del="[31-42]" - run_stoch -188.00154729 2.e-3 50000 + run_stoch -188.002190327443 2.e-3 50000 } @test "[Cu(NH3)4]2+" { # 0:01:53 [[ -n $TRAVIS ]] && skip qp set_file cu_nh3_4_2plus.ezfio qp set_mo_class --core="[1-24]" --act="[25-45]" --del="[46-87]" - run_stoch -1862.98705091 1.e-05 50000 + run_stoch -1862.98705340328 1.e-05 50000 } @test "HCN" { # 0:01:26 [[ -n $TRAVIS ]] && skip qp set_file hcn.ezfio qp set_mo_class --core="[1,2]" --act="[3-40]" --del="[41-55]" - run_stoch -93.09855896 5.e-4 50000 + run_stoch -93.0980746734051 5.e-4 50000 } @test "F2" { # 0:03:34 [[ -n $TRAVIS ]] && skip qp set_file f2.ezfio qp set_frozen_core - run_stoch -199.30821487 0.002 100000 + run_stoch -199.307512211742 0.002 100000 } From 389db7b4cb4532793733d141339bf9dc1322e31c Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 10 Jun 2022 12:11:08 +0200 Subject: [PATCH 35/80] Fixed max memory detection --- external/qp2-dependencies | 2 +- src/mo_two_e_ints/mo_bi_integrals.irp.f | 4 +--- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/external/qp2-dependencies b/external/qp2-dependencies index 242151e0..bc856147 160000 --- a/external/qp2-dependencies +++ b/external/qp2-dependencies @@ -1 +1 @@ -Subproject commit 242151e03d1d6bf042387226431d82d35845686a +Subproject commit bc856147f6e626a6616b20344e5b8e3f30f44a92 diff --git a/src/mo_two_e_ints/mo_bi_integrals.irp.f b/src/mo_two_e_ints/mo_bi_integrals.irp.f index c03b363d..6f4c5c17 100644 --- a/src/mo_two_e_ints/mo_bi_integrals.irp.f +++ b/src/mo_two_e_ints/mo_bi_integrals.irp.f @@ -53,7 +53,7 @@ BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ] ! call four_idx_novvvv call four_idx_novvvv_old else - if (ao_num*ao_num*ao_num*ao_num*32.d-9 < dble(qp_max_mem)) then + if (32.d-9*dble(ao_num)**4 < dble(qp_max_mem)) then call four_idx_dgemm else call add_integrals_to_map(full_ijkl_bitmask_4) @@ -130,7 +130,6 @@ subroutine four_idx_dgemm real(integral_kind), allocatable :: buffer_value(:) size_buffer = min(ao_num*ao_num*ao_num,16000000) - print *, 'Storing' !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l,buffer_value,buffer_i,n_integrals) allocate ( buffer_i(size_buffer), buffer_value(size_buffer) ) @@ -164,7 +163,6 @@ subroutine four_idx_dgemm deallocate (a1) - print *, 'Unique' call map_unique(mo_integrals_map) integer*8 :: get_mo_map_size, mo_map_size From 31572fddc3b8de11008e214e29b602d9f0ff5c8d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 10 Jun 2022 14:28:37 +0200 Subject: [PATCH 36/80] Prepared CFG H.Psi for Vijay --- src/davidson/diagonalize_ci.irp.f | 25 ++++++++++++++++++++++--- 1 file changed, 22 insertions(+), 3 deletions(-) diff --git a/src/davidson/diagonalize_ci.irp.f b/src/davidson/diagonalize_ci.irp.f index 46ad8f78..6930cc07 100644 --- a/src/davidson/diagonalize_ci.irp.f +++ b/src/davidson/diagonalize_ci.irp.f @@ -1,3 +1,13 @@ +BEGIN_PROVIDER [ character*(3), sigma_vector_algorithm ] + implicit none + BEGIN_DOC + ! If 'det', use in Davidson + ! + ! If 'cfg', use in Davidson + END_DOC + sigma_vector_algorithm = 'det' +END_PROVIDER + BEGIN_PROVIDER [ double precision, CI_energy, (N_states_diag) ] implicit none BEGIN_DOC @@ -61,9 +71,18 @@ END_PROVIDER if (diag_algorithm == "Davidson") then if (do_csf) then - call davidson_diag_H_csf(psi_det,CI_eigenvectors, & - size(CI_eigenvectors,1),CI_electronic_energy, & - N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged) + if (sigma_vector_algorithm == 'det') then + call davidson_diag_H_csf(psi_det,CI_eigenvectors, & + size(CI_eigenvectors,1),CI_electronic_energy, & + N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged) +! else if (sigma_vector_algorithm == 'cfg') then +! call davidson_diag_H_csf(psi_det,CI_eigenvectors, & +! size(CI_eigenvectors,1),CI_electronic_energy, & +! N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged) +! else +! print *, irp_here +! stop 'bug' + endif else call davidson_diag_HS2(psi_det,CI_eigenvectors, CI_s2, & size(CI_eigenvectors,1),CI_electronic_energy, & From cc7943f3936a64dbe3ac9449d293a7144f793324 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 14 Jun 2022 16:19:14 +0200 Subject: [PATCH 37/80] Update qp2-dependencies --- external/qp2-dependencies | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/external/qp2-dependencies b/external/qp2-dependencies index bc856147..242151e0 160000 --- a/external/qp2-dependencies +++ b/external/qp2-dependencies @@ -1 +1 @@ -Subproject commit bc856147f6e626a6616b20344e5b8e3f30f44a92 +Subproject commit 242151e03d1d6bf042387226431d82d35845686a From f093592124457451eeb0b6817488b4591cf9295f Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 14 Jun 2022 18:10:32 +0200 Subject: [PATCH 38/80] Update guess in CISD --- src/cisd/cisd.irp.f | 37 ++++++++++++++++--- .../diagonalization_hcsf_dressed.irp.f | 19 +++------- src/determinants/determinants.irp.f | 4 +- 3 files changed, 38 insertions(+), 22 deletions(-) diff --git a/src/cisd/cisd.irp.f b/src/cisd/cisd.irp.f index 5f167686..3e1e8d97 100644 --- a/src/cisd/cisd.irp.f +++ b/src/cisd/cisd.irp.f @@ -47,6 +47,37 @@ program cisd PROVIDE N_states read_wf = .False. SOFT_TOUCH read_wf + + integer :: i,k + + if(pseudo_sym)then + call H_apply_cisd_sym + else + call H_apply_cisd + endif + double precision :: r1, r2 + double precision, allocatable :: U_csf(:,:) + + allocate(U_csf(N_csf,N_states)) + U_csf = 0.d0 + U_csf(1,1) = 1.d0 + do k=2,N_states + do i=1,N_csf + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dacos(-1.d0)*2.d0*r2 + U_csf(i,k) = r1*dcos(r2) + enddo + U_csf(k,k) = U_csf(k,k) +100.d0 + enddo + do k=1,N_states + call normalize(U_csf(1,k),N_csf) + enddo + call convertWFfromCSFtoDET(N_states,U_csf(1,1),psi_coef(1,1)) + deallocate(U_csf) + SOFT_TOUCH psi_coef + call run end @@ -56,13 +87,7 @@ subroutine run double precision :: cisdq(N_states), delta_e double precision,external :: diag_h_mat_elem - if(pseudo_sym)then - call H_apply_cisd_sym - else - call H_apply_cisd - endif psi_coef = ci_eigenvectors - SOFT_TOUCH psi_coef call save_wavefunction_truncated(save_threshold) call ezfio_set_cisd_energy(CI_energy) diff --git a/src/davidson/diagonalization_hcsf_dressed.irp.f b/src/davidson/diagonalization_hcsf_dressed.irp.f index 0c3c6f92..5f8aa4c9 100644 --- a/src/davidson/diagonalization_hcsf_dressed.irp.f +++ b/src/davidson/diagonalization_hcsf_dressed.irp.f @@ -263,29 +263,20 @@ subroutine davidson_diag_csf_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N ! =================== converged = .False. - + call convertWFfromDETtoCSF(N_st_diag,u_in(1,1),U_csf(1,1)) do k=N_st+1,N_st_diag - do i=1,sze + do i=1,sze_csf call random_number(r1) call random_number(r2) r1 = dsqrt(-2.d0*dlog(r1)) r2 = dtwo_pi*r2 - u_in(i,k) = r1*dcos(r2) * u_in(i,k-N_st) + U_csf(i,k) = r1*dcos(r2) * u_csf(i,k-N_st) enddo - u_in(k,k) = u_in(k,k) + 10.d0 + U_csf(k,k) = u_csf(k,k) + 10.d0 enddo do k=1,N_st_diag - call normalize(u_in(1,k),sze) + call normalize(U_csf(1,k),sze_csf) enddo - - do k=1,N_st_diag - do i=1,sze - U(i,k) = u_in(i,k) - enddo - enddo - - ! Make random verctors eigenstates of S2 - call convertWFfromDETtoCSF(N_st_diag,U(1,1),U_csf(1,1)) call convertWFfromCSFtoDET(N_st_diag,U_csf(1,1),U(1,1)) do while (.not.converged) diff --git a/src/determinants/determinants.irp.f b/src/determinants/determinants.irp.f index 4b317025..e1c14bfe 100644 --- a/src/determinants/determinants.irp.f +++ b/src/determinants/determinants.irp.f @@ -77,7 +77,7 @@ BEGIN_PROVIDER [ integer, psi_det_size ] END_DOC PROVIDE ezfio_filename logical :: exists - psi_det_size = 1 + psi_det_size = N_states PROVIDE mpi_master if (read_wf) then if (mpi_master) then @@ -85,7 +85,7 @@ BEGIN_PROVIDER [ integer, psi_det_size ] if (exists) then call ezfio_get_determinants_n_det(psi_det_size) else - psi_det_size = 1 + psi_det_size = N_states endif call write_int(6,psi_det_size,'Dimension of the psi arrays') endif From d11b7365cbd6c47718e84b908a5226dfb95d2f47 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 14 Jun 2022 18:15:53 +0200 Subject: [PATCH 39/80] Update itermax with CSF --- src/davidson/diagonalization_hcsf_dressed.irp.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/davidson/diagonalization_hcsf_dressed.irp.f b/src/davidson/diagonalization_hcsf_dressed.irp.f index 5f8aa4c9..7aaaa842 100644 --- a/src/davidson/diagonalization_hcsf_dressed.irp.f +++ b/src/davidson/diagonalization_hcsf_dressed.irp.f @@ -124,7 +124,7 @@ subroutine davidson_diag_csf_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N stop -1 endif - itermax = max(2,min(davidson_sze_max, sze/N_st_diag))+1 + itermax = max(2,min(davidson_sze_max, sze_csf/N_st_diag))+1 itertot = 0 if (state_following) then From e99e976c227f5c9c1c95f4b13af4aed406f4b5cd Mon Sep 17 00:00:00 2001 From: eginer Date: Wed, 15 Jun 2022 19:39:01 +0200 Subject: [PATCH 40/80] added pbe_ueg_self_contained.irp.f --- .../pbe_ueg_self_contained.irp.f | 62 +++++++++++++++++++ src/basis_correction/print_su_pbe_ot.irp.f | 1 + src/basis_correction/weak_corr_func.irp.f | 51 +++++++++++++++ src/dft_utils_func/ecmd_pbe_general.irp.f | 2 +- 4 files changed, 115 insertions(+), 1 deletion(-) create mode 100644 src/basis_correction/pbe_ueg_self_contained.irp.f diff --git a/src/basis_correction/pbe_ueg_self_contained.irp.f b/src/basis_correction/pbe_ueg_self_contained.irp.f new file mode 100644 index 00000000..afedfc9c --- /dev/null +++ b/src/basis_correction/pbe_ueg_self_contained.irp.f @@ -0,0 +1,62 @@ +double precision function ecmd_pbe_ueg_self_cont(dens,spin_pol,mu,e_PBE) + implicit none + ! dens = total density + ! spin_pol = spin_polarization (n_a - n_b)/dens + ! e_PBE = PBE correlation (mu=0) energy evaluated at (dens,spin_pol,grad_rho) + ! e_PBE = epsilon_PBE * dens + ! dens = a + b + ! spin_pol = (a - b)/(a+b) + ! spin_pol * dens = a - b + ! a - b + a+b = 2 a + ! a - b - a - b = - 2b + double precision, intent(in) :: dens,spin_pol,mu,e_PBE + double precision :: rho_a,rho_b,pi,g0_UEG_func,denom,beta + pi = dacos(-1.d0) + rho_a = (dens * spin_pol + dens)*0.5d0 + rho_b = (dens - dens * spin_pol)*0.5d0 + if(mu == 0.d0) then + ecmd_pbe_ueg_self_cont = e_PBE + else +! note: the on-top pair density is (1-zeta^2) rhoc^2 g0 = 4 rhoa * rhob * g0 + denom = (-2.d0+sqrt(2d0))*sqrt(2.d0*pi) * 4.d0*rho_a*rho_b*g0_UEG_func(rho_a,rho_b) + if (dabs(denom) > 1.d-12) then + beta = (3.d0*e_PBE)/denom + ecmd_pbe_ueg_self_cont=e_PBE/(1.d0+beta*mu**3) + else + ecmd_pbe_ueg_self_cont=0.d0 + endif + endif +end + +double precision function g0_UEG_func(rho_a,rho_b) +! Pair distribution function g0(n_alpha,n_beta) of the Colombic UEG +! +! Taken from Eq. (46) P. Gori-Giorgi and A. Savin, Phys. Rev. A 73, 032506 (2006). + implicit none + double precision, intent(in) :: rho_a,rho_b + double precision :: rho,pi,x + double precision :: B, C, D, E, d2, rs, ahd + rho = rho_a+rho_b + pi = 4d0 * datan(1d0) + ahd = -0.36583d0 + d2 = 0.7524d0 + B = -2d0 * ahd - d2 + C = 0.08193d0 + D = -0.01277d0 + E = 0.001859d0 + x = -d2*rs + if (dabs(rho) > 1.d-20) then + rs = (3d0 / (4d0*pi*rho))**(1d0/3d0) ! JT: serious bug fixed 20/03/19 + x = -d2*rs + if(dabs(x).lt.50.d0)then + g0_UEG_func= 0.5d0 * (1d0+ rs* (-B + rs*(C + rs*(D + rs*E))))*dexp(x) + else + g0_UEG_func= 0.d0 + endif + else + g0_UEG_func= 0.d0 + endif + g0_UEG_func = max(g0_UEG_func,1.d-14) + +end + diff --git a/src/basis_correction/print_su_pbe_ot.irp.f b/src/basis_correction/print_su_pbe_ot.irp.f index 49f90ade..dcd4b6f1 100644 --- a/src/basis_correction/print_su_pbe_ot.irp.f +++ b/src/basis_correction/print_su_pbe_ot.irp.f @@ -20,6 +20,7 @@ subroutine print_su_pbe_ot integer :: istate do istate = 1, N_states write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD PBE-UEG , state ',istate,' = ',ecmd_pbe_ueg_mu_of_r(istate) + write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ecmd_pbe_ueg_test , state ',istate,' = ',ecmd_pbe_ueg_test(istate) enddo do istate = 1, N_states write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD SU-PBE-OT , state ',istate,' = ',ecmd_pbe_on_top_su_mu_of_r(istate) diff --git a/src/basis_correction/weak_corr_func.irp.f b/src/basis_correction/weak_corr_func.irp.f index 6af5e49d..4d4f7075 100644 --- a/src/basis_correction/weak_corr_func.irp.f +++ b/src/basis_correction/weak_corr_func.irp.f @@ -81,3 +81,54 @@ BEGIN_PROVIDER [double precision, ecmd_pbe_ueg_mu_of_r, (N_states)] print*,'Time for the ecmd_pbe_ueg_mu_of_r:',wall1-wall0 END_PROVIDER + +BEGIN_PROVIDER [double precision, ecmd_pbe_ueg_test, (N_states)] +BEGIN_DOC +! test of the routines contained in pbe_ueg_self_contained.irp.f +END_DOC +implicit none +double precision :: weight +integer :: ipoint,istate,m +double precision :: mu,rho_a,rho_b +double precision :: dens,spin_pol,grad_rho,e_PBE,delta_rho +double precision :: ecmd_pbe_ueg_self_cont,eps_c_md_PBE +ecmd_pbe_ueg_test = 0.d0 + +do istate = 1, N_states + do ipoint = 1, n_points_final_grid + weight=final_weight_at_r_vector(ipoint) + + ! mu(r) defined by Eq. (37) of J. Chem. Phys. 149, 194301 (2018) + mu = mu_of_r_prov(ipoint,istate) + + ! conversion from rho_a,rho_b --> dens,spin_pol + rho_a = one_e_dm_and_grad_alpha_in_r(4,ipoint,istate) + rho_b = one_e_dm_and_grad_beta_in_r(4,ipoint,istate) + dens = rho_a + rho_b + spin_pol = (rho_a - rho_b)/(max(dens,1.d-12)) + delta_rho = rho_a - rho_b + + ! conversion from grad_rho_a ... to sigma + double precision :: grad_rho_a(3),grad_rho_b(3),grad_rho_a_2(3),grad_rho_b_2(3),grad_rho_a_b(3) + double precision :: sigmacc,sigmaco,sigmaoo + grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,ipoint,istate) + grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,ipoint,istate) + grad_rho_a_2 = 0.d0 + grad_rho_b_2 = 0.d0 + grad_rho_a_b = 0.d0 + do m = 1, 3 + grad_rho_a_2 += grad_rho_a(m)*grad_rho_a(m) + grad_rho_b_2 += grad_rho_b(m)*grad_rho_b(m) + grad_rho_a_b += grad_rho_a(m)*grad_rho_b(m) + enddo + call grad_rho_ab_to_grad_rho_oc(grad_rho_a_2,grad_rho_b_2,grad_rho_a_b,sigmaoo,sigmacc,sigmaco) + + ! call the PBE energy + call ec_pbe_only(0.d0,dens,delta_rho,sigmacc,sigmaco,sigmaoo,e_PBE) + eps_c_md_PBE = ecmd_pbe_ueg_self_cont(dens,spin_pol,mu,e_PBE) + + ecmd_pbe_ueg_test(istate) += eps_c_md_PBE * weight + enddo +enddo +! +END_PROVIDER diff --git a/src/dft_utils_func/ecmd_pbe_general.irp.f b/src/dft_utils_func/ecmd_pbe_general.irp.f index cf58092c..48f1608d 100644 --- a/src/dft_utils_func/ecmd_pbe_general.irp.f +++ b/src/dft_utils_func/ecmd_pbe_general.irp.f @@ -57,4 +57,4 @@ subroutine ec_md_pbe_on_top_general(mu,rho_a,rho_b,grad_rho_a,grad_rho_b,on_top, endif end - + From a407d7e15668f40da1c0bf12d1fc0a450ed69ba0 Mon Sep 17 00:00:00 2001 From: eginer Date: Fri, 17 Jun 2022 15:04:32 +0200 Subject: [PATCH 41/80] added test_ueg_self_contained.irp.f --- .../pbe_ueg_self_contained.irp.f | 13 +-- src/basis_correction/print_su_pbe_ot.irp.f | 6 +- .../test_ueg_self_contained.irp.f | 84 +++++++++++++++++++ src/becke_numerical_grid/grid_becke.irp.f | 6 +- 4 files changed, 95 insertions(+), 14 deletions(-) create mode 100644 src/basis_correction/test_ueg_self_contained.irp.f diff --git a/src/basis_correction/pbe_ueg_self_contained.irp.f b/src/basis_correction/pbe_ueg_self_contained.irp.f index afedfc9c..1dbc5e17 100644 --- a/src/basis_correction/pbe_ueg_self_contained.irp.f +++ b/src/basis_correction/pbe_ueg_self_contained.irp.f @@ -2,13 +2,8 @@ double precision function ecmd_pbe_ueg_self_cont(dens,spin_pol,mu,e_PBE) implicit none ! dens = total density ! spin_pol = spin_polarization (n_a - n_b)/dens - ! e_PBE = PBE correlation (mu=0) energy evaluated at (dens,spin_pol,grad_rho) - ! e_PBE = epsilon_PBE * dens - ! dens = a + b - ! spin_pol = (a - b)/(a+b) - ! spin_pol * dens = a - b - ! a - b + a+b = 2 a - ! a - b - a - b = - 2b + ! e_PBE = PBE correlation (mu=0) energy evaluated at dens,spin_pol (and grad_rho) + ! e_PBE = epsilon_PBE * dens which means that it is not the energy density but the energy density X the density double precision, intent(in) :: dens,spin_pol,mu,e_PBE double precision :: rho_a,rho_b,pi,g0_UEG_func,denom,beta pi = dacos(-1.d0) @@ -31,7 +26,7 @@ end double precision function g0_UEG_func(rho_a,rho_b) ! Pair distribution function g0(n_alpha,n_beta) of the Colombic UEG ! -! Taken from Eq. (46) P. Gori-Giorgi and A. Savin, Phys. Rev. A 73, 032506 (2006). +! Taken from Eq. (46) P. Gori-Giorgi and A. Savin, Phys. Rev. A 73, 032506 (2006). implicit none double precision, intent(in) :: rho_a,rho_b double precision :: rho,pi,x @@ -46,7 +41,7 @@ double precision function g0_UEG_func(rho_a,rho_b) E = 0.001859d0 x = -d2*rs if (dabs(rho) > 1.d-20) then - rs = (3d0 / (4d0*pi*rho))**(1d0/3d0) ! JT: serious bug fixed 20/03/19 + rs = (3d0 / (4d0*pi*rho))**(1d0/3d0) x = -d2*rs if(dabs(x).lt.50.d0)then g0_UEG_func= 0.5d0 * (1d0+ rs* (-B + rs*(C + rs*(D + rs*E))))*dexp(x) diff --git a/src/basis_correction/print_su_pbe_ot.irp.f b/src/basis_correction/print_su_pbe_ot.irp.f index dcd4b6f1..1d9416e5 100644 --- a/src/basis_correction/print_su_pbe_ot.irp.f +++ b/src/basis_correction/print_su_pbe_ot.irp.f @@ -22,8 +22,8 @@ subroutine print_su_pbe_ot write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD PBE-UEG , state ',istate,' = ',ecmd_pbe_ueg_mu_of_r(istate) write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ecmd_pbe_ueg_test , state ',istate,' = ',ecmd_pbe_ueg_test(istate) enddo - do istate = 1, N_states - write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD SU-PBE-OT , state ',istate,' = ',ecmd_pbe_on_top_su_mu_of_r(istate) - enddo +! do istate = 1, N_states +! write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD SU-PBE-OT , state ',istate,' = ',ecmd_pbe_on_top_su_mu_of_r(istate) +! enddo end diff --git a/src/basis_correction/test_ueg_self_contained.irp.f b/src/basis_correction/test_ueg_self_contained.irp.f new file mode 100644 index 00000000..7f08b875 --- /dev/null +++ b/src/basis_correction/test_ueg_self_contained.irp.f @@ -0,0 +1,84 @@ +program test_sc + implicit none + integer :: m + double precision :: r(3),f_hf,on_top,mu,sqpi + double precision :: rho_a,rho_b,w_hf,dens,delta_rho,e_pbe + double precision :: grad_rho_a(3),grad_rho_b(3),grad_rho_a_2(3),grad_rho_b_2(3),grad_rho_a_b(3) + double precision :: sigmacc,sigmaco,sigmaoo,spin_pol + double precision :: eps_c_md_PBE , ecmd_pbe_ueg_self_cont + r = 0.D0 + r(3) = 1.D0 + call f_HF_valence_ab(r,r,f_hf,on_top) + sqpi = dsqrt(dacos(-1.d0)) + if(on_top.le.1.d-12.or.f_hf.le.0.d0.or.f_hf * on_top.lt.0.d0)then + w_hf = 1.d+10 + else + w_hf = f_hf / on_top + endif + mu = sqpi * 0.5d0 * w_hf + call density_and_grad_alpha_beta(r,rho_a,rho_b, grad_rho_a, grad_rho_b) + dens = rho_a + rho_b + delta_rho = rho_a - rho_b + spin_pol = delta_rho/(max(1.d-10,dens)) + grad_rho_a_2 = 0.d0 + grad_rho_b_2 = 0.d0 + grad_rho_a_b = 0.d0 + do m = 1, 3 + grad_rho_a_2 += grad_rho_a(m)*grad_rho_a(m) + grad_rho_b_2 += grad_rho_b(m)*grad_rho_b(m) + grad_rho_a_b += grad_rho_a(m)*grad_rho_b(m) + enddo + call grad_rho_ab_to_grad_rho_oc(grad_rho_a_2,grad_rho_b_2,grad_rho_a_b,sigmaoo,sigmacc,sigmaco) + + ! call the PBE energy + print*,'f_hf,on_top = ',f_hf,on_top + print*,'mu = ',mu + print*,'dens,spin_pol',dens,spin_pol + call ec_pbe_only(0.d0,dens,delta_rho,sigmacc,sigmaco,sigmaoo,e_PBE) + print*,'e_PBE = ',e_PBE + eps_c_md_PBE = ecmd_pbe_ueg_self_cont(dens,spin_pol,mu,e_PBE) + print*,'eps_c_md_PBE = ',eps_c_md_PBE + + print*,'' + print*,'' + print*,'' + print*,'energy_c' ,energy_c + + integer::ipoint + double precision :: weight , accu + accu = 0.d0 + do ipoint = 1, n_points_final_grid + r = final_grid_points(:,ipoint) + weight = final_weight_at_r_vector(ipoint) + call f_HF_valence_ab(r,r,f_hf,on_top) + sqpi = dsqrt(dacos(-1.d0)) + if(on_top.le.1.d-12.or.f_hf.le.0.d0.or.f_hf * on_top.lt.0.d0)then + w_hf = 1.d+10 + else + w_hf = f_hf / on_top + endif + mu = sqpi * 0.5d0 * w_hf + call density_and_grad_alpha_beta(r,rho_a,rho_b, grad_rho_a, grad_rho_b) + dens = rho_a + rho_b + delta_rho = rho_a - rho_b + spin_pol = delta_rho/(max(1.d-10,dens)) + grad_rho_a_2 = 0.d0 + grad_rho_b_2 = 0.d0 + grad_rho_a_b = 0.d0 + do m = 1, 3 + grad_rho_a_2 += grad_rho_a(m)*grad_rho_a(m) + grad_rho_b_2 += grad_rho_b(m)*grad_rho_b(m) + grad_rho_a_b += grad_rho_a(m)*grad_rho_b(m) + enddo + call grad_rho_ab_to_grad_rho_oc(grad_rho_a_2,grad_rho_b_2,grad_rho_a_b,sigmaoo,sigmacc,sigmaco) + ! call the PBE energy + call ec_pbe_only(0.d0,dens,delta_rho,sigmacc,sigmaco,sigmaoo,e_PBE) + eps_c_md_PBE = ecmd_pbe_ueg_self_cont(dens,spin_pol,mu,e_PBE) + write(33,'(100(F16.10,X))')r(:), weight, w_hf, on_top, mu, dens, spin_pol, e_PBE, eps_c_md_PBE + accu += weight * eps_c_md_PBE + enddo + print*,'accu = ',accu + write(*, *) ' ECMD PBE-UEG ',ecmd_pbe_ueg_mu_of_r(1) + write(*, *) ' ecmd_pbe_ueg_test ',ecmd_pbe_ueg_test(1) + +end diff --git a/src/becke_numerical_grid/grid_becke.irp.f b/src/becke_numerical_grid/grid_becke.irp.f index 79f15c9a..48fd041a 100644 --- a/src/becke_numerical_grid/grid_becke.irp.f +++ b/src/becke_numerical_grid/grid_becke.irp.f @@ -64,7 +64,8 @@ END_PROVIDER END_PROVIDER -BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_angular,n_points_radial_grid,nucl_num)] + BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_angular,n_points_radial_grid,nucl_num)] +&BEGIN_PROVIDER [double precision, radial_points_per_atom, (n_points_radial_grid,nucl_num)] BEGIN_DOC ! x,y,z coordinates of grid points used for integration in 3d space END_DOC @@ -72,6 +73,7 @@ BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_ integer :: i,j,k double precision :: dr,x_ref,y_ref,z_ref double precision :: knowles_function + radial_points_per_atom = 0.D0 do i = 1, nucl_num x_ref = nucl_coord(i,1) y_ref = nucl_coord(i,2) @@ -83,7 +85,7 @@ BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_ ! value of the radial coordinate for the integration r = knowles_function(alpha_knowles(grid_atomic_number(i)),m_knowles,x) - + radial_points_per_atom(j,i) = r ! 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) = & From a0949cba45749d1e43a28273a1a9bdb05c2d1ab1 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sat, 18 Jun 2022 11:39:36 +0200 Subject: [PATCH 42/80] Better error handling on ocaml --- etc/qp.rc | 2 -- external/qp2-dependencies | 2 +- ocaml/Command_line.ml | 19 +++++++++++-------- ocaml/Command_line.mli | 2 ++ ocaml/qp_create_ezfio.ml | 11 ++++++++--- 5 files changed, 22 insertions(+), 14 deletions(-) diff --git a/etc/qp.rc b/etc/qp.rc index c56661c7..064ca3f7 100644 --- a/etc/qp.rc +++ b/etc/qp.rc @@ -80,8 +80,6 @@ function qp() if [[ -d $NAME ]] ; then [[ -d $EZFIO_FILE ]] && ezfio unset_file ezfio set_file $NAME - else - qp_create_ezfio -h | more fi unset _ARGS ;; diff --git a/external/qp2-dependencies b/external/qp2-dependencies index 242151e0..90ee61f5 160000 --- a/external/qp2-dependencies +++ b/external/qp2-dependencies @@ -1 +1 @@ -Subproject commit 242151e03d1d6bf042387226431d82d35845686a +Subproject commit 90ee61f5041c7c94a0c605625a264860292813a0 diff --git a/ocaml/Command_line.ml b/ocaml/Command_line.ml index 1dd57892..602315c6 100644 --- a/ocaml/Command_line.ml +++ b/ocaml/Command_line.ml @@ -1,3 +1,5 @@ +exception Error of string + type short_opt = char type long_opt = string type optional = Mandatory | Optional @@ -181,15 +183,16 @@ let set_specs specs_in = Getopt.parse_cmdline cmd_specs (fun x -> anon_args := !anon_args @ [x]); if show_help () then - (help () ; exit 0); + help () + else + (* Check that all mandatory arguments are set *) + List.filter (fun x -> x.short <> ' ' && x.opt = Mandatory) !specs + |> List.iter (fun x -> + match get x.long with + | Some _ -> () + | None -> raise (Error ("--"^x.long^" option is missing.")) + ) - (* Check that all mandatory arguments are set *) - List.filter (fun x -> x.short <> ' ' && x.opt = Mandatory) !specs - |> List.iter (fun x -> - match get x.long with - | Some _ -> () - | None -> failwith ("Error: --"^x.long^" option is missing.") - ) ;; diff --git a/ocaml/Command_line.mli b/ocaml/Command_line.mli index 9f6e7022..5ad4ee08 100644 --- a/ocaml/Command_line.mli +++ b/ocaml/Command_line.mli @@ -59,6 +59,8 @@ let () = *) +exception Error of string + type short_opt = char type long_opt = string diff --git a/ocaml/qp_create_ezfio.ml b/ocaml/qp_create_ezfio.ml index be6c305b..4583b118 100644 --- a/ocaml/qp_create_ezfio.ml +++ b/ocaml/qp_create_ezfio.ml @@ -677,6 +677,7 @@ let run ?o b au c d m p cart xyz_file = let () = + try ( let open Command_line in begin @@ -734,7 +735,7 @@ If a file with the same name as the basis set exists, this file will be read. O let basis = match Command_line.get "basis" with - | None -> assert false + | None -> "" | Some x -> x in @@ -773,10 +774,14 @@ If a file with the same name as the basis set exists, this file will be read. O let xyz_filename = match Command_line.anon_args () with - | [x] -> x - | _ -> (Command_line.help () ; failwith "input file is missing") + | [] -> failwith "input file is missing" + | x::_ -> x in run ?o:output basis au charge dummy multiplicity pseudo cart xyz_filename + ) + with + | Failure txt -> Printf.eprintf "Fatal error: %s\n%!" txt + | Command_line.Error txt -> Printf.eprintf "Command line error: %s\n%!" txt From f1a9a223997fa521e681ece7ce043f626c82c341 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sat, 18 Jun 2022 15:54:59 +0200 Subject: [PATCH 43/80] Improved truncate_wf --- src/tools/truncate_wf.irp.f | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/src/tools/truncate_wf.irp.f b/src/tools/truncate_wf.irp.f index 6c66c8ec..64c15bf7 100644 --- a/src/tools/truncate_wf.irp.f +++ b/src/tools/truncate_wf.irp.f @@ -54,11 +54,23 @@ subroutine routine_s2 double precision, allocatable :: psi_coef_tmp(:,:) integer :: i,j,k double precision :: accu(N_states) + integer :: weights(0:16), ix + double precision :: x - print *, 'Weights of the CFG' + weights(:) = 0 do i=1,N_det - print *, i, real(weight_configuration(det_to_configuration(i),:)), real(sum(weight_configuration(det_to_configuration(i),:))) + x = -dlog(1.d-32+sum(weight_configuration(det_to_configuration(i),:)))/dlog(10.d0) + ix = min(int(x), 16) + weights(ix) += 1 enddo + + print *, 'Histogram of the weights of the CFG' + do i=0,15 + print *, ' 10^{-', i, '} ', weights(i) + end do + print *, '< 10^{-', 15, '} ', weights(16) + + print*, 'Min weight of the configuration?' read(5,*) wmin From 0407def6782badc884946023753ba49196f0152d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 22 Jun 2022 23:19:18 +0200 Subject: [PATCH 44/80] dummy args in ocaml --- external/qp2-dependencies | 2 +- ocaml/Molecule.ml | 4 ++-- ocaml/qp_run.ml | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/external/qp2-dependencies b/external/qp2-dependencies index 90ee61f5..242151e0 160000 --- a/external/qp2-dependencies +++ b/external/qp2-dependencies @@ -1 +1 @@ -Subproject commit 90ee61f5041c7c94a0c605625a264860292813a0 +Subproject commit 242151e03d1d6bf042387226431d82d35845686a diff --git a/ocaml/Molecule.ml b/ocaml/Molecule.ml index 9b01ac3a..603244c8 100644 --- a/ocaml/Molecule.ml +++ b/ocaml/Molecule.ml @@ -101,7 +101,7 @@ let to_string_general ~f m = |> String.concat "\n" let to_string = - to_string_general ~f:(fun x -> Atom.to_string Units.Angstrom x) + to_string_general ~f:(fun x -> Atom.to_string ~units:Units.Angstrom x) let to_xyz = to_string_general ~f:Atom.to_xyz @@ -113,7 +113,7 @@ let of_xyz_string s = let l = String_ext.split s ~on:'\n' |> List.filter (fun x -> x <> "") - |> list_map (fun x -> Atom.of_string units x) + |> list_map (fun x -> Atom.of_string ~units x) in let ne = ( get_charge { nuclei=l ; diff --git a/ocaml/qp_run.ml b/ocaml/qp_run.ml index d096b15b..dfbab167 100644 --- a/ocaml/qp_run.ml +++ b/ocaml/qp_run.ml @@ -110,7 +110,7 @@ let run slave ?prefix exe ezfio_file = let task_thread = let thread = Thread.create ( fun () -> - TaskServer.run port_number ) + TaskServer.run ~port:port_number ) in thread (); in From f629fc993e05222e3e97674c51f39fa34f2b204c Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 29 Jun 2022 15:25:19 +0200 Subject: [PATCH 45/80] Fix normf=1 problem with gamess conversion --- bin/qp_convert_output_to_ezfio | 1 + 1 file changed, 1 insertion(+) diff --git a/bin/qp_convert_output_to_ezfio b/bin/qp_convert_output_to_ezfio index 07ad2236..4c440dd9 100755 --- a/bin/qp_convert_output_to_ezfio +++ b/bin/qp_convert_output_to_ezfio @@ -146,6 +146,7 @@ def write_ezfio(res, filename): ezfio.set_ao_basis_ao_nucl(at) ezfio.set_ao_basis_ao_prim_num(num_prim) ezfio.set_ao_basis_ao_power(power_x + power_y + power_z) + ezfio.set_ao_basis_ao_normalized(False) # ~#~#~#~#~#~#~ # # P a r s i n g # From b1c91c205b98a2ea36c44d1870e4ef2e4206af95 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 29 Jun 2022 15:38:03 +0200 Subject: [PATCH 46/80] Better handling of normf=1 --- bin/qp_convert_output_to_ezfio | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/bin/qp_convert_output_to_ezfio b/bin/qp_convert_output_to_ezfio index 4c440dd9..a6bbcf85 100755 --- a/bin/qp_convert_output_to_ezfio +++ b/bin/qp_convert_output_to_ezfio @@ -146,7 +146,13 @@ def write_ezfio(res, filename): ezfio.set_ao_basis_ao_nucl(at) ezfio.set_ao_basis_ao_prim_num(num_prim) ezfio.set_ao_basis_ao_power(power_x + power_y + power_z) - ezfio.set_ao_basis_ao_normalized(False) + try: + if res.normf == 0: + ezfio.set_ao_basis_ao_normalized(True) + elif res.normf == 1: + ezfio.set_ao_basis_ao_normalized(False) + except: + ezfio.set_ao_basis_ao_normalized(True) # ~#~#~#~#~#~#~ # # P a r s i n g # From 0e6ebdc5a2f806297bdb8eb6cc46d901ed4a7167 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 29 Jun 2022 15:43:35 +0200 Subject: [PATCH 47/80] Better handling of normf=1 --- bin/qp_convert_output_to_ezfio | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/bin/qp_convert_output_to_ezfio b/bin/qp_convert_output_to_ezfio index a6bbcf85..e7c44b37 100755 --- a/bin/qp_convert_output_to_ezfio +++ b/bin/qp_convert_output_to_ezfio @@ -147,11 +147,15 @@ def write_ezfio(res, filename): ezfio.set_ao_basis_ao_prim_num(num_prim) ezfio.set_ao_basis_ao_power(power_x + power_y + power_z) try: - if res.normf == 0: + normf = res.normf + if normf == 0: ezfio.set_ao_basis_ao_normalized(True) - elif res.normf == 1: + elif normf == 1: ezfio.set_ao_basis_ao_normalized(False) - except: + else: + print("BUG in NORMF") + sys.exit(0) + except AttributeError: ezfio.set_ao_basis_ao_normalized(True) # ~#~#~#~#~#~#~ # From eb4d6f254f7e6186d9db8acb5aea1836f54223df Mon Sep 17 00:00:00 2001 From: eginer Date: Wed, 29 Jun 2022 17:44:04 +0200 Subject: [PATCH 48/80] added Abdallah's non hermit davidson --- .../dav_ext_rout_nonsym_B1space.irp.f | 608 ++++++++++++++++++ 1 file changed, 608 insertions(+) create mode 100644 src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f diff --git a/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f b/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f new file mode 100644 index 00000000..c5127861 --- /dev/null +++ b/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f @@ -0,0 +1,608 @@ + +! --- + +subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N_st, N_st_diag_in, converged, hcalc) + + use mmap_module + + BEGIN_DOC + ! Generic modified-Davidson diagonalization + ! + ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson + ! + ! u_in : guess coefficients on the various states. Overwritten on exit by right eigenvectors + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! N_st_diag_in : Number of states in which H is diagonalized. Assumed > N_st + ! + ! Initial guess vectors are not necessarily orthonormal + ! + ! hcalc subroutine to compute W = H U (see routine hcalc_template for template of input/output) + END_DOC + + implicit none + + integer, intent(in) :: sze, N_st, N_st_diag_in + double precision, intent(in) :: H_jj(sze) + logical, intent(inout) :: converged + double precision, intent(inout) :: u_in(sze,N_st_diag_in) + double precision, intent(out) :: energies(N_st) + external hcalc + + character*(16384) :: write_buffer + integer :: iter, N_st_diag + integer :: i, j, k, m + integer :: iter2, itertot + logical :: disk_based + integer :: shift, shift2, itermax + integer :: nproc_target + integer :: order(N_st_diag_in) + double precision :: to_print(2,N_st) + double precision :: r1, r2, alpha + double precision :: cpu, wall + double precision :: cmax + double precision :: energy_shift(N_st_diag_in*davidson_sze_max) + double precision, allocatable :: U(:,:) + double precision, allocatable :: y(:,:), h(:,:), lambda(:) + double precision, allocatable :: residual_norm(:) + + integer :: i_omax + double precision :: lambda_tmp + double precision, allocatable :: U_tmp(:), overlap(:) + + double precision, allocatable :: W(:,:) + !double precision, pointer :: W(:,:) + double precision, external :: u_dot_v, u_dot_u + + + include 'constants.include.F' + + N_st_diag = N_st_diag_in + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, y, h, lambda + if(N_st_diag*3 > sze) then + print *, 'error in Davidson :' + print *, 'Increase n_det_max_full to ', N_st_diag*3 + stop -1 + endif + + itermax = max(2, min(davidson_sze_max, sze/N_st_diag)) + 1 + + provide threshold_nonsym_davidson + call write_time(6) + write(6,'(A)') '' + write(6,'(A)') 'Davidson Diagonalization' + write(6,'(A)') '------------------------' + write(6,'(A)') '' + + + ! Find max number of cores to fit in memory + ! ----------------------------------------- + + nproc_target = nproc + double precision :: rss + integer :: maxab + maxab = sze + + m=1 + disk_based = .False. + call resident_memory(rss) + do + r1 = 8.d0 * &! bytes + ( dble(sze)*(N_st_diag*itermax) &! U + + 1.d0*dble(sze*m)*(N_st_diag*itermax) &! W + + 2.d0*(N_st_diag*itermax)**2 &! h,y + + 2.d0*(N_st_diag*itermax) &! s2,lambda + + 1.d0*(N_st_diag) &! residual_norm + ! In H_S2_u_0_nstates_zmq + + 3.d0*(N_st_diag*N_det) &! u_t, v_t, s_t on collector + + 3.d0*(N_st_diag*N_det) &! u_t, v_t, s_t on slave + + 0.5d0*maxab &! idx0 in H_S2_u_0_nstates_openmp_work_* + + nproc_target * &! In OMP section + ( 1.d0*(N_int*maxab) &! buffer + + 3.5d0*(maxab) ) &! singles_a, singles_b, doubles, idx + ) / 1024.d0**3 + + if(nproc_target == 0) then + call check_mem(r1, irp_here) + nproc_target = 1 + exit + endif + + if(r1+rss < qp_max_mem) then + exit + endif + + if(itermax > 4) then + itermax = itermax - 1 + else if (m==1.and.disk_based_davidson) then + m = 0 + disk_based = .True. + itermax = 6 + else + nproc_target = nproc_target - 1 + endif + + enddo + + nthreads_davidson = nproc_target + TOUCH nthreads_davidson + + call write_int(6, N_st, 'Number of states') + call write_int(6, N_st_diag, 'Number of states in diagonalization') + call write_int(6, sze, 'Number of basis functions') + call write_int(6, nproc_target, 'Number of threads for diagonalization') + call write_double(6, r1, 'Memory(Gb)') + if(disk_based) then + print *, 'Using swap space to reduce RAM' + endif + + !--------------- + + write(6,'(A)') '' + write_buffer = '=====' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ ===========' + enddo + write(6,'(A)') write_buffer(1:6+41*N_st) + write_buffer = 'Iter' + do i=1,N_st + write_buffer = trim(write_buffer)//' Energy Residual ' + enddo + write(6,'(A)') write_buffer(1:6+41*N_st) + write_buffer = '=====' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ ===========' + enddo + write(6,'(A)') write_buffer(1:6+41*N_st) + + ! --- + + + allocate( W(sze,N_st_diag*itermax) ) + + allocate( & + ! Large + U(sze,N_st_diag*itermax), & + ! Small + h(N_st_diag*itermax,N_st_diag*itermax), & + y(N_st_diag*itermax,N_st_diag*itermax), & + lambda(N_st_diag*itermax), & + residual_norm(N_st_diag) & + ) + + U = 0.d0 + h = 0.d0 + y = 0.d0 + lambda = 0.d0 + residual_norm = 0.d0 + + + ASSERT (N_st > 0) + ASSERT (N_st_diag >= N_st) + ASSERT (sze > 0) + + ! Davidson iterations + ! =================== + + converged = .False. + + ! Initialize from N_st to N_st_diag with gaussian random numbers + ! to be sure to have overlap with any eigenvectors + do k = N_st+1, N_st_diag + u_in(k,k) = 10.d0 + do i = 1, sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + u_in(i,k) = r1*dcos(r2) + enddo + enddo + ! Normalize all states + do k = 1, N_st_diag + call normalize(u_in(1,k), sze) + enddo + + ! Copy from the guess input "u_in" to the working vectors "U" + do k = 1, N_st_diag + do i = 1, sze + U(i,k) = u_in(i,k) + enddo + enddo + + ! --- + + itertot = 0 + + do while (.not.converged) + + itertot = itertot + 1 + if(itertot == 8) then + exit + endif + + do iter = 1, itermax-1 + + shift = N_st_diag * (iter-1) + shift2 = N_st_diag * iter + + if( (iter > 1) .or. (itertot == 1) ) then + + ! Gram-Schmidt to orthogonalize all new guess with the previous vectors + call ortho_qr(U, size(U, 1), sze, shift2) + call ortho_qr(U, size(U, 1), sze, shift2) + + ! W = H U + call hcalc(W(1,shift+1), U(1,shift+1), N_st_diag, sze) + + else + + ! Already computed in update below + continue + endif + + ! Compute h_kl = = + ! ------------------------------------------- + call dgemm( 'T', 'N', shift2, shift2, sze, 1.d0 & + , U, size(U, 1), W, size(W, 1) & + , 0.d0, h, size(h, 1) ) + + + ! Diagonalize h y = lambda y + ! --------------------------- + call diag_nonsym_right(shift2, h(1,1), size(h, 1), y(1,1), size(y, 1), lambda(1), size(lambda, 1)) + + + ! Express eigenvectors of h in the determinant basis: + ! --------------------------------------------------- + + ! y(:,k) = rk + ! U(:,k) = Bk + ! U(:,shift2+k) = Rk = Bk x rk + call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 & + , U, size(U, 1), y, size(y, 1) & + , 0.d0, U(1,shift2+1), size(U, 1) ) + + do k = 1, N_st_diag + call normalize(U(1,shift2+k), sze) + enddo + + ! --- + ! select the max overlap + + ! + ! start test ------------------------------------------------------------------------ + ! + !double precision, allocatable :: Utest(:,:), Otest(:) + !allocate( Utest(sze,shift2), Otest(shift2) ) + + !call dgemm( 'N', 'N', sze, shift2, shift2, 1.d0 & + ! , U, size(U, 1), y, size(y, 1), 0.d0, Utest(1,1), size(Utest, 1) ) + !do k = 1, shift2 + ! call normalize(Utest(1,k), sze) + !enddo + !do j = 1, sze + ! write(455, '(100(1X, F16.10))') (Utest(j,k), k=1,shift2) + !enddo + + !do k = 1, shift2 + ! Otest(k) = 0.d0 + ! do i = 1, sze + ! Otest(k) += Utest(i,k) * u_in(i,1) + ! enddo + ! Otest(k) = dabs(Otest(k)) + ! print *, ' Otest =', k, Otest(k), lambda(k) + !enddo + + !deallocate(Utest, Otest) + ! + ! end test ------------------------------------------------------------------------ + ! + + + allocate( overlap(N_st_diag) ) + + do k = 1, N_st_diag + overlap(k) = 0.d0 + do i = 1, sze + overlap(k) = overlap(k) + U(i,shift2+k) * u_in(i,1) + enddo + overlap(k) = dabs(overlap(k)) + !print *, ' overlap =', k, overlap(k) + enddo + + lambda_tmp = 0.d0 + do k = 1, N_st_diag + if(overlap(k) .gt. lambda_tmp) then + i_omax = k + lambda_tmp = overlap(k) + endif + enddo + deallocate(overlap) + if( lambda_tmp .lt. 0.8d0) then + print *, ' very small overlap..' + print*, ' max overlap = ', lambda_tmp, i_omax + stop + endif + +! lambda_tmp = lambda(1) +! lambda(1) = lambda(i_omax) +! lambda(i_omax) = lambda_tmp +! +! allocate( U_tmp(sze) ) +! do i = 1, sze +! U_tmp(i) = U(i,shift2+1) +! U(i,shift2+1) = U(i,shift2+i_omax) +! U(i,shift2+i_omax) = U_tmp(i) +! enddo +! deallocate(U_tmp) +! +! allocate( U_tmp(N_st_diag*itermax) ) +! do i = 1, shift2 +! U_tmp(i) = y(i,1) +! y(i,1) = y(i,i_omax) +! y(i,i_omax) = U_tmp(i) +! enddo +! deallocate(U_tmp) + + ! --- + + !do k = 1, N_st_diag + ! call normalize(U(1,shift2+k), sze) + !enddo + + ! --- + + ! y(:,k) = rk + ! W(:,k) = H x Bk + ! W(:,shift2+k) = H x Bk x rk + ! = Wk + call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 & + , W, size(W, 1), y, size(y, 1) & + , 0.d0, W(1,shift2+1), size(W, 1) ) + + ! --- + + ! Compute residual vector and davidson step + ! ----------------------------------------- + + !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,k) + do k = 1, N_st_diag + do i = 1, sze + U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k)) / max(H_jj(i)-lambda(k), 1.d-2) + enddo + !if(k <= N_st) then + ! residual_norm(k) = u_dot_u(U(1,shift2+k), sze) + ! to_print(1,k) = lambda(k) + ! to_print(2,k) = residual_norm(k) + !endif + enddo + !$OMP END PARALLEL DO + residual_norm(1) = u_dot_u(U(1,shift2+i_omax), sze) + to_print(1,1) = lambda(i_omax) + to_print(2,1) = residual_norm(1) + + + if( (itertot > 1) .and. (iter == 1) ) then + !don't print + continue + else + write(*, '(1X, I3, 1X, 100(1X, F16.10, 1X, F16.10, 1X, F16.10))') iter-1, to_print(1:2,1:N_st) + endif + + ! Check convergence + if(iter > 1) then + converged = dabs(maxval(residual_norm(1:N_st))) < threshold_nonsym_davidson + endif + + do k = 1, N_st + if(residual_norm(k) > 1.e8) then + print *, 'Davidson failed' + stop -1 + endif + enddo + if(converged) then + exit + endif + + logical, external :: qp_stop + if(qp_stop()) then + converged = .True. + exit + endif + + enddo ! loop over iter + + + ! Re-contract U and update W + ! -------------------------------- + + call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 & + , W, size(W, 1), y, size(y, 1) & + , 0.d0, u_in, size(u_in, 1) ) + do k = 1, N_st_diag + do i = 1, sze + W(i,k) = u_in(i,k) + enddo + enddo + + call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 & + , U, size(U, 1), y, size(y, 1) & + , 0.d0, u_in, size(u_in, 1) ) + do k = 1, N_st_diag + do i = 1, sze + U(i,k) = u_in(i,k) + enddo + enddo + + call ortho_qr(U, size(U, 1), sze, N_st_diag) + call ortho_qr(U, size(U, 1), sze, N_st_diag) + do j = 1, N_st_diag + k = 1 + do while( (k < sze) .and. (U(k,j) == 0.d0) ) + k = k+1 + enddo + if(U(k,j) * u_in(k,j) < 0.d0) then + do i = 1, sze + W(i,j) = -W(i,j) + enddo + endif + enddo + + enddo ! loop over while + + ! --- + + do k = 1, N_st + energies(k) = lambda(k) + enddo + write_buffer = '=====' + do i = 1, N_st + write_buffer = trim(write_buffer)//' ================ ===========' + enddo + write(6,'(A)') trim(write_buffer) + write(6,'(A)') '' + call write_time(6) + + deallocate(W) + deallocate(U, h, y, lambda, residual_norm) + + FREE nthreads_davidson + +end subroutine davidson_general_ext_rout_nonsym_b1space + +! --- + +subroutine diag_nonsym_right(n, A, A_ldim, V, V_ldim, energy, E_ldim) + + implicit none + + integer, intent(in) :: n, A_ldim, V_ldim, E_ldim + double precision, intent(in) :: A(A_ldim,n) + double precision, intent(out) :: energy(E_ldim), V(V_ldim,n) + + character*1 :: JOBVL, JOBVR, BALANC, SENSE + integer :: i, j + integer :: ILO, IHI, lda, ldvl, ldvr, LWORK, INFO + double precision :: ABNRM + integer, allocatable :: iorder(:), IWORK(:) + double precision, allocatable :: WORK(:), SCALE_array(:), RCONDE(:), RCONDV(:) + double precision, allocatable :: Atmp(:,:), WR(:), WI(:), VL(:,:), VR(:,:), Vtmp(:) + double precision, allocatable :: energy_loc(:), V_loc(:,:) + + allocate( Atmp(n,n), WR(n), WI(n), VL(1,1), VR(n,n) ) + do i = 1, n + do j = 1, n + Atmp(j,i) = A(j,i) + enddo + enddo + + JOBVL = "N" ! computes the left eigenvectors + JOBVR = "V" ! computes the right eigenvectors + BALANC = "B" ! Diagonal scaling and Permutation for optimization + SENSE = "V" ! Determines which reciprocal condition numbers are computed + lda = n + ldvr = n + ldvl = 1 + + allocate( WORK(1), SCALE_array(n), RCONDE(n), RCONDV(n), IWORK(2*n-2) ) + + LWORK = -1 ! to ask for the optimal size of WORK + call dgeevx( BALANC, JOBVL, JOBVR, SENSE & ! CHARACTERS + , n, Atmp, lda & ! MATRIX TO DIAGONALIZE + , WR, WI & ! REAL AND IMAGINARY PART OF EIGENVALUES + , VL, ldvl, VR, ldvr & ! LEFT AND RIGHT EIGENVECTORS + , ILO, IHI, SCALE_array, ABNRM, RCONDE, RCONDV & ! OUTPUTS OF OPTIMIZATION + , WORK, LWORK, IWORK, INFO ) + + if(INFO .ne. 0) then + print*, 'dgeevx failed !!', INFO + stop + endif + + LWORK = max(int(work(1)), 1) ! this is the optimal size of WORK + deallocate(WORK) + allocate(WORK(LWORK)) + call dgeevx( BALANC, JOBVL, JOBVR, SENSE & + , n, Atmp, lda & + , WR, WI & + , VL, ldvl, VR, ldvr & + , ILO, IHI, SCALE_array, ABNRM, RCONDE, RCONDV & + , WORK, LWORK, IWORK, INFO ) + if(INFO .ne. 0) then + print*, 'dgeevx failed !!', INFO + stop + endif + + deallocate( WORK, SCALE_array, RCONDE, RCONDV, IWORK ) + deallocate( VL, Atmp ) + + + allocate( energy_loc(n), V_loc(n,n) ) + energy_loc = 0.d0 + V_loc = 0.d0 + + i = 1 + do while(i .le. n) + +! print*, i, WR(i), WI(i) + + if( dabs(WI(i)) .gt. 1e-7 ) then + + print*, ' Found an imaginary component to eigenvalue' + print*, ' Re(i) + Im(i)', i, WR(i), WI(i) + + energy_loc(i) = WR(i) + do j = 1, n + V_loc(j,i) = WR(i) * VR(j,i) - WI(i) * VR(j,i+1) + enddo + energy_loc(i+1) = WI(i) + do j = 1, n + V_loc(j,i+1) = WR(i) * VR(j,i+1) + WI(i) * VR(j,i) + enddo + i = i + 2 + + else + + energy_loc(i) = WR(i) + do j = 1, n + V_loc(j,i) = VR(j,i) + enddo + i = i + 1 + + endif + + enddo + + deallocate(WR, WI, VR) + + + ! ordering +! do j = 1, n +! write(444, '(100(1X, F16.10))') (V_loc(j,i), i=1,5) +! enddo + allocate( iorder(n) ) + do i = 1, n + iorder(i) = i + enddo + call dsort(energy_loc, iorder, n) + do i = 1, n + energy(i) = energy_loc(i) + do j = 1, n + V(j,i) = V_loc(j,iorder(i)) + enddo + enddo + deallocate(iorder) +! do j = 1, n +! write(445, '(100(1X, F16.10))') (V_loc(j,i), i=1,5) +! enddo + deallocate(V_loc, energy_loc) + +end subroutine diag_nonsym_right + +! --- + From 25201fc4beca4efae4c1f0751663ba5c0110dab6 Mon Sep 17 00:00:00 2001 From: eginer Date: Wed, 29 Jun 2022 17:46:27 +0200 Subject: [PATCH 49/80] added Abdallah's non hermit davidson --- src/davidson/EZFIO.cfg | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/davidson/EZFIO.cfg b/src/davidson/EZFIO.cfg index 92c41b4c..b7fb633c 100644 --- a/src/davidson/EZFIO.cfg +++ b/src/davidson/EZFIO.cfg @@ -63,3 +63,10 @@ type: logical doc: If |true|, don't use denominator default: False interface: ezfio,provider,ocaml + +[threshold_nonsym_davidson] +type: Threshold +doc: Thresholds of non-symetric Davidson's algorithm +interface: ezfio,provider,ocaml +default: 1.e-5 + From 17d20c6880a8fcc4e9fa2441a3e32eace8286238 Mon Sep 17 00:00:00 2001 From: eginer Date: Thu, 30 Jun 2022 18:02:04 +0200 Subject: [PATCH 50/80] removed stupid bug in scf_utils/scf_density_matrix_ao.irp.f in the case of elec_beta_num==0 --- src/davidson/EZFIO.cfg | 2 +- src/scf_utils/scf_density_matrix_ao.irp.f | 16 ++++++++++------ 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/src/davidson/EZFIO.cfg b/src/davidson/EZFIO.cfg index b7fb633c..8696d72e 100644 --- a/src/davidson/EZFIO.cfg +++ b/src/davidson/EZFIO.cfg @@ -68,5 +68,5 @@ interface: ezfio,provider,ocaml type: Threshold doc: Thresholds of non-symetric Davidson's algorithm interface: ezfio,provider,ocaml -default: 1.e-5 +default: 1.e-6 diff --git a/src/scf_utils/scf_density_matrix_ao.irp.f b/src/scf_utils/scf_density_matrix_ao.irp.f index 55fa8e7c..6154c333 100644 --- a/src/scf_utils/scf_density_matrix_ao.irp.f +++ b/src/scf_utils/scf_density_matrix_ao.irp.f @@ -3,11 +3,13 @@ BEGIN_PROVIDER [double precision, SCF_density_matrix_ao_alpha, (ao_num,ao_num) ] BEGIN_DOC ! $C.C^t$ over $\alpha$ MOs END_DOC - - call dgemm('N','T',ao_num,ao_num,elec_alpha_num,1.d0, & - mo_coef, size(mo_coef,1), & - mo_coef, size(mo_coef,1), 0.d0, & - SCF_density_matrix_ao_alpha, size(SCF_density_matrix_ao_alpha,1)) + SCF_density_matrix_ao_alpha = 0.d0 + if(elec_alpha_num.gt.0)then + call dgemm('N','T',ao_num,ao_num,elec_alpha_num,1.d0, & + mo_coef, size(mo_coef,1), & + mo_coef, size(mo_coef,1), 0.d0, & + SCF_density_matrix_ao_alpha, size(SCF_density_matrix_ao_alpha,1)) + endif END_PROVIDER @@ -16,11 +18,13 @@ BEGIN_PROVIDER [ double precision, SCF_density_matrix_ao_beta, (ao_num,ao_num) BEGIN_DOC ! $C.C^t$ over $\beta$ MOs END_DOC - + SCF_density_matrix_ao_beta = 0.d0 + if(elec_beta_num.gt.0)then call dgemm('N','T',ao_num,ao_num,elec_beta_num,1.d0, & mo_coef, size(mo_coef,1), & mo_coef, size(mo_coef,1), 0.d0, & SCF_density_matrix_ao_beta, size(SCF_density_matrix_ao_beta,1)) + endif END_PROVIDER From a6ffaa7da148bd24313112425507fe68bc4d0a6a Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 21 Apr 2022 13:39:01 +0200 Subject: [PATCH 51/80] Update test values --- src/fci/40.fci.bats | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/fci/40.fci.bats b/src/fci/40.fci.bats index 1a0c5507..b8528e97 100644 --- a/src/fci/40.fci.bats +++ b/src/fci/40.fci.bats @@ -71,7 +71,7 @@ function run_stoch() { @test "HBO" { # 13.3144s [[ -n $TRAVIS ]] && skip qp set_file hbo.ezfio - run -100.214099486337 1.e-3 100000 + run -100.213 1.e-3 100000 } @test "H2O" { # 11.3727s @@ -89,7 +89,7 @@ function run_stoch() { @test "SO" { # 13.4952s [[ -n $TRAVIS ]] && skip qp set_file so.ezfio - run -26.0176563764039 1.e-3 100000 + run -26.014 5.e-3 100000 } @test "H2S" { # 13.6745s @@ -119,7 +119,7 @@ function run_stoch() { @test "SiH3" { # 15.99s [[ -n $TRAVIS ]] && skip qp set_file sih3.ezfio - run -5.57241217753818 5.e-4 100000 + run -5.572 1.e-3 100000 } @test "CH4" { # 16.1612s @@ -153,7 +153,7 @@ function run_stoch() { [[ -n $TRAVIS ]] && skip qp set_file n2.ezfio qp set_mo_class --core="[1,2]" --act="[3-40]" --del="[41-60]" - run -109.287917088107 1.5e-3 100000 + run -109.288 2.e-3 100000 } @test "N2H4" { # 18.5006s From d2c40fc1cb3afa6c22a0ef05eb16f25abf8b631f Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 21 Apr 2022 13:42:10 +0200 Subject: [PATCH 52/80] Update test values --- src/fci/40.fci.bats | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/fci/40.fci.bats b/src/fci/40.fci.bats index b8528e97..d890d586 100644 --- a/src/fci/40.fci.bats +++ b/src/fci/40.fci.bats @@ -42,7 +42,7 @@ function run_stoch() { [[ -n $TRAVIS ]] && skip qp set_file f2.ezfio qp set_frozen_core - run_stoch -199.304922384814 3.e-4 100000 + run_stoch -199.304922384814 3.e-3 100000 } @test "NH3" { # 10.6657s @@ -89,7 +89,7 @@ function run_stoch() { @test "SO" { # 13.4952s [[ -n $TRAVIS ]] && skip qp set_file so.ezfio - run -26.014 5.e-3 100000 + run -26.015 3.e-3 100000 } @test "H2S" { # 13.6745s @@ -146,7 +146,7 @@ function run_stoch() { [[ -n $TRAVIS ]] && skip qp set_file c2h2.ezfio qp set_mo_class --act="[1-30]" --del="[31-36]" - run -12.3685464085969 2.e-3 100000 + run -12.367 3.e-3 100000 } @test "N2" { # 18.0198s @@ -182,6 +182,6 @@ function run_stoch() { [[ -n $TRAVIS ]] && skip qp set_file hcn.ezfio qp set_mo_class --core="[1,2]" --act="[3-40]" --del="[41-55]" - run -93.0777619629755 1.e-3 100000 + run -93.078 2.e-3 100000 } From c429ed483a7f05db00df06b8597b9f8a3087fbf3 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 4 Jul 2022 15:20:15 +0200 Subject: [PATCH 53/80] Discussion list QP --- README.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/README.md b/README.md index 24d6277e..b03f2ecc 100644 --- a/README.md +++ b/README.md @@ -35,6 +35,12 @@ https://arxiv.org/abs/1902.08154 * [Download the latest release](http://github.com/QuantumPackage/qp2/releases) * [Read the documentation](https://quantum-package.readthedocs.io) +# Discussion list + +For any questions or announcements regarding QuantumPackage, you can join our discussion list by registering [here](https://groupes.renater.fr/sympa/subscribe/quantum_package) or by sending an email to `quantum_package-request@groupes.renater.fr` . +You can also look over its [archives](https://groupes.renater.fr/sympa/arc/quantum_package). + + # Build status * Master [![master build status](https://travis-ci.com/QuantumPackage/qp2.svg?branch=master)](https://travis-ci.org/QuantumPackage/qp2) From d919d6ce7df82a429a08e82df64ccab69aab78b1 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Tue, 5 Jul 2022 01:17:43 +0200 Subject: [PATCH 54/80] forked v --- external/Python/docopt.py | 579 +++++++++++++ include/f77_zmq.h | 617 ++++++++++++++ ocaml/Command_line.ml | 19 +- ocaml/Command_line.mli | 2 - ocaml/Input_ao_two_e_eff_pot.ml | 113 +++ ocaml/Input_bi_ortho_mos.ml | 87 ++ ocaml/Input_cassd.ml | 113 +++ ocaml/Input_cipsi_deb.ml | 243 ++++++ ocaml/Input_tc_h_clean.ml | 351 ++++++++ ocaml/Input_tc_scf.ml | 143 ++++ ocaml/Molecule.ml | 4 +- ocaml/Qputils.ml | 4 - ocaml/qp_create_ezfio.ml | 97 +-- ocaml/qp_run.ml | 2 +- ocaml/qp_tunnel.ml | 131 ++- src/ao_basis/EZFIO.cfg | 2 +- src/ao_basis/aos.irp.f | 28 +- src/ao_basis/aos_in_r.irp.f | 26 +- src/ao_basis/spherical_to_cartesian.irp.f | 2 +- src/ao_one_e_ints/NEED | 1 + src/ao_one_e_ints/ao_overlap.irp.f | 184 +++-- src/ao_one_e_ints/kin_ao_ints.irp.f | 206 ++--- src/ao_one_e_ints/pot_ao_ints.irp.f | 182 ++-- src/ao_one_e_ints/pot_ao_pseudo_ints.irp.f | 4 +- src/ao_two_e_ints/EZFIO.cfg | 7 - src/ao_two_e_ints/gauss_legendre.irp.f | 57 -- src/ao_two_e_ints/map_integrals.irp.f | 2 - src/ao_two_e_ints/test_cosgtos_1e.irp.f | 191 +++++ src/ao_two_e_ints/test_cosgtos_2e.irp.f | 165 ++++ src/ao_two_e_ints/two_e_integrals.irp.f | 194 +++-- src/basis/EZFIO.cfg | 10 +- src/basis/basis.irp.f | 9 +- src/basis_correction/print_routine.irp.f | 2 +- .../grid_becke_vector.irp.f | 14 - src/bitmask/bitmasks_routines.irp.f | 15 - src/cipsi/EZFIO.cfg | 12 +- src/cipsi/NEED | 1 + src/cipsi/cipsi.irp.f | 4 +- src/cipsi/pert_rdm_providers.irp.f | 183 ++++ src/cipsi/pt2_stoch_routines.irp.f | 124 +-- src/cipsi/run_pt2_slave.irp.f | 55 +- src/cipsi/run_selection_slave.irp.f | 8 +- src/cipsi/selection.irp.f | 102 +-- src/cipsi/selection_buffer.irp.f | 92 +-- src/cipsi/selection_weight.irp.f | 24 +- src/cipsi/slave_cipsi.irp.f | 8 +- src/cipsi/stochastic_cipsi.irp.f | 4 +- src/cipsi/update_2rdm.irp.f | 223 +++++ src/cipsi/zmq_selection.irp.f | 2 +- src/cis/cis.irp.f | 11 +- src/cis_read/EZFIO.cfg | 7 - src/cis_read/NEED | 3 - src/cis_read/README.rst | 5 - src/cis_read/cis_read.irp.f | 88 -- src/cis_read/h_apply.irp.f | 14 - src/cisd/cisd.irp.f | 94 +-- src/csf/configurations.irp.f | 24 - src/csf/conversion.irp.f | 23 +- src/csf/sigma_vector.irp.f | 75 +- .../dav_diag_dressed_ext_rout.irp.f | 32 +- src/dav_general_mat/dav_ext_rout.irp.f | 4 +- .../dav_ext_rout_nonsym_B1space.irp.f | 608 ++++++++++++++ src/dav_general_mat/dav_general.irp.f | 4 +- src/davidson/EZFIO.cfg | 6 + src/davidson/davidson_parallel.irp.f | 2 +- src/davidson/davidson_parallel_csf.irp.f | 3 +- src/davidson/davidson_parallel_nos2.irp.f | 3 +- .../diagonalization_hcsf_dressed.irp.f | 44 +- .../diagonalization_hs2_dressed.irp.f | 10 +- src/davidson/diagonalize_ci.irp.f | 26 +- .../print_e_components.irp.f | 0 src/davidson/u0_hs2_u0.irp.f | 16 +- src/davidson_dressed/diagonalize_ci.irp.f | 318 +++---- src/determinants/EZFIO.cfg | 17 +- src/determinants/density_matrix.irp.f | 95 +-- src/determinants/determinants.irp.f | 110 ++- src/determinants/dipole_moments.irp.f | 41 +- src/determinants/h_apply.irp.f | 5 +- src/determinants/s2.irp.f | 6 +- src/determinants/slater_rules.irp.f | 40 +- src/determinants/slater_rules_wee_mono.irp.f | 3 + .../spindeterminants.ezfio_config | 2 + src/determinants/spindeterminants.irp.f | 2 +- src/determinants/utils.irp.f | 12 +- src/dft_one_e/NEED | 1 - src/dft_one_e/mu_erf_dft.irp.f | 70 -- src/dft_utils_func/mu_of_r_dft.irp.f | 37 - src/dft_utils_func/mu_rsc.irp.f | 13 + src/dft_utils_func/on_top_from_ueg.irp.f | 4 +- src/dft_utils_in_r/ao_in_r.irp.f | 34 +- src/dft_utils_in_r/ints_grad.irp.f | 39 - src/dft_utils_in_r/mo_in_r.irp.f | 2 +- src/dressing/alpha_factory.irp.f | 2 +- src/dressing/run_dress_slave.irp.f | 6 +- src/ezfio_files/output.irp.f | 2 +- src/functionals/sr_lda.irp.f | 18 +- src/functionals/sr_pbe.irp.f | 14 +- src/iterations/print_extrapolation.irp.f | 3 +- src/iterations/print_summary.irp.f | 14 +- src/kohn_sham_rs/rs_ks_scf.irp.f | 2 +- src/mo_basis/mos_in_r.irp.f | 3 - src/mo_guess/h_core_guess_routine.irp.f | 2 +- src/mo_two_e_erf_ints/map_integrals_erf.irp.f | 12 +- src/mo_two_e_ints/core_quantities.irp.f | 2 +- src/mo_two_e_ints/map_integrals.irp.f | 30 +- src/mo_two_e_ints/mo_bi_integrals.irp.f | 94 +-- src/mu_of_r/basis_def.irp.f | 18 +- src/mu_of_r/mu_of_r_conditions.irp.f | 2 +- src/scf_utils/scf_density_matrix_ao.irp.f | 11 + src/tools/NEED | 1 - src/tools/molden.irp.f | 2 +- src/tools/print_dipole.irp.f | 4 +- src/tools/print_wf.irp.f | 6 +- src/tools/save_natorb_no_ov_rot.irp.f | 25 - src/tools/save_natorb_no_ref.irp.f | 24 - src/tools/truncate_wf.irp.f | 110 --- src/two_body_rdm/two_e_dm_mo.irp.f | 7 +- .../davidson_like_state_av_2rdm.irp.f | 8 +- src/utils/EZFIO.cfg | 1 + src/utils/cgtos_one_e.irp.f | 120 +++ src/utils/cgtos_utils.irp.f | 780 ++++++++++++++++++ src/utils/constants.include.F | 3 +- src/utils/cpx_erf.irp.f | 204 +++++ src/utils/format_w_error.irp.f | 71 -- src/utils/integration.irp.f | 117 ++- src/utils/linear_algebra.irp.f | 100 +++ src/utils/map_module.f90 | 6 +- src/utils/memory.irp.f | 2 +- src/utils/qsort.c | 373 --------- src/utils/qsort.org | 169 ---- src/utils/qsort_module.f90 | 347 -------- src/utils/set_multiple_levels_omp.irp.f | 26 - src/utils/sort.irp.f | 693 ++++++++++++++++ src/utils/units.irp.f | 22 - src/utils/util.irp.f | 31 +- 135 files changed, 6878 insertions(+), 3210 deletions(-) create mode 100644 external/Python/docopt.py create mode 100644 include/f77_zmq.h create mode 100644 ocaml/Input_ao_two_e_eff_pot.ml create mode 100644 ocaml/Input_bi_ortho_mos.ml create mode 100644 ocaml/Input_cassd.ml create mode 100644 ocaml/Input_cipsi_deb.ml create mode 100644 ocaml/Input_tc_h_clean.ml create mode 100644 ocaml/Input_tc_scf.ml delete mode 100644 src/ao_two_e_ints/gauss_legendre.irp.f create mode 100644 src/ao_two_e_ints/test_cosgtos_1e.irp.f create mode 100644 src/ao_two_e_ints/test_cosgtos_2e.irp.f create mode 100644 src/cipsi/pert_rdm_providers.irp.f create mode 100644 src/cipsi/update_2rdm.irp.f delete mode 100644 src/cis_read/EZFIO.cfg delete mode 100644 src/cis_read/NEED delete mode 100644 src/cis_read/README.rst delete mode 100644 src/cis_read/cis_read.irp.f delete mode 100644 src/cis_read/h_apply.irp.f create mode 100644 src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f rename src/{two_body_rdm => davidson}/print_e_components.irp.f (100%) delete mode 100644 src/dft_utils_func/mu_of_r_dft.irp.f create mode 100644 src/dft_utils_func/mu_rsc.irp.f delete mode 100644 src/dft_utils_in_r/ints_grad.irp.f delete mode 100644 src/tools/save_natorb_no_ov_rot.irp.f delete mode 100644 src/tools/save_natorb_no_ref.irp.f delete mode 100644 src/tools/truncate_wf.irp.f create mode 100644 src/utils/cgtos_one_e.irp.f create mode 100644 src/utils/cgtos_utils.irp.f create mode 100644 src/utils/cpx_erf.irp.f delete mode 100644 src/utils/format_w_error.irp.f delete mode 100644 src/utils/qsort.c delete mode 100644 src/utils/qsort.org delete mode 100644 src/utils/qsort_module.f90 delete mode 100644 src/utils/set_multiple_levels_omp.irp.f delete mode 100644 src/utils/units.irp.f diff --git a/external/Python/docopt.py b/external/Python/docopt.py new file mode 100644 index 00000000..7b927e2f --- /dev/null +++ b/external/Python/docopt.py @@ -0,0 +1,579 @@ +"""Pythonic command-line interface parser that will make you smile. + + * http://docopt.org + * Repository and issue-tracker: https://github.com/docopt/docopt + * Licensed under terms of MIT license (see LICENSE-MIT) + * Copyright (c) 2013 Vladimir Keleshev, vladimir@keleshev.com + +""" +import sys +import re + + +__all__ = ['docopt'] +__version__ = '0.6.2' + + +class DocoptLanguageError(Exception): + + """Error in construction of usage-message by developer.""" + + +class DocoptExit(SystemExit): + + """Exit in case user invoked program with incorrect arguments.""" + + usage = '' + + def __init__(self, message=''): + SystemExit.__init__(self, (message + '\n' + self.usage).strip()) + + +class Pattern(object): + + def __eq__(self, other): + return repr(self) == repr(other) + + def __hash__(self): + return hash(repr(self)) + + def fix(self): + self.fix_identities() + self.fix_repeating_arguments() + return self + + def fix_identities(self, uniq=None): + """Make pattern-tree tips point to same object if they are equal.""" + if not hasattr(self, 'children'): + return self + uniq = list(set(self.flat())) if uniq is None else uniq + for i, c in enumerate(self.children): + if not hasattr(c, 'children'): + assert c in uniq + self.children[i] = uniq[uniq.index(c)] + else: + c.fix_identities(uniq) + + def fix_repeating_arguments(self): + """Fix elements that should accumulate/increment values.""" + either = [list(c.children) for c in self.either.children] + for case in either: + for e in [c for c in case if case.count(c) > 1]: + if type(e) is Argument or type(e) is Option and e.argcount: + if e.value is None: + e.value = [] + elif type(e.value) is not list: + e.value = e.value.split() + if type(e) is Command or type(e) is Option and e.argcount == 0: + e.value = 0 + return self + + @property + def either(self): + """Transform pattern into an equivalent, with only top-level Either.""" + # Currently the pattern will not be equivalent, but more "narrow", + # although good enough to reason about list arguments. + ret = [] + groups = [[self]] + while groups: + children = groups.pop(0) + types = [type(c) for c in children] + if Either in types: + either = [c for c in children if type(c) is Either][0] + children.pop(children.index(either)) + for c in either.children: + groups.append([c] + children) + elif Required in types: + required = [c for c in children if type(c) is Required][0] + children.pop(children.index(required)) + groups.append(list(required.children) + children) + elif Optional in types: + optional = [c for c in children if type(c) is Optional][0] + children.pop(children.index(optional)) + groups.append(list(optional.children) + children) + elif AnyOptions in types: + optional = [c for c in children if type(c) is AnyOptions][0] + children.pop(children.index(optional)) + groups.append(list(optional.children) + children) + elif OneOrMore in types: + oneormore = [c for c in children if type(c) is OneOrMore][0] + children.pop(children.index(oneormore)) + groups.append(list(oneormore.children) * 2 + children) + else: + ret.append(children) + return Either(*[Required(*e) for e in ret]) + + +class ChildPattern(Pattern): + + def __init__(self, name, value=None): + self.name = name + self.value = value + + def __repr__(self): + return '%s(%r, %r)' % (self.__class__.__name__, self.name, self.value) + + def flat(self, *types): + return [self] if not types or type(self) in types else [] + + def match(self, left, collected=None): + collected = [] if collected is None else collected + pos, match = self.single_match(left) + if match is None: + return False, left, collected + left_ = left[:pos] + left[pos + 1:] + same_name = [a for a in collected if a.name == self.name] + if type(self.value) in (int, list): + if type(self.value) is int: + increment = 1 + else: + increment = ([match.value] if type(match.value) is str + else match.value) + if not same_name: + match.value = increment + return True, left_, collected + [match] + same_name[0].value += increment + return True, left_, collected + return True, left_, collected + [match] + + +class ParentPattern(Pattern): + + def __init__(self, *children): + self.children = list(children) + + def __repr__(self): + return '%s(%s)' % (self.__class__.__name__, + ', '.join(repr(a) for a in self.children)) + + def flat(self, *types): + if type(self) in types: + return [self] + return sum([c.flat(*types) for c in self.children], []) + + +class Argument(ChildPattern): + + def single_match(self, left): + for n, p in enumerate(left): + if type(p) is Argument: + return n, Argument(self.name, p.value) + return None, None + + @classmethod + def parse(class_, source): + name = re.findall('(<\S*?>)', source)[0] + value = re.findall('\[default: (.*)\]', source, flags=re.I) + return class_(name, value[0] if value else None) + + +class Command(Argument): + + def __init__(self, name, value=False): + self.name = name + self.value = value + + def single_match(self, left): + for n, p in enumerate(left): + if type(p) is Argument: + if p.value == self.name: + return n, Command(self.name, True) + else: + break + return None, None + + +class Option(ChildPattern): + + def __init__(self, short=None, long=None, argcount=0, value=False): + assert argcount in (0, 1) + self.short, self.long = short, long + self.argcount, self.value = argcount, value + self.value = None if value is False and argcount else value + + @classmethod + def parse(class_, option_description): + short, long, argcount, value = None, None, 0, False + options, _, description = option_description.strip().partition(' ') + options = options.replace(',', ' ').replace('=', ' ') + for s in options.split(): + if s.startswith('--'): + long = s + elif s.startswith('-'): + short = s + else: + argcount = 1 + if argcount: + matched = re.findall('\[default: (.*)\]', description, flags=re.I) + value = matched[0] if matched else None + return class_(short, long, argcount, value) + + def single_match(self, left): + for n, p in enumerate(left): + if self.name == p.name: + return n, p + return None, None + + @property + def name(self): + return self.long or self.short + + def __repr__(self): + return 'Option(%r, %r, %r, %r)' % (self.short, self.long, + self.argcount, self.value) + + +class Required(ParentPattern): + + def match(self, left, collected=None): + collected = [] if collected is None else collected + l = left + c = collected + for p in self.children: + matched, l, c = p.match(l, c) + if not matched: + return False, left, collected + return True, l, c + + +class Optional(ParentPattern): + + def match(self, left, collected=None): + collected = [] if collected is None else collected + for p in self.children: + m, left, collected = p.match(left, collected) + return True, left, collected + + +class AnyOptions(Optional): + + """Marker/placeholder for [options] shortcut.""" + + +class OneOrMore(ParentPattern): + + def match(self, left, collected=None): + assert len(self.children) == 1 + collected = [] if collected is None else collected + l = left + c = collected + l_ = None + matched = True + times = 0 + while matched: + # could it be that something didn't match but changed l or c? + matched, l, c = self.children[0].match(l, c) + times += 1 if matched else 0 + if l_ == l: + break + l_ = l + if times >= 1: + return True, l, c + return False, left, collected + + +class Either(ParentPattern): + + def match(self, left, collected=None): + collected = [] if collected is None else collected + outcomes = [] + for p in self.children: + matched, _, _ = outcome = p.match(left, collected) + if matched: + outcomes.append(outcome) + if outcomes: + return min(outcomes, key=lambda outcome: len(outcome[1])) + return False, left, collected + + +class TokenStream(list): + + def __init__(self, source, error): + self += source.split() if hasattr(source, 'split') else source + self.error = error + + def move(self): + return self.pop(0) if len(self) else None + + def current(self): + return self[0] if len(self) else None + + +def parse_long(tokens, options): + """long ::= '--' chars [ ( ' ' | '=' ) chars ] ;""" + long, eq, value = tokens.move().partition('=') + assert long.startswith('--') + value = None if eq == value == '' else value + similar = [o for o in options if o.long == long] + if tokens.error is DocoptExit and similar == []: # if no exact match + similar = [o for o in options if o.long and o.long.startswith(long)] + if len(similar) > 1: # might be simply specified ambiguously 2+ times? + raise tokens.error('%s is not a unique prefix: %s?' % + (long, ', '.join(o.long for o in similar))) + elif len(similar) < 1: + argcount = 1 if eq == '=' else 0 + o = Option(None, long, argcount) + options.append(o) + if tokens.error is DocoptExit: + o = Option(None, long, argcount, value if argcount else True) + else: + o = Option(similar[0].short, similar[0].long, + similar[0].argcount, similar[0].value) + if o.argcount == 0: + if value is not None: + raise tokens.error('%s must not have an argument' % o.long) + else: + if value is None: + if tokens.current() is None: + raise tokens.error('%s requires argument' % o.long) + value = tokens.move() + if tokens.error is DocoptExit: + o.value = value if value is not None else True + return [o] + + +def parse_shorts(tokens, options): + """shorts ::= '-' ( chars )* [ [ ' ' ] chars ] ;""" + token = tokens.move() + assert token.startswith('-') and not token.startswith('--') + left = token.lstrip('-') + parsed = [] + while left != '': + short, left = '-' + left[0], left[1:] + similar = [o for o in options if o.short == short] + if len(similar) > 1: + raise tokens.error('%s is specified ambiguously %d times' % + (short, len(similar))) + elif len(similar) < 1: + o = Option(short, None, 0) + options.append(o) + if tokens.error is DocoptExit: + o = Option(short, None, 0, True) + else: # why copying is necessary here? + o = Option(short, similar[0].long, + similar[0].argcount, similar[0].value) + value = None + if o.argcount != 0: + if left == '': + if tokens.current() is None: + raise tokens.error('%s requires argument' % short) + value = tokens.move() + else: + value = left + left = '' + if tokens.error is DocoptExit: + o.value = value if value is not None else True + parsed.append(o) + return parsed + + +def parse_pattern(source, options): + tokens = TokenStream(re.sub(r'([\[\]\(\)\|]|\.\.\.)', r' \1 ', source), + DocoptLanguageError) + result = parse_expr(tokens, options) + if tokens.current() is not None: + raise tokens.error('unexpected ending: %r' % ' '.join(tokens)) + return Required(*result) + + +def parse_expr(tokens, options): + """expr ::= seq ( '|' seq )* ;""" + seq = parse_seq(tokens, options) + if tokens.current() != '|': + return seq + result = [Required(*seq)] if len(seq) > 1 else seq + while tokens.current() == '|': + tokens.move() + seq = parse_seq(tokens, options) + result += [Required(*seq)] if len(seq) > 1 else seq + return [Either(*result)] if len(result) > 1 else result + + +def parse_seq(tokens, options): + """seq ::= ( atom [ '...' ] )* ;""" + result = [] + while tokens.current() not in [None, ']', ')', '|']: + atom = parse_atom(tokens, options) + if tokens.current() == '...': + atom = [OneOrMore(*atom)] + tokens.move() + result += atom + return result + + +def parse_atom(tokens, options): + """atom ::= '(' expr ')' | '[' expr ']' | 'options' + | long | shorts | argument | command ; + """ + token = tokens.current() + result = [] + if token in '([': + tokens.move() + matching, pattern = {'(': [')', Required], '[': [']', Optional]}[token] + result = pattern(*parse_expr(tokens, options)) + if tokens.move() != matching: + raise tokens.error("unmatched '%s'" % token) + return [result] + elif token == 'options': + tokens.move() + return [AnyOptions()] + elif token.startswith('--') and token != '--': + return parse_long(tokens, options) + elif token.startswith('-') and token not in ('-', '--'): + return parse_shorts(tokens, options) + elif token.startswith('<') and token.endswith('>') or token.isupper(): + return [Argument(tokens.move())] + else: + return [Command(tokens.move())] + + +def parse_argv(tokens, options, options_first=False): + """Parse command-line argument vector. + + If options_first: + argv ::= [ long | shorts ]* [ argument ]* [ '--' [ argument ]* ] ; + else: + argv ::= [ long | shorts | argument ]* [ '--' [ argument ]* ] ; + + """ + parsed = [] + while tokens.current() is not None: + if tokens.current() == '--': + return parsed + [Argument(None, v) for v in tokens] + elif tokens.current().startswith('--'): + parsed += parse_long(tokens, options) + elif tokens.current().startswith('-') and tokens.current() != '-': + parsed += parse_shorts(tokens, options) + elif options_first: + return parsed + [Argument(None, v) for v in tokens] + else: + parsed.append(Argument(None, tokens.move())) + return parsed + + +def parse_defaults(doc): + # in python < 2.7 you can't pass flags=re.MULTILINE + split = re.split('\n *(<\S+?>|-\S+?)', doc)[1:] + split = [s1 + s2 for s1, s2 in zip(split[::2], split[1::2])] + options = [Option.parse(s) for s in split if s.startswith('-')] + #arguments = [Argument.parse(s) for s in split if s.startswith('<')] + #return options, arguments + return options + + +def printable_usage(doc): + # in python < 2.7 you can't pass flags=re.IGNORECASE + usage_split = re.split(r'([Uu][Ss][Aa][Gg][Ee]:)', doc) + if len(usage_split) < 3: + raise DocoptLanguageError('"usage:" (case-insensitive) not found.') + if len(usage_split) > 3: + raise DocoptLanguageError('More than one "usage:" (case-insensitive).') + return re.split(r'\n\s*\n', ''.join(usage_split[1:]))[0].strip() + + +def formal_usage(printable_usage): + pu = printable_usage.split()[1:] # split and drop "usage:" + return '( ' + ' '.join(') | (' if s == pu[0] else s for s in pu[1:]) + ' )' + + +def extras(help, version, options, doc): + if help and any((o.name in ('-h', '--help')) and o.value for o in options): + print(doc.strip("\n")) + sys.exit() + if version and any(o.name == '--version' and o.value for o in options): + print(version) + sys.exit() + + +class Dict(dict): + def __repr__(self): + return '{%s}' % ',\n '.join('%r: %r' % i for i in sorted(self.items())) + + +def docopt(doc, argv=None, help=True, version=None, options_first=False): + """Parse `argv` based on command-line interface described in `doc`. + + `docopt` creates your command-line interface based on its + description that you pass as `doc`. Such description can contain + --options, , commands, which could be + [optional], (required), (mutually | exclusive) or repeated... + + Parameters + ---------- + doc : str + Description of your command-line interface. + argv : list of str, optional + Argument vector to be parsed. sys.argv[1:] is used if not + provided. + help : bool (default: True) + Set to False to disable automatic help on -h or --help + options. + version : any object + If passed, the object will be printed if --version is in + `argv`. + options_first : bool (default: False) + Set to True to require options preceed positional arguments, + i.e. to forbid options and positional arguments intermix. + + Returns + ------- + args : dict + A dictionary, where keys are names of command-line elements + such as e.g. "--verbose" and "", and values are the + parsed values of those elements. + + Example + ------- + >>> from docopt import docopt + >>> doc = ''' + Usage: + my_program tcp [--timeout=] + my_program serial [--baud=] [--timeout=] + my_program (-h | --help | --version) + + Options: + -h, --help Show this screen and exit. + --baud= Baudrate [default: 9600] + ''' + >>> argv = ['tcp', '127.0.0.1', '80', '--timeout', '30'] + >>> docopt(doc, argv) + {'--baud': '9600', + '--help': False, + '--timeout': '30', + '--version': False, + '': '127.0.0.1', + '': '80', + 'serial': False, + 'tcp': True} + + See also + -------- + * For video introduction see http://docopt.org + * Full documentation is available in README.rst as well as online + at https://github.com/docopt/docopt#readme + + """ + if argv is None: + argv = sys.argv[1:] + DocoptExit.usage = printable_usage(doc) + options = parse_defaults(doc) + pattern = parse_pattern(formal_usage(DocoptExit.usage), options) + # [default] syntax for argument is disabled + #for a in pattern.flat(Argument): + # same_name = [d for d in arguments if d.name == a.name] + # if same_name: + # a.value = same_name[0].value + argv = parse_argv(TokenStream(argv, DocoptExit), list(options), + options_first) + pattern_options = set(pattern.flat(Option)) + for ao in pattern.flat(AnyOptions): + doc_options = parse_defaults(doc) + ao.children = list(set(doc_options) - pattern_options) + #if any_options: + # ao.children += [Option(o.short, o.long, o.argcount) + # for o in argv if type(o) is Option] + extras(help, version, argv, doc) + matched, left, collected = pattern.fix().match(argv) + if matched and left == []: # better error message if left? + return Dict((a.name, a.value) for a in (pattern.flat() + collected)) + raise DocoptExit() diff --git a/include/f77_zmq.h b/include/f77_zmq.h new file mode 100644 index 00000000..b19bb707 --- /dev/null +++ b/include/f77_zmq.h @@ -0,0 +1,617 @@ + integer EADDRINUSE + integer EADDRNOTAVAIL + integer EAFNOSUPPORT + integer ECONNABORTED + integer ECONNREFUSED + integer ECONNRESET + integer EFSM + integer EHOSTUNREACH + integer EINPROGRESS + integer EMSGSIZE + integer EMTHREAD + integer ENETDOWN + integer ENETRESET + integer ENETUNREACH + integer ENOBUFS + integer ENOCOMPATPROTO + integer ENOTCONN + integer ENOTSOCK + integer ENOTSUP + integer EPROTONOSUPPORT + integer ETERM + integer ETIMEDOUT + integer ZMQ_AFFINITY + integer ZMQ_BACKLOG + integer ZMQ_BINDTODEVICE + integer ZMQ_BLOCKY + integer ZMQ_CHANNEL + integer ZMQ_CLIENT + integer ZMQ_CONFLATE + integer ZMQ_CONNECT_RID + integer ZMQ_CONNECT_ROUTING_ID + integer ZMQ_CONNECT_TIMEOUT + integer ZMQ_CURRENT_EVENT_VERSION + integer ZMQ_CURRENT_EVENT_VERSION_DRAFT + integer ZMQ_CURVE + integer ZMQ_CURVE_PUBLICKEY + integer ZMQ_CURVE_SECRETKEY + integer ZMQ_CURVE_SERVER + integer ZMQ_CURVE_SERVERKEY + integer ZMQ_DEALER + integer ZMQ_DEFINED_STDINT + integer ZMQ_DELAY_ATTACH_ON_CONNECT + integer ZMQ_DGRAM + integer ZMQ_DISCONNECT_MSG + integer ZMQ_DISH + integer ZMQ_DONTWAIT + integer ZMQ_EVENTS + integer ZMQ_EVENT_ACCEPTED + integer ZMQ_EVENT_ACCEPT_FAILED + integer ZMQ_EVENT_ALL + integer ZMQ_EVENT_ALL_V1 + integer ZMQ_EVENT_ALL_V2 + integer ZMQ_EVENT_BIND_FAILED + integer ZMQ_EVENT_CLOSED + integer ZMQ_EVENT_CLOSE_FAILED + integer ZMQ_EVENT_CONNECTED + integer ZMQ_EVENT_CONNECT_DELAYED + integer ZMQ_EVENT_CONNECT_RETRIED + integer ZMQ_EVENT_DISCONNECTED + integer ZMQ_EVENT_HANDSHAKE_FAILED_AUTH + integer ZMQ_EVENT_HANDSHAKE_FAILED_NO_DETAIL + integer ZMQ_EVENT_HANDSHAKE_FAILED_PROTOCOL + integer ZMQ_EVENT_HANDSHAKE_SUCCEEDED + integer ZMQ_EVENT_LISTENING + integer ZMQ_EVENT_MONITOR_STOPPED + integer ZMQ_EVENT_PIPES_STATS + integer ZMQ_FAIL_UNROUTABLE + integer ZMQ_FD + integer ZMQ_FORWARDER + integer ZMQ_GATHER + integer ZMQ_GROUP_MAX_LENGTH + integer ZMQ_GSSAPI + integer ZMQ_GSSAPI_NT_HOSTBASED + integer ZMQ_GSSAPI_NT_KRB5_PRINCIPAL + integer ZMQ_GSSAPI_NT_USER_NAME + integer ZMQ_GSSAPI_PLAINTEXT + integer ZMQ_GSSAPI_PRINCIPAL + integer ZMQ_GSSAPI_PRINCIPAL_NAMETYPE + integer ZMQ_GSSAPI_SERVER + integer ZMQ_GSSAPI_SERVICE_PRINCIPAL + integer ZMQ_GSSAPI_SERVICE_PRINCIPAL_NAMETYPE + integer ZMQ_HANDSHAKE_IVL + integer ZMQ_HAS_CAPABILITIES + integer ZMQ_HAUSNUMERO + integer ZMQ_HEARTBEAT_IVL + integer ZMQ_HEARTBEAT_TIMEOUT + integer ZMQ_HEARTBEAT_TTL + integer ZMQ_HELLO_MSG + integer ZMQ_IDENTITY + integer ZMQ_IMMEDIATE + integer ZMQ_INVERT_MATCHING + integer ZMQ_IN_BATCH_SIZE + integer ZMQ_IO_THREADS + integer ZMQ_IO_THREADS_DFLT + integer ZMQ_IPC_FILTER_GID + integer ZMQ_IPC_FILTER_PID + integer ZMQ_IPC_FILTER_UID + integer ZMQ_IPV4ONLY + integer ZMQ_IPV6 + integer ZMQ_LAST_ENDPOINT + integer ZMQ_LINGER + integer ZMQ_LOOPBACK_FASTPATH + integer ZMQ_MAXMSGSIZE + integer ZMQ_MAX_MSGSZ + integer ZMQ_MAX_SOCKETS + integer ZMQ_MAX_SOCKETS_DFLT + integer ZMQ_MECHANISM + integer ZMQ_METADATA + integer ZMQ_MORE + integer ZMQ_MSG_T_SIZE + integer ZMQ_MULTICAST_HOPS + integer ZMQ_MULTICAST_LOOP + integer ZMQ_MULTICAST_MAXTPDU + integer ZMQ_NOBLOCK + integer ZMQ_NOTIFY_CONNECT + integer ZMQ_NOTIFY_DISCONNECT + integer ZMQ_NULL + integer ZMQ_ONLY_FIRST_SUBSCRIBE + integer ZMQ_OUT_BATCH_SIZE + integer ZMQ_PAIR + integer ZMQ_PEER + integer ZMQ_PLAIN + integer ZMQ_PLAIN_PASSWORD + integer ZMQ_PLAIN_SERVER + integer ZMQ_PLAIN_USERNAME + integer ZMQ_POLLERR + integer ZMQ_POLLIN + integer ZMQ_POLLITEMS_DFLT + integer ZMQ_POLLOUT + integer ZMQ_POLLPRI + integer ZMQ_PRIORITY + integer ZMQ_PROBE_ROUTER + integer ZMQ_PROTOCOL_ERROR_WS_UNSPECIFIED + integer ZMQ_PROTOCOL_ERROR_ZAP_BAD_REQUEST_ID + integer ZMQ_PROTOCOL_ERROR_ZAP_BAD_VERSION + integer ZMQ_PROTOCOL_ERROR_ZAP_INVALID_METADATA + integer ZMQ_PROTOCOL_ERROR_ZAP_INVALID_STATUS_CODE + integer ZMQ_PROTOCOL_ERROR_ZAP_MALFORMED_REPLY + integer ZMQ_PROTOCOL_ERROR_ZAP_UNSPECIFIED + integer ZMQ_PROTOCOL_ERROR_ZMTP_CRYPTOGRAPHIC + integer ZMQ_PROTOCOL_ERROR_ZMTP_INVALID_METADATA + integer ZMQ_PROTOCOL_ERROR_ZMTP_INVALID_SEQUENCE + integer ZMQ_PROTOCOL_ERROR_ZMTP_KEY_EXCHANGE + integer ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_ERROR + integer ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_HELLO + integer ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_INITIATE + integer ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_MESSAGE + integer ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_READY + integer ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_UNSPECIFIED + integer ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_WELCOME + integer ZMQ_PROTOCOL_ERROR_ZMTP_MECHANISM_MISMATCH + integer ZMQ_PROTOCOL_ERROR_ZMTP_UNEXPECTED_COMMAND + integer ZMQ_PROTOCOL_ERROR_ZMTP_UNSPECIFIED + integer ZMQ_PTR + integer ZMQ_PUB + integer ZMQ_PULL + integer ZMQ_PUSH + integer ZMQ_QUEUE + integer ZMQ_RADIO + integer ZMQ_RATE + integer ZMQ_RCVBUF + integer ZMQ_RCVHWM + integer ZMQ_RCVMORE + integer ZMQ_RCVTIMEO + integer ZMQ_RECONNECT_IVL + integer ZMQ_RECONNECT_IVL_MAX + integer ZMQ_RECONNECT_STOP + integer ZMQ_RECONNECT_STOP_AFTER_DISCONNECT + integer ZMQ_RECONNECT_STOP_CONN_REFUSED + integer ZMQ_RECONNECT_STOP_HANDSHAKE_FAILED + integer ZMQ_RECOVERY_IVL + integer ZMQ_REP + integer ZMQ_REQ + integer ZMQ_REQ_CORRELATE + integer ZMQ_REQ_RELAXED + integer ZMQ_ROUTER + integer ZMQ_ROUTER_BEHAVIOR + integer ZMQ_ROUTER_HANDOVER + integer ZMQ_ROUTER_MANDATORY + integer ZMQ_ROUTER_NOTIFY + integer ZMQ_ROUTER_RAW + integer ZMQ_ROUTING_ID + integer ZMQ_SCATTER + integer ZMQ_SERVER + integer ZMQ_SHARED + integer ZMQ_SNDBUF + integer ZMQ_SNDHWM + integer ZMQ_SNDMORE + integer ZMQ_SNDTIMEO + integer ZMQ_SOCKET_LIMIT + integer ZMQ_SOCKS_PASSWORD + integer ZMQ_SOCKS_PROXY + integer ZMQ_SOCKS_USERNAME + integer ZMQ_SRCFD + integer ZMQ_STREAM + integer ZMQ_STREAMER + integer ZMQ_STREAM_NOTIFY + integer ZMQ_SUB + integer ZMQ_SUBSCRIBE + integer ZMQ_TCP_ACCEPT_FILTER + integer ZMQ_TCP_KEEPALIVE + integer ZMQ_TCP_KEEPALIVE_CNT + integer ZMQ_TCP_KEEPALIVE_IDLE + integer ZMQ_TCP_KEEPALIVE_INTVL + integer ZMQ_TCP_MAXRT + integer ZMQ_THREAD_AFFINITY_CPU_ADD + integer ZMQ_THREAD_AFFINITY_CPU_REMOVE + integer ZMQ_THREAD_NAME_PREFIX + integer ZMQ_THREAD_PRIORITY + integer ZMQ_THREAD_PRIORITY_DFLT + integer ZMQ_THREAD_SAFE + integer ZMQ_THREAD_SCHED_POLICY + integer ZMQ_THREAD_SCHED_POLICY_DFLT + integer ZMQ_TOS + integer ZMQ_TYPE + integer ZMQ_UNSUBSCRIBE + integer ZMQ_USE_FD + integer ZMQ_VERSION + integer ZMQ_VERSION_MAJOR + integer ZMQ_VERSION_MINOR + integer ZMQ_VERSION_PATCH + integer ZMQ_VMCI_BUFFER_MAX_SIZE + integer ZMQ_VMCI_BUFFER_MIN_SIZE + integer ZMQ_VMCI_BUFFER_SIZE + integer ZMQ_VMCI_CONNECT_TIMEOUT + integer ZMQ_WSS_CERT_PEM + integer ZMQ_WSS_HOSTNAME + integer ZMQ_WSS_KEY_PEM + integer ZMQ_WSS_TRUST_PEM + integer ZMQ_WSS_TRUST_SYSTEM + integer ZMQ_XPUB + integer ZMQ_XPUB_MANUAL + integer ZMQ_XPUB_MANUAL_LAST_VALUE + integer ZMQ_XPUB_NODROP + integer ZMQ_XPUB_VERBOSE + integer ZMQ_XPUB_VERBOSER + integer ZMQ_XPUB_WELCOME_MSG + integer ZMQ_XREP + integer ZMQ_XREQ + integer ZMQ_XSUB + integer ZMQ_ZAP_DOMAIN + integer ZMQ_ZAP_ENFORCE_DOMAIN + integer ZMQ_ZERO_COPY_RECV + parameter(EADDRINUSE=156384717) + parameter(EADDRNOTAVAIL=156384718) + parameter(EAFNOSUPPORT=156384723) + parameter(ECONNABORTED=156384725) + parameter(ECONNREFUSED=156384719) + parameter(ECONNRESET=156384726) + parameter(EFSM=156384763) + parameter(EHOSTUNREACH=156384729) + parameter(EINPROGRESS=156384720) + parameter(EMSGSIZE=156384722) + parameter(EMTHREAD=156384766) + parameter(ENETDOWN=156384716) + parameter(ENETRESET=156384730) + parameter(ENETUNREACH=156384724) + parameter(ENOBUFS=156384715) + parameter(ENOCOMPATPROTO=156384764) + parameter(ENOTCONN=156384727) + parameter(ENOTSOCK=156384721) + parameter(ENOTSUP=156384713) + parameter(EPROTONOSUPPORT=156384714) + parameter(ETERM=156384765) + parameter(ETIMEDOUT=156384728) + parameter(ZMQ_AFFINITY=4) + parameter(ZMQ_BACKLOG=19) + parameter(ZMQ_BINDTODEVICE=92) + parameter(ZMQ_BLOCKY=70) + parameter(ZMQ_CHANNEL=20) + parameter(ZMQ_CLIENT=13) + parameter(ZMQ_CONFLATE=54) + parameter(ZMQ_CONNECT_RID=61) + parameter(ZMQ_CONNECT_ROUTING_ID=61) + parameter(ZMQ_CONNECT_TIMEOUT=79) + parameter(ZMQ_CURRENT_EVENT_VERSION=1) + parameter(ZMQ_CURRENT_EVENT_VERSION_DRAFT=2) + parameter(ZMQ_CURVE=2) + parameter(ZMQ_CURVE_PUBLICKEY=48) + parameter(ZMQ_CURVE_SECRETKEY=49) + parameter(ZMQ_CURVE_SERVER=47) + parameter(ZMQ_CURVE_SERVERKEY=50) + parameter(ZMQ_DEALER=5) + parameter(ZMQ_DEFINED_STDINT=1) + parameter(ZMQ_DELAY_ATTACH_ON_CONNECT=39) + parameter(ZMQ_DGRAM=18) + parameter(ZMQ_DISCONNECT_MSG=111) + parameter(ZMQ_DISH=15) + parameter(ZMQ_DONTWAIT=1) + parameter(ZMQ_EVENTS=15) + parameter(ZMQ_EVENT_ACCEPTED=32) + parameter(ZMQ_EVENT_ACCEPT_FAILED=64) + parameter(ZMQ_EVENT_ALL=65535) + parameter(ZMQ_EVENT_ALL_V1=65535) + parameter(ZMQ_EVENT_ALL_V2=131071) + parameter(ZMQ_EVENT_BIND_FAILED=16) + parameter(ZMQ_EVENT_CLOSED=128) + parameter(ZMQ_EVENT_CLOSE_FAILED=256) + parameter(ZMQ_EVENT_CONNECTED=1) + parameter(ZMQ_EVENT_CONNECT_DELAYED=2) + parameter(ZMQ_EVENT_CONNECT_RETRIED=4) + parameter(ZMQ_EVENT_DISCONNECTED=512) + parameter(ZMQ_EVENT_HANDSHAKE_FAILED_AUTH=16384) + parameter(ZMQ_EVENT_HANDSHAKE_FAILED_NO_DETAIL=2048) + parameter(ZMQ_EVENT_HANDSHAKE_FAILED_PROTOCOL=8192) + parameter(ZMQ_EVENT_HANDSHAKE_SUCCEEDED=4096) + parameter(ZMQ_EVENT_LISTENING=8) + parameter(ZMQ_EVENT_MONITOR_STOPPED=1024) + parameter(ZMQ_EVENT_PIPES_STATS=65536) + parameter(ZMQ_FAIL_UNROUTABLE=33) + parameter(ZMQ_FD=14) + parameter(ZMQ_FORWARDER=2) + parameter(ZMQ_GATHER=16) + parameter(ZMQ_GROUP_MAX_LENGTH=255) + parameter(ZMQ_GSSAPI=3) + parameter(ZMQ_GSSAPI_NT_HOSTBASED=0) + parameter(ZMQ_GSSAPI_NT_KRB5_PRINCIPAL=2) + parameter(ZMQ_GSSAPI_NT_USER_NAME=1) + parameter(ZMQ_GSSAPI_PLAINTEXT=65) + parameter(ZMQ_GSSAPI_PRINCIPAL=63) + parameter(ZMQ_GSSAPI_PRINCIPAL_NAMETYPE=90) + parameter(ZMQ_GSSAPI_SERVER=62) + parameter(ZMQ_GSSAPI_SERVICE_PRINCIPAL=64) + parameter(ZMQ_GSSAPI_SERVICE_PRINCIPAL_NAMETYPE=91) + parameter(ZMQ_HANDSHAKE_IVL=66) + parameter(ZMQ_HAS_CAPABILITIES=1) + parameter(ZMQ_HAUSNUMERO=156384712) + parameter(ZMQ_HEARTBEAT_IVL=75) + parameter(ZMQ_HEARTBEAT_TIMEOUT=77) + parameter(ZMQ_HEARTBEAT_TTL=76) + parameter(ZMQ_HELLO_MSG=110) + parameter(ZMQ_IDENTITY=5) + parameter(ZMQ_IMMEDIATE=39) + parameter(ZMQ_INVERT_MATCHING=74) + parameter(ZMQ_IN_BATCH_SIZE=101) + parameter(ZMQ_IO_THREADS=1) + parameter(ZMQ_IO_THREADS_DFLT=1) + parameter(ZMQ_IPC_FILTER_GID=60) + parameter(ZMQ_IPC_FILTER_PID=58) + parameter(ZMQ_IPC_FILTER_UID=59) + parameter(ZMQ_IPV4ONLY=31) + parameter(ZMQ_IPV6=42) + parameter(ZMQ_LAST_ENDPOINT=32) + parameter(ZMQ_LINGER=17) + parameter(ZMQ_LOOPBACK_FASTPATH=94) + parameter(ZMQ_MAXMSGSIZE=22) + parameter(ZMQ_MAX_MSGSZ=5) + parameter(ZMQ_MAX_SOCKETS=2) + parameter(ZMQ_MAX_SOCKETS_DFLT=1023) + parameter(ZMQ_MECHANISM=43) + parameter(ZMQ_METADATA=95) + parameter(ZMQ_MORE=1) + parameter(ZMQ_MSG_T_SIZE=6) + parameter(ZMQ_MULTICAST_HOPS=25) + parameter(ZMQ_MULTICAST_LOOP=96) + parameter(ZMQ_MULTICAST_MAXTPDU=84) + parameter(ZMQ_NOBLOCK=1) + parameter(ZMQ_NOTIFY_CONNECT=1) + parameter(ZMQ_NOTIFY_DISCONNECT=2) + parameter(ZMQ_NULL=0) + parameter(ZMQ_ONLY_FIRST_SUBSCRIBE=108) + parameter(ZMQ_OUT_BATCH_SIZE=102) + parameter(ZMQ_PAIR=0) + parameter(ZMQ_PEER=19) + parameter(ZMQ_PLAIN=1) + parameter(ZMQ_PLAIN_PASSWORD=46) + parameter(ZMQ_PLAIN_SERVER=44) + parameter(ZMQ_PLAIN_USERNAME=45) + parameter(ZMQ_POLLERR=4) + parameter(ZMQ_POLLIN=1) + parameter(ZMQ_POLLITEMS_DFLT=16) + parameter(ZMQ_POLLOUT=2) + parameter(ZMQ_POLLPRI=8) + parameter(ZMQ_PRIORITY=112) + parameter(ZMQ_PROBE_ROUTER=51) + parameter(ZMQ_PROTOCOL_ERROR_WS_UNSPECIFIED=805306368) + parameter(ZMQ_PROTOCOL_ERROR_ZAP_BAD_REQUEST_ID=536870914) + parameter(ZMQ_PROTOCOL_ERROR_ZAP_BAD_VERSION=536870915) + parameter(ZMQ_PROTOCOL_ERROR_ZAP_INVALID_METADATA=536870917) + parameter(ZMQ_PROTOCOL_ERROR_ZAP_INVALID_STATUS_CODE=536870916) + parameter(ZMQ_PROTOCOL_ERROR_ZAP_MALFORMED_REPLY=536870913) + parameter(ZMQ_PROTOCOL_ERROR_ZAP_UNSPECIFIED=536870912) + parameter(ZMQ_PROTOCOL_ERROR_ZMTP_CRYPTOGRAPHIC=285212673) + parameter(ZMQ_PROTOCOL_ERROR_ZMTP_INVALID_METADATA=268435480) + parameter(ZMQ_PROTOCOL_ERROR_ZMTP_INVALID_SEQUENCE=268435458) + parameter(ZMQ_PROTOCOL_ERROR_ZMTP_KEY_EXCHANGE=268435459) + parameter( + & ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_ERROR=268435477) + parameter( + & ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_HELLO=268435475) + parameter( + & ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_INITIATE=268435476) + parameter( + & ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_MESSAGE=268435474) + parameter( + & ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_READY=268435478) + parameter( + & ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_UNSPECIFIED=268435473) + parameter( + & ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_WELCOME=268435479) + parameter(ZMQ_PROTOCOL_ERROR_ZMTP_MECHANISM_MISMATCH=285212674) + parameter(ZMQ_PROTOCOL_ERROR_ZMTP_UNEXPECTED_COMMAND=268435457) + parameter(ZMQ_PROTOCOL_ERROR_ZMTP_UNSPECIFIED=268435456) + parameter(ZMQ_PTR=8) + parameter(ZMQ_PUB=1) + parameter(ZMQ_PULL=7) + parameter(ZMQ_PUSH=8) + parameter(ZMQ_QUEUE=3) + parameter(ZMQ_RADIO=14) + parameter(ZMQ_RATE=8) + parameter(ZMQ_RCVBUF=12) + parameter(ZMQ_RCVHWM=24) + parameter(ZMQ_RCVMORE=13) + parameter(ZMQ_RCVTIMEO=27) + parameter(ZMQ_RECONNECT_IVL=18) + parameter(ZMQ_RECONNECT_IVL_MAX=21) + parameter(ZMQ_RECONNECT_STOP=109) + parameter(ZMQ_RECONNECT_STOP_AFTER_DISCONNECT=3) + parameter(ZMQ_RECONNECT_STOP_CONN_REFUSED=1) + parameter(ZMQ_RECONNECT_STOP_HANDSHAKE_FAILED=2) + parameter(ZMQ_RECOVERY_IVL=9) + parameter(ZMQ_REP=4) + parameter(ZMQ_REQ=3) + parameter(ZMQ_REQ_CORRELATE=52) + parameter(ZMQ_REQ_RELAXED=53) + parameter(ZMQ_ROUTER=6) + parameter(ZMQ_ROUTER_BEHAVIOR=33) + parameter(ZMQ_ROUTER_HANDOVER=56) + parameter(ZMQ_ROUTER_MANDATORY=33) + parameter(ZMQ_ROUTER_NOTIFY=97) + parameter(ZMQ_ROUTER_RAW=41) + parameter(ZMQ_ROUTING_ID=5) + parameter(ZMQ_SCATTER=17) + parameter(ZMQ_SERVER=12) + parameter(ZMQ_SHARED=3) + parameter(ZMQ_SNDBUF=11) + parameter(ZMQ_SNDHWM=23) + parameter(ZMQ_SNDMORE=2) + parameter(ZMQ_SNDTIMEO=28) + parameter(ZMQ_SOCKET_LIMIT=3) + parameter(ZMQ_SOCKS_PASSWORD=100) + parameter(ZMQ_SOCKS_PROXY=68) + parameter(ZMQ_SOCKS_USERNAME=99) + parameter(ZMQ_SRCFD=2) + parameter(ZMQ_STREAM=11) + parameter(ZMQ_STREAMER=1) + parameter(ZMQ_STREAM_NOTIFY=73) + parameter(ZMQ_SUB=2) + parameter(ZMQ_SUBSCRIBE=6) + parameter(ZMQ_TCP_ACCEPT_FILTER=38) + parameter(ZMQ_TCP_KEEPALIVE=34) + parameter(ZMQ_TCP_KEEPALIVE_CNT=35) + parameter(ZMQ_TCP_KEEPALIVE_IDLE=36) + parameter(ZMQ_TCP_KEEPALIVE_INTVL=37) + parameter(ZMQ_TCP_MAXRT=80) + parameter(ZMQ_THREAD_AFFINITY_CPU_ADD=7) + parameter(ZMQ_THREAD_AFFINITY_CPU_REMOVE=8) + parameter(ZMQ_THREAD_NAME_PREFIX=9) + parameter(ZMQ_THREAD_PRIORITY=3) + parameter(ZMQ_THREAD_PRIORITY_DFLT=-1) + parameter(ZMQ_THREAD_SAFE=81) + parameter(ZMQ_THREAD_SCHED_POLICY=4) + parameter(ZMQ_THREAD_SCHED_POLICY_DFLT=-1) + parameter(ZMQ_TOS=57) + parameter(ZMQ_TYPE=16) + parameter(ZMQ_UNSUBSCRIBE=7) + parameter(ZMQ_USE_FD=89) + parameter(ZMQ_VERSION=40304) + parameter(ZMQ_VERSION_MAJOR=4) + parameter(ZMQ_VERSION_MINOR=3) + parameter(ZMQ_VERSION_PATCH=4) + parameter(ZMQ_VMCI_BUFFER_MAX_SIZE=87) + parameter(ZMQ_VMCI_BUFFER_MIN_SIZE=86) + parameter(ZMQ_VMCI_BUFFER_SIZE=85) + parameter(ZMQ_VMCI_CONNECT_TIMEOUT=88) + parameter(ZMQ_WSS_CERT_PEM=104) + parameter(ZMQ_WSS_HOSTNAME=106) + parameter(ZMQ_WSS_KEY_PEM=103) + parameter(ZMQ_WSS_TRUST_PEM=105) + parameter(ZMQ_WSS_TRUST_SYSTEM=107) + parameter(ZMQ_XPUB=9) + parameter(ZMQ_XPUB_MANUAL=71) + parameter(ZMQ_XPUB_MANUAL_LAST_VALUE=98) + parameter(ZMQ_XPUB_NODROP=69) + parameter(ZMQ_XPUB_VERBOSE=40) + parameter(ZMQ_XPUB_VERBOSER=78) + parameter(ZMQ_XPUB_WELCOME_MSG=72) + parameter(ZMQ_XREP=6) + parameter(ZMQ_XREQ=5) + parameter(ZMQ_XSUB=10) + parameter(ZMQ_ZAP_DOMAIN=55) + parameter(ZMQ_ZAP_ENFORCE_DOMAIN=93) + parameter(ZMQ_ZERO_COPY_RECV=10) + integer f77_zmq_bind + external f77_zmq_bind + integer f77_zmq_close + external f77_zmq_close + integer f77_zmq_connect + external f77_zmq_connect + integer f77_zmq_ctx_destroy + external f77_zmq_ctx_destroy + integer f77_zmq_ctx_get + external f77_zmq_ctx_get + integer*8 f77_zmq_ctx_new + external f77_zmq_ctx_new + integer f77_zmq_ctx_set + external f77_zmq_ctx_set + integer f77_zmq_ctx_shutdown + external f77_zmq_ctx_shutdown + integer f77_zmq_ctx_term + external f77_zmq_ctx_term + integer f77_zmq_disconnect + external f77_zmq_disconnect + integer f77_zmq_errno + external f77_zmq_errno + integer f77_zmq_getsockopt + external f77_zmq_getsockopt + integer f77_zmq_microsleep + external f77_zmq_microsleep + integer f77_zmq_msg_close + external f77_zmq_msg_close + integer f77_zmq_msg_copy + external f77_zmq_msg_copy + integer f77_zmq_msg_copy_from_data + external f77_zmq_msg_copy_from_data + integer f77_zmq_msg_copy_to_data + external f77_zmq_msg_copy_to_data + integer f77_zmq_msg_copy_to_data8 + external f77_zmq_msg_copy_to_data8 + integer*8 f77_zmq_msg_data + external f77_zmq_msg_data + integer*8 f77_zmq_msg_data_new + external f77_zmq_msg_data_new + integer f77_zmq_msg_destroy + external f77_zmq_msg_destroy + integer f77_zmq_msg_destroy_data + external f77_zmq_msg_destroy_data + integer f77_zmq_msg_get + external f77_zmq_msg_get + character*(64) f77_zmq_msg_gets + external f77_zmq_msg_gets + integer f77_zmq_msg_init + external f77_zmq_msg_init + integer f77_zmq_msg_init_data + external f77_zmq_msg_init_data + integer f77_zmq_msg_init_size + external f77_zmq_msg_init_size + integer f77_zmq_msg_more + external f77_zmq_msg_more + integer f77_zmq_msg_move + external f77_zmq_msg_move + integer*8 f77_zmq_msg_new + external f77_zmq_msg_new + integer f77_zmq_msg_recv + external f77_zmq_msg_recv + integer*8 f77_zmq_msg_recv8 + external f77_zmq_msg_recv8 + integer f77_zmq_msg_send + external f77_zmq_msg_send + integer*8 f77_zmq_msg_send8 + external f77_zmq_msg_send8 + integer f77_zmq_msg_set + external f77_zmq_msg_set + integer f77_zmq_msg_size + external f77_zmq_msg_size + integer*8 f77_zmq_msg_size8 + external f77_zmq_msg_size8 + integer f77_zmq_poll + external f77_zmq_poll + integer f77_zmq_pollitem_destroy + external f77_zmq_pollitem_destroy + integer*8 f77_zmq_pollitem_new + external f77_zmq_pollitem_new + integer f77_zmq_pollitem_revents + external f77_zmq_pollitem_revents + integer f77_zmq_pollitem_set_events + external f77_zmq_pollitem_set_events + integer f77_zmq_pollitem_set_socket + external f77_zmq_pollitem_set_socket + integer f77_zmq_proxy + external f77_zmq_proxy + integer f77_zmq_proxy_steerable + external f77_zmq_proxy_steerable + integer f77_zmq_recv + external f77_zmq_recv + integer*8 f77_zmq_recv8 + external f77_zmq_recv8 + integer f77_zmq_send + external f77_zmq_send + integer*8 f77_zmq_send8 + external f77_zmq_send8 + integer f77_zmq_send_const + external f77_zmq_send_const + integer*8 f77_zmq_send_const8 + external f77_zmq_send_const8 + integer f77_zmq_setsockopt + external f77_zmq_setsockopt + integer*8 f77_zmq_socket + external f77_zmq_socket + integer f77_zmq_socket_monitor + external f77_zmq_socket_monitor + character*(64) f77_zmq_strerror + external f77_zmq_strerror + integer f77_zmq_term + external f77_zmq_term + integer f77_zmq_unbind + external f77_zmq_unbind + integer f77_zmq_version + external f77_zmq_version + integer pthread_create + external pthread_create + integer pthread_create_arg + external pthread_create_arg + integer pthread_detach + external pthread_detach + integer pthread_join + external pthread_join diff --git a/ocaml/Command_line.ml b/ocaml/Command_line.ml index 602315c6..1dd57892 100644 --- a/ocaml/Command_line.ml +++ b/ocaml/Command_line.ml @@ -1,5 +1,3 @@ -exception Error of string - type short_opt = char type long_opt = string type optional = Mandatory | Optional @@ -183,16 +181,15 @@ let set_specs specs_in = Getopt.parse_cmdline cmd_specs (fun x -> anon_args := !anon_args @ [x]); if show_help () then - help () - else - (* Check that all mandatory arguments are set *) - List.filter (fun x -> x.short <> ' ' && x.opt = Mandatory) !specs - |> List.iter (fun x -> - match get x.long with - | Some _ -> () - | None -> raise (Error ("--"^x.long^" option is missing.")) - ) + (help () ; exit 0); + (* Check that all mandatory arguments are set *) + List.filter (fun x -> x.short <> ' ' && x.opt = Mandatory) !specs + |> List.iter (fun x -> + match get x.long with + | Some _ -> () + | None -> failwith ("Error: --"^x.long^" option is missing.") + ) ;; diff --git a/ocaml/Command_line.mli b/ocaml/Command_line.mli index 5ad4ee08..9f6e7022 100644 --- a/ocaml/Command_line.mli +++ b/ocaml/Command_line.mli @@ -59,8 +59,6 @@ let () = *) -exception Error of string - type short_opt = char type long_opt = string diff --git a/ocaml/Input_ao_two_e_eff_pot.ml b/ocaml/Input_ao_two_e_eff_pot.ml new file mode 100644 index 00000000..e4e2c059 --- /dev/null +++ b/ocaml/Input_ao_two_e_eff_pot.ml @@ -0,0 +1,113 @@ +(* =~=~ *) +(* Init *) +(* =~=~ *) + +open Qptypes;; +open Qputils;; +open Sexplib.Std;; + +module Ao_two_e_eff_pot : sig +(* Generate type *) + type t = + { + adjoint_tc_h : bool; + grad_squared : bool; + } [@@deriving sexp] + ;; + val read : unit -> t option + val write : t-> unit + val to_string : t -> string + val to_rst : t -> Rst_string.t + val of_rst : Rst_string.t -> t option +end = struct +(* Generate type *) + type t = + { + adjoint_tc_h : bool; + grad_squared : bool; + } [@@deriving sexp] + ;; + + let get_default = Qpackage.get_ezfio_default "ao_two_e_eff_pot";; + +(* =~=~=~=~=~=~==~=~=~=~=~=~ *) +(* Generate Special Function *) +(* =~=~=~==~=~~=~=~=~=~=~=~=~ *) + +(* Read snippet for adjoint_tc_h *) + let read_adjoint_tc_h () = + if not (Ezfio.has_ao_two_e_eff_pot_adjoint_tc_h ()) then + get_default "adjoint_tc_h" + |> bool_of_string + |> Ezfio.set_ao_two_e_eff_pot_adjoint_tc_h + ; + Ezfio.get_ao_two_e_eff_pot_adjoint_tc_h () + ;; +(* Write snippet for adjoint_tc_h *) + let write_adjoint_tc_h = + Ezfio.set_ao_two_e_eff_pot_adjoint_tc_h + ;; + +(* Read snippet for grad_squared *) + let read_grad_squared () = + if not (Ezfio.has_ao_two_e_eff_pot_grad_squared ()) then + get_default "grad_squared" + |> bool_of_string + |> Ezfio.set_ao_two_e_eff_pot_grad_squared + ; + Ezfio.get_ao_two_e_eff_pot_grad_squared () + ;; +(* Write snippet for grad_squared *) + let write_grad_squared = + Ezfio.set_ao_two_e_eff_pot_grad_squared + ;; + +(* =~=~=~=~=~=~=~=~=~=~=~=~ *) +(* Generate Global Function *) +(* =~=~=~=~=~=~=~=~=~=~=~=~ *) + +(* Read all *) + let read() = + Some + { + adjoint_tc_h = read_adjoint_tc_h (); + grad_squared = read_grad_squared (); + } + ;; +(* Write all *) + let write{ + adjoint_tc_h; + grad_squared; + } = + write_adjoint_tc_h adjoint_tc_h; + write_grad_squared grad_squared; + ;; +(* to_string*) + let to_string b = + Printf.sprintf " + adjoint_tc_h = %s + grad_squared = %s + " + (string_of_bool b.adjoint_tc_h) + (string_of_bool b.grad_squared) + ;; +(* to_rst*) + let to_rst b = + Printf.sprintf " + If |true|, you compute the adjoint of the transcorrelated Hamiltonian :: + + adjoint_tc_h = %s + + If |true|, you compute also the square of the gradient of the correlation factor :: + + grad_squared = %s + + " + (string_of_bool b.adjoint_tc_h) + (string_of_bool b.grad_squared) + |> Rst_string.of_string + ;; + include Generic_input_of_rst;; + let of_rst = of_rst t_of_sexp;; + +end \ No newline at end of file diff --git a/ocaml/Input_bi_ortho_mos.ml b/ocaml/Input_bi_ortho_mos.ml new file mode 100644 index 00000000..5523a589 --- /dev/null +++ b/ocaml/Input_bi_ortho_mos.ml @@ -0,0 +1,87 @@ +(* =~=~ *) +(* Init *) +(* =~=~ *) + +open Qptypes;; +open Qputils;; +open Sexplib.Std;; + +module Bi_ortho_mos : sig +(* Generate type *) + type t = + { + bi_ortho : bool; + } [@@deriving sexp] + ;; + val read : unit -> t option + val write : t-> unit + val to_string : t -> string + val to_rst : t -> Rst_string.t + val of_rst : Rst_string.t -> t option +end = struct +(* Generate type *) + type t = + { + bi_ortho : bool; + } [@@deriving sexp] + ;; + + let get_default = Qpackage.get_ezfio_default "bi_ortho_mos";; + +(* =~=~=~=~=~=~==~=~=~=~=~=~ *) +(* Generate Special Function *) +(* =~=~=~==~=~~=~=~=~=~=~=~=~ *) + +(* Read snippet for bi_ortho *) + let read_bi_ortho () = + if not (Ezfio.has_bi_ortho_mos_bi_ortho ()) then + get_default "bi_ortho" + |> bool_of_string + |> Ezfio.set_bi_ortho_mos_bi_ortho + ; + Ezfio.get_bi_ortho_mos_bi_ortho () + ;; +(* Write snippet for bi_ortho *) + let write_bi_ortho = + Ezfio.set_bi_ortho_mos_bi_ortho + ;; + +(* =~=~=~=~=~=~=~=~=~=~=~=~ *) +(* Generate Global Function *) +(* =~=~=~=~=~=~=~=~=~=~=~=~ *) + +(* Read all *) + let read() = + Some + { + bi_ortho = read_bi_ortho (); + } + ;; +(* Write all *) + let write{ + bi_ortho; + } = + write_bi_ortho bi_ortho; + ;; +(* to_string*) + let to_string b = + Printf.sprintf " + bi_ortho = %s + " + (string_of_bool b.bi_ortho) + ;; +(* to_rst*) + let to_rst b = + Printf.sprintf " + If |true|, the MO basis is assumed to be bi-orthonormal :: + + bi_ortho = %s + + " + (string_of_bool b.bi_ortho) + |> Rst_string.of_string + ;; + include Generic_input_of_rst;; + let of_rst = of_rst t_of_sexp;; + +end \ No newline at end of file diff --git a/ocaml/Input_cassd.ml b/ocaml/Input_cassd.ml new file mode 100644 index 00000000..03416f42 --- /dev/null +++ b/ocaml/Input_cassd.ml @@ -0,0 +1,113 @@ +(* =~=~ *) +(* Init *) +(* =~=~ *) + +open Qptypes;; +open Qputils;; +open Sexplib.Std;; + +module Cassd : sig +(* Generate type *) + type t = + { + do_ddci : bool; + do_only_1h1p : bool; + } [@@deriving sexp] + ;; + val read : unit -> t option + val write : t-> unit + val to_string : t -> string + val to_rst : t -> Rst_string.t + val of_rst : Rst_string.t -> t option +end = struct +(* Generate type *) + type t = + { + do_ddci : bool; + do_only_1h1p : bool; + } [@@deriving sexp] + ;; + + let get_default = Qpackage.get_ezfio_default "cassd";; + +(* =~=~=~=~=~=~==~=~=~=~=~=~ *) +(* Generate Special Function *) +(* =~=~=~==~=~~=~=~=~=~=~=~=~ *) + +(* Read snippet for do_ddci *) + let read_do_ddci () = + if not (Ezfio.has_cassd_do_ddci ()) then + get_default "do_ddci" + |> bool_of_string + |> Ezfio.set_cassd_do_ddci + ; + Ezfio.get_cassd_do_ddci () + ;; +(* Write snippet for do_ddci *) + let write_do_ddci = + Ezfio.set_cassd_do_ddci + ;; + +(* Read snippet for do_only_1h1p *) + let read_do_only_1h1p () = + if not (Ezfio.has_cassd_do_only_1h1p ()) then + get_default "do_only_1h1p" + |> bool_of_string + |> Ezfio.set_cassd_do_only_1h1p + ; + Ezfio.get_cassd_do_only_1h1p () + ;; +(* Write snippet for do_only_1h1p *) + let write_do_only_1h1p = + Ezfio.set_cassd_do_only_1h1p + ;; + +(* =~=~=~=~=~=~=~=~=~=~=~=~ *) +(* Generate Global Function *) +(* =~=~=~=~=~=~=~=~=~=~=~=~ *) + +(* Read all *) + let read() = + Some + { + do_ddci = read_do_ddci (); + do_only_1h1p = read_do_only_1h1p (); + } + ;; +(* Write all *) + let write{ + do_ddci; + do_only_1h1p; + } = + write_do_ddci do_ddci; + write_do_only_1h1p do_only_1h1p; + ;; +(* to_string*) + let to_string b = + Printf.sprintf " + do_ddci = %s + do_only_1h1p = %s + " + (string_of_bool b.do_ddci) + (string_of_bool b.do_only_1h1p) + ;; +(* to_rst*) + let to_rst b = + Printf.sprintf " + If true, remove purely inactive double excitations :: + + do_ddci = %s + + If true, do only one hole/one particle excitations :: + + do_only_1h1p = %s + + " + (string_of_bool b.do_ddci) + (string_of_bool b.do_only_1h1p) + |> Rst_string.of_string + ;; + include Generic_input_of_rst;; + let of_rst = of_rst t_of_sexp;; + +end \ No newline at end of file diff --git a/ocaml/Input_cipsi_deb.ml b/ocaml/Input_cipsi_deb.ml new file mode 100644 index 00000000..9849b0e2 --- /dev/null +++ b/ocaml/Input_cipsi_deb.ml @@ -0,0 +1,243 @@ +(* =~=~ *) +(* Init *) +(* =~=~ *) + +open Qptypes;; +open Qputils;; +open Sexplib.Std;; + +module Cipsi_deb : sig +(* Generate type *) + type t = + { + pert_2rdm : bool; + save_wf_after_selection : bool; + seniority_max : int; + excitation_ref : int; + excitation_max : int; + excitation_alpha_max : int; + excitation_beta_max : int; + } [@@deriving sexp] + ;; + val read : unit -> t option + val write : t-> unit + val to_string : t -> string + val to_rst : t -> Rst_string.t + val of_rst : Rst_string.t -> t option +end = struct +(* Generate type *) + type t = + { + pert_2rdm : bool; + save_wf_after_selection : bool; + seniority_max : int; + excitation_ref : int; + excitation_max : int; + excitation_alpha_max : int; + excitation_beta_max : int; + } [@@deriving sexp] + ;; + + let get_default = Qpackage.get_ezfio_default "cipsi_deb";; + +(* =~=~=~=~=~=~==~=~=~=~=~=~ *) +(* Generate Special Function *) +(* =~=~=~==~=~~=~=~=~=~=~=~=~ *) + +(* Read snippet for excitation_alpha_max *) + let read_excitation_alpha_max () = + if not (Ezfio.has_cipsi_deb_excitation_alpha_max ()) then + get_default "excitation_alpha_max" + |> int_of_string + |> Ezfio.set_cipsi_deb_excitation_alpha_max + ; + Ezfio.get_cipsi_deb_excitation_alpha_max () + ;; +(* Write snippet for excitation_alpha_max *) + let write_excitation_alpha_max = + Ezfio.set_cipsi_deb_excitation_alpha_max + ;; + +(* Read snippet for excitation_beta_max *) + let read_excitation_beta_max () = + if not (Ezfio.has_cipsi_deb_excitation_beta_max ()) then + get_default "excitation_beta_max" + |> int_of_string + |> Ezfio.set_cipsi_deb_excitation_beta_max + ; + Ezfio.get_cipsi_deb_excitation_beta_max () + ;; +(* Write snippet for excitation_beta_max *) + let write_excitation_beta_max = + Ezfio.set_cipsi_deb_excitation_beta_max + ;; + +(* Read snippet for excitation_max *) + let read_excitation_max () = + if not (Ezfio.has_cipsi_deb_excitation_max ()) then + get_default "excitation_max" + |> int_of_string + |> Ezfio.set_cipsi_deb_excitation_max + ; + Ezfio.get_cipsi_deb_excitation_max () + ;; +(* Write snippet for excitation_max *) + let write_excitation_max = + Ezfio.set_cipsi_deb_excitation_max + ;; + +(* Read snippet for excitation_ref *) + let read_excitation_ref () = + if not (Ezfio.has_cipsi_deb_excitation_ref ()) then + get_default "excitation_ref" + |> int_of_string + |> Ezfio.set_cipsi_deb_excitation_ref + ; + Ezfio.get_cipsi_deb_excitation_ref () + ;; +(* Write snippet for excitation_ref *) + let write_excitation_ref = + Ezfio.set_cipsi_deb_excitation_ref + ;; + +(* Read snippet for pert_2rdm *) + let read_pert_2rdm () = + if not (Ezfio.has_cipsi_deb_pert_2rdm ()) then + get_default "pert_2rdm" + |> bool_of_string + |> Ezfio.set_cipsi_deb_pert_2rdm + ; + Ezfio.get_cipsi_deb_pert_2rdm () + ;; +(* Write snippet for pert_2rdm *) + let write_pert_2rdm = + Ezfio.set_cipsi_deb_pert_2rdm + ;; + +(* Read snippet for save_wf_after_selection *) + let read_save_wf_after_selection () = + if not (Ezfio.has_cipsi_deb_save_wf_after_selection ()) then + get_default "save_wf_after_selection" + |> bool_of_string + |> Ezfio.set_cipsi_deb_save_wf_after_selection + ; + Ezfio.get_cipsi_deb_save_wf_after_selection () + ;; +(* Write snippet for save_wf_after_selection *) + let write_save_wf_after_selection = + Ezfio.set_cipsi_deb_save_wf_after_selection + ;; + +(* Read snippet for seniority_max *) + let read_seniority_max () = + if not (Ezfio.has_cipsi_deb_seniority_max ()) then + get_default "seniority_max" + |> int_of_string + |> Ezfio.set_cipsi_deb_seniority_max + ; + Ezfio.get_cipsi_deb_seniority_max () + ;; +(* Write snippet for seniority_max *) + let write_seniority_max = + Ezfio.set_cipsi_deb_seniority_max + ;; + +(* =~=~=~=~=~=~=~=~=~=~=~=~ *) +(* Generate Global Function *) +(* =~=~=~=~=~=~=~=~=~=~=~=~ *) + +(* Read all *) + let read() = + Some + { + pert_2rdm = read_pert_2rdm (); + save_wf_after_selection = read_save_wf_after_selection (); + seniority_max = read_seniority_max (); + excitation_ref = read_excitation_ref (); + excitation_max = read_excitation_max (); + excitation_alpha_max = read_excitation_alpha_max (); + excitation_beta_max = read_excitation_beta_max (); + } + ;; +(* Write all *) + let write{ + pert_2rdm; + save_wf_after_selection; + seniority_max; + excitation_ref; + excitation_max; + excitation_alpha_max; + excitation_beta_max; + } = + write_pert_2rdm pert_2rdm; + write_save_wf_after_selection save_wf_after_selection; + write_seniority_max seniority_max; + write_excitation_ref excitation_ref; + write_excitation_max excitation_max; + write_excitation_alpha_max excitation_alpha_max; + write_excitation_beta_max excitation_beta_max; + ;; +(* to_string*) + let to_string b = + Printf.sprintf " + pert_2rdm = %s + save_wf_after_selection = %s + seniority_max = %s + excitation_ref = %s + excitation_max = %s + excitation_alpha_max = %s + excitation_beta_max = %s + " + (string_of_bool b.pert_2rdm) + (string_of_bool b.save_wf_after_selection) + (string_of_int b.seniority_max) + (string_of_int b.excitation_ref) + (string_of_int b.excitation_max) + (string_of_int b.excitation_alpha_max) + (string_of_int b.excitation_beta_max) + ;; +(* to_rst*) + let to_rst b = + Printf.sprintf " + If true, computes the one- and two-body rdms with perturbation theory :: + + pert_2rdm = %s + + If true, saves the wave function after the selection, before the diagonalization :: + + save_wf_after_selection = %s + + Maximum number of allowed open shells. Using -1 selects all determinants :: + + seniority_max = %s + + 1: Hartree-Fock determinant, 2:All determinants of the dominant configuration :: + + excitation_ref = %s + + Maximum number of excitation with respect to the Hartree-Fock determinant. Using -1 selects all determinants :: + + excitation_max = %s + + Maximum number of excitation for alpha determinants with respect to the Hartree-Fock determinant. Using -1 selects all determinants :: + + excitation_alpha_max = %s + + Maximum number of excitation for beta determinants with respect to the Hartree-Fock determinant. Using -1 selects all determinants :: + + excitation_beta_max = %s + + " + (string_of_bool b.pert_2rdm) + (string_of_bool b.save_wf_after_selection) + (string_of_int b.seniority_max) + (string_of_int b.excitation_ref) + (string_of_int b.excitation_max) + (string_of_int b.excitation_alpha_max) + (string_of_int b.excitation_beta_max) + |> Rst_string.of_string + ;; + include Generic_input_of_rst;; + let of_rst = of_rst t_of_sexp;; + +end \ No newline at end of file diff --git a/ocaml/Input_tc_h_clean.ml b/ocaml/Input_tc_h_clean.ml new file mode 100644 index 00000000..2fd145fa --- /dev/null +++ b/ocaml/Input_tc_h_clean.ml @@ -0,0 +1,351 @@ +(* =~=~ *) +(* Init *) +(* =~=~ *) + +open Qptypes;; +open Qputils;; +open Sexplib.Std;; + +module Tc_h_clean : sig +(* Generate type *) + type t = + { + read_rl_eigv : bool; + comp_left_eigv : bool; + three_body_h_tc : bool; + pure_three_body_h_tc : bool; + double_normal_ord : bool; + core_tc_op : bool; + full_tc_h_solver : bool; + thresh_it_dav : Threshold.t; + max_it_dav : int; + thresh_psi_r : Threshold.t; + thresh_psi_r_norm : bool; + } [@@deriving sexp] + ;; + val read : unit -> t option + val write : t-> unit + val to_string : t -> string + val to_rst : t -> Rst_string.t + val of_rst : Rst_string.t -> t option +end = struct +(* Generate type *) + type t = + { + read_rl_eigv : bool; + comp_left_eigv : bool; + three_body_h_tc : bool; + pure_three_body_h_tc : bool; + double_normal_ord : bool; + core_tc_op : bool; + full_tc_h_solver : bool; + thresh_it_dav : Threshold.t; + max_it_dav : int; + thresh_psi_r : Threshold.t; + thresh_psi_r_norm : bool; + } [@@deriving sexp] + ;; + + let get_default = Qpackage.get_ezfio_default "tc_h_clean";; + +(* =~=~=~=~=~=~==~=~=~=~=~=~ *) +(* Generate Special Function *) +(* =~=~=~==~=~~=~=~=~=~=~=~=~ *) + +(* Read snippet for comp_left_eigv *) + let read_comp_left_eigv () = + if not (Ezfio.has_tc_h_clean_comp_left_eigv ()) then + get_default "comp_left_eigv" + |> bool_of_string + |> Ezfio.set_tc_h_clean_comp_left_eigv + ; + Ezfio.get_tc_h_clean_comp_left_eigv () + ;; +(* Write snippet for comp_left_eigv *) + let write_comp_left_eigv = + Ezfio.set_tc_h_clean_comp_left_eigv + ;; + +(* Read snippet for core_tc_op *) + let read_core_tc_op () = + if not (Ezfio.has_tc_h_clean_core_tc_op ()) then + get_default "core_tc_op" + |> bool_of_string + |> Ezfio.set_tc_h_clean_core_tc_op + ; + Ezfio.get_tc_h_clean_core_tc_op () + ;; +(* Write snippet for core_tc_op *) + let write_core_tc_op = + Ezfio.set_tc_h_clean_core_tc_op + ;; + +(* Read snippet for double_normal_ord *) + let read_double_normal_ord () = + if not (Ezfio.has_tc_h_clean_double_normal_ord ()) then + get_default "double_normal_ord" + |> bool_of_string + |> Ezfio.set_tc_h_clean_double_normal_ord + ; + Ezfio.get_tc_h_clean_double_normal_ord () + ;; +(* Write snippet for double_normal_ord *) + let write_double_normal_ord = + Ezfio.set_tc_h_clean_double_normal_ord + ;; + +(* Read snippet for full_tc_h_solver *) + let read_full_tc_h_solver () = + if not (Ezfio.has_tc_h_clean_full_tc_h_solver ()) then + get_default "full_tc_h_solver" + |> bool_of_string + |> Ezfio.set_tc_h_clean_full_tc_h_solver + ; + Ezfio.get_tc_h_clean_full_tc_h_solver () + ;; +(* Write snippet for full_tc_h_solver *) + let write_full_tc_h_solver = + Ezfio.set_tc_h_clean_full_tc_h_solver + ;; + +(* Read snippet for max_it_dav *) + let read_max_it_dav () = + if not (Ezfio.has_tc_h_clean_max_it_dav ()) then + get_default "max_it_dav" + |> int_of_string + |> Ezfio.set_tc_h_clean_max_it_dav + ; + Ezfio.get_tc_h_clean_max_it_dav () + ;; +(* Write snippet for max_it_dav *) + let write_max_it_dav = + Ezfio.set_tc_h_clean_max_it_dav + ;; + +(* Read snippet for pure_three_body_h_tc *) + let read_pure_three_body_h_tc () = + if not (Ezfio.has_tc_h_clean_pure_three_body_h_tc ()) then + get_default "pure_three_body_h_tc" + |> bool_of_string + |> Ezfio.set_tc_h_clean_pure_three_body_h_tc + ; + Ezfio.get_tc_h_clean_pure_three_body_h_tc () + ;; +(* Write snippet for pure_three_body_h_tc *) + let write_pure_three_body_h_tc = + Ezfio.set_tc_h_clean_pure_three_body_h_tc + ;; + +(* Read snippet for read_rl_eigv *) + let read_read_rl_eigv () = + if not (Ezfio.has_tc_h_clean_read_rl_eigv ()) then + get_default "read_rl_eigv" + |> bool_of_string + |> Ezfio.set_tc_h_clean_read_rl_eigv + ; + Ezfio.get_tc_h_clean_read_rl_eigv () + ;; +(* Write snippet for read_rl_eigv *) + let write_read_rl_eigv = + Ezfio.set_tc_h_clean_read_rl_eigv + ;; + +(* Read snippet for three_body_h_tc *) + let read_three_body_h_tc () = + if not (Ezfio.has_tc_h_clean_three_body_h_tc ()) then + get_default "three_body_h_tc" + |> bool_of_string + |> Ezfio.set_tc_h_clean_three_body_h_tc + ; + Ezfio.get_tc_h_clean_three_body_h_tc () + ;; +(* Write snippet for three_body_h_tc *) + let write_three_body_h_tc = + Ezfio.set_tc_h_clean_three_body_h_tc + ;; + +(* Read snippet for thresh_it_dav *) + let read_thresh_it_dav () = + if not (Ezfio.has_tc_h_clean_thresh_it_dav ()) then + get_default "thresh_it_dav" + |> float_of_string + |> Ezfio.set_tc_h_clean_thresh_it_dav + ; + Ezfio.get_tc_h_clean_thresh_it_dav () + |> Threshold.of_float + ;; +(* Write snippet for thresh_it_dav *) + let write_thresh_it_dav var = + Threshold.to_float var + |> Ezfio.set_tc_h_clean_thresh_it_dav + ;; + +(* Read snippet for thresh_psi_r *) + let read_thresh_psi_r () = + if not (Ezfio.has_tc_h_clean_thresh_psi_r ()) then + get_default "thresh_psi_r" + |> float_of_string + |> Ezfio.set_tc_h_clean_thresh_psi_r + ; + Ezfio.get_tc_h_clean_thresh_psi_r () + |> Threshold.of_float + ;; +(* Write snippet for thresh_psi_r *) + let write_thresh_psi_r var = + Threshold.to_float var + |> Ezfio.set_tc_h_clean_thresh_psi_r + ;; + +(* Read snippet for thresh_psi_r_norm *) + let read_thresh_psi_r_norm () = + if not (Ezfio.has_tc_h_clean_thresh_psi_r_norm ()) then + get_default "thresh_psi_r_norm" + |> bool_of_string + |> Ezfio.set_tc_h_clean_thresh_psi_r_norm + ; + Ezfio.get_tc_h_clean_thresh_psi_r_norm () + ;; +(* Write snippet for thresh_psi_r_norm *) + let write_thresh_psi_r_norm = + Ezfio.set_tc_h_clean_thresh_psi_r_norm + ;; + +(* =~=~=~=~=~=~=~=~=~=~=~=~ *) +(* Generate Global Function *) +(* =~=~=~=~=~=~=~=~=~=~=~=~ *) + +(* Read all *) + let read() = + Some + { + read_rl_eigv = read_read_rl_eigv (); + comp_left_eigv = read_comp_left_eigv (); + three_body_h_tc = read_three_body_h_tc (); + pure_three_body_h_tc = read_pure_three_body_h_tc (); + double_normal_ord = read_double_normal_ord (); + core_tc_op = read_core_tc_op (); + full_tc_h_solver = read_full_tc_h_solver (); + thresh_it_dav = read_thresh_it_dav (); + max_it_dav = read_max_it_dav (); + thresh_psi_r = read_thresh_psi_r (); + thresh_psi_r_norm = read_thresh_psi_r_norm (); + } + ;; +(* Write all *) + let write{ + read_rl_eigv; + comp_left_eigv; + three_body_h_tc; + pure_three_body_h_tc; + double_normal_ord; + core_tc_op; + full_tc_h_solver; + thresh_it_dav; + max_it_dav; + thresh_psi_r; + thresh_psi_r_norm; + } = + write_read_rl_eigv read_rl_eigv; + write_comp_left_eigv comp_left_eigv; + write_three_body_h_tc three_body_h_tc; + write_pure_three_body_h_tc pure_three_body_h_tc; + write_double_normal_ord double_normal_ord; + write_core_tc_op core_tc_op; + write_full_tc_h_solver full_tc_h_solver; + write_thresh_it_dav thresh_it_dav; + write_max_it_dav max_it_dav; + write_thresh_psi_r thresh_psi_r; + write_thresh_psi_r_norm thresh_psi_r_norm; + ;; +(* to_string*) + let to_string b = + Printf.sprintf " + read_rl_eigv = %s + comp_left_eigv = %s + three_body_h_tc = %s + pure_three_body_h_tc = %s + double_normal_ord = %s + core_tc_op = %s + full_tc_h_solver = %s + thresh_it_dav = %s + max_it_dav = %s + thresh_psi_r = %s + thresh_psi_r_norm = %s + " + (string_of_bool b.read_rl_eigv) + (string_of_bool b.comp_left_eigv) + (string_of_bool b.three_body_h_tc) + (string_of_bool b.pure_three_body_h_tc) + (string_of_bool b.double_normal_ord) + (string_of_bool b.core_tc_op) + (string_of_bool b.full_tc_h_solver) + (Threshold.to_string b.thresh_it_dav) + (string_of_int b.max_it_dav) + (Threshold.to_string b.thresh_psi_r) + (string_of_bool b.thresh_psi_r_norm) + ;; +(* to_rst*) + let to_rst b = + Printf.sprintf " + If |true|, read the right/left eigenvectors from ezfio :: + + read_rl_eigv = %s + + If |true|, computes also the left-eigenvector :: + + comp_left_eigv = %s + + If |true|, three-body terms are included :: + + three_body_h_tc = %s + + If |true|, pure triple excitation three-body terms are included :: + + pure_three_body_h_tc = %s + + If |true|, contracted double excitation three-body terms are included :: + + double_normal_ord = %s + + If |true|, takes the usual Hamiltonian for core orbitals (assumed to be doubly occupied) :: + + core_tc_op = %s + + If |true|, you diagonalize the full TC H matrix :: + + full_tc_h_solver = %s + + Thresholds on the energy for iterative Davidson used in TC :: + + thresh_it_dav = %s + + nb max of iteration in Davidson used in TC :: + + max_it_dav = %s + + Thresholds on the coefficients of the right-eigenvector. Used for PT2 computation. :: + + thresh_psi_r = %s + + If |true|, you prune the WF to compute the PT1 coef based on the norm. If False, the pruning is done through the amplitude on the right-coefficient. :: + + thresh_psi_r_norm = %s + + " + (string_of_bool b.read_rl_eigv) + (string_of_bool b.comp_left_eigv) + (string_of_bool b.three_body_h_tc) + (string_of_bool b.pure_three_body_h_tc) + (string_of_bool b.double_normal_ord) + (string_of_bool b.core_tc_op) + (string_of_bool b.full_tc_h_solver) + (Threshold.to_string b.thresh_it_dav) + (string_of_int b.max_it_dav) + (Threshold.to_string b.thresh_psi_r) + (string_of_bool b.thresh_psi_r_norm) + |> Rst_string.of_string + ;; + include Generic_input_of_rst;; + let of_rst = of_rst t_of_sexp;; + +end \ No newline at end of file diff --git a/ocaml/Input_tc_scf.ml b/ocaml/Input_tc_scf.ml new file mode 100644 index 00000000..2a709716 --- /dev/null +++ b/ocaml/Input_tc_scf.ml @@ -0,0 +1,143 @@ +(* =~=~ *) +(* Init *) +(* =~=~ *) + +open Qptypes;; +open Qputils;; +open Sexplib.Std;; + +module Tc_scf : sig +(* Generate type *) + type t = + { + bi_ortho : bool; + thresh_tcscf : Threshold.t; + n_it_tcscf_max : Strictly_positive_int.t; + } [@@deriving sexp] + ;; + val read : unit -> t option + val write : t-> unit + val to_string : t -> string + val to_rst : t -> Rst_string.t + val of_rst : Rst_string.t -> t option +end = struct +(* Generate type *) + type t = + { + bi_ortho : bool; + thresh_tcscf : Threshold.t; + n_it_tcscf_max : Strictly_positive_int.t; + } [@@deriving sexp] + ;; + + let get_default = Qpackage.get_ezfio_default "tc_scf";; + +(* =~=~=~=~=~=~==~=~=~=~=~=~ *) +(* Generate Special Function *) +(* =~=~=~==~=~~=~=~=~=~=~=~=~ *) + +(* Read snippet for bi_ortho *) + let read_bi_ortho () = + if not (Ezfio.has_tc_scf_bi_ortho ()) then + get_default "bi_ortho" + |> bool_of_string + |> Ezfio.set_tc_scf_bi_ortho + ; + Ezfio.get_tc_scf_bi_ortho () + ;; +(* Write snippet for bi_ortho *) + let write_bi_ortho = + Ezfio.set_tc_scf_bi_ortho + ;; + +(* Read snippet for n_it_tcscf_max *) + let read_n_it_tcscf_max () = + if not (Ezfio.has_tc_scf_n_it_tcscf_max ()) then + get_default "n_it_tcscf_max" + |> int_of_string + |> Ezfio.set_tc_scf_n_it_tcscf_max + ; + Ezfio.get_tc_scf_n_it_tcscf_max () + |> Strictly_positive_int.of_int + ;; +(* Write snippet for n_it_tcscf_max *) + let write_n_it_tcscf_max var = + Strictly_positive_int.to_int var + |> Ezfio.set_tc_scf_n_it_tcscf_max + ;; + +(* Read snippet for thresh_tcscf *) + let read_thresh_tcscf () = + if not (Ezfio.has_tc_scf_thresh_tcscf ()) then + get_default "thresh_tcscf" + |> float_of_string + |> Ezfio.set_tc_scf_thresh_tcscf + ; + Ezfio.get_tc_scf_thresh_tcscf () + |> Threshold.of_float + ;; +(* Write snippet for thresh_tcscf *) + let write_thresh_tcscf var = + Threshold.to_float var + |> Ezfio.set_tc_scf_thresh_tcscf + ;; + +(* =~=~=~=~=~=~=~=~=~=~=~=~ *) +(* Generate Global Function *) +(* =~=~=~=~=~=~=~=~=~=~=~=~ *) + +(* Read all *) + let read() = + Some + { + bi_ortho = read_bi_ortho (); + thresh_tcscf = read_thresh_tcscf (); + n_it_tcscf_max = read_n_it_tcscf_max (); + } + ;; +(* Write all *) + let write{ + bi_ortho; + thresh_tcscf; + n_it_tcscf_max; + } = + write_bi_ortho bi_ortho; + write_thresh_tcscf thresh_tcscf; + write_n_it_tcscf_max n_it_tcscf_max; + ;; +(* to_string*) + let to_string b = + Printf.sprintf " + bi_ortho = %s + thresh_tcscf = %s + n_it_tcscf_max = %s + " + (string_of_bool b.bi_ortho) + (Threshold.to_string b.thresh_tcscf) + (Strictly_positive_int.to_string b.n_it_tcscf_max) + ;; +(* to_rst*) + let to_rst b = + Printf.sprintf " + If |true|, the MO basis is assumed to be bi-orthonormal :: + + bi_ortho = %s + + Threshold on the convergence of the Hartree Fock energy. :: + + thresh_tcscf = %s + + Maximum number of SCF iterations :: + + n_it_tcscf_max = %s + + " + (string_of_bool b.bi_ortho) + (Threshold.to_string b.thresh_tcscf) + (Strictly_positive_int.to_string b.n_it_tcscf_max) + |> Rst_string.of_string + ;; + include Generic_input_of_rst;; + let of_rst = of_rst t_of_sexp;; + +end \ No newline at end of file diff --git a/ocaml/Molecule.ml b/ocaml/Molecule.ml index 603244c8..9b01ac3a 100644 --- a/ocaml/Molecule.ml +++ b/ocaml/Molecule.ml @@ -101,7 +101,7 @@ let to_string_general ~f m = |> String.concat "\n" let to_string = - to_string_general ~f:(fun x -> Atom.to_string ~units:Units.Angstrom x) + to_string_general ~f:(fun x -> Atom.to_string Units.Angstrom x) let to_xyz = to_string_general ~f:Atom.to_xyz @@ -113,7 +113,7 @@ let of_xyz_string s = let l = String_ext.split s ~on:'\n' |> List.filter (fun x -> x <> "") - |> list_map (fun x -> Atom.of_string ~units x) + |> list_map (fun x -> Atom.of_string units x) in let ne = ( get_charge { nuclei=l ; diff --git a/ocaml/Qputils.ml b/ocaml/Qputils.ml index 752a65a0..270e069f 100644 --- a/ocaml/Qputils.ml +++ b/ocaml/Qputils.ml @@ -56,7 +56,3 @@ let string_of_string s = s let list_map f l = List.rev_map f l |> List.rev - -let socket_convert socket = - ((Obj.magic (Obj.repr socket)) : [ `Xsub ] Zmq.Socket.t ) - diff --git a/ocaml/qp_create_ezfio.ml b/ocaml/qp_create_ezfio.ml index 4583b118..a4865e2b 100644 --- a/ocaml/qp_create_ezfio.ml +++ b/ocaml/qp_create_ezfio.ml @@ -91,7 +91,7 @@ let run ?o b au c d m p cart xyz_file = | Element e -> Element.to_string e | Int_elem (i,e) -> Printf.sprintf "%d,%s" (Nucl_number.to_int i) (Element.to_string e) in - Hashtbl.find basis_table key + Hashtbl.find basis_table key in let temp_filename = @@ -132,7 +132,7 @@ let run ?o b au c d m p cart xyz_file = Element.to_string elem.Atom.element in Hashtbl.add basis_table key new_channel - ) nuclei + ) nuclei end | Some (key, basis) -> (*Aux basis *) begin @@ -277,16 +277,6 @@ let run ?o b au c d m p cart xyz_file = ) nuclei in - let z_core = - List.map (fun x -> - Positive_int.to_int x.Pseudo.n_elec - |> float_of_int - ) pseudo - in - let nucl_num = (List.length z_core) in - Ezfio.set_pseudo_nucl_charge_remove (Ezfio.ezfio_array_of_list - ~rank:1 ~dim:[| nucl_num |] ~data:z_core); - let molecule = let n_elec_to_remove = List.fold_left (fun accu x -> @@ -303,13 +293,13 @@ let run ?o b au c d m p cart xyz_file = Molecule.nuclei = let charges = list_map (fun x -> Positive_int.to_int x.Pseudo.n_elec - |> Float.of_int) pseudo + |> Float.of_int) pseudo |> Array.of_list in List.mapi (fun i x -> { x with Atom.charge = (Charge.to_float x.Atom.charge) -. charges.(i) |> Charge.of_float } - ) molecule.Molecule.nuclei + ) molecule.Molecule.nuclei } in let nuclei = @@ -366,11 +356,11 @@ let run ?o b au c d m p cart xyz_file = in if (x > accu) then x else accu - ) 0 x.Pseudo.non_local + ) 0 x.Pseudo.non_local in if (x > accu) then x else accu - ) 0 pseudo + ) 0 pseudo in let kmax = @@ -378,10 +368,10 @@ let run ?o b au c d m p cart xyz_file = list_map (fun x -> List.filter (fun (y,_) -> (Positive_int.to_int y.Pseudo.GaussianPrimitive_non_local.proj) = i) - x.Pseudo.non_local - |> List.length ) pseudo + x.Pseudo.non_local + |> List.length ) pseudo |> List.fold_left (fun accu x -> - if accu > x then accu else x) 0 + if accu > x then accu else x) 0 ) |> Array.fold_left (fun accu i -> if i > accu then i else accu) 0 @@ -406,11 +396,11 @@ let run ?o b au c d m p cart xyz_file = in tmp_array_dz_k.(i).(j) <- y; tmp_array_n_k.(i).(j) <- z; - ) x.Pseudo.local + ) x.Pseudo.local ) pseudo ; let concat_2d tmp_array = let data = - Array.map Array.to_list tmp_array + Array.map Array.to_list tmp_array |> Array.to_list |> List.concat in @@ -448,14 +438,14 @@ let run ?o b au c d m p cart xyz_file = tmp_array_dz_kl.(k).(i).(j) <- y; tmp_array_n_kl.(k).(i).(j) <- z; last_idx.(k) <- i+1; - ) x.Pseudo.non_local + ) x.Pseudo.non_local ) pseudo ; let concat_3d tmp_array = let data = Array.map (fun x -> Array.map Array.to_list x |> Array.to_list - |> List.concat) tmp_array + |> List.concat) tmp_array |> Array.to_list |> List.concat in @@ -523,8 +513,8 @@ let run ?o b au c d m p cart xyz_file = 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 + 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)@ @@ -536,7 +526,7 @@ let run ?o b au c d m p cart xyz_file = else s) 0 ao_prim_num in let gtos = - list_map (fun (_,x,_) -> x) long_basis + list_map (fun (_,x,_) -> x) long_basis in let create_expo_coef ec = @@ -544,10 +534,10 @@ let run ?o b au c d m p cart xyz_file = begin match ec with | `Coefs -> list_map (fun x-> list_map (fun (_,coef) -> - AO_coef.to_float coef) x.Gto.lc) gtos + 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 + prim.GaussianPrimitive.expo) x.Gto.lc) gtos end in let rec get_n n accu = function @@ -577,7 +567,7 @@ let run ?o b au c d m p cart xyz_file = list_map ( fun (g,_) -> g.Gto.lc ) basis in let ang_mom = - list_map (fun (l : (GaussianPrimitive.t * Qptypes.AO_coef.t) list) -> + 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 @@ -587,7 +577,7 @@ let run ?o b au c d m p cart xyz_file = |> List.concat in let coef = - list_map (fun l -> + list_map (fun l -> list_map (fun (_,x) -> Qptypes.AO_coef.to_float x) l ) lc |> List.concat @@ -595,16 +585,12 @@ let run ?o b au c d m p cart xyz_file = 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 shell_prim_idx = 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 + let newcount = count+(List.length l) in + aux newcount (count::accu) rest in aux 1 [] lc in @@ -616,18 +602,26 @@ let run ?o b au c d m p cart xyz_file = ~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_shell_prim_index (Ezfio.ezfio_array_of_list + ~rank:1 ~dim:[| shell_num |] ~data:shell_prim_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) - ) ; + ~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 + | [] -> [] + | (h,j) :: rest -> if j == i then ((h+1,j)::rest) else ((h+1,i)::(h+1,j)::rest) + ) [(0,0)] + |> List.rev + |> List.map fst + )) ; 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 + |> 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) ) [] @@ -677,7 +671,6 @@ let run ?o b au c d m p cart xyz_file = let () = - try ( let open Command_line in begin @@ -724,7 +717,7 @@ If a file with the same name as the basis set exists, this file will be read. O anonymous "FILE" Mandatory "Input file in xyz format or z-matrix."; ] - |> set_specs + |> set_specs end; @@ -735,7 +728,7 @@ If a file with the same name as the basis set exists, this file will be read. O let basis = match Command_line.get "basis" with - | None -> "" + | None -> assert false | Some x -> x in @@ -748,7 +741,7 @@ If a file with the same name as the basis set exists, this file will be read. O | None -> 0 | Some x -> ( if x.[0] = 'm' then ~- (int_of_string (String.sub x 1 (String.length x - 1))) - else + else int_of_string x ) in @@ -774,14 +767,10 @@ If a file with the same name as the basis set exists, this file will be read. O let xyz_filename = match Command_line.anon_args () with - | [] -> failwith "input file is missing" - | x::_ -> x + | [x] -> x + | _ -> (Command_line.help () ; failwith "input file is missing") in run ?o:output basis au charge dummy multiplicity pseudo cart xyz_filename - ) - with - | Failure txt -> Printf.eprintf "Fatal error: %s\n%!" txt - | Command_line.Error txt -> Printf.eprintf "Command line error: %s\n%!" txt diff --git a/ocaml/qp_run.ml b/ocaml/qp_run.ml index dfbab167..d096b15b 100644 --- a/ocaml/qp_run.ml +++ b/ocaml/qp_run.ml @@ -110,7 +110,7 @@ let run slave ?prefix exe ezfio_file = let task_thread = let thread = Thread.create ( fun () -> - TaskServer.run ~port:port_number ) + TaskServer.run port_number ) in thread (); in diff --git a/ocaml/qp_tunnel.ml b/ocaml/qp_tunnel.ml index 6885db73..84e50eb5 100644 --- a/ocaml/qp_tunnel.ml +++ b/ocaml/qp_tunnel.ml @@ -2,7 +2,7 @@ open Qputils open Qptypes type ezfio_or_address = EZFIO of string | ADDRESS of string -type req_or_sub = REQ | SUB +type req_or_sub = REQ | SUB let localport = 42379 @@ -29,7 +29,7 @@ let () = end; let arg = - let x = + let x = match Command_line.anon_args () with | [x] -> x | _ -> begin @@ -44,7 +44,7 @@ let () = in - let localhost = + let localhost = Lazy.force TaskServer.ip_address in @@ -52,28 +52,28 @@ let () = let long_address = match arg with | ADDRESS x -> x - | EZFIO x -> - let ic = + | EZFIO x -> + let ic = Filename.concat (Qpackage.ezfio_work x) "qp_run_address" |> open_in in - let result = + let result = input_line ic |> String.trim in close_in ic; result in - + let protocol, address, port = match String.split_on_char ':' long_address with | t :: a :: p :: [] -> t, a, int_of_string p - | _ -> failwith @@ + | _ -> failwith @@ Printf.sprintf "%s : Malformed address" long_address in - let zmq_context = + let zmq_context = Zmq.Context.create () in @@ -105,10 +105,10 @@ let () = let create_socket sock_type bind_or_connect addr = - let socket = + let socket = Zmq.Socket.create zmq_context sock_type in - let () = + let () = try bind_or_connect socket addr with @@ -131,64 +131,37 @@ let () = Sys.set_signal Sys.sigint handler; - let new_thread_req addr_in addr_out = + let new_thread req_or_sub addr_in addr_out = let socket_in, socket_out = + match req_or_sub with + | REQ -> create_socket Zmq.Socket.router Zmq.Socket.bind addr_in, create_socket Zmq.Socket.dealer Zmq.Socket.connect addr_out - in - - - let action_in = - fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out - in - - let action_out = - fun () -> Zmq.Socket.recv_all socket_out |> Zmq.Socket.send_all socket_in - in - - let pollitem = - Zmq.Poll.mask_of - [| (socket_convert socket_in, Zmq.Poll.In) ; (socket_convert socket_out, Zmq.Poll.In) |] - in - - while !run_status do - - let polling = - Zmq.Poll.poll ~timeout:1000 pollitem - in - - match polling with - | [| Some Zmq.Poll.In ; Some Zmq.Poll.In |] -> ( action_out () ; action_in () ) - | [| _ ; Some Zmq.Poll.In |] -> action_out () - | [| Some Zmq.Poll.In ; _ |] -> action_in () - | _ -> () - done; - - Zmq.Socket.close socket_in; - Zmq.Socket.close socket_out; - in - - let new_thread_sub addr_in addr_out = - let socket_in, socket_out = + | SUB -> create_socket Zmq.Socket.sub Zmq.Socket.connect addr_in, create_socket Zmq.Socket.pub Zmq.Socket.bind addr_out in - Zmq.Socket.subscribe socket_in ""; + if req_or_sub = SUB then + Zmq.Socket.subscribe socket_in ""; - let action_in = - fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out + let action_in = + match req_or_sub with + | REQ -> (fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out) + | SUB -> (fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out) in - let action_out = - fun () -> () + let action_out = + match req_or_sub with + | REQ -> (fun () -> Zmq.Socket.recv_all socket_out |> Zmq.Socket.send_all socket_in ) + | SUB -> (fun () -> () ) in let pollitem = Zmq.Poll.mask_of - [| (socket_convert socket_in, Zmq.Poll.In) ; (socket_convert socket_out, Zmq.Poll.In) |] + [| (socket_in, Zmq.Poll.In) ; (socket_out, Zmq.Poll.In) |] in @@ -200,8 +173,8 @@ let () = match polling with | [| Some Zmq.Poll.In ; Some Zmq.Poll.In |] -> ( action_out () ; action_in () ) - | [| _ ; Some Zmq.Poll.In |] -> action_out () - | [| Some Zmq.Poll.In ; _ |] -> action_in () + | [| _ ; Some Zmq.Poll.In |] -> action_out () + | [| Some Zmq.Poll.In ; _ |] -> action_in () | _ -> () done; @@ -220,8 +193,8 @@ let () = Printf.sprintf "tcp://*:%d" localport in - let f () = - new_thread_req addr_in addr_out + let f () = + new_thread REQ addr_in addr_out in (Thread.create f) () @@ -238,8 +211,8 @@ let () = Printf.sprintf "tcp://*:%d" (localport+2) in - let f () = - new_thread_req addr_in addr_out + let f () = + new_thread REQ addr_in addr_out in (Thread.create f) () in @@ -254,8 +227,8 @@ let () = Printf.sprintf "tcp://*:%d" (localport+1) in - let f () = - new_thread_sub addr_in addr_out + let f () = + new_thread SUB addr_in addr_out in (Thread.create f) () in @@ -263,7 +236,7 @@ let () = let input_thread = - let f () = + let f () = let addr_out = match arg with | EZFIO _ -> None @@ -275,22 +248,22 @@ let () = Printf.sprintf "tcp://*:%d" (localport+9) in - let socket_in = + let socket_in = create_socket Zmq.Socket.rep Zmq.Socket.bind addr_in in let socket_out = - match addr_out with + match addr_out with | Some addr_out -> Some ( create_socket Zmq.Socket.req Zmq.Socket.connect addr_out) | None -> None in - let temp_file = + let temp_file = Filename.temp_file "qp_tunnel" ".tar.gz" in - let get_ezfio_filename () = + let get_ezfio_filename () = match arg with | EZFIO x -> x | ADDRESS _ -> @@ -304,9 +277,9 @@ let () = end in - let get_input () = + let get_input () = match arg with - | EZFIO x -> + | EZFIO x -> begin Printf.sprintf "tar --exclude=\"*.gz.*\" -zcf %s %s" temp_file x |> Sys.command |> ignore; @@ -318,11 +291,11 @@ let () = in ignore @@ Unix.lseek fd 0 Unix.SEEK_SET ; let bstr = - Unix.map_file fd Bigarray.char + Unix.map_file fd Bigarray.char Bigarray.c_layout false [| len |] |> Bigarray.array1_of_genarray in - let result = + let result = String.init len (fun i -> bstr.{i}) ; in Unix.close fd; @@ -340,7 +313,7 @@ let () = end in - let () = + let () = match socket_out with | None -> () | Some socket_out -> @@ -356,7 +329,7 @@ let () = | ADDRESS _ -> begin Printf.printf "Getting input... %!"; - let ezfio_filename = + let ezfio_filename = get_ezfio_filename () in Printf.printf "%s%!" ezfio_filename; @@ -370,7 +343,7 @@ let () = |> Sys.command |> ignore ; let oc = Filename.concat (Qpackage.ezfio_work ezfio_filename) "qp_run_address" - |> open_out + |> open_out in Printf.fprintf oc "tcp://%s:%d\n" localhost localport; close_out oc; @@ -386,9 +359,9 @@ let () = let action () = match Zmq.Socket.recv socket_in with | "get_input" -> get_input () - |> Zmq.Socket.send socket_in + |> Zmq.Socket.send socket_in | "get_ezfio_filename" -> get_ezfio_filename () - |> Zmq.Socket.send socket_in + |> Zmq.Socket.send socket_in | "test" -> Zmq.Socket.send socket_in "OK" | x -> Printf.sprintf "Message '%s' not understood" x |> Zmq.Socket.send socket_in @@ -399,7 +372,7 @@ On remote hosts, create ssh tunnel using: ssh -L %d:%s:%d -L %d:%s:%d -L %d:%s:%d -L %d:%s:%d %s & Or from this host connect to clients using: ssh -R %d:localhost:%d -R %d:localhost:%d -R %d:localhost:%d -R %d:localhost:%d & -%!" +%!" (port ) localhost (localport ) (port+1) localhost (localport+1) (port+2) localhost (localport+2) @@ -419,12 +392,12 @@ Or from this host connect to clients using: match polling.(0) with | Some Zmq.Poll.In -> action () | None -> () - | Some Zmq.Poll.In_out + | Some Zmq.Poll.In_out | Some Zmq.Poll.Out -> () done; - let () = + let () = match socket_out with | Some socket_out -> Zmq.Socket.close socket_out | None -> () @@ -442,7 +415,7 @@ Or from this host connect to clients using: Thread.join ocaml_thread; Zmq.Context.terminate zmq_context; Printf.printf "qp_tunnel exited properly.\n" - + diff --git a/src/ao_basis/EZFIO.cfg b/src/ao_basis/EZFIO.cfg index 51d726da..b4b4b1d9 100644 --- a/src/ao_basis/EZFIO.cfg +++ b/src/ao_basis/EZFIO.cfg @@ -17,7 +17,7 @@ interface: ezfio, provider [ao_prim_num_max] type: integer doc: Maximum number of primitives -default: =maxval(ao_basis.ao_prim_num) +#default: =maxval(ao_basis.ao_prim_num) interface: ezfio [ao_nucl] diff --git a/src/ao_basis/aos.irp.f b/src/ao_basis/aos.irp.f index 1cbd3976..553543b9 100644 --- a/src/ao_basis/aos.irp.f +++ b/src/ao_basis/aos.irp.f @@ -1,11 +1,20 @@ + +! --- + BEGIN_PROVIDER [ integer, ao_prim_num_max ] - implicit none + BEGIN_DOC ! Max number of primitives. END_DOC - ao_prim_num_max = maxval(ao_prim_num) + + implicit none + ao_prim_num_max = maxval(ao_prim_num) + call ezfio_set_ao_basis_ao_prim_num_max(ao_prim_num_max) + END_PROVIDER +! --- + BEGIN_PROVIDER [ integer, ao_shell, (ao_num) ] implicit none BEGIN_DOC @@ -21,21 +30,6 @@ BEGIN_PROVIDER [ integer, ao_shell, (ao_num) ] enddo enddo -END_PROVIDER - -BEGIN_PROVIDER [ integer, ao_first_of_shell, (shell_num) ] - implicit none - BEGIN_DOC - ! Index of the shell to which the AO corresponds - END_DOC - integer :: i, j, k, n - k=1 - do i=1,shell_num - ao_first_of_shell(i) = k - n = shell_ang_mom(i)+1 - k = k+(n*(n+1))/2 - enddo - END_PROVIDER BEGIN_PROVIDER [ double precision, ao_coef_normalized, (ao_num,ao_prim_num_max) ] diff --git a/src/ao_basis/aos_in_r.irp.f b/src/ao_basis/aos_in_r.irp.f index 902827eb..7fcb980a 100644 --- a/src/ao_basis/aos_in_r.irp.f +++ b/src/ao_basis/aos_in_r.irp.f @@ -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 diff --git a/src/ao_basis/spherical_to_cartesian.irp.f b/src/ao_basis/spherical_to_cartesian.irp.f index 336161f8..33a3bc89 100644 --- a/src/ao_basis/spherical_to_cartesian.irp.f +++ b/src/ao_basis/spherical_to_cartesian.irp.f @@ -1,7 +1,7 @@ ! Spherical to cartesian transformation matrix obtained with ! Horton (http://theochem.github.com/horton/, 2015) -! First index is the index of the cartesian AO, obtained by ao_power_index +! First index is the index of the carteisan AO, obtained by ao_power_index ! Second index is the index of the spherical AO BEGIN_PROVIDER [ double precision, cart_to_sphe_0, (1,1) ] diff --git a/src/ao_one_e_ints/NEED b/src/ao_one_e_ints/NEED index 61d23b1e..b9caaf5d 100644 --- a/src/ao_one_e_ints/NEED +++ b/src/ao_one_e_ints/NEED @@ -1,2 +1,3 @@ ao_basis pseudo +cosgtos_ao_int diff --git a/src/ao_one_e_ints/ao_overlap.irp.f b/src/ao_one_e_ints/ao_overlap.irp.f index d9061d67..86fa7cd4 100644 --- a/src/ao_one_e_ints/ao_overlap.irp.f +++ b/src/ao_one_e_ints/ao_overlap.irp.f @@ -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,37 +126,39 @@ 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 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,& @@ -161,9 +191,13 @@ BEGIN_PROVIDER [ double precision, ao_overlap_abs,(ao_num,ao_num) ] enddo enddo !$OMP END PARALLEL DO + endif + END_PROVIDER +! --- + BEGIN_PROVIDER [ double precision, S_inv,(ao_num,ao_num) ] implicit none BEGIN_DOC diff --git a/src/ao_one_e_ints/kin_ao_ints.irp.f b/src/ao_one_e_ints/kin_ao_ints.irp.f index 4f117deb..a5ee0670 100644 --- a/src/ao_one_e_ints/kin_ao_ints.irp.f +++ b/src/ao_one_e_ints/kin_ao_ints.irp.f @@ -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 diff --git a/src/ao_one_e_ints/pot_ao_ints.irp.f b/src/ao_one_e_ints/pot_ao_ints.irp.f index 4108ce71..2b6a4d05 100644 --- a/src/ao_one_e_ints/pot_ao_ints.irp.f +++ b/src/ao_one_e_ints/pot_ao_ints.irp.f @@ -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,78 +10,103 @@ 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 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 + ao_integrals_n_e = 0.d0 - !$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) + !$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) - do i = 1, ao_num + n_pt_in = n_pt_max_integrals - num_B = ao_nucl(i) - power_B(1:3)= ao_power(i,1:3) - B_center(1:3) = nucl_coord(num_B,1:3) + !$OMP DO SCHEDULE (dynamic) - do l=1,ao_prim_num(j) - alpha = ao_expo_ordered_transp(l,j) + 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 m=1,ao_prim_num(i) - beta = ao_expo_ordered_transp(m,i) + do i = 1, ao_num - double precision :: c - c = 0.d0 + 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 k = 1, nucl_num - double precision :: Z - Z = nucl_charge(k) + do l=1,ao_prim_num(j) + alpha = ao_expo_ordered_transp(l,j) - C_center(1:3) = nucl_coord(k,1:3) + do m=1,ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) - c = c - Z * NAI_pol_mult(A_center,B_center, & - power_A,power_B,alpha,beta,C_center,n_pt_in) + double precision :: c, c1 + c = 0.d0 + do k = 1, nucl_num + double precision :: Z + 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 *, 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 @@ -98,7 +127,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) @@ -121,7 +150,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) @@ -259,11 +288,14 @@ double precision function NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,b ! sum of integrals of type : int {t,[0,1]} exp-(rho.(P-Q)^2 * t^2) * t^i do i =0 ,n_pt_out,2 accu += d(i) * rint(i/2,const) + +! print *, i/2, const, d(i), rint(shiftr(i, 1), const) enddo NAI_pol_mult = accu * coeff 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 @@ -575,61 +607,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 - - diff --git a/src/ao_one_e_ints/pot_ao_pseudo_ints.irp.f b/src/ao_one_e_ints/pot_ao_pseudo_ints.irp.f index e75ca056..24f43311 100644 --- a/src/ao_one_e_ints/pot_ao_pseudo_ints.irp.f +++ b/src/ao_one_e_ints/pot_ao_pseudo_ints.irp.f @@ -28,7 +28,6 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integrals, (ao_num,ao_num)] END_PROVIDER BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_local, (ao_num,ao_num)] - use omp_lib implicit none BEGIN_DOC ! Local pseudo-potential @@ -43,6 +42,7 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_local, (ao_num,ao_num)] double precision :: wall_1, wall_2, wall_0 integer :: thread_num + integer :: omp_get_thread_num double precision :: c double precision :: Z @@ -158,7 +158,6 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_local, (ao_num,ao_num)] BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_non_local, (ao_num,ao_num)] - use omp_lib implicit none BEGIN_DOC ! Non-local pseudo-potential @@ -170,6 +169,7 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_local, (ao_num,ao_num)] integer :: power_A(3),power_B(3) integer :: i,j,k,l,m double precision :: Vloc, Vpseudo + integer :: omp_get_thread_num double precision :: wall_1, wall_2, wall_0 integer :: thread_num diff --git a/src/ao_two_e_ints/EZFIO.cfg b/src/ao_two_e_ints/EZFIO.cfg index b18c65d1..dfceddb5 100644 --- a/src/ao_two_e_ints/EZFIO.cfg +++ b/src/ao_two_e_ints/EZFIO.cfg @@ -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) diff --git a/src/ao_two_e_ints/gauss_legendre.irp.f b/src/ao_two_e_ints/gauss_legendre.irp.f deleted file mode 100644 index 4bdadb6e..00000000 --- a/src/ao_two_e_ints/gauss_legendre.irp.f +++ /dev/null @@ -1,57 +0,0 @@ - BEGIN_PROVIDER [ double precision, gauleg_t2, (n_pt_max_integrals,n_pt_max_integrals/2) ] -&BEGIN_PROVIDER [ double precision, gauleg_w, (n_pt_max_integrals,n_pt_max_integrals/2) ] - implicit none - BEGIN_DOC - ! t_w(i,1,k) = w(i) - ! t_w(i,2,k) = t(i) - END_DOC - integer :: i,j,l - l=0 - do i = 2,n_pt_max_integrals,2 - l = l+1 - call gauleg(0.d0,1.d0,gauleg_t2(1,l),gauleg_w(1,l),i) - do j=1,i - gauleg_t2(j,l) *= gauleg_t2(j,l) - enddo - enddo - -END_PROVIDER - -subroutine gauleg(x1,x2,x,w,n) - implicit none - BEGIN_DOC - ! Gauss-Legendre - END_DOC - integer, intent(in) :: n - double precision, intent(in) :: x1, x2 - double precision, intent (out) :: x(n),w(n) - double precision, parameter :: eps=3.d-14 - - integer :: m,i,j - double precision :: xm, xl, z, z1, p1, p2, p3, pp, dn - m=(n+1)/2 - xm=0.5d0*(x2+x1) - xl=0.5d0*(x2-x1) - dn = dble(n) - do i=1,m - z=dcos(3.141592654d0*(dble(i)-.25d0)/(dble(n)+.5d0)) - z1 = z+1.d0 - do while (dabs(z-z1) > eps) - p1=1.d0 - p2=0.d0 - do j=1,n - p3=p2 - p2=p1 - p1=(dble(j+j-1)*z*p2-dble(j-1)*p3)/j - enddo - pp=dn*(z*p1-p2)/(z*z-1.d0) - z1=z - z=z1-p1/pp - end do - x(i)=xm-xl*z - x(n+1-i)=xm+xl*z - w(i)=(xl+xl)/((1.d0-z*z)*pp*pp) - w(n+1-i)=w(i) - enddo -end - diff --git a/src/ao_two_e_ints/map_integrals.irp.f b/src/ao_two_e_ints/map_integrals.irp.f index c3b206e1..55b2d5e2 100644 --- a/src/ao_two_e_ints/map_integrals.irp.f +++ b/src/ao_two_e_ints/map_integrals.irp.f @@ -327,8 +327,6 @@ double precision function get_ao_two_e_integral(i,j,k,l,map) result(result) implicit none BEGIN_DOC ! Gets one AO bi-electronic integral from the AO map - ! - ! i,j,k,l in physicist notation END_DOC integer, intent(in) :: i,j,k,l integer(key_kind) :: idx diff --git a/src/ao_two_e_ints/test_cosgtos_1e.irp.f b/src/ao_two_e_ints/test_cosgtos_1e.irp.f new file mode 100644 index 00000000..9c1a7215 --- /dev/null +++ b/src/ao_two_e_ints/test_cosgtos_1e.irp.f @@ -0,0 +1,191 @@ + +! --- + +program test_cosgtos + + implicit none + integer :: i, j + + call init_expo() + +! call test_coef() + call test_1e_kin() + call test_1e_coul() + + i = 1 + j = 1 +! call test_1e_coul_real(i, j) +! call test_1e_coul_cpx (i, j) + +end + +! --- + +subroutine init_expo() + + implicit none + + integer :: i, j + double precision, allocatable :: expo_im(:,:) + + allocate(expo_im(ao_num, ao_prim_num_max)) + + do j = 1, ao_prim_num_max + do i = 1, ao_num + ao_expoim_cosgtos(i,j) = 0.d0 + enddo + enddo + + call ezfio_set_cosgtos_ao_int_ao_expoim_cosgtos(expo_im) + + deallocate(expo_im) + +end subroutine init_expo + +! --- + +subroutine test_coef() + + implicit none + + integer :: i, j + double precision :: coef, coef_gtos, coef_cosgtos + double precision :: delta, accu_abs + + print*, ' check coefs' + + accu_abs = 0.d0 + accu_abs = 0.d0 + do i = 1, ao_num + do j = 1, ao_prim_num(i) + + coef = ao_coef(i,j) + coef_gtos = 1.d0 * ao_coef_normalized_ordered_transp(j,i) + coef_cosgtos = 2.d0 * ao_coef_norm_ord_transp_cosgtos (j,i) + + delta = dabs(coef_gtos - coef_cosgtos) + accu_abs += delta + + if(delta .gt. 1.d-10) then + print*, ' problem on: ' + print*, i, j + print*, coef_gtos, coef_cosgtos, delta + print*, coef + stop + endif + + enddo + enddo + + print*, 'accu_abs = ', accu_abs + +end subroutine test_coef + +! --- + +subroutine test_1e_kin() + + implicit none + + integer :: i, j + double precision :: integral_gtos, integral_cosgtos + double precision :: delta, accu_abs + + print*, ' check kin 1e integrals' + + accu_abs = 0.d0 + accu_abs = 0.d0 + + do j = 1, ao_num + do i = 1, ao_num + + integral_gtos = ao_kinetic_integrals (i,j) + integral_cosgtos = ao_kinetic_integrals_cosgtos(i,j) + + + delta = dabs(integral_gtos - integral_cosgtos) + accu_abs += delta + + if(delta .gt. 1.d-7) then + print*, ' problem on: ' + print*, i, j + print*, integral_gtos, integral_cosgtos, delta + !stop + endif + + enddo + enddo + + print*,'accu_abs = ', accu_abs + +end subroutine test_1e_kin + +! --- + +subroutine test_1e_coul() + + implicit none + + integer :: i, j + double precision :: integral_gtos, integral_cosgtos + double precision :: delta, accu_abs + + print*, ' check Coulomb 1e integrals' + + accu_abs = 0.d0 + accu_abs = 0.d0 + + do j = 1, ao_num + do i = 1, ao_num + + integral_gtos = ao_integrals_n_e (i,j) + integral_cosgtos = ao_integrals_n_e_cosgtos(i,j) + + delta = dabs(integral_gtos - integral_cosgtos) + accu_abs += delta + + if(delta .gt. 1.d-7) then + print*, ' problem on: ' + print*, i, j + print*, integral_gtos, integral_cosgtos, delta + !stop + endif + + enddo + enddo + + print*,'accu_abs = ', accu_abs + +end subroutine test_1e_coul + +! --- + +subroutine test_1e_coul_cpx(i, j) + + implicit none + + integer, intent(in) :: i, j + double precision :: integral + + integral = ao_integrals_n_e_cosgtos(i,j) + + print*, ' cpx Coulomb 1e integrals', integral + +end subroutine test_1e_coul_cpx + +! --- + +subroutine test_1e_coul_real(i, j) + + implicit none + + integer, intent(in) :: i, j + double precision :: integral + + integral = ao_integrals_n_e(i,j) + + print*, ' real Coulomb 1e integrals', integral + +end subroutine test_1e_coul_real + +! --- diff --git a/src/ao_two_e_ints/test_cosgtos_2e.irp.f b/src/ao_two_e_ints/test_cosgtos_2e.irp.f new file mode 100644 index 00000000..de991dd1 --- /dev/null +++ b/src/ao_two_e_ints/test_cosgtos_2e.irp.f @@ -0,0 +1,165 @@ + +! --- + +program test_cosgtos + + implicit none + integer :: iao, jao, kao, lao + + call init_expo() + +! call test_coef() + call test_2e() + + iao = 1 + jao = 1 + kao = 1 + lao = 21 +! call test_2e_cpx (iao, jao, kao, lao) +! call test_2e_real(iao, jao, kao, lao) + +end + +! --- + +subroutine init_expo() + + implicit none + + integer :: i, j + double precision, allocatable :: expo_im(:,:) + + allocate(expo_im(ao_num, ao_prim_num_max)) + + do j = 1, ao_prim_num_max + do i = 1, ao_num + ao_expoim_cosgtos(i,j) = 0.d0 + enddo + enddo + + call ezfio_set_cosgtos_ao_int_ao_expoim_cosgtos(expo_im) + + deallocate(expo_im) + +end subroutine init_expo + +! --- + +subroutine test_coef() + + implicit none + + integer :: i, j + double precision :: coef, coef_gtos, coef_cosgtos + double precision :: delta, accu_abs + + print*, ' check coefs' + + accu_abs = 0.d0 + accu_abs = 0.d0 + do i = 1, ao_num + do j = 1, ao_prim_num(i) + + coef = ao_coef(i,j) + coef_gtos = 1.d0 * ao_coef_normalized_ordered_transp(j,i) + coef_cosgtos = 2.d0 * ao_coef_norm_ord_transp_cosgtos (j,i) + + delta = dabs(coef_gtos - coef_cosgtos) + accu_abs += delta + + if(delta .gt. 1.d-10) then + print*, ' problem on: ' + print*, i, j + print*, coef_gtos, coef_cosgtos, delta + print*, coef + stop + endif + + enddo + enddo + + print*, 'accu_abs = ', accu_abs + +end subroutine test_coef + + +! --- + +subroutine test_2e() + + implicit none + + integer :: iao, jao, kao, lao + double precision :: integral_gtos, integral_cosgtos + double precision :: delta, accu_abs + + double precision :: ao_two_e_integral, ao_two_e_integral_cosgtos + + print*, ' check integrals' + + accu_abs = 0.d0 + accu_abs = 0.d0 + + ! iao = 1 + ! jao = 1 + ! kao = 1 + ! lao = 24 + + do iao = 1, ao_num ! r1 + do jao = 1, ao_num ! r2 + do kao = 1, ao_num ! r1 + do lao = 1, ao_num ! r2 + + integral_gtos = ao_two_e_integral (iao, kao, jao, lao) + integral_cosgtos = ao_two_e_integral_cosgtos(iao, kao, jao, lao) + + delta = dabs(integral_gtos - integral_cosgtos) + accu_abs += delta + + if(delta .gt. 1.d-7) then + print*, ' problem on: ' + print*, iao, jao, kao, lao + print*, integral_gtos, integral_cosgtos, delta + !stop + endif + + enddo + enddo + enddo + enddo + + print*,'accu_abs = ', accu_abs + +end subroutine test_2e + +! --- + +subroutine test_2e_cpx(iao, jao, kao, lao) + + implicit none + integer, intent(in) :: iao, jao, kao, lao + double precision :: integral + double precision :: ao_two_e_integral_cosgtos + + integral = ao_two_e_integral_cosgtos(iao, kao, jao, lao) + print *, ' cosgtos: ', integral + +end subroutine test_2e_cpx + +! --- + +subroutine test_2e_real(iao, jao, kao, lao) + + implicit none + integer, intent(in) :: iao, jao, kao, lao + double precision :: integral + double precision :: ao_two_e_integral + + integral = ao_two_e_integral(iao, kao, jao, lao) + print *, ' gtos: ', integral + +end subroutine test_2e_real + +! --- + + diff --git a/src/ao_two_e_ints/two_e_integrals.irp.f b/src/ao_two_e_ints/two_e_integrals.irp.f index 8032bd92..e60e6eeb 100644 --- a/src/ao_two_e_ints/two_e_integrals.irp.f +++ b/src/ao_two_e_ints/two_e_integrals.irp.f @@ -1,108 +1,132 @@ + +! --- + double precision function ao_two_e_integral(i,j,k,l) - implicit none + BEGIN_DOC ! integral of the AO basis 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 endif + end +! --- + double precision function ao_two_e_integral_schwartz_accel(i,j,k,l) implicit none BEGIN_DOC @@ -575,7 +599,10 @@ double precision function general_primitive_integral(dim, & !DIR$ FORCEINLINE call multiply_poly(d_poly ,n_pt_tmp ,Iz_pol,n_Iz,d1,n_pt_out) double precision :: rint_sum + accu = accu + rint_sum(n_pt_out,const,d1) +! print *, n_pt_out, d1(0:n_pt_out) +! print *, accu general_primitive_integral = fact_p * fact_q * accu *pi_5_2*p_inv*q_inv/dsqrt(p+q) end @@ -840,6 +867,15 @@ subroutine give_polynom_mult_center_x(P_center,Q_center,a_x,d_x,p,q,n_pt_in,pq_i !DIR$ FORCEINLINE call I_x1_pol_mult(a_x,d_x,B10,B01,B00,C00,D00,d,n_pt1,n_pt_in) n_pt_out = n_pt1 + +! print *, ' ' +! print *, a_x, d_x +! print *, B10, B01, B00, C00, D00 +! print *, n_pt1, d(0:n_pt1) +! print *, ' ' + + + if(n_pt1<0)then n_pt_out = -1 do i = 0,n_pt_in diff --git a/src/basis/EZFIO.cfg b/src/basis/EZFIO.cfg index a6864418..7f2ede4c 100644 --- a/src/basis/EZFIO.cfg +++ b/src/basis/EZFIO.cfg @@ -37,16 +37,16 @@ doc: Number of primitives in a shell size: (basis.shell_num) interface: ezfio, provider -[shell_index] +[shell_prim_index] type: integer -doc: Index of the shell for each primitive -size: (basis.prim_num) +doc: Max number of primitives in a shell +size: (basis.shell_num) interface: ezfio, provider [basis_nucleus_index] type: integer -doc: Nucleus on which the shell is centered -size: (basis.shell_num) +doc: Index of the nucleus on which the shell is centered +size: (nuclei.nucl_num) interface: ezfio, provider [prim_normalization_factor] diff --git a/src/basis/basis.irp.f b/src/basis/basis.irp.f index b750d75a..6a406e28 100644 --- a/src/basis/basis.irp.f +++ b/src/basis/basis.irp.f @@ -30,10 +30,8 @@ BEGIN_PROVIDER [ double precision, shell_normalization_factor , (shell_num) ] powA(3) = 0 norm = 0.d0 - do k=1, prim_num - if (shell_index(k) /= i) cycle - do j=1, prim_num - if (shell_index(j) /= i) cycle + do k=shell_prim_index(i),shell_prim_index(i)+shell_prim_num(i)-1 + do j=shell_prim_index(i),shell_prim_index(i)+shell_prim_num(i)-1 call overlap_gaussian_xyz(C_A,C_A,prim_expo(j),prim_expo(k), & powA,powA,overlap_x,overlap_y,overlap_z,c,nz) norm = norm+c*prim_coef(j)*prim_coef(k) * prim_normalization_factor(j) * prim_normalization_factor(k) @@ -93,8 +91,7 @@ BEGIN_PROVIDER [ double precision, prim_normalization_factor , (prim_num) ] powA(2) = 0 powA(3) = 0 - do k=1, prim_num - if (shell_index(k) /= i) cycle + do k=shell_prim_index(i),shell_prim_index(i)+shell_prim_num(i)-1 call overlap_gaussian_xyz(C_A,C_A,prim_expo(k),prim_expo(k), & powA,powA,overlap_x,overlap_y,overlap_z,norm,nz) prim_normalization_factor(k) = 1.d0/dsqrt(norm) diff --git a/src/basis_correction/print_routine.irp.f b/src/basis_correction/print_routine.irp.f index 67c5c6c2..05fbbf60 100644 --- a/src/basis_correction/print_routine.irp.f +++ b/src/basis_correction/print_routine.irp.f @@ -38,7 +38,7 @@ subroutine print_basis_correction write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD PBE-UEG , state ',istate,' = ',ecmd_pbe_ueg_mu_of_r(istate) enddo - else if(mu_of_r_potential.EQ."cas_ful".or.mu_of_r_potential.EQ."cas_truncated".or.mu_of_r_potential.EQ."pure_act")then + else if(mu_of_r_potential.EQ."cas_ful")then print*, '' print*,'Using a CAS-like two-body density to define mu(r)' print*,'This assumes that the CAS is a qualitative representation of the wave function ' diff --git a/src/becke_numerical_grid/grid_becke_vector.irp.f b/src/becke_numerical_grid/grid_becke_vector.irp.f index 343bd054..a72200f7 100644 --- a/src/becke_numerical_grid/grid_becke_vector.irp.f +++ b/src/becke_numerical_grid/grid_becke_vector.irp.f @@ -58,17 +58,3 @@ END_PROVIDER enddo END_PROVIDER - -BEGIN_PROVIDER [double precision, final_grid_points_transp, (n_points_final_grid,3)] - implicit none - BEGIN_DOC -! Transposed final_grid_points - END_DOC - - integer :: i,j - do j=1,3 - do i=1,n_points_final_grid - final_grid_points_transp(i,j) = final_grid_points(j,i) - enddo - enddo -END_PROVIDER diff --git a/src/bitmask/bitmasks_routines.irp.f b/src/bitmask/bitmasks_routines.irp.f index 9c6f4f0c..c34d54dc 100644 --- a/src/bitmask/bitmasks_routines.irp.f +++ b/src/bitmask/bitmasks_routines.irp.f @@ -268,21 +268,6 @@ subroutine print_spindet(string,Nint) end -subroutine print_det_one_dimension(string,Nint) - use bitmasks - implicit none - BEGIN_DOC - ! Subroutine to print the content of a determinant using the '+-' notation - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: string(Nint) - character*(2048) :: output(1) - - call bitstring_to_str( output(1), string, Nint ) - print *, trim(output(1)) - -end - logical function is_integer_in_string(bite,string,Nint) use bitmasks implicit none diff --git a/src/cipsi/EZFIO.cfg b/src/cipsi/EZFIO.cfg index e01359c5..19b45ac1 100644 --- a/src/cipsi/EZFIO.cfg +++ b/src/cipsi/EZFIO.cfg @@ -1,3 +1,9 @@ +[pert_2rdm] +type: logical +doc: If true, computes the one- and two-body rdms with perturbation theory +interface: ezfio,provider,ocaml +default: False + [save_wf_after_selection] type: logical doc: If true, saves the wave function after the selection, before the diagonalization @@ -34,9 +40,3 @@ doc: Maximum number of excitation for beta determinants with respect to the Hart interface: ezfio,ocaml,provider default: -1 -[twice_hierarchy_max] -type: integer -doc: Twice the maximum hierarchy parameter (excitation degree plus half the seniority number). Using -1 selects all determinants -interface: ezfio,ocaml,provider -default: -1 - diff --git a/src/cipsi/NEED b/src/cipsi/NEED index 85d01f79..bfbc559a 100644 --- a/src/cipsi/NEED +++ b/src/cipsi/NEED @@ -2,4 +2,5 @@ perturbation zmq mpi iterations +two_body_rdm csf diff --git a/src/cipsi/cipsi.irp.f b/src/cipsi/cipsi.irp.f index da77a527..6e715531 100644 --- a/src/cipsi/cipsi.irp.f +++ b/src/cipsi/cipsi.irp.f @@ -70,8 +70,8 @@ subroutine run_cipsi do while ( & (N_det < N_det_max) .and. & - (sum(abs(pt2_data % pt2(1:N_states)) * state_average_weight(1:N_states)) > pt2_max) .and. & - (sum(abs(pt2_data % variance(1:N_states)) * state_average_weight(1:N_states)) > variance_max) .and. & + (maxval(abs(pt2_data % pt2(1:N_states))) > pt2_max) .and. & + (maxval(abs(pt2_data % variance(1:N_states))) > variance_max) .and. & (correlation_energy_ratio <= correlation_energy_ratio_max) & ) write(*,'(A)') '--------------------------------------------------------------------------------' diff --git a/src/cipsi/pert_rdm_providers.irp.f b/src/cipsi/pert_rdm_providers.irp.f new file mode 100644 index 00000000..eca8decc --- /dev/null +++ b/src/cipsi/pert_rdm_providers.irp.f @@ -0,0 +1,183 @@ + +use bitmasks +use omp_lib + +BEGIN_PROVIDER [ integer(omp_lock_kind), pert_2rdm_lock] + use f77_zmq + implicit none + call omp_init_lock(pert_2rdm_lock) +END_PROVIDER + +BEGIN_PROVIDER [integer, n_orb_pert_rdm] + implicit none + n_orb_pert_rdm = n_act_orb +END_PROVIDER + +BEGIN_PROVIDER [integer, list_orb_reverse_pert_rdm, (mo_num)] + implicit none + list_orb_reverse_pert_rdm = list_act_reverse + +END_PROVIDER + +BEGIN_PROVIDER [integer, list_orb_pert_rdm, (n_orb_pert_rdm)] + implicit none + list_orb_pert_rdm = list_act + +END_PROVIDER + +BEGIN_PROVIDER [double precision, pert_2rdm_provider, (n_orb_pert_rdm,n_orb_pert_rdm,n_orb_pert_rdm,n_orb_pert_rdm)] + implicit none + pert_2rdm_provider = 0.d0 + +END_PROVIDER + +subroutine fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf, psi_det_connection, psi_coef_connection_reverse, n_det_connection) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: n_det_connection + double precision, intent(in) :: psi_coef_connection_reverse(N_states,n_det_connection) + integer(bit_kind), intent(in) :: psi_det_connection(N_int,2,n_det_connection) + integer, intent(in) :: i_generator, sp, h1, h2 + double precision, intent(in) :: mat(N_states, mo_num, mo_num) + logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num) + double precision, intent(in) :: fock_diag_tmp(mo_num) + double precision, intent(in) :: E0(N_states) + type(pt2_type), intent(inout) :: pt2_data + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, j, istate, jstate + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii, sum_e_pert, tmp, alpha_h_psi, coef(N_states) + double precision, external :: diag_H_mat_elem_fock + double precision :: E_shift + + logical, external :: detEq + double precision, allocatable :: values(:) + integer, allocatable :: keys(:,:) + integer :: nkeys + integer :: sze_buff + sze_buff = 5 * mo_num ** 2 + allocate(keys(4,sze_buff),values(sze_buff)) + nkeys = 0 + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) + E_shift = 0.d0 + + if (h0_type == 'CFG') then + j = det_to_configuration(i_generator) + E_shift = psi_det_Hii(i_generator) - psi_configuration_Hii(j) + endif + + do p1=1,mo_num + if(bannedOrb(p1, s1)) cycle + ib = 1 + if(sp /= 3) ib = p1+1 + + do p2=ib,mo_num + +! ----- +! /!\ Generating only single excited determinants doesn't work because a +! determinant generated by a single excitation may be doubly excited wrt +! to a determinant of the future. In that case, the determinant will be +! detected as already generated when generating in the future with a +! double excitation. +! +! if (.not.do_singles) then +! if ((h1 == p1) .or. (h2 == p2)) then +! cycle +! endif +! endif +! +! if (.not.do_doubles) then +! if ((h1 /= p1).and.(h2 /= p2)) then +! cycle +! endif +! endif +! ----- + + if(bannedOrb(p2, s2)) cycle + if(banned(p1,p2)) cycle + + + if( sum(abs(mat(1:N_states, p1, p2))) == 0d0) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + + if (do_only_cas) then + integer, external :: number_of_holes, number_of_particles + if (number_of_particles(det)>0) then + cycle + endif + if (number_of_holes(det)>0) then + cycle + endif + endif + + if (do_ddci) then + logical, external :: is_a_two_holes_two_particles + if (is_a_two_holes_two_particles(det)) then + cycle + endif + endif + + if (do_only_1h1p) then + logical, external :: is_a_1h1p + if (.not.is_a_1h1p(det)) cycle + endif + + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + + sum_e_pert = 0d0 + integer :: degree + call get_excitation_degree(det,HF_bitmask,degree,N_int) + if(degree == 2)cycle + do istate=1,N_states + delta_E = E0(istate) - Hii + E_shift + alpha_h_psi = mat(istate, p1, p2) + val = alpha_h_psi + alpha_h_psi + tmp = dsqrt(delta_E * delta_E + val * val) + if (delta_E < 0.d0) then + tmp = -tmp + endif + e_pert = 0.5d0 * (tmp - delta_E) + coef(istate) = e_pert / alpha_h_psi + print*,e_pert,coef,alpha_h_psi + pt2_data % pt2(istate) += e_pert + pt2_data % variance(istate) += alpha_h_psi * alpha_h_psi + enddo + + do istate=1,N_states + alpha_h_psi = mat(istate, p1, p2) + e_pert = coef(istate) * alpha_h_psi + do jstate=1,N_states + pt2_data % overlap(jstate,jstate) = coef(istate) * coef(jstate) + enddo + + if (weight_selection /= 5) then + ! Energy selection + sum_e_pert = sum_e_pert + e_pert * selection_weight(istate) + + else + ! Variance selection + sum_e_pert = sum_e_pert - alpha_h_psi * alpha_h_psi * selection_weight(istate) + endif + end do + call give_2rdm_pert_contrib(det,coef,psi_det_connection,psi_coef_connection_reverse,n_det_connection,nkeys,keys,values,sze_buff) + + if(sum_e_pert <= buf%mini) then + call add_to_selection_buffer(buf, det, sum_e_pert) + end if + end do + end do + call update_keys_values(keys,values,nkeys,n_orb_pert_rdm,pert_2rdm_provider,pert_2rdm_lock) +end + + diff --git a/src/cipsi/pt2_stoch_routines.irp.f b/src/cipsi/pt2_stoch_routines.irp.f index 1328e7a0..b366a268 100644 --- a/src/cipsi/pt2_stoch_routines.irp.f +++ b/src/cipsi/pt2_stoch_routines.irp.f @@ -117,6 +117,7 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in) integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull integer, intent(in) :: N_in +! integer, intent(inout) :: N_in double precision, intent(in) :: relative_error, E(N_states) type(pt2_type), intent(inout) :: pt2_data, pt2_data_err ! @@ -131,8 +132,8 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in) PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp psi_det_sorted PROVIDE psi_det_hii selection_weight pseudo_sym - PROVIDE list_act list_inact list_core list_virt list_del seniority_max - PROVIDE excitation_beta_max excitation_alpha_max excitation_max + PROVIDE n_act_orb n_inact_orb n_core_orb n_virt_orb n_del_orb seniority_max + PROVIDE pert_2rdm excitation_beta_max excitation_alpha_max excitation_max if (h0_type == 'CFG') then PROVIDE psi_configuration_hii det_to_configuration @@ -287,16 +288,12 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in) call write_int(6,nproc_target,'Number of threads for PT2') call write_double(6,mem,'Memory (Gb)') - call set_multiple_levels_omp(.False.) + call omp_set_max_active_levels(1) - ! old - !print '(A)', '========== ======================= ===================== ===================== ===========' - !print '(A)', ' Samples Energy Variance Norm^2 Seconds' - !print '(A)', '========== ======================= ===================== ===================== ===========' - print '(A)', '========== ==================== ================ ================ ================ ============= ===========' - print '(A)', ' Samples Energy PT2 Variance Norm^2 Convergence Seconds' - print '(A)', '========== ==================== ================ ================ ================ ============= ===========' + print '(A)', '========== ======================= ===================== ===================== ===========' + print '(A)', ' Samples Energy Variance Norm^2 Seconds' + print '(A)', '========== ======================= ===================== ===================== ===========' PROVIDE global_selection_buffer @@ -318,17 +315,14 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in) endif !$OMP END PARALLEL call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2') - call set_multiple_levels_omp(.True.) + call omp_set_max_active_levels(8) - ! old - !print '(A)', '========== ======================= ===================== ===================== ===========' - print '(A)', '========== ==================== ================ ================ ================ ============= ===========' + print '(A)', '========== ======================= ===================== ===================== ===========' - - do k=1,N_states - pt2_overlap(pt2_stoch_istate,k) = pt2_data % overlap(k,pt2_stoch_istate) - enddo - SOFT_TOUCH pt2_overlap + do k=1,N_states + pt2_overlap(pt2_stoch_istate,k) = pt2_data % overlap(k,pt2_stoch_istate) + enddo + SOFT_TOUCH pt2_overlap enddo FREE pt2_stoch_istate @@ -421,17 +415,6 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_ double precision :: rss double precision, external :: memory_of_double, memory_of_int - character(len=20) :: format_str1, str_error1, format_str2, str_error2 - character(len=20) :: format_str3, str_error3, format_str4, str_error4 - character(len=20) :: format_value1, format_value2, format_value3, format_value4 - character(len=20) :: str_value1, str_value2, str_value3, str_value4 - character(len=20) :: str_conv - double precision :: value1, value2, value3, value4 - double precision :: error1, error2, error3, error4 - integer :: size1,size2,size3,size4 - - double precision :: conv_crit - sending =.False. rss = memory_of_int(pt2_n_tasks_max*2+N_det_generators*2) @@ -541,74 +524,28 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_ ! 1/(N-1.5) : see Brugger, The American Statistician (23) 4 p. 32 (1969) if(c > 2) then eqt = dabs((pt2_data_S2(t) % pt2(pt2_stoch_istate) / c) - (pt2_data_S(t) % pt2(pt2_stoch_istate)/c)**2) ! dabs for numerical stability - eqt = dsqrt(eqt / (dble(c) - 1.5d0)) + eqt = sqrt(eqt / (dble(c) - 1.5d0)) pt2_data_err % pt2(pt2_stoch_istate) = eqt eqt = dabs((pt2_data_S2(t) % variance(pt2_stoch_istate) / c) - (pt2_data_S(t) % variance(pt2_stoch_istate)/c)**2) ! dabs for numerical stability - eqt = dsqrt(eqt / (dble(c) - 1.5d0)) + eqt = sqrt(eqt / (dble(c) - 1.5d0)) pt2_data_err % variance(pt2_stoch_istate) = eqt eqta(:) = dabs((pt2_data_S2(t) % overlap(:,pt2_stoch_istate) / c) - (pt2_data_S(t) % overlap(:,pt2_stoch_istate)/c)**2) ! dabs for numerical stability - eqta(:) = dsqrt(eqta(:) / (dble(c) - 1.5d0)) + eqta(:) = sqrt(eqta(:) / (dble(c) - 1.5d0)) pt2_data_err % overlap(:,pt2_stoch_istate) = eqta(:) if ((time - time1 > 1.d0) .or. (n==N_det_generators)) then time1 = time - - value1 = pt2_data % pt2(pt2_stoch_istate) + E - error1 = pt2_data_err % pt2(pt2_stoch_istate) - value2 = pt2_data % pt2(pt2_stoch_istate) - error2 = pt2_data_err % pt2(pt2_stoch_istate) - value3 = pt2_data % variance(pt2_stoch_istate) - error3 = pt2_data_err % variance(pt2_stoch_istate) - value4 = pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate) - error4 = pt2_data_err % overlap(pt2_stoch_istate,pt2_stoch_istate) - - ! Max size of the values (FX.Y) with X=size - size1 = 15 - size2 = 12 - size3 = 12 - size4 = 12 - - ! To generate the format: number(error) - call format_w_error(value1,error1,size1,8,format_value1,str_error1) - call format_w_error(value2,error2,size2,8,format_value2,str_error2) - call format_w_error(value3,error3,size3,8,format_value3,str_error3) - call format_w_error(value4,error4,size4,8,format_value4,str_error4) - - ! value > string with the right format - write(str_value1,'('//format_value1//')') value1 - write(str_value2,'('//format_value2//')') value2 - write(str_value3,'('//format_value3//')') value3 - write(str_value4,'('//format_value4//')') value4 - - ! Convergence criterion - conv_crit = dabs(pt2_data_err % pt2(pt2_stoch_istate)) / & - (1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) ) - write(str_conv,'(G10.3)') conv_crit - - write(*,'(I10,X,X,A20,X,A16,X,A16,X,A16,X,A12,X,F10.1)') c,& - adjustl(adjustr(str_value1)//'('//str_error1(1:1)//')'),& - adjustl(adjustr(str_value2)//'('//str_error2(1:1)//')'),& - adjustl(adjustr(str_value3)//'('//str_error3(1:1)//')'),& - adjustl(adjustr(str_value4)//'('//str_error4(1:1)//')'),& - adjustl(str_conv),& - time-time0 - - ! Old print - !print '(I10, X, F12.6, X, G10.3, X, F10.6, X, G10.3, X, F10.6, X, G10.3, X, F10.1,1pE16.6,1pE16.6)', c, & - ! pt2_data % pt2(pt2_stoch_istate) +E, & - ! pt2_data_err % pt2(pt2_stoch_istate), & - ! pt2_data % variance(pt2_stoch_istate), & - ! pt2_data_err % variance(pt2_stoch_istate), & - ! pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate), & - ! pt2_data_err % overlap(pt2_stoch_istate,pt2_stoch_istate), & - ! time-time0, & - ! pt2_data % pt2(pt2_stoch_istate), & - ! dabs(pt2_data_err % pt2(pt2_stoch_istate)) / & - ! (1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) ) - + print '(I10, X, F12.6, X, G10.3, X, F10.6, X, G10.3, X, F10.6, X, G10.3, X, F10.4)', c, & + pt2_data % pt2(pt2_stoch_istate) +E, & + pt2_data_err % pt2(pt2_stoch_istate), & + pt2_data % variance(pt2_stoch_istate), & + pt2_data_err % variance(pt2_stoch_istate), & + pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate), & + pt2_data_err % overlap(pt2_stoch_istate,pt2_stoch_istate), & + time-time0 if (stop_now .or. ( & (do_exit .and. (dabs(pt2_data_err % pt2(pt2_stoch_istate)) / & (1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) ) <= relative_error))) ) then @@ -639,11 +576,11 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_ endif do i=1,n_tasks if(index(i).gt.size(pt2_data_I,1).or.index(i).lt.1)then - print*,'PB !!!' - print*,'If you see this, send a bug report with the following content' - print*,irp_here - print*,'i,index(i),size(pt2_data_I,1) = ',i,index(i),size(pt2_data_I,1) - stop -1 + print*,'PB !!!' + print*,'If you see this, send a bug report with the following content' + print*,irp_here + print*,'i,index(i),size(pt2_data_I,1) = ',i,index(i),size(pt2_data_I,1) + stop -1 endif call pt2_add(pt2_data_I(index(i)),1.d0,pt2_data_task(i)) f(index(i)) -= 1 @@ -906,8 +843,9 @@ END_PROVIDER do t=1, pt2_N_teeth tooth_width = tilde_cW(pt2_n_0(t+1)) - tilde_cW(pt2_n_0(t)) if (tooth_width == 0.d0) then - tooth_width = max(1.d-15,sum(tilde_w(pt2_n_0(t):pt2_n_0(t+1)))) + tooth_width = sum(tilde_w(pt2_n_0(t):pt2_n_0(t+1))) endif + ASSERT(tooth_width > 0.d0) do i=pt2_n_0(t)+1, pt2_n_0(t+1) pt2_w(i) = tilde_w(i) * pt2_W_T / tooth_width end do diff --git a/src/cipsi/run_pt2_slave.irp.f b/src/cipsi/run_pt2_slave.irp.f index 30fc7ce0..a72d3dbb 100644 --- a/src/cipsi/run_pt2_slave.irp.f +++ b/src/cipsi/run_pt2_slave.irp.f @@ -31,11 +31,12 @@ subroutine run_pt2_slave(thread,iproc,energy) double precision, intent(in) :: energy(N_states_diag) integer, intent(in) :: thread, iproc - if (N_det > 100000 ) then - call run_pt2_slave_large(thread,iproc,energy) - else - call run_pt2_slave_small(thread,iproc,energy) - endif + call run_pt2_slave_large(thread,iproc,energy) +! if (N_det > nproc*(elec_alpha_num * (mo_num-elec_alpha_num))**2) then +! call run_pt2_slave_large(thread,iproc,energy) +! else +! call run_pt2_slave_small(thread,iproc,energy) +! endif end subroutine run_pt2_slave_small(thread,iproc,energy) @@ -66,6 +67,7 @@ subroutine run_pt2_slave_small(thread,iproc,energy) double precision, external :: memory_of_double, memory_of_int integer :: bsize ! Size of selection buffers +! logical :: sending allocate(task_id(pt2_n_tasks_max), task(pt2_n_tasks_max)) allocate(pt2_data(pt2_n_tasks_max), i_generator(pt2_n_tasks_max), subset(pt2_n_tasks_max)) @@ -83,6 +85,7 @@ subroutine run_pt2_slave_small(thread,iproc,energy) buffer_ready = .False. n_tasks = 1 +! sending = .False. done = .False. do while (.not.done) @@ -116,13 +119,14 @@ subroutine run_pt2_slave_small(thread,iproc,energy) do k=1,n_tasks call pt2_alloc(pt2_data(k),N_states) b%cur = 0 -! double precision :: time2 -! call wall_time(time2) +!double precision :: time2 +!call wall_time(time2) call select_connected(i_generator(k),energy,pt2_data(k),b,subset(k),pt2_F(i_generator(k))) -! call wall_time(time1) -! print *, i_generator(1), time1-time2, n_tasks, pt2_F(i_generator(1)) +!call wall_time(time1) +!print *, i_generator(1), time1-time2, n_tasks, pt2_F(i_generator(1)) enddo call wall_time(time1) +!print *, '-->', i_generator(1), time1-time0, n_tasks integer, external :: tasks_done_to_taskserver if (tasks_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_tasks) == -1) then @@ -160,11 +164,6 @@ end subroutine subroutine run_pt2_slave_large(thread,iproc,energy) use selection_types use f77_zmq - BEGIN_DOC -! This subroutine can miss important determinants when the PT2 is completely -! computed. It should be called only for large workloads where the PT2 is -! interrupted before the end - END_DOC implicit none double precision, intent(in) :: energy(N_states_diag) @@ -190,12 +189,8 @@ subroutine run_pt2_slave_large(thread,iproc,energy) integer :: bsize ! Size of selection buffers logical :: sending - double precision :: time_shift - PROVIDE global_selection_buffer global_selection_buffer_lock - call random_number(time_shift) - time_shift = time_shift*15.d0 zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() @@ -213,9 +208,6 @@ subroutine run_pt2_slave_large(thread,iproc,energy) sending = .False. done = .False. - double precision :: time0, time1 - call wall_time(time0) - time0 = time0+time_shift do while (.not.done) integer, external :: get_tasks_from_taskserver @@ -242,28 +234,25 @@ subroutine run_pt2_slave_large(thread,iproc,energy) ASSERT (b%N == bsize) endif + double precision :: time0, time1 + call wall_time(time0) call pt2_alloc(pt2_data,N_states) b%cur = 0 call select_connected(i_generator,energy,pt2_data,b,subset,pt2_F(i_generator)) + call wall_time(time1) integer, external :: tasks_done_to_taskserver if (tasks_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_tasks) == -1) then done = .true. endif call sort_selection_buffer(b) - - call wall_time(time1) -! if (time1-time0 > 15.d0) then - call omp_set_lock(global_selection_buffer_lock) - global_selection_buffer%mini = b%mini - call merge_selection_buffers(b,global_selection_buffer) - b%cur=0 - call omp_unset_lock(global_selection_buffer_lock) - call wall_time(time0) -! endif - call push_pt2_results_async_recv(zmq_socket_push,b%mini,sending) - if ( iproc == 1 .or. i_generator < 100 .or. done) then + call omp_set_lock(global_selection_buffer_lock) + global_selection_buffer%mini = b%mini + call merge_selection_buffers(b,global_selection_buffer) + b%cur=0 + call omp_unset_lock(global_selection_buffer_lock) + if ( iproc == 1 ) then call omp_set_lock(global_selection_buffer_lock) call push_pt2_results_async_send(zmq_socket_push, (/i_generator/), (/pt2_data/), global_selection_buffer, (/task_id/), 1,sending) global_selection_buffer%cur = 0 diff --git a/src/cipsi/run_selection_slave.irp.f b/src/cipsi/run_selection_slave.irp.f index de7c209c..91bd3a38 100644 --- a/src/cipsi/run_selection_slave.irp.f +++ b/src/cipsi/run_selection_slave.irp.f @@ -61,14 +61,10 @@ subroutine run_selection_slave(thread,iproc,energy) if (N /= buf%N) then print *, 'N=', N print *, 'buf%N=', buf%N - print *, 'In ', irp_here, ': N /= buf%N' - stop -1 + print *, 'bug in ', irp_here + stop '-1' end if end if - if (i_generator > N_det_generators) then - print *, 'In ', irp_here, ': i_generator > N_det_generators' - stop -1 - endif call select_connected(i_generator,energy,pt2_data,buf,subset,pt2_F(i_generator)) endif diff --git a/src/cipsi/selection.irp.f b/src/cipsi/selection.irp.f index ec60c606..eda9642c 100644 --- a/src/cipsi/selection.irp.f +++ b/src/cipsi/selection.irp.f @@ -195,10 +195,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d integer :: l_a, nmax, idx integer, allocatable :: indices(:), exc_degree(:), iorder(:) - - ! Removed to avoid introducing determinants already presents in the wf - !double precision, parameter :: norm_thr = 1.d-16 - + double precision, parameter :: norm_thr = 1.d-16 allocate (indices(N_det), & exc_degree(max(N_det_alpha_unique,N_det_beta_unique))) @@ -218,11 +215,10 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d i = psi_bilinear_matrix_rows(l_a) if (nt + exc_degree(i) <= 4) then idx = psi_det_sorted_order(psi_bilinear_matrix_order(l_a)) - ! Removed to avoid introducing determinants already presents in the wf - !if (psi_average_norm_contrib_sorted(idx) > norm_thr) then + if (psi_average_norm_contrib_sorted(idx) > norm_thr) then indices(k) = idx k=k+1 - !endif + endif endif enddo enddo @@ -246,11 +242,10 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d idx = psi_det_sorted_order( & psi_bilinear_matrix_order( & psi_bilinear_matrix_transp_order(l_a))) - ! Removed to avoid introducing determinants already presents in the wf - !if (psi_average_norm_contrib_sorted(idx) > norm_thr) then + if (psi_average_norm_contrib_sorted(idx) > norm_thr) then indices(k) = idx k=k+1 - !endif + endif endif enddo enddo @@ -258,6 +253,8 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d deallocate(exc_degree) nmax=k-1 + call isort_noidx(indices,nmax) + ! Start with 32 elements. Size will double along with the filtering. allocate(preinteresting(0:32), prefullinteresting(0:32), & interesting(0:32), fullinteresting(0:32)) @@ -467,21 +464,27 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d allocate (fullminilist (N_int, 2, fullinteresting(0)), & minilist (N_int, 2, interesting(0)) ) -! if(pert_2rdm)then -! allocate(coef_fullminilist_rev(N_states,fullinteresting(0))) -! do i=1,fullinteresting(0) -! do j = 1, N_states -! coef_fullminilist_rev(j,i) = psi_coef_sorted(fullinteresting(i),j) -! enddo -! enddo -! endif + if(pert_2rdm)then + allocate(coef_fullminilist_rev(N_states,fullinteresting(0))) + do i=1,fullinteresting(0) + do j = 1, N_states + coef_fullminilist_rev(j,i) = psi_coef_sorted(fullinteresting(i),j) + enddo + enddo + endif do i=1,fullinteresting(0) - fullminilist(:,:,i) = psi_det_sorted(:,:,fullinteresting(i)) + do k=1,N_int + fullminilist(k,1,i) = psi_det_sorted(k,1,fullinteresting(i)) + fullminilist(k,2,i) = psi_det_sorted(k,2,fullinteresting(i)) + enddo enddo do i=1,interesting(0) - minilist(:,:,i) = psi_det_sorted(:,:,interesting(i)) + do k=1,N_int + minilist(k,1,i) = psi_det_sorted(k,1,interesting(i)) + minilist(k,2,i) = psi_det_sorted(k,2,interesting(i)) + enddo enddo do s2=s1,2 @@ -528,19 +531,19 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) -! if(.not.pert_2rdm)then + if(.not.pert_2rdm)then call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf) -! else -! call fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf,fullminilist, coef_fullminilist_rev, fullinteresting(0)) -! endif + else + call fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf,fullminilist, coef_fullminilist_rev, fullinteresting(0)) + endif end if enddo if(s1 /= s2) monoBdo = .false. enddo deallocate(fullminilist,minilist) -! if(pert_2rdm)then -! deallocate(coef_fullminilist_rev) -! endif + if(pert_2rdm)then + deallocate(coef_fullminilist_rev) + endif enddo enddo deallocate(preinteresting, prefullinteresting, interesting, fullinteresting) @@ -569,7 +572,6 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d double precision, external :: diag_H_mat_elem_fock double precision :: E_shift double precision :: s_weight(N_states,N_states) - logical, external :: is_in_wavefunction PROVIDE dominant_dets_of_cfgs N_dominant_dets_of_cfgs do jstate=1,N_states do istate=1,N_states @@ -711,25 +713,6 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d if (do_cycle) cycle endif - if (twice_hierarchy_max >= 0) then - s = 0 - do k=1,N_int - s = s + popcnt(ieor(det(k,1),det(k,2))) - enddo - if ( mod(s,2)>0 ) stop 'For now, hierarchy CI is defined only for an even number of electrons' - if (excitation_ref == 1) then - call get_excitation_degree(HF_bitmask,det(1,1),degree,N_int) - else if (excitation_ref == 2) then - stop 'For now, hierarchy CI is defined only for a single reference determinant' -! do k=1,N_dominant_dets_of_cfgs -! call get_excitation_degree(dominant_dets_of_cfgs(1,1,k),det(1,1),degree,N_int) -! enddo - endif - integer :: twice_hierarchy - twice_hierarchy = degree + s/2 - if (twice_hierarchy > twice_hierarchy_max) cycle - endif - Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) w = 0d0 @@ -800,9 +783,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d alpha_h_psi = mat(istate, p1, p2) - do k=1,N_states - pt2_data % overlap(k,istate) = pt2_data % overlap(k,istate) + coef(k) * coef(istate) - end do + pt2_data % overlap(:,istate) = pt2_data % overlap(:,istate) + coef(:) * coef(istate) pt2_data % variance(istate) = pt2_data % variance(istate) + alpha_h_psi * alpha_h_psi pt2_data % pt2(istate) = pt2_data % pt2(istate) + e_pert(istate) @@ -853,27 +834,8 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d endif end select - - ! To force the inclusion of determinants with a positive pt2 contribution - if (e_pert(istate) > 1d-8) then - w = -huge(1.0) - endif - end do -!!!BEGIN_DEBUG -! ! To check if the pt2 is taking determinants already in the wf -! if (is_in_wavefunction(det(N_int,1),N_int)) then -! print*, 'A determinant contributing to the pt2 is already in' -! print*, 'the wave function:' -! call print_det(det(N_int,1),N_int) -! print*,'contribution to the pt2 for the states:', e_pert(:) -! print*,'error in the filtering in' -! print*, 'cipsi/selection.irp.f sub: selecte_singles_and_doubles' -! print*, 'abort' -! call abort -! endif -!!!END_DEBUG integer(bit_kind) :: occ(N_int,2), n if (h0_type == 'CFG') then @@ -1594,7 +1556,7 @@ subroutine bitstring_to_list_in_selection( string, list, n_elements, Nint) use bitmasks implicit none BEGIN_DOC - ! Gives the indices(+1) of the bits set to 1 in the bit string + ! Gives the inidices(+1) of the bits set to 1 in the bit string END_DOC integer, intent(in) :: Nint integer(bit_kind), intent(in) :: string(Nint) diff --git a/src/cipsi/selection_buffer.irp.f b/src/cipsi/selection_buffer.irp.f index 1f743e0e..10132086 100644 --- a/src/cipsi/selection_buffer.irp.f +++ b/src/cipsi/selection_buffer.irp.f @@ -60,7 +60,6 @@ subroutine add_to_selection_buffer(b, det, val) b%val(b%cur) = val if(b%cur == size(b%val)) then call sort_selection_buffer(b) - b%cur = b%cur-1 end if end if end subroutine @@ -87,56 +86,43 @@ subroutine merge_selection_buffers(b1, b2) double precision :: rss double precision, external :: memory_of_double sze = max(size(b1%val), size(b2%val)) -! rss = memory_of_double(sze) + 2*N_int*memory_of_double(sze) -! call check_mem(rss,irp_here) + rss = memory_of_double(sze) + 2*N_int*memory_of_double(sze) + call check_mem(rss,irp_here) allocate(val(sze), detmp(N_int, 2, sze)) i1=1 i2=1 - - select case (N_int) -BEGIN_TEMPLATE - case $case - do i=1,nmwen - if ( (i1 > b1%cur).and.(i2 > b2%cur) ) then - exit - else if (i1 > b1%cur) then - val(i) = b2%val(i2) - detmp(1:$N_int,1,i) = b2%det(1:$N_int,1,i2) - detmp(1:$N_int,2,i) = b2%det(1:$N_int,2,i2) - i2=i2+1 - else if (i2 > b2%cur) then - val(i) = b1%val(i1) - detmp(1:$N_int,1,i) = b1%det(1:$N_int,1,i1) - detmp(1:$N_int,2,i) = b1%det(1:$N_int,2,i1) - i1=i1+1 + do i=1,nmwen + if ( (i1 > b1%cur).and.(i2 > b2%cur) ) then + exit + else if (i1 > b1%cur) then + val(i) = b2%val(i2) + detmp(1:N_int,1,i) = b2%det(1:N_int,1,i2) + detmp(1:N_int,2,i) = b2%det(1:N_int,2,i2) + i2=i2+1 + else if (i2 > b2%cur) then + val(i) = b1%val(i1) + detmp(1:N_int,1,i) = b1%det(1:N_int,1,i1) + detmp(1:N_int,2,i) = b1%det(1:N_int,2,i1) + i1=i1+1 + else + if (b1%val(i1) <= b2%val(i2)) then + val(i) = b1%val(i1) + detmp(1:N_int,1,i) = b1%det(1:N_int,1,i1) + detmp(1:N_int,2,i) = b1%det(1:N_int,2,i1) + i1=i1+1 else - if (b1%val(i1) <= b2%val(i2)) then - val(i) = b1%val(i1) - detmp(1:$N_int,1,i) = b1%det(1:$N_int,1,i1) - detmp(1:$N_int,2,i) = b1%det(1:$N_int,2,i1) - i1=i1+1 - else - val(i) = b2%val(i2) - detmp(1:$N_int,1,i) = b2%det(1:$N_int,1,i2) - detmp(1:$N_int,2,i) = b2%det(1:$N_int,2,i2) - i2=i2+1 - endif + val(i) = b2%val(i2) + detmp(1:N_int,1,i) = b2%det(1:N_int,1,i2) + detmp(1:N_int,2,i) = b2%det(1:N_int,2,i2) + i2=i2+1 endif - enddo - do i=nmwen+1,b2%N - val(i) = 0.d0 -! detmp(1:$N_int,1,i) = 0_bit_kind -! detmp(1:$N_int,2,i) = 0_bit_kind - enddo -SUBST [ case, N_int ] -(1); 1;; -(2); 2;; -(3); 3;; -(4); 4;; -default; N_int;; -END_TEMPLATE - end select + endif + enddo deallocate(b2%det, b2%val) + do i=nmwen+1,b2%N + val(i) = 0.d0 + detmp(1:N_int,1:2,i) = 0_bit_kind + enddo b2%det => detmp b2%val => val b2%mini = min(b2%mini,b2%val(b2%N)) @@ -158,8 +144,8 @@ subroutine sort_selection_buffer(b) double precision :: rss double precision, external :: memory_of_double, memory_of_int -! rss = memory_of_int(b%cur) + 2*N_int*memory_of_double(size(b%det,3)) -! call check_mem(rss,irp_here) + rss = memory_of_int(b%cur) + 2*N_int*memory_of_double(size(b%det,3)) + call check_mem(rss,irp_here) allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3))) do i=1,b%cur iorder(i) = i @@ -239,14 +225,14 @@ subroutine make_selection_buffer_s2(b) endif dup = .True. do k=1,N_int - if ( (tmp_array(k,1,i) /= tmp_array(k,1,j)) .or. & - (tmp_array(k,2,i) /= tmp_array(k,2,j)) ) then + if ( (tmp_array(k,1,i) /= tmp_array(k,1,j)) & + .or. (tmp_array(k,2,i) /= tmp_array(k,2,j)) ) then dup = .False. exit endif enddo if (dup) then - val(i) = min(val(i), val(j)) + val(i) = max(val(i), val(j)) duplicate(j) = .True. endif j+=1 @@ -296,6 +282,9 @@ subroutine make_selection_buffer_s2(b) call configuration_to_dets_size(o(1,1,i),sze,elec_alpha_num,N_int) n_d = n_d + sze if (n_d > b%cur) then +! if (n_d - b%cur > b%cur - n_d + sze) then +! n_d = n_d - sze +! endif exit endif enddo @@ -340,11 +329,10 @@ subroutine remove_duplicates_in_selection_buffer(b) integer(bit_kind), allocatable :: tmp_array(:,:,:) logical, allocatable :: duplicate(:) + n_d = b%cur logical :: found_duplicates double precision :: rss double precision, external :: memory_of_double - - n_d = b%cur rss = (4*N_int+4)*memory_of_double(n_d) call check_mem(rss,irp_here) diff --git a/src/cipsi/selection_weight.irp.f b/src/cipsi/selection_weight.irp.f index 756c65a1..3c09e59a 100644 --- a/src/cipsi/selection_weight.irp.f +++ b/src/cipsi/selection_weight.irp.f @@ -38,11 +38,11 @@ subroutine update_pt2_and_variance_weights(pt2_data, N_st) avg = sum(pt2(1:N_st)) / dble(N_st) + 1.d-32 ! Avoid future division by zero - dt = 4.d0 !* selection_factor + dt = 8.d0 !* selection_factor do k=1,N_st - element = pt2(k) !exp(dt*(pt2(k)/avg - 1.d0)) -! element = min(2.0d0 , element) -! element = max(0.5d0 , element) + element = exp(dt*(pt2(k)/avg - 1.d0)) + element = min(2.0d0 , element) + element = max(0.5d0 , element) pt2_match_weight(k) *= element enddo @@ -50,9 +50,9 @@ subroutine update_pt2_and_variance_weights(pt2_data, N_st) avg = sum(variance(1:N_st)) / dble(N_st) + 1.d-32 ! Avoid future division by zero do k=1,N_st - element = variance(k) ! exp(dt*(variance(k)/avg -1.d0)) -! element = min(2.0d0 , element) -! element = max(0.5d0 , element) + element = exp(dt*(variance(k)/avg -1.d0)) + element = min(2.0d0 , element) + element = max(0.5d0 , element) variance_match_weight(k) *= element enddo @@ -62,9 +62,6 @@ subroutine update_pt2_and_variance_weights(pt2_data, N_st) variance_match_weight(:) = 1.d0 endif - pt2_match_weight(:) = pt2_match_weight(:)/sum(pt2_match_weight(:)) - variance_match_weight(:) = variance_match_weight(:)/sum(variance_match_weight(:)) - threshold_davidson_pt2 = min(1.d-6, & max(threshold_davidson, 1.e-1 * PT2_relative_error * minval(abs(pt2(1:N_states)))) ) @@ -90,7 +87,7 @@ BEGIN_PROVIDER [ double precision, selection_weight, (N_states) ] selection_weight(1:N_states) = c0_weight(1:N_states) case (2) - print *, 'Using PT2-matching weight in selection' + print *, 'Using pt2-matching weight in selection' selection_weight(1:N_states) = c0_weight(1:N_states) * pt2_match_weight(1:N_states) print *, '# PT2 weight ', real(pt2_match_weight(:),4) @@ -100,7 +97,7 @@ BEGIN_PROVIDER [ double precision, selection_weight, (N_states) ] print *, '# var weight ', real(variance_match_weight(:),4) case (4) - print *, 'Using variance- and PT2-matching weights in selection' + print *, 'Using variance- and pt2-matching weights in selection' selection_weight(1:N_states) = c0_weight(1:N_states) * sqrt(variance_match_weight(1:N_states) * pt2_match_weight(1:N_states)) print *, '# PT2 weight ', real(pt2_match_weight(:),4) print *, '# var weight ', real(variance_match_weight(:),4) @@ -115,7 +112,7 @@ BEGIN_PROVIDER [ double precision, selection_weight, (N_states) ] selection_weight(1:N_states) = c0_weight(1:N_states) case (7) - print *, 'Input weights multiplied by variance- and PT2-matching' + print *, 'Input weights multiplied by variance- and pt2-matching' selection_weight(1:N_states) = c0_weight(1:N_states) * sqrt(variance_match_weight(1:N_states) * pt2_match_weight(1:N_states)) * state_average_weight(1:N_states) print *, '# PT2 weight ', real(pt2_match_weight(:),4) print *, '# var weight ', real(variance_match_weight(:),4) @@ -131,7 +128,6 @@ BEGIN_PROVIDER [ double precision, selection_weight, (N_states) ] print *, '# var weight ', real(variance_match_weight(:),4) end select - selection_weight(:) = selection_weight(:)/sum(selection_weight(:)) print *, '# Total weight ', real(selection_weight(:),4) END_PROVIDER diff --git a/src/cipsi/slave_cipsi.irp.f b/src/cipsi/slave_cipsi.irp.f index f96aaa6a..510c667b 100644 --- a/src/cipsi/slave_cipsi.irp.f +++ b/src/cipsi/slave_cipsi.irp.f @@ -4,7 +4,7 @@ subroutine run_slave_cipsi ! Helper program for distributed parallelism END_DOC - call set_multiple_levels_omp(.False.) + call omp_set_max_active_levels(1) distributed_davidson = .False. read_wf = .False. SOFT_TOUCH read_wf distributed_davidson @@ -171,9 +171,9 @@ subroutine run_slave_main call write_double(6,(t1-t0),'Broadcast time') !--- - call set_multiple_levels_omp(.True.) + call omp_set_max_active_levels(8) call davidson_slave_tcp(0) - call set_multiple_levels_omp(.False.) + call omp_set_max_active_levels(1) print *, mpi_rank, ': Davidson done' !--- @@ -311,7 +311,7 @@ subroutine run_slave_main if (mpi_master) then print *, 'Running PT2' endif - !$OMP PARALLEL PRIVATE(i) NUM_THREADS(nproc_target) + !$OMP PARALLEL PRIVATE(i) NUM_THREADS(nproc_target+1) i = omp_get_thread_num() call run_pt2_slave(0,i,pt2_e0_denominator) !$OMP END PARALLEL diff --git a/src/cipsi/stochastic_cipsi.irp.f b/src/cipsi/stochastic_cipsi.irp.f index 5fc9db0f..781fcda6 100644 --- a/src/cipsi/stochastic_cipsi.irp.f +++ b/src/cipsi/stochastic_cipsi.irp.f @@ -69,8 +69,8 @@ subroutine run_stochastic_cipsi do while ( & (N_det < N_det_max) .and. & - (sum(abs(pt2_data % pt2(1:N_states)) * state_average_weight(1:N_states)) > pt2_max) .and. & - (sum(abs(pt2_data % variance(1:N_states)) * state_average_weight(1:N_states)) > variance_max) .and. & + (maxval(abs(pt2_data % pt2(1:N_states))) > pt2_max) .and. & + (maxval(abs(pt2_data % variance(1:N_states))) > variance_max) .and. & (correlation_energy_ratio <= correlation_energy_ratio_max) & ) write(*,'(A)') '--------------------------------------------------------------------------------' diff --git a/src/cipsi/update_2rdm.irp.f b/src/cipsi/update_2rdm.irp.f new file mode 100644 index 00000000..260c48fd --- /dev/null +++ b/src/cipsi/update_2rdm.irp.f @@ -0,0 +1,223 @@ +use bitmasks + +subroutine give_2rdm_pert_contrib(det,coef,psi_det_connection,psi_coef_connection_reverse,n_det_connection,nkeys,keys,values,sze_buff) + implicit none + integer, intent(in) :: n_det_connection,sze_buff + double precision, intent(in) :: coef(N_states) + integer(bit_kind), intent(in) :: det(N_int,2) + integer(bit_kind), intent(in) :: psi_det_connection(N_int,2,n_det_connection) + double precision, intent(in) :: psi_coef_connection_reverse(N_states,n_det_connection) + integer, intent(inout) :: keys(4,sze_buff),nkeys + double precision, intent(inout) :: values(sze_buff) + integer :: i,j + integer :: exc(0:2,2,2) + integer :: degree + double precision :: phase, contrib + do i = 1, n_det_connection + call get_excitation(det,psi_det_connection(1,1,i),exc,degree,phase,N_int) + if(degree.gt.2)cycle + contrib = 0.d0 + do j = 1, N_states + contrib += state_average_weight(j) * psi_coef_connection_reverse(j,i) * phase * coef(j) + enddo + ! case of single excitations + if(degree == 1)then + if (nkeys + 6 * elec_alpha_num .ge. sze_buff)then + call update_keys_values(keys,values,nkeys,n_orb_pert_rdm,pert_2rdm_provider,pert_2rdm_lock) + nkeys = 0 + endif + call update_buffer_single_exc_rdm(det,psi_det_connection(1,1,i),exc,phase,contrib,nkeys,keys,values,sze_buff) + else + !! case of double excitations + ! if (nkeys + 4 .ge. sze_buff)then + ! call update_keys_values(keys,values,nkeys,n_orb_pert_rdm,pert_2rdm_provider,pert_2rdm_lock) + ! nkeys = 0 + ! endif + ! call update_buffer_double_exc_rdm(exc,phase,contrib,nkeys,keys,values,sze_buff) + endif + enddo +!call update_keys_values(keys,values,nkeys,n_orb_pert_rdm,pert_2rdm_provider,pert_2rdm_lock) +!nkeys = 0 + +end + +subroutine update_buffer_single_exc_rdm(det1,det2,exc,phase,contrib,nkeys,keys,values,sze_buff) + implicit none + integer, intent(in) :: sze_buff + integer(bit_kind), intent(in) :: det1(N_int,2) + integer(bit_kind), intent(in) :: det2(N_int,2) + integer,intent(in) :: exc(0:2,2,2) + double precision,intent(in) :: phase, contrib + integer, intent(inout) :: nkeys, keys(4,sze_buff) + double precision, intent(inout):: values(sze_buff) + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2),ispin,other_spin + integer :: h1,h2,p1,p2,i + call bitstring_to_list_ab(det1, occ, n_occ_ab, N_int) + + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + p1 = exc(1,2,1) + ispin = 1 + other_spin = 2 + else + ! Mono beta + h1 = exc(1,1,2) + p1 = exc(1,2,2) + ispin = 2 + other_spin = 1 + endif + if(list_orb_reverse_pert_rdm(h1).lt.0)return + h1 = list_orb_reverse_pert_rdm(h1) + if(list_orb_reverse_pert_rdm(p1).lt.0)return + p1 = list_orb_reverse_pert_rdm(p1) + !update the alpha/beta part + do i = 1, n_occ_ab(other_spin) + h2 = occ(i,other_spin) + if(list_orb_reverse_pert_rdm(h2).lt.0)return + h2 = list_orb_reverse_pert_rdm(h2) + + nkeys += 1 + values(nkeys) = 0.5d0 * contrib * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + nkeys += 1 + values(nkeys) = 0.5d0 * contrib * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + enddo + !update the same spin part +!do i = 1, n_occ_ab(ispin) +! h2 = occ(i,ispin) +! if(list_orb_reverse_pert_rdm(h2).lt.0)return +! h2 = list_orb_reverse_pert_rdm(h2) + +! nkeys += 1 +! values(nkeys) = 0.5d0 * contrib * phase +! keys(1,nkeys) = h1 +! keys(2,nkeys) = h2 +! keys(3,nkeys) = p1 +! keys(4,nkeys) = h2 + +! nkeys += 1 +! values(nkeys) = - 0.5d0 * contrib * phase +! keys(1,nkeys) = h1 +! keys(2,nkeys) = h2 +! keys(3,nkeys) = h2 +! keys(4,nkeys) = p1 +! +! nkeys += 1 +! values(nkeys) = 0.5d0 * contrib * phase +! keys(1,nkeys) = h2 +! keys(2,nkeys) = h1 +! keys(3,nkeys) = h2 +! keys(4,nkeys) = p1 + +! nkeys += 1 +! values(nkeys) = - 0.5d0 * contrib * phase +! keys(1,nkeys) = h2 +! keys(2,nkeys) = h1 +! keys(3,nkeys) = p1 +! keys(4,nkeys) = h2 +!enddo + +end + +subroutine update_buffer_double_exc_rdm(exc,phase,contrib,nkeys,keys,values,sze_buff) + implicit none + integer, intent(in) :: sze_buff + integer,intent(in) :: exc(0:2,2,2) + double precision,intent(in) :: phase, contrib + integer, intent(inout) :: nkeys, keys(4,sze_buff) + double precision, intent(inout):: values(sze_buff) + integer :: h1,h2,p1,p2 + + if (exc(0,1,1) == 1) then + ! Double alpha/beta + h1 = exc(1,1,1) + h2 = exc(1,1,2) + p1 = exc(1,2,1) + p2 = exc(1,2,2) + ! check if the orbitals involved are within the orbital range + if(list_orb_reverse_pert_rdm(h1).lt.0)return + h1 = list_orb_reverse_pert_rdm(h1) + if(list_orb_reverse_pert_rdm(h2).lt.0)return + h2 = list_orb_reverse_pert_rdm(h2) + if(list_orb_reverse_pert_rdm(p1).lt.0)return + p1 = list_orb_reverse_pert_rdm(p1) + if(list_orb_reverse_pert_rdm(p2).lt.0)return + p2 = list_orb_reverse_pert_rdm(p2) + nkeys += 1 + values(nkeys) = 0.5d0 * contrib * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + nkeys += 1 + values(nkeys) = 0.5d0 * contrib * phase + keys(1,nkeys) = p1 + keys(2,nkeys) = p2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + + else + if (exc(0,1,1) == 2) then + ! Double alpha/alpha + h1 = exc(1,1,1) + h2 = exc(2,1,1) + p1 = exc(1,2,1) + p2 = exc(2,2,1) + else if (exc(0,1,2) == 2) then + ! Double beta + h1 = exc(1,1,2) + h2 = exc(2,1,2) + p1 = exc(1,2,2) + p2 = exc(2,2,2) + endif + ! check if the orbitals involved are within the orbital range + if(list_orb_reverse_pert_rdm(h1).lt.0)return + h1 = list_orb_reverse_pert_rdm(h1) + if(list_orb_reverse_pert_rdm(h2).lt.0)return + h2 = list_orb_reverse_pert_rdm(h2) + if(list_orb_reverse_pert_rdm(p1).lt.0)return + p1 = list_orb_reverse_pert_rdm(p1) + if(list_orb_reverse_pert_rdm(p2).lt.0)return + p2 = list_orb_reverse_pert_rdm(p2) + nkeys += 1 + values(nkeys) = 0.5d0 * contrib * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + + nkeys += 1 + values(nkeys) = - 0.5d0 * contrib * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = 0.5d0 * contrib * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = - 0.5d0 * contrib * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + endif + +end + + diff --git a/src/cipsi/zmq_selection.irp.f b/src/cipsi/zmq_selection.irp.f index 1bfe87c0..58630709 100644 --- a/src/cipsi/zmq_selection.irp.f +++ b/src/cipsi/zmq_selection.irp.f @@ -22,7 +22,7 @@ subroutine ZMQ_selection(N_in, pt2_data) PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns PROVIDE psi_bilinear_matrix_transp_order selection_weight pseudo_sym PROVIDE n_act_orb n_inact_orb n_core_orb n_virt_orb n_del_orb seniority_max - PROVIDE excitation_beta_max excitation_alpha_max excitation_max + PROVIDE pert_2rdm excitation_beta_max excitation_alpha_max excitation_max call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'selection') diff --git a/src/cis/cis.irp.f b/src/cis/cis.irp.f index 2b16a5f7..acec29c2 100644 --- a/src/cis/cis.irp.f +++ b/src/cis/cis.irp.f @@ -62,7 +62,6 @@ subroutine run else call H_apply_cis endif - print*,'' print *, 'N_det = ', N_det print*,'******************************' print *, 'Energies of the states:' @@ -70,18 +69,16 @@ subroutine run print *, i, CI_energy(i) enddo if (N_states > 1) then - print*,'' - print*,'******************************************************' - print*,'Excitation energies (au) (eV)' + print*,'******************************' + print*,'Excitation energies ' do i = 2, N_states - print*, i ,CI_energy(i) - CI_energy(1), (CI_energy(i) - CI_energy(1)) * ha_to_ev + print*, i ,CI_energy(i) - CI_energy(1) enddo - print*,'' endif call ezfio_set_cis_energy(CI_energy) psi_coef = ci_eigenvectors SOFT_TOUCH psi_coef - call save_wavefunction_truncated(save_threshold) + call save_wavefunction_truncated(1.d-12) end diff --git a/src/cis_read/EZFIO.cfg b/src/cis_read/EZFIO.cfg deleted file mode 100644 index 955d1bef..00000000 --- a/src/cis_read/EZFIO.cfg +++ /dev/null @@ -1,7 +0,0 @@ -[energy] -type: double precision -doc: Variational |CIS| energy -interface: ezfio -size: (determinants.n_states) - - diff --git a/src/cis_read/NEED b/src/cis_read/NEED deleted file mode 100644 index 42992ac6..00000000 --- a/src/cis_read/NEED +++ /dev/null @@ -1,3 +0,0 @@ -selectors_full -generators_full -davidson_undressed diff --git a/src/cis_read/README.rst b/src/cis_read/README.rst deleted file mode 100644 index 31648636..00000000 --- a/src/cis_read/README.rst +++ /dev/null @@ -1,5 +0,0 @@ -=== -cis_read -=== - -Reads the input WF and performs all singles on top of it. diff --git a/src/cis_read/cis_read.irp.f b/src/cis_read/cis_read.irp.f deleted file mode 100644 index 055b5e15..00000000 --- a/src/cis_read/cis_read.irp.f +++ /dev/null @@ -1,88 +0,0 @@ -program cis - implicit none - BEGIN_DOC -! -! Configuration Interaction with Single excitations. -! -! This program takes a reference Slater determinant of ROHF-like -! occupancy, and performs all single excitations on top of it. -! Disregarding spatial symmetry, it computes the `n_states` lowest -! eigenstates of that CI matrix. (see :option:`determinants n_states`) -! -! This program can be useful in many cases: -! -! -! 1. Ground state calculation -! -! To be sure to have the lowest |SCF| solution, perform an :ref:`scf` -! (see the :ref:`module_hartree_fock` module), then a :ref:`cis`, save the -! natural orbitals (see :ref:`save_natorb`) and re-run an :ref:`scf` -! optimization from this |MO| guess. -! -! -! 2. Excited states calculations -! -! The lowest excited states are much likely to be dominated by -! single-excitations. Therefore, running a :ref:`cis` will save the -! `n_states` lowest states within the |CIS| space in the |EZFIO| -! directory, which can afterwards be used as guess wave functions for -! a further multi-state |FCI| calculation if :option:`determinants -! read_wf` is set to |true| before running the :ref:`fci` executable. -! -! -! If :option:`determinants s2_eig` is set to |true|, the |CIS| -! will only retain states having the expected |S^2| value (see -! :option:`determinants expected_s2`). Otherwise, the |CIS| will take -! the lowest :option:`determinants n_states`, whatever multiplicity -! they are. -! -! .. note:: -! -! To discard some orbitals, use the :ref:`qp_set_mo_class` -! command to specify: -! -! * *core* orbitals which will be always doubly occupied -! -! * *act* orbitals where an electron can be either excited from or to -! -! * *del* orbitals which will be never occupied -! - END_DOC - read_wf = .True. - TOUCH read_wf - call run -end - -subroutine run - implicit none - integer :: i - - - if(pseudo_sym)then - call H_apply_cis_sym - else - call H_apply_cis - endif - print*,'' - print *, 'N_det = ', N_det - print*,'******************************' - print *, 'Energies of the states:' - do i = 1,N_states - print *, i, CI_energy(i) - enddo - if (N_states > 1) then - print*,'' - print*,'******************************************************' - print*,'Excitation energies (au) (eV)' - do i = 2, N_states - print*, i ,CI_energy(i) - CI_energy(1), (CI_energy(i) - CI_energy(1))/0.0367502d0 - enddo - print*,'' - endif - - call ezfio_set_cis_energy(CI_energy) - psi_coef = ci_eigenvectors - SOFT_TOUCH psi_coef - call save_wavefunction_truncated(save_threshold) - -end diff --git a/src/cis_read/h_apply.irp.f b/src/cis_read/h_apply.irp.f deleted file mode 100644 index 14389bed..00000000 --- a/src/cis_read/h_apply.irp.f +++ /dev/null @@ -1,14 +0,0 @@ -! Generates subroutine H_apply_cis -! -------------------------------- - -BEGIN_SHELL [ /usr/bin/env python3 ] -from generate_h_apply import H_apply -H = H_apply("cis",do_double_exc=False) -print(H) - -H = H_apply("cis_sym",do_double_exc=False) -H.filter_only_connected_to_hf() -print(H) - -END_SHELL - diff --git a/src/cisd/cisd.irp.f b/src/cisd/cisd.irp.f index 3e1e8d97..6c55e2ff 100644 --- a/src/cisd/cisd.irp.f +++ b/src/cisd/cisd.irp.f @@ -47,37 +47,6 @@ program cisd PROVIDE N_states read_wf = .False. SOFT_TOUCH read_wf - - integer :: i,k - - if(pseudo_sym)then - call H_apply_cisd_sym - else - call H_apply_cisd - endif - double precision :: r1, r2 - double precision, allocatable :: U_csf(:,:) - - allocate(U_csf(N_csf,N_states)) - U_csf = 0.d0 - U_csf(1,1) = 1.d0 - do k=2,N_states - do i=1,N_csf - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dacos(-1.d0)*2.d0*r2 - U_csf(i,k) = r1*dcos(r2) - enddo - U_csf(k,k) = U_csf(k,k) +100.d0 - enddo - do k=1,N_states - call normalize(U_csf(1,k),N_csf) - enddo - call convertWFfromCSFtoDET(N_states,U_csf(1,1),psi_coef(1,1)) - deallocate(U_csf) - SOFT_TOUCH psi_coef - call run end @@ -87,16 +56,20 @@ subroutine run double precision :: cisdq(N_states), delta_e double precision,external :: diag_h_mat_elem + if(pseudo_sym)then + call H_apply_cisd_sym + else + call H_apply_cisd + endif psi_coef = ci_eigenvectors - call save_wavefunction_truncated(save_threshold) + SOFT_TOUCH psi_coef + call save_wavefunction call ezfio_set_cisd_energy(CI_energy) do i = 1,N_states k = maxloc(dabs(psi_coef_sorted(1:N_det,i)),dim=1) delta_E = CI_electronic_energy(i) - diag_h_mat_elem(psi_det_sorted(1,1,k),N_int) - if (elec_alpha_num + elec_beta_num >= 4) then - cisdq(i) = CI_energy(i) + delta_E * (1.d0 - psi_coef_sorted(k,i)**2) - endif + cisdq(i) = CI_energy(i) + delta_E * (1.d0 - psi_coef_sorted(k,i)**2) enddo print *, 'N_det = ', N_det print*,'' @@ -105,43 +78,26 @@ subroutine run do i = 1,N_states print *, i, CI_energy(i) enddo - if (elec_alpha_num + elec_beta_num >= 4) then + print*,'' + print*,'******************************' + print *, 'CISD+Q Energies' + do i = 1,N_states + print *, i, cisdq(i) + enddo + if (N_states > 1) then print*,'' print*,'******************************' - print *, 'CISD+Q Energies' - do i = 1,N_states - print *, i, cisdq(i) + print*,'Excitation energies (au) (CISD+Q)' + do i = 2, N_states + print*, i ,CI_energy(i) - CI_energy(1), cisdq(i) - cisdq(1) + enddo + print*,'' + print*,'******************************' + print*,'Excitation energies (eV) (CISD+Q)' + do i = 2, N_states + print*, i ,(CI_energy(i) - CI_energy(1))/0.0367502d0, & + (cisdq(i) - cisdq(1)) / 0.0367502d0 enddo - endif - if (N_states > 1) then - if (elec_alpha_num + elec_beta_num >= 4) then - print*,'' - print*,'******************************' - print*,'Excitation energies (au) (CISD+Q)' - do i = 2, N_states - print*, i ,CI_energy(i) - CI_energy(1), cisdq(i) - cisdq(1) - enddo - print*,'' - print*,'******************************' - print*,'Excitation energies (eV) (CISD+Q)' - do i = 2, N_states - print*, i ,(CI_energy(i) - CI_energy(1)) * ha_to_ev, & - (cisdq(i) - cisdq(1)) * ha_to_ev - enddo - else - print*,'' - print*,'******************************' - print*,'Excitation energies (au) (CISD)' - do i = 2, N_states - print*, i ,CI_energy(i) - CI_energy(1) - enddo - print*,'' - print*,'******************************' - print*,'Excitation energies (eV) (CISD)' - do i = 2, N_states - print*, i ,(CI_energy(i) - CI_energy(1)) * ha_to_ev - enddo - endif endif end diff --git a/src/csf/configurations.irp.f b/src/csf/configurations.irp.f index ce5d48ab..8e2a513c 100644 --- a/src/csf/configurations.irp.f +++ b/src/csf/configurations.irp.f @@ -779,7 +779,6 @@ subroutine binary_search_cfg(cfgInp,addcfg) end subroutine BEGIN_PROVIDER [ integer, psi_configuration_to_psi_det, (2,N_configuration) ] -&BEGIN_PROVIDER [ integer, psi_configuration_n_det, (N_configuration) ] &BEGIN_PROVIDER [ integer, psi_configuration_to_psi_det_data, (N_det) ] implicit none @@ -868,29 +867,6 @@ end subroutine enddo deallocate(dets, old_order) - integer :: ndet_conf - do i = 1, N_configuration - ndet_conf = psi_configuration_to_psi_det(2,i) - psi_configuration_to_psi_det(1,i) + 1 - psi_configuration_n_det(i) = ndet_conf - enddo END_PROVIDER - -BEGIN_PROVIDER [ integer, n_elec_alpha_for_psi_configuration, (N_configuration)] - implicit none - integer :: i,j,k,l - integer(bit_kind) :: det_tmp(N_int,2),det_alpha(N_int) - n_elec_alpha_for_psi_configuration = 0 - do i = 1, N_configuration - j = psi_configuration_to_psi_det(2,i) - det_tmp(:,:) = psi_det(:,:,j) - k = 0 - do l = 1, N_int - det_alpha(N_int) = iand(det_tmp(l,1),psi_configuration(l,1,i)) - k += popcnt(det_alpha(l)) - enddo - n_elec_alpha_for_psi_configuration(i) = k - enddo - -END_PROVIDER diff --git a/src/csf/conversion.irp.f b/src/csf/conversion.irp.f index 75f6e539..fecc6123 100644 --- a/src/csf/conversion.irp.f +++ b/src/csf/conversion.irp.f @@ -1,15 +1,3 @@ -BEGIN_PROVIDER [ double precision, psi_csf_coef, (N_csf, N_states) ] - implicit none - BEGIN_DOC - ! Wafe function in CSF basis - END_DOC - - double precision, allocatable :: buffer(:,:) - allocate ( buffer(N_det, N_states) ) - buffer(1:N_det, 1:N_states) = psi_coef(1:N_det, 1:N_states) - call convertWFfromDETtoCSF(N_states, buffer, psi_csf_coef) -END_PROVIDER - subroutine convertWFfromDETtoCSF(N_st,psi_coef_det_in, psi_coef_cfg_out) use cfunctions use bitmasks @@ -38,8 +26,6 @@ subroutine convertWFfromDETtoCSF(N_st,psi_coef_det_in, psi_coef_cfg_out) integer s, bfIcfg integer countcsf - integer MS - MS = elec_alpha_num-elec_beta_num countcsf = 0 phasedet = 1.0d0 do i = 1,N_configuration @@ -58,17 +44,12 @@ subroutine convertWFfromDETtoCSF(N_st,psi_coef_det_in, psi_coef_cfg_out) enddo enddo - s = 0 ! s == total number of SOMOs + s = 0 do k=1,N_int if (psi_configuration(k,1,i) == 0_bit_kind) cycle s = s + popcnt(psi_configuration(k,1,i)) enddo - - if(iand(s,1) .EQ. 0) then - bfIcfg = max(1,nint((binom(s,s/2)-binom(s,(s/2)+1)))) - else - bfIcfg = max(1,nint((binom(s,(s+1)/2)-binom(s,((s+1)/2)+1)))) - endif + bfIcfg = max(1,nint((binom(s,(s+1)/2)-binom(s,((s+1)/2)+1)))) ! perhaps blocking with CFGs of same seniority ! can be more efficient diff --git a/src/csf/sigma_vector.irp.f b/src/csf/sigma_vector.irp.f index 5aaba9a3..85ed5f84 100644 --- a/src/csf/sigma_vector.irp.f +++ b/src/csf/sigma_vector.irp.f @@ -1,12 +1,9 @@ real*8 function logabsgamma(x) implicit none real*8, intent(in) :: x - logabsgamma = 1.d32 ! Avoid floating point exception - if (x>0.d0) then - logabsgamma = log(abs(gamma(x))) - endif + logabsgamma = log(abs(gamma(x))) end function logabsgamma - + BEGIN_PROVIDER [ integer, NSOMOMax] &BEGIN_PROVIDER [ integer, NCSFMax] &BEGIN_PROVIDER [ integer*8, NMO] @@ -51,60 +48,42 @@ if(cfg_seniority_index(i+2) > ncfgpersomo) then ncfgpersomo = cfg_seniority_index(i+2) else - ! l = i+k+2 - ! Loop over l with a constraint to ensure that l <= size(cfg_seniority_index,1)-1 - ! Old version commented just below - do l = min(size(cfg_seniority_index,1)-1, i+2), size(cfg_seniority_index,1)-1, 2 - if (cfg_seniority_index(l) >= ncfgpersomo) then - ncfgpersomo = cfg_seniority_index(l) - endif + k = 0 + do while(cfg_seniority_index(i+2+k) < ncfgpersomo) + k = k + 2 + ncfgpersomo = cfg_seniority_index(i+2+k) enddo - !k = 0 - !if ((i+2+k) < size(cfg_seniority_index,1)) then - ! do while(cfg_seniority_index(i+2+k) < ncfgpersomo) - ! k = k + 2 - ! if ((i+2+k) >= size(cfg_seniority_index,1)) then - ! exit - ! endif - ! ncfgpersomo = cfg_seniority_index(i+2+k) - ! enddo - !endif endif endif ncfg = ncfgpersomo - ncfgprev - if(i .EQ. 0 .OR. i .EQ. 1) then - dimcsfpercfg = 1 - elseif( i .EQ. 3) then - dimcsfpercfg = 2 + if(iand(MS,1) .EQ. 0) then + !dimcsfpercfg = max(1,nint((binom(i,i/2)-binom(i,i/2+1)))) + binom1 = dexp(logabsgamma(1.0d0*(i+1)) & + - logabsgamma(1.0d0*((i/2)+1)) & + - logabsgamma(1.0d0*(i-((i/2))+1))); + binom2 = dexp(logabsgamma(1.0d0*(i+1)) & + - logabsgamma(1.0d0*(((i/2)+1)+1)) & + - logabsgamma(1.0d0*(i-((i/2)+1)+1))); + dimcsfpercfg = max(1,nint(binom1 - binom2)) else - if(iand(MS,1) .EQ. 0) then - dimcsfpercfg = max(1,nint((binom(i,i/2)-binom(i,i/2+1)))) - else - dimcsfpercfg = max(1,nint((binom(i,(i+1)/2)-binom(i,(i+3)/2)))) - endif + !dimcsfpercfg = max(1,nint((binom(i,(i+1)/2)-binom(i,(i+3)/2)))) + binom1 = dexp(logabsgamma(1.0d0*(i+1)) & + - logabsgamma(1.0d0*(((i+1)/2)+1)) & + - logabsgamma(1.0d0*(i-(((i+1)/2))+1))); + binom2 = dexp(logabsgamma(1.0d0*(i+1)) & + - logabsgamma(1.0d0*((((i+3)/2)+1)+1)) & + - logabsgamma(1.0d0*(i-(((i+3)/2)+1)+1))); + dimcsfpercfg = max(1,nint(binom1 - binom2)) endif n_CSF += ncfg * dimcsfpercfg if(cfg_seniority_index(i+2) > ncfgprev) then ncfgprev = cfg_seniority_index(i+2) else - ! l = i+k+2 - ! Loop over l with a constraint to ensure that l <= size(cfg_seniority_index,1)-1 - ! Old version commented just below - do l = min(size(cfg_seniority_index,1)-1, i+2), size(cfg_seniority_index,1)-1, 2 - if (cfg_seniority_index(l) >= ncfgprev) then - ncfgprev = cfg_seniority_index(l) - endif + k = 0 + do while(cfg_seniority_index(i+2+k) < ncfgprev) + k = k + 2 + ncfgprev = cfg_seniority_index(i+2+k) enddo - !k = 0 - !if ((i+2+k) < size(cfg_seniority_index,1)) then - ! do while(cfg_seniority_index(i+2+k) < ncfgprev) - ! k = k + 2 - ! if ((i+2+k) >= size(cfg_seniority_index,1)) then - ! exit - ! endif - ! ncfgprev = cfg_seniority_index(i+2+k) - ! enddo - !endif endif enddo END_PROVIDER diff --git a/src/dav_general_mat/dav_diag_dressed_ext_rout.irp.f b/src/dav_general_mat/dav_diag_dressed_ext_rout.irp.f index 243e9995..2f3d7f80 100644 --- a/src/dav_general_mat/dav_diag_dressed_ext_rout.irp.f +++ b/src/dav_general_mat/dav_diag_dressed_ext_rout.irp.f @@ -1,5 +1,5 @@ -subroutine davidson_general_ext_rout_diag_dressed(u_in,H_jj,Dress_jj,energies,sze,N_st,N_st_diag_in,converged,hcalc) +subroutine davidson_general_ext_rout(u_in,H_jj,Dress_jj,energies,sze,N_st,N_st_diag_in,converged,hcalc) use mmap_module implicit none BEGIN_DOC @@ -412,6 +412,36 @@ subroutine davidson_general_ext_rout_diag_dressed(u_in,H_jj,Dress_jj,energies,sz FREE nthreads_davidson end +subroutine hcalc_template(v,u,N_st,sze) + use bitmasks + implicit none + BEGIN_DOC + ! Template of routine for the application of H + ! + ! Here, it is done with the Hamiltonian matrix + ! + ! on the set of determinants of psi_det + ! + ! Computes $v = H | u \rangle$ + ! + END_DOC + integer, intent(in) :: N_st,sze + double precision, intent(in) :: u(sze,N_st) + double precision, intent(inout) :: v(sze,N_st) + integer :: i,j,istate + v = 0.d0 + do istate = 1, N_st + do i = 1, sze + do j = 1, sze + v(i,istate) += H_matrix_all_dets(j,i) * u(j,istate) + enddo + enddo + do i = 1, sze + v(i,istate) += u(i,istate) * nuclear_repulsion + enddo + enddo +end + subroutine dressing_diag_uv(v,u,dress_diag,N_st,sze) implicit none BEGIN_DOC diff --git a/src/dav_general_mat/dav_ext_rout.irp.f b/src/dav_general_mat/dav_ext_rout.irp.f index 868d928b..aee4ba09 100644 --- a/src/dav_general_mat/dav_ext_rout.irp.f +++ b/src/dav_general_mat/dav_ext_rout.irp.f @@ -247,8 +247,8 @@ subroutine davidson_general_ext_rout(u_in,H_jj,energies,sze,N_st,N_st_diag_in,co if (state_following) then overlap = -1.d0 - do k=1,shift2 - do i=1,shift2 + do i=1,shift2 + do k=1,shift2 overlap(k,i) = dabs(y(k,i)) enddo enddo diff --git a/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f b/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f new file mode 100644 index 00000000..c5127861 --- /dev/null +++ b/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f @@ -0,0 +1,608 @@ + +! --- + +subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N_st, N_st_diag_in, converged, hcalc) + + use mmap_module + + BEGIN_DOC + ! Generic modified-Davidson diagonalization + ! + ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson + ! + ! u_in : guess coefficients on the various states. Overwritten on exit by right eigenvectors + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! N_st_diag_in : Number of states in which H is diagonalized. Assumed > N_st + ! + ! Initial guess vectors are not necessarily orthonormal + ! + ! hcalc subroutine to compute W = H U (see routine hcalc_template for template of input/output) + END_DOC + + implicit none + + integer, intent(in) :: sze, N_st, N_st_diag_in + double precision, intent(in) :: H_jj(sze) + logical, intent(inout) :: converged + double precision, intent(inout) :: u_in(sze,N_st_diag_in) + double precision, intent(out) :: energies(N_st) + external hcalc + + character*(16384) :: write_buffer + integer :: iter, N_st_diag + integer :: i, j, k, m + integer :: iter2, itertot + logical :: disk_based + integer :: shift, shift2, itermax + integer :: nproc_target + integer :: order(N_st_diag_in) + double precision :: to_print(2,N_st) + double precision :: r1, r2, alpha + double precision :: cpu, wall + double precision :: cmax + double precision :: energy_shift(N_st_diag_in*davidson_sze_max) + double precision, allocatable :: U(:,:) + double precision, allocatable :: y(:,:), h(:,:), lambda(:) + double precision, allocatable :: residual_norm(:) + + integer :: i_omax + double precision :: lambda_tmp + double precision, allocatable :: U_tmp(:), overlap(:) + + double precision, allocatable :: W(:,:) + !double precision, pointer :: W(:,:) + double precision, external :: u_dot_v, u_dot_u + + + include 'constants.include.F' + + N_st_diag = N_st_diag_in + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, y, h, lambda + if(N_st_diag*3 > sze) then + print *, 'error in Davidson :' + print *, 'Increase n_det_max_full to ', N_st_diag*3 + stop -1 + endif + + itermax = max(2, min(davidson_sze_max, sze/N_st_diag)) + 1 + + provide threshold_nonsym_davidson + call write_time(6) + write(6,'(A)') '' + write(6,'(A)') 'Davidson Diagonalization' + write(6,'(A)') '------------------------' + write(6,'(A)') '' + + + ! Find max number of cores to fit in memory + ! ----------------------------------------- + + nproc_target = nproc + double precision :: rss + integer :: maxab + maxab = sze + + m=1 + disk_based = .False. + call resident_memory(rss) + do + r1 = 8.d0 * &! bytes + ( dble(sze)*(N_st_diag*itermax) &! U + + 1.d0*dble(sze*m)*(N_st_diag*itermax) &! W + + 2.d0*(N_st_diag*itermax)**2 &! h,y + + 2.d0*(N_st_diag*itermax) &! s2,lambda + + 1.d0*(N_st_diag) &! residual_norm + ! In H_S2_u_0_nstates_zmq + + 3.d0*(N_st_diag*N_det) &! u_t, v_t, s_t on collector + + 3.d0*(N_st_diag*N_det) &! u_t, v_t, s_t on slave + + 0.5d0*maxab &! idx0 in H_S2_u_0_nstates_openmp_work_* + + nproc_target * &! In OMP section + ( 1.d0*(N_int*maxab) &! buffer + + 3.5d0*(maxab) ) &! singles_a, singles_b, doubles, idx + ) / 1024.d0**3 + + if(nproc_target == 0) then + call check_mem(r1, irp_here) + nproc_target = 1 + exit + endif + + if(r1+rss < qp_max_mem) then + exit + endif + + if(itermax > 4) then + itermax = itermax - 1 + else if (m==1.and.disk_based_davidson) then + m = 0 + disk_based = .True. + itermax = 6 + else + nproc_target = nproc_target - 1 + endif + + enddo + + nthreads_davidson = nproc_target + TOUCH nthreads_davidson + + call write_int(6, N_st, 'Number of states') + call write_int(6, N_st_diag, 'Number of states in diagonalization') + call write_int(6, sze, 'Number of basis functions') + call write_int(6, nproc_target, 'Number of threads for diagonalization') + call write_double(6, r1, 'Memory(Gb)') + if(disk_based) then + print *, 'Using swap space to reduce RAM' + endif + + !--------------- + + write(6,'(A)') '' + write_buffer = '=====' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ ===========' + enddo + write(6,'(A)') write_buffer(1:6+41*N_st) + write_buffer = 'Iter' + do i=1,N_st + write_buffer = trim(write_buffer)//' Energy Residual ' + enddo + write(6,'(A)') write_buffer(1:6+41*N_st) + write_buffer = '=====' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ ===========' + enddo + write(6,'(A)') write_buffer(1:6+41*N_st) + + ! --- + + + allocate( W(sze,N_st_diag*itermax) ) + + allocate( & + ! Large + U(sze,N_st_diag*itermax), & + ! Small + h(N_st_diag*itermax,N_st_diag*itermax), & + y(N_st_diag*itermax,N_st_diag*itermax), & + lambda(N_st_diag*itermax), & + residual_norm(N_st_diag) & + ) + + U = 0.d0 + h = 0.d0 + y = 0.d0 + lambda = 0.d0 + residual_norm = 0.d0 + + + ASSERT (N_st > 0) + ASSERT (N_st_diag >= N_st) + ASSERT (sze > 0) + + ! Davidson iterations + ! =================== + + converged = .False. + + ! Initialize from N_st to N_st_diag with gaussian random numbers + ! to be sure to have overlap with any eigenvectors + do k = N_st+1, N_st_diag + u_in(k,k) = 10.d0 + do i = 1, sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + u_in(i,k) = r1*dcos(r2) + enddo + enddo + ! Normalize all states + do k = 1, N_st_diag + call normalize(u_in(1,k), sze) + enddo + + ! Copy from the guess input "u_in" to the working vectors "U" + do k = 1, N_st_diag + do i = 1, sze + U(i,k) = u_in(i,k) + enddo + enddo + + ! --- + + itertot = 0 + + do while (.not.converged) + + itertot = itertot + 1 + if(itertot == 8) then + exit + endif + + do iter = 1, itermax-1 + + shift = N_st_diag * (iter-1) + shift2 = N_st_diag * iter + + if( (iter > 1) .or. (itertot == 1) ) then + + ! Gram-Schmidt to orthogonalize all new guess with the previous vectors + call ortho_qr(U, size(U, 1), sze, shift2) + call ortho_qr(U, size(U, 1), sze, shift2) + + ! W = H U + call hcalc(W(1,shift+1), U(1,shift+1), N_st_diag, sze) + + else + + ! Already computed in update below + continue + endif + + ! Compute h_kl = = + ! ------------------------------------------- + call dgemm( 'T', 'N', shift2, shift2, sze, 1.d0 & + , U, size(U, 1), W, size(W, 1) & + , 0.d0, h, size(h, 1) ) + + + ! Diagonalize h y = lambda y + ! --------------------------- + call diag_nonsym_right(shift2, h(1,1), size(h, 1), y(1,1), size(y, 1), lambda(1), size(lambda, 1)) + + + ! Express eigenvectors of h in the determinant basis: + ! --------------------------------------------------- + + ! y(:,k) = rk + ! U(:,k) = Bk + ! U(:,shift2+k) = Rk = Bk x rk + call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 & + , U, size(U, 1), y, size(y, 1) & + , 0.d0, U(1,shift2+1), size(U, 1) ) + + do k = 1, N_st_diag + call normalize(U(1,shift2+k), sze) + enddo + + ! --- + ! select the max overlap + + ! + ! start test ------------------------------------------------------------------------ + ! + !double precision, allocatable :: Utest(:,:), Otest(:) + !allocate( Utest(sze,shift2), Otest(shift2) ) + + !call dgemm( 'N', 'N', sze, shift2, shift2, 1.d0 & + ! , U, size(U, 1), y, size(y, 1), 0.d0, Utest(1,1), size(Utest, 1) ) + !do k = 1, shift2 + ! call normalize(Utest(1,k), sze) + !enddo + !do j = 1, sze + ! write(455, '(100(1X, F16.10))') (Utest(j,k), k=1,shift2) + !enddo + + !do k = 1, shift2 + ! Otest(k) = 0.d0 + ! do i = 1, sze + ! Otest(k) += Utest(i,k) * u_in(i,1) + ! enddo + ! Otest(k) = dabs(Otest(k)) + ! print *, ' Otest =', k, Otest(k), lambda(k) + !enddo + + !deallocate(Utest, Otest) + ! + ! end test ------------------------------------------------------------------------ + ! + + + allocate( overlap(N_st_diag) ) + + do k = 1, N_st_diag + overlap(k) = 0.d0 + do i = 1, sze + overlap(k) = overlap(k) + U(i,shift2+k) * u_in(i,1) + enddo + overlap(k) = dabs(overlap(k)) + !print *, ' overlap =', k, overlap(k) + enddo + + lambda_tmp = 0.d0 + do k = 1, N_st_diag + if(overlap(k) .gt. lambda_tmp) then + i_omax = k + lambda_tmp = overlap(k) + endif + enddo + deallocate(overlap) + if( lambda_tmp .lt. 0.8d0) then + print *, ' very small overlap..' + print*, ' max overlap = ', lambda_tmp, i_omax + stop + endif + +! lambda_tmp = lambda(1) +! lambda(1) = lambda(i_omax) +! lambda(i_omax) = lambda_tmp +! +! allocate( U_tmp(sze) ) +! do i = 1, sze +! U_tmp(i) = U(i,shift2+1) +! U(i,shift2+1) = U(i,shift2+i_omax) +! U(i,shift2+i_omax) = U_tmp(i) +! enddo +! deallocate(U_tmp) +! +! allocate( U_tmp(N_st_diag*itermax) ) +! do i = 1, shift2 +! U_tmp(i) = y(i,1) +! y(i,1) = y(i,i_omax) +! y(i,i_omax) = U_tmp(i) +! enddo +! deallocate(U_tmp) + + ! --- + + !do k = 1, N_st_diag + ! call normalize(U(1,shift2+k), sze) + !enddo + + ! --- + + ! y(:,k) = rk + ! W(:,k) = H x Bk + ! W(:,shift2+k) = H x Bk x rk + ! = Wk + call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 & + , W, size(W, 1), y, size(y, 1) & + , 0.d0, W(1,shift2+1), size(W, 1) ) + + ! --- + + ! Compute residual vector and davidson step + ! ----------------------------------------- + + !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,k) + do k = 1, N_st_diag + do i = 1, sze + U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k)) / max(H_jj(i)-lambda(k), 1.d-2) + enddo + !if(k <= N_st) then + ! residual_norm(k) = u_dot_u(U(1,shift2+k), sze) + ! to_print(1,k) = lambda(k) + ! to_print(2,k) = residual_norm(k) + !endif + enddo + !$OMP END PARALLEL DO + residual_norm(1) = u_dot_u(U(1,shift2+i_omax), sze) + to_print(1,1) = lambda(i_omax) + to_print(2,1) = residual_norm(1) + + + if( (itertot > 1) .and. (iter == 1) ) then + !don't print + continue + else + write(*, '(1X, I3, 1X, 100(1X, F16.10, 1X, F16.10, 1X, F16.10))') iter-1, to_print(1:2,1:N_st) + endif + + ! Check convergence + if(iter > 1) then + converged = dabs(maxval(residual_norm(1:N_st))) < threshold_nonsym_davidson + endif + + do k = 1, N_st + if(residual_norm(k) > 1.e8) then + print *, 'Davidson failed' + stop -1 + endif + enddo + if(converged) then + exit + endif + + logical, external :: qp_stop + if(qp_stop()) then + converged = .True. + exit + endif + + enddo ! loop over iter + + + ! Re-contract U and update W + ! -------------------------------- + + call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 & + , W, size(W, 1), y, size(y, 1) & + , 0.d0, u_in, size(u_in, 1) ) + do k = 1, N_st_diag + do i = 1, sze + W(i,k) = u_in(i,k) + enddo + enddo + + call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 & + , U, size(U, 1), y, size(y, 1) & + , 0.d0, u_in, size(u_in, 1) ) + do k = 1, N_st_diag + do i = 1, sze + U(i,k) = u_in(i,k) + enddo + enddo + + call ortho_qr(U, size(U, 1), sze, N_st_diag) + call ortho_qr(U, size(U, 1), sze, N_st_diag) + do j = 1, N_st_diag + k = 1 + do while( (k < sze) .and. (U(k,j) == 0.d0) ) + k = k+1 + enddo + if(U(k,j) * u_in(k,j) < 0.d0) then + do i = 1, sze + W(i,j) = -W(i,j) + enddo + endif + enddo + + enddo ! loop over while + + ! --- + + do k = 1, N_st + energies(k) = lambda(k) + enddo + write_buffer = '=====' + do i = 1, N_st + write_buffer = trim(write_buffer)//' ================ ===========' + enddo + write(6,'(A)') trim(write_buffer) + write(6,'(A)') '' + call write_time(6) + + deallocate(W) + deallocate(U, h, y, lambda, residual_norm) + + FREE nthreads_davidson + +end subroutine davidson_general_ext_rout_nonsym_b1space + +! --- + +subroutine diag_nonsym_right(n, A, A_ldim, V, V_ldim, energy, E_ldim) + + implicit none + + integer, intent(in) :: n, A_ldim, V_ldim, E_ldim + double precision, intent(in) :: A(A_ldim,n) + double precision, intent(out) :: energy(E_ldim), V(V_ldim,n) + + character*1 :: JOBVL, JOBVR, BALANC, SENSE + integer :: i, j + integer :: ILO, IHI, lda, ldvl, ldvr, LWORK, INFO + double precision :: ABNRM + integer, allocatable :: iorder(:), IWORK(:) + double precision, allocatable :: WORK(:), SCALE_array(:), RCONDE(:), RCONDV(:) + double precision, allocatable :: Atmp(:,:), WR(:), WI(:), VL(:,:), VR(:,:), Vtmp(:) + double precision, allocatable :: energy_loc(:), V_loc(:,:) + + allocate( Atmp(n,n), WR(n), WI(n), VL(1,1), VR(n,n) ) + do i = 1, n + do j = 1, n + Atmp(j,i) = A(j,i) + enddo + enddo + + JOBVL = "N" ! computes the left eigenvectors + JOBVR = "V" ! computes the right eigenvectors + BALANC = "B" ! Diagonal scaling and Permutation for optimization + SENSE = "V" ! Determines which reciprocal condition numbers are computed + lda = n + ldvr = n + ldvl = 1 + + allocate( WORK(1), SCALE_array(n), RCONDE(n), RCONDV(n), IWORK(2*n-2) ) + + LWORK = -1 ! to ask for the optimal size of WORK + call dgeevx( BALANC, JOBVL, JOBVR, SENSE & ! CHARACTERS + , n, Atmp, lda & ! MATRIX TO DIAGONALIZE + , WR, WI & ! REAL AND IMAGINARY PART OF EIGENVALUES + , VL, ldvl, VR, ldvr & ! LEFT AND RIGHT EIGENVECTORS + , ILO, IHI, SCALE_array, ABNRM, RCONDE, RCONDV & ! OUTPUTS OF OPTIMIZATION + , WORK, LWORK, IWORK, INFO ) + + if(INFO .ne. 0) then + print*, 'dgeevx failed !!', INFO + stop + endif + + LWORK = max(int(work(1)), 1) ! this is the optimal size of WORK + deallocate(WORK) + allocate(WORK(LWORK)) + call dgeevx( BALANC, JOBVL, JOBVR, SENSE & + , n, Atmp, lda & + , WR, WI & + , VL, ldvl, VR, ldvr & + , ILO, IHI, SCALE_array, ABNRM, RCONDE, RCONDV & + , WORK, LWORK, IWORK, INFO ) + if(INFO .ne. 0) then + print*, 'dgeevx failed !!', INFO + stop + endif + + deallocate( WORK, SCALE_array, RCONDE, RCONDV, IWORK ) + deallocate( VL, Atmp ) + + + allocate( energy_loc(n), V_loc(n,n) ) + energy_loc = 0.d0 + V_loc = 0.d0 + + i = 1 + do while(i .le. n) + +! print*, i, WR(i), WI(i) + + if( dabs(WI(i)) .gt. 1e-7 ) then + + print*, ' Found an imaginary component to eigenvalue' + print*, ' Re(i) + Im(i)', i, WR(i), WI(i) + + energy_loc(i) = WR(i) + do j = 1, n + V_loc(j,i) = WR(i) * VR(j,i) - WI(i) * VR(j,i+1) + enddo + energy_loc(i+1) = WI(i) + do j = 1, n + V_loc(j,i+1) = WR(i) * VR(j,i+1) + WI(i) * VR(j,i) + enddo + i = i + 2 + + else + + energy_loc(i) = WR(i) + do j = 1, n + V_loc(j,i) = VR(j,i) + enddo + i = i + 1 + + endif + + enddo + + deallocate(WR, WI, VR) + + + ! ordering +! do j = 1, n +! write(444, '(100(1X, F16.10))') (V_loc(j,i), i=1,5) +! enddo + allocate( iorder(n) ) + do i = 1, n + iorder(i) = i + enddo + call dsort(energy_loc, iorder, n) + do i = 1, n + energy(i) = energy_loc(i) + do j = 1, n + V(j,i) = V_loc(j,iorder(i)) + enddo + enddo + deallocate(iorder) +! do j = 1, n +! write(445, '(100(1X, F16.10))') (V_loc(j,i), i=1,5) +! enddo + deallocate(V_loc, energy_loc) + +end subroutine diag_nonsym_right + +! --- + diff --git a/src/dav_general_mat/dav_general.irp.f b/src/dav_general_mat/dav_general.irp.f index aa4a2eb3..39cb68bb 100644 --- a/src/dav_general_mat/dav_general.irp.f +++ b/src/dav_general_mat/dav_general.irp.f @@ -258,8 +258,8 @@ subroutine davidson_general(u_in,H_jj,energies,dim_in,sze,N_st,N_st_diag_in,conv if (state_following) then overlap = -1.d0 - do k=1,shift2 - do i=1,shift2 + do i=1,shift2 + do k=1,shift2 overlap(k,i) = dabs(y(k,i)) enddo enddo diff --git a/src/davidson/EZFIO.cfg b/src/davidson/EZFIO.cfg index 92c41b4c..de814b94 100644 --- a/src/davidson/EZFIO.cfg +++ b/src/davidson/EZFIO.cfg @@ -4,6 +4,12 @@ doc: Thresholds of Davidson's algorithm if threshold_davidson_from_pt2 is false. interface: ezfio,provider,ocaml default: 1.e-10 +[threshold_nonsym_davidson] +type: Threshold +doc: Thresholds of non-symetric Davidson's algorithm +interface: ezfio,provider,ocaml +default: 1.e-5 + [threshold_davidson_from_pt2] type: logical doc: Thresholds of Davidson's algorithm is set to E(rPT2)*threshold_davidson_from_pt2 diff --git a/src/davidson/davidson_parallel.irp.f b/src/davidson/davidson_parallel.irp.f index e627dfc9..8fd023da 100644 --- a/src/davidson/davidson_parallel.irp.f +++ b/src/davidson/davidson_parallel.irp.f @@ -508,7 +508,7 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze) endif - call set_multiple_levels_omp(.True.) + call omp_set_max_active_levels(5) !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(2) PRIVATE(ithread) ithread = omp_get_thread_num() diff --git a/src/davidson/davidson_parallel_csf.irp.f b/src/davidson/davidson_parallel_csf.irp.f index d8e9bffa..fe651b1d 100644 --- a/src/davidson/davidson_parallel_csf.irp.f +++ b/src/davidson/davidson_parallel_csf.irp.f @@ -464,8 +464,7 @@ subroutine H_u_0_nstates_zmq(v_0,u_0,N_st,sze) print *, irp_here, ': Failed in zmq_set_running' endif - call set_multiple_levels_omp(.True.) - + call omp_set_max_active_levels(4) !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(2) PRIVATE(ithread) ithread = omp_get_thread_num() if (ithread == 0 ) then diff --git a/src/davidson/davidson_parallel_nos2.irp.f b/src/davidson/davidson_parallel_nos2.irp.f index 597b001f..84cbe3af 100644 --- a/src/davidson/davidson_parallel_nos2.irp.f +++ b/src/davidson/davidson_parallel_nos2.irp.f @@ -464,8 +464,7 @@ subroutine H_u_0_nstates_zmq(v_0,u_0,N_st,sze) print *, irp_here, ': Failed in zmq_set_running' endif - call set_multiple_levels_omp(.True.) - + call omp_set_max_active_levels(4) !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(2) PRIVATE(ithread) ithread = omp_get_thread_num() if (ithread == 0 ) then diff --git a/src/davidson/diagonalization_hcsf_dressed.irp.f b/src/davidson/diagonalization_hcsf_dressed.irp.f index 7aaaa842..b6f438a0 100644 --- a/src/davidson/diagonalization_hcsf_dressed.irp.f +++ b/src/davidson/diagonalization_hcsf_dressed.irp.f @@ -124,7 +124,7 @@ subroutine davidson_diag_csf_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N stop -1 endif - itermax = max(2,min(davidson_sze_max, sze_csf/N_st_diag))+1 + itermax = max(2,min(davidson_sze_max, sze/N_st_diag))+1 itertot = 0 if (state_following) then @@ -263,20 +263,29 @@ subroutine davidson_diag_csf_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N ! =================== converged = .False. - call convertWFfromDETtoCSF(N_st_diag,u_in(1,1),U_csf(1,1)) + do k=N_st+1,N_st_diag - do i=1,sze_csf + do i=1,sze call random_number(r1) call random_number(r2) r1 = dsqrt(-2.d0*dlog(r1)) r2 = dtwo_pi*r2 - U_csf(i,k) = r1*dcos(r2) * u_csf(i,k-N_st) + u_in(i,k) = r1*dcos(r2) * u_in(i,k-N_st) enddo - U_csf(k,k) = u_csf(k,k) + 10.d0 + u_in(k,k) = u_in(k,k) + 10.d0 enddo do k=1,N_st_diag - call normalize(U_csf(1,k),sze_csf) + call normalize(u_in(1,k),sze) enddo + + do k=1,N_st_diag + do i=1,sze + U(i,k) = u_in(i,k) + enddo + enddo + + ! Make random verctors eigenstates of S2 + call convertWFfromDETtoCSF(N_st_diag,U(1,1),U_csf(1,1)) call convertWFfromCSFtoDET(N_st_diag,U_csf(1,1),U(1,1)) do while (.not.converged) @@ -290,7 +299,7 @@ subroutine davidson_diag_csf_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N shift = N_st_diag*(iter-1) shift2 = N_st_diag*iter -! if ((iter > 1).or.(itertot == 1)) then + if ((iter > 1).or.(itertot == 1)) then ! Compute |W_k> = \sum_i |i> ! ----------------------------------- @@ -300,10 +309,10 @@ subroutine davidson_diag_csf_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N else call H_u_0_nstates_openmp(W,U,N_st_diag,sze) endif -! else -! ! Already computed in update below -! continue -! endif + else + ! Already computed in update below + continue + endif if (dressing_state > 0) then @@ -499,8 +508,17 @@ subroutine davidson_diag_csf_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N enddo - ! Re-contract U - ! ------------- + ! Re-contract U and update W + ! -------------------------------- + + call dgemm('N','N', sze_csf, N_st_diag, shift2, 1.d0, & + W_csf, size(W_csf,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) + do k=1,N_st_diag + do i=1,sze_csf + W_csf(i,k) = u_in(i,k) + enddo + enddo + call convertWFfromCSFtoDET(N_st_diag,W_csf,W) call dgemm('N','N', sze_csf, N_st_diag, shift2, 1.d0, & U_csf, size(U_csf,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) diff --git a/src/davidson/diagonalization_hs2_dressed.irp.f b/src/davidson/diagonalization_hs2_dressed.irp.f index d37b7386..1a27a75e 100644 --- a/src/davidson/diagonalization_hs2_dressed.irp.f +++ b/src/davidson/diagonalization_hs2_dressed.irp.f @@ -349,7 +349,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ shift = N_st_diag*(iter-1) shift2 = N_st_diag*iter -! if ((iter > 1).or.(itertot == 1)) then + if ((iter > 1).or.(itertot == 1)) then ! Compute |W_k> = \sum_i |i> ! ----------------------------------- @@ -359,10 +359,10 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ call H_S2_u_0_nstates_openmp(W(1,shift+1),S_d,U(1,shift+1),N_st_diag,sze) endif S(1:sze,shift+1:shift+N_st_diag) = real(S_d(1:sze,1:N_st_diag)) -! else -! ! Already computed in update below -! continue -! endif + else + ! Already computed in update below + continue + endif if (dressing_state > 0) then diff --git a/src/davidson/diagonalize_ci.irp.f b/src/davidson/diagonalize_ci.irp.f index 6930cc07..fb991b65 100644 --- a/src/davidson/diagonalize_ci.irp.f +++ b/src/davidson/diagonalize_ci.irp.f @@ -1,19 +1,9 @@ -BEGIN_PROVIDER [ character*(3), sigma_vector_algorithm ] - implicit none - BEGIN_DOC - ! If 'det', use in Davidson - ! - ! If 'cfg', use in Davidson - END_DOC - sigma_vector_algorithm = 'det' -END_PROVIDER BEGIN_PROVIDER [ double precision, CI_energy, (N_states_diag) ] implicit none BEGIN_DOC ! :c:data:`n_states` lowest eigenvalues of the |CI| matrix END_DOC - PROVIDE distributed_davidson integer :: j character*(8) :: st @@ -71,18 +61,9 @@ END_PROVIDER if (diag_algorithm == "Davidson") then if (do_csf) then - if (sigma_vector_algorithm == 'det') then - call davidson_diag_H_csf(psi_det,CI_eigenvectors, & - size(CI_eigenvectors,1),CI_electronic_energy, & - N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged) -! else if (sigma_vector_algorithm == 'cfg') then -! call davidson_diag_H_csf(psi_det,CI_eigenvectors, & -! size(CI_eigenvectors,1),CI_electronic_energy, & -! N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged) -! else -! print *, irp_here -! stop 'bug' - endif + call davidson_diag_H_csf(psi_det,CI_eigenvectors, & + size(CI_eigenvectors,1),CI_electronic_energy, & + N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged) else call davidson_diag_HS2(psi_det,CI_eigenvectors, CI_s2, & size(CI_eigenvectors,1),CI_electronic_energy, & @@ -266,7 +247,6 @@ subroutine diagonalize_CI ! eigenstates of the |CI| matrix. END_DOC integer :: i,j - PROVIDE distributed_davidson do j=1,N_states do i=1,N_det psi_coef(i,j) = CI_eigenvectors(i,j) diff --git a/src/two_body_rdm/print_e_components.irp.f b/src/davidson/print_e_components.irp.f similarity index 100% rename from src/two_body_rdm/print_e_components.irp.f rename to src/davidson/print_e_components.irp.f diff --git a/src/davidson/u0_hs2_u0.irp.f b/src/davidson/u0_hs2_u0.irp.f index 38fb56bd..8f7bf06b 100644 --- a/src/davidson/u0_hs2_u0.irp.f +++ b/src/davidson/u0_hs2_u0.irp.f @@ -203,7 +203,7 @@ subroutine H_S2_u_0_nstates_openmp_work_$N_int(v_t,s_t,u_t,N_st,sze,istart,iend, integer, allocatable :: doubles(:) integer, allocatable :: singles_a(:) integer, allocatable :: singles_b(:) - integer, allocatable :: idx(:), buffer_lrow(:), idx0(:) + integer, allocatable :: idx(:), idx0(:) integer :: maxab, n_singles_a, n_singles_b, kcol_prev integer*8 :: k8 logical :: compute_singles @@ -253,7 +253,7 @@ compute_singles=.True. !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, & !$OMP lcol, lrow, l_a, l_b, utl, kk, u_is_sparse, & !$OMP buffer, doubles, n_doubles, umax, & - !$OMP tmp_det2, hij, sij, idx, buffer_lrow, l, kcol_prev, & + !$OMP tmp_det2, hij, sij, idx, l, kcol_prev, & !$OMP singles_a, n_singles_a, singles_b, ratio, & !$OMP n_singles_b, k8, last_found,left,right,right_max) @@ -264,7 +264,7 @@ compute_singles=.True. singles_a(maxab), & singles_b(maxab), & doubles(maxab), & - idx(maxab), buffer_lrow(maxab), utl(N_st,block_size)) + idx(maxab), utl(N_st,block_size)) kcol_prev=-1 @@ -332,20 +332,18 @@ compute_singles=.True. l_a = psi_bilinear_matrix_columns_loc(lcol) ASSERT (l_a <= N_det) + !DIR$ UNROLL(8) + !DIR$ LOOP COUNT avg(50000) do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol) lrow = psi_bilinear_matrix_rows(l_a) ASSERT (lrow <= N_det_alpha_unique) - buffer_lrow(j) = lrow + buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) ! hot spot ASSERT (l_a <= N_det) idx(j) = l_a l_a = l_a+1 enddo - - do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol) - buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, buffer_lrow(j)) ! hot spot - enddo j = j-1 call get_all_spin_singles_$N_int( & @@ -791,7 +789,7 @@ compute_singles=.True. end do !$OMP END DO - deallocate(buffer, singles_a, singles_b, doubles, idx, buffer_lrow, utl) + deallocate(buffer, singles_a, singles_b, doubles, idx, utl) !$OMP END PARALLEL end diff --git a/src/davidson_dressed/diagonalize_ci.irp.f b/src/davidson_dressed/diagonalize_ci.irp.f index b58ce9c0..7619532a 100644 --- a/src/davidson_dressed/diagonalize_ci.irp.f +++ b/src/davidson_dressed/diagonalize_ci.irp.f @@ -12,7 +12,7 @@ BEGIN_PROVIDER [ double precision, CI_energy_dressed, (N_states_diag) ] enddo do j=1,min(N_det,N_states) write(st,'(I4)') j - call write_double(6,CI_energy_dressed(j),'Energy dressed of state '//trim(st)) + call write_double(6,CI_energy_dressed(j),'Energy of state '//trim(st)) call write_double(6,CI_eigenvectors_s2_dressed(j),'S^2 of state '//trim(st)) enddo @@ -21,201 +21,133 @@ END_PROVIDER BEGIN_PROVIDER [ double precision, CI_electronic_energy_dressed, (N_states_diag) ] &BEGIN_PROVIDER [ double precision, CI_eigenvectors_dressed, (N_det,N_states_diag) ] &BEGIN_PROVIDER [ double precision, CI_eigenvectors_s2_dressed, (N_states_diag) ] - BEGIN_DOC - ! Eigenvectors/values of the CI matrix - END_DOC - implicit none - double precision :: ovrlp,u_dot_v - integer :: i_good_state - integer, allocatable :: index_good_state_array(:) - logical, allocatable :: good_state_array(:) - double precision, allocatable :: s2_values_tmp(:) - integer :: i_other_state - double precision, allocatable :: eigenvectors(:,:), eigenvectors_s2(:,:), eigenvalues(:) - integer :: i_state - double precision :: e_0 - integer :: i,j,k,mrcc_state - double precision, allocatable :: s2_eigvalues(:) - double precision, allocatable :: e_array(:) - integer, allocatable :: iorder(:) - logical :: converged - logical :: do_csf - - PROVIDE threshold_davidson nthreads_davidson - ! Guess values for the "N_states" states of the CI_eigenvectors_dressed - do j=1,min(N_states,N_det) - do i=1,N_det - CI_eigenvectors_dressed(i,j) = psi_coef(i,j) - enddo - enddo - - do j=min(N_states,N_det)+1,N_states_diag - do i=1,N_det - CI_eigenvectors_dressed(i,j) = 0.d0 - enddo - enddo - - do_csf = s2_eig .and. only_expected_s2 .and. csf_based - - if (diag_algorithm == "Davidson") then - - do j=1,min(N_states,N_det) - do i=1,N_det - CI_eigenvectors_dressed(i,j) = psi_coef(i,j) + BEGIN_DOC + ! Eigenvectors/values of the CI matrix + END_DOC + implicit none + double precision :: ovrlp,u_dot_v + integer :: i_good_state + integer, allocatable :: index_good_state_array(:) + logical, allocatable :: good_state_array(:) + double precision, allocatable :: s2_values_tmp(:) + integer :: i_other_state + double precision, allocatable :: eigenvectors(:,:), eigenvectors_s2(:,:), eigenvalues(:) + integer :: i_state + double precision :: e_0 + integer :: i,j,k,mrcc_state + double precision, allocatable :: s2_eigvalues(:) + double precision, allocatable :: e_array(:) + integer, allocatable :: iorder(:) + + PROVIDE threshold_davidson nthreads_davidson + ! Guess values for the "N_states" states of the CI_eigenvectors_dressed + do j=1,min(N_states,N_det) + do i=1,N_det + CI_eigenvectors_dressed(i,j) = psi_coef(i,j) + enddo + enddo + + do j=min(N_states,N_det)+1,N_states_diag + do i=1,N_det + CI_eigenvectors_dressed(i,j) = 0.d0 + enddo + enddo + + if (diag_algorithm == "Davidson") then + + do j=1,min(N_states,N_det) + do i=1,N_det + CI_eigenvectors_dressed(i,j) = psi_coef(i,j) + enddo + enddo + logical :: converged + converged = .False. + call davidson_diag_HS2(psi_det,CI_eigenvectors_dressed, CI_eigenvectors_s2_dressed,& + size(CI_eigenvectors_dressed,1), CI_electronic_energy_dressed,& + N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,1,converged) + + else if (diag_algorithm == "Lapack") then + + allocate (eigenvectors(size(H_matrix_dressed,1),N_det)) + allocate (eigenvalues(N_det)) + + call lapack_diag(eigenvalues,eigenvectors, & + H_matrix_dressed,size(H_matrix_dressed,1),N_det) + CI_electronic_energy_dressed(:) = 0.d0 + if (s2_eig) then + i_state = 0 + allocate (s2_eigvalues(N_det)) + allocate(index_good_state_array(N_det),good_state_array(N_det)) + good_state_array = .False. + + call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,& + N_det,size(eigenvectors,1)) + do j=1,N_det + ! Select at least n_states states with S^2 values closed to "expected_s2" + if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then + i_state +=1 + index_good_state_array(i_state) = j + good_state_array(j) = .True. + endif + if(i_state.eq.N_states) then + exit + endif enddo - enddo - converged = .False. - if (do_csf) then - call davidson_diag_H_csf(psi_det,CI_eigenvectors_dressed, & - size(CI_eigenvectors_dressed,1),CI_electronic_energy_dressed, & - N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,1,converged) + if(i_state .ne.0)then + ! Fill the first "i_state" states that have a correct S^2 value + do j = 1, i_state + do i=1,N_det + CI_eigenvectors_dressed(i,j) = eigenvectors(i,index_good_state_array(j)) + enddo + CI_electronic_energy_dressed(j) = eigenvalues(index_good_state_array(j)) + CI_eigenvectors_s2_dressed(j) = s2_eigvalues(index_good_state_array(j)) + enddo + i_other_state = 0 + do j = 1, N_det + if(good_state_array(j))cycle + i_other_state +=1 + if(i_state+i_other_state.gt.n_states_diag)then + exit + endif + do i=1,N_det + CI_eigenvectors_dressed(i,i_state+i_other_state) = eigenvectors(i,j) + enddo + CI_electronic_energy_dressed(i_state+i_other_state) = eigenvalues(j) + CI_eigenvectors_s2_dressed(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state) + enddo + else + print*,'' + print*,'!!!!!!!! WARNING !!!!!!!!!' + print*,' Within the ',N_det,'determinants selected' + print*,' and the ',N_states_diag,'states requested' + print*,' We did not find any state with S^2 values close to ',expected_s2 + print*,' We will then set the first N_states eigenvectors of the H matrix' + print*,' as the CI_eigenvectors_dressed' + print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space' + print*,'' + do j=1,min(N_states_diag,N_det) + do i=1,N_det + CI_eigenvectors_dressed(i,j) = eigenvectors(i,j) + enddo + CI_electronic_energy_dressed(j) = eigenvalues(j) + CI_eigenvectors_s2_dressed(j) = s2_eigvalues(j) + enddo + endif + deallocate(index_good_state_array,good_state_array) + deallocate(s2_eigvalues) else - call davidson_diag_HS2(psi_det,CI_eigenvectors_dressed, CI_eigenvectors_s2_dressed,& - size(CI_eigenvectors_dressed,1), CI_electronic_energy_dressed,& - N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,1,converged) + call u_0_S2_u_0(CI_eigenvectors_s2_dressed,eigenvectors,N_det,psi_det,N_int,& + min(N_det,N_states_diag),size(eigenvectors,1)) + ! Select the "N_states_diag" states of lowest energy + do j=1,min(N_det,N_states_diag) + do i=1,N_det + CI_eigenvectors_dressed(i,j) = eigenvectors(i,j) + enddo + CI_electronic_energy_dressed(j) = eigenvalues(j) + enddo endif - - integer :: N_states_diag_save - N_states_diag_save = N_states_diag - do while (.not.converged) - double precision, allocatable :: CI_electronic_energy_tmp (:) - double precision, allocatable :: CI_eigenvectors_tmp (:,:) - double precision, allocatable :: CI_s2_tmp (:) - - N_states_diag *= 2 - TOUCH N_states_diag - - if (do_csf) then - - allocate (CI_electronic_energy_tmp (N_states_diag) ) - allocate (CI_eigenvectors_tmp (N_det,N_states_diag) ) - - CI_electronic_energy_tmp(1:N_states_diag_save) = CI_electronic_energy_dressed(1:N_states_diag_save) - CI_eigenvectors_tmp(1:N_det,1:N_states_diag_save) = CI_eigenvectors_dressed(1:N_det,1:N_states_diag_save) - - call davidson_diag_H_csf(psi_det,CI_eigenvectors_tmp, & - size(CI_eigenvectors_tmp,1),CI_electronic_energy_tmp, & - N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,1,converged) - - CI_electronic_energy_dressed(1:N_states_diag_save) = CI_electronic_energy_tmp(1:N_states_diag_save) - CI_eigenvectors_dressed(1:N_det,1:N_states_diag_save) = CI_eigenvectors_tmp(1:N_det,1:N_states_diag_save) - - deallocate (CI_electronic_energy_tmp) - deallocate (CI_eigenvectors_tmp) - - else - - allocate (CI_electronic_energy_tmp (N_states_diag) ) - allocate (CI_eigenvectors_tmp (N_det,N_states_diag) ) - allocate (CI_s2_tmp (N_states_diag) ) - - CI_electronic_energy_tmp(1:N_states_diag_save) = CI_electronic_energy_dressed(1:N_states_diag_save) - CI_eigenvectors_tmp(1:N_det,1:N_states_diag_save) = CI_eigenvectors_dressed(1:N_det,1:N_states_diag_save) - CI_s2_tmp(1:N_states_diag_save) = CI_eigenvectors_s2_dressed(1:N_states_diag_save) - - call davidson_diag_HS2(psi_det,CI_eigenvectors_tmp, CI_s2_tmp, & - size(CI_eigenvectors_tmp,1),CI_electronic_energy_tmp, & - N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,1,converged) - - CI_electronic_energy_dressed(1:N_states_diag_save) = CI_electronic_energy_tmp(1:N_states_diag_save) - CI_eigenvectors_dressed(1:N_det,1:N_states_diag_save) = CI_eigenvectors_tmp(1:N_det,1:N_states_diag_save) - CI_eigenvectors_s2_dressed(1:N_states_diag_save) = CI_s2_tmp(1:N_states_diag_save) - - deallocate (CI_electronic_energy_tmp) - deallocate (CI_eigenvectors_tmp) - deallocate (CI_s2_tmp) - - endif - - enddo - if (N_states_diag > N_states_diag_save) then - N_states_diag = N_states_diag_save - TOUCH N_states_diag - endif - - else if (diag_algorithm == "Lapack") then - - print *, 'Diagonalization of H using Lapack' - allocate (eigenvectors(size(H_matrix_dressed,1),N_det)) - allocate (eigenvalues(N_det)) - - call lapack_diag(eigenvalues,eigenvectors, & - H_matrix_dressed,size(H_matrix_dressed,1),N_det) - CI_electronic_energy_dressed(:) = 0.d0 - if (s2_eig) then - i_state = 0 - allocate (s2_eigvalues(N_det)) - allocate(index_good_state_array(N_det),good_state_array(N_det)) - good_state_array = .False. - - call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,& - N_det,size(eigenvectors,1)) - do j=1,N_det - ! Select at least n_states states with S^2 values closed to "expected_s2" - if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then - i_state +=1 - index_good_state_array(i_state) = j - good_state_array(j) = .True. - endif - if(i_state.eq.N_states) then - exit - endif - enddo - if(i_state .ne.0)then - ! Fill the first "i_state" states that have a correct S^2 value - do j = 1, i_state - do i=1,N_det - CI_eigenvectors_dressed(i,j) = eigenvectors(i,index_good_state_array(j)) - enddo - CI_electronic_energy_dressed(j) = eigenvalues(index_good_state_array(j)) - CI_eigenvectors_s2_dressed(j) = s2_eigvalues(index_good_state_array(j)) - enddo - i_other_state = 0 - do j = 1, N_det - if(good_state_array(j))cycle - i_other_state +=1 - if(i_state+i_other_state.gt.n_states_diag)then - exit - endif - do i=1,N_det - CI_eigenvectors_dressed(i,i_state+i_other_state) = eigenvectors(i,j) - enddo - CI_electronic_energy_dressed(i_state+i_other_state) = eigenvalues(j) - CI_eigenvectors_s2_dressed(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state) - enddo - else - print*,'' - print*,'!!!!!!!! WARNING !!!!!!!!!' - print*,' Within the ',N_det,'determinants selected' - print*,' and the ',N_states_diag,'states requested' - print*,' We did not find any state with S^2 values close to ',expected_s2 - print*,' We will then set the first N_states eigenvectors of the H matrix' - print*,' as the CI_eigenvectors_dressed' - print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space' - print*,'' - do j=1,min(N_states_diag,N_det) - do i=1,N_det - CI_eigenvectors_dressed(i,j) = eigenvectors(i,j) - enddo - CI_electronic_energy_dressed(j) = eigenvalues(j) - CI_eigenvectors_s2_dressed(j) = s2_eigvalues(j) - enddo - endif - deallocate(index_good_state_array,good_state_array) - deallocate(s2_eigvalues) - else - call u_0_S2_u_0(CI_eigenvectors_s2_dressed,eigenvectors,N_det,psi_det,N_int,& - min(N_det,N_states_diag),size(eigenvectors,1)) - ! Select the "N_states_diag" states of lowest energy - do j=1,min(N_det,N_states_diag) - do i=1,N_det - CI_eigenvectors_dressed(i,j) = eigenvectors(i,j) - enddo - CI_electronic_energy_dressed(j) = eigenvalues(j) - enddo - endif - deallocate(eigenvectors,eigenvalues) - endif + deallocate(eigenvectors,eigenvalues) + endif END_PROVIDER diff --git a/src/determinants/EZFIO.cfg b/src/determinants/EZFIO.cfg index 9eefa66c..662c6fbb 100644 --- a/src/determinants/EZFIO.cfg +++ b/src/determinants/EZFIO.cfg @@ -42,13 +42,13 @@ default: 2 [weight_selection] type: integer -doc: Weight used in the selection. 0: input state-average weight, 1: 1./(c_0^2), 2: PT2 matching, 3: variance matching, 4: variance and PT2 matching, 5: variance minimization and matching, 6: CI coefficients 7: input state-average multiplied by variance and PT2 matching 8: input state-average multiplied by PT2 matching 9: input state-average multiplied by variance matching +doc: Weight used in the selection. 0: input state-average weight, 1: 1./(c_0^2), 2: rPT2 matching, 3: variance matching, 4: variance and rPT2 matching, 5: variance minimization and matching, 6: CI coefficients 7: input state-average multiplied by variance and rPT2 matching 8: input state-average multiplied by rPT2 matching 9: input state-average multiplied by variance matching interface: ezfio,provider,ocaml default: 1 [threshold_generators] type: Threshold -doc: Thresholds on generators (fraction of the square of the norm) +doc: Thresholds on generators (fraction of the square of the norm) interface: ezfio,provider,ocaml default: 0.999 @@ -80,7 +80,7 @@ type: integer [psi_coef] interface: ezfio doc: Coefficients of the wave function -type: double precision +type: double precision size: (determinants.n_det,determinants.n_states) [psi_det] @@ -92,7 +92,7 @@ size: (determinants.n_int*determinants.bit_kind/8,2,determinants.n_det) [psi_coef_qp_edit] interface: ezfio doc: Coefficients of the wave function -type: double precision +type: double precision size: (determinants.n_det_qp_edit,determinants.n_states) [psi_det_qp_edit] @@ -126,18 +126,13 @@ default: 1. [thresh_sym] type: Threshold -doc: Thresholds to check if a determinant is connected with HF +doc: Thresholds to check if a determinant is connected with HF interface: ezfio,provider,ocaml default: 1.e-15 [pseudo_sym] type: logical -doc: If |true|, discard any Slater determinants with an interaction smaller than thresh_sym with HF. +doc: If |true|, discard any Slater determinants with an interaction smaller than thresh_sym with HF. interface: ezfio,provider,ocaml default: False -[save_threshold] -type: Threshold -doc: Cut-off to apply to the CI coefficients when the wave function is stored -interface: ezfio,provider,ocaml -default: 1.e-14 diff --git a/src/determinants/density_matrix.irp.f b/src/determinants/density_matrix.irp.f index 1a1d92b5..7c4a7fec 100644 --- a/src/determinants/density_matrix.irp.f +++ b/src/determinants/density_matrix.irp.f @@ -262,86 +262,17 @@ subroutine set_natural_mos iorb = list_virt(i) do j = 1, n_core_inact_act_orb jorb = list_core_inact_act(j) + if(one_e_dm_mo(iorb,jorb).ne. 0.d0)then + print*,'AHAHAH' + print*,iorb,jorb,one_e_dm_mo(iorb,jorb) + stop + endif enddo enddo call mo_as_svd_vectors_of_mo_matrix_eig(one_e_dm_mo,size(one_e_dm_mo,1),mo_num,mo_num,mo_occ,label) soft_touch mo_occ + end - - -subroutine save_natural_mos_canon_label - implicit none - BEGIN_DOC - ! Save natural orbitals, obtained by diagonalization of the one-body density matrix in - ! the |MO| basis - END_DOC - call set_natural_mos_canon_label - call nullify_small_elements(ao_num,mo_num,mo_coef,size(mo_coef,1),1.d-10) - call orthonormalize_mos - call save_mos -end - -subroutine set_natural_mos_canon_label - implicit none - BEGIN_DOC - ! Set natural orbitals, obtained by diagonalization of the one-body density matrix - ! in the |MO| basis - END_DOC - character*(64) :: label - double precision, allocatable :: tmp(:,:) - - label = "Canonical" - integer :: i,j,iorb,jorb - do i = 1, n_virt_orb - iorb = list_virt(i) - do j = 1, n_core_inact_act_orb - jorb = list_core_inact_act(j) - enddo - enddo - call mo_as_svd_vectors_of_mo_matrix_eig(one_e_dm_mo,size(one_e_dm_mo,1),mo_num,mo_num,mo_occ,label) - soft_touch mo_occ -end - - - - - -subroutine set_natorb_no_ov_rot - implicit none - BEGIN_DOC - ! Set natural orbitals, obtained by diagonalization of the one-body density matrix - ! in the |MO| basis - END_DOC - character*(64) :: label - double precision, allocatable :: tmp(:,:) - allocate(tmp(mo_num, mo_num)) - label = "Natural" - tmp = one_e_dm_mo - integer :: i,j,iorb,jorb - do i = 1, n_virt_orb - iorb = list_virt(i) - do j = 1, n_core_inact_act_orb - jorb = list_core_inact_act(j) - tmp(iorb, jorb) = 0.d0 - tmp(jorb, iorb) = 0.d0 - enddo - enddo - call mo_as_svd_vectors_of_mo_matrix_eig(tmp,size(tmp,1),mo_num,mo_num,mo_occ,label) - soft_touch mo_occ -end - -subroutine save_natural_mos_no_ov_rot - implicit none - BEGIN_DOC - ! Save natural orbitals, obtained by diagonalization of the one-body density matrix in - ! the |MO| basis - END_DOC - call set_natorb_no_ov_rot - call nullify_small_elements(ao_num,mo_num,mo_coef,size(mo_coef,1),1.d-10) - call orthonormalize_mos - call save_mos -end - subroutine save_natural_mos implicit none BEGIN_DOC @@ -368,12 +299,12 @@ BEGIN_PROVIDER [ double precision, c0_weight, (N_states) ] c = maxval(psi_coef(:,i) * psi_coef(:,i)) c0_weight(i) = 1.d0/(c+1.d-20) enddo - c = 1.d0/sum(c0_weight(:)) + c = 1.d0/minval(c0_weight(:)) do i=1,N_states c0_weight(i) = c0_weight(i) * c enddo else - c0_weight(:) = 1.d0 + c0_weight = 1.d0 endif END_PROVIDER @@ -390,7 +321,7 @@ BEGIN_PROVIDER [ double precision, state_average_weight, (N_states) ] if (weight_one_e_dm == 0) then state_average_weight(:) = c0_weight(:) else if (weight_one_e_dm == 1) then - state_average_weight(:) = 1.d0/N_states + state_average_weight(:) = 1./N_states else call ezfio_has_determinants_state_average_weight(exists) if (exists) then @@ -453,14 +384,6 @@ END_PROVIDER END_PROVIDER -BEGIN_PROVIDER [ double precision, one_e_dm_ao, (ao_num, ao_num)] - implicit none - BEGIN_DOC - ! one_e_dm_ao = one_e_dm_ao_alpha + one_e_dm_ao_beta - END_DOC - one_e_dm_ao = one_e_dm_ao_alpha + one_e_dm_ao_beta -END_PROVIDER - subroutine get_occupation_from_dets(istate,occupation) implicit none diff --git a/src/determinants/determinants.irp.f b/src/determinants/determinants.irp.f index e1c14bfe..5b12a6d9 100644 --- a/src/determinants/determinants.irp.f +++ b/src/determinants/determinants.irp.f @@ -77,31 +77,28 @@ BEGIN_PROVIDER [ integer, psi_det_size ] END_DOC PROVIDE ezfio_filename logical :: exists - psi_det_size = N_states - PROVIDE mpi_master - if (read_wf) then - if (mpi_master) then - call ezfio_has_determinants_n_det(exists) - if (exists) then - call ezfio_get_determinants_n_det(psi_det_size) - else - psi_det_size = N_states - endif - call write_int(6,psi_det_size,'Dimension of the psi arrays') + if (mpi_master) then + call ezfio_has_determinants_n_det(exists) + if (exists) then + call ezfio_get_determinants_n_det(psi_det_size) + else + psi_det_size = 1 endif - IRP_IF MPI_DEBUG - print *, irp_here, mpi_rank - call MPI_BARRIER(MPI_COMM_WORLD, ierr) - IRP_ENDIF - IRP_IF MPI - include 'mpif.h' - integer :: ierr - call MPI_BCAST( psi_det_size, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to read psi_det_size with MPI' - endif - IRP_ENDIF + call write_int(6,psi_det_size,'Dimension of the psi arrays') endif + IRP_IF MPI_DEBUG + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + IRP_ENDIF + IRP_IF MPI + include 'mpif.h' + integer :: ierr + call MPI_BCAST( psi_det_size, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read psi_det_size with MPI' + endif + IRP_ENDIF + END_PROVIDER @@ -542,7 +539,7 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef) integer :: i,j,k, ndet_qp_edit if (mpi_master) then - ndet_qp_edit = min(ndet,10000) + ndet_qp_edit = min(ndet,N_det_qp_edit) call ezfio_set_determinants_N_int(N_int) call ezfio_set_determinants_bit_kind(bit_kind) @@ -590,6 +587,71 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef) end +subroutine save_wavefunction_general_unormalized(ndet,nstates,psidet,dim_psicoef,psicoef) + implicit none + BEGIN_DOC + ! Save the wave function into the |EZFIO| file + END_DOC + use bitmasks + include 'constants.include.F' + integer, intent(in) :: ndet,nstates,dim_psicoef + integer(bit_kind), intent(in) :: psidet(N_int,2,ndet) + double precision, intent(in) :: psicoef(dim_psicoef,nstates) + integer*8, allocatable :: psi_det_save(:,:,:) + double precision, allocatable :: psi_coef_save(:,:) + + double precision :: accu_norm + integer :: i,j,k, ndet_qp_edit + + if (mpi_master) then + ndet_qp_edit = min(ndet,N_det_qp_edit) + + call ezfio_set_determinants_N_int(N_int) + call ezfio_set_determinants_bit_kind(bit_kind) + call ezfio_set_determinants_N_det(ndet) + call ezfio_set_determinants_N_det_qp_edit(ndet_qp_edit) + call ezfio_set_determinants_n_states(nstates) + call ezfio_set_determinants_mo_label(mo_label) + + allocate (psi_det_save(N_int,2,ndet)) + do i=1,ndet + do j=1,2 + do k=1,N_int + psi_det_save(k,j,i) = transfer(psidet(k,j,i),1_8) + enddo + enddo + enddo + call ezfio_set_determinants_psi_det(psi_det_save) + call ezfio_set_determinants_psi_det_qp_edit(psi_det_save) + deallocate (psi_det_save) + + allocate (psi_coef_save(ndet,nstates)) + do k=1,nstates + do i=1,ndet + psi_coef_save(i,k) = psicoef(i,k) + enddo + enddo + + call ezfio_set_determinants_psi_coef(psi_coef_save) + deallocate (psi_coef_save) + + allocate (psi_coef_save(ndet_qp_edit,nstates)) + do k=1,nstates + do i=1,ndet_qp_edit + psi_coef_save(i,k) = psicoef(i,k) + enddo + enddo + + call ezfio_set_determinants_psi_coef_qp_edit(psi_coef_save) + deallocate (psi_coef_save) + + call write_int(6,ndet,'Saved determinants') + endif +end + + + + subroutine save_wavefunction_specified(ndet,nstates,psidet,psicoef,ndetsave,index_det_save) implicit none diff --git a/src/determinants/dipole_moments.irp.f b/src/determinants/dipole_moments.irp.f index b411dda4..8a5f1a2d 100644 --- a/src/determinants/dipole_moments.irp.f +++ b/src/determinants/dipole_moments.irp.f @@ -9,7 +9,7 @@ double precision :: weight, r(3) double precision :: cpu0,cpu1,nuclei_part_z,nuclei_part_y,nuclei_part_x -! call cpu_time(cpu0) + call cpu_time(cpu0) z_dipole_moment = 0.d0 y_dipole_moment = 0.d0 x_dipole_moment = 0.d0 @@ -26,10 +26,10 @@ enddo enddo -! print*,'electron part for z_dipole = ',z_dipole_moment -! print*,'electron part for y_dipole = ',y_dipole_moment -! print*,'electron part for x_dipole = ',x_dipole_moment -! + print*,'electron part for z_dipole = ',z_dipole_moment + print*,'electron part for y_dipole = ',y_dipole_moment + print*,'electron part for x_dipole = ',x_dipole_moment + nuclei_part_z = 0.d0 nuclei_part_y = 0.d0 nuclei_part_x = 0.d0 @@ -38,43 +38,28 @@ nuclei_part_y += nucl_charge(i) * nucl_coord(i,2) nuclei_part_x += nucl_charge(i) * nucl_coord(i,1) enddo -! print*,'nuclei part for z_dipole = ',nuclei_part_z -! print*,'nuclei part for y_dipole = ',nuclei_part_y -! print*,'nuclei part for x_dipole = ',nuclei_part_x -! + print*,'nuclei part for z_dipole = ',nuclei_part_z + print*,'nuclei part for y_dipole = ',nuclei_part_y + print*,'nuclei part for x_dipole = ',nuclei_part_x + do istate = 1, N_states z_dipole_moment(istate) += nuclei_part_z y_dipole_moment(istate) += nuclei_part_y x_dipole_moment(istate) += nuclei_part_x enddo -! call cpu_time(cpu1) -! print*,'Time to provide the dipole moment :',cpu1-cpu0 + call cpu_time(cpu1) + print*,'Time to provide the dipole moment :',cpu1-cpu0 END_PROVIDER - subroutine print_dipole_moments + subroutine print_z_dipole_moment_only implicit none - integer :: i print*, '' print*, '' print*, '****************************************' - write(*,'(A10)',advance='no') ' State : ' - do i = 1,N_states - write(*,'(i16)',advance='no') i - end do - write(*,*) '' - write(*,'(A23,100(1pE16.8))') 'x_dipole_moment (au) = ',x_dipole_moment - write(*,'(A23,100(1pE16.8))') 'y_dipole_moment (au) = ',y_dipole_moment - write(*,'(A23,100(1pE16.8))') 'z_dipole_moment (au) = ',z_dipole_moment - write(*,*) '' - write(*,'(A23,100(1pE16.8))') 'x_dipole_moment (D) = ',x_dipole_moment * au_to_D - write(*,'(A23,100(1pE16.8))') 'y_dipole_moment (D) = ',y_dipole_moment * au_to_D - write(*,'(A23,100(1pE16.8))') 'z_dipole_moment (D) = ',z_dipole_moment * au_to_D - !print*, 'x_dipole_moment = ',x_dipole_moment - !print*, 'y_dipole_moment = ',y_dipole_moment - !print*, 'z_dipole_moment = ',z_dipole_moment + print*, 'z_dipole_moment = ',z_dipole_moment print*, '****************************************' end diff --git a/src/determinants/h_apply.irp.f b/src/determinants/h_apply.irp.f index d01ad1c7..98fafb4a 100644 --- a/src/determinants/h_apply.irp.f +++ b/src/determinants/h_apply.irp.f @@ -322,7 +322,10 @@ subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc) ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num) enddo do i=1,n_selected - H_apply_buffer(iproc)%det(:,:,i+H_apply_buffer(iproc)%N_det) = det_buffer(:,:,i) + do j=1,N_int + H_apply_buffer(iproc)%det(j,1,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,1,i) + H_apply_buffer(iproc)%det(j,2,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,2,i) + enddo ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i+H_apply_buffer(iproc)%N_det)) )== elec_alpha_num) ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i+H_apply_buffer(iproc)%N_det))) == elec_beta_num) enddo diff --git a/src/determinants/s2.irp.f b/src/determinants/s2.irp.f index 2c1a8757..d73b2dbf 100644 --- a/src/determinants/s2.irp.f +++ b/src/determinants/s2.irp.f @@ -103,17 +103,13 @@ BEGIN_PROVIDER [ double precision, expected_s2] END_PROVIDER - BEGIN_PROVIDER [ double precision, s2_values, (N_states) ] -&BEGIN_PROVIDER [ double precision, s_values, (N_states) ] +BEGIN_PROVIDER [ double precision, s2_values, (N_states) ] implicit none BEGIN_DOC ! array of the averaged values of the S^2 operator on the various states END_DOC integer :: i call u_0_S2_u_0(s2_values,psi_coef,n_det,psi_det,N_int,N_states,psi_det_size) - do i = 1, N_states - s_values(i) = 0.5d0 *(-1.d0 + dsqrt(1.d0 + 4 * s2_values(i))) - enddo END_PROVIDER diff --git a/src/determinants/slater_rules.irp.f b/src/determinants/slater_rules.irp.f index 897607a9..04cf861f 100644 --- a/src/determinants/slater_rules.irp.f +++ b/src/determinants/slater_rules.irp.f @@ -438,7 +438,7 @@ subroutine bitstring_to_list_ab( string, list, n_elements, Nint) use bitmasks implicit none BEGIN_DOC - ! Gives the indices(+1) of the bits set to 1 in the bit string + ! Gives the inidices(+1) of the bits set to 1 in the bit string ! For alpha/beta determinants. END_DOC integer, intent(in) :: Nint @@ -472,35 +472,6 @@ subroutine bitstring_to_list_ab( string, list, n_elements, Nint) end -!subroutine bitstring_to_list( string, list, n_elements, Nint) -! use bitmasks -! implicit none -! BEGIN_DOC -! ! Gives the indices(+1) of the bits set to 1 in the bit string -! END_DOC -! integer, intent(in) :: Nint -! integer(bit_kind), intent(in) :: string(Nint) -! integer, intent(out) :: list(Nint*bit_kind_size) -! integer, intent(out) :: n_elements -! -! integer :: i, j, ishift -! integer(bit_kind) :: l -! -! n_elements = 0 -! ishift = 1 -! do i=1,Nint -! l = string(i) -! do while (l /= 0_bit_kind) -! j = trailz(l) -! n_elements = n_elements + 1 -! l = ibclr(l,j) -! list(n_elements) = ishift+j -! enddo -! ishift = ishift + bit_kind_size -! enddo -! -!end - subroutine i_H_j_s2(key_i,key_j,Nint,hij,s2) use bitmasks @@ -623,8 +594,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij) integer :: occ(Nint*bit_kind_size,2) double precision :: diag_H_mat_elem, phase integer :: n_occ_ab(2) - PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals - PROVIDE ao_one_e_integrals mo_one_e_integrals + PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals ASSERT (Nint > 0) ASSERT (Nint == N_int) @@ -682,6 +652,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij) case (1) call get_single_excitation(key_i,key_j,exc,phase,Nint) !DIR$ FORCEINLINE + call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) if (exc(0,1,1) == 1) then ! Single alpha m = exc(1,1,1) @@ -700,6 +671,10 @@ subroutine i_H_j(key_i,key_j,Nint,hij) end select end + + + + subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble,phase) use bitmasks implicit none @@ -1034,6 +1009,7 @@ subroutine i_H_psi(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array) end + subroutine i_H_psi_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array) use bitmasks implicit none diff --git a/src/determinants/slater_rules_wee_mono.irp.f b/src/determinants/slater_rules_wee_mono.irp.f index 7c2ad148..4c1c9330 100644 --- a/src/determinants/slater_rules_wee_mono.irp.f +++ b/src/determinants/slater_rules_wee_mono.irp.f @@ -282,7 +282,9 @@ subroutine i_H_j_two_e(key_i,key_j,Nint,hij) double precision :: get_two_e_integral integer :: m,n,p,q integer :: i,j,k + integer :: occ(Nint*bit_kind_size,2) double precision :: diag_H_mat_elem, phase,phase_2 + integer :: n_occ_ab(2) PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals ref_bitmask_two_e_energy ASSERT (Nint > 0) @@ -340,6 +342,7 @@ subroutine i_H_j_two_e(key_i,key_j,Nint,hij) case (1) call get_single_excitation(key_i,key_j,exc,phase,Nint) !DIR$ FORCEINLINE + call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) if (exc(0,1,1) == 1) then ! Mono alpha m = exc(1,1,1) diff --git a/src/determinants/spindeterminants.ezfio_config b/src/determinants/spindeterminants.ezfio_config index 39ccb82b..dd4c9b0c 100644 --- a/src/determinants/spindeterminants.ezfio_config +++ b/src/determinants/spindeterminants.ezfio_config @@ -11,6 +11,8 @@ spindeterminants psi_coef_matrix_columns integer (spindeterminants_n_det) psi_coef_matrix_values double precision (spindeterminants_n_det,spindeterminants_n_states) n_svd_coefs integer + n_svd_alpha integer + n_svd_beta integer psi_svd_alpha double precision (spindeterminants_n_det_alpha,spindeterminants_n_svd_coefs,spindeterminants_n_states) psi_svd_beta double precision (spindeterminants_n_det_beta,spindeterminants_n_svd_coefs,spindeterminants_n_states) psi_svd_coefs double precision (spindeterminants_n_svd_coefs,spindeterminants_n_states) diff --git a/src/determinants/spindeterminants.irp.f b/src/determinants/spindeterminants.irp.f index dd55e112..dea4a566 100644 --- a/src/determinants/spindeterminants.irp.f +++ b/src/determinants/spindeterminants.irp.f @@ -585,7 +585,7 @@ END_PROVIDER enddo !$OMP ENDDO !$OMP END PARALLEL - call i8sort(to_sort, psi_bilinear_matrix_transp_order, N_det) + call i8radix_sort(to_sort, psi_bilinear_matrix_transp_order, N_det,-1) call iset_order(psi_bilinear_matrix_transp_rows,psi_bilinear_matrix_transp_order,N_det) call iset_order(psi_bilinear_matrix_transp_columns,psi_bilinear_matrix_transp_order,N_det) !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(l) diff --git a/src/determinants/utils.irp.f b/src/determinants/utils.irp.f index 7b75d985..957e74d5 100644 --- a/src/determinants/utils.irp.f +++ b/src/determinants/utils.irp.f @@ -6,10 +6,9 @@ BEGIN_PROVIDER [ double precision, H_matrix_all_dets,(N_det,N_det) ] END_DOC integer :: i,j,k double precision :: hij - integer :: degree(N_det),idx(0:N_det) call i_H_j(psi_det(1,1,1),psi_det(1,1,1),N_int,hij) print*,'Providing the H_matrix_all_dets ...' - !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,hij,degree,idx,k) & + !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,hij,k) & !$OMP SHARED (N_det, psi_det, N_int,H_matrix_all_dets) do i =1,N_det do j = i, N_det @@ -30,15 +29,16 @@ BEGIN_PROVIDER [ double precision, H_matrix_diag_all_dets,(N_det) ] END_DOC integer :: i double precision :: hij - integer :: degree(N_det) + call i_H_j(psi_det(1,1,1),psi_det(1,1,1),N_int,hij) - !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,hij,degree) & + !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,hij) & !$OMP SHARED (N_det, psi_det, N_int,H_matrix_diag_all_dets) do i =1,N_det call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,hij) H_matrix_diag_all_dets(i) = hij enddo !$OMP END PARALLEL DO + END_PROVIDER @@ -50,9 +50,8 @@ BEGIN_PROVIDER [ double precision, S2_matrix_all_dets,(N_det,N_det) ] END_DOC integer :: i,j,k double precision :: sij - integer :: degree(N_det),idx(0:N_det) call get_s2(psi_det(1,1,1),psi_det(1,1,1),N_int,sij) - !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,sij,degree,idx,k) & + !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,sij,k) & !$OMP SHARED (N_det, psi_det, N_int,S2_matrix_all_dets) do i =1,N_det do j = i, N_det @@ -63,4 +62,3 @@ BEGIN_PROVIDER [ double precision, S2_matrix_all_dets,(N_det,N_det) ] enddo !$OMP END PARALLEL DO END_PROVIDER - diff --git a/src/dft_one_e/NEED b/src/dft_one_e/NEED index 615ee97e..3a942f28 100644 --- a/src/dft_one_e/NEED +++ b/src/dft_one_e/NEED @@ -6,4 +6,3 @@ ao_one_e_ints ao_two_e_ints mo_two_e_erf_ints ao_two_e_erf_ints -mu_of_r diff --git a/src/dft_one_e/mu_erf_dft.irp.f b/src/dft_one_e/mu_erf_dft.irp.f index 0b870564..53effcb6 100644 --- a/src/dft_one_e/mu_erf_dft.irp.f +++ b/src/dft_one_e/mu_erf_dft.irp.f @@ -8,73 +8,3 @@ BEGIN_PROVIDER [double precision, mu_erf_dft] mu_erf_dft = mu_erf END_PROVIDER - -BEGIN_PROVIDER [double precision, mu_of_r_dft, (n_points_final_grid)] - implicit none - integer :: i - if(mu_dft_type == "Read")then - call ezfio_get_mu_of_r_mu_of_r_disk(mu_of_r_dft) - else - do i = 1, n_points_final_grid - if(mu_dft_type == "cst")then - mu_of_r_dft(i) = mu_erf_dft - else if(mu_dft_type == "hf")then - mu_of_r_dft(i) = mu_of_r_hf(i) - else if(mu_dft_type == "rsc")then - mu_of_r_dft(i) = mu_rsc_of_r(i) - else if(mu_dft_type == "grad_rho")then - mu_of_r_dft(i) = mu_grad_rho(i) - else - print*,'mu_dft_type is not of good type = ',mu_dft_type - print*,'it must be of type Read, cst, hf, rsc' - print*,'Stopping ...' - stop - endif - enddo - endif -END_PROVIDER - -BEGIN_PROVIDER [double precision, mu_rsc_of_r, (n_points_final_grid)] - implicit none - integer :: i - double precision :: mu_rs_c,rho,r(3), dm_a, dm_b - do i = 1, n_points_final_grid - r(1) = final_grid_points(1,i) - r(2) = final_grid_points(2,i) - r(3) = final_grid_points(3,i) - call dm_dft_alpha_beta_at_r(r,dm_a,dm_b) - rho = dm_a + dm_b - mu_rsc_of_r(i) = mu_rs_c(rho) - enddo -END_PROVIDER - -BEGIN_PROVIDER [double precision, mu_grad_rho, (n_points_final_grid)] - implicit none - integer :: i - double precision :: mu_grad_rho_func, r(3) - do i = 1, n_points_final_grid - r(1) = final_grid_points(1,i) - r(2) = final_grid_points(2,i) - r(3) = final_grid_points(3,i) - mu_grad_rho(i) = mu_grad_rho_func(r) - enddo -END_PROVIDER - - -BEGIN_PROVIDER [double precision, mu_of_r_dft_average] - implicit none - integer :: i - double precision :: mu_rs_c,rho,r(3), dm_a, dm_b - mu_of_r_dft_average = 0.d0 - do i = 1, n_points_final_grid - r(1) = final_grid_points(1,i) - r(2) = final_grid_points(2,i) - r(3) = final_grid_points(3,i) - call dm_dft_alpha_beta_at_r(r,dm_a,dm_b) - rho = dm_a + dm_b - if(mu_of_r_dft(i).gt.1.d+3)cycle - mu_of_r_dft_average += rho * mu_of_r_dft(i) * final_weight_at_r_vector(i) - enddo - mu_of_r_dft_average = mu_of_r_dft_average / dble(elec_alpha_num + elec_beta_num) - print*,'mu_of_r_dft_average = ',mu_of_r_dft_average -END_PROVIDER diff --git a/src/dft_utils_func/mu_of_r_dft.irp.f b/src/dft_utils_func/mu_of_r_dft.irp.f deleted file mode 100644 index 0e9a0f1b..00000000 --- a/src/dft_utils_func/mu_of_r_dft.irp.f +++ /dev/null @@ -1,37 +0,0 @@ -double precision function mu_rs_c(rho) - implicit none - double precision, intent(in) :: rho - include 'constants.include.F' - double precision :: cst_rs,alpha_rs,rs - cst_rs = (4.d0 * dacos(-1.d0)/3.d0)**(-1.d0/3.d0) - alpha_rs = 2.d0 * dsqrt((9.d0 * dacos(-1.d0)/4.d0)**(-1.d0/3.d0)) / sqpi - - rs = cst_rs * rho**(-1.d0/3.d0) - mu_rs_c = alpha_rs/dsqrt(rs) - -end - -double precision function mu_grad_rho_func(r) - implicit none - double precision , intent(in) :: r(3) - integer :: m - double precision :: rho, dm_a, dm_b, grad_dm_a(3), grad_dm_b(3) - double precision :: eta, grad_rho(3), grad_sqr - eta = mu_erf - call density_and_grad_alpha_beta(r,dm_a,dm_b, grad_dm_a, grad_dm_b) - rho = dm_a + dm_b - do m = 1,3 - grad_rho(m) = grad_dm_a(m) + grad_dm_b(m) - enddo - grad_sqr=0.d0 - do m = 1,3 - grad_sqr=grad_sqr+grad_rho(m)*grad_rho(m) - enddo - grad_sqr = dsqrt(grad_sqr) - if (rho<1.d-12) then - mu_grad_rho_func = 1.d-10 - else - mu_grad_rho_func = eta * grad_sqr / rho - endif - -end diff --git a/src/dft_utils_func/mu_rsc.irp.f b/src/dft_utils_func/mu_rsc.irp.f new file mode 100644 index 00000000..cda444d4 --- /dev/null +++ b/src/dft_utils_func/mu_rsc.irp.f @@ -0,0 +1,13 @@ +double precision function mu_rs_c(rho) + implicit none + double precision, intent(in) :: rho + include 'constants.include.F' + double precision :: cst_rs,alpha_rs,rs + cst_rs = (4.d0 * dacos(-1.d0)/3.d0)**(-1.d0/3.d0) + alpha_rs = 2.d0 * dsqrt((9.d0 * dacos(-1.d0)/4.d0)**(-1.d0/3.d0)) / sqpi + + rs = cst_rs * rho**(-1.d0/3.d0) + mu_rs_c = alpha_rs/dsqrt(rs) + +end + diff --git a/src/dft_utils_func/on_top_from_ueg.irp.f b/src/dft_utils_func/on_top_from_ueg.irp.f index 5b964a03..717081a7 100644 --- a/src/dft_utils_func/on_top_from_ueg.irp.f +++ b/src/dft_utils_func/on_top_from_ueg.irp.f @@ -37,15 +37,13 @@ double precision function g0_UEG_mu_inf(rho_a,rho_b) rs = (3d0 / (4d0*pi*rho))**(1d0/3d0) ! JT: serious bug fixed 20/03/19 x = -d2*rs if(dabs(x).lt.50.d0)then -! g0_UEG_mu_inf= 0.5d0 * (1d0- B*rs + C*rs**2 + D*rs**3 + E*rs**4)*dexp(x) - g0_UEG_mu_inf= 0.5d0 * (1d0+ rs* (-B + rs*(C + rs*(D + rs*E))))*dexp(x) + g0_UEG_mu_inf= 0.5d0 * (1d0- B*rs + C*rs**2 + D*rs**3 + E*rs**4)*dexp(x) else g0_UEG_mu_inf= 0.d0 endif else g0_UEG_mu_inf= 0.d0 endif - g0_UEG_mu_inf = max(g0_UEG_mu_inf,1.d-14) end diff --git a/src/dft_utils_in_r/ao_in_r.irp.f b/src/dft_utils_in_r/ao_in_r.irp.f index 38478d21..6fa6a4c7 100644 --- a/src/dft_utils_in_r/ao_in_r.irp.f +++ b/src/dft_utils_in_r/ao_in_r.irp.f @@ -91,19 +91,7 @@ enddo END_PROVIDER - BEGIN_PROVIDER [double precision, aos_lapl_in_r_array_transp, (ao_num, n_points_final_grid,3)] - implicit none - integer :: i,j,m - do i = 1, n_points_final_grid - do j = 1, ao_num - do m = 1, 3 - aos_lapl_in_r_array_transp(j,i,m) = aos_lapl_in_r_array(m,j,i) - enddo - enddo - enddo - END_PROVIDER - - BEGIN_PROVIDER [double precision, aos_lapl_in_r_array, (3,ao_num,n_points_final_grid)] + BEGIN_PROVIDER[double precision, aos_lapl_in_r_array, (ao_num,n_points_final_grid,3)] implicit none BEGIN_DOC ! aos_lapl_in_r_array(i,j,k) = value of the kth component of the laplacian of jth ao on the ith grid point @@ -112,20 +100,20 @@ END_DOC integer :: i,j,m double precision :: aos_array(ao_num), r(3) - double precision :: aos_grad_array(3,ao_num) - double precision :: aos_lapl_array(3,ao_num) + double precision :: aos_grad_array(ao_num,3) + double precision :: aos_lapl_array(ao_num,3) !$OMP PARALLEL DO & !$OMP DEFAULT (NONE) & !$OMP PRIVATE (i,r,aos_array,aos_grad_array,aos_lapl_array,j,m) & !$OMP SHARED(aos_lapl_in_r_array,n_points_final_grid,ao_num,final_grid_points) - do i = 1, n_points_final_grid - r(1) = final_grid_points(1,i) - r(2) = final_grid_points(2,i) - r(3) = final_grid_points(3,i) - call give_all_aos_and_grad_and_lapl_at_r(r,aos_array,aos_grad_array,aos_lapl_array) - do j = 1, ao_num - do m = 1, 3 - aos_lapl_in_r_array(m,j,i) = aos_lapl_array(m,j) + do m = 1, 3 + do i = 1, n_points_final_grid + r(1) = final_grid_points(1,i) + r(2) = final_grid_points(2,i) + r(3) = final_grid_points(3,i) + call give_all_aos_and_grad_and_lapl_at_r(r,aos_array,aos_grad_array,aos_lapl_array) + do j = 1, ao_num + aos_lapl_in_r_array(j,i,m) = aos_lapl_array(j,m) enddo enddo enddo diff --git a/src/dft_utils_in_r/ints_grad.irp.f b/src/dft_utils_in_r/ints_grad.irp.f deleted file mode 100644 index 239fe554..00000000 --- a/src/dft_utils_in_r/ints_grad.irp.f +++ /dev/null @@ -1,39 +0,0 @@ - BEGIN_PROVIDER [ double precision, mo_grad_ints, (mo_num, mo_num,3)] - implicit none - BEGIN_DOC -! mo_grad_ints(i,j,m) = - END_DOC - integer :: i,j,ipoint,m - double precision :: weight - mo_grad_ints = 0.d0 - do m = 1, 3 - do ipoint = 1, n_points_final_grid - weight = final_weight_at_r_vector(ipoint) - do j = 1, mo_num - do i = 1, mo_num - mo_grad_ints(i,j,m) += mos_grad_in_r_array(j,ipoint,m) * mos_in_r_array(i,ipoint) * weight - enddo - enddo - enddo - enddo - - -END_PROVIDER - - BEGIN_PROVIDER [ double precision, mo_grad_ints_transp, (3,mo_num, mo_num)] - implicit none - BEGIN_DOC -! mo_grad_ints(i,j,m) = - END_DOC - integer :: i,j,ipoint,m - double precision :: weight - do m = 1, 3 - do j = 1, mo_num - do i = 1, mo_num - mo_grad_ints_transp(m,i,j) = mo_grad_ints(i,j,m) - enddo - enddo - enddo - - -END_PROVIDER diff --git a/src/dft_utils_in_r/mo_in_r.irp.f b/src/dft_utils_in_r/mo_in_r.irp.f index 192cb25a..0a8b4d52 100644 --- a/src/dft_utils_in_r/mo_in_r.irp.f +++ b/src/dft_utils_in_r/mo_in_r.irp.f @@ -138,7 +138,7 @@ integer :: m mos_lapl_in_r_array = 0.d0 do m=1,3 - call dgemm('N','N',mo_num,n_points_final_grid,ao_num,1.d0,mo_coef_transp,mo_num,aos_lapl_in_r_array_transp(1,1,m),ao_num,0.d0,mos_lapl_in_r_array(1,1,m),mo_num) + call dgemm('N','N',mo_num,n_points_final_grid,ao_num,1.d0,mo_coef_transp,mo_num,aos_lapl_in_r_array(1,1,m),ao_num,0.d0,mos_lapl_in_r_array(1,1,m),mo_num) enddo END_PROVIDER diff --git a/src/dressing/alpha_factory.irp.f b/src/dressing/alpha_factory.irp.f index c7adffe3..5eeeb1a6 100644 --- a/src/dressing/alpha_factory.irp.f +++ b/src/dressing/alpha_factory.irp.f @@ -1179,7 +1179,7 @@ subroutine bitstring_to_list_in_selection( string, list, n_elements, Nint) use bitmasks implicit none BEGIN_DOC - ! Gives the indices(+1) of the bits set to 1 in the bit string + ! Gives the inidices(+1) of the bits set to 1 in the bit string END_DOC integer, intent(in) :: Nint integer(bit_kind), intent(in) :: string(Nint) diff --git a/src/dressing/run_dress_slave.irp.f b/src/dressing/run_dress_slave.irp.f index 08b654c9..a33fb1dd 100644 --- a/src/dressing/run_dress_slave.irp.f +++ b/src/dressing/run_dress_slave.irp.f @@ -72,7 +72,7 @@ subroutine run_dress_slave(thread,iproce,energy) provide psi_energy ending = dress_N_cp+1 ntask_tbd = 0 - call set_multiple_levels_omp(.True.) + call omp_set_max_active_levels(8) !$OMP PARALLEL DEFAULT(SHARED) & !$OMP PRIVATE(interesting, breve_delta_m, task_id) & @@ -84,7 +84,7 @@ subroutine run_dress_slave(thread,iproce,energy) zmq_socket_push = new_zmq_push_socket(thread) integer, external :: connect_to_taskserver !$OMP CRITICAL - call set_multiple_levels_omp(.False.) + call omp_set_max_active_levels(1) if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then print *, irp_here, ': Unable to connect to task server' stop -1 @@ -296,7 +296,7 @@ subroutine run_dress_slave(thread,iproce,energy) !$OMP END CRITICAL !$OMP END PARALLEL - call set_multiple_levels_omp(.False.) + call omp_set_max_active_levels(1) ! do i=0,dress_N_cp+1 ! call omp_destroy_lock(lck_sto(i)) ! end do diff --git a/src/ezfio_files/output.irp.f b/src/ezfio_files/output.irp.f index 7b2663a0..48512f92 100644 --- a/src/ezfio_files/output.irp.f +++ b/src/ezfio_files/output.irp.f @@ -25,7 +25,7 @@ subroutine write_time(iunit) ct = ct - output_cpu_time_0 call wall_time(wt) wt = wt - output_wall_time_0 - write(6,'(A,F14.2,A,F14.2,A)') & + write(6,'(A,F14.6,A,F14.6,A)') & '.. >>>>> [ WALL TIME: ', wt, ' s ] [ CPU TIME: ', ct, ' s ] <<<<< ..' write(6,*) end diff --git a/src/functionals/sr_lda.irp.f b/src/functionals/sr_lda.irp.f index bd062a02..965a744c 100644 --- a/src/functionals/sr_lda.irp.f +++ b/src/functionals/sr_lda.irp.f @@ -21,9 +21,7 @@ weight = final_weight_at_r_vector(i) rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) - double precision :: mu_local - mu_local = mu_of_r_dft(i) - call ex_lda_sr(mu_local,rhoa(istate),rhob(istate),e_x,vx_a,vx_b) + call ex_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_x,vx_a,vx_b) energy_x_sr_lda(istate) += weight * e_x enddo enddo @@ -50,9 +48,7 @@ weight = final_weight_at_r_vector(i) rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) - double precision :: mu_local - mu_local = mu_of_r_dft(i) - call ec_lda_sr(mu_local,rhoa(istate),rhob(istate),e_c,vc_a,vc_b) + call ec_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_c,vc_a,vc_b) energy_c_sr_lda(istate) += weight * e_c enddo enddo @@ -126,10 +122,8 @@ END_PROVIDER weight = final_weight_at_r_vector(i) rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) - double precision :: mu_local - mu_local = mu_of_r_dft(i) - call ec_lda_sr(mu_local,rhoa(istate),rhob(istate),e_c,sr_vc_a,sr_vc_b) - call ex_lda_sr(mu_local,rhoa(istate),rhob(istate),e_x,sr_vx_a,sr_vx_b) + call ec_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_c,sr_vc_a,sr_vc_b) + call ex_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_x,sr_vx_a,sr_vx_b) do j =1, ao_num aos_sr_vc_alpha_lda_w(j,i,istate) = sr_vc_a * aos_in_r_array(j,i)*weight aos_sr_vc_beta_lda_w(j,i,istate) = sr_vc_b * aos_in_r_array(j,i)*weight @@ -153,6 +147,8 @@ END_PROVIDER double precision :: mu,weight double precision :: e_c,sr_vc_a,sr_vc_b,e_x,sr_vx_a,sr_vx_b double precision, allocatable :: rhoa(:),rhob(:) + double precision :: mu_local + mu_local = mu_erf_dft allocate(rhoa(N_states), rhob(N_states)) do istate = 1, N_states do i = 1, n_points_final_grid @@ -162,8 +158,6 @@ END_PROVIDER weight = final_weight_at_r_vector(i) rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) - double precision :: mu_local - mu_local = mu_of_r_dft(i) call ec_lda_sr(mu_local,rhoa(istate),rhob(istate),e_c,sr_vc_a,sr_vc_b) call ex_lda_sr(mu_local,rhoa(istate),rhob(istate),e_x,sr_vx_a,sr_vx_b) do j =1, ao_num diff --git a/src/functionals/sr_pbe.irp.f b/src/functionals/sr_pbe.irp.f index 7053cfb6..93c51067 100644 --- a/src/functionals/sr_pbe.irp.f +++ b/src/functionals/sr_pbe.irp.f @@ -35,11 +35,9 @@ grad_rho_b_2 += grad_rho_b(m) * grad_rho_b(m) grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m) enddo - - double precision :: mu_local - mu_local = mu_of_r_dft(i) + ! inputs - call GGA_sr_type_functionals(mu_local,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange + call GGA_sr_type_functionals(mu_erf_dft,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b ) energy_x_sr_pbe(istate) += ex * weight @@ -137,10 +135,8 @@ END_PROVIDER grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m) enddo - double precision :: mu_local - mu_local = mu_of_r_dft(i) ! inputs - call GGA_sr_type_functionals(mu_local,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange + call GGA_sr_type_functionals(mu_erf_dft,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b ) vx_rho_a *= weight @@ -296,10 +292,8 @@ END_PROVIDER grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m) enddo - double precision :: mu_local - mu_local = mu_of_r_dft(i) ! inputs - call GGA_sr_type_functionals(mu_local,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange + call GGA_sr_type_functionals(mu_erf_dft,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b ) vx_rho_a *= weight diff --git a/src/iterations/print_extrapolation.irp.f b/src/iterations/print_extrapolation.irp.f index 7c6dbb9b..cb46fb67 100644 --- a/src/iterations/print_extrapolation.irp.f +++ b/src/iterations/print_extrapolation.irp.f @@ -35,13 +35,12 @@ subroutine print_extrapolated_energy do k=2,min(N_iter,8) write(*,'(F11.4,X,3(X,F18.8))') pt2_iterations(i,N_iter+1-k), extrapolated_energy(k,i), & extrapolated_energy(k,i) - extrapolated_energy(k,1), & - (extrapolated_energy(k,i) - extrapolated_energy(k,1) ) * ha_to_ev + (extrapolated_energy(k,i) - extrapolated_energy(k,1) ) * 27.211396641308d0 enddo write(*,*) '=========== ', '=================== ', '=================== ', '===================' enddo print *, '' - call ezfio_set_fci_energy_extrapolated(extrapolated_energy(min(N_iter,3),1:N_states)) end subroutine diff --git a/src/iterations/print_summary.irp.f b/src/iterations/print_summary.irp.f index a0db3534..641ee209 100644 --- a/src/iterations/print_summary.irp.f +++ b/src/iterations/print_summary.irp.f @@ -36,7 +36,7 @@ subroutine print_summary(e_,pt2_data,pt2_data_err,n_det_,n_configuration_,n_st,s write(*,fmt) '# E ', e_(1:N_states_p) if (N_states_p > 1) then write(*,fmt) '# Excit. (au)', e_(1:N_states_p)-e_(1) - write(*,fmt) '# Excit. (eV)', (e_(1:N_states_p)-e_(1))*ha_to_ev + write(*,fmt) '# Excit. (eV)', (e_(1:N_states_p)-e_(1))*27.211396641308d0 endif write(fmt,*) '(A13,', 2*N_states_p, '(1X,F14.8))' write(*,fmt) '# PT2 '//pt2_string, (pt2_data % pt2(k), pt2_data_err % pt2(k), k=1,N_states_p) @@ -47,8 +47,8 @@ subroutine print_summary(e_,pt2_data,pt2_data_err,n_det_,n_configuration_,n_st,s if (N_states_p > 1) then write(*,fmt) '# Excit. (au)', ( (e_(k)+pt2_data % pt2(k)-e_(1)-pt2_data % pt2(1)), & dsqrt(pt2_data_err % pt2(k)*pt2_data_err % pt2(k)+pt2_data_err % pt2(1)*pt2_data_err % pt2(1)), k=1,N_states_p) - write(*,fmt) '# Excit. (eV)', ( (e_(k)+pt2_data % pt2(k)-e_(1)-pt2_data % pt2(1))*ha_to_ev, & - dsqrt(pt2_data_err % pt2(k)*pt2_data_err % pt2(k)+pt2_data_err % pt2(1)*pt2_data_err % pt2(1))*ha_to_ev, k=1,N_states_p) + write(*,fmt) '# Excit. (eV)', ( (e_(k)+pt2_data % pt2(k)-e_(1)-pt2_data % pt2(1))*27.211396641308d0, & + dsqrt(pt2_data_err % pt2(k)*pt2_data_err % pt2(k)+pt2_data_err % pt2(1)*pt2_data_err % pt2(1))*27.211396641308d0, k=1,N_states_p) endif write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))' write(*,fmt) @@ -82,23 +82,23 @@ subroutine print_summary(e_,pt2_data,pt2_data_err,n_det_,n_configuration_,n_st,s print *, 'Variational Energy difference (au | eV)' do i=2, N_states_p print*,'Delta E = ', (e_(i) - e_(1)), & - (e_(i) - e_(1)) * ha_to_ev + (e_(i) - e_(1)) * 27.211396641308d0 enddo print *, '-----' print*, 'Variational + perturbative Energy difference (au | eV)' do i=2, N_states_p print*,'Delta E = ', (e_(i)+ pt2_data % pt2(i) - (e_(1) + pt2_data % pt2(1))), & - (e_(i)+ pt2_data % pt2(i) - (e_(1) + pt2_data % pt2(1))) * ha_to_ev + (e_(i)+ pt2_data % pt2(i) - (e_(1) + pt2_data % pt2(1))) * 27.211396641308d0 enddo print *, '-----' print*, 'Variational + renormalized perturbative Energy difference (au | eV)' do i=2, N_states_p print*,'Delta E = ', (e_(i)+ pt2_data % rpt2(i) - (e_(1) + pt2_data % rpt2(1))), & - (e_(i)+ pt2_data % rpt2(i) - (e_(1) + pt2_data % rpt2(1))) * ha_to_ev + (e_(i)+ pt2_data % rpt2(i) - (e_(1) + pt2_data % rpt2(1))) * 27.211396641308d0 enddo endif -! call print_energy_components() + call print_energy_components() end subroutine diff --git a/src/kohn_sham_rs/rs_ks_scf.irp.f b/src/kohn_sham_rs/rs_ks_scf.irp.f index 84b85136..5d23544e 100644 --- a/src/kohn_sham_rs/rs_ks_scf.irp.f +++ b/src/kohn_sham_rs/rs_ks_scf.irp.f @@ -17,7 +17,7 @@ program rs_ks_scf print*, '**************************' print*, 'mu_erf_dft = ',mu_erf_dft print*, '**************************' -! call check_coherence_functional + call check_coherence_functional call create_guess call orthonormalize_mos call run diff --git a/src/mo_basis/mos_in_r.irp.f b/src/mo_basis/mos_in_r.irp.f index e5d3b243..ee2795d0 100644 --- a/src/mo_basis/mos_in_r.irp.f +++ b/src/mo_basis/mos_in_r.irp.f @@ -1,9 +1,6 @@ subroutine give_all_mos_at_r(r,mos_array) implicit none - BEGIN_DOC -! mos_array(i) = ith MO function evaluated at "r" - END_DOC double precision, intent(in) :: r(3) double precision, intent(out) :: mos_array(mo_num) double precision :: aos_array(ao_num) diff --git a/src/mo_guess/h_core_guess_routine.irp.f b/src/mo_guess/h_core_guess_routine.irp.f index fcbdde49..cbf23a9a 100644 --- a/src/mo_guess/h_core_guess_routine.irp.f +++ b/src/mo_guess/h_core_guess_routine.irp.f @@ -7,7 +7,7 @@ subroutine hcore_guess label = 'Guess' call mo_as_eigvectors_of_mo_matrix(mo_one_e_integrals, & size(mo_one_e_integrals,1), & - size(mo_one_e_integrals,2),label,1,.true.) + size(mo_one_e_integrals,2),label,1,.false.) call nullify_small_elements(ao_num, mo_num, mo_coef, size(mo_coef,1), 1.d-12 ) call save_mos TOUCH mo_coef mo_label diff --git a/src/mo_two_e_erf_ints/map_integrals_erf.irp.f b/src/mo_two_e_erf_ints/map_integrals_erf.irp.f index 3405ec2b..73050ec5 100644 --- a/src/mo_two_e_erf_ints/map_integrals_erf.irp.f +++ b/src/mo_two_e_erf_ints/map_integrals_erf.irp.f @@ -235,11 +235,11 @@ subroutine get_mo_two_e_integrals_erf_ij(k,l,sze,out_array,map) logical :: integral_is_in_map if (key_kind == 8) then - call i8sort(hash,iorder,kk) + call i8radix_sort(hash,iorder,kk,-1) else if (key_kind == 4) then - call isort(hash,iorder,kk) + call iradix_sort(hash,iorder,kk,-1) else if (key_kind == 2) then - call i2sort(hash,iorder,kk) + call i2radix_sort(hash,iorder,kk,-1) endif call map_get_many(mo_integrals_erf_map, hash, tmp_val, kk) @@ -290,11 +290,11 @@ subroutine get_mo_two_e_integrals_erf_i1j1(k,l,sze,out_array,map) logical :: integral_is_in_map if (key_kind == 8) then - call i8sort(hash,iorder,kk) + call i8radix_sort(hash,iorder,kk,-1) else if (key_kind == 4) then - call isort(hash,iorder,kk) + call iradix_sort(hash,iorder,kk,-1) else if (key_kind == 2) then - call i2sort(hash,iorder,kk) + call i2radix_sort(hash,iorder,kk,-1) endif call map_get_many(mo_integrals_erf_map, hash, tmp_val, kk) diff --git a/src/mo_two_e_ints/core_quantities.irp.f b/src/mo_two_e_ints/core_quantities.irp.f index b764a1a6..3642365e 100644 --- a/src/mo_two_e_ints/core_quantities.irp.f +++ b/src/mo_two_e_ints/core_quantities.irp.f @@ -53,7 +53,7 @@ BEGIN_PROVIDER [ double precision, h_core_ri, (mo_num, mo_num) ] enddo do k=1,mo_num do i=1,mo_num - h_core_ri(i,j) = h_core_ri(i,j) - 0.5 * big_array_exchange_integrals(k,i,j) + h_core_ri(i,j) = h_core_ri(i,j) - 0.5d0 * big_array_exchange_integrals(k,i,j) enddo enddo enddo diff --git a/src/mo_two_e_ints/map_integrals.irp.f b/src/mo_two_e_ints/map_integrals.irp.f index 272916e3..9f73d518 100644 --- a/src/mo_two_e_ints/map_integrals.irp.f +++ b/src/mo_two_e_ints/map_integrals.irp.f @@ -302,21 +302,21 @@ end integer(key_kind) :: idx double precision :: tmp -!icount = 1 ! Avoid division by zero -!do j=1,mo_num -! do i=1,j-1 -! call two_e_integrals_index(i,j,j,i,idx) -! !DIR$ FORCEINLINE -! call map_get(mo_integrals_map,idx,tmp) -! banned_excitation(i,j) = dabs(tmp) < 1.d-14 -! banned_excitation(j,i) = banned_excitation(i,j) -! if (banned_excitation(i,j)) icount = icount+2 -! enddo -!enddo -!use_banned_excitation = (mo_num*mo_num) / icount <= 100 !1% -!if (use_banned_excitation) then -! print *, 'Using sparsity of exchange integrals' -!endif + icount = 1 ! Avoid division by zero + do j=1,mo_num + do i=1,j-1 + call two_e_integrals_index(i,j,j,i,idx) + !DIR$ FORCEINLINE + call map_get(mo_integrals_map,idx,tmp) + banned_excitation(i,j) = dabs(tmp) < 1.d-14 + banned_excitation(j,i) = banned_excitation(i,j) + if (banned_excitation(i,j)) icount = icount+2 + enddo + enddo + use_banned_excitation = (mo_num*mo_num) / icount <= 100 !1% + if (use_banned_excitation) then + print *, 'Using sparsity of exchange integrals' + endif END_PROVIDER diff --git a/src/mo_two_e_ints/mo_bi_integrals.irp.f b/src/mo_two_e_ints/mo_bi_integrals.irp.f index 6f4c5c17..d58932ce 100644 --- a/src/mo_two_e_ints/mo_bi_integrals.irp.f +++ b/src/mo_two_e_ints/mo_bi_integrals.irp.f @@ -53,11 +53,7 @@ BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ] ! call four_idx_novvvv call four_idx_novvvv_old else - if (32.d-9*dble(ao_num)**4 < dble(qp_max_mem)) then - call four_idx_dgemm - else - call add_integrals_to_map(full_ijkl_bitmask_4) - endif + call add_integrals_to_map(full_ijkl_bitmask_4) endif call wall_time(wall_2) @@ -81,94 +77,6 @@ BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ] END_PROVIDER -subroutine four_idx_dgemm - implicit none - integer :: p,q,r,s,i,j,k,l - double precision, allocatable :: a1(:,:,:,:) - double precision, allocatable :: a2(:,:,:,:) - - allocate (a1(ao_num,ao_num,ao_num,ao_num)) - - print *, 'Getting AOs' - !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(q,r,s) - do s=1,ao_num - do r=1,ao_num - do q=1,ao_num - call get_ao_two_e_integrals(q,r,s,ao_num,a1(1,q,r,s)) - enddo - enddo - enddo - !$OMP END PARALLEL DO - - print *, '1st transformation' - ! 1st transformation - allocate (a2(ao_num,ao_num,ao_num,mo_num)) - call dgemm('T','N', (ao_num*ao_num*ao_num), mo_num, ao_num, 1.d0, a1, ao_num, mo_coef, ao_num, 0.d0, a2, (ao_num*ao_num*ao_num)) - - ! 2nd transformation - print *, '2nd transformation' - deallocate (a1) - allocate (a1(ao_num,ao_num,mo_num,mo_num)) - call dgemm('T','N', (ao_num*ao_num*mo_num), mo_num, ao_num, 1.d0, a2, ao_num, mo_coef, ao_num, 0.d0, a1, (ao_num*ao_num*mo_num)) - - ! 3rd transformation - print *, '3rd transformation' - deallocate (a2) - allocate (a2(ao_num,mo_num,mo_num,mo_num)) - call dgemm('T','N', (ao_num*mo_num*mo_num), mo_num, ao_num, 1.d0, a1, ao_num, mo_coef, ao_num, 0.d0, a2, (ao_num*mo_num*mo_num)) - - ! 4th transformation - print *, '4th transformation' - deallocate (a1) - allocate (a1(mo_num,mo_num,mo_num,mo_num)) - call dgemm('T','N', (mo_num*mo_num*mo_num), mo_num, ao_num, 1.d0, a2, ao_num, mo_coef, ao_num, 0.d0, a1, (mo_num*mo_num*mo_num)) - - deallocate (a2) - - integer :: n_integrals, size_buffer - integer(key_kind) , allocatable :: buffer_i(:) - real(integral_kind), allocatable :: buffer_value(:) - size_buffer = min(ao_num*ao_num*ao_num,16000000) - - !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l,buffer_value,buffer_i,n_integrals) - allocate ( buffer_i(size_buffer), buffer_value(size_buffer) ) - - n_integrals = 0 - !$OMP DO - do l=1,mo_num - do k=1,mo_num - do j=1,l - do i=1,k - if (abs(a1(i,j,k,l)) < mo_integrals_threshold) then - cycle - endif - n_integrals += 1 - buffer_value(n_integrals) = a1(i,j,k,l) - !DIR$ FORCEINLINE - call mo_two_e_integrals_index(i,j,k,l,buffer_i(n_integrals)) - if (n_integrals == size_buffer) then - call map_append(mo_integrals_map, buffer_i, buffer_value, n_integrals) - n_integrals = 0 - endif - enddo - enddo - enddo - enddo - !$OMP END DO - - call map_append(mo_integrals_map, buffer_i, buffer_value, n_integrals) - - deallocate(buffer_i, buffer_value) - !$OMP END PARALLEL - - deallocate (a1) - - call map_unique(mo_integrals_map) - - integer*8 :: get_mo_map_size, mo_map_size - mo_map_size = get_mo_map_size() - -end subroutine subroutine add_integrals_to_map(mask_ijkl) use bitmasks diff --git a/src/mu_of_r/basis_def.irp.f b/src/mu_of_r/basis_def.irp.f index fff9f581..4da27cb0 100644 --- a/src/mu_of_r/basis_def.irp.f +++ b/src/mu_of_r/basis_def.irp.f @@ -76,11 +76,7 @@ BEGIN_PROVIDER [integer, n_basis_orb] ! ! It corresponds to all MOs except those defined as "deleted" END_DOC - if(mu_of_r_potential == "pure_act")then - n_basis_orb = n_act_orb - else - n_basis_orb = n_all_but_del_orb - endif + n_basis_orb = n_all_but_del_orb END_PROVIDER BEGIN_PROVIDER [integer, list_basis, (n_basis_orb)] @@ -93,15 +89,9 @@ BEGIN_PROVIDER [integer, list_basis, (n_basis_orb)] ! It corresponds to all MOs except those defined as "deleted" END_DOC integer :: i - if(mu_of_r_potential == "pure_act")then - do i = 1, n_act_orb - list_basis(i) = list_act(i) - enddo - else - do i = 1, n_all_but_del_orb - list_basis(i) = list_all_but_del_orb(i) - enddo - endif + do i = 1, n_all_but_del_orb + list_basis(i) = list_all_but_del_orb(i) + enddo END_PROVIDER BEGIN_PROVIDER [double precision, basis_mos_in_r_array, (n_basis_orb,n_points_final_grid)] diff --git a/src/mu_of_r/mu_of_r_conditions.irp.f b/src/mu_of_r/mu_of_r_conditions.irp.f index 5c41acdc..148c65b3 100644 --- a/src/mu_of_r/mu_of_r_conditions.irp.f +++ b/src/mu_of_r/mu_of_r_conditions.irp.f @@ -26,7 +26,7 @@ do ipoint = 1, n_points_final_grid if(mu_of_r_potential.EQ."hf")then mu_of_r_prov(ipoint,istate) = mu_of_r_hf(ipoint) - else if(mu_of_r_potential.EQ."cas_ful".or.mu_of_r_potential.EQ."cas_truncated".or.mu_of_r_potential.EQ."pure_act")then + else if(mu_of_r_potential.EQ."cas_ful".or.mu_of_r_potential.EQ."cas_truncated")then mu_of_r_prov(ipoint,istate) = mu_of_r_psi_cas(ipoint,istate) else print*,'you requested the following mu_of_r_potential' diff --git a/src/scf_utils/scf_density_matrix_ao.irp.f b/src/scf_utils/scf_density_matrix_ao.irp.f index 55fa8e7c..639855b3 100644 --- a/src/scf_utils/scf_density_matrix_ao.irp.f +++ b/src/scf_utils/scf_density_matrix_ao.irp.f @@ -9,6 +9,17 @@ BEGIN_PROVIDER [double precision, SCF_density_matrix_ao_alpha, (ao_num,ao_num) ] mo_coef, size(mo_coef,1), 0.d0, & SCF_density_matrix_ao_alpha, size(SCF_density_matrix_ao_alpha,1)) +! integer :: i, j +! double precision :: trace_density +! trace_density = 0.d0 +! do i = 1, ao_num !elec_alpha_num +! do j = 1, ao_num !elec_alpha_num +! trace_density = trace_density & +! + SCF_density_matrix_ao_alpha(j,i) * ao_overlap(j,i) +! enddo +! enddo +! print *, ' trace of SCF_density_matrix_ao_alpha =', trace_density + END_PROVIDER BEGIN_PROVIDER [ double precision, SCF_density_matrix_ao_beta, (ao_num,ao_num) ] diff --git a/src/tools/NEED b/src/tools/NEED index 0f4e17b0..c07c9109 100644 --- a/src/tools/NEED +++ b/src/tools/NEED @@ -2,4 +2,3 @@ fci mo_two_e_erf_ints aux_quantities hartree_fock -two_body_rdm diff --git a/src/tools/molden.irp.f b/src/tools/molden.irp.f index 830a141e..417b25ad 100644 --- a/src/tools/molden.irp.f +++ b/src/tools/molden.irp.f @@ -52,8 +52,8 @@ program molden l += 1 if (l > ao_num) exit enddo + write(i_unit_output,*)'' enddo - write(i_unit_output,*)'' enddo diff --git a/src/tools/print_dipole.irp.f b/src/tools/print_dipole.irp.f index 8db9aa09..8351308e 100644 --- a/src/tools/print_dipole.irp.f +++ b/src/tools/print_dipole.irp.f @@ -1,7 +1,5 @@ program print_dipole implicit none - read_wf = .True. - TOUCH read_wf - call print_dipole_moments + call print_z_dipole_moment_only end diff --git a/src/tools/print_wf.irp.f b/src/tools/print_wf.irp.f index 64eb1a1f..7e51caaf 100644 --- a/src/tools/print_wf.irp.f +++ b/src/tools/print_wf.irp.f @@ -32,9 +32,8 @@ subroutine routine double precision :: norm_mono_a,norm_mono_b double precision :: norm_mono_a_2,norm_mono_b_2 double precision :: norm_mono_a_pert_2,norm_mono_b_pert_2 - double precision :: norm_mono_a_pert,norm_mono_b_pert,norm_double_1 + double precision :: norm_mono_a_pert,norm_mono_b_pert double precision :: delta_e,coef_2_2 - norm_mono_a = 0.d0 norm_mono_b = 0.d0 norm_mono_a_2 = 0.d0 @@ -43,7 +42,6 @@ subroutine routine norm_mono_b_pert = 0.d0 norm_mono_a_pert_2 = 0.d0 norm_mono_b_pert_2 = 0.d0 - norm_double_1 = 0.d0 do i = 1, min(N_det_print_wf,N_det) print*,'' print*,'i = ',i @@ -95,7 +93,6 @@ subroutine routine print*,'h1,p1 = ',h1,p1 print*,'s2',s2 print*,'h2,p2 = ',h2,p2 - norm_double_1 += dabs(psi_coef_sorted(i,1)/psi_coef_sorted(1,1)) endif print*,' = ',hij @@ -112,7 +109,6 @@ subroutine routine print*,'' print*,'L1 norm of mono alpha = ',norm_mono_a print*,'L1 norm of mono beta = ',norm_mono_b - print*,'L1 norm of double exc = ',norm_double_1 print*, '---' print*,'L2 norm of mono alpha = ',norm_mono_a_2 print*,'L2 norm of mono beta = ',norm_mono_b_2 diff --git a/src/tools/save_natorb_no_ov_rot.irp.f b/src/tools/save_natorb_no_ov_rot.irp.f deleted file mode 100644 index e5b69fbf..00000000 --- a/src/tools/save_natorb_no_ov_rot.irp.f +++ /dev/null @@ -1,25 +0,0 @@ -program save_natorb - implicit none - BEGIN_DOC -! Save natural |MOs| into the |EZFIO|. -! -! This program reads the wave function stored in the |EZFIO| directory, -! extracts the corresponding natural orbitals and setd them as the new -! |MOs|. -! -! If this is a multi-state calculation, the density matrix that produces -! the natural orbitals is obtained from an average of the density -! matrices of each state with the corresponding -! :option:`determinants state_average_weight` - END_DOC - read_wf = .True. - touch read_wf - call save_natural_mos_no_ov_rot - call save_ref_determinant - call ezfio_set_mo_two_e_ints_io_mo_two_e_integrals('None') - call ezfio_set_mo_one_e_ints_io_mo_one_e_integrals('None') - call ezfio_set_mo_one_e_ints_io_mo_integrals_kinetic('None') - call ezfio_set_mo_one_e_ints_io_mo_integrals_n_e('None') - call ezfio_set_mo_one_e_ints_io_mo_integrals_pseudo('None') -end - diff --git a/src/tools/save_natorb_no_ref.irp.f b/src/tools/save_natorb_no_ref.irp.f deleted file mode 100644 index 9d253fa0..00000000 --- a/src/tools/save_natorb_no_ref.irp.f +++ /dev/null @@ -1,24 +0,0 @@ -program save_natorb - implicit none - BEGIN_DOC -! Save natural |MOs| into the |EZFIO|. -! -! This program reads the wave function stored in the |EZFIO| directory, -! extracts the corresponding natural orbitals and setd them as the new -! |MOs|. -! -! If this is a multi-state calculation, the density matrix that produces -! the natural orbitals is obtained from an average of the density -! matrices of each state with the corresponding -! :option:`determinants state_average_weight` - END_DOC - read_wf = .True. - touch read_wf - call save_natural_mos_canon_label - call ezfio_set_mo_two_e_ints_io_mo_two_e_integrals('None') - call ezfio_set_mo_one_e_ints_io_mo_one_e_integrals('None') - call ezfio_set_mo_one_e_ints_io_mo_integrals_kinetic('None') - call ezfio_set_mo_one_e_ints_io_mo_integrals_n_e('None') - call ezfio_set_mo_one_e_ints_io_mo_integrals_pseudo('None') -end - diff --git a/src/tools/truncate_wf.irp.f b/src/tools/truncate_wf.irp.f deleted file mode 100644 index 64c15bf7..00000000 --- a/src/tools/truncate_wf.irp.f +++ /dev/null @@ -1,110 +0,0 @@ -program truncate_wf - implicit none - BEGIN_DOC -! Truncate the wave function - END_DOC - read_wf = .True. - if (s2_eig) then - call routine_s2 - else - call routine - endif -end - -subroutine routine - implicit none - integer :: ndet_max - print*, 'Max number of determinants ?' - read(5,*) ndet_max - integer(bit_kind), allocatable :: psi_det_tmp(:,:,:) - double precision, allocatable :: psi_coef_tmp(:,:) - allocate(psi_det_tmp(N_int,2,ndet_max),psi_coef_tmp(ndet_max, N_states)) - - integer :: i,j - double precision :: accu(N_states) - accu = 0.d0 - do i = 1, ndet_max - do j = 1, N_int - psi_det_tmp(j,1,i) = psi_det_sorted(j,1,i) - psi_det_tmp(j,2,i) = psi_det_sorted(j,2,i) - enddo - do j = 1, N_states - psi_coef_tmp(i,j) = psi_coef_sorted(i,j) - accu(j) += psi_coef_tmp(i,j) **2 - enddo - enddo - do j = 1, N_states - accu(j) = 1.d0/dsqrt(accu(j)) - enddo - do j = 1, N_states - do i = 1, ndet_max - psi_coef_tmp(i,j) = psi_coef_tmp(i,j) * accu(j) - enddo - enddo - - call save_wavefunction_general(ndet_max,N_states,psi_det_tmp,size(psi_coef_tmp,1),psi_coef_tmp) - -end - -subroutine routine_s2 - implicit none - integer :: ndet_max - double precision :: wmin - integer(bit_kind), allocatable :: psi_det_tmp(:,:,:) - double precision, allocatable :: psi_coef_tmp(:,:) - integer :: i,j,k - double precision :: accu(N_states) - integer :: weights(0:16), ix - double precision :: x - - weights(:) = 0 - do i=1,N_det - x = -dlog(1.d-32+sum(weight_configuration(det_to_configuration(i),:)))/dlog(10.d0) - ix = min(int(x), 16) - weights(ix) += 1 - enddo - - print *, 'Histogram of the weights of the CFG' - do i=0,15 - print *, ' 10^{-', i, '} ', weights(i) - end do - print *, '< 10^{-', 15, '} ', weights(16) - - - print*, 'Min weight of the configuration?' - read(5,*) wmin - - ndet_max = 0 - do i=1,N_det - if (maxval(weight_configuration( det_to_configuration(i),:)) < wmin) cycle - ndet_max = ndet_max+1 - enddo - - allocate(psi_det_tmp(N_int,2,ndet_max),psi_coef_tmp(ndet_max, N_states)) - - accu = 0.d0 - k=0 - do i = 1, N_det - if (maxval(weight_configuration( det_to_configuration(i),:)) < wmin) cycle - k = k+1 - do j = 1, N_int - psi_det_tmp(j,1,k) = psi_det(j,1,i) - psi_det_tmp(j,2,k) = psi_det(j,2,i) - enddo - do j = 1, N_states - psi_coef_tmp(k,j) = psi_coef(i,j) - accu(j) += psi_coef_tmp(k,j)**2 - enddo - enddo - do j = 1, N_states - accu(j) = 1.d0/dsqrt(accu(j)) - enddo - do j = 1, N_states - do i = 1, ndet_max - psi_coef_tmp(i,j) = psi_coef_tmp(i,j) * accu(j) - enddo - enddo - - call save_wavefunction_general(ndet_max,N_states,psi_det_tmp,size(psi_coef_tmp,1),psi_coef_tmp) - -end diff --git a/src/two_body_rdm/two_e_dm_mo.irp.f b/src/two_body_rdm/two_e_dm_mo.irp.f index a4dea15f..4dadd2e6 100644 --- a/src/two_body_rdm/two_e_dm_mo.irp.f +++ b/src/two_body_rdm/two_e_dm_mo.irp.f @@ -1,8 +1,9 @@ BEGIN_PROVIDER [double precision, two_e_dm_mo, (mo_num,mo_num,mo_num,mo_num)] implicit none BEGIN_DOC - ! \sum_{\sigma \sigma'} - ! + ! two_e_dm_bb_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons + ! + ! ! ! where the indices (i,j,k,l) belong to all MOs. ! @@ -11,7 +12,7 @@ BEGIN_PROVIDER [double precision, two_e_dm_mo, (mo_num,mo_num,mo_num,mo_num)] ! !!!!! WARNING !!!!! IF "no_core_density" then all elements involving at least one CORE MO are set to zero ! The state-averaged two-electron energy : ! - ! \sum_{i,j,k,l = 1, mo_num} two_e_dm_mo(i,j,k,l) * < kk ll | ii jj > + ! \sum_{i,j,k,l = 1, mo_num} two_e_dm_mo(i,j,k,l) * < ii jj | kk ll > END_DOC two_e_dm_mo = 0.d0 integer :: i,j,k,l,iorb,jorb,korb,lorb,istate diff --git a/src/two_rdm_routines/davidson_like_state_av_2rdm.irp.f b/src/two_rdm_routines/davidson_like_state_av_2rdm.irp.f index 26ed5ae6..eb247dea 100644 --- a/src/two_rdm_routines/davidson_like_state_av_2rdm.irp.f +++ b/src/two_rdm_routines/davidson_like_state_av_2rdm.irp.f @@ -529,14 +529,10 @@ subroutine orb_range_2_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,list_ c_average += c_1(l) * c_1(l) * state_weights(l) enddo - if (nkeys > 0) then - call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) - endif + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 call orb_range_diag_to_all_2_rdm_dm_buffer(tmp_det,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) - if (nkeys > 0) then - call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) - endif + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 end do diff --git a/src/utils/EZFIO.cfg b/src/utils/EZFIO.cfg index 7d367f0c..9e9a62f1 100644 --- a/src/utils/EZFIO.cfg +++ b/src/utils/EZFIO.cfg @@ -3,3 +3,4 @@ type: logical doc: If true, try to find symmetry in the MO coefficient matrices interface: ezfio,provider,ocaml default: False + diff --git a/src/utils/cgtos_one_e.irp.f b/src/utils/cgtos_one_e.irp.f new file mode 100644 index 00000000..43ca8224 --- /dev/null +++ b/src/utils/cgtos_one_e.irp.f @@ -0,0 +1,120 @@ + +! --- + +complex*16 function overlap_cgaussian_x(A_center, B_center, alpha, beta, power_A, power_B, dim) + + BEGIN_DOC + ! + ! \int_{-infty}^{+infty} (x-A_x)^ax (x-B_x)^bx exp(-alpha (x-A_x)^2) exp(- beta(x-B_X)^2) dx + ! with complex arguments + ! + END_DOC + + implicit none + include 'constants.include.F' + + integer, intent(in) :: dim, power_A, power_B + complex*16, intent(in) :: A_center, B_center, alpha, beta + + integer :: i, iorder_p + double precision :: fact_p_mod + complex*16 :: P_new(0:max_dim), P_center, fact_p, p, inv_sq_p + + complex*16 :: Fc_integral + + + call give_explicit_cpoly_and_cgaussian_x( P_new, P_center, p, fact_p, iorder_p & + , alpha, beta, power_A, power_B, A_center, B_center, dim) + + fact_p_mod = dsqrt(real(fact_p)*real(fact_p) + aimag(fact_p)*aimag(fact_p)) + if(fact_p_mod .lt. 1.d-14) then + overlap_cgaussian_x = (0.d0, 0.d0) + return + endif + + + inv_sq_p = (1.d0, 0.d0) / zsqrt(p) + + overlap_cgaussian_x = (0.d0, 0.d0) + do i = 0, iorder_p + overlap_cgaussian_x += P_new(i) * Fc_integral(i, inv_sq_p) + enddo + + overlap_cgaussian_x *= fact_p + +end function overlap_cgaussian_x + +! --- + +subroutine overlap_cgaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B & + , overlap_x, overlap_y, overlap_z, overlap, dim ) + + BEGIN_DOC + ! + ! S_x = \int (x-A_x)^{a_x} exp(-\alpha(x-A_x)^2) (x-B_x)^{b_x} exp(-beta(x-B_x)^2) dx + ! S = S_x S_y S_z + ! for complex arguments + ! + END_DOC + + implicit none + include 'constants.include.F' + + integer, intent(in) :: dim, power_A(3), power_B(3) + complex*16, intent(in) :: A_center(3), B_center(3), alpha, beta + complex*16, intent(out) :: overlap_x, overlap_y, overlap_z, overlap + + integer :: i, nmax, iorder_p(3) + double precision :: fact_p_mod + complex*16 :: P_new(0:max_dim,3), P_center(3), fact_p, p, inv_sq_p + complex*16 :: F_integral_tab(0:max_dim) + + complex*16 :: Fc_integral + + call give_explicit_cpoly_and_cgaussian(P_new, P_center, p, fact_p, iorder_p, alpha, beta, power_A, power_B, A_center, B_center, dim) + + fact_p_mod = dsqrt(real(fact_p)*real(fact_p) + aimag(fact_p)*aimag(fact_p)) + if(fact_p_mod .lt. 1.d-14) then + overlap_x = (1.d-10, 0.d0) + overlap_y = (1.d-10, 0.d0) + overlap_z = (1.d-10, 0.d0) + overlap = (1.d-10, 0.d0) + return + endif + + nmax = maxval(iorder_p) + + inv_sq_p = (1.d0, 0.d0) / zsqrt(p) + do i = 0, nmax + F_integral_tab(i) = Fc_integral(i, inv_sq_p) + enddo + + overlap_x = P_new(0,1) * F_integral_tab(0) + overlap_y = P_new(0,2) * F_integral_tab(0) + overlap_z = P_new(0,3) * F_integral_tab(0) + + do i = 1, iorder_p(1) + overlap_x = overlap_x + P_new(i,1) * F_integral_tab(i) + enddo + call cgaussian_product_x(alpha, A_center(1), beta, B_center(1), fact_p, p, P_center(1)) + overlap_x *= fact_p + + do i = 1, iorder_p(2) + overlap_y = overlap_y + P_new(i,2) * F_integral_tab(i) + enddo + call cgaussian_product_x(alpha, A_center(2), beta, B_center(2), fact_p, p, P_center(2)) + overlap_y *= fact_p + + do i = 1, iorder_p(3) + overlap_z = overlap_z + P_new(i,3) * F_integral_tab(i) + enddo + call cgaussian_product_x(alpha, A_center(3), beta, B_center(3), fact_p, p, P_center(3)) + overlap_z *= fact_p + + overlap = overlap_x * overlap_y * overlap_z + +end subroutine overlap_cgaussian_xyz + +! --- + + diff --git a/src/utils/cgtos_utils.irp.f b/src/utils/cgtos_utils.irp.f new file mode 100644 index 00000000..a820d5f2 --- /dev/null +++ b/src/utils/cgtos_utils.irp.f @@ -0,0 +1,780 @@ + +! --- + +subroutine give_explicit_cpoly_and_cgaussian_x(P_new, P_center, p, fact_k, iorder, alpha, beta, a, b, A_center, B_center, dim) + + BEGIN_DOC + ! Transform the product of + ! (x-x_A)^a (x-x_B)^b exp(-(r-A)^2 alpha) exp(-(r-B)^2 beta) + ! into + ! fact_k \sum_{i=0}^{iorder} (x-x_P)^i exp(-p(r-P)^2) + END_DOC + + implicit none + include 'constants.include.F' + + integer, intent(in) :: dim + integer, intent(in) :: a, b + complex*16, intent(in) :: alpha, beta, A_center, B_center + integer, intent(out) :: iorder + complex*16, intent(out) :: p, P_center, fact_k + complex*16, intent(out) :: P_new(0:max_dim) + + integer :: n_new, i, j + double precision :: tmp_mod + complex*16 :: P_a(0:max_dim), P_b(0:max_dim) + complex*16 :: p_inv, ab, d_AB, tmp + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: P_a, P_b + + P_new = (0.d0, 0.d0) + + ! new exponent + p = alpha + beta + + ! new center + p_inv = (1.d0, 0.d0) / p + ab = alpha * beta + P_center = (alpha * A_center + beta * B_center) * p_inv + + ! get the factor + d_AB = (A_center - B_center) * (A_center - B_center) + tmp = ab * p_inv * d_AB + tmp_mod = dsqrt(REAL(tmp)*REAL(tmp) + AIMAG(tmp)*AIMAG(tmp)) + if(tmp_mod .lt. 50.d0) then + fact_k = zexp(-tmp) + else + fact_k = (0.d0, 0.d0) + endif + + ! Recenter the polynomials P_a and P_b on P_center + !DIR$ FORCEINLINE + call recentered_cpoly2(P_a(0), A_center, P_center, a, P_b(0), B_center, P_center, b) + n_new = 0 + + !DIR$ FORCEINLINE + call multiply_cpoly(P_a(0), a, P_b(0), b, P_new(0), n_new) + iorder = a + b + +end subroutine give_explicit_cpoly_and_cgaussian_x + +! --- + +subroutine give_explicit_cpoly_and_cgaussian(P_new, P_center, p, fact_k, iorder, alpha, beta, a, b, A_center, B_center, dim) + + BEGIN_DOC + ! Transforms the product of + ! (x-x_A)^a(1) (x-x_B)^b(1) (y-y_A)^a(2) (y-y_B)^b(2) (z-z_A)^a(3) (z-z_B)^b(3) exp(-(r-A)^2 alpha) exp(-(r-B)^2 beta) + ! into + ! fact_k * [ sum (l_x = 0,i_order(1)) P_new(l_x,1) * (x-P_center(1))^l_x ] exp (- p (x-P_center(1))^2 ) + ! * [ sum (l_y = 0,i_order(2)) P_new(l_y,2) * (y-P_center(2))^l_y ] exp (- p (y-P_center(2))^2 ) + ! * [ sum (l_z = 0,i_order(3)) P_new(l_z,3) * (z-P_center(3))^l_z ] exp (- p (z-P_center(3))^2 ) + ! + ! WARNING ::: IF fact_k is too smal then: + ! returns a "s" function centered in zero + ! with an inifinite exponent and a zero polynom coef + END_DOC + + implicit none + include 'constants.include.F' + + integer, intent(in) :: dim, a(3), b(3) + complex*16, intent(in) :: alpha, beta, A_center(3), B_center(3) + integer, intent(out) :: iorder(3) + complex*16, intent(out) :: p, P_center(3), fact_k, P_new(0:max_dim,3) + + integer :: n_new, i, j + double precision :: tmp_mod + complex*16 :: P_a(0:max_dim,3), P_b(0:max_dim,3) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: P_a, P_b + + iorder(1) = 0 + iorder(2) = 0 + iorder(3) = 0 + + P_new(0,1) = (0.d0, 0.d0) + P_new(0,2) = (0.d0, 0.d0) + P_new(0,3) = (0.d0, 0.d0) + + !DIR$ FORCEINLINE + call cgaussian_product(alpha, A_center, beta, B_center, fact_k, p, P_center) + + ! IF fact_k is too smal then: returns a "s" function centered in zero + ! with an inifinite exponent and a zero polynom coef + tmp_mod = dsqrt(REAL(fact_k)*REAL(fact_k) + AIMAG(fact_k)*AIMAG(fact_k)) + if(tmp_mod < 1d-14) then + iorder = 0 + p = (1.d+14, 0.d0) + fact_k = (0.d0 , 0.d0) + P_new(0:max_dim,1:3) = (0.d0 , 0.d0) + P_center(1:3) = (0.d0 , 0.d0) + return + endif + + !DIR$ FORCEINLINE + call recentered_cpoly2(P_a(0,1), A_center(1), P_center(1), a(1), P_b(0,1), B_center(1), P_center(1), b(1)) + iorder(1) = a(1) + b(1) + do i = 0, iorder(1) + P_new(i,1) = 0.d0 + enddo + n_new = 0 + !DIR$ FORCEINLINE + call multiply_cpoly(P_a(0,1), a(1), P_b(0,1), b(1), P_new(0,1), n_new) + + !DIR$ FORCEINLINE + call recentered_cpoly2(P_a(0,2), A_center(2), P_center(2), a(2), P_b(0,2), B_center(2), P_center(2), b(2)) + iorder(2) = a(2) + b(2) + do i = 0, iorder(2) + P_new(i,2) = 0.d0 + enddo + n_new = 0 + !DIR$ FORCEINLINE + call multiply_cpoly(P_a(0,2), a(2), P_b(0,2), b(2), P_new(0,2), n_new) + + !DIR$ FORCEINLINE + call recentered_cpoly2(P_a(0,3), A_center(3), P_center(3), a(3), P_b(0,3), B_center(3), P_center(3), b(3)) + iorder(3) = a(3) + b(3) + do i = 0, iorder(3) + P_new(i,3) = 0.d0 + enddo + n_new = 0 + !DIR$ FORCEINLINE + call multiply_cpoly(P_a(0,3), a(3), P_b(0,3), b(3), P_new(0,3), n_new) + +end subroutine give_explicit_cpoly_and_cgaussian + +! --- + +!subroutine give_explicit_poly_and_gaussian_double(P_new,P_center,p,fact_k,iorder,alpha,beta,gama,a,b,A_center,B_center,Nucl_center,dim) +! BEGIN_DOC +! ! Transforms the product of +! ! (x-x_A)^a(1) (x-x_B)^b(1) (x-x_A)^a(2) (y-y_B)^b(2) (z-z_A)^a(3) (z-z_B)^b(3) +! ! exp(-(r-A)^2 alpha) exp(-(r-B)^2 beta) exp(-(r-Nucl_center)^2 gama +! ! +! ! into +! ! fact_k * [ sum (l_x = 0,i_order(1)) P_new(l_x,1) * (x-P_center(1))^l_x ] exp (- p (x-P_center(1))^2 ) +! ! * [ sum (l_y = 0,i_order(2)) P_new(l_y,2) * (y-P_center(2))^l_y ] exp (- p (y-P_center(2))^2 ) +! ! * [ sum (l_z = 0,i_order(3)) P_new(l_z,3) * (z-P_center(3))^l_z ] exp (- p (z-P_center(3))^2 ) +! END_DOC +! implicit none +! include 'constants.include.F' +! integer, intent(in) :: dim +! integer, intent(in) :: a(3),b(3) ! powers : (x-xa)**a_x = (x-A(1))**a(1) +! double precision, intent(in) :: alpha, beta, gama ! exponents +! double precision, intent(in) :: A_center(3) ! A center +! double precision, intent(in) :: B_center (3) ! B center +! double precision, intent(in) :: Nucl_center(3) ! B center +! double precision, intent(out) :: P_center(3) ! new center +! double precision, intent(out) :: p ! new exponent +! double precision, intent(out) :: fact_k ! constant factor +! double precision, intent(out) :: P_new(0:max_dim,3)! polynomial +! integer , intent(out) :: iorder(3) ! i_order(i) = order of the polynomials +! +! double precision :: P_center_tmp(3) ! new center +! double precision :: p_tmp ! new exponent +! double precision :: fact_k_tmp,fact_k_bis ! constant factor +! double precision :: P_new_tmp(0:max_dim,3)! polynomial +! integer :: i,j +! double precision :: binom_func +! +! ! First you transform the two primitives into a sum of primitive with the same center P_center_tmp and gaussian exponent p_tmp +! call give_explicit_cpoly_and_cgaussian(P_new_tmp,P_center_tmp,p_tmp,fact_k_tmp,iorder,alpha,beta,a,b,A_center,B_center,dim) +! ! Then you create the new gaussian from the product of the new one per the Nuclei one +! call cgaussian_product(p_tmp,P_center_tmp,gama,Nucl_center,fact_k_bis,p,P_center) +! fact_k = fact_k_bis * fact_k_tmp +! +! ! Then you build the coefficient of the new polynom +! do i = 0, iorder(1) +! P_new(i,1) = 0.d0 +! do j = i,iorder(1) +! P_new(i,1) = P_new(i,1) + P_new_tmp(j,1) * binom_func(j,j-i) * (P_center(1) - P_center_tmp(1))**(j-i) +! enddo +! enddo +! do i = 0, iorder(2) +! P_new(i,2) = 0.d0 +! do j = i,iorder(2) +! P_new(i,2) = P_new(i,2) + P_new_tmp(j,2) * binom_func(j,j-i) * (P_center(2) - P_center_tmp(2))**(j-i) +! enddo +! enddo +! do i = 0, iorder(3) +! P_new(i,3) = 0.d0 +! do j = i,iorder(3) +! P_new(i,3) = P_new(i,3) + P_new_tmp(j,3) * binom_func(j,j-i) * (P_center(3) - P_center_tmp(3))**(j-i) +! enddo +! enddo +! +!end + +! --- + +subroutine cgaussian_product(a, xa, b, xb, k, p, xp) + + BEGIN_DOC + ! complex Gaussian product + ! e^{-a (r-r_A)^2} e^{-b (r-r_B)^2} = k e^{-p (r-r_P)^2} + END_DOC + + implicit none + complex*16, intent(in) :: a, b, xa(3), xb(3) + complex*16, intent(out) :: p, k, xp(3) + + double precision :: tmp_mod + complex*16 :: p_inv, xab(3), ab + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xab + + ASSERT (REAL(a) > 0.) + ASSERT (REAL(b) > 0.) + + ! new exponent + p = a + b + + xab(1) = xa(1) - xb(1) + xab(2) = xa(2) - xb(2) + xab(3) = xa(3) - xb(3) + + p_inv = (1.d0, 0.d0) / p + ab = a * b * p_inv + + k = ab * (xab(1)*xab(1) + xab(2)*xab(2) + xab(3)*xab(3)) + tmp_mod = dsqrt(REAL(k)*REAL(k) + AIMAG(k)*AIMAG(k)) + if(tmp_mod .gt. 40.d0) then + k = (0.d0, 0.d0) + xp(1:3) = (0.d0, 0.d0) + return + endif + + k = zexp(-k) + xp(1) = ( a * xa(1) + b * xb(1) ) * p_inv + xp(2) = ( a * xa(2) + b * xb(2) ) * p_inv + xp(3) = ( a * xa(3) + b * xb(3) ) * p_inv + +end subroutine cgaussian_product + +! --- + +subroutine cgaussian_product_x(a, xa, b, xb, k, p, xp) + + BEGIN_DOC + ! complex Gaussian product in 1D. + ! e^{-a (x-x_A)^2} e^{-b (x-x_B)^2} = K e^{-p (x-x_P)^2} + END_DOC + + implicit none + complex*16, intent(in) :: a, b, xa, xb + complex*16, intent(out) :: p, k, xp + + double precision :: tmp_mod + complex*16 :: p_inv + complex*16 :: xab, ab + + ASSERT (REAL(a) > 0.) + ASSERT (REAL(b) > 0.) + + ! new center + p = a + b + + xab = xa - xb + + p_inv = (1.d0, 0.d0) / p + ab = a * b * p_inv + + k = ab * xab*xab + tmp_mod = dsqrt(REAL(k)*REAL(k) + AIMAG(k)*AIMAG(k)) + if(tmp_mod > 40.d0) then + k = (0.d0, 0.d0) + xp = (0.d0, 0.d0) + return + endif + + k = zexp(-k) + xp = (a*xa + b*xb) * p_inv + +end subroutine cgaussian_product_x + +! --- + +subroutine multiply_cpoly(b, nb, c, nc, d, nd) + + BEGIN_DOC + ! Multiply two complex polynomials + ! D(t) += B(t) * C(t) + END_DOC + + implicit none + + integer, intent(in) :: nb, nc + complex*16, intent(in) :: b(0:nb), c(0:nc) + complex*16, intent(inout) :: d(0:nb+nc) + integer, intent(out) :: nd + + integer :: ndtmp, ib, ic + double precision :: tmp_mod + complex*16 :: tmp + + if(ior(nc, nb) >= 0) then ! True if nc>=0 and nb>=0 + continue + else + return + endif + + ndtmp = nb + nc + + do ic = 0, nc + d(ic) = d(ic) + c(ic) * b(0) + enddo + + do ib = 1, nb + d(ib) = d(ib) + c(0) * b(ib) + do ic = 1, nc + d(ib+ic) = d(ib+ic) + c(ic) * b(ib) + enddo + enddo + + do nd = ndtmp, 0, -1 + tmp = d(nd) + tmp_mod = dsqrt(REAL(tmp)*REAL(tmp) + AIMAG(tmp)*AIMAG(tmp)) + if(tmp_mod .lt. 1.d-15) cycle + exit + enddo + +end subroutine multiply_cpoly + +! --- + +subroutine add_cpoly(b, nb, c, nc, d, nd) + + BEGIN_DOC + ! Add two complex polynomials + ! D(t) += B(t) + C(t) + END_DOC + + implicit none + complex*16, intent(in) :: b(0:nb), c(0:nc) + integer, intent(inout) :: nb, nc + integer, intent(out) :: nd + complex*16, intent(out) :: d(0:nb+nc) + + integer :: ib + double precision :: tmp_mod + complex*16 :: tmp + + nd = nb + nc + do ib = 0, max(nb, nc) + d(ib) = d(ib) + c(ib) + b(ib) + enddo + + tmp = d(nd) + tmp_mod = dsqrt(REAL(tmp)*REAL(tmp) + AIMAG(tmp)*AIMAG(tmp)) + do while( (tmp_mod .lt. 1.d-15) .and. (nd >= 0) ) + nd -= 1 + tmp = d(nd) + tmp_mod = dsqrt(REAL(tmp)*REAL(tmp) + AIMAG(tmp)*AIMAG(tmp)) + if(nd < 0) exit + enddo + +end subroutine add_cpoly + +! --- + +subroutine add_cpoly_multiply(b, nb, cst, d, nd) + + BEGIN_DOC + ! Add a complex polynomial multiplied by a complex constant + ! D(t) += cst * B(t) + END_DOC + + implicit none + + integer, intent(in) :: nb + complex*16, intent(in) :: b(0:nb), cst + integer, intent(inout) :: nd + complex*16, intent(inout) :: d(0:max(nb, nd)) + + integer :: ib + double precision :: tmp_mod + complex*16 :: tmp + + nd = max(nd, nb) + if(nd /= -1) then + + do ib = 0, nb + d(ib) = d(ib) + cst * b(ib) + enddo + + tmp = d(nd) + tmp_mod = dsqrt(REAL(tmp)*REAL(tmp) + AIMAG(tmp)*AIMAG(tmp)) + do while(tmp_mod .lt. 1.d-15) + nd -= 1 + if(nd < 0) exit + tmp = d(nd) + tmp_mod = dsqrt(REAL(tmp)*REAL(tmp) + AIMAG(tmp)*AIMAG(tmp)) + enddo + + endif + +end subroutine add_cpoly_multiply + +! --- + +subroutine recentered_cpoly2(P_A, x_A, x_P, a, P_B, x_B, x_Q, b) + + BEGIN_DOC + ! + ! write two complex polynomials (x-x_A)^a (x-x_B)^b + ! as P_A(x-x_P) and P_B(x-x_Q) + ! + END_DOC + + implicit none + + integer, intent(in) :: a, b + complex*16, intent(in) :: x_A, x_P, x_B, x_Q + complex*16, intent(out) :: P_A(0:a), P_B(0:b) + + integer :: i, minab, maxab + complex*16 :: pows_a(-2:a+b+4), pows_b(-2:a+b+4) + + double precision :: binom_func + + if((a<0) .or. (b<0)) return + + maxab = max(a, b) + minab = max(min(a, b), 0) + + pows_a(0) = (1.d0, 0.d0) + pows_a(1) = x_P - x_A + + pows_b(0) = (1.d0, 0.d0) + pows_b(1) = x_Q - x_B + + do i = 2, maxab + pows_a(i) = pows_a(i-1) * pows_a(1) + pows_b(i) = pows_b(i-1) * pows_b(1) + enddo + + P_A(0) = pows_a(a) + P_B(0) = pows_b(b) + + do i = 1, min(minab, 20) + P_A(i) = binom_transp(a-i,a) * pows_a(a-i) + P_B(i) = binom_transp(b-i,b) * pows_b(b-i) + enddo + + do i = minab+1, min(a, 20) + P_A(i) = binom_transp(a-i,a) * pows_a(a-i) + enddo + do i = minab+1, min(b, 20) + P_B(i) = binom_transp(b-i,b) * pows_b(b-i) + enddo + + do i = 101, a + P_A(i) = binom_func(a,a-i) * pows_a(a-i) + enddo + do i = 101, b + P_B(i) = binom_func(b,b-i) * pows_b(b-i) + enddo + +end subroutine recentered_cpoly2 + +! --- + +complex*16 function Fc_integral(n, inv_sq_p) + + BEGIN_DOC + ! function that calculates the following integral + ! \int_{\-infty}^{+\infty} x^n \exp(-p x^2) dx + ! for complex valued p + END_DOC + + implicit none + include 'constants.include.F' + + integer, intent(in) :: n + complex*16, intent(in) :: inv_sq_p + + ! (n)! + double precision :: fact + + if(n < 0) then + Fc_integral = (0.d0, 0.d0) + return + endif + + ! odd n + if(iand(n, 1) .ne. 0) then + Fc_integral = (0.d0, 0.d0) + return + endif + + if(n == 0) then + Fc_integral = sqpi * inv_sq_p + return + endif + + Fc_integral = sqpi * 0.5d0**n * inv_sq_p**dble(n+1) * fact(n) / fact(shiftr(n, 1)) + +end function Fc_integral + +! --- + +complex*16 function crint(n, rho) + + implicit none + include 'constants.include.F' + + integer, intent(in) :: n + complex*16, intent(in) :: rho + + integer :: i, mmax + double precision :: rho_mod, rho_re, rho_im + double precision :: sq_rho_re, sq_rho_im + double precision :: n_tmp + complex*16 :: sq_rho, rho_inv, rho_exp + + complex*16 :: crint_smallz, cpx_erf + + rho_re = REAL (rho) + rho_im = AIMAG(rho) + rho_mod = dsqrt(rho_re*rho_re + rho_im*rho_im) + + if(rho_mod < 10.d0) then + ! small z + + if(rho_mod .lt. 1.d-10) then + crint = 1.d0 / dble(n + n + 1) + else + crint = crint_smallz(n, rho) + endif + + else + ! large z + + if(rho_mod .gt. 40.d0) then + + n_tmp = dble(n) + 0.5d0 + crint = 0.5d0 * gamma(n_tmp) / (rho**n_tmp) + + else + + ! get \sqrt(rho) + sq_rho_re = sq_op5 * dsqrt(rho_re + rho_mod) + sq_rho_im = 0.5d0 * rho_im / sq_rho_re + sq_rho = sq_rho_re + (0.d0, 1.d0) * sq_rho_im + + rho_exp = 0.5d0 * zexp(-rho) + rho_inv = (1.d0, 0.d0) / rho + + crint = 0.5d0 * sqpi * cpx_erf(sq_rho_re, sq_rho_im) / sq_rho + mmax = n + if(mmax .gt. 0) then + do i = 0, mmax-1 + crint = ((dble(i) + 0.5d0) * crint - rho_exp) * rho_inv + enddo + endif + + ! *** + + endif + + endif + +! print *, n, real(rho), real(crint) + +end function crint + +! --- + +complex*16 function crint_sum(n_pt_out, rho, d1) + + implicit none + include 'constants.include.F' + + integer, intent(in) :: n_pt_out + complex*16, intent(in) :: rho, d1(0:n_pt_out) + + integer :: n, i, mmax + double precision :: rho_mod, rho_re, rho_im + double precision :: sq_rho_re, sq_rho_im + complex*16 :: sq_rho, F0 + complex*16 :: rho_tmp, rho_inv, rho_exp + complex*16, allocatable :: Fm(:) + + complex*16 :: crint_smallz, cpx_erf + + rho_re = REAL (rho) + rho_im = AIMAG(rho) + rho_mod = dsqrt(rho_re*rho_re + rho_im*rho_im) + + if(rho_mod < 10.d0) then + ! small z + + if(rho_mod .lt. 1.d-10) then + +! print *, ' 111' +! print *, ' rho = ', rho + + crint_sum = d1(0) +! print *, 0, 1 + + do i = 2, n_pt_out, 2 + + n = shiftr(i, 1) + crint_sum = crint_sum + d1(i) / dble(n+n+1) + +! print *, n, 1.d0 / dble(n+n+1) + enddo + + ! *** + + else + +! print *, ' 222' +! print *, ' rho = ', real(rho) +! if(abs(aimag(rho)) .gt. 1d-15) then +! print *, ' complex rho', rho +! stop +! endif + + crint_sum = d1(0) * crint_smallz(0, rho) + +! print *, 0, real(d1(0)), real(crint_smallz(0, rho)) +! if(abs(aimag(d1(0))) .gt. 1d-15) then +! print *, ' complex d1(0)', d1(0) +! stop +! endif + + do i = 2, n_pt_out, 2 + n = shiftr(i, 1) + crint_sum = crint_sum + d1(i) * crint_smallz(n, rho) + +! print *, n, real(d1(i)), real(crint_smallz(n, rho)) +! if(abs(aimag(d1(i))) .gt. 1d-15) then +! print *, ' complex d1(i)', i, d1(i) +! stop +! endif + + enddo + +! print *, 'sum = ', real(crint_sum) +! if(abs(aimag(crint_sum)) .gt. 1d-15) then +! print *, ' complex crint_sum', crint_sum +! stop +! endif + + ! *** + + endif + + else + ! large z + + if(rho_mod .gt. 40.d0) then + +! print *, ' 333' +! print *, ' rho = ', rho + + rho_inv = (1.d0, 0.d0) / rho + rho_tmp = 0.5d0 * sqpi * zsqrt(rho_inv) + crint_sum = rho_tmp * d1(0) +! print *, 0, rho_tmp + + do i = 2, n_pt_out, 2 + n = shiftr(i, 1) + rho_tmp = rho_tmp * (dble(n) + 0.5d0) * rho_inv + crint_sum = crint_sum + rho_tmp * d1(i) +! print *, n, rho_tmp + enddo + + ! *** + + else + +! print *, ' 444' +! print *, ' rho = ', rho + + ! get \sqrt(rho) + sq_rho_re = sq_op5 * dsqrt(rho_re + rho_mod) + sq_rho_im = 0.5d0 * rho_im / sq_rho_re + sq_rho = sq_rho_re + (0.d0, 1.d0) * sq_rho_im + !sq_rho = zsqrt(rho) + + + F0 = 0.5d0 * sqpi * cpx_erf(sq_rho_re, sq_rho_im) / sq_rho + crint_sum = F0 * d1(0) +! print *, 0, F0 + + rho_exp = 0.5d0 * zexp(-rho) + rho_inv = (1.d0, 0.d0) / rho + + mmax = shiftr(n_pt_out, 1) + if(mmax .gt. 0) then + + allocate( Fm(mmax) ) + Fm(1:mmax) = (0.d0, 0.d0) + + do n = 0, mmax-1 + F0 = ((dble(n) + 0.5d0) * F0 - rho_exp) * rho_inv + Fm(n+1) = F0 +! print *, n, F0 + enddo + + do i = 2, n_pt_out, 2 + n = shiftr(i, 1) + crint_sum = crint_sum + Fm(n) * d1(i) + enddo + deallocate(Fm) + endif + + ! *** + + endif + + endif + +end function crint_sum + +! --- + +complex*16 function crint_smallz(n, rho) + + BEGIN_DOC + ! Standard version of rint + END_DOC + + implicit none + integer, intent(in) :: n + complex*16, intent(in) :: rho + + integer, parameter :: kmax = 40 + double precision, parameter :: eps = 1.d-13 + + integer :: k + double precision :: delta_mod + complex*16 :: rho_k, ct, delta_k + + ct = 0.5d0 * zexp(-rho) * gamma(dble(n) + 0.5d0) + rho_k = (1.d0, 0.d0) + crint_smallz = ct * rho_k / gamma(dble(n) + 1.5d0) + + do k = 1, kmax + + rho_k = rho_k * rho + delta_k = ct * rho_k / gamma(dble(n+k) + 1.5d0) + crint_smallz = crint_smallz + delta_k + + delta_mod = dsqrt(REAL(delta_k)*REAL(delta_k) + AIMAG(delta_k)*AIMAG(delta_k)) + if(delta_mod .lt. eps) return + enddo + + if(delta_mod > eps) then + write(*,*) ' pb in crint_smallz !' + write(*,*) ' n, rho = ', n, rho + write(*,*) ' delta_mod = ', delta_mod + stop 1 + endif + +end function crint_smallz + +! --- + diff --git a/src/utils/constants.include.F b/src/utils/constants.include.F index 297a839e..a96fabe6 100644 --- a/src/utils/constants.include.F +++ b/src/utils/constants.include.F @@ -16,4 +16,5 @@ double precision, parameter :: c_2_4_3 = 2.5198420997897464d0 double precision, parameter :: cst_lda = -0.93052573634909996d0 double precision, parameter :: c_4_3 = 1.3333333333333333d0 double precision, parameter :: c_1_3 = 0.3333333333333333d0 - +double precision, parameter :: sq_op5 = dsqrt(0.5d0) +double precision, parameter :: dlog_2pi = dlog(2.d0*dacos(-1.d0)) diff --git a/src/utils/cpx_erf.irp.f b/src/utils/cpx_erf.irp.f new file mode 100644 index 00000000..61f81055 --- /dev/null +++ b/src/utils/cpx_erf.irp.f @@ -0,0 +1,204 @@ + +! --- + +complex*16 function cpx_erf(x, y) + + BEGIN_DOC + ! + ! compute erf(z) for z = x + i y + ! + ! REF: Abramowitz and Stegun + ! + END_DOC + + implicit none + + double precision, intent(in) :: x, y + + double precision :: yabs + complex*16 :: erf_tmp1, erf_tmp2, erf_tmp3, erf_tot + + double precision :: erf_F + complex*16 :: erf_E, erf_G, erf_H + + yabs = dabs(y) + + if(yabs .lt. 1.d-15) then + + cpx_erf = (1.d0, 0.d0) * derf(x) + return + + else + + erf_tmp1 = (1.d0, 0.d0) * derf(x) + erf_tmp2 = erf_E(x, yabs) + erf_F(x, yabs) + erf_tmp3 = zexp(-(0.d0, 2.d0) * x * yabs) * ( erf_G(x, yabs) + erf_H(x, yabs) ) + erf_tot = erf_tmp1 + erf_tmp2 - erf_tmp3 + + endif + + if(y .gt. 0.d0) then + cpx_erf = erf_tot + else + cpx_erf = CONJG(erf_tot) + endif + +end function cpx_erf + +! --- + +complex*16 function erf_E(x, yabs) + + implicit none + include 'constants.include.F' + + double precision, intent(in) :: x, yabs + + if( (dabs(x).gt.6.d0) .or. (x==0.d0) ) then + erf_E = (0.d0, 0.d0) + return + endif + + if(dabs(x) .lt. 1.d-7) then + + erf_E = -inv_pi * (0.d0, 1.d0) * yabs + + else + + erf_E = 0.5d0 * inv_pi * dexp(-x*x) & + * ((1.d0, 0.d0) - zexp(-(2.d0, 0.d0) * x * yabs)) / x + + endif + +end function erf_E + +! --- + +double precision function erf_F(x, yabs) + + implicit none + include 'constants.include.F' + + double precision, intent(in) :: x, yabs + + integer, parameter :: Nmax = 13 + + integer :: i + double precision :: tmp1, tmp2, x2, ct + + + if(dabs(x) .gt. 5.8d0) then + + erf_F = 0.d0 + + else + + x2 = x * x + ct = x * inv_pi + + erf_F = 0.d0 + do i = 1, Nmax + + tmp1 = 0.25d0 * dble(i) * dble(i) + x2 + tmp2 = dexp(-tmp1) / tmp1 + erf_F = erf_F + tmp2 + + if(dabs(tmp2) .lt. 1d-15) exit + enddo + erf_F = ct * erf_F + + endif + +end function erf_F + +! --- + +complex*16 function erf_G(x, yabs) + + implicit none + include 'constants.include.F' + + double precision, intent(in) :: x, yabs + + integer, parameter :: Nmax = 13 + + integer :: i, tmpi, imin, imax + double precision :: tmp0, tmp1, x2, idble + complex*16 :: tmp2 + + if(x .eq. 0.d0) then + erf_G = (0.d0, 0.d0) + return + endif + + tmpi = int(2.d0 * yabs) + imin = max(1, tmpi-Nmax) + imax = tmpi + Nmax + + x2 = x * x + + erf_G = 0.d0 + do i = imin, imax + + idble = dble(i) + tmp0 = 0.5d0 * idble + tmp1 = tmp0 * tmp0 + x2 + tmp2 = dexp( idble * yabs - tmp1 - dlog(tmp1) - dlog_2pi) * (x - (0.d0, 1.d0)*tmp0) + + erf_G = erf_G + tmp2 + + enddo + +end function erf_G + +! --- + +complex*16 function erf_H(x, yabs) + + implicit none + include 'constants.include.F' + + double precision, intent(in) :: x, yabs + + integer, parameter :: Nmax = 13 + + integer :: i + double precision :: tmp0, tmp1, tmp_mod, x2, ct, idble + complex*16 :: tmp2 + + if(x .eq. 0.d0) then + erf_H = (0.d0, 0.d0) + return + endif + + + if( (dabs(x) .lt. 10d0) .and. (yabs .lt. 6.1d0) ) then + + x2 = x * x + ct = 0.5d0 * inv_pi + + erf_H = 0.d0 + do i = 1, Nmax + + idble = dble(i) + tmp0 = 0.5d0 * idble + tmp1 = tmp0 * tmp0 + x2 + tmp2 = dexp(-tmp1-idble*yabs) * (x + (0.d0, 1.d0)*tmp0) / tmp1 + erf_H = erf_H + tmp2 + + tmp_mod = dsqrt(REAL(tmp2)*REAL(tmp2) + AIMAG(tmp2)*AIMAG(tmp2)) + if(tmp_mod .lt. 1d-15) exit + enddo + erf_H = ct * erf_H + + else + + erf_H = (0.d0, 0.d0) + + endif + +end function erf_H + +! --- + + diff --git a/src/utils/format_w_error.irp.f b/src/utils/format_w_error.irp.f deleted file mode 100644 index 1378d367..00000000 --- a/src/utils/format_w_error.irp.f +++ /dev/null @@ -1,71 +0,0 @@ -subroutine format_w_error(value,error,size_nb,max_nb_digits,format_value,str_error) - - implicit none - - BEGIN_DOC - ! Format for double precision, value(error) - END_DOC - - ! in - ! | value | double precision | value... | - ! | error | double precision | error... | - ! | size_nb | integer | X in FX.Y | - ! | max_nb_digits | integer | Max Y in FX.Y | - - ! out - ! | format_value | character | string FX.Y for the format | - ! | str_error | character | string of the error | - - ! internal - ! | str_size | character | size in string format | - ! | nb_digits | integer | number of digits Y in FX.Y depending of the error | - ! | str_nb_digits | character | nb_digits in string format | - ! | str_exp | character | string of the value in exponential format | - - ! in - double precision, intent(in) :: error, value - integer, intent(in) :: size_nb, max_nb_digits - - ! out - character(len=20), intent(out) :: str_error, format_value - - ! internal - character(len=20) :: str_size, str_nb_digits, str_exp - integer :: nb_digits - - ! max_nb_digit: Y max - ! size_nb = Size of the double: X (FX.Y) - write(str_size,'(I3)') size_nb - - ! Error - write(str_exp,'(1pE20.0)') error - str_error = trim(adjustl(str_exp)) - - ! Number of digit: Y (FX.Y) from the exponent - str_nb_digits = str_exp(19:20) - read(str_nb_digits,*) nb_digits - - ! If the error is 0d0 - if (error <= 1d-16) then - write(str_nb_digits,*) max_nb_digits - endif - - ! If the error is too small - if (nb_digits > max_nb_digits) then - write(str_nb_digits,*) max_nb_digits - str_error(1:1) = '0' - endif - - ! If the error is too big (>= 0.5) - if (error >= 0.5d0) then - str_nb_digits = '1' - str_error(1:1) = '*' - endif - - ! FX.Y,A1,A1,A1 for value(str_error) - !string = 'F'//trim(adjustl(str_size))//'.'//trim(adjustl(str_nb_digits))//',A1,A1,A1' - - ! FX.Y just for the value - format_value = 'F'//trim(adjustl(str_size))//'.'//trim(adjustl(str_nb_digits)) - -end diff --git a/src/utils/integration.irp.f b/src/utils/integration.irp.f index 38e198dc..fe4418ac 100644 --- a/src/utils/integration.irp.f +++ b/src/utils/integration.irp.f @@ -443,14 +443,16 @@ end -double precision function rint(n,rho) - implicit none +double precision function rint(n, rho) + BEGIN_DOC -!.. math:: -! -! \int_0^1 dx \exp(-p x^2) x^n -! + !.. math:: + ! + ! \int_0^1 dx \exp(-p x^2) x^n + ! END_DOC + + implicit none include 'constants.include.F' double precision :: rho,u,rint1,v,val0,rint_large_n,u_inv integer :: n,k @@ -464,6 +466,7 @@ double precision function rint(n,rho) u=rho*u_inv rint=0.5d0*u_inv*sqpi*derf(u) endif +! print *, n, rho, rint return endif if(rho.lt.1.d0)then @@ -487,6 +490,7 @@ double precision function rint(n,rho) rint=rint_large_n(n,rho) endif endif +! print *, n, rho, rint end @@ -503,20 +507,24 @@ double precision function rint_sum(n_pt_out,rho,d1) integer :: n,k,i double precision :: two_rho_inv, rint_tmp, di +! print *, ' rho = ', rho if(rho < 1.d0)then if(rho == 0.d0)then rint_sum=d1(0) +! print *, 0, d1(0), 1 else u_inv=1.d0/dsqrt(rho) u=rho*u_inv rint_sum=0.5d0*u_inv*sqpi*derf(u) *d1(0) +! print *, 0, d1(0), 0.5d0*u_inv*sqpi*derf(u) endif do i=2,n_pt_out,2 n = shiftr(i,1) rint_sum = rint_sum + d1(i)*rint1(n,rho) +! print *, n, d1(i), rint1(n,rho) enddo else @@ -532,19 +540,25 @@ double precision function rint_sum(n_pt_out,rho,d1) two_rho_inv = 0.5d0*u_inv*u_inv val0=0.5d0*u_inv*sqpi*derf(u) rint_sum=val0*d1(0) +! print *, 0, d1(0), val0 + rint_tmp=(val0-v)*two_rho_inv di = 3.d0 do i=2,min(n_pt_out,40),2 rint_sum = rint_sum + d1(i)*rint_tmp +! print *, i, d1(i), rint_tmp rint_tmp = (rint_tmp*di-v)*two_rho_inv di = di+2.d0 enddo do i=42,n_pt_out,2 n = shiftr(i,1) rint_sum = rint_sum + d1(i)*rint_large_n(n,rho) +! print *, i, d1(i), rint_large_n(n, rho) enddo endif + +! print *, 'sum = ', rint_sum end double precision function hermite(n,x) @@ -627,3 +641,94 @@ double precision function rint1(n,rho) write(*,*)'pb in rint1 k too large!' stop 1 end + +! --- + +double precision function V_phi(n, m) + + 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 + + implicit none + integer, intent(in) :: n, m + + integer :: i + double precision :: prod + + double precision :: 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 function V_phi + +! --- + +double precision function V_theta(n, m) + + 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 + + implicit none + include 'utils/constants.include.F' + integer, intent(in) :: n, m + + integer :: i + double precision :: prod + + double precision :: Wallis + + 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 function V_theta + +! --- + +double precision function Wallis(n) + + BEGIN_DOC + ! Wallis integral: + ! + ! $\int_{0}^{\pi} \cos(\theta)^n d\theta$. + END_DOC + + implicit none + include 'utils/constants.include.F' + + integer, intent(in) :: n + + integer :: p + + double precision :: fact + + 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 function Wallis + +! --- + diff --git a/src/utils/linear_algebra.irp.f b/src/utils/linear_algebra.irp.f index 405d2d20..ae0bb8e5 100644 --- a/src/utils/linear_algebra.irp.f +++ b/src/utils/linear_algebra.irp.f @@ -1649,3 +1649,103 @@ subroutine restore_symmetry(m,n,A,LDA,thresh) enddo end + + + + + + + + + + + + + + + + + +!subroutine svd_s(A, LDA, U, LDU, D, Vt, LDVt, m, n) +! implicit none +! BEGIN_DOC +! ! !!! +! ! DGESVD computes the singular value decomposition (SVD) of a real +! ! M-by-N matrix A, optionally computing the left and/or right singular +! ! vectors. The SVD is written: +! ! A = U * SIGMA * transpose(V) +! ! where SIGMA is an M-by-N matrix which is zero except for its +! ! min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and +! ! V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA +! ! are the singular values of A; they are real and non-negative, and +! ! are returned in descending order. The first min(m,n) columns of +! ! U and V are the left and right singular vectors of A. +! ! +! ! Note that the routine returns V**T, not V. +! ! !!! +! END_DOC +! +! integer, intent(in) :: LDA, LDU, LDVt, m, n +! double precision, intent(in) :: A(LDA,n) +! double precision, intent(out) :: U(LDU,m), Vt(LDVt,n), D(min(m,n)) +! double precision,allocatable :: work(:), A_tmp(:,:) +! integer :: info, lwork, i, j, k +! +! +! allocate (A_tmp(LDA,n)) +! do k=1,n +! do i=1,m +! !A_tmp(i,k) = A(i,k) + 1d-16 +! A_tmp(i,k) = A(i,k) +! enddo +! enddo +! +! ! Find optimal size for temp arrays +! allocate(work(1)) +! lwork = -1 +! ! 'A': all M columns of U are returned in array U +! ! 'A': all N rows of V**T are returned in the array VT +! call dgesvd('A', 'A', m, n, A_tmp, LDA, D, U, LDU, Vt, LDVt, work, lwork, info) +! ! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648 +! if( info.ne.0 ) then +! print *, ' problem in first call DGESVD !!!!' +! print *, ' info = ', info +! print *, ' < 0 : if INFO = -i, the i-th argument had an illegal value.' +! print *, ' > 0 : if DBDSQR did not converge, INFO specifies how many ' +! print *, ' superdiagonals of an intermediate bidiagonal form B ' +! print *, ' did not converge to zero. See the description of WORK' +! print *, ' above for details. ' +! stop +! endif +! lwork = max(int(work(1)), 5*MIN(M,N)) +! deallocate(work) +! +! allocate(work(lwork)) +! +! call dgesvd('A', 'A', m, n, A_tmp, LDA, D, U, LDU, Vt, LDVt, work, lwork, info) +! if( info.ne.0 ) then +! print *, ' problem in second call DGESVD !!!!' +! print *, ' info = ', info +! print *, ' < 0 : if INFO = -i, the i-th argument had an illegal value.' +! print *, ' > 0 : if DBDSQR did not converge, INFO specifies how many ' +! print *, ' superdiagonals of an intermediate bidiagonal form B ' +! print *, ' did not converge to zero. See the description of WORK' +! print *, ' above for details. ' +! stop +! endif +! +! deallocate(A_tmp,work) +! +! !do j=1, m +! ! do i=1, LDU +! ! if (dabs(U(i,j)) < 1.d-14) U(i,j) = 0.d0 +! ! enddo +! !enddo +! !do j = 1, n +! ! do i = 1, LDVt +! ! if (dabs(Vt(i,j)) < 1.d-14) Vt(i,j) = 0.d0 +! ! enddo +! !enddo +! +!end +! diff --git a/src/utils/map_module.f90 b/src/utils/map_module.f90 index ceaec874..98e73470 100644 --- a/src/utils/map_module.f90 +++ b/src/utils/map_module.f90 @@ -238,11 +238,11 @@ subroutine cache_map_sort(map) iorder(i) = i enddo if (cache_key_kind == 2) then - call i2sort(map%key,iorder,map%n_elements,-1) + call i2radix_sort(map%key,iorder,map%n_elements,-1) else if (cache_key_kind == 4) then - call isort(map%key,iorder,map%n_elements,-1) + call iradix_sort(map%key,iorder,map%n_elements,-1) else if (cache_key_kind == 8) then - call i8sort(map%key,iorder,map%n_elements,-1) + call i8radix_sort(map%key,iorder,map%n_elements,-1) endif if (integral_kind == 4) then call set_order(map%value,iorder,map%n_elements) diff --git a/src/utils/memory.irp.f b/src/utils/memory.irp.f index d5a066a1..3ea242b0 100644 --- a/src/utils/memory.irp.f +++ b/src/utils/memory.irp.f @@ -114,7 +114,7 @@ subroutine print_memory_usage() call resident_memory(rss) call total_memory(mem) - write(*,'(A,F14.3,A,F14.3,A)') & + write(*,'(A,F14.6,A,F14.6,A)') & '.. >>>>> [ RES MEM : ', rss , & ' GB ] [ VIRT MEM : ', mem, ' GB ] <<<<< ..' end diff --git a/src/utils/qsort.c b/src/utils/qsort.c deleted file mode 100644 index c011b35a..00000000 --- a/src/utils/qsort.c +++ /dev/null @@ -1,373 +0,0 @@ -/* [[file:~/qp2/src/utils/qsort.org::*Generated%20C%20file][Generated C file:1]] */ -#include -#include - -struct int16_t_comp { - int16_t x; - int32_t i; -}; - -int compare_int16_t( const void * l, const void * r ) -{ - const int16_t * restrict _l= l; - const int16_t * restrict _r= r; - if( *_l > *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_int16_t(int16_t* restrict A_in, int32_t* restrict iorder, int32_t isize) { - struct int16_t_comp* A = malloc(isize * sizeof(struct int16_t_comp)); - if (A == NULL) return; - - for (int i=0 ; i *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_int16_t_big(int16_t* restrict A_in, int64_t* restrict iorder, int64_t isize) { - struct int16_t_comp_big* A = malloc(isize * sizeof(struct int16_t_comp_big)); - if (A == NULL) return; - - for (int i=0 ; i *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_int32_t(int32_t* restrict A_in, int32_t* restrict iorder, int32_t isize) { - struct int32_t_comp* A = malloc(isize * sizeof(struct int32_t_comp)); - if (A == NULL) return; - - for (int i=0 ; i *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_int32_t_big(int32_t* restrict A_in, int64_t* restrict iorder, int64_t isize) { - struct int32_t_comp_big* A = malloc(isize * sizeof(struct int32_t_comp_big)); - if (A == NULL) return; - - for (int i=0 ; i *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_int64_t(int64_t* restrict A_in, int32_t* restrict iorder, int32_t isize) { - struct int64_t_comp* A = malloc(isize * sizeof(struct int64_t_comp)); - if (A == NULL) return; - - for (int i=0 ; i *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_int64_t_big(int64_t* restrict A_in, int64_t* restrict iorder, int64_t isize) { - struct int64_t_comp_big* A = malloc(isize * sizeof(struct int64_t_comp_big)); - if (A == NULL) return; - - for (int i=0 ; i *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_double(double* restrict A_in, int32_t* restrict iorder, int32_t isize) { - struct double_comp* A = malloc(isize * sizeof(struct double_comp)); - if (A == NULL) return; - - for (int i=0 ; i *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_double_big(double* restrict A_in, int64_t* restrict iorder, int64_t isize) { - struct double_comp_big* A = malloc(isize * sizeof(struct double_comp_big)); - if (A == NULL) return; - - for (int i=0 ; i *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_float(float* restrict A_in, int32_t* restrict iorder, int32_t isize) { - struct float_comp* A = malloc(isize * sizeof(struct float_comp)); - if (A == NULL) return; - - for (int i=0 ; i *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_float_big(float* restrict A_in, int64_t* restrict iorder, int64_t isize) { - struct float_comp_big* A = malloc(isize * sizeof(struct float_comp_big)); - if (A == NULL) return; - - for (int i=0 ; i *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_TYPE_big(TYPE* restrict A_in, int32_t* restrict iorder, int32_t isize) { - struct TYPE_comp_big* A = malloc(isize * sizeof(struct TYPE_comp_big)); - if (A == NULL) return; - - for (int i=0 ; i> -""" -for typ in ["int16_t", "int32_t", "int64_t", "double", "float"]: - print( data.replace("TYPE", typ).replace("_big", "") ) - print( data.replace("int32_t", "int64_t").replace("TYPE", typ) ) -#+end_src - -#+NAME: replaced_f -#+begin_src python :results output :noweb yes -data = """ -<> -""" -c1 = { - "int16_t": "i2", - "int32_t": "i", - "int64_t": "i8", - "double": "d", - "float": "" -} -c2 = { - "int16_t": "integer", - "int32_t": "integer", - "int64_t": "integer", - "double": "real", - "float": "real" -} - -for typ in ["int16_t", "int32_t", "int64_t", "double", "float"]: - print( data.replace("real",c2[typ]).replace("L",c1[typ]).replace("TYPE", typ).replace("_big", "") ) - print( data.replace("real",c2[typ]).replace("L",c1[typ]).replace("int32_t", "int64_t").replace("TYPE", typ) ) -#+end_src - -#+NAME: replaced_f2 -#+begin_src python :results output :noweb yes -data = """ -<> -""" -c1 = { - "int16_t": "i2", - "int32_t": "i", - "int64_t": "i8", - "double": "d", - "float": "" -} -c2 = { - "int16_t": "integer", - "int32_t": "integer", - "int64_t": "integer", - "double": "real", - "float": "real" -} - -for typ in ["int16_t", "int32_t", "int64_t", "double", "float"]: - print( data.replace("real",c2[typ]).replace("L",c1[typ]).replace("TYPE", typ).replace("_big", "") ) - print( data.replace("real",c2[typ]).replace("L",c1[typ]).replace("int32_t", "int64_t").replace("TYPE", typ) ) -#+end_src - -* Generated C file - -#+BEGIN_SRC c :comments link :tangle qsort.c :noweb yes -#include -#include -<> -#+END_SRC - -* Generated Fortran file - -#+BEGIN_SRC f90 :tangle qsort_module.f90 :noweb yes -module qsort_module - use iso_c_binding - - interface - <> - end interface - -end module qsort_module - -<> - -#+END_SRC - diff --git a/src/utils/qsort_module.f90 b/src/utils/qsort_module.f90 deleted file mode 100644 index a72a4f9e..00000000 --- a/src/utils/qsort_module.f90 +++ /dev/null @@ -1,347 +0,0 @@ -module qsort_module - use iso_c_binding - - interface - - subroutine i2sort_c(A, iorder, isize) bind(C, name="qsort_int16_t") - use iso_c_binding - integer(c_int32_t), value :: isize - integer(c_int32_t) :: iorder(isize) - integer (c_int16_t) :: A(isize) - end subroutine i2sort_c - - subroutine i2sort_noidx_c(A, isize) bind(C, name="qsort_int16_t_noidx") - use iso_c_binding - integer(c_int32_t), value :: isize - integer (c_int16_t) :: A(isize) - end subroutine i2sort_noidx_c - - - - subroutine i2sort_big_c(A, iorder, isize) bind(C, name="qsort_int16_t_big") - use iso_c_binding - integer(c_int64_t), value :: isize - integer(c_int64_t) :: iorder(isize) - integer (c_int16_t) :: A(isize) - end subroutine i2sort_big_c - - subroutine i2sort_noidx_big_c(A, isize) bind(C, name="qsort_int16_t_noidx_big") - use iso_c_binding - integer(c_int64_t), value :: isize - integer (c_int16_t) :: A(isize) - end subroutine i2sort_noidx_big_c - - - - subroutine isort_c(A, iorder, isize) bind(C, name="qsort_int32_t") - use iso_c_binding - integer(c_int32_t), value :: isize - integer(c_int32_t) :: iorder(isize) - integer (c_int32_t) :: A(isize) - end subroutine isort_c - - subroutine isort_noidx_c(A, isize) bind(C, name="qsort_int32_t_noidx") - use iso_c_binding - integer(c_int32_t), value :: isize - integer (c_int32_t) :: A(isize) - end subroutine isort_noidx_c - - - - subroutine isort_big_c(A, iorder, isize) bind(C, name="qsort_int32_t_big") - use iso_c_binding - integer(c_int64_t), value :: isize - integer(c_int64_t) :: iorder(isize) - integer (c_int32_t) :: A(isize) - end subroutine isort_big_c - - subroutine isort_noidx_big_c(A, isize) bind(C, name="qsort_int32_t_noidx_big") - use iso_c_binding - integer(c_int64_t), value :: isize - integer (c_int32_t) :: A(isize) - end subroutine isort_noidx_big_c - - - - subroutine i8sort_c(A, iorder, isize) bind(C, name="qsort_int64_t") - use iso_c_binding - integer(c_int32_t), value :: isize - integer(c_int32_t) :: iorder(isize) - integer (c_int64_t) :: A(isize) - end subroutine i8sort_c - - subroutine i8sort_noidx_c(A, isize) bind(C, name="qsort_int64_t_noidx") - use iso_c_binding - integer(c_int32_t), value :: isize - integer (c_int64_t) :: A(isize) - end subroutine i8sort_noidx_c - - - - subroutine i8sort_big_c(A, iorder, isize) bind(C, name="qsort_int64_t_big") - use iso_c_binding - integer(c_int64_t), value :: isize - integer(c_int64_t) :: iorder(isize) - integer (c_int64_t) :: A(isize) - end subroutine i8sort_big_c - - subroutine i8sort_noidx_big_c(A, isize) bind(C, name="qsort_int64_t_noidx_big") - use iso_c_binding - integer(c_int64_t), value :: isize - integer (c_int64_t) :: A(isize) - end subroutine i8sort_noidx_big_c - - - - subroutine dsort_c(A, iorder, isize) bind(C, name="qsort_double") - use iso_c_binding - integer(c_int32_t), value :: isize - integer(c_int32_t) :: iorder(isize) - real (c_double) :: A(isize) - end subroutine dsort_c - - subroutine dsort_noidx_c(A, isize) bind(C, name="qsort_double_noidx") - use iso_c_binding - integer(c_int32_t), value :: isize - real (c_double) :: A(isize) - end subroutine dsort_noidx_c - - - - subroutine dsort_big_c(A, iorder, isize) bind(C, name="qsort_double_big") - use iso_c_binding - integer(c_int64_t), value :: isize - integer(c_int64_t) :: iorder(isize) - real (c_double) :: A(isize) - end subroutine dsort_big_c - - subroutine dsort_noidx_big_c(A, isize) bind(C, name="qsort_double_noidx_big") - use iso_c_binding - integer(c_int64_t), value :: isize - real (c_double) :: A(isize) - end subroutine dsort_noidx_big_c - - - - subroutine sort_c(A, iorder, isize) bind(C, name="qsort_float") - use iso_c_binding - integer(c_int32_t), value :: isize - integer(c_int32_t) :: iorder(isize) - real (c_float) :: A(isize) - end subroutine sort_c - - subroutine sort_noidx_c(A, isize) bind(C, name="qsort_float_noidx") - use iso_c_binding - integer(c_int32_t), value :: isize - real (c_float) :: A(isize) - end subroutine sort_noidx_c - - - - subroutine sort_big_c(A, iorder, isize) bind(C, name="qsort_float_big") - use iso_c_binding - integer(c_int64_t), value :: isize - integer(c_int64_t) :: iorder(isize) - real (c_float) :: A(isize) - end subroutine sort_big_c - - subroutine sort_noidx_big_c(A, isize) bind(C, name="qsort_float_noidx_big") - use iso_c_binding - integer(c_int64_t), value :: isize - real (c_float) :: A(isize) - end subroutine sort_noidx_big_c - - - - end interface - -end module qsort_module - - -subroutine i2sort(A, iorder, isize) - use qsort_module - use iso_c_binding - integer(c_int32_t) :: isize - integer(c_int32_t) :: iorder(isize) - integer (c_int16_t) :: A(isize) - call i2sort_c(A, iorder, isize) -end subroutine i2sort - -subroutine i2sort_noidx(A, isize) - use iso_c_binding - use qsort_module - integer(c_int32_t) :: isize - integer (c_int16_t) :: A(isize) - call i2sort_noidx_c(A, isize) -end subroutine i2sort_noidx - - - -subroutine i2sort_big(A, iorder, isize) - use qsort_module - use iso_c_binding - integer(c_int64_t) :: isize - integer(c_int64_t) :: iorder(isize) - integer (c_int16_t) :: A(isize) - call i2sort_big_c(A, iorder, isize) -end subroutine i2sort_big - -subroutine i2sort_noidx_big(A, isize) - use iso_c_binding - use qsort_module - integer(c_int64_t) :: isize - integer (c_int16_t) :: A(isize) - call i2sort_noidx_big_c(A, isize) -end subroutine i2sort_noidx_big - - - -subroutine isort(A, iorder, isize) - use qsort_module - use iso_c_binding - integer(c_int32_t) :: isize - integer(c_int32_t) :: iorder(isize) - integer (c_int32_t) :: A(isize) - call isort_c(A, iorder, isize) -end subroutine isort - -subroutine isort_noidx(A, isize) - use iso_c_binding - use qsort_module - integer(c_int32_t) :: isize - integer (c_int32_t) :: A(isize) - call isort_noidx_c(A, isize) -end subroutine isort_noidx - - - -subroutine isort_big(A, iorder, isize) - use qsort_module - use iso_c_binding - integer(c_int64_t) :: isize - integer(c_int64_t) :: iorder(isize) - integer (c_int32_t) :: A(isize) - call isort_big_c(A, iorder, isize) -end subroutine isort_big - -subroutine isort_noidx_big(A, isize) - use iso_c_binding - use qsort_module - integer(c_int64_t) :: isize - integer (c_int32_t) :: A(isize) - call isort_noidx_big_c(A, isize) -end subroutine isort_noidx_big - - - -subroutine i8sort(A, iorder, isize) - use qsort_module - use iso_c_binding - integer(c_int32_t) :: isize - integer(c_int32_t) :: iorder(isize) - integer (c_int64_t) :: A(isize) - call i8sort_c(A, iorder, isize) -end subroutine i8sort - -subroutine i8sort_noidx(A, isize) - use iso_c_binding - use qsort_module - integer(c_int32_t) :: isize - integer (c_int64_t) :: A(isize) - call i8sort_noidx_c(A, isize) -end subroutine i8sort_noidx - - - -subroutine i8sort_big(A, iorder, isize) - use qsort_module - use iso_c_binding - integer(c_int64_t) :: isize - integer(c_int64_t) :: iorder(isize) - integer (c_int64_t) :: A(isize) - call i8sort_big_c(A, iorder, isize) -end subroutine i8sort_big - -subroutine i8sort_noidx_big(A, isize) - use iso_c_binding - use qsort_module - integer(c_int64_t) :: isize - integer (c_int64_t) :: A(isize) - call i8sort_noidx_big_c(A, isize) -end subroutine i8sort_noidx_big - - - -subroutine dsort(A, iorder, isize) - use qsort_module - use iso_c_binding - integer(c_int32_t) :: isize - integer(c_int32_t) :: iorder(isize) - real (c_double) :: A(isize) - call dsort_c(A, iorder, isize) -end subroutine dsort - -subroutine dsort_noidx(A, isize) - use iso_c_binding - use qsort_module - integer(c_int32_t) :: isize - real (c_double) :: A(isize) - call dsort_noidx_c(A, isize) -end subroutine dsort_noidx - - - -subroutine dsort_big(A, iorder, isize) - use qsort_module - use iso_c_binding - integer(c_int64_t) :: isize - integer(c_int64_t) :: iorder(isize) - real (c_double) :: A(isize) - call dsort_big_c(A, iorder, isize) -end subroutine dsort_big - -subroutine dsort_noidx_big(A, isize) - use iso_c_binding - use qsort_module - integer(c_int64_t) :: isize - real (c_double) :: A(isize) - call dsort_noidx_big_c(A, isize) -end subroutine dsort_noidx_big - - - -subroutine sort(A, iorder, isize) - use qsort_module - use iso_c_binding - integer(c_int32_t) :: isize - integer(c_int32_t) :: iorder(isize) - real (c_float) :: A(isize) - call sort_c(A, iorder, isize) -end subroutine sort - -subroutine sort_noidx(A, isize) - use iso_c_binding - use qsort_module - integer(c_int32_t) :: isize - real (c_float) :: A(isize) - call sort_noidx_c(A, isize) -end subroutine sort_noidx - - - -subroutine sort_big(A, iorder, isize) - use qsort_module - use iso_c_binding - integer(c_int64_t) :: isize - integer(c_int64_t) :: iorder(isize) - real (c_float) :: A(isize) - call sort_big_c(A, iorder, isize) -end subroutine sort_big - -subroutine sort_noidx_big(A, isize) - use iso_c_binding - use qsort_module - integer(c_int64_t) :: isize - real (c_float) :: A(isize) - call sort_noidx_big_c(A, isize) -end subroutine sort_noidx_big diff --git a/src/utils/set_multiple_levels_omp.irp.f b/src/utils/set_multiple_levels_omp.irp.f deleted file mode 100644 index 572a13f4..00000000 --- a/src/utils/set_multiple_levels_omp.irp.f +++ /dev/null @@ -1,26 +0,0 @@ -subroutine set_multiple_levels_omp(activate) - - BEGIN_DOC -! If true, activate OpenMP nested parallelism. If false, deactivate. - END_DOC - - implicit none - logical, intent(in) :: activate - - if (activate) then - call omp_set_max_active_levels(3) - - IRP_IF SET_NESTED - call omp_set_nested(.True.) - IRP_ENDIF - - else - - call omp_set_max_active_levels(1) - - IRP_IF SET_NESTED - call omp_set_nested(.False.) - IRP_ENDIF - end if - -end diff --git a/src/utils/sort.irp.f b/src/utils/sort.irp.f index 089c3871..a63eb4a3 100644 --- a/src/utils/sort.irp.f +++ b/src/utils/sort.irp.f @@ -1,4 +1,222 @@ BEGIN_TEMPLATE + subroutine insertion_$Xsort (x,iorder,isize) + implicit none + BEGIN_DOC + ! Sort array x(isize) using the insertion sort algorithm. + ! iorder in input should be (1,2,3,...,isize), and in output + ! contains the new order of the elements. + END_DOC + integer,intent(in) :: isize + $type,intent(inout) :: x(isize) + integer,intent(inout) :: iorder(isize) + $type :: xtmp + integer :: i, i0, j, jmax + + do i=2,isize + xtmp = x(i) + i0 = iorder(i) + j=i-1 + do while (j>0) + if ((x(j) <= xtmp)) exit + x(j+1) = x(j) + iorder(j+1) = iorder(j) + j=j-1 + enddo + x(j+1) = xtmp + iorder(j+1) = i0 + enddo + end subroutine insertion_$Xsort + + subroutine quick_$Xsort(x, iorder, isize) + implicit none + BEGIN_DOC + ! Sort array x(isize) using the quicksort algorithm. + ! iorder in input should be (1,2,3,...,isize), and in output + ! contains the new order of the elements. + END_DOC + integer,intent(in) :: isize + $type,intent(inout) :: x(isize) + integer,intent(inout) :: iorder(isize) + integer, external :: omp_get_num_threads + call rec_$X_quicksort(x,iorder,isize,1,isize,nproc) + end + + recursive subroutine rec_$X_quicksort(x, iorder, isize, first, last, level) + implicit none + integer, intent(in) :: isize, first, last, level + integer,intent(inout) :: iorder(isize) + $type, intent(inout) :: x(isize) + $type :: c, tmp + integer :: itmp + integer :: i, j + + if(isize<2)return + + c = x( shiftr(first+last,1) ) + i = first + j = last + do + do while (x(i) < c) + i=i+1 + end do + do while (c < x(j)) + j=j-1 + end do + if (i >= j) exit + tmp = x(i) + x(i) = x(j) + x(j) = tmp + itmp = iorder(i) + iorder(i) = iorder(j) + iorder(j) = itmp + i=i+1 + j=j-1 + enddo + if ( ((i-first <= 10000).and.(last-j <= 10000)).or.(level<=0) ) then + if (first < i-1) then + call rec_$X_quicksort(x, iorder, isize, first, i-1,level/2) + endif + if (j+1 < last) then + call rec_$X_quicksort(x, iorder, isize, j+1, last,level/2) + endif + else + if (first < i-1) then + call rec_$X_quicksort(x, iorder, isize, first, i-1,level/2) + endif + if (j+1 < last) then + call rec_$X_quicksort(x, iorder, isize, j+1, last,level/2) + endif + endif + end + + subroutine heap_$Xsort(x,iorder,isize) + implicit none + BEGIN_DOC + ! Sort array x(isize) using the heap sort algorithm. + ! iorder in input should be (1,2,3,...,isize), and in output + ! contains the new order of the elements. + END_DOC + integer,intent(in) :: isize + $type,intent(inout) :: x(isize) + integer,intent(inout) :: iorder(isize) + + integer :: i, k, j, l, i0 + $type :: xtemp + + l = isize/2+1 + k = isize + do while (.True.) + if (l>1) then + l=l-1 + xtemp = x(l) + i0 = iorder(l) + else + xtemp = x(k) + i0 = iorder(k) + x(k) = x(1) + iorder(k) = iorder(1) + k = k-1 + if (k == 1) then + x(1) = xtemp + iorder(1) = i0 + exit + endif + endif + i=l + j = shiftl(l,1) + do while (j1) then + l=l-1 + xtemp = x(l) + i0 = iorder(l) + else + xtemp = x(k) + i0 = iorder(k) + x(k) = x(1) + iorder(k) = iorder(1) + k = k-1 + if (k == 1) then + x(1) = xtemp + iorder(1) = i0 + exit + endif + endif + i=l + j = shiftl(l,1) + do while (j0_8) + if (x(j)<=xtmp) exit + x(j+1_8) = x(j) + iorder(j+1_8) = iorder(j) + j = j-1_8 + enddo + x(j+1_8) = xtmp + iorder(j+1_8) = i0 + enddo + + end subroutine insertion_$Xsort_big + subroutine $Xset_order_big(x,iorder,isize) implicit none BEGIN_DOC @@ -90,3 +563,223 @@ SUBST [ X, type ] END_TEMPLATE +BEGIN_TEMPLATE + +recursive subroutine $Xradix_sort$big(x,iorder,isize,iradix) + implicit none + + BEGIN_DOC + ! Sort integer array x(isize) using the radix sort algorithm. + ! iorder in input should be (1,2,3,...,isize), and in output + ! contains the new order of the elements. + ! iradix should be -1 in input. + END_DOC + integer*$int_type, intent(in) :: isize + integer*$int_type, intent(inout) :: iorder(isize) + integer*$type, intent(inout) :: x(isize) + integer, intent(in) :: iradix + integer :: iradix_new + integer*$type, allocatable :: x2(:), x1(:) + integer*$type :: i4 ! data type + integer*$int_type, allocatable :: iorder1(:),iorder2(:) + integer*$int_type :: i0, i1, i2, i3, i ! index type + integer*$type :: mask + integer :: err + !DIR$ ATTRIBUTES ALIGN : 128 :: iorder1,iorder2, x2, x1 + + if (isize < 2) then + return + endif + + if (iradix == -1) then ! Sort Positive and negative + + allocate(x1(isize),iorder1(isize), x2(isize),iorder2(isize),stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to allocate arrays' + stop + endif + + i1=1_$int_type + i2=1_$int_type + do i=1_$int_type,isize + if (x(i) < 0_$type) then + iorder1(i1) = iorder(i) + x1(i1) = -x(i) + i1 = i1+1_$int_type + else + iorder2(i2) = iorder(i) + x2(i2) = x(i) + i2 = i2+1_$int_type + endif + enddo + i1=i1-1_$int_type + i2=i2-1_$int_type + + do i=1_$int_type,i2 + iorder(i1+i) = iorder2(i) + x(i1+i) = x2(i) + enddo + deallocate(x2,iorder2,stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to deallocate arrays x2, iorder2' + stop + endif + + + if (i1 > 1_$int_type) then + call $Xradix_sort$big(x1,iorder1,i1,-2) + do i=1_$int_type,i1 + x(i) = -x1(1_$int_type+i1-i) + iorder(i) = iorder1(1_$int_type+i1-i) + enddo + endif + + if (i2>1_$int_type) then + call $Xradix_sort$big(x(i1+1_$int_type),iorder(i1+1_$int_type),i2,-2) + endif + + deallocate(x1,iorder1,stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to deallocate arrays x1, iorder1' + stop + endif + return + + else if (iradix == -2) then ! Positive + + ! Find most significant bit + + i0 = 0_$int_type + i4 = maxval(x) + + iradix_new = max($integer_size-1-leadz(i4),1) + mask = ibset(0_$type,iradix_new) + + allocate(x1(isize),iorder1(isize), x2(isize),iorder2(isize),stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to allocate arrays' + stop + endif + + i1=1_$int_type + i2=1_$int_type + + do i=1_$int_type,isize + if (iand(mask,x(i)) == 0_$type) then + iorder1(i1) = iorder(i) + x1(i1) = x(i) + i1 = i1+1_$int_type + else + iorder2(i2) = iorder(i) + x2(i2) = x(i) + i2 = i2+1_$int_type + endif + enddo + i1=i1-1_$int_type + i2=i2-1_$int_type + + do i=1_$int_type,i1 + iorder(i0+i) = iorder1(i) + x(i0+i) = x1(i) + enddo + i0 = i0+i1 + i3 = i0 + deallocate(x1,iorder1,stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to deallocate arrays x1, iorder1' + stop + endif + + + do i=1_$int_type,i2 + iorder(i0+i) = iorder2(i) + x(i0+i) = x2(i) + enddo + i0 = i0+i2 + deallocate(x2,iorder2,stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to deallocate arrays x2, iorder2' + stop + endif + + + if (i3>1_$int_type) then + call $Xradix_sort$big(x,iorder,i3,iradix_new-1) + endif + + if (isize-i3>1_$int_type) then + call $Xradix_sort$big(x(i3+1_$int_type),iorder(i3+1_$int_type),isize-i3,iradix_new-1) + endif + + return + endif + + ASSERT (iradix >= 0) + + if (isize < 48) then + call insertion_$Xsort$big(x,iorder,isize) + return + endif + + + allocate(x2(isize),iorder2(isize),stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to allocate arrays x1, iorder1' + stop + endif + + + mask = ibset(0_$type,iradix) + i0=1_$int_type + i1=1_$int_type + + do i=1_$int_type,isize + if (iand(mask,x(i)) == 0_$type) then + iorder(i0) = iorder(i) + x(i0) = x(i) + i0 = i0+1_$int_type + else + iorder2(i1) = iorder(i) + x2(i1) = x(i) + i1 = i1+1_$int_type + endif + enddo + i0=i0-1_$int_type + i1=i1-1_$int_type + + do i=1_$int_type,i1 + iorder(i0+i) = iorder2(i) + x(i0+i) = x2(i) + enddo + + deallocate(x2,iorder2,stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to allocate arrays x2, iorder2' + stop + endif + + + if (iradix == 0) then + return + endif + + + if (i1>1_$int_type) then + call $Xradix_sort$big(x(i0+1_$int_type),iorder(i0+1_$int_type),i1,iradix-1) + endif + if (i0>1) then + call $Xradix_sort$big(x,iorder,i0,iradix-1) + endif + + end + +SUBST [ X, type, integer_size, is_big, big, int_type ] + i ; 4 ; 32 ; .False. ; ; 4 ;; + i8 ; 8 ; 64 ; .False. ; ; 4 ;; + i2 ; 2 ; 16 ; .False. ; ; 4 ;; + i ; 4 ; 32 ; .True. ; _big ; 8 ;; + i8 ; 8 ; 64 ; .True. ; _big ; 8 ;; +END_TEMPLATE + + + diff --git a/src/utils/units.irp.f b/src/utils/units.irp.f deleted file mode 100644 index 1850b28b..00000000 --- a/src/utils/units.irp.f +++ /dev/null @@ -1,22 +0,0 @@ -BEGIN_PROVIDER [double precision, ha_to_ev] - - implicit none - BEGIN_DOC - ! Converstion from Hartree to eV - END_DOC - - ha_to_ev = 27.211396641308d0 - -END_PROVIDER - -BEGIN_PROVIDER [double precision, au_to_D] - - implicit none - BEGIN_DOC - ! Converstion from au to Debye - END_DOC - - au_to_D = 2.5415802529d0 - -END_PROVIDER - diff --git a/src/utils/util.irp.f b/src/utils/util.irp.f index 84593031..184d8052 100644 --- a/src/utils/util.irp.f +++ b/src/utils/util.irp.f @@ -37,10 +37,6 @@ double precision function binom_func(i,j) else binom_func = dexp( logfact(i)-logfact(j)-logfact(i-j) ) endif - - ! To avoid .999999 numbers - binom_func = floor(binom_func + 0.5d0) - end @@ -136,7 +132,7 @@ double precision function logfact(n) enddo end function - +! --- BEGIN_PROVIDER [ double precision, fact_inv, (128) ] implicit none @@ -150,6 +146,29 @@ BEGIN_PROVIDER [ double precision, fact_inv, (128) ] enddo END_PROVIDER +! --- + +BEGIN_PROVIDER [ double precision, shiftfact_op5_inv, (128) ] + + BEGIN_DOC + ! + ! 1 / Gamma(n + 0.5) + ! + END_DOC + + implicit none + integer :: i + double precision :: tmp + + do i = 1, size(shiftfact_op5_inv) + !tmp = dgamma(dble(i) + 0.5d0) + tmp = gamma(dble(i) + 0.5d0) + shiftfact_op5_inv(i) = 1.d0 / tmp + enddo + +END_PROVIDER + +! --- double precision function dble_fact(n) implicit none @@ -304,12 +323,12 @@ subroutine wall_time(t) end BEGIN_PROVIDER [ integer, nproc ] - use omp_lib implicit none BEGIN_DOC ! Number of current OpenMP threads END_DOC + integer :: omp_get_num_threads nproc = 1 !$OMP PARALLEL !$OMP MASTER From c7f3d2674b95e1973af1619c39cc559606c6a5de Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 1 Aug 2022 08:42:21 +0200 Subject: [PATCH 55/80] Fix basis set --- configure | 8 +------- data/basis/cc-pv5z_ecp_bfd | 2 +- 2 files changed, 2 insertions(+), 8 deletions(-) diff --git a/configure b/configure index 5c38b9f2..b3ed7758 100755 --- a/configure +++ b/configure @@ -180,7 +180,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 bse" fi @@ -354,12 +354,6 @@ echo " ||----w | " echo " || || " echo "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" echo "" -echo "If you have PIP, you can install the Basis Set Exchange command-line tool:" -echo "" -echo " ./configure -i bse" -echo "" -echo "This will enable the usage of qp_basis to install extra basis sets." -echo "" echo "" printf "\e[m\n" diff --git a/data/basis/cc-pv5z_ecp_bfd b/data/basis/cc-pv5z_ecp_bfd index a19ce9d8..84b0300e 100644 --- a/data/basis/cc-pv5z_ecp_bfd +++ b/data/basis/cc-pv5z_ecp_bfd @@ -555,7 +555,7 @@ g 1 1.00 g 1 1.00 1 0.457496 1.000000 -MAGNESIUM +MAGNESIUM s 9 1.00 1 0.030975 0.165290 2 0.062959 0.506272 From 121799148faddaff922bc757488e675b8a9fcda6 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 29 Aug 2022 15:21:10 +0200 Subject: [PATCH 56/80] Fixed Dsyev failed with CSF --- .../diagonalization_hcsf_dressed.irp.f | 3 +- src/davidson/diagonalize_ci.irp.f | 62 ++++++++++++++----- 2 files changed, 49 insertions(+), 16 deletions(-) diff --git a/src/davidson/diagonalization_hcsf_dressed.irp.f b/src/davidson/diagonalization_hcsf_dressed.irp.f index 7aaaa842..a88330f6 100644 --- a/src/davidson/diagonalization_hcsf_dressed.irp.f +++ b/src/davidson/diagonalization_hcsf_dressed.irp.f @@ -1,4 +1,5 @@ -subroutine davidson_diag_h_csf(dets_in,u_in,dim_in,energies,sze,sze_csf,N_st,N_st_diag,Nint,dressing_state,converged) +subroutine davidson_diag_h_csf(dets_in, u_in, dim_in, energies, sze, sze_csf, & + N_st, N_st_diag, Nint, dressing_state,converged) use bitmasks implicit none BEGIN_DOC diff --git a/src/davidson/diagonalize_ci.irp.f b/src/davidson/diagonalize_ci.irp.f index 6930cc07..befd1907 100644 --- a/src/davidson/diagonalize_ci.irp.f +++ b/src/davidson/diagonalize_ci.irp.f @@ -68,13 +68,21 @@ END_PROVIDER do_csf = s2_eig .and. only_expected_s2 .and. csf_based - if (diag_algorithm == "Davidson") then + if (diag_algorithm == 'Davidson') then if (do_csf) then - if (sigma_vector_algorithm == 'det') then - call davidson_diag_H_csf(psi_det,CI_eigenvectors, & - size(CI_eigenvectors,1),CI_electronic_energy, & - N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged) +! if (sigma_vector_algorithm == 'det') then + call davidson_diag_H_csf (psi_det, & + CI_eigenvectors, & + size(CI_eigenvectors,1), & + CI_electronic_energy, & + N_det, & + N_csf, & + min(N_csf,N_states), & + min(N_csf,N_states_diag), & + N_int, & + 0, & + converged) ! else if (sigma_vector_algorithm == 'cfg') then ! call davidson_diag_H_csf(psi_det,CI_eigenvectors, & ! size(CI_eigenvectors,1),CI_electronic_energy, & @@ -82,11 +90,19 @@ END_PROVIDER ! else ! print *, irp_here ! stop 'bug' - endif +! endif else - call davidson_diag_HS2(psi_det,CI_eigenvectors, CI_s2, & - size(CI_eigenvectors,1),CI_electronic_energy, & - N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged) + call davidson_diag_HS2(psi_det, & + CI_eigenvectors, & + CI_s2, & + size(CI_eigenvectors,1), & + CI_electronic_energy, & + N_det, & + min(N_det,N_states), & + min(N_det,N_states_diag), & + N_int, & + 0, & + converged) endif integer :: N_states_diag_save @@ -107,9 +123,17 @@ END_PROVIDER CI_electronic_energy_tmp(1:N_states_diag_save) = CI_electronic_energy(1:N_states_diag_save) CI_eigenvectors_tmp(1:N_det,1:N_states_diag_save) = CI_eigenvectors(1:N_det,1:N_states_diag_save) - call davidson_diag_H_csf(psi_det,CI_eigenvectors_tmp, & - size(CI_eigenvectors_tmp,1),CI_electronic_energy_tmp, & - N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged) + call davidson_diag_H_csf (psi_det, & + CI_eigenvectors_tmp, & + size(CI_eigenvectors_tmp,1), & + CI_electronic_energy_tmp, & + N_det, & + N_csf, & + min(N_csf,N_states), & + min(N_csf,N_states_diag), & + N_int, & + 0, & + converged) CI_electronic_energy(1:N_states_diag_save) = CI_electronic_energy_tmp(1:N_states_diag_save) CI_eigenvectors(1:N_det,1:N_states_diag_save) = CI_eigenvectors_tmp(1:N_det,1:N_states_diag_save) @@ -127,9 +151,17 @@ END_PROVIDER CI_eigenvectors_tmp(1:N_det,1:N_states_diag_save) = CI_eigenvectors(1:N_det,1:N_states_diag_save) CI_s2_tmp(1:N_states_diag_save) = CI_s2(1:N_states_diag_save) - call davidson_diag_HS2(psi_det,CI_eigenvectors_tmp, CI_s2_tmp, & - size(CI_eigenvectors_tmp,1),CI_electronic_energy_tmp, & - N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged) + call davidson_diag_HS2(psi_det, & + CI_eigenvectors_tmp, & + CI_s2_tmp, & + size(CI_eigenvectors_tmp,1), & + CI_electronic_energy_tmp, & + N_det, & + min(N_det,N_states), & + min(N_det,N_states_diag), & + N_int, & + 0, & + converged) CI_electronic_energy(1:N_states_diag_save) = CI_electronic_energy_tmp(1:N_states_diag_save) CI_eigenvectors(1:N_det,1:N_states_diag_save) = CI_eigenvectors_tmp(1:N_det,1:N_states_diag_save) From 0a254628e5af2bd8f5dc50ed0aaef8dba738707d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 21 Apr 2022 13:39:01 +0200 Subject: [PATCH 57/80] Update test values --- src/fci/40.fci.bats | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/fci/40.fci.bats b/src/fci/40.fci.bats index 1a0c5507..b8528e97 100644 --- a/src/fci/40.fci.bats +++ b/src/fci/40.fci.bats @@ -71,7 +71,7 @@ function run_stoch() { @test "HBO" { # 13.3144s [[ -n $TRAVIS ]] && skip qp set_file hbo.ezfio - run -100.214099486337 1.e-3 100000 + run -100.213 1.e-3 100000 } @test "H2O" { # 11.3727s @@ -89,7 +89,7 @@ function run_stoch() { @test "SO" { # 13.4952s [[ -n $TRAVIS ]] && skip qp set_file so.ezfio - run -26.0176563764039 1.e-3 100000 + run -26.014 5.e-3 100000 } @test "H2S" { # 13.6745s @@ -119,7 +119,7 @@ function run_stoch() { @test "SiH3" { # 15.99s [[ -n $TRAVIS ]] && skip qp set_file sih3.ezfio - run -5.57241217753818 5.e-4 100000 + run -5.572 1.e-3 100000 } @test "CH4" { # 16.1612s @@ -153,7 +153,7 @@ function run_stoch() { [[ -n $TRAVIS ]] && skip qp set_file n2.ezfio qp set_mo_class --core="[1,2]" --act="[3-40]" --del="[41-60]" - run -109.287917088107 1.5e-3 100000 + run -109.288 2.e-3 100000 } @test "N2H4" { # 18.5006s From 058cf26ae4eac62d1de71c2e3db2de40e437cb70 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 21 Apr 2022 13:42:10 +0200 Subject: [PATCH 58/80] Update test values --- src/fci/40.fci.bats | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/fci/40.fci.bats b/src/fci/40.fci.bats index b8528e97..d890d586 100644 --- a/src/fci/40.fci.bats +++ b/src/fci/40.fci.bats @@ -42,7 +42,7 @@ function run_stoch() { [[ -n $TRAVIS ]] && skip qp set_file f2.ezfio qp set_frozen_core - run_stoch -199.304922384814 3.e-4 100000 + run_stoch -199.304922384814 3.e-3 100000 } @test "NH3" { # 10.6657s @@ -89,7 +89,7 @@ function run_stoch() { @test "SO" { # 13.4952s [[ -n $TRAVIS ]] && skip qp set_file so.ezfio - run -26.014 5.e-3 100000 + run -26.015 3.e-3 100000 } @test "H2S" { # 13.6745s @@ -146,7 +146,7 @@ function run_stoch() { [[ -n $TRAVIS ]] && skip qp set_file c2h2.ezfio qp set_mo_class --act="[1-30]" --del="[31-36]" - run -12.3685464085969 2.e-3 100000 + run -12.367 3.e-3 100000 } @test "N2" { # 18.0198s @@ -182,6 +182,6 @@ function run_stoch() { [[ -n $TRAVIS ]] && skip qp set_file hcn.ezfio qp set_mo_class --core="[1,2]" --act="[3-40]" --del="[41-55]" - run -93.0777619629755 1.e-3 100000 + run -93.078 2.e-3 100000 } From d7424f50df6aa2fc0710f6908f7c6974c5b74809 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 29 Aug 2022 15:32:36 +0200 Subject: [PATCH 59/80] Fixing tests --- external/qp2-dependencies | 2 +- src/cisd/30.cisd.bats | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/external/qp2-dependencies b/external/qp2-dependencies index 90ee61f5..242151e0 160000 --- a/external/qp2-dependencies +++ b/external/qp2-dependencies @@ -1 +1 @@ -Subproject commit 90ee61f5041c7c94a0c605625a264860292813a0 +Subproject commit 242151e03d1d6bf042387226431d82d35845686a diff --git a/src/cisd/30.cisd.bats b/src/cisd/30.cisd.bats index 58d996f8..69b862b0 100644 --- a/src/cisd/30.cisd.bats +++ b/src/cisd/30.cisd.bats @@ -4,7 +4,7 @@ source $QP_ROOT/tests/bats/common.bats.sh source $QP_ROOT/quantum_package.rc function run() { - thresh=1.e-5 + thresh=2.e-5 test_exe cisd || skip qp edit --check qp set determinants n_states 2 From c8109a1f516b9e7e7f71ecbfe61c9f6386755e8a Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 29 Aug 2022 15:32:36 +0200 Subject: [PATCH 60/80] Fixing tests --- external/qp2-dependencies | 2 +- src/cisd/30.cisd.bats | 2 +- src/fci/40.fci.bats | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/external/qp2-dependencies b/external/qp2-dependencies index 90ee61f5..242151e0 160000 --- a/external/qp2-dependencies +++ b/external/qp2-dependencies @@ -1 +1 @@ -Subproject commit 90ee61f5041c7c94a0c605625a264860292813a0 +Subproject commit 242151e03d1d6bf042387226431d82d35845686a diff --git a/src/cisd/30.cisd.bats b/src/cisd/30.cisd.bats index 58d996f8..69b862b0 100644 --- a/src/cisd/30.cisd.bats +++ b/src/cisd/30.cisd.bats @@ -4,7 +4,7 @@ source $QP_ROOT/tests/bats/common.bats.sh source $QP_ROOT/quantum_package.rc function run() { - thresh=1.e-5 + thresh=2.e-5 test_exe cisd || skip qp edit --check qp set determinants n_states 2 diff --git a/src/fci/40.fci.bats b/src/fci/40.fci.bats index d890d586..4523d0e0 100644 --- a/src/fci/40.fci.bats +++ b/src/fci/40.fci.bats @@ -71,7 +71,7 @@ function run_stoch() { @test "HBO" { # 13.3144s [[ -n $TRAVIS ]] && skip qp set_file hbo.ezfio - run -100.213 1.e-3 100000 + run -100.213 1.5e-3 100000 } @test "H2O" { # 11.3727s @@ -167,7 +167,7 @@ function run_stoch() { [[ -n $TRAVIS ]] && skip qp set_file co2.ezfio qp set_mo_class --core="[1,2]" --act="[3-30]" --del="[31-42]" - run -187.970184372047 1.5e-3 100000 + run -187.970184372047 1.6e-3 100000 } From 089b9eb18a300446770780717d4d787837a7788a Mon Sep 17 00:00:00 2001 From: AbdAmmar Date: Wed, 7 Sep 2022 15:03:13 +0200 Subject: [PATCH 61/80] dressing multi states --- src/dav_general_mat/NEED | 1 - .../dav_ext_rout_nonsym_B1space.irp.f | 205 ++----- .../diagonalization_hs2_dressed.irp.f | 15 +- .../diagonalization_nonsym_h_dressed.irp.f | 537 ++++++++++++++++++ src/davidson/overlap_states.irp.f | 40 ++ .../nonsym_diagonalize_ci.irp.f | 186 ++++++ src/scf_utils/diagonalize_fock.irp.f | 15 + src/utils/linear_algebra.irp.f | 136 ++++- 8 files changed, 968 insertions(+), 167 deletions(-) create mode 100644 src/davidson/diagonalization_nonsym_h_dressed.irp.f create mode 100644 src/davidson/overlap_states.irp.f create mode 100644 src/davidson_dressed/nonsym_diagonalize_ci.irp.f diff --git a/src/dav_general_mat/NEED b/src/dav_general_mat/NEED index 711fbf96..e69de29b 100644 --- a/src/dav_general_mat/NEED +++ b/src/dav_general_mat/NEED @@ -1 +0,0 @@ -davidson_undressed diff --git a/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f b/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f index c5127861..4ff84423 100644 --- a/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f +++ b/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f @@ -34,7 +34,7 @@ subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N character*(16384) :: write_buffer integer :: iter, N_st_diag - integer :: i, j, k, m + integer :: i, j, k, l, m integer :: iter2, itertot logical :: disk_based integer :: shift, shift2, itermax @@ -49,8 +49,8 @@ subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N double precision, allocatable :: y(:,:), h(:,:), lambda(:) double precision, allocatable :: residual_norm(:) - integer :: i_omax double precision :: lambda_tmp + integer, allocatable :: i_omax(:) double precision, allocatable :: U_tmp(:), overlap(:) double precision, allocatable :: W(:,:) @@ -171,7 +171,8 @@ subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N h(N_st_diag*itermax,N_st_diag*itermax), & y(N_st_diag*itermax,N_st_diag*itermax), & lambda(N_st_diag*itermax), & - residual_norm(N_st_diag) & + residual_norm(N_st_diag), & + i_omax(N_st) & ) U = 0.d0 @@ -303,31 +304,43 @@ subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N ! end test ------------------------------------------------------------------------ ! + + ! TODO + ! state_following is more efficient + do l = 1, N_st - allocate( overlap(N_st_diag) ) + allocate( overlap(N_st_diag) ) - do k = 1, N_st_diag - overlap(k) = 0.d0 - do i = 1, sze - overlap(k) = overlap(k) + U(i,shift2+k) * u_in(i,1) + do k = 1, N_st_diag + overlap(k) = 0.d0 + do i = 1, sze + overlap(k) = overlap(k) + U(i,shift2+k) * u_in(i,l) + enddo + overlap(k) = dabs(overlap(k)) + !print *, ' overlap =', k, overlap(k) enddo - overlap(k) = dabs(overlap(k)) - !print *, ' overlap =', k, overlap(k) - enddo - lambda_tmp = 0.d0 - do k = 1, N_st_diag - if(overlap(k) .gt. lambda_tmp) then - i_omax = k - lambda_tmp = overlap(k) + lambda_tmp = 0.d0 + do k = 1, N_st_diag + if(overlap(k) .gt. lambda_tmp) then + i_omax(l) = k + lambda_tmp = overlap(k) + endif + enddo + + deallocate(overlap) + + if(lambda_tmp .lt. 0.7d0) then + print *, ' very small overlap ...', l, i_omax(l) + print *, ' max overlap = ', lambda_tmp + stop + endif + + if(i_omax(l) .ne. l) then + print *, ' !!! WARNONG !!!' + print *, ' index of state', l, i_omax(l) endif enddo - deallocate(overlap) - if( lambda_tmp .lt. 0.8d0) then - print *, ' very small overlap..' - print*, ' max overlap = ', lambda_tmp, i_omax - stop - endif ! lambda_tmp = lambda(1) ! lambda(1) = lambda(i_omax) @@ -375,16 +388,17 @@ subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N do i = 1, sze U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k)) / max(H_jj(i)-lambda(k), 1.d-2) enddo - !if(k <= N_st) then - ! residual_norm(k) = u_dot_u(U(1,shift2+k), sze) - ! to_print(1,k) = lambda(k) - ! to_print(2,k) = residual_norm(k) - !endif + if(k <= N_st) then + l = k + residual_norm(k) = u_dot_u(U(1,shift2+l), sze) + to_print(1,k) = lambda(l) + to_print(2,k) = residual_norm(l) + endif enddo !$OMP END PARALLEL DO - residual_norm(1) = u_dot_u(U(1,shift2+i_omax), sze) - to_print(1,1) = lambda(i_omax) - to_print(2,1) = residual_norm(1) + !residual_norm(1) = u_dot_u(U(1,shift2+1), sze) + !to_print(1,1) = lambda(1) + !to_print(2,1) = residual_norm(1) if( (itertot > 1) .and. (iter == 1) ) then @@ -469,7 +483,7 @@ subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N call write_time(6) deallocate(W) - deallocate(U, h, y, lambda, residual_norm) + deallocate(U, h, y, lambda, residual_norm, i_omax) FREE nthreads_davidson @@ -477,132 +491,3 @@ end subroutine davidson_general_ext_rout_nonsym_b1space ! --- -subroutine diag_nonsym_right(n, A, A_ldim, V, V_ldim, energy, E_ldim) - - implicit none - - integer, intent(in) :: n, A_ldim, V_ldim, E_ldim - double precision, intent(in) :: A(A_ldim,n) - double precision, intent(out) :: energy(E_ldim), V(V_ldim,n) - - character*1 :: JOBVL, JOBVR, BALANC, SENSE - integer :: i, j - integer :: ILO, IHI, lda, ldvl, ldvr, LWORK, INFO - double precision :: ABNRM - integer, allocatable :: iorder(:), IWORK(:) - double precision, allocatable :: WORK(:), SCALE_array(:), RCONDE(:), RCONDV(:) - double precision, allocatable :: Atmp(:,:), WR(:), WI(:), VL(:,:), VR(:,:), Vtmp(:) - double precision, allocatable :: energy_loc(:), V_loc(:,:) - - allocate( Atmp(n,n), WR(n), WI(n), VL(1,1), VR(n,n) ) - do i = 1, n - do j = 1, n - Atmp(j,i) = A(j,i) - enddo - enddo - - JOBVL = "N" ! computes the left eigenvectors - JOBVR = "V" ! computes the right eigenvectors - BALANC = "B" ! Diagonal scaling and Permutation for optimization - SENSE = "V" ! Determines which reciprocal condition numbers are computed - lda = n - ldvr = n - ldvl = 1 - - allocate( WORK(1), SCALE_array(n), RCONDE(n), RCONDV(n), IWORK(2*n-2) ) - - LWORK = -1 ! to ask for the optimal size of WORK - call dgeevx( BALANC, JOBVL, JOBVR, SENSE & ! CHARACTERS - , n, Atmp, lda & ! MATRIX TO DIAGONALIZE - , WR, WI & ! REAL AND IMAGINARY PART OF EIGENVALUES - , VL, ldvl, VR, ldvr & ! LEFT AND RIGHT EIGENVECTORS - , ILO, IHI, SCALE_array, ABNRM, RCONDE, RCONDV & ! OUTPUTS OF OPTIMIZATION - , WORK, LWORK, IWORK, INFO ) - - if(INFO .ne. 0) then - print*, 'dgeevx failed !!', INFO - stop - endif - - LWORK = max(int(work(1)), 1) ! this is the optimal size of WORK - deallocate(WORK) - allocate(WORK(LWORK)) - call dgeevx( BALANC, JOBVL, JOBVR, SENSE & - , n, Atmp, lda & - , WR, WI & - , VL, ldvl, VR, ldvr & - , ILO, IHI, SCALE_array, ABNRM, RCONDE, RCONDV & - , WORK, LWORK, IWORK, INFO ) - if(INFO .ne. 0) then - print*, 'dgeevx failed !!', INFO - stop - endif - - deallocate( WORK, SCALE_array, RCONDE, RCONDV, IWORK ) - deallocate( VL, Atmp ) - - - allocate( energy_loc(n), V_loc(n,n) ) - energy_loc = 0.d0 - V_loc = 0.d0 - - i = 1 - do while(i .le. n) - -! print*, i, WR(i), WI(i) - - if( dabs(WI(i)) .gt. 1e-7 ) then - - print*, ' Found an imaginary component to eigenvalue' - print*, ' Re(i) + Im(i)', i, WR(i), WI(i) - - energy_loc(i) = WR(i) - do j = 1, n - V_loc(j,i) = WR(i) * VR(j,i) - WI(i) * VR(j,i+1) - enddo - energy_loc(i+1) = WI(i) - do j = 1, n - V_loc(j,i+1) = WR(i) * VR(j,i+1) + WI(i) * VR(j,i) - enddo - i = i + 2 - - else - - energy_loc(i) = WR(i) - do j = 1, n - V_loc(j,i) = VR(j,i) - enddo - i = i + 1 - - endif - - enddo - - deallocate(WR, WI, VR) - - - ! ordering -! do j = 1, n -! write(444, '(100(1X, F16.10))') (V_loc(j,i), i=1,5) -! enddo - allocate( iorder(n) ) - do i = 1, n - iorder(i) = i - enddo - call dsort(energy_loc, iorder, n) - do i = 1, n - energy(i) = energy_loc(i) - do j = 1, n - V(j,i) = V_loc(j,iorder(i)) - enddo - enddo - deallocate(iorder) -! do j = 1, n -! write(445, '(100(1X, F16.10))') (V_loc(j,i), i=1,5) -! enddo - deallocate(V_loc, energy_loc) - -end subroutine diag_nonsym_right - -! --- - diff --git a/src/davidson/diagonalization_hs2_dressed.irp.f b/src/davidson/diagonalization_hs2_dressed.irp.f index 1a27a75e..0f5b38e3 100644 --- a/src/davidson/diagonalization_hs2_dressed.irp.f +++ b/src/davidson/diagonalization_hs2_dressed.irp.f @@ -66,7 +66,7 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d double precision, allocatable :: H_jj(:) double precision, external :: diag_H_mat_elem, diag_S_mat_elem - integer :: i,k + integer :: i,k,l ASSERT (N_st > 0) ASSERT (sze > 0) ASSERT (Nint > 0) @@ -86,10 +86,15 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d !$OMP END PARALLEL if (dressing_state > 0) then - do k=1,N_st - do i=1,sze - H_jj(i) += u_in(i,k) * dressing_column_h(i,k) - enddo + do k = 1, N_st + + ! do i = 1, sze + ! H_jj(i) += u_in(i,k) * dressing_column_h(i,k) + ! enddo + + l = dressed_column_idx(k) + H_jj(l) += u_in(l,k) * dressing_column_h(l,k) + enddo endif diff --git a/src/davidson/diagonalization_nonsym_h_dressed.irp.f b/src/davidson/diagonalization_nonsym_h_dressed.irp.f new file mode 100644 index 00000000..7db02a32 --- /dev/null +++ b/src/davidson/diagonalization_nonsym_h_dressed.irp.f @@ -0,0 +1,537 @@ + +! --- + +subroutine davidson_diag_nonsym_h(dets_in, u_in, dim_in, energies, sze, N_st, N_st_diag, Nint, dressing_state, converged) + + BEGIN_DOC + ! + ! non-sym Davidson diagonalization. + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! Initial guess vectors are not necessarily orthonormal + ! + END_DOC + + use bitmasks + + implicit none + + integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint + integer, intent(in) :: dressing_state + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + logical, intent(out) :: converged + double precision, intent(out) :: energies(N_st_diag) + double precision, intent(inout) :: u_in(dim_in,N_st_diag) + + integer :: i, k, l + double precision :: f + double precision, allocatable :: H_jj(:) + + double precision, external :: diag_H_mat_elem + + ASSERT (N_st > 0) + ASSERT (sze > 0) + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + PROVIDE mo_two_e_integrals_in_map + + allocate(H_jj(sze)) + + H_jj(1) = diag_H_mat_elem(dets_in(1,1,1), Nint) + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(sze, H_jj, dets_in, Nint) & + !$OMP PRIVATE(i) + !$OMP DO SCHEDULE(static) + do i = 2, sze + H_jj(i) = diag_H_mat_elem(dets_in(1,1,i), Nint) + enddo + !$OMP END DO + !$OMP END PARALLEL + + if(dressing_state > 0) then + do k = 1, N_st + do l = 1, N_st + f = overlap_states_inv(k,l) + do i = 1, N_det + H_jj(i) += f * dressing_delta(i,k) * psi_coef(i,l) + enddo + enddo + enddo + endif + + call davidson_diag_nonsym_hjj(dets_in, u_in, H_jj, energies, dim_in, sze, N_st, N_st_diag, Nint, dressing_state, converged) + + deallocate(H_jj) + +end subroutine davidson_diag_nonsym_h + +! --- + +subroutine davidson_diag_nonsym_hjj(dets_in, u_in, H_jj, energies, dim_in, sze, N_st, N_st_diag_in, Nint, dressing_state, converged) + + BEGIN_DOC + ! + ! non-sym Davidson diagonalization with specific diagonal elements of the H matrix + ! + ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! N_st_diag_in : Number of states in which H is diagonalized. Assumed > sze + ! + ! Initial guess vectors are not necessarily orthonormal + ! + END_DOC + + include 'constants.include.F' + + use bitmasks + use mmap_module + + implicit none + + integer, intent(in) :: dim_in, sze, N_st, N_st_diag_in, Nint + integer, intent(in) :: dressing_state + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + double precision, intent(in) :: H_jj(sze) + double precision, intent(out) :: energies(N_st_diag_in) + logical, intent(inout) :: converged + double precision, intent(inout) :: u_in(dim_in,N_st_diag_in) + + logical :: disk_based + character*(16384) :: write_buffer + integer :: i, j, k, l, m + integer :: iter, N_st_diag, itertot, shift, shift2, itermax, istate + integer :: nproc_target + integer :: order(N_st_diag_in) + integer :: maxab + double precision :: rss + double precision :: cmax + double precision :: to_print(2,N_st) + double precision :: r1, r2 + double precision :: f + double precision, allocatable :: y(:,:), h(:,:), lambda(:) + double precision, allocatable :: s_tmp(:,:), u_tmp(:,:) + double precision, allocatable :: residual_norm(:) + double precision, allocatable :: U(:,:), overlap(:,:) + double precision, pointer :: W(:,:) + + double precision, external :: u_dot_u + + + N_st_diag = N_st_diag_in + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, y, h, lambda + if(N_st_diag*3 > sze) then + print *, 'error in Davidson :' + print *, 'Increase n_det_max_full to ', N_st_diag*3 + stop -1 + endif + + itermax = max(2, min(davidson_sze_max, sze/N_st_diag)) + 1 + itertot = 0 + + if(state_following) then + allocate(overlap(N_st_diag*itermax, N_st_diag*itermax)) + else + allocate(overlap(1,1)) ! avoid 'if' for deallocate + endif + overlap = 0.d0 + + PROVIDE nuclear_repulsion expected_s2 psi_bilinear_matrix_order psi_bilinear_matrix_order_reverse threshold_davidson_pt2 threshold_davidson_from_pt2 + PROVIDE threshold_nonsym_davidson + + call write_time(6) + write(6,'(A)') '' + write(6,'(A)') 'Davidson Diagonalization' + write(6,'(A)') '------------------------' + write(6,'(A)') '' + + ! Find max number of cores to fit in memory + ! ----------------------------------------- + + nproc_target = nproc + maxab = max(N_det_alpha_unique, N_det_beta_unique) + 1 + + m=1 + disk_based = .False. + call resident_memory(rss) + do + r1 = 8.d0 * &! bytes + ( dble(sze)*(N_st_diag*itermax) &! U + + 1.0d0*dble(sze*m)*(N_st_diag*itermax) &! W + + 3.0d0*(N_st_diag*itermax)**2 &! h,y,s_tmp + + 1.d0*(N_st_diag*itermax) &! lambda + + 1.d0*(N_st_diag) &! residual_norm + ! In H_u_0_nstates_zmq + + 2.d0*(N_st_diag*N_det) &! u_t, v_t, on collector + + 2.d0*(N_st_diag*N_det) &! u_t, v_t, on slave + + 0.5d0*maxab &! idx0 in H_u_0_nstates_openmp_work_* + + nproc_target * &! In OMP section + ( 1.d0*(N_int*maxab) &! buffer + + 3.5d0*(maxab) ) &! singles_a, singles_b, doubles, idx + ) / 1024.d0**3 + + if(nproc_target == 0) then + call check_mem(r1, irp_here) + nproc_target = 1 + exit + endif + + if(r1+rss < qp_max_mem) then + exit + endif + + if(itermax > 4) then + itermax = itermax - 1 + else if(m==1 .and. disk_based_davidson) then + m = 0 + disk_based = .True. + itermax = 6 + else + nproc_target = nproc_target - 1 + endif + + enddo + + nthreads_davidson = nproc_target + TOUCH nthreads_davidson + + call write_int(6, N_st, 'Number of states') + call write_int(6, N_st_diag, 'Number of states in diagonalization') + call write_int(6, sze, 'Number of determinants') + call write_int(6, nproc_target, 'Number of threads for diagonalization') + call write_double(6, r1, 'Memory(Gb)') + if(disk_based) then + print *, 'Using swap space to reduce RAM' + endif + + !--------------- + + write(6,'(A)') '' + write_buffer = '=====' + do i = 1, N_st + write_buffer = trim(write_buffer)//' ================ ===========' + enddo + write(6, '(A)') write_buffer(1:6+41*N_st) + write_buffer = 'Iter' + do i = 1, N_st + write_buffer = trim(write_buffer)//' Energy Residual ' + enddo + write(6,'(A)') write_buffer(1:6+41*N_st) + write_buffer = '=====' + do i = 1, N_st + write_buffer = trim(write_buffer)//' ================ ===========' + enddo + write(6,'(A)') write_buffer(1:6+41*N_st) + + + if(disk_based) then + ! Create memory-mapped files for W and S + type(c_ptr) :: ptr_w, ptr_s + integer :: fd_s, fd_w + call mmap(trim(ezfio_work_dir)//'davidson_w', (/int(sze,8),int(N_st_diag*itermax,8)/),& + 8, fd_w, .False., ptr_w) + call c_f_pointer(ptr_w, w, (/sze,N_st_diag*itermax/)) + else + allocate(W(sze,N_st_diag*itermax)) + endif + + allocate( & + ! Large + U(sze,N_st_diag*itermax), & + ! Small + h(N_st_diag*itermax,N_st_diag*itermax), & + y(N_st_diag*itermax,N_st_diag*itermax), & + s_tmp(N_st_diag*itermax,N_st_diag*itermax), & + residual_norm(N_st_diag), & + lambda(N_st_diag*itermax), & + u_tmp(N_st,N_st_diag)) + + h = 0.d0 + U = 0.d0 + y = 0.d0 + s_tmp = 0.d0 + + + ASSERT (N_st > 0) + ASSERT (N_st_diag >= N_st) + ASSERT (sze > 0) + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + + ! Davidson iterations + ! =================== + + converged = .False. + + do k = N_st+1, N_st_diag + do i = 1, sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + u_in(i,k) = r1*dcos(r2) * u_in(i,k-N_st) + enddo + u_in(k,k) = u_in(k,k) + 10.d0 + enddo + do k = 1, N_st_diag + call normalize(u_in(1,k), sze) + enddo + + do k = 1, N_st_diag + do i = 1, sze + U(i,k) = u_in(i,k) + enddo + enddo + + + do while (.not.converged) + itertot = itertot + 1 + if(itertot == 8) then + exit + endif + + do iter = 1, itermax-1 + + shift = N_st_diag*(iter-1) + shift2 = N_st_diag*iter + + if( (iter > 1) .or. (itertot == 1) ) then + + ! Gram-Schmidt to orthogonalize all new guess with the previous vectors + call ortho_qr(U, size(U, 1), sze, shift2) + call ortho_qr(U, size(U, 1), sze, shift2) + + ! Compute |W_k> = \sum_i |i> + ! ----------------------------------- + + if( (sze > 100000) .and. distributed_davidson ) then + call H_u_0_nstates_zmq (W(1,shift+1), U(1,shift+1), N_st_diag, sze) + else + call H_u_0_nstates_openmp(W(1,shift+1), U(1,shift+1), N_st_diag, sze) + endif + else + ! Already computed in update below + continue + endif + + if(dressing_state > 0) then + + call dgemm( 'T', 'N', N_st, N_st_diag, sze, 1.d0 & + , psi_coef, size(psi_coef, 1), U(1, shift+1), size(U, 1) & + , 0.d0, u_tmp, size(u_tmp, 1)) + + do istate = 1, N_st_diag + do k = 1, N_st + do l = 1, N_st + f = overlap_states_inv(k,l) + do i = 1, sze + W(i,shift+istate) += f * dressing_delta(i,k) * u_tmp(l,istate) + enddo + enddo + enddo + enddo + + endif + + ! Compute h_kl = = + ! ------------------------------------------- + + call dgemm( 'T', 'N', shift2, shift2, sze, 1.d0 & + , U, size(U, 1), W, size(W, 1) & + , 0.d0, h, size(h, 1)) + + ! Diagonalize h + ! --------------- + call diag_nonsym_right(shift2, h(1,1), size(h, 1), y(1,1), size(y, 1), lambda(1), size(lambda, 1)) + + + if (state_following) then + + overlap = -1.d0 + do k = 1, shift2 + do i = 1, shift2 + overlap(k,i) = dabs(y(k,i)) + enddo + enddo + do k = 1, N_st + cmax = -1.d0 + do i = 1, N_st + if(overlap(i,k) > cmax) then + cmax = overlap(i,k) + order(k) = i + endif + enddo + do i = 1, N_st_diag + overlap(order(k),i) = -1.d0 + enddo + enddo + overlap = y + do k = 1, N_st + l = order(k) + if (k /= l) then + y(1:shift2,k) = overlap(1:shift2,l) + endif + enddo + do k = 1, N_st + overlap(k,1) = lambda(k) + enddo + + endif + + ! Express eigenvectors of h in the determinant basis + ! -------------------------------------------------- + + call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 & + , U, size(U, 1), y, size(y, 1) & + , 0.d0, U(1,shift2+1), size(U, 1)) + + do k = 1, N_st_diag + call normalize(U(1,shift2+k), sze) + enddo + + call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 & + , W, size(W, 1), y, size(y, 1) & + , 0.d0, W(1,shift2+1), size(W,1)) + + ! Compute residual vector and davidson step + ! ----------------------------------------- + + !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,k) + do k = 1, N_st_diag + do i = 1, sze + U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) / max(H_jj(i)-lambda(k), 1.d-2) + enddo + + if(k <= N_st) then + residual_norm(k) = u_dot_u(U(1,shift2+k), sze) + to_print(1,k) = lambda(k) + nuclear_repulsion + to_print(2,k) = residual_norm(k) + endif + enddo + !$OMP END PARALLEL DO + + if ((itertot>1).and.(iter == 1)) then + !don't print + continue + else + write(*, '(1X, I3, 1X, 100(1X, F16.10, 1X, E11.3))') iter-1, to_print(1:2,1:N_st) + endif + + ! Check convergence + if(iter > 1) then + if(threshold_davidson_from_pt2) then + converged = dabs(maxval(residual_norm(1:N_st))) < threshold_davidson_pt2 + else + converged = dabs(maxval(residual_norm(1:N_st))) < threshold_nonsym_davidson + endif + endif + + do k = 1, N_st + if(residual_norm(k) > 1.d8) then + print *, 'Davidson failed' + stop -1 + endif + enddo + if(converged) then + exit + endif + + logical, external :: qp_stop + if(qp_stop()) then + converged = .True. + exit + endif + + + enddo + + ! Re-contract U and update W + ! -------------------------------- + + call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 & + , W, size(W, 1), y, size(y, 1) & + , 0.d0, u_in, size(u_in, 1)) + do k = 1, N_st_diag + do i = 1, sze + W(i,k) = u_in(i,k) + enddo + enddo + + call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 & + , U, size(U, 1), y, size(y, 1), 0.d0 & + , u_in, size(u_in, 1)) + + do k = 1, N_st_diag + do i = 1, sze + U(i,k) = u_in(i,k) + enddo + enddo + + enddo + + + call nullify_small_elements(sze, N_st_diag, U, size(U, 1), threshold_davidson_pt2) + do k = 1, N_st_diag + do i = 1, sze + u_in(i,k) = U(i,k) + enddo + enddo + + do k = 1, N_st_diag + energies(k) = lambda(k) + enddo + write_buffer = '======' + do i = 1, N_st + write_buffer = trim(write_buffer)//' ================ ===========' + enddo + write(6,'(A)') trim(write_buffer) + write(6,'(A)') '' + call write_time(6) + + if(disk_based) then + ! Remove temp files + integer, external :: getUnitAndOpen + call munmap( (/int(sze,8),int(N_st_diag*itermax,8)/), 8, fd_w, ptr_w ) + fd_w = getUnitAndOpen(trim(ezfio_work_dir)//'davidson_w','r') + close(fd_w,status='delete') + else + deallocate(W) + endif + + deallocate ( & + residual_norm, & + U, overlap, & + h, y, s_tmp, & + lambda, & + u_tmp & + ) + FREE nthreads_davidson + +end subroutine davidson_diag_nonsym_hjj + +! --- + + + + + + + diff --git a/src/davidson/overlap_states.irp.f b/src/davidson/overlap_states.irp.f new file mode 100644 index 00000000..797d1210 --- /dev/null +++ b/src/davidson/overlap_states.irp.f @@ -0,0 +1,40 @@ + +! --- + + BEGIN_PROVIDER [ double precision, overlap_states, (N_states,N_states) ] +&BEGIN_PROVIDER [ double precision, overlap_states_inv, (N_states,N_states) ] + + BEGIN_DOC + ! + ! S_kl = ck.T x cl + ! = psi_coef(:,k).T x psi_coef(:,l) + ! + END_DOC + + implicit none + integer :: i + double precision :: o_tmp + + if(N_states == 1) then + + o_tmp = 0.d0 + do i = 1, N_det + o_tmp = o_tmp + psi_coef(i,1) * psi_coef(i,1) + enddo + overlap_states (1,1) = o_tmp + overlap_states_inv(1,1) = 1.d0 / o_tmp + + else + + call dgemm( 'T', 'N', N_states, N_states, N_det, 1.d0 & + , psi_coef, size(psi_coef, 1), psi_coef, size(psi_coef, 1) & + , 0.d0, overlap_states, size(overlap_states, 1) ) + + call get_inverse(overlap_states, N_states, N_states, overlap_states_inv, N_states) + + endif + +END_PROVIDER + +! --- + diff --git a/src/davidson_dressed/nonsym_diagonalize_ci.irp.f b/src/davidson_dressed/nonsym_diagonalize_ci.irp.f new file mode 100644 index 00000000..764802c2 --- /dev/null +++ b/src/davidson_dressed/nonsym_diagonalize_ci.irp.f @@ -0,0 +1,186 @@ + +! --- + +BEGIN_PROVIDER [ double precision, CI_energy_nonsym_dressed, (N_states_diag) ] + + BEGIN_DOC + ! N_states lowest eigenvalues of the CI matrix + END_DOC + + implicit none + integer :: j + character*(8) :: st + + call write_time(6) + do j = 1, min(N_det, N_states_diag) + CI_energy_nonsym_dressed(j) = CI_electronic_energy_nonsym_dressed(j) + nuclear_repulsion + enddo + + do j = 1, min(N_det, N_states) + write(st, '(I4)') j + call write_double(6, CI_energy_nonsym_dressed(j), 'Energy of state '//trim(st)) + enddo + +END_PROVIDER + +! --- + + BEGIN_PROVIDER [ double precision, CI_electronic_energy_nonsym_dressed, (N_states_diag) ] +&BEGIN_PROVIDER [ double precision, CI_eigenvectors_nonsym_dressed, (N_det,N_states_diag) ] + + BEGIN_DOC + ! Eigenvectors/values of the CI matrix + END_DOC + + implicit none + logical :: converged + integer :: i, j, k + integer :: i_other_state + integer :: i_state + logical, allocatable :: good_state_array(:) + integer, allocatable :: index_good_state_array(:) + double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) + + PROVIDE threshold_nonsym_davidson nthreads_davidson + + ! Guess values for the "N_states" states of the CI_eigenvectors_nonsym_dressed + do j = 1, min(N_states, N_det) + do i = 1, N_det + CI_eigenvectors_nonsym_dressed(i,j) = psi_coef(i,j) + enddo + enddo + + do j = min(N_states, N_det)+1, N_states_diag + do i = 1, N_det + CI_eigenvectors_nonsym_dressed(i,j) = 0.d0 + enddo + enddo + + ! --- + + if(diag_algorithm == "Davidson") then + + do j = 1, min(N_states, N_det) + do i = 1, N_det + CI_eigenvectors_nonsym_dressed(i,j) = psi_coef(i,j) + enddo + enddo + + converged = .False. + call davidson_diag_nonsym_h( psi_det, CI_eigenvectors_nonsym_dressed & + , size(CI_eigenvectors_nonsym_dressed, 1) & + , CI_electronic_energy_nonsym_dressed & + , N_det, min(N_det, N_states), min(N_det, N_states_diag), N_int, 1, converged ) + + else if(diag_algorithm == "Lapack") then + + allocate(eigenvectors(size(H_matrix_nonsym_dressed, 1),N_det)) + allocate(eigenvalues(N_det)) + + call diag_nonsym_right( N_det, H_matrix_nonsym_dressed, size(H_matrix_nonsym_dressed, 1) & + , eigenvectors, size(eigenvectors, 1), eigenvalues, size(eigenvalues, 1) ) + + CI_electronic_energy_nonsym_dressed(:) = 0.d0 + + ! Select the "N_states_diag" states of lowest energy + do j = 1, min(N_det, N_states_diag) + do i = 1, N_det + CI_eigenvectors_nonsym_dressed(i,j) = eigenvectors(i,j) + enddo + CI_electronic_energy_nonsym_dressed(j) = eigenvalues(j) + enddo + + deallocate(eigenvectors, eigenvalues) + + ! --- --- + + endif + + ! --- + +END_PROVIDER + +! --- + +subroutine diagonalize_CI_nonsym_dressed() + + BEGIN_DOC + ! Replace the coefficients of the CI states by the coefficients of the + ! eigenstates of the CI matrix + END_DOC + + implicit none + integer :: i, j + + PROVIDE dressing_delta + + do j = 1, N_states + do i = 1, N_det + psi_coef(i,j) = CI_eigenvectors_nonsym_dressed(i,j) + enddo + enddo + + SOFT_TOUCH psi_coef + +end subroutine diagonalize_CI_nonsym_dressed + +! --- + +BEGIN_PROVIDER [ double precision, H_matrix_nonsym_dressed, (N_det,N_det) ] + + BEGIN_DOC + ! Dressed H with Delta_ij + END_DOC + + implicit none + integer :: i, j, l, k + double precision :: f + + H_matrix_nonsym_dressed(1:N_det,1:N_det) = h_matrix_all_dets(1:N_det,1:N_det) + + if(N_states == 1) then + +! !symmetric formula +! l = dressed_column_idx(1) +! f = 1.0d0/psi_coef(l,1) +! do i=1,N_det +! h_matrix_nonsym_dressed(i,l) += dressing_column_h(i,1) *f +! h_matrix_nonsym_dressed(l,i) += dressing_column_h(i,1) *f +! enddo + +! l = dressed_column_idx(1) +! f = 1.0d0 / psi_coef(l,1) +! do j = 1, N_det +! H_matrix_nonsym_dressed(j,l) += f * dressing_delta(j,1) +! enddo + + k = 1 + l = 1 + f = overlap_states_inv(k,l) + do j = 1, N_det + do i = 1, N_det + H_matrix_nonsym_dressed(i,j) = H_matrix_nonsym_dressed(i,j) + f * dressing_delta(i,k) * psi_coef(j,l) + enddo + enddo + + else + + do k = 1, N_states + do l = 1, N_states + f = overlap_states_inv(k,l) + + do j = 1, N_det + do i = 1, N_det + H_matrix_nonsym_dressed(i,j) = H_matrix_nonsym_dressed(i,j) + f * dressing_delta(i,k) * psi_coef(j,l) + enddo + enddo + + enddo + enddo + + endif + +END_PROVIDER + +! --- + diff --git a/src/scf_utils/diagonalize_fock.irp.f b/src/scf_utils/diagonalize_fock.irp.f index 5188581a..a567b9c7 100644 --- a/src/scf_utils/diagonalize_fock.irp.f +++ b/src/scf_utils/diagonalize_fock.irp.f @@ -73,6 +73,11 @@ BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num,mo_num) liwork = -1 F_save = F + !print *, ' Fock matrix' + !do i = 1, mo_num + ! write(*, '(1000(F16.10,X))') F_save(:,i) + !enddo + call dsyevd( 'V', 'U', mo_num, F, & size(F,1), diag, work, lwork, iwork, liwork, info) @@ -103,6 +108,16 @@ BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num,mo_num) endif endif + !print *, ' eigenvalues' + !do i = 1, mo_num + ! write(*, '(1000(F16.10,X))') diag(i) + !enddo + !print *, ' eigenvectors' + !do i = 1, mo_num + ! write(*, '(1000(F16.10,X))') F(:,i) + !enddo + + call dgemm('N','N',ao_num,mo_num,mo_num, 1.d0, & mo_coef, size(mo_coef,1), F, size(F,1), & 0.d0, eigenvectors_Fock_matrix_mo, size(eigenvectors_Fock_matrix_mo,1)) diff --git a/src/utils/linear_algebra.irp.f b/src/utils/linear_algebra.irp.f index ae0bb8e5..809f594b 100644 --- a/src/utils/linear_algebra.irp.f +++ b/src/utils/linear_algebra.irp.f @@ -1,4 +1,7 @@ -subroutine svd(A,LDA,U,LDU,D,Vt,LDVt,m,n) + +! --- + +subroutine svd(A, LDA, U, LDU, D, Vt, LDVt, m, n) implicit none BEGIN_DOC ! Compute A = U.D.Vt @@ -1749,3 +1752,134 @@ end ! !end ! + +! --- + +subroutine diag_nonsym_right(n, A, A_ldim, V, V_ldim, energy, E_ldim) + + implicit none + + integer, intent(in) :: n, A_ldim, V_ldim, E_ldim + double precision, intent(in) :: A(A_ldim,n) + double precision, intent(out) :: energy(E_ldim), V(V_ldim,n) + + character*1 :: JOBVL, JOBVR, BALANC, SENSE + integer :: i, j + integer :: ILO, IHI, lda, ldvl, ldvr, LWORK, INFO + double precision :: ABNRM + integer, allocatable :: iorder(:), IWORK(:) + double precision, allocatable :: WORK(:), SCALE_array(:), RCONDE(:), RCONDV(:) + double precision, allocatable :: Atmp(:,:), WR(:), WI(:), VL(:,:), VR(:,:), Vtmp(:) + double precision, allocatable :: energy_loc(:), V_loc(:,:) + + allocate( Atmp(n,n), WR(n), WI(n), VL(1,1), VR(n,n) ) + do i = 1, n + do j = 1, n + Atmp(j,i) = A(j,i) + enddo + enddo + + JOBVL = "N" ! computes the left eigenvectors + JOBVR = "V" ! computes the right eigenvectors + BALANC = "B" ! Diagonal scaling and Permutation for optimization + SENSE = "V" ! Determines which reciprocal condition numbers are computed + lda = n + ldvr = n + ldvl = 1 + + allocate( WORK(1), SCALE_array(n), RCONDE(n), RCONDV(n), IWORK(2*n-2) ) + + LWORK = -1 ! to ask for the optimal size of WORK + call dgeevx( BALANC, JOBVL, JOBVR, SENSE & ! CHARACTERS + , n, Atmp, lda & ! MATRIX TO DIAGONALIZE + , WR, WI & ! REAL AND IMAGINARY PART OF EIGENVALUES + , VL, ldvl, VR, ldvr & ! LEFT AND RIGHT EIGENVECTORS + , ILO, IHI, SCALE_array, ABNRM, RCONDE, RCONDV & ! OUTPUTS OF OPTIMIZATION + , WORK, LWORK, IWORK, INFO ) + + if(INFO .ne. 0) then + print*, 'dgeevx failed !!', INFO + stop + endif + + LWORK = max(int(work(1)), 1) ! this is the optimal size of WORK + deallocate(WORK) + allocate(WORK(LWORK)) + call dgeevx( BALANC, JOBVL, JOBVR, SENSE & + , n, Atmp, lda & + , WR, WI & + , VL, ldvl, VR, ldvr & + , ILO, IHI, SCALE_array, ABNRM, RCONDE, RCONDV & + , WORK, LWORK, IWORK, INFO ) + if(INFO .ne. 0) then + print*, 'dgeevx failed !!', INFO + stop + endif + + deallocate( WORK, SCALE_array, RCONDE, RCONDV, IWORK ) + deallocate( VL, Atmp ) + + + allocate( energy_loc(n), V_loc(n,n) ) + energy_loc = 0.d0 + V_loc = 0.d0 + + i = 1 + do while(i .le. n) + +! print*, i, WR(i), WI(i) + + if( dabs(WI(i)) .gt. 1e-7 ) then + + print*, ' Found an imaginary component to eigenvalue' + print*, ' Re(i) + Im(i)', i, WR(i), WI(i) + + energy_loc(i) = WR(i) + do j = 1, n + V_loc(j,i) = WR(i) * VR(j,i) - WI(i) * VR(j,i+1) + enddo + energy_loc(i+1) = WI(i) + do j = 1, n + V_loc(j,i+1) = WR(i) * VR(j,i+1) + WI(i) * VR(j,i) + enddo + i = i + 2 + + else + + energy_loc(i) = WR(i) + do j = 1, n + V_loc(j,i) = VR(j,i) + enddo + i = i + 1 + + endif + + enddo + + deallocate(WR, WI, VR) + + + ! ordering +! do j = 1, n +! write(444, '(100(1X, F16.10))') (V_loc(j,i), i=1,5) +! enddo + allocate( iorder(n) ) + do i = 1, n + iorder(i) = i + enddo + call dsort(energy_loc, iorder, n) + do i = 1, n + energy(i) = energy_loc(i) + do j = 1, n + V(j,i) = V_loc(j,iorder(i)) + enddo + enddo + deallocate(iorder) +! do j = 1, n +! write(445, '(100(1X, F16.10))') (V_loc(j,i), i=1,5) +! enddo + deallocate(V_loc, energy_loc) + +end subroutine diag_nonsym_right + +! --- From 5ee1c1cb436e9008741785eb1c32cedabb808770 Mon Sep 17 00:00:00 2001 From: AbdAmmar Date: Wed, 7 Sep 2022 15:37:39 +0200 Subject: [PATCH 62/80] dav_general NEED ok --- src/dav_general_mat/NEED | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/dav_general_mat/NEED b/src/dav_general_mat/NEED index e69de29b..71828e2c 100644 --- a/src/dav_general_mat/NEED +++ b/src/dav_general_mat/NEED @@ -0,0 +1,2 @@ +determinants +davidson_keywords From 46653575870d810c0af76e159daf84f339455a67 Mon Sep 17 00:00:00 2001 From: AbdAmmar Date: Wed, 7 Sep 2022 15:38:07 +0200 Subject: [PATCH 63/80] dav_general NEED ok --- src/davidson/EZFIO.cfg | 35 ------------------- src/davidson/NEED | 1 + src/davidson/davidson_parallel.irp.f | 26 +++++++------- .../diagonalization_hs2_dressed.irp.f | 16 ++++----- 4 files changed, 22 insertions(+), 56 deletions(-) diff --git a/src/davidson/EZFIO.cfg b/src/davidson/EZFIO.cfg index de814b94..40bc8a09 100644 --- a/src/davidson/EZFIO.cfg +++ b/src/davidson/EZFIO.cfg @@ -1,14 +1,3 @@ -[threshold_davidson] -type: Threshold -doc: Thresholds of Davidson's algorithm if threshold_davidson_from_pt2 is false. -interface: ezfio,provider,ocaml -default: 1.e-10 - -[threshold_nonsym_davidson] -type: Threshold -doc: Thresholds of non-symetric Davidson's algorithm -interface: ezfio,provider,ocaml -default: 1.e-5 [threshold_davidson_from_pt2] type: logical @@ -16,30 +5,6 @@ doc: Thresholds of Davidson's algorithm is set to E(rPT2)*threshold_davidson_fro interface: ezfio,provider,ocaml default: false -[n_states_diag] -type: States_number -doc: Controls the number of states to consider during the Davdison diagonalization. The number of states is n_states * n_states_diag -default: 4 -interface: ezfio,ocaml - -[davidson_sze_max] -type: Strictly_positive_int -doc: Number of micro-iterations before re-contracting -default: 15 -interface: ezfio,provider,ocaml - -[state_following] -type: logical -doc: If |true|, the states are re-ordered to match the input states -default: False -interface: ezfio,provider,ocaml - -[disk_based_davidson] -type: logical -doc: If |true|, a memory-mapped file may be used to store the W and S2 vectors if not enough RAM is available -default: True -interface: ezfio,provider,ocaml - [csf_based] type: logical doc: If |true|, use the CSF-based algorithm diff --git a/src/davidson/NEED b/src/davidson/NEED index bfe31bd0..bd0abe2f 100644 --- a/src/davidson/NEED +++ b/src/davidson/NEED @@ -1 +1,2 @@ csf +davidson_keywords diff --git a/src/davidson/davidson_parallel.irp.f b/src/davidson/davidson_parallel.irp.f index 8fd023da..9e212094 100644 --- a/src/davidson/davidson_parallel.irp.f +++ b/src/davidson/davidson_parallel.irp.f @@ -546,19 +546,19 @@ end -BEGIN_PROVIDER [ integer, nthreads_davidson ] - implicit none - BEGIN_DOC - ! Number of threads for Davidson - END_DOC - nthreads_davidson = nproc - character*(32) :: env - call getenv('QP_NTHREADS_DAVIDSON',env) - if (trim(env) /= '') then - read(env,*) nthreads_davidson - call write_int(6,nthreads_davidson,'Target number of threads for ') - endif -END_PROVIDER +!BEGIN_PROVIDER [ integer, nthreads_davidson ] +! implicit none +! BEGIN_DOC +! ! Number of threads for Davidson +! END_DOC +! nthreads_davidson = nproc +! character*(32) :: env +! call getenv('QP_NTHREADS_DAVIDSON',env) +! if (trim(env) /= '') then +! read(env,*) nthreads_davidson +! call write_int(6,nthreads_davidson,'Target number of threads for ') +! endif +!END_PROVIDER integer function zmq_put_N_states_diag(zmq_to_qp_run_socket,worker_id) diff --git a/src/davidson/diagonalization_hs2_dressed.irp.f b/src/davidson/diagonalization_hs2_dressed.irp.f index 0f5b38e3..bd8cfbe4 100644 --- a/src/davidson/diagonalization_hs2_dressed.irp.f +++ b/src/davidson/diagonalization_hs2_dressed.irp.f @@ -14,14 +14,14 @@ BEGIN_PROVIDER [ character*(64), diag_algorithm ] endif END_PROVIDER -BEGIN_PROVIDER [ double precision, threshold_davidson_pt2 ] - implicit none - BEGIN_DOC - ! Threshold of Davidson's algorithm, using PT2 as a guide - END_DOC - threshold_davidson_pt2 = threshold_davidson - -END_PROVIDER +!BEGIN_PROVIDER [ double precision, threshold_davidson_pt2 ] +! implicit none +! BEGIN_DOC +! ! Threshold of Davidson's algorithm, using PT2 as a guide +! END_DOC +! threshold_davidson_pt2 = threshold_davidson +! +!END_PROVIDER From 40cb9e6f359af3d687e5159ba5780c34dbfd4fab Mon Sep 17 00:00:00 2001 From: AbdAmmar Date: Wed, 7 Sep 2022 15:54:47 +0200 Subject: [PATCH 64/80] NEED dav ok --- src/davidson/input.irp.f | 78 ++++++++++++++++++++-------------------- 1 file changed, 39 insertions(+), 39 deletions(-) diff --git a/src/davidson/input.irp.f b/src/davidson/input.irp.f index aba88ae9..83f5c09e 100644 --- a/src/davidson/input.irp.f +++ b/src/davidson/input.irp.f @@ -1,39 +1,39 @@ -BEGIN_PROVIDER [ integer, n_states_diag ] - implicit none - BEGIN_DOC -! Number of states to consider during the Davdison diagonalization - END_DOC - - logical :: has - PROVIDE ezfio_filename - if (mpi_master) then - - call ezfio_has_davidson_n_states_diag(has) - if (has) then - call ezfio_get_davidson_n_states_diag(n_states_diag) - else - print *, 'davidson/n_states_diag not found in EZFIO file' - stop 1 - endif - n_states_diag = max(2,N_states * N_states_diag) - endif - IRP_IF MPI_DEBUG - print *, irp_here, mpi_rank - call MPI_BARRIER(MPI_COMM_WORLD, ierr) - IRP_ENDIF - IRP_IF MPI - include 'mpif.h' - integer :: ierr - call MPI_BCAST( n_states_diag, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to read n_states_diag with MPI' - endif - IRP_ENDIF - - call write_time(6) - if (mpi_master) then - write(6, *) 'Read n_states_diag' - endif - -END_PROVIDER - +!BEGIN_PROVIDER [ integer, n_states_diag ] +! implicit none +! BEGIN_DOC +!! Number of states to consider during the Davdison diagonalization +! END_DOC +! +! logical :: has +! PROVIDE ezfio_filename +! if (mpi_master) then +! +! call ezfio_has_davidson_n_states_diag(has) +! if (has) then +! call ezfio_get_davidson_n_states_diag(n_states_diag) +! else +! print *, 'davidson/n_states_diag not found in EZFIO file' +! stop 1 +! endif +! n_states_diag = max(2,N_states * N_states_diag) +! endif +! IRP_IF MPI_DEBUG +! print *, irp_here, mpi_rank +! call MPI_BARRIER(MPI_COMM_WORLD, ierr) +! IRP_ENDIF +! IRP_IF MPI +! include 'mpif.h' +! integer :: ierr +! call MPI_BCAST( n_states_diag, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) +! if (ierr /= MPI_SUCCESS) then +! stop 'Unable to read n_states_diag with MPI' +! endif +! IRP_ENDIF +! +! call write_time(6) +! if (mpi_master) then +! write(6, *) 'Read n_states_diag' +! endif +! +!END_PROVIDER +! From e1739ecd351867ba50a97d27bb93efd9f362fe86 Mon Sep 17 00:00:00 2001 From: AbdAmmar Date: Fri, 9 Sep 2022 10:22:59 +0200 Subject: [PATCH 65/80] dressing excited states: ok --- src/davidson/EZFIO.cfg | 19 ------------------- .../diagonalization_hs2_dressed.irp.f | 10 +++++----- .../diagonalization_nonsym_h_dressed.irp.f | 12 ++++++++---- .../nonsym_diagonalize_ci.irp.f | 2 ++ .../null_dressing_vector.irp.f | 2 ++ 5 files changed, 17 insertions(+), 28 deletions(-) diff --git a/src/davidson/EZFIO.cfg b/src/davidson/EZFIO.cfg index 40bc8a09..718d199b 100644 --- a/src/davidson/EZFIO.cfg +++ b/src/davidson/EZFIO.cfg @@ -1,34 +1,15 @@ - -[threshold_davidson_from_pt2] -type: logical -doc: Thresholds of Davidson's algorithm is set to E(rPT2)*threshold_davidson_from_pt2 -interface: ezfio,provider,ocaml -default: false - [csf_based] type: logical doc: If |true|, use the CSF-based algorithm default: False interface: ezfio,provider,ocaml -[distributed_davidson] -type: logical -doc: If |true|, use the distributed algorithm -default: True -interface: ezfio,provider,ocaml - [only_expected_s2] type: logical doc: If |true|, use filter out all vectors with bad |S^2| values default: True interface: ezfio,provider,ocaml -[n_det_max_full] -type: Det_number_max -doc: Maximum number of determinants where |H| is fully diagonalized -interface: ezfio,provider,ocaml -default: 1000 - [without_diagonal] type: logical doc: If |true|, don't use denominator diff --git a/src/davidson/diagonalization_hs2_dressed.irp.f b/src/davidson/diagonalization_hs2_dressed.irp.f index bd8cfbe4..68f3420d 100644 --- a/src/davidson/diagonalization_hs2_dressed.irp.f +++ b/src/davidson/diagonalization_hs2_dressed.irp.f @@ -88,12 +88,12 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d if (dressing_state > 0) then do k = 1, N_st - ! do i = 1, sze - ! H_jj(i) += u_in(i,k) * dressing_column_h(i,k) - ! enddo + do i = 1, sze + H_jj(i) += u_in(i,k) * dressing_column_h(i,k) + enddo - l = dressed_column_idx(k) - H_jj(l) += u_in(l,k) * dressing_column_h(l,k) + !l = dressed_column_idx(k) + !H_jj(l) += u_in(l,k) * dressing_column_h(l,k) enddo endif diff --git a/src/davidson/diagonalization_nonsym_h_dressed.irp.f b/src/davidson/diagonalization_nonsym_h_dressed.irp.f index 7db02a32..cd576b02 100644 --- a/src/davidson/diagonalization_nonsym_h_dressed.irp.f +++ b/src/davidson/diagonalization_nonsym_h_dressed.irp.f @@ -61,9 +61,13 @@ subroutine davidson_diag_nonsym_h(dets_in, u_in, dim_in, energies, sze, N_st, N_ do k = 1, N_st do l = 1, N_st f = overlap_states_inv(k,l) - do i = 1, N_det - H_jj(i) += f * dressing_delta(i,k) * psi_coef(i,l) + + !do i = 1, N_det + ! H_jj(i) += f * dressing_delta(i,k) * psi_coef(i,l) + do i = 1, dim_in + H_jj(i) += f * dressing_delta(i,k) * u_in(i,l) enddo + enddo enddo endif @@ -417,7 +421,7 @@ subroutine davidson_diag_nonsym_hjj(dets_in, u_in, H_jj, energies, dim_in, sze, !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,k) do k = 1, N_st_diag do i = 1, sze - U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) / max(H_jj(i)-lambda(k), 1.d-2) + U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k)) / max(H_jj(i)-lambda(k), 1.d-2) enddo if(k <= N_st) then @@ -428,7 +432,7 @@ subroutine davidson_diag_nonsym_hjj(dets_in, u_in, H_jj, energies, dim_in, sze, enddo !$OMP END PARALLEL DO - if ((itertot>1).and.(iter == 1)) then + if((itertot>1).and.(iter == 1)) then !don't print continue else diff --git a/src/davidson_dressed/nonsym_diagonalize_ci.irp.f b/src/davidson_dressed/nonsym_diagonalize_ci.irp.f index 764802c2..fa4b8b33 100644 --- a/src/davidson_dressed/nonsym_diagonalize_ci.irp.f +++ b/src/davidson_dressed/nonsym_diagonalize_ci.irp.f @@ -60,6 +60,8 @@ END_PROVIDER if(diag_algorithm == "Davidson") then + ASSERT(n_states_diag .lt. n_states) + do j = 1, min(N_states, N_det) do i = 1, N_det CI_eigenvectors_nonsym_dressed(i,j) = psi_coef(i,j) diff --git a/src/davidson_undressed/null_dressing_vector.irp.f b/src/davidson_undressed/null_dressing_vector.irp.f index faffe964..1989bb6d 100644 --- a/src/davidson_undressed/null_dressing_vector.irp.f +++ b/src/davidson_undressed/null_dressing_vector.irp.f @@ -1,10 +1,12 @@ BEGIN_PROVIDER [ double precision, dressing_column_h, (N_det,N_states) ] &BEGIN_PROVIDER [ double precision, dressing_column_s, (N_det,N_states) ] +&BEGIN_PROVIDER [ double precision, dressing_delta , (N_det,N_states) ] implicit none BEGIN_DOC ! Null dressing vectors END_DOC dressing_column_h(:,:) = 0.d0 dressing_column_s(:,:) = 0.d0 + dressing_delta (:,:) = 0.d0 END_PROVIDER From 78e7c0543a4354ed0864a07a07589cb71cdfc4f3 Mon Sep 17 00:00:00 2001 From: eginer Date: Mon, 12 Sep 2022 21:19:32 +0200 Subject: [PATCH 66/80] added new davidson threshold --- src/davidson/EZFIO.cfg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/davidson/EZFIO.cfg b/src/davidson/EZFIO.cfg index 8696d72e..e1ddddae 100644 --- a/src/davidson/EZFIO.cfg +++ b/src/davidson/EZFIO.cfg @@ -68,5 +68,5 @@ interface: ezfio,provider,ocaml type: Threshold doc: Thresholds of non-symetric Davidson's algorithm interface: ezfio,provider,ocaml -default: 1.e-6 +default: 1.e-10 From d4dc02363e1a89f71354c7e8050f347177ba3999 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 14 Sep 2022 18:25:11 +0200 Subject: [PATCH 67/80] Introducing slowly shells in basis --- src/ao_basis/EZFIO.cfg | 5 +- src/ao_basis/aos.irp.f | 59 ++++++++------- src/basis/EZFIO.cfg | 1 - src/basis/basis.irp.f | 159 +++++++++++++++++++++++++---------------- 4 files changed, 134 insertions(+), 90 deletions(-) diff --git a/src/ao_basis/EZFIO.cfg b/src/ao_basis/EZFIO.cfg index 51d726da..2099ad59 100644 --- a/src/ao_basis/EZFIO.cfg +++ b/src/ao_basis/EZFIO.cfg @@ -36,13 +36,13 @@ interface: ezfio, provider type: double precision doc: Primitive coefficients, read from input. Those should not be used directly, as the MOs are expressed on the basis of **normalized** AOs. size: (ao_basis.ao_num,ao_basis.ao_prim_num_max) -interface: ezfio, provider +interface: ezfio [ao_expo] type: double precision doc: Exponents for each primitive of each |AO| size: (ao_basis.ao_num,ao_basis.ao_prim_num_max) -interface: ezfio, provider +interface: ezfio [ao_md5] type: character*(32) @@ -67,3 +67,4 @@ doc: Use normalized primitive functions interface: ezfio, provider default: true + diff --git a/src/ao_basis/aos.irp.f b/src/ao_basis/aos.irp.f index 1cbd3976..9d8cf018 100644 --- a/src/ao_basis/aos.irp.f +++ b/src/ao_basis/aos.irp.f @@ -1,11 +1,3 @@ -BEGIN_PROVIDER [ integer, ao_prim_num_max ] - implicit none - BEGIN_DOC - ! Max number of primitives. - END_DOC - ao_prim_num_max = maxval(ao_prim_num) -END_PROVIDER - BEGIN_PROVIDER [ integer, ao_shell, (ao_num) ] implicit none BEGIN_DOC @@ -23,6 +15,32 @@ BEGIN_PROVIDER [ integer, ao_shell, (ao_num) ] END_PROVIDER + +BEGIN_PROVIDER [ double precision, ao_coef , (ao_num,ao_prim_num_max) ] +&BEGIN_PROVIDER [ double precision, ao_expo , (ao_num,ao_prim_num_max) ] + implicit none + BEGIN_DOC +! Primitive coefficients and exponents for each atomic orbital. Copied from shell info. + END_DOC + + integer :: i, l + do i=1,ao_num + l = ao_shell(i) + ao_coef(i,:) = shell_coef(l,:) + ao_expo(i,:) = shell_expo(l,:) + end do + +END_PROVIDER + + +BEGIN_PROVIDER [ integer, ao_prim_num_max ] + implicit none + BEGIN_DOC + ! Max number of primitives. + END_DOC + ao_prim_num_max = shell_prim_num_max +END_PROVIDER + BEGIN_PROVIDER [ integer, ao_first_of_shell, (shell_num) ] implicit none BEGIN_DOC @@ -44,20 +62,20 @@ END_PROVIDER BEGIN_DOC ! Coefficients including the |AO| normalization END_DOC + + do i=1,ao_num + l = ao_shell(i) + ao_coef_normalized(i,:) = shell_coef(l,:) * shell_normalization_factor(l) + end do + double precision :: norm,overlap_x,overlap_y,overlap_z,C_A(3), c integer :: l, powA(3), nz integer :: i,j,k nz=100 - C_A(1) = 0.d0 - C_A(2) = 0.d0 - C_A(3) = 0.d0 - ao_coef_normalized = 0.d0 + C_A = 0.d0 do i=1,ao_num -! powA(1) = ao_power(i,1) + ao_power(i,2) + ao_power(i,3) -! powA(2) = 0 -! powA(3) = 0 powA(1) = ao_power(i,1) powA(2) = ao_power(i,2) powA(3) = ao_power(i,3) @@ -67,18 +85,9 @@ END_PROVIDER do j=1,ao_prim_num(i) call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,j), & powA,powA,overlap_x,overlap_y,overlap_z,norm,nz) - ao_coef_normalized(i,j) = ao_coef(i,j)/dsqrt(norm) - enddo - else - do j=1,ao_prim_num(i) - ao_coef_normalized(i,j) = ao_coef(i,j) + ao_coef_normalized(i,j) = ao_coef_normalized(i,j)/dsqrt(norm) enddo endif - - powA(1) = ao_power(i,1) - powA(2) = ao_power(i,2) - powA(3) = ao_power(i,3) - ! Normalization of the contracted basis functions if (ao_normalized) then norm = 0.d0 diff --git a/src/basis/EZFIO.cfg b/src/basis/EZFIO.cfg index a6864418..342fd4cc 100644 --- a/src/basis/EZFIO.cfg +++ b/src/basis/EZFIO.cfg @@ -72,4 +72,3 @@ doc: Exponents in the shell size: (basis.prim_num) interface: ezfio, provider - diff --git a/src/basis/basis.irp.f b/src/basis/basis.irp.f index b750d75a..0fe84506 100644 --- a/src/basis/basis.irp.f +++ b/src/basis/basis.irp.f @@ -1,67 +1,11 @@ -BEGIN_PROVIDER [ double precision, shell_normalization_factor , (shell_num) ] - implicit none - BEGIN_DOC - ! Number of primitives per |AO| - END_DOC - - logical :: has - PROVIDE ezfio_filename - if (mpi_master) then - if (size(shell_normalization_factor) == 0) return - - call ezfio_has_basis_shell_normalization_factor(has) - if (has) then - write(6,'(A)') '.. >>>>> [ IO READ: shell_normalization_factor ] <<<<< ..' - call ezfio_get_basis_shell_normalization_factor(shell_normalization_factor) - else - - double precision :: norm,overlap_x,overlap_y,overlap_z,C_A(3), c - integer :: l, powA(3), nz - integer :: i,j,k - nz=100 - C_A(1) = 0.d0 - C_A(2) = 0.d0 - C_A(3) = 0.d0 - - do i=1,shell_num - - powA(1) = shell_ang_mom(i) - powA(2) = 0 - powA(3) = 0 - - norm = 0.d0 - do k=1, prim_num - if (shell_index(k) /= i) cycle - do j=1, prim_num - if (shell_index(j) /= i) cycle - call overlap_gaussian_xyz(C_A,C_A,prim_expo(j),prim_expo(k), & - powA,powA,overlap_x,overlap_y,overlap_z,c,nz) - norm = norm+c*prim_coef(j)*prim_coef(k) * prim_normalization_factor(j) * prim_normalization_factor(k) - enddo - enddo - shell_normalization_factor(i) = 1.d0/dsqrt(norm) - enddo - - endif - endif - IRP_IF MPI_DEBUG - print *, irp_here, mpi_rank - call MPI_BARRIER(MPI_COMM_WORLD, ierr) - IRP_ENDIF - IRP_IF MPI - include 'mpif.h' - integer :: ierr - call MPI_BCAST( shell_normalization_factor, (shell_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to read shell_normalization_factor with MPI' - endif - IRP_ENDIF - - call write_time(6) - +BEGIN_PROVIDER [ integer, shell_prim_num_max ] + implicit none + BEGIN_DOC + ! Max number of primitives. + END_DOC + shell_prim_num_max = maxval(shell_prim_num) END_PROVIDER - BEGIN_PROVIDER [ double precision, prim_normalization_factor , (prim_num) ] implicit none BEGIN_DOC @@ -120,3 +64,94 @@ BEGIN_PROVIDER [ double precision, prim_normalization_factor , (prim_num) ] call write_time(6) END_PROVIDER + + BEGIN_PROVIDER [ double precision, shell_coef , (shell_num, shell_prim_num_max) ] +&BEGIN_PROVIDER [ double precision, shell_expo , (shell_num, shell_prim_num_max) ] + implicit none + BEGIN_DOC +! Primitive coefficients and exponents for each shell. + END_DOC + + integer :: i, idx + integer :: count(shell_num) + + count(:) = 0 + do i=1, prim_num + idx = shell_index(i) + count(idx) += 1 + shell_coef(idx, count(idx)) = prim_coef(i) + shell_expo(idx, count(idx)) = prim_expo(i) + end do +END_PROVIDER + + + BEGIN_PROVIDER [ double precision, shell_coef_normalized, (shell_num,shell_prim_num_max) ] +&BEGIN_PROVIDER [ double precision, shell_normalization_factor, (shell_num) ] + implicit none + BEGIN_DOC + ! Coefficients including the |shell| normalization + END_DOC + logical :: has + PROVIDE ezfio_filename + + shell_normalization_factor(:) = 1.d0 + if (mpi_master) then + if (size(shell_normalization_factor) == 0) return + + call ezfio_has_basis_shell_normalization_factor(has) + if (has) then + write(6,'(A)') '.. >>>>> [ IO READ: shell_normalization_factor ] <<<<< ..' + call ezfio_get_basis_shell_normalization_factor(shell_normalization_factor) + endif + endif + IRP_IF MPI_DEBUG + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + IRP_ENDIF + IRP_IF MPI + include 'mpif.h' + integer :: ierr + call MPI_BCAST( shell_normalization_factor, (shell_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read shell_normalization_factor with MPI' + endif + IRP_ENDIF + + call write_time(6) + double precision :: norm,overlap_x,overlap_y,overlap_z,C_A(3), c + integer :: l, powA(3), nz + integer :: i,j,k + nz=100 + C_A = 0.d0 + powA = 0 + shell_coef_normalized = 0.d0 + + do i=1,shell_num + + powA(1) = shell_ang_mom(i) + + ! Normalization of the primitives + if (primitives_normalized) then + do j=1,shell_prim_num(i) + call overlap_gaussian_xyz(C_A,C_A,shell_expo(i,j),shell_expo(i,j), & + powA,powA,overlap_x,overlap_y,overlap_z,norm,nz) + shell_coef_normalized(i,j) = shell_coef(i,j)/dsqrt(norm) + enddo + else + do j=1,shell_prim_num(i) + shell_coef_normalized(i,j) = shell_coef(i,j) + enddo + endif + + ! Normalization of the contracted basis functions + norm = 0.d0 + do j=1,shell_prim_num(i) + do k=1,shell_prim_num(i) + call overlap_gaussian_xyz(C_A,C_A,shell_expo(i,j),shell_expo(i,k),powA,powA,overlap_x,overlap_y,overlap_z,c,nz) + norm = norm+c*shell_coef_normalized(i,j)*shell_coef_normalized(i,k) + enddo + enddo + shell_normalization_factor(i) *= 1.d0/dsqrt(norm) + enddo +END_PROVIDER + From 1727f547f78e92a2e6fa6076c15f08245c64ca53 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 15 Sep 2022 18:12:06 +0200 Subject: [PATCH 68/80] Fix normalization in qp_edit --- src/determinants/determinants.irp.f | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/determinants/determinants.irp.f b/src/determinants/determinants.irp.f index e1c14bfe..5f1c92a2 100644 --- a/src/determinants/determinants.irp.f +++ b/src/determinants/determinants.irp.f @@ -537,6 +537,7 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef) double precision, intent(in) :: psicoef(dim_psicoef,nstates) integer*8, allocatable :: psi_det_save(:,:,:) double precision, allocatable :: psi_coef_save(:,:) + double precision, allocatable :: psi_coef_save2(:,:) double precision :: accu_norm integer :: i,j,k, ndet_qp_edit @@ -572,18 +573,17 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef) enddo call ezfio_set_determinants_psi_coef(psi_coef_save) - deallocate (psi_coef_save) - allocate (psi_coef_save(ndet_qp_edit,nstates)) + allocate (psi_coef_save2(ndet_qp_edit,nstates)) do k=1,nstates do i=1,ndet_qp_edit - psi_coef_save(i,k) = psicoef(i,k) + psi_coef_save2(i,k) = psi_coef_save(i,k) enddo - call normalize(psi_coef_save(1,k),ndet_qp_edit) enddo - call ezfio_set_determinants_psi_coef_qp_edit(psi_coef_save) + call ezfio_set_determinants_psi_coef_qp_edit(psi_coef_save2) deallocate (psi_coef_save) + deallocate (psi_coef_save2) call write_int(6,ndet,'Saved determinants') endif From 71693637b65c82160fb3476bd4623c33af198fe8 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 15 Sep 2022 18:12:06 +0200 Subject: [PATCH 69/80] Fix normalization in qp_edit --- src/determinants/determinants.irp.f | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/determinants/determinants.irp.f b/src/determinants/determinants.irp.f index eeadf779..b6b11485 100644 --- a/src/determinants/determinants.irp.f +++ b/src/determinants/determinants.irp.f @@ -537,6 +537,7 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef) double precision, intent(in) :: psicoef(dim_psicoef,nstates) integer*8, allocatable :: psi_det_save(:,:,:) double precision, allocatable :: psi_coef_save(:,:) + double precision, allocatable :: psi_coef_save2(:,:) double precision :: accu_norm integer :: i,j,k, ndet_qp_edit @@ -572,18 +573,17 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef) enddo call ezfio_set_determinants_psi_coef(psi_coef_save) - deallocate (psi_coef_save) - allocate (psi_coef_save(ndet_qp_edit,nstates)) + allocate (psi_coef_save2(ndet_qp_edit,nstates)) do k=1,nstates do i=1,ndet_qp_edit - psi_coef_save(i,k) = psicoef(i,k) + psi_coef_save2(i,k) = psi_coef_save(i,k) enddo - call normalize(psi_coef_save(1,k),ndet_qp_edit) enddo - call ezfio_set_determinants_psi_coef_qp_edit(psi_coef_save) + call ezfio_set_determinants_psi_coef_qp_edit(psi_coef_save2) deallocate (psi_coef_save) + deallocate (psi_coef_save2) call write_int(6,ndet,'Saved determinants') endif From 8788e460497cc705277b5b9923ec2512bea77a96 Mon Sep 17 00:00:00 2001 From: eginer Date: Mon, 26 Sep 2022 11:41:55 +0200 Subject: [PATCH 70/80] added test in dav_non_hermit dav --- src/basis_correction/print_routine.irp.f | 61 +++++++++++++++++++ .../dav_ext_rout_nonsym_B1space.irp.f | 16 ++++- src/davidson/EZFIO.cfg | 2 +- 3 files changed, 75 insertions(+), 4 deletions(-) diff --git a/src/basis_correction/print_routine.irp.f b/src/basis_correction/print_routine.irp.f index 67c5c6c2..d7506231 100644 --- a/src/basis_correction/print_routine.irp.f +++ b/src/basis_correction/print_routine.irp.f @@ -80,3 +80,64 @@ subroutine print_basis_correction end + +subroutine print_all_basis_correction + implicit none + integer :: istate + provide mu_average_prov + provide ecmd_lda_mu_of_r ecmd_pbe_ueg_mu_of_r + provide ecmd_pbe_on_top_mu_of_r ecmd_pbe_on_top_su_mu_of_r + + print*, '' + print*, '' + print*, '****************************************' + print*, '****************************************' + print*, 'Basis set correction for WFT using DFT Ecmd functionals' + print*, 'These functionals are accurate for short-range correlation' + print*, '' + print*, 'For more details look at Journal of Chemical Physics 149, 194301 1-15 (2018) ' + print*, ' Journal of Physical Chemistry Letters 10, 2931-2937 (2019) ' + print*, ' ???REF SC?' + print*, '****************************************' + print*, '****************************************' + print*, 'mu_of_r_potential = ',mu_of_r_potential + print*, '' + print*,'Using a CAS-like two-body density to define mu(r)' + print*,'This assumes that the CAS is a qualitative representation of the wave function ' + print*,'********************************************' + print*,'Functionals more suited for weak correlation' + print*,'********************************************' + print*,'+) LDA Ecmd functional : purely based on the UEG (JCP,149,194301,1-15 (2018)) ' + do istate = 1, N_states + write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD LDA , state ',istate,' = ',ecmd_lda_mu_of_r(istate) + enddo + print*,'+) PBE-UEG Ecmd functional : PBE at mu=0, UEG ontop pair density at large mu (JPCL, 10, 2931-2937 (2019))' + do istate = 1, N_states + write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD PBE-UEG , state ',istate,' = ',ecmd_pbe_ueg_mu_of_r(istate) + enddo + print*,'' + print*,'********************************************' + print*,'********************************************' + print*,'+) PBE-on-top Ecmd functional : (??????? REF-SCF ??????????)' + print*,'PBE at mu=0, extrapolated ontop pair density at large mu, usual spin-polarization' + do istate = 1, N_states + write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD PBE-OT , state ',istate,' = ',ecmd_pbe_on_top_mu_of_r(istate) + enddo + print*,'' + print*,'********************************************' + print*,'+) PBE-on-top no spin polarization Ecmd functional : (??????? REF-SCF ??????????)' + print*,'PBE at mu=0, extrapolated ontop pair density at large mu, and ZERO SPIN POLARIZATION' + do istate = 1, N_states + write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD SU-PBE-OT , state ',istate,' = ',ecmd_pbe_on_top_su_mu_of_r(istate) + enddo + print*,'' + + print*,'' + print*,'**************' + do istate = 1, N_states + write(*, '(A29,X,I3,X,A3,X,F16.10)') ' Average mu(r) , state ',istate,' = ',mu_average_prov(istate) + enddo + +end + + diff --git a/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f b/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f index c5127861..3fbae325 100644 --- a/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f +++ b/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f @@ -61,6 +61,16 @@ subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N include 'constants.include.F' N_st_diag = N_st_diag_in +! print*,'trial vector' + do i = 1, sze + if(isnan(u_in(i,1)))then + print*,'pb in input vector of davidson_general_ext_rout_nonsym_b1space' + print*,i,u_in(i,1) + stop + else if (dabs(u_in(i,1)).lt.1.d-16)then + u_in(i,1) = 0.d0 + endif + enddo !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, y, h, lambda if(N_st_diag*3 > sze) then @@ -323,7 +333,7 @@ subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N endif enddo deallocate(overlap) - if( lambda_tmp .lt. 0.8d0) then + if( lambda_tmp .lt. 0.5d0) then print *, ' very small overlap..' print*, ' max overlap = ', lambda_tmp, i_omax stop @@ -520,7 +530,7 @@ subroutine diag_nonsym_right(n, A, A_ldim, V, V_ldim, energy, E_ldim) , WORK, LWORK, IWORK, INFO ) if(INFO .ne. 0) then - print*, 'dgeevx failed !!', INFO + print*, 'first dgeevx failed !!', INFO stop endif @@ -534,7 +544,7 @@ subroutine diag_nonsym_right(n, A, A_ldim, V, V_ldim, energy, E_ldim) , ILO, IHI, SCALE_array, ABNRM, RCONDE, RCONDV & , WORK, LWORK, IWORK, INFO ) if(INFO .ne. 0) then - print*, 'dgeevx failed !!', INFO + print*, 'second dgeevx failed !!', INFO stop endif diff --git a/src/davidson/EZFIO.cfg b/src/davidson/EZFIO.cfg index 8696d72e..b46a8cc5 100644 --- a/src/davidson/EZFIO.cfg +++ b/src/davidson/EZFIO.cfg @@ -68,5 +68,5 @@ interface: ezfio,provider,ocaml type: Threshold doc: Thresholds of non-symetric Davidson's algorithm interface: ezfio,provider,ocaml -default: 1.e-6 +default: 1.e-12 From 34f996064e61f9006c069206418e16ae4f6e6c7c Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 26 Sep 2022 18:42:06 +0200 Subject: [PATCH 71/80] Doc in qp_set_frozen_core --- bin/qp_set_frozen_core | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/bin/qp_set_frozen_core b/bin/qp_set_frozen_core index bc6f6834..f9761144 100755 --- a/bin/qp_set_frozen_core +++ b/bin/qp_set_frozen_core @@ -11,8 +11,8 @@ Usage: Options: -q --query Prints in the standard output the number of frozen MOs - -l --large Use a small core - -s --small Use a large core + -l --large Use a large core + -s --small Use a small core -u --unset Unset frozen core From 09116900af2d4dc9187f6b5cde1ae5266e2552f7 Mon Sep 17 00:00:00 2001 From: AbdAmmar Date: Thu, 29 Sep 2022 11:31:35 +0200 Subject: [PATCH 72/80] lr ok --- src/determinants/determinants.irp.f | 12 +++++++----- src/determinants/spindeterminants.ezfio_config | 3 ++- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/src/determinants/determinants.irp.f b/src/determinants/determinants.irp.f index 5b12a6d9..dccea368 100644 --- a/src/determinants/determinants.irp.f +++ b/src/determinants/determinants.irp.f @@ -171,22 +171,24 @@ BEGIN_PROVIDER [ integer(bit_kind), psi_det, (N_int,2,psi_det_size) ] END_PROVIDER - +! --- BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states) ] - implicit none + BEGIN_DOC ! The wave function coefficients. Initialized with Hartree-Fock if the |EZFIO| file ! is empty. END_DOC + implicit none integer :: i,k, N_int2 logical :: exists character*(64) :: label PROVIDE read_wf N_det mo_label ezfio_filename + psi_coef = 0.d0 - do i=1,min(N_states,psi_det_size) + do i = 1, min(N_states, psi_det_size) psi_coef(i,i) = 1.d0 enddo @@ -230,10 +232,10 @@ BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states) ] endif IRP_ENDIF - - END_PROVIDER +! --- + BEGIN_PROVIDER [ double precision, psi_average_norm_contrib, (psi_det_size) ] implicit none BEGIN_DOC diff --git a/src/determinants/spindeterminants.ezfio_config b/src/determinants/spindeterminants.ezfio_config index dd4c9b0c..4fe1333a 100644 --- a/src/determinants/spindeterminants.ezfio_config +++ b/src/determinants/spindeterminants.ezfio_config @@ -9,7 +9,8 @@ spindeterminants psi_det_beta integer*8 (spindeterminants_n_int*spindeterminants_bit_kind/8,spindeterminants_n_det_beta) psi_coef_matrix_rows integer (spindeterminants_n_det) psi_coef_matrix_columns integer (spindeterminants_n_det) - psi_coef_matrix_values double precision (spindeterminants_n_det,spindeterminants_n_states) + psi_coef_matrix_values double precision (spindeterminants_n_det,spindeterminants_n_states) + psi_left_coef_matrix_values double precision (spindeterminants_n_det,spindeterminants_n_states) n_svd_coefs integer n_svd_alpha integer n_svd_beta integer From 7597fe9f5b08d43ac10f333bcbcc87886ba4129c Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Thu, 29 Sep 2022 11:34:40 +0200 Subject: [PATCH 73/80] prep tu git pull from olympe 2 --- src/ao_two_e_ints/two_e_integrals.irp.f | 12 ++++--- src/utils/one_e_integration.irp.f | 43 ++++++++++++++----------- 2 files changed, 33 insertions(+), 22 deletions(-) diff --git a/src/ao_two_e_ints/two_e_integrals.irp.f b/src/ao_two_e_ints/two_e_integrals.irp.f index e60e6eeb..b4b21f5c 100644 --- a/src/ao_two_e_ints/two_e_integrals.irp.f +++ b/src/ao_two_e_ints/two_e_integrals.irp.f @@ -444,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) & @@ -468,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, & diff --git a/src/utils/one_e_integration.irp.f b/src/utils/one_e_integration.irp.f index cacc3bf7..9c1d2445 100644 --- a/src/utils/one_e_integration.irp.f +++ b/src/utils/one_e_integration.irp.f @@ -92,41 +92,48 @@ subroutine overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,& overlap = overlap_x * overlap_y * overlap_z end + +! --- + +subroutine overlap_x_abs(A_center, B_center, alpha, beta, power_A, power_B, overlap_x, lower_exp_val, dx, nx) - -subroutine overlap_x_abs(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,lower_exp_val,dx,nx) - implicit none BEGIN_DOC ! .. math :: ! ! \int_{-infty}^{+infty} (x-A_center)^(power_A) * (x-B_center)^power_B * exp(-alpha(x-A_center)^2) * exp(-beta(x-B_center)^2) dx ! END_DOC - integer :: i,j,k,l - integer,intent(in) :: power_A,power_B - double precision, intent(in) :: lower_exp_val - double precision,intent(in) :: A_center, B_center,alpha,beta - double precision, intent(out) :: overlap_x,dx - integer, intent(in) :: nx - double precision :: x_min,x_max,domain,x,factor,dist,p,p_inv,rho - double precision :: P_center - if(power_A.lt.0.or.power_B.lt.0)then + + implicit none + + integer, intent(in) :: power_A, power_B, nx + double precision, intent(in) :: lower_exp_val, A_center, B_center, alpha, beta + double precision, intent(out) :: overlap_x, dx + + integer :: i, j, k, l + double precision :: x_min, x_max, domain, x, factor, dist, p, p_inv, rho + double precision :: P_center + double precision :: tmp + + if(power_A.lt.0 .or. power_B.lt.0) then overlap_x = 0.d0 dx = 0.d0 return endif - p = alpha + beta - p_inv= 1.d0/p - rho = alpha * beta * p_inv - dist = (A_center - B_center)*(A_center - B_center) + + p = alpha + beta + p_inv = 1.d0/p + rho = alpha * beta * p_inv + dist = (A_center - B_center)*(A_center - B_center) P_center = (alpha * A_center + beta * B_center) * p_inv - if(rho*dist.gt.80.d0)then + + if(rho*dist.gt.80.d0) then overlap_x= 0.d0 return endif + factor = dexp(-rho * dist) - double precision :: tmp tmp = dsqrt(lower_exp_val/p) x_min = P_center - tmp From d09e3e73080dd2bc2be2392d87d927df75c7d132 Mon Sep 17 00:00:00 2001 From: eginer Date: Fri, 30 Sep 2022 16:22:18 +0200 Subject: [PATCH 74/80] minor modifs to merge --- ocaml/qp_create_ezfio.ml | 88 +++++++++++++++-------------- src/basis/EZFIO.cfg | 10 ++-- src/davidson/EZFIO.cfg | 6 -- src/determinants/determinants.irp.f | 68 ---------------------- 4 files changed, 51 insertions(+), 121 deletions(-) diff --git a/ocaml/qp_create_ezfio.ml b/ocaml/qp_create_ezfio.ml index a4865e2b..d6c8d66c 100644 --- a/ocaml/qp_create_ezfio.ml +++ b/ocaml/qp_create_ezfio.ml @@ -91,7 +91,7 @@ let run ?o b au c d m p cart xyz_file = | Element e -> Element.to_string e | Int_elem (i,e) -> Printf.sprintf "%d,%s" (Nucl_number.to_int i) (Element.to_string e) in - Hashtbl.find basis_table key + Hashtbl.find basis_table key in let temp_filename = @@ -132,7 +132,7 @@ let run ?o b au c d m p cart xyz_file = Element.to_string elem.Atom.element in Hashtbl.add basis_table key new_channel - ) nuclei + ) nuclei end | Some (key, basis) -> (*Aux basis *) begin @@ -277,6 +277,16 @@ let run ?o b au c d m p cart xyz_file = ) nuclei in + let z_core = + List.map (fun x -> + Positive_int.to_int x.Pseudo.n_elec + |> float_of_int + ) pseudo + in + let nucl_num = (List.length z_core) in + Ezfio.set_pseudo_nucl_charge_remove (Ezfio.ezfio_array_of_list + ~rank:1 ~dim:[| nucl_num |] ~data:z_core); + let molecule = let n_elec_to_remove = List.fold_left (fun accu x -> @@ -293,13 +303,13 @@ let run ?o b au c d m p cart xyz_file = Molecule.nuclei = let charges = list_map (fun x -> Positive_int.to_int x.Pseudo.n_elec - |> Float.of_int) pseudo + |> Float.of_int) pseudo |> Array.of_list in List.mapi (fun i x -> { x with Atom.charge = (Charge.to_float x.Atom.charge) -. charges.(i) |> Charge.of_float } - ) molecule.Molecule.nuclei + ) molecule.Molecule.nuclei } in let nuclei = @@ -356,11 +366,11 @@ let run ?o b au c d m p cart xyz_file = in if (x > accu) then x else accu - ) 0 x.Pseudo.non_local + ) 0 x.Pseudo.non_local in if (x > accu) then x else accu - ) 0 pseudo + ) 0 pseudo in let kmax = @@ -368,10 +378,10 @@ let run ?o b au c d m p cart xyz_file = list_map (fun x -> List.filter (fun (y,_) -> (Positive_int.to_int y.Pseudo.GaussianPrimitive_non_local.proj) = i) - x.Pseudo.non_local - |> List.length ) pseudo + x.Pseudo.non_local + |> List.length ) pseudo |> List.fold_left (fun accu x -> - if accu > x then accu else x) 0 + if accu > x then accu else x) 0 ) |> Array.fold_left (fun accu i -> if i > accu then i else accu) 0 @@ -396,11 +406,11 @@ let run ?o b au c d m p cart xyz_file = in tmp_array_dz_k.(i).(j) <- y; tmp_array_n_k.(i).(j) <- z; - ) x.Pseudo.local + ) x.Pseudo.local ) pseudo ; let concat_2d tmp_array = let data = - Array.map Array.to_list tmp_array + Array.map Array.to_list tmp_array |> Array.to_list |> List.concat in @@ -438,14 +448,14 @@ let run ?o b au c d m p cart xyz_file = tmp_array_dz_kl.(k).(i).(j) <- y; tmp_array_n_kl.(k).(i).(j) <- z; last_idx.(k) <- i+1; - ) x.Pseudo.non_local + ) x.Pseudo.non_local ) pseudo ; let concat_3d tmp_array = let data = Array.map (fun x -> Array.map Array.to_list x |> Array.to_list - |> List.concat) tmp_array + |> List.concat) tmp_array |> Array.to_list |> List.concat in @@ -513,8 +523,8 @@ let run ?o b au c d m p cart xyz_file = 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 + 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)@ @@ -526,7 +536,7 @@ let run ?o b au c d m p cart xyz_file = else s) 0 ao_prim_num in let gtos = - list_map (fun (_,x,_) -> x) long_basis + list_map (fun (_,x,_) -> x) long_basis in let create_expo_coef ec = @@ -534,10 +544,10 @@ let run ?o b au c d m p cart xyz_file = begin match ec with | `Coefs -> list_map (fun x-> list_map (fun (_,coef) -> - AO_coef.to_float coef) x.Gto.lc) gtos + 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 + prim.GaussianPrimitive.expo) x.Gto.lc) gtos end in let rec get_n n accu = function @@ -567,7 +577,7 @@ let run ?o b au c d m p cart xyz_file = list_map ( fun (g,_) -> g.Gto.lc ) basis in let ang_mom = - list_map (fun (l : (GaussianPrimitive.t * Qptypes.AO_coef.t) list) -> + 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 @@ -577,7 +587,7 @@ let run ?o b au c d m p cart xyz_file = |> List.concat in let coef = - list_map (fun l -> + list_map (fun l -> list_map (fun (_,x) -> Qptypes.AO_coef.to_float x) l ) lc |> List.concat @@ -585,12 +595,16 @@ let run ?o b au c d m p cart xyz_file = let shell_prim_num = list_map List.length lc in - let shell_prim_idx = + 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 newcount = count+(List.length l) in - aux newcount (count::accu) rest + let new_l = make_list count accu (List.length l) in + aux (count+1) new_l rest in aux 1 [] lc in @@ -602,26 +616,18 @@ let run ?o b au c d m p cart xyz_file = ~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_prim_index (Ezfio.ezfio_array_of_list - ~rank:1 ~dim:[| shell_num |] ~data:shell_prim_idx) ; + 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:[| nucl_num |] - ~data:( - list_map (fun (_,n) -> Nucl_number.to_int n) basis - |> List.fold_left (fun accu i -> - match accu with - | [] -> [] - | (h,j) :: rest -> if j == i then ((h+1,j)::rest) else ((h+1,i)::(h+1,j)::rest) - ) [(0,0)] - |> List.rev - |> List.map fst - )) ; + ~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 + |> 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) ) [] @@ -675,10 +681,8 @@ let () = let open Command_line in begin "Creates an EZFIO directory from a standard xyz file or from a z-matrix file in Gaussian format. The basis set is defined as a single string if all the atoms are taken from the same basis set, otherwise specific elements can be defined as follows: - -b \"cc-pcvdz | H:cc-pvdz | C:6-31g\" -b \"cc-pvtz | 1,H:sto-3g | 3,H:6-31g\" - If a file with the same name as the basis set exists, this file will be read. Otherwise, the basis set is obtained from the database. " |> set_description_doc ; set_header_doc (Sys.argv.(0) ^ " - Quantum Package command"); @@ -717,7 +721,7 @@ If a file with the same name as the basis set exists, this file will be read. O anonymous "FILE" Mandatory "Input file in xyz format or z-matrix."; ] - |> set_specs + |> set_specs end; @@ -741,7 +745,7 @@ If a file with the same name as the basis set exists, this file will be read. O | None -> 0 | Some x -> ( if x.[0] = 'm' then ~- (int_of_string (String.sub x 1 (String.length x - 1))) - else + else int_of_string x ) in diff --git a/src/basis/EZFIO.cfg b/src/basis/EZFIO.cfg index 92d8d14e..342fd4cc 100644 --- a/src/basis/EZFIO.cfg +++ b/src/basis/EZFIO.cfg @@ -37,16 +37,16 @@ doc: Number of primitives in a shell size: (basis.shell_num) interface: ezfio, provider -[shell_prim_index] +[shell_index] type: integer -doc: Max number of primitives in a shell -size: (basis.shell_num) +doc: Index of the shell for each primitive +size: (basis.prim_num) interface: ezfio, provider [basis_nucleus_index] type: integer -doc: Index of the nucleus on which the shell is centered -size: (nuclei.nucl_num) +doc: Nucleus on which the shell is centered +size: (basis.shell_num) interface: ezfio, provider [prim_normalization_factor] diff --git a/src/davidson/EZFIO.cfg b/src/davidson/EZFIO.cfg index a67f5355..1152560f 100644 --- a/src/davidson/EZFIO.cfg +++ b/src/davidson/EZFIO.cfg @@ -16,9 +16,3 @@ doc: If |true|, don't use denominator default: False interface: ezfio,provider,ocaml -[threshold_nonsym_davidson] -type: Threshold -doc: Thresholds of non-symetric Davidson's algorithm -interface: ezfio,provider,ocaml -default: 1.e-12 - diff --git a/src/determinants/determinants.irp.f b/src/determinants/determinants.irp.f index 150111d3..eceab58c 100644 --- a/src/determinants/determinants.irp.f +++ b/src/determinants/determinants.irp.f @@ -652,74 +652,6 @@ subroutine save_wavefunction_general_unormalized(ndet,nstates,psidet,dim_psicoef end -subroutine save_wavefunction_general_unormalized(ndet,nstates,psidet,dim_psicoef,psicoef) - implicit none - BEGIN_DOC - ! Save the wave function into the |EZFIO| file - END_DOC - use bitmasks - include 'constants.include.F' - integer, intent(in) :: ndet,nstates,dim_psicoef - integer(bit_kind), intent(in) :: psidet(N_int,2,ndet) - double precision, intent(in) :: psicoef(dim_psicoef,nstates) - integer*8, allocatable :: psi_det_save(:,:,:) - double precision, allocatable :: psi_coef_save(:,:) - - double precision :: accu_norm - integer :: i,j,k, ndet_qp_edit - - if (mpi_master) then - ndet_qp_edit = min(ndet,N_det_qp_edit) - - call ezfio_set_determinants_N_int(N_int) - call ezfio_set_determinants_bit_kind(bit_kind) - call ezfio_set_determinants_N_det(ndet) - call ezfio_set_determinants_N_det_qp_edit(ndet_qp_edit) - call ezfio_set_determinants_n_states(nstates) - call ezfio_set_determinants_mo_label(mo_label) - - allocate (psi_det_save(N_int,2,ndet)) - do i=1,ndet - do j=1,2 - do k=1,N_int - psi_det_save(k,j,i) = transfer(psidet(k,j,i),1_8) - enddo - enddo - enddo - call ezfio_set_determinants_psi_det(psi_det_save) - call ezfio_set_determinants_psi_det_qp_edit(psi_det_save) - deallocate (psi_det_save) - - allocate (psi_coef_save(ndet,nstates)) - do k=1,nstates - do i=1,ndet - psi_coef_save(i,k) = psicoef(i,k) - enddo - enddo - - call ezfio_set_determinants_psi_coef(psi_coef_save) - deallocate (psi_coef_save) - - allocate (psi_coef_save(ndet_qp_edit,nstates)) - do k=1,nstates - do i=1,ndet_qp_edit - psi_coef_save(i,k) = psicoef(i,k) - enddo - enddo - - call ezfio_set_determinants_psi_coef_qp_edit(psi_coef_save) - deallocate (psi_coef_save) - - call write_int(6,ndet,'Saved determinants') - endif -end - - - - - - - subroutine save_wavefunction_specified(ndet,nstates,psidet,psicoef,ndetsave,index_det_save) implicit none BEGIN_DOC From bdce53d8b184406567e0b4b363bcb8300449a256 Mon Sep 17 00:00:00 2001 From: eginer Date: Wed, 5 Oct 2022 00:05:22 +0200 Subject: [PATCH 75/80] added many files and did a lot of documentation for bi-ortho scf --- src/ao_many_one_e_ints/NEED | 5 + src/ao_many_one_e_ints/README.rst | 25 + src/ao_many_one_e_ints/ao_erf_gauss.irp.f | 269 ++++++ .../ao_erf_gauss_grad.irp.f | 150 +++ src/ao_many_one_e_ints/ao_gaus_gauss.irp.f | 136 +++ src/ao_many_one_e_ints/fit_slat_gauss.irp.f | 94 ++ .../grad_related_ints.irp.f | 342 +++++++ .../prim_int_erf_gauss.irp.f | 195 ++++ .../prim_int_gauss_gauss.irp.f | 191 ++++ src/ao_many_one_e_ints/stg_gauss_int.irp.f | 121 +++ src/ao_many_one_e_ints/taylor_exp.irp.f | 101 +++ .../xyz_grad_xyz_ao_pol.irp.f | 343 +++++++ src/ao_tc_eff_map/EZFIO.cfg | 12 + src/ao_tc_eff_map/NEED | 4 + src/ao_tc_eff_map/README.rst | 12 + src/ao_tc_eff_map/compute_ints_eff_pot.irp.f | 75 ++ .../integrals_eff_pot_in_map_slave.irp.f | 194 ++++ src/ao_tc_eff_map/j1b_1eInteg.py | 299 ++++++ src/ao_tc_eff_map/j1b_pen.irp.f | 59 ++ src/ao_tc_eff_map/map_integrals_eff_pot.irp.f | 291 ++++++ src/ao_tc_eff_map/one_e_1bgauss_hermit.irp.f | 519 +++++++++++ src/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f | 319 +++++++ src/ao_tc_eff_map/potential.irp.f | 203 +++++ src/ao_tc_eff_map/providers_ao_eff_pot.irp.f | 86 ++ src/ao_tc_eff_map/two_e_1bgauss_coul.irp.f | 800 ++++++++++++++++ .../two_e_1bgauss_coul_acc.irp.f | 433 +++++++++ .../two_e_1bgauss_coul_debug.irp.f | 397 ++++++++ .../two_e_1bgauss_coul_modifdebug.irp.f | 324 +++++++ src/ao_tc_eff_map/two_e_1bgauss_coulerf.irp.f | 102 +++ .../two_e_1bgauss_coulerf_schwartz.irp.f | 624 +++++++++++++ src/ao_tc_eff_map/two_e_1bgauss_erf.irp.f | 854 ++++++++++++++++++ src/ao_tc_eff_map/two_e_1bgauss_erf_acc.irp.f | 433 +++++++++ src/ao_tc_eff_map/two_e_ints_gauss.irp.f | 326 +++++++ src/bi_ort_ints/NEED | 3 + src/bi_ort_ints/README.rst | 25 + src/bi_ort_ints/bi_ort_ints.irp.f | 123 +++ src/bi_ort_ints/one_e_bi_ort.irp.f | 70 ++ src/bi_ort_ints/semi_num_ints_mo.irp.f | 177 ++++ src/bi_ort_ints/three_body_ijm.irp.f | 304 +++++++ src/bi_ort_ints/three_body_ijmk.irp.f | 228 +++++ src/bi_ort_ints/three_body_ijmkl.irp.f | 240 +++++ src/bi_ort_ints/three_body_ints_bi_ort.irp.f | 78 ++ src/bi_ort_ints/total_twoe_pot.irp.f | 138 +++ src/bi_ortho_aos/NEED | 2 + src/bi_ortho_aos/README.rst | 5 + src/bi_ortho_aos/aos_l.irp.f | 97 ++ src/bi_ortho_aos/aos_r.irp.f | 97 ++ src/bi_ortho_mos/EZFIO.cfg | 11 + src/bi_ortho_mos/NEED | 3 + src/bi_ortho_mos/bi_density.irp.f | 49 + src/bi_ortho_mos/bi_ort_mos_in_r.irp.f | 137 +++ src/bi_ortho_mos/grad_bi_ort_mos_in_r.irp.f | 100 ++ src/bi_ortho_mos/mos_rl.irp.f | 173 ++++ src/bi_ortho_mos/overlap.irp.f | 120 +++ src/non_h_ints_mu/NEED | 2 + src/non_h_ints_mu/README.rst | 11 + src/non_h_ints_mu/grad_tc_int.irp.f | 177 ++++ src/utils/integration.irp.f | 73 ++ 58 files changed, 10781 insertions(+) create mode 100644 src/ao_many_one_e_ints/NEED create mode 100644 src/ao_many_one_e_ints/README.rst create mode 100644 src/ao_many_one_e_ints/ao_erf_gauss.irp.f create mode 100644 src/ao_many_one_e_ints/ao_erf_gauss_grad.irp.f create mode 100644 src/ao_many_one_e_ints/ao_gaus_gauss.irp.f create mode 100644 src/ao_many_one_e_ints/fit_slat_gauss.irp.f create mode 100644 src/ao_many_one_e_ints/grad_related_ints.irp.f create mode 100644 src/ao_many_one_e_ints/prim_int_erf_gauss.irp.f create mode 100644 src/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f create mode 100644 src/ao_many_one_e_ints/stg_gauss_int.irp.f create mode 100644 src/ao_many_one_e_ints/taylor_exp.irp.f create mode 100644 src/ao_many_one_e_ints/xyz_grad_xyz_ao_pol.irp.f create mode 100644 src/ao_tc_eff_map/EZFIO.cfg create mode 100644 src/ao_tc_eff_map/NEED create mode 100644 src/ao_tc_eff_map/README.rst create mode 100644 src/ao_tc_eff_map/compute_ints_eff_pot.irp.f create mode 100644 src/ao_tc_eff_map/integrals_eff_pot_in_map_slave.irp.f create mode 100644 src/ao_tc_eff_map/j1b_1eInteg.py create mode 100644 src/ao_tc_eff_map/j1b_pen.irp.f create mode 100644 src/ao_tc_eff_map/map_integrals_eff_pot.irp.f create mode 100644 src/ao_tc_eff_map/one_e_1bgauss_hermit.irp.f create mode 100644 src/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f create mode 100644 src/ao_tc_eff_map/potential.irp.f create mode 100644 src/ao_tc_eff_map/providers_ao_eff_pot.irp.f create mode 100644 src/ao_tc_eff_map/two_e_1bgauss_coul.irp.f create mode 100644 src/ao_tc_eff_map/two_e_1bgauss_coul_acc.irp.f create mode 100644 src/ao_tc_eff_map/two_e_1bgauss_coul_debug.irp.f create mode 100644 src/ao_tc_eff_map/two_e_1bgauss_coul_modifdebug.irp.f create mode 100644 src/ao_tc_eff_map/two_e_1bgauss_coulerf.irp.f create mode 100644 src/ao_tc_eff_map/two_e_1bgauss_coulerf_schwartz.irp.f create mode 100644 src/ao_tc_eff_map/two_e_1bgauss_erf.irp.f create mode 100644 src/ao_tc_eff_map/two_e_1bgauss_erf_acc.irp.f create mode 100644 src/ao_tc_eff_map/two_e_ints_gauss.irp.f create mode 100644 src/bi_ort_ints/NEED create mode 100644 src/bi_ort_ints/README.rst create mode 100644 src/bi_ort_ints/bi_ort_ints.irp.f create mode 100644 src/bi_ort_ints/one_e_bi_ort.irp.f create mode 100644 src/bi_ort_ints/semi_num_ints_mo.irp.f create mode 100644 src/bi_ort_ints/three_body_ijm.irp.f create mode 100644 src/bi_ort_ints/three_body_ijmk.irp.f create mode 100644 src/bi_ort_ints/three_body_ijmkl.irp.f create mode 100644 src/bi_ort_ints/three_body_ints_bi_ort.irp.f create mode 100644 src/bi_ort_ints/total_twoe_pot.irp.f create mode 100644 src/bi_ortho_aos/NEED create mode 100644 src/bi_ortho_aos/README.rst create mode 100644 src/bi_ortho_aos/aos_l.irp.f create mode 100644 src/bi_ortho_aos/aos_r.irp.f create mode 100644 src/bi_ortho_mos/EZFIO.cfg create mode 100644 src/bi_ortho_mos/NEED create mode 100644 src/bi_ortho_mos/bi_density.irp.f create mode 100644 src/bi_ortho_mos/bi_ort_mos_in_r.irp.f create mode 100644 src/bi_ortho_mos/grad_bi_ort_mos_in_r.irp.f create mode 100644 src/bi_ortho_mos/mos_rl.irp.f create mode 100644 src/bi_ortho_mos/overlap.irp.f create mode 100644 src/non_h_ints_mu/NEED create mode 100644 src/non_h_ints_mu/README.rst create mode 100644 src/non_h_ints_mu/grad_tc_int.irp.f diff --git a/src/ao_many_one_e_ints/NEED b/src/ao_many_one_e_ints/NEED new file mode 100644 index 00000000..0d08442c --- /dev/null +++ b/src/ao_many_one_e_ints/NEED @@ -0,0 +1,5 @@ +ao_one_e_ints +ao_two_e_ints +becke_numerical_grid +mo_one_e_ints +dft_utils_in_r diff --git a/src/ao_many_one_e_ints/README.rst b/src/ao_many_one_e_ints/README.rst new file mode 100644 index 00000000..6d2c083f --- /dev/null +++ b/src/ao_many_one_e_ints/README.rst @@ -0,0 +1,25 @@ +================== +ao_many_one_e_ints +================== + +This module contains A LOT of one-electron integrals of the type +A_ij( r ) = \int dr' phi_i(r') w(r,r') phi_j(r') +where r is a point in real space. + ++) ao_gaus_gauss.irp.f: w(r,r') is a exp(-(r-r')^2) , and can be multiplied by x/y/z ++) ao_erf_gauss.irp.f : w(r,r') is a exp(-(r-r')^2) erf(mu * |r-r'|)/|r-r'| , and can be multiplied by x/y/z ++) ao_erf_gauss_grad.irp.f: w(r,r') is a exp(-(r-r')^2) erf(mu * |r-r'|)/|r-r'| , and can be multiplied by x/y/z, but evaluated with also one gradient of an AO function. + +Fit of a Slater function and corresponding integrals +---------------------------------------------------- +The file fit_slat_gauss.irp.f contains many useful providers/routines to fit a Slater function with 20 gaussian. ++) coef_fit_slat_gauss : coefficients of the gaussians to fit e^(-x) ++) expo_fit_slat_gauss : exponents of the gaussians to fit e^(-x) + +Integrals involving Slater functions : stg_gauss_int.irp.f + +Taylor expansion of full correlation factor +------------------------------------------- +In taylor_exp.irp.f you might find interesting integrals of the type +\int dr' exp( e^{-alpha |r-r|' - beta |r-r'|^2}) phi_i(r') phi_j(r') +evaluated as a Taylor expansion of the exponential. diff --git a/src/ao_many_one_e_ints/ao_erf_gauss.irp.f b/src/ao_many_one_e_ints/ao_erf_gauss.irp.f new file mode 100644 index 00000000..39be352f --- /dev/null +++ b/src/ao_many_one_e_ints/ao_erf_gauss.irp.f @@ -0,0 +1,269 @@ + +subroutine phi_j_erf_mu_r_xyz_phi(i,j,mu_in, C_center, xyz_ints) + implicit none + BEGIN_DOC +! xyz_ints(1/2/3) = int dr phi_j(r) [erf(mu |r - C|)/|r-C|] x/y/z phi_i(r) +! +! where phi_i and phi_j are AOs + END_DOC + integer, intent(in) :: i,j + double precision, intent(in) :: mu_in, C_center(3) + double precision, intent(out):: xyz_ints(3) + integer :: num_A,power_A(3), num_b, power_B(3),power_B_tmp(3) + double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf + integer :: n_pt_in,l,m,mm + xyz_ints = 0.d0 + if(ao_overlap_abs(j,i).lt.1.d-12)then + return + endif + n_pt_in = n_pt_max_integrals + ! j + num_A = ao_nucl(j) + power_A(1:3)= ao_power(j,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) + ! i + num_B = ao_nucl(i) + power_B(1:3)= ao_power(i,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) + + do l=1,ao_prim_num(j) + alpha = ao_expo_ordered_transp(l,j) + do m=1,ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) + do mm = 1, 3 + ! (x phi_i ) * phi_j + ! x * (x - B_x)^b_x = b_x (x - B_x)^b_x + 1 * (x - B_x)^{b_x+1} + ! + ! first contribution :: B_x (x - B_x)^b_x :: usual integral multiplied by B_x + power_B_tmp = power_B + contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in) + xyz_ints(mm) += contrib * B_center(mm) * ao_coef_normalized_ordered_transp(l,j) & + * ao_coef_normalized_ordered_transp(m,i) + ! second contribution :: 1 * (x - B_x)^(b_x+1) :: integral with b_x=>b_x+1 + power_B_tmp(mm) += 1 + contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in) + xyz_ints(mm) += contrib * 1.d0 * ao_coef_normalized_ordered_transp(l,j) & + * ao_coef_normalized_ordered_transp(m,i) + enddo + enddo + enddo +end + + +double precision function phi_j_erf_mu_r_phi(i,j,mu_in, C_center) + implicit none + BEGIN_DOC +! phi_j_erf_mu_r_phi = int dr phi_j(r) [erf(mu |r - C|)/|r-C|] phi_i(r) + END_DOC + integer, intent(in) :: i,j + double precision, intent(in) :: mu_in, C_center(3) + integer :: num_A,power_A(3), num_b, power_B(3) + double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf + integer :: n_pt_in,l,m + phi_j_erf_mu_r_phi = 0.d0 + if(ao_overlap_abs(j,i).lt.1.d-12)then + return + endif + n_pt_in = n_pt_max_integrals + ! j + num_A = ao_nucl(j) + power_A(1:3)= ao_power(j,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) + ! i + num_B = ao_nucl(i) + power_B(1:3)= ao_power(i,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) + + do l=1,ao_prim_num(j) + alpha = ao_expo_ordered_transp(l,j) + do m=1,ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) + contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in,mu_in) + phi_j_erf_mu_r_phi += contrib * ao_coef_normalized_ordered_transp(l,j) & + * ao_coef_normalized_ordered_transp(m,i) + enddo + enddo +end + + + +subroutine erfc_mu_gauss_xyz_ij_ao(i,j,mu, C_center, delta,gauss_ints) + implicit none + BEGIN_DOC + ! gauss_ints(m) = \int dr exp(-delta (r - C)^2 ) x/y/z * ( 1 - erf(mu |r-r'|))/ |r-r'| * AO_i(r') * AO_j(r') + ! + ! with m = 1 ==> x, m = 2, m = 3 ==> z + ! + ! m = 4 ==> no x/y/z + END_DOC + integer, intent(in) :: i,j + double precision, intent(in) :: mu, C_center(3),delta + double precision, intent(out):: gauss_ints(4) + + integer :: num_A,power_A(3), num_b, power_B(3) + double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf + double precision :: xyz_ints(4) + integer :: n_pt_in,l,m,mm + gauss_ints = 0.d0 + if(ao_overlap_abs(j,i).lt.1.d-12)then + return + endif + n_pt_in = n_pt_max_integrals + ! j + num_A = ao_nucl(j) + power_A(1:3)= ao_power(j,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) + ! i + num_B = ao_nucl(i) + power_B(1:3)= ao_power(i,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) + + gauss_ints = 0.d0 + do l=1,ao_prim_num(j) + alpha = ao_expo_ordered_transp(l,j) + do m=1,ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) + call erfc_mu_gauss_xyz(C_center,delta,mu,A_center,B_center,power_A,power_B,alpha,beta,n_pt_in,xyz_ints) + do mm = 1, 4 + gauss_ints(mm) += xyz_ints(mm) * ao_coef_normalized_ordered_transp(l,j) & + * ao_coef_normalized_ordered_transp(m,i) + enddo + enddo + enddo +end + +subroutine erf_mu_gauss_ij_ao(i,j,mu, C_center, delta,gauss_ints) + implicit none + BEGIN_DOC + ! gauss_ints(m) = \int dr exp(-delta (r - C)^2 ) * erf(mu |r-r'|)/ |r-r'| * AO_i(r') * AO_j(r') + ! + END_DOC + integer, intent(in) :: i,j + double precision, intent(in) :: mu, C_center(3),delta + double precision, intent(out):: gauss_ints + + integer :: num_A,power_A(3), num_b, power_B(3) + double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf + double precision :: integral , erf_mu_gauss + integer :: n_pt_in,l,m,mm + gauss_ints = 0.d0 + if(ao_overlap_abs(j,i).lt.1.d-12)then + return + endif + n_pt_in = n_pt_max_integrals + ! j + num_A = ao_nucl(j) + power_A(1:3)= ao_power(j,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) + ! i + num_B = ao_nucl(i) + power_B(1:3)= ao_power(i,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) + + do l=1,ao_prim_num(j) + alpha = ao_expo_ordered_transp(l,j) + do m=1,ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) + if(dabs(ao_coef_normalized_ordered_transp(l,j) * ao_coef_normalized_ordered_transp(m,i)).lt.1.d-12)cycle + integral = erf_mu_gauss(C_center,delta,mu,A_center,B_center,power_A,power_B,alpha,beta,n_pt_in) + gauss_ints += integral * ao_coef_normalized_ordered_transp(l,j) & + * ao_coef_normalized_ordered_transp(m,i) + enddo + enddo +end + + +subroutine NAI_pol_x_mult_erf_ao(i_ao,j_ao,mu_in,C_center,ints) + implicit none + BEGIN_DOC + ! Computes the following integral : + ! $\int_{-\infty}^{infty} dr x * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$. + ! + ! $\int_{-\infty}^{infty} dr y * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$. + ! + ! $\int_{-\infty}^{infty} dr z * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$. + END_DOC + include 'utils/constants.include.F' + integer, intent(in) :: i_ao,j_ao + double precision, intent(in) :: mu_in, C_center(3) + double precision, intent(out):: ints(3) + double precision :: A_center(3), B_center(3),integral, alpha,beta + double precision :: NAI_pol_mult_erf + integer :: i,j,num_A,num_B, power_A(3), power_B(3), n_pt_in, power_xA(3),m + ints = 0.d0 + if(ao_overlap_abs(j_ao,i_ao).lt.1.d-12)then + return + endif + 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) + B_center(1:3) = nucl_coord(num_B,1:3) + n_pt_in = n_pt_max_integrals + + + do i = 1, ao_prim_num(i_ao) + alpha = ao_expo_ordered_transp(i,i_ao) + do m = 1, 3 + power_xA = power_A + ! x * phi_i(r) = x * (x-Ax)**ax = (x-Ax)**(ax+1) + Ax * (x-Ax)**ax + power_xA(m) += 1 + do j = 1, ao_prim_num(j_ao) + beta = ao_expo_ordered_transp(j,j_ao) + ! First term = (x-Ax)**(ax+1) + integral = NAI_pol_mult_erf(A_center,B_center,power_xA,power_B,alpha,beta,C_center,n_pt_in,mu_in) + ints(m) += integral * ao_coef_normalized_ordered_transp(j,j_ao)*ao_coef_normalized_ordered_transp(i,i_ao) + ! Second term = Ax * (x-Ax)**(ax) + integral = NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in,mu_in) + ints(m) += A_center(m) * integral * ao_coef_normalized_ordered_transp(j,j_ao)*ao_coef_normalized_ordered_transp(i,i_ao) + enddo + enddo + enddo +end + +subroutine NAI_pol_x_specify_mult_erf_ao(i_ao,j_ao,mu_in,C_center,m,ints) + implicit none + BEGIN_DOC + ! Computes the following integral : + ! $\int_{-\infty}^{infty} dr X(m) * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$. + ! + ! if m == 1 X(m) = x, m == 1 X(m) = y, m == 1 X(m) = z + END_DOC + include 'utils/constants.include.F' + integer, intent(in) :: i_ao,j_ao,m + double precision, intent(in) :: mu_in, C_center(3) + double precision, intent(out):: ints + double precision :: A_center(3), B_center(3),integral, alpha,beta + double precision :: NAI_pol_mult_erf + integer :: i,j,num_A,num_B, power_A(3), power_B(3), n_pt_in, power_xA(3) + ints = 0.d0 + if(ao_overlap_abs(j_ao,i_ao).lt.1.d-12)then + return + endif + 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) + B_center(1:3) = nucl_coord(num_B,1:3) + n_pt_in = n_pt_max_integrals + + + do i = 1, ao_prim_num(i_ao) + alpha = ao_expo_ordered_transp(i,i_ao) + power_xA = power_A + ! x * phi_i(r) = x * (x-Ax)**ax = (x-Ax)**(ax+1) + Ax * (x-Ax)**ax + power_xA(m) += 1 + do j = 1, ao_prim_num(j_ao) + beta = ao_expo_ordered_transp(j,j_ao) + ! First term = (x-Ax)**(ax+1) + integral = NAI_pol_mult_erf(A_center,B_center,power_xA,power_B,alpha,beta,C_center,n_pt_in,mu_in) + ints += integral * ao_coef_normalized_ordered_transp(j,j_ao)*ao_coef_normalized_ordered_transp(i,i_ao) + ! Second term = Ax * (x-Ax)**(ax) + integral = NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in,mu_in) + ints += A_center(m) * integral * ao_coef_normalized_ordered_transp(j,j_ao)*ao_coef_normalized_ordered_transp(i,i_ao) + enddo + enddo +end + diff --git a/src/ao_many_one_e_ints/ao_erf_gauss_grad.irp.f b/src/ao_many_one_e_ints/ao_erf_gauss_grad.irp.f new file mode 100644 index 00000000..8a32c38a --- /dev/null +++ b/src/ao_many_one_e_ints/ao_erf_gauss_grad.irp.f @@ -0,0 +1,150 @@ +subroutine phi_j_erf_mu_r_dxyz_phi(i,j,mu_in, C_center, dxyz_ints) + implicit none + BEGIN_DOC +! dxyz_ints(1/2/3) = int dr phi_i(r) [erf(mu |r - C|)/|r-C|] d/d(x/y/z) phi_i(r) + END_DOC + integer, intent(in) :: i,j + double precision, intent(in) :: mu_in, C_center(3) + double precision, intent(out):: dxyz_ints(3) + integer :: num_A,power_A(3), num_b, power_B(3),power_B_tmp(3) + double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf,coef,thr + integer :: n_pt_in,l,m,mm + thr = 1.d-12 + dxyz_ints = 0.d0 + if(ao_overlap_abs(j,i).lt.thr)then + return + endif + + n_pt_in = n_pt_max_integrals + ! j + num_A = ao_nucl(j) + power_A(1:3)= ao_power(j,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) + ! i + num_B = ao_nucl(i) + power_B(1:3)= ao_power(i,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) + + do l=1,ao_prim_num(j) + alpha = ao_expo_ordered_transp(l,j) + do m=1,ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) + coef = ao_coef_normalized_ordered_transp(l,j) * ao_coef_normalized_ordered_transp(m,i) + if(dabs(coef).lt.thr)cycle + do mm = 1, 3 + ! (d/dx phi_i ) * phi_j + ! d/dx * (x - B_x)^b_x exp(-beta * (x -B_x)^2)= [b_x * (x - B_x)^(b_x - 1) - 2 beta * (x - B_x)^(b_x + 1)] exp(-beta * (x -B_x)^2) + ! + ! first contribution :: b_x (x - B_x)^(b_x-1) :: integral with b_x=>b_x-1 multiplied by b_x + power_B_tmp = power_B + power_B_tmp(mm) += -1 + contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in) + dxyz_ints(mm) += contrib * dble(power_B(mm)) * coef + + ! second contribution :: - 2 beta * (x - B_x)^(b_x + 1) :: integral with b_x=> b_x+1 multiplied by -2 * beta + power_B_tmp = power_B + power_B_tmp(mm) += 1 + contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in) + dxyz_ints(mm) += contrib * (-2.d0 * beta ) * coef + + enddo + enddo + enddo +end + + + + +subroutine phi_j_erf_mu_r_dxyz_phi_bis(i,j,mu_in, C_center, dxyz_ints) + implicit none + BEGIN_DOC +! dxyz_ints(1/2/3) = int dr phi_j(r) [erf(mu |r - C|)/|r-C|] d/d(x/y/z) phi_i(r) + END_DOC + integer, intent(in) :: i,j + double precision, intent(in) :: mu_in, C_center(3) + double precision, intent(out):: dxyz_ints(3) + integer :: num_A,power_A(3), num_b, power_B(3),power_B_tmp(3) + double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf + double precision :: thr, coef + integer :: n_pt_in,l,m,mm,kk + thr = 1.d-12 + dxyz_ints = 0.d0 + if(ao_overlap_abs(j,i).lt.thr)then + return + endif + + n_pt_in = n_pt_max_integrals + ! j == A + num_A = ao_nucl(j) + power_A(1:3)= ao_power(j,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) + ! i == B + num_B = ao_nucl(i) + power_B(1:3)= ao_power(i,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) + + dxyz_ints = 0.d0 + do l=1,ao_prim_num(j) + alpha = ao_expo_ordered_transp(l,j) + do m=1,ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) + do kk = 1, 2 ! loop over the extra terms induced by the d/dx/y/z * AO(i) + do mm = 1, 3 + power_B_tmp = power_B + power_B_tmp(mm) = power_ord_grad_transp(kk,mm,i) + coef = ao_coef_normalized_ordered_transp(l,j) * ao_coef_ord_grad_transp(kk,mm,m,i) + if(dabs(coef).lt.thr)cycle + contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in) + dxyz_ints(mm) += contrib * coef + enddo + enddo + enddo + enddo +end + +subroutine phi_j_erf_mu_r_xyz_dxyz_phi(i,j,mu_in, C_center, dxyz_ints) + implicit none + BEGIN_DOC +! dxyz_ints(1/2/3) = int dr phi_j(r) x/y/z [erf(mu |r - C|)/|r-C|] d/d(x/y/z) phi_i(r) + END_DOC + integer, intent(in) :: i,j + double precision, intent(in) :: mu_in, C_center(3) + double precision, intent(out):: dxyz_ints(3) + integer :: num_A,power_A(3), num_b, power_B(3),power_B_tmp(3) + double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf + double precision :: thr, coef + integer :: n_pt_in,l,m,mm,kk + thr = 1.d-12 + dxyz_ints = 0.d0 + if(ao_overlap_abs(j,i).lt.thr)then + return + endif + + n_pt_in = n_pt_max_integrals + ! j == A + num_A = ao_nucl(j) + power_A(1:3)= ao_power(j,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) + ! i == B + num_B = ao_nucl(i) + power_B(1:3)= ao_power(i,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) + + dxyz_ints = 0.d0 + do l=1,ao_prim_num(j) + alpha = ao_expo_ordered_transp(l,j) + do m=1,ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) + do kk = 1, 4 ! loop over the extra terms induced by the x/y/z * d dx/y/z AO(i) + do mm = 1, 3 + power_B_tmp = power_B + power_B_tmp(mm) = power_ord_xyz_grad_transp(kk,mm,i) + coef = ao_coef_normalized_ordered_transp(l,j) * ao_coef_ord_xyz_grad_transp(kk,mm,m,i) + if(dabs(coef).lt.thr)cycle + contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in) + dxyz_ints(mm) += contrib * coef + enddo + enddo + enddo + enddo +end diff --git a/src/ao_many_one_e_ints/ao_gaus_gauss.irp.f b/src/ao_many_one_e_ints/ao_gaus_gauss.irp.f new file mode 100644 index 00000000..cd9a486d --- /dev/null +++ b/src/ao_many_one_e_ints/ao_gaus_gauss.irp.f @@ -0,0 +1,136 @@ +subroutine overlap_gauss_xyz_r12_ao(D_center,delta,i,j,gauss_ints) + implicit none + BEGIN_DOC +! gauss_ints(m) = \int dr AO_i(r) AO_j(r) x/y/z e^{-delta |r-D_center|^2} +! +! with m == 1 ==> x, m == 2 ==> y, m == 3 ==> z + END_DOC + integer, intent(in) :: i,j + double precision, intent(in) :: D_center(3), delta + double precision, intent(out) :: gauss_ints(3) + + integer :: num_a,num_b,power_A(3), power_B(3),l,k,m + double precision :: A_center(3), B_center(3),overlap_gauss_r12,alpha,beta,gauss_ints_tmp(3) + gauss_ints = 0.d0 + if(ao_overlap_abs(j,i).lt.1.d-12)then + return + endif + num_A = ao_nucl(i) + power_A(1:3)= ao_power(i,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) + num_B = ao_nucl(j) + power_B(1:3)= ao_power(j,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) + do l=1,ao_prim_num(i) + alpha = ao_expo_ordered_transp(l,i) + do k=1,ao_prim_num(j) + beta = ao_expo_ordered_transp(k,j) + call overlap_gauss_xyz_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,gauss_ints_tmp) + do m = 1, 3 + gauss_ints(m) += gauss_ints_tmp(m) * ao_coef_normalized_ordered_transp(l,i) & + * ao_coef_normalized_ordered_transp(k,j) + enddo + enddo + enddo +end + + + +double precision function overlap_gauss_xyz_r12_ao_specific(D_center,delta,i,j,mx) + implicit none + BEGIN_DOC +! \int dr AO_i(r) AO_j(r) x/y/z e^{-delta |r-D_center|^2} +! +! with mx == 1 ==> x, mx == 2 ==> y, mx == 3 ==> z + END_DOC + integer, intent(in) :: i,j,mx + double precision, intent(in) :: D_center(3), delta + + integer :: num_a,num_b,power_A(3), power_B(3),l,k + double precision :: gauss_int + double precision :: A_center(3), B_center(3),overlap_gauss_r12,alpha,beta + double precision :: overlap_gauss_xyz_r12_specific + overlap_gauss_xyz_r12_ao_specific = 0.d0 + if(ao_overlap_abs(j,i).lt.1.d-12)then + return + endif + num_A = ao_nucl(i) + power_A(1:3)= ao_power(i,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) + num_B = ao_nucl(j) + power_B(1:3)= ao_power(j,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) + do l=1,ao_prim_num(i) + alpha = ao_expo_ordered_transp(l,i) + do k=1,ao_prim_num(j) + beta = ao_expo_ordered_transp(k,j) + gauss_int = overlap_gauss_xyz_r12_specific(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,mx) + overlap_gauss_xyz_r12_ao_specific = gauss_int * ao_coef_normalized_ordered_transp(l,i) & + * ao_coef_normalized_ordered_transp(k,j) + enddo + enddo +end + + +subroutine overlap_gauss_r12_all_ao(D_center,delta,aos_ints) + implicit none + double precision, intent(in) :: D_center(3), delta + double precision, intent(out):: aos_ints(ao_num,ao_num) + + integer :: num_a,num_b,power_A(3), power_B(3),l,k,i,j + double precision :: A_center(3), B_center(3),overlap_gauss_r12,alpha,beta,analytical_j + aos_ints = 0.d0 + do i = 1, ao_num + do j = 1, ao_num + if(ao_overlap_abs(j,i).lt.1.d-12)cycle + num_A = ao_nucl(i) + power_A(1:3)= ao_power(i,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) + num_B = ao_nucl(j) + power_B(1:3)= ao_power(j,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) + do l=1,ao_prim_num(i) + alpha = ao_expo_ordered_transp(l,i) + do k=1,ao_prim_num(j) + beta = ao_expo_ordered_transp(k,j) + analytical_j = overlap_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta) + aos_ints(j,i) += analytical_j * ao_coef_normalized_ordered_transp(l,i) & + * ao_coef_normalized_ordered_transp(k,j) + enddo + enddo + enddo + enddo +end + +double precision function overlap_gauss_r12_ao(D_center,delta,i,j) + implicit none + BEGIN_DOC +! \int dr AO_i(r) AO_j(r) e^{-delta |r-D_center|^2} + END_DOC + integer, intent(in) :: i,j + double precision, intent(in) :: D_center(3), delta + + integer :: num_a,num_b,power_A(3), power_B(3),l,k + double precision :: A_center(3), B_center(3),overlap_gauss_r12,alpha,beta,analytical_j + overlap_gauss_r12_ao = 0.d0 + if(ao_overlap_abs(j,i).lt.1.d-12)then + return + endif + num_A = ao_nucl(i) + power_A(1:3)= ao_power(i,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) + num_B = ao_nucl(j) + power_B(1:3)= ao_power(j,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) + do l=1,ao_prim_num(i) + alpha = ao_expo_ordered_transp(l,i) + do k=1,ao_prim_num(j) + beta = ao_expo_ordered_transp(k,j) + analytical_j = overlap_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta) + overlap_gauss_r12_ao += analytical_j * ao_coef_normalized_ordered_transp(l,i) & + * ao_coef_normalized_ordered_transp(k,j) + enddo + enddo +end + + diff --git a/src/ao_many_one_e_ints/fit_slat_gauss.irp.f b/src/ao_many_one_e_ints/fit_slat_gauss.irp.f new file mode 100644 index 00000000..052ad072 --- /dev/null +++ b/src/ao_many_one_e_ints/fit_slat_gauss.irp.f @@ -0,0 +1,94 @@ + BEGIN_PROVIDER [integer, n_max_fit_slat] + implicit none + BEGIN_DOC +! number of gaussian to fit exp(-x) +! +! I took 20 gaussians from the program bassto.f + END_DOC + n_max_fit_slat = 20 + END_PROVIDER + + BEGIN_PROVIDER [double precision, coef_fit_slat_gauss, (n_max_fit_slat)] +&BEGIN_PROVIDER [double precision, expo_fit_slat_gauss, (n_max_fit_slat)] + implicit none + include 'constants.include.F' + BEGIN_DOC + ! fit the exp(-x) as + ! + ! \sum_{i = 1, n_max_fit_slat} coef_fit_slat_gauss(i) * exp(-expo_fit_slat_gauss(i) * x**2) + ! + ! The coefficient are taken from the program bassto.f + END_DOC + + + expo_fit_slat_gauss(01)=30573.77073000000 + coef_fit_slat_gauss(01)=0.00338925525 + expo_fit_slat_gauss(02)=5608.45238100000 + coef_fit_slat_gauss(02)=0.00536433869 + expo_fit_slat_gauss(03)=1570.95673400000 + coef_fit_slat_gauss(03)=0.00818702846 + expo_fit_slat_gauss(04)=541.39785110000 + coef_fit_slat_gauss(04)=0.01202047655 + expo_fit_slat_gauss(05)=212.43469630000 + coef_fit_slat_gauss(05)=0.01711289568 + expo_fit_slat_gauss(06)=91.31444574000 + coef_fit_slat_gauss(06)=0.02376001022 + expo_fit_slat_gauss(07)=42.04087246000 + coef_fit_slat_gauss(07)=0.03229121736 + expo_fit_slat_gauss(08)=20.43200443000 + coef_fit_slat_gauss(08)=0.04303646818 + expo_fit_slat_gauss(09)=10.37775161000 + coef_fit_slat_gauss(09)=0.05624657578 + expo_fit_slat_gauss(10)=5.46880754500 + coef_fit_slat_gauss(10)=0.07192311571 + expo_fit_slat_gauss(11)=2.97373529200 + coef_fit_slat_gauss(11)=0.08949389001 + expo_fit_slat_gauss(12)=1.66144190200 + coef_fit_slat_gauss(12)=0.10727599240 + expo_fit_slat_gauss(13)=0.95052560820 + coef_fit_slat_gauss(13)=0.12178961750 + expo_fit_slat_gauss(14)=0.55528683970 + coef_fit_slat_gauss(14)=0.12740141870 + expo_fit_slat_gauss(15)=0.33043360020 + coef_fit_slat_gauss(15)=0.11759168160 + expo_fit_slat_gauss(16)=0.19982303230 + coef_fit_slat_gauss(16)=0.08953504394 + expo_fit_slat_gauss(17)=0.12246840760 + coef_fit_slat_gauss(17)=0.05066721317 + expo_fit_slat_gauss(18)=0.07575825322 + coef_fit_slat_gauss(18)=0.01806363869 + expo_fit_slat_gauss(19)=0.04690146243 + coef_fit_slat_gauss(19)=0.00305632563 + expo_fit_slat_gauss(20)=0.02834749861 + coef_fit_slat_gauss(20)=0.00013317513 + + + +END_PROVIDER + +double precision function slater_fit_gam(x,gam) + implicit none + double precision, intent(in) :: x,gam + BEGIN_DOC +! fit of the function exp(-gam * x) with gaussian functions + END_DOC + integer :: i + slater_fit_gam = 0.d0 + do i = 1, n_max_fit_slat + slater_fit_gam += coef_fit_slat_gauss(i) * dexp(-expo_fit_slat_gauss(i) * gam * gam * x * x) + enddo +end + +subroutine expo_fit_slater_gam(gam,expos) + implicit none + BEGIN_DOC +! returns the array of the exponents of the gaussians to fit exp(-gam*x) + END_DOC + double precision, intent(in) :: gam + double precision, intent(out) :: expos(n_max_fit_slat) + integer :: i + do i = 1, n_max_fit_slat + expos(i) = expo_fit_slat_gauss(i) * gam * gam + enddo +end + diff --git a/src/ao_many_one_e_ints/grad_related_ints.irp.f b/src/ao_many_one_e_ints/grad_related_ints.irp.f new file mode 100644 index 00000000..c3c886f8 --- /dev/null +++ b/src/ao_many_one_e_ints/grad_related_ints.irp.f @@ -0,0 +1,342 @@ +BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu, ( ao_num, ao_num,n_points_final_grid)] + implicit none + BEGIN_DOC +! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R| - 1)/|r - R| + END_DOC + integer :: i,j,ipoint + double precision :: mu,r(3),NAI_pol_mult_erf_ao + double precision :: int_mu, int_coulomb + provide mu_erf final_grid_points + double precision :: wall0, wall1 + call wall_time(wall0) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,ipoint,mu,r,int_mu,int_coulomb) & + !$OMP SHARED (ao_num,n_points_final_grid,v_ij_erf_rk_cst_mu,final_grid_points,mu_erf) + !$OMP DO SCHEDULE (dynamic) + do ipoint = 1, n_points_final_grid + do i = 1, ao_num + do j = i, ao_num + mu = mu_erf + r(1) = final_grid_points(1,ipoint) + r(2) = final_grid_points(2,ipoint) + r(3) = final_grid_points(3,ipoint) + int_mu = NAI_pol_mult_erf_ao(i,j,mu,r) + int_coulomb = NAI_pol_mult_erf_ao(i,j,1.d+9,r) + v_ij_erf_rk_cst_mu(j,i,ipoint)= (int_mu - int_coulomb ) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + do ipoint = 1, n_points_final_grid + do i = 1, ao_num + do j = 1, i-1 + v_ij_erf_rk_cst_mu(j,i,ipoint)= v_ij_erf_rk_cst_mu(i,j,ipoint) + enddo + enddo + enddo + + call wall_time(wall1) + print*,'wall time for v_ij_erf_rk_cst_mu ',wall1 - wall0 +END_PROVIDER + +BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_transp, (n_points_final_grid, ao_num, ao_num)] + implicit none + BEGIN_DOC +! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R| - 1)/|r - R| + END_DOC + integer :: i,j,ipoint + double precision :: mu,r(3),NAI_pol_mult_erf_ao + double precision :: int_mu, int_coulomb + provide mu_erf final_grid_points + double precision :: wall0, wall1 + call wall_time(wall0) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,ipoint,mu,r,int_mu,int_coulomb) & + !$OMP SHARED (ao_num,n_points_final_grid,v_ij_erf_rk_cst_mu_transp,final_grid_points,mu_erf) + !$OMP DO SCHEDULE (dynamic) + do i = 1, ao_num + do j = i, ao_num + do ipoint = 1, n_points_final_grid + mu = mu_erf + r(1) = final_grid_points(1,ipoint) + r(2) = final_grid_points(2,ipoint) + r(3) = final_grid_points(3,ipoint) + int_mu = NAI_pol_mult_erf_ao(i,j,mu,r) + int_coulomb = NAI_pol_mult_erf_ao(i,j,1.d+9,r) + v_ij_erf_rk_cst_mu_transp(ipoint,j,i)= (int_mu - int_coulomb ) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + do i = 1, ao_num + do j = 1, i-1 + do ipoint = 1, n_points_final_grid + v_ij_erf_rk_cst_mu_transp(ipoint,j,i)= v_ij_erf_rk_cst_mu_transp(ipoint,i,j) + enddo + enddo + enddo + + call wall_time(wall1) + print*,'wall time for v_ij_erf_rk_cst_mu_transp ',wall1 - wall0 +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_tmp, (3,ao_num, ao_num,n_points_final_grid)] + implicit none + BEGIN_DOC +! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R| + END_DOC + integer :: i,j,ipoint,m + double precision :: mu,r(3),ints(3),ints_coulomb(3) + double precision :: wall0, wall1 + call wall_time(wall0) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,ipoint,mu,r,ints,m,ints_coulomb) & + !$OMP SHARED (ao_num,n_points_final_grid,x_v_ij_erf_rk_cst_mu_tmp,final_grid_points,mu_erf) + !$OMP DO SCHEDULE (dynamic) + do ipoint = 1, n_points_final_grid + do i = 1, ao_num + do j = i, ao_num + mu = mu_erf + r(1) = final_grid_points(1,ipoint) + r(2) = final_grid_points(2,ipoint) + r(3) = final_grid_points(3,ipoint) + call NAI_pol_x_mult_erf_ao(i,j,mu,r,ints) + call NAI_pol_x_mult_erf_ao(i,j,1.d+9,r,ints_coulomb) + do m = 1, 3 + x_v_ij_erf_rk_cst_mu_tmp(m,j,i,ipoint) = ( ints(m) - ints_coulomb(m)) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + do ipoint = 1, n_points_final_grid + do i = 1, ao_num + do j = 1, i-1 + do m = 1, 3 + x_v_ij_erf_rk_cst_mu_tmp(m,j,i,ipoint)= x_v_ij_erf_rk_cst_mu_tmp(m,i,j,ipoint) + enddo + enddo + enddo + enddo + call wall_time(wall1) + print*,'wall time for x_v_ij_erf_rk_cst_mu_tmp',wall1 - wall0 + + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu, (ao_num, ao_num,n_points_final_grid,3)] + implicit none + BEGIN_DOC +! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R| + END_DOC + integer :: i,j,ipoint,m + double precision :: mu,r(3),ints,ints_coulomb + double precision :: wall0, wall1 + call wall_time(wall0) + do ipoint = 1, n_points_final_grid + do i = 1, ao_num + do j = 1, ao_num + do m = 1, 3 + x_v_ij_erf_rk_cst_mu(j,i,ipoint,m)= x_v_ij_erf_rk_cst_mu_tmp(m,j,i,ipoint) + enddo + enddo + enddo + enddo + + call wall_time(wall1) + print*,'wall time for x_v_ij_erf_rk_cst_mu',wall1 - wall0 + +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_transp, (ao_num, ao_num,3,n_points_final_grid)] + implicit none + BEGIN_DOC +! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R| + END_DOC + integer :: i,j,ipoint,m + double precision :: mu,r(3),ints,ints_coulomb + double precision :: wall0, wall1 + call wall_time(wall0) + do ipoint = 1, n_points_final_grid + do m = 1, 3 + do i = 1, ao_num + do j = 1, ao_num + x_v_ij_erf_rk_cst_mu_transp(j,i,m,ipoint)= x_v_ij_erf_rk_cst_mu_tmp(m,j,i,ipoint) + enddo + enddo + enddo + enddo + call wall_time(wall1) + print*,'wall time for x_v_ij_erf_rk_cst_mu_transp',wall1 - wall0 + + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_transp_bis, (n_points_final_grid,ao_num, ao_num,3)] + implicit none + BEGIN_DOC +! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R| + END_DOC + integer :: i,j,ipoint,m + double precision :: mu,r(3),ints,ints_coulomb + double precision :: wall0, wall1 + call wall_time(wall0) + do m = 1, 3 + do i = 1, ao_num + do j = 1, ao_num + do ipoint = 1, n_points_final_grid + x_v_ij_erf_rk_cst_mu_transp_bis(ipoint,j,i,m)= x_v_ij_erf_rk_cst_mu_tmp(m,j,i,ipoint) + enddo + enddo + enddo + enddo + call wall_time(wall1) + print*,'wall time for x_v_ij_erf_rk_cst_mu_transp',wall1 - wall0 + + +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, d_dx_v_ij_erf_rk_cst_mu_tmp, (3,n_points_final_grid,ao_num, ao_num)] + implicit none + BEGIN_DOC +! d_dx_v_ij_erf_rk_cst_mu_tmp(m,R,j,i) = int dr phi_j(r)) (erf(mu(R) |r - R|) - 1)/|r - R| d/dx (phi_i(r) +! +! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz + END_DOC + integer :: i,j,ipoint,m + double precision :: mu,r(3),ints(3),ints_coulomb(3) + double precision :: wall0, wall1 + call wall_time(wall0) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,ipoint,mu,r,ints,m,ints_coulomb) & + !$OMP SHARED (ao_num,n_points_final_grid,d_dx_v_ij_erf_rk_cst_mu_tmp,final_grid_points,mu_erf) + !$OMP DO SCHEDULE (dynamic) + do i = 1, ao_num + do j = 1, ao_num + do ipoint = 1, n_points_final_grid + mu = mu_erf + r(1) = final_grid_points(1,ipoint) + r(2) = final_grid_points(2,ipoint) + r(3) = final_grid_points(3,ipoint) + call phi_j_erf_mu_r_dxyz_phi(j,i,mu, r, ints) + call phi_j_erf_mu_r_dxyz_phi(j,i,1.d+9, r, ints_coulomb) + do m = 1, 3 + d_dx_v_ij_erf_rk_cst_mu_tmp(m,ipoint,j,i) = ( ints(m) - ints_coulomb(m)) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + call wall_time(wall1) + print*,'wall time for d_dx_v_ij_erf_rk_cst_mu_tmp',wall1 - wall0 + + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, d_dx_v_ij_erf_rk_cst_mu, (n_points_final_grid,ao_num, ao_num,3)] + implicit none + BEGIN_DOC +! d_dx_v_ij_erf_rk_cst_mu_tmp(j,i,R,m) = int dr phi_j(r)) (erf(mu(R) |r - R|) - 1)/|r - R| d/dx (phi_i(r) +! +! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz + END_DOC + integer :: i,j,ipoint,m + double precision :: mu,r(3),ints,ints_coulomb + double precision :: wall0, wall1 + call wall_time(wall0) + do i = 1, ao_num + do j = 1, ao_num + do m = 1, 3 + do ipoint = 1, n_points_final_grid + d_dx_v_ij_erf_rk_cst_mu(ipoint,j,i,m)= d_dx_v_ij_erf_rk_cst_mu_tmp(m,ipoint,j,i) + enddo + enddo + enddo + enddo + + call wall_time(wall1) + print*,'wall time for d_dx_v_ij_erf_rk_cst_mu',wall1 - wall0 + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, x_d_dx_v_ij_erf_rk_cst_mu_tmp, (3,n_points_final_grid,ao_num, ao_num)] + implicit none + BEGIN_DOC +! x_d_dx_v_ij_erf_rk_cst_mu_tmp(m,j,i,R) = int dr x phi_j(r)) (erf(mu(R) |r - R|) - 1)/|r - R| d/dx (phi_i(r) +! +! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz + END_DOC + integer :: i,j,ipoint,m + double precision :: mu,r(3),ints(3),ints_coulomb(3) + double precision :: wall0, wall1 + call wall_time(wall0) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,ipoint,mu,r,ints,m,ints_coulomb) & + !$OMP SHARED (ao_num,n_points_final_grid,x_d_dx_v_ij_erf_rk_cst_mu_tmp,final_grid_points,mu_erf) + !$OMP DO SCHEDULE (dynamic) + do i = 1, ao_num + do j = 1, ao_num + do ipoint = 1, n_points_final_grid + mu = mu_erf + r(1) = final_grid_points(1,ipoint) + r(2) = final_grid_points(2,ipoint) + r(3) = final_grid_points(3,ipoint) + call phi_j_erf_mu_r_xyz_dxyz_phi(j,i,mu, r, ints) + call phi_j_erf_mu_r_xyz_dxyz_phi(j,i,1.d+9, r, ints_coulomb) + do m = 1, 3 + x_d_dx_v_ij_erf_rk_cst_mu_tmp(m,ipoint,j,i) = ( ints(m) - ints_coulomb(m)) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + call wall_time(wall1) + print*,'wall time for x_d_dx_v_ij_erf_rk_cst_mu_tmp',wall1 - wall0 + + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, x_d_dx_v_ij_erf_rk_cst_mu, (n_points_final_grid,ao_num, ao_num,3)] + implicit none + BEGIN_DOC +! x_d_dx_v_ij_erf_rk_cst_mu_tmp(j,i,R,m) = int dr x phi_j(r)) (erf(mu(R) |r - R|) - 1)/|r - R| d/dx (phi_i(r) +! +! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz + END_DOC + integer :: i,j,ipoint,m + double precision :: mu,r(3),ints,ints_coulomb + double precision :: wall0, wall1 + call wall_time(wall0) + do i = 1, ao_num + do j = 1, ao_num + do ipoint = 1, n_points_final_grid + do m = 1, 3 + x_d_dx_v_ij_erf_rk_cst_mu(ipoint,j,i,m)= x_d_dx_v_ij_erf_rk_cst_mu_tmp(m,ipoint,j,i) + enddo + enddo + enddo + enddo + + call wall_time(wall1) + print*,'wall time for x_d_dx_v_ij_erf_rk_cst_mu',wall1 - wall0 + +END_PROVIDER + diff --git a/src/ao_many_one_e_ints/prim_int_erf_gauss.irp.f b/src/ao_many_one_e_ints/prim_int_erf_gauss.irp.f new file mode 100644 index 00000000..641d25fe --- /dev/null +++ b/src/ao_many_one_e_ints/prim_int_erf_gauss.irp.f @@ -0,0 +1,195 @@ +double precision function NAI_pol_mult_erf_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu) + BEGIN_DOC + ! Computes the following integral R^3 : + ! + ! .. 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 | }$ exp(-delta (r - D)^2 ). + ! + END_DOC + + implicit none + include 'constants.include.F' + double precision, intent(in) :: D_center(3), delta ! pure gaussian "D" + double precision, intent(in) :: C_center(3),mu ! coulomb center "C" and "mu" in the erf(mu*x)/x function + double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B" + integer, intent(in) :: power_A(3),power_B(3) + + double precision :: NAI_pol_mult_erf + ! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 ) + double precision :: A_new(0:max_dim,3)! new polynom + double precision :: A_center_new(3) ! new center + integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A + double precision :: alpha_new ! new exponent + double precision :: fact_a_new ! constant factor + double precision :: accu,coefx,coefy,coefz,coefxy,coefxyz,thr + integer :: d(3),i,lx,ly,lz,iorder_tmp(3) + thr = 1.d-10 + d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0 + + ! New gaussian/polynom defined by :: new pol new center new expo cst fact new order + call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , & + delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals) + ! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2 + accu = 0.d0 + do lx = 0, iorder_a_new(1) + coefx = A_new(lx,1) + if(dabs(coefx).lt.thr)cycle + iorder_tmp(1) = lx + do ly = 0, iorder_a_new(2) + coefy = A_new(ly,2) + coefxy = coefx * coefy + if(dabs(coefxy).lt.thr)cycle + iorder_tmp(2) = ly + do lz = 0, iorder_a_new(3) + coefz = A_new(lz,3) + coefxyz = coefxy * coefz + if(dabs(coefxyz).lt.thr)cycle + iorder_tmp(3) = lz + accu += coefxyz * NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B,alpha_new,beta,C_center,n_pt_max_integrals,mu) + enddo + enddo + enddo + NAI_pol_mult_erf_gauss_r12 = fact_a_new * accu +end + +subroutine erfc_mu_gauss_xyz(D_center,delta,mu,A_center,B_center,power_A,power_B,alpha,beta,n_pt_in,xyz_ints) + BEGIN_DOC + ! Computes the following integral : + ! + ! .. math:: + ! + ! \int dr exp(-delta (r - D)^2 ) x/y/z * (1 - erf(mu |r-r'|))/ |r-r'| * (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 ) + ! + ! xyz_ints(1) = x , xyz_ints(2) = y, xyz_ints(3) = z, xyz_ints(4) = x^0 + END_DOC + + implicit none + include 'constants.include.F' + double precision, intent(in) :: D_center(3), delta,mu ! pure gaussian "D" and mu parameter + double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B" + integer, intent(in) :: power_A(3),power_B(3),n_pt_in + double precision, intent(out) :: xyz_ints(4) + + double precision :: NAI_pol_mult_erf + ! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 ) + double precision :: A_new(0:max_dim,3)! new polynom + double precision :: A_center_new(3) ! new center + integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A + double precision :: alpha_new ! new exponent + double precision :: fact_a_new ! constant factor + double precision :: accu,coefx,coefy,coefz,coefxy,coefxyz,thr,contrib,contrib_inf,mu_inf + integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1,mm + integer :: power_B_tmp(3) + dim1=100 + mu_inf = 1.d+10 + thr = 1.d-10 + d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0 + + ! New gaussian/polynom defined by :: new pol new center new expo cst fact new order + call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , & + delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals) + ! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2 + xyz_ints = 0.d0 + do lx = 0, iorder_a_new(1) + coefx = A_new(lx,1) + if(dabs(coefx).lt.thr)cycle + iorder_tmp(1) = lx + do ly = 0, iorder_a_new(2) + coefy = A_new(ly,2) + coefxy = coefx * coefy + if(dabs(coefxy).lt.thr)cycle + iorder_tmp(2) = ly + do lz = 0, iorder_a_new(3) + coefz = A_new(lz,3) + coefxyz = coefxy * coefz + if(dabs(coefxyz).lt.thr)cycle + iorder_tmp(3) = lz + power_B_tmp = power_B + contrib = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu) + contrib_inf = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu_inf) + xyz_ints(4) += (contrib_inf - contrib) * coefxyz ! usual term with no x/y/z + + do mm = 1, 3 + ! (x phi_i ) * phi_j + ! x * (x - B_x)^b_x = B_x (x - B_x)^b_x + 1 * (x - B_x)^{b_x+1} + + ! + ! first contribution :: B_x (x - B_x)^b_x :: usual integral multiplied by B_x + power_B_tmp = power_B + contrib_inf = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu_inf) + contrib = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu) + xyz_ints(mm) += (contrib_inf - contrib) * B_center(mm) * coefxyz + + ! + ! second contribution :: (x - B_x)^(b_x+1) :: integral with b_x=>b_x+1 + power_B_tmp(mm) += 1 + contrib = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu) + contrib_inf = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu_inf) + xyz_ints(mm) += (contrib_inf - contrib) * coefxyz + enddo + enddo + enddo + enddo + xyz_ints *= fact_a_new +end + + +double precision function erf_mu_gauss(D_center,delta,mu,A_center,B_center,power_A,power_B,alpha,beta,n_pt_in) + BEGIN_DOC + ! Computes the following integral : + ! + ! .. math:: + ! + ! \int dr exp(-delta (r - D)^2 ) erf(mu*|r-r'|)/ |r-r'| * (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 ) + ! + END_DOC + + implicit none + include 'constants.include.F' + double precision, intent(in) :: D_center(3), delta,mu ! pure gaussian "D" and mu parameter + double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B" + integer, intent(in) :: power_A(3),power_B(3),n_pt_in + + double precision :: NAI_pol_mult_erf + ! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 ) + double precision :: A_new(0:max_dim,3)! new polynom + double precision :: A_center_new(3) ! new center + integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A + double precision :: alpha_new ! new exponent + double precision :: fact_a_new ! constant factor + double precision :: accu,coefx,coefy,coefz,coefxy,coefxyz,thr,contrib,contrib_inf,mu_inf + integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1,mm + dim1=100 + mu_inf = 1.d+10 + thr = 1.d-10 + d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0 + + ! New gaussian/polynom defined by :: new pol new center new expo cst fact new order + call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , & + delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals) + ! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2 + erf_mu_gauss = 0.d0 + do lx = 0, iorder_a_new(1) + coefx = A_new(lx,1) + if(dabs(coefx).lt.thr)cycle + iorder_tmp(1) = lx + do ly = 0, iorder_a_new(2) + coefy = A_new(ly,2) + coefxy = coefx * coefy + if(dabs(coefxy).lt.thr)cycle + iorder_tmp(2) = ly + do lz = 0, iorder_a_new(3) + coefz = A_new(lz,3) + coefxyz = coefxy * coefz + if(dabs(coefxyz).lt.thr)cycle + iorder_tmp(3) = lz + contrib = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B,alpha_new,beta,D_center,n_pt_in,mu) + erf_mu_gauss += contrib * coefxyz + enddo + enddo + enddo + erf_mu_gauss *= fact_a_new +end + diff --git a/src/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f b/src/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f new file mode 100644 index 00000000..749227ea --- /dev/null +++ b/src/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f @@ -0,0 +1,191 @@ + +double precision function overlap_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta) + BEGIN_DOC + ! Computes the following integral : + ! + ! .. math:: + ! + ! \int dr exp(-delta (r - D)^2 ) (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 ) + ! + END_DOC + + implicit none + include 'constants.include.F' + double precision, intent(in) :: D_center(3), delta ! pure gaussian "D" + double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B" + integer, intent(in) :: power_A(3),power_B(3) + + double precision :: overlap_x,overlap_y,overlap_z,overlap + ! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 ) + double precision :: A_new(0:max_dim,3)! new polynom + double precision :: A_center_new(3) ! new center + integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A + double precision :: alpha_new ! new exponent + double precision :: fact_a_new ! constant factor + double precision :: accu,coefx,coefy,coefz,coefxy,coefxyz,thr + integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1 + dim1=100 + thr = 1.d-10 + d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0 + + ! New gaussian/polynom defined by :: new pol new center new expo cst fact new order + call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , & + delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals) + ! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2 + accu = 0.d0 + do lx = 0, iorder_a_new(1) + coefx = A_new(lx,1) + if(dabs(coefx).lt.thr)cycle + iorder_tmp(1) = lx + do ly = 0, iorder_a_new(2) + coefy = A_new(ly,2) + coefxy = coefx * coefy + if(dabs(coefxy).lt.thr)cycle + iorder_tmp(2) = ly + do lz = 0, iorder_a_new(3) + coefz = A_new(lz,3) + coefxyz = coefxy * coefz + if(dabs(coefxyz).lt.thr)cycle + iorder_tmp(3) = lz + call overlap_gaussian_xyz(A_center_new,B_center,alpha_new,beta,iorder_tmp,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1) + accu += coefxyz * overlap + enddo + enddo + enddo + overlap_gauss_r12 = fact_a_new * accu +end + + +subroutine overlap_gauss_xyz_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,gauss_ints) + BEGIN_DOC + ! Computes the following integral : + ! + ! .. math:: + ! + ! gauss_ints(m) = \int dr exp(-delta (r - D)^2 ) * x/y/z (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 ) + ! + ! with m == 1 ==> x, m == 2 ==> y, m == 3 ==> z + END_DOC + + implicit none + include 'constants.include.F' + double precision, intent(in) :: D_center(3), delta ! pure gaussian "D" + double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B" + integer, intent(in) :: power_A(3),power_B(3) + double precision, intent(out) :: gauss_ints(3) + + double precision :: overlap_x,overlap_y,overlap_z,overlap + ! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 ) + double precision :: A_new(0:max_dim,3)! new polynom + double precision :: A_center_new(3) ! new center + integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A + integer :: power_B_new(3) + double precision :: alpha_new ! new exponent + double precision :: fact_a_new ! constant factor + double precision :: coefx,coefy,coefz,coefxy,coefxyz,thr + integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1,m + dim1=100 + thr = 1.d-10 + d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0 + + ! New gaussian/polynom defined by :: new pol new center new expo cst fact new order + call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , & + delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals) + ! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2 + gauss_ints = 0.d0 + do lx = 0, iorder_a_new(1) + coefx = A_new(lx,1) + if(dabs(coefx).lt.thr)cycle + iorder_tmp(1) = lx + do ly = 0, iorder_a_new(2) + coefy = A_new(ly,2) + coefxy = coefx * coefy + if(dabs(coefxy).lt.thr)cycle + iorder_tmp(2) = ly + do lz = 0, iorder_a_new(3) + coefz = A_new(lz,3) + coefxyz = coefxy * coefz + if(dabs(coefxyz).lt.thr)cycle + iorder_tmp(3) = lz + do m = 1, 3 + ! change (x-Bx)^bx --> (x-Bx)^(bx+1) + Bx(x-Bx)^bx + power_B_new = power_B + power_B_new(m) += 1 ! (x-Bx)^(bx+1) + call overlap_gaussian_xyz(A_center_new,B_center,alpha_new,beta,iorder_tmp,power_B_new,overlap_x,overlap_y,overlap_z,overlap,dim1) + gauss_ints(m) += coefxyz * overlap + + power_B_new = power_B + call overlap_gaussian_xyz(A_center_new,B_center,alpha_new,beta,iorder_tmp,power_B_new,overlap_x,overlap_y,overlap_z,overlap,dim1) + gauss_ints(m) += coefxyz * overlap * B_center(m) ! Bx (x-Bx)^(bx) + enddo + enddo + enddo + enddo + gauss_ints *= fact_a_new +end + +double precision function overlap_gauss_xyz_r12_specific(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,mx) + BEGIN_DOC + ! Computes the following integral : + ! + ! .. math:: + ! + ! \int dr exp(-delta (r - D)^2 ) * x/y/z (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 ) + ! + ! with mx == 1 ==> x, mx == 2 ==> y, mx == 3 ==> z + END_DOC + + implicit none + include 'constants.include.F' + double precision, intent(in) :: D_center(3), delta ! pure gaussian "D" + double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B" + integer, intent(in) :: power_A(3),power_B(3),mx + + double precision :: overlap_x,overlap_y,overlap_z,overlap + ! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 ) + double precision :: A_new(0:max_dim,3)! new polynom + double precision :: A_center_new(3) ! new center + integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A + integer :: power_B_new(3) + double precision :: alpha_new ! new exponent + double precision :: fact_a_new ! constant factor + double precision :: coefx,coefy,coefz,coefxy,coefxyz,thr + integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1,m + dim1=100 + thr = 1.d-10 + d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0 + + ! New gaussian/polynom defined by :: new pol new center new expo cst fact new order + call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , & + delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals) + ! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2 + overlap_gauss_xyz_r12_specific = 0.d0 + do lx = 0, iorder_a_new(1) + coefx = A_new(lx,1) + if(dabs(coefx).lt.thr)cycle + iorder_tmp(1) = lx + do ly = 0, iorder_a_new(2) + coefy = A_new(ly,2) + coefxy = coefx * coefy + if(dabs(coefxy).lt.thr)cycle + iorder_tmp(2) = ly + do lz = 0, iorder_a_new(3) + coefz = A_new(lz,3) + coefxyz = coefxy * coefz + if(dabs(coefxyz).lt.thr)cycle + iorder_tmp(3) = lz + m = mx + ! change (x-Bx)^bx --> (x-Bx)^(bx+1) + Bx(x-Bx)^bx + power_B_new = power_B + power_B_new(m) += 1 ! (x-Bx)^(bx+1) + call overlap_gaussian_xyz(A_center_new,B_center,alpha_new,beta,iorder_tmp,power_B_new,overlap_x,overlap_y,overlap_z,overlap,dim1) + overlap_gauss_xyz_r12_specific += coefxyz * overlap + + power_B_new = power_B + call overlap_gaussian_xyz(A_center_new,B_center,alpha_new,beta,iorder_tmp,power_B_new,overlap_x,overlap_y,overlap_z,overlap,dim1) + overlap_gauss_xyz_r12_specific += coefxyz * overlap * B_center(m) ! Bx (x-Bx)^(bx) + enddo + enddo + enddo + overlap_gauss_xyz_r12_specific *= fact_a_new +end diff --git a/src/ao_many_one_e_ints/stg_gauss_int.irp.f b/src/ao_many_one_e_ints/stg_gauss_int.irp.f new file mode 100644 index 00000000..384f744b --- /dev/null +++ b/src/ao_many_one_e_ints/stg_gauss_int.irp.f @@ -0,0 +1,121 @@ +double precision function ovlp_stg_gauss_int_phi_ij(D_center,gam,delta,A_center,B_center,power_A,power_B,alpha,beta) + BEGIN_DOC + ! Computes the following integral : + ! + ! .. math:: + ! + ! \int dr exp(-gam (r - D)) exp(-delta * (r -D)^2) (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 ) + ! + END_DOC + + implicit none + double precision, intent(in) :: D_center(3), gam ! pure Slater "D" in r-r_D + double precision, intent(in) :: delta ! gaussian in r-r_D + double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B" + integer, intent(in) :: power_A(3),power_B(3) + + integer :: i + double precision :: integral,gama_gauss + double precision, allocatable :: expos_slat(:) + allocate(expos_slat(n_max_fit_slat)) + double precision :: overlap_gauss_r12 + ovlp_stg_gauss_int_phi_ij = 0.d0 + call expo_fit_slater_gam(gam,expos_slat) + do i = 1, n_max_fit_slat + gama_gauss = expos_slat(i)+delta + integral = overlap_gauss_r12(D_center,gama_gauss,A_center,B_center,power_A,power_B,alpha,beta) + ovlp_stg_gauss_int_phi_ij += coef_fit_slat_gauss(i) * integral + enddo +end + + +double precision function erf_mu_stg_gauss_int_phi_ij(D_center,gam,delta,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu) + BEGIN_DOC + ! Computes the following integral : + ! + ! .. math:: + ! + ! \int dr exp(-gam(r - D)-delta(r - D)^2) (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 + + implicit none + include 'constants.include.F' + double precision, intent(in) :: D_center(3), gam ! pure Slater "D" in r-r_D + double precision, intent(in) :: delta ! gaussian in r-r_D + double precision, intent(in) :: C_center(3),mu ! coulomb center "C" and "mu" in the erf(mu*x)/x function + double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B" + integer, intent(in) :: power_A(3),power_B(3) + + integer :: i + double precision :: NAI_pol_mult_erf_gauss_r12 + double precision :: integral,gama_gauss + double precision, allocatable :: expos_slat(:) + allocate(expos_slat(n_max_fit_slat)) + erf_mu_stg_gauss_int_phi_ij = 0.d0 + call expo_fit_slater_gam(gam,expos_slat) + do i = 1, n_max_fit_slat + gama_gauss = expos_slat(i) + delta + integral = NAI_pol_mult_erf_gauss_r12(D_center,gama_gauss,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu) + erf_mu_stg_gauss_int_phi_ij += coef_fit_slat_gauss(i) * integral + enddo +end + +double precision function overlap_stg_gauss(D_center,gam,A_center,B_center,power_A,power_B,alpha,beta) + BEGIN_DOC + ! Computes the following integral : + ! + ! .. math:: + ! + ! \int dr exp(-gam (r - D)) (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 ) + ! + END_DOC + + implicit none + double precision, intent(in) :: D_center(3), gam ! pure Slater "D" + double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B" + integer, intent(in) :: power_A(3),power_B(3) + + integer :: i + double precision :: expos_slat(n_max_fit_slat),integral,delta + double precision :: overlap_gauss_r12 + overlap_stg_gauss = 0.d0 + call expo_fit_slater_gam(gam,expos_slat) + do i = 1, n_max_fit_slat + delta = expos_slat(i) + integral = overlap_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta) + overlap_stg_gauss += coef_fit_slat_gauss(i) * integral + enddo +end + +double precision function erf_mu_stg_gauss(D_center,gam,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu) + BEGIN_DOC + ! Computes the following integral : + ! + ! .. math:: + ! + ! \int dr exp(-gam(r - D)) (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 + + implicit none + include 'constants.include.F' + double precision, intent(in) :: D_center(3), gam ! pure Slater "D" + double precision, intent(in) :: C_center(3),mu ! coulomb center "C" and "mu" in the erf(mu*x)/x function + double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B" + integer, intent(in) :: power_A(3),power_B(3) + + + integer :: i + double precision :: expos_slat(n_max_fit_slat),integral,delta + double precision :: NAI_pol_mult_erf_gauss_r12 + erf_mu_stg_gauss = 0.d0 + call expo_fit_slater_gam(gam,expos_slat) + do i = 1, n_max_fit_slat + delta = expos_slat(i) + integral = NAI_pol_mult_erf_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu) + erf_mu_stg_gauss += coef_fit_slat_gauss(i) * integral + enddo +end diff --git a/src/ao_many_one_e_ints/taylor_exp.irp.f b/src/ao_many_one_e_ints/taylor_exp.irp.f new file mode 100644 index 00000000..9857875a --- /dev/null +++ b/src/ao_many_one_e_ints/taylor_exp.irp.f @@ -0,0 +1,101 @@ +double precision function exp_dl(x,n) + implicit none + double precision, intent(in) :: x + integer , intent(in) :: n + integer :: i + exp_dl = 1.d0 + do i = 1, n + exp_dl += fact_inv(i) * x**dble(i) + enddo +end + +subroutine exp_dl_rout(x,n, array) + implicit none + double precision, intent(in) :: x + integer , intent(in) :: n + double precision, intent(out):: array(0:n) + integer :: i + double precision :: accu + accu = 1.d0 + array(0) = 1.d0 + do i = 1, n + accu += fact_inv(i) * x**dble(i) + array(i) = accu + enddo +end + +subroutine exp_dl_ovlp_stg_phi_ij(zeta,D_center,gam,delta,A_center,B_center,power_A,power_B,alpha,beta,n_taylor,array_ints,integral_taylor,exponent_exp) + BEGIN_DOC + ! Computes the following integrals : + ! + ! .. math:: + ! + ! array(i) = \int dr EXP{exponent_exp * [exp(-gam*i (r - D)) exp(-delta*i * (r -D)^2)] (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 ) + ! + ! + ! and gives back the Taylor expansion of the exponential in integral_taylor + END_DOC + + implicit none + double precision, intent(in) :: zeta ! prefactor of the argument of the exp(-zeta*x) + integer, intent(in) :: n_taylor ! order of the Taylor expansion of the exponential + double precision, intent(in) :: D_center(3), gam ! pure Slater "D" in r-r_D + double precision, intent(in) :: delta ! gaussian in r-r_D + double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B" + double precision, intent(in) :: exponent_exp + integer, intent(in) :: power_A(3),power_B(3) + double precision, intent(out) :: array_ints(0:n_taylor),integral_taylor + + integer :: i,dim1 + double precision :: delta_exp,gam_exp,ovlp_stg_gauss_int_phi_ij + double precision :: overlap_x,overlap_y,overlap_z,overlap + dim1=100 + call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1) + array_ints(0) = overlap + integral_taylor = array_ints(0) + do i = 1, n_taylor + delta_exp = dble(i) * delta + gam_exp = dble(i) * gam + array_ints(i) = ovlp_stg_gauss_int_phi_ij(D_center,gam_exp,delta_exp,A_center,B_center,power_A,power_B,alpha,beta) + integral_taylor += (-zeta*exponent_exp)**dble(i) * fact_inv(i) * array_ints(i) + enddo + +end + +subroutine exp_dl_erf_stg_phi_ij(zeta,D_center,gam,delta,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu,n_taylor,array_ints,integral_taylor) + BEGIN_DOC + ! Computes the following integrals : + ! + ! .. math:: + ! + ! array(i) = \int dr exp(-gam*i (r - D)) exp(-delta*i * (r -D)^2) (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 | }$. + ! + ! + ! and gives back the Taylor expansion of the exponential in integral_taylor + END_DOC + + implicit none + integer, intent(in) :: n_taylor ! order of the Taylor expansion of the exponential + double precision, intent(in) :: zeta ! prefactor of the argument of the exp(-zeta*x) + double precision, intent(in) :: D_center(3), gam ! pure Slater "D" in r-r_D + double precision, intent(in) :: delta ! gaussian in r-r_D + double precision, intent(in) :: C_center(3),mu ! coulomb center "C" and "mu" in the erf(mu*x)/x function + double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B" + integer, intent(in) :: power_A(3),power_B(3) + double precision, intent(out) :: array_ints(0:n_taylor),integral_taylor + + integer :: i,dim1 + double precision :: delta_exp,gam_exp,NAI_pol_mult_erf,erf_mu_stg_gauss_int_phi_ij + dim1=100 + + array_ints(0) = NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_max_integrals,mu) + integral_taylor = array_ints(0) + do i = 1, n_taylor + delta_exp = dble(i) * delta + gam_exp = dble(i) * gam + array_ints(i) = erf_mu_stg_gauss_int_phi_ij(D_center,gam_exp,delta_exp,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu) + integral_taylor += (-zeta)**dble(i) * fact_inv(i) * array_ints(i) + enddo + +end diff --git a/src/ao_many_one_e_ints/xyz_grad_xyz_ao_pol.irp.f b/src/ao_many_one_e_ints/xyz_grad_xyz_ao_pol.irp.f new file mode 100644 index 00000000..eed1c348 --- /dev/null +++ b/src/ao_many_one_e_ints/xyz_grad_xyz_ao_pol.irp.f @@ -0,0 +1,343 @@ + BEGIN_PROVIDER [double precision, coef_xyz_ao, (2,3,ao_num)] +&BEGIN_PROVIDER [integer, power_xyz_ao, (2,3,ao_num)] + implicit none + BEGIN_DOC +! coefficient for the basis function :: (x * phi_i(r), y * phi_i(r), * z_phi(r)) +! +! x * (x - A_x)^a_x = A_x (x - A_x)^a_x + 1 * (x - A_x)^{a_x+1} + END_DOC + integer :: i,j,k,num_ao,power_ao(1:3) + double precision :: center_ao(1:3) + do i = 1, ao_num + power_ao(1:3)= ao_power(i,1:3) + num_ao = ao_nucl(i) + center_ao(1:3) = nucl_coord(num_ao,1:3) + do j = 1, 3 + coef_xyz_ao(1,j,i) = center_ao(j) ! A_x (x - A_x)^a_x + power_xyz_ao(1,j,i)= power_ao(j) + coef_xyz_ao(2,j,i) = 1.d0 ! 1 * (x - A_x)^a_{x+1} + power_xyz_ao(2,j,i)= power_ao(j) + 1 + enddo + enddo +END_PROVIDER + + BEGIN_PROVIDER [ double precision, ao_coef_ord_grad_transp, (2,3,ao_prim_num_max,ao_num) ] +&BEGIN_PROVIDER [ integer, power_ord_grad_transp, (2,3,ao_num) ] + implicit none + BEGIN_DOC + ! grad AO in terms of polynoms and coefficients + ! + ! WARNING !!!! SOME polynoms might be negative !!!!! + ! + ! WHEN IT IS THE CASE, coefficients are ZERO + END_DOC + integer :: i,j,power_ao(3), m,kk + do j=1, ao_num + power_ao(1:3)= ao_power(j,1:3) + do m = 1, 3 + power_ord_grad_transp(1,m,j) = power_ao(m) - 1 + power_ord_grad_transp(2,m,j) = power_ao(m) + 1 + enddo + do i=1, ao_prim_num_max + do m = 1, 3 + ao_coef_ord_grad_transp(1,m,i,j) = ao_coef_normalized_ordered(j,i) * dble(power_ao(m)) ! a_x * c_i + ao_coef_ord_grad_transp(2,m,i,j) = -2.d0 * ao_coef_normalized_ordered(j,i) * ao_expo_ordered_transp(i,j) ! -2 * c_i * alpha_i + do kk = 1, 2 + if(power_ord_grad_transp(kk,m,j).lt.0)then + ao_coef_ord_grad_transp(kk,m,i,j) = 0.d0 + endif + enddo + enddo + enddo + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ double precision, ao_coef_ord_xyz_grad_transp, (4,3,ao_prim_num_max,ao_num) ] +&BEGIN_PROVIDER [ integer, power_ord_xyz_grad_transp, (4,3,ao_num) ] + implicit none + BEGIN_DOC + ! x * d/dx of an AO in terms of polynoms and coefficients + ! + ! WARNING !!!! SOME polynoms might be negative !!!!! + ! + ! WHEN IT IS THE CASE, coefficients are ZERO + END_DOC + integer :: i,j,power_ao(3), m,num_ao,kk + double precision :: center_ao(1:3) + do j=1, ao_num + power_ao(1:3)= ao_power(j,1:3) + num_ao = ao_nucl(j) + center_ao(1:3) = nucl_coord(num_ao,1:3) + do m = 1, 3 + power_ord_xyz_grad_transp(1,m,j) = power_ao(m) - 1 + power_ord_xyz_grad_transp(2,m,j) = power_ao(m) + power_ord_xyz_grad_transp(3,m,j) = power_ao(m) + 1 + power_ord_xyz_grad_transp(4,m,j) = power_ao(m) + 2 + do kk = 1, 4 + if(power_ord_xyz_grad_transp(kk,m,j).lt.0)then + power_ord_xyz_grad_transp(kk,m,j) = -1 + endif + enddo + enddo + do i=1, ao_prim_num_max + do m = 1, 3 + ao_coef_ord_xyz_grad_transp(1,m,i,j) = dble(power_ao(m)) * ao_coef_normalized_ordered(j,i) * center_ao(m) + ao_coef_ord_xyz_grad_transp(2,m,i,j) = dble(power_ao(m)) * ao_coef_normalized_ordered(j,i) + ao_coef_ord_xyz_grad_transp(3,m,i,j) = -2.d0 * ao_coef_normalized_ordered(j,i) * ao_expo_ordered_transp(i,j) * center_ao(m) + ao_coef_ord_xyz_grad_transp(4,m,i,j) = -2.d0 * ao_coef_normalized_ordered(j,i) * ao_expo_ordered_transp(i,j) + do kk = 1, 4 + if(power_ord_xyz_grad_transp(kk,m,j).lt.0)then + ao_coef_ord_xyz_grad_transp(kk,m,i,j) = 0.d0 + endif + enddo + enddo + enddo + enddo + +END_PROVIDER + +subroutine xyz_grad_phi_ao(r,i_ao,xyz_grad_phi) + implicit none + integer, intent(in) :: i_ao + double precision, intent(in) :: r(3) + double precision, intent(out):: xyz_grad_phi(3) ! x * d/dx phi i, y * d/dy phi_i, z * d/dz phi_ + double precision :: center_ao(3),beta + double precision :: accu(3,4),dr(3),r2,pol_usual(3) + integer :: m,power_ao(3),num_ao,j_prim + power_ao(1:3)= ao_power(i_ao,1:3) + num_ao = ao_nucl(i_ao) + center_ao(1:3) = nucl_coord(num_ao,1:3) + dr(1) = (r(1) - center_ao(1)) + dr(2) = (r(2) - center_ao(2)) + dr(3) = (r(3) - center_ao(3)) + r2 = 0.d0 + do m = 1, 3 + r2 += dr(m)*dr(m) + enddo + ! computes the gaussian part + accu = 0.d0 + do j_prim =1,ao_prim_num(i_ao) + beta = ao_expo_ordered_transp(j_prim,i_ao) + if(dabs(beta*r2).gt.50.d0)cycle + do m = 1, 3 + accu(m,1) += ao_coef_ord_xyz_grad_transp(1,m,j_prim,i_ao) * dexp(-beta*r2) + accu(m,2) += ao_coef_ord_xyz_grad_transp(2,m,j_prim,i_ao) * dexp(-beta*r2) + accu(m,3) += ao_coef_ord_xyz_grad_transp(3,m,j_prim,i_ao) * dexp(-beta*r2) + accu(m,4) += ao_coef_ord_xyz_grad_transp(4,m,j_prim,i_ao) * dexp(-beta*r2) + enddo + enddo + ! computes the polynom part + pol_usual = 0.d0 + pol_usual(1) = dr(2)**dble(power_ao(2)) * dr(3)**dble(power_ao(3)) + pol_usual(2) = dr(1)**dble(power_ao(1)) * dr(3)**dble(power_ao(3)) + pol_usual(3) = dr(1)**dble(power_ao(1)) * dr(2)**dble(power_ao(2)) + + xyz_grad_phi = 0.d0 + do m = 1, 3 + xyz_grad_phi(m) += accu(m,2) * pol_usual(m) * dr(m)**dble(power_ord_xyz_grad_transp(2,m,i_ao)) + xyz_grad_phi(m) += accu(m,3) * pol_usual(m) * dr(m)**dble(power_ord_xyz_grad_transp(3,m,i_ao)) + xyz_grad_phi(m) += accu(m,4) * pol_usual(m) * dr(m)**dble(power_ord_xyz_grad_transp(4,m,i_ao)) + if(power_ord_xyz_grad_transp(1,m,i_ao).lt.0)cycle + xyz_grad_phi(m) += accu(m,1) * pol_usual(m) * dr(m)**dble(power_ord_xyz_grad_transp(1,m,i_ao)) + enddo +end + +subroutine grad_phi_ao(r,i_ao,grad_xyz_phi) + implicit none + integer, intent(in) :: i_ao + double precision, intent(in) :: r(3) + double precision, intent(out):: grad_xyz_phi(3) ! x * phi i, y * phi_i, z * phi_ + double precision :: center_ao(3),beta + double precision :: accu(3,2),dr(3),r2,pol_usual(3) + integer :: m,power_ao(3),num_ao,j_prim + power_ao(1:3)= ao_power(i_ao,1:3) + num_ao = ao_nucl(i_ao) + center_ao(1:3) = nucl_coord(num_ao,1:3) + dr(1) = (r(1) - center_ao(1)) + dr(2) = (r(2) - center_ao(2)) + dr(3) = (r(3) - center_ao(3)) + r2 = 0.d0 + do m = 1, 3 + r2 += dr(m)*dr(m) + enddo + ! computes the gaussian part + accu = 0.d0 + do j_prim =1,ao_prim_num(i_ao) + beta = ao_expo_ordered_transp(j_prim,i_ao) + if(dabs(beta*r2).gt.50.d0)cycle + do m = 1, 3 + accu(m,1) += ao_coef_ord_grad_transp(1,m,j_prim,i_ao) * dexp(-beta*r2) + accu(m,2) += ao_coef_ord_grad_transp(2,m,j_prim,i_ao) * dexp(-beta*r2) + enddo + enddo + ! computes the polynom part + pol_usual = 0.d0 + pol_usual(1) = dr(2)**dble(power_ao(2)) * dr(3)**dble(power_ao(3)) + pol_usual(2) = dr(1)**dble(power_ao(1)) * dr(3)**dble(power_ao(3)) + pol_usual(3) = dr(1)**dble(power_ao(1)) * dr(2)**dble(power_ao(2)) + do m = 1, 3 + grad_xyz_phi(m) = accu(m,2) * pol_usual(m) * dr(m)**dble(power_ord_grad_transp(2,m,i_ao)) + if(power_ao(m)==0)cycle + grad_xyz_phi(m) += accu(m,1) * pol_usual(m) * dr(m)**dble(power_ord_grad_transp(1,m,i_ao)) + enddo +end + +subroutine xyz_phi_ao(r,i_ao,xyz_phi) + implicit none + integer, intent(in) :: i_ao + double precision, intent(in) :: r(3) + double precision, intent(out):: xyz_phi(3) ! x * phi i, y * phi_i, z * phi_i + double precision :: center_ao(3),beta + double precision :: accu,dr(3),r2,pol_usual(3) + integer :: m,power_ao(3),num_ao + power_ao(1:3)= ao_power(i_ao,1:3) + num_ao = ao_nucl(i_ao) + center_ao(1:3) = nucl_coord(num_ao,1:3) + dr(1) = (r(1) - center_ao(1)) + dr(2) = (r(2) - center_ao(2)) + dr(3) = (r(3) - center_ao(3)) + r2 = 0.d0 + do m = 1, 3 + r2 += dr(m)*dr(m) + enddo + ! computes the gaussian part + accu = 0.d0 + do m=1,ao_prim_num(i_ao) + beta = ao_expo_ordered_transp(m,i_ao) + if(dabs(beta*r2).gt.50.d0)cycle + accu += ao_coef_normalized_ordered_transp(m,i_ao) * dexp(-beta*r2) + enddo + ! computes the polynom part + pol_usual = 0.d0 + pol_usual(1) = dr(2)**dble(power_ao(2)) * dr(3)**dble(power_ao(3)) + pol_usual(2) = dr(1)**dble(power_ao(1)) * dr(3)**dble(power_ao(3)) + pol_usual(3) = dr(1)**dble(power_ao(1)) * dr(2)**dble(power_ao(2)) + do m = 1, 3 + xyz_phi(m) = accu * pol_usual(m) * dr(m)**(dble(power_ao(m))) * ( coef_xyz_ao(1,m,i_ao) + coef_xyz_ao(2,m,i_ao) * dr(m) ) + enddo +end + + +subroutine test_pol_xyz + implicit none + integer :: ipoint,i,j,m,jpoint + double precision :: r1(3),derf_mu_x + double precision :: weight1,r12,xyz_phi(3),grad_phi(3),xyz_grad_phi(3) + double precision, allocatable :: aos_array(:),aos_grad_array(:,:) + double precision :: num_xyz_phi(3),num_grad_phi(3),num_xyz_grad_phi(3) + double precision :: accu_xyz_phi(3),accu_grad_phi(3),accu_xyz_grad_phi(3) + double precision :: meta_accu_xyz_phi(3),meta_accu_grad_phi(3),meta_accu_xyz_grad_phi(3) + allocate(aos_array(ao_num),aos_grad_array(3,ao_num)) + meta_accu_xyz_phi = 0.d0 + meta_accu_grad_phi = 0.d0 + meta_accu_xyz_grad_phi= 0.d0 + do i = 1, ao_num + accu_xyz_phi = 0.d0 + accu_grad_phi = 0.d0 + accu_xyz_grad_phi= 0.d0 + + do ipoint = 1, n_points_final_grid + r1(:) = final_grid_points(:,ipoint) + weight1 = final_weight_at_r_vector(ipoint) + call give_all_aos_and_grad_at_r(r1,aos_array,aos_grad_array) + do m = 1, 3 + num_xyz_phi(m) = r1(m) * aos_array(i) + num_grad_phi(m) = aos_grad_array(m,i) + num_xyz_grad_phi(m) = r1(m) * aos_grad_array(m,i) + enddo + call xyz_phi_ao(r1,i,xyz_phi) + call grad_phi_ao(r1,i,grad_phi) + call xyz_grad_phi_ao(r1,i,xyz_grad_phi) + do m = 1, 3 + accu_xyz_phi(m) += weight1 * dabs(num_xyz_phi(m) - xyz_phi(m) ) + accu_grad_phi(m) += weight1 * dabs(num_grad_phi(m) - grad_phi(m) ) + accu_xyz_grad_phi(m) += weight1 * dabs(num_xyz_grad_phi(m) - xyz_grad_phi(m)) + enddo + enddo + print*,'' + print*,'' + print*,'i,',i + print*,'' + do m = 1, 3 +! print*, 'm, accu_xyz_phi(m) ' ,m, accu_xyz_phi(m) +! print*, 'm, accu_grad_phi(m) ' ,m, accu_grad_phi(m) + print*, 'm, accu_xyz_grad_phi' ,m, accu_xyz_grad_phi(m) + enddo + do m = 1, 3 + meta_accu_xyz_phi(m) += dabs(accu_xyz_phi(m)) + meta_accu_grad_phi(m) += dabs(accu_grad_phi(m)) + meta_accu_xyz_grad_phi(m) += dabs(accu_xyz_grad_phi(m)) + enddo + enddo + do m = 1, 3 +! print*, 'm, meta_accu_xyz_phi(m) ' ,m, meta_accu_xyz_phi(m) +! print*, 'm, meta_accu_grad_phi(m) ' ,m, meta_accu_grad_phi(m) + print*, 'm, meta_accu_xyz_grad_phi' ,m, meta_accu_xyz_grad_phi(m) + enddo + + + +end + +subroutine test_ints_semi_bis + implicit none + integer :: ipoint,i,j,m + double precision :: r1(3), aos_grad_array_r1(3, ao_num), aos_array_r1(ao_num) + double precision :: C_center(3), weight1,mu_in,r12,derf_mu_x,dxyz_ints(3),NAI_pol_mult_erf_ao + double precision :: ao_mat(ao_num,ao_num),ao_xmat(3,ao_num,ao_num),accu1, accu2(3) + mu_in = 0.5d0 + C_center = 0.d0 + C_center(1) = 0.25d0 + C_center(3) = 1.12d0 + C_center(2) = -1.d0 + ao_mat = 0.d0 + ao_xmat = 0.d0 + do ipoint = 1, n_points_final_grid + r1(1) = final_grid_points(1,ipoint) + r1(2) = final_grid_points(2,ipoint) + r1(3) = final_grid_points(3,ipoint) + call give_all_aos_and_grad_at_r(r1,aos_array_r1,aos_grad_array_r1) + weight1 = final_weight_at_r_vector(ipoint) + r12 = (r1(1) - C_center(1))**2.d0 + (r1(2) - C_center(2))**2.d0 + (r1(3) - C_center(3))**2.d0 + r12 = dsqrt(r12) + do i = 1, ao_num + do j = 1, ao_num + ao_mat(j,i) += aos_array_r1(i) * aos_array_r1(j) * weight1 * derf_mu_x(mu_in,r12) + do m = 1, 3 + ao_xmat(m,j,i) += r1(m) * aos_array_r1(j) * aos_grad_array_r1(m,i) * weight1 * derf_mu_x(mu_in,r12) + enddo + enddo + enddo + enddo + + accu1 = 0.d0 + accu2 = 0.d0 + accu1relat = 0.d0 + accu2relat = 0.d0 + double precision :: accu1relat, accu2relat(3) + double precision :: contrib(3) + do i = 1, ao_num + do j = 1, ao_num + call phi_j_erf_mu_r_xyz_dxyz_phi(i,j,mu_in, C_center, dxyz_ints) + print*,'' + print*,'i,j',i,j + print*,dxyz_ints(:) + print*,ao_xmat(:,j,i) + do m = 1, 3 + contrib(m) = dabs(ao_xmat(m,j,i) - dxyz_ints(m)) + accu2(m) += contrib(m) + if(dabs(ao_xmat(m,j,i)).gt.1.d-10)then + accu2relat(m) += dabs(ao_xmat(m,j,i) - dxyz_ints(m))/dabs(ao_xmat(m,j,i)) + endif + enddo + print*,contrib + enddo + print*,'' + enddo + print*,'accu2relat = ' + print*, accu2relat /dble(ao_num * ao_num) + +end + + diff --git a/src/ao_tc_eff_map/EZFIO.cfg b/src/ao_tc_eff_map/EZFIO.cfg new file mode 100644 index 00000000..1c72e2f5 --- /dev/null +++ b/src/ao_tc_eff_map/EZFIO.cfg @@ -0,0 +1,12 @@ + +[j1b_gauss_pen] +type: double precision +doc: exponents of the 1-body Jastrow +interface: ezfio +size: (nuclei.nucl_num) + +[j1b_gauss] +type: integer +doc: Use 1-body Gaussian Jastrow +interface: ezfio, provider, ocaml +default: 0 diff --git a/src/ao_tc_eff_map/NEED b/src/ao_tc_eff_map/NEED new file mode 100644 index 00000000..38638c7c --- /dev/null +++ b/src/ao_tc_eff_map/NEED @@ -0,0 +1,4 @@ +ao_two_e_erf_ints +mo_one_e_ints +ao_many_one_e_ints +dft_utils_in_r diff --git a/src/ao_tc_eff_map/README.rst b/src/ao_tc_eff_map/README.rst new file mode 100644 index 00000000..d45df18f --- /dev/null +++ b/src/ao_tc_eff_map/README.rst @@ -0,0 +1,12 @@ +ao_tc_eff_map +============= + +This is a module to obtain the integrals on the AO basis of the SCALAR HERMITIAN +effective potential defined in Eq. 32 of JCP 154, 084119 (2021) +It also contains the modification by a one-body Jastrow factor. + +The main routine/providers are + ++) ao_tc_sym_two_e_pot_map : map of the SCALAR PART of total effective two-electron on the AO basis in PHYSICIST notations. It might contain the two-electron term coming from the one-e correlation factor. ++) get_ao_tc_sym_two_e_pot(i,j,k,l,ao_tc_sym_two_e_pot_map) : routine to get the integrals from ao_tc_sym_two_e_pot_map. ++) ao_tc_sym_two_e_pot(i,j,k,l) : FUNCTION that returns the scalar part of TC-potential EXCLUDING the erf(mu r12)/r12. See two_e_ints_gauss.irp.f for more details. diff --git a/src/ao_tc_eff_map/compute_ints_eff_pot.irp.f b/src/ao_tc_eff_map/compute_ints_eff_pot.irp.f new file mode 100644 index 00000000..6196f56e --- /dev/null +++ b/src/ao_tc_eff_map/compute_ints_eff_pot.irp.f @@ -0,0 +1,75 @@ +subroutine compute_ao_tc_sym_two_e_pot_jl(j, l, n_integrals, buffer_i, buffer_value) + + use map_module + + BEGIN_DOC + ! Parallel client for AO integrals of the TC integrals involving purely hermitian operators + END_DOC + + implicit none + + integer, intent(in) :: j, l + integer,intent(out) :: n_integrals + integer(key_kind),intent(out) :: buffer_i(ao_num*ao_num) + real(integral_kind),intent(out) :: buffer_value(ao_num*ao_num) + + integer :: i, k + integer :: kk, m, j1, i1 + double precision :: cpu_1, cpu_2, wall_1, wall_2 + double precision :: integral, wall_0, integral_pot, integral_erf + double precision :: thr + + logical, external :: ao_two_e_integral_zero + double precision :: ao_tc_sym_two_e_pot, ao_two_e_integral_erf + double precision :: j1b_gauss_erf, j1b_gauss_coul + double precision :: j1b_gauss_coul_debug + double precision :: j1b_gauss_coul_modifdebug + double precision :: j1b_gauss_coulerf + + + PROVIDE j1b_gauss + + thr = ao_integrals_threshold + + n_integrals = 0 + + j1 = j+ishft(l*l-l,-1) + do k = 1, ao_num ! r1 + i1 = ishft(k*k-k,-1) + if (i1 > j1) then + exit + endif + do i = 1, k + i1 += 1 + if (i1 > j1) then + exit + endif + + if (ao_two_e_integral_erf_schwartz(i,k)*ao_two_e_integral_erf_schwartz(j,l) < thr ) then + cycle + endif + + !DIR$ FORCEINLINE + integral_pot = ao_tc_sym_two_e_pot (i, k, j, l) ! i,k : r1 j,l : r2 + integral_erf = ao_two_e_integral_erf(i, k, j, l) + integral = integral_erf + integral_pot + + if( j1b_gauss .eq. 1 ) then + integral = integral & + + j1b_gauss_coulerf(i, k, j, l) + endif + + + if(abs(integral) < thr) then + cycle + endif + + n_integrals += 1 + !DIR$ FORCEINLINE + call two_e_integrals_index(i, j, k, l, buffer_i(n_integrals)) + buffer_value(n_integrals) = integral + enddo + enddo + +end subroutine compute_ao_tc_sym_two_e_pot_jl + diff --git a/src/ao_tc_eff_map/integrals_eff_pot_in_map_slave.irp.f b/src/ao_tc_eff_map/integrals_eff_pot_in_map_slave.irp.f new file mode 100644 index 00000000..28401cc4 --- /dev/null +++ b/src/ao_tc_eff_map/integrals_eff_pot_in_map_slave.irp.f @@ -0,0 +1,194 @@ +subroutine ao_tc_sym_two_e_pot_in_map_slave_tcp(i) + implicit none + integer, intent(in) :: i + BEGIN_DOC +! Computes a buffer of integrals. i is the ID of the current thread. + END_DOC + call ao_tc_sym_two_e_pot_in_map_slave(0,i) +end + + +subroutine ao_tc_sym_two_e_pot_in_map_slave_inproc(i) + implicit none + integer, intent(in) :: i + BEGIN_DOC +! Computes a buffer of integrals. i is the ID of the current thread. + END_DOC + call ao_tc_sym_two_e_pot_in_map_slave(1,i) +end + + + + + +subroutine ao_tc_sym_two_e_pot_in_map_slave(thread,iproc) + use map_module + use f77_zmq + implicit none + BEGIN_DOC +! Computes a buffer of integrals + END_DOC + + integer, intent(in) :: thread, iproc + + integer :: j,l,n_integrals + integer :: rc + real(integral_kind), allocatable :: buffer_value(:) + integer(key_kind), allocatable :: buffer_i(:) + + integer :: worker_id, task_id + character*(512) :: task + + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_push_socket + integer(ZMQ_PTR) :: zmq_socket_push + + character*(64) :: state + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + + integer, external :: connect_to_taskserver + if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + return + endif + + zmq_socket_push = new_zmq_push_socket(thread) + + allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) ) + + + do + integer, external :: get_task_from_taskserver + if (get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) == -1) then + exit + endif + if (task_id == 0) exit + read(task,*) j, l + integer, external :: task_done_to_taskserver + call compute_ao_tc_sym_two_e_pot_jl(j,l,n_integrals,buffer_i,buffer_value) + if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) == -1) then + stop 'Unable to send task_done' + endif + call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id) + enddo + + integer, external :: disconnect_from_taskserver + if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) == -1) then + continue + endif + deallocate( buffer_i, buffer_value ) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_push_socket(zmq_socket_push,thread) + +end + + +subroutine ao_tc_sym_two_e_pot_in_map_collector(zmq_socket_pull) + use map_module + use f77_zmq + implicit none + BEGIN_DOC +! Collects results from the AO integral calculation + END_DOC + + integer(ZMQ_PTR), intent(in) :: zmq_socket_pull + integer :: j,l,n_integrals + integer :: rc + + real(integral_kind), allocatable :: buffer_value(:) + integer(key_kind), allocatable :: buffer_i(:) + + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_pull_socket + + integer*8 :: control, accu, sze + integer :: task_id, more + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + + sze = ao_num*ao_num + allocate ( buffer_i(sze), buffer_value(sze) ) + + accu = 0_8 + more = 1 + do while (more == 1) + + rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0) + if (rc == -1) then + n_integrals = 0 + return + endif + if (rc /= 4) then + print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)' + stop 'error' + endif + + if (n_integrals >= 0) then + + if (n_integrals > sze) then + deallocate (buffer_value, buffer_i) + sze = n_integrals + allocate (buffer_value(sze), buffer_i(sze)) + endif + + rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0) + if (rc /= key_kind*n_integrals) then + print *, rc, key_kind, n_integrals + print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)' + stop 'error' + endif + + rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0) + if (rc /= integral_kind*n_integrals) then + print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)' + stop 'error' + endif + + rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0) + +IRP_IF ZMQ_PUSH +IRP_ELSE + rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0) + if (rc /= 4) then + print *, irp_here, ' : f77_zmq_send (zmq_socket_pull,...' + stop 'error' + endif +IRP_ENDIF + + + call insert_into_ao_tc_sym_two_e_pot_map(n_integrals,buffer_i,buffer_value) + accu += n_integrals + if (task_id /= 0) then + integer, external :: zmq_delete_task + if (zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) == -1) then + stop 'Unable to delete task' + endif + endif + endif + + enddo + + deallocate( buffer_i, buffer_value ) + + integer (map_size_kind) :: get_ao_tc_sym_two_e_pot_map_size + control = get_ao_tc_sym_two_e_pot_map_size(ao_tc_sym_two_e_pot_map) + + if (control /= accu) then + print *, '' + print *, irp_here + print *, 'Control : ', control + print *, 'Accu : ', accu + print *, 'Some integrals were lost during the parallel computation.' + print *, 'Try to reduce the number of threads.' + stop + endif + + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + +end + diff --git a/src/ao_tc_eff_map/j1b_1eInteg.py b/src/ao_tc_eff_map/j1b_1eInteg.py new file mode 100644 index 00000000..53fb1a41 --- /dev/null +++ b/src/ao_tc_eff_map/j1b_1eInteg.py @@ -0,0 +1,299 @@ +import sys, os +QP_PATH=os.environ["QP_EZFIO"] +sys.path.insert(0,QP_PATH+"/Python/") +from ezfio import ezfio +from datetime import datetime +import time +from math import exp, sqrt, pi +import numpy as np +import subprocess +from scipy.integrate import tplquad +import multiprocessing +from multiprocessing import Pool + + +# _____________________________________________________________________________ +# +def read_ao(): + + with open('ao_data') as f: + lines = f.readlines() + + ao_prim_num = np.zeros((ao_num), dtype=int) + ao_nucl = np.zeros((ao_num), dtype=int) + ao_power = np.zeros((ao_num, 3)) + nucl_coord = np.zeros((ao_num, 3)) + ao_expo = np.zeros((ao_num, ao_num)) + ao_coef = np.zeros((ao_num, ao_num)) + + iline = 0 + for j in range(ao_num): + + line = lines[iline] + iline += 1 + ao_nucl[j] = int(line) - 1 + + line = lines[iline].split() + iline += 1 + ao_power[j, 0] = float(line[0]) + ao_power[j, 1] = float(line[1]) + ao_power[j, 2] = float(line[2]) + + line = lines[iline].split() + iline += 1 + nucl_coord[ao_nucl[j], 0] = float(line[0]) + nucl_coord[ao_nucl[j], 1] = float(line[1]) + nucl_coord[ao_nucl[j], 2] = float(line[2]) + + line = lines[iline] + iline += 1 + ao_prim_num[j] = int(line) + + for l in range(ao_prim_num[j]): + + line = lines[iline].split() + iline += 1 + ao_expo[l, j] = float(line[0]) + ao_coef[l, j] = float(line[1]) + + return( ao_prim_num + , ao_nucl + , ao_power + , nucl_coord + , ao_expo + , ao_coef ) +# _____________________________________________________________________________ + + +# _____________________________________________________________________________ +# +def Gao(X, i_ao): + + ii = ao_nucl[i_ao] + C = np.array([nucl_coord[ii,0], nucl_coord[ii,1], nucl_coord[ii,2]]) + Y = X - C + dis = np.dot(Y,Y) + + ip = np.array([ao_power[i_ao,0], ao_power[i_ao,1], ao_power[i_ao,2]]) + pol = np.prod(Y**ip) + + xi = np.sum( ao_coef[:,i_ao] * np.exp(-dis*ao_expo[:,i_ao]) ) + + return(xi*pol) +# _____________________________________________________________________________ + + +# _____________________________________________________________________________ +# +def grad_Gao(X, i_ao): + + ii = ao_nucl[i_ao] + C = np.array([nucl_coord[ii,0], nucl_coord[ii,1], nucl_coord[ii,2]]) + + ix = ao_power[i_ao,0] + iy = ao_power[i_ao,1] + iz = ao_power[i_ao,2] + + Y = X - C + dis = np.dot(Y,Y) + + xm = np.sum( ao_coef[:,i_ao]*np.exp(-dis*ao_expo[:,i_ao])) + xp = np.sum(ao_expo[:,i_ao]*ao_coef[:,i_ao]*np.exp(-dis*ao_expo[:,i_ao])) + + ip = np.array([ix+1, iy, iz]) + dx = -2. * np.prod(Y**ip) * xp + if(ix > 0): + ip = np.array([ix-1, iy, iz]) + dx += ix * np.prod(Y**ip) * xm + + ip = np.array([ix, iy+1, iz]) + dy = -2. * np.prod(Y**ip) * xp + if(iy > 0): + ip = np.array([ix, iy-1, iz]) + dy += iy * np.prod(Y**ip) * xm + + ip = np.array([ix, iy, iz+1]) + dz = -2. * np.prod(Y**ip) * xp + if(iz > 0): + ip = np.array([ix, iy, iz-1]) + dz += iz * np.prod(Y**ip) * xm + + return(np.array([dx, dy, dz])) +# _____________________________________________________________________________ + + +# _____________________________________________________________________________ +# +# 3 x < XA | exp[-gama r_C^2] | XB > +# - 2 x < XA | r_A^2 exp[-gama r_C^2] | XB > +# +def integ_lap(z, y, x, i_ao, j_ao): + + X = np.array([x, y, z]) + + Gi = Gao(X, i_ao) + Gj = Gao(X, j_ao) + + c = 0. + for k in range(nucl_num): + gama = j1b_gauss_pen[k] + C = nucl_coord[k,:] + Y = X - C + dis = np.dot(Y, Y) + arg = exp(-gama*dis) + arg = exp(-gama*dis) + c += ( 3. - 2. * dis * gama ) * arg * gama * Gi * Gj + + return(c) +# _____________________________________________________________________________ + + +# _____________________________________________________________________________ +# +# +def integ_grad2(z, y, x, i_ao, j_ao): + + X = np.array([x, y, z]) + + Gi = Gao(X, i_ao) + Gj = Gao(X, j_ao) + + c = np.zeros((3)) + for k in range(nucl_num): + gama = j1b_gauss_pen[k] + C = nucl_coord[k,:] + Y = X - C + c += gama * exp(-gama*np.dot(Y, Y)) * Y + + return(-2*np.dot(c,c)*Gi*Gj) +# _____________________________________________________________________________ + + +# _____________________________________________________________________________ +# +# +def integ_nonh(z, y, x, i_ao, j_ao): + + X = np.array([x, y, z]) + + Gi = Gao(X, i_ao) + + c = 0. + for k in range(nucl_num): + gama = j1b_gauss_pen[k] + C = nucl_coord[k,:] + Y = X - C + grad = grad_Gao(X, j_ao) + c += gama * exp(-gama*np.dot(Y,Y)) * np.dot(Y,grad) + + return(2*c*Gi) +# _____________________________________________________________________________ + + +# _____________________________________________________________________________ +# +def perform_integ( ind_ao ): + + i_ao = ind_ao[0] + j_ao = ind_ao[1] + + a = -15. #-np.Inf + b = +15. #+np.Inf + epsrel = 1e-5 + + res_lap, err_lap = tplquad( integ_lap + , a, b + , lambda x : a, lambda x : b + , lambda x,y: a, lambda x,y: b + , (i_ao, j_ao) + , epsrel=epsrel ) + + res_grd, err_grd = tplquad( integ_grad2 + , a, b + , lambda x : a, lambda x : b + , lambda x,y: a, lambda x,y: b + , (i_ao, j_ao) + , epsrel=epsrel ) + + res_nnh, err_nnh = tplquad( integ_nonh + , a, b + , lambda x : a, lambda x : b + , lambda x,y: a, lambda x,y: b + , (i_ao, j_ao) + , epsrel=epsrel ) + + return( [ res_lap, err_lap + , res_grd, err_grd + , res_nnh, err_nnh ]) +# _____________________________________________________________________________ + + +# _____________________________________________________________________________ +# +def integ_eval(): + + list_ind = [] + for i_ao in range(ao_num): + for j_ao in range(ao_num): + list_ind.append( [i_ao, j_ao] ) + + nb_proc = multiprocessing.cpu_count() + print(" --- Excexution with {} processors ---\n".format(nb_proc)) + + p = Pool(nb_proc) + res = np.array( p.map( perform_integ, list_ind ) ) + + ii = 0 + for i_ao in range(ao_num): + for j_ao in range(ao_num): + print(" {} {} {:+e} {:+e} {:+e} {:+e}".format( i_ao, j_ao + , res[ii][0], res[ii][1], res[ii][2], res[ii][3]) ) + ii += 1 + + p.close() +# _____________________________________________________________________________ + + + +# _____________________________________________________________________________ +# +if __name__=="__main__": + + t0 = time.time() + + EZFIO_file = sys.argv[1] + ezfio.set_file(EZFIO_file) + + print(" Today's date:", datetime.now() ) + print(" EZFIO file = {}".format(EZFIO_file)) + + nucl_num = ezfio.get_nuclei_nucl_num() + ao_num = ezfio.get_ao_basis_ao_num() + j1b_gauss_pen = ezfio.get_ao_tc_eff_map_j1b_gauss_pen() + + ao_prim_num, ao_nucl, ao_power, nucl_coord, ao_expo, ao_coef = read_ao() + + #integ_eval() + + i_ao = 0 + j_ao = 0 + + a = -5. + b = +5. + epsrel = 1e-1 + res_grd, err_grd = tplquad( integ_nonh + , a, b + , lambda x : a, lambda x : b + , lambda x,y: a, lambda x,y: b + , (i_ao, j_ao) + , epsrel=epsrel ) + + print(res_grd, err_grd) + + + tf = time.time() - t0 + print(' end after {} min'.format(tf/60.)) +# _____________________________________________________________________________ + + + diff --git a/src/ao_tc_eff_map/j1b_pen.irp.f b/src/ao_tc_eff_map/j1b_pen.irp.f new file mode 100644 index 00000000..9587cfe2 --- /dev/null +++ b/src/ao_tc_eff_map/j1b_pen.irp.f @@ -0,0 +1,59 @@ + +! --- + +BEGIN_PROVIDER [ double precision, j1b_gauss_pen, (nucl_num) ] + + BEGIN_DOC + ! exponents of the 1-body Jastrow + END_DOC + + implicit none + logical :: exists + + PROVIDE ezfio_filename + + if (mpi_master) then + call ezfio_has_ao_tc_eff_map_j1b_gauss_pen(exists) + endif + + IRP_IF MPI_DEBUG + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + IRP_ENDIF + + IRP_IF MPI + include 'mpif.h' + integer :: ierr + call MPI_BCAST(j1b_gauss_pen, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read j1b_gauss_pen with MPI' + endif + IRP_ENDIF + + if (exists) then + + if (mpi_master) then + write(6,'(A)') '.. >>>>> [ IO READ: j1b_gauss_pen ] <<<<< ..' + call ezfio_get_ao_tc_eff_map_j1b_gauss_pen(j1b_gauss_pen) + IRP_IF MPI + call MPI_BCAST(j1b_gauss_pen, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read j1b_gauss_pen with MPI' + endif + IRP_ENDIF + endif + + else + + integer :: i + do i = 1, nucl_num + j1b_gauss_pen(i) = 1d5 + enddo + + endif + +END_PROVIDER + +! --- + + diff --git a/src/ao_tc_eff_map/map_integrals_eff_pot.irp.f b/src/ao_tc_eff_map/map_integrals_eff_pot.irp.f new file mode 100644 index 00000000..aea4644f --- /dev/null +++ b/src/ao_tc_eff_map/map_integrals_eff_pot.irp.f @@ -0,0 +1,291 @@ +use map_module + +!! AO Map +!! ====== + +BEGIN_PROVIDER [ type(map_type), ao_tc_sym_two_e_pot_map ] + implicit none + BEGIN_DOC + ! |AO| integrals + END_DOC + integer(key_kind) :: key_max + integer(map_size_kind) :: sze + call two_e_integrals_index(ao_num,ao_num,ao_num,ao_num,key_max) + sze = key_max + call map_init(ao_tc_sym_two_e_pot_map,sze) + print*, 'ao_tc_sym_two_e_pot_map map initialized : ', sze +END_PROVIDER + + BEGIN_PROVIDER [ integer, ao_tc_sym_two_e_pot_cache_min ] +&BEGIN_PROVIDER [ integer, ao_tc_sym_two_e_pot_cache_max ] + implicit none + BEGIN_DOC + ! Min and max values of the AOs for which the integrals are in the cache + END_DOC + ao_tc_sym_two_e_pot_cache_min = max(1,ao_num - 63) + ao_tc_sym_two_e_pot_cache_max = ao_num + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, ao_tc_sym_two_e_pot_cache, (0:64*64*64*64) ] + use map_module + implicit none + BEGIN_DOC + ! Cache of |AO| integrals for fast access + END_DOC + PROVIDE ao_tc_sym_two_e_pot_in_map + integer :: i,j,k,l,ii + integer(key_kind) :: idx + real(integral_kind) :: integral + !$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral) + do l=ao_tc_sym_two_e_pot_cache_min,ao_tc_sym_two_e_pot_cache_max + do k=ao_tc_sym_two_e_pot_cache_min,ao_tc_sym_two_e_pot_cache_max + do j=ao_tc_sym_two_e_pot_cache_min,ao_tc_sym_two_e_pot_cache_max + do i=ao_tc_sym_two_e_pot_cache_min,ao_tc_sym_two_e_pot_cache_max + !DIR$ FORCEINLINE + call two_e_integrals_index(i,j,k,l,idx) + !DIR$ FORCEINLINE + call map_get(ao_tc_sym_two_e_pot_map,idx,integral) + ii = l-ao_tc_sym_two_e_pot_cache_min + ii = ior( ishft(ii,6), k-ao_tc_sym_two_e_pot_cache_min) + ii = ior( ishft(ii,6), j-ao_tc_sym_two_e_pot_cache_min) + ii = ior( ishft(ii,6), i-ao_tc_sym_two_e_pot_cache_min) + ao_tc_sym_two_e_pot_cache(ii) = integral + enddo + enddo + enddo + enddo + !$OMP END PARALLEL DO + +END_PROVIDER + + +subroutine insert_into_ao_tc_sym_two_e_pot_map(n_integrals,buffer_i, buffer_values) + use map_module + implicit none + BEGIN_DOC + ! Create new entry into |AO| map + END_DOC + + integer, intent(in) :: n_integrals + integer(key_kind), intent(inout) :: buffer_i(n_integrals) + real(integral_kind), intent(inout) :: buffer_values(n_integrals) + + call map_append(ao_tc_sym_two_e_pot_map, buffer_i, buffer_values, n_integrals) +end + +double precision function get_ao_tc_sym_two_e_pot(i,j,k,l,map) result(result) + use map_module + implicit none + BEGIN_DOC + ! Gets one |AO| two-electron integral from the |AO| map + END_DOC + integer, intent(in) :: i,j,k,l + integer(key_kind) :: idx + type(map_type), intent(inout) :: map + integer :: ii + real(integral_kind) :: tmp + logical, external :: ao_two_e_integral_zero + PROVIDE ao_tc_sym_two_e_pot_in_map ao_tc_sym_two_e_pot_cache ao_tc_sym_two_e_pot_cache_min + !DIR$ FORCEINLINE +! if (ao_two_e_integral_zero(i,j,k,l)) then + if (.False.) then + tmp = 0.d0 + !else if (ao_two_e_integral_erf_schwartz(i,k)*ao_two_e_integral_erf_schwartz(j,l) < ao_integrals_threshold) then + ! tmp = 0.d0 + else + ii = l-ao_tc_sym_two_e_pot_cache_min + ii = ior(ii, k-ao_tc_sym_two_e_pot_cache_min) + ii = ior(ii, j-ao_tc_sym_two_e_pot_cache_min) + ii = ior(ii, i-ao_tc_sym_two_e_pot_cache_min) + if (iand(ii, -64) /= 0) then + !DIR$ FORCEINLINE + call two_e_integrals_index(i,j,k,l,idx) + !DIR$ FORCEINLINE + call map_get(map,idx,tmp) + tmp = tmp + else + ii = l-ao_tc_sym_two_e_pot_cache_min + ii = ior( ishft(ii,6), k-ao_tc_sym_two_e_pot_cache_min) + ii = ior( ishft(ii,6), j-ao_tc_sym_two_e_pot_cache_min) + ii = ior( ishft(ii,6), i-ao_tc_sym_two_e_pot_cache_min) + tmp = ao_tc_sym_two_e_pot_cache(ii) + endif + endif + result = tmp +end + + +subroutine get_many_ao_tc_sym_two_e_pot(j,k,l,sze,out_val) + use map_module + BEGIN_DOC + ! Gets multiple |AO| two-electron integral from the |AO| map . + ! All i are retrieved for j,k,l fixed. + END_DOC + implicit none + integer, intent(in) :: j,k,l, sze + real(integral_kind), intent(out) :: out_val(sze) + + integer :: i + integer(key_kind) :: hash + double precision :: thresh +! logical, external :: ao_one_e_integral_zero + PROVIDE ao_tc_sym_two_e_pot_in_map ao_tc_sym_two_e_pot_map + thresh = ao_integrals_threshold + +! if (ao_one_e_integral_zero(j,l)) then + if (.False.) then + out_val = 0.d0 + return + endif + + double precision :: get_ao_tc_sym_two_e_pot + do i=1,sze + out_val(i) = get_ao_tc_sym_two_e_pot(i,j,k,l,ao_tc_sym_two_e_pot_map) + enddo + +end + +subroutine get_many_ao_tc_sym_two_e_pot_non_zero(j,k,l,sze,out_val,out_val_index,non_zero_int) + use map_module + implicit none + BEGIN_DOC + ! Gets multiple |AO| two-electron integrals from the |AO| map . + ! All non-zero i are retrieved for j,k,l fixed. + END_DOC + integer, intent(in) :: j,k,l, sze + real(integral_kind), intent(out) :: out_val(sze) + integer, intent(out) :: out_val_index(sze),non_zero_int + + integer :: i + integer(key_kind) :: hash + double precision :: thresh,tmp +! logical, external :: ao_one_e_integral_zero + PROVIDE ao_tc_sym_two_e_pot_in_map + thresh = ao_integrals_threshold + + non_zero_int = 0 +! if (ao_one_e_integral_zero(j,l)) then + if (.False.) then + out_val = 0.d0 + return + endif + + non_zero_int = 0 + do i=1,sze + integer, external :: ao_l4 + double precision, external :: ao_two_e_integral_eff_pot + !DIR$ FORCEINLINE + !if (ao_two_e_integral_erf_schwartz(i,k)*ao_two_e_integral_erf_schwartz(j,l) < thresh) then + ! cycle + !endif + call two_e_integrals_index(i,j,k,l,hash) + call map_get(ao_tc_sym_two_e_pot_map, hash,tmp) + if (dabs(tmp) < thresh ) cycle + non_zero_int = non_zero_int+1 + out_val_index(non_zero_int) = i + out_val(non_zero_int) = tmp + enddo + +end + + +function get_ao_tc_sym_two_e_pot_map_size() + implicit none + integer (map_size_kind) :: get_ao_tc_sym_two_e_pot_map_size + BEGIN_DOC + ! Returns the number of elements in the |AO| map + END_DOC + get_ao_tc_sym_two_e_pot_map_size = ao_tc_sym_two_e_pot_map % n_elements +end + +subroutine clear_ao_tc_sym_two_e_pot_map + implicit none + BEGIN_DOC + ! Frees the memory of the |AO| map + END_DOC + call map_deinit(ao_tc_sym_two_e_pot_map) + FREE ao_tc_sym_two_e_pot_map +end + + + +subroutine dump_ao_tc_sym_two_e_pot(filename) + use map_module + implicit none + BEGIN_DOC + ! Save to disk the |AO| eff_pot integrals + END_DOC + character*(*), intent(in) :: filename + integer(cache_key_kind), pointer :: key(:) + real(integral_kind), pointer :: val(:) + integer*8 :: i,j, n + call ezfio_set_work_empty(.False.) + open(unit=66,file=filename,FORM='unformatted') + write(66) integral_kind, key_kind + write(66) ao_tc_sym_two_e_pot_map%sorted, ao_tc_sym_two_e_pot_map%map_size, & + ao_tc_sym_two_e_pot_map%n_elements + do i=0_8,ao_tc_sym_two_e_pot_map%map_size + write(66) ao_tc_sym_two_e_pot_map%map(i)%sorted, ao_tc_sym_two_e_pot_map%map(i)%map_size,& + ao_tc_sym_two_e_pot_map%map(i)%n_elements + enddo + do i=0_8,ao_tc_sym_two_e_pot_map%map_size + key => ao_tc_sym_two_e_pot_map%map(i)%key + val => ao_tc_sym_two_e_pot_map%map(i)%value + n = ao_tc_sym_two_e_pot_map%map(i)%n_elements + write(66) (key(j), j=1,n), (val(j), j=1,n) + enddo + close(66) + +end + + + +integer function load_ao_tc_sym_two_e_pot(filename) + implicit none + BEGIN_DOC + ! Read from disk the |AO| eff_pot integrals + END_DOC + character*(*), intent(in) :: filename + integer*8 :: i + integer(cache_key_kind), pointer :: key(:) + real(integral_kind), pointer :: val(:) + integer :: iknd, kknd + integer*8 :: n, j + load_ao_tc_sym_two_e_pot = 1 + open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN') + read(66,err=98,end=98) iknd, kknd + if (iknd /= integral_kind) then + print *, 'Wrong integrals kind in file :', iknd + stop 1 + endif + if (kknd /= key_kind) then + print *, 'Wrong key kind in file :', kknd + stop 1 + endif + read(66,err=98,end=98) ao_tc_sym_two_e_pot_map%sorted, ao_tc_sym_two_e_pot_map%map_size,& + ao_tc_sym_two_e_pot_map%n_elements + do i=0_8, ao_tc_sym_two_e_pot_map%map_size + read(66,err=99,end=99) ao_tc_sym_two_e_pot_map%map(i)%sorted, & + ao_tc_sym_two_e_pot_map%map(i)%map_size, ao_tc_sym_two_e_pot_map%map(i)%n_elements + call cache_map_reallocate(ao_tc_sym_two_e_pot_map%map(i),ao_tc_sym_two_e_pot_map%map(i)%map_size) + enddo + do i=0_8, ao_tc_sym_two_e_pot_map%map_size + key => ao_tc_sym_two_e_pot_map%map(i)%key + val => ao_tc_sym_two_e_pot_map%map(i)%value + n = ao_tc_sym_two_e_pot_map%map(i)%n_elements + read(66,err=99,end=99) (key(j), j=1,n), (val(j), j=1,n) + enddo + call map_sort(ao_tc_sym_two_e_pot_map) + load_ao_tc_sym_two_e_pot = 0 + return + 99 continue + call map_deinit(ao_tc_sym_two_e_pot_map) + 98 continue + stop 'Problem reading ao_tc_sym_two_e_pot_map file in work/' + +end + + + + diff --git a/src/ao_tc_eff_map/one_e_1bgauss_hermit.irp.f b/src/ao_tc_eff_map/one_e_1bgauss_hermit.irp.f new file mode 100644 index 00000000..21b6ed83 --- /dev/null +++ b/src/ao_tc_eff_map/one_e_1bgauss_hermit.irp.f @@ -0,0 +1,519 @@ + +BEGIN_PROVIDER [ double precision, j1b_gauss_hermII, (ao_num,ao_num)] + + BEGIN_DOC + ! + ! Hermitian part of 1-body Jastrow factow in the |AO| basis set. + ! + ! :math:`\langle \chi_A | -0.5 \grad \tau_{1b} \cdot \grad \tau_{1b} | \chi_B \rangle` + ! + END_DOC + + implicit none + + integer :: num_A, num_B + integer :: power_A(3), power_B(3) + integer :: i, j, k1, k2, l, m + double precision :: alpha, beta, gama1, gama2 + double precision :: A_center(3), B_center(3), C_center1(3), C_center2(3) + double precision :: c1, c + + integer :: dim1 + double precision :: overlap_y, d_a_2, overlap_z, overlap + + double precision :: int_gauss_4G + + PROVIDE j1b_gauss_pen + + ! -------------------------------------------------------------------------------- + ! -- Dummy call to provide everything + dim1 = 100 + A_center(:) = 0.d0 + B_center(:) = 1.d0 + alpha = 1.d0 + beta = 0.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 ) + ! -------------------------------------------------------------------------------- + + + j1b_gauss_hermII(1:ao_num,1:ao_num) = 0.d0 + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, j, k1, k2, l, m, alpha, beta, gama1, gama2, & + !$OMP A_center, B_center, C_center1, C_center2, & + !$OMP power_A, power_B, num_A, num_B, c1, c) & + !$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, & + !$OMP ao_power, ao_nucl, nucl_coord, & + !$OMP ao_coef_normalized_ordered_transp, & + !$OMP nucl_num, j1b_gauss_pen, j1b_gauss_hermII) + + !$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_ordered_transp(l,j) + + do m = 1, ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) + + c = 0.d0 + do k1 = 1, nucl_num + gama1 = j1b_gauss_pen(k1) + C_center1(1:3) = nucl_coord(k1,1:3) + + do k2 = 1, nucl_num + gama2 = j1b_gauss_pen(k2) + C_center2(1:3) = nucl_coord(k2,1:3) + + ! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] r_C1 \cdot r_C2 | XB > + c1 = int_gauss_4G( A_center, B_center, C_center1, C_center2 & + , power_A, power_B, alpha, beta, gama1, gama2 ) + + c = c - 2.d0 * gama1 * gama2 * c1 + enddo + enddo + + j1b_gauss_hermII(i,j) = j1b_gauss_hermII(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 + +END_PROVIDER + + + + + +!_____________________________________________________________________________________________________________ +! +! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] r_C1 \cdot r_C2 | XB > +! +double precision function int_gauss_4G( A_center, B_center, C_center1, C_center2, power_A, power_B & + , alpha, beta, gama1, gama2 ) + + ! for max_dim + include 'constants.include.F' + + implicit none + + integer , intent(in) :: power_A(3), power_B(3) + double precision, intent(in) :: A_center(3), B_center(3), C_center1(3), C_center2(3) + double precision, intent(in) :: alpha, beta, gama1, gama2 + + integer :: i, dim1, power_C + integer :: iorder(3) + double precision :: AB_expo, fact_AB, AB_center(3), P_AB(0:max_dim,3) + double precision :: gama, fact_C, C_center(3) + double precision :: cx0, cy0, cz0, c_tmp1, c_tmp2, cx, cy, cz + double precision :: int_tmp + + double precision :: overlap_gaussian_x + + dim1 = 100 + + ! P_AB(0:max_dim,3) polynomial + ! AB_center(3) new center + ! AB_expo new exponent + ! fact_AB constant factor + ! iorder(3) i_order(i) = order of the polynomials + call give_explicit_poly_and_gaussian( P_AB, AB_center, AB_expo, fact_AB & + , iorder, alpha, beta, power_A, power_B, A_center, B_center, dim1) + + call gaussian_product(gama1, C_center1, gama2, C_center2, fact_C, gama, C_center) + + ! <<< + ! to avoid multi-evaluation + power_C = 0 + + cx0 = 0.d0 + do i = 0, iorder(1) + cx0 = cx0 + P_AB(i,1) * overlap_gaussian_x( AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1) + enddo + cy0 = 0.d0 + do i = 0, iorder(2) + cy0 = cy0 + P_AB(i,2) * overlap_gaussian_x( AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1) + enddo + cz0 = 0.d0 + do i = 0, iorder(3) + cz0 = cz0 + P_AB(i,3) * overlap_gaussian_x( AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1) + enddo + ! >>> + + int_tmp = 0.d0 + + ! ----------------------------------------------------------------------------------------------- + ! + ! x term: + ! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] (x - x_C1) (x - x_C2) | XB > + ! + + c_tmp1 = 2.d0 * C_center(1) - C_center1(1) - C_center2(1) + c_tmp2 = ( C_center(1) - C_center1(1) ) * ( C_center(1) - C_center2(1) ) + + cx = 0.d0 + do i = 0, iorder(1) + + ! < XA | exp[-gama r_C^2] (x - x_C)^2 | XB > + power_C = 2 + cx = cx + P_AB(i,1) & + * overlap_gaussian_x( AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1) + + ! < XA | exp[-gama r_C^2] (x - x_C) | XB > + power_C = 1 + cx = cx + P_AB(i,1) * c_tmp1 & + * overlap_gaussian_x( AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1) + + ! < XA | exp[-gama r_C^2] | XB > + power_C = 0 + cx = cx + P_AB(i,1) * c_tmp2 & + * overlap_gaussian_x( AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1) + + enddo + + int_tmp += cx * cy0 * cz0 + + ! ----------------------------------------------------------------------------------------------- + + + ! ----------------------------------------------------------------------------------------------- + ! + ! y term: + ! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] (y - y_C1) (y - y_C2) | XB > + ! + + c_tmp1 = 2.d0 * C_center(2) - C_center1(2) - C_center2(2) + c_tmp2 = ( C_center(2) - C_center1(2) ) * ( C_center(2) - C_center2(2) ) + + cy = 0.d0 + do i = 0, iorder(2) + + ! < XA | exp[-gama r_C^2] (y - y_C)^2 | XB > + power_C = 2 + cy = cy + P_AB(i,2) & + * overlap_gaussian_x( AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1) + + ! < XA | exp[-gama r_C^2] (y - y_C) | XB > + power_C = 1 + cy = cy + P_AB(i,2) * c_tmp1 & + * overlap_gaussian_x( AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1) + + ! < XA | exp[-gama r_C^2] | XB > + power_C = 0 + cy = cy + P_AB(i,2) * c_tmp2 & + * overlap_gaussian_x( AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1) + + enddo + + int_tmp += cx0 * cy * cz0 + + ! ----------------------------------------------------------------------------------------------- + + + ! ----------------------------------------------------------------------------------------------- + ! + ! z term: + ! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] (z - z_C1) (z - z_C2) | XB > + ! + + c_tmp1 = 2.d0 * C_center(3) - C_center1(3) - C_center2(3) + c_tmp2 = ( C_center(3) - C_center1(3) ) * ( C_center(3) - C_center2(3) ) + + cz = 0.d0 + do i = 0, iorder(3) + + ! < XA | exp[-gama r_C^2] (z - z_C)^2 | XB > + power_C = 2 + cz = cz + P_AB(i,3) & + * overlap_gaussian_x( AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1) + + ! < XA | exp[-gama r_C^2] (z - z_C) | XB > + power_C = 1 + cz = cz + P_AB(i,3) * c_tmp1 & + * overlap_gaussian_x( AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1) + + ! < XA | exp[-gama r_C^2] | XB > + power_C = 0 + cz = cz + P_AB(i,3) * c_tmp2 & + * overlap_gaussian_x( AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1) + + enddo + + int_tmp += cx0 * cy0 * cz + + ! ----------------------------------------------------------------------------------------------- + + int_gauss_4G = fact_AB * fact_C * int_tmp + + return +end function int_gauss_4G +!_____________________________________________________________________________________________________________ +!_____________________________________________________________________________________________________________ + +BEGIN_PROVIDER [ double precision, j1b_gauss_hermI, (ao_num,ao_num)] + + BEGIN_DOC + ! + ! Hermitian part of 1-body Jastrow factow in the |AO| basis set. + ! + ! :math:`\langle \chi_A | -0.5 \Delta \tau_{1b} | \chi_B \rangle` + ! + END_DOC + + implicit none + + integer :: num_A, num_B + integer :: power_A(3), power_B(3) + integer :: i, j, k, l, m + double precision :: alpha, beta, gama + double precision :: A_center(3), B_center(3), C_center(3) + double precision :: c1, c2, c + + integer :: dim1 + double precision :: overlap_y, d_a_2, overlap_z, overlap + + double precision :: int_gauss_r0, int_gauss_r2 + + PROVIDE j1b_gauss_pen + + ! -------------------------------------------------------------------------------- + ! -- Dummy call to provide everything + dim1 = 100 + A_center(:) = 0.d0 + B_center(:) = 1.d0 + alpha = 1.d0 + beta = 0.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 ) + ! -------------------------------------------------------------------------------- + + j1b_gauss_hermI(1:ao_num,1:ao_num) = 0.d0 + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, j, k, l, m, alpha, beta, gama, & + !$OMP A_center, B_center, C_center, power_A, power_B, & + !$OMP num_A, num_B, c1, c2, c) & + !$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, & + !$OMP ao_power, ao_nucl, nucl_coord, & + !$OMP ao_coef_normalized_ordered_transp, & + !$OMP nucl_num, j1b_gauss_pen, j1b_gauss_hermI) + + !$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_ordered_transp(l,j) + + do m = 1, ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) + + c = 0.d0 + do k = 1, nucl_num + + gama = j1b_gauss_pen(k) + C_center(1:3) = nucl_coord(k,1:3) + + ! < XA | exp[-gama r_C^2] | XB > + c1 = int_gauss_r0( A_center, B_center, C_center & + , power_A, power_B, alpha, beta, gama ) + + ! < XA | r_A^2 exp[-gama r_C^2] | XB > + c2 = int_gauss_r2( A_center, B_center, C_center & + , power_A, power_B, alpha, beta, gama ) + + c = c + 3.d0 * gama * c1 - 2.d0 * gama * gama * c2 + enddo + + j1b_gauss_hermI(i,j) = j1b_gauss_hermI(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 + +END_PROVIDER + + +!_____________________________________________________________________________________________________________ +! +! < XA | exp[-gama r_C^2] | XB > +! +double precision function int_gauss_r0(A_center, B_center, C_center, power_A, power_B, alpha, beta, gama) + + ! for max_dim + include 'constants.include.F' + + implicit none + + integer , intent(in) :: power_A(3), power_B(3) + double precision, intent(in) :: A_center(3), B_center(3), C_center(3) + double precision, intent(in) :: alpha, beta, gama + + integer :: i, power_C, dim1 + integer :: iorder(3) + integer :: nmax + double precision :: AB_expo, fact_AB, AB_center(3), P_AB(0:max_dim,3) + double precision :: cx, cy, cz + + double precision :: overlap_gaussian_x + + dim1 = 100 + + ! P_AB(0:max_dim,3) polynomial + ! AB_center(3) new center + ! AB_expo new exponent + ! fact_AB constant factor + ! iorder(3) i_order(i) = order of the polynomials + call give_explicit_poly_and_gaussian( P_AB, AB_center, AB_expo, fact_AB & + , iorder, alpha, beta, power_A, power_B, A_center, B_center, dim1) + + if( fact_AB .lt. 1d-20 ) then + int_gauss_r0 = 0.d0 + return + endif + + power_C = 0 + cx = 0.d0 + do i = 0, iorder(1) + cx = cx + P_AB(i,1) * overlap_gaussian_x(AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1) + enddo + cy = 0.d0 + do i = 0, iorder(2) + cy = cy + P_AB(i,2) * overlap_gaussian_x(AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1) + enddo + cz = 0.d0 + do i = 0, iorder(3) + cz = cz + P_AB(i,3) * overlap_gaussian_x(AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1) + enddo + + int_gauss_r0 = fact_AB * cx * cy * cz + + return +end function int_gauss_r0 +!_____________________________________________________________________________________________________________ +!_____________________________________________________________________________________________________________ + + + +!_____________________________________________________________________________________________________________ +! +! < XA | r_C^2 exp[-gama r_C^2] | XB > +! +double precision function int_gauss_r2(A_center, B_center, C_center, power_A, power_B, alpha, beta, gama) + + ! for max_dim + include 'constants.include.F' + + implicit none + + integer, intent(in) :: power_A(3), power_B(3) + double precision, intent(in) :: A_center(3), B_center(3), C_center(3) + double precision, intent(in) :: alpha, beta, gama + + integer :: i, power_C, dim1 + integer :: iorder(3) + double precision :: AB_expo, fact_AB, AB_center(3), P_AB(0:max_dim,3) + double precision :: cx0, cy0, cz0, cx, cy, cz + double precision :: int_tmp + + double precision :: overlap_gaussian_x + + dim1 = 100 + + ! P_AB(0:max_dim,3) polynomial centered on AB_center + ! AB_center(3) new center + ! AB_expo new exponent + ! fact_AB constant factor + ! iorder(3) i_order(i) = order of the polynomials + call give_explicit_poly_and_gaussian( P_AB, AB_center, AB_expo, fact_AB & + , iorder, alpha, beta, power_A, power_B, A_center, B_center, dim1) + + ! <<< + ! to avoid multi-evaluation + power_C = 0 + + cx0 = 0.d0 + do i = 0, iorder(1) + cx0 = cx0 + P_AB(i,1) * overlap_gaussian_x(AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1) + enddo + cy0 = 0.d0 + do i = 0, iorder(2) + cy0 = cy0 + P_AB(i,2) * overlap_gaussian_x(AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1) + enddo + cz0 = 0.d0 + do i = 0, iorder(3) + cz0 = cz0 + P_AB(i,3) * overlap_gaussian_x(AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1) + enddo + ! >>> + + int_tmp = 0.d0 + + power_C = 2 + + ! ( x - XC)^2 + cx = 0.d0 + do i = 0, iorder(1) + cx = cx + P_AB(i,1) * overlap_gaussian_x(AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1) + enddo + int_tmp += cx * cy0 * cz0 + + ! ( y - YC)^2 + cy = 0.d0 + do i = 0, iorder(2) + cy = cy + P_AB(i,2) * overlap_gaussian_x(AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1) + enddo + int_tmp += cx0 * cy * cz0 + + ! ( z - ZC)^2 + cz = 0.d0 + do i = 0, iorder(3) + cz = cz + P_AB(i,3) * overlap_gaussian_x(AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1) + enddo + int_tmp += cx0 * cy0 * cz + + int_gauss_r2 = fact_AB * int_tmp + + return +end function int_gauss_r2 +!_____________________________________________________________________________________________________________ +!_____________________________________________________________________________________________________________ diff --git a/src/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f b/src/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f new file mode 100644 index 00000000..3ae3e019 --- /dev/null +++ b/src/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f @@ -0,0 +1,319 @@ +BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)] + + BEGIN_DOC + ! + ! Hermitian part of 1-body Jastrow factow in the |AO| basis set. + ! + ! \langle \chi_i | - grad \tau_{1b} \cdot grad | \chi_j \rangle = + ! 2 \sum_A aA \langle \chi_i | exp[-aA riA^2] (ri-rA) \cdot grad | \chi_j \rangle + ! + END_DOC + + implicit none + + integer :: num_A, num_B + integer :: power_A(3), power_B(3) + integer :: i, j, k, l, m + double precision :: alpha, beta, gama + double precision :: A_center(3), B_center(3), C_center(3) + double precision :: c1, c + + integer :: dim1 + double precision :: overlap_y, d_a_2, overlap_z, overlap + + double precision :: int_gauss_deriv + + PROVIDE j1b_gauss_pen + + ! -------------------------------------------------------------------------------- + ! -- Dummy call to provide everything + dim1 = 100 + A_center(:) = 0.d0 + B_center(:) = 1.d0 + alpha = 1.d0 + beta = 0.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 ) + ! -------------------------------------------------------------------------------- + + + j1b_gauss_nonherm(1:ao_num,1:ao_num) = 0.d0 + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, j, k, l, m, alpha, beta, gama, & + !$OMP A_center, B_center, C_center, power_A, power_B, & + !$OMP num_A, num_B, c1, c) & + !$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, & + !$OMP ao_power, ao_nucl, nucl_coord, & + !$OMP ao_coef_normalized_ordered_transp, & + !$OMP nucl_num, j1b_gauss_pen, j1b_gauss_nonherm) + + !$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_ordered_transp(l,j) + + do m = 1, ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) + + c = 0.d0 + do k = 1, nucl_num + + gama = j1b_gauss_pen(k) + C_center(1:3) = nucl_coord(k,1:3) + + ! \langle \chi_A | exp[-gama r_C^2] r_C \cdot grad | \chi_B \rangle + c1 = int_gauss_deriv( A_center, B_center, C_center & + , power_A, power_B, alpha, beta, gama ) + + c = c + 2.d0 * gama * c1 + enddo + + j1b_gauss_nonherm(i,j) = j1b_gauss_nonherm(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 + +END_PROVIDER + + + + + +!_____________________________________________________________________________________________________________ +! +! < XA | exp[-gama r_C^2] r_C \cdot grad | XB > +! +double precision function int_gauss_deriv(A_center, B_center, C_center, power_A, power_B, alpha, beta, gama) + + ! for max_dim + include 'constants.include.F' + + implicit none + + double precision, intent(in) :: A_center(3), B_center(3), C_center(3) + integer , intent(in) :: power_A(3), power_B(3) + double precision, intent(in) :: alpha, beta, gama + + integer :: i, power_C, dim1 + integer :: iorder(3), power_D(3) + double precision :: AB_expo + double precision :: fact_AB, center_AB(3), pol_AB(0:max_dim,3) + double precision :: cx, cy, cz + + double precision :: overlap_gaussian_x + + dim1 = 100 + + int_gauss_deriv = 0.d0 + + ! =============== + ! term I: + ! \partial_x + ! =============== + + if( power_B(1) .ge. 1 ) then + + power_D(1) = power_B(1) - 1 + power_D(2) = power_B(2) + power_D(3) = power_B(3) + + call give_explicit_poly_and_gaussian( pol_AB, center_AB, AB_expo, fact_AB & + , iorder, alpha, beta, power_A, power_D, A_center, B_center, dim1) + power_C = 1 + cx = 0.d0 + do i = 0, iorder(1) + cx = cx + pol_AB(i,1) * overlap_gaussian_x( center_AB(1), C_center(1), AB_expo, gama, i, power_C, dim1) + enddo + power_C = 0 + cy = 0.d0 + do i = 0, iorder(2) + cy = cy + pol_AB(i,2) * overlap_gaussian_x( center_AB(2), C_center(2), AB_expo, gama, i, power_C, dim1) + enddo + power_C = 0 + cz = 0.d0 + do i = 0, iorder(3) + cz = cz + pol_AB(i,3) * overlap_gaussian_x( center_AB(3), C_center(3), AB_expo, gama, i, power_C, dim1) + enddo + + int_gauss_deriv = int_gauss_deriv + fact_AB * dble(power_B(1)) * cx * cy * cz + endif + + ! =============== + + power_D(1) = power_B(1) + 1 + power_D(2) = power_B(2) + power_D(3) = power_B(3) + + call give_explicit_poly_and_gaussian( pol_AB, center_AB, AB_expo, fact_AB & + , iorder, alpha, beta, power_A, power_D, A_center, B_center, dim1) + power_C = 1 + cx = 0.d0 + do i = 0, iorder(1) + cx = cx + pol_AB(i,1) * overlap_gaussian_x( center_AB(1), C_center(1), AB_expo, gama, i, power_C, dim1) + enddo + power_C = 0 + cy = 0.d0 + do i = 0, iorder(2) + cy = cy + pol_AB(i,2) * overlap_gaussian_x( center_AB(2), C_center(2), AB_expo, gama, i, power_C, dim1) + enddo + power_C = 0 + cz = 0.d0 + do i = 0, iorder(3) + cz = cz + pol_AB(i,3) * overlap_gaussian_x( center_AB(3), C_center(3), AB_expo, gama, i, power_C, dim1) + enddo + + int_gauss_deriv = int_gauss_deriv - 2.d0 * beta * fact_AB * cx * cy * cz + + ! =============== + ! =============== + + + ! =============== + ! term II: + ! \partial_y + ! =============== + + if( power_B(2) .ge. 1 ) then + + power_D(1) = power_B(1) + power_D(2) = power_B(2) - 1 + power_D(3) = power_B(3) + + call give_explicit_poly_and_gaussian( pol_AB, center_AB, AB_expo, fact_AB & + , iorder, alpha, beta, power_A, power_D, A_center, B_center, dim1) + power_C = 0 + cx = 0.d0 + do i = 0, iorder(1) + cx = cx + pol_AB(i,1) * overlap_gaussian_x( center_AB(1), C_center(1), AB_expo, gama, i, power_C, dim1) + enddo + power_C = 1 + cy = 0.d0 + do i = 0, iorder(2) + cy = cy + pol_AB(i,2) * overlap_gaussian_x( center_AB(2), C_center(2), AB_expo, gama, i, power_C, dim1) + enddo + power_C = 0 + cz = 0.d0 + do i = 0, iorder(3) + cz = cz + pol_AB(i,3) * overlap_gaussian_x( center_AB(3), C_center(3), AB_expo, gama, i, power_C, dim1) + enddo + + int_gauss_deriv = int_gauss_deriv + fact_AB * dble(power_B(2)) * cx * cy * cz + endif + + ! =============== + + power_D(1) = power_B(1) + power_D(2) = power_B(2) + 1 + power_D(3) = power_B(3) + + call give_explicit_poly_and_gaussian( pol_AB, center_AB, AB_expo, fact_AB & + , iorder, alpha, beta, power_A, power_D, A_center, B_center, dim1) + power_C = 0 + cx = 0.d0 + do i = 0, iorder(1) + cx = cx + pol_AB(i,1) * overlap_gaussian_x( center_AB(1), C_center(1), AB_expo, gama, i, power_C, dim1) + enddo + power_C = 1 + cy = 0.d0 + do i = 0, iorder(2) + cy = cy + pol_AB(i,2) * overlap_gaussian_x( center_AB(2), C_center(2), AB_expo, gama, i, power_C, dim1) + enddo + power_C = 0 + cz = 0.d0 + do i = 0, iorder(3) + cz = cz + pol_AB(i,3) * overlap_gaussian_x( center_AB(3), C_center(3), AB_expo, gama, i, power_C, dim1) + enddo + + int_gauss_deriv = int_gauss_deriv - 2.d0 * beta * fact_AB * cx * cy * cz + + ! =============== + ! =============== + + ! =============== + ! term III: + ! \partial_z + ! =============== + + if( power_B(3) .ge. 1 ) then + + power_D(1) = power_B(1) + power_D(2) = power_B(2) + power_D(3) = power_B(3) - 1 + + call give_explicit_poly_and_gaussian( pol_AB, center_AB, AB_expo, fact_AB & + , iorder, alpha, beta, power_A, power_D, A_center, B_center, dim1) + power_C = 0 + cx = 0.d0 + do i = 0, iorder(1) + cx = cx + pol_AB(i,1) * overlap_gaussian_x( center_AB(1), C_center(1), AB_expo, gama, i, power_C, dim1) + enddo + power_C = 0 + cy = 0.d0 + do i = 0, iorder(2) + cy = cy + pol_AB(i,2) * overlap_gaussian_x( center_AB(2), C_center(2), AB_expo, gama, i, power_C, dim1) + enddo + power_C = 1 + cz = 0.d0 + do i = 0, iorder(3) + cz = cz + pol_AB(i,3) * overlap_gaussian_x( center_AB(3), C_center(3), AB_expo, gama, i, power_C, dim1) + enddo + + int_gauss_deriv = int_gauss_deriv + fact_AB * dble(power_B(3)) * cx * cy * cz + endif + + ! =============== + + power_D(1) = power_B(1) + power_D(2) = power_B(2) + power_D(3) = power_B(3) + 1 + + call give_explicit_poly_and_gaussian( pol_AB, center_AB, AB_expo, fact_AB & + , iorder, alpha, beta, power_A, power_D, A_center, B_center, dim1) + power_C = 0 + cx = 0.d0 + do i = 0, iorder(1) + cx = cx + pol_AB(i,1) * overlap_gaussian_x( center_AB(1), C_center(1), AB_expo, gama, i, power_C, dim1) + enddo + power_C = 0 + cy = 0.d0 + do i = 0, iorder(2) + cy = cy + pol_AB(i,2) * overlap_gaussian_x( center_AB(2), C_center(2), AB_expo, gama, i, power_C, dim1) + enddo + power_C = 1 + cz = 0.d0 + do i = 0, iorder(3) + cz = cz + pol_AB(i,3) * overlap_gaussian_x( center_AB(3), C_center(3), AB_expo, gama, i, power_C, dim1) + enddo + + int_gauss_deriv = int_gauss_deriv - 2.d0 * beta * fact_AB * cx * cy * cz + + ! =============== + ! =============== + + return +end function int_gauss_deriv +!_____________________________________________________________________________________________________________ +!_____________________________________________________________________________________________________________ diff --git a/src/ao_tc_eff_map/potential.irp.f b/src/ao_tc_eff_map/potential.irp.f new file mode 100644 index 00000000..2f7ea4d6 --- /dev/null +++ b/src/ao_tc_eff_map/potential.irp.f @@ -0,0 +1,203 @@ +BEGIN_PROVIDER [integer, n_gauss_eff_pot] + implicit none + BEGIN_DOC +! number of gaussians to represent the effective potential : +! +! V(mu,r12) = -0.25 * (1 - erf(mu*r12))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*r12)^2) +! +! Here (1 - erf(mu*r12))^2 is expanded in Gaussians as Eqs A11-A20 in JCP 154, 084119 (2021) + END_DOC + n_gauss_eff_pot = n_max_fit_slat + 1 +END_PROVIDER + +BEGIN_PROVIDER [integer, n_gauss_eff_pot_deriv] + implicit none + BEGIN_DOC +! V(r12) = -(1 - erf(mu*r12))^2 is expanded in Gaussians as Eqs A11-A20 in JCP 154, 084119 (2021) + END_DOC + n_gauss_eff_pot_deriv = n_max_fit_slat +END_PROVIDER + + BEGIN_PROVIDER [double precision, expo_gauss_eff_pot, (n_gauss_eff_pot)] +&BEGIN_PROVIDER [double precision, coef_gauss_eff_pot, (n_gauss_eff_pot)] + implicit none + BEGIN_DOC +! Coefficients and exponents of the Fit on Gaussians of V(X) = -(1 - erf(mu*X))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*X)^2) +! +! V(X) = \sum_{i=1,n_gauss_eff_pot} coef_gauss_eff_pot(i) * exp(-expo_gauss_eff_pot(i) * X^2) +! +! Relies on the fit proposed in Eqs A11-A20 in JCP 154, 084119 (2021) + END_DOC + include 'constants.include.F' + + integer :: i + ! fit of the -0.25 * (1 - erf(mu*x))^2 with n_max_fit_slat gaussians + do i = 1, n_max_fit_slat + expo_gauss_eff_pot(i) = expo_gauss_1_erf_x_2(i) + coef_gauss_eff_pot(i) = -0.25d0 * coef_gauss_1_erf_x_2(i) ! -1/4 * (1 - erf(mu*x))^2 + enddo + ! Analytical Gaussian part of the potential: + 1/(\sqrt(pi)mu) * exp(-(mu*x)^2) + expo_gauss_eff_pot(n_max_fit_slat+1) = mu_erf * mu_erf + coef_gauss_eff_pot(n_max_fit_slat+1) = 1.d0 * mu_erf * inv_sq_pi + +END_PROVIDER + + +double precision function eff_pot_gauss(x,mu) + implicit none + BEGIN_DOC + ! V(mu,r12) = -0.25 * (1 - erf(mu*r12))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*r12)^2) + END_DOC + double precision, intent(in) :: x,mu + eff_pot_gauss = mu/dsqrt(dacos(-1.d0)) * dexp(-mu*mu*x*x) - 0.25d0 * (1.d0 - derf(mu*x))**2.d0 +end + + + +! ------------------------------------------------------------------------------------------------- +! --- + +double precision function eff_pot_fit_gauss(x) + implicit none + BEGIN_DOC + ! V(mu,r12) = -0.25 * (1 - erf(mu*r12))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*r12)^2) + ! + ! but fitted with gaussians + END_DOC + double precision, intent(in) :: x + integer :: i + double precision :: alpha + eff_pot_fit_gauss = derf(mu_erf*x)/x + do i = 1, n_gauss_eff_pot + alpha = expo_gauss_eff_pot(i) + eff_pot_fit_gauss += coef_gauss_eff_pot(i) * dexp(-alpha*x*x) + enddo +end + +BEGIN_PROVIDER [integer, n_fit_1_erf_x] + implicit none + BEGIN_DOC +! + END_DOC + n_fit_1_erf_x = 2 + +END_PROVIDER + +BEGIN_PROVIDER [double precision, expos_slat_gauss_1_erf_x, (n_fit_1_erf_x)] + implicit none + BEGIN_DOC +! 1 - erf(mu*x) is fitted with a Slater and gaussian as in Eq.A15 of JCP 154, 084119 (2021) +! +! 1 - erf(mu*x) = e^{-expos_slat_gauss_1_erf_x(1) * mu *x} * e^{-expos_slat_gauss_1_erf_x(2) * mu^2 * x^2} + END_DOC + expos_slat_gauss_1_erf_x(1) = 1.09529d0 + expos_slat_gauss_1_erf_x(2) = 0.756023d0 +END_PROVIDER + + BEGIN_PROVIDER [double precision, expo_gauss_1_erf_x, (n_max_fit_slat)] +&BEGIN_PROVIDER [double precision, coef_gauss_1_erf_x, (n_max_fit_slat)] + implicit none + BEGIN_DOC +! (1 - erf(mu*x)) = \sum_i coef_gauss_1_erf_x(i) * exp(-expo_gauss_1_erf_x(i) * x^2) +! +! This is based on a fit of (1 - erf(mu*x)) by exp(-alpha * x) exp(-beta*mu^2x^2) +! +! and the slater function exp(-alpha * x) is fitted with n_max_fit_slat gaussians +! +! See Appendix 2 of JCP 154, 084119 (2021) + END_DOC + integer :: i + double precision :: expos(n_max_fit_slat),alpha,beta + alpha = expos_slat_gauss_1_erf_x(1) * mu_erf + call expo_fit_slater_gam(alpha,expos) + beta = expos_slat_gauss_1_erf_x(2) * mu_erf**2.d0 + + do i = 1, n_max_fit_slat + expo_gauss_1_erf_x(i) = expos(i) + beta + coef_gauss_1_erf_x(i) = coef_fit_slat_gauss(i) + enddo +END_PROVIDER + +double precision function fit_1_erf_x(x) + implicit none + double precision, intent(in) :: x + BEGIN_DOC +! fit_1_erf_x(x) = \sum_i c_i exp (-alpha_i x^2) \approx (1 - erf(mu*x)) + END_DOC + integer :: i + fit_1_erf_x = 0.d0 + do i = 1, n_max_fit_slat + fit_1_erf_x += dexp(-expo_gauss_1_erf_x(i) *x*x) * coef_gauss_1_erf_x(i) + enddo + +end + + BEGIN_PROVIDER [double precision, expo_gauss_1_erf_x_2, (n_max_fit_slat)] +&BEGIN_PROVIDER [double precision, coef_gauss_1_erf_x_2, (n_max_fit_slat)] + implicit none + BEGIN_DOC +! (1 - erf(mu*x))^2 = \sum_i coef_gauss_1_erf_x_2(i) * exp(-expo_gauss_1_erf_x_2(i) * x^2) +! +! This is based on a fit of (1 - erf(mu*x)) by exp(-alpha * x) exp(-beta*mu^2x^2) +! +! and the slater function exp(-alpha * x) is fitted with n_max_fit_slat gaussians + END_DOC + integer :: i + double precision :: expos(n_max_fit_slat),alpha,beta + alpha = 2.d0 * expos_slat_gauss_1_erf_x(1) * mu_erf + call expo_fit_slater_gam(alpha,expos) + beta = 2.d0 * expos_slat_gauss_1_erf_x(2) * mu_erf**2.d0 + do i = 1, n_max_fit_slat + expo_gauss_1_erf_x_2(i) = expos(i) + beta + coef_gauss_1_erf_x_2(i) = coef_fit_slat_gauss(i) + enddo +END_PROVIDER + +double precision function fit_1_erf_x_2(x) + implicit none + double precision, intent(in) :: x + BEGIN_DOC +! fit_1_erf_x_2(x) = \sum_i c_i exp (-alpha_i x^2) \approx (1 - erf(mu*x))^2 + END_DOC + integer :: i + fit_1_erf_x_2 = 0.d0 + do i = 1, n_max_fit_slat + fit_1_erf_x_2 += dexp(-expo_gauss_1_erf_x_2(i) *x*x) * coef_gauss_1_erf_x_2(i) + enddo + +end + +subroutine inv_r_times_poly(r, dist_r, dist_vec, poly) + implicit none + BEGIN_DOC +! returns +! +! poly(1) = x / sqrt(x^2+y^2+z^2), poly(2) = y / sqrt(x^2+y^2+z^2), poly(3) = z / sqrt(x^2+y^2+z^2) +! +! with the arguments +! +! r(1) = x, r(2) = y, r(3) = z, dist_r = sqrt(x^2+y^2+z^2) +! +! dist_vec(1) = sqrt(y^2+z^2), dist_vec(2) = sqrt(x^2+z^2), dist_vec(3) = sqrt(x^2+y^2) + END_DOC + double precision, intent(in) :: r(3), dist_r, dist_vec(3) + double precision, intent(out):: poly(3) + double precision :: inv_dist + integer :: i + if (dist_r.gt. 1.d-8)then + inv_dist = 1.d0/dist_r + do i = 1, 3 + poly(i) = r(i) * inv_dist + enddo + else + do i = 1, 3 + if(dabs(r(i)).lt.dist_vec(i))then + inv_dist = 1.d0/dist_r + poly(i) = r(i) * inv_dist + else !if(dabs(r(i)))then + poly(i) = 1.d0 +! poly(i) = 0.d0 + endif + enddo + endif +end diff --git a/src/ao_tc_eff_map/providers_ao_eff_pot.irp.f b/src/ao_tc_eff_map/providers_ao_eff_pot.irp.f new file mode 100644 index 00000000..055bf323 --- /dev/null +++ b/src/ao_tc_eff_map/providers_ao_eff_pot.irp.f @@ -0,0 +1,86 @@ + +BEGIN_PROVIDER [ logical, ao_tc_sym_two_e_pot_in_map ] + implicit none + use f77_zmq + use map_module + BEGIN_DOC + ! Map of Atomic integrals + ! i(r1) j(r2) 1/r12 k(r1) l(r2) + END_DOC + + integer :: i,j,k,l + double precision :: ao_tc_sym_two_e_pot,cpu_1,cpu_2, wall_1, wall_2 + double precision :: integral, wall_0 + include 'utils/constants.include.F' + + ! For integrals file + integer(key_kind),allocatable :: buffer_i(:) + integer,parameter :: size_buffer = 1024*64 + real(integral_kind),allocatable :: buffer_value(:) + + integer :: n_integrals, rc + integer :: kk, m, j1, i1, lmax + character*(64) :: fmt + + !double precision :: j1b_gauss_coul_debug + !integral = j1b_gauss_coul_debug(1,1,1,1) + + integral = ao_tc_sym_two_e_pot(1,1,1,1) + + double precision :: map_mb + + print*, 'Providing the ao_tc_sym_two_e_pot_map integrals' + call wall_time(wall_0) + call wall_time(wall_1) + call cpu_time(cpu_1) + + integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull + call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'ao_tc_sym_two_e_pot') + + character(len=:), allocatable :: task + allocate(character(len=ao_num*12) :: task) + write(fmt,*) '(', ao_num, '(I5,X,I5,''|''))' + do l=1,ao_num + write(task,fmt) (i,l, i=1,l) + integer, external :: add_task_to_taskserver + if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) == -1) then + stop 'Unable to add task to server' + endif + enddo + deallocate(task) + + integer, external :: zmq_set_running + if (zmq_set_running(zmq_to_qp_run_socket) == -1) then + print *, irp_here, ': Failed in zmq_set_running' + endif + + PROVIDE nproc + !$OMP PARALLEL DEFAULT(shared) private(i) num_threads(nproc+1) + i = omp_get_thread_num() + if (i==0) then + call ao_tc_sym_two_e_pot_in_map_collector(zmq_socket_pull) + else + call ao_tc_sym_two_e_pot_in_map_slave_inproc(i) + endif + !$OMP END PARALLEL + + call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'ao_tc_sym_two_e_pot') + + + print*, 'Sorting the map' + call map_sort(ao_tc_sym_two_e_pot_map) + call cpu_time(cpu_2) + call wall_time(wall_2) + integer(map_size_kind) :: get_ao_tc_sym_two_e_pot_map_size, ao_eff_pot_map_size + ao_eff_pot_map_size = get_ao_tc_sym_two_e_pot_map_size() + + print*, 'AO eff_pot integrals provided:' + print*, ' Size of AO eff_pot map : ', map_mb(ao_tc_sym_two_e_pot_map) ,'MB' + print*, ' Number of AO eff_pot integrals :', ao_eff_pot_map_size + print*, ' cpu time :',cpu_2 - cpu_1, 's' + print*, ' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1+tiny(1.d0)), ' )' + + ao_tc_sym_two_e_pot_in_map = .True. + + +END_PROVIDER diff --git a/src/ao_tc_eff_map/two_e_1bgauss_coul.irp.f b/src/ao_tc_eff_map/two_e_1bgauss_coul.irp.f new file mode 100644 index 00000000..8d819711 --- /dev/null +++ b/src/ao_tc_eff_map/two_e_1bgauss_coul.irp.f @@ -0,0 +1,800 @@ +double precision function j1b_gauss_coul(i, j, k, l) + + BEGIN_DOC + ! + ! integral in the AO basis: + ! i(r1) j(r1) f(r12) k(r2) l(r2) + ! + ! with: + ! f(r12) = - [ 0.5 / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ] + ! = [ 1 / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2) + ! + (r2-RA)^2 exp(-aA r2A^2) + ! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) + ! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ] + ! + END_DOC + + include 'utils/constants.include.F' + + implicit none + + integer, intent(in) :: i, j, k, l + + integer :: p, q, r, s, ii + integer :: num_i, num_j, num_k, num_l, num_ii + integer :: I_power(3), J_power(3), K_power(3), L_power(3) + integer :: iorder_p(3), iorder_q(3) + integer :: shift_P(3), shift_Q(3) + integer :: dim1 + + double precision :: coef1, coef2, coef3, coef4 + double precision :: expo1, expo2, expo3, expo4 + double precision :: p_inv, q_inv + double precision :: P_new_tmp(0:max_dim,3), P_center_tmp(3), fact_p_tmp, pp_tmp + double precision :: Q_new_tmp(0:max_dim,3), Q_center_tmp(3), fact_q_tmp, qq_tmp + 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 + double precision :: I_center(3), J_center(3), K_center(3), L_center(3) + double precision :: expoii, factii, Centerii(3) + double precision :: ff, gg, cx, cy, cz + + double precision :: general_primitive_integral_coul_shifted + + PROVIDE j1b_gauss_pen + + 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) + + 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 + + j1b_gauss_coul = 0.d0 + + ! ------------------------------------------------------------------------------------------------------------------- + ! + ! [ 1 / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2) + ! + ! ------------------------------------------------------------------------------------------------------------------- + + shift_Q = (/ 0, 0, 0 /) + + do p = 1, ao_prim_num(i) + coef1 = ao_coef_normalized_ordered_transp(p, i) + expo1 = ao_expo_ordered_transp(p, i) + + do q = 1, ao_prim_num(j) + coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j) + expo2 = ao_expo_ordered_transp(q, j) + + call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 & + , I_power, J_power, I_center, J_center, dim1 ) + + do r = 1, ao_prim_num(k) + coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k) + expo3 = ao_expo_ordered_transp(r, k) + + do s = 1, ao_prim_num(l) + coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l) + expo4 = ao_expo_ordered_transp(s, l) + + call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 & + , K_power, L_power, K_center, L_center, dim1 ) + q_inv = 1.d0 / qq + + cx = 0.d0 + cy = 0.d0 + cz = 0.d0 + do ii = 1, nucl_num + expoii = j1b_gauss_pen(ii) + Centerii(1:3) = nucl_coord(ii, 1:3) + + call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center) + + fact_p = fact_p_tmp * factii + p_inv = 1.d0 / pp + + ! pol centerd on P_center_tmp ==> centerd on P_center + call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new) + + ! ---------------------------------------------------------------------------------------------------- + ! x term: + + ff = P_center(1) - Centerii(1) + + shift_P = (/ 2, 0, 0 /) + cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P = (/ 1, 0, 0 /) + cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 0, 0 /) + cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + ! ---------------------------------------------------------------------------------------------------- + ! y term: + + ff = P_center(2) - Centerii(2) + + shift_P = (/ 0, 2, 0 /) + cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 1, 0 /) + cy = cy + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 0, 0 /) + cy = cy + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + ! ---------------------------------------------------------------------------------------------------- + ! z term: + + ff = P_center(3) - Centerii(3) + + shift_P = (/ 0, 0, 2 /) + cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 0, 1 /) + cz = cz + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 0, 0 /) + cz = cz + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + enddo + + j1b_gauss_coul = j1b_gauss_coul + coef4 * ( cx + cy + cz ) + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + + ! ------------------------------------------------------------------------------------------------------------------- + ! + ! [ 1 / r12 ] \sum_A a_A [ (r2-RA)^2 exp(-aA r2A^2) + ! + ! ------------------------------------------------------------------------------------------------------------------- + + shift_P = (/ 0, 0, 0 /) + + do p = 1, ao_prim_num(i) + coef1 = ao_coef_normalized_ordered_transp(p, i) + expo1 = ao_expo_ordered_transp(p, i) + + do q = 1, ao_prim_num(j) + coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j) + expo2 = ao_expo_ordered_transp(q, j) + + call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 & + , 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) + expo3 = ao_expo_ordered_transp(r, k) + + do s = 1, ao_prim_num(l) + coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l) + expo4 = ao_expo_ordered_transp(s, l) + + call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 & + , K_power, L_power, K_center, L_center, dim1 ) + + cx = 0.d0 + cy = 0.d0 + cz = 0.d0 + do ii = 1, nucl_num + expoii = j1b_gauss_pen(ii) + Centerii(1:3) = nucl_coord(ii, 1:3) + + call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center) + + fact_q = fact_q_tmp * factii + q_inv = 1.d0 / qq + + ! pol centerd on Q_center_tmp ==> centerd on Q_center + call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new) + + ! ---------------------------------------------------------------------------------------------------- + ! x term: + + ff = Q_center(1) - Centerii(1) + + shift_Q = (/ 2, 0, 0 /) + cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_Q = (/ 1, 0, 0 /) + cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_Q = (/ 0, 0, 0 /) + cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + ! ---------------------------------------------------------------------------------------------------- + ! y term: + + ff = Q_center(2) - Centerii(2) + + shift_Q = (/ 0, 2, 0 /) + cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_Q = (/ 0, 1, 0 /) + cy = cy + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_Q = (/ 0, 0, 0 /) + cy = cy + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + ! ---------------------------------------------------------------------------------------------------- + ! z term: + + ff = Q_center(3) - Centerii(3) + + shift_Q = (/ 0, 0, 2 /) + cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_Q = (/ 0, 0, 1 /) + cz = cz + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_Q = (/ 0, 0, 0 /) + cz = cz + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + enddo + + j1b_gauss_coul = j1b_gauss_coul + coef4 * ( cx + cy + cz ) + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + + ! ------------------------------------------------------------------------------------------------------------------- + ! + ! - [ 1 / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) ] + ! + ! ------------------------------------------------------------------------------------------------------------------- + + do p = 1, ao_prim_num(i) + coef1 = ao_coef_normalized_ordered_transp(p, i) + expo1 = ao_expo_ordered_transp(p, i) + + do q = 1, ao_prim_num(j) + coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j) + expo2 = ao_expo_ordered_transp(q, j) + + call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 & + , I_power, J_power, I_center, J_center, dim1 ) + + do r = 1, ao_prim_num(k) + coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k) + expo3 = ao_expo_ordered_transp(r, k) + + do s = 1, ao_prim_num(l) + coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l) + expo4 = ao_expo_ordered_transp(s, l) + + call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 & + , K_power, L_power, K_center, L_center, dim1 ) + q_inv = 1.d0 / qq + + cx = 0.d0 + cy = 0.d0 + cz = 0.d0 + do ii = 1, nucl_num + expoii = j1b_gauss_pen(ii) + Centerii(1:3) = nucl_coord(ii, 1:3) + + call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center) + + fact_p = fact_p_tmp * factii + p_inv = 1.d0 / pp + + ! pol centerd on P_center_tmp ==> centerd on P_center + call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new) + + ! ---------------------------------------------------------------------------------------------------- + ! x term: + + ff = P_center(1) - Centerii(1) + gg = Q_center(1) - Centerii(1) + + shift_p = (/ 1, 0, 0 /) + shift_Q = (/ 1, 0, 0 /) + cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_p = (/ 1, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cx = cx + expoii * gg * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 1, 0, 0 /) + cx = cx + expoii * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cx = cx + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + ! ---------------------------------------------------------------------------------------------------- + ! y term: + + ff = P_center(2) - Centerii(2) + gg = Q_center(2) - Centerii(2) + + shift_p = (/ 0, 1, 0 /) + shift_Q = (/ 0, 1, 0 /) + cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 1, 0 /) + shift_Q = (/ 0, 0, 0 /) + cy = cy + expoii * gg * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 1, 0 /) + cy = cy + expoii * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cy = cy + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + ! ---------------------------------------------------------------------------------------------------- + ! z term: + + ff = P_center(3) - Centerii(3) + gg = Q_center(3) - Centerii(3) + + shift_p = (/ 0, 0, 1 /) + shift_Q = (/ 0, 0, 1 /) + cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 1 /) + shift_Q = (/ 0, 0, 0 /) + cz = cz + expoii * gg * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 1 /) + cz = cz + expoii * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cz = cz + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + enddo + + j1b_gauss_coul = j1b_gauss_coul - coef4 * ( cx + cy + cz ) + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + + + ! ------------------------------------------------------------------------------------------------------------------- + ! + ! - [ 1 / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ] + ! + ! ------------------------------------------------------------------------------------------------------------------- + + do p = 1, ao_prim_num(i) + coef1 = ao_coef_normalized_ordered_transp(p, i) + expo1 = ao_expo_ordered_transp(p, i) + + do q = 1, ao_prim_num(j) + coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j) + expo2 = ao_expo_ordered_transp(q, j) + + call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 & + , 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) + expo3 = ao_expo_ordered_transp(r, k) + + do s = 1, ao_prim_num(l) + coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l) + expo4 = ao_expo_ordered_transp(s, l) + + call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 & + , K_power, L_power, K_center, L_center, dim1 ) + + cx = 0.d0 + cy = 0.d0 + cz = 0.d0 + do ii = 1, nucl_num + expoii = j1b_gauss_pen(ii) + Centerii(1:3) = nucl_coord(ii, 1:3) + + call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center) + + fact_q = fact_q_tmp * factii + q_inv = 1.d0 / qq + + ! pol centerd on Q_center_tmp ==> centerd on Q_center + call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new) + + ! ---------------------------------------------------------------------------------------------------- + ! x term: + + ff = P_center(1) - Centerii(1) + gg = Q_center(1) - Centerii(1) + + shift_p = (/ 1, 0, 0 /) + shift_Q = (/ 1, 0, 0 /) + cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_p = (/ 1, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cx = cx + expoii * gg * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 1, 0, 0 /) + cx = cx + expoii * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cx = cx + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + ! ---------------------------------------------------------------------------------------------------- + ! y term: + + ff = P_center(2) - Centerii(2) + gg = Q_center(2) - Centerii(2) + + shift_p = (/ 0, 1, 0 /) + shift_Q = (/ 0, 1, 0 /) + cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 1, 0 /) + shift_Q = (/ 0, 0, 0 /) + cy = cy + expoii * gg * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 1, 0 /) + cy = cy + expoii * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cy = cy + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + ! ---------------------------------------------------------------------------------------------------- + ! z term: + + ff = P_center(3) - Centerii(3) + gg = Q_center(3) - Centerii(3) + + shift_p = (/ 0, 0, 1 /) + shift_Q = (/ 0, 0, 1 /) + cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 1 /) + shift_Q = (/ 0, 0, 0 /) + cz = cz + expoii * gg * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 1 /) + cz = cz + expoii * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cz = cz + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + enddo + + j1b_gauss_coul = j1b_gauss_coul - coef4 * ( cx + cy + cz ) + + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + return +end function j1b_gauss_coul + + + + +!______________________________________________________________________________________________________________________ +!______________________________________________________________________________________________________________________ + +double precision function general_primitive_integral_coul_shifted( dim & + , P_new, P_center, fact_p, p, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, q, q_inv, iorder_q, shift_Q ) + + include 'utils/constants.include.F' + + implicit none + + integer, intent(in) :: dim + integer, intent(in) :: iorder_p(3), shift_P(3) + integer, intent(in) :: iorder_q(3), shift_Q(3) + double precision, intent(in) :: P_new(0:max_dim,3), P_center(3), fact_p, p, p_inv + double precision, intent(in) :: Q_new(0:max_dim,3), Q_center(3), fact_q, q, q_inv + + integer :: n_Ix, n_Iy, n_Iz, nx, ny, nz + integer :: ix, iy, iz, jx, jy, jz, i + integer :: n_pt_tmp, n_pt_out, iorder + integer :: ii, jj + double precision :: rho, dist + double precision :: dx(0:max_dim), Ix_pol(0:max_dim) + double precision :: dy(0:max_dim), Iy_pol(0:max_dim) + double precision :: dz(0:max_dim), Iz_pol(0:max_dim) + double precision :: a, b, c, d, e, f, accu, pq, const + double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2, pq_inv_2 + double precision :: d1(0:max_dim), d_poly(0:max_dim) + double precision :: p_plus_q + + double precision :: rint_sum + + general_primitive_integral_coul_shifted = 0.d0 + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx, Ix_pol, dy, Iy_pol, dz, Iz_pol + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly + + ! Gaussian Product + ! ---------------- + p_plus_q = (p+q) + pq = p_inv * 0.5d0 * q_inv + pq_inv = 0.5d0 / p_plus_q + p10_1 = q * pq ! 1/(2p) + p01_1 = p * pq ! 1/(2q) + pq_inv_2 = pq_inv + pq_inv + p10_2 = pq_inv_2 * p10_1 * q ! 0.5d0 * q / (pq + p*p) + p01_2 = pq_inv_2 * p01_1 * p ! 0.5d0 * p / (q*q + pq) + + accu = 0.d0 + + iorder = iorder_p(1) + iorder_q(1) + iorder_p(1) + iorder_q(1) + iorder = iorder + shift_P(1) + shift_Q(1) + iorder = iorder + shift_P(1) + shift_Q(1) + !DIR$ VECTOR ALIGNED + do ix = 0, iorder + Ix_pol(ix) = 0.d0 + enddo + n_Ix = 0 + do ix = 0, iorder_p(1) + + ii = ix + shift_P(1) + a = P_new(ix,1) + if(abs(a) < thresh) cycle + + do jx = 0, iorder_q(1) + + jj = jx + shift_Q(1) + d = a * Q_new(jx,1) + if(abs(d) < thresh) cycle + + !DEC$ FORCEINLINE + call give_polynom_mult_center_x( P_center(1), Q_center(1), ii, jj & + , p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dx, nx ) + !DEC$ FORCEINLINE + call add_poly_multiply(dx, nx, d, Ix_pol, n_Ix) + enddo + enddo + if(n_Ix == -1) then + return + endif + + iorder = iorder_p(2) + iorder_q(2) + iorder_p(2) + iorder_q(2) + iorder = iorder + shift_P(2) + shift_Q(2) + iorder = iorder + shift_P(2) + shift_Q(2) + !DIR$ VECTOR ALIGNED + do ix = 0, iorder + Iy_pol(ix) = 0.d0 + enddo + n_Iy = 0 + do iy = 0, iorder_p(2) + + if(abs(P_new(iy,2)) > thresh) then + + ii = iy + shift_P(2) + b = P_new(iy,2) + + do jy = 0, iorder_q(2) + + jj = jy + shift_Q(2) + e = b * Q_new(jy,2) + if(abs(e) < thresh) cycle + + !DEC$ FORCEINLINE + call give_polynom_mult_center_x( P_center(2), Q_center(2), ii, jj & + , p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dy, ny ) + !DEC$ FORCEINLINE + call add_poly_multiply(dy, ny, e, Iy_pol, n_Iy) + enddo + endif + enddo + if(n_Iy == -1) then + return + endif + + iorder = iorder_p(3) + iorder_q(3) + iorder_p(3) + iorder_q(3) + iorder = iorder + shift_P(3) + shift_Q(3) + iorder = iorder + shift_P(3) + shift_Q(3) + do ix = 0, iorder + Iz_pol(ix) = 0.d0 + enddo + n_Iz = 0 + do iz = 0, iorder_p(3) + + if( abs(P_new(iz,3)) > thresh ) then + + ii = iz + shift_P(3) + c = P_new(iz,3) + + do jz = 0, iorder_q(3) + + jj = jz + shift_Q(3) + f = c * Q_new(jz,3) + if(abs(f) < thresh) cycle + + !DEC$ FORCEINLINE + call give_polynom_mult_center_x( P_center(3), Q_center(3), ii, jj & + , p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dz, nz ) + !DEC$ FORCEINLINE + call add_poly_multiply(dz, nz, f, Iz_pol, n_Iz) + enddo + endif + enddo + if(n_Iz == -1) then + return + endif + + rho = p * q * pq_inv_2 + dist = (P_center(1) - Q_center(1)) * (P_center(1) - Q_center(1)) & + + (P_center(2) - Q_center(2)) * (P_center(2) - Q_center(2)) & + + (P_center(3) - Q_center(3)) * (P_center(3) - Q_center(3)) + const = dist*rho + + n_pt_tmp = n_Ix + n_Iy + do i = 0, n_pt_tmp + d_poly(i) = 0.d0 + enddo + + !DEC$ FORCEINLINE + call multiply_poly(Ix_pol, n_Ix, Iy_pol, n_Iy, d_poly, n_pt_tmp) + if(n_pt_tmp == -1) then + return + endif + n_pt_out = n_pt_tmp + n_Iz + do i = 0, n_pt_out + d1(i) = 0.d0 + enddo + + !DEC$ FORCEINLINE + call multiply_poly(d_poly, n_pt_tmp, Iz_pol, n_Iz, d1, n_pt_out) + accu = accu + rint_sum(n_pt_out, const, d1) + + general_primitive_integral_coul_shifted = fact_p * fact_q * accu * pi_5_2 * p_inv * q_inv / dsqrt(p_plus_q) + + return +end function general_primitive_integral_coul_shifted +!______________________________________________________________________________________________________________________ +!______________________________________________________________________________________________________________________ diff --git a/src/ao_tc_eff_map/two_e_1bgauss_coul_acc.irp.f b/src/ao_tc_eff_map/two_e_1bgauss_coul_acc.irp.f new file mode 100644 index 00000000..cee9183c --- /dev/null +++ b/src/ao_tc_eff_map/two_e_1bgauss_coul_acc.irp.f @@ -0,0 +1,433 @@ +double precision function j1b_gauss_coul_acc(i, j, k, l) + + BEGIN_DOC + ! + ! integral in the AO basis: + ! i(r1) j(r1) f(r12) k(r2) l(r2) + ! + ! with: + ! f(r12) = - [ 0.5 / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ] + ! = [ 1 / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2) + ! + (r2-RA)^2 exp(-aA r2A^2) + ! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) + ! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ] + ! + END_DOC + + include 'utils/constants.include.F' + + implicit none + + integer, intent(in) :: i, j, k, l + + integer :: p, q, r, s, ii + integer :: num_i, num_j, num_k, num_l, num_ii + integer :: I_power(3), J_power(3), K_power(3), L_power(3) + integer :: iorder_p(3), iorder_q(3) + integer :: shift_P(3), shift_Q(3) + integer :: dim1 + + double precision :: coef1, coef2, coef3, coef4 + double precision :: expo1, expo2, expo3, expo4 + double precision :: p1_inv, q1_inv, p2_inv, q2_inv + double precision :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1 + double precision :: P2_new(0:max_dim,3), P2_center(3), fact_p2, pp2 + double precision :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1 + double precision :: Q2_new(0:max_dim,3), Q2_center(3), fact_q2, qq2 + double precision :: I_center(3), J_center(3), K_center(3), L_center(3) + double precision :: expoii, factii, Centerii(3) + double precision :: ff, gg, cx, cy, cz + + double precision :: general_primitive_integral_coul_shifted + !double precision :: j1b_gauss_coul_schwartz_accel + + PROVIDE j1b_gauss_pen + + dim1 = n_pt_max_integrals + + ! TODO + !if( ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then + ! j1b_gauss_coul_schwartz_accel = j1b_gauss_coul_schwartz_accel(i, j, k, l) + ! return + !endif + + num_i = ao_nucl(i) + num_j = ao_nucl(j) + num_k = ao_nucl(k) + num_l = ao_nucl(l) + + 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 + + j1b_gauss_coul_acc = 0.d0 + + do p = 1, ao_prim_num(i) + coef1 = ao_coef_normalized_ordered_transp(p, i) + expo1 = ao_expo_ordered_transp(p, i) + + do q = 1, ao_prim_num(j) + coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j) + expo2 = ao_expo_ordered_transp(q, j) + + call give_explicit_poly_and_gaussian( P1_new, P1_center, pp1, fact_p1, iorder_p, expo1, expo2 & + , I_power, J_power, I_center, J_center, dim1 ) + p1_inv = 1.d0 / pp1 + + do r = 1, ao_prim_num(k) + coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k) + expo3 = ao_expo_ordered_transp(r, k) + + do s = 1, ao_prim_num(l) + coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l) + expo4 = ao_expo_ordered_transp(s, l) + + call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 & + , K_power, L_power, K_center, L_center, dim1 ) + q1_inv = 1.d0 / qq1 + + cx = 0.d0 + cy = 0.d0 + cz = 0.d0 + do ii = 1, nucl_num + expoii = j1b_gauss_pen(ii) + Centerii(1:3) = nucl_coord(ii, 1:3) + + call gaussian_product(pp1, P1_center, expoii, Centerii, factii, pp2, P2_center) + fact_p2 = fact_p1 * factii + p2_inv = 1.d0 / pp2 + call pol_modif_center( P1_center, P2_center, iorder_p, P1_new, P2_new) + + call gaussian_product(qq1, Q1_center, expoii, Centerii, factii, qq2, Q2_center) + fact_q2 = fact_q1 * factii + q2_inv = 1.d0 / qq2 + call pol_modif_center( Q1_center, Q2_center, iorder_q, Q1_new, Q2_new) + + + ! ---------------------------------------------------------------------------------------------------- + ! [ 1 / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2) + ! ---------------------------------------------------------------------------------------------------- + + shift_Q = (/ 0, 0, 0 /) + + ! x term: + ff = P2_center(1) - Centerii(1) + + shift_P = (/ 2, 0, 0 /) + cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_P = (/ 1, 0, 0 /) + cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 0, 0 /) + cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + ! y term: + ff = P2_center(2) - Centerii(2) + + shift_P = (/ 0, 2, 0 /) + cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 1, 0 /) + cy = cy + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 0, 0 /) + cy = cy + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + ! z term: + ff = P2_center(3) - Centerii(3) + + shift_P = (/ 0, 0, 2 /) + cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 0, 1 /) + cz = cz + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 0, 0 /) + cz = cz + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + + + ! ---------------------------------------------------------------------------------------------------- + ! [ 1 / r12 ] \sum_A a_A [ (r2-RA)^2 exp(-aA r2A^2) + ! ---------------------------------------------------------------------------------------------------- + + shift_P = (/ 0, 0, 0 /) + + ! x term: + ff = Q2_center(1) - Centerii(1) + + shift_Q = (/ 2, 0, 0 /) + cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_Q = (/ 1, 0, 0 /) + cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_Q = (/ 0, 0, 0 /) + cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + ! y term: + ff = Q2_center(2) - Centerii(2) + + shift_Q = (/ 0, 2, 0 /) + cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_Q = (/ 0, 1, 0 /) + cy = cy + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_Q = (/ 0, 0, 0 /) + cy = cy + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + ! z term: + ff = Q2_center(3) - Centerii(3) + + shift_Q = (/ 0, 0, 2 /) + cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_Q = (/ 0, 0, 1 /) + cz = cz + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_Q = (/ 0, 0, 0 /) + cz = cz + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + + + ! ---------------------------------------------------------------------------------------------------- + ! - [ 1 / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) ] + ! ---------------------------------------------------------------------------------------------------- + + ! x term: + ff = P2_center(1) - Centerii(1) + gg = Q1_center(1) - Centerii(1) + + shift_p = (/ 1, 0, 0 /) + shift_Q = (/ 1, 0, 0 /) + cx = cx - expoii * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 1, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cx = cx - expoii * gg * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 1, 0, 0 /) + cx = cx - expoii * ff * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cx = cx - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + ! y term: + ff = P2_center(2) - Centerii(2) + gg = Q1_center(2) - Centerii(2) + + shift_p = (/ 0, 1, 0 /) + shift_Q = (/ 0, 1, 0 /) + cy = cy - expoii * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 1, 0 /) + shift_Q = (/ 0, 0, 0 /) + cy = cy - expoii * gg * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 1, 0 /) + cy = cy - expoii * ff * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cy = cy - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + ! z term: + ff = P2_center(3) - Centerii(3) + gg = Q1_center(3) - Centerii(3) + + shift_p = (/ 0, 0, 1 /) + shift_Q = (/ 0, 0, 1 /) + cz = cz - expoii * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 1 /) + shift_Q = (/ 0, 0, 0 /) + cz = cz - expoii * gg * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 1 /) + cz = cz - expoii * ff * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cz = cz - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + + + ! ---------------------------------------------------------------------------------------------------- + ! - [ 1 / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ] + ! ---------------------------------------------------------------------------------------------------- + + ! x term: + ff = P1_center(1) - Centerii(1) + gg = Q2_center(1) - Centerii(1) + + shift_p = (/ 1, 0, 0 /) + shift_Q = (/ 1, 0, 0 /) + cx = cx - expoii * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 1, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cx = cx - expoii * gg * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 1, 0, 0 /) + cx = cx - expoii * ff * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cx = cx - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + ! y term: + ff = P1_center(2) - Centerii(2) + gg = Q2_center(2) - Centerii(2) + + shift_p = (/ 0, 1, 0 /) + shift_Q = (/ 0, 1, 0 /) + cy = cy - expoii * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 1, 0 /) + shift_Q = (/ 0, 0, 0 /) + cy = cy - expoii * gg * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 1, 0 /) + cy = cy - expoii * ff * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cy = cy - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + ! z term: + ff = P1_center(3) - Centerii(3) + gg = Q2_center(3) - Centerii(3) + + shift_p = (/ 0, 0, 1 /) + shift_Q = (/ 0, 0, 1 /) + cz = cz - expoii * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 1 /) + shift_Q = (/ 0, 0, 0 /) + cz = cz - expoii * gg * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 1 /) + cz = cz - expoii * ff * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cz = cz - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + enddo + + j1b_gauss_coul_acc = j1b_gauss_coul_acc + coef4 * ( cx + cy + cz ) + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + return +end function j1b_gauss_coul_acc diff --git a/src/ao_tc_eff_map/two_e_1bgauss_coul_debug.irp.f b/src/ao_tc_eff_map/two_e_1bgauss_coul_debug.irp.f new file mode 100644 index 00000000..8ced59e4 --- /dev/null +++ b/src/ao_tc_eff_map/two_e_1bgauss_coul_debug.irp.f @@ -0,0 +1,397 @@ +double precision function j1b_gauss_coul_debug(i, j, k, l) + + BEGIN_DOC + ! + ! integral in the AO basis: + ! i(r1) j(r1) f(r12) k(r2) l(r2) + ! + ! with: + ! f(r12) = - [ 0.5 / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ] + ! = [ 1 / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2) + ! + (r2-RA)^2 exp(-aA r2A^2) + ! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) + ! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ] + ! + END_DOC + + include 'utils/constants.include.F' + + implicit none + + integer, intent(in) :: i, j, k, l + + integer :: p, q, r, s, ii + integer :: num_i, num_j, num_k, num_l, num_ii + integer :: I_power(3), J_power(3), K_power(3), L_power(3) + integer :: iorder_p(3), iorder_q(3) + integer :: shift_P(3), shift_Q(3) + integer :: dim1 + + double precision :: coef1, coef2, coef3, coef4 + double precision :: expo1, expo2, expo3, expo4 + double precision :: p_inv, q_inv + double precision :: P_new_tmp(0:max_dim,3), P_center_tmp(3), fact_p_tmp, pp_tmp + double precision :: Q_new_tmp(0:max_dim,3), Q_center_tmp(3), fact_q_tmp, qq_tmp + 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 + double precision :: I_center(3), J_center(3), K_center(3), L_center(3) + double precision :: expoii, factii, Centerii(3) + double precision :: ff, gg, cx, cy, cz + + double precision :: general_primitive_integral_coul_shifted + + PROVIDE j1b_gauss_pen + + 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) + + 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 + + j1b_gauss_coul_debug = 0.d0 + + + ! ------------------------------------------------------------------------------------------------------------------- + ! + ! [ 1 / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2) + ! + ! ------------------------------------------------------------------------------------------------------------------- + + shift_Q = (/ 0, 0, 0 /) + + do p = 1, ao_prim_num(i) + coef1 = ao_coef_normalized_ordered_transp(p, i) + expo1 = ao_expo_ordered_transp(p, i) + + do q = 1, ao_prim_num(j) + coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j) + expo2 = ao_expo_ordered_transp(q, j) + + call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 & + , I_power, J_power, I_center, J_center, dim1 ) + + do r = 1, ao_prim_num(k) + coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k) + expo3 = ao_expo_ordered_transp(r, k) + + do s = 1, ao_prim_num(l) + coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l) + expo4 = ao_expo_ordered_transp(s, l) + + call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 & + , K_power, L_power, K_center, L_center, dim1 ) + q_inv = 1.d0 / qq + + cx = 0.d0 + do ii = 1, nucl_num + expoii = j1b_gauss_pen(ii) + Centerii(1:3) = nucl_coord(ii, 1:3) + + call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center) + + fact_p = fact_p_tmp * factii + p_inv = 1.d0 / pp + + ! pol centerd on P_center_tmp ==> centerd on P_center + call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new) + + ! ---------------------------------------------------------------------------------------------------- + ! x term: + + ff = P_center(1) - Centerii(1) + + shift_P = (/ 2, 0, 0 /) + cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P = (/ 1, 0, 0 /) + cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 0, 0 /) + cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + enddo + + j1b_gauss_coul_debug = j1b_gauss_coul_debug + coef4 * cx + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + +! ! ------------------------------------------------------------------------------------------------------------------- +! ! +! ! [ 1 / r12 ] \sum_A a_A [ (r2-RA)^2 exp(-aA r2A^2) +! ! +! ! ------------------------------------------------------------------------------------------------------------------- +! +! shift_P = (/ 0, 0, 0 /) +! +! do p = 1, ao_prim_num(i) +! coef1 = ao_coef_normalized_ordered_transp(p, i) +! expo1 = ao_expo_ordered_transp(p, i) +! +! do q = 1, ao_prim_num(j) +! coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j) +! expo2 = ao_expo_ordered_transp(q, j) +! +! call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 & +! , 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) +! expo3 = ao_expo_ordered_transp(r, k) +! +! do s = 1, ao_prim_num(l) +! coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l) +! expo4 = ao_expo_ordered_transp(s, l) +! +! call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 & +! , K_power, L_power, K_center, L_center, dim1 ) +! +! cx = 0.d0 +! do ii = 1, nucl_num +! expoii = j1b_gauss_pen(ii) +! Centerii(1:3) = nucl_coord(ii, 1:3) +! +! call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center) +! +! fact_q = fact_q_tmp * factii +! q_inv = 1.d0 / qq +! +! ! pol centerd on Q_center_tmp ==> centerd on Q_center +! call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new) +! +! ! ---------------------------------------------------------------------------------------------------- +! ! x term: +! +! ff = Q_center(1) - Centerii(1) +! +! shift_Q = (/ 2, 0, 0 /) +! cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 & +! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & +! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) +! +! shift_Q = (/ 1, 0, 0 /) +! cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 & +! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & +! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) +! +! shift_Q = (/ 0, 0, 0 /) +! cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 & +! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & +! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) +! +! ! ---------------------------------------------------------------------------------------------------- +! +! enddo +! +! j1b_gauss_coul_debug = j1b_gauss_coul_debug + coef4 * cx +! enddo ! s +! enddo ! r +! enddo ! q +! enddo ! p +! +! ! ------------------------------------------------------------------------------------------------------------------- +! ! ------------------------------------------------------------------------------------------------------------------- + + + ! ------------------------------------------------------------------------------------------------------------------- + ! + ! - [ 1 / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) ] + ! + ! ------------------------------------------------------------------------------------------------------------------- + + do p = 1, ao_prim_num(i) + coef1 = ao_coef_normalized_ordered_transp(p, i) + expo1 = ao_expo_ordered_transp(p, i) + + do q = 1, ao_prim_num(j) + coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j) + expo2 = ao_expo_ordered_transp(q, j) + + call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 & + , I_power, J_power, I_center, J_center, dim1 ) + + do r = 1, ao_prim_num(k) + coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k) + expo3 = ao_expo_ordered_transp(r, k) + + do s = 1, ao_prim_num(l) + coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l) + expo4 = ao_expo_ordered_transp(s, l) + + call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 & + , K_power, L_power, K_center, L_center, dim1 ) + q_inv = 1.d0 / qq + + cx = 0.d0 + do ii = 1, nucl_num + expoii = j1b_gauss_pen(ii) + Centerii(1:3) = nucl_coord(ii, 1:3) + + call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center) + + fact_p = fact_p_tmp * factii + p_inv = 1.d0 / pp + + ! pol centerd on P_center_tmp ==> centerd on P_center + call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new) + + ! ---------------------------------------------------------------------------------------------------- + ! x term: + + ff = P_center(1) - Centerii(1) + gg = Q_center(1) - Centerii(1) + + shift_P = (/ 1, 0, 0 /) + shift_Q = (/ 1, 0, 0 /) + cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P = (/ 1, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cx = cx + expoii * gg * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 0, 0 /) + shift_Q = (/ 1, 0, 0 /) + cx = cx + expoii * ff * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cx = cx + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + enddo + + j1b_gauss_coul_debug = j1b_gauss_coul_debug - coef4 * cx + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + + +! ! ------------------------------------------------------------------------------------------------------------------- +! ! +! ! - [ 1 / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ] +! ! +! ! ------------------------------------------------------------------------------------------------------------------- +! +! do p = 1, ao_prim_num(i) +! coef1 = ao_coef_normalized_ordered_transp(p, i) +! expo1 = ao_expo_ordered_transp(p, i) +! +! do q = 1, ao_prim_num(j) +! coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j) +! expo2 = ao_expo_ordered_transp(q, j) +! +! call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 & +! , 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) +! expo3 = ao_expo_ordered_transp(r, k) +! +! do s = 1, ao_prim_num(l) +! coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l) +! expo4 = ao_expo_ordered_transp(s, l) +! +! call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 & +! , K_power, L_power, K_center, L_center, dim1 ) +! +! cx = 0.d0 +! do ii = 1, nucl_num +! expoii = j1b_gauss_pen(ii) +! Centerii(1:3) = nucl_coord(ii, 1:3) +! +! call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center) +! +! fact_q = fact_q_tmp * factii +! q_inv = 1.d0 / qq +! +! ! pol centerd on Q_center_tmp ==> centerd on Q_center +! call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new) +! +! ! ---------------------------------------------------------------------------------------------------- +! ! x term: +! +! ff = P_center(1) - Centerii(1) +! gg = Q_center(1) - Centerii(1) +! +! shift_P = (/ 1, 0, 0 /) +! shift_Q = (/ 1, 0, 0 /) +! cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 & +! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & +! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) +! +! shift_P = (/ 1, 0, 0 /) +! shift_Q = (/ 0, 0, 0 /) +! cx = cx + expoii * gg * general_primitive_integral_coul_shifted( dim1 & +! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & +! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) +! +! shift_P = (/ 0, 0, 0 /) +! shift_Q = (/ 1, 0, 0 /) +! cx = cx + expoii * ff * general_primitive_integral_coul_shifted( dim1 & +! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & +! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) +! +! shift_P = (/ 0, 0, 0 /) +! shift_Q = (/ 0, 0, 0 /) +! cx = cx + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 & +! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & +! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) +! +! ! ---------------------------------------------------------------------------------------------------- +! +! enddo +! +! j1b_gauss_coul_debug = j1b_gauss_coul_debug - coef4 * cx +! +! enddo ! s +! enddo ! r +! enddo ! q +! enddo ! p +! +! ! ------------------------------------------------------------------------------------------------------------------- +! ! ------------------------------------------------------------------------------------------------------------------- + + return +end function j1b_gauss_coul_debug + diff --git a/src/ao_tc_eff_map/two_e_1bgauss_coul_modifdebug.irp.f b/src/ao_tc_eff_map/two_e_1bgauss_coul_modifdebug.irp.f new file mode 100644 index 00000000..753fff8f --- /dev/null +++ b/src/ao_tc_eff_map/two_e_1bgauss_coul_modifdebug.irp.f @@ -0,0 +1,324 @@ +double precision function j1b_gauss_coul_modifdebug(i, j, k, l) + + include 'utils/constants.include.F' + + implicit none + + integer, intent(in) :: i, j, k, l + + integer :: p, q, r, s, ii + integer :: num_i, num_j, num_k, num_l, num_ii + integer :: I_power(3), J_power(3), K_power(3), L_power(3) + integer :: iorder_p(3), iorder_q(3) + integer :: shift_P(3), shift_Q(3) + integer :: dim1 + + double precision :: coef1, coef2, coef3, coef4 + double precision :: expo1, expo2, expo3, expo4 + double precision :: p_inv, q_inv + double precision :: P_new_tmp(0:max_dim,3), P_center_tmp(3), fact_p_tmp, pp_tmp + double precision :: Q_new_tmp(0:max_dim,3), Q_center_tmp(3), fact_q_tmp, qq_tmp + 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 + double precision :: I_center(3), J_center(3), K_center(3), L_center(3) + double precision :: expoii, factii, Centerii(3) + double precision :: ff, gg, cx, cy, cz + + double precision :: general_primitive_integral_coul + double precision :: general_primitive_integral_coul_shifted + double precision :: ao_two_e_integral + + PROVIDE j1b_gauss_pen + + 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) + + 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 + + j1b_gauss_coul_modifdebug = 0.d0 + +! do ii = 1, nucl_num +! expoii = j1b_gauss_pen(ii) +! j1b_gauss_coul_modifdebug += expoii * ao_two_e_integral(i, j, k, l) +! enddo + + + ! ------------------------------------------------------------------------------------------------------------------- + ! + ! [ 1 / r12 ] \sum_A a_A exp(-aA r1A^2) + ! + ! ------------------------------------------------------------------------------------------------------------------- + + shift_P = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + + do p = 1, ao_prim_num(i) + coef1 = ao_coef_normalized_ordered_transp(p, i) + expo1 = ao_expo_ordered_transp(p, i) + + do q = 1, ao_prim_num(j) + coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j) + expo2 = ao_expo_ordered_transp(q, j) + + call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 & + , I_power, J_power, I_center, J_center, dim1 ) + + do r = 1, ao_prim_num(k) + coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k) + expo3 = ao_expo_ordered_transp(r, k) + + do s = 1, ao_prim_num(l) + coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l) + expo4 = ao_expo_ordered_transp(s, l) + + call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 & + , K_power, L_power, K_center, L_center, dim1 ) + q_inv = 1.d0 / qq + + cx = 0.d0 + do ii = 1, nucl_num + expoii = j1b_gauss_pen(ii) + Centerii(1:3) = nucl_coord(ii, 1:3) + + call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center) + fact_p = fact_p_tmp * factii + p_inv = 1.d0 / pp + P_new(:,:) = 0.d0 + call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new) + + ! ---------------------------------------------------------------------------------------------------- + ! x term: + + cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + enddo + + j1b_gauss_coul_modifdebug = j1b_gauss_coul_modifdebug + coef4 * cx + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + + ! ------------------------------------------------------------------------------------------------------------------- + ! + ! [ 1 / r12 ] \sum_A a_A exp(-aA r2A^2) + ! + ! ------------------------------------------------------------------------------------------------------------------- + + shift_P = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + + do p = 1, ao_prim_num(i) + coef1 = ao_coef_normalized_ordered_transp(p, i) + expo1 = ao_expo_ordered_transp(p, i) + + do q = 1, ao_prim_num(j) + coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j) + expo2 = ao_expo_ordered_transp(q, j) + + call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 & + , 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) + expo3 = ao_expo_ordered_transp(r, k) + + do s = 1, ao_prim_num(l) + coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l) + expo4 = ao_expo_ordered_transp(s, l) + + call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 & + , K_power, L_power, K_center, L_center, dim1 ) + + cx = 0.d0 + do ii = 1, nucl_num + expoii = j1b_gauss_pen(ii) + Centerii(1:3) = nucl_coord(ii, 1:3) + + call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center) + fact_q = fact_q_tmp * factii + Q_inv = 1.d0 / qq + call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new) + + ! ---------------------------------------------------------------------------------------------------- + ! x term: + + cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + enddo + + j1b_gauss_coul_modifdebug = j1b_gauss_coul_modifdebug + coef4 * cx + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + return +end function j1b_gauss_coul_modifdebug + + + + +double precision function general_primitive_integral_coul(dim, & + P_new,P_center,fact_p,p,p_inv,iorder_p, & + Q_new,Q_center,fact_q,q,q_inv,iorder_q) + implicit none + BEGIN_DOC + ! Computes the integral where p,q,r,s are Gaussian primitives + END_DOC + integer,intent(in) :: dim + include 'utils/constants.include.F' + double precision, intent(in) :: P_new(0:max_dim,3),P_center(3),fact_p,p,p_inv + double precision, intent(in) :: Q_new(0:max_dim,3),Q_center(3),fact_q,q,q_inv + integer, intent(in) :: iorder_p(3) + integer, intent(in) :: iorder_q(3) + + double precision :: r_cut,gama_r_cut,rho,dist + double precision :: dx(0:max_dim),Ix_pol(0:max_dim),dy(0:max_dim),Iy_pol(0:max_dim),dz(0:max_dim),Iz_pol(0:max_dim) + integer :: n_Ix,n_Iy,n_Iz,nx,ny,nz + double precision :: bla + integer :: ix,iy,iz,jx,jy,jz,i + double precision :: a,b,c,d,e,f,accu,pq,const + double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2,pq_inv_2 + integer :: n_pt_tmp,n_pt_out, iorder + double precision :: d1(0:max_dim),d_poly(0:max_dim),rint,d1_screened(0:max_dim) + + general_primitive_integral_coul = 0.d0 + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx,Ix_pol,dy,Iy_pol,dz,Iz_pol + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly + + ! Gaussian Product + ! ---------------- + + pq = p_inv*0.5d0*q_inv + pq_inv = 0.5d0/(p+q) + p10_1 = q*pq ! 1/(2p) + p01_1 = p*pq ! 1/(2q) + pq_inv_2 = pq_inv+pq_inv + p10_2 = pq_inv_2 * p10_1*q !0.5d0*q/(pq + p*p) + p01_2 = pq_inv_2 * p01_1*p !0.5d0*p/(q*q + pq) + + + accu = 0.d0 + iorder = iorder_p(1)+iorder_q(1)+iorder_p(1)+iorder_q(1) + do ix=0,iorder + Ix_pol(ix) = 0.d0 + enddo + n_Ix = 0 + do ix = 0, iorder_p(1) + if (abs(P_new(ix,1)) < thresh) cycle + a = P_new(ix,1) + do jx = 0, iorder_q(1) + d = a*Q_new(jx,1) + if (abs(d) < thresh) cycle + !DIR$ FORCEINLINE + call give_polynom_mult_center_x(P_center(1),Q_center(1),ix,jx,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dx,nx) + !DIR$ FORCEINLINE + call add_poly_multiply(dx,nx,d,Ix_pol,n_Ix) + enddo + enddo + if (n_Ix == -1) then + return + endif + iorder = iorder_p(2)+iorder_q(2)+iorder_p(2)+iorder_q(2) + do ix=0, iorder + Iy_pol(ix) = 0.d0 + enddo + n_Iy = 0 + do iy = 0, iorder_p(2) + if (abs(P_new(iy,2)) > thresh) then + b = P_new(iy,2) + do jy = 0, iorder_q(2) + e = b*Q_new(jy,2) + if (abs(e) < thresh) cycle + !DIR$ FORCEINLINE + call give_polynom_mult_center_x(P_center(2),Q_center(2),iy,jy,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dy,ny) + !DIR$ FORCEINLINE + call add_poly_multiply(dy,ny,e,Iy_pol,n_Iy) + enddo + endif + enddo + if (n_Iy == -1) then + return + endif + + iorder = iorder_p(3)+iorder_q(3)+iorder_p(3)+iorder_q(3) + do ix=0,iorder + Iz_pol(ix) = 0.d0 + enddo + n_Iz = 0 + do iz = 0, iorder_p(3) + if (abs(P_new(iz,3)) > thresh) then + c = P_new(iz,3) + do jz = 0, iorder_q(3) + f = c*Q_new(jz,3) + if (abs(f) < thresh) cycle + !DIR$ FORCEINLINE + call give_polynom_mult_center_x(P_center(3),Q_center(3),iz,jz,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dz,nz) + !DIR$ FORCEINLINE + call add_poly_multiply(dz,nz,f,Iz_pol,n_Iz) + enddo + endif + enddo + if (n_Iz == -1) then + return + endif + + rho = p*q *pq_inv_2 + dist = (P_center(1) - Q_center(1))*(P_center(1) - Q_center(1)) + & + (P_center(2) - Q_center(2))*(P_center(2) - Q_center(2)) + & + (P_center(3) - Q_center(3))*(P_center(3) - Q_center(3)) + const = dist*rho + + n_pt_tmp = n_Ix+n_Iy + do i=0,n_pt_tmp + d_poly(i)=0.d0 + enddo + + !DIR$ FORCEINLINE + call multiply_poly(Ix_pol,n_Ix,Iy_pol,n_Iy,d_poly,n_pt_tmp) + if (n_pt_tmp == -1) then + return + endif + n_pt_out = n_pt_tmp+n_Iz + do i=0,n_pt_out + d1(i)=0.d0 + enddo + + !DIR$ FORCEINLINE + call multiply_poly(d_poly ,n_pt_tmp ,Iz_pol,n_Iz,d1,n_pt_out) + double precision :: rint_sum + accu = accu + rint_sum(n_pt_out,const,d1) + + general_primitive_integral_coul = fact_p * fact_q * accu *pi_5_2*p_inv*q_inv/dsqrt(p+q) +end function general_primitive_integral_coul diff --git a/src/ao_tc_eff_map/two_e_1bgauss_coulerf.irp.f b/src/ao_tc_eff_map/two_e_1bgauss_coulerf.irp.f new file mode 100644 index 00000000..92512bd7 --- /dev/null +++ b/src/ao_tc_eff_map/two_e_1bgauss_coulerf.irp.f @@ -0,0 +1,102 @@ +double precision function j1b_gauss_coulerf(i, j, k, l) + + BEGIN_DOC + ! + ! integral in the AO basis: + ! i(r1) j(r1) f(r12) k(r2) l(r2) + ! + ! with: + ! f(r12) = - [ (0.5 - 0.5 erf(mu r12)) / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ] + ! = [ (1 - erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2) + ! + (r2-RA)^2 exp(-aA r2A^2) + ! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) + ! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ] + ! + END_DOC + + include 'utils/constants.include.F' + + implicit none + + integer, intent(in) :: i, j, k, l + + integer :: p, q, r, s + integer :: num_i, num_j, num_k, num_l, num_ii + integer :: I_power(3), J_power(3), K_power(3), L_power(3) + integer :: iorder_p(3), iorder_q(3) + integer :: shift_P(3), shift_Q(3) + integer :: dim1 + + double precision :: coef1, coef2, coef3, coef4 + double precision :: expo1, expo2, expo3, expo4 + double precision :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1, p1_inv + double precision :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1, q1_inv + double precision :: I_center(3), J_center(3), K_center(3), L_center(3) + double precision :: ff, gg, cx, cy, cz + + double precision :: j1b_gauss_coulerf_schwartz + + PROVIDE j1b_gauss_pen + + dim1 = n_pt_max_integrals + + if( ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then + j1b_gauss_coulerf = j1b_gauss_coulerf_schwartz(i, j, k, l) + return + endif + + num_i = ao_nucl(i) + num_j = ao_nucl(j) + num_k = ao_nucl(k) + num_l = ao_nucl(l) + + 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 + + j1b_gauss_coulerf = 0.d0 + + do p = 1, ao_prim_num(i) + coef1 = ao_coef_normalized_ordered_transp(p, i) + expo1 = ao_expo_ordered_transp(p, i) + + do q = 1, ao_prim_num(j) + coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j) + expo2 = ao_expo_ordered_transp(q, j) + + call give_explicit_poly_and_gaussian( P1_new, P1_center, pp1, fact_p1, iorder_p, expo1, expo2 & + , I_power, J_power, I_center, J_center, dim1 ) + p1_inv = 1.d0 / pp1 + + do r = 1, ao_prim_num(k) + coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k) + expo3 = ao_expo_ordered_transp(r, k) + + do s = 1, ao_prim_num(l) + coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l) + expo4 = ao_expo_ordered_transp(s, l) + + call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 & + , K_power, L_power, K_center, L_center, dim1 ) + q1_inv = 1.d0 / qq1 + + call get_cxcycz( dim1, cx, cy, cz & + , P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p & + , Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q ) + + j1b_gauss_coulerf = j1b_gauss_coulerf + coef4 * ( cx + cy + cz ) + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + return +end function j1b_gauss_coulerf + diff --git a/src/ao_tc_eff_map/two_e_1bgauss_coulerf_schwartz.irp.f b/src/ao_tc_eff_map/two_e_1bgauss_coulerf_schwartz.irp.f new file mode 100644 index 00000000..f2ba8276 --- /dev/null +++ b/src/ao_tc_eff_map/two_e_1bgauss_coulerf_schwartz.irp.f @@ -0,0 +1,624 @@ +double precision function j1b_gauss_coulerf_schwartz(i, j, k, l) + + BEGIN_DOC + ! + ! integral in the AO basis: + ! i(r1) j(r1) f(r12) k(r2) l(r2) + ! + ! with: + ! f(r12) = - [ (0.5 - 0.5 erf(mu r12)) / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ] + ! = [ (1 - erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2) + ! + (r2-RA)^2 exp(-aA r2A^2) + ! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) + ! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ] + ! + END_DOC + + include 'utils/constants.include.F' + + implicit none + + integer, intent(in) :: i, j, k, l + + integer :: p, q, r, s + integer :: num_i, num_j, num_k, num_l, num_ii + integer :: I_power(3), J_power(3), K_power(3), L_power(3) + integer :: iorder_p(3), iorder_q(3) + integer :: dim1 + + double precision :: coef1, coef2, coef3, coef4 + double precision :: expo1, expo2, expo3, expo4 + double precision :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1, p1_inv + double precision :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1, q1_inv + double precision :: I_center(3), J_center(3), K_center(3), L_center(3) + double precision :: cx, cy, cz + double precision :: schwartz_ij, thr + double precision, allocatable :: schwartz_kl(:,:) + + PROVIDE j1b_gauss_pen + + dim1 = n_pt_max_integrals + thr = ao_integrals_threshold * ao_integrals_threshold + + num_i = ao_nucl(i) + num_j = ao_nucl(j) + num_k = ao_nucl(k) + num_l = ao_nucl(l) + + 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 + + + allocate( schwartz_kl(0:ao_prim_num(l) , 0:ao_prim_num(k)) ) + + schwartz_kl(0,0) = 0.d0 + do r = 1, ao_prim_num(k) + expo3 = ao_expo_ordered_transp(r,k) + coef3 = ao_coef_normalized_ordered_transp(r,k) * ao_coef_normalized_ordered_transp(r,k) + + schwartz_kl(0,r) = 0.d0 + do s = 1, ao_prim_num(l) + expo4 = ao_expo_ordered_transp(s,l) + coef4 = coef3 * ao_coef_normalized_ordered_transp(s,l) * ao_coef_normalized_ordered_transp(s,l) + + call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 & + , K_power, L_power, K_center, L_center, dim1 ) + q1_inv = 1.d0 / qq1 + + call get_cxcycz( dim1, cx, cy, cz & + , Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q & + , Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q ) + + schwartz_kl(s,r) = coef4 * dabs( cx + cy + cz ) + schwartz_kl(0,r) = max( schwartz_kl(0,r) , schwartz_kl(s,r) ) + enddo + + schwartz_kl(0,0) = max( schwartz_kl(0,r) , schwartz_kl(0,0) ) + enddo + + + j1b_gauss_coulerf_schwartz = 0.d0 + + do p = 1, ao_prim_num(i) + expo1 = ao_expo_ordered_transp(p, i) + coef1 = ao_coef_normalized_ordered_transp(p, i) + + do q = 1, ao_prim_num(j) + expo2 = ao_expo_ordered_transp(q, j) + coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j) + + call give_explicit_poly_and_gaussian( P1_new, P1_center, pp1, fact_p1, iorder_p, expo1, expo2 & + , I_power, J_power, I_center, J_center, dim1 ) + p1_inv = 1.d0 / pp1 + + call get_cxcycz( dim1, cx, cy, cz & + , P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p & + , P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p ) + + schwartz_ij = coef2 * coef2 * dabs( cx + cy + cz ) + if( schwartz_kl(0,0) * schwartz_ij < thr ) cycle + + do r = 1, ao_prim_num(k) + if( schwartz_kl(0,r) * schwartz_ij < thr ) cycle + coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k) + expo3 = ao_expo_ordered_transp(r, k) + + do s = 1, ao_prim_num(l) + if( schwartz_kl(s,r) * schwartz_ij < thr ) cycle + coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l) + expo4 = ao_expo_ordered_transp(s, l) + + call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 & + , K_power, L_power, K_center, L_center, dim1 ) + q1_inv = 1.d0 / qq1 + + call get_cxcycz( dim1, cx, cy, cz & + , P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p & + , Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q ) + + j1b_gauss_coulerf_schwartz = j1b_gauss_coulerf_schwartz + coef4 * ( cx + cy + cz ) + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + deallocate( schwartz_kl ) + + return +end function j1b_gauss_coulerf_schwartz + + + + + +subroutine get_cxcycz( dim1, cx, cy, cz & + , P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p & + , Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q ) + + include 'utils/constants.include.F' + + implicit none + + integer, intent(in) :: dim1 + integer, intent(in) :: iorder_p(3), iorder_q(3) + double precision, intent(in) :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1, p1_inv + double precision, intent(in) :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1, q1_inv + double precision, intent(out) :: cx, cy, cz + + integer :: ii + integer :: shift_P(3), shift_Q(3) + double precision :: expoii, factii, Centerii(3) + double precision :: P2_new(0:max_dim,3), P2_center(3), fact_p2, pp2, p2_inv + double precision :: Q2_new(0:max_dim,3), Q2_center(3), fact_q2, qq2, q2_inv + double precision :: ff, gg + + double precision :: general_primitive_integral_erf_shifted + double precision :: general_primitive_integral_coul_shifted + + cx = 0.d0 + cy = 0.d0 + cz = 0.d0 + do ii = 1, nucl_num + + expoii = j1b_gauss_pen(ii) + Centerii(1:3) = nucl_coord(ii, 1:3) + + call gaussian_product(pp1, P1_center, expoii, Centerii, factii, pp2, P2_center) + fact_p2 = fact_p1 * factii + p2_inv = 1.d0 / pp2 + call pol_modif_center( P1_center, P2_center, iorder_p, P1_new, P2_new ) + + call gaussian_product(qq1, Q1_center, expoii, Centerii, factii, qq2, Q2_center) + fact_q2 = fact_q1 * factii + q2_inv = 1.d0 / qq2 + call pol_modif_center( Q1_center, Q2_center, iorder_q, Q1_new, Q2_new ) + + + ! ---------------------------------------------------------------------------------------------------- + ! [ (1-erf(mu r12)) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2) + ! ---------------------------------------------------------------------------------------------------- + + shift_Q = (/ 0, 0, 0 /) + + ! x term: + ff = P2_center(1) - Centerii(1) + + shift_P = (/ 2, 0, 0 /) + cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cx = cx - expoii * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_P = (/ 1, 0, 0 /) + cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cx = cx - expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 0, 0 /) + cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cx = cx - expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + ! y term: + ff = P2_center(2) - Centerii(2) + + shift_P = (/ 0, 2, 0 /) + cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cy = cy - expoii * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 1, 0 /) + cy = cy + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cy = cy - expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 0, 0 /) + cy = cy + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cy = cy - expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + ! z term: + ff = P2_center(3) - Centerii(3) + + shift_P = (/ 0, 0, 2 /) + cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cz = cz - expoii * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 0, 1 /) + cz = cz + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cz = cz - expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 0, 0 /) + cz = cz + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cz = cz - expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + ! ---------------------------------------------------------------------------------------------------- + + + + ! ---------------------------------------------------------------------------------------------------- + ! [ (1-erf(mu r12)) / r12 ] \sum_A a_A [ (r2-RA)^2 exp(-aA r2A^2) + ! ---------------------------------------------------------------------------------------------------- + + shift_P = (/ 0, 0, 0 /) + + ! x term: + ff = Q2_center(1) - Centerii(1) + + shift_Q = (/ 2, 0, 0 /) + cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cx = cx - expoii * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_Q = (/ 1, 0, 0 /) + cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cx = cx - expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_Q = (/ 0, 0, 0 /) + cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cx = cx - expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + ! y term: + ff = Q2_center(2) - Centerii(2) + + shift_Q = (/ 0, 2, 0 /) + cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cy = cy - expoii * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_Q = (/ 0, 1, 0 /) + cy = cy + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cy = cy - expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_Q = (/ 0, 0, 0 /) + cy = cy + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cy = cy - expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + ! z term: + ff = Q2_center(3) - Centerii(3) + + shift_Q = (/ 0, 0, 2 /) + cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cz = cz - expoii * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_Q = (/ 0, 0, 1 /) + cz = cz + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cz = cz - expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_Q = (/ 0, 0, 0 /) + cz = cz + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cz = cz - expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + + + ! ---------------------------------------------------------------------------------------------------- + ! - [ (1-erf(mu r12)) / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) ] + ! ---------------------------------------------------------------------------------------------------- + + ! x term: + ff = P2_center(1) - Centerii(1) + gg = Q1_center(1) - Centerii(1) + + shift_p = (/ 1, 0, 0 /) + shift_Q = (/ 1, 0, 0 /) + cx = cx - expoii * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 1, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cx = cx - expoii * gg * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cx = cx + expoii * gg * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 1, 0, 0 /) + cx = cx - expoii * ff * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cx = cx + expoii * ff * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cx = cx - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cx = cx + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + ! y term: + ff = P2_center(2) - Centerii(2) + gg = Q1_center(2) - Centerii(2) + + shift_p = (/ 0, 1, 0 /) + shift_Q = (/ 0, 1, 0 /) + cy = cy - expoii * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 1, 0 /) + shift_Q = (/ 0, 0, 0 /) + cy = cy - expoii * gg * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cy = cy + expoii * gg * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 1, 0 /) + cy = cy - expoii * ff * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cy = cy + expoii * ff * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cy = cy - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cy = cy + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + ! z term: + ff = P2_center(3) - Centerii(3) + gg = Q1_center(3) - Centerii(3) + + shift_p = (/ 0, 0, 1 /) + shift_Q = (/ 0, 0, 1 /) + cz = cz - expoii * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 1 /) + shift_Q = (/ 0, 0, 0 /) + cz = cz - expoii * gg * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cz = cz + expoii * gg * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 1 /) + cz = cz - expoii * ff * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cz = cz + expoii * ff * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cz = cz - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + cz = cz + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + + + ! ---------------------------------------------------------------------------------------------------- + ! - [ (1-erf(mu r12)) / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ] + ! ---------------------------------------------------------------------------------------------------- + + ! x term: + ff = P1_center(1) - Centerii(1) + gg = Q2_center(1) - Centerii(1) + + shift_p = (/ 1, 0, 0 /) + shift_Q = (/ 1, 0, 0 /) + cx = cx - expoii * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 1, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cx = cx - expoii * gg * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cx = cx + expoii * gg * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 1, 0, 0 /) + cx = cx - expoii * ff * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cx = cx + expoii * ff * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cx = cx - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cx = cx + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + ! y term: + ff = P1_center(2) - Centerii(2) + gg = Q2_center(2) - Centerii(2) + + shift_p = (/ 0, 1, 0 /) + shift_Q = (/ 0, 1, 0 /) + cy = cy - expoii * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 1, 0 /) + shift_Q = (/ 0, 0, 0 /) + cy = cy - expoii * gg * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cy = cy + expoii * gg * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 1, 0 /) + cy = cy - expoii * ff * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cy = cy + expoii * ff * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cy = cy - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cy = cy + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + ! z term: + ff = P1_center(3) - Centerii(3) + gg = Q2_center(3) - Centerii(3) + + shift_p = (/ 0, 0, 1 /) + shift_Q = (/ 0, 0, 1 /) + cz = cz - expoii * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 1 /) + shift_Q = (/ 0, 0, 0 /) + cz = cz - expoii * gg * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cz = cz + expoii * gg * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 1 /) + cz = cz - expoii * ff * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cz = cz + expoii * ff * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cz = cz - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + cz = cz + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + enddo + + return +end subroutine get_cxcycz + diff --git a/src/ao_tc_eff_map/two_e_1bgauss_erf.irp.f b/src/ao_tc_eff_map/two_e_1bgauss_erf.irp.f new file mode 100644 index 00000000..f5ff5499 --- /dev/null +++ b/src/ao_tc_eff_map/two_e_1bgauss_erf.irp.f @@ -0,0 +1,854 @@ +double precision function j1b_gauss_erf(i, j, k, l) + + BEGIN_DOC + ! + ! integral in the AO basis: + ! i(r1) j(r1) f(r12) k(r2) l(r2) + ! + ! with: + ! f(r12) = - [ -0.5 erf(mu r12) / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ] + ! = - [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2) + ! + (r2-RA)^2 exp(-aA r2A^2) + ! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) + ! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ] + ! + END_DOC + + include 'utils/constants.include.F' + + implicit none + + integer, intent(in) :: i, j, k, l + + integer :: p, q, r, s, ii + integer :: num_i, num_j, num_k, num_l, num_ii + integer :: I_power(3), J_power(3), K_power(3), L_power(3) + integer :: iorder_p(3), iorder_q(3) + integer :: shift_P(3), shift_Q(3) + integer :: dim1 + + double precision :: coef1, coef2, coef3, coef4 + double precision :: expo1, expo2, expo3, expo4 + double precision :: p_inv, q_inv + double precision :: P_new_tmp(0:max_dim,3), P_center_tmp(3), fact_p_tmp, pp_tmp + double precision :: Q_new_tmp(0:max_dim,3), Q_center_tmp(3), fact_q_tmp, qq_tmp + 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 + double precision :: I_center(3), J_center(3), K_center(3), L_center(3) + double precision :: expoii, factii, Centerii(3) + double precision :: ff, gg, cx, cy, cz + + double precision :: general_primitive_integral_erf_shifted + + PROVIDE mu_erf + PROVIDE j1b_gauss_pen + + 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) + + 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 + + j1b_gauss_erf = 0.d0 + + ! ------------------------------------------------------------------------------------------------------------------- + ! + ! - [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2) + ! + ! ------------------------------------------------------------------------------------------------------------------- + + shift_Q(1) = 0 + shift_Q(2) = 0 + shift_Q(3) = 0 + + do p = 1, ao_prim_num(i) + coef1 = ao_coef_normalized_ordered_transp(p, i) + expo1 = ao_expo_ordered_transp(p, i) + + do q = 1, ao_prim_num(j) + coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j) + expo2 = ao_expo_ordered_transp(q, j) + + call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 & + , I_power, J_power, I_center, J_center, dim1 ) + + do r = 1, ao_prim_num(k) + coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k) + expo3 = ao_expo_ordered_transp(r, k) + + do s = 1, ao_prim_num(l) + coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l) + expo4 = ao_expo_ordered_transp(s, l) + + call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 & + , K_power, L_power, K_center, L_center, dim1 ) + q_inv = 1.d0 / qq + + cx = 0.d0 + cy = 0.d0 + cz = 0.d0 + do ii = 1, nucl_num + expoii = j1b_gauss_pen(ii) + Centerii(1:3) = nucl_coord(ii, 1:3) + + call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center) + + fact_p = fact_p_tmp * factii + p_inv = 1.d0 / pp + + ! pol centerd on P_center_tmp ==> centerd on P_center + call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new) + + ! ---------------------------------------------------------------------------------------------------- + ! x term: + + shift_P(2) = 0 + shift_P(3) = 0 + + ff = P_center(1) - Centerii(1) + + shift_P(1) = 2 + cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(1) = 1 + cx = cx + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(1) = 0 + cx = cx + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + ! ---------------------------------------------------------------------------------------------------- + ! y term: + + shift_P(1) = 0 + shift_P(3) = 0 + + ff = P_center(2) - Centerii(2) + + shift_P(2) = 2 + cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(2) = 1 + cy = cy + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(2) = 0 + cy = cy + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + ! ---------------------------------------------------------------------------------------------------- + ! z term: + + shift_P(1) = 0 + shift_P(2) = 0 + + ff = P_center(3) - Centerii(3) + + shift_P(3) = 2 + cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(3) = 1 + cz = cz + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(3) = 0 + cz = cz + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + enddo + + j1b_gauss_erf = j1b_gauss_erf - coef4 * ( cx + cy + cz ) + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + + ! ------------------------------------------------------------------------------------------------------------------- + ! + ! - [ erf(mu r12) / r12 ] \sum_A a_A [ (r2-RA)^2 exp(-aA r2A^2) + ! + ! ------------------------------------------------------------------------------------------------------------------- + + shift_P(1) = 0 + shift_P(2) = 0 + shift_P(3) = 0 + + do p = 1, ao_prim_num(i) + coef1 = ao_coef_normalized_ordered_transp(p, i) + expo1 = ao_expo_ordered_transp(p, i) + + do q = 1, ao_prim_num(j) + coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j) + expo2 = ao_expo_ordered_transp(q, j) + + call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 & + , 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) + expo3 = ao_expo_ordered_transp(r, k) + + do s = 1, ao_prim_num(l) + coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l) + expo4 = ao_expo_ordered_transp(s, l) + + call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 & + , K_power, L_power, K_center, L_center, dim1 ) + + cx = 0.d0 + cy = 0.d0 + cz = 0.d0 + do ii = 1, nucl_num + expoii = j1b_gauss_pen(ii) + Centerii(1:3) = nucl_coord(ii, 1:3) + + call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center) + + fact_q = fact_q_tmp * factii + q_inv = 1.d0 / qq + + ! pol centerd on Q_center_tmp ==> centerd on Q_center + call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new) + + ! ---------------------------------------------------------------------------------------------------- + ! x term: + + shift_Q(2) = 0 + shift_Q(3) = 0 + + ff = Q_center(1) - Centerii(1) + + shift_Q(1) = 2 + cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_Q(1) = 1 + cx = cx + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_Q(1) = 0 + cx = cx + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + ! ---------------------------------------------------------------------------------------------------- + ! y term: + + shift_Q(1) = 0 + shift_Q(3) = 0 + + ff = Q_center(2) - Centerii(2) + + shift_Q(2) = 2 + cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_Q(2) = 1 + cy = cy + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_Q(2) = 0 + cy = cy + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + ! ---------------------------------------------------------------------------------------------------- + ! z term: + + shift_Q(1) = 0 + shift_Q(2) = 0 + + ff = Q_center(3) - Centerii(3) + + shift_Q(3) = 2 + cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_Q(3) = 1 + cz = cz + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_Q(3) = 0 + cz = cz + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + enddo + + j1b_gauss_erf = j1b_gauss_erf - coef4 * ( cx + cy + cz ) + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + + ! ------------------------------------------------------------------------------------------------------------------- + ! + ! [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) ] + ! + ! ------------------------------------------------------------------------------------------------------------------- + + do p = 1, ao_prim_num(i) + coef1 = ao_coef_normalized_ordered_transp(p, i) + expo1 = ao_expo_ordered_transp(p, i) + + do q = 1, ao_prim_num(j) + coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j) + expo2 = ao_expo_ordered_transp(q, j) + + call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 & + , I_power, J_power, I_center, J_center, dim1 ) + + do r = 1, ao_prim_num(k) + coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k) + expo3 = ao_expo_ordered_transp(r, k) + + do s = 1, ao_prim_num(l) + coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l) + expo4 = ao_expo_ordered_transp(s, l) + + call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 & + , K_power, L_power, K_center, L_center, dim1 ) + q_inv = 1.d0 / qq + + cx = 0.d0 + cy = 0.d0 + cz = 0.d0 + do ii = 1, nucl_num + expoii = j1b_gauss_pen(ii) + Centerii(1:3) = nucl_coord(ii, 1:3) + + call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center) + + fact_p = fact_p_tmp * factii + p_inv = 1.d0 / pp + + ! pol centerd on P_center_tmp ==> centerd on P_center + call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new) + + ! ---------------------------------------------------------------------------------------------------- + ! x term: + + shift_P(2) = 0 + shift_P(3) = 0 + shift_Q(2) = 0 + shift_Q(3) = 0 + + ff = P_center(1) - Centerii(1) + gg = Q_center(1) - Centerii(1) + + shift_P(1) = 1 + shift_Q(1) = 1 + cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(1) = 1 + shift_Q(1) = 0 + cx = cx + expoii * gg * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(1) = 0 + shift_Q(1) = 1 + cx = cx + expoii * ff * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(1) = 0 + shift_Q(1) = 0 + cx = cx + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + ! ---------------------------------------------------------------------------------------------------- + ! y term: + + shift_P(1) = 0 + shift_P(3) = 0 + shift_Q(1) = 0 + shift_Q(3) = 0 + + ff = P_center(2) - Centerii(2) + gg = Q_center(2) - Centerii(2) + + shift_P(2) = 1 + shift_Q(2) = 1 + cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(2) = 1 + shift_Q(2) = 0 + cy = cy + expoii * gg * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(2) = 0 + shift_Q(2) = 1 + cy = cy + expoii * ff * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(2) = 0 + shift_Q(2) = 0 + cy = cy + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + ! ---------------------------------------------------------------------------------------------------- + ! z term: + + shift_P(1) = 0 + shift_P(2) = 0 + shift_Q(1) = 0 + shift_Q(2) = 0 + + ff = P_center(3) - Centerii(3) + gg = Q_center(3) - Centerii(3) + + shift_P(3) = 1 + shift_Q(3) = 1 + cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(3) = 1 + shift_Q(3) = 0 + cz = cz + expoii * gg * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(3) = 0 + shift_Q(3) = 1 + cz = cz + expoii * ff * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(3) = 0 + shift_Q(3) = 0 + cz = cz + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + enddo + + j1b_gauss_erf = j1b_gauss_erf + coef4 * ( cx + cy + cz ) + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + + + ! ------------------------------------------------------------------------------------------------------------------- + ! + ! [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ] + ! + ! ------------------------------------------------------------------------------------------------------------------- + + do p = 1, ao_prim_num(i) + coef1 = ao_coef_normalized_ordered_transp(p, i) + expo1 = ao_expo_ordered_transp(p, i) + + do q = 1, ao_prim_num(j) + coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j) + expo2 = ao_expo_ordered_transp(q, j) + + call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 & + , 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) + expo3 = ao_expo_ordered_transp(r, k) + + do s = 1, ao_prim_num(l) + coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l) + expo4 = ao_expo_ordered_transp(s, l) + + call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 & + , K_power, L_power, K_center, L_center, dim1 ) + + cx = 0.d0 + cy = 0.d0 + cz = 0.d0 + do ii = 1, nucl_num + expoii = j1b_gauss_pen(ii) + Centerii(1:3) = nucl_coord(ii, 1:3) + + call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center) + + fact_q = fact_q_tmp * factii + q_inv = 1.d0 / qq + + ! pol centerd on Q_center_tmp ==> centerd on Q_center + call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new) + + ! ---------------------------------------------------------------------------------------------------- + ! x term: + + shift_P(2) = 0 + shift_P(3) = 0 + shift_Q(2) = 0 + shift_Q(3) = 0 + + ff = P_center(1) - Centerii(1) + gg = Q_center(1) - Centerii(1) + + shift_P(1) = 1 + shift_Q(1) = 1 + cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(1) = 1 + shift_Q(1) = 0 + cx = cx + expoii * gg * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(1) = 0 + shift_Q(1) = 1 + cx = cx + expoii * ff * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(1) = 0 + shift_Q(1) = 0 + cx = cx + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + ! ---------------------------------------------------------------------------------------------------- + ! y term: + + shift_P(1) = 0 + shift_P(3) = 0 + shift_Q(1) = 0 + shift_Q(3) = 0 + + ff = P_center(2) - Centerii(2) + gg = Q_center(2) - Centerii(2) + + shift_P(2) = 1 + shift_Q(2) = 1 + cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(2) = 1 + shift_Q(2) = 0 + cy = cy + expoii * gg * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(2) = 0 + shift_Q(2) = 1 + cy = cy + expoii * ff * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(2) = 0 + shift_Q(2) = 0 + cy = cy + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + ! ---------------------------------------------------------------------------------------------------- + ! z term: + + shift_P(1) = 0 + shift_P(2) = 0 + shift_Q(1) = 0 + shift_Q(2) = 0 + + ff = P_center(3) - Centerii(3) + gg = Q_center(3) - Centerii(3) + + shift_P(3) = 1 + shift_Q(3) = 1 + cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(3) = 1 + shift_Q(3) = 0 + cz = cz + expoii * gg * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(3) = 0 + shift_Q(3) = 1 + cz = cz + expoii * ff * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + shift_P(3) = 0 + shift_Q(3) = 0 + cz = cz + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 & + , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + enddo + + j1b_gauss_erf = j1b_gauss_erf + coef4 * ( cx + cy + cz ) + + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + + return +end function j1b_gauss_erf + + + + +!______________________________________________________________________________________________________________________ +!______________________________________________________________________________________________________________________ + +double precision function general_primitive_integral_erf_shifted( dim & + , P_new, P_center, fact_p, p, p_inv, iorder_p, shift_P & + , Q_new, Q_center, fact_q, q, q_inv, iorder_q, shift_Q ) + + include 'utils/constants.include.F' + + implicit none + + integer, intent(in) :: dim + integer, intent(in) :: iorder_p(3), shift_P(3) + integer, intent(in) :: iorder_q(3), shift_Q(3) + double precision, intent(in) :: P_new(0:max_dim,3), P_center(3), fact_p, p, p_inv + double precision, intent(in) :: Q_new(0:max_dim,3), Q_center(3), fact_q, q, q_inv + + integer :: n_Ix, n_Iy, n_Iz, nx, ny, nz + integer :: ix, iy, iz, jx, jy, jz, i + integer :: n_pt_tmp, n_pt_out, iorder + integer :: ii, jj + double precision :: rho, dist + double precision :: dx(0:max_dim), Ix_pol(0:max_dim) + double precision :: dy(0:max_dim), Iy_pol(0:max_dim) + double precision :: dz(0:max_dim), Iz_pol(0:max_dim) + double precision :: a, b, c, d, e, f, accu, pq, const + double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2, pq_inv_2 + double precision :: d1(0:max_dim), d_poly(0:max_dim) + double precision :: p_plus_q + + double precision :: rint_sum + + general_primitive_integral_erf_shifted = 0.d0 + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx, Ix_pol, dy, Iy_pol, dz, Iz_pol + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly + + ! Gaussian Product + ! ---------------- + p_plus_q = (p+q) * ( (p*q)/(p+q) + mu_erf*mu_erf ) / (mu_erf*mu_erf) + pq = p_inv * 0.5d0 * q_inv + pq_inv = 0.5d0 / p_plus_q + p10_1 = q * pq ! 1/(2p) + p01_1 = p * pq ! 1/(2q) + pq_inv_2 = pq_inv + pq_inv + p10_2 = pq_inv_2 * p10_1 * q ! 0.5d0 * q / (pq + p*p) + p01_2 = pq_inv_2 * p01_1 * p ! 0.5d0 * p / (q*q + pq) + + accu = 0.d0 + + iorder = iorder_p(1) + iorder_q(1) + iorder_p(1) + iorder_q(1) + iorder = iorder + shift_P(1) + shift_Q(1) + iorder = iorder + shift_P(1) + shift_Q(1) + !DIR$ VECTOR ALIGNED + do ix = 0, iorder + Ix_pol(ix) = 0.d0 + enddo + n_Ix = 0 + do ix = 0, iorder_p(1) + + ii = ix + shift_P(1) + a = P_new(ix,1) + if(abs(a) < thresh) cycle + + do jx = 0, iorder_q(1) + + jj = jx + shift_Q(1) + d = a * Q_new(jx,1) + if(abs(d) < thresh) cycle + + !DEC$ FORCEINLINE + call give_polynom_mult_center_x( P_center(1), Q_center(1), ii, jj & + , p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dx, nx ) + !DEC$ FORCEINLINE + call add_poly_multiply(dx, nx, d, Ix_pol, n_Ix) + enddo + enddo + if(n_Ix == -1) then + return + endif + + iorder = iorder_p(2) + iorder_q(2) + iorder_p(2) + iorder_q(2) + iorder = iorder + shift_P(2) + shift_Q(2) + iorder = iorder + shift_P(2) + shift_Q(2) + !DIR$ VECTOR ALIGNED + do ix = 0, iorder + Iy_pol(ix) = 0.d0 + enddo + n_Iy = 0 + do iy = 0, iorder_p(2) + + if(abs(P_new(iy,2)) > thresh) then + + ii = iy + shift_P(2) + b = P_new(iy,2) + + do jy = 0, iorder_q(2) + + jj = jy + shift_Q(2) + e = b * Q_new(jy,2) + if(abs(e) < thresh) cycle + + !DEC$ FORCEINLINE + call give_polynom_mult_center_x( P_center(2), Q_center(2), ii, jj & + , p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dy, ny ) + !DEC$ FORCEINLINE + call add_poly_multiply(dy, ny, e, Iy_pol, n_Iy) + enddo + endif + enddo + if(n_Iy == -1) then + return + endif + + iorder = iorder_p(3) + iorder_q(3) + iorder_p(3) + iorder_q(3) + iorder = iorder + shift_P(3) + shift_Q(3) + iorder = iorder + shift_P(3) + shift_Q(3) + do ix = 0, iorder + Iz_pol(ix) = 0.d0 + enddo + n_Iz = 0 + do iz = 0, iorder_p(3) + + if( abs(P_new(iz,3)) > thresh ) then + + ii = iz + shift_P(3) + c = P_new(iz,3) + + do jz = 0, iorder_q(3) + + jj = jz + shift_Q(3) + f = c * Q_new(jz,3) + if(abs(f) < thresh) cycle + + !DEC$ FORCEINLINE + call give_polynom_mult_center_x( P_center(3), Q_center(3), ii, jj & + , p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dz, nz ) + !DEC$ FORCEINLINE + call add_poly_multiply(dz, nz, f, Iz_pol, n_Iz) + enddo + endif + enddo + if(n_Iz == -1) then + return + endif + + rho = p * q * pq_inv_2 + dist = (P_center(1) - Q_center(1)) * (P_center(1) - Q_center(1)) & + + (P_center(2) - Q_center(2)) * (P_center(2) - Q_center(2)) & + + (P_center(3) - Q_center(3)) * (P_center(3) - Q_center(3)) + const = dist*rho + + n_pt_tmp = n_Ix + n_Iy + do i = 0, n_pt_tmp + d_poly(i) = 0.d0 + enddo + + !DEC$ FORCEINLINE + call multiply_poly(Ix_pol, n_Ix, Iy_pol, n_Iy, d_poly, n_pt_tmp) + if(n_pt_tmp == -1) then + return + endif + n_pt_out = n_pt_tmp + n_Iz + do i = 0, n_pt_out + d1(i) = 0.d0 + enddo + + !DEC$ FORCEINLINE + call multiply_poly(d_poly, n_pt_tmp, Iz_pol, n_Iz, d1, n_pt_out) + accu = accu + rint_sum(n_pt_out, const, d1) + + general_primitive_integral_erf_shifted = fact_p * fact_q * accu * pi_5_2 * p_inv * q_inv / dsqrt(p_plus_q) + + return +end function general_primitive_integral_erf_shifted +!______________________________________________________________________________________________________________________ +!______________________________________________________________________________________________________________________ diff --git a/src/ao_tc_eff_map/two_e_1bgauss_erf_acc.irp.f b/src/ao_tc_eff_map/two_e_1bgauss_erf_acc.irp.f new file mode 100644 index 00000000..54210c44 --- /dev/null +++ b/src/ao_tc_eff_map/two_e_1bgauss_erf_acc.irp.f @@ -0,0 +1,433 @@ +double precision function j1b_gauss_erf_acc(i, j, k, l) + + BEGIN_DOC + ! + ! integral in the AO basis: + ! i(r1) j(r1) f(r12) k(r2) l(r2) + ! + ! with: + ! f(r12) = - [ -0.5 erf(mu r12) / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ] + ! = - [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2) + ! + (r2-RA)^2 exp(-aA r2A^2) + ! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) + ! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ] + ! + END_DOC + + include 'utils/constants.include.F' + + implicit none + + integer, intent(in) :: i, j, k, l + + integer :: p, q, r, s, ii + integer :: num_i, num_j, num_k, num_l, num_ii + integer :: I_power(3), J_power(3), K_power(3), L_power(3) + integer :: iorder_p(3), iorder_q(3) + integer :: shift_P(3), shift_Q(3) + integer :: dim1 + + double precision :: coef1, coef2, coef3, coef4 + double precision :: expo1, expo2, expo3, expo4 + double precision :: p1_inv, q1_inv, p2_inv, q2_inv + double precision :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1 + double precision :: P2_new(0:max_dim,3), P2_center(3), fact_p2, pp2 + double precision :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1 + double precision :: Q2_new(0:max_dim,3), Q2_center(3), fact_q2, qq2 + double precision :: I_center(3), J_center(3), K_center(3), L_center(3) + double precision :: expoii, factii, Centerii(3) + double precision :: ff, gg, cx, cy, cz + + double precision :: general_primitive_integral_erf_shifted + !double precision :: j1b_gauss_erf_schwartz_accel + + PROVIDE j1b_gauss_pen + + dim1 = n_pt_max_integrals + + ! TODO + !if( ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then + ! j1b_gauss_erf_schwartz_accel = j1b_gauss_erf_schwartz_accel(i, j, k, l) + ! return + !endif + + num_i = ao_nucl(i) + num_j = ao_nucl(j) + num_k = ao_nucl(k) + num_l = ao_nucl(l) + + 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 + + j1b_gauss_erf_acc = 0.d0 + + do p = 1, ao_prim_num(i) + coef1 = ao_coef_normalized_ordered_transp(p, i) + expo1 = ao_expo_ordered_transp(p, i) + + do q = 1, ao_prim_num(j) + coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j) + expo2 = ao_expo_ordered_transp(q, j) + + call give_explicit_poly_and_gaussian( P1_new, P1_center, pp1, fact_p1, iorder_p, expo1, expo2 & + , I_power, J_power, I_center, J_center, dim1 ) + p1_inv = 1.d0 / pp1 + + do r = 1, ao_prim_num(k) + coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k) + expo3 = ao_expo_ordered_transp(r, k) + + do s = 1, ao_prim_num(l) + coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l) + expo4 = ao_expo_ordered_transp(s, l) + + call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 & + , K_power, L_power, K_center, L_center, dim1 ) + q1_inv = 1.d0 / qq1 + + cx = 0.d0 + cy = 0.d0 + cz = 0.d0 + do ii = 1, nucl_num + expoii = j1b_gauss_pen(ii) + Centerii(1:3) = nucl_coord(ii, 1:3) + + call gaussian_product(pp1, P1_center, expoii, Centerii, factii, pp2, P2_center) + fact_p2 = fact_p1 * factii + p2_inv = 1.d0 / pp2 + call pol_modif_center( P1_center, P2_center, iorder_p, P1_new, P2_new) + + call gaussian_product(qq1, Q1_center, expoii, Centerii, factii, qq2, Q2_center) + fact_q2 = fact_q1 * factii + q2_inv = 1.d0 / qq2 + call pol_modif_center( Q1_center, Q2_center, iorder_q, Q1_new, Q2_new) + + + ! ---------------------------------------------------------------------------------------------------- + ! [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2) + ! ---------------------------------------------------------------------------------------------------- + + shift_Q = (/ 0, 0, 0 /) + + ! x term: + ff = P2_center(1) - Centerii(1) + + shift_P = (/ 2, 0, 0 /) + cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_P = (/ 1, 0, 0 /) + cx = cx + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 0, 0 /) + cx = cx + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + ! y term: + ff = P2_center(2) - Centerii(2) + + shift_P = (/ 0, 2, 0 /) + cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 1, 0 /) + cy = cy + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 0, 0 /) + cy = cy + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + ! z term: + ff = P2_center(3) - Centerii(3) + + shift_P = (/ 0, 0, 2 /) + cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 0, 1 /) + cz = cz + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_P = (/ 0, 0, 0 /) + cz = cz + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + + + ! ---------------------------------------------------------------------------------------------------- + ! [ erf(mu r12) / r12 ] \sum_A a_A [ (r2-RA)^2 exp(-aA r2A^2) + ! ---------------------------------------------------------------------------------------------------- + + shift_P = (/ 0, 0, 0 /) + + ! x term: + ff = Q2_center(1) - Centerii(1) + + shift_Q = (/ 2, 0, 0 /) + cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_Q = (/ 1, 0, 0 /) + cx = cx + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_Q = (/ 0, 0, 0 /) + cx = cx + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + ! y term: + ff = Q2_center(2) - Centerii(2) + + shift_Q = (/ 0, 2, 0 /) + cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_Q = (/ 0, 1, 0 /) + cy = cy + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_Q = (/ 0, 0, 0 /) + cy = cy + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + ! z term: + ff = Q2_center(3) - Centerii(3) + + shift_Q = (/ 0, 0, 2 /) + cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_Q = (/ 0, 0, 1 /) + cz = cz + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_Q = (/ 0, 0, 0 /) + cz = cz + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + + + ! ---------------------------------------------------------------------------------------------------- + ! - [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) ] + ! ---------------------------------------------------------------------------------------------------- + + ! x term: + ff = P2_center(1) - Centerii(1) + gg = Q1_center(1) - Centerii(1) + + shift_p = (/ 1, 0, 0 /) + shift_Q = (/ 1, 0, 0 /) + cx = cx - expoii * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 1, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cx = cx - expoii * gg * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 1, 0, 0 /) + cx = cx - expoii * ff * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cx = cx - expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + ! y term: + ff = P2_center(2) - Centerii(2) + gg = Q1_center(2) - Centerii(2) + + shift_p = (/ 0, 1, 0 /) + shift_Q = (/ 0, 1, 0 /) + cy = cy - expoii * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 1, 0 /) + shift_Q = (/ 0, 0, 0 /) + cy = cy - expoii * gg * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 1, 0 /) + cy = cy - expoii * ff * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cy = cy - expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + ! z term: + ff = P2_center(3) - Centerii(3) + gg = Q1_center(3) - Centerii(3) + + shift_p = (/ 0, 0, 1 /) + shift_Q = (/ 0, 0, 1 /) + cz = cz - expoii * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 1 /) + shift_Q = (/ 0, 0, 0 /) + cz = cz - expoii * gg * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 1 /) + cz = cz - expoii * ff * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cz = cz - expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 & + , P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P & + , Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + + + ! ---------------------------------------------------------------------------------------------------- + ! - [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ] + ! ---------------------------------------------------------------------------------------------------- + + ! x term: + ff = P1_center(1) - Centerii(1) + gg = Q2_center(1) - Centerii(1) + + shift_p = (/ 1, 0, 0 /) + shift_Q = (/ 1, 0, 0 /) + cx = cx - expoii * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 1, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cx = cx - expoii * gg * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 1, 0, 0 /) + cx = cx - expoii * ff * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cx = cx - expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + ! y term: + ff = P1_center(2) - Centerii(2) + gg = Q2_center(2) - Centerii(2) + + shift_p = (/ 0, 1, 0 /) + shift_Q = (/ 0, 1, 0 /) + cy = cy - expoii * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 1, 0 /) + shift_Q = (/ 0, 0, 0 /) + cy = cy - expoii * gg * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 1, 0 /) + cy = cy - expoii * ff * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cy = cy - expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + ! z term: + ff = P1_center(3) - Centerii(3) + gg = Q2_center(3) - Centerii(3) + + shift_p = (/ 0, 0, 1 /) + shift_Q = (/ 0, 0, 1 /) + cz = cz - expoii * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 1 /) + shift_Q = (/ 0, 0, 0 /) + cz = cz - expoii * gg * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 1 /) + cz = cz - expoii * ff * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + shift_p = (/ 0, 0, 0 /) + shift_Q = (/ 0, 0, 0 /) + cz = cz - expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 & + , P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P & + , Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q ) + + ! ---------------------------------------------------------------------------------------------------- + + enddo + + j1b_gauss_erf_acc = j1b_gauss_erf_acc - coef4 * ( cx + cy + cz ) + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + return +end function j1b_gauss_erf_acc diff --git a/src/ao_tc_eff_map/two_e_ints_gauss.irp.f b/src/ao_tc_eff_map/two_e_ints_gauss.irp.f new file mode 100644 index 00000000..988b0b58 --- /dev/null +++ b/src/ao_tc_eff_map/two_e_ints_gauss.irp.f @@ -0,0 +1,326 @@ +double precision function ao_tc_sym_two_e_pot(i,j,k,l) + implicit none + BEGIN_DOC + ! integral of the AO basis or (ij|kl) + ! i(r1) j(r1) (tc_pot(r12,mu)) k(r2) l(r2) + ! + ! where (tc_pot(r12,mu)) is the scalar part of the potential EXCLUDING the term erf(mu r12)/r12. + ! + ! See Eq. (32) of JCP 154, 084119 (2021). + 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 + include 'utils/constants.include.F' + 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, allocatable :: schwartz_kl(:,:) + double precision :: schwartz_ij + double precision :: scw_gauss_int,general_primitive_integral_gauss + + 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_tc_sym_two_e_pot = 0.d0 + double precision :: thr + thr = ao_integrals_threshold*ao_integrals_threshold + + allocate(schwartz_kl(0:ao_prim_num(l),0:ao_prim_num(k))) + + double precision :: coef3 + double precision :: coef2 + double precision :: p_inv,q_inv + double precision :: coef1 + double precision :: coef4 + + 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 + + schwartz_kl(0,0) = 0.d0 + do r = 1, ao_prim_num(k) + coef1 = ao_coef_normalized_ordered_transp(r,k)*ao_coef_normalized_ordered_transp(r,k) + schwartz_kl(0,r) = 0.d0 + do s = 1, ao_prim_num(l) + coef2 = coef1 * ao_coef_normalized_ordered_transp(s,l) * 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 + scw_gauss_int = general_primitive_integral_gauss(dim1, & + Q_new,Q_center,fact_q,qq,q_inv,iorder_q, & + Q_new,Q_center,fact_q,qq,q_inv,iorder_q) + + schwartz_kl(s,r) = dabs(scw_gauss_int * coef2) + schwartz_kl(0,r) = max(schwartz_kl(0,r),schwartz_kl(s,r)) + enddo + schwartz_kl(0,0) = max(schwartz_kl(0,r),schwartz_kl(0,0)) + enddo + 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 + scw_gauss_int = general_primitive_integral_gauss(dim1, & + P_new,P_center,fact_p,pp,p_inv,iorder_p, & + P_new,P_center,fact_p,pp,p_inv,iorder_p) + schwartz_ij = dabs(scw_gauss_int * coef2*coef2) + if (schwartz_kl(0,0)*schwartz_ij < thr) then + cycle + endif + do r = 1, ao_prim_num(k) + if (schwartz_kl(0,r)*schwartz_ij < thr) then + cycle + endif + coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) + do s = 1, ao_prim_num(l) + if (schwartz_kl(s,r)*schwartz_ij < thr) then + cycle + endif + 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_gauss(dim1, & + P_new,P_center,fact_p,pp,p_inv,iorder_p, & + Q_new,Q_center,fact_q,qq,q_inv,iorder_q) + ao_tc_sym_two_e_pot = ao_tc_sym_two_e_pot + coef4 * integral + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + deallocate (schwartz_kl) + +end + + +double precision function general_primitive_integral_gauss(dim, & + P_new,P_center,fact_p,p,p_inv,iorder_p, & + Q_new,Q_center,fact_q,q,q_inv,iorder_q) + implicit none + BEGIN_DOC + ! Computes the integral where p,q,r,s are Gaussian primitives + END_DOC + integer,intent(in) :: dim + include 'utils/constants.include.F' + double precision, intent(in) :: P_new(0:max_dim,3),P_center(3),fact_p,p,p_inv + double precision, intent(in) :: Q_new(0:max_dim,3),Q_center(3),fact_q,q,q_inv + integer, intent(in) :: iorder_p(3) + integer, intent(in) :: iorder_q(3) + + double precision :: r_cut,gama_r_cut,rho,dist + double precision :: dx(0:max_dim),Ix_pol(0:max_dim),dy(0:max_dim),Iy_pol(0:max_dim),dz(0:max_dim),Iz_pol(0:max_dim) + integer :: n_Ix,n_Iy,n_Iz,nx,ny,nz + double precision :: bla + integer :: ix,iy,iz,jx,jy,jz,i + double precision :: a,b,c,d,e,f,accu,pq,const + double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2,pq_inv_2 + integer :: n_pt_tmp,n_pt_out, iorder + double precision :: d1(0:max_dim),d_poly(0:max_dim),rint,d1_screened(0:max_dim) + double precision :: thr + + thr = ao_integrals_threshold + + general_primitive_integral_gauss = 0.d0 + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx,Ix_pol,dy,Iy_pol,dz,Iz_pol + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly + + ! Gaussian Product + ! ---------------- + + pq = p_inv*0.5d0*q_inv + pq_inv = 0.5d0/(p+q) + p10_1 = q*pq ! 1/(2p) + p01_1 = p*pq ! 1/(2q) + pq_inv_2 = pq_inv+pq_inv + p10_2 = pq_inv_2 * p10_1*q !0.5d0*q/(pq + p*p) + p01_2 = pq_inv_2 * p01_1*p !0.5d0*p/(q*q + pq) + + + accu = 0.d0 + iorder = iorder_p(1)+iorder_q(1)+iorder_p(1)+iorder_q(1) + do ix=0,iorder + Ix_pol(ix) = 0.d0 + enddo + n_Ix = 0 + do ix = 0, iorder_p(1) + if (abs(P_new(ix,1)) < thr) cycle + a = P_new(ix,1) + do jx = 0, iorder_q(1) + d = a*Q_new(jx,1) + if (abs(d) < thr) cycle + !DIR$ FORCEINLINE + call give_polynom_mult_center_x(P_center(1),Q_center(1),ix,jx,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dx,nx) + !DIR$ FORCEINLINE + call add_poly_multiply(dx,nx,d,Ix_pol,n_Ix) + enddo + enddo + if (n_Ix == -1) then + return + endif + iorder = iorder_p(2)+iorder_q(2)+iorder_p(2)+iorder_q(2) + do ix=0, iorder + Iy_pol(ix) = 0.d0 + enddo + n_Iy = 0 + do iy = 0, iorder_p(2) + if (abs(P_new(iy,2)) > thr) then + b = P_new(iy,2) + do jy = 0, iorder_q(2) + e = b*Q_new(jy,2) + if (abs(e) < thr) cycle + !DIR$ FORCEINLINE + call give_polynom_mult_center_x(P_center(2),Q_center(2),iy,jy,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dy,ny) + !DIR$ FORCEINLINE + call add_poly_multiply(dy,ny,e,Iy_pol,n_Iy) + enddo + endif + enddo + if (n_Iy == -1) then + return + endif + + iorder = iorder_p(3)+iorder_q(3)+iorder_p(3)+iorder_q(3) + do ix=0,iorder + Iz_pol(ix) = 0.d0 + enddo + n_Iz = 0 + do iz = 0, iorder_p(3) + if (abs(P_new(iz,3)) > thr) then + c = P_new(iz,3) + do jz = 0, iorder_q(3) + f = c*Q_new(jz,3) + if (abs(f) < thr) cycle + !DIR$ FORCEINLINE + call give_polynom_mult_center_x(P_center(3),Q_center(3),iz,jz,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dz,nz) + !DIR$ FORCEINLINE + call add_poly_multiply(dz,nz,f,Iz_pol,n_Iz) + enddo + endif + enddo + if (n_Iz == -1) then + return + endif + + rho = p*q *pq_inv_2 + dist = (P_center(1) - Q_center(1))*(P_center(1) - Q_center(1)) + & + (P_center(2) - Q_center(2))*(P_center(2) - Q_center(2)) + & + (P_center(3) - Q_center(3))*(P_center(3) - Q_center(3)) + const = dist*rho + + n_pt_tmp = n_Ix+n_Iy + do i=0,n_pt_tmp + d_poly(i)=0.d0 + enddo + + !DIR$ FORCEINLINE + call multiply_poly(Ix_pol,n_Ix,Iy_pol,n_Iy,d_poly,n_pt_tmp) + if (n_pt_tmp == -1) then + return + endif + n_pt_out = n_pt_tmp+n_Iz + do i=0,n_pt_out + d1(i)=0.d0 + enddo + + !DIR$ FORCEINLINE + call multiply_poly(d_poly ,n_pt_tmp ,Iz_pol,n_Iz,d1,n_pt_out) + + double precision :: aa,c_a,t_a,rho_old,w_a,pi_3,prefactor,inv_pq_3_2 + double precision :: gauss_int + integer :: m + gauss_int = 0.d0 + pi_3 = pi*pi*pi + inv_pq_3_2 = (p_inv * q_inv)**(1.5d0) + rho_old = (p*q)/(p+q) + prefactor = pi_3 * inv_pq_3_2 * fact_p * fact_q + do i = 1, n_gauss_eff_pot ! browse the gaussians with different expo/coef + aa = expo_gauss_eff_pot(i) + c_a = coef_gauss_eff_pot(i) + t_a = dsqrt( aa /(rho_old + aa) ) + w_a = dexp(-t_a*t_a*rho_old*dist) + accu = 0.d0 + ! evaluation of the polynom Ix(t_a) * Iy(t_a) * Iz(t_a) + do m = 0, n_pt_out,2 + accu += d1(m) * (t_a)**(dble(m)) + enddo + ! equation A8 of PRA-70-062505 (2004) of Toul. Col. Sav. + gauss_int = gauss_int + c_a * prefactor * (1.d0 - t_a*t_a)**(1.5d0) * w_a * accu + enddo + + general_primitive_integral_gauss = gauss_int +end + +subroutine compute_ao_integrals_gauss_jl(j,l,n_integrals,buffer_i,buffer_value) + implicit none + use map_module + BEGIN_DOC + ! Parallel client for AO integrals + END_DOC + + integer, intent(in) :: j,l + integer,intent(out) :: n_integrals + integer(key_kind),intent(out) :: buffer_i(ao_num*ao_num) + real(integral_kind),intent(out) :: buffer_value(ao_num*ao_num) + + integer :: i,k + double precision :: cpu_1,cpu_2, wall_1, wall_2 + double precision :: integral, wall_0 + double precision :: thr,ao_tc_sym_two_e_pot + integer :: kk, m, j1, i1 + logical, external :: ao_two_e_integral_zero + + thr = ao_integrals_threshold + + n_integrals = 0 + + j1 = j+ishft(l*l-l,-1) + do k = 1, ao_num ! r1 + i1 = ishft(k*k-k,-1) + if (i1 > j1) then + exit + endif + do i = 1, k + i1 += 1 + if (i1 > j1) then + exit + endif +! if (ao_two_e_integral_zero(i,j,k,l)) then + if (.False.) then + cycle + endif + if (ao_two_e_integral_erf_schwartz(i,k)*ao_two_e_integral_erf_schwartz(j,l) < thr ) then + cycle + endif + !DIR$ FORCEINLINE + integral = ao_tc_sym_two_e_pot(i,k,j,l) ! i,k : r1 j,l : r2 + if (abs(integral) < thr) then + cycle + endif + n_integrals += 1 + !DIR$ FORCEINLINE + call two_e_integrals_index(i,j,k,l,buffer_i(n_integrals)) + buffer_value(n_integrals) = integral + enddo + enddo + +end diff --git a/src/bi_ort_ints/NEED b/src/bi_ort_ints/NEED new file mode 100644 index 00000000..4142e19f --- /dev/null +++ b/src/bi_ort_ints/NEED @@ -0,0 +1,3 @@ +non_h_ints_mu +ao_tc_eff_map +bi_ortho_mos diff --git a/src/bi_ort_ints/README.rst b/src/bi_ort_ints/README.rst new file mode 100644 index 00000000..d496c4f7 --- /dev/null +++ b/src/bi_ort_ints/README.rst @@ -0,0 +1,25 @@ +=========== +bi_ort_ints +=========== + +This module contains all necessary integrals for the TC Hamiltonian in a bi-orthonormal (BO) MO Basis. +See in bi_ortho_basis for more information. +The main providers are : + +One-electron integrals +---------------------- ++) ao_one_e_integrals_tc_tot : total one-electron Hamiltonian which might include non hermitian part coming from one-e correlation factor. ++) mo_bi_ortho_tc_one_e : one-electron Hamiltonian (h_core+one-J terms) on the BO-MO basis. ++) mo_bi_orth_bipole_x : x-component of the dipole operator on the BO-MO basis. (Same for y,z) + +Two-electron integrals +---------------------- ++) ao_two_e_tc_tot : Total two-electron operator (including the non-hermitian term of the TC Hamiltonian) on the AO basis ++) mo_bi_ortho_tc_two_e : Total two-electron operator on the BO-MO basis + +Three-electron integrals +------------------------ ++) three_body_ints_bi_ort : 6-indices three-electron tensor (-L) on the BO-MO basis. WARNING :: N^6 storage ! ++) three_e_3_idx_direct_bi_ort : DIRECT term with 3 different indices of the -L operator. These terms appear in the DIAGONAL matrix element of the -L operator. The 5 other permutations needed to compute matrix elements can be found in three_body_ijm.irp.f ++) three_e_4_idx_direct_bi_ort : DIRECT term with 4 different indices of the -L operator. These terms appear in the OFF-DIAGONAL matrix element of the -L operator including SINGLE EXCITATIONS. The 5 other permutations needed to compute matrix elements can be found in three_body_ijmk.irp.f ++) three_e_5_idx_direct_bi_ort : DIRECT term with 5 different indices of the -L operator. These terms appear in the OFF-DIAGONAL matrix element of the -L operator including DOUBLE EXCITATIONS. The 5 other permutations needed to compute matrix elements can be found in three_body_ijmkl.irp.f diff --git a/src/bi_ort_ints/bi_ort_ints.irp.f b/src/bi_ort_ints/bi_ort_ints.irp.f new file mode 100644 index 00000000..6884ff38 --- /dev/null +++ b/src/bi_ort_ints/bi_ort_ints.irp.f @@ -0,0 +1,123 @@ +program bi_ort_ints + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid +! call test_overlap +! call routine_twoe +! call routine_onee +! call test_v_ki_bi_ortho +! call test_x_v_ki_bi_ortho +! call test_3_body_bi_ort +! call test_3_e_diag +! call test_3_e_diag_cycle1 +! call test_3_e + call routine_test_one_int +end + +subroutine routine_test_one_int + implicit none + integer :: p,q,r,s,ii + integer :: i,j + i = 3 + j = 5 + double precision :: accu + double precision, allocatable :: vec(:) + integer, allocatable :: iorder(:) + allocate(vec(ao_num**4),iorder(ao_num**4)) + accu = 0.d0 + ii = 0 + do p = 1, ao_num ! + do q = 1, ao_num + do r = 1, ao_num + do s = 1, ao_num + ! + ! + ! j j i i + if(dabs(mo_l_coef(s,j) * mo_l_coef(q,i) * ao_two_e_tc_tot(s,r,q,p) * mo_r_coef(p,i) * mo_r_coef(r,j)).gt.10)then + write(33,'(3(F16.10,X),4(I3,X))')mo_l_coef(s,j) * mo_l_coef(q,i)* mo_r_coef(p,i) * mo_r_coef(r,j) , ao_two_e_tc_tot(s,r,q,p), mo_l_coef(s,j) * mo_l_coef(q,i) * ao_two_e_tc_tot(s,r,q,p) * mo_r_coef(p,i) * mo_r_coef(r,j) , s,q,p,r + endif + ii += 1 + iorder(ii) = ii + vec(ii) = mo_l_coef(s,j) * mo_l_coef(q,i) * ao_two_e_tc_tot(s,r,q,p) * mo_r_coef(p,i) * mo_r_coef(r,j) + accu += mo_l_coef(s,j) * mo_l_coef(q,i) * ao_two_e_tc_tot(s,r,q,p) * mo_r_coef(p,i) * mo_r_coef(r,j) + enddo + enddo + enddo + enddo + call dsort(vec,iorder,ao_num**4) + accu = 0.d0 + do i = 1, ao_num**4 + accu += vec(i) + write(34,*)i,vec(i),accu + enddo + + print*,'accu = ',accu + + +end + +subroutine routine_twoe + implicit none + integer :: i,j,k,l + double precision :: old, get_mo_two_e_integral_tc_int + double precision :: ref,new, accu, contrib, bi_ortho_mo_ints + accu = 0.d0 + print*,'Testing the bi ortho two e' + do j = 1, mo_num + do i = 1, mo_num + do l = 1, mo_num + do k = 1, mo_num + ! mo_non_hermit_term(k,l,i,j) = +! ref = bi_ortho_mo_ints(k,l,i,j) + ref = bi_ortho_mo_ints(l,k,j,i) + new = mo_bi_ortho_tc_two_e(l,k,j,i) +! old = get_mo_two_e_integral_tc_int(k,l,i,j,mo_integrals_tc_int_map) +! old += mo_non_hermit_term(l,k,j,i) + + contrib = dabs(ref - new) + if(dabs(ref).gt.1.d-10)then + if(contrib.gt.1.d-10)then + print*,k,l,i,j + print*,ref,new,contrib + endif + endif + accu += contrib + enddo + enddo + enddo + enddo + print*,'accu = ',accu/(dble(mo_num)**4) + +end + +subroutine routine_onee + implicit none + integer :: i,k + double precision :: ref,new,accu,contrib + print*,'Testing the bi ortho one e' + accu = 0.d0 + do i = 1, mo_num + do k = 1, mo_num + ref = mo_bi_ortho_tc_one_e_slow(k,i) + new = mo_bi_ortho_tc_one_e(k,i) + contrib = dabs(ref - new) + if(dabs(ref).gt.1.d-10)then + if(contrib .gt. 1.d-10)then + print*,'i,k',i,k + print*,ref,new,contrib + endif + endif + accu += contrib + enddo + enddo + print*,'accu = ',accu/mo_num**2 +end + + + + diff --git a/src/bi_ort_ints/one_e_bi_ort.irp.f b/src/bi_ort_ints/one_e_bi_ort.irp.f new file mode 100644 index 00000000..b7b87463 --- /dev/null +++ b/src/bi_ort_ints/one_e_bi_ort.irp.f @@ -0,0 +1,70 @@ + +! --- + +BEGIN_PROVIDER [double precision, ao_one_e_integrals_tc_tot, (ao_num,ao_num)] + + implicit none + integer :: i, j + + ao_one_e_integrals_tc_tot = ao_one_e_integrals + + provide j1b_gauss + + if(j1b_gauss .eq. 1) then + + do i = 1, ao_num + do j = 1, ao_num + ao_one_e_integrals_tc_tot(j,i) += ( j1b_gauss_hermI (j,i) & + + j1b_gauss_hermII (j,i) & + + j1b_gauss_nonherm(j,i) ) + enddo + enddo + + endif + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_one_e, (mo_num, mo_num)] + implicit none + BEGIN_DOC +! mo_bi_ortho_tc_one_e(k,i) = + END_DOC + integer :: i,k,p,q + + call ao_to_mo_bi_ortho(ao_one_e_integrals_tc_tot, ao_num, mo_bi_ortho_tc_one_e, mo_num) + +END_PROVIDER + +! --- + + BEGIN_PROVIDER [double precision, mo_bi_orth_bipole_x , (mo_num,mo_num)] +&BEGIN_PROVIDER [double precision, mo_bi_orth_bipole_y , (mo_num,mo_num)] +&BEGIN_PROVIDER [double precision, mo_bi_orth_bipole_z , (mo_num,mo_num)] + BEGIN_DOC + ! array of the integrals of MO_i * x MO_j + ! array of the integrals of MO_i * y MO_j + ! array of the integrals of MO_i * z MO_j + END_DOC + implicit none + + call ao_to_mo_bi_ortho( & + ao_dipole_x, & + size(ao_dipole_x,1), & + mo_bi_orth_bipole_x, & + size(mo_bi_orth_bipole_x,1) & + ) + call ao_to_mo_bi_ortho( & + ao_dipole_y, & + size(ao_dipole_y,1), & + mo_bi_orth_bipole_y, & + size(mo_bi_orth_bipole_y,1) & + ) + call ao_to_mo_bi_ortho( & + ao_dipole_z, & + size(ao_dipole_z,1), & + mo_bi_orth_bipole_z, & + size(mo_bi_orth_bipole_z,1) & + ) + +END_PROVIDER + diff --git a/src/bi_ort_ints/semi_num_ints_mo.irp.f b/src/bi_ort_ints/semi_num_ints_mo.irp.f new file mode 100644 index 00000000..6c4b44c0 --- /dev/null +++ b/src/bi_ort_ints/semi_num_ints_mo.irp.f @@ -0,0 +1,177 @@ +BEGIN_PROVIDER [ double precision, mo_v_ki_bi_ortho_erf_rk_cst_mu, ( mo_num, mo_num,n_points_final_grid)] + implicit none + BEGIN_DOC +! mo_v_ki_bi_ortho_erf_rk_cst_mu(k,i,ip) = int dr chi_k(r) phi_i(r) (erf(mu |r - R_ip|) - 1 )/(2|r - R_ip|) on the BI-ORTHO MO basis +! +! where phi_k(r) is a LEFT MOs and phi_i(r) is a RIGHT MO +! +! R_ip = the "ip"-th point of the DFT Grid + END_DOC + integer :: ipoint + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint) & + !$OMP SHARED (n_points_final_grid,v_ij_erf_rk_cst_mu,mo_v_ki_bi_ortho_erf_rk_cst_mu) + !$OMP DO SCHEDULE (dynamic) +! TODO :: optimization : transform into a DGEMM + do ipoint = 1, n_points_final_grid + call ao_to_mo_bi_ortho(v_ij_erf_rk_cst_mu(1,1,ipoint),size(v_ij_erf_rk_cst_mu,1),mo_v_ki_bi_ortho_erf_rk_cst_mu(1,1,ipoint),size(mo_v_ki_bi_ortho_erf_rk_cst_mu,1)) + enddo + !$OMP END DO + !$OMP END PARALLEL + mo_v_ki_bi_ortho_erf_rk_cst_mu = mo_v_ki_bi_ortho_erf_rk_cst_mu * 0.5d0 +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, mo_v_ki_bi_ortho_erf_rk_cst_mu_transp, ( n_points_final_grid,mo_num, mo_num)] + implicit none + BEGIN_DOC +! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/(2|r - R|) on the BI-ORTHO MO basis + END_DOC + integer :: ipoint,i,j + do i = 1, mo_num + do j = 1, mo_num + do ipoint = 1, n_points_final_grid + mo_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,j,i) = mo_v_ki_bi_ortho_erf_rk_cst_mu(j,i,ipoint) + enddo + enddo + enddo +! FREE mo_v_ki_bi_ortho_erf_rk_cst_mu +END_PROVIDER + +BEGIN_PROVIDER [ double precision, mo_x_v_ki_bi_ortho_erf_rk_cst_mu, ( mo_num, mo_num,3,n_points_final_grid)] + implicit none + BEGIN_DOC +! mo_x_v_ki_bi_ortho_erf_rk_cst_mu(k,i,m,ip) = int dr x(m) * chi_k(r) phi_i(r) (erf(mu |r - R_ip|) - 1)/2|r - R_ip| on the BI-ORTHO MO basis +! +! where chi_k(r)/phi_i(r) are left/right MOs, m=1 => x(m) = x, m=2 => x(m) = y, m=3 => x(m) = z, +! +! R_ip = the "ip"-th point of the DFT Grid + END_DOC + integer :: ipoint,m + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint,m) & + !$OMP SHARED (n_points_final_grid,x_v_ij_erf_rk_cst_mu_transp,mo_x_v_ki_bi_ortho_erf_rk_cst_mu) + !$OMP DO SCHEDULE (dynamic) +! TODO :: optimization : transform into a DGEMM + do ipoint = 1, n_points_final_grid + do m = 1, 3 + call ao_to_mo_bi_ortho(x_v_ij_erf_rk_cst_mu_transp(1,1,m,ipoint),size(x_v_ij_erf_rk_cst_mu_transp,1),mo_x_v_ki_bi_ortho_erf_rk_cst_mu(1,1,m,ipoint),size(mo_x_v_ki_bi_ortho_erf_rk_cst_mu,1)) + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + mo_x_v_ki_bi_ortho_erf_rk_cst_mu = 0.5d0 * mo_x_v_ki_bi_ortho_erf_rk_cst_mu + +END_PROVIDER + +! --- +BEGIN_PROVIDER [ double precision, mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp, (n_points_final_grid, 3, mo_num, mo_num)] + implicit none + integer :: i, j, m, ipoint + do i = 1, mo_num + do j = 1, mo_num + do m = 1, 3 + do ipoint = 1, n_points_final_grid + mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,m,j,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu(j,i,m,ipoint) + enddo + enddo + enddo + enddo +END_PROVIDER + +! --- + + +BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk, (n_points_final_grid, 3, mo_num, mo_num)] + BEGIN_DOC + ! x_W_ki_bi_ortho_erf_rk(ip,m,k,i) = \int dr chi_k(r) (1 - erf(mu |r-R_ip|)) (x(m)-X(m)_ip) phi_i(r) ON THE BI-ORTHO MO BASIS +! +! where chi_k(r)/phi_i(r) are left/right MOs, m=1 => X(m) = x, m=2 => X(m) = y, m=3 => X(m) = z, +! +! R_ip = the "ip"-th point of the DFT Grid + END_DOC + + implicit none + include 'constants.include.F' + + integer :: ipoint, m, i, k + double precision :: xyz + double precision :: wall0, wall1 + + print*,'providing x_W_ki_bi_ortho_erf_rk ...' + call wall_time(wall0) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint,m,i,k,xyz) & + !$OMP SHARED (x_W_ki_bi_ortho_erf_rk,n_points_final_grid,mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp,mo_v_ki_bi_ortho_erf_rk_cst_mu_transp,mo_num,final_grid_points) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do k = 1, mo_num + do m = 1, 3 + do ipoint = 1, n_points_final_grid + xyz = final_grid_points(m,ipoint) + x_W_ki_bi_ortho_erf_rk(ipoint,m,k,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,m,k,i) - xyz * mo_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,k,i) + enddo + enddo + enddo + enddo + + !$OMP END DO + !$OMP END PARALLEL + + ! FREE mo_v_ki_bi_ortho_erf_rk_cst_mu_transp + ! FREE mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp + + call wall_time(wall1) + print*,'time to provide x_W_ki_bi_ortho_erf_rk = ',wall1 - wall0 + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk_diag, (n_points_final_grid, 3, mo_num)] + BEGIN_DOC + ! x_W_ki_bi_ortho_erf_rk_diag(ip,m,i) = \int dr chi_i(r) (1 - erf(mu |r-R_ip|)) (x(m)-X(m)_ip) phi_i(r) ON THE BI-ORTHO MO BASIS +! +! where chi_k(r)/phi_i(r) are left/right MOs, m=1 => X(m) = x, m=2 => X(m) = y, m=3 => X(m) = z, +! +! R_ip = the "ip"-th point of the DFT Grid + END_DOC + + implicit none + include 'constants.include.F' + + integer :: ipoint, m, i + double precision :: xyz + double precision :: wall0, wall1 + + print*,'providing x_W_ki_bi_ortho_erf_rk_diag ...' + call wall_time(wall0) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint,m,i,xyz) & + !$OMP SHARED (x_W_ki_bi_ortho_erf_rk_diag,n_points_final_grid,mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp,mo_v_ki_bi_ortho_erf_rk_cst_mu_transp,mo_num,final_grid_points) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do m = 1, 3 + do ipoint = 1, n_points_final_grid + xyz = final_grid_points(m,ipoint) + x_W_ki_bi_ortho_erf_rk_diag(ipoint,m,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,m,i,i) - xyz * mo_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,i,i) + enddo + enddo + enddo + + !$OMP END DO + !$OMP END PARALLEL + + call wall_time(wall1) + print*,'time to provide x_W_ki_bi_ortho_erf_rk_diag = ',wall1 - wall0 + +END_PROVIDER + +! --- + diff --git a/src/bi_ort_ints/three_body_ijm.irp.f b/src/bi_ort_ints/three_body_ijm.irp.f new file mode 100644 index 00000000..4fd85756 --- /dev/null +++ b/src/bi_ort_ints/three_body_ijm.irp.f @@ -0,0 +1,304 @@ +BEGIN_PROVIDER [ double precision, three_e_3_idx_direct_bi_ort, (mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the direct terms +! +! three_e_3_idx_direct_bi_ort(m,j,i) = +! +! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + integer :: i,j,m + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_e_3_idx_direct_bi_ort = 0.d0 + print*,'Providing the three_e_3_idx_direct_bi_ort ...' + call wall_time(wall0) + name_file = 'six_index_tensor' + provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,integral) & + !$OMP SHARED (mo_num,three_e_3_idx_direct_bi_ort) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do j = 1, mo_num + do m = j, mo_num + call give_integrals_3_body_bi_ort(m,j,i,m,j,i,integral) + three_e_3_idx_direct_bi_ort(m,j,i) = -1.d0 * integral + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call wall_time(wall1) + print*,'wall time for three_e_3_idx_direct_bi_ort',wall1 - wall0 + + do i = 1, mo_num + do j = 1, mo_num + do m = 1, j + three_e_3_idx_direct_bi_ort(m,j,i) = three_e_3_idx_direct_bi_ort(j,m,i) + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_1_bi_ort, (mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the first cyclic permutation +! +! three_e_3_idx_direct_bi_ort(m,j,i) = +! +! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + integer :: i,j,m + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_e_3_idx_cycle_1_bi_ort = 0.d0 + print*,'Providing the three_e_3_idx_cycle_1_bi_ort ...' + call wall_time(wall0) + name_file = 'six_index_tensor' + provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,integral) & + !$OMP SHARED (mo_num,three_e_3_idx_cycle_1_bi_ort) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do j = 1, mo_num + do m = j, mo_num + call give_integrals_3_body_bi_ort(m,j,i,j,i,m,integral) + three_e_3_idx_cycle_1_bi_ort(m,j,i) = -1.d0 * integral + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call wall_time(wall1) + + do i = 1, mo_num + do j = 1, mo_num + do m = 1, j + three_e_3_idx_cycle_1_bi_ort(m,j,i) = three_e_3_idx_cycle_1_bi_ort(j,m,i) + enddo + enddo + enddo + print*,'wall time for three_e_3_idx_cycle_1_bi_ort',wall1 - wall0 + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_2_bi_ort, (mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the second cyclic permutation +! +! three_e_3_idx_direct_bi_ort(m,j,i) = +! +! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + integer :: i,j,m + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_e_3_idx_cycle_2_bi_ort = 0.d0 + print*,'Providing the three_e_3_idx_cycle_2_bi_ort ...' + call wall_time(wall0) + name_file = 'six_index_tensor' + provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,integral) & + !$OMP SHARED (mo_num,three_e_3_idx_cycle_2_bi_ort) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do j = 1, mo_num + do m = j, mo_num + call give_integrals_3_body_bi_ort(m,j,i,i,m,j,integral) + three_e_3_idx_cycle_2_bi_ort(m,j,i) = -1.d0 * integral + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call wall_time(wall1) + do i = 1, mo_num + do j = 1, mo_num + do m = 1, j + three_e_3_idx_cycle_2_bi_ort(m,j,i) = three_e_3_idx_cycle_2_bi_ort(j,m,i) + enddo + enddo + enddo + print*,'wall time for three_e_3_idx_cycle_2_bi_ort',wall1 - wall0 + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_e_3_idx_exch23_bi_ort, (mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the permutations of particle 2 and 3 +! +! three_e_3_idx_exch23_bi_ort(m,j,i) = +! +! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + integer :: i,j,m + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_e_3_idx_exch23_bi_ort = 0.d0 + print*,'Providing the three_e_3_idx_exch23_bi_ort ...' + call wall_time(wall0) + name_file = 'six_index_tensor' + provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,integral) & + !$OMP SHARED (mo_num,three_e_3_idx_exch23_bi_ort) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do j = 1, mo_num + do m = j, mo_num + call give_integrals_3_body_bi_ort(m,j,i,j,m,i,integral) + three_e_3_idx_exch23_bi_ort(m,j,i) = -1.d0 * integral + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + do i = 1, mo_num + do j = 1, mo_num + do m = 1, j + three_e_3_idx_exch23_bi_ort(m,j,i) = three_e_3_idx_exch23_bi_ort(j,m,i) + enddo + enddo + enddo + call wall_time(wall1) + print*,'wall time for three_e_3_idx_exch23_bi_ort',wall1 - wall0 + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_e_3_idx_exch13_bi_ort, (mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the permutations of particle 1 and 3 +! +! three_e_3_idx_exch13_bi_ort(m,j,i) = +! +! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + integer :: i,j,m + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_e_3_idx_exch13_bi_ort = 0.d0 + print*,'Providing the three_e_3_idx_exch13_bi_ort ...' + call wall_time(wall0) + name_file = 'six_index_tensor' + provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,integral) & + !$OMP SHARED (mo_num,three_e_3_idx_exch13_bi_ort) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do j = 1, mo_num + do m = j, mo_num + call give_integrals_3_body_bi_ort(m,j,i,i,j,m,integral) + three_e_3_idx_exch13_bi_ort(m,j,i) = -1.d0 * integral + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + do i = 1, mo_num + do j = 1, mo_num + do m = 1, j + three_e_3_idx_exch13_bi_ort(m,j,i) = three_e_3_idx_exch13_bi_ort(j,m,i) + enddo + enddo + enddo + call wall_time(wall1) + print*,'wall time for three_e_3_idx_exch13_bi_ort',wall1 - wall0 + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_e_3_idx_exch12_bi_ort, (mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the permutations of particle 1 and 2 +! +! three_e_3_idx_exch12_bi_ort(m,j,i) = +! +! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + integer :: i,j,m + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_e_3_idx_exch12_bi_ort = 0.d0 + print*,'Providing the three_e_3_idx_exch12_bi_ort ...' + call wall_time(wall0) + name_file = 'six_index_tensor' + provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,integral) & + !$OMP SHARED (mo_num,three_e_3_idx_exch12_bi_ort) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do j = 1, mo_num + do m = 1, mo_num + call give_integrals_3_body_bi_ort(m,j,i,m,i,j,integral) + three_e_3_idx_exch12_bi_ort(m,j,i) = -1.d0 * integral + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call wall_time(wall1) + print*,'wall time for three_e_3_idx_exch12_bi_ort',wall1 - wall0 + +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, three_e_3_idx_exch12_bi_ort_new, (mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the permutations of particle 1 and 2 +! +! three_e_3_idx_exch12_bi_ort_new(m,j,i) = +! +! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + integer :: i,j,m + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_e_3_idx_exch12_bi_ort_new = 0.d0 + print*,'Providing the three_e_3_idx_exch12_bi_ort_new ...' + call wall_time(wall0) + name_file = 'six_index_tensor' + provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,integral) & + !$OMP SHARED (mo_num,three_e_3_idx_exch12_bi_ort_new) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do j = 1, mo_num + do m = j, mo_num + call give_integrals_3_body_bi_ort(m,j,i,m,i,j,integral) + three_e_3_idx_exch12_bi_ort_new(m,j,i) = -1.d0 * integral + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + do i = 1, mo_num + do j = 1, mo_num + do m = 1, j + three_e_3_idx_exch12_bi_ort_new(m,j,i) = three_e_3_idx_exch12_bi_ort_new(j,m,i) + enddo + enddo + enddo + call wall_time(wall1) + print*,'wall time for three_e_3_idx_exch12_bi_ort_new',wall1 - wall0 + +END_PROVIDER + diff --git a/src/bi_ort_ints/three_body_ijmk.irp.f b/src/bi_ort_ints/three_body_ijmk.irp.f new file mode 100644 index 00000000..40c34ddf --- /dev/null +++ b/src/bi_ort_ints/three_body_ijmk.irp.f @@ -0,0 +1,228 @@ +BEGIN_PROVIDER [ double precision, three_e_4_idx_direct_bi_ort, (mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs +! +!three_e_4_idx_direct_bi_ort(m,j,k,i) = ::: notice that i is the RIGHT MO and k is the LEFT MO +! +! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + integer :: i,j,k,m + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_e_4_idx_direct_bi_ort = 0.d0 + print*,'Providing the three_e_4_idx_direct_bi_ort ...' + call wall_time(wall0) + provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,m,integral) & + !$OMP SHARED (mo_num,three_e_4_idx_direct_bi_ort) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do m = 1, mo_num + call give_integrals_3_body_bi_ort(m,j,k,m,j,i,integral) + three_e_4_idx_direct_bi_ort(m,j,k,i) = -1.d0 * integral + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call wall_time(wall1) + print*,'wall time for three_e_4_idx_direct_bi_ort',wall1 - wall0 + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_1_bi_ort, (mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs +! +!three_e_4_idx_cycle_1_bi_ort(m,j,k,i) = ::: notice that i is the RIGHT MO and k is the LEFT MO +! +! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + integer :: i,j,k,m + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_e_4_idx_cycle_1_bi_ort = 0.d0 + print*,'Providing the three_e_4_idx_cycle_1_bi_ort ...' + call wall_time(wall0) + provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,m,integral) & + !$OMP SHARED (mo_num,three_e_4_idx_cycle_1_bi_ort) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do m = 1, mo_num + call give_integrals_3_body_bi_ort(m,j,k,j,i,m,integral) + three_e_4_idx_cycle_1_bi_ort(m,j,k,i) = -1.d0 * integral + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call wall_time(wall1) + print*,'wall time for three_e_4_idx_cycle_1_bi_ort',wall1 - wall0 + +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_2_bi_ort, (mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs +! +!three_e_4_idx_cycle_2_bi_ort(m,j,k,i) = ::: notice that i is the RIGHT MO and k is the LEFT MO +! +! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + integer :: i,j,k,m + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_e_4_idx_cycle_2_bi_ort = 0.d0 + print*,'Providing the three_e_4_idx_cycle_2_bi_ort ...' + call wall_time(wall0) + provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,m,integral) & + !$OMP SHARED (mo_num,three_e_4_idx_cycle_2_bi_ort) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do m = 1, mo_num + call give_integrals_3_body_bi_ort(m,j,k,i,m,j,integral) + three_e_4_idx_cycle_2_bi_ort(m,j,k,i) = -1.d0 * integral + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call wall_time(wall1) + print*,'wall time for three_e_4_idx_cycle_2_bi_ort',wall1 - wall0 + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_e_4_idx_exch23_bi_ort, (mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs +! +!three_e_4_idx_exch23_bi_ort(m,j,k,i) = ::: notice that i is the RIGHT MO and k is the LEFT MO +! +! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + integer :: i,j,k,m + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_e_4_idx_exch23_bi_ort = 0.d0 + print*,'Providing the three_e_4_idx_exch23_bi_ort ...' + call wall_time(wall0) + provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,m,integral) & + !$OMP SHARED (mo_num,three_e_4_idx_exch23_bi_ort) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do m = 1, mo_num + call give_integrals_3_body_bi_ort(m,j,k,j,m,i,integral) + three_e_4_idx_exch23_bi_ort(m,j,k,i) = -1.d0 * integral + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call wall_time(wall1) + print*,'wall time for three_e_4_idx_exch23_bi_ort',wall1 - wall0 + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_e_4_idx_exch13_bi_ort, (mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs +! +!three_e_4_idx_exch13_bi_ort(m,j,k,i) = ::: notice that i is the RIGHT MO and k is the LEFT MO +! +! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + integer :: i,j,k,m + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_e_4_idx_exch13_bi_ort = 0.d0 + print*,'Providing the three_e_4_idx_exch13_bi_ort ...' + call wall_time(wall0) + provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,m,integral) & + !$OMP SHARED (mo_num,three_e_4_idx_exch13_bi_ort) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do m = 1, mo_num + call give_integrals_3_body_bi_ort(m,j,k,i,j,m,integral) + three_e_4_idx_exch13_bi_ort(m,j,k,i) = -1.d0 * integral + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call wall_time(wall1) + print*,'wall time for three_e_4_idx_exch13_bi_ort',wall1 - wall0 + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_e_4_idx_exch12_bi_ort, (mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs +! +!three_e_4_idx_exch12_bi_ort(m,j,k,i) = ::: notice that i is the RIGHT MO and k is the LEFT MO +! +! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + integer :: i,j,k,m + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_e_4_idx_exch12_bi_ort = 0.d0 + print*,'Providing the three_e_4_idx_exch12_bi_ort ...' + call wall_time(wall0) + provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,m,integral) & + !$OMP SHARED (mo_num,three_e_4_idx_exch12_bi_ort) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do m = 1, mo_num + call give_integrals_3_body_bi_ort(m,j,k,m,i,j,integral) + three_e_4_idx_exch12_bi_ort(m,j,k,i) = -1.d0 * integral + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call wall_time(wall1) + print*,'wall time for three_e_4_idx_exch12_bi_ort',wall1 - wall0 + +END_PROVIDER diff --git a/src/bi_ort_ints/three_body_ijmkl.irp.f b/src/bi_ort_ints/three_body_ijmkl.irp.f new file mode 100644 index 00000000..72e93955 --- /dev/null +++ b/src/bi_ort_ints/three_body_ijmkl.irp.f @@ -0,0 +1,240 @@ +BEGIN_PROVIDER [ double precision, three_e_5_idx_direct_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs +! +!three_e_5_idx_direct_bi_ort(m,l,j,k,i) = ::: notice that i is the RIGHT MO and k is the LEFT MO +! +! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + integer :: i,j,k,m,l + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_e_5_idx_direct_bi_ort = 0.d0 + print*,'Providing the three_e_5_idx_direct_bi_ort ...' + call wall_time(wall0) + provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,m,l,integral) & + !$OMP SHARED (mo_num,three_e_5_idx_direct_bi_ort) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do l = 1, mo_num + do m = 1, mo_num + call give_integrals_3_body_bi_ort(m,l,k,m,j,i,integral) + three_e_5_idx_direct_bi_ort(m,l,j,k,i) = -1.d0 * integral + enddo + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call wall_time(wall1) + print*,'wall time for three_e_5_idx_direct_bi_ort',wall1 - wall0 + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_e_5_idx_cycle_1_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs +! +!three_e_5_idx_cycle_1_bi_ort(m,l,j,k,i) = ::: notice that i is the RIGHT MO and k is the LEFT MO +! +! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + integer :: i,j,k,m,l + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_e_5_idx_cycle_1_bi_ort = 0.d0 + print*,'Providing the three_e_5_idx_cycle_1_bi_ort ...' + call wall_time(wall0) + provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,m,l,integral) & + !$OMP SHARED (mo_num,three_e_5_idx_cycle_1_bi_ort) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do l = 1, mo_num + do m = 1, mo_num + call give_integrals_3_body_bi_ort(m,l,k,j,i,m,integral) + three_e_5_idx_cycle_1_bi_ort(m,l,j,k,i) = -1.d0 * integral + enddo + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call wall_time(wall1) + print*,'wall time for three_e_5_idx_cycle_1_bi_ort',wall1 - wall0 + +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, three_e_5_idx_cycle_2_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs +! +!three_e_5_idx_cycle_2_bi_ort(m,l,j,k,i) = ::: notice that i is the RIGHT MO and k is the LEFT MO +! +! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + integer :: i,j,k,m,l + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_e_5_idx_cycle_2_bi_ort = 0.d0 + print*,'Providing the three_e_5_idx_cycle_2_bi_ort ...' + call wall_time(wall0) + provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,m,l,integral) & + !$OMP SHARED (mo_num,three_e_5_idx_cycle_2_bi_ort) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do m = 1, mo_num + do l = 1, mo_num + call give_integrals_3_body_bi_ort(m,l,k,i,m,j,integral) + three_e_5_idx_cycle_2_bi_ort(m,l,j,k,i) = -1.d0 * integral + enddo + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call wall_time(wall1) + print*,'wall time for three_e_5_idx_cycle_2_bi_ort',wall1 - wall0 + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_e_5_idx_exch23_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs +! +!three_e_5_idx_exch23_bi_ort(m,l,j,k,i) = ::: notice that i is the RIGHT MO and k is the LEFT MO +! +! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + integer :: i,j,k,m,l + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_e_5_idx_exch23_bi_ort = 0.d0 + print*,'Providing the three_e_5_idx_exch23_bi_ort ...' + call wall_time(wall0) + provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,m,l,integral) & + !$OMP SHARED (mo_num,three_e_5_idx_exch23_bi_ort) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do l = 1, mo_num + do m = 1, mo_num + call give_integrals_3_body_bi_ort(m,l,k,j,m,i,integral) + three_e_5_idx_exch23_bi_ort(m,l,j,k,i) = -1.d0 * integral + enddo + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call wall_time(wall1) + print*,'wall time for three_e_5_idx_exch23_bi_ort',wall1 - wall0 + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_e_5_idx_exch13_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs +! +!three_e_5_idx_exch13_bi_ort(m,l,j,k,i) = ::: notice that i is the RIGHT MO and k is the LEFT MO +! +! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + integer :: i,j,k,m,l + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_e_5_idx_exch13_bi_ort = 0.d0 + print*,'Providing the three_e_5_idx_exch13_bi_ort ...' + call wall_time(wall0) + provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,m,l,integral) & + !$OMP SHARED (mo_num,three_e_5_idx_exch13_bi_ort) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do l = 1, mo_num + do m = 1, mo_num + call give_integrals_3_body_bi_ort(m,l,k,i,j,m,integral) + three_e_5_idx_exch13_bi_ort(m,l,j,k,i) = -1.d0 * integral + enddo + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call wall_time(wall1) + print*,'wall time for three_e_5_idx_exch13_bi_ort',wall1 - wall0 + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_e_5_idx_exch12_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs +! +!three_e_5_idx_exch12_bi_ort(m,l,j,k,i) = ::: notice that i is the RIGHT MO and k is the LEFT MO +! +! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + integer :: i,j,k,m,l + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_e_5_idx_exch12_bi_ort = 0.d0 + print*,'Providing the three_e_5_idx_exch12_bi_ort ...' + call wall_time(wall0) + provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,m,l,integral) & + !$OMP SHARED (mo_num,three_e_5_idx_exch12_bi_ort) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do l = 1, mo_num + do m = 1, mo_num + call give_integrals_3_body_bi_ort(m,l,k,m,i,j,integral) + three_e_5_idx_exch12_bi_ort(m,l,j,k,i) = -1.d0 * integral + enddo + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call wall_time(wall1) + print*,'wall time for three_e_5_idx_exch12_bi_ort',wall1 - wall0 + +END_PROVIDER diff --git a/src/bi_ort_ints/three_body_ints_bi_ort.irp.f b/src/bi_ort_ints/three_body_ints_bi_ort.irp.f new file mode 100644 index 00000000..1fe27ab1 --- /dev/null +++ b/src/bi_ort_ints/three_body_ints_bi_ort.irp.f @@ -0,0 +1,78 @@ +BEGIN_PROVIDER [ double precision, three_body_ints_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator +! +! notice the -1 sign: in this way three_body_ints_bi_ort can be directly used to compute Slater rules :) + END_DOC + integer :: i,j,k,l,m,n + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_body_ints_bi_ort = 0.d0 + print*,'Providing the three_body_ints_bi_ort ...' + call wall_time(wall0) + name_file = 'six_index_tensor' +! if(read_three_body_ints_bi_ort)then +! call read_fcidump_3_tc(three_body_ints_bi_ort) +! else +! if(read_three_body_ints_bi_ort)then +! print*,'Reading three_body_ints_bi_ort from disk ...' +! call read_array_6_index_tensor(mo_num,three_body_ints_bi_ort,name_file) +! else + provide x_W_ki_bi_ortho_erf_rk mos_r_in_r_array_transp mos_l_in_r_array_transp + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,l,m,n,integral) & + !$OMP SHARED (mo_num,three_body_ints_bi_ort) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do j = 1, mo_num + do m = 1, mo_num + do k = 1, mo_num + do l = 1, mo_num + do n = 1, mo_num + call give_integrals_3_body_bi_ort(n,l,k,m,j,i,integral) + three_body_ints_bi_ort(n,l,k,m,j,i) = -1.d0 * integral + enddo + enddo + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL +! endif +! endif + call wall_time(wall1) + print*,'wall time for three_body_ints_bi_ort',wall1 - wall0 +! if(write_three_body_ints_bi_ort)then +! print*,'Writing three_body_ints_bi_ort on disk ...' +! call write_array_6_index_tensor(mo_num,three_body_ints_bi_ort,name_file) +! call ezfio_set_three_body_ints_bi_ort_io_three_body_ints_bi_ort("Read") +! endif + +END_PROVIDER + +subroutine give_integrals_3_body_bi_ort(n,l,k,m,j,i,integral) + implicit none + double precision, intent(out) :: integral + integer, intent(in) :: n,l,k,m,j,i + double precision :: weight + BEGIN_DOC +! with a BI ORTHONORMAL ORBITALS + END_DOC + integer :: ipoint,mm + integral = 0.d0 + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + weight = final_weight_at_r_vector(ipoint) + integral += weight * mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i) & + * x_W_ki_bi_ortho_erf_rk(ipoint,mm,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,mm,l,j) + integral += weight * mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,j) & + * x_W_ki_bi_ortho_erf_rk(ipoint,mm,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,mm,k,i) + integral += weight * mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,m) & + * x_W_ki_bi_ortho_erf_rk(ipoint,mm,l,j) * x_W_ki_bi_ortho_erf_rk(ipoint,mm,k,i) + enddo + enddo +end + diff --git a/src/bi_ort_ints/total_twoe_pot.irp.f b/src/bi_ort_ints/total_twoe_pot.irp.f new file mode 100644 index 00000000..b71a85d2 --- /dev/null +++ b/src/bi_ort_ints/total_twoe_pot.irp.f @@ -0,0 +1,138 @@ +BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_num) ] + integer :: i,j,k,l + BEGIN_DOC +! ao_two_e_tc_tot(k,i,l,j) = (ki|V^TC(r_12)|lj) = where V^TC(r_12) is the total TC operator +! +! including both hermitian and non hermitian parts. THIS IS IN CHEMIST NOTATION. +! +! WARNING :: non hermitian ! acts on "the right functions" (i,j) + END_DOC + double precision :: integral_sym, integral_nsym, get_ao_tc_sym_two_e_pot + PROVIDE ao_tc_sym_two_e_pot_in_map + do j = 1, ao_num + do l = 1, ao_num + do i = 1, ao_num + do k = 1, ao_num + integral_sym = get_ao_tc_sym_two_e_pot(i,j,k,l,ao_tc_sym_two_e_pot_map) + ! ao_non_hermit_term_chemist(k,i,l,j) = < k l | [erf( mu r12) - 1] d/d_r12 | i j > on the AO basis + integral_nsym = ao_non_hermit_term_chemist(k,i,l,j) + ao_two_e_tc_tot(k,i,l,j) = integral_sym + integral_nsym + enddo + enddo + enddo + enddo +END_PROVIDER + + +double precision function bi_ortho_mo_ints(l,k,j,i) + implicit none + BEGIN_DOC +! +! +! WARNING :: very naive, super slow, only used to DEBUG. + END_DOC + integer, intent(in) :: i,j,k,l + integer :: m,n,p,q + bi_ortho_mo_ints = 0.d0 + do m = 1, ao_num + do p = 1, ao_num + do n = 1, ao_num + do q = 1, ao_num + ! p1h1p2h2 l1 l2 r1 r2 + bi_ortho_mo_ints += ao_two_e_tc_tot(n,q,m,p) * mo_l_coef(m,l) * mo_l_coef(n,k) * mo_r_coef(p,j) * mo_r_coef(q,i) + enddo + enddo + enddo + enddo + +end + +! --- + +BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! mo_bi_ortho_tc_two_e_chemist(k,i,l,j) = where i,j are right MOs and k,l are left MOs + END_DOC + integer :: i,j,k,l,m,n,p,q + double precision, allocatable :: mo_tmp_1(:,:,:,:),mo_tmp_2(:,:,:,:),mo_tmp_3(:,:,:,:) + +!! TODO :: transform into DEGEMM + + allocate(mo_tmp_1(mo_num,ao_num,ao_num,ao_num)) + mo_tmp_1 = 0.d0 + do m = 1, ao_num + do p = 1, ao_num + do n = 1, ao_num + do q = 1, ao_num + do k = 1, mo_num + ! (k n|p m) = sum_q c_qk * (q n|p m) + mo_tmp_1(k,n,p,m) += mo_l_coef_transp(k,q) * ao_two_e_tc_tot(q,n,p,m) + enddo + enddo + enddo + enddo + enddo + allocate(mo_tmp_2(mo_num,mo_num,ao_num,ao_num)) + mo_tmp_2 = 0.d0 + do m = 1, ao_num + do p = 1, ao_num + do n = 1, ao_num + do i = 1, mo_num + do k = 1, mo_num + ! (k i|p m) = sum_n c_ni * (k n|p m) + mo_tmp_2(k,i,p,m) += mo_r_coef_transp(i,n) * mo_tmp_1(k,n,p,m) + enddo + enddo + enddo + enddo + enddo + deallocate(mo_tmp_1) + allocate(mo_tmp_1(mo_num,mo_num,mo_num,ao_num)) + mo_tmp_1 = 0.d0 + do m = 1, ao_num + do p = 1, ao_num + do l = 1, mo_num + do i = 1, mo_num + do k = 1, mo_num + mo_tmp_1(k,i,l,m) += mo_l_coef_transp(l,p) * mo_tmp_2(k,i,p,m) + enddo + enddo + enddo + enddo + enddo + deallocate(mo_tmp_2) + mo_bi_ortho_tc_two_e_chemist = 0.d0 + do m = 1, ao_num + do j = 1, mo_num + do l = 1, mo_num + do i = 1, mo_num + do k = 1, mo_num + mo_bi_ortho_tc_two_e_chemist(k,i,l,j) += mo_r_coef_transp(j,m) * mo_tmp_1(k,i,l,m) + enddo + enddo + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e, (mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! mo_bi_ortho_tc_two_e(k,l,i,j) = where i,j are right MOs and k,l are left MOs +! +! the potential V(r_12) contains ALL TWO-E CONTRIBUTION OF THE TC-HAMILTONIAN + END_DOC + integer :: i,j,k,l + do j = 1, mo_num + do i = 1, mo_num + do l = 1, mo_num + do k = 1, mo_num + ! (k i|l j) = + mo_bi_ortho_tc_two_e(k,l,i,j) = mo_bi_ortho_tc_two_e_chemist(k,i,l,j) + enddo + enddo + enddo + enddo +END_PROVIDER diff --git a/src/bi_ortho_aos/NEED b/src/bi_ortho_aos/NEED new file mode 100644 index 00000000..26404a02 --- /dev/null +++ b/src/bi_ortho_aos/NEED @@ -0,0 +1,2 @@ +basis +ao_basis diff --git a/src/bi_ortho_aos/README.rst b/src/bi_ortho_aos/README.rst new file mode 100644 index 00000000..f35bfc4f --- /dev/null +++ b/src/bi_ortho_aos/README.rst @@ -0,0 +1,5 @@ +============ +bi_ortho_aos +============ + +TODO diff --git a/src/bi_ortho_aos/aos_l.irp.f b/src/bi_ortho_aos/aos_l.irp.f new file mode 100644 index 00000000..7c89c82b --- /dev/null +++ b/src/bi_ortho_aos/aos_l.irp.f @@ -0,0 +1,97 @@ + BEGIN_PROVIDER [ double precision, ao_coef_l , (ao_num,ao_prim_num_max) ] + implicit none + BEGIN_DOC +! Primitive coefficients and exponents for each atomic orbital. Copied from shell info. + END_DOC + + integer :: i, l + do i=1,ao_num + l = ao_shell(i) + ao_coef_l(i,:) = shell_coef(l,:) + end do +END_PROVIDER + + BEGIN_PROVIDER [ double precision, ao_coef_l_normalized, (ao_num,ao_prim_num_max) ] +&BEGIN_PROVIDER [ double precision, ao_coef_l_normalization_factor, (ao_num) ] + implicit none + BEGIN_DOC + ! Coefficients including the |AO| normalization + END_DOC + + do i=1,ao_num + l = ao_shell(i) + ao_coef_l_normalized(i,:) = shell_coef(l,:) * shell_normalization_factor(l) + end do + + double precision :: norm,overlap_x,overlap_y,overlap_z,C_A(3), c + integer :: l, powA(3), nz + integer :: i,j,k + nz=100 + C_A = 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) + call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,j), & + powA,powA,overlap_x,overlap_y,overlap_z,norm,nz) + ao_coef_l_normalized(i,j) = ao_coef_l_normalized(i,j)/dsqrt(norm) + enddo + endif + ! Normalization of the contracted basis functions + if (ao_normalized) then + norm = 0.d0 + do j=1,ao_prim_num(i) + do k=1,ao_prim_num(i) + call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,k),powA,powA,overlap_x,overlap_y,overlap_z,c,nz) + norm = norm+c*ao_coef_l_normalized(i,j)*ao_coef_l_normalized(i,k) + enddo + enddo + ao_coef_l_normalization_factor(i) = 1.d0/dsqrt(norm) + else + ao_coef_l_normalization_factor(i) = 1.d0 + endif + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ double precision, ao_coef_l_normalized_ordered, (ao_num,ao_prim_num_max) ] + implicit none + BEGIN_DOC + ! Sorted primitives to accelerate 4 index |MO| transformation + END_DOC + + integer :: iorder(ao_prim_num_max) + double precision :: d(ao_prim_num_max,2) + integer :: i,j + do i=1,ao_num + do j=1,ao_prim_num(i) + iorder(j) = j + d(j,2) = ao_coef_l_normalized(i,j) + enddo + call dsort(d(1,1),iorder,ao_prim_num(i)) + call dset_order(d(1,2),iorder,ao_prim_num(i)) + do j=1,ao_prim_num(i) + ao_coef_l_normalized_ordered(i,j) = d(j,2) + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, ao_coef_l_normalized_ordered_transp, (ao_prim_num_max,ao_num) ] + implicit none + BEGIN_DOC + ! Transposed :c:data:`ao_coef_l_normalized_ordered` + END_DOC + integer :: i,j + do j=1, ao_num + do i=1, ao_prim_num_max + ao_coef_l_normalized_ordered_transp(i,j) = ao_coef_l_normalized_ordered(j,i) + enddo + enddo +END_PROVIDER + diff --git a/src/bi_ortho_aos/aos_r.irp.f b/src/bi_ortho_aos/aos_r.irp.f new file mode 100644 index 00000000..8ca6d94e --- /dev/null +++ b/src/bi_ortho_aos/aos_r.irp.f @@ -0,0 +1,97 @@ + BEGIN_PROVIDER [ double precision, ao_coef_r , (ao_num,ao_prim_num_max) ] + implicit none + BEGIN_DOC +! Primitive coefficients and exponents for each atomic orbital. Copied from shell info. + END_DOC + + integer :: i, l + do i=1,ao_num + l = ao_shell(i) + ao_coef_r(i,:) = shell_coef(l,:) + end do +END_PROVIDER + + BEGIN_PROVIDER [ double precision, ao_coef_r_normalized, (ao_num,ao_prim_num_max) ] +&BEGIN_PROVIDER [ double precision, ao_coef_r_normalization_factor, (ao_num) ] + implicit none + BEGIN_DOC + ! Coefficients including the |AO| normalization + END_DOC + + do i=1,ao_num + l = ao_shell(i) + ao_coef_r_normalized(i,:) = shell_coef(l,:) * shell_normalization_factor(l) + end do + + double precision :: norm,overlap_x,overlap_y,overlap_z,C_A(3), c + integer :: l, powA(3), nz + integer :: i,j,k + nz=100 + C_A = 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) + call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,j), & + powA,powA,overlap_x,overlap_y,overlap_z,norm,nz) + ao_coef_r_normalized(i,j) = ao_coef_r_normalized(i,j)/dsqrt(norm) + enddo + endif + ! Normalization of the contracted basis functions + if (ao_normalized) then + norm = 0.d0 + do j=1,ao_prim_num(i) + do k=1,ao_prim_num(i) + call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,k),powA,powA,overlap_x,overlap_y,overlap_z,c,nz) + norm = norm+c*ao_coef_r_normalized(i,j)*ao_coef_r_normalized(i,k) + enddo + enddo + ao_coef_r_normalization_factor(i) = 1.d0/dsqrt(norm) + else + ao_coef_r_normalization_factor(i) = 1.d0 + endif + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ double precision, ao_coef_r_normalized_ordered, (ao_num,ao_prim_num_max) ] + implicit none + BEGIN_DOC + ! Sorted primitives to accelerate 4 index |MO| transformation + END_DOC + + integer :: iorder(ao_prim_num_max) + double precision :: d(ao_prim_num_max,2) + integer :: i,j + do i=1,ao_num + do j=1,ao_prim_num(i) + iorder(j) = j + d(j,2) = ao_coef_r_normalized(i,j) + enddo + call dsort(d(1,1),iorder,ao_prim_num(i)) + call dset_order(d(1,2),iorder,ao_prim_num(i)) + do j=1,ao_prim_num(i) + ao_coef_r_normalized_ordered(i,j) = d(j,2) + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, ao_coef_r_normalized_ordered_transp, (ao_prim_num_max,ao_num) ] + implicit none + BEGIN_DOC + ! Transposed :c:data:`ao_coef_r_normalized_ordered` + END_DOC + integer :: i,j + do j=1, ao_num + do i=1, ao_prim_num_max + ao_coef_r_normalized_ordered_transp(i,j) = ao_coef_r_normalized_ordered(j,i) + enddo + enddo +END_PROVIDER + diff --git a/src/bi_ortho_mos/EZFIO.cfg b/src/bi_ortho_mos/EZFIO.cfg new file mode 100644 index 00000000..9b06a655 --- /dev/null +++ b/src/bi_ortho_mos/EZFIO.cfg @@ -0,0 +1,11 @@ +[mo_r_coef] +type: double precision +doc: right-coefficient of the i-th |AO| on the j-th |MO| +interface: ezfio +size: (ao_basis.ao_num,mo_basis.mo_num) + +[mo_l_coef] +type: double precision +doc: right-coefficient of the i-th |AO| on the j-th |MO| +interface: ezfio +size: (ao_basis.ao_num,mo_basis.mo_num) diff --git a/src/bi_ortho_mos/NEED b/src/bi_ortho_mos/NEED new file mode 100644 index 00000000..2a2196e5 --- /dev/null +++ b/src/bi_ortho_mos/NEED @@ -0,0 +1,3 @@ +mo_basis +becke_numerical_grid +dft_utils_in_r diff --git a/src/bi_ortho_mos/bi_density.irp.f b/src/bi_ortho_mos/bi_density.irp.f new file mode 100644 index 00000000..947be870 --- /dev/null +++ b/src/bi_ortho_mos/bi_density.irp.f @@ -0,0 +1,49 @@ + +! --- + +BEGIN_PROVIDER [double precision, TCSCF_bi_ort_dm_ao_alpha, (ao_num, ao_num) ] + implicit none + BEGIN_DOC +! TCSCF_bi_ort_dm_ao_alpha(i,j) = where i,j are AO basis. +! +! This is the equivalent of the alpha density of the HF Slater determinant, but with a couple of bi-orthonormal Slater determinant |Chi_0> and |Phi_0> + END_DOC + call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 & + , mo_l_coef, size(mo_l_coef, 1), mo_r_coef, size(mo_r_coef, 1) & + , 0.d0, TCSCF_bi_ort_dm_ao_alpha, size(TCSCF_bi_ort_dm_ao_alpha, 1) ) +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, TCSCF_bi_ort_dm_ao_beta, (ao_num, ao_num) ] + implicit none + BEGIN_DOC +! TCSCF_bi_ort_dm_ao_beta(i,j) = where i,j are AO basis. +! +! This is the equivalent of the beta density of the HF Slater determinant, but with a couple of bi-orthonormal Slater determinant |Chi_0> and |Phi_0> + END_DOC + call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 & + , mo_l_coef, size(mo_l_coef, 1), mo_r_coef, size(mo_r_coef, 1) & + , 0.d0, TCSCF_bi_ort_dm_ao_beta, size(TCSCF_bi_ort_dm_ao_beta, 1) ) +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, TCSCF_bi_ort_dm_ao, (ao_num, ao_num) ] + implicit none + BEGIN_DOC +! TCSCF_bi_ort_dm_ao(i,j) = where i,j are AO basis. +! +! This is the equivalent of the total electronic density of the HF Slater determinant, but with a couple of bi-orthonormal Slater determinant |Chi_0> and |Phi_0> + END_DOC + ASSERT ( size(TCSCF_bi_ort_dm_ao, 1) == size(TCSCF_bi_ort_dm_ao_alpha, 1) ) + if( elec_alpha_num==elec_beta_num ) then + TCSCF_bi_ort_dm_ao = TCSCF_bi_ort_dm_ao_alpha + TCSCF_bi_ort_dm_ao_alpha + else + ASSERT ( size(TCSCF_bi_ort_dm_ao, 1) == size(TCSCF_bi_ort_dm_ao_beta, 1)) + TCSCF_bi_ort_dm_ao = TCSCF_bi_ort_dm_ao_alpha + TCSCF_bi_ort_dm_ao_beta + endif +END_PROVIDER + +! --- + diff --git a/src/bi_ortho_mos/bi_ort_mos_in_r.irp.f b/src/bi_ortho_mos/bi_ort_mos_in_r.irp.f new file mode 100644 index 00000000..42130575 --- /dev/null +++ b/src/bi_ortho_mos/bi_ort_mos_in_r.irp.f @@ -0,0 +1,137 @@ + +! TODO: left & right MO without duplicate AO calculation + +! --- + +BEGIN_PROVIDER[double precision, mos_r_in_r_array, (mo_num, n_points_final_grid)] + + BEGIN_DOC + ! mos_in_r_array(i,j) = value of the ith RIGHT mo on the jth grid point + END_DOC + + implicit none + integer :: i, j + double precision :: mos_array(mo_num), r(3) + + !$OMP PARALLEL DO & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, j, r, mos_array) & + !$OMP SHARED (mos_r_in_r_array, n_points_final_grid, mo_num, final_grid_points) + do i = 1, n_points_final_grid + r(1) = final_grid_points(1,i) + r(2) = final_grid_points(2,i) + r(3) = final_grid_points(3,i) + call give_all_mos_r_at_r(r, mos_array) + do j = 1, mo_num + mos_r_in_r_array(j,i) = mos_array(j) + enddo + enddo + !$OMP END PARALLEL DO + +END_PROVIDER + +! --- + +BEGIN_PROVIDER[double precision, mos_r_in_r_array_transp, (n_points_final_grid, mo_num)] + + BEGIN_DOC + ! mos_r_in_r_array_transp(i,j) = value of the jth mo on the ith grid point + END_DOC + + implicit none + integer :: i,j + + do i = 1, n_points_final_grid + do j = 1, mo_num + mos_r_in_r_array_transp(i,j) = mos_r_in_r_array(j,i) + enddo + enddo + +END_PROVIDER + +! --- + +subroutine give_all_mos_r_at_r(r, mos_r_array) + + BEGIN_DOC + ! mos_r_array(i) = ith RIGHT MO function evaluated at "r" + END_DOC + + implicit none + double precision, intent(in) :: r(3) + double precision, intent(out) :: mos_r_array(mo_num) + double precision :: aos_array(ao_num) + + call give_all_aos_at_r(r, aos_array) + call dgemv('N', mo_num, ao_num, 1.d0, mo_r_coef_transp, mo_num, aos_array, 1, 0.d0, mos_r_array, 1) + +end subroutine give_all_mos_r_at_r + +! --- + +BEGIN_PROVIDER[double precision, mos_l_in_r_array, (mo_num, n_points_final_grid)] + + BEGIN_DOC + ! mos_in_r_array(i,j) = value of the ith LEFT mo on the jth grid point + END_DOC + + implicit none + integer :: i, j + double precision :: mos_array(mo_num), r(3) + + !$OMP PARALLEL DO & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,r,mos_array,j) & + !$OMP SHARED(mos_l_in_r_array,n_points_final_grid,mo_num,final_grid_points) + do i = 1, n_points_final_grid + r(1) = final_grid_points(1,i) + r(2) = final_grid_points(2,i) + r(3) = final_grid_points(3,i) + call give_all_mos_l_at_r(r, mos_array) + do j = 1, mo_num + mos_l_in_r_array(j,i) = mos_array(j) + enddo + enddo + !$OMP END PARALLEL DO + +END_PROVIDER + +! --- + +subroutine give_all_mos_l_at_r(r, mos_l_array) + + BEGIN_DOC + ! mos_l_array(i) = ith LEFT MO function evaluated at "r" + END_DOC + + implicit none + double precision, intent(in) :: r(3) + double precision, intent(out) :: mos_l_array(mo_num) + double precision :: aos_array(ao_num) + + call give_all_aos_at_r(r, aos_array) + call dgemv('N', mo_num, ao_num, 1.d0, mo_l_coef_transp, mo_num, aos_array, 1, 0.d0, mos_l_array, 1) + +end subroutine give_all_mos_l_at_r + +! --- + +BEGIN_PROVIDER[double precision, mos_l_in_r_array_transp,(n_points_final_grid,mo_num)] + + BEGIN_DOC + ! mos_l_in_r_array_transp(i,j) = value of the jth mo on the ith grid point + END_DOC + + implicit none + integer :: i, j + + do i = 1, n_points_final_grid + do j = 1, mo_num + mos_l_in_r_array_transp(i,j) = mos_l_in_r_array(j,i) + enddo + enddo + +END_PROVIDER + +! --- + diff --git a/src/bi_ortho_mos/grad_bi_ort_mos_in_r.irp.f b/src/bi_ortho_mos/grad_bi_ort_mos_in_r.irp.f new file mode 100644 index 00000000..5478fa5c --- /dev/null +++ b/src/bi_ortho_mos/grad_bi_ort_mos_in_r.irp.f @@ -0,0 +1,100 @@ + BEGIN_PROVIDER[double precision, mos_r_grad_in_r_array,(mo_num,n_points_final_grid,3)] + implicit none + BEGIN_DOC + ! mos_r_grad_in_r_array(i,j,k) = value of the kth component of the gradient of ith RIGHT mo on the jth grid point + ! + ! k = 1 : x, k= 2, y, k 3, z + END_DOC + integer :: m + mos_r_grad_in_r_array = 0.d0 + do m=1,3 + call dgemm('N','N',mo_num,n_points_final_grid,ao_num,1.d0,mo_r_coef_transp,mo_num,aos_grad_in_r_array(1,1,m),ao_num,0.d0,mos_r_grad_in_r_array(1,1,m),mo_num) + enddo + END_PROVIDER + + BEGIN_PROVIDER[double precision, mos_r_grad_in_r_array_transp,(3,mo_num,n_points_final_grid)] + implicit none + BEGIN_DOC + ! mos_r_grad_in_r_array_transp(i,j,k) = value of the kth component of the gradient of jth RIGHT mo on the ith grid point + ! + ! k = 1 : x, k= 2, y, k 3, z + END_DOC + integer :: m + integer :: i,j + mos_r_grad_in_r_array_transp = 0.d0 + do i = 1, n_points_final_grid + do j = 1, mo_num + do m = 1, 3 + mos_r_grad_in_r_array_transp(m,j,i) = mos_r_grad_in_r_array(j,i,m) + enddo + enddo + enddo + END_PROVIDER + + BEGIN_PROVIDER[double precision, mos_r_grad_in_r_array_transp_bis,(3,n_points_final_grid,mo_num)] + implicit none + BEGIN_DOC + ! mos_r_grad_in_r_array_transp(i,j,k) = value of the ith component of the gradient on the jth grid point of jth RIGHT MO + END_DOC + integer :: m + integer :: i,j + mos_r_grad_in_r_array_transp_bis = 0.d0 + do j = 1, mo_num + do i = 1, n_points_final_grid + do m = 1, 3 + mos_r_grad_in_r_array_transp_bis(m,i,j) = mos_r_grad_in_r_array(j,i,m) + enddo + enddo + enddo + END_PROVIDER + + + BEGIN_PROVIDER[double precision, mos_l_grad_in_r_array,(mo_num,n_points_final_grid,3)] + implicit none + BEGIN_DOC + ! mos_l_grad_in_r_array(i,j,k) = value of the kth component of the gradient of ith RIGHT mo on the jth grid point + ! + ! k = 1 : x, k= 2, y, k 3, z + END_DOC + integer :: m + mos_l_grad_in_r_array = 0.d0 + do m=1,3 + call dgemm('N','N',mo_num,n_points_final_grid,ao_num,1.d0,mo_r_coef_transp,mo_num,aos_grad_in_r_array(1,1,m),ao_num,0.d0,mos_l_grad_in_r_array(1,1,m),mo_num) + enddo + END_PROVIDER + + BEGIN_PROVIDER[double precision, mos_l_grad_in_r_array_transp,(3,mo_num,n_points_final_grid)] + implicit none + BEGIN_DOC + ! mos_l_grad_in_r_array_transp(i,j,k) = value of the kth component of the gradient of jth RIGHT mo on the ith grid point + ! + ! k = 1 : x, k= 2, y, k 3, z + END_DOC + integer :: m + integer :: i,j + mos_l_grad_in_r_array_transp = 0.d0 + do i = 1, n_points_final_grid + do j = 1, mo_num + do m = 1, 3 + mos_l_grad_in_r_array_transp(m,j,i) = mos_l_grad_in_r_array(j,i,m) + enddo + enddo + enddo + END_PROVIDER + + BEGIN_PROVIDER[double precision, mos_l_grad_in_r_array_transp_bis,(3,n_points_final_grid,mo_num)] + implicit none + BEGIN_DOC + ! mos_l_grad_in_r_array_transp(i,j,k) = value of the ith component of the gradient on the jth grid point of jth RIGHT MO + END_DOC + integer :: m + integer :: i,j + mos_l_grad_in_r_array_transp_bis = 0.d0 + do j = 1, mo_num + do i = 1, n_points_final_grid + do m = 1, 3 + mos_l_grad_in_r_array_transp_bis(m,i,j) = mos_l_grad_in_r_array(j,i,m) + enddo + enddo + enddo + END_PROVIDER diff --git a/src/bi_ortho_mos/mos_rl.irp.f b/src/bi_ortho_mos/mos_rl.irp.f new file mode 100644 index 00000000..b6e93c17 --- /dev/null +++ b/src/bi_ortho_mos/mos_rl.irp.f @@ -0,0 +1,173 @@ +subroutine ao_to_mo_bi_ortho(A_ao, LDA_ao, A_mo, LDA_mo) + + BEGIN_DOC + ! Transform A from the |AO| basis to the BI ORTHONORMAL MOS + ! + ! $C_L^\dagger.A_{ao}.C_R$ where C_L and C_R are the LEFT and RIGHT MO coefs + END_DOC + + implicit none + integer, intent(in) :: LDA_ao,LDA_mo + double precision, intent(in) :: A_ao(LDA_ao,ao_num) + double precision, intent(out) :: A_mo(LDA_mo,mo_num) + double precision, allocatable :: T(:,:) + + allocate ( T(ao_num,mo_num) ) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T + integer :: i,j,p,q + + call dgemm('N', 'N', ao_num, mo_num, ao_num, & + 1.d0, A_ao, LDA_ao, & + mo_r_coef, size(mo_r_coef, 1), & + 0.d0, T, size(T, 1)) + + call dgemm('T', 'N', mo_num, mo_num, ao_num, & + 1.d0, mo_l_coef, size(mo_l_coef, 1), & + T, ao_num, & + 0.d0, A_mo, size(A_mo, 1)) + +! call restore_symmetry(mo_num,mo_num,A_mo,size(A_mo,1),1.d-12) + deallocate(T) + +end subroutine ao_to_mo_bi_ortho + +! --- + +BEGIN_PROVIDER [ double precision, mo_r_coef, (ao_num, mo_num) ] + + BEGIN_DOC + ! + ! Molecular right-orbital coefficients on |AO| basis set + ! + END_DOC + + implicit none + integer :: i, j + logical :: exists + + PROVIDE ezfio_filename + + if (mpi_master) then + call ezfio_has_bi_ortho_mos_mo_r_coef(exists) + endif + IRP_IF MPI_DEBUG + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + IRP_ENDIF + IRP_IF MPI + include 'mpif.h' + integer :: ierr + call MPI_BCAST(exists, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read mo_r_coef with MPI' + endif + IRP_ENDIF + + if (exists) then + if (mpi_master) then + call ezfio_get_bi_ortho_mos_mo_r_coef(mo_r_coef) + write(*,*) 'Read mo_r_coef' + endif + IRP_IF MPI + call MPI_BCAST(mo_r_coef, mo_num*ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read mo_r_coef with MPI' + endif + IRP_ENDIF + else + + print*, 'mo_r_coef are mo_coef' + do i = 1, mo_num + do j = 1, ao_num + mo_r_coef(j,i) = mo_coef(j,i) + enddo + enddo + endif + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, mo_l_coef, (ao_num, mo_num) ] + + BEGIN_DOC + ! + ! Molecular left-orbital coefficients on |AO| basis set + ! + END_DOC + + implicit none + integer :: i, j + logical :: exists + + PROVIDE ezfio_filename + + if (mpi_master) then + call ezfio_has_bi_ortho_mos_mo_l_coef(exists) + endif + IRP_IF MPI_DEBUG + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + IRP_ENDIF + IRP_IF MPI + include 'mpif.h' + integer :: ierr + call MPI_BCAST(exists, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read mo_l_coef with MPI' + endif + IRP_ENDIF + + if (exists) then + if (mpi_master) then + call ezfio_get_bi_ortho_mos_mo_l_coef(mo_l_coef) + write(*,*) 'Read mo_l_coef' + endif + IRP_IF MPI + call MPI_BCAST(mo_l_coef, mo_num*ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read mo_l_coef with MPI' + endif + IRP_ENDIF + else + + print*, 'mo_r_coef are mo_coef' + do i = 1, mo_num + do j = 1, ao_num + mo_l_coef(j,i) = mo_coef(j,i) + enddo + enddo + endif + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, mo_r_coef_transp, (mo_num, ao_num)] + + implicit none + integer :: j, m + do j = 1, mo_num + do m = 1, ao_num + mo_r_coef_transp(j,m) = mo_r_coef(m,j) + enddo + enddo + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, mo_l_coef_transp, (mo_num, ao_num)] + + implicit none + integer :: j, m + do j = 1, mo_num + do m = 1, ao_num + mo_l_coef_transp(j,m) = mo_l_coef(m,j) + enddo + enddo + +END_PROVIDER + +! --- + diff --git a/src/bi_ortho_mos/overlap.irp.f b/src/bi_ortho_mos/overlap.irp.f new file mode 100644 index 00000000..b974492f --- /dev/null +++ b/src/bi_ortho_mos/overlap.irp.f @@ -0,0 +1,120 @@ + + + BEGIN_PROVIDER [ double precision, overlap_bi_ortho, (mo_num, mo_num)] +&BEGIN_PROVIDER [ double precision, overlap_diag_bi_ortho, (mo_num)] + + BEGIN_DOC + ! Overlap matrix between the RIGHT and LEFT MOs. Should be the identity matrix + END_DOC + + implicit none + integer :: i, k, m, n + double precision :: accu_d, accu_nd + double precision, allocatable :: tmp(:,:) + + ! TODO : re do the DEGEMM + + overlap_bi_ortho = 0.d0 + do i = 1, mo_num + do k = 1, mo_num + do m = 1, ao_num + do n = 1, ao_num + overlap_bi_ortho(k,i) += ao_overlap(n,m) * mo_l_coef(n,k) * mo_r_coef(m,i) + enddo + enddo + enddo + enddo + +! allocate( tmp(mo_num,ao_num) ) +! +! ! tmp <-- L.T x S_ao +! call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 & +! , mo_l_coef, size(mo_l_coef, 1), ao_overlap, size(ao_overlap, 1) & +! , 0.d0, tmp, size(tmp, 1) ) +! +! ! S <-- tmp x R +! call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0 & +! , tmp, size(tmp, 1), mo_r_coef, size(mo_r_coef, 1) & +! , 0.d0, overlap_bi_ortho, size(overlap_bi_ortho, 1) ) +! +! deallocate( tmp ) + + do i = 1, mo_num + overlap_diag_bi_ortho(i) = overlap_bi_ortho(i,i) + enddo + + accu_d = 0.d0 + accu_nd = 0.d0 + do i = 1, mo_num + do k = 1, mo_num + if(i==k) then + accu_d += dabs(overlap_bi_ortho(k,i)) + else + accu_nd += dabs(overlap_bi_ortho(k,i)) + endif + enddo + enddo + accu_d = accu_d/dble(mo_num) + accu_nd = accu_nd/dble(mo_num**2-mo_num) + if(dabs(accu_d-1.d0).gt.1.d-10.or.dabs(accu_nd).gt.1.d-10)then + print*,'Warning !!!' + print*,'Average trace of overlap_bi_ortho is different from 1 by ', accu_d + print*,'And bi orthogonality is off by an average of ',accu_nd + print*,'****************' + print*,'Overlap matrix betwee mo_l_coef and mo_r_coef ' + do i = 1, mo_num + write(*,'(100(F16.10,X))')overlap_bi_ortho(i,:) + enddo + endif + print*,'Average trace of overlap_bi_ortho (should be 1.)' + print*,'accu_d = ',accu_d + print*,'Sum of off diagonal terms of overlap_bi_ortho (should be zero)' + print*,'accu_nd = ',accu_nd + print*,'****************' + +END_PROVIDER + +! --- + + + BEGIN_PROVIDER [ double precision, overlap_mo_r, (mo_num, mo_num)] +&BEGIN_PROVIDER [ double precision, overlap_mo_l, (mo_num, mo_num)] + implicit none + BEGIN_DOC +! overlap_mo_r_mo(j,i) = + END_DOC + integer :: i,j,p,q + overlap_mo_r= 0.d0 + overlap_mo_l= 0.d0 + do i = 1, mo_num + do j = 1, mo_num + do p = 1, ao_num + do q = 1, ao_num + overlap_mo_r(j,i) += mo_r_coef(q,i) * mo_r_coef(p,j) * ao_overlap(q,p) + overlap_mo_l(j,i) += mo_l_coef(q,i) * mo_l_coef(p,j) * ao_overlap(q,p) + enddo + enddo + enddo + enddo +END_PROVIDER + + BEGIN_PROVIDER [ double precision, overlap_mo_r_mo, (mo_num, mo_num)] +&BEGIN_PROVIDER [ double precision, overlap_mo_l_mo, (mo_num, mo_num)] + implicit none + BEGIN_DOC +! overlap_mo_r_mo(j,i) = + END_DOC + integer :: i,j,p,q + overlap_mo_r_mo = 0.d0 + overlap_mo_l_mo = 0.d0 + do i = 1, mo_num + do j = 1, mo_num + do p = 1, ao_num + do q = 1, ao_num + overlap_mo_r_mo(j,i) += mo_coef(p,j) * mo_r_coef(q,i) * ao_overlap(q,p) + overlap_mo_l_mo(j,i) += mo_coef(p,j) * mo_l_coef(q,i) * ao_overlap(q,p) + enddo + enddo + enddo + enddo +END_PROVIDER diff --git a/src/non_h_ints_mu/NEED b/src/non_h_ints_mu/NEED new file mode 100644 index 00000000..d09ab4a5 --- /dev/null +++ b/src/non_h_ints_mu/NEED @@ -0,0 +1,2 @@ +ao_tc_eff_map +bi_ortho_mos diff --git a/src/non_h_ints_mu/README.rst b/src/non_h_ints_mu/README.rst new file mode 100644 index 00000000..6a36bb98 --- /dev/null +++ b/src/non_h_ints_mu/README.rst @@ -0,0 +1,11 @@ +============= +non_h_ints_mu +============= + +Computes the non hermitian potential of the mu-TC Hamiltonian on the AO and BI-ORTHO MO basis. +The operator is defined in Eq. 33 of JCP 154, 084119 (2021) + +The two providers are : ++) ao_non_hermit_term_chemist which returns the non hermitian part of the two-electron TC Hamiltonian on the MO basis. ++) mo_non_hermit_term_chemist which returns the non hermitian part of the two-electron TC Hamiltonian on the BI-ORTHO MO basis. + diff --git a/src/non_h_ints_mu/grad_tc_int.irp.f b/src/non_h_ints_mu/grad_tc_int.irp.f new file mode 100644 index 00000000..dd60e724 --- /dev/null +++ b/src/non_h_ints_mu/grad_tc_int.irp.f @@ -0,0 +1,177 @@ +BEGIN_PROVIDER [double precision, ao_non_hermit_term_chemist, (ao_num, ao_num, ao_num, ao_num)] + implicit none +BEGIN_DOC +! 1 1 2 2 1 2 1 2 +! +! ao_non_hermit_term_chemist(k,i,l,j) = < k l | [erf( mu r12) - 1] d/d_r12 | i j > on the AO basis +END_DOC + integer :: i,j,k,l,ipoint,m + double precision :: weight1,thr,r(3) + thr = 1.d-8 + double precision, allocatable :: b_mat(:,:,:,:),ac_mat(:,:,:,:) +! provide v_ij_erf_rk_cst_mu + provide v_ij_erf_rk_cst_mu x_v_ij_erf_rk_cst_mu + call wall_time(wall0) + allocate(b_mat(n_points_final_grid,ao_num,ao_num,3),ac_mat(ao_num, ao_num, ao_num, ao_num)) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,k,m,ipoint,r,weight1) & + !$OMP SHARED (aos_in_r_array_transp,aos_grad_in_r_array_transp_bis,b_mat)& + !$OMP SHARED (ao_num,n_points_final_grid,final_grid_points,final_weight_at_r_vector) + !$OMP DO SCHEDULE (static) + do m = 1, 3 + do i = 1, ao_num + do k = 1, ao_num + do ipoint = 1, n_points_final_grid + r(1) = final_grid_points(1,ipoint) + r(2) = final_grid_points(2,ipoint) + r(3) = final_grid_points(3,ipoint) + weight1 = final_weight_at_r_vector(ipoint) + b_mat(ipoint,k,i,m) = 0.5d0 * aos_in_r_array_transp(ipoint,k) * r(m) * weight1 * aos_grad_in_r_array_transp_bis(ipoint,i,m) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + ac_mat = 0.d0 + do m = 1, 3 + ! A B^T dim(A,1) dim(B,2) dim(A,2) alpha * A LDA + call dgemm("N","N",ao_num*ao_num,ao_num*ao_num,n_points_final_grid,1.d0,v_ij_erf_rk_cst_mu(1,1,1),ao_num*ao_num & + ,b_mat(1,1,1,m),n_points_final_grid,1.d0,ac_mat,ao_num*ao_num) + enddo + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,k,m,ipoint,weight1) & + !$OMP SHARED (aos_in_r_array_transp,aos_grad_in_r_array_transp_bis,b_mat,ao_num,n_points_final_grid,final_weight_at_r_vector) + !$OMP DO SCHEDULE (static) + do m = 1, 3 + do i = 1, ao_num + do k = 1, ao_num + do ipoint = 1, n_points_final_grid + weight1 = final_weight_at_r_vector(ipoint) + b_mat(ipoint,k,i,m) = 0.5d0 * aos_in_r_array_transp(ipoint,k) * weight1 * aos_grad_in_r_array_transp_bis(ipoint,i,m) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + do m = 1, 3 + ! A B^T dim(A,1) dim(B,2) dim(A,2) alpha * A LDA + call dgemm("N","N",ao_num*ao_num,ao_num*ao_num,n_points_final_grid,-1.d0,x_v_ij_erf_rk_cst_mu(1,1,1,m),ao_num*ao_num & + ,b_mat(1,1,1,m),n_points_final_grid,1.d0,ac_mat,ao_num*ao_num) + enddo + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,k,j,l) & + !$OMP SHARED (ac_mat,ao_non_hermit_term_chemist,ao_num) + !$OMP DO SCHEDULE (static) + do j = 1, ao_num + do l = 1, ao_num + do i = 1, ao_num + do k = 1, ao_num + ao_non_hermit_term_chemist(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + double precision :: wall1, wall0 + call wall_time(wall1) + print*,'wall time dgemm ',wall1 - wall0 +END_PROVIDER + +BEGIN_PROVIDER [double precision, mo_non_hermit_term_chemist, (mo_num, mo_num, mo_num, mo_num)] + implicit none +BEGIN_DOC +! 1 1 2 2 1 2 1 2 +! +! mo_non_hermit_term_chemist(k,i,l,j) = < k l | [erf( mu r12) - 1] d/d_r12 | i j > on the MO basis +END_DOC + integer :: i,j,k,l,m,n,p,q + double precision, allocatable :: mo_tmp_1(:,:,:,:),mo_tmp_2(:,:,:,:),mo_tmp_3(:,:,:,:) + + allocate(mo_tmp_1(mo_num,ao_num,ao_num,ao_num)) + ! TODO :: optimization :: transform into DGEM + mo_tmp_1 = 0.d0 + do m = 1, ao_num + do p = 1, ao_num + do n = 1, ao_num + do q = 1, ao_num + do k = 1, mo_num + ! (k n|p m) = sum_q c_qk * (q n|p m) + mo_tmp_1(k,n,p,m) += mo_coef_transp(k,q) * ao_non_hermit_term_chemist(q,n,p,m) + enddo + enddo + enddo + enddo + enddo + free ao_non_hermit_term_chemist + allocate(mo_tmp_2(mo_num,mo_num,ao_num,ao_num)) + mo_tmp_2 = 0.d0 + do m = 1, ao_num + do p = 1, ao_num + do n = 1, ao_num + do i = 1, mo_num + do k = 1, mo_num + ! (k i|p m) = sum_n c_ni * (k n|p m) + mo_tmp_2(k,i,p,m) += mo_coef_transp(i,n) * mo_tmp_1(k,n,p,m) + enddo + enddo + enddo + enddo + enddo + deallocate(mo_tmp_1) + allocate(mo_tmp_1(mo_num,mo_num,mo_num,ao_num)) + mo_tmp_1 = 0.d0 + do m = 1, ao_num + do p = 1, ao_num + do l = 1, mo_num + do i = 1, mo_num + do k = 1, mo_num + mo_tmp_1(k,i,l,m) += mo_coef_transp(l,p) * mo_tmp_2(k,i,p,m) + enddo + enddo + enddo + enddo + enddo + deallocate(mo_tmp_2) + mo_non_hermit_term_chemist = 0.d0 + do m = 1, ao_num + do j = 1, mo_num + do l = 1, mo_num + do i = 1, mo_num + do k = 1, mo_num + mo_non_hermit_term_chemist(k,i,l,j) += mo_coef_transp(j,m) * mo_tmp_1(k,i,l,m) + enddo + enddo + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [double precision, mo_non_hermit_term, (mo_num, mo_num, mo_num, mo_num)] + implicit none +BEGIN_DOC +! 1 2 1 2 1 2 1 2 +! +! mo_non_hermit_term(k,l,i,j) = < k l | [erf( mu r12) - 1] d/d_r12 | i j > on the MO basis +END_DOC + integer :: i,j,k,l + do j = 1, mo_num + do i = 1, mo_num + do l = 1, mo_num + do k = 1, mo_num + mo_non_hermit_term(k,l,i,j) = mo_non_hermit_term_chemist(k,i,l,j) + enddo + enddo + enddo + enddo +END_PROVIDER diff --git a/src/utils/integration.irp.f b/src/utils/integration.irp.f index fe4418ac..c2bff2e8 100644 --- a/src/utils/integration.irp.f +++ b/src/utils/integration.irp.f @@ -412,6 +412,79 @@ subroutine recentered_poly2(P_new,x_A,x_P,a,P_new2,x_B,x_Q,b) enddo end +subroutine pol_modif_center(A_center, B_center, iorder, A_pol, B_pol) + + BEGIN_DOC + ! + ! Transform the pol centerd on A: + ! [ \sum_i ax_i (x-x_A)^i ] [ \sum_j ay_j (y-y_A)^j ] [ \sum_k az_k (z-z_A)^k ] + ! to a pol centered on B + ! [ \sum_i bx_i (x-x_B)^i ] [ \sum_j by_j (y-y_B)^j ] [ \sum_k bz_k (z-z_B)^k ] + ! + END_DOC + + ! useful for max_dim + include 'constants.include.F' + + implicit none + + integer, intent(in) :: iorder(3) + double precision, intent(in) :: A_center(3), B_center(3) + double precision, intent(in) :: A_pol(0:max_dim, 3) + double precision, intent(out) :: B_pol(0:max_dim, 3) + + integer :: i, Lmax + + do i = 1, 3 + Lmax = iorder(i) + call pol_modif_center_x( A_center(i), B_center(i), Lmax, A_pol(0:Lmax, i), B_pol(0:Lmax, i) ) + enddo + + return +end subroutine pol_modif_center + + + +subroutine pol_modif_center_x(A_center, B_center, iorder, A_pol, B_pol) + + BEGIN_DOC + ! + ! Transform the pol centerd on A: + ! [ \sum_i ax_i (x-x_A)^i ] + ! to a pol centered on B + ! [ \sum_i bx_i (x-x_B)^i ] + ! + ! bx_i = \sum_{j=i}^{iorder} ax_j (x_B - x_A)^(j-i) j! / [ i! (j-i)! ] + ! = \sum_{j=i}^{iorder} ax_j (x_B - x_A)^(j-i) binom_func(j,i) + ! + END_DOC + + implicit none + + integer, intent(in) :: iorder + double precision, intent(in) :: A_center, B_center + double precision, intent(in) :: A_pol(0:iorder) + double precision, intent(out) :: B_pol(0:iorder) + + integer :: i, j + double precision :: fact_tmp, dx + + double precision :: binom_func + + dx = B_center - A_center + + do i = 0, iorder + fact_tmp = 0.d0 + do j = i, iorder + fact_tmp += A_pol(j) * binom_func(j, i) * dx**dble(j-i) + enddo + B_pol(i) = fact_tmp + enddo + + return +end subroutine pol_modif_center_x + + From 8c51af6c5a6fabe47856bc4c2be3a171a5044074 Mon Sep 17 00:00:00 2001 From: eginer Date: Wed, 5 Oct 2022 16:04:49 +0200 Subject: [PATCH 76/80] added tc_scf --- src/tc_scf/EZFIO.cfg | 4 + src/tc_scf/NEED | 6 + src/tc_scf/combine_lr_tcscf.irp.f | 74 +++++ src/tc_scf/diago_bi_ort_tcfock.irp.f | 168 +++++++++++ src/tc_scf/fock_for_right.irp.f | 107 +++++++ src/tc_scf/fock_tc.irp.f | 133 +++++++++ src/tc_scf/fock_three.irp.f | 197 +++++++++++++ src/tc_scf/fock_three_bi_ortho.irp.f | 160 ++++++++++ src/tc_scf/fock_three_utils.irp.f | 140 +++++++++ src/tc_scf/integrals_in_r_stuff.irp.f | 391 +++++++++++++++++++++++++ src/tc_scf/molden_lr_mos.irp.f | 176 +++++++++++ src/tc_scf/rotate_tcscf_orbitals.irp.f | 248 ++++++++++++++++ src/tc_scf/tc_scf.irp.f | 179 +++++++++++ src/tc_scf/tc_scf_dm.irp.f | 25 ++ src/tc_scf/tc_scf_energy.irp.f | 32 ++ src/tc_scf/tc_scf_utils.irp.f | 42 +++ src/utils/loc.f | 304 +++++++++++++++++++ 17 files changed, 2386 insertions(+) create mode 100644 src/tc_scf/EZFIO.cfg create mode 100644 src/tc_scf/NEED create mode 100644 src/tc_scf/combine_lr_tcscf.irp.f create mode 100644 src/tc_scf/diago_bi_ort_tcfock.irp.f create mode 100644 src/tc_scf/fock_for_right.irp.f create mode 100644 src/tc_scf/fock_tc.irp.f create mode 100644 src/tc_scf/fock_three.irp.f create mode 100644 src/tc_scf/fock_three_bi_ortho.irp.f create mode 100644 src/tc_scf/fock_three_utils.irp.f create mode 100644 src/tc_scf/integrals_in_r_stuff.irp.f create mode 100644 src/tc_scf/molden_lr_mos.irp.f create mode 100644 src/tc_scf/rotate_tcscf_orbitals.irp.f create mode 100644 src/tc_scf/tc_scf.irp.f create mode 100644 src/tc_scf/tc_scf_dm.irp.f create mode 100644 src/tc_scf/tc_scf_energy.irp.f create mode 100644 src/tc_scf/tc_scf_utils.irp.f create mode 100644 src/utils/loc.f diff --git a/src/tc_scf/EZFIO.cfg b/src/tc_scf/EZFIO.cfg new file mode 100644 index 00000000..313d6f2b --- /dev/null +++ b/src/tc_scf/EZFIO.cfg @@ -0,0 +1,4 @@ +[bitc_energy] +type: Threshold +doc: Energy bi-tc HF +interface: ezfio diff --git a/src/tc_scf/NEED b/src/tc_scf/NEED new file mode 100644 index 00000000..4e340cfe --- /dev/null +++ b/src/tc_scf/NEED @@ -0,0 +1,6 @@ +hartree_fock +bi_ortho_mos +three_body_ints +bi_ort_ints +tc_keywords +non_hermit_dav diff --git a/src/tc_scf/combine_lr_tcscf.irp.f b/src/tc_scf/combine_lr_tcscf.irp.f new file mode 100644 index 00000000..b257f4a5 --- /dev/null +++ b/src/tc_scf/combine_lr_tcscf.irp.f @@ -0,0 +1,74 @@ + +! --- + +program combine_lr_tcscf + + BEGIN_DOC + ! TODO : Put the documentation of the program here + END_DOC + + implicit none + + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + bi_ortho = .True. + touch bi_ortho + + call comb_orbitals() + +end + +! --- + +subroutine comb_orbitals() + + implicit none + integer :: i, m, n, nn, mm + double precision :: accu_d, accu_nd + double precision, allocatable :: R(:,:), L(:,:), Rnew(:,:), tmp(:,:), S(:,:) + + n = ao_num + m = mo_num + nn = elec_alpha_num + mm = m - nn + + allocate(L(n,m), R(n,m), Rnew(n,m), S(m,m)) + L = mo_l_coef + R = mo_r_coef + + call check_weighted_biorthog(n, m, ao_overlap, L, R, accu_d, accu_nd, S, .true.) + + allocate(tmp(n,nn)) + do i = 1, nn + tmp(1:n,i) = R(1:n,i) + enddo + call impose_weighted_orthog_svd(n, nn, ao_overlap, tmp) + do i = 1, nn + Rnew(1:n,i) = tmp(1:n,i) + enddo + deallocate(tmp) + + allocate(tmp(n,mm)) + do i = 1, mm + tmp(1:n,i) = L(1:n,i+nn) + enddo + call impose_weighted_orthog_svd(n, mm, ao_overlap, tmp) + do i = 1, mm + Rnew(1:n,i+nn) = tmp(1:n,i) + enddo + deallocate(tmp) + + call check_weighted_biorthog(n, m, ao_overlap, Rnew, Rnew, accu_d, accu_nd, S, .true.) + + mo_r_coef = Rnew + call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef) + + deallocate(L, R, Rnew, S) + +end subroutine comb_orbitals + +! --- + diff --git a/src/tc_scf/diago_bi_ort_tcfock.irp.f b/src/tc_scf/diago_bi_ort_tcfock.irp.f new file mode 100644 index 00000000..69083e33 --- /dev/null +++ b/src/tc_scf/diago_bi_ort_tcfock.irp.f @@ -0,0 +1,168 @@ + BEGIN_PROVIDER [ double precision, fock_tc_reigvec_mo, (mo_num, mo_num)] +&BEGIN_PROVIDER [ double precision, fock_tc_leigvec_mo, (mo_num, mo_num)] +&BEGIN_PROVIDER [ double precision, eigval_fock_tc_mo, (mo_num)] +&BEGIN_PROVIDER [ double precision, overlap_fock_tc_eigvec_mo, (mo_num, mo_num)] + + BEGIN_DOC + ! EIGENVECTORS OF FOCK MATRIX ON THE MO BASIS and their OVERLAP + END_DOC + + implicit none + integer :: n_real_tc + integer :: i, k, l + double precision :: accu_d, accu_nd, accu_tmp + double precision :: norm + double precision, allocatable :: eigval_right_tmp(:) + + allocate( eigval_right_tmp(mo_num) ) + + PROVIDE Fock_matrix_tc_mo_tot + + call non_hrmt_bieig( mo_num, Fock_matrix_tc_mo_tot & + , fock_tc_leigvec_mo, fock_tc_reigvec_mo & + , n_real_tc, eigval_right_tmp ) + !if(max_ov_tc_scf)then + ! call non_hrmt_fock_mat( mo_num, Fock_matrix_tc_mo_tot & + ! , fock_tc_leigvec_mo, fock_tc_reigvec_mo & + ! , n_real_tc, eigval_right_tmp ) + !else + ! call non_hrmt_diag_split_degen_bi_orthog( mo_num, Fock_matrix_tc_mo_tot & + ! , fock_tc_leigvec_mo, fock_tc_reigvec_mo & + ! , n_real_tc, eigval_right_tmp ) + !endif + +! if(n_real_tc .ne. mo_num)then +! print*,'n_real_tc ne mo_num ! ',n_real_tc +! stop +! endif + + eigval_fock_tc_mo = eigval_right_tmp +! print*,'Eigenvalues of Fock_matrix_tc_mo_tot' +! do i = 1, mo_num +! print*, i, eigval_fock_tc_mo(i) +! enddo +! deallocate( eigval_right_tmp ) + + ! L.T x R + call dgemm( "T", "N", mo_num, mo_num, mo_num, 1.d0 & + , fock_tc_leigvec_mo, size(fock_tc_leigvec_mo, 1) & + , fock_tc_reigvec_mo, size(fock_tc_reigvec_mo, 1) & + , 0.d0, overlap_fock_tc_eigvec_mo, size(overlap_fock_tc_eigvec_mo, 1) ) + + accu_d = 0.d0 + accu_nd = 0.d0 + do i = 1, mo_num + do k = 1, mo_num + if(i==k) then + accu_tmp = overlap_fock_tc_eigvec_mo(k,i) + accu_d += dabs(accu_tmp ) + else + accu_tmp = overlap_fock_tc_eigvec_mo(k,i) + accu_nd += accu_tmp * accu_tmp + if(dabs(overlap_fock_tc_eigvec_mo(k,i)).gt.1.d-10)then + print*,'k,i',k,i,overlap_fock_tc_eigvec_mo(k,i) + endif + endif + enddo + enddo + accu_nd = dsqrt(accu_nd)/accu_d + + if( accu_nd .gt. 1d-8 ) then + print *, ' bi-orthog failed' + print*,'accu_nd MO = ', accu_nd + print*,'overlap_fock_tc_eigvec_mo = ' + do i = 1, mo_num + write(*,'(100(F16.10,X))') overlap_fock_tc_eigvec_mo(i,:) + enddo + stop + endif + + if( dabs(accu_d - dble(mo_num)) .gt. 1e-7 ) then + print *, 'mo_num = ', mo_num + print *, 'accu_d MO = ', accu_d + print *, 'normalizing vectors ...' + do i = 1, mo_num + norm = dsqrt(dabs(overlap_fock_tc_eigvec_mo(i,i))) + if( norm.gt.1e-7 ) then + do k = 1, mo_num + fock_tc_reigvec_mo(k,i) *= 1.d0/norm + fock_tc_leigvec_mo(k,i) *= 1.d0/norm + enddo + endif + enddo + call dgemm( "T", "N", mo_num, mo_num, mo_num, 1.d0 & + , fock_tc_leigvec_mo, size(fock_tc_leigvec_mo, 1) & + , fock_tc_reigvec_mo, size(fock_tc_reigvec_mo, 1) & + , 0.d0, overlap_fock_tc_eigvec_mo, size(overlap_fock_tc_eigvec_mo, 1) ) + endif + +END_PROVIDER + + BEGIN_PROVIDER [ double precision, fock_tc_reigvec_ao, (ao_num, mo_num)] +&BEGIN_PROVIDER [ double precision, fock_tc_leigvec_ao, (ao_num, mo_num)] +&BEGIN_PROVIDER [ double precision, overlap_fock_tc_eigvec_ao, (mo_num, mo_num) ] + + BEGIN_DOC + ! EIGENVECTORS OF FOCK MATRIX ON THE AO BASIS and their OVERLAP + ! + ! THE OVERLAP SHOULD BE THE SAME AS overlap_fock_tc_eigvec_mo + END_DOC + + implicit none + integer :: i, j, k, q, p + double precision :: accu, accu_d + double precision, allocatable :: tmp(:,:) + + +! ! MO_R x R + call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0 & + , mo_r_coef, size(mo_r_coef, 1) & + , fock_tc_reigvec_mo, size(fock_tc_reigvec_mo, 1) & + , 0.d0, fock_tc_reigvec_ao, size(fock_tc_reigvec_ao, 1) ) + + ! MO_L x L + call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0 & + , mo_l_coef, size(mo_l_coef, 1) & + , fock_tc_leigvec_mo, size(fock_tc_leigvec_mo, 1) & + , 0.d0, fock_tc_leigvec_ao, size(fock_tc_leigvec_ao, 1) ) + + allocate( tmp(mo_num,ao_num) ) + + ! tmp <-- L.T x S_ao + call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 & + , fock_tc_leigvec_ao, size(fock_tc_leigvec_ao, 1), ao_overlap, size(ao_overlap, 1) & + , 0.d0, tmp, size(tmp, 1) ) + + ! S <-- tmp x R + call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0 & + , tmp, size(tmp, 1), fock_tc_reigvec_ao, size(fock_tc_reigvec_ao, 1) & + , 0.d0, overlap_fock_tc_eigvec_ao, size(overlap_fock_tc_eigvec_ao, 1) ) + + deallocate( tmp ) + + ! --- + double precision :: norm + do i = 1, mo_num + norm = 1.d0/dsqrt(dabs(overlap_fock_tc_eigvec_ao(i,i))) + do j = 1, mo_num + fock_tc_reigvec_ao(j,i) *= norm + fock_tc_leigvec_ao(j,i) *= norm + enddo + enddo + + allocate( tmp(mo_num,ao_num) ) + + ! tmp <-- L.T x S_ao + call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 & + , fock_tc_leigvec_ao, size(fock_tc_leigvec_ao, 1), ao_overlap, size(ao_overlap, 1) & + , 0.d0, tmp, size(tmp, 1) ) + + ! S <-- tmp x R + call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0 & + , tmp, size(tmp, 1), fock_tc_reigvec_ao, size(fock_tc_reigvec_ao, 1) & + , 0.d0, overlap_fock_tc_eigvec_ao, size(overlap_fock_tc_eigvec_ao, 1) ) + + deallocate( tmp ) + +END_PROVIDER + diff --git a/src/tc_scf/fock_for_right.irp.f b/src/tc_scf/fock_for_right.irp.f new file mode 100644 index 00000000..5a51b324 --- /dev/null +++ b/src/tc_scf/fock_for_right.irp.f @@ -0,0 +1,107 @@ + +! --- + +BEGIN_PROVIDER [ double precision, good_hermit_tc_fock_mat, (mo_num, mo_num)] + + BEGIN_DOC +! good_hermit_tc_fock_mat = Hermitian Upper triangular Fock matrix +! +! The converged eigenvectors of such matrix yield to orthonormal vectors satisfying the left Brillouin theorem + END_DOC + implicit none + integer :: i, j + + good_hermit_tc_fock_mat = Fock_matrix_tc_mo_tot + do j = 1, mo_num + do i = 1, j-1 + good_hermit_tc_fock_mat(i,j) = Fock_matrix_tc_mo_tot(j,i) + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, hermit_average_tc_fock_mat, (mo_num, mo_num)] + + BEGIN_DOC +! hermit_average_tc_fock_mat = (F + F^\dagger)/2 + END_DOC + implicit none + integer :: i, j + + hermit_average_tc_fock_mat = Fock_matrix_tc_mo_tot + do j = 1, mo_num + do i = 1, mo_num + hermit_average_tc_fock_mat(i,j) = 0.5d0 * (Fock_matrix_tc_mo_tot(j,i) + Fock_matrix_tc_mo_tot(i,j)) + enddo + enddo + +END_PROVIDER + + +! --- +BEGIN_PROVIDER [ double precision, grad_hermit] + implicit none + BEGIN_DOC + ! square of gradient of the energy + END_DOC + if(symetric_fock_tc)then + grad_hermit = grad_hermit_average_tc_fock_mat + else + grad_hermit = grad_good_hermit_tc_fock_mat + endif + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, grad_good_hermit_tc_fock_mat] + implicit none + BEGIN_DOC + ! grad_good_hermit_tc_fock_mat = norm of gradients of the upper triangular TC fock + END_DOC + integer :: i, j + grad_good_hermit_tc_fock_mat = 0.d0 + do i = 1, elec_alpha_num + do j = elec_alpha_num+1, mo_num + grad_good_hermit_tc_fock_mat += dabs(good_hermit_tc_fock_mat(i,j)) + enddo + enddo +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, grad_hermit_average_tc_fock_mat] + implicit none + BEGIN_DOC + ! grad_hermit_average_tc_fock_mat = norm of gradients of the upper triangular TC fock + END_DOC + integer :: i, j + grad_hermit_average_tc_fock_mat = 0.d0 + do i = 1, elec_alpha_num + do j = elec_alpha_num+1, mo_num + grad_hermit_average_tc_fock_mat += dabs(hermit_average_tc_fock_mat(i,j)) + enddo + enddo +END_PROVIDER + + +! --- + +subroutine save_good_hermit_tc_eigvectors() + + implicit none + integer :: sign + character*(64) :: label + logical :: output + + sign = 1 + label = "Canonical" + output = .False. + + if(symetric_fock_tc)then + call mo_as_eigvectors_of_mo_matrix(hermit_average_tc_fock_mat, mo_num, mo_num, label, sign, output) + else + call mo_as_eigvectors_of_mo_matrix(good_hermit_tc_fock_mat, mo_num, mo_num, label, sign, output) + endif +end subroutine save_good_hermit_tc_eigvectors + +! --- + diff --git a/src/tc_scf/fock_tc.irp.f b/src/tc_scf/fock_tc.irp.f new file mode 100644 index 00000000..42b429d5 --- /dev/null +++ b/src/tc_scf/fock_tc.irp.f @@ -0,0 +1,133 @@ + +! --- + + BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_alpha, (ao_num, ao_num)] +&BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_beta , (ao_num, ao_num)] + BEGIN_DOC +! two_e_tc_non_hermit_integral_alpha(k,i) = +! +! where F^tc is the two-body part of the TC Fock matrix and k,i are AO basis functions + END_DOC + implicit none + integer :: i, j, k, l + double precision :: density, density_a, density_b + + two_e_tc_non_hermit_integral_alpha = 0.d0 + two_e_tc_non_hermit_integral_beta = 0.d0 + + !! TODO :: parallelization properly done + do i = 1, ao_num + do k = 1, ao_num +!!$OMP PARALLEL & +!!$OMP DEFAULT (NONE) & +!!$OMP PRIVATE (j,l,density_a,density_b,density) & +!!$OMP SHARED (i,k,ao_num,SCF_density_matrix_ao_alpha,SCF_density_matrix_ao_beta,ao_non_hermit_term_chemist) & +!!$OMP SHARED (two_e_tc_non_hermit_integral_alpha,two_e_tc_non_hermit_integral_beta) +!!$OMP DO SCHEDULE (dynamic) + do j = 1, ao_num + do l = 1, ao_num + + density_a = TCSCF_density_matrix_ao_alpha(l,j) + density_b = TCSCF_density_matrix_ao_beta (l,j) + density = density_a + density_b + + ! rho(l,j) * < k l| T | i j> + two_e_tc_non_hermit_integral_alpha(k,i) += density * ao_two_e_tc_tot(l,j,k,i) + ! rho(l,j) * < k l| T | i j> + two_e_tc_non_hermit_integral_beta (k,i) += density * ao_two_e_tc_tot(l,j,k,i) + ! rho_a(l,j) * < l k| T | i j> + two_e_tc_non_hermit_integral_alpha(k,i) -= density_a * ao_two_e_tc_tot(k,j,l,i) + ! rho_b(l,j) * < l k| T | i j> + two_e_tc_non_hermit_integral_beta (k,i) -= density_b * ao_two_e_tc_tot(k,j,l,i) + + enddo + enddo +!!$OMP END DO +!!$OMP END PARALLEL + enddo + enddo + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_alpha, (ao_num, ao_num)] + implicit none + BEGIN_DOC + ! Total alpha TC Fock matrix : h_c + Two-e^TC terms on the AO basis + END_DOC + Fock_matrix_tc_ao_alpha = ao_one_e_integrals_tc_tot & + + two_e_tc_non_hermit_integral_alpha + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_beta, (ao_num, ao_num)] + + BEGIN_DOC + ! Total beta TC Fock matrix : h_c + Two-e^TC terms on the AO basis + END_DOC + implicit none + + Fock_matrix_tc_ao_beta = ao_one_e_integrals_tc_tot & + + two_e_tc_non_hermit_integral_beta + +END_PROVIDER +! --- + +BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_tot, (ao_num, ao_num) ] + implicit none + BEGIN_DOC + ! Total alpha+beta TC Fock matrix : h_c + Two-e^TC terms on the AO basis + END_DOC + Fock_matrix_tc_ao_tot = 0.5d0 * (Fock_matrix_tc_ao_alpha + Fock_matrix_tc_ao_beta) +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num) ] + implicit none + BEGIN_DOC + ! Total alpha TC Fock matrix : h_c + Two-e^TC terms on the MO basis + END_DOC + if(bi_ortho)then + call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) & + , Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) ) + else + call ao_to_mo( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) & + , Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) ) + endif +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_beta, (mo_num,mo_num) ] + implicit none + BEGIN_DOC + ! Total beta TC Fock matrix : h_c + Two-e^TC terms on the MO basis + END_DOC + if(bi_ortho)then + call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) & + , Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) ) + else + call ao_to_mo( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) & + , Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) ) + endif +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_tot, (mo_num, mo_num)] + implicit none + BEGIN_DOC + ! Total alpha+beta TC Fock matrix : h_c + Two-e^TC terms on the MO basis + END_DOC + Fock_matrix_tc_mo_tot = 0.5d0 * (Fock_matrix_tc_mo_alpha + Fock_matrix_tc_mo_beta) + if(three_body_h_tc) then + Fock_matrix_tc_mo_tot += fock_3_mat + endif + !call restore_symmetry(mo_num, mo_num, Fock_matrix_tc_mo_tot, mo_num, 1.d-10) +END_PROVIDER + +! --- + diff --git a/src/tc_scf/fock_three.irp.f b/src/tc_scf/fock_three.irp.f new file mode 100644 index 00000000..e4348892 --- /dev/null +++ b/src/tc_scf/fock_three.irp.f @@ -0,0 +1,197 @@ +BEGIN_PROVIDER [ double precision, fock_3_mat, (mo_num, mo_num)] + implicit none + integer :: i,j + double precision :: contrib + fock_3_mat = 0.d0 + if(.not.bi_ortho.and.three_body_h_tc)then + call give_fock_ia_three_e_total(1,1,contrib) +!! !$OMP PARALLEL & +!! !$OMP DEFAULT (NONE) & +!! !$OMP PRIVATE (i,j,m,integral) & +!! !$OMP SHARED (mo_num,three_body_3_index) +!! !$OMP DO SCHEDULE (guided) COLLAPSE(3) + do i = 1, mo_num + do j = 1, mo_num + call give_fock_ia_three_e_total(j,i,contrib) + fock_3_mat(j,i) = -contrib + enddo + enddo +!! !$OMP END DO +!! !$OMP END PARALLEL +!! do i = 1, mo_num +!! do j = 1, i-1 +!! mat_three(j,i) = mat_three(i,j) +!! enddo +!! enddo + endif + +END_PROVIDER + + +subroutine give_fock_ia_three_e_total(i,a,contrib) + implicit none + BEGIN_DOC +! contrib is the TOTAL (same spins / opposite spins) contribution from the three body term to the Fock operator +! + END_DOC + integer, intent(in) :: i,a + double precision, intent(out) :: contrib + double precision :: int_1, int_2, int_3 + double precision :: mos_i, mos_a, w_ia + double precision :: mos_ia, weight + + integer :: mm, ipoint,k,l + + int_1 = 0.d0 + int_2 = 0.d0 + int_3 = 0.d0 + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + weight = final_weight_at_r_vector(ipoint) + mos_i = mos_in_r_array_transp(ipoint,i) + mos_a = mos_in_r_array_transp(ipoint,a) + mos_ia = mos_a * mos_i + w_ia = x_W_ij_erf_rk(ipoint,mm,i,a) + + int_1 += weight * fock_3_w_kk_sum(ipoint,mm) * (4.d0 * fock_3_rho_beta(ipoint) * w_ia & + + 2.0d0 * mos_ia * fock_3_w_kk_sum(ipoint,mm) & + - 2.0d0 * fock_3_w_ki_mos_k(ipoint,mm,i) * mos_a & + - 2.0d0 * fock_3_w_ki_mos_k(ipoint,mm,a) * mos_i ) + int_2 += weight * (-1.d0) * ( 2.0d0 * fock_3_w_kl_mo_k_mo_l(ipoint,mm) * w_ia & + + 2.0d0 * fock_3_rho_beta(ipoint) * fock_3_w_ki_wk_a(ipoint,mm,i,a) & + + 1.0d0 * mos_ia * fock_3_trace_w_tilde(ipoint,mm) ) + + int_3 += weight * 1.d0 * (fock_3_w_kl_wla_phi_k(ipoint,mm,i) * mos_a + fock_3_w_kl_wla_phi_k(ipoint,mm,a) * mos_i & + +fock_3_w_ki_mos_k(ipoint,mm,i) * fock_3_w_ki_mos_k(ipoint,mm,a) ) + enddo + enddo + contrib = int_1 + int_2 + int_3 + +end + +BEGIN_PROVIDER [double precision, diag_three_elem_hf] + implicit none + integer :: i,j,k,ipoint,mm + double precision :: contrib,weight,four_third,one_third,two_third,exchange_int_231 + if(.not.bi_ortho)then + if(three_body_h_tc)then + one_third = 1.d0/3.d0 + two_third = 2.d0/3.d0 + four_third = 4.d0/3.d0 + diag_three_elem_hf = 0.d0 + do i = 1, elec_beta_num + do j = 1, elec_beta_num + do k = 1, elec_beta_num + call give_integrals_3_body(k,j,i,j,i,k,exchange_int_231) + diag_three_elem_hf += two_third * exchange_int_231 + enddo + enddo + enddo + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + weight = final_weight_at_r_vector(ipoint) + contrib = 3.d0 * fock_3_w_kk_sum(ipoint,mm) * fock_3_rho_beta(ipoint) * fock_3_w_kk_sum(ipoint,mm) & + -2.d0 * fock_3_w_kl_mo_k_mo_l(ipoint,mm) * fock_3_w_kk_sum(ipoint,mm) & + -1.d0 * fock_3_rho_beta(ipoint) * fock_3_w_kl_w_kl(ipoint,mm) + contrib *= four_third + contrib += -two_third * fock_3_rho_beta(ipoint) * fock_3_w_kl_w_kl(ipoint,mm) & + - four_third * fock_3_w_kk_sum(ipoint,mm) * fock_3_w_kl_mo_k_mo_l(ipoint,mm) + diag_three_elem_hf += weight * contrib + enddo + enddo + diag_three_elem_hf = - diag_three_elem_hf + else + diag_three_elem_hf = 0.D0 + endif + else + diag_three_elem_hf = 0.D0 + endif +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, fock_3_mat_a_op_sh, (mo_num, mo_num)] + implicit none + integer :: h,p,i,j + double precision :: direct_int, exch_int, exchange_int_231, exchange_int_312 + double precision :: exchange_int_23, exchange_int_12, exchange_int_13 + + fock_3_mat_a_op_sh = 0.d0 + do h = 1, mo_num + do p = 1, mo_num + !F_a^{ab}(h,p) + do i = 1, elec_beta_num ! beta + do j = elec_beta_num+1, elec_alpha_num ! alpha + call give_integrals_3_body(h,j,i,p,j,i,direct_int) ! + call give_integrals_3_body(h,j,i,j,p,i,exch_int) + fock_3_mat_a_op_sh(h,p) -= direct_int - exch_int + enddo + enddo + !F_a^{aa}(h,p) + do i = 1, elec_beta_num ! alpha + do j = elec_beta_num+1, elec_alpha_num ! alpha + direct_int = three_body_4_index(j,i,h,p) + call give_integrals_3_body(h,j,i,p,j,i,direct_int) + call give_integrals_3_body(h,j,i,i,p,j,exchange_int_231) + call give_integrals_3_body(h,j,i,j,i,p,exchange_int_312) + call give_integrals_3_body(h,j,i,p,i,j,exchange_int_23) + call give_integrals_3_body(h,j,i,i,j,p,exchange_int_12) + call give_integrals_3_body(h,j,i,j,p,i,exchange_int_13) + fock_3_mat_a_op_sh(h,p) -= ( direct_int + exchange_int_231 + exchange_int_312 & + - exchange_int_23 & ! i <-> j + - exchange_int_12 & ! p <-> j + - exchange_int_13 )! p <-> i + enddo + enddo + enddo + enddo +! symmetrized +! do p = 1, elec_beta_num +! do h = elec_alpha_num +1, mo_num +! fock_3_mat_a_op_sh(h,p) = fock_3_mat_a_op_sh(p,h) +! enddo +! enddo + +! do h = elec_beta_num+1, elec_alpha_num +! do p = elec_alpha_num +1, mo_num +! !F_a^{bb}(h,p) +! do i = 1, elec_beta_num +! do j = i+1, elec_beta_num +! call give_integrals_3_body(h,j,i,p,j,i,direct_int) +! call give_integrals_3_body(h,j,i,p,i,j,exch_int) +! fock_3_mat_a_op_sh(h,p) -= direct_int - exch_int +! enddo +! enddo +! enddo +! enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_mat_b_op_sh, (mo_num, mo_num)] + implicit none + integer :: h,p,i,j + double precision :: direct_int, exch_int + fock_3_mat_b_op_sh = 0.d0 + do h = 1, elec_beta_num + do p = elec_alpha_num +1, mo_num + !F_b^{aa}(h,p) + do i = 1, elec_beta_num + do j = elec_beta_num+1, elec_alpha_num + call give_integrals_3_body(h,j,i,p,j,i,direct_int) + call give_integrals_3_body(h,j,i,p,i,j,exch_int) + fock_3_mat_b_op_sh(h,p) += direct_int - exch_int + enddo + enddo + + !F_b^{ab}(h,p) + do i = elec_beta_num+1, elec_beta_num + do j = 1, elec_beta_num + call give_integrals_3_body(h,j,i,p,j,i,direct_int) + call give_integrals_3_body(h,j,i,j,p,i,exch_int) + fock_3_mat_b_op_sh(h,p) += direct_int - exch_int + enddo + enddo + + enddo + enddo + +END_PROVIDER diff --git a/src/tc_scf/fock_three_bi_ortho.irp.f b/src/tc_scf/fock_three_bi_ortho.irp.f new file mode 100644 index 00000000..6960ebc2 --- /dev/null +++ b/src/tc_scf/fock_three_bi_ortho.irp.f @@ -0,0 +1,160 @@ + +! --- + +BEGIN_PROVIDER [ double precision, fock_3_mat_a_op_sh_bi_orth_old, (mo_num, mo_num)] + + BEGIN_DOC + ! Fock matrix for opposite spin contribution for bi ortho + END_DOC + + implicit none + integer :: j, m, i, a + double precision :: direct_int, exch_int + + fock_3_mat_a_op_sh_bi_orth_old = 0.d0 + + do i = 1, mo_num ! alpha single excitation + do a = 1, mo_num ! alpha single excitation + + ! --- + + do j = 1, elec_beta_num + do m = 1, elec_beta_num + call give_integrals_3_body_bi_ort(a, m, j, i, m, j, direct_int) + fock_3_mat_a_op_sh_bi_orth_old(a,i) += 1.d0 * direct_int + call give_integrals_3_body_bi_ort(a, m, j, j, m, i, exch_int) + fock_3_mat_a_op_sh_bi_orth_old(a,i) += -1.d0 * exch_int + enddo + enddo + + ! --- + + do j = 1, elec_beta_num ! beta + do m = j+1, elec_beta_num ! beta + call give_integrals_3_body_bi_ort(a, m, j, i, m, j, direct_int) + fock_3_mat_a_op_sh_bi_orth_old(a,i) += 1.d0 * direct_int + call give_integrals_3_body_bi_ort(a, m, j, i, j, m, exch_int) + fock_3_mat_a_op_sh_bi_orth_old(a,i) += -1.d0 * exch_int + enddo + enddo + + ! --- + + enddo + enddo + + fock_3_mat_a_op_sh_bi_orth_old = - fock_3_mat_a_op_sh_bi_orth_old + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, fock_3_mat_a_op_sh_bi_orth, (mo_num, mo_num)] + + BEGIN_DOC + ! Fock matrix for opposite spin contribution for bi ortho + END_DOC + + implicit none + integer :: i, a + double precision :: integral1, integral2, integral3 + + fock_3_mat_a_op_sh_bi_orth = 0.d0 + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, a, integral1, integral2, integral3) & + !$OMP SHARED (mo_num, fock_3_mat_a_op_sh_bi_orth) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num ! alpha single excitation + do a = 1, mo_num ! alpha single excitation + + call direct_term_imj_bi_ortho(a, i, integral1) + call exch_term_jmi_bi_ortho (a, i, integral2) + call exch_term_ijm_bi_ortho (a, i, integral3) + + fock_3_mat_a_op_sh_bi_orth(a,i) += 1.5d0 * integral1 - integral2 - 0.5d0 * integral3 + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + fock_3_mat_a_op_sh_bi_orth = - fock_3_mat_a_op_sh_bi_orth + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, fock_3_mat_a_sa_sh_bi_orth_old, (mo_num, mo_num)] + + BEGIN_DOC + ! Fock matrix for same spin contribution for bi ortho + END_DOC + + implicit none + integer :: j, m, i, a + double precision :: direct_int, cyclic_1, cyclic_2, non_cyclic_1, non_cyclic_2, non_cyclic_3 + + fock_3_mat_a_sa_sh_bi_orth_old = 0.d0 + + do i = 1, mo_num + do a = 1, mo_num + do j = 1, elec_beta_num + do m = j+1, elec_beta_num + + call give_integrals_3_body_bi_ort(a, m, j, i, m, j, direct_int) + call give_integrals_3_body_bi_ort(a, m, j, j, i, m, cyclic_1) + call give_integrals_3_body_bi_ort(a, m, j, m, j, i, cyclic_2) + fock_3_mat_a_sa_sh_bi_orth_old(a,i) += direct_int + cyclic_1 + cyclic_2 + + call give_integrals_3_body_bi_ort(a, m, j, j, m, i, non_cyclic_1) + call give_integrals_3_body_bi_ort(a, m, j, i, j, m, non_cyclic_2) + call give_integrals_3_body_bi_ort(a, m, j, m, i, j, non_cyclic_3) + fock_3_mat_a_sa_sh_bi_orth_old(a,i) += -1.d0 * (non_cyclic_1 + non_cyclic_2 + non_cyclic_3) + + enddo + enddo + enddo + enddo + + fock_3_mat_a_sa_sh_bi_orth_old = -fock_3_mat_a_sa_sh_bi_orth_old + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, fock_3_mat_a_sa_sh_bi_orth, (mo_num, mo_num)] + + BEGIN_DOC + ! Fock matrix for same spin contribution for bi ortho + END_DOC + + implicit none + integer :: j, m, i, a + double precision :: integral1, integral2, integral3, integral4 + + fock_3_mat_a_sa_sh_bi_orth = 0.d0 + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, a, integral1, integral2, integral3, integral4) & + !$OMP SHARED (mo_num, fock_3_mat_a_sa_sh_bi_orth) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do a = 1, mo_num + call direct_term_imj_bi_ortho(a, i, integral1) + call cyclic_term_jim_bi_ortho(a, i, integral2) + call exch_term_jmi_bi_ortho (a, i, integral3) + call exch_term_ijm_bi_ortho (a, i, integral4) + fock_3_mat_a_sa_sh_bi_orth(a,i) += 0.5d0 * (integral1 - integral4) + integral2 - integral3 + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + fock_3_mat_a_sa_sh_bi_orth = -fock_3_mat_a_sa_sh_bi_orth + +END_PROVIDER + +! --- + diff --git a/src/tc_scf/fock_three_utils.irp.f b/src/tc_scf/fock_three_utils.irp.f new file mode 100644 index 00000000..5aec1d9e --- /dev/null +++ b/src/tc_scf/fock_three_utils.irp.f @@ -0,0 +1,140 @@ + +BEGIN_PROVIDER [ double precision, fock_3_w_kk_sum, (n_points_final_grid,3)] + implicit none + integer :: mm, ipoint,k + double precision :: w_kk + fock_3_w_kk_sum = 0.d0 + do k = 1, elec_beta_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + w_kk = x_W_ij_erf_rk(ipoint,mm,k,k) + fock_3_w_kk_sum(ipoint,mm) += w_kk + enddo + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_w_ki_mos_k, (n_points_final_grid,3,mo_num)] + implicit none + integer :: mm, ipoint,k,i + double precision :: w_ki, mo_k + fock_3_w_ki_mos_k = 0.d0 + do i = 1, mo_num + do k = 1, elec_beta_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + w_ki = x_W_ij_erf_rk(ipoint,mm,k,i) + mo_k = mos_in_r_array(k,ipoint) + fock_3_w_ki_mos_k(ipoint,mm,i) += w_ki * mo_k + enddo + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_w_kl_w_kl, (n_points_final_grid,3)] + implicit none + integer :: k,j,ipoint,mm + double precision :: w_kj + fock_3_w_kl_w_kl = 0.d0 + do j = 1, elec_beta_num + do k = 1, elec_beta_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + w_kj = x_W_ij_erf_rk(ipoint,mm,k,j) + fock_3_w_kl_w_kl(ipoint,mm) += w_kj * w_kj + enddo + enddo + enddo + enddo + + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_rho_beta, (n_points_final_grid)] + implicit none + integer :: ipoint,k + fock_3_rho_beta = 0.d0 + do ipoint = 1, n_points_final_grid + do k = 1, elec_beta_num + fock_3_rho_beta(ipoint) += mos_in_r_array(k,ipoint) * mos_in_r_array(k,ipoint) + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_w_kl_mo_k_mo_l, (n_points_final_grid,3)] + implicit none + integer :: ipoint,k,l,mm + double precision :: mos_k, mos_l, w_kl + fock_3_w_kl_mo_k_mo_l = 0.d0 + do k = 1, elec_beta_num + do l = 1, elec_beta_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + mos_k = mos_in_r_array_transp(ipoint,k) + mos_l = mos_in_r_array_transp(ipoint,l) + w_kl = x_W_ij_erf_rk(ipoint,mm,l,k) + fock_3_w_kl_mo_k_mo_l(ipoint,mm) += w_kl * mos_k * mos_l + enddo + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_w_ki_wk_a, (n_points_final_grid,3,mo_num, mo_num)] + implicit none + integer :: ipoint,i,a,k,mm + double precision :: w_ki,w_ka + fock_3_w_ki_wk_a = 0.d0 + do i = 1, mo_num + do a = 1, mo_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + do k = 1, elec_beta_num + w_ki = x_W_ij_erf_rk(ipoint,mm,k,i) + w_ka = x_W_ij_erf_rk(ipoint,mm,k,a) + fock_3_w_ki_wk_a(ipoint,mm,a,i) += w_ki * w_ka + enddo + enddo + enddo + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_trace_w_tilde, (n_points_final_grid,3)] + implicit none + integer :: ipoint,k,mm + fock_3_trace_w_tilde = 0.d0 + do k = 1, elec_beta_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + fock_3_trace_w_tilde(ipoint,mm) += fock_3_w_ki_wk_a(ipoint,mm,k,k) + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_w_kl_wla_phi_k, (n_points_final_grid,3,mo_num)] + implicit none + integer :: ipoint,a,k,mm,l + double precision :: w_kl,w_la, mo_k + fock_3_w_kl_wla_phi_k = 0.d0 + do a = 1, mo_num + do k = 1, elec_beta_num + do l = 1, elec_beta_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + w_kl = x_W_ij_erf_rk(ipoint,mm,l,k) + w_la = x_W_ij_erf_rk(ipoint,mm,l,a) + mo_k = mos_in_r_array_transp(ipoint,k) + fock_3_w_kl_wla_phi_k(ipoint,mm,a) += w_kl * w_la * mo_k + enddo + enddo + enddo + enddo + enddo +END_PROVIDER + diff --git a/src/tc_scf/integrals_in_r_stuff.irp.f b/src/tc_scf/integrals_in_r_stuff.irp.f new file mode 100644 index 00000000..3ce85a97 --- /dev/null +++ b/src/tc_scf/integrals_in_r_stuff.irp.f @@ -0,0 +1,391 @@ + +! --- + +BEGIN_PROVIDER [ double precision, tc_scf_dm_in_r, (n_points_final_grid) ] + + implicit none + integer :: i, j + + tc_scf_dm_in_r = 0.d0 + do i = 1, n_points_final_grid + do j = 1, elec_beta_num + tc_scf_dm_in_r(i) += mos_r_in_r_array(j,i) * mos_l_in_r_array(j,i) + enddo + enddo + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, w_sum_in_r, (n_points_final_grid, 3)] + + implicit none + integer :: ipoint, j, xi + + w_sum_in_r = 0.d0 + do j = 1, elec_beta_num + do xi = 1, 3 + do ipoint = 1, n_points_final_grid + !w_sum_in_r(ipoint,xi) += x_W_ki_bi_ortho_erf_rk(ipoint,xi,j,j) + w_sum_in_r(ipoint,xi) += x_W_ki_bi_ortho_erf_rk_diag(ipoint,xi,j) + enddo + enddo + enddo + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, ww_sum_in_r, (n_points_final_grid, 3)] + + implicit none + integer :: ipoint, j, xi + double precision :: tmp + + ww_sum_in_r = 0.d0 + do j = 1, elec_beta_num + do xi = 1, 3 + do ipoint = 1, n_points_final_grid + tmp = x_W_ki_bi_ortho_erf_rk_diag(ipoint,xi,j) + ww_sum_in_r(ipoint,xi) += tmp * tmp + enddo + enddo + enddo + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, W1_r_in_r, (n_points_final_grid, 3, mo_num)] + + implicit none + integer :: i, j, xi, ipoint + + ! TODO: call lapack + + W1_r_in_r = 0.d0 + do i = 1, mo_num + do j = 1, elec_beta_num + do xi = 1, 3 + do ipoint = 1, n_points_final_grid + W1_r_in_r(ipoint,xi,i) += mos_r_in_r_array_transp(ipoint,j) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,j,i) + enddo + enddo + enddo + enddo + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, W1_l_in_r, (n_points_final_grid, 3, mo_num)] + + implicit none + integer :: i, j, xi, ipoint + + ! TODO: call lapack + + W1_l_in_r = 0.d0 + do i = 1, mo_num + do j = 1, elec_beta_num + do xi = 1, 3 + do ipoint = 1, n_points_final_grid + W1_l_in_r(ipoint,xi,i) += mos_l_in_r_array_transp(ipoint,j) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,i,j) + enddo + enddo + enddo + enddo + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, W1_in_r, (n_points_final_grid, 3)] + + implicit none + integer :: j, xi, ipoint + + ! TODO: call lapack + + W1_in_r = 0.d0 + do j = 1, elec_beta_num + do xi = 1, 3 + do ipoint = 1, n_points_final_grid + W1_in_r(ipoint,xi) += W1_l_in_r(ipoint,xi,j) * mos_r_in_r_array_transp(ipoint,j) + enddo + enddo + enddo + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, W1_diag_in_r, (n_points_final_grid, 3)] + + implicit none + integer :: j, xi, ipoint + + ! TODO: call lapack + + W1_diag_in_r = 0.d0 + do j = 1, elec_beta_num + do xi = 1, 3 + do ipoint = 1, n_points_final_grid + W1_diag_in_r(ipoint,xi) += mos_r_in_r_array_transp(ipoint,j) * mos_l_in_r_array_transp(ipoint,j) * x_W_ki_bi_ortho_erf_rk_diag(ipoint,xi,j) + enddo + enddo + enddo + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, v_sum_in_r, (n_points_final_grid, 3)] + + implicit none + integer :: i, j, xi, ipoint + + ! TODO: call lapack + v_sum_in_r = 0.d0 + do i = 1, elec_beta_num + do j = 1, elec_beta_num + do xi = 1, 3 + do ipoint = 1, n_points_final_grid + v_sum_in_r(ipoint,xi) += x_W_ki_bi_ortho_erf_rk(ipoint,xi,i,j) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,j,i) + enddo + enddo + enddo + enddo + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, W1_W1_r_in_r, (n_points_final_grid, 3, mo_num)] + + implicit none + integer :: i, m, xi, ipoint + + ! TODO: call lapack + + W1_W1_r_in_r = 0.d0 + do i = 1, mo_num + do m = 1, elec_beta_num + do xi = 1, 3 + do ipoint = 1, n_points_final_grid + W1_W1_r_in_r(ipoint,xi,i) += x_W_ki_bi_ortho_erf_rk(ipoint,xi,m,i) * W1_r_in_r(ipoint,xi,m) + enddo + enddo + enddo + enddo + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, W1_W1_l_in_r, (n_points_final_grid, 3, mo_num)] + + implicit none + integer :: i, j, xi, ipoint + + ! TODO: call lapack + + W1_W1_l_in_r = 0.d0 + do i = 1, mo_num + do j = 1, elec_beta_num + do xi = 1, 3 + do ipoint = 1, n_points_final_grid + W1_W1_l_in_r(ipoint,xi,i) += x_W_ki_bi_ortho_erf_rk(ipoint,xi,i,j) * W1_l_in_r(ipoint,xi,j) + enddo + enddo + enddo + enddo + +END_PROVIDER + +! --- + +subroutine direct_term_imj_bi_ortho(a, i, integral) + + BEGIN_DOC + ! computes sum_(j,m = 1, elec_beta_num) < a m j | i m j > with bi ortho mos + END_DOC + + implicit none + integer, intent(in) :: i, a + double precision, intent(out) :: integral + + integer :: ipoint, xi + double precision :: weight, tmp + + integral = 0.d0 + do xi = 1, 3 + do ipoint = 1, n_points_final_grid + weight = final_weight_at_r_vector(ipoint) + !integral += ( mos_l_in_r_array(a,ipoint) * mos_r_in_r_array(i,ipoint) * w_sum_in_r(ipoint,xi) * w_sum_in_r(ipoint,xi) & + ! + 2.d0 * tc_scf_dm_in_r(ipoint) * w_sum_in_r(ipoint,xi) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,a,i) ) * weight + + tmp = w_sum_in_r(ipoint,xi) + + integral += ( mos_l_in_r_array_transp(ipoint,a) * mos_r_in_r_array_transp(ipoint,i) * tmp * tmp & + + 2.d0 * tc_scf_dm_in_r(ipoint) * tmp * x_W_ki_bi_ortho_erf_rk(ipoint,xi,a,i) & + ) * weight + enddo + enddo + +end + +! --- + +subroutine exch_term_jmi_bi_ortho(a, i, integral) + + BEGIN_DOC + ! computes sum_(j,m = 1, elec_beta_num) < a m j | j m i > with bi ortho mos + END_DOC + + implicit none + integer, intent(in) :: i, a + double precision, intent(out) :: integral + + integer :: ipoint, xi, j + double precision :: weight, tmp + + integral = 0.d0 + do xi = 1, 3 + do ipoint = 1, n_points_final_grid + weight = final_weight_at_r_vector(ipoint) + + tmp = 0.d0 + do j = 1, elec_beta_num + tmp = tmp + x_W_ki_bi_ortho_erf_rk(ipoint,xi,a,j) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,j,i) + enddo + + integral += ( mos_l_in_r_array_transp(ipoint,a) * W1_r_in_r(ipoint,xi,i) * w_sum_in_r(ipoint,xi) & + + tc_scf_dm_in_r(ipoint) * tmp & + + mos_r_in_r_array_transp(ipoint,i) * W1_l_in_r(ipoint,xi,a) * w_sum_in_r(ipoint,xi) & + ) * weight + + enddo + enddo + +end + +! --- + +subroutine exch_term_ijm_bi_ortho(a, i, integral) + + BEGIN_DOC + ! computes sum_(j,m = 1, elec_beta_num) < a m j | i j m > with bi ortho mos + END_DOC + + implicit none + integer, intent(in) :: i, a + double precision, intent(out) :: integral + + integer :: ipoint, xi + double precision :: weight + + integral = 0.d0 + do xi = 1, 3 + do ipoint = 1, n_points_final_grid + weight = final_weight_at_r_vector(ipoint) + + integral += ( mos_l_in_r_array_transp(ipoint,a) * mos_r_in_r_array_transp(ipoint,i) * v_sum_in_r(ipoint,xi) & + + 2.d0 * x_W_ki_bi_ortho_erf_rk(ipoint,xi,a,i) * W1_in_r(ipoint,xi) & + ) * weight + + enddo + enddo + +end + +! --- + +subroutine direct_term_ijj_bi_ortho(a, i, integral) + + BEGIN_DOC + ! computes sum_(j = 1, elec_beta_num) < a j j | i j j > with bi ortho mos + END_DOC + + implicit none + integer, intent(in) :: i, a + double precision, intent(out) :: integral + + integer :: ipoint, xi + double precision :: weight + + integral = 0.d0 + do xi = 1, 3 + do ipoint = 1, n_points_final_grid + weight = final_weight_at_r_vector(ipoint) + + integral += ( mos_l_in_r_array_transp(ipoint,a) * mos_r_in_r_array_transp(ipoint,i) * ww_sum_in_r(ipoint,xi) & + + 2.d0 * W1_diag_in_r(ipoint, xi) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,a,i) & + ) * weight + enddo + enddo + +end + +! --- + +subroutine cyclic_term_jim_bi_ortho(a, i, integral) + + BEGIN_DOC + ! computes sum_(j,m = 1, elec_beta_num) < a m j | j i m > with bi ortho mos + END_DOC + + implicit none + integer, intent(in) :: i, a + double precision, intent(out) :: integral + + integer :: ipoint, xi + double precision :: weight + + integral = 0.d0 + do xi = 1, 3 + do ipoint = 1, n_points_final_grid + weight = final_weight_at_r_vector(ipoint) + + integral += ( mos_l_in_r_array_transp(ipoint,a) * W1_W1_r_in_r(ipoint,xi,i) & + + W1_W1_l_in_r(ipoint,xi,a) * mos_r_in_r_array_transp(ipoint,i) & + + W1_l_in_r(ipoint,xi,a) * W1_r_in_r(ipoint,xi,i) & + ) * weight + + enddo + enddo + +end + +! --- + +subroutine cyclic_term_mji_bi_ortho(a, i, integral) + + BEGIN_DOC + ! computes sum_(j,m = 1, elec_beta_num) < a m j | m j i > with bi ortho mos + END_DOC + + implicit none + integer, intent(in) :: i, a + double precision, intent(out) :: integral + + integer :: ipoint, xi + double precision :: weight + + integral = 0.d0 + do xi = 1, 3 + do ipoint = 1, n_points_final_grid + weight = final_weight_at_r_vector(ipoint) + + integral += ( mos_l_in_r_array_transp(ipoint,a) * W1_W1_r_in_r(ipoint,xi,i) & + + W1_l_in_r(ipoint,xi,a) * W1_r_in_r(ipoint,xi,i) & + + W1_W1_l_in_r(ipoint,xi,a) * mos_r_in_r_array_transp(ipoint,i) & + ) * weight + + enddo + enddo + +end + +! --- + diff --git a/src/tc_scf/molden_lr_mos.irp.f b/src/tc_scf/molden_lr_mos.irp.f new file mode 100644 index 00000000..735349ba --- /dev/null +++ b/src/tc_scf/molden_lr_mos.irp.f @@ -0,0 +1,176 @@ +program molden + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + + implicit none + + print *, 'starting ...' + + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 +! my_n_pt_r_grid = 10 ! small grid for quick debug +! my_n_pt_a_grid = 26 ! small grid for quick debug + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + call molden_lr +end +subroutine molden_lr + implicit none + BEGIN_DOC + ! Produces a Molden file + END_DOC + character*(128) :: output + integer :: i_unit_output,getUnitAndOpen + integer :: i,j,k,l + double precision, parameter :: a0 = 0.529177249d0 + + PROVIDE ezfio_filename + + output=trim(ezfio_filename)//'.mol' + print*,'output = ',trim(output) + + i_unit_output = getUnitAndOpen(output,'w') + + write(i_unit_output,'(A)') '[Molden Format]' + + write(i_unit_output,'(A)') '[Atoms] Angs' + do i = 1, nucl_num + write(i_unit_output,'(A2,2X,I4,2X,I4,3(2X,F15.10))') & + trim(element_name(int(nucl_charge(i)))), & + i, & + int(nucl_charge(i)), & + nucl_coord(i,1)*a0, nucl_coord(i,2)*a0, nucl_coord(i,3)*a0 + enddo + + write(i_unit_output,'(A)') '[GTO]' + + character*(1) :: character_shell + integer :: i_shell,i_prim,i_ao + integer :: iorder(ao_num) + integer :: nsort(ao_num) + + i_shell = 0 + i_prim = 0 + do i=1,nucl_num + write(i_unit_output,*) i, 0 + do j=1,nucl_num_shell_aos(i) + i_shell +=1 + i_ao = nucl_list_shell_aos(i,j) + character_shell = trim(ao_l_char(i_ao)) + write(i_unit_output,*) character_shell, ao_prim_num(i_ao), '1.00' + do k = 1, ao_prim_num(i_ao) + i_prim +=1 + write(i_unit_output,'(E20.10,2X,E20.10)') ao_expo(i_ao,k), ao_coef(i_ao,k) + enddo + l = i_ao + do while ( ao_l(l) == ao_l(i_ao) ) + nsort(l) = i*10000 + j*100 + l += 1 + if (l > ao_num) exit + enddo + enddo + write(i_unit_output,*)'' + enddo + + + do i=1,ao_num + iorder(i) = i + ! p + if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 1 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 2 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 3 + ! d + else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 1 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 2 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 2 )) then + nsort(i) += 3 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 4 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 5 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 6 + ! f + else if ((ao_power(i,1) == 3 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 1 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 3 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 2 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 3 )) then + nsort(i) += 3 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 4 + else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 5 + else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 6 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 2 )) then + nsort(i) += 7 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 2 )) then + nsort(i) += 8 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 9 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 10 + ! g + else if ((ao_power(i,1) == 4 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 1 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 4 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 2 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 4 )) then + nsort(i) += 3 + else if ((ao_power(i,1) == 3 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 4 + else if ((ao_power(i,1) == 3 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 5 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 3 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 6 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 3 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 7 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 3 )) then + nsort(i) += 8 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 3 )) then + nsort(i) += 9 + else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 10 + else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 2 )) then + nsort(i) += 11 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 2 )) then + nsort(i) += 12 + else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 13 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 14 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 2 )) then + nsort(i) += 15 + endif + enddo + + call isort(nsort,iorder,ao_num) + write(i_unit_output,'(A)') '[MO]' + do i=1,mo_num + write (i_unit_output,*) 'Sym= 1' + write (i_unit_output,*) 'Ene=', Fock_matrix_tc_mo_tot(i,i) + write (i_unit_output,*) 'Spin= Alpha' + write (i_unit_output,*) 'Occup=', mo_occ(i) + do j=1,ao_num + write(i_unit_output, '(I6,2X,E20.10)') j, mo_r_coef(iorder(j),i) + enddo + + write (i_unit_output,*) 'Sym= 1' + write (i_unit_output,*) 'Ene=', Fock_matrix_tc_mo_tot(i,i) + write (i_unit_output,*) 'Spin= Alpha' + write (i_unit_output,*) 'Occup=', mo_occ(i) + do j=1,ao_num + write(i_unit_output, '(I6,2X,E20.10)') j, mo_l_coef(iorder(j),i) + enddo + enddo + close(i_unit_output) +end + diff --git a/src/tc_scf/rotate_tcscf_orbitals.irp.f b/src/tc_scf/rotate_tcscf_orbitals.irp.f new file mode 100644 index 00000000..49f8bfa6 --- /dev/null +++ b/src/tc_scf/rotate_tcscf_orbitals.irp.f @@ -0,0 +1,248 @@ + +! --- + +program rotate_tcscf_orbitals + + BEGIN_DOC + ! TODO : Put the documentation of the program here + END_DOC + + implicit none + + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + bi_ortho = .True. + touch bi_ortho + + call maximize_overlap() + +end + +! --- + +subroutine maximize_overlap() + + implicit none + integer :: i, m, n + double precision :: accu_d, accu_nd + double precision, allocatable :: C(:,:), R(:,:), L(:,:), W(:,:), e(:) + double precision, allocatable :: S(:,:) + + n = ao_num + m = mo_num + + allocate(L(n,m), R(n,m), C(n,m), W(n,n), e(m)) + L = mo_l_coef + R = mo_r_coef + C = mo_coef + W = ao_overlap + + print*, ' fock matrix diag elements' + do i = 1, m + e(i) = Fock_matrix_tc_mo_tot(i,i) + print*, e(i) + enddo + + ! --- + + print *, ' overlap before :' + print *, ' ' + + allocate(S(m,m)) + + call LTxSxR(n, m, L, W, R, S) + !print*, " L.T x R" + !do i = 1, m + ! write(*, '(100(F16.10,X))') S(i,i) + !enddo + call LTxSxR(n, m, L, W, C, S) + print*, " L.T x C" + do i = 1, m + write(*, '(100(F16.10,X))') S(i,:) + enddo + call LTxSxR(n, m, C, W, R, S) + print*, " C.T x R" + do i = 1, m + write(*, '(100(F16.10,X))') S(i,:) + enddo + + deallocate(S) + + ! --- + + call rotate_degen_eigvec(n, m, e, C, W, L, R) + + ! --- + + print *, ' overlap after :' + print *, ' ' + + allocate(S(m,m)) + + call LTxSxR(n, m, L, W, R, S) + !print*, " L.T x R" + !do i = 1, m + ! write(*, '(100(F16.10,X))') S(i,i) + !enddo + call LTxSxR(n, m, L, W, C, S) + print*, " L.T x C" + do i = 1, m + write(*, '(100(F16.10,X))') S(i,:) + enddo + call LTxSxR(n, m, C, W, R, S) + print*, " C.T x R" + do i = 1, m + write(*, '(100(F16.10,X))') S(i,:) + enddo + + deallocate(S) + + ! --- + + mo_l_coef = L + mo_r_coef = R + call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef) + call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef) + + ! --- + + deallocate(L, R, C, W, e) + +end subroutine maximize_overlap + +! --- + +subroutine rotate_degen_eigvec(n, m, e0, C0, W0, L0, R0) + + implicit none + + integer, intent(in) :: n, m + double precision, intent(in) :: e0(m), W0(n,n), C0(n,m) + double precision, intent(inout) :: L0(n,m), R0(n,m) + + + integer :: i, j, k, kk, mm, id1 + double precision :: ei, ej, de, de_thr + integer, allocatable :: deg_num(:) + double precision, allocatable :: L(:,:), R(:,:), C(:,:), Lnew(:,:), Rnew(:,:), tmp(:,:) + !double precision, allocatable :: S(:,:), Snew(:,:), T(:,:), Ttmp(:,:), Stmp(:,:) + double precision, allocatable :: S(:,:), Snew(:,:), T(:,:), Ttmp(:,:), Stmp(:,:) + !real*8 :: S(m,m), Snew(m,m), T(m,m) + + id1 = 700 + allocate(S(id1,id1), Snew(id1,id1), T(id1,id1)) + + ! --- + + allocate( deg_num(m) ) + do i = 1, m + deg_num(i) = 1 + enddo + + de_thr = 1d-10 + + do i = 1, m-1 + ei = e0(i) + + ! already considered in degen vectors + if(deg_num(i).eq.0) cycle + + do j = i+1, m + ej = e0(j) + de = dabs(ei - ej) + + if(de .lt. de_thr) then + deg_num(i) = deg_num(i) + 1 + deg_num(j) = 0 + endif + + enddo + enddo + + do i = 1, m + if(deg_num(i).gt.1) then + print *, ' degen on', i, deg_num(i) + endif + enddo + + ! --- + + do i = 1, m + mm = deg_num(i) + + if(mm .gt. 1) then + + allocate(L(n,mm), R(n,mm), C(n,mm)) + do j = 1, mm + L(1:n,j) = L0(1:n,i+j-1) + R(1:n,j) = R0(1:n,i+j-1) + C(1:n,j) = C0(1:n,i+j-1) + enddo + + ! --- + + ! C.T x W0 x R + allocate(tmp(mm,n), Stmp(mm,mm)) + call dgemm( 'T', 'N', mm, n, n, 1.d0 & + , C, size(C, 1), W0, size(W0, 1) & + , 0.d0, tmp, size(tmp, 1) ) + call dgemm( 'N', 'N', mm, mm, n, 1.d0 & + , tmp, size(tmp, 1), R, size(R, 1) & + , 0.d0, Stmp, size(Stmp, 1) ) + deallocate(C, tmp) + + S = 0.d0 + do k = 1, mm + do kk = 1, mm + S(kk,k) = Stmp(kk,k) + enddo + enddo + deallocate(Stmp) + + !print*, " overlap bef" + !do k = 1, mm + ! write(*, '(100(F16.10,X))') (S(k,kk), kk=1, mm) + !enddo + + T = 0.d0 + Snew = 0.d0 + call maxovl(mm, mm, S, T, Snew) + + !print*, " overlap aft" + !do k = 1, mm + ! write(*, '(100(F16.10,X))') (Snew(k,kk), kk=1, mm) + !enddo + + allocate(Ttmp(mm,mm)) + Ttmp(1:mm,1:mm) = T(1:mm,1:mm) + + allocate(Lnew(n,mm), Rnew(n,mm)) + call dgemm( 'N', 'N', n, mm, mm, 1.d0 & + , R, size(R, 1), Ttmp(1,1), size(Ttmp, 1) & + , 0.d0, Rnew, size(Rnew, 1) ) + call dgemm( 'N', 'N', n, mm, mm, 1.d0 & + , L, size(L, 1), Ttmp(1,1), size(Ttmp, 1) & + , 0.d0, Lnew, size(Lnew, 1) ) + + deallocate(L, R) + deallocate(Ttmp) + + ! --- + + do j = 1, mm + L0(1:n,i+j-1) = Lnew(1:n,j) + R0(1:n,i+j-1) = Rnew(1:n,j) + enddo + deallocate(Lnew, Rnew) + + endif + enddo + + deallocate(S, Snew, T) + +end subroutine rotate_degen_eigvec + +! --- diff --git a/src/tc_scf/tc_scf.irp.f b/src/tc_scf/tc_scf.irp.f new file mode 100644 index 00000000..5af5206e --- /dev/null +++ b/src/tc_scf/tc_scf.irp.f @@ -0,0 +1,179 @@ +program tc_scf + + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + + implicit none + + print *, 'starting ...' + + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 +! my_n_pt_r_grid = 10 ! small grid for quick debug +! my_n_pt_a_grid = 26 ! small grid for quick debug + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + !call create_guess + !call orthonormalize_mos + + call routine_scf() + +end + +! --- + +subroutine create_guess + + BEGIN_DOC + ! Create a MO guess if no MOs are present in the EZFIO directory + END_DOC + + implicit none + logical :: exists + + PROVIDE ezfio_filename + call ezfio_has_mo_basis_mo_coef(exists) + + if (.not.exists) then + mo_label = 'Guess' + if (mo_guess_type == "HCore") then + mo_coef = ao_ortho_lowdin_coef + call restore_symmetry(ao_num, mo_num, mo_coef, size(mo_coef, 1), 1.d-10) + TOUCH mo_coef + call mo_as_eigvectors_of_mo_matrix(mo_one_e_integrals, & + size(mo_one_e_integrals,1), & + size(mo_one_e_integrals,2), & + mo_label,1,.false.) + call restore_symmetry(ao_num, mo_num, mo_coef, size(mo_coef,1), 1.d-10) + SOFT_TOUCH mo_coef + else if (mo_guess_type == "Huckel") then + call huckel_guess + else + print *, 'Unrecognized MO guess type : '//mo_guess_type + stop 1 + endif + SOFT_TOUCH mo_label + endif + +end subroutine create_guess + +! --- + +subroutine routine_scf() + + implicit none + integer :: i, j, it + double precision :: e_save, e_delta, rho_delta + double precision, allocatable :: rho_old(:,:), rho_new(:,:) + + allocate(rho_old(ao_num,ao_num), rho_new(ao_num,ao_num)) + + it = 0 + print*,'iteration = ', it + + !print*,'grad_hermit = ', grad_hermit + print*,'***' + print*,'TC HF total energy = ', TC_HF_energy + print*,'TC HF 1 e energy = ', TC_HF_one_electron_energy + print*,'TC HF 2 e energy = ', TC_HF_two_e_energy + if(.not. bi_ortho)then + print*,'TC HF 3 body = ', diag_three_elem_hf + endif + print*,'***' + e_delta = 10.d0 + e_save = 0.d0 !TC_HF_energy + rho_delta = 10.d0 + + + if(bi_ortho)then + + mo_l_coef = fock_tc_leigvec_ao + mo_r_coef = fock_tc_reigvec_ao + rho_old = TCSCF_bi_ort_dm_ao + call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef) + call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef) + TOUCH mo_l_coef mo_r_coef + + + else + + print*,'grad_hermit = ',grad_hermit + call save_good_hermit_tc_eigvectors + TOUCH mo_coef + call save_mos + + endif + + ! --- + + if(bi_ortho) then + + !do while( it .lt. n_it_tcscf_max .and. (e_delta .gt. dsqrt(thresh_tcscf)) ) + !do while( it .lt. n_it_tcscf_max .and. (e_delta .gt. thresh_tcscf) ) + do while( it .lt. n_it_tcscf_max .and. (rho_delta .gt. thresh_tcscf) ) + + it += 1 + print*,'iteration = ', it + print*,'***' + print*,'TC HF total energy = ', TC_HF_energy + print*,'TC HF 1 e energy = ', TC_HF_one_electron_energy + print*,'TC HF 2 non hermit = ', TC_HF_two_e_energy + print*,'***' + e_delta = dabs( TC_HF_energy - e_save ) + print*, 'it, delta E = ', it, e_delta + e_save = TC_HF_energy + mo_l_coef = fock_tc_leigvec_ao + mo_r_coef = fock_tc_reigvec_ao + + rho_new = TCSCF_bi_ort_dm_ao + !print*, rho_new + rho_delta = 0.d0 + do i = 1, ao_num + do j = 1, ao_num + rho_delta += dabs(rho_new(j,i) - rho_old(j,i)) + enddo + enddo + print*, ' rho_delta =', rho_delta + rho_old = rho_new + + call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef) + call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef) + TOUCH mo_l_coef mo_r_coef + + call ezfio_set_tc_scf_bitc_energy(TC_HF_energy) + + enddo + + else + do while( (grad_hermit.gt.dsqrt(thresh_tcscf)) .and. it .lt. n_it_tcscf_max ) + print*,'grad_hermit = ',grad_hermit + it += 1 + print*,'iteration = ', it + print*,'***' + print*,'TC HF total energy = ', TC_HF_energy + print*,'TC HF 1 e energy = ', TC_HF_one_electron_energy + print*,'TC HF 2 e energy = ', TC_HF_two_e_energy + print*,'TC HF 3 body = ', diag_three_elem_hf + print*,'***' + call save_good_hermit_tc_eigvectors + TOUCH mo_coef + call save_mos + + enddo + + endif + + print*,'Energy converged !' + print*,'Diagonal Fock elements ' + do i = 1, mo_num + print*,i,Fock_matrix_tc_mo_tot(i,i) + enddo + + deallocate(rho_old, rho_new) + +end subroutine routine_scf + +! --- + diff --git a/src/tc_scf/tc_scf_dm.irp.f b/src/tc_scf/tc_scf_dm.irp.f new file mode 100644 index 00000000..f6ae3e1f --- /dev/null +++ b/src/tc_scf/tc_scf_dm.irp.f @@ -0,0 +1,25 @@ +BEGIN_PROVIDER [ double precision, TCSCF_density_matrix_ao_beta, (ao_num, ao_num) ] + implicit none + if(bi_ortho)then + TCSCF_density_matrix_ao_beta = TCSCF_bi_ort_dm_ao_beta + else + TCSCF_density_matrix_ao_beta = SCF_density_matrix_ao_beta + endif +END_PROVIDER + +BEGIN_PROVIDER [ double precision, TCSCF_density_matrix_ao_alpha, (ao_num, ao_num) ] + implicit none + if(bi_ortho)then + TCSCF_density_matrix_ao_alpha = TCSCF_bi_ort_dm_ao_alpha + else + TCSCF_density_matrix_ao_alpha = SCF_density_matrix_ao_alpha + endif +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, TCSCF_density_matrix_ao_tot, (ao_num, ao_num) ] + implicit none + TCSCF_density_matrix_ao_tot = TCSCF_density_matrix_ao_beta + TCSCF_density_matrix_ao_alpha +END_PROVIDER + + diff --git a/src/tc_scf/tc_scf_energy.irp.f b/src/tc_scf/tc_scf_energy.irp.f new file mode 100644 index 00000000..aa2a16ff --- /dev/null +++ b/src/tc_scf/tc_scf_energy.irp.f @@ -0,0 +1,32 @@ + + BEGIN_PROVIDER [ double precision, TC_HF_energy] +&BEGIN_PROVIDER [ double precision, TC_HF_one_electron_energy] +&BEGIN_PROVIDER [ double precision, TC_HF_two_e_energy] + + BEGIN_DOC + ! TC Hartree-Fock energy containing the nuclear repulsion, and its one- and two-body components. + END_DOC + + implicit none + integer :: i, j + + TC_HF_energy = nuclear_repulsion + TC_HF_one_electron_energy = 0.d0 + TC_HF_two_e_energy = 0.d0 + + do j = 1, ao_num + do i = 1, ao_num + TC_HF_two_e_energy += 0.5d0 * ( two_e_tc_non_hermit_integral_alpha(i,j) * TCSCF_density_matrix_ao_alpha(i,j) & + + two_e_tc_non_hermit_integral_beta(i,j) * TCSCF_density_matrix_ao_beta(i,j) ) + TC_HF_one_electron_energy += ao_one_e_integrals_tc_tot(i,j) & + * (TCSCF_density_matrix_ao_alpha(i,j) + TCSCF_density_matrix_ao_beta (i,j) ) + enddo + enddo + + TC_HF_energy += TC_HF_one_electron_energy + TC_HF_two_e_energy + TC_HF_energy += diag_three_elem_hf + +END_PROVIDER + +! --- + diff --git a/src/tc_scf/tc_scf_utils.irp.f b/src/tc_scf/tc_scf_utils.irp.f new file mode 100644 index 00000000..09a4a1b9 --- /dev/null +++ b/src/tc_scf/tc_scf_utils.irp.f @@ -0,0 +1,42 @@ + +! --- + +subroutine LTxSxR(n, m, L, S, R, C) + + implicit none + integer, intent(in) :: n, m + double precision, intent(in) :: L(n,m), S(n,n), R(n,m) + double precision, intent(out) :: C(m,m) + integer :: i, j + double precision :: accu_d, accu_nd + double precision, allocatable :: tmp(:,:) + + ! L.T x S x R + allocate(tmp(m,n)) + call dgemm( 'T', 'N', m, n, n, 1.d0 & + , L, size(L, 1), S, size(S, 1) & + , 0.d0, tmp, size(tmp, 1) ) + call dgemm( 'N', 'N', m, m, n, 1.d0 & + , tmp, size(tmp, 1), R, size(R, 1) & + , 0.d0, C, size(C, 1) ) + deallocate(tmp) + + accu_d = 0.d0 + accu_nd = 0.d0 + do i = 1, m + do j = 1, m + if(j.eq.i) then + accu_d += dabs(C(j,i)) + else + accu_nd += C(j,i) * C(j,i) + endif + enddo + enddo + accu_nd = dsqrt(accu_nd) + + print*, ' accu_d = ', accu_d + print*, ' accu_nd = ', accu_nd + +end subroutine LTxR + +! --- diff --git a/src/utils/loc.f b/src/utils/loc.f new file mode 100644 index 00000000..32d2cd03 --- /dev/null +++ b/src/utils/loc.f @@ -0,0 +1,304 @@ +c************************************************************************ + subroutine maxovl(n,m,s,t,w) +C +C This subprogram contains an iterative procedure to find the +C unitary transformation of a set of n vectors which maximizes +C the sum of their square overlaps with a set of m reference +C vectors (m.le.n) +C +C S: overlap matrix +C T: rotation matrix +C W: new overlap matrix +C +C + implicit real*8(a-h,o-y),logical*1(z) + parameter (id1=700) + dimension s(id1,id1),t(id1,id1),w(id1,id1) + data small/1.d-6/ + + zprt=.true. + niter=1000000 + conv=1.d-12 + +C niter=1000000 +C conv=1.d-6 + write (6,5) n,m,conv + 5 format (//5x,'Unitary transformation of',i3,' vectors'/ + * 5x,'following the principle of maximum overlap with a set of', + * i3,' reference vectors'/5x,'required convergence on rotation ', + * 'angle =',f13.10///5x,'Starting overlap matrix'/) + do 6 i=1,m + write (6,145) i + 6 write (6,150) (s(i,j),j=1,n) + 8 mm=m-1 + if (m.lt.n) mm=m + iter=0 + do 20 j=1,n + do 16 i=1,n + t(i,j)=0.d0 + 16 continue + do 18 i=1,m + 18 w(i,j)=s(i,j) + 20 t(j,j)=1.d0 + sum=0.d0 + do 10 i=1,m + sum=sum+s(i,i)*s(i,i) + 10 continue + sum=sum/m + if (zprt) write (6,12) sum + 12 format (//5x,'Average square overlap =',f10.6) + if (n.eq.1) goto 100 + last=n + j=1 + 21 if (j.ge.last) goto 30 + sum=0.d0 + + do 22 i=1,n + 22 sum=sum+s(i,j)*s(i,j) + if (sum.gt.small) goto 28 + do 24 i=1,n + sij=s(i,j) + s(i,j)=-s(i,last) + s(i,last)=sij + tij=t(i,j) + t(i,j)=-t(i,last) + t(i,last)=tij + 24 continue + last=last-1 + goto 21 + 28 j=j+1 + goto 21 + 30 iter=iter+1 + imax=0 + jmax=0 + dmax=0.d0 + amax=0.d0 + do 60 i=1,mm + ip=i+1 + do 50 j=ip,n + a=s(i,j)*s(i,j)-s(i,i)*s(i,i) + b=-s(i,i)*s(i,j) + if (j.gt.m) goto 31 + a=a+s(j,i)*s(j,i)-s(j,j)*s(j,j) + b=b+s(j,i)*s(j,j) + 31 b=b+b + if (a.eq.0.d0) goto 32 + ba=b/a + if (dabs(ba).gt.small) goto 32 + if (a.gt.0.d0) goto 33 + tang=-0.5d0*ba + cosine=1.d0/dsqrt(1.d0+tang*tang) + sine=tang*cosine + goto 34 + 32 tang=0.d0 + if (b.ne.0.d0) tang=(a+dsqrt(a*a+b*b))/b + cosine=1.d0/dsqrt(1.d0+tang*tang) + sine=tang*cosine + goto 34 + 33 cosine=0.d0 + sine=1.d0 + 34 delta=sine*(a*sine+b*cosine) + if (zprt.and.delta.lt.0.d0) write (6,71) i,j,a,b,sine,cosine,delta + do 35 k=1,m + p=s(k,i)*cosine-s(k,j)*sine + q=s(k,i)*sine+s(k,j)*cosine + s(k,i)=p + 35 s(k,j)=q + do 40 k=1,n + p=t(k,i)*cosine-t(k,j)*sine + q=t(k,i)*sine+t(k,j)*cosine + t(k,i)=p + t(k,j)=q + 40 continue + 45 d=dabs(sine) + if (d.le.amax) goto 50 + imax=i + jmax=j + amax=d + dmax=delta + 50 continue + 60 continue + if (zprt) write (6,70) iter,amax,imax,jmax,dmax + 70 format (' iter=',i4,' largest rotation=',f12.8, + * ', vectors',i3,' and',i3,', incr. of diag. squares=',g12.5) + 71 format (' i,j,a,b,sin,cos,delta =',2i3,5f10.5) + if (amax.lt.conv) goto 100 + if (iter.lt.niter) goto 30 + write (6,80) + write (6,*) 'niter=',niter + 80 format (//5x,'*** maximum number of cycles exceeded ', + * 'in subroutine maxovl ***'//) + stop + 100 continue + do 120 j=1,n + if (s(j,j).gt.0.d0) goto 120 + do 105 i=1,m + 105 s(i,j)=-s(i,j) + do 110 i=1,n + 110 t(i,j)=-t(i,j) + 120 continue + sum=0.d0 + do 125 i=1,m + 125 sum=sum+s(i,i)*s(i,i) + sum=sum/m + do 122 i=1,m + do 122 j=1,n + sw=s(i,j) + s(i,j)=w(i,j) + 122 w(i,j)=sw + if (.not.zprt) return + write (6,12) sum + write (6,130) + 130 format (//5x,'transformation matrix') + do 140 i=1,n + write (6,145) i + 140 write (6,150) (t(i,j),j=1,n) + 145 format (i8) + 150 format (2x,10f12.8) + write (6,160) + 160 format (//5x,'new overlap matrix'/) + do 170 i=1,m + write (6,145) i + 170 write (6,150) (w(i,j),j=1,n) + return + end + + +c************************************************************************ + subroutine maxovl_no_print(n,m,s,t,w) +C +C This subprogram contains an iterative procedure to find the +C unitary transformation of a set of n vectors which maximizes +C the sum of their square overlaps with a set of m reference +C vectors (m.le.n) +C +C S: overlap matrix +C T: rotation matrix +C W: new overlap matrix +C +C + implicit real*8(a-h,o-y),logical*1(z) + parameter (id1=300) + dimension s(id1,id1),t(id1,id1),w(id1,id1) + data small/1.d-6/ + + zprt=.false. + niter=1000000 + conv=1.d-8 + +C niter=1000000 +C conv=1.d-6 + 8 mm=m-1 + if (m.lt.n) mm=m + iter=0 + do 20 j=1,n + do 16 i=1,n + t(i,j)=0.d0 + 16 continue + do 18 i=1,m + 18 w(i,j)=s(i,j) + 20 t(j,j)=1.d0 + sum=0.d0 + do 10 i=1,m + sum=sum+s(i,i)*s(i,i) + 10 continue + sum=sum/m + 12 format (//5x,'Average square overlap =',f10.6) + if (n.eq.1) goto 100 + last=n + j=1 + 21 if (j.ge.last) goto 30 + sum=0.d0 + + do 22 i=1,n + 22 sum=sum+s(i,j)*s(i,j) + if (sum.gt.small) goto 28 + do 24 i=1,n + sij=s(i,j) + s(i,j)=-s(i,last) + s(i,last)=sij + tij=t(i,j) + t(i,j)=-t(i,last) + t(i,last)=tij + 24 continue + last=last-1 + goto 21 + 28 j=j+1 + goto 21 + 30 iter=iter+1 + imax=0 + jmax=0 + dmax=0.d0 + amax=0.d0 + do 60 i=1,mm + ip=i+1 + do 50 j=ip,n + a=s(i,j)*s(i,j)-s(i,i)*s(i,i) + b=-s(i,i)*s(i,j) + if (j.gt.m) goto 31 + a=a+s(j,i)*s(j,i)-s(j,j)*s(j,j) + b=b+s(j,i)*s(j,j) + 31 b=b+b + if (a.eq.0.d0) goto 32 + ba=b/a + if (dabs(ba).gt.small) goto 32 + if (a.gt.0.d0) goto 33 + tang=-0.5d0*ba + cosine=1.d0/dsqrt(1.d0+tang*tang) + sine=tang*cosine + goto 34 + 32 tang=0.d0 + if (b.ne.0.d0) tang=(a+dsqrt(a*a+b*b))/b + cosine=1.d0/dsqrt(1.d0+tang*tang) + sine=tang*cosine + goto 34 + 33 cosine=0.d0 + sine=1.d0 + 34 delta=sine*(a*sine+b*cosine) + do 35 k=1,m + p=s(k,i)*cosine-s(k,j)*sine + q=s(k,i)*sine+s(k,j)*cosine + s(k,i)=p + 35 s(k,j)=q + do 40 k=1,n + p=t(k,i)*cosine-t(k,j)*sine + q=t(k,i)*sine+t(k,j)*cosine + t(k,i)=p + t(k,j)=q + 40 continue + 45 d=dabs(sine) + if (d.le.amax) goto 50 + imax=i + jmax=j + amax=d + dmax=delta + 50 continue + 60 continue + 70 format (' iter=',i4,' largest rotation=',f12.8, + * ', vectors',i3,' and',i3,', incr. of diag. squares=',g12.5) + 71 format (' i,j,a,b,sin,cos,delta =',2i3,5f10.5) + if (amax.lt.conv) goto 100 + if (iter.lt.niter) goto 30 + 80 format (//5x,'*** maximum number of cycles exceeded ', + * 'in subroutine maxovl ***'//) + stop + 100 continue + do 120 j=1,n + if (s(j,j).gt.0.d0) goto 120 + do 105 i=1,m + 105 s(i,j)=-s(i,j) + do 110 i=1,n + 110 t(i,j)=-t(i,j) + 120 continue + sum=0.d0 + do 125 i=1,m + 125 sum=sum+s(i,i)*s(i,i) + sum=sum/m + do 122 i=1,m + do 122 j=1,n + sw=s(i,j) + s(i,j)=w(i,j) + 122 w(i,j)=sw + return + end + From 57e592870cb3fa3e4cc650433adc7f28398d9983 Mon Sep 17 00:00:00 2001 From: eginer Date: Wed, 5 Oct 2022 17:01:27 +0200 Subject: [PATCH 77/80] added tc_bi_ortho --- src/tc_bi_ortho/EZFIO.cfg | 11 + src/tc_bi_ortho/NEED | 6 + src/tc_bi_ortho/e_corr_bi_ortho.irp.f | 104 +++++ src/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f | 92 +++++ src/tc_bi_ortho/normal_ordered.irp.f | 319 ++++++++++++++++ src/tc_bi_ortho/print_tc_wf.irp.f | 104 +++++ src/tc_bi_ortho/psi_det_tc_sorted.irp.f | 157 ++++++++ src/tc_bi_ortho/psi_left_qmc.irp.f | 44 +++ src/tc_bi_ortho/psi_r_l_prov.irp.f | 217 +++++++++++ .../save_bitcpsileft_for_qmcchem.irp.f | 61 +++ src/tc_bi_ortho/save_lr_bi_ortho_states.irp.f | 15 + src/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f | 33 ++ src/tc_bi_ortho/select_dets_bi_ortho.irp.f | 61 +++ src/tc_bi_ortho/slater_tc.irp.f | 359 ++++++++++++++++++ src/tc_bi_ortho/slater_tc_3e.irp.f | 293 ++++++++++++++ src/tc_bi_ortho/symmetrized_3_e_int.irp.f | 111 ++++++ src/tc_bi_ortho/tc_bi_ortho.irp.f | 61 +++ src/tc_bi_ortho/tc_bi_ortho_prop.irp.f | 24 ++ src/tc_bi_ortho/tc_cisd_sc2.irp.f | 24 ++ src/tc_bi_ortho/tc_cisd_sc2_utils.irp.f | 110 ++++++ src/tc_bi_ortho/tc_h_eigvectors.irp.f | 179 +++++++++ src/tc_bi_ortho/tc_hmat.irp.f | 41 ++ src/tc_bi_ortho/tc_prop.irp.f | 268 +++++++++++++ src/tc_bi_ortho/test_normal_order.irp.f | 73 ++++ src/tc_bi_ortho/test_tc_bi_ortho.irp.f | 131 +++++++ src/tc_bi_ortho/test_tc_fock.irp.f | 169 +++++++++ 26 files changed, 3067 insertions(+) create mode 100644 src/tc_bi_ortho/EZFIO.cfg create mode 100644 src/tc_bi_ortho/NEED create mode 100644 src/tc_bi_ortho/e_corr_bi_ortho.irp.f create mode 100644 src/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f create mode 100644 src/tc_bi_ortho/normal_ordered.irp.f create mode 100644 src/tc_bi_ortho/print_tc_wf.irp.f create mode 100644 src/tc_bi_ortho/psi_det_tc_sorted.irp.f create mode 100644 src/tc_bi_ortho/psi_left_qmc.irp.f create mode 100644 src/tc_bi_ortho/psi_r_l_prov.irp.f create mode 100644 src/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f create mode 100644 src/tc_bi_ortho/save_lr_bi_ortho_states.irp.f create mode 100644 src/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f create mode 100644 src/tc_bi_ortho/select_dets_bi_ortho.irp.f create mode 100644 src/tc_bi_ortho/slater_tc.irp.f create mode 100644 src/tc_bi_ortho/slater_tc_3e.irp.f create mode 100644 src/tc_bi_ortho/symmetrized_3_e_int.irp.f create mode 100644 src/tc_bi_ortho/tc_bi_ortho.irp.f create mode 100644 src/tc_bi_ortho/tc_bi_ortho_prop.irp.f create mode 100644 src/tc_bi_ortho/tc_cisd_sc2.irp.f create mode 100644 src/tc_bi_ortho/tc_cisd_sc2_utils.irp.f create mode 100644 src/tc_bi_ortho/tc_h_eigvectors.irp.f create mode 100644 src/tc_bi_ortho/tc_hmat.irp.f create mode 100644 src/tc_bi_ortho/tc_prop.irp.f create mode 100644 src/tc_bi_ortho/test_normal_order.irp.f create mode 100644 src/tc_bi_ortho/test_tc_bi_ortho.irp.f create mode 100644 src/tc_bi_ortho/test_tc_fock.irp.f diff --git a/src/tc_bi_ortho/EZFIO.cfg b/src/tc_bi_ortho/EZFIO.cfg new file mode 100644 index 00000000..a34d2134 --- /dev/null +++ b/src/tc_bi_ortho/EZFIO.cfg @@ -0,0 +1,11 @@ +[psi_l_coef_bi_ortho] +interface: ezfio +doc: Coefficients for the left wave function +type: double precision +size: (determinants.n_det,determinants.n_states) + +[psi_r_coef_bi_ortho] +interface: ezfio +doc: Coefficients for the right wave function +type: double precision +size: (determinants.n_det,determinants.n_states) diff --git a/src/tc_bi_ortho/NEED b/src/tc_bi_ortho/NEED new file mode 100644 index 00000000..9a0c20ef --- /dev/null +++ b/src/tc_bi_ortho/NEED @@ -0,0 +1,6 @@ +bi_ort_ints +bi_ortho_mos +tc_keywords +non_hermit_dav +dav_general_mat +tc_scf diff --git a/src/tc_bi_ortho/e_corr_bi_ortho.irp.f b/src/tc_bi_ortho/e_corr_bi_ortho.irp.f new file mode 100644 index 00000000..ec66a8b5 --- /dev/null +++ b/src/tc_bi_ortho/e_corr_bi_ortho.irp.f @@ -0,0 +1,104 @@ + use bitmasks ! you need to include the bitmasks_module.f90 features + BEGIN_PROVIDER [ double precision, e_tilde_00] + implicit none + double precision :: hmono,htwoe,hthree,htot + call htilde_mu_mat_bi_ortho(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,htot) + e_tilde_00 = htot + END_PROVIDER + + BEGIN_PROVIDER [ double precision, e_pt2_tc_bi_orth] +&BEGIN_PROVIDER [ double precision, e_pt2_tc_bi_orth_single] +&BEGIN_PROVIDER [ double precision, e_pt2_tc_bi_orth_double] + implicit none + integer :: i,degree + double precision :: hmono,htwoe,hthree,htilde_ij,coef_pt1,e_i0,delta_e + e_pt2_tc_bi_orth = 0.d0 + e_pt2_tc_bi_orth_single = 0.d0 + e_pt2_tc_bi_orth_double = 0.d0 + do i = 1, N_det + call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int) + if(degree == 1 .or. degree == 2)then + call htilde_mu_mat_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) + call htilde_mu_mat_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0) + delta_e = e_tilde_00 - e_i0 + coef_pt1 = htilde_ij / delta_e + call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij) + e_pt2_tc_bi_orth += coef_pt1 * htilde_ij + if(degree == 1)then + e_pt2_tc_bi_orth_single += coef_pt1 * htilde_ij + else +! print*,'coef_pt1, e_pt2',coef_pt1,coef_pt1 * htilde_ij + e_pt2_tc_bi_orth_double += coef_pt1 * htilde_ij + endif + endif + enddo + END_PROVIDER + + BEGIN_PROVIDER [ double precision, e_tilde_bi_orth_00] + implicit none + double precision :: hmono,htwoe,hthree,htilde_ij + call htilde_mu_mat_bi_ortho(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,e_tilde_bi_orth_00) + e_tilde_bi_orth_00 += nuclear_repulsion + END_PROVIDER + + BEGIN_PROVIDER [ double precision, e_corr_bi_orth ] +&BEGIN_PROVIDER [ double precision, e_corr_bi_orth_proj ] +&BEGIN_PROVIDER [ double precision, e_corr_single_bi_orth ] +&BEGIN_PROVIDER [ double precision, e_corr_double_bi_orth ] + implicit none + integer :: i,degree + double precision :: hmono,htwoe,hthree,htilde_ij + + e_corr_bi_orth = 0.d0 + e_corr_single_bi_orth = 0.d0 + e_corr_double_bi_orth = 0.d0 + do i = 1, N_det + call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int) + call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij) + if(degree == 1)then + e_corr_single_bi_orth += reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1) + else if(degree == 2)then + e_corr_double_bi_orth += reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1) +! print*,'coef_wf , e_cor',reigvec_tc_bi_orth(i,1)/reigvec_tc_bi_orth(1,1), reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1) + endif + enddo + e_corr_bi_orth_proj = e_corr_single_bi_orth + e_corr_double_bi_orth + e_corr_bi_orth = eigval_right_tc_bi_orth(1) - e_tilde_bi_orth_00 + END_PROVIDER + + BEGIN_PROVIDER [ double precision, e_tc_left_right ] + implicit none + integer :: i,j + double precision :: hmono,htwoe,hthree,htilde_ij,accu + e_tc_left_right = 0.d0 + accu = 0.d0 + do i = 1, N_det + accu += reigvec_tc_bi_orth(i,1) * leigvec_tc_bi_orth(i,1) + do j = 1, N_det + call htilde_mu_mat_bi_ortho(psi_det(1,1,j),psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij) + e_tc_left_right += htilde_ij * reigvec_tc_bi_orth(i,1) * leigvec_tc_bi_orth(j,1) + enddo + enddo + e_tc_left_right *= 1.d0/accu + e_tc_left_right += nuclear_repulsion + + END_PROVIDER + + +BEGIN_PROVIDER [ double precision, coef_pt1_bi_ortho, (N_det)] + implicit none + integer :: i,degree + double precision :: hmono,htwoe,hthree,htilde_ij,coef_pt1,e_i0,delta_e + do i = 1, N_det + call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int) + if(degree==0)then + coef_pt1_bi_ortho(i) = 1.d0 + else + call htilde_mu_mat_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) + call htilde_mu_mat_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0) + delta_e = e_tilde_00 - e_i0 + coef_pt1 = htilde_ij / delta_e + coef_pt1_bi_ortho(i)= coef_pt1 + endif + enddo +END_PROVIDER diff --git a/src/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f b/src/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f new file mode 100644 index 00000000..b7129d36 --- /dev/null +++ b/src/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f @@ -0,0 +1,92 @@ +subroutine htc_bi_ortho_calc_tdav(v, u, N_st, sze) + + use bitmasks + + BEGIN_DOC + ! Application of H_TC on a vector + ! + ! v(i,istate) = \sum_j u(j,istate) H_TC(i,j), with: + ! H_TC(i,j) = < Di | H_TC | Dj > + ! + END_DOC + + implicit none + + integer, intent(in) :: N_st, sze + double precision, intent(in) :: u(sze,N_st) + double precision, intent(inout) :: v(sze,N_st) + + integer :: i, j, istate + double precision :: htot + + PROVIDE N_int + PROVIDE psi_det + + + ! TODO : transform it with the bi-linear representation in terms of alpha-beta. + + i = 1 + j = 1 + call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,j), N_int, htot) + + v = 0.d0 + !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) & + !$OMP SHARED(N_st, sze, N_int, psi_det, u, v) & + !$OMP PRIVATE(istate, i, j, htot) + do istate = 1, N_st + do i = 1, sze + do j = 1, sze + call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,j), N_int, htot) + v(i,istate) = v(i,istate) + htot * u(j,istate) + enddo + enddo + enddo + !$OMP END PARALLEL DO + +end + +subroutine htcdag_bi_ortho_calc_tdav(v, u, N_st, sze) + + use bitmasks + + BEGIN_DOC + ! Application of (H_TC)^dagger on a vector + ! + ! v(i,istate) = \sum_j u(j,istate) H_TC(j,i), with: + ! H_TC(i,j) = < Di | H_TC | Dj > + ! + END_DOC + + implicit none + + integer, intent(in) :: N_st, sze + double precision, intent(in) :: u(sze,N_st) + double precision, intent(inout) :: v(sze,N_st) + + integer :: i, j, istate + double precision :: htot + + PROVIDE N_int + PROVIDE psi_det + + i = 1 + j = 1 + call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,j), N_int, htot) + + v = 0.d0 + + !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) & + !$OMP SHARED(N_st, sze, N_int, psi_det, u, v) & + !$OMP PRIVATE(istate, i, j, htot) + do istate = 1, N_st + do i = 1, sze + do j = 1, sze + call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,j), psi_det(1,1,i), N_int, htot) + v(i,istate) = v(i,istate) + htot * u(j,istate) + enddo + enddo + enddo + !$OMP END PARALLEL DO + +end + diff --git a/src/tc_bi_ortho/normal_ordered.irp.f b/src/tc_bi_ortho/normal_ordered.irp.f new file mode 100644 index 00000000..81f5fb2c --- /dev/null +++ b/src/tc_bi_ortho/normal_ordered.irp.f @@ -0,0 +1,319 @@ +BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth, (mo_num, mo_num, mo_num, mo_num)] + + BEGIN_DOC + ! Normal ordering of the three body interaction on the HF density + END_DOC + + use bitmasks ! you need to include the bitmasks_module.f90 features + + implicit none + + integer :: i,h1,p1,h2,p2 + integer :: hh1,hh2,pp1,pp2 + integer :: Ne(2) + integer, allocatable :: occ(:,:) + integer(bit_kind), allocatable :: key_i_core(:,:) + double precision :: hthree_aba,hthree_aaa,hthree_aab + double precision :: wall0,wall1 + + PROVIDE N_int + + allocate( occ(N_int*bit_kind_size,2) ) + allocate( key_i_core(N_int,2) ) + + if(core_tc_op) then + do i = 1, N_int + key_i_core(i,1) = xor(ref_bitmask(i,1),core_bitmask(i,1)) + key_i_core(i,2) = xor(ref_bitmask(i,2),core_bitmask(i,2)) + enddo + call bitstring_to_list_ab(key_i_core,occ,Ne,N_int) + else + call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int) + endif + + normal_two_body_bi_orth = 0.d0 + print*,'Providing normal_two_body_bi_orth ...' + call wall_time(wall0) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (hh1, h1, hh2, h2, pp1, p1, pp2, p2, hthree_aba, hthree_aab, hthree_aaa) & + !$OMP SHARED (N_int, n_act_orb, list_act, Ne, occ, normal_two_body_bi_orth) + !$OMP DO SCHEDULE (static) + do hh1 = 1, n_act_orb + h1 = list_act(hh1) + do pp1 = 1, n_act_orb + p1 = list_act(pp1) + do hh2 = 1, n_act_orb + h2 = list_act(hh2) + do pp2 = 1, n_act_orb + p2 = list_act(pp2) + ! opposite spin double excitations + call give_aba_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aba) + ! same spin double excitations with opposite spin contributions + if(h1h2 + ! same spin double excitations with same spin contributions + if(Ne(2).ge.3)then + call give_aaa_contraction(N_int, h2, h1, p1, p2, Ne, occ, hthree_aaa) ! exchange h1<->h2 + else + hthree_aaa = 0.d0 + endif + else + call give_aab_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aab) + if(Ne(2).ge.3)then + call give_aaa_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aaa) + else + hthree_aaa = 0.d0 + endif + endif + normal_two_body_bi_orth(p2,h2,p1,h1) = 0.5d0*(hthree_aba + hthree_aab + hthree_aaa) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + call wall_time(wall1) + print*,'Wall time for normal_two_body_bi_orth ',wall1-wall0 + + deallocate( occ ) + deallocate( key_i_core ) + +END_PROVIDER + + + +subroutine give_aba_contraction(Nint, h1, h2, p1, p2, Ne, occ, hthree) + + use bitmasks ! you need to include the bitmasks_module.f90 features + + implicit none + integer, intent(in) :: Nint, h1, h2, p1, p2 + integer, intent(in) :: Ne(2), occ(Nint*bit_kind_size,2) + double precision, intent(out) :: hthree + integer :: ii, i + double precision :: int_direct, int_exc_12, int_exc_13, integral + + !!!! double alpha/beta + hthree = 0.d0 + do ii = 1, Ne(2) ! purely closed shell part + i = occ(ii,2) + call give_integrals_3_body_bi_ort(i ,p2,p1,i,h2,h1,integral) + int_direct = -1.d0 * integral + call give_integrals_3_body_bi_ort(p1,p2, i,i,h2,h1,integral) + int_exc_13 = -1.d0 * integral + call give_integrals_3_body_bi_ort(p2, i,p1,i,h2,h1,integral) + int_exc_12 = -1.d0 * integral + hthree += 2.d0 * int_direct - 1.d0 * ( int_exc_13 + int_exc_12) + enddo + do ii = Ne(2) + 1, Ne(1) ! purely open-shell part + i = occ(ii,1) + call give_integrals_3_body_bi_ort(i ,p2,p1,i,h2,h1,integral) + int_direct = -1.d0 * integral + call give_integrals_3_body_bi_ort(p1,p2, i,i,h2,h1,integral) + int_exc_13 = -1.d0 * integral + call give_integrals_3_body_bi_ort(p2, i,p1,i,h2,h1,integral) + int_exc_12 = -1.d0 * integral + hthree += 1.d0 * int_direct - 0.5d0* ( int_exc_13 + int_exc_12) + enddo + +end subroutine give_aba_contraction + + + +BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth_ab, (mo_num, mo_num, mo_num, mo_num)] + + BEGIN_DOC + ! Normal ordered two-body sector of the three-body terms for opposite spin double excitations + END_DOC + + use bitmasks ! you need to include the bitmasks_module.f90 features + + implicit none + integer :: h1, p1, h2, p2, i + integer :: hh1, hh2, pp1, pp2 + integer :: Ne(2) + integer, allocatable :: occ(:,:) + integer(bit_kind), allocatable :: key_i_core(:,:) + double precision :: hthree + + PROVIDE N_int + + allocate( key_i_core(N_int,2) ) + allocate( occ(N_int*bit_kind_size,2) ) + + if(core_tc_op)then + do i = 1, N_int + key_i_core(i,1) = xor(ref_bitmask(i,1),core_bitmask(i,1)) + key_i_core(i,2) = xor(ref_bitmask(i,2),core_bitmask(i,2)) + enddo + call bitstring_to_list_ab(key_i_core,occ,Ne,N_int) + else + call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int) + endif + normal_two_body_bi_orth_ab = 0.d0 + do hh1 = 1, n_act_orb + h1 = list_act(hh1) + do pp1 = 1, n_act_orb + p1 = list_act(pp1) + do hh2 = 1, n_act_orb + h2 = list_act(hh2) + do pp2 = 1, n_act_orb + p2 = list_act(pp2) + call give_aba_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree) + normal_two_body_bi_orth_ab(p2,h2,p1,h1) = hthree + enddo + enddo + enddo + enddo + + deallocate( key_i_core ) + deallocate( occ ) + +END_PROVIDER + + + +BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth_aa_bb, (n_act_orb, n_act_orb, n_act_orb, n_act_orb)] + + BEGIN_DOC + ! Normal ordered two-body sector of the three-body terms for same spin double excitations + END_DOC + + use bitmasks ! you need to include the bitmasks_module.f90 features + + implicit none + integer :: i,ii,j,h1,p1,h2,p2 + integer :: hh1,hh2,pp1,pp2 + integer :: Ne(2) + integer, allocatable :: occ(:,:) + integer(bit_kind), allocatable :: key_i_core(:,:) + double precision :: hthree_aab, hthree_aaa + + PROVIDE N_int + + allocate( key_i_core(N_int,2) ) + allocate( occ(N_int*bit_kind_size,2) ) + + if(core_tc_op)then + do i = 1, N_int + key_i_core(i,1) = xor(ref_bitmask(i,1),core_bitmask(i,1)) + key_i_core(i,2) = xor(ref_bitmask(i,2),core_bitmask(i,2)) + enddo + call bitstring_to_list_ab(key_i_core, occ, Ne, N_int) + else + call bitstring_to_list_ab(ref_bitmask, occ, Ne, N_int) + endif + + normal_two_body_bi_orth_aa_bb = 0.d0 + do hh1 = 1, n_act_orb + h1 = list_act(hh1) + do pp1 = 1 , n_act_orb + p1 = list_act(pp1) + do hh2 = 1, n_act_orb + h2 = list_act(hh2) + do pp2 = 1 , n_act_orb + p2 = list_act(pp2) + if(h1h2 + if(Ne(2).ge.3)then + call give_aaa_contraction(N_int, h2, h1, p1, p2, Ne, occ, hthree_aaa) ! exchange h1<->h2 + else + hthree_aaa = 0.d0 + endif + else + call give_aab_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aab) + if(Ne(2).ge.3)then + call give_aaa_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aaa) + else + hthree_aaa = 0.d0 + endif + endif + normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1) = hthree_aab + hthree_aaa + enddo + enddo + enddo + enddo + + deallocate( key_i_core ) + deallocate( occ ) + +END_PROVIDER + + + +subroutine give_aaa_contraction(Nint, h1, h2, p1, p2, Ne, occ, hthree) + + use bitmasks ! you need to include the bitmasks_module.f90 features + + implicit none + integer, intent(in) :: Nint, h1, h2, p1, p2 + integer, intent(in) :: Ne(2), occ(Nint*bit_kind_size,2) + double precision, intent(out) :: hthree + integer :: ii,i + double precision :: int_direct,int_exc_12,int_exc_13,int_exc_23 + double precision :: integral,int_exc_l,int_exc_ll + + hthree = 0.d0 + do ii = 1, Ne(2) ! purely closed shell part + i = occ(ii,2) + call give_integrals_3_body_bi_ort(i ,p2,p1,i,h2,h1,integral) + int_direct = -1.d0 * integral + call give_integrals_3_body_bi_ort(p2,p1,i ,i,h2,h1,integral) + int_exc_l = -1.d0 * integral + call give_integrals_3_body_bi_ort(p1,i ,p2,i,h2,h1,integral) + int_exc_ll= -1.d0 * integral + call give_integrals_3_body_bi_ort(p2,i ,p1,i,h2,h1,integral) + int_exc_12= -1.d0 * integral + call give_integrals_3_body_bi_ort(p1,p2, i,i,h2,h1,integral) + int_exc_13= -1.d0 * integral + call give_integrals_3_body_bi_ort(i ,p1,p2,i,h2,h1,integral) + int_exc_23= -1.d0 * integral + + hthree += 1.d0 * int_direct + int_exc_l + int_exc_ll -( int_exc_12+ int_exc_13+ int_exc_23 ) + enddo + do ii = Ne(2)+1,Ne(1) ! purely open-shell part + i = occ(ii,1) + call give_integrals_3_body_bi_ort(i ,p2,p1,i,h2,h1,integral) + int_direct = -1.d0 * integral + call give_integrals_3_body_bi_ort(p2,p1,i ,i,h2,h1,integral) + int_exc_l = -1.d0 * integral + call give_integrals_3_body_bi_ort(p1,i ,p2,i,h2,h1,integral) + int_exc_ll= -1.d0 * integral + call give_integrals_3_body_bi_ort(p2,i ,p1,i,h2,h1,integral) + int_exc_12= -1.d0 * integral + call give_integrals_3_body_bi_ort(p1,p2, i,i,h2,h1,integral) + int_exc_13= -1.d0 * integral + call give_integrals_3_body_bi_ort(i ,p1,p2,i,h2,h1,integral) + int_exc_23= -1.d0 * integral + + hthree += 1.d0 * int_direct + 0.5d0 * (int_exc_l + int_exc_ll -( int_exc_12+ int_exc_13+ int_exc_23 )) + enddo + +end subroutine give_aaa_contraction + + + +subroutine give_aab_contraction(Nint, h1, h2, p1, p2, Ne, occ, hthree) + implicit none + use bitmasks ! you need to include the bitmasks_module.f90 features + integer, intent(in) :: Nint, h1, h2, p1, p2 + integer, intent(in) :: Ne(2), occ(Nint*bit_kind_size,2) + double precision, intent(out) :: hthree + integer :: ii, i + double precision :: int_direct, int_exc_12, int_exc_13, int_exc_23 + double precision :: integral, int_exc_l, int_exc_ll + + hthree = 0.d0 + do ii = 1, Ne(2) ! purely closed shell part + i = occ(ii,2) + call give_integrals_3_body_bi_ort(p2,p1,i,h2,h1,i,integral) + int_direct = -1.d0 * integral + call give_integrals_3_body_bi_ort(p1,p2,i,h2,h1,i,integral) + int_exc_23= -1.d0 * integral + hthree += 1.d0 * int_direct - int_exc_23 + enddo + +end subroutine give_aab_contraction diff --git a/src/tc_bi_ortho/print_tc_wf.irp.f b/src/tc_bi_ortho/print_tc_wf.irp.f new file mode 100644 index 00000000..58a733a7 --- /dev/null +++ b/src/tc_bi_ortho/print_tc_wf.irp.f @@ -0,0 +1,104 @@ +program print_tc_bi_ortho + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid +! if(three_body_h_tc)then +! call provide_all_three_ints_bi_ortho +! endif +! call routine + call write_l_r_wf +end + +subroutine write_l_r_wf + implicit none + character*(128) :: output + integer :: i_unit_output,getUnitAndOpen + output=trim(ezfio_filename)//'.tc_wf' + i_unit_output = getUnitAndOpen(output,'w') + integer :: i + print*,'Writing the left-right wf' + do i = 1, N_det + write(i_unit_output,*)i,psi_l_coef_sorted_bi_ortho_left(i),psi_r_coef_sorted_bi_ortho_right(i) + enddo + + +end + +subroutine routine + implicit none + integer :: i,degree + integer :: exc(0:2,2,2),h1,p1,s1,h2,p2,s2 + double precision :: hmono,htwoe,hthree,htilde_ij,coef_pt1,e_i0,delta_e,e_pt2 + double precision :: contrib_pt,e_corr,coef,contrib,phase + double precision :: accu_positive,accu_positive_pt, accu_positive_core,accu_positive_core_pt + e_pt2 = 0.d0 + accu_positive = 0.D0 + accu_positive_pt = 0.D0 + accu_positive_core = 0.d0 + accu_positive_core_pt = 0.d0 + + do i = 1, N_det + call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int) + if(degree == 1 .or. degree == 2)then + call htilde_mu_mat_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) + call htilde_mu_mat_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0) + delta_e = e_tilde_00 - e_i0 + coef_pt1 = htilde_ij / delta_e + + call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij) + contrib_pt = coef_pt1 * htilde_ij + e_pt2 += contrib_pt + + coef = psi_r_coef_bi_ortho(i,1)/psi_r_coef_bi_ortho(1,1) + contrib = coef * htilde_ij + e_corr += contrib + call get_excitation(HF_bitmask,psi_det(1,1,i),exc,degree,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + print*,'*********' + if(degree==1)then + print*,'s1',s1 + print*,'h1,p1 = ',h1,p1 + else if(degree ==2)then + print*,'s1',s1 + print*,'h1,p1 = ',h1,p1 + print*,'s2',s2 + print*,'h2,p2 = ',h2,p2 + endif + print*,'coef_pt1 = ',coef_pt1 + print*,'coef = ',coef + print*,'contrib_pt ',contrib_pt + print*,'contrib = ',contrib + if(contrib.gt.0.d0)then + accu_positive += contrib + if(h1==1.or.h2==1)then + accu_positive_core += contrib + endif + if(dabs(contrib).gt.1.d-5)then + print*,'Found a positive contribution to correlation energy !!' + endif + endif + if(contrib_pt.gt.0.d0)then + accu_positive_pt += contrib_pt + if(h2==1.or.h1==1)then + accu_positive_core_pt += contrib_pt + endif + endif + endif + enddo + print*,'' + print*,'' + print*,'Total correlation energy = ',e_corr + print*,'Total correlation energy PT = ',e_pt2 + print*,'Positive contribution to ecorr = ',accu_positive + print*,'Positive contribution to ecorr PT = ',accu_positive_pt + print*,'Pure core contribution = ',accu_positive_core + print*,'Pure core contribution PT = ',accu_positive_core_pt +end diff --git a/src/tc_bi_ortho/psi_det_tc_sorted.irp.f b/src/tc_bi_ortho/psi_det_tc_sorted.irp.f new file mode 100644 index 00000000..212c8588 --- /dev/null +++ b/src/tc_bi_ortho/psi_det_tc_sorted.irp.f @@ -0,0 +1,157 @@ +use bitmasks + +BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_tc, (psi_det_size) ] + implicit none + BEGIN_DOC + ! Contribution of determinants to the state-averaged density. + END_DOC + integer :: i,j,k + double precision :: f + + psi_average_norm_contrib_tc(:) = 0.d0 + do k=1,N_states + do i=1,N_det + psi_average_norm_contrib_tc(i) = psi_average_norm_contrib_tc(i) + & + dabs(psi_l_coef_bi_ortho(i,k)*psi_r_coef_bi_ortho(i,k))*state_average_weight(k) + enddo + enddo + f = 1.d0/sum(psi_average_norm_contrib_tc(1:N_det)) + do i=1,N_det + psi_average_norm_contrib_tc(i) = psi_average_norm_contrib_tc(i)*f + enddo +END_PROVIDER + + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_tc, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_sorted_tc, (psi_det_size,N_states) ] +&BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_sorted_tc, (psi_det_size) ] +&BEGIN_PROVIDER [ integer, psi_det_sorted_tc_order, (psi_det_size) ] + implicit none + BEGIN_DOC + ! Wave function sorted by determinants contribution to the norm (state-averaged) + ! + ! psi_det_sorted_tc_order(i) -> k : index in psi_det + END_DOC + integer :: i,j,k + integer, allocatable :: iorder(:) + allocate ( iorder(N_det) ) + do i=1,N_det + psi_average_norm_contrib_sorted_tc(i) = -psi_average_norm_contrib_tc(i) + iorder(i) = i + enddo + call dsort(psi_average_norm_contrib_sorted_tc,iorder,N_det) + do i=1,N_det + do j=1,N_int + psi_det_sorted_tc(j,1,i) = psi_det(j,1,iorder(i)) + psi_det_sorted_tc(j,2,i) = psi_det(j,2,iorder(i)) + enddo + psi_average_norm_contrib_sorted_tc(i) = -psi_average_norm_contrib_sorted_tc(i) + psi_det_sorted_tc_order(iorder(i)) = i + enddo + double precision :: accu + do k=1,N_states + accu = 0.d0 + do i=1,N_det + psi_coef_sorted_tc(i,k) = dsqrt(dabs(psi_l_coef_bi_ortho(iorder(i),k)*psi_r_coef_bi_ortho(iorder(i),k))) + accu += psi_coef_sorted_tc(i,k)**2 + enddo + accu = 1.d0/dsqrt(accu) + do i=1,N_det + psi_coef_sorted_tc(i,k) *= accu + enddo + enddo + + psi_det_sorted_tc(:,:,N_det+1:psi_det_size) = 0_bit_kind + psi_coef_sorted_tc(N_det+1:psi_det_size,:) = 0.d0 + psi_average_norm_contrib_sorted_tc(N_det+1:psi_det_size) = 0.d0 + psi_det_sorted_tc_order(N_det+1:psi_det_size) = 0 + + deallocate(iorder) + +END_PROVIDER + + BEGIN_PROVIDER [double precision, psi_r_coef_sorted_bi_ortho, (psi_det_size, N_states)] +&BEGIN_PROVIDER [double precision, psi_l_coef_sorted_bi_ortho, (psi_det_size, N_states)] + BEGIN_DOC + ! psi_r_coef_sorted_bi_ortho : right coefficients corresponding to psi_det_sorted_tc + ! psi_l_coef_sorted_bi_ortho : left coefficients corresponding to psi_det_sorted_tc + END_DOC + implicit none + integer :: i, j, k + psi_r_coef_sorted_bi_ortho = 0.d0 + psi_l_coef_sorted_bi_ortho = 0.d0 + do i = 1, N_det + psi_r_coef_sorted_bi_ortho(i,1) = psi_r_coef_bi_ortho(psi_det_sorted_tc_order(i),1) + psi_l_coef_sorted_bi_ortho(i,1) = psi_l_coef_bi_ortho(psi_det_sorted_tc_order(i),1) + enddo + +END_PROVIDER + + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_tc_bit, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_sorted_tc_bit, (psi_det_size,N_states) ] + implicit none + BEGIN_DOC + ! Determinants on which we apply $\langle i|H|psi \rangle$ for perturbation. + ! They are sorted by determinants interpreted as integers. Useful + ! to accelerate the search of a random determinant in the wave + ! function. + END_DOC + + call sort_dets_by_det_search_key(N_det, psi_det, psi_coef, size(psi_coef,1), & + psi_det_sorted_tc_bit, psi_coef_sorted_tc_bit, N_states) + +END_PROVIDER + + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_tc_right, (N_int,2,N_det) ] +&BEGIN_PROVIDER [double precision, psi_r_coef_sorted_bi_ortho_right, (N_det)] + implicit none + BEGIN_DOC + ! psi_det_sorted_tc_right : Slater determinants sorted by decreasing value of |right- coefficients| + ! + ! psi_r_coef_sorted_bi_ortho_right : right wave function according to psi_det_sorted_tc_right + END_DOC + integer, allocatable :: iorder(:) + double precision, allocatable :: coef(:) + integer :: i,j + allocate ( iorder(N_det) , coef(N_det)) + do i=1,N_det + coef(i) = -dabs(psi_r_coef_bi_ortho(i,1)/psi_r_coef_bi_ortho(1,1)) + iorder(i) = i + enddo + call dsort(coef,iorder,N_det) + do i=1,N_det + do j=1,N_int + psi_det_sorted_tc_right(j,1,i) = psi_det(j,1,iorder(i)) + psi_det_sorted_tc_right(j,2,i) = psi_det(j,2,iorder(i)) + enddo + psi_r_coef_sorted_bi_ortho_right(i) = psi_r_coef_bi_ortho(iorder(i),1)/psi_r_coef_bi_ortho(iorder(1),1) + enddo +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_tc_left, (N_int,2,N_det) ] +&BEGIN_PROVIDER [double precision, psi_l_coef_sorted_bi_ortho_left, (N_det)] + implicit none + BEGIN_DOC + ! psi_det_sorted_tc_left : Slater determinants sorted by decreasing value of |LEFTt- coefficients| + ! + ! psi_r_coef_sorted_bi_ortho_left : LEFT wave function according to psi_det_sorted_tc_left + END_DOC + integer, allocatable :: iorder(:) + double precision, allocatable :: coef(:) + integer :: i,j + allocate ( iorder(N_det) , coef(N_det)) + do i=1,N_det + coef(i) = -dabs(psi_l_coef_bi_ortho(i,1)/psi_r_coef_bi_ortho(1,1)) + iorder(i) = i + enddo + call dsort(coef,iorder,N_det) + do i=1,N_det + do j=1,N_int + psi_det_sorted_tc_left(j,1,i) = psi_det(j,1,iorder(i)) + psi_det_sorted_tc_left(j,2,i) = psi_det(j,2,iorder(i)) + enddo + psi_l_coef_sorted_bi_ortho_left(i) = psi_l_coef_bi_ortho(iorder(i),1)/psi_l_coef_bi_ortho(iorder(1),1) + enddo +END_PROVIDER diff --git a/src/tc_bi_ortho/psi_left_qmc.irp.f b/src/tc_bi_ortho/psi_left_qmc.irp.f new file mode 100644 index 00000000..25048f82 --- /dev/null +++ b/src/tc_bi_ortho/psi_left_qmc.irp.f @@ -0,0 +1,44 @@ + +! --- + +BEGIN_PROVIDER [ double precision, psi_bitcleft_bilinear_matrix_values, (N_det,N_states) ] + + BEGIN_DOC + ! Sparse coefficient matrix if the wave function is expressed in a bilinear form : + ! $D_\alpha^\dagger.C.D_\beta$ + ! + ! Rows are $\alpha$ determinants and columns are $\beta$. + ! + ! Order refers to psi_det + END_DOC + + use bitmasks + + implicit none + integer :: k, l + + if(N_det .eq. 1) then + + do l = 1, N_states + psi_bitcleft_bilinear_matrix_values(1,l) = 1.d0 + enddo + + else + + do l = 1, N_states + do k = 1, N_det + psi_bitcleft_bilinear_matrix_values(k,l) = psi_l_coef_bi_ortho(k,l) + enddo + enddo + + PROVIDE psi_bilinear_matrix_order + do l = 1, N_states + call dset_order(psi_bitcleft_bilinear_matrix_values(1,l), psi_bilinear_matrix_order, N_det) + enddo + + endif + +END_PROVIDER + +! --- + diff --git a/src/tc_bi_ortho/psi_r_l_prov.irp.f b/src/tc_bi_ortho/psi_r_l_prov.irp.f new file mode 100644 index 00000000..551da858 --- /dev/null +++ b/src/tc_bi_ortho/psi_r_l_prov.irp.f @@ -0,0 +1,217 @@ +use bitmasks + +BEGIN_PROVIDER [ double precision, psi_l_coef_bi_ortho, (psi_det_size,N_states) ] + implicit none + BEGIN_DOC + ! The wave function coefficients. Initialized with Hartree-Fock if the |EZFIO| file + ! is empty. + END_DOC + + integer :: i,k, N_int2 + logical :: exists + character*(64) :: label + + PROVIDE read_wf N_det mo_label ezfio_filename nproc + psi_l_coef_bi_ortho = 0.d0 + do i=1,min(N_states,N_det) + psi_l_coef_bi_ortho(i,i) = 1.d0 + enddo + + if (mpi_master) then + if (read_wf) then + call ezfio_has_tc_bi_ortho_psi_l_coef_bi_ortho(exists) +! if (exists) then +! call ezfio_has_tc_bi_ortho_mo_label(exists) +! if (exists) then +! call ezfio_get_tc_bi_ortho_mo_label(label) +! exists = (label == mo_label) +! endif +! endif + + if (exists) then + + double precision, allocatable :: psi_l_coef_bi_ortho_read(:,:) + allocate (psi_l_coef_bi_ortho_read(N_det,N_states)) + print *, 'Read psi_l_coef_bi_ortho', N_det, N_states + call ezfio_get_tc_bi_ortho_psi_l_coef_bi_ortho(psi_l_coef_bi_ortho_read) + do k=1,N_states + do i=1,N_det + psi_l_coef_bi_ortho(i,k) = psi_l_coef_bi_ortho_read(i,k) + enddo + enddo + deallocate(psi_l_coef_bi_ortho_read) + + endif + endif + endif + IRP_IF MPI_DEBUG + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + IRP_ENDIF + IRP_IF MPI + include 'mpif.h' + integer :: ierr + call MPI_BCAST( psi_l_coef_bi_ortho, size(psi_l_coef_bi_ortho), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read psi_l_coef_bi_ortho with MPI' + endif + IRP_ENDIF +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, psi_r_coef_bi_ortho, (psi_det_size,N_states) ] + implicit none + BEGIN_DOC + ! The wave function coefficients. Initialized with Hartree-Fock if the |EZFIO| file + ! is empty. + END_DOC + + integer :: i,k, N_int2 + logical :: exists + character*(64) :: label + + PROVIDE read_wf N_det mo_label ezfio_filename nproc + psi_r_coef_bi_ortho = 0.d0 + do i=1,min(N_states,N_det) + psi_r_coef_bi_ortho(i,i) = 1.d0 + enddo + + if (mpi_master) then + if (read_wf) then + call ezfio_has_tc_bi_ortho_psi_r_coef_bi_ortho(exists) +! if (exists) then +! call ezfio_has_tc_bi_ortho_mo_label(exists) +! if (exists) then +! call ezfio_get_tc_bi_ortho_mo_label(label) +! exists = (label == mo_label) +! endif +! endif + + if (exists) then + + double precision, allocatable :: psi_r_coef_bi_ortho_read(:,:) + allocate (psi_r_coef_bi_ortho_read(N_det,N_states)) + print *, 'Read psi_r_coef_bi_ortho', N_det, N_states + call ezfio_get_tc_bi_ortho_psi_r_coef_bi_ortho(psi_r_coef_bi_ortho_read) + do k=1,N_states + do i=1,N_det + psi_r_coef_bi_ortho(i,k) = psi_r_coef_bi_ortho_read(i,k) + enddo + enddo + deallocate(psi_r_coef_bi_ortho_read) + + endif + endif + endif + IRP_IF MPI_DEBUG + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + IRP_ENDIF + IRP_IF MPI + include 'mpif.h' + integer :: ierr + call MPI_BCAST( psi_r_coef_bi_ortho, size(psi_r_coef_bi_ortho), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read psi_r_coef_bi_ortho with MPI' + endif + IRP_ENDIF +END_PROVIDER + + +subroutine save_tc_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psilcoef,psircoef) + implicit none + BEGIN_DOC + ! Save the wave function into the |EZFIO| file + END_DOC + use bitmasks + include 'constants.include.F' + integer, intent(in) :: ndet,nstates,dim_psicoef + integer(bit_kind), intent(in) :: psidet(N_int,2,ndet) + double precision, intent(in) :: psilcoef(dim_psicoef,nstates) + double precision, intent(in) :: psircoef(dim_psicoef,nstates) + integer*8, allocatable :: psi_det_save(:,:,:) + double precision, allocatable :: psil_coef_save(:,:) + double precision, allocatable :: psir_coef_save(:,:) + + double precision :: accu_norm + integer :: i,j,k, ndet_qp_edit + + if (mpi_master) then + ndet_qp_edit = min(ndet,N_det_qp_edit) + + call ezfio_set_determinants_N_int(N_int) + call ezfio_set_determinants_bit_kind(bit_kind) + call ezfio_set_determinants_N_det(ndet) + call ezfio_set_determinants_N_det_qp_edit(ndet_qp_edit) + call ezfio_set_determinants_n_states(nstates) + call ezfio_set_determinants_mo_label(mo_label) + + allocate (psi_det_save(N_int,2,ndet)) + do i=1,ndet + do j=1,2 + do k=1,N_int + psi_det_save(k,j,i) = transfer(psidet(k,j,i),1_8) + enddo + enddo + enddo + call ezfio_set_determinants_psi_det(psi_det_save) + call ezfio_set_determinants_psi_det_qp_edit(psi_det_save) + deallocate (psi_det_save) + + allocate (psil_coef_save(ndet,nstates),psir_coef_save(ndet,nstates)) + do k=1,nstates + do i=1,ndet + psil_coef_save(i,k) = psilcoef(i,k) + psir_coef_save(i,k) = psircoef(i,k) + enddo + enddo + + call ezfio_set_tc_bi_ortho_psi_l_coef_bi_ortho(psil_coef_save) + call ezfio_set_tc_bi_ortho_psi_r_coef_bi_ortho(psir_coef_save) + deallocate (psil_coef_save,psir_coef_save) + +! allocate (psi_coef_save(ndet_qp_edit,nstates)) +! do k=1,nstates +! do i=1,ndet_qp_edit +! psi_coef_save(i,k) = psicoef(i,k) +! enddo +! enddo +! +! call ezfio_set_determinants_psi_coef_qp_edit(psi_coef_save) +! deallocate (psi_coef_save) + + call write_int(6,ndet,'Saved determinantsi and psi_r/psi_l coef') + endif +end + +subroutine save_tc_bi_ortho_wavefunction + implicit none + call save_tc_wavefunction_general(N_det,N_states,psi_det,size(psi_l_coef_bi_ortho, 1),psi_l_coef_bi_ortho,psi_r_coef_bi_ortho) + call routine_save_right_bi_ortho +end + +subroutine routine_save_right_bi_ortho + implicit none + double precision, allocatable :: coef_tmp(:,:) + integer :: i + N_states = 1 + allocate(coef_tmp(N_det, N_states)) + do i = 1, N_det + coef_tmp(i,1) = psi_r_coef_bi_ortho(i,1) + enddo + call save_wavefunction_general_unormalized(N_det,N_states,psi_det,size(coef_tmp,1),coef_tmp(1,1)) +end + +subroutine routine_save_left_right_bi_ortho + implicit none + double precision, allocatable :: coef_tmp(:,:) + integer :: i,n_states_tmp + n_states_tmp = 2 + allocate(coef_tmp(N_det, n_states_tmp)) + do i = 1, N_det + coef_tmp(i,1) = psi_r_coef_bi_ortho(i,1) + coef_tmp(i,2) = psi_l_coef_bi_ortho(i,1) + enddo + call save_wavefunction_general_unormalized(N_det,n_states_tmp,psi_det,size(coef_tmp,1),coef_tmp(1,1)) +end + diff --git a/src/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f b/src/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f new file mode 100644 index 00000000..60201f5f --- /dev/null +++ b/src/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f @@ -0,0 +1,61 @@ +program save_bitcpsileft_for_qmcchem + + integer :: iunit + logical :: exists + double precision :: e_ref + + print *, ' ' + print *, ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' + print *, ' call save_for_qmcchem before ' + print *, ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' + print *, ' ' + + call write_lr_spindeterminants() + + e_ref = 0.d0 + iunit = 13 + open(unit=iunit,file=trim(ezfio_filename)//'/simulation/e_ref',action='write') + call ezfio_has_fci_energy_pt2(exists) + + if(.not.exists) then + call ezfio_has_fci_energy(exists) + + if(.not.exists) then + call ezfio_has_tc_scf_bitc_energy(exists) + if(exists) then + call ezfio_get_tc_scf_bitc_energy(e_ref) + endif + endif + + endif + write(iunit,*) e_ref + close(iunit) + +end + +! -- + +subroutine write_lr_spindeterminants() + + use bitmasks + + implicit none + + integer :: k, l + double precision, allocatable :: buffer(:,:) + + PROVIDE psi_bitcleft_bilinear_matrix_values + + allocate(buffer(N_det,N_states)) + do l = 1, N_states + do k = 1, N_det + buffer(k,l) = psi_bitcleft_bilinear_matrix_values(k,l) + enddo + enddo + call ezfio_set_spindeterminants_psi_left_coef_matrix_values(buffer) + deallocate(buffer) + +end subroutine write_lr_spindeterminants + +! --- + diff --git a/src/tc_bi_ortho/save_lr_bi_ortho_states.irp.f b/src/tc_bi_ortho/save_lr_bi_ortho_states.irp.f new file mode 100644 index 00000000..5eb3c069 --- /dev/null +++ b/src/tc_bi_ortho/save_lr_bi_ortho_states.irp.f @@ -0,0 +1,15 @@ +program tc_bi_ortho + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + call routine_save_left_right_bi_ortho +! call test +end diff --git a/src/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f b/src/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f new file mode 100644 index 00000000..9b7b9f5a --- /dev/null +++ b/src/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f @@ -0,0 +1,33 @@ + program tc_natorb_bi_ortho + implicit none + BEGIN_DOC + ! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + call save_tc_natorb + end + + subroutine save_tc_natorb + implicit none + print*,'Saving the natorbs ' + provide natorb_tc_leigvec_ao natorb_tc_reigvec_ao + call ezfio_set_bi_ortho_mos_mo_l_coef(natorb_tc_leigvec_ao) + call ezfio_set_bi_ortho_mos_mo_r_coef(natorb_tc_reigvec_ao) + call save_ref_determinant_nstates_1 + call ezfio_set_determinants_read_wf(.False.) + end + + subroutine save_ref_determinant_nstates_1 + implicit none + use bitmasks + double precision :: buffer(1,N_states) + buffer = 0.d0 + buffer(1,1) = 1.d0 + call save_wavefunction_general(1,1,ref_bitmask,1,buffer) + end diff --git a/src/tc_bi_ortho/select_dets_bi_ortho.irp.f b/src/tc_bi_ortho/select_dets_bi_ortho.irp.f new file mode 100644 index 00000000..e6bf3d6e --- /dev/null +++ b/src/tc_bi_ortho/select_dets_bi_ortho.irp.f @@ -0,0 +1,61 @@ +program tc_bi_ortho + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + !!!!!!!!!!!!!!! WARNING NO 3-BODY + !!!!!!!!!!!!!!! WARNING NO 3-BODY + three_body_h_tc = .False. + touch three_body_h_tc + !!!!!!!!!!!!!!! WARNING NO 3-BODY + !!!!!!!!!!!!!!! WARNING NO 3-BODY + + call routine_test +! call test +end + +subroutine routine_test + implicit none + use bitmasks ! you need to include the bitmasks_module.f90 features + integer :: i,n_good,degree + integer(bit_kind), allocatable :: dets(:,:,:) + integer, allocatable :: iorder(:) + double precision, allocatable :: coef(:),coef_new(:,:) + double precision :: thr + allocate(coef(N_det), iorder(N_det)) + do i = 1, N_det + iorder(i) = i + call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int) + if(degree==1)then + coef(i) = -0.5d0 + else + coef(i) = -dabs(coef_pt1_bi_ortho(i)) + endif + enddo + call dsort(coef,iorder,N_det) + !thr = save_threshold + thr = 1d-15 + n_good = 0 + do i = 1, N_det + if(dabs(coef(i)).gt.thr)then + n_good += 1 + endif + enddo + print*,'n_good = ',n_good + allocate(dets(N_int,2,n_good),coef_new(n_good,n_states)) + do i = 1, n_good + dets(:,:,i) = psi_det(:,:,iorder(i)) + coef_new(i,:) = psi_coef(iorder(i),:) + enddo + call save_wavefunction_general(n_good,n_states,dets,n_good,coef_new) + + +end diff --git a/src/tc_bi_ortho/slater_tc.irp.f b/src/tc_bi_ortho/slater_tc.irp.f new file mode 100644 index 00000000..45115a40 --- /dev/null +++ b/src/tc_bi_ortho/slater_tc.irp.f @@ -0,0 +1,359 @@ +!!!!!! +subroutine htilde_mu_mat_bi_ortho_tot(key_j, key_i, Nint, htot) + + BEGIN_DOC + ! where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis + !! + !! WARNING !! + ! + ! Non hermitian !! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) + double precision, intent(out) :: htot + double precision :: hmono,htwoe,hthree + integer :: degree + call get_excitation_degree(key_j, key_i, degree, Nint) + if(degree.gt.2)then + htot = 0.d0 + else + call htilde_mu_mat_bi_ortho(key_j,key_i, Nint, hmono,htwoe,hthree,htot) + endif + +end subroutine htilde_mu_mat_tot + +! -- + +subroutine htilde_mu_mat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot) + implicit none + use bitmasks + BEGIN_DOC + ! where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis + !! + ! Returns the detail of the matrix element in terms of single, two and three electron contribution. + !! WARNING !! + ! + ! Non hermitian !! + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2),key_j(Nint,2) + double precision, intent(out) :: hmono,htwoe,hthree,htot + integer :: degree + + hmono = 0.d0 + htwoe= 0.d0 + htot = 0.d0 + hthree = 0.D0 + call get_excitation_degree(key_i, key_j, degree, Nint) + if(degree.gt.2)return + if(degree == 0)then + call diag_htilde_mu_mat_bi_ortho(Nint, key_i, hmono, htwoe, htot) + else if (degree == 1)then + call single_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot) + else if(degree == 2)then + call double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot) + endif + if(three_body_h_tc) then + if(degree == 2) then + if(.not.double_normal_ord) then + call double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree) + endif + else if(degree == 1)then + call single_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree) + else if(degree == 0)then + call diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree) + endif + endif + htot = hmono + htwoe + hthree + if(degree==0)then + htot += nuclear_repulsion + endif + +end + +subroutine diag_htilde_mu_mat_bi_ortho(Nint, key_i, hmono, htwoe, htot) + + BEGIN_DOC + ! diagonal element of htilde ONLY FOR ONE- AND TWO-BODY TERMS + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2) + double precision, intent(out) :: hmono,htwoe,htot + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk + double precision :: get_mo_two_e_integral_tc_int + integer(bit_kind) :: key_i_core(Nint,2) + +! PROVIDE mo_two_e_integrals_tc_int_in_map mo_bi_ortho_tc_two_e +! +! PROVIDE mo_integrals_erf_map core_energy nuclear_repulsion core_bitmask +! PROVIDE core_fock_operator +! +! PROVIDE j1b_gauss + +! if(core_tc_op)then +! print*,'core_tc_op not already taken into account for bi ortho' +! print*,'stopping ...' +! stop +! do i = 1, Nint +! key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1)) +! key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2)) +! enddo +! call bitstring_to_list_ab(key_i_core, occ, Ne, Nint) +! hmono = core_energy - nuclear_repulsion +! else + call bitstring_to_list_ab(key_i, occ, Ne, Nint) + hmono = 0.d0 +! endif + htwoe= 0.d0 + htot = 0.d0 + + do ispin = 1, 2 + do i = 1, Ne(ispin) ! + ii = occ(i,ispin) + hmono += mo_bi_ortho_tc_one_e(ii,ii) + +! if(j1b_gauss .eq. 1) then +! print*,'j1b not implemented for bi ortho TC' +! print*,'stopping ....' +! stop +! !hmono += mo_j1b_gauss_hermI (ii,ii) & +! ! + mo_j1b_gauss_hermII (ii,ii) & +! ! + mo_j1b_gauss_nonherm(ii,ii) +! endif + +! if(core_tc_op)then +! print*,'core_tc_op not already taken into account for bi ortho' +! print*,'stopping ...' +! stop +! hmono += core_fock_operator(ii,ii) ! add the usual Coulomb - Exchange from the core +! endif + enddo + enddo + + + ! alpha/beta two-body + ispin = 1 + jspin = 2 + do i = 1, Ne(ispin) ! electron 1 (so it can be associated to mu(r1)) + ii = occ(i,ispin) + do j = 1, Ne(jspin) ! electron 2 + jj = occ(j,jspin) + htwoe += mo_bi_ortho_tc_two_e(jj,ii,jj,ii) + enddo + enddo + + ! alpha/alpha two-body + do i = 1, Ne(ispin) + ii = occ(i,ispin) + do j = i+1, Ne(ispin) + jj = occ(j,ispin) + htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii) + enddo + enddo + + ! beta/beta two-body + do i = 1, Ne(jspin) + ii = occ(i,jspin) + do j = i+1, Ne(jspin) + jj = occ(j,jspin) + htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii) + enddo + enddo + htot = hmono + htwoe + +end + + + +subroutine double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot) + + BEGIN_DOC + ! for double excitation ONLY FOR ONE- AND TWO-BODY TERMS + !! + !! WARNING !! + ! + ! Non hermitian !! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2) + double precision, intent(out) :: hmono, htwoe, htot + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk + integer :: degree,exc(0:2,2,2) + integer :: h1, p1, h2, p2, s1, s2 + integer :: other_spin(2) + integer(bit_kind) :: key_i_core(Nint,2) + double precision :: get_mo_two_e_integral_tc_int,phase + +! PROVIDE mo_two_e_integrals_tc_int_in_map mo_bi_ortho_tc_two_e + + other_spin(1) = 2 + other_spin(2) = 1 + + call get_excitation_degree(key_i, key_j, degree, Nint) + + hmono = 0.d0 + htwoe= 0.d0 + htot = 0.d0 + + if(degree.ne.2)then + return + endif + +! if(core_tc_op)then +! print*,'core_tc_op not already taken into account for bi ortho' +! print*,'stopping ...' +! stop +! do i = 1, Nint +! key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1)) +! key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2)) +! enddo +! call bitstring_to_list_ab(key_i_core, occ, Ne, Nint) +! else + call bitstring_to_list_ab(key_i, occ, Ne, Nint) +! endif + call get_double_excitation(key_i, key_j, exc, phase, Nint) + call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2) + + if(s1.ne.s2)then + ! opposite spin two-body +! key_j, key_i + htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1) + if(double_normal_ord.and.+Ne(1).gt.2)then + htwoe += normal_two_body_bi_orth(p2,h2,p1,h1)!!! WTF ??? + endif + else + ! same spin two-body + ! direct terms + htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1) + ! exchange terms + htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1) + if(double_normal_ord.and.+Ne(1).gt.2)then + htwoe -= normal_two_body_bi_orth(h2,p1,h1,p2)!!! WTF ??? + htwoe += normal_two_body_bi_orth(h1,p1,h2,p2)!!! WTF ??? + endif + endif + htwoe *= phase + htot = htwoe + +end + + +subroutine single_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot) + + BEGIN_DOC + ! for single excitation ONLY FOR ONE- AND TWO-BODY TERMS + !! + !! WARNING !! + ! + ! Non hermitian !! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2) + double precision, intent(out) :: hmono, htwoe, htot + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk + integer :: degree,exc(0:2,2,2) + integer :: h1, p1, h2, p2, s1, s2 + double precision :: get_mo_two_e_integral_tc_int, phase + double precision :: direct_int, exchange_int_12, exchange_int_23, exchange_int_13 + integer :: other_spin(2) + integer(bit_kind) :: key_j_core(Nint,2), key_i_core(Nint,2) + +! PROVIDE mo_two_e_integrals_tc_int_in_map mo_bi_ortho_tc_two_e +! +! PROVIDE core_bitmask core_fock_operator mo_integrals_erf_map + +! PROVIDE j1b_gauss + + other_spin(1) = 2 + other_spin(2) = 1 + + hmono = 0.d0 + htwoe= 0.d0 + htot = 0.d0 + call get_excitation_degree(key_i, key_j, degree, Nint) + if(degree.ne.1)then + return + endif +! if(core_tc_op)then +! print*,'core_tc_op not already taken into account for bi ortho' +! print*,'stopping ...' +! stop +! do i = 1, Nint +! key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1)) +! key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2)) +! key_j_core(i,1) = xor(key_j(i,1),core_bitmask(i,1)) +! key_j_core(i,2) = xor(key_j(i,2),core_bitmask(i,2)) +! enddo +! call bitstring_to_list_ab(key_i_core, occ, Ne, Nint) +! else + call bitstring_to_list_ab(key_i, occ, Ne, Nint) +! endif + + call get_single_excitation(key_i, key_j, exc, phase, Nint) + call decode_exc(exc,1,h1,p1,h2,p2,s1,s2) + + hmono = mo_bi_ortho_tc_one_e(p1,h1) * phase + +! if(j1b_gauss .eq. 1) then +! print*,'j1b not implemented for bi ortho TC' +! print*,'stopping ....' +! stop +! !hmono += ( mo_j1b_gauss_hermI (h1,p1) & +! ! + mo_j1b_gauss_hermII (h1,p1) & +! ! + mo_j1b_gauss_nonherm(h1,p1) ) * phase +! endif + +! if(core_tc_op)then +! print*,'core_tc_op not already taken into account for bi ortho' +! print*,'stopping ...' +! stop +! hmono += phase * core_fock_operator(h1,p1) +! endif + + ! alpha/beta two-body + ispin = other_spin(s1) + if(s1==1)then + ! single alpha + do i = 1, Ne(ispin) ! electron 2 + ii = occ(i,ispin) + htwoe += mo_bi_ortho_tc_two_e(ii,p1,ii,h1) + enddo + else + ! single beta + do i = 1, Ne(ispin) ! electron 1 + ii = occ(i,ispin) + htwoe += mo_bi_ortho_tc_two_e(p1,ii,h1,ii) + enddo + endif +! ! same spin two-body + do i = 1, Ne(s1) + ii = occ(i,s1) + ! (h1p1|ii ii) - (h1 ii| p1 ii) + htwoe += mo_bi_ortho_tc_two_e(ii,p1,ii,h1) - mo_bi_ortho_tc_two_e(p1,ii,ii,h1) + enddo + + htwoe *= phase + htot = hmono + htwoe + +end + + diff --git a/src/tc_bi_ortho/slater_tc_3e.irp.f b/src/tc_bi_ortho/slater_tc_3e.irp.f new file mode 100644 index 00000000..7c2c9c86 --- /dev/null +++ b/src/tc_bi_ortho/slater_tc_3e.irp.f @@ -0,0 +1,293 @@ +subroutine provide_all_three_ints_bi_ortho + implicit none + BEGIN_DOC +! routine that provides all necessary three-electron integrals + END_DOC + if(three_body_h_tc)then + PROVIDE three_e_3_idx_direct_bi_ort three_e_3_idx_cycle_1_bi_ort three_e_3_idx_cycle_2_bi_ort + PROVIDE three_e_3_idx_exch23_bi_ort three_e_3_idx_exch13_bi_ort three_e_3_idx_exch12_bi_ort + PROVIDE three_e_4_idx_direct_bi_ort three_e_4_idx_cycle_1_bi_ort three_e_4_idx_cycle_2_bi_ort + PROVIDE three_e_4_idx_exch23_bi_ort three_e_4_idx_exch13_bi_ort three_e_4_idx_exch12_bi_ort + endif +if(.not.double_normal_ord)then + PROVIDE three_e_5_idx_direct_bi_ort three_e_5_idx_cycle_1_bi_ort three_e_5_idx_cycle_2_bi_ort + PROVIDE three_e_5_idx_exch23_bi_ort three_e_5_idx_exch13_bi_ort three_e_5_idx_exch12_bi_ort +else + PROVIDE normal_two_body_bi_orth +endif +end + +subroutine diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree) + + BEGIN_DOC + ! diagonal element of htilde ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2) + double precision, intent(out) :: hthree + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2),i,j,ii,jj,ispin,jspin,m,mm + integer(bit_kind) :: key_i_core(Nint,2) + double precision :: direct_int, exchange_int + double precision :: sym_3_e_int_from_6_idx_tensor + double precision :: three_e_diag_parrallel_spin + + if(core_tc_op)then + do i = 1, Nint + key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1)) + key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2)) + enddo + call bitstring_to_list_ab(key_i_core,occ,Ne,Nint) + else + call bitstring_to_list_ab(key_i,occ,Ne,Nint) + endif + hthree = 0.d0 + + if(Ne(1)+Ne(2).ge.3)then +!! ! alpha/alpha/beta three-body + do i = 1, Ne(1) + ii = occ(i,1) + do j = i+1, Ne(1) + jj = occ(j,1) + do m = 1, Ne(2) + mm = occ(m,2) +! direct_int = three_body_ints_bi_ort(mm,jj,ii,mm,jj,ii) USES THE 6-IDX TENSOR +! exchange_int = three_body_ints_bi_ort(mm,jj,ii,mm,ii,jj) USES THE 6-IDX TENSOR + direct_int = three_e_3_idx_direct_bi_ort(mm,jj,ii) ! USES 3-IDX TENSOR + exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,ii) ! USES 3-IDX TENSOR + hthree += direct_int - exchange_int + enddo + enddo + enddo + + ! beta/beta/alpha three-body + do i = 1, Ne(2) + ii = occ(i,2) + do j = i+1, Ne(2) + jj = occ(j,2) + do m = 1, Ne(1) + mm = occ(m,1) + direct_int = three_e_3_idx_direct_bi_ort(mm,jj,ii) + exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,ii) + hthree += direct_int - exchange_int + enddo + enddo + enddo + + ! alpha/alpha/alpha three-body + do i = 1, Ne(1) + ii = occ(i,1) ! 1 + do j = i+1, Ne(1) + jj = occ(j,1) ! 2 + do m = j+1, Ne(1) + mm = occ(m,1) ! 3 +! ref = sym_3_e_int_from_6_idx_tensor(mm,jj,ii,mm,jj,ii) USES THE 6 IDX TENSOR + hthree += three_e_diag_parrallel_spin(mm,jj,ii) ! USES ONLY 3-IDX TENSORS + enddo + enddo + enddo + + ! beta/beta/beta three-body + do i = 1, Ne(2) + ii = occ(i,2) ! 1 + do j = i+1, Ne(2) + jj = occ(j,2) ! 2 + do m = j+1, Ne(2) + mm = occ(m,2) ! 3 +! ref = sym_3_e_int_from_6_idx_tensor(mm,jj,ii,mm,jj,ii) USES THE 6 IDX TENSOR + hthree += three_e_diag_parrallel_spin(mm,jj,ii) ! USES ONLY 3-IDX TENSORS + enddo + enddo + enddo + endif + +end + + +subroutine single_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree) + + BEGIN_DOC + ! for single excitation ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS + !! + !! WARNING !! + ! + ! Non hermitian !! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) + double precision, intent(out) :: hthree + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2),i,j,ii,jj,ispin,jspin,k,kk + integer :: degree,exc(0:2,2,2) + integer :: h1, p1, h2, p2, s1, s2 + double precision :: direct_int,phase,exchange_int,three_e_single_parrallel_spin + double precision :: sym_3_e_int_from_6_idx_tensor + integer :: other_spin(2) + integer(bit_kind) :: key_j_core(Nint,2),key_i_core(Nint,2) + + other_spin(1) = 2 + other_spin(2) = 1 + + + hthree = 0.d0 + call get_excitation_degree(key_i,key_j,degree,Nint) + if(degree.ne.1)then + return + endif + if(core_tc_op)then + do i = 1, Nint + key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1)) + key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2)) + key_j_core(i,1) = xor(key_j(i,1),core_bitmask(i,1)) + key_j_core(i,2) = xor(key_j(i,2),core_bitmask(i,2)) + enddo + call bitstring_to_list_ab(key_i_core, occ, Ne, Nint) + else + call bitstring_to_list_ab(key_i, occ, Ne, Nint) + endif + + call get_single_excitation(key_i, key_j, exc, phase, Nint) + call decode_exc(exc, 1, h1, p1, h2, p2, s1, s2) + + ! alpha/alpha/beta three-body +! print*,'IN SLAT RULES' + if(Ne(1)+Ne(2).ge.3)then + ! hole of spin s1 :: contribution from purely other spin + ispin = other_spin(s1) ! ispin is the other spin than s1 + do i = 1, Ne(ispin) ! i is the orbitals of the other spin than s1 + ii = occ(i,ispin) + do j = i+1, Ne(ispin) ! j has the same spin than s1 + jj = occ(j,ispin) + ! is == ispin in ::: s1 is is s1 is is s1 is is s1 is is + ! < h1 j i | p1 j i > - < h1 j i | p1 i j > + ! +! direct_int = three_body_ints_bi_ort(jj,ii,p1,jj,ii,h1) ! USES THE 6-IDX tensor +! exchange_int = three_body_ints_bi_ort(jj,ii,p1,ii,jj,h1) ! USES THE 6-IDX tensor + direct_int = three_e_4_idx_direct_bi_ort(jj,ii,p1,h1) + exchange_int = three_e_4_idx_exch23_bi_ort(jj,ii,p1,h1) + hthree += direct_int - exchange_int + enddo + enddo + + ! hole of spin s1 :: contribution from mixed other spin / same spin + do i = 1, Ne(ispin) ! other spin + ii = occ(i,ispin) ! other spin + do j = 1, Ne(s1) ! same spin + jj = occ(j,s1) ! same spin +! direct_int = three_body_ints_bi_ort(jj,ii,p1,jj,ii,h1) ! USES THE 6-IDX tensor +! exchange_int = three_body_ints_bi_ort(jj,ii,p1,h1,ii,jj) ! exchange the spin s1 :: 6-IDX tensor + direct_int = three_e_4_idx_direct_bi_ort(jj,ii,p1,h1) + exchange_int = three_e_4_idx_exch13_bi_ort(jj,ii,p1,h1) + ! < h1 j i | p1 j i > - < h1 j i | j p1 i > + hthree += direct_int - exchange_int +! print*,'h1,p1,ii,jj = ',h1,p1,ii,jj +! print*,direct_int, exchange_int + enddo + enddo +! + ! hole of spin s1 :: PURE SAME SPIN CONTRIBUTIONS !!! + do i = 1, Ne(s1) + ii = occ(i,s1) + do j = i+1, Ne(s1) + jj = occ(j,s1) +! ref = sym_3_e_int_from_6_idx_tensor(jj,ii,p1,jj,ii,h1) + hthree += three_e_single_parrallel_spin(jj,ii,p1,h1) ! USES THE 4-IDX TENSOR + enddo + enddo + endif + hthree *= phase + +end + +subroutine double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree) + + BEGIN_DOC + ! for double excitation ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS + !! + !! WARNING !! + ! + ! Non hermitian !! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) + double precision, intent(out) :: hthree + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2),i,j,ii,jj,ispin,jspin,m,mm + integer :: degree,exc(0:2,2,2) + integer :: h1, p1, h2, p2, s1, s2 + double precision :: phase + integer :: other_spin(2) + integer(bit_kind) :: key_i_core(Nint,2) + double precision :: direct_int,exchange_int,sym_3_e_int_from_6_idx_tensor + double precision :: three_e_double_parrallel_spin + + other_spin(1) = 2 + other_spin(2) = 1 + + call get_excitation_degree(key_i, key_j, degree, Nint) + + hthree = 0.d0 + + if(degree.ne.2)then + return + endif + + if(core_tc_op)then + do i = 1, Nint + key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1)) + key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2)) + enddo + call bitstring_to_list_ab(key_i_core, occ, Ne, Nint) + else + call bitstring_to_list_ab(key_i, occ, Ne, Nint) + endif + call get_double_excitation(key_i, key_j, exc, phase, Nint) + call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2) + + + if(Ne(1)+Ne(2).ge.3)then + if(s1==s2)then ! same spin excitation + ispin = other_spin(s1) +! print*,'htilde ij' + do m = 1, Ne(ispin) ! direct(other_spin) - exchange(s1) + mm = occ(m,ispin) +!! direct_int = three_body_ints_bi_ort(mm,p2,p1,mm,h2,h1) +!! exchange_int = three_body_ints_bi_ort(mm,p2,p1,mm,h1,h2) + direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1) + exchange_int = three_e_5_idx_exch12_bi_ort(mm,p2,h2,p1,h1) +! print*,direct_int,exchange_int + hthree += direct_int - exchange_int + enddo + do m = 1, Ne(s1) ! pure contribution from s1 + mm = occ(m,s1) + hthree += three_e_double_parrallel_spin(mm,p2,h2,p1,h1) + enddo + else ! different spin excitation + do m = 1, Ne(s1) + mm = occ(m,s1) ! + direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1) + exchange_int = three_e_5_idx_exch13_bi_ort(mm,p2,h2,p1,h1) + hthree += direct_int - exchange_int + enddo + do m = 1, Ne(s2) + mm = occ(m,s2) ! + direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1) + exchange_int = three_e_5_idx_exch23_bi_ort(mm,p2,h2,p1,h1) + hthree += direct_int - exchange_int + enddo + endif + endif + hthree *= phase + end diff --git a/src/tc_bi_ortho/symmetrized_3_e_int.irp.f b/src/tc_bi_ortho/symmetrized_3_e_int.irp.f new file mode 100644 index 00000000..e4f7ca93 --- /dev/null +++ b/src/tc_bi_ortho/symmetrized_3_e_int.irp.f @@ -0,0 +1,111 @@ +subroutine give_all_perm_for_three_e(n,l,k,m,j,i,idx_list,phase) + implicit none + BEGIN_DOC + ! returns all the list of permutting indices for the antimmetrization of + ! + ! (k^dagger l^dagger n^dagger m j i) when all indices have the same spins + ! + ! idx_list(:,i) == list of the 6 indices corresponding the permutation "i" + ! + ! phase(i) == phase of the permutation "i" + ! + ! there are in total 6 permutations with different indices + END_DOC + integer, intent(in) :: n,l,k,m,j,i + integer, intent(out) :: idx_list(6,6) + double precision :: phase(6) + integer :: list(6) + !!! CYCLIC PERMUTATIONS + phase(1:3) = 1.d0 + !!! IDENTITY PERMUTATION + list = (/n,l,k,m,j,i/) + idx_list(:,1) = list(:) + !!! FIRST CYCLIC PERMUTATION + list = (/n,l,k,j,i,m/) + idx_list(:,2) = list(:) + !!! FIRST CYCLIC PERMUTATION + list = (/n,l,k,i,m,j/) + idx_list(:,3) = list(:) + + !!! NON CYCLIC PERMUTATIONS + phase(1:3) = -1.d0 + !!! PARTICLE 1 is FIXED + list = (/n,l,k,j,m,i/) + idx_list(:,4) = list(:) + !!! PARTICLE 2 is FIXED + list = (/n,l,k,i,j,m/) + idx_list(:,5) = list(:) + !!! PARTICLE 3 is FIXED + list = (/n,l,k,m,i,j/) + idx_list(:,6) = list(:) + +end + +double precision function sym_3_e_int_from_6_idx_tensor(n,l,k,m,j,i) + implicit none + BEGIN_DOC + ! returns all good combinations of permutations of integrals with the good signs + ! + ! for a given (k^dagger l^dagger n^dagger m j i) when all indices have the same spins + END_DOC + integer, intent(in) :: n,l,k,m,j,i + sym_3_e_int_from_6_idx_tensor = three_body_ints_bi_ort(n,l,k,m,j,i) & ! direct + + three_body_ints_bi_ort(n,l,k,j,i,m) & ! 1st cyclic permutation + + three_body_ints_bi_ort(n,l,k,i,m,j) & ! 2nd cyclic permutation + - three_body_ints_bi_ort(n,l,k,j,m,i) & ! elec 1 is kept fixed + - three_body_ints_bi_ort(n,l,k,i,j,m) & ! elec 2 is kept fixed + - three_body_ints_bi_ort(n,l,k,m,i,j) ! elec 3 is kept fixed + +end + +double precision function direct_sym_3_e_int(n,l,k,m,j,i) + implicit none + BEGIN_DOC + ! returns all good combinations of permutations of integrals with the good signs + ! + ! for a given (k^dagger l^dagger n^dagger m j i) when all indices have the same spins + END_DOC + integer, intent(in) :: n,l,k,m,j,i + double precision :: integral + direct_sym_3_e_int = 0.d0 + call give_integrals_3_body_bi_ort(n,l,k,m,j,i,integral) ! direct + direct_sym_3_e_int += integral + call give_integrals_3_body_bi_ort(n,l,k,j,i,m,integral) ! 1st cyclic permutation + direct_sym_3_e_int += integral + call give_integrals_3_body_bi_ort(n,l,k,i,m,j,integral) ! 2nd cyclic permutation + direct_sym_3_e_int += integral + call give_integrals_3_body_bi_ort(n,l,k,j,m,i,integral) ! elec 1 is kept fixed + direct_sym_3_e_int += -integral + call give_integrals_3_body_bi_ort(n,l,k,i,j,m,integral) ! elec 2 is kept fixed + direct_sym_3_e_int += -integral + call give_integrals_3_body_bi_ort(n,l,k,m,i,j,integral) ! elec 3 is kept fixed + direct_sym_3_e_int += -integral + +end + +double precision function three_e_diag_parrallel_spin(m,j,i) + implicit none + integer, intent(in) :: i,j,m + three_e_diag_parrallel_spin = three_e_3_idx_direct_bi_ort(m,j,i) ! direct + three_e_diag_parrallel_spin += three_e_3_idx_cycle_1_bi_ort(m,j,i) + three_e_3_idx_cycle_2_bi_ort(m,j,i) & ! two cyclic permutations + - three_e_3_idx_exch23_bi_ort(m,j,i) - three_e_3_idx_exch13_bi_ort(m,j,i) & ! two first exchange + - three_e_3_idx_exch12_bi_ort(m,j,i) ! last exchange +end + +double precision function three_e_single_parrallel_spin(m,j,k,i) + implicit none + integer, intent(in) :: i,k,j,m + three_e_single_parrallel_spin = three_e_4_idx_direct_bi_ort(m,j,k,i) ! direct + three_e_single_parrallel_spin += three_e_4_idx_cycle_1_bi_ort(m,j,k,i) + three_e_4_idx_cycle_2_bi_ort(m,j,k,i) & ! two cyclic permutations + - three_e_4_idx_exch23_bi_ort(m,j,k,i) - three_e_4_idx_exch13_bi_ort(m,j,k,i) & ! two first exchange + - three_e_4_idx_exch12_bi_ort(m,j,k,i) ! last exchange +end + +double precision function three_e_double_parrallel_spin(m,l,j,k,i) + implicit none + integer, intent(in) :: i,k,j,m,l + three_e_double_parrallel_spin = three_e_5_idx_direct_bi_ort(m,l,j,k,i) ! direct + three_e_double_parrallel_spin += three_e_5_idx_cycle_1_bi_ort(m,l,j,k,i) + three_e_5_idx_cycle_2_bi_ort(m,l,j,k,i) & ! two cyclic permutations + - three_e_5_idx_exch23_bi_ort(m,l,j,k,i) - three_e_5_idx_exch13_bi_ort(m,l,j,k,i) & ! two first exchange + - three_e_5_idx_exch12_bi_ort(m,l,j,k,i) ! last exchange +end diff --git a/src/tc_bi_ortho/tc_bi_ortho.irp.f b/src/tc_bi_ortho/tc_bi_ortho.irp.f new file mode 100644 index 00000000..cfa24f3b --- /dev/null +++ b/src/tc_bi_ortho/tc_bi_ortho.irp.f @@ -0,0 +1,61 @@ +program tc_bi_ortho + implicit none + BEGIN_DOC +! TODO : Reads psi_det in the EZFIO folder and prints out the left- and right-eigenvectors together with the energy. Saves the left-right wave functions at the end. + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + call routine_diag +! call test +end + +subroutine test + implicit none + integer :: i,j + double precision :: hmono,htwoe,hthree,htot + use bitmasks + + print*,'test' +! call htilde_mu_mat_bi_ortho(psi_det(1,1,1), psi_det(1,1,2), N_int, hmono, htwoe, hthree, htot) + call double_htilde_mu_mat_bi_ortho(N_int,psi_det(1,1,1), psi_det(1,1,2), hmono, htwoe, htot) + print*,hmono, htwoe, htot + +end + +subroutine routine_diag + implicit none +! provide eigval_right_tc_bi_orth + provide overlap_bi_ortho +! provide htilde_matrix_elmt_bi_ortho + integer ::i,j + print*,'eigval_right_tc_bi_orth = ',eigval_right_tc_bi_orth(1) + print*,'e_tc_left_right = ',e_tc_left_right + print*,'e_tilde_bi_orth_00 = ',e_tilde_bi_orth_00 + print*,'e_pt2_tc_bi_orth = ',e_pt2_tc_bi_orth + print*,'e_pt2_tc_bi_orth_single = ',e_pt2_tc_bi_orth_single + print*,'e_pt2_tc_bi_orth_double = ',e_pt2_tc_bi_orth_double + print*,'***' + print*,'e_corr_bi_orth = ',e_corr_bi_orth + print*,'e_corr_bi_orth_proj = ',e_corr_bi_orth_proj + print*,'e_corr_single_bi_orth = ',e_corr_single_bi_orth + print*,'e_corr_double_bi_orth = ',e_corr_double_bi_orth + print*,'Left/right eigenvectors' + do i = 1,N_det + write(*,'(I5,X,(100(F12.7,X)))')i,leigvec_tc_bi_orth(i,1),reigvec_tc_bi_orth(i,1) + enddo + do j=1,N_states + do i=1,N_det + psi_l_coef_bi_ortho(i,j) = leigvec_tc_bi_orth(i,j) + psi_r_coef_bi_ortho(i,j) = reigvec_tc_bi_orth(i,j) + enddo + enddo + SOFT_TOUCH psi_l_coef_bi_ortho psi_r_coef_bi_ortho + call save_tc_bi_ortho_wavefunction +! call routine_save_left_right_bi_ortho +end + diff --git a/src/tc_bi_ortho/tc_bi_ortho_prop.irp.f b/src/tc_bi_ortho/tc_bi_ortho_prop.irp.f new file mode 100644 index 00000000..28f122ee --- /dev/null +++ b/src/tc_bi_ortho/tc_bi_ortho_prop.irp.f @@ -0,0 +1,24 @@ +program tc_bi_ortho_prop + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid +! call routine_diag + call test +end + +subroutine test + implicit none + integer :: i + print*,'TC Dipole components' + do i= 1, 3 + print*,tc_bi_ortho_dipole(i,1) + enddo +end diff --git a/src/tc_bi_ortho/tc_cisd_sc2.irp.f b/src/tc_bi_ortho/tc_cisd_sc2.irp.f new file mode 100644 index 00000000..0fb9f524 --- /dev/null +++ b/src/tc_bi_ortho/tc_cisd_sc2.irp.f @@ -0,0 +1,24 @@ +program tc_bi_ortho + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + call test +end + +subroutine test + implicit none +! double precision, allocatable :: dressing_dets(:),e_corr_dets(:) +! allocate(dressing_dets(N_det),e_corr_dets(N_det)) +! e_corr_dets = 0.d0 +! call get_cisd_sc2_dressing(psi_det,e_corr_dets,N_det,dressing_dets) + provide eigval_tc_cisd_sc2_bi_ortho +end diff --git a/src/tc_bi_ortho/tc_cisd_sc2_utils.irp.f b/src/tc_bi_ortho/tc_cisd_sc2_utils.irp.f new file mode 100644 index 00000000..406ee9e3 --- /dev/null +++ b/src/tc_bi_ortho/tc_cisd_sc2_utils.irp.f @@ -0,0 +1,110 @@ + BEGIN_PROVIDER [ double precision, reigvec_tc_cisd_sc2_bi_ortho, (N_det,N_states)] +&BEGIN_PROVIDER [ double precision, leigvec_tc_cisd_sc2_bi_ortho, (N_det,N_states)] +&BEGIN_PROVIDER [ double precision, eigval_tc_cisd_sc2_bi_ortho, (N_states)] + implicit none + integer :: it,n_real,degree,i + double precision :: e_before, e_current,thr, hmono,htwoe,hthree + double precision, allocatable :: e_corr_dets(:),h0j(:), h_sc2(:,:), dressing_dets(:) + double precision, allocatable :: leigvec_tc_bi_orth_tmp(:,:),reigvec_tc_bi_orth_tmp(:,:),eigval_right_tmp(:) + allocate(leigvec_tc_bi_orth_tmp(N_det,N_det),reigvec_tc_bi_orth_tmp(N_det,N_det),eigval_right_tmp(N_det)) + allocate(e_corr_dets(N_det),h0j(N_det),h_sc2(N_det,N_det),dressing_dets(N_det)) + do i = 1, N_det + call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int) + if(degree == 1 .or. degree == 2)then + call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,h0j(i)) + endif + enddo + do i = 1, N_det + e_corr_dets(i) = reigvec_tc_bi_orth(i,1) * h0j(i)/reigvec_tc_bi_orth(1,1) + enddo + print*,'Starting from ',eigval_right_tc_bi_orth(1) + + e_before = 0.d0 + e_current = 10.d0 + thr = 1.d-5 + it = 0 + dressing_dets = 0.d0 + do while (dabs(E_before-E_current).gt.thr) + it += 1 + E_before = E_current + h_sc2 = htilde_matrix_elmt_bi_ortho + call get_cisd_sc2_dressing(psi_det,e_corr_dets,N_det,dressing_dets) + do i = 1, N_det + print*,'dressing_dets(i) = ',dressing_dets(i) + h_sc2(i,i) += dressing_dets(i) + enddo + call non_hrmt_real_diag(N_det,h_sc2,& + leigvec_tc_bi_orth_tmp,reigvec_tc_bi_orth_tmp,& + n_real,eigval_right_tmp) + do i = 1, N_det + e_corr_dets(i) = reigvec_tc_bi_orth_tmp(i,1) * h0j(i)/reigvec_tc_bi_orth_tmp(1,1) + enddo + E_current = eigval_right_tmp(1) + print*,'it, E(SC)^2 = ',it,E_current + enddo + eigval_tc_cisd_sc2_bi_ortho(1:N_states) = eigval_right_tmp(1:N_states) + reigvec_tc_cisd_sc2_bi_ortho(1:N_det,1:N_states) = reigvec_tc_bi_orth_tmp(1:N_det,1:N_states) + leigvec_tc_cisd_sc2_bi_ortho(1:N_det,1:N_states) = leigvec_tc_bi_orth_tmp(1:N_det,1:N_states) + +END_PROVIDER + +subroutine get_cisd_sc2_dressing(dets,e_corr_dets,ndet,dressing_dets) + implicit none + use bitmasks + integer, intent(in) :: ndet + integer(bit_kind), intent(in) :: dets(N_int,2,ndet) + double precision, intent(in) :: e_corr_dets(ndet) + double precision, intent(out) :: dressing_dets(ndet) + integer, allocatable :: degree(:),hole(:,:),part(:,:),spin(:,:) + integer(bit_kind), allocatable :: hole_part(:,:,:) + integer :: i,j,k, exc(0:2,2,2),h1,p1,h2,p2,s1,s2 + integer(bit_kind) :: xorvec(2,N_int) + + double precision :: phase + dressing_dets = 0.d0 + allocate(degree(ndet),hole(2,ndet),part(2,ndet), spin(2,ndet),hole_part(N_int,2,ndet)) + do i = 2, ndet + call get_excitation_degree(HF_bitmask,dets(1,1,i),degree(i),N_int) + do j = 1, N_int + hole_part(j,1,i) = xor( HF_bitmask(j,1), dets(j,1,i)) + hole_part(j,2,i) = xor( HF_bitmask(j,2), dets(j,2,i)) + enddo + if(degree(i) == 1)then + call get_single_excitation(HF_bitmask,psi_det(1,1,i),exc,phase,N_int) + else if(degree(i) == 2)then + call get_double_excitation(HF_bitmask,psi_det(1,1,i),exc,phase,N_int) + endif + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + hole(1,i) = h1 + hole(2,i) = h2 + part(1,i) = p1 + part(2,i) = p2 + spin(1,i) = s1 + spin(2,i) = s2 + enddo + + integer :: same + if(elec_alpha_num+elec_beta_num<3)return + do i = 2, ndet + do j = i+1, ndet + same = 0 + if(degree(i) == degree(j) .and. degree(i)==1)cycle + do k = 1, N_int + xorvec(k,1) = iand(hole_part(k,1,i),hole_part(k,1,j)) + xorvec(k,2) = iand(hole_part(k,2,i),hole_part(k,2,j)) + same += popcnt(xorvec(k,1)) + popcnt(xorvec(k,2)) + enddo +! print*,'i,j',i,j +! call debug_det(dets(1,1,i),N_int) +! call debug_det(hole_part(1,1,i),N_int) +! call debug_det(dets(1,1,j),N_int) +! call debug_det(hole_part(1,1,j),N_int) +! print*,'same = ',same + if(same.eq.0)then + dressing_dets(i) += e_corr_dets(j) + dressing_dets(j) += e_corr_dets(i) + endif + enddo + enddo + +end diff --git a/src/tc_bi_ortho/tc_h_eigvectors.irp.f b/src/tc_bi_ortho/tc_h_eigvectors.irp.f new file mode 100644 index 00000000..651088be --- /dev/null +++ b/src/tc_bi_ortho/tc_h_eigvectors.irp.f @@ -0,0 +1,179 @@ + use bitmasks + + BEGIN_PROVIDER [ integer, index_HF_psi_det] + implicit none + integer :: i,degree + do i = 1, N_det + call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int) + if(degree == 0)then + index_HF_psi_det = i + exit + endif + enddo + END_PROVIDER + + + + BEGIN_PROVIDER [double precision, eigval_right_tc_bi_orth, (N_states)] +&BEGIN_PROVIDER [double precision, eigval_left_tc_bi_orth, (N_states)] +&BEGIN_PROVIDER [double precision, reigvec_tc_bi_orth, (N_det,N_states)] +&BEGIN_PROVIDER [double precision, leigvec_tc_bi_orth, (N_det,N_states)] +&BEGIN_PROVIDER [double precision, norm_ground_left_right_bi_orth ] + + BEGIN_DOC + ! eigenvalues, right and left eigenvectors of the transcorrelated Hamiltonian on the BI-ORTHO basis + END_DOC + + implicit none + integer :: i, idx_dress, j, istate + logical :: converged, dagger + integer :: n_real_tc_bi_orth_eigval_right,igood_r,igood_l + double precision, allocatable :: reigvec_tc_bi_orth_tmp(:,:),leigvec_tc_bi_orth_tmp(:,:),eigval_right_tmp(:) + + PROVIDE N_det N_int + + if(n_det.le.N_det_max_full)then + allocate(reigvec_tc_bi_orth_tmp(N_det,N_det),leigvec_tc_bi_orth_tmp(N_det,N_det),eigval_right_tmp(N_det)) + call non_hrmt_real_diag(N_det,htilde_matrix_elmt_bi_ortho,& + leigvec_tc_bi_orth_tmp,reigvec_tc_bi_orth_tmp,& + n_real_tc_bi_orth_eigval_right,eigval_right_tmp) + double precision, allocatable :: coef_hf_r(:),coef_hf_l(:) + integer, allocatable :: iorder(:) + allocate(coef_hf_r(N_det),coef_hf_l(N_det),iorder(N_det)) + do i = 1,N_det + iorder(i) = i + coef_hf_r(i) = -dabs(reigvec_tc_bi_orth_tmp(index_HF_psi_det,i)) + enddo + call dsort(coef_hf_r,iorder,N_det) + igood_r = iorder(1) + print*,'igood_r, coef_hf_r = ',igood_r,coef_hf_r(1) + do i = 1,N_det + iorder(i) = i + coef_hf_l(i) = -dabs(leigvec_tc_bi_orth_tmp(index_HF_psi_det,i)) + enddo + call dsort(coef_hf_l,iorder,N_det) + igood_l = iorder(1) + print*,'igood_l, coef_hf_l = ',igood_l,coef_hf_l(1) + + if(igood_r.ne.igood_l.and.igood_r.ne.1)then + print *,'' + print *,'Warning, the left and right eigenvectors are "not the same" ' + print *,'Warning, the ground state is not dominated by HF...' + print *,'State with largest RIGHT coefficient of HF ',igood_r + print *,'coef of HF in RIGHT eigenvector = ',reigvec_tc_bi_orth_tmp(index_HF_psi_det,igood_r) + print *,'State with largest LEFT coefficient of HF ',igood_l + print *,'coef of HF in LEFT eigenvector = ',leigvec_tc_bi_orth_tmp(index_HF_psi_det,igood_l) + endif + if(state_following_tc)then + print *,'Following the states with the largest coef on HF' + print *,'igood_r,igood_l',igood_r,igood_l + i= igood_r + eigval_right_tc_bi_orth(1) = eigval_right_tmp(i) + do j = 1, N_det + reigvec_tc_bi_orth(j,1) = reigvec_tc_bi_orth_tmp(j,i) +! print*,reigvec_tc_bi_orth(j,1) + enddo + i= igood_l + eigval_left_tc_bi_orth(1) = eigval_right_tmp(i) + do j = 1, N_det + leigvec_tc_bi_orth(j,1) = leigvec_tc_bi_orth_tmp(j,i) + enddo + else + do i = 1, N_states + eigval_right_tc_bi_orth(i) = eigval_right_tmp(i) + eigval_left_tc_bi_orth(i) = eigval_right_tmp(i) + do j = 1, N_det + reigvec_tc_bi_orth(j,i) = reigvec_tc_bi_orth_tmp(j,i) + leigvec_tc_bi_orth(j,i) = leigvec_tc_bi_orth_tmp(j,i) + enddo + enddo + endif + else + double precision, allocatable :: H_jj(:),vec_tmp(:,:) + external htc_bi_ortho_calc_tdav + external htcdag_bi_ortho_calc_tdav + allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag)) + do i = 1, N_det + call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i)) + enddo + !!!! Preparing the left-eigenvector + print*,'Computing the left-eigenvector ' + vec_tmp = 0.d0 + do istate = 1, N_states + vec_tmp(:,istate) = psi_l_coef_bi_ortho(:,istate) + enddo + do istate = N_states+1, n_states_diag + vec_tmp(istate,istate) = 1.d0 + enddo + call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_left_tc_bi_orth, N_det, n_states, n_states_diag, converged, htcdag_bi_ortho_calc_tdav) + do istate = 1, N_states + leigvec_tc_bi_orth(:,istate) = vec_tmp(:,istate) + enddo + + print*,'Computing the right-eigenvector ' + !!!! Preparing the right-eigenvector + vec_tmp = 0.d0 + do istate = 1, N_states + vec_tmp(:,istate) = psi_r_coef_bi_ortho(:,istate) + enddo + do istate = N_states+1, n_states_diag + vec_tmp(istate,istate) = 1.d0 + enddo + call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_right_tc_bi_orth, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav) + do istate = 1, N_states + reigvec_tc_bi_orth(:,istate) = vec_tmp(:,istate) + enddo + + deallocate(H_jj) + endif + call bi_normalize(leigvec_tc_bi_orth,reigvec_tc_bi_orth,N_det,N_det,N_states) + print*,'leigvec_tc_bi_orth(1,1),reigvec_tc_bi_orth(1,1) = ',leigvec_tc_bi_orth(1,1),reigvec_tc_bi_orth(1,1) + norm_ground_left_right_bi_orth = 0.d0 + do j = 1, N_det + norm_ground_left_right_bi_orth += leigvec_tc_bi_orth(j,1) * reigvec_tc_bi_orth(j,1) + enddo + print*,'norm l/r = ',norm_ground_left_right_bi_orth + +END_PROVIDER + + + +subroutine bi_normalize(u_l,u_r,n,ld,nstates) + !!!! Normalization of the scalar product of the left/right eigenvectors + double precision, intent(inout) :: u_l(ld,nstates), u_r(ld,nstates) + integer, intent(in) :: n,ld,nstates + integer :: i + double precision :: accu, tmp + do i = 1, nstates + !!!! Normalization of right eigenvectors |Phi> + accu = 0.d0 + do j = 1, n + accu += u_r(j,i) * u_r(j,i) + enddo + accu = 1.d0/dsqrt(accu) + print*,'accu_r = ',accu + do j = 1, n + u_r(j,i) *= accu + enddo + tmp = u_r(1,i) / dabs(u_r(1,i)) + do j = 1, n + u_r(j,i) *= tmp + enddo + !!!! Adaptation of the norm of the left eigenvector such that = 1 + accu = 0.d0 + do j = 1, n + accu += u_l(j,i) * u_r(j,i) +! print*,j, u_l(j,i) , u_r(j,i) + enddo + if(accu.gt.0.d0)then + accu = 1.d0/dsqrt(accu) + else + accu = 1.d0/dsqrt(-accu) + endif + tmp = (u_l(1,i) * u_r(1,i) )/dabs(u_l(1,i) * u_r(1,i)) + do j = 1, n + u_l(j,i) *= accu * tmp + u_r(j,i) *= accu + enddo + enddo +end diff --git a/src/tc_bi_ortho/tc_hmat.irp.f b/src/tc_bi_ortho/tc_hmat.irp.f new file mode 100644 index 00000000..bf1388e5 --- /dev/null +++ b/src/tc_bi_ortho/tc_hmat.irp.f @@ -0,0 +1,41 @@ + + BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho, (N_det,N_det)] + + BEGIN_DOC + ! htilde_matrix_elmt_bi_ortho(j,i) = + ! + ! WARNING !!!!!!!!! IT IS NOT HERMITIAN !!!!!!!!! + END_DOC + + implicit none + integer :: i, j + double precision :: hmono,htwoe,hthree,htot + + PROVIDE N_int + !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,hmono, htwoe, hthree, htot) & + !$OMP SHARED (N_det, psi_det, N_int,htilde_matrix_elmt_bi_ortho) + do i = 1, N_det + do j = 1, N_det + ! < J | Htilde | I > + call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) + htilde_matrix_elmt_bi_ortho(j,i) = htot + enddo + enddo + !$OMP END PARALLEL DO +! print*,'htilde_matrix_elmt_bi_ortho = ' +! do i = 1, min(100,N_det) +! write(*,'(100(F16.10,X))')htilde_matrix_elmt_bi_ortho(1:min(100,N_det),i) +! enddo + + +END_PROVIDER + + BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho_tranp, (N_det,N_det)] + implicit none + integer ::i,j + do i = 1, N_det + do j = 1, N_det + htilde_matrix_elmt_bi_ortho_tranp(j,i) = htilde_matrix_elmt_bi_ortho(i,j) + enddo + enddo +END_PROVIDER diff --git a/src/tc_bi_ortho/tc_prop.irp.f b/src/tc_bi_ortho/tc_prop.irp.f new file mode 100644 index 00000000..6db8e80e --- /dev/null +++ b/src/tc_bi_ortho/tc_prop.irp.f @@ -0,0 +1,268 @@ + +BEGIN_PROVIDER [ double precision, tc_transition_matrix, (mo_num, mo_num,N_states,N_states) ] + implicit none + BEGIN_DOC + ! tc_transition_matrix(p,h,istate,jstate) = + ! + ! where are the left/right eigenvectors on a bi-ortho basis + END_DOC + integer :: i,j,istate,jstate,m,n,p,h + double precision :: phase + integer, allocatable :: occ(:,:) + integer :: n_occ_ab(2),degree,exc(0:2,2,2) + allocate(occ(N_int*bit_kind_size,2)) + tc_transition_matrix = 0.d0 + do istate = 1, N_states + do jstate = 1, N_states + do i = 1, N_det + do j = 1, N_det + call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) + if(degree.gt.1)then + cycle + else if (degree == 0)then + call bitstring_to_list_ab(psi_det(1,1,i), occ, n_occ_ab, N_int) + do p = 1, n_occ_ab(1) ! browsing the alpha electrons + m = occ(p,1) + tc_transition_matrix(m,m,istate,jstate)+= psi_l_coef_bi_ortho(i,istate) * psi_r_coef_bi_ortho(j,jstate) + enddo + do p = 1, n_occ_ab(2) ! browsing the beta electrons + m = occ(p,1) + tc_transition_matrix(m,m,istate,jstate)+= psi_l_coef_bi_ortho(i,istate) * psi_r_coef_bi_ortho(j,jstate) + enddo + else + call get_single_excitation(psi_det(1,1,j),psi_det(1,1,i),exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Single alpha + h = exc(1,1,1) ! hole in psi_det(1,1,j) + p = exc(1,2,1) ! particle in psi_det(1,1,j) + else + ! Single beta + h = exc(1,1,2) ! hole in psi_det(1,1,j) + p = exc(1,2,2) ! particle in psi_det(1,1,j) + endif + tc_transition_matrix(p,h,istate,jstate)+= phase * psi_l_coef_bi_ortho(i,istate) * psi_r_coef_bi_ortho(j,jstate) + endif + enddo + enddo + enddo + enddo + END_PROVIDER + + + BEGIN_PROVIDER [ double precision, natorb_tc_reigvec_mo, (mo_num, mo_num)] + &BEGIN_PROVIDER [ double precision, natorb_tc_leigvec_mo, (mo_num, mo_num)] + &BEGIN_PROVIDER [ double precision, natorb_tc_eigval, (mo_num)] + implicit none + BEGIN_DOC + ! natorb_tc_reigvec_mo : RIGHT eigenvectors of the ground state transition matrix (equivalent of natural orbitals) + ! natorb_tc_leigvec_mo : LEFT eigenvectors of the ground state transition matrix (equivalent of natural orbitals) + ! natorb_tc_eigval : eigenvalues of the ground state transition matrix (equivalent of the occupation numbers). WARNINING :: can be negative !! + END_DOC + double precision, allocatable :: dm_tmp(:,:) + integer :: i,j,k,n_real + allocate( dm_tmp(mo_num,mo_num)) + dm_tmp(:,:) = -tc_transition_matrix(:,:,1,1) + print*,'dm_tmp' + do i = 1, mo_num + write(*,'(100(F16.10,X))')-dm_tmp(:,i) + enddo +! call non_hrmt_diag_split_degen( mo_num, dm_tmp& + call non_hrmt_fock_mat( mo_num, dm_tmp& +! call non_hrmt_bieig( mo_num, dm_tmp& + , natorb_tc_leigvec_mo, natorb_tc_reigvec_mo& + , n_real, natorb_tc_eigval ) + double precision :: accu + accu = 0.d0 + do i = 1, n_real + print*,'natorb_tc_eigval(i) = ',-natorb_tc_eigval(i) + accu += -natorb_tc_eigval(i) + enddo + print*,'accu = ',accu + dm_tmp = 0.d0 + do i = 1, n_real + accu = 0.d0 + do k = 1, mo_num + accu += natorb_tc_reigvec_mo(k,i) * natorb_tc_leigvec_mo(k,i) + enddo + accu = 1.d0/dsqrt(dabs(accu)) + natorb_tc_reigvec_mo(:,i) *= accu + natorb_tc_leigvec_mo(:,i) *= accu + do j = 1, n_real + do k = 1, mo_num + dm_tmp(j,i) += natorb_tc_reigvec_mo(k,i) * natorb_tc_leigvec_mo(k,j) + enddo + enddo + enddo + double precision :: accu_d, accu_nd + accu_d = 0.d0 + accu_nd = 0.d0 + do i = 1, mo_num + accu_d += dm_tmp(i,i) + ! write(*,'(100(F16.10,X))')dm_tmp(:,i) + do j = 1, mo_num + if(i==j)cycle + accu_nd += dabs(dm_tmp(j,i)) + enddo + enddo + print*,'Trace of the overlap between TC natural orbitals ',accu_d + print*,'L1 norm of extra diagonal elements of overlap matrix ',accu_nd + + + END_PROVIDER + + BEGIN_PROVIDER [ double precision, fock_diag_sorted_r_natorb, (mo_num, mo_num)] + &BEGIN_PROVIDER [ double precision, fock_diag_sorted_l_natorb, (mo_num, mo_num)] + &BEGIN_PROVIDER [ double precision, fock_diag_sorted_v_natorb, (mo_num)] + implicit none + integer ::i,j,k + print*,'Diagonal elements of the Fock matrix before ' + do i = 1, mo_num + write(*,*)i,Fock_matrix_tc_mo_tot(i,i) + enddo + double precision, allocatable :: fock_diag(:) + allocate(fock_diag(mo_num)) + fock_diag = 0.d0 + do i = 1, mo_num + fock_diag(i) = 0.d0 + do j = 1, mo_num + do k = 1, mo_num + fock_diag(i) += natorb_tc_leigvec_mo(k,i) * Fock_matrix_tc_mo_tot(k,j) * natorb_tc_reigvec_mo(j,i) + enddo + enddo + enddo + integer, allocatable :: iorder(:) + allocate(iorder(mo_num)) + do i = 1, mo_num + iorder(i) = i + enddo + call dsort(fock_diag,iorder,mo_num) + print*,'Diagonal elements of the Fock matrix after ' + do i = 1, mo_num + write(*,*)i,fock_diag(i) + enddo + do i = 1, mo_num + fock_diag_sorted_v_natorb(i) = natorb_tc_eigval(iorder(i)) + do j = 1, mo_num + fock_diag_sorted_r_natorb(j,i) = natorb_tc_reigvec_mo(j,iorder(i)) + fock_diag_sorted_l_natorb(j,i) = natorb_tc_leigvec_mo(j,iorder(i)) + enddo + enddo + + END_PROVIDER + + + + BEGIN_PROVIDER [ double precision, natorb_tc_reigvec_ao, (ao_num, mo_num)] + &BEGIN_PROVIDER [ double precision, natorb_tc_leigvec_ao, (ao_num, mo_num)] + &BEGIN_PROVIDER [ double precision, overlap_natorb_tc_eigvec_ao, (mo_num, mo_num) ] + + BEGIN_DOC + ! EIGENVECTORS OF FOCK MATRIX ON THE AO BASIS and their OVERLAP + ! + ! THE OVERLAP SHOULD BE THE SAME AS overlap_natorb_tc_eigvec_mo + END_DOC + + implicit none + integer :: i, j, k, q, p + double precision :: accu, accu_d + double precision, allocatable :: tmp(:,:) + + + ! ! MO_R x R + call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0 & + , mo_r_coef, size(mo_r_coef, 1) & + , fock_diag_sorted_r_natorb, size(fock_diag_sorted_r_natorb, 1) & + , 0.d0, natorb_tc_reigvec_ao, size(natorb_tc_reigvec_ao, 1) ) + ! + ! MO_L x L + call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0 & + , mo_l_coef, size(mo_l_coef, 1) & + , fock_diag_sorted_l_natorb, size(fock_diag_sorted_l_natorb, 1) & + , 0.d0, natorb_tc_leigvec_ao, size(natorb_tc_leigvec_ao, 1) ) + + + allocate( tmp(mo_num,ao_num) ) + + ! tmp <-- L.T x S_ao + call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 & + , natorb_tc_leigvec_ao, size(natorb_tc_leigvec_ao, 1), ao_overlap, size(ao_overlap, 1) & + , 0.d0, tmp, size(tmp, 1) ) + + ! S <-- tmp x R + call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0 & + , tmp, size(tmp, 1), natorb_tc_reigvec_ao, size(natorb_tc_reigvec_ao, 1) & + , 0.d0, overlap_natorb_tc_eigvec_ao, size(overlap_natorb_tc_eigvec_ao, 1) ) + + deallocate( tmp ) + + ! --- + double precision :: norm + do i = 1, mo_num + norm = 1.d0/dsqrt(dabs(overlap_natorb_tc_eigvec_ao(i,i))) + do j = 1, mo_num + natorb_tc_reigvec_ao(j,i) *= norm + natorb_tc_leigvec_ao(j,i) *= norm + enddo + enddo + + allocate( tmp(mo_num,ao_num) ) + + ! tmp <-- L.T x S_ao + call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 & + , natorb_tc_leigvec_ao, size(natorb_tc_leigvec_ao, 1), ao_overlap, size(ao_overlap, 1) & + , 0.d0, tmp, size(tmp, 1) ) + + ! S <-- tmp x R + call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0 & + , tmp, size(tmp, 1), natorb_tc_reigvec_ao, size(natorb_tc_reigvec_ao, 1) & + , 0.d0, overlap_natorb_tc_eigvec_ao, size(overlap_natorb_tc_eigvec_ao, 1) ) + + + + deallocate( tmp ) + + accu_d = 0.d0 + accu = 0.d0 + do i = 1, mo_num + accu_d += overlap_natorb_tc_eigvec_ao(i,i) + do j = 1, mo_num + if(i==j)cycle + accu += dabs(overlap_natorb_tc_eigvec_ao(j,i)) + enddo + enddo + print*,'Trace of the overlap_natorb_tc_eigvec_ao = ',accu_d + print*,'mo_num = ',mo_num + print*,'L1 norm of extra diagonal elements of overlap matrix ',accu + accu = accu / dble(mo_num**2) + + END_PROVIDER + + BEGIN_PROVIDER [double precision, tc_bi_ortho_dipole, (3,N_states)] + implicit none + integer :: i,j,istate,m + double precision :: nuclei_part(3) + tc_bi_ortho_dipole = 0.d0 + do istate = 1, N_states + do i = 1, mo_num + do j = 1, mo_num + tc_bi_ortho_dipole(1,istate) += -(tc_transition_matrix(j,i,istate,istate)) * mo_bi_orth_bipole_x(j,i) + tc_bi_ortho_dipole(2,istate) += -(tc_transition_matrix(j,i,istate,istate)) * mo_bi_orth_bipole_y(j,i) + tc_bi_ortho_dipole(3,istate) += -(tc_transition_matrix(j,i,istate,istate)) * mo_bi_orth_bipole_z(j,i) + enddo + enddo + enddo + + nuclei_part = 0.d0 + do m = 1, 3 + do i = 1,nucl_num + nuclei_part(m) += nucl_charge(i) * nucl_coord(i,m) + enddo + enddo +! + do istate = 1, N_states + do m = 1, 3 + tc_bi_ortho_dipole(m,istate) += nuclei_part(m) + enddo + enddo + END_PROVIDER + diff --git a/src/tc_bi_ortho/test_normal_order.irp.f b/src/tc_bi_ortho/test_normal_order.irp.f new file mode 100644 index 00000000..8bdc57ee --- /dev/null +++ b/src/tc_bi_ortho/test_normal_order.irp.f @@ -0,0 +1,73 @@ +program test_normal_order + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + call test +end + +subroutine test + implicit none + use bitmasks ! you need to include the bitmasks_module.f90 features + integer :: h1,h2,p1,p2,s1,s2,i_ok,degree,Ne(2) + integer :: exc(0:2,2,2) + integer(bit_kind), allocatable :: det_i(:,:) + double precision :: hmono,htwoe,hthree,htilde_ij,accu,phase,normal + integer, allocatable :: occ(:,:) + allocate( occ(N_int*bit_kind_size,2) ) + call bitstring_to_list_ab(ref_bitmask, occ, Ne, N_int) + allocate(det_i(N_int,2)) + s1 = 1 + s2 = 2 + accu = 0.d0 + do h1 = 1, elec_beta_num + do p1 = elec_beta_num+1, mo_num + do h2 = 1, elec_beta_num + do p2 = elec_beta_num+1, mo_num + det_i = ref_bitmask + call do_single_excitation(det_i,h1,p1,s1,i_ok) + call do_single_excitation(det_i,h2,p2,s2,i_ok) + call htilde_mu_mat_bi_ortho(det_i,HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) + call get_excitation_degree(ref_bitmask,det_i,degree,N_int) + call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int) + hthree *= phase + normal = normal_two_body_bi_orth_ab(p2,h2,p1,h1) + accu += dabs(hthree-normal) + enddo + enddo + enddo + enddo + print*,'accu opposite spin = ',accu + + s1 = 2 + s2 = 2 + accu = 0.d0 + do h1 = 1, elec_beta_num + do p1 = elec_beta_num+1, mo_num + do h2 = h1+1, elec_beta_num + do p2 = elec_beta_num+1, mo_num + det_i = ref_bitmask + call do_single_excitation(det_i,h1,p1,s1,i_ok) + call do_single_excitation(det_i,h2,p2,s2,i_ok) + if(i_ok.ne.1)cycle + call htilde_mu_mat_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) + call get_excitation_degree(ref_bitmask,det_i,degree,N_int) + call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int) + hthree *= phase + normal = normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1) + accu += dabs(hthree-normal) + enddo + enddo + enddo + enddo + print*,'accu same spin = ',accu +end + + diff --git a/src/tc_bi_ortho/test_tc_bi_ortho.irp.f b/src/tc_bi_ortho/test_tc_bi_ortho.irp.f new file mode 100644 index 00000000..2d71b6b2 --- /dev/null +++ b/src/tc_bi_ortho/test_tc_bi_ortho.irp.f @@ -0,0 +1,131 @@ +program tc_bi_ortho + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + ! call routine_2 + call test_rout +end + +subroutine test_rout + implicit none + integer :: i,j,ii,jj + use bitmasks ! you need to include the bitmasks_module.f90 features + integer(bit_kind), allocatable :: det_i(:,:) + allocate(det_i(N_int,2)) + det_i(:,:)= psi_det(:,:,1) + call debug_det(det_i,N_int) + integer, allocatable :: occ(:,:) + integer :: n_occ_ab(2) + allocate(occ(N_int*bit_kind_size,2)) + call bitstring_to_list_ab(det_i, occ, n_occ_ab, N_int) + double precision :: hmono, htwoe, htot + call diag_htilde_mu_mat_bi_ortho(N_int, det_i, hmono, htwoe, htot) + print*,'hmono, htwoe, htot' + print*, hmono, htwoe, htot + print*,'alpha electrons orbital occupancy' + do i = 1, n_occ_ab(1) ! browsing the alpha electrons + j = occ(i,1) + print*,j,mo_bi_ortho_tc_one_e(j,j) + enddo + print*,'beta electrons orbital occupancy' + do i = 1, n_occ_ab(2) ! browsing the beta electrons + j = occ(i,2) + print*,j,mo_bi_ortho_tc_one_e(j,j) + enddo + print*,'alpha beta' + do i = 1, n_occ_ab(1) + ii = occ(i,1) + do j = 1, n_occ_ab(2) + jj = occ(j,2) + print*,ii,jj,mo_bi_ortho_tc_two_e(jj,ii,jj,ii) + enddo + enddo + print*,'alpha alpha' + do i = 1, n_occ_ab(1) + ii = occ(i,1) + do j = 1, n_occ_ab(1) + jj = occ(j,1) + print*,ii,jj,mo_bi_ortho_tc_two_e(jj,ii,jj,ii), mo_bi_ortho_tc_two_e(ii,jj,jj,ii) + enddo + enddo + + print*,'beta beta' + do i = 1, n_occ_ab(2) + ii = occ(i,2) + do j = 1, n_occ_ab(2) + jj = occ(j,2) + print*,ii,jj,mo_bi_ortho_tc_two_e(jj,ii,jj,ii), mo_bi_ortho_tc_two_e(ii,jj,jj,ii) + enddo + enddo + + +end + +subroutine routine_2 + implicit none + integer :: i + double precision :: bi_ortho_mo_ints + print*,'H matrix' + do i = 1, N_det + write(*,'(1000(F16.5,X))')htilde_matrix_elmt_bi_ortho(:,i) + enddo + i = 1 + double precision :: phase + integer :: degree,h1, p1, h2, p2, s1, s2, exc(0:2,2,2) + call get_excitation_degree(ref_bitmask, psi_det(1,1,i), degree, N_int) + if(degree==2)then + call get_double_excitation(ref_bitmask, psi_det(1,1,i), exc, phase, N_int) + call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2) + print*,'h1,h2,p1,p2' + print*, h1,h2,p1,p2 + print*,mo_bi_ortho_tc_two_e(p1,p2,h1,h2),mo_bi_ortho_tc_two_e(h1,h2,p1,p2) + endif + + + print*,'coef' + do i = 1, ao_num + print*,i,mo_l_coef(i,8),mo_r_coef(i,8) + enddo +! print*,'mdlqfmlqgmqglj' +! print*,'mo_bi_ortho_tc_two_e()',mo_bi_ortho_tc_two_e(2,2,3,3) +! print*,'bi_ortho_mo_ints ',bi_ortho_mo_ints(2,2,3,3) + print*,'Overlap' + do i = 1, mo_num + write(*,'(100(F16.10,X))')overlap_bi_ortho(:,i) + enddo + +end + +subroutine routine + implicit none + double precision :: hmono,htwoe,hthree,htot + integer(bit_kind), allocatable :: key1(:,:) + integer(bit_kind), allocatable :: key2(:,:) + allocate(key1(N_int,2),key2(N_int,2)) + use bitmasks + key1 = ref_bitmask + call htilde_mu_mat_bi_ortho(key1,key1, N_int, hmono,htwoe,hthree,htot) + key2 = key1 + integer :: h,p,i_ok + h = 1 + p = 8 + call do_single_excitation(key2,h,p,1,i_ok) + call debug_det(key2,N_int) + call htilde_mu_mat_bi_ortho(key2,key1, N_int, hmono,htwoe,hthree,htot) +! print*,'fock_matrix_tc_mo_alpha(p,h) = ',fock_matrix_tc_mo_alpha(p,h) + print*,'htot = ',htot + print*,'hmono = ',hmono + print*,'htwoe = ',htwoe + double precision :: bi_ortho_mo_ints + print*,'bi_ortho_mo_ints(1,p,1,h)',bi_ortho_mo_ints(1,p,1,h) + +end diff --git a/src/tc_bi_ortho/test_tc_fock.irp.f b/src/tc_bi_ortho/test_tc_fock.irp.f new file mode 100644 index 00000000..badc40b6 --- /dev/null +++ b/src/tc_bi_ortho/test_tc_fock.irp.f @@ -0,0 +1,169 @@ +program test_tc_fock + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + read_wf = .True. + touch read_wf + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + !call routine_1 + !call routine_2 + call routine_3() + +end + +! --- + +subroutine routine_0 + implicit none + use bitmasks ! you need to include the bitmasks_module.f90 features + integer :: i,a,j,m,i_ok + integer :: exc(0:2,2,2),h1,p1,s1,h2,p2,s2,degree + + integer(bit_kind), allocatable :: det_i(:,:) + double precision :: hmono,htwoe,hthree,htilde_ij,phase + double precision :: same, op, tot, accu + allocate(det_i(N_int,2)) + s1 = 1 + accu = 0.d0 + do i = 1, elec_alpha_num ! occupied + do a = elec_alpha_num+1, mo_num ! virtual + det_i = ref_bitmask + call do_single_excitation(det_i,i,a,s1,i_ok) + if(i_ok == -1)then + print*,'PB !!' + print*,i,a + stop + endif +! call debug_det(det_i,N_int) + call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int) + call htilde_mu_mat_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) + op = fock_3_mat_a_op_sh_bi_orth(a,i) + same = fock_3_mat_a_sa_sh_bi_orth(a,i) +! same = 0.d0 + tot = same + op + if(dabs(tot - phase*hthree).gt.1.d-10)then + print*,'------' + print*,i,a,phase + print*,'hthree = ',phase*hthree + print*,'fock = ',tot + print*,'same,op= ',same,op + print*,dabs(tot - phase*hthree) + stop + endif + accu += dabs(tot - phase*hthree) + enddo + enddo + print*,'accu = ',accu + +end subroutine routine_0 + +! --- + +subroutine routine_1 + + implicit none + integer :: i, a + double precision :: accu + + accu = 0.d0 + do i = 1, mo_num + do a = 1, mo_num + accu += dabs( fock_3_mat_a_op_sh_bi_orth_old(a,i) - fock_3_mat_a_op_sh_bi_orth(a,i) ) + !if(dabs( fock_3_mat_a_op_sh_bi_orth_old(a,i) - fock_3_mat_a_op_sh_bi_orth(a,i) ) .gt. 1.d-10)then + print*, i, a + print*, dabs( fock_3_mat_a_op_sh_bi_orth_old(a,i) - fock_3_mat_a_op_sh_bi_orth(a,i) ) & + , fock_3_mat_a_op_sh_bi_orth_old(a,i), fock_3_mat_a_op_sh_bi_orth(a,i) + !endif + enddo + enddo + + print *, 'accu = ', accu + +end subroutine routine_1 + +! --- + +subroutine routine_2 + + implicit none + integer :: i, a + double precision :: accu + + accu = 0.d0 + do i = 1, mo_num + do a = 1, mo_num + accu += dabs( fock_3_mat_a_sa_sh_bi_orth_old(a,i) - fock_3_mat_a_sa_sh_bi_orth(a,i) ) + !if(dabs( fock_3_mat_a_sa_sh_bi_orth_old(a,i) - fock_3_mat_a_sa_sh_bi_orth(a,i) ) .gt. 1.d-10)then + print*, i, a + print*, dabs( fock_3_mat_a_sa_sh_bi_orth_old(a,i) - fock_3_mat_a_sa_sh_bi_orth(a,i) ) & + , fock_3_mat_a_sa_sh_bi_orth_old(a,i), fock_3_mat_a_sa_sh_bi_orth(a,i) + !endif + enddo + enddo + + print *, 'accu = ', accu + +end subroutine routine_2 + +! --- + +subroutine routine_3() + + use bitmasks ! you need to include the bitmasks_module.f90 features + + implicit none + integer :: i, a, i_ok, s1 + double precision :: hmono, htwoe, hthree, htilde_ij + double precision :: err_ai, err_tot + integer(bit_kind), allocatable :: det_i(:,:) + + allocate(det_i(N_int,2)) + + err_tot = 0.d0 + + s1 = 1 + + det_i = ref_bitmask + call debug_det(det_i, N_int) + print*, ' HF det' + call debug_det(det_i, N_int) + + do i = 1, elec_alpha_num ! occupied + do a = elec_alpha_num+1, mo_num ! virtual + + + det_i = ref_bitmask + call do_single_excitation(det_i, i, a, s1, i_ok) + if(i_ok == -1) then + print*, 'PB !!' + print*, i, a + stop + endif + !print*, ' excited det' + !call debug_det(det_i, N_int) + + call htilde_mu_mat_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij) + err_ai = dabs(htilde_ij) + if(err_ai .gt. 1d-7) then + print*, ' warning on', i, a + print*, hmono, htwoe, htilde_ij + endif + err_tot += err_ai + + write(22, *) htilde_ij + enddo + enddo + + print *, ' err_tot = ', err_tot + + deallocate(det_i) + +end subroutine routine_3 + +! --- From ad0203c959cea4d7fe5c5fa49af4081f9ae95ca8 Mon Sep 17 00:00:00 2001 From: eginer Date: Wed, 5 Oct 2022 17:29:26 +0200 Subject: [PATCH 78/80] added tc_keywords and three_body_ints --- src/some_mu_of_r/EZFIO.cfg | 59 +++ src/some_mu_of_r/NEED | 2 + src/some_mu_of_r/mu_grad_n.irp.f | 144 +++++++ src/some_mu_of_r/mu_lda.irp.f | 208 +++++++++ src/some_mu_of_r/mu_of_r_ints.irp.f | 150 +++++++ src/some_mu_of_r/mu_rsc.irp.f | 162 +++++++ src/some_mu_of_r/mu_test.irp.f | 119 +++++ src/some_mu_of_r/some_mu_of_r.irp.f | 7 + src/tc_keywords/EZFIO.cfg | 107 +++++ src/tc_keywords/NEED | 1 + src/tc_keywords/tc_keywords.irp.f | 7 + src/three_body_ints/EZFIO.cfg | 20 + src/three_body_ints/NEED | 1 + src/three_body_ints/io_6_index_tensor.irp.f | 63 +++ src/three_body_ints/semi_num_ints_mo.irp.f | 207 +++++++++ src/three_body_ints/three_body_tensor.irp.f | 106 +++++ src/three_body_ints/three_e_3_idx.irp.f | 338 +++++++++++++++ src/three_body_ints/three_e_4_idx.irp.f | 347 +++++++++++++++ src/three_body_ints/three_e_5_idx.irp.f | 453 ++++++++++++++++++++ 19 files changed, 2501 insertions(+) create mode 100644 src/some_mu_of_r/EZFIO.cfg create mode 100644 src/some_mu_of_r/NEED create mode 100644 src/some_mu_of_r/mu_grad_n.irp.f create mode 100644 src/some_mu_of_r/mu_lda.irp.f create mode 100644 src/some_mu_of_r/mu_of_r_ints.irp.f create mode 100644 src/some_mu_of_r/mu_rsc.irp.f create mode 100644 src/some_mu_of_r/mu_test.irp.f create mode 100644 src/some_mu_of_r/some_mu_of_r.irp.f create mode 100644 src/tc_keywords/EZFIO.cfg create mode 100644 src/tc_keywords/NEED create mode 100644 src/tc_keywords/tc_keywords.irp.f create mode 100644 src/three_body_ints/EZFIO.cfg create mode 100644 src/three_body_ints/NEED create mode 100644 src/three_body_ints/io_6_index_tensor.irp.f create mode 100644 src/three_body_ints/semi_num_ints_mo.irp.f create mode 100644 src/three_body_ints/three_body_tensor.irp.f create mode 100644 src/three_body_ints/three_e_3_idx.irp.f create mode 100644 src/three_body_ints/three_e_4_idx.irp.f create mode 100644 src/three_body_ints/three_e_5_idx.irp.f diff --git a/src/some_mu_of_r/EZFIO.cfg b/src/some_mu_of_r/EZFIO.cfg new file mode 100644 index 00000000..d63ea874 --- /dev/null +++ b/src/some_mu_of_r/EZFIO.cfg @@ -0,0 +1,59 @@ +[constant_mu] +type: logical +doc: If |true|, the mu(r) is constant and set to mu_erf +interface: ezfio,provider,ocaml +default: True + +[mu_of_r_tc_ints] +type: character*(32) +doc: type of mu(r) for the TC Hamiltonian : can be [ basis| rsc | lda ] +interface: ezfio, provider, ocaml +default: lda + +[damped_mu_of_r] +type: logical +doc: If |true|, the mu(r) is damped by an error function to take a minimal value of mu_erf +interface: ezfio,provider,ocaml +default: False + +[mu_of_r_min] +type: double precision +doc: minimal value of mu(r) +interface: ezfio,provider,ocaml +default: 0.001 +ezfio_name: mu_of_r_min + + +[ampl_cos] +type: double precision +doc: amplitude of the cos for mu_test(r) +interface: ezfio,provider,ocaml +default: 0.1 +ezfio_name: ampl_cos + + +[omega_cos] +type: double precision +doc: pulsation of the cos for mu_test(r) +interface: ezfio,provider,ocaml +default: 0.1 +ezfio_name: omega_cos + +[dexp_gauss] +type: double precision +doc: pulsation of the cos for mu_test(r) +interface: ezfio,provider,ocaml +default: 10.0 +ezfio_name: dexp_gauss + +[mu_test_choice] +type: character*(32) +doc: type of mu(r) for the TC Hamiltonian : can be [ cos | gauss ] +interface: ezfio, provider, ocaml +default: cos + +[rescaled_on_top_mu] +type: logical +doc: If |true|, the mu(r) is rescaled by the ratio of ontop and density at HF level +interface: ezfio,provider,ocaml +default: False diff --git a/src/some_mu_of_r/NEED b/src/some_mu_of_r/NEED new file mode 100644 index 00000000..9e928543 --- /dev/null +++ b/src/some_mu_of_r/NEED @@ -0,0 +1,2 @@ +dft_utils_func +ao_two_e_erf_ints diff --git a/src/some_mu_of_r/mu_grad_n.irp.f b/src/some_mu_of_r/mu_grad_n.irp.f new file mode 100644 index 00000000..a0180b2b --- /dev/null +++ b/src/some_mu_of_r/mu_grad_n.irp.f @@ -0,0 +1,144 @@ + +BEGIN_PROVIDER [double precision, mu_of_r_extra_grid_grad_n , (n_points_extra_final_grid,N_states) ] + implicit none + integer :: ipoint,i,m + double precision :: weight, rho_a_hf, rho_b_hf, g0,rho_hf + double precision :: rs,grad_n + double precision :: g0_UEG_mu_inf + double precision :: cst_rs,alpha_rs + double precision :: elec_a,elec_b + double precision :: r(3),dx,mu_grad_n,mu_tmp,mu,damped_mu, mu_min + dx = 1.d-5 + elec_a = 0.d0 + elec_b = 0.d0 + mu_min = mu_erf + do ipoint = 1, n_points_extra_final_grid + weight = final_weight_at_r_vector_extra(ipoint) + r(:) = final_grid_points_extra(:,ipoint) + mu_tmp = mu_grad_n(r) + if(damped_mu_of_r)then + mu = damped_mu(mu_tmp,mu_min) + else + mu = max(mu_tmp,mu_of_r_min) + endif + mu_of_r_extra_grid_grad_n(ipoint,1) = mu + elec_a += rho_a_hf * weight + elec_b += rho_b_hf * weight + enddo +END_PROVIDER + + BEGIN_PROVIDER [double precision, average_mu_grad_n ] +&BEGIN_PROVIDER [double precision, mu_of_r_grad_n , (n_points_final_grid,N_states) ] +&BEGIN_PROVIDER [double precision, grad_mu_of_r_grad_n , (3,n_points_final_grid,N_states) ] + implicit none + integer :: ipoint,i,m + double precision :: weight, rho_a_hf, rho_b_hf, g0,rho_hf + double precision :: rs,grad_n + double precision :: g0_UEG_mu_inf + double precision :: cst_rs,alpha_rs + double precision :: elec_a,elec_b,grad_mu(3),mu_grad_n + double precision :: mu, r(3),dx,damped_mu,mu_min,mu_tmp + mu_min = mu_erf + dx = 1.d-5 + average_mu_grad_n = 0.d0 + elec_a = 0.d0 + elec_b = 0.d0 + do ipoint = 1, n_points_final_grid + weight = final_weight_at_r_vector(ipoint) + r(:) = final_grid_points(:,ipoint) + mu_tmp = mu_grad_n(r) + if(damped_mu_of_r)then + mu = damped_mu(mu_tmp,mu_min) + mu = max(mu_tmp,mu_of_r_min) + else + mu = mu_tmp + endif + + mu_of_r_grad_n(ipoint,1) = mu + + average_mu_grad_n += mu_of_r_grad_n(ipoint,1) * weight * rho_hf + elec_a += rho_a_hf * weight + elec_b += rho_b_hf * weight + + r(:) = final_grid_points(:,ipoint) + if(damped_mu_of_r)then + call get_grad_damped_mu_grad_n(r,dx,mu_min,grad_mu) + else + call get_grad_mu_grad_n(r,dx,grad_mu) + if(mu_tmp.lt.mu)then + grad_mu = 0.d0 + endif + endif + grad_mu_of_r_grad_n(:,ipoint,1) = grad_mu(:) + + enddo + average_mu_grad_n = average_mu_grad_n / dble(elec_a+ elec_b) + +END_PROVIDER + + + +double precision function mu_grad_n(r) + implicit none + double precision, intent(in) :: r(3) + double precision, allocatable :: aos_array(:),grad_aos_array(:,:) + double precision, allocatable :: dm_a(:),dm_b(:), dm_a_grad(:,:), dm_b_grad(:,:) + double precision :: grad_n, rho + integer :: m + allocate(dm_a(N_states),dm_b(N_states), dm_a_grad(3,N_states), dm_b_grad(3,N_states)) + allocate(aos_array(ao_num),grad_aos_array(3,ao_num)) + call density_and_grad_alpha_beta_and_all_aos_and_grad_aos_at_r(r,dm_a,dm_b, dm_a_grad, dm_b_grad, aos_array, grad_aos_array) + grad_n = 0.D0 + do m = 1, 3 + grad_n += dm_a_grad(m,1)**2 + dm_b_grad(m,1)**2 + 2.d0 * dm_a_grad(m,1)*dm_b_grad(m,1) + enddo + rho = dm_a(1) + dm_b(1) + grad_n = dsqrt(grad_n) + if(dabs(rho).gt.1.d-20)then + mu_grad_n = grad_n/(4.d0 * rho) + else + mu_grad_n = 0.d0 + endif +end + +double precision function mu_grad_n_damped(r,mu_min) + implicit none + double precision, intent(in) :: r(3), mu_min + double precision :: mu_grad_n, damped_mu, mu_tmp + mu_tmp = mu_grad_n(r) + mu_grad_n_damped = damped_mu(mu_tmp,mu_min) +end + +subroutine get_grad_mu_grad_n(r,dx,grad_mu) + implicit none + double precision, intent(in) :: r(3),dx + double precision, intent(out):: grad_mu(3) + double precision :: r1(3),mu_plus,mu_minus,mu_grad_n + integer :: m + do m = 1, 3 ! compute grad mu + r1 = r + r1(m) += dx + mu_plus = mu_grad_n(r1) + r1 = r + r1(m) -= dx + mu_minus = mu_grad_n(r1) + grad_mu(m) = (mu_plus - mu_minus)/(2.d0 * dx) + enddo +end + +subroutine get_grad_damped_mu_grad_n(r,dx,mu_min,grad_mu) + implicit none + double precision, intent(in) :: r(3),dx,mu_min + double precision, intent(out):: grad_mu(3) + double precision :: r1(3),mu_plus,mu_minus,mu_grad_n_damped + integer :: m + do m = 1, 3 ! compute grad mu + r1 = r + r1(m) += dx + mu_plus = mu_grad_n_damped(r1,mu_min) + r1 = r + r1(m) -= dx + mu_minus = mu_grad_n_damped(r1,mu_min) + grad_mu(m) = (mu_plus - mu_minus)/(2.d0 * dx) + enddo +end diff --git a/src/some_mu_of_r/mu_lda.irp.f b/src/some_mu_of_r/mu_lda.irp.f new file mode 100644 index 00000000..b05f8e0b --- /dev/null +++ b/src/some_mu_of_r/mu_lda.irp.f @@ -0,0 +1,208 @@ + + BEGIN_PROVIDER [double precision, mu_of_r_extra_grid_lda , (n_points_extra_final_grid,N_states) ] + implicit none + integer :: ipoint,i,m + double precision :: weight, rho_a_hf, rho_b_hf, g0,rho_hf + double precision :: rs,grad_n + double precision :: g0_UEG_mu_inf + double precision :: cst_rs,alpha_rs + double precision :: elec_a,elec_b + double precision :: r(3),dx,mu_lda,mu_tmp,mu,damped_mu, mu_min + dx = 1.d-5 + elec_a = 0.d0 + elec_b = 0.d0 + mu_min = mu_erf + do ipoint = 1, n_points_extra_final_grid + weight = final_weight_at_r_vector_extra(ipoint) + r(:) = final_grid_points_extra(:,ipoint) + call dm_dft_alpha_beta_at_r(r,rho_a_hf,rho_b_hf) + mu_tmp = mu_lda(rho_a_hf,rho_b_hf) + if(damped_mu_of_r)then + mu = damped_mu(mu_tmp,mu_min) + else + mu = max(mu_tmp,mu_of_r_min) + endif + if(rescaled_on_top_mu)then + mu = mu * dsqrt(0.25d0 * (rho_a_hf+rho_b_hf)**2/(rho_a_hf*rho_b_hf+1.d-12)) + else + mu=mu + endif + mu_of_r_extra_grid_lda(ipoint,1) = mu + + elec_a += rho_a_hf * weight + elec_b += rho_b_hf * weight + + enddo + +END_PROVIDER + + + + + BEGIN_PROVIDER [double precision, average_mu_lda ] +&BEGIN_PROVIDER [double precision, mu_of_r_lda , (n_points_final_grid,N_states) ] +&BEGIN_PROVIDER [double precision, grad_mu_of_r_lda , (3,n_points_final_grid,N_states) ] + implicit none + integer :: ipoint,i,m + double precision :: weight, rho_a_hf, rho_b_hf, g0,rho_hf + double precision :: rs,grad_n + double precision :: g0_UEG_mu_inf + double precision :: cst_rs,alpha_rs + double precision :: elec_a,elec_b,grad_mu(3),mu_lda + double precision :: mu, r(3),dx,damped_mu,mu_min,mu_tmp + mu_min = mu_erf + dx = 1.d-5 + average_mu_lda = 0.d0 + elec_a = 0.d0 + elec_b = 0.d0 + do ipoint = 1, n_points_final_grid + weight = final_weight_at_r_vector(ipoint) + rho_a_hf = one_e_dm_and_grad_alpha_in_r(4,ipoint,1) + rho_b_hf = one_e_dm_and_grad_beta_in_r(4,ipoint,1) + rho_hf = rho_a_hf + rho_b_hf + mu_tmp = mu_lda(rho_a_hf,rho_b_hf) + if(damped_mu_of_r)then + mu = damped_mu(mu_tmp,mu_min) + mu = max(mu_tmp,mu_of_r_min) + else + mu = mu_tmp + endif + if(rescaled_on_top_mu)then + mu = mu * dsqrt(0.25d0 * (rho_a_hf+rho_b_hf)**2/(rho_a_hf*rho_b_hf+1.d-12)) + else + mu=mu + endif + + mu_of_r_lda(ipoint,1) = mu + + average_mu_lda += mu_of_r_lda(ipoint,1) * weight * rho_hf + elec_a += rho_a_hf * weight + elec_b += rho_b_hf * weight + + r(:) = final_grid_points(:,ipoint) + if(damped_mu_of_r)then + call get_grad_damped_mu_lda(r,dx,mu_min,grad_mu) + else + call get_grad_mu_lda(r,dx,grad_mu) + if(mu_tmp.lt.mu)then + grad_mu = 0.d0 + endif + endif + grad_mu_of_r_lda(:,ipoint,1) = grad_mu(:) + + enddo + average_mu_lda = average_mu_lda / dble(elec_a+ elec_b) + +END_PROVIDER + + +double precision function mu_lda(rho_a,rho_b) + implicit none + double precision, intent(in) :: rho_a,rho_b + include 'constants.include.F' + double precision :: g0,g0_UEG_mu_inf + g0 = g0_UEG_mu_inf(rho_a,rho_b) + mu_lda = - 1.d0 / (dlog(2.d0 * g0) * sqpi) +end + +double precision function damped_mu(mu,mu_min) + implicit none + double precision, intent(in) :: mu, mu_min + damped_mu = mu_min * (1.d0 - derf(mu)) + derf(mu)*mu +end + +double precision function mu_lda_damped(rho_a_hf,rho_b_hf,mu_min) + implicit none + double precision, intent(in) :: rho_b_hf,rho_a_hf,mu_min + double precision :: mu_lda,mu,damped_mu + mu = mu_lda(rho_a_hf,rho_b_hf) + mu_lda_damped = damped_mu(mu,mu_min) +end + +subroutine get_grad_mu_lda(r,dx,grad_mu) + implicit none + double precision, intent(in) :: r(3),dx + double precision, intent(out):: grad_mu(3) + double precision :: r1(3),rho_a_hf,rho_b_hf,mu_plus,mu_minus,mu_lda + integer :: m + do m = 1, 3 ! compute grad mu + r1 = r + r1(m) += dx + call dm_dft_alpha_beta_at_r(r1,rho_a_hf,rho_b_hf) + mu_plus = mu_lda(rho_a_hf,rho_b_hf) + r1 = r + r1(m) -= dx + call dm_dft_alpha_beta_at_r(r1,rho_a_hf,rho_b_hf) + mu_minus = mu_lda(rho_a_hf,rho_b_hf) + grad_mu(m) = (mu_plus - mu_minus)/(2.d0 * dx) + enddo +end + +subroutine get_grad_damped_mu_lda(r,dx,mu_min,grad_mu) + implicit none + double precision, intent(in) :: r(3),dx,mu_min + double precision, intent(out):: grad_mu(3) + double precision :: r1(3),rho_a_hf,rho_b_hf,mu_plus,mu_minus,mu_lda_damped + integer :: m + do m = 1, 3 ! compute grad mu + r1 = r + r1(m) += dx + call dm_dft_alpha_beta_at_r(r1,rho_a_hf,rho_b_hf) + mu_plus = mu_lda_damped(rho_a_hf,rho_b_hf,mu_min) + r1 = r + r1(m) -= dx + call dm_dft_alpha_beta_at_r(r1,rho_a_hf,rho_b_hf) + mu_minus = mu_lda_damped(rho_a_hf,rho_b_hf,mu_min) + grad_mu(m) = (mu_plus - mu_minus)/(2.d0 * dx) + enddo +end + +double precision function grad_mu_lda_comp(r,dx,mu_min,m) + implicit none + double precision, intent(in) :: r(3),dx,mu_min + integer, intent(in) :: m + double precision :: r1(3),rho_a_hf,rho_b_hf,mu_plus,mu_minus,mu_lda_damped + r1 = r + r1(m) += dx + call dm_dft_alpha_beta_at_r(r1,rho_a_hf,rho_b_hf) + mu_plus = mu_lda_damped(rho_a_hf,rho_b_hf,mu_min) + r1 = r + r1(m) -= dx + call dm_dft_alpha_beta_at_r(r1,rho_a_hf,rho_b_hf) + mu_minus = mu_lda_damped(rho_a_hf,rho_b_hf,mu_min) + grad_mu_lda_comp = (mu_plus - mu_minus)/(2.d0 * dx) +end + +subroutine get_lapl_mu_lda(r,dx,mu_min,lapl_mu) + implicit none + double precision, intent(in) :: r(3),dx,mu_min + double precision, intent(out):: lapl_mu(3) + double precision :: r1(3),rho_a_hf,rho_b_hf,mu_plus,mu_minus,mu_lda_damped,mu + integer :: m + do m = 1, 3 + r1 = r + call dm_dft_alpha_beta_at_r(r1,rho_a_hf,rho_b_hf) + mu = mu_lda_damped(rho_a_hf,rho_b_hf,mu_min) + + r1 = r + r1(m) += 2.d0 * dx + call dm_dft_alpha_beta_at_r(r1,rho_a_hf,rho_b_hf) + mu_plus = mu_lda_damped(rho_a_hf,rho_b_hf,mu_min) + + r1 = r + r1(m) -= 2.d0 * dx + call dm_dft_alpha_beta_at_r(r1,rho_a_hf,rho_b_hf) + mu_minus = mu_lda_damped(rho_a_hf,rho_b_hf,mu_min) + + lapl_mu(m) = (mu_plus + mu_minus - 2.d0 * mu)/(4.d0 * dx * dx) + enddo + lapl_mu = 0.d0 +end + +BEGIN_PROVIDER [ double precision, average_mu_rs_c_lda] + implicit none + average_mu_rs_c_lda = 0.5d0 * (average_mu_rs_c + average_mu_lda) +END_PROVIDER + + + diff --git a/src/some_mu_of_r/mu_of_r_ints.irp.f b/src/some_mu_of_r/mu_of_r_ints.irp.f new file mode 100644 index 00000000..6452fec7 --- /dev/null +++ b/src/some_mu_of_r/mu_of_r_ints.irp.f @@ -0,0 +1,150 @@ + + BEGIN_PROVIDER [double precision, average_mu_of_r_for_ints, (N_states) ] +&BEGIN_PROVIDER [double precision, average_grad_mu_of_r, (N_states) ] +&BEGIN_PROVIDER [double precision, av_grad_inv_mu_mu_of_r, (N_states) ] +&BEGIN_PROVIDER [double precision, inv_2_mu_of_r_for_ints, (n_points_final_grid,N_states) ] +&BEGIN_PROVIDER [double precision, mu_of_r_for_ints, (n_points_final_grid,N_states) ] +&BEGIN_PROVIDER [double precision, inv_4_mu_of_r_for_ints, (n_points_final_grid,N_states) ] +&BEGIN_PROVIDER [double precision, grad_mu_of_r_for_ints, (3,n_points_final_grid,N_states) ] +&BEGIN_PROVIDER [double precision, grad_mu_of_r_transp_for_ints, (n_points_final_grid,N_states,3) ] +&BEGIN_PROVIDER [double precision, grad_sq_mu_of_r_for_ints, (n_points_final_grid,N_states) ] + implicit none + BEGIN_DOC + ! + ! mu(r) and its gradient for evaluation f integrals for the TC hamiltonian + END_DOC + integer :: ipoint,istate,mm + double precision :: wall0,wall1,mu_max + mu_max = 1.d-4 + print*,'providing mu_of_r ...' + call wall_time(wall0) + +! if(.not.constant_mu)then +! do istate = 1, N_states +! do ipoint = 1, n_points_final_grid +! if(mu_of_r_tc_ints.EQ."basis")then +! mu_of_r_for_ints(ipoint,istate) = mu_of_r_basis_hf(ipoint) +! grad_mu_of_r_for_ints(:,ipoint,istate) = grad_mu_of_r_basis_hf(:,ipoint) +! if(mu_of_r_tc_ints.EQ."rsc")then +! mu_of_r_for_ints(ipoint,istate) = mu_of_r_rs_c(ipoint,istate) +! grad_mu_of_r_for_ints(:,ipoint,istate) = grad_mu_of_r_rs_c(:,ipoint,istate) +! else if(mu_of_r_tc_ints.EQ."lda")then +! mu_of_r_for_ints(ipoint,istate) = mu_of_r_lda(ipoint,istate) +! grad_mu_of_r_for_ints(:,ipoint,istate) = grad_mu_of_r_lda(:,ipoint,istate) +! else if(mu_of_r_tc_ints.EQ."rsc_lda")then +! mu_of_r_for_ints(ipoint,istate) = 0.5d0 * (mu_of_r_lda(ipoint,istate) + mu_of_r_rs_c(ipoint,istate)) +! grad_mu_of_r_for_ints(:,ipoint,istate) = 0.5d0 * (grad_mu_of_r_lda(:,ipoint,istate) + grad_mu_of_r_rs_c(:,ipoint,istate)) +! else if(mu_of_r_tc_ints.EQ."grad_n")then +! mu_of_r_for_ints(ipoint,istate) = mu_of_r_grad_n(ipoint,istate) +! grad_mu_of_r_for_ints(:,ipoint,istate) = grad_mu_of_r_grad_n(:,ipoint,istate) +! else if(mu_of_r_tc_ints.EQ."mu_test")then +! mu_of_r_for_ints(ipoint,istate) = mu_of_r_test_func(ipoint,istate) +! grad_mu_of_r_for_ints(:,ipoint,istate) = grad_mu_of_r_test_func(:,ipoint,istate) +! else +! print*,'you requested the following mu_of_r_tc_ints' +! print*,mu_of_r_tc_ints +! print*,'which does not correspond to any of the options for such keyword' +! stop +! endif +! enddo +! enddo +! else + do istate = 1, N_states + do ipoint = 1, n_points_final_grid + mu_of_r_for_ints(ipoint,istate) = mu_erf + grad_mu_of_r_for_ints(:,ipoint,istate) = 0.d0 + grad_sq_mu_of_r_for_ints(ipoint,istate) = 0.d0 + enddo + enddo +! endif +! do istate = 1, N_states +! do ipoint = 1, n_points_final_grid +! mu_of_r_for_ints(ipoint,istate) = max(mu_of_r_for_ints(ipoint,istate),mu_max) +! inv_2_mu_of_r_for_ints(ipoint,istate) = 1.d0/(mu_of_r_for_ints(ipoint,istate))**2 +! inv_4_mu_of_r_for_ints(ipoint,istate) = 1.d0/(mu_of_r_for_ints(ipoint,istate))**4 +! do mm = 1, 3 +! grad_mu_of_r_transp_for_ints(ipoint,istate,mm) = grad_mu_of_r_for_ints(mm,ipoint,istate) +! enddo +! +! grad_sq_mu_of_r_for_ints(ipoint,istate) = 0.d0 +! do mm = 1, 3 +! grad_sq_mu_of_r_for_ints(ipoint,istate) += grad_mu_of_r_for_ints(mm,ipoint,istate)**2.d0 +! enddo +! enddo +! enddo + + double precision :: elec_tot,dm,weight,grad_mu_sq + average_grad_mu_of_r = 0.d0 + average_mu_of_r_for_ints = 0.d0 + av_grad_inv_mu_mu_of_r = 0.d0 +! do istate = 1, N_states +! elec_tot = 0.d0 +! do ipoint = 1, n_points_final_grid +! dm = one_e_dm_and_grad_alpha_in_r(4,ipoint,istate) + one_e_dm_and_grad_beta_in_r(4,ipoint,istate) +! weight = final_weight_at_r_vector_extra(ipoint) +! average_grad_mu_of_r(istate) += dsqrt(grad_sq_mu_of_r_for_ints(ipoint,istate)) * dm * weight +! average_mu_of_r_for_ints(istate) += mu_of_r_for_ints(ipoint,istate) * dm * weight +! av_grad_inv_mu_mu_of_r(istate) += mu_of_r_for_ints(ipoint,istate)**(-2) * dsqrt(grad_sq_mu_of_r_for_ints(ipoint,istate)) * dm * weight +! elec_tot += dm * weight +! enddo +! average_mu_of_r_for_ints(istate) = average_mu_of_r_for_ints(istate) / elec_tot +! average_grad_mu_of_r(istate) = average_grad_mu_of_r(istate) / elec_tot +! av_grad_inv_mu_mu_of_r(istate) = av_grad_inv_mu_mu_of_r(istate)/elec_tot +! enddo + + call wall_time(wall1) + print*,'Time to provide mu_of_r_for_ints = ',wall1-wall0 + END_PROVIDER + + + BEGIN_PROVIDER [double precision, mu_of_r_extra_grid_for_ints, (n_points_extra_final_grid,N_states) ] + implicit none + BEGIN_DOC + ! + ! mu(r) and its gradient for evaluation f integrals for the TC hamiltonian + END_DOC + integer :: ipoint,istate,mm,mu_tmp + double precision :: wall0,wall1,mu_max + mu_max = 1.d-4 + print*,'providing mu_of_r_extra_grid ...' + call wall_time(wall0) + +! if(.not.constant_mu)then + +! do istate = 1, N_states +! do ipoint = 1, n_points_extra_final_grid +! if(mu_of_r_tc_ints.EQ."basis")then +! mu_of_r_extra_grid_for_ints(ipoint,istate) = mu_of_r_extra_grid_basis_hf(ipoint) +! if(mu_of_r_tc_ints.EQ."rsc")then +! mu_of_r_extra_grid_for_ints(ipoint,istate) = mu_of_r_extra_grid_rs_c(ipoint,istate) +! else if(mu_of_r_tc_ints.EQ."lda")then +! mu_of_r_extra_grid_for_ints(ipoint,istate) = mu_of_r_extra_grid_lda(ipoint,istate) +! else if(mu_of_r_tc_ints.EQ."rsc_lda")then +! mu_of_r_extra_grid_for_ints(ipoint,istate) = 0.5d0 * (mu_of_r_extra_grid_lda(ipoint,istate) + mu_of_r_extra_grid_rs_c(ipoint,istate)) +! else if(mu_of_r_tc_ints.EQ."grad_n")then +! mu_of_r_extra_grid_for_ints(ipoint,istate) = mu_of_r_extra_grid_grad_n(ipoint,istate) +! else if(mu_of_r_tc_ints.EQ."mu_test")then +! mu_of_r_extra_grid_for_ints(ipoint,istate) = mu_of_r_extra_grid_test_func(ipoint,istate) +! else +! print*,'you requested the following mu_of_r_extra_grid_for_ints' +! print*,mu_of_r_tc_ints +! print*,'which does not correspond to any of the options for such keyword' +! stop +! endif +! mu_of_r_extra_grid_for_ints(ipoint,istate) = max(mu_of_r_extra_grid_for_ints(ipoint,istate),mu_max) +! enddo +! enddo +! else + do istate = 1, N_states + do ipoint = 1, n_points_extra_final_grid + mu_of_r_extra_grid_for_ints(ipoint,istate) = mu_erf + enddo + enddo +! endif + + + call wall_time(wall1) + print*,'Time to provide mu_of_r_extra_grid_for_ints = ',wall1-wall0 + END_PROVIDER + + diff --git a/src/some_mu_of_r/mu_rsc.irp.f b/src/some_mu_of_r/mu_rsc.irp.f new file mode 100644 index 00000000..47292ced --- /dev/null +++ b/src/some_mu_of_r/mu_rsc.irp.f @@ -0,0 +1,162 @@ + + BEGIN_PROVIDER [double precision, average_mu_rs_c ] +&BEGIN_PROVIDER [double precision, mu_of_r_rs_c, (n_points_final_grid,N_states) ] +&BEGIN_PROVIDER [double precision, grad_mu_of_r_rs_c, (3,n_points_final_grid,N_states) ] + implicit none + integer :: ipoint,i,m + include 'constants.include.F' + double precision :: weight, rho_a_hf, rho_b_hf, rho_hf, mu_rs_c,r(3) + average_mu_rs_c = 0.d0 + double precision :: elec_a,elec_b,grad_mu(3) + double precision :: dx,mu_lda, mu_tmp,mu_min,mu,damped_mu + dx = 1.d-5 + elec_a = 0.d0 + elec_b = 0.d0 + mu_min = mu_erf + do ipoint = 1, n_points_final_grid + weight = final_weight_at_r_vector(ipoint) + r(:) = final_grid_points(:,ipoint) + rho_a_hf = one_e_dm_and_grad_alpha_in_r(4,ipoint,1) + rho_b_hf = one_e_dm_and_grad_beta_in_r(4,ipoint,1) + rho_hf = rho_a_hf + rho_b_hf + rho_hf = max(rho_hf,1.D-10) + mu_tmp = mu_rs_c(rho_hf) + if(damped_mu_of_r)then + mu = damped_mu(mu_tmp,mu_min) + mu = max(mu_tmp,mu_of_r_min) + else + mu = mu_tmp + endif + if(rescaled_on_top_mu)then + mu = mu *dsqrt(0.25d0 * (rho_hf+rho_hf)**2/(rho_a_hf*rho_b_hf+1.d-12)) + else + mu=mu + endif + mu_of_r_rs_c(ipoint,1) = mu + average_mu_rs_c += mu_of_r_rs_c(ipoint,1) * rho_hf * weight + elec_a += rho_a_hf * weight + elec_b += rho_b_hf * weight + + if(damped_mu_of_r)then + call get_grad_damped_mu_rsc(r,mu_min,dx,grad_mu) + else + call get_grad_mu_rsc(r,dx,grad_mu) + endif + grad_mu_of_r_rs_c(:,ipoint,1) = grad_mu(:) + + enddo + average_mu_rs_c = average_mu_rs_c / dble(elec_a+ elec_b) + +END_PROVIDER + + + +!double precision function mu_rs_c(rho) +! implicit none +! double precision, intent(in) :: rho +! include 'constants.include.F' +! double precision :: cst_rs,alpha_rs,rs +! cst_rs = (4.d0 * dacos(-1.d0)/3.d0)**(-1.d0/3.d0) +! alpha_rs = 2.d0 * dsqrt((9.d0 * dacos(-1.d0)/4.d0)**(-1.d0/3.d0)) / sqpi +! +! rs = cst_rs * rho**(-1.d0/3.d0) +! mu_rs_c = alpha_rs/dsqrt(rs) +! +!end + +double precision function damped_mu_rs_c(rho,mu_min) + implicit none + double precision, intent(in) :: rho,mu_min + double precision :: mu_rs_c,mu_tmp,damped_mu + mu_tmp = mu_rs_c(rho) + damped_mu_rs_c = damped_mu(mu_tmp, mu_min) +end + +subroutine get_grad_mu_rsc(r,dx,grad_mu) + implicit none + double precision, intent(in) :: r(3),dx + double precision, intent(out):: grad_mu(3) + integer :: m + double precision :: r_tmp(3),mu_plus, mu_minus,mu_rs_c,rho_a_hf,rho_b_hf,rho_hf + do m = 1, 3 + r_tmp = r + r_tmp(m) += dx + call dm_dft_alpha_beta_at_r(r_tmp,rho_a_hf,rho_b_hf) + rho_hf = rho_a_hf + rho_b_hf + rho_hf = max(rho_hf,1.D-10) + mu_plus = mu_rs_c(rho_hf) + r_tmp = r + r_tmp(m) -= dx + call dm_dft_alpha_beta_at_r(r_tmp,rho_a_hf,rho_b_hf) + rho_hf = rho_a_hf + rho_b_hf + rho_hf = max(rho_hf,1.D-10) + mu_minus = mu_rs_c(rho_hf) + + grad_mu(m) = (mu_plus - mu_minus)/(2.d0 * dx) + enddo +end + +subroutine get_grad_damped_mu_rsc(r,mu_min,dx,grad_mu) + implicit none + double precision, intent(in) :: r(3),mu_min,dx + double precision, intent(out):: grad_mu(3) + integer :: m + double precision :: r_tmp(3),mu_plus, mu_minus,mu_rs_c,mu_tmp + double precision :: rho_a_hf,rho_b_hf,rho_hf,damped_mu,rho,damped_mu_rs_c + do m = 1, 3 + r_tmp = r + r_tmp(m) += dx + call dm_dft_alpha_beta_at_r(r_tmp,rho_a_hf,rho_b_hf) + rho_hf = rho_a_hf + rho_b_hf + rho_hf = max(rho_hf,1.D-10) + mu_plus = damped_mu_rs_c(rho_hf,mu_min) + + r_tmp = r + r_tmp(m) -= dx + call dm_dft_alpha_beta_at_r(r_tmp,rho_a_hf,rho_b_hf) + rho_hf = rho_a_hf + rho_b_hf + rho_hf = max(rho_hf,1.D-10) + mu_minus = damped_mu_rs_c(rho_hf,mu_min) + + grad_mu(m) = (mu_plus - mu_minus)/(2.d0 * dx) + enddo +end + + + BEGIN_PROVIDER [double precision, mu_of_r_extra_grid_rs_c, (n_points_extra_final_grid,N_states) ] + implicit none + integer :: ipoint,i,m + include 'constants.include.F' + double precision :: weight, rho_a_hf, rho_b_hf, rho_hf, mu_rs_c + average_mu_rs_c = 0.d0 + double precision :: elec_a,elec_b,r(3) + double precision :: mu_tmp ,damped_mu, mu ,dx,mu_min + dx = 1.d-5 + elec_a = 0.d0 + elec_b = 0.d0 + mu_min = mu_erf + do ipoint = 1, n_points_extra_final_grid + weight = final_weight_at_r_vector_extra(ipoint) + r(:) = final_grid_points_extra(:,ipoint) + call dm_dft_alpha_beta_at_r(r,rho_a_hf,rho_b_hf) + rho_hf = rho_a_hf + rho_b_hf + rho_hf = max(rho_hf,1.D-10) + mu_tmp = mu_rs_c(rho_hf) + if(damped_mu_of_r)then + mu = damped_mu(mu_tmp,mu_min) + else + mu = max(mu_tmp,mu_of_r_min) + endif + if(rescaled_on_top_mu)then + mu = mu *dsqrt(0.25d0 * (rho_a_hf+rho_b_hf)**2/(rho_a_hf*rho_b_hf+1.d-12)) + else + mu=mu + endif + mu_of_r_extra_grid_rs_c(ipoint,1) = mu + elec_a += rho_a_hf * weight + elec_b += rho_b_hf * weight + enddo + +END_PROVIDER + + diff --git a/src/some_mu_of_r/mu_test.irp.f b/src/some_mu_of_r/mu_test.irp.f new file mode 100644 index 00000000..120383b4 --- /dev/null +++ b/src/some_mu_of_r/mu_test.irp.f @@ -0,0 +1,119 @@ + + BEGIN_PROVIDER [double precision, mu_of_r_extra_grid_test_func , (n_points_extra_final_grid,N_states) ] + implicit none + integer :: ipoint,i,m + double precision :: weight, rho_a_hf, rho_b_hf, g0,rho_hf + double precision :: rs,grad_n + double precision :: g0_UEG_mu_inf + double precision :: cst_rs,alpha_rs + double precision :: elec_a,elec_b + double precision :: r(3),dx,mu_test_func,mu_tmp,mu,damped_mu, mu_min + dx = 1.d-5 + elec_a = 0.d0 + elec_b = 0.d0 + mu_min = mu_erf + do ipoint = 1, n_points_extra_final_grid + weight = final_weight_at_r_vector_extra(ipoint) + r(:) = final_grid_points_extra(:,ipoint) + mu = mu_test_func(r) + mu_of_r_extra_grid_test_func(ipoint,1) = mu + + elec_a += rho_a_hf * weight + elec_b += rho_b_hf * weight + + enddo + +END_PROVIDER + + + + + BEGIN_PROVIDER [double precision, average_mu_test_func ] +&BEGIN_PROVIDER [double precision, mu_of_r_test_func , (n_points_final_grid,N_states) ] +&BEGIN_PROVIDER [double precision, grad_mu_of_r_test_func , (3,n_points_final_grid,N_states) ] + implicit none + integer :: ipoint,i,m + double precision :: weight, rho_a_hf, rho_b_hf, g0,rho_hf + double precision :: rs,grad_n + double precision :: g0_UEG_mu_inf + double precision :: cst_rs,alpha_rs + double precision :: elec_a,elec_b,grad_mu(3),mu_test_func + double precision :: mu, r(3),dx,damped_mu,mu_min,mu_tmp + mu_min = mu_erf + dx = 1.d-5 + average_mu_test_func = 0.d0 + elec_a = 0.d0 + elec_b = 0.d0 + do ipoint = 1, n_points_final_grid + weight = final_weight_at_r_vector(ipoint) + r(:) = final_grid_points(:,ipoint) + mu_tmp = mu_test_func(r) + + mu_of_r_test_func(ipoint,1) = mu_tmp + + average_mu_test_func += mu_of_r_test_func(ipoint,1) * weight * rho_hf + elec_a += rho_a_hf * weight + elec_b += rho_b_hf * weight + + call get_grad_mu_test_func(r,dx,grad_mu) + if(mu_tmp.lt.mu)then + grad_mu = 0.d0 + endif + grad_mu_of_r_test_func(:,ipoint,1) = grad_mu(:) + + enddo + average_mu_test_func = average_mu_test_func / dble(elec_a+ elec_b) + +END_PROVIDER + + +double precision function mu_test_func(r) + implicit none + double precision, intent(in) :: r(3) + double precision :: x,y,z + x = r(1) + y = r(2) + z = r(3) + if(mu_test_choice == "cos")then + mu_test_func = mu_erf + ampl_cos * dcos(omega_cos * x) * dcos(omega_cos * y) * dcos(omega_cos * z) !& +! * dexp(-dexp_gauss * (x**2 + y**2 + z**2)) + else if(mu_test_choice== "gauss" )then + mu_test_func = mu_erf + ampl_cos * dexp(-dexp_gauss * (x**2 + y**2 + z**2)) + endif + mu_test_func = max(mu_of_r_min,mu_test_func) +end + +subroutine get_grad_mu_test_func(r,dx,grad_mu) + implicit none + double precision, intent(in) :: r(3),dx + double precision, intent(out):: grad_mu(3) + double precision :: x,y,z + if(mu_test_choice == "cos")then + x = r(1) + y = r(2) + z = r(3) + grad_mu(1) = -ampl_cos * omega_cos * dsin(omega_cos * x) * dcos(omega_cos * y) * dcos(omega_cos * z) + grad_mu(2) = -ampl_cos * omega_cos * dcos(omega_cos * x) * dsin(omega_cos * y) * dcos(omega_cos * z) + grad_mu(3) = -ampl_cos * omega_cos * dcos(omega_cos * x) * dcos(omega_cos * y) * dsin(omega_cos * z) + else + call get_grad_mu_test_num(r,dx,grad_mu) + endif +end + +subroutine get_grad_mu_test_num(r,dx,grad_mu) + implicit none + double precision, intent(in) :: r(3), dx + double precision, intent(out):: grad_mu(3) + double precision :: r1(3),mu_plus,mu_minus,mu_test_func + integer :: m + do m = 1, 3 ! compute grad mu + r1 = r + r1(m) += dx + mu_plus = mu_test_func(r1) + r1 = r + r1(m) -= dx + mu_minus = mu_test_func(r1) + grad_mu(m) = (mu_plus - mu_minus)/(2.d0 * dx) + enddo + +end diff --git a/src/some_mu_of_r/some_mu_of_r.irp.f b/src/some_mu_of_r/some_mu_of_r.irp.f new file mode 100644 index 00000000..67d364e9 --- /dev/null +++ b/src/some_mu_of_r/some_mu_of_r.irp.f @@ -0,0 +1,7 @@ +program some_mu_of_r + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' +end diff --git a/src/tc_keywords/EZFIO.cfg b/src/tc_keywords/EZFIO.cfg new file mode 100644 index 00000000..eedede5b --- /dev/null +++ b/src/tc_keywords/EZFIO.cfg @@ -0,0 +1,107 @@ +[read_rl_eigv] +type: logical +doc: If |true|, read the right/left eigenvectors from ezfio +interface: ezfio,provider,ocaml +default: False + +[comp_left_eigv] +type: logical +doc: If |true|, computes also the left-eigenvector +interface: ezfio,provider,ocaml +default: False + +[three_body_h_tc] +type: logical +doc: If |true|, three-body terms are included +interface: ezfio,provider,ocaml +default: True + +[pure_three_body_h_tc] +type: logical +doc: If |true|, pure triple excitation three-body terms are included +interface: ezfio,provider,ocaml +default: False + +[double_normal_ord] +type: logical +doc: If |true|, contracted double excitation three-body terms are included +interface: ezfio,provider,ocaml +default: False + +[core_tc_op] +type: logical +doc: If |true|, takes the usual Hamiltonian for core orbitals (assumed to be doubly occupied) +interface: ezfio,provider,ocaml +default: False + +[full_tc_h_solver] +type: logical +doc: If |true|, you diagonalize the full TC H matrix +interface: ezfio,provider,ocaml +default: False + +[thresh_it_dav] +type: Threshold +doc: Thresholds on the energy for iterative Davidson used in TC +interface: ezfio,provider,ocaml +default: 1.e-5 + +[max_it_dav] +type: integer +doc: nb max of iteration in Davidson used in TC +interface: ezfio,provider,ocaml +default: 1000 + +[thresh_psi_r] +type: Threshold +doc: Thresholds on the coefficients of the right-eigenvector. Used for PT2 computation. +interface: ezfio,provider,ocaml +default: 0.000005 + +[thresh_psi_r_norm] +type: logical +doc: If |true|, you prune the WF to compute the PT1 coef based on the norm. If False, the pruning is done through the amplitude on the right-coefficient. +interface: ezfio,provider,ocaml +default: False + +[state_following_tc] +type: logical +doc: If |true|, the states are re-ordered to match the input states +default: False +interface: ezfio,provider,ocaml + +[bi_ortho] +type: logical +doc: If |true|, the MO basis is assumed to be bi-orthonormal +interface: ezfio,provider,ocaml +default: True + +[symetric_fock_tc] +type: logical +doc: If |true|, using F+F^\dagger as Fock TC +interface: ezfio,provider,ocaml +default: False + +[thresh_tcscf] +type: Threshold +doc: Threshold on the convergence of the Hartree Fock energy. +interface: ezfio,provider,ocaml +default: 1.e-10 + +[n_it_tcscf_max] +type: Strictly_positive_int +doc: Maximum number of SCF iterations +interface: ezfio,provider,ocaml +default: 500 + +[max_ov_tc_scf] +type: logical +doc: If |true|, the TC-SCF is done with a kind of maximum overlap with RHF MOs +interface: ezfio,provider,ocaml +default: True + +[selection_tc] +type: integer +doc: if +1: only positive is selected, -1: only negative is selected, :0 both positive and negative +interface: ezfio,provider,ocaml +default: 0 diff --git a/src/tc_keywords/NEED b/src/tc_keywords/NEED new file mode 100644 index 00000000..5a3182ed --- /dev/null +++ b/src/tc_keywords/NEED @@ -0,0 +1 @@ +ezfio_files diff --git a/src/tc_keywords/tc_keywords.irp.f b/src/tc_keywords/tc_keywords.irp.f new file mode 100644 index 00000000..3bc68550 --- /dev/null +++ b/src/tc_keywords/tc_keywords.irp.f @@ -0,0 +1,7 @@ +program tc_keywords + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' +end diff --git a/src/three_body_ints/EZFIO.cfg b/src/three_body_ints/EZFIO.cfg new file mode 100644 index 00000000..9624c161 --- /dev/null +++ b/src/three_body_ints/EZFIO.cfg @@ -0,0 +1,20 @@ +[io_three_body_ints] +type: Disk_access +doc: Read/Write the 6 index tensor three-body terms from/to disk [ Write | Read | None ] +interface: ezfio,provider,ocaml +default: None + +[symm_3_body_tensor] +type: logical +doc: If |true|, you have a symmetrized two body tensor +interface: ezfio,provider,ocaml +default: False + + +[read_3_body_tc_ints] +type: logical +doc: If |true|, you read the 3 body integrals from an FCIDUMP like file +interface: ezfio,provider,ocaml +default: False + + diff --git a/src/three_body_ints/NEED b/src/three_body_ints/NEED new file mode 100644 index 00000000..ad7b6bf8 --- /dev/null +++ b/src/three_body_ints/NEED @@ -0,0 +1 @@ +bi_ort_ints diff --git a/src/three_body_ints/io_6_index_tensor.irp.f b/src/three_body_ints/io_6_index_tensor.irp.f new file mode 100644 index 00000000..dd654f7e --- /dev/null +++ b/src/three_body_ints/io_6_index_tensor.irp.f @@ -0,0 +1,63 @@ + +subroutine write_array_6_index_tensor(n_orb,array_tmp,name_file) + implicit none + integer, intent(in) :: n_orb + character*(128), intent(in) :: name_file + double precision, intent(in) :: array_tmp(n_orb,n_orb,n_orb,n_orb,n_orb,n_orb) + + character*(128) :: output + integer :: i_unit_output,getUnitAndOpen + PROVIDE ezfio_filename + output=trim(ezfio_filename)//'/work/'//trim(name_file) + i_unit_output = getUnitAndOpen(output,'W') + write(i_unit_output)array_tmp + close(unit=i_unit_output) +end + +subroutine read_array_6_index_tensor(n_orb,array_tmp,name_file) + implicit none + character*(128) :: output + integer :: i_unit_output,getUnitAndOpen + integer, intent(in) :: n_orb + character*(128), intent(in) :: name_file + double precision, intent(out) :: array_tmp(n_orb,n_orb,n_orb,n_orb,n_orb,n_orb) + PROVIDE ezfio_filename + output=trim(ezfio_filename)//'/work/'//trim(name_file) + i_unit_output = getUnitAndOpen(output,'R') + read(i_unit_output)array_tmp + close(unit=i_unit_output) +end + +subroutine read_fcidump_3_tc(array) + implicit none + double precision, intent(out) :: array(mo_num, mo_num, mo_num, mo_num, mo_num, mo_num) + integer :: i,j,k,l,m,n,i_mo, Reason + double precision :: integral + print*,'Reading the THREE-body integrals from a TC FCIDUMP' + open (unit=15, file="TCDUMP-nosym", status='old', & + access='sequential', action='read' ) + read(15,*)i_mo + if(i_mo.ne.mo_num)then + print*,'Something went wrong in the read_fcidump_3_tc !' + print*,'i_mo.ne.mo_num !' + print*,i_mo,mo_num + stop + endif + do + read(15,*,IOSTAT=Reason)integral,i, j, m, k, l, n + if(Reason > 0)then + print*,'Something went wrong in the I/O of read_fcidump_3_tc' + stop + else if(Reason < 0)then + exit + else + ! 1 2 3 1 2 3 + ! + ! (ik|jl|mn) +! integral = integral * 1.d0/3.d0 !!!! For NECI convention + array(i,j,m,k,l,n) = integral * 3.d0 + + endif + enddo + +end diff --git a/src/three_body_ints/semi_num_ints_mo.irp.f b/src/three_body_ints/semi_num_ints_mo.irp.f new file mode 100644 index 00000000..831ceb9b --- /dev/null +++ b/src/three_body_ints/semi_num_ints_mo.irp.f @@ -0,0 +1,207 @@ + +BEGIN_PROVIDER [ double precision, mo_v_ij_erf_rk_cst_mu_naive, ( mo_num, mo_num,n_points_final_grid)] + implicit none + BEGIN_DOC +! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1 )/(2|r - R|) on the MO basis + END_DOC + integer :: i,j,k,l,ipoint + do ipoint = 1, n_points_final_grid + mo_v_ij_erf_rk_cst_mu_naive(:,:,ipoint) = 0.d0 + do i = 1, mo_num + do j = 1, mo_num + do k = 1, ao_num + do l = 1, ao_num + mo_v_ij_erf_rk_cst_mu_naive(j,i,ipoint) += mo_coef(l,j) * 0.5d0 * v_ij_erf_rk_cst_mu(l,k,ipoint) * mo_coef(k,i) + enddo + enddo + enddo + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, mo_v_ij_erf_rk_cst_mu, ( mo_num, mo_num,n_points_final_grid)] + implicit none + BEGIN_DOC +! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/(2|r - R|) on the MO basis + END_DOC + integer :: ipoint + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint) & + !$OMP SHARED (n_points_final_grid,v_ij_erf_rk_cst_mu,mo_v_ij_erf_rk_cst_mu) + !$OMP DO SCHEDULE (dynamic) + do ipoint = 1, n_points_final_grid + call ao_to_mo(v_ij_erf_rk_cst_mu(1,1,ipoint),size(v_ij_erf_rk_cst_mu,1),mo_v_ij_erf_rk_cst_mu(1,1,ipoint),size(mo_v_ij_erf_rk_cst_mu,1)) + enddo + !$OMP END DO + !$OMP END PARALLEL + mo_v_ij_erf_rk_cst_mu = mo_v_ij_erf_rk_cst_mu * 0.5d0 +END_PROVIDER + +BEGIN_PROVIDER [ double precision, mo_v_ij_erf_rk_cst_mu_transp, ( n_points_final_grid,mo_num, mo_num)] + implicit none + BEGIN_DOC +! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/(2|r - R|) on the MO basis + END_DOC + integer :: ipoint,i,j + do i = 1, mo_num + do j = 1, mo_num + do ipoint = 1, n_points_final_grid + mo_v_ij_erf_rk_cst_mu_transp(ipoint,j,i) = mo_v_ij_erf_rk_cst_mu(j,i,ipoint) + enddo + enddo + enddo + FREE mo_v_ij_erf_rk_cst_mu +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, mo_x_v_ij_erf_rk_cst_mu_naive, ( mo_num, mo_num,3,n_points_final_grid)] + implicit none + BEGIN_DOC +! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1 )/|r - R| on the MO basis + END_DOC + integer :: i,j,k,l,ipoint,m + do ipoint = 1, n_points_final_grid + mo_x_v_ij_erf_rk_cst_mu_naive(:,:,:,ipoint) = 0.d0 + do i = 1, mo_num + do j = 1, mo_num + do m = 1, 3 + do k = 1, ao_num + do l = 1, ao_num + mo_x_v_ij_erf_rk_cst_mu_naive(j,i,m,ipoint) += mo_coef(l,j) * 0.5d0 * x_v_ij_erf_rk_cst_mu_transp(l,k,m,ipoint) * mo_coef(k,i) + enddo + enddo + enddo + enddo + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, mo_x_v_ij_erf_rk_cst_mu, ( mo_num, mo_num,3,n_points_final_grid)] + implicit none + BEGIN_DOC +! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/2|r - R| on the MO basis + END_DOC + integer :: ipoint,m + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint,m) & + !$OMP SHARED (n_points_final_grid,x_v_ij_erf_rk_cst_mu_transp,mo_x_v_ij_erf_rk_cst_mu) + !$OMP DO SCHEDULE (dynamic) + do ipoint = 1, n_points_final_grid + do m = 1, 3 + call ao_to_mo(x_v_ij_erf_rk_cst_mu_transp(1,1,m,ipoint),size(x_v_ij_erf_rk_cst_mu_transp,1),mo_x_v_ij_erf_rk_cst_mu(1,1,m,ipoint),size(mo_x_v_ij_erf_rk_cst_mu,1)) + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + mo_x_v_ij_erf_rk_cst_mu = 0.5d0 * mo_x_v_ij_erf_rk_cst_mu + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, mo_x_v_ij_erf_rk_cst_mu_transp, (n_points_final_grid,3, mo_num, mo_num)] + implicit none + integer :: i,j,m,ipoint + do i = 1, mo_num + do j = 1, mo_num + do m = 1, 3 + do ipoint = 1, n_points_final_grid + mo_x_v_ij_erf_rk_cst_mu_transp(ipoint,m,j,i) = mo_x_v_ij_erf_rk_cst_mu(j,i,m,ipoint) + enddo + enddo + enddo + enddo + +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, x_W_ij_erf_rk, ( n_points_final_grid,3,mo_num, mo_num)] + implicit none + BEGIN_DOC +! W_mn^X(R) = \int dr phi_m(r) phi_n(r) (1 - erf(mu |r-R|)) (x-X) + END_DOC + include 'constants.include.F' + integer :: ipoint,m,i,j + double precision :: xyz,cst + double precision :: wall0, wall1 + + cst = 0.5d0 * inv_sq_pi + print*,'providing x_W_ij_erf_rk ...' + call wall_time(wall0) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint,m,i,j,xyz) & + !$OMP SHARED (x_W_ij_erf_rk,n_points_final_grid,mo_x_v_ij_erf_rk_cst_mu_transp,mo_v_ij_erf_rk_cst_mu_transp,mo_num,final_grid_points) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do j = 1, mo_num + do m = 1, 3 + do ipoint = 1, n_points_final_grid + xyz = final_grid_points(m,ipoint) + x_W_ij_erf_rk(ipoint,m,j,i) = mo_x_v_ij_erf_rk_cst_mu_transp(ipoint,m,j,i) - xyz * mo_v_ij_erf_rk_cst_mu_transp(ipoint,j,i) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + FREE mo_v_ij_erf_rk_cst_mu_transp + FREE mo_x_v_ij_erf_rk_cst_mu_transp + call wall_time(wall1) + print*,'time to provide x_W_ij_erf_rk = ',wall1 - wall0 + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, sqrt_weight_at_r, (n_points_final_grid)] + implicit none + integer :: ipoint + do ipoint = 1, n_points_final_grid + sqrt_weight_at_r(ipoint) = dsqrt(final_weight_at_r_vector(ipoint)) + enddo +END_PROVIDER + +!BEGIN_PROVIDER [ double precision, mos_in_r_array_transp_sq_weight, (n_points_final_grid,mo_num)] + + +!BEGIN_PROVIDER [ double precision, gauss_ij_rk_transp, (ao_num, ao_num, n_points_final_grid) ] +! implicit none +! integer :: i,j,ipoint +! do ipoint = 1, n_points_final_grid +! do j = 1, ao_num +! do i = 1, ao_num +! gauss_ij_rk_transp(i,j,ipoint) = gauss_ij_rk(ipoint,i,j) +! enddo +! enddo +! enddo +!END_PROVIDER +! +! +!BEGIN_PROVIDER [ double precision, mo_gauss_ij_rk, ( mo_num, mo_num,n_points_final_grid)] +! implicit none +! integer :: ipoint +! !$OMP PARALLEL & +! !$OMP DEFAULT (NONE) & +! !$OMP PRIVATE (ipoint) & +! !$OMP SHARED (n_points_final_grid,gauss_ij_rk_transp,mo_gauss_ij_rk) +! !$OMP DO SCHEDULE (dynamic) +! do ipoint = 1, n_points_final_grid +! call ao_to_mo(gauss_ij_rk_transp(1,1,ipoint),size(gauss_ij_rk_transp,1),mo_gauss_ij_rk(1,1,ipoint),size(mo_gauss_ij_rk,1)) +! enddo +! !$OMP END DO +! !$OMP END PARALLEL +! +!END_PROVIDER +! +!BEGIN_PROVIDER [ double precision, mo_gauss_ij_rk_transp, (n_points_final_grid, mo_num, mo_num)] +! implicit none +! integer :: i,j,ipoint +! do ipoint = 1, n_points_final_grid +! do j = 1, mo_num +! do i = 1, mo_num +! mo_gauss_ij_rk_transp(ipoint,i,j) = mo_gauss_ij_rk(i,j,ipoint) +! enddo +! enddo +! enddo +! +!END_PROVIDER +! diff --git a/src/three_body_ints/three_body_tensor.irp.f b/src/three_body_ints/three_body_tensor.irp.f new file mode 100644 index 00000000..2b65a925 --- /dev/null +++ b/src/three_body_ints/three_body_tensor.irp.f @@ -0,0 +1,106 @@ +BEGIN_PROVIDER [ double precision, three_body_ints, (mo_num, mo_num, mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! matrix element of the -L three-body operator +! +! notice the -1 sign: in this way three_body_ints can be directly used to compute Slater rules :) + END_DOC + integer :: i,j,k,l,m,n + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_body_ints = 0.d0 + print*,'Providing the three_body_ints ...' + call wall_time(wall0) + name_file = 'six_index_tensor' + if(read_three_body_ints)then + call read_fcidump_3_tc(three_body_ints) + else + if(read_three_body_ints)then + print*,'Reading three_body_ints from disk ...' + call read_array_6_index_tensor(mo_num,three_body_ints,name_file) + else + provide x_W_ij_erf_rk + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,l,m,n,integral) & + !$OMP SHARED (mo_num,three_body_ints) + !$OMP DO SCHEDULE (dynamic) + do n = 1, mo_num + do l = 1, mo_num + do k = 1, mo_num + do m = n, mo_num + do j = l, mo_num + do i = k, mo_num +!! if(i>=j)then + integral = 0.d0 + call give_integrals_3_body(i,j,m,k,l,n,integral) + + three_body_ints(i,j,m,k,l,n) = -1.d0 * integral + + ! permutation with k,i + three_body_ints(k,j,m,i,l,n) = -1.d0 * integral ! i,k + ! two permutations with k,i + three_body_ints(k,l,m,i,j,n) = -1.d0 * integral + three_body_ints(k,j,n,i,l,m) = -1.d0 * integral + ! three permutations with k,i + three_body_ints(k,l,n,i,j,m) = -1.d0 * integral + + ! permutation with l,j + three_body_ints(i,l,m,k,j,n) = -1.d0 * integral ! j,l + ! two permutations with l,j + three_body_ints(k,l,m,i,j,n) = -1.d0 * integral + three_body_ints(i,l,n,k,j,m) = -1.d0 * integral + ! two permutations with l,j +!!!! three_body_ints(k,l,n,i,j,m) = -1.d0 * integral + + ! permutation with m,n + three_body_ints(i,j,n,k,l,m) = -1.d0 * integral ! m,n + ! two permutations with m,n + three_body_ints(k,j,n,i,l,m) = -1.d0 * integral ! m,n + three_body_ints(i,l,n,k,j,m) = -1.d0 * integral ! m,n + ! three permutations with k,i +!!!! three_body_ints(k,l,n,i,j,m) = -1.d0 * integral ! m,n + +!! endif + enddo + enddo + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + endif + endif + call wall_time(wall1) + print*,'wall time for three_body_ints',wall1 - wall0 + if(write_three_body_ints)then + print*,'Writing three_body_ints on disk ...' + call write_array_6_index_tensor(mo_num,three_body_ints,name_file) + call ezfio_set_three_body_ints_io_three_body_ints("Read") + endif + +END_PROVIDER + + + +subroutine give_integrals_3_body(i,j,m,k,l,n,integral) + implicit none + double precision, intent(out) :: integral + integer, intent(in) :: i,j,m,k,l,n + double precision :: weight + BEGIN_DOC +! + END_DOC + integer :: ipoint,mm + integral = 0.d0 + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + weight = final_weight_at_r_vector(ipoint) + integral += weight * mos_in_r_array_transp(ipoint,i) * mos_in_r_array_transp(ipoint,k) * x_W_ij_erf_rk(ipoint,mm,m,n) * x_W_ij_erf_rk(ipoint,mm,j,l) + integral += weight * mos_in_r_array_transp(ipoint,j) * mos_in_r_array_transp(ipoint,l) * x_W_ij_erf_rk(ipoint,mm,m,n) * x_W_ij_erf_rk(ipoint,mm,i,k) + integral += weight * mos_in_r_array_transp(ipoint,m) * mos_in_r_array_transp(ipoint,n) * x_W_ij_erf_rk(ipoint,mm,j,l) * x_W_ij_erf_rk(ipoint,mm,i,k) + enddo + enddo +end + diff --git a/src/three_body_ints/three_e_3_idx.irp.f b/src/three_body_ints/three_e_3_idx.irp.f new file mode 100644 index 00000000..13210f00 --- /dev/null +++ b/src/three_body_ints/three_e_3_idx.irp.f @@ -0,0 +1,338 @@ + +BEGIN_PROVIDER [ double precision, three_body_3_index, (mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! 3 index matrix element of the -L three-body operator +! +! three_body_3_index(k,l,n) = < phi_k phi_l phi_n | phi_k phi_l phi_n > +! +! notice the -1 sign: in this way three_body_3_index can be directly used to compute Slater rules :) + END_DOC + integer :: i,j,m + double precision :: integral, wall1, wall0 + character*(128) :: name_file + print*,'Providing the three_body_3_index ...' + name_file = 'three_body_3_index' + call wall_time(wall0) + if(read_three_body_ints)then + print*,'Reading three_body_ints from disk ...' + call read_array_3_index_tensor(mo_num,three_body_3_index,name_file) + else + provide x_W_ij_erf_rk + three_body_3_index = 0.d0 + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,integral) & + !$OMP SHARED (mo_num,three_body_3_index) + !$OMP DO SCHEDULE (guided) COLLAPSE(3) + do m = 1, mo_num ! 3 + do j = 1, mo_num ! 2 + do i = 1, mo_num ! 1 + integral = 0.d0 + ! 1 2 3 1 2 3 + call give_integrals_3_body(i,j,m,i,j,m,integral) + + three_body_3_index(i,j,m) = -1.d0 * integral + + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + endif + call wall_time(wall1) + print*,'wall time for three_body_3_index',wall1 - wall0 + if(write_three_body_ints)then + print*,'Writing three_body_3_index on disk ...' + call write_array_3_index_tensor(mo_num,three_body_3_index,name_file) + call ezfio_set_three_body_ints_io_three_body_ints("Read") + endif + + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_body_3_index_exch_12, (mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! 3 index matrix EXCHANGE element of the -L three-body operator +! +! three_body_3_index_exch_12(k,l,n) = < phi_k phi_l phi_n | phi_l phi_k phi_n > +! +! notice the -1 sign: in this way three_body_3_index_exch_12 can be directly used to compute Slater rules :) + END_DOC + integer :: i,j,m + double precision :: integral, wall1, wall0 + character*(128) :: name_file + name_file = 'three_body_3_index_exch_12' + print*,'Providing the three_body_3_index_exch_12 ...' + call wall_time(wall0) + if(read_three_body_ints)then + print*,'Reading three_body_ints from disk ...' + call read_array_3_index_tensor(mo_num,three_body_3_index_exch_12,name_file) + else + provide x_W_ij_erf_rk + three_body_3_index_exch_12 = 0.d0 + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,integral) & + !$OMP SHARED (mo_num,three_body_3_index_exch_12) + !$OMP DO SCHEDULE (guided) COLLAPSE(3) + do m = 1, mo_num ! 3 + do j = 1, mo_num ! 2 + do i = 1, mo_num ! 1 + integral = 0.d0 + ! 1 2 3 1 2 3 + call give_integrals_3_body(i,j,m,j,i,m,integral) + + three_body_3_index_exch_12(i,j,m) = -1.d0 * integral + + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + endif + call wall_time(wall1) + print*,'wall time for three_body_3_index_exch_12',wall1 - wall0 + if(write_three_body_ints)then + print*,'Writing three_body_3_index_exch_12 on disk ...' + call write_array_3_index_tensor(mo_num,three_body_3_index_exch_12,name_file) + call ezfio_set_three_body_ints_io_three_body_ints("Read") + endif +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_body_3_index_exch_23, (mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! 3 index matrix EXCHANGE element of the -L three-body operator +! +! three_body_3_index_exch_12(k,l,n) = < phi_k phi_l phi_n | phi_k phi_n phi_l > +! +! notice the -1 sign: in this way three_body_3_index_exch_12 can be directly used to compute Slater rules :) + END_DOC + integer :: i,j,m + double precision :: integral, wall1, wall0 + character*(128) :: name_file + print*,'Providing the three_body_3_index_exch_23 ...' + call wall_time(wall0) + name_file = 'three_body_3_index_exch_23' + if(read_three_body_ints)then + print*,'Reading three_body_ints from disk ...' + call read_array_3_index_tensor(mo_num,three_body_3_index_exch_23,name_file) + else + provide x_W_ij_erf_rk + three_body_3_index_exch_23 = 0.d0 + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,integral) & + !$OMP SHARED (mo_num,three_body_3_index_exch_23) + !$OMP DO SCHEDULE (guided) COLLAPSE(3) + do m = 1, mo_num ! 3 + do j = 1, mo_num ! 2 + do i = 1, mo_num ! 1 + integral = 0.d0 + ! 1 2 3 1 2 3 + call give_integrals_3_body(i,j,m,i,m,j,integral) + + three_body_3_index_exch_23(i,j,m) = -1.d0 * integral + + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call wall_time(wall1) + endif + print*,'wall time for three_body_3_index_exch_23',wall1 - wall0 + if(write_three_body_ints)then + print*,'Writing three_body_3_index_exch_23 on disk ...' + call write_array_3_index_tensor(mo_num,three_body_3_index_exch_23,name_file) + call ezfio_set_three_body_ints_io_three_body_ints("Read") + endif + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_body_3_index_exch_13, (mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! 3 index matrix EXCHANGE element of the -L three-body operator +! +! three_body_3_index_exch_12(k,l,n) = < phi_k phi_l phi_n | phi_k phi_n phi_l > +! +! notice the -1 sign: in this way three_body_3_index_exch_12 can be directly used to compute Slater rules :) + END_DOC + integer :: i,j,m + double precision :: integral, wall1, wall0 + character*(128) :: name_file + print*,'Providing the three_body_3_index_exch_13 ...' + call wall_time(wall0) + name_file = 'three_body_3_index_exch_13' + if(read_three_body_ints)then + print*,'Reading three_body_ints from disk ...' + call read_array_3_index_tensor(mo_num,three_body_3_index_exch_13,name_file) + else + provide x_W_ij_erf_rk + three_body_3_index_exch_13 = 0.d0 + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,integral) & + !$OMP SHARED (mo_num,three_body_3_index_exch_13) + !$OMP DO SCHEDULE (guided) + do m = 1, mo_num ! 3 + do j = 1, mo_num ! 2 + do i = 1, mo_num ! 1 + integral = 0.d0 + ! 1 2 3 1 2 3 + call give_integrals_3_body(i,j,m,m,j,i,integral) + + three_body_3_index_exch_13(i,j,m) = -1.d0 * integral + + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + endif + + call wall_time(wall1) + print*,'wall time for three_body_3_index_exch_13',wall1 - wall0 + if(write_three_body_ints)then + print*,'Writing three_body_3_index_exch_13 on disk ...' + call write_array_3_index_tensor(mo_num,three_body_3_index_exch_13,name_file) + call ezfio_set_three_body_ints_io_three_body_ints("Read") + endif +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, three_body_3_index_exch_231, (mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! 3 index matrix element of the -L three-body operator +! +! three_body_3_index_exch_231(k,l,n) = < phi_k phi_l phi_n | phi_l phi_n phi_k > +! +! notice the -1 sign: in this way three_body_3_index can be directly used to compute Slater rules :) + END_DOC + integer :: i,j,m + double precision :: integral, wall1, wall0 + character*(128) :: name_file + print*,'Providing the three_body_3_index_231 ...' + call wall_time(wall0) + name_file = 'three_body_3_index_exch_231' + if(read_three_body_ints)then + print*,'Reading three_body_ints from disk ...' + call read_array_3_index_tensor(mo_num,three_body_3_index_exch_231,name_file) + else + provide x_W_ij_erf_rk + three_body_3_index_exch_231 = 0.d0 + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,integral) & + !$OMP SHARED (mo_num,three_body_3_index_exch_231) + !$OMP DO SCHEDULE (guided) COLLAPSE(3) + do m = 1, mo_num ! 3 + do j = 1, mo_num ! 2 + do i = 1, mo_num ! 1 + integral = 0.d0 + ! 1 2 3 1 2 3 + call give_integrals_3_body(i,j,m,j,m,i,integral) + + three_body_3_index_exch_231(i,j,m) = -1.d0 * integral + + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + endif + call wall_time(wall1) + print*,'wall time for three_body_3_index_exch_231 ',wall1 - wall0 + + if(write_three_body_ints)then + print*,'Writing three_body_3_index_exch_231 on disk ...' + call write_array_3_index_tensor(mo_num,three_body_3_index_exch_231,name_file) + call ezfio_set_three_body_ints_io_three_body_ints("Read") + endif + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_body_3_index_exch_312, (mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! 3 index matrix element of the -L three-body operator +! +! three_body_3_index(k,l,n) = < phi_k phi_l phi_n | phi_l phi_n phi_k > +! +! notice the -1 sign: in this way three_body_3_index can be directly used to compute Slater rules :) + END_DOC + integer :: i,j,m + double precision :: integral, wall1, wall0 + character*(128) :: name_file + print*,'Providing the three_body_3_index_312 ...' + call wall_time(wall0) + name_file = 'three_body_3_index_exch_312' + if(read_three_body_ints)then + print*,'Reading three_body_ints from disk ...' + call read_array_3_index_tensor(mo_num,three_body_3_index_exch_312,name_file) + else + provide x_W_ij_erf_rk + three_body_3_index_exch_312 = 0.d0 + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,integral) & + !$OMP SHARED (mo_num,three_body_3_index_exch_312) + !$OMP DO SCHEDULE (guided) COLLAPSE(3) + do m = 1, mo_num ! 3 + do j = 1, mo_num ! 2 + do i = 1, mo_num ! 1 + integral = 0.d0 + ! 1 2 3 1 2 3 + call give_integrals_3_body(i,j,m,m,i,j,integral) + + three_body_3_index_exch_312(i,j,m) = -1.d0 * integral + + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + endif + call wall_time(wall1) + print*,'wall time for three_body_3_index_312',wall1 - wall0 + if(write_three_body_ints)then + print*,'Writing three_body_3_index_exch_312 on disk ...' + call write_array_3_index_tensor(mo_num,three_body_3_index_exch_312,name_file) + call ezfio_set_three_body_ints_io_three_body_ints("Read") + endif + +END_PROVIDER + +subroutine write_array_3_index_tensor(n_orb,array_tmp,name_file) + implicit none + integer, intent(in) :: n_orb + character*(128), intent(in) :: name_file + double precision, intent(in) :: array_tmp(n_orb,n_orb,n_orb) + + character*(128) :: output + integer :: i_unit_output,getUnitAndOpen + PROVIDE ezfio_filename + output=trim(ezfio_filename)//'/work/'//trim(name_file) + i_unit_output = getUnitAndOpen(output,'W') + write(i_unit_output)array_tmp + close(unit=i_unit_output) +end + +subroutine read_array_3_index_tensor(n_orb,array_tmp,name_file) + implicit none + character*(128) :: output + integer :: i_unit_output,getUnitAndOpen + integer, intent(in) :: n_orb + character*(128), intent(in) :: name_file + double precision, intent(out) :: array_tmp(n_orb,n_orb,n_orb) + PROVIDE ezfio_filename + output=trim(ezfio_filename)//'/work/'//trim(name_file) + i_unit_output = getUnitAndOpen(output,'R') + read(i_unit_output)array_tmp + close(unit=i_unit_output) +end diff --git a/src/three_body_ints/three_e_4_idx.irp.f b/src/three_body_ints/three_e_4_idx.irp.f new file mode 100644 index 00000000..0c6743f0 --- /dev/null +++ b/src/three_body_ints/three_e_4_idx.irp.f @@ -0,0 +1,347 @@ + +BEGIN_PROVIDER [ double precision, three_body_4_index, (mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! 4 index matrix direct element of the -L three-body operator +! +! three_body_4_index(j,m,k,i) = < phi_j phi_m phi_k | phi_j phi_m phi_i > +! +! notice the -1 sign: in this way three_body_4_index can be directly used to compute Slater rules :) + END_DOC + integer :: i,j,k,l,m,n + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_body_4_index = 0.d0 + print*,'Providing the three_body_4_index ...' + call wall_time(wall0) + + name_file = 'three_body_4_index' + if(read_three_body_ints)then + print*,'Reading three_body_4_index from disk ...' + call read_array_4_index_tensor(mo_num,three_body_4_index,name_file) + else + provide x_W_ij_erf_rk + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,k,integral) & + !$OMP SHARED (mo_num,three_body_4_index) + !$OMP DO SCHEDULE (guided) COLLAPSE(2) + do i = 1, mo_num + do k = 1, mo_num + do m = 1, mo_num + do j = 1, mo_num + integral = 0.d0 + call give_integrals_3_body(i,j,m,k,j,m,integral) + + three_body_4_index(j,m,k,i) = -1.d0 * integral + + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + endif + call wall_time(wall1) + print*,'wall time for three_body_4_index',wall1 - wall0 + if(write_three_body_ints)then + print*,'Writing three_body_4_index on disk ...' + call write_array_4_index_tensor(mo_num,three_body_4_index,name_file) + call ezfio_set_three_body_ints_io_three_body_ints("Read") + endif + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_body_4_index_exch_12, (mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! 4 index matrix EXCHANGE element of the -L three-body operator +! +! three_body_4_index_exch_12(j,m,k,i) = < phi_m phi_j phi_i | phi_j phi_m phi_k > +! +! notice the -1 sign: in this way three_body_3_index_exch_12 can be directly used to compute Slater rules :) + END_DOC + integer :: i,j,k,l,m,n + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_body_4_index_exch_12 = 0.d0 + print*,'Providing the three_body_4_index_exch_12 ...' + call wall_time(wall0) + + name_file = 'three_body_4_index_exch_12' + if(read_three_body_ints)then + print*,'Reading three_body_4_index_exch_12 from disk ...' + call read_array_4_index_tensor(mo_num,three_body_4_index_exch_12,name_file) + else + provide x_W_ij_erf_rk + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,k,integral) & + !$OMP SHARED (mo_num,three_body_4_index_exch_12) + !$OMP DO SCHEDULE (guided) COLLAPSE(4) + do i = 1, mo_num + do k = 1, mo_num + do m = 1, mo_num + do j = 1, mo_num + integral = 0.d0 + call give_integrals_3_body(i,m,j,k,j,m,integral) + + three_body_4_index_exch_12(j,m,k,i) = -1.d0 * integral + + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + endif + call wall_time(wall1) + print*,'wall time for three_body_4_index_exch_12',wall1 - wall0 + + if(write_three_body_ints)then + print*,'Writing three_body_4_index_exch_12 on disk ...' + call write_array_4_index_tensor(mo_num,three_body_4_index_exch_12,name_file) + call ezfio_set_three_body_ints_io_three_body_ints("Read") + endif + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_body_4_index_exch_12_part, (mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! 4 index matrix EXCHANGE element of the -L three-body operator +! +! three_body_4_index_exch_12_part(j,m,k,i) = < phi_m phi_j phi_i | phi_m phi_k phi_j > +! +! notice the -1 sign: in this way three_body_3_index_exch_12 can be directly used to compute Slater rules :) + END_DOC + integer :: i,j,k,l,m,n + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_body_4_index_exch_12_part = 0.d0 + print*,'Providing the three_body_4_index_exch_12_part ...' + call wall_time(wall0) + + name_file = 'three_body_4_index_exch_12_part' + if(read_three_body_ints)then + print*,'Reading three_body_4_index_exch_12_part from disk ...' + call read_array_4_index_tensor(mo_num,three_body_4_index_exch_12_part,name_file) + else + provide x_W_ij_erf_rk + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,k,integral) & + !$OMP SHARED (mo_num,three_body_4_index_exch_12_part) + !$OMP DO SCHEDULE (guided) COLLAPSE(2) + do i = 1, mo_num + do k = 1, mo_num + do m = 1, mo_num + do j = 1, mo_num + integral = 0.d0 + ! + call give_integrals_3_body(i,j,m,j,k,m,integral) + three_body_4_index_exch_12_part(j,m,k,i) = -1.d0 * integral + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call wall_time(wall1) + endif + print*,'wall time for three_body_4_index_exch_12_part',wall1 - wall0 + if(write_three_body_ints)then + print*,'Writing three_body_4_index_exch_12_part on disk ...' + call write_array_4_index_tensor(mo_num,three_body_4_index_exch_12_part,name_file) + call ezfio_set_three_body_ints_io_three_body_ints("Read") + endif + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_body_4_index_exch_12_part_bis, (mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! 4 index matrix EXCHANGE element of the -L three-body operator +! +! three_body_4_index_exch_12_part_bis(j,m,k,i) = < phi_m phi_j phi_i | phi_m phi_k phi_j > +! +! notice the -1 sign: in this way three_body_3_index_exch_12 can be directly used to compute Slater rules :) + END_DOC + integer :: i,j,k,l,m,n + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_body_4_index_exch_12_part_bis = 0.d0 + print*,'Providing the three_body_4_index_exch_12_part_bis ...' + call wall_time(wall0) + + name_file = 'three_body_4_index_exch_12_part_bis' + if(read_three_body_ints)then + print*,'Reading three_body_4_index_exch_12_part_bisfrom disk ...' + call read_array_4_index_tensor(mo_num,three_body_4_index_exch_12_part_bis,name_file) + else + provide x_W_ij_erf_rk + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,k,integral) & + !$OMP SHARED (mo_num,three_body_4_index_exch_12_part_bis) + !$OMP DO SCHEDULE (guided) COLLAPSE(2) + do i = 1, mo_num + do k = 1, mo_num + do m = 1, mo_num + do j = 1, mo_num + integral = 0.d0 + ! + call give_integrals_3_body(i,j,m,m,j,k,integral) + + three_body_4_index_exch_12_part_bis(j,m,k,i) = -1.d0 * integral + + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + endif + call wall_time(wall1) + print*,'wall time for three_body_4_index_exch_12_part_bis',wall1 - wall0 + if(write_three_body_ints)then + print*,'Writing three_body_4_index_exch_12_part_bis on disk ...' + call write_array_4_index_tensor(mo_num,three_body_4_index_exch_12_part_bis,name_file) + call ezfio_set_three_body_ints_io_three_body_ints("Read") + endif + +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, three_body_4_index_exch_231, (mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! 4 index matrix direct element of the -L three-body operator +! +! three_body_4_index_exch_231(j,m,k,i) = < phi_j phi_m phi_k | phi_j phi_m phi_i > +! +! notice the -1 sign: in this way three_body_4_index_exch_231 can be directly used to compute Slater rules :) + END_DOC + integer :: i,j,k,l,m,n + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_body_4_index_exch_231 = 0.d0 + print*,'Providing the three_body_4_index_exch_231 ...' + call wall_time(wall0) + name_file = 'three_body_4_index_exch_231' + if(read_three_body_ints)then + print*,'Reading three_body_4_index_exch_231 from disk ...' + call read_array_4_index_tensor(mo_num,three_body_4_index_exch_231,name_file) + else + provide x_W_ij_erf_rk + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,k,integral) & + !$OMP SHARED (mo_num,three_body_4_index_exch_231) + !$OMP DO SCHEDULE (guided) COLLAPSE(2) + do i = 1, mo_num + do k = 1, mo_num + do m = 1, mo_num + do j = 1, mo_num + integral = 0.d0 + call give_integrals_3_body(i,j,m,j,m,k,integral) + + three_body_4_index_exch_231(j,m,k,i) = -1.d0 * integral + + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + endif + call wall_time(wall1) + print*,'wall time for three_body_4_index_exch_231',wall1 - wall0 + if(write_three_body_ints)then + print*,'Writing three_body_4_index_exch_231 on disk ...' + call write_array_4_index_tensor(mo_num,three_body_4_index_exch_231,name_file) + call ezfio_set_three_body_ints_io_three_body_ints("Read") + endif + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_body_4_index_exch_312, (mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! 4 index matrix direct element of the -L three-body operator +! +! three_body_4_index_exch_312(j,m,k,i) = < phi_j phi_m phi_k | phi_j phi_m phi_i > +! +! notice the -1 sign: in this way three_body_4_index_exch_312 can be directly used to compute Slater rules :) + END_DOC + integer :: i,j,k,l,m,n + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_body_4_index_exch_312 = 0.d0 + print*,'Providing the three_body_4_index_exch_312 ...' + call wall_time(wall0) + name_file = 'three_body_4_index_exch_312' + if(read_three_body_ints)then + print*,'Reading three_body_4_index_exch_312 from disk ...' + call read_array_4_index_tensor(mo_num,three_body_4_index_exch_312,name_file) + else + provide x_W_ij_erf_rk + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,k,integral) & + !$OMP SHARED (mo_num,three_body_4_index_exch_312) + !$OMP DO SCHEDULE (guided) COLLAPSE(2) + do i = 1, mo_num + do k = 1, mo_num + do m = 1, mo_num + do j = 1, mo_num + integral = 0.d0 + call give_integrals_3_body(i,j,m,m,k,j,integral) + + three_body_4_index_exch_312(j,m,k,i) = -1.d0 * integral + + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + endif + call wall_time(wall1) + print*,'wall time for three_body_4_index_exch_312',wall1 - wall0 + if(write_three_body_ints)then + print*,'Writing three_body_4_index_exch_312 on disk ...' + call write_array_4_index_tensor(mo_num,three_body_4_index_exch_312,name_file) + call ezfio_set_three_body_ints_io_three_body_ints("Read") + endif + +END_PROVIDER + +subroutine write_array_4_index_tensor(n_orb,array_tmp,name_file) + implicit none + integer, intent(in) :: n_orb + character*(128), intent(in) :: name_file + double precision, intent(in) :: array_tmp(n_orb,n_orb,n_orb,n_orb) + + character*(128) :: output + integer :: i_unit_output,getUnitAndOpen + PROVIDE ezfio_filename + output=trim(ezfio_filename)//'/work/'//trim(name_file) + i_unit_output = getUnitAndOpen(output,'W') + write(i_unit_output)array_tmp + close(unit=i_unit_output) +end + +subroutine read_array_4_index_tensor(n_orb,array_tmp,name_file) + implicit none + character*(128) :: output + integer :: i_unit_output,getUnitAndOpen + integer, intent(in) :: n_orb + character*(128), intent(in) :: name_file + double precision, intent(out) :: array_tmp(n_orb,n_orb,n_orb,n_orb) + PROVIDE ezfio_filename + output=trim(ezfio_filename)//'/work/'//trim(name_file) + i_unit_output = getUnitAndOpen(output,'R') + read(i_unit_output)array_tmp + close(unit=i_unit_output) +end diff --git a/src/three_body_ints/three_e_5_idx.irp.f b/src/three_body_ints/three_e_5_idx.irp.f new file mode 100644 index 00000000..914601ff --- /dev/null +++ b/src/three_body_ints/three_e_5_idx.irp.f @@ -0,0 +1,453 @@ + +BEGIN_PROVIDER [ double precision, three_body_5_index, (mo_num, mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! 5 index matrix element of the -L three-body operator +! +! three_body_5_index(i,j,m,l,n) = < phi_i phi_j phi_m | phi_i phi_l phi_n > +! +! notice the -1 sign: in this way three_body_5_index can be directly used to compute Slater rules :) + END_DOC + integer :: j,k,l,m,n + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_body_5_index(1:mo_num, 1:mo_num, 1:mo_num, 1:mo_num, 1:mo_num) = 0.d0 + print*,'Providing the three_body_5_index ...' + name_file = 'three_body_5_index' + call wall_time(wall0) + if(read_three_body_ints)then + print*,'Reading three_body_5_index from disk ...' + call read_array_5_index_tensor(mo_num,three_body_5_index,name_file) + else + provide x_W_ij_erf_rk + provide x_W_ij_erf_rk + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (j,k,l,m,n,integral) & + !$OMP SHARED (mo_num,three_body_5_index) + !$OMP DO SCHEDULE (guided) COLLAPSE(2) + do n = 1, mo_num + do l = 1, mo_num + do k = 1, mo_num +! do m = n, mo_num +! do j = l, mo_num + do m = 1, mo_num + do j = 1, mo_num + integral = 0.d0 + + call give_integrals_3_body(j,m,k,l,n,k,integral) + + three_body_5_index(k,j,m,l,n) = -1.d0 * integral + + enddo + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + endif + call wall_time(wall1) + print*,'wall time for three_body_5_index',wall1 - wall0 + if(write_three_body_ints)then + print*,'Writing three_body_5_index on disk ...' + call write_array_5_index_tensor(mo_num,three_body_5_index,name_file) + call ezfio_set_three_body_ints_io_three_body_ints("Read") + endif +! do n = 1, mo_num +! do l = 1, mo_num +! do k = 1, mo_num +! do m = 1, n-1 +! do j = 1, l-1 +! three_body_5_index(k,j,m,l,n) = three_body_5_index(k,l,n,j,m) +! three_body_5_index(k,j,m,l,n) +! enddo +! enddo +! enddo +! enddo +! enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_body_5_index_exch_13, (mo_num, mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! 5 index matrix element of the -L three-body operator +! +! three_body_5_index_exch_13(k,j,m,l,n) = < phi_j phi_m phi_k | phi_k phi_n phi_l > +! +! notice the -1 sign: in this way three_body_5_index_exch_13 can be directly used to compute Slater rules :) + END_DOC + integer :: j,k,l,m,n + double precision :: integral, wall1, wall0 + character*(128) :: name_file + + three_body_5_index_exch_13 = 0.d0 + + name_file = 'three_body_5_index_exch_13' + print*,'Providing the three_body_5_index_exch_13 ...' + call wall_time(wall0) + if(read_three_body_ints)then + print*,'Reading three_body_5_index_exch_13 from disk ...' + call read_array_5_index_tensor(mo_num,three_body_5_index_exch_13,name_file) + else + provide x_W_ij_erf_rk + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (j,k,l,m,n,integral) & + !$OMP SHARED (mo_num,three_body_5_index_exch_13) + !$OMP DO SCHEDULE (guided) COLLAPSE(2) + do n = 1, mo_num + do l = 1, mo_num + do k = 1, mo_num +! do m = n, mo_num +! do j = l, mo_num + do m = 1, mo_num + do j = 1, mo_num + integral = 0.d0 +!! j,m,k,l,n,k : direct (case 2) + call give_integrals_3_body(j,m,k,k,n,l,integral) +!! j,m,k,k,n,l : exchange 1 3 + + three_body_5_index_exch_13(k,j,m,l,n) = -1.d0 * integral + enddo + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + endif + call wall_time(wall1) + print*,'wall time for three_body_5_index_exch_13',wall1 - wall0 + if(write_three_body_ints)then + print*,'Writing three_body_5_index_exch_13 on disk ...' + call write_array_5_index_tensor(mo_num,three_body_5_index_exch_13,name_file) + call ezfio_set_three_body_ints_io_three_body_ints("Read") + endif +! do n = 1, mo_num +! do l = 1, mo_num +! do k = 1, mo_num +! do m = n, mo_num +! do j = l, mo_num +! three_body_5_index_exch_13(k,l,n,j,m) = three_body_5_index_exch_13(k,j,m,l,n) +! enddo +! enddo +! enddo +! enddo +! enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_body_5_index_exch_32, (mo_num, mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! 5 index matrix element of the -L three-body operator +! +! three_body_5_index_exch_32(i,j,m,l,n) = < phi_i phi_j phi_m | phi_i phi_l phi_n > +! +! notice the -1 sign: in this way three_body_5_index_exch_32 can be directly used to compute Slater rules :) + END_DOC + integer :: i,j,k,l,m,n + double precision :: integral, wall1, wall0 + character*(328) :: name_file + + three_body_5_index_exch_32 = 0.d0 + name_file = 'three_body_5_index_exch_32' + print*,'Providing the three_body_5_index_exch_32 ...' + call wall_time(wall0) + + if(read_three_body_ints)then + print*,'Reading three_body_5_index_exch_32 from disk ...' + call read_array_5_index_tensor(mo_num,three_body_5_index_exch_32,name_file) + else + provide x_W_ij_erf_rk + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (j,k,l,m,n,integral) & + !$OMP SHARED (mo_num,three_body_5_index_exch_32) + !$OMP DO SCHEDULE (guided) COLLAPSE(2) + do n = 1, mo_num + do l = 1, mo_num + do k = 1, mo_num +! do m = n, mo_num +! do j = l, mo_num + do m = 1, mo_num + do j = 1, mo_num + integral = 0.d0 +!! j,m,k,l,n,k : direct (case 3) + call give_integrals_3_body(j,m,k,l,k,n,integral) +!! j,m,k,l,k,n : exchange 2 3 + + three_body_5_index_exch_32(k,j,m,l,n) = -1.d0 * integral + + enddo + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + endif + call wall_time(wall1) + print*,'wall time for three_body_5_index_exch_32',wall1 - wall0 + if(write_three_body_ints)then + print*,'Writing three_body_5_index_exch_32 on disk ...' + call write_array_5_index_tensor(mo_num,three_body_5_index_exch_32,name_file) + call ezfio_set_three_body_ints_io_three_body_ints("Read") + endif +! do n = 1, mo_num +! do l = 1, mo_num +! do k = 1, mo_num +! do m = n, mo_num +! do j = l, mo_num +! three_body_5_index_exch_32(k,l,n,j,m) = three_body_5_index_exch_32(k,j,m,l,n) +! enddo +! enddo +! enddo +! enddo +! enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_body_5_index_exch_12, (mo_num, mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! 5 index matrix element of the -L three-body operator +! +! three_body_5_index_exch_12(i,j,m,l,n) = < phi_i phi_j phi_m | phi_i phi_l phi_n > +! +! notice the -1 sign: in this way three_body_5_index_exch_12 can be directly used to compute Slater rules :) + END_DOC + integer :: i,j,k,l,m,n + double precision :: integral, wall1, wall0 + character*(328) :: name_file + + three_body_5_index_exch_12 = 0.d0 + name_file = 'three_body_5_index_exch_12' + print*,'Providing the three_body_5_index_exch_12 ...' + call wall_time(wall0) + + if(read_three_body_ints)then + print*,'Reading three_body_5_index_exch_12 from disk ...' + call read_array_5_index_tensor(mo_num,three_body_5_index_exch_12,name_file) + else + provide x_W_ij_erf_rk + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (j,k,l,m,n,integral) & + !$OMP SHARED (mo_num,three_body_5_index_exch_12) + !$OMP DO SCHEDULE (guided) COLLAPSE(2) + do n = 1, mo_num + do l = 1, mo_num + do k = 1, mo_num +! do m = n, mo_num +! do j = l, mo_num + do m = 1, mo_num + do j = 1, mo_num + integral = 0.d0 +!! j,m,k,l,n,k : direct (case 1) + call give_integrals_3_body(j,m,k,n,l,k,integral) +!! j,m,k,l,k,n : exchange 2 3 + + three_body_5_index_exch_12(k,j,m,l,n) = -1.d0 * integral + + enddo + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + endif + call wall_time(wall1) + print*,'wall time for three_body_5_index_exch_12',wall1 - wall0 +! do n = 1, mo_num +! do l = 1, mo_num +! do k = 1, mo_num +! do m = n, mo_num +! do j = l, mo_num +! three_body_5_index_exch_12(k,l,n,j,m) = three_body_5_index_exch_12(k,j,m,l,n) +! enddo +! enddo +! enddo +! enddo +! enddo + if(write_three_body_ints)then + print*,'Writing three_body_5_index_exch_12 on disk ...' + call write_array_5_index_tensor(mo_num,three_body_5_index_exch_12,name_file) + call ezfio_set_three_body_ints_io_three_body_ints("Read") + endif + +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, three_body_5_index_312, (mo_num, mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! 5 index matrix element of the -L three-body operator +! +! three_body_5_index_312(i,j,m,l,n) = < phi_i phi_j phi_m | phi_i phi_l phi_n > +! +! notice the -1 sign: in this way three_body_5_index_312 can be directly used to compute Slater rules :) + END_DOC + integer :: j,k,l,m,n + double precision :: integral, wall1, wall0 + character*(128) :: name_file + + three_body_5_index_312 = 0.d0 + name_file = 'three_body_5_index_312' + print*,'Providing the three_body_5_index_312 ...' + call wall_time(wall0) + + if(read_three_body_ints)then + print*,'Reading three_body_5_index_312 from disk ...' + call read_array_5_index_tensor(mo_num,three_body_5_index_312,name_file) + else + provide x_W_ij_erf_rk + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (j,k,l,m,n,integral) & + !$OMP SHARED (mo_num,three_body_5_index_312) + !$OMP DO SCHEDULE (guided) COLLAPSE(2) + do n = 1, mo_num + do l = 1, mo_num + do k = 1, mo_num +! do m = n, mo_num +! do j = l, mo_num + do m = 1, mo_num + do j = 1, mo_num + integral = 0.d0 + + ! - > + call give_integrals_3_body(j,m,k,n,k,l,integral) + + three_body_5_index_312(k,j,m,l,n) = -1.d0 * integral + + enddo + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + endif + call wall_time(wall1) + print*,'wall time for three_body_5_index_312',wall1 - wall0 +! do n = 1, mo_num +! do l = 1, mo_num +! do k = 1, mo_num +! do m = n, mo_num +! do j = l, mo_num +! three_body_5_index_312(k,l,n,j,m) = three_body_5_index_312(k,j,m,l,n) +! enddo +! enddo +! enddo +! enddo +! enddo + if(write_three_body_ints)then + print*,'Writing three_body_5_index_312 on disk ...' + call write_array_5_index_tensor(mo_num,three_body_5_index_312,name_file) + call ezfio_set_three_body_ints_io_three_body_ints("Read") + endif + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_body_5_index_132, (mo_num, mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC +! 5 index matrix element of the -L three-body operator +! +! three_body_5_index_132(i,j,m,l,n) = < phi_i phi_j phi_m | phi_i phi_l phi_n > +! +! notice the -1 sign: in this way three_body_5_index_132 can be directly used to compute Slater rules :) + END_DOC + integer :: j,k,l,m,n + double precision :: integral, wall1, wall0 + character*(128) :: name_file + three_body_5_index_132 = 0.d0 + name_file = 'three_body_5_index_132' + print*,'Providing the three_body_5_index_132 ...' + call wall_time(wall0) + + if(read_three_body_ints)then + print*,'Reading three_body_5_index_132 from disk ...' + call read_array_5_index_tensor(mo_num,three_body_5_index_132,name_file) + else + provide x_W_ij_erf_rk + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (j,k,l,m,n,integral) & + !$OMP SHARED (mo_num,three_body_5_index_132) + !$OMP DO SCHEDULE (guided) COLLAPSE(2) + do n = 1, mo_num + do l = 1, mo_num + do k = 1, mo_num +! do m = n, mo_num +! do j = l, mo_num + do m = 1, mo_num + do j = 1, mo_num + integral = 0.d0 + + ! - > + call give_integrals_3_body(j,m,k,k,l,n,integral) + + three_body_5_index_132(k,j,m,l,n) = -1.d0 * integral + + enddo + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + endif + call wall_time(wall1) + print*,'wall time for three_body_5_index_132',wall1 - wall0 +! do n = 1, mo_num +! do l = 1, mo_num +! do k = 1, mo_num +! do m = n, mo_num +! do j = l, mo_num +! three_body_5_index_132(k,l,n,j,m) = three_body_5_index_132(k,j,m,l,n) +! enddo +! enddo +! enddo +! enddo +! enddo + if(write_three_body_ints)then + print*,'Writing three_body_5_index_132 on disk ...' + call write_array_5_index_tensor(mo_num,three_body_5_index_132,name_file) + call ezfio_set_three_body_ints_io_three_body_ints("Read") + endif + +END_PROVIDER + +subroutine write_array_5_index_tensor(n_orb,array_tmp,name_file) + implicit none + integer, intent(in) :: n_orb + character*(128), intent(in) :: name_file + double precision, intent(in) :: array_tmp(n_orb,n_orb,n_orb,n_orb,n_orb) + + character*(128) :: output + integer :: i_unit_output,getUnitAndOpen + PROVIDE ezfio_filename + output=trim(ezfio_filename)//'/work/'//trim(name_file) + i_unit_output = getUnitAndOpen(output,'W') + write(i_unit_output)array_tmp + close(unit=i_unit_output) +end + +subroutine read_array_5_index_tensor(n_orb,array_tmp,name_file) + implicit none + character*(128) :: output + integer :: i_unit_output,getUnitAndOpen + integer, intent(in) :: n_orb + character*(128), intent(in) :: name_file + double precision, intent(out) :: array_tmp(n_orb,n_orb,n_orb,n_orb,n_orb) + PROVIDE ezfio_filename + output=trim(ezfio_filename)//'/work/'//trim(name_file) + i_unit_output = getUnitAndOpen(output,'R') + read(i_unit_output)array_tmp + close(unit=i_unit_output) +end From 70516c8c05f625085a72dc9a95031c8d06fd2aec Mon Sep 17 00:00:00 2001 From: eginer Date: Wed, 5 Oct 2022 17:59:23 +0200 Subject: [PATCH 79/80] added fci_tc_bi --- src/bi_ort_ints/bi_ort_ints.irp.f | 104 +-------- src/fci_tc_bi/EZFIO.cfg | 17 ++ src/fci_tc_bi/NEED | 3 + src/fci_tc_bi/class.irp.f | 12 + src/fci_tc_bi/copy_wf.irp.f | 215 ++++++++++++++++++ src/fci_tc_bi/diagonalize_ci.irp.f | 100 ++++++++ src/fci_tc_bi/fci_tc_bi_ortho.irp.f | 85 +++++++ src/fci_tc_bi/generators.irp.f | 51 +++++ src/fci_tc_bi/save_energy.irp.f | 9 + src/fci_tc_bi/scripts_fci_tc/CH2.xyz | 6 + src/fci_tc_bi/scripts_fci_tc/FH.xyz | 5 + .../scripts_fci_tc/extract_tables.sh | 16 ++ src/fci_tc_bi/scripts_fci_tc/h2o.sh | 41 ++++ src/fci_tc_bi/scripts_fci_tc/h2o.xyz | 6 + src/fci_tc_bi/scripts_fci_tc/script.sh | 31 +++ src/fci_tc_bi/selectors.irp.f | 92 ++++++++ src/fci_tc_bi/zmq.irp.f | 103 +++++++++ 17 files changed, 793 insertions(+), 103 deletions(-) create mode 100644 src/fci_tc_bi/EZFIO.cfg create mode 100644 src/fci_tc_bi/NEED create mode 100644 src/fci_tc_bi/class.irp.f create mode 100644 src/fci_tc_bi/copy_wf.irp.f create mode 100644 src/fci_tc_bi/diagonalize_ci.irp.f create mode 100644 src/fci_tc_bi/fci_tc_bi_ortho.irp.f create mode 100644 src/fci_tc_bi/generators.irp.f create mode 100644 src/fci_tc_bi/save_energy.irp.f create mode 100644 src/fci_tc_bi/scripts_fci_tc/CH2.xyz create mode 100644 src/fci_tc_bi/scripts_fci_tc/FH.xyz create mode 100755 src/fci_tc_bi/scripts_fci_tc/extract_tables.sh create mode 100644 src/fci_tc_bi/scripts_fci_tc/h2o.sh create mode 100644 src/fci_tc_bi/scripts_fci_tc/h2o.xyz create mode 100755 src/fci_tc_bi/scripts_fci_tc/script.sh create mode 100644 src/fci_tc_bi/selectors.irp.f create mode 100644 src/fci_tc_bi/zmq.irp.f diff --git a/src/bi_ort_ints/bi_ort_ints.irp.f b/src/bi_ort_ints/bi_ort_ints.irp.f index 6884ff38..bb894b44 100644 --- a/src/bi_ort_ints/bi_ort_ints.irp.f +++ b/src/bi_ort_ints/bi_ort_ints.irp.f @@ -16,108 +16,6 @@ program bi_ort_ints ! call test_3_e_diag ! call test_3_e_diag_cycle1 ! call test_3_e - call routine_test_one_int +! call routine_test_one_int end -subroutine routine_test_one_int - implicit none - integer :: p,q,r,s,ii - integer :: i,j - i = 3 - j = 5 - double precision :: accu - double precision, allocatable :: vec(:) - integer, allocatable :: iorder(:) - allocate(vec(ao_num**4),iorder(ao_num**4)) - accu = 0.d0 - ii = 0 - do p = 1, ao_num ! - do q = 1, ao_num - do r = 1, ao_num - do s = 1, ao_num - ! - ! - ! j j i i - if(dabs(mo_l_coef(s,j) * mo_l_coef(q,i) * ao_two_e_tc_tot(s,r,q,p) * mo_r_coef(p,i) * mo_r_coef(r,j)).gt.10)then - write(33,'(3(F16.10,X),4(I3,X))')mo_l_coef(s,j) * mo_l_coef(q,i)* mo_r_coef(p,i) * mo_r_coef(r,j) , ao_two_e_tc_tot(s,r,q,p), mo_l_coef(s,j) * mo_l_coef(q,i) * ao_two_e_tc_tot(s,r,q,p) * mo_r_coef(p,i) * mo_r_coef(r,j) , s,q,p,r - endif - ii += 1 - iorder(ii) = ii - vec(ii) = mo_l_coef(s,j) * mo_l_coef(q,i) * ao_two_e_tc_tot(s,r,q,p) * mo_r_coef(p,i) * mo_r_coef(r,j) - accu += mo_l_coef(s,j) * mo_l_coef(q,i) * ao_two_e_tc_tot(s,r,q,p) * mo_r_coef(p,i) * mo_r_coef(r,j) - enddo - enddo - enddo - enddo - call dsort(vec,iorder,ao_num**4) - accu = 0.d0 - do i = 1, ao_num**4 - accu += vec(i) - write(34,*)i,vec(i),accu - enddo - - print*,'accu = ',accu - - -end - -subroutine routine_twoe - implicit none - integer :: i,j,k,l - double precision :: old, get_mo_two_e_integral_tc_int - double precision :: ref,new, accu, contrib, bi_ortho_mo_ints - accu = 0.d0 - print*,'Testing the bi ortho two e' - do j = 1, mo_num - do i = 1, mo_num - do l = 1, mo_num - do k = 1, mo_num - ! mo_non_hermit_term(k,l,i,j) = -! ref = bi_ortho_mo_ints(k,l,i,j) - ref = bi_ortho_mo_ints(l,k,j,i) - new = mo_bi_ortho_tc_two_e(l,k,j,i) -! old = get_mo_two_e_integral_tc_int(k,l,i,j,mo_integrals_tc_int_map) -! old += mo_non_hermit_term(l,k,j,i) - - contrib = dabs(ref - new) - if(dabs(ref).gt.1.d-10)then - if(contrib.gt.1.d-10)then - print*,k,l,i,j - print*,ref,new,contrib - endif - endif - accu += contrib - enddo - enddo - enddo - enddo - print*,'accu = ',accu/(dble(mo_num)**4) - -end - -subroutine routine_onee - implicit none - integer :: i,k - double precision :: ref,new,accu,contrib - print*,'Testing the bi ortho one e' - accu = 0.d0 - do i = 1, mo_num - do k = 1, mo_num - ref = mo_bi_ortho_tc_one_e_slow(k,i) - new = mo_bi_ortho_tc_one_e(k,i) - contrib = dabs(ref - new) - if(dabs(ref).gt.1.d-10)then - if(contrib .gt. 1.d-10)then - print*,'i,k',i,k - print*,ref,new,contrib - endif - endif - accu += contrib - enddo - enddo - print*,'accu = ',accu/mo_num**2 -end - - - - diff --git a/src/fci_tc_bi/EZFIO.cfg b/src/fci_tc_bi/EZFIO.cfg new file mode 100644 index 00000000..a2552c74 --- /dev/null +++ b/src/fci_tc_bi/EZFIO.cfg @@ -0,0 +1,17 @@ +[energy] +type: double precision +doc: Calculated Selected |FCI| energy +interface: ezfio +size: (determinants.n_states) + +[energy_pt2] +type: double precision +doc: Calculated |FCI| energy + |PT2| +interface: ezfio +size: (determinants.n_states) + +[cipsi_tc] +type: character*(32) +doc: TODO +interface: ezfio,provider,ocaml +default: h_tc diff --git a/src/fci_tc_bi/NEED b/src/fci_tc_bi/NEED new file mode 100644 index 00000000..000b0deb --- /dev/null +++ b/src/fci_tc_bi/NEED @@ -0,0 +1,3 @@ +tc_bi_ortho +davidson_undressed +cipsi_tc_bi_ortho diff --git a/src/fci_tc_bi/class.irp.f b/src/fci_tc_bi/class.irp.f new file mode 100644 index 00000000..b4a68ac2 --- /dev/null +++ b/src/fci_tc_bi/class.irp.f @@ -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 + diff --git a/src/fci_tc_bi/copy_wf.irp.f b/src/fci_tc_bi/copy_wf.irp.f new file mode 100644 index 00000000..cdb1ead8 --- /dev/null +++ b/src/fci_tc_bi/copy_wf.irp.f @@ -0,0 +1,215 @@ + +use bitmasks + +subroutine copy_H_apply_buffer_to_wf_tc + use omp_lib + implicit none + BEGIN_DOC +! Copies the H_apply buffer to psi_coef. +! After calling this subroutine, N_det, psi_det and psi_coef need to be touched + END_DOC + integer(bit_kind), allocatable :: buffer_det(:,:,:) + double precision, allocatable :: buffer_r_coef(:,:), buffer_l_coef(:,:) + integer :: i,j,k + integer :: N_det_old + + PROVIDE H_apply_buffer_allocated + + + ASSERT (N_int > 0) + ASSERT (N_det > 0) + + allocate ( buffer_det(N_int,2,N_det), buffer_r_coef(N_det,N_states), buffer_l_coef(N_det,N_states) ) + + ! Backup determinants + j=0 + do i=1,N_det +! if (pruned(i)) cycle ! Pruned determinants + j+=1 + ASSERT (sum(popcnt(psi_det(:,1,i))) == elec_alpha_num) + ASSERT (sum(popcnt(psi_det(:,2,i))) == elec_beta_num) + buffer_det(:,:,j) = psi_det(:,:,i) + enddo + N_det_old = j + + ! Backup coefficients + do k=1,N_states + j=0 + do i=1,N_det +! if (pruned(i)) cycle ! Pruned determinants + j += 1 + buffer_r_coef(j,k) = psi_r_coef_bi_ortho(i,k) + buffer_l_coef(j,k) = psi_l_coef_bi_ortho(i,k) + enddo + ASSERT ( j == N_det_old ) + enddo + + ! Update N_det + N_det = N_det_old + do j=0,nproc-1 + N_det = N_det + H_apply_buffer(j)%N_det + enddo + + ! Update array sizes + if (psi_det_size < N_det) then + psi_det_size = N_det + TOUCH psi_det_size + endif + + ! Restore backup in resized array + do i=1,N_det_old + psi_det(:,:,i) = buffer_det(:,:,i) + ASSERT (sum(popcnt(psi_det(:,1,i))) == elec_alpha_num) + ASSERT (sum(popcnt(psi_det(:,2,i))) == elec_beta_num ) + enddo + do k=1,N_states + do i=1,N_det_old + psi_r_coef_bi_ortho(i,k) = buffer_r_coef(i,k) + psi_l_coef_bi_ortho(i,k) = buffer_l_coef(i,k) + enddo + enddo + + ! Copy new buffers + + !$OMP PARALLEL DEFAULT(SHARED) & + !$OMP PRIVATE(j,k,i) FIRSTPRIVATE(N_det_old) & + !$OMP SHARED(N_int,H_apply_buffer,psi_det,psi_r_coef_bi_ortho,psi_l_coef_bi_ortho,N_states,psi_det_size) + j=0 + !$ j=omp_get_thread_num() + do k=0,j-1 + N_det_old += H_apply_buffer(k)%N_det + enddo + do i=1,H_apply_buffer(j)%N_det + do k=1,N_int + psi_det(k,1,i+N_det_old) = H_apply_buffer(j)%det(k,1,i) + psi_det(k,2,i+N_det_old) = H_apply_buffer(j)%det(k,2,i) + enddo + ASSERT (sum(popcnt(psi_det(:,1,i+N_det_old))) == elec_alpha_num) + ASSERT (sum(popcnt(psi_det(:,2,i+N_det_old))) == elec_beta_num ) + enddo + do k=1,N_states + do i=1,H_apply_buffer(j)%N_det + psi_r_coef_bi_ortho(i+N_det_old,k) = H_apply_buffer(j)%coef(i,k) + psi_l_coef_bi_ortho(i+N_det_old,k) = 0.d0 + enddo + enddo + !$OMP BARRIER + H_apply_buffer(j)%N_det = 0 + !$OMP END PARALLEL + SOFT_TOUCH N_det psi_det psi_r_coef_bi_ortho psi_l_coef_bi_ortho + + logical :: found_duplicates + call remove_duplicates_in_psi_det_tc(found_duplicates) + call bi_normalize(psi_l_coef_bi_ortho,psi_r_coef_bi_ortho,size(psi_l_coef_bi_ortho,1),N_det,N_states) + SOFT_TOUCH N_det psi_det psi_r_coef_bi_ortho psi_l_coef_bi_ortho + +end + +subroutine remove_duplicates_in_psi_det_tc(found_duplicates) + implicit none + logical, intent(out) :: found_duplicates + BEGIN_DOC +! Removes duplicate determinants in the wave function. + END_DOC + integer :: i,j,k + integer(bit_kind), allocatable :: bit_tmp(:) + logical,allocatable :: duplicate(:) + logical :: dup + + allocate (duplicate(N_det), bit_tmp(N_det)) + + found_duplicates = .False. + + !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,dup) + + !$OMP DO + do i=1,N_det + integer, external :: det_search_key + !$DIR FORCEINLINE + bit_tmp(i) = det_search_key(psi_det_sorted_bit_tc(1,1,i),N_int) + duplicate(i) = .False. + enddo + !$OMP END DO + + !$OMP DO schedule(dynamic,1024) + do i=1,N_det-1 + if (duplicate(i)) then + cycle + endif + j = i+1 + do while (bit_tmp(j)==bit_tmp(i)) + if (duplicate(j)) then + j = j+1 + if (j > N_det) then + exit + else + cycle + endif + endif + dup = .True. + do k=1,N_int + if ( (psi_det_sorted_bit_tc(k,1,i) /= psi_det_sorted_bit_tc(k,1,j) ) & + .or. (psi_det_sorted_bit_tc(k,2,i) /= psi_det_sorted_bit_tc(k,2,j) ) ) then + dup = .False. + exit + endif + enddo + if (dup) then + duplicate(j) = .True. + found_duplicates = .True. + endif + j += 1 + if (j > N_det) then + exit + endif + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + if (found_duplicates) then + k=0 + do i=1,N_det + if (.not.duplicate(i)) then + k += 1 + psi_det(:,:,k) = psi_det_sorted_bit_tc (:,:,i) + psi_r_coef_bi_ortho(k,:) = psi_r_coef_sorted_bit(i,:) + psi_l_coef_bi_ortho(k,:) = psi_l_coef_sorted_bit(i,:) + else + if (sum(abs(psi_r_coef_sorted_bit(i,:))) /= 0.d0 ) then + psi_r_coef_bi_ortho(k,:) = psi_r_coef_sorted_bit(i,:) + psi_l_coef_bi_ortho(k,:) = psi_l_coef_sorted_bit(i,:) + endif + endif + enddo + N_det = k + psi_det_sorted_bit_tc(:,:,1:N_det) = psi_det(:,:,1:N_det) + psi_r_coef_sorted_bit(1:N_det,:) = psi_r_coef_bi_ortho(1:N_det,:) + psi_l_coef_sorted_bit(1:N_det,:) = psi_l_coef_bi_ortho(1:N_det,:) + TOUCH N_det psi_det psi_det_sorted_bit_tc c0_weight psi_r_coef_sorted_bit psi_l_coef_sorted_bit + endif + psi_det = psi_det_sorted_tc + psi_r_coef_bi_ortho = psi_r_coef_sorted_bi_ortho + psi_l_coef_bi_ortho = psi_l_coef_sorted_bi_ortho + SOFT_TOUCH psi_det psi_r_coef_bi_ortho psi_l_coef_bi_ortho psi_det_sorted_bit_tc psi_r_coef_sorted_bit psi_l_coef_sorted_bit + deallocate (duplicate,bit_tmp) +end + + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_bit_tc, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_r_coef_sorted_bit, (N_det,N_states) ] +&BEGIN_PROVIDER [ double precision, psi_l_coef_sorted_bit, (N_det,N_states) ] + implicit none + BEGIN_DOC + ! Determinants on which we apply $\langle i|H|psi \rangle$ for perturbation. + ! They are sorted by determinants interpreted as integers. Useful + ! to accelerate the search of a random determinant in the wave + ! function. + END_DOC + + call sort_dets_by_det_search_key(N_det, psi_det, psi_r_coef_bi_ortho, size(psi_r_coef_bi_ortho,1), & + psi_det_sorted_bit_tc, psi_r_coef_sorted_bit, N_states) + call sort_dets_by_det_search_key(N_det, psi_det, psi_l_coef_bi_ortho, size(psi_l_coef_bi_ortho,1), & + psi_det_sorted_bit_tc, psi_l_coef_sorted_bit, N_states) + +END_PROVIDER diff --git a/src/fci_tc_bi/diagonalize_ci.irp.f b/src/fci_tc_bi/diagonalize_ci.irp.f new file mode 100644 index 00000000..56c561ac --- /dev/null +++ b/src/fci_tc_bi/diagonalize_ci.irp.f @@ -0,0 +1,100 @@ + +subroutine diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2) + use selection_types + implicit none + integer, intent(inout) :: ndet ! number of determinants from before + double precision, intent(inout) :: E_tc,norm ! E and norm from previous wave function + type(pt2_type) , intent(in) :: pt2_data ! PT2 from previous wave function + logical, intent(in) :: print_pt2 + BEGIN_DOC +! Replace the coefficients of the CI states by the coefficients of the +! eigenstates of the CI matrix + END_DOC + integer :: i,j + double precision :: pt2_tmp,pt1_norm,rpt2_tmp,abs_pt2 + pt2_tmp = pt2_data % pt2(1) + abs_pt2 = pt2_data % variance(1) + pt1_norm = pt2_data % overlap(1,1) + rpt2_tmp = pt2_tmp/(1.d0 + pt1_norm) + print*,'*****' + print*,'New wave function information' + print*,'N_det tc = ',N_det + print*,'norm_ground_left_right_bi_orth = ',norm_ground_left_right_bi_orth + print*,'eigval_right_tc = ',eigval_right_tc_bi_orth(1) + print*,'Ndet, E_tc = ',N_det,eigval_right_tc_bi_orth(1) + print*,'*****' + if(print_pt2)then + print*,'*****' + print*,'previous wave function info' + print*,'norm(before) = ',norm + print*,'E(before) = ',E_tc + print*,'PT1 norm = ',dsqrt(pt1_norm) + print*,'PT2 = ',pt2_tmp + print*,'rPT2 = ',rpt2_tmp + print*,'|PT2| = ',abs_pt2 + print*,'Positive PT2 = ',(pt2_tmp + abs_pt2)*0.5d0 + print*,'Negative PT2 = ',(pt2_tmp - abs_pt2)*0.5d0 + print*,'E(before) + PT2 = ',E_tc + pt2_tmp/norm + print*,'E(before) +rPT2 = ',E_tc + rpt2_tmp/norm + write(*,'(A28,X,I10,X,100(F16.8,X))')'Ndet,E,E+PT2,E+RPT2,|PT2|=',ndet,E_tc ,E_tc + pt2_tmp/norm,E_tc + rpt2_tmp/norm,abs_pt2 + print*,'*****' + endif + E_tc = eigval_right_tc_bi_orth(1) + norm = norm_ground_left_right_bi_orth + ndet = N_det + do j=1,N_states + do i=1,N_det + psi_l_coef_bi_ortho(i,j) = leigvec_tc_bi_orth(i,j) + psi_r_coef_bi_ortho(i,j) = reigvec_tc_bi_orth(i,j) + psi_coef(i,j) = dabs(psi_l_coef_bi_ortho(i,j) * psi_r_coef_bi_ortho(i,j)) + enddo + enddo + SOFT_TOUCH eigval_left_tc_bi_orth eigval_right_tc_bi_orth leigvec_tc_bi_orth reigvec_tc_bi_orth norm_ground_left_right_bi_orth psi_coef psi_l_coef_bi_ortho psi_r_coef_bi_ortho + + + + call save_tc_bi_ortho_wavefunction +end + +subroutine print_CI_dressed(ndet, E_tc,norm,pt2_data,print_pt2) + use selection_types + implicit none + integer, intent(inout) :: ndet ! number of determinants from before + double precision, intent(inout) :: E_tc,norm ! E and norm from previous wave function + type(pt2_type) , intent(in) :: pt2_data ! PT2 from previous wave function + logical, intent(in) :: print_pt2 + BEGIN_DOC +! Replace the coefficients of the CI states by the coefficients of the +! eigenstates of the CI matrix + END_DOC + integer :: i,j + print*,'*****' + print*,'New wave function information' + print*,'N_det tc = ',N_det + print*,'norm_ground_left_right_bi_orth = ',norm_ground_left_right_bi_orth + print*,'eigval_right_tc = ',eigval_right_tc_bi_orth(1) + print*,'Ndet, E_tc = ',N_det,eigval_right_tc_bi_orth(1) + print*,'*****' + if(print_pt2)then + print*,'*****' + print*,'previous wave function info' + print*,'norm(before) = ',norm + print*,'E(before) = ',E_tc + print*,'PT1 norm = ',dsqrt(pt2_data % overlap(1,1)) + print*,'E(before) + PT2 = ',E_tc + (pt2_data % pt2(1))/norm + print*,'PT2 = ',pt2_data % pt2(1) + print*,'Ndet, E_tc, E+PT2 = ',ndet,E_tc,E_tc + (pt2_data % pt2(1))/norm,dsqrt(pt2_data % overlap(1,1)) + print*,'*****' + endif + E_tc = eigval_right_tc_bi_orth(1) + norm = norm_ground_left_right_bi_orth + ndet = N_det + do j=1,N_states + do i=1,N_det + psi_coef(i,j) = reigvec_tc_bi_orth(i,j) + enddo + enddo + SOFT_TOUCH eigval_left_tc_bi_orth eigval_right_tc_bi_orth leigvec_tc_bi_orth norm_ground_left_right_bi_orth psi_coef reigvec_tc_bi_orth + +end + diff --git a/src/fci_tc_bi/fci_tc_bi_ortho.irp.f b/src/fci_tc_bi/fci_tc_bi_ortho.irp.f new file mode 100644 index 00000000..84ac8166 --- /dev/null +++ b/src/fci_tc_bi/fci_tc_bi_ortho.irp.f @@ -0,0 +1,85 @@ +program fci + implicit none + BEGIN_DOC + ! Selected Full Configuration Interaction with stochastic selection + ! and PT2. + ! + ! This program performs a |CIPSI|-like selected |CI| using a + ! stochastic scheme for both the selection of the important Slater + ! determinants and the computation of the |PT2| correction. This + ! |CIPSI|-like algorithm will be performed for the lowest states of + ! the variational space (see :option:`determinants n_states`). The + ! |FCI| program will stop when reaching at least one the two following + ! conditions: + ! + ! * number of Slater determinants > :option:`determinants n_det_max` + ! * abs(|PT2|) less than :option:`perturbation pt2_max` + ! + ! The following other options can be of interest: + ! + ! :option:`determinants read_wf` + ! When set to |false|, the program starts with a ROHF-like Slater + ! determinant as a guess wave function. When set to |true|, the + ! program starts with the wave function(s) stored in the |EZFIO| + ! directory as guess wave function(s). + ! + ! :option:`determinants s2_eig` + ! When set to |true|, the selection will systematically add all the + ! necessary Slater determinants in order to have a pure spin wave + ! function with an |S^2| value corresponding to + ! :option:`determinants expected_s2`. + ! + ! For excited states calculations, it is recommended to start with + ! :ref:`cis` or :ref:`cisd` guess wave functions, eventually in + ! a restricted set of |MOs|, and to set :option:`determinants s2_eig` + ! to |true|. + ! + END_DOC + + + my_grid_becke = .True. + my_n_pt_r_grid = 30 + my_n_pt_a_grid = 50 + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + pruning = -1.d0 + touch pruning +! pt2_relative_error = 0.01d0 +! touch pt2_relative_error + call run_cipsi_tc + +end + + +subroutine run_cipsi_tc + + implicit none + + if (.not.is_zmq_slave) then + PROVIDE psi_det psi_coef mo_bi_ortho_tc_two_e mo_bi_ortho_tc_one_e + if(elec_alpha_num+elec_beta_num.ge.3)then + if(three_body_h_tc)then + call provide_all_three_ints_bi_ortho + endif + endif + ! --- + + if (do_pt2) then + call run_stochastic_cipsi + else + call run_cipsi + endif + + else + PROVIDE mo_bi_ortho_tc_one_e mo_bi_ortho_tc_two_e pt2_min_parallel_tasks + if(elec_alpha_num+elec_beta_num.ge.3)then + if(three_body_h_tc)then + call provide_all_three_ints_bi_ortho + endif + endif + ! --- + + call run_slave_cipsi + + endif + +end diff --git a/src/fci_tc_bi/generators.irp.f b/src/fci_tc_bi/generators.irp.f new file mode 100644 index 00000000..55c0cbb9 --- /dev/null +++ b/src/fci_tc_bi/generators.irp.f @@ -0,0 +1,51 @@ +use bitmasks + +BEGIN_PROVIDER [ integer, N_det_generators ] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the number of generators is 1 : the + ! Hartree-Fock determinant + END_DOC + integer :: i + double precision :: norm + call write_time(6) + norm = 1.d0 + N_det_generators = N_det + do i=1,N_det + norm = norm - psi_average_norm_contrib_sorted_tc(i) + if (norm - 1.d-10 < 1.d0 - threshold_generators) then + N_det_generators = i + exit + endif + enddo + N_det_generators = max(N_det_generators,1) + call write_int(6,N_det_generators,'Number of generators') +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the generator is the + ! Hartree-Fock determinant + END_DOC + psi_det_generators(1:N_int,1:2,1:N_det) = psi_det_sorted_tc(1:N_int,1:2,1:N_det) + psi_coef_generators(1:N_det,1:N_states) = psi_coef_sorted_tc(1:N_det,1:N_states) + +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_tc_gen, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_sorted_tc_gen, (psi_det_size,N_states) ] +&BEGIN_PROVIDER [ integer, psi_det_sorted_tc_gen_order, (psi_det_size) ] + + implicit none + BEGIN_DOC + ! For Single reference wave functions, the generator is the + ! Hartree-Fock determinant + END_DOC + psi_det_sorted_tc_gen = psi_det_sorted_tc + psi_coef_sorted_tc_gen = psi_coef_sorted_tc + psi_det_sorted_tc_gen_order = psi_det_sorted_tc_order +END_PROVIDER + + diff --git a/src/fci_tc_bi/save_energy.irp.f b/src/fci_tc_bi/save_energy.irp.f new file mode 100644 index 00000000..7c41d00f --- /dev/null +++ b/src/fci_tc_bi/save_energy.irp.f @@ -0,0 +1,9 @@ +subroutine save_energy(E,pt2) + implicit none + BEGIN_DOC +! Saves the energy in |EZFIO|. + END_DOC + double precision, intent(in) :: E(N_states), pt2(N_states) + call ezfio_set_fci_tc_energy(E(1:N_states)) + call ezfio_set_fci_tc_energy_pt2(E(1:N_states)+pt2(1:N_states)) +end diff --git a/src/fci_tc_bi/scripts_fci_tc/CH2.xyz b/src/fci_tc_bi/scripts_fci_tc/CH2.xyz new file mode 100644 index 00000000..9fa57f4b --- /dev/null +++ b/src/fci_tc_bi/scripts_fci_tc/CH2.xyz @@ -0,0 +1,6 @@ +3 + +C 6.000000 0.000000 0.000000 0.173480 +H 1.000000 0.000000 -0.861500 -0.520430 +H 1.000000 0.000000 0.861500 -0.520430 + diff --git a/src/fci_tc_bi/scripts_fci_tc/FH.xyz b/src/fci_tc_bi/scripts_fci_tc/FH.xyz new file mode 100644 index 00000000..9a1563f4 --- /dev/null +++ b/src/fci_tc_bi/scripts_fci_tc/FH.xyz @@ -0,0 +1,5 @@ +2 + +H 0.000000 0.000000 -0.825120 +F 0.000000 0.000000 0.091680 + diff --git a/src/fci_tc_bi/scripts_fci_tc/extract_tables.sh b/src/fci_tc_bi/scripts_fci_tc/extract_tables.sh new file mode 100755 index 00000000..a585884e --- /dev/null +++ b/src/fci_tc_bi/scripts_fci_tc/extract_tables.sh @@ -0,0 +1,16 @@ + +input=h2o +basis=dz +EZFIO=${input}_${basis}_bi_ortho +file=${EZFIO}.tc_fci.out +grep "Ndet,E,E+PT2,E+RPT2,|PT2|=" ${file} | cut -d "=" -f 2 > data_${EZFIO} +file=${EZFIO}.tc_fci_normal_order.out +grep "Ndet,E,E+PT2,E+RPT2=" ${file} | cut -d "=" -f 2 > data_${EZFIO}_normal + +#EZFIO=${input}_${basis}_ortho +#file=${EZFIO}.tc_fci.out +#grep "Ndet, E_tc, E+PT2 =" ${file} | cut -d "=" -f 2 > data_${EZFIO} +#file=${EZFIO}.tc_fci_normal_order.out +#grep "Ndet, E_tc, E+PT2 =" ${file} | cut -d "=" -f 2 > data_${EZFIO}_normal + +#zip data_${input}_${basis}.zip data* diff --git a/src/fci_tc_bi/scripts_fci_tc/h2o.sh b/src/fci_tc_bi/scripts_fci_tc/h2o.sh new file mode 100644 index 00000000..d0afca30 --- /dev/null +++ b/src/fci_tc_bi/scripts_fci_tc/h2o.sh @@ -0,0 +1,41 @@ +#!/bin/bash +# This is a sample PBS script +# temps CPU a ajuster au calcul + #PBS -l cput=2000:00:00 + #PBS -l nodes=1:ppn=16 +# memoire a ajuster au calcul + #PBS -l vmem=100gb +# a changer +# Pour savoir sur quel noeud on est +#echo $HOSTNAME +# Startdir = ou sont les fichiers d'input, par defaut HOMEDIR +# +StartDir=$PBS_O_WORKDIR +echo $StartDir +# +# SCRATCHDIR = espace temporaire (local au noeud et a vider apres le calcul) +# NE PAS MODIFIER +ulimit -s unlimited +export SCRATCHDIR=/scratch/$USER/$PBS_JOBID +# +cd $StartDir + + +############################################################################ +#### EXAMPLE OF SCRIPT TO RUN A CIPSI CALCULATION ON 5 STATES ON THE Ne^+ CATION +#### USING NATURAL ORBITALS OF A SMALL CIPSI AS MOS +#### ALL STATES WILL HAVE THE SAME SPIN SIMETRY : A DOUBLET + +####### YOU PUT THE PATH TO YOUR +QP_ROOT=/home_lct/eginer/programs/qp2 +source ${QP_ROOT}/quantum_package.rc +####### YOU LOAD SOME LIBRARIES +alias python3='/programmes/installation/Python/3.7.1/bin/python3' +type -a python3 + +export OMP_NUM_THREADS=16 + +module load intel2016_OMPI-V2 + +source ~/programs/qp2/quantum_package.rc +./script.sh h2o dz O 1 diff --git a/src/fci_tc_bi/scripts_fci_tc/h2o.xyz b/src/fci_tc_bi/scripts_fci_tc/h2o.xyz new file mode 100644 index 00000000..dee51ffc --- /dev/null +++ b/src/fci_tc_bi/scripts_fci_tc/h2o.xyz @@ -0,0 +1,6 @@ +3 + +O 0.000000 0.000000 0.000000 +H 0.000000 0.000000 0.957200 +H -0.926627 0.000000 -0.239987 + diff --git a/src/fci_tc_bi/scripts_fci_tc/script.sh b/src/fci_tc_bi/scripts_fci_tc/script.sh new file mode 100755 index 00000000..58585658 --- /dev/null +++ b/src/fci_tc_bi/scripts_fci_tc/script.sh @@ -0,0 +1,31 @@ +source /home_lct/eginer/qp2/quantum_package.rc +input=$1 + basis=$2 + atom=$3 + mul=$4 + EXPORT_OMP_NUM_THREADS=16 + dir=${input}_${basis} + mkdir ${dir} + cp ${input}.xyz ${dir}/ + cd $dir + EZFIO=${input}_${basis}_bi_ortho + qp create_ezfio -b "${atom}:cc-pcv${basis}|H:cc-pv${basis}" ${input}.xyz -m $mul -o $EZFIO + qp run scf + # Getting THE GOOD VALUE OF MU + qp run print_mu_av_tc | tee ${EZFIO_FILE}.mu_av.out + mu=`grep "average_mu_rs_c_lda =" ${EZFIO_FILE}.mu_av.out | cut -d "=" -f 2` + qp set ao_two_e_erf_ints mu_erf $mu + # Carrying the BI-ORTHO TC-SCF + qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out + # Three body terms without normal order + ### THREE E TERMS FOR FCI + qp set tc_keywords three_body_h_tc True + qp set tc_keywords double_normal_ord False + qp set perturbation pt2_max 0.003 + qp run fci_tc_bi_ortho | tee ${EZFIO_FILE}.tc_fci.out + # Three body terms with normal order + qp set tc_keywords double_normal_ord True + qp run fci_tc_bi_ortho | tee ${EZFIO_FILE}.tc_fci_normal_order.out + +cd ../ + diff --git a/src/fci_tc_bi/selectors.irp.f b/src/fci_tc_bi/selectors.irp.f new file mode 100644 index 00000000..734c8ed0 --- /dev/null +++ b/src/fci_tc_bi/selectors.irp.f @@ -0,0 +1,92 @@ +use bitmasks + +BEGIN_PROVIDER [ double precision, threshold_selectors ] + implicit none + BEGIN_DOC + ! Thresholds on selectors (fraction of the square of the norm) + END_DOC + threshold_selectors = dsqrt(threshold_generators) +END_PROVIDER + +BEGIN_PROVIDER [ integer, N_det_selectors] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the number of selectors is 1 : the + ! Hartree-Fock determinant + END_DOC + integer :: i + double precision :: norm, norm_max + call write_time(6) + N_det_selectors = N_det + norm = 1.d0 + do i=1,N_det + norm = norm - psi_average_norm_contrib_tc(i) + if (norm - 1.d-10 < 1.d0 - threshold_selectors) then + N_det_selectors = i + exit + endif + enddo + N_det_selectors = max(N_det_selectors,N_det_generators) + call write_int(6,N_det_selectors,'Number of selectors') +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_selectors, (N_int,2,psi_selectors_size) ] +&BEGIN_PROVIDER [ double precision, psi_selectors_coef, (psi_selectors_size,N_states) ] + implicit none + BEGIN_DOC + ! Determinants on which we apply for perturbation. + END_DOC + integer :: i,k + + do i=1,N_det_selectors + do k=1,N_int + psi_selectors(k,1,i) = psi_det_sorted_tc(k,1,i) + psi_selectors(k,2,i) = psi_det_sorted_tc(k,2,i) + enddo + enddo + do k=1,N_states + do i=1,N_det_selectors + psi_selectors_coef(i,k) = psi_coef_sorted_tc_gen(i,k) + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, psi_selectors_coef_transp, (N_states,psi_selectors_size) ] + implicit none + BEGIN_DOC + ! Transposed psi_selectors + END_DOC + integer :: i,k + + do i=1,N_det_selectors + do k=1,N_states + psi_selectors_coef_transp(k,i) = psi_selectors_coef(i,k) + enddo + enddo +END_PROVIDER + + BEGIN_PROVIDER [ double precision, psi_selectors_rcoef_bi_orth_transp, (N_states, psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_selectors_lcoef_bi_orth_transp, (N_states, psi_det_size) ] + + implicit none + integer :: i, k + + psi_selectors_rcoef_bi_orth_transp = 0.d0 + psi_selectors_lcoef_bi_orth_transp = 0.d0 + + print*,'N_det,N_det_selectors',N_det,N_det_selectors + do i = 1, N_det_selectors + do k = 1, N_states + psi_selectors_rcoef_bi_orth_transp(k,i) = psi_r_coef_sorted_bi_ortho(i,k) + psi_selectors_lcoef_bi_orth_transp(k,i) = psi_l_coef_sorted_bi_ortho(i,k) + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ integer, psi_selectors_size ] + implicit none + psi_selectors_size = psi_det_size +END_PROVIDER + diff --git a/src/fci_tc_bi/zmq.irp.f b/src/fci_tc_bi/zmq.irp.f new file mode 100644 index 00000000..cb2df483 --- /dev/null +++ b/src/fci_tc_bi/zmq.irp.f @@ -0,0 +1,103 @@ +BEGIN_TEMPLATE + +integer function zmq_put_$X(zmq_to_qp_run_socket,worker_id) + use f77_zmq + implicit none + BEGIN_DOC +! Put $X on the qp_run scheduler + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer, intent(in) :: worker_id + integer :: rc + character*(256) :: msg + + zmq_put_$X = 0 + + write(msg,'(A,1X,I8,1X,A200)') 'put_data '//trim(zmq_state), worker_id, '$X' + rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE) + if (rc /= len(trim(msg))) then + zmq_put_$X = -1 + return + endif + + rc = f77_zmq_send(zmq_to_qp_run_socket,$X,4,0) + if (rc /= 4) then + zmq_put_$X = -1 + return + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0) + if (msg(1:rc) /= 'put_data_reply ok') then + zmq_put_$X = -1 + return + endif + +end + +integer function zmq_get_$X(zmq_to_qp_run_socket, worker_id) + use f77_zmq + implicit none + BEGIN_DOC +! Get $X from the qp_run scheduler + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer, intent(in) :: worker_id + integer :: rc + character*(256) :: msg + + PROVIDE zmq_state + zmq_get_$X = 0 + if (mpi_master) then + + write(msg,'(A,1X,I8,1X,A200)') 'get_data '//trim(zmq_state), worker_id, '$X' + rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0) + if (rc /= len(trim(msg))) then + zmq_get_$X = -1 + go to 10 + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0) + if (msg(1:14) /= 'get_data_reply') then + zmq_get_$X = -1 + go to 10 + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,$X,4,0) + if (rc /= 4) then + zmq_get_$X = -1 + go to 10 + endif + + endif + + 10 continue + + IRP_IF MPI_DEBUG + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + IRP_ENDIF + IRP_IF MPI + include 'mpif.h' + integer :: ierr + + call MPI_BCAST (zmq_get_$X, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + print *, irp_here//': Unable to broadcast N_det_generators' + stop -1 + endif + call MPI_BCAST ($X, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + print *, irp_here//': Unable to broadcast N_det_generators' + stop -1 + endif + IRP_ENDIF + +end + +SUBST [ X ] + +N_det_generators ;; +N_det_selectors ;; + +END_TEMPLATE + From 996c09d2207fd5e09be99d86d405049a385eacb4 Mon Sep 17 00:00:00 2001 From: eginer Date: Mon, 10 Oct 2022 18:20:33 +0200 Subject: [PATCH 80/80] beginning to work on new jastrow --- src/ao_many_one_e_ints/ao_gaus_gauss.irp.f | 1 + src/ao_tc_eff_map/map_integrals_eff_pot.irp.f | 2 +- src/ao_two_e_ints/map_integrals.irp.f | 4 +- src/non_h_ints_mu/fit_j.irp.f | 91 ++++++++++++++++ src/non_h_ints_mu/grad_squared.irp.f | 72 +++++++++++++ src/non_h_ints_mu/grad_tc_int.irp.f | 8 ++ src/non_h_ints_mu/new_grad_tc.irp.f | 70 ++++++++++++ src/non_h_ints_mu/test_non_h_ints.irp.f | 102 ++++++++++++++++++ 8 files changed, 348 insertions(+), 2 deletions(-) create mode 100644 src/non_h_ints_mu/fit_j.irp.f create mode 100644 src/non_h_ints_mu/grad_squared.irp.f create mode 100644 src/non_h_ints_mu/new_grad_tc.irp.f create mode 100644 src/non_h_ints_mu/test_non_h_ints.irp.f diff --git a/src/ao_many_one_e_ints/ao_gaus_gauss.irp.f b/src/ao_many_one_e_ints/ao_gaus_gauss.irp.f index cd9a486d..681d1e6f 100644 --- a/src/ao_many_one_e_ints/ao_gaus_gauss.irp.f +++ b/src/ao_many_one_e_ints/ao_gaus_gauss.irp.f @@ -116,6 +116,7 @@ double precision function overlap_gauss_r12_ao(D_center,delta,i,j) if(ao_overlap_abs(j,i).lt.1.d-12)then return endif + ! TODO :: PUT CYCLES IN LOOPS num_A = ao_nucl(i) power_A(1:3)= ao_power(i,1:3) A_center(1:3) = nucl_coord(num_A,1:3) diff --git a/src/ao_tc_eff_map/map_integrals_eff_pot.irp.f b/src/ao_tc_eff_map/map_integrals_eff_pot.irp.f index aea4644f..4a6128b9 100644 --- a/src/ao_tc_eff_map/map_integrals_eff_pot.irp.f +++ b/src/ao_tc_eff_map/map_integrals_eff_pot.irp.f @@ -78,7 +78,7 @@ double precision function get_ao_tc_sym_two_e_pot(i,j,k,l,map) result(result) use map_module implicit none BEGIN_DOC - ! Gets one |AO| two-electron integral from the |AO| map + ! Gets one |AO| two-electron integral from the |AO| map in PHYSICIST NOTATION END_DOC integer, intent(in) :: i,j,k,l integer(key_kind) :: idx diff --git a/src/ao_two_e_ints/map_integrals.irp.f b/src/ao_two_e_ints/map_integrals.irp.f index 55b2d5e2..de4195ba 100644 --- a/src/ao_two_e_ints/map_integrals.irp.f +++ b/src/ao_two_e_ints/map_integrals.irp.f @@ -326,7 +326,9 @@ double precision function get_ao_two_e_integral(i,j,k,l,map) result(result) use map_module implicit none BEGIN_DOC - ! Gets one AO bi-electronic integral from the AO map + ! Gets one AO bi-electronic integral from the AO map in PHYSICIST NOTATION + ! + ! <1:k, 2:l |1:i, 2:j> END_DOC integer, intent(in) :: i,j,k,l integer(key_kind) :: idx diff --git a/src/non_h_ints_mu/fit_j.irp.f b/src/non_h_ints_mu/fit_j.irp.f new file mode 100644 index 00000000..695ead7f --- /dev/null +++ b/src/non_h_ints_mu/fit_j.irp.f @@ -0,0 +1,91 @@ +BEGIN_PROVIDER [ double precision, expo_j_xmu, (n_fit_1_erf_x) ] + implicit none + BEGIN_DOC + ! F(x) = x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2) is fitted with a gaussian and a Slater + ! + ! \approx - 1/sqrt(pi) * exp(-alpha * x ) exp(-beta * x**2) + ! + ! where alpha = expo_j_xmu(1) and beta = expo_j_xmu(2) + END_DOC + expo_j_xmu(1) = 1.7477d0 + expo_j_xmu(2) = 0.668662d0 + +END_PROVIDER + + BEGIN_PROVIDER [double precision, expo_gauss_j_mu_x, (n_max_fit_slat)] +&BEGIN_PROVIDER [double precision, coef_gauss_j_mu_x, (n_max_fit_slat)] + implicit none + BEGIN_DOC +! J(mu,r12) = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2) is expressed as +! +! J(mu,r12) = 0.5/mu * F(r12*mu) where F(x) = x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2) +! +! F(x) is fitted by - 1/sqrt(pi) * exp(-alpha * x) exp(-beta*mu^2x^2) (see expo_j_xmu) +! +! The slater function exp(-alpha * x) is fitted with n_max_fit_slat gaussians +! +! See Appendix 2 of JCP 154, 084119 (2021) +! + END_DOC + integer :: i + double precision :: expos(n_max_fit_slat),alpha,beta + alpha = expo_j_xmu(1) * mu_erf + call expo_fit_slater_gam(alpha,expos) + beta = expo_j_xmu(2) * mu_erf**2.d0 + + do i = 1, n_max_fit_slat + expo_gauss_j_mu_x(i) = expos(i) + beta + coef_gauss_j_mu_x(i) = coef_fit_slat_gauss(i) / (2.d0 * mu_erf) * (- 1/dsqrt(dacos(-1.d0))) + enddo +END_PROVIDER + +double precision function F_x_j(x) + implicit none + BEGIN_DOC + ! F_x_j(x) = dimension-less correlation factor = x (1 - erf(x)) - 1/sqrt(pi) exp(-x^2) + END_DOC + double precision, intent(in) :: x + F_x_j = x * (1.d0 - derf(x)) - 1/dsqrt(dacos(-1.d0)) * dexp(-x**2) + +end + +double precision function j_mu_F_x_j(x) + implicit none + BEGIN_DOC + ! j_mu_F_x_j(x) = correlation factor = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2) + ! + ! = 1/(2*mu) * F_x_j(mu*x) + END_DOC + double precision :: F_x_j + double precision, intent(in) :: x + j_mu_F_x_j = 0.5d0/mu_erf * F_x_j(x*mu_erf) +end + +double precision function j_mu(x) + implicit none + double precision, intent(in) :: x + BEGIN_DOC + ! j_mu(x) = correlation factor = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2) + END_DOC + j_mu = 0.5d0* x * (1.d0 - derf(mu_erf*x)) - 0.5d0/( dsqrt(dacos(-1.d0))*mu_erf) * dexp(-(mu_erf*x)*(mu_erf*x)) + +end + +double precision function j_mu_fit_gauss(x) + implicit none + BEGIN_DOC + ! j_mu_fit_gauss(x) = correlation factor = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2) + ! + ! but fitted with gaussians + END_DOC + double precision, intent(in) :: x + integer :: i + double precision :: alpha,coef + j_mu_fit_gauss = 0.d0 + do i = 1, n_max_fit_slat + alpha = expo_gauss_j_mu_x(i) + coef = coef_gauss_j_mu_x(i) + j_mu_fit_gauss += coef_gauss_j_mu_x(i) * dexp(-expo_gauss_j_mu_x(i)*x*x) + enddo + +end diff --git a/src/non_h_ints_mu/grad_squared.irp.f b/src/non_h_ints_mu/grad_squared.irp.f new file mode 100644 index 00000000..a88521a1 --- /dev/null +++ b/src/non_h_ints_mu/grad_squared.irp.f @@ -0,0 +1,72 @@ + BEGIN_PROVIDER [ double precision, grad_1_squared_u_ij_mu, ( ao_num, ao_num,n_points_final_grid)] + implicit none + integer :: ipoint,i,j,m,igauss + BEGIN_DOC + ! grad_1_squared_u_ij_mu(j,i,ipoint) = -1/2 \int dr2 phi_j(r2) phi_i(r2) |\grad_r1 u(r1,r2,\mu)|^2 + ! |\grad_r1 u(r1,r2,\mu)|^2 = 1/4 * (1 - erf(mu*r12))^2 + ! ! (1 - erf(mu*r12))^2 = \sum_i coef_gauss_1_erf_x_2(i) * exp(-expo_gauss_1_erf_x_2(i) * r12^2) + END_DOC + double precision :: r(3),delta,coef + double precision :: overlap_gauss_r12_ao,time0,time1 + print*,'providing grad_1_squared_u_ij_mu ...' + call wall_time(time0) + !TODO : strong optmization : write the loops in a different way + ! : for each couple of AO, the gaussian product are done once for all + do ipoint = 1, n_points_final_grid + r(1) = final_grid_points(1,ipoint) + r(2) = final_grid_points(2,ipoint) + r(3) = final_grid_points(3,ipoint) + do j = 1, ao_num + do i = 1, ao_num + ! \int dr2 phi_j(r2) phi_i(r2) (1 - erf(mu*r12))^2 + ! = \sum_i coef_gauss_1_erf_x_2(i) \int dr2 phi_j(r2) phi_i(r2) exp(-expo_gauss_1_erf_x_2(i) * (r_1 - r_2)^2) + do igauss = 1, n_max_fit_slat + delta = expo_gauss_1_erf_x_2(igauss) + coef = coef_gauss_1_erf_x_2(igauss) + grad_1_squared_u_ij_mu(j,i,ipoint) += -0.25 * coef * overlap_gauss_r12_ao(r,delta,i,j) + enddo + enddo + enddo + enddo + call wall_time(time1) + print*,'Wall time for grad_1_squared_u_ij_mu = ',time1 - time0 + END_PROVIDER + +BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao_num)] + implicit none + BEGIN_DOC + ! tc_grad_square_ao(k,i,l,j) = -1/2 + ! + END_DOC + integer :: ipoint,i,j,k,l + double precision :: contrib,weight1 + double precision, allocatable :: ac_mat(:,:,:,:) + allocate(ac_mat(ao_num, ao_num, ao_num, ao_num)) + ac_mat = 0.d0 + do ipoint = 1, n_points_final_grid + weight1 = final_weight_at_r_vector(ipoint) + do j = 1, ao_num + do l = 1, ao_num + do i = 1, ao_num + do k = 1, ao_num + contrib = weight1 *0.5D0* (aos_in_r_array_transp(ipoint,k) * aos_in_r_array_transp(ipoint,i)) + ! \int dr1 phi_k(r1) phi_i(r1) . \int dr2 |\grad_1 u(r1,r2)|^2 \phi_l(r2) \phi_j(r2) + ac_mat(k,i,l,j) += grad_1_squared_u_ij_mu(l,j,ipoint) * contrib + enddo + enddo + enddo + enddo + enddo + + do j = 1, ao_num + do l = 1, ao_num + do i = 1, ao_num + do k = 1, ao_num + tc_grad_square_ao(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i) + enddo + enddo + enddo + enddo + +END_PROVIDER + diff --git a/src/non_h_ints_mu/grad_tc_int.irp.f b/src/non_h_ints_mu/grad_tc_int.irp.f index dd60e724..40600335 100644 --- a/src/non_h_ints_mu/grad_tc_int.irp.f +++ b/src/non_h_ints_mu/grad_tc_int.irp.f @@ -11,6 +11,8 @@ END_DOC double precision, allocatable :: b_mat(:,:,:,:),ac_mat(:,:,:,:) ! provide v_ij_erf_rk_cst_mu provide v_ij_erf_rk_cst_mu x_v_ij_erf_rk_cst_mu +! ao_non_hermit_term_chemist = non_h_ints +! return call wall_time(wall0) allocate(b_mat(n_points_final_grid,ao_num,ao_num,3),ac_mat(ao_num, ao_num, ao_num, ao_num)) !$OMP PARALLEL & @@ -35,6 +37,9 @@ END_DOC !$OMP END DO !$OMP END PARALLEL + + ! (A) b_mat(ipoint,k,i,m) X v_ij_erf_rk_cst_mu(j,l,r1) + ! 1/2 \int dr1 x1 phi_k(1) d/dx1 phi_i(1) \int dr2 (1 - erf(mu_r12))/r12 phi_j(2) phi_l(2) ac_mat = 0.d0 do m = 1, 3 ! A B^T dim(A,1) dim(B,2) dim(A,2) alpha * A LDA @@ -60,6 +65,8 @@ END_DOC !$OMP END DO !$OMP END PARALLEL + ! (B) b_mat(ipoint,k,i,m) X x_v_ij_erf_rk_cst_mu(j,l,r1,m) + ! 1/2 \int dr1 phi_k(1) d/dx1 phi_i(1) \int dr2 x2(1 - erf(mu_r12))/r12 phi_j(2) phi_l(2) do m = 1, 3 ! A B^T dim(A,1) dim(B,2) dim(A,2) alpha * A LDA call dgemm("N","N",ao_num*ao_num,ao_num*ao_num,n_points_final_grid,-1.d0,x_v_ij_erf_rk_cst_mu(1,1,1,m),ao_num*ao_num & @@ -75,6 +82,7 @@ END_DOC do l = 1, ao_num do i = 1, ao_num do k = 1, ao_num + ! (ki|lj) (ki|lj) (lj|ki) ao_non_hermit_term_chemist(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i) enddo enddo diff --git a/src/non_h_ints_mu/new_grad_tc.irp.f b/src/non_h_ints_mu/new_grad_tc.irp.f new file mode 100644 index 00000000..068381b4 --- /dev/null +++ b/src/non_h_ints_mu/new_grad_tc.irp.f @@ -0,0 +1,70 @@ +BEGIN_PROVIDER [ double precision, grad_1_u_ij_mu, ( ao_num, ao_num,n_points_final_grid,3)] + implicit none + BEGIN_DOC + ! grad_1_u_ij_mu(i,j,ipoint) = -1 * \int dr2 \grad_r1 u(r1,r2) \phi_i(r2) \phi_j(r2) + ! + ! where r1 = r(ipoint) + ! + ! grad_1_u_ij_mu(i,j,ipoint) = \int dr2 (r1 - r2) (erf(mu * r12)-1)/2 r_12 \phi_i(r2) \phi_j(r2) + END_DOC + integer :: ipoint,i,j,m + double precision :: r(3) + do m = 1, 3 + do ipoint = 1, n_points_final_grid + r(1) = final_grid_points(1,ipoint) + r(2) = final_grid_points(2,ipoint) + r(3) = final_grid_points(3,ipoint) + do j = 1, ao_num + do i = 1, ao_num + grad_1_u_ij_mu(i,j,ipoint,m) = v_ij_erf_rk_cst_mu(i,j,ipoint) * r(m) - x_v_ij_erf_rk_cst_mu(i,j,ipoint,m) + enddo + enddo + enddo + enddo + grad_1_u_ij_mu *= 0.5d0 + +END_PROVIDER + +BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao, (ao_num, ao_num, ao_num, ao_num)] + implicit none + BEGIN_DOC + ! tc_grad_and_lapl_ao(k,i,l,j) = + ! + ! = 1/2 \int dr1 (phi_k(r1) \grad_r1 phi_i(r1) - phi_i(r1) \grad_r1 phi_k(r1)) . \int dr2 \grad_r1 u(r1,r2) \phi_l(r2) \phi_j(r2) + ! + ! This is obtained by integration by parts. + END_DOC + integer :: ipoint,i,j,k,l,m + double precision :: contrib,weight1 + double precision, allocatable :: ac_mat(:,:,:,:) + allocate(ac_mat(ao_num, ao_num, ao_num, ao_num)) + ac_mat = 0.d0 + do m = 1, 3 + do ipoint = 1, n_points_final_grid + weight1 = final_weight_at_r_vector(ipoint) + do j = 1, ao_num + do l = 1, ao_num + do i = 1, ao_num + do k = 1, ao_num + contrib = weight1 *0.5D0* (aos_in_r_array_transp(ipoint,k) * aos_grad_in_r_array_transp_bis(ipoint,i,m) & + -aos_in_r_array_transp(ipoint,i) * aos_grad_in_r_array_transp_bis(ipoint,k,m) ) + ! \int dr1 phi_k(r1) \grad_r1 phi_i(r1) . \int dr2 \grad_r1 u(r1,r2) \phi_l(r2) \phi_j(r2) + ac_mat(k,i,l,j) += grad_1_u_ij_mu(l,j,ipoint,m) * contrib + enddo + enddo + enddo + enddo + enddo + enddo + + do j = 1, ao_num + do l = 1, ao_num + do i = 1, ao_num + do k = 1, ao_num + tc_grad_and_lapl_ao(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i) + enddo + enddo + enddo + enddo + +END_PROVIDER diff --git a/src/non_h_ints_mu/test_non_h_ints.irp.f b/src/non_h_ints_mu/test_non_h_ints.irp.f new file mode 100644 index 00000000..c535d0c5 --- /dev/null +++ b/src/non_h_ints_mu/test_non_h_ints.irp.f @@ -0,0 +1,102 @@ +program test_non_h + implicit none + my_grid_becke = .True. + my_n_pt_r_grid = 50 + my_n_pt_a_grid = 74 +! my_n_pt_r_grid = 10 ! small grid for quick debug +! my_n_pt_a_grid = 26 ! small grid for quick debug + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid +!call routine_grad_squared + call routine_fit +end + +subroutine routine_lapl_grad + implicit none + integer :: i,j,k,l + double precision :: grad_lapl, get_ao_tc_sym_two_e_pot,new,accu,contrib + double precision :: ao_two_e_integral_erf,get_ao_two_e_integral,count_n,accu_relat +! !!!!!!!!!!!!!!!!!!!!! WARNING +! THIS ROUTINE MAKES SENSE ONLY IF HAND MODIFIED coef_gauss_eff_pot(1:n_max_fit_slat) = 0. to cancel (1-erf(mu*r12))^2 + accu = 0.d0 + accu_relat = 0.d0 + count_n = 0.d0 + do i = 1, ao_num + do j = 1, ao_num + do k = 1, ao_num + do l = 1, ao_num + grad_lapl = get_ao_tc_sym_two_e_pot(i,j,k,l,ao_tc_sym_two_e_pot_map) ! pure gaussian part : comes from Lapl + grad_lapl += ao_two_e_integral_erf(i, k, j, l) ! erf(mu r12)/r12 : comes from Lapl + grad_lapl += ao_non_hermit_term_chemist(k,i,l,j) ! \grad u(r12) . grad + new = tc_grad_and_lapl_ao(k,i,l,j) + new += get_ao_two_e_integral(i,j,k,l,ao_integrals_map) + contrib = dabs(new - grad_lapl) + if(dabs(grad_lapl).gt.1.d-12)then + count_n += 1.d0 + accu_relat += 2.0d0 * contrib/dabs(grad_lapl+new) + endif + if(contrib.gt.1.d-10)then + print*,i,j,k,l + print*,grad_lapl,new,contrib + print*,2.0d0*contrib/dabs(grad_lapl+new+1.d-12) + endif + accu += contrib + enddo + enddo + enddo + enddo + print*,'accu = ',accu/count_n + print*,'accu/rel = ',accu_relat/count_n + +end + +subroutine routine_grad_squared + implicit none + integer :: i,j,k,l + double precision :: grad_squared, get_ao_tc_sym_two_e_pot,new,accu,contrib + double precision :: count_n,accu_relat +! !!!!!!!!!!!!!!!!!!!!! WARNING +! THIS ROUTINE MAKES SENSE ONLY IF HAND MODIFIED coef_gauss_eff_pot(n_max_fit_slat:n_max_fit_slat+1) = 0. to cancel exp(-'mu*r12)^2) + accu = 0.d0 + accu_relat = 0.d0 + count_n = 0.d0 + do i = 1, ao_num + do j = 1, ao_num + do k = 1, ao_num + do l = 1, ao_num + grad_squared = get_ao_tc_sym_two_e_pot(i,j,k,l,ao_tc_sym_two_e_pot_map) ! pure gaussian part : comes from Lapl + new = tc_grad_square_ao(k,i,l,j) + contrib = dabs(new - grad_squared) + if(dabs(grad_squared).gt.1.d-12)then + count_n += 1.d0 + accu_relat += 2.0d0 * contrib/dabs(grad_squared+new) + endif + if(contrib.gt.1.d-10)then + print*,i,j,k,l + print*,grad_squared,new,contrib + print*,2.0d0*contrib/dabs(grad_squared+new+1.d-12) + endif + accu += contrib + enddo + enddo + enddo + enddo + print*,'accu = ',accu/count_n + print*,'accu/rel = ',accu_relat/count_n + +end + +subroutine routine_fit + implicit none + integer :: i,nx + double precision :: dx,xmax,x,j_mu,j_mu_F_x_j,j_mu_fit_gauss + nx = 500 + xmax = 5.d0 + dx = xmax/dble(nx) + x = 0.d0 + print*,'coucou',mu_erf + do i = 1, nx + write(33,'(100(F16.10,X))') x,j_mu(x),j_mu_F_x_j(x),j_mu_fit_gauss(x) + x += dx + enddo + +end